diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,11 +25,11 @@ - [Installation](#installation) - [Using Taskell](#using-taskell) - [Options](#options) - - [Controls](#controls) - [Storage](#storage) - [Importing Trello Boards](#importing-trello-boards) - [Importing GitHub Projects](#importing-github-projects) - [Configuration](#configuration) + - [Controls](#controls) - [Theming](#theming) - [Roadmap](#roadmap) @@ -83,10 +83,6 @@ - `-t `: import a Trello board ([see below](#importing-trello-boards)) - `-g `: import a GitHub project ([see below](#importing-github-projects)) -### Controls - -Press `?` for a [list of controls](https://github.com/smallhadroncollider/taskell/blob/master/templates/controls.md) - #### Tips - If you're using a simple two-column "To Do" and "Done" then use the space bar to mark an item as complete while staying in the "To Do" list. If you're using a more complicated column setup then you will want to use `H`/`L` to move tasks between columns. @@ -250,6 +246,58 @@ ``` **Warning**: currently if you change your `[markdown]` settings any older files stored with different settings will not be readable. + +### Controls + +You can edit keyboard bindings in the `bindings.ini` config file. + +The default bindings are as follows: + +```ini +# general +quit = q +undo = u +search = / +help = ? + +# navigation +previous = k +next = j +left = h +right = l +bottom = G + +# new tasks +new = a +newAbove = O +newBelow = o + +# editing tasks +edit = e, A, i +clear = C +delete = D +detail = +dueDate = @ + +# moving tasks +moveUp = K +moveDown = J +moveLeft = H +moveRight = L, +moveMenu = m + +# lists +listNew = N +listEdit = E +listDelete = X +listRight = > +listLeft = < +``` + +Available special keys: ``, ``, ``, ``, ``, ``, `` + +You shouldn't try to assign the `1`-`9` keys, as it will not overwrite the default behaviour. + ### Theming diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -16,14 +16,14 @@ import Data.Taskell.Date (currentDay) import Data.Taskell.Lists (Lists) -import Events.Actions (event) +import Events.Actions (ActionSets, event, generateActions) import Events.State (continue, countCurrent) import Events.State.Types (State, current, io, lists, mode, path) import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..)) -import IO.Config (Config, generateAttrMap, layout) +import IO.Config (Config, generateAttrMap, getBindings, layout) import IO.Taskell (writeData) import UI.Draw (chooseCursor, draw) -import UI.Types (ResourceName (..)) +import UI.Types (ListIndex (..), ResourceName (..), TaskIndex (..)) type DebouncedMessage = (Lists, FilePath) @@ -51,7 +51,7 @@ Debounce.new Debounce.Args { Debounce.cb = store config - , Debounce.fold = \_ b -> b + , Debounce.fold = flip const , Debounce.init = (initial ^. lists, initial ^. path) } Debounce.def @@ -63,14 +63,14 @@ clearCache state = do let (li, ti) = state ^. current invalidateCacheEntry (RNList li) - invalidateCacheEntry (RNTask (li, ti)) + invalidateCacheEntry (RNTask (ListIndex li, TaskIndex ti)) clearAllTitles :: State -> EventM ResourceName () clearAllTitles state = do let count = length (state ^. lists) let range = [0 .. (count - 1)] - void . sequence $ invalidateCacheEntry . RNList <$> range - void . sequence $ invalidateCacheEntry . (\x -> RNTask (x, -1)) <$> range + traverse_ (invalidateCacheEntry . RNList) range + traverse_ (invalidateCacheEntry . RNTask . flip (,) (TaskIndex (-1)) . ListIndex) range clearList :: State -> EventM ResourceName () clearList state = do @@ -78,12 +78,13 @@ let count = countCurrent state let range = [0 .. (count - 1)] invalidateCacheEntry $ RNList list - void . sequence $ invalidateCacheEntry . (\x -> RNTask (list, x)) <$> range + traverse_ (invalidateCacheEntry . RNTask . (,) (ListIndex list) . TaskIndex) range -- event handling -handleVtyEvent :: (DebouncedWrite, Trigger) -> State -> Event -> EventM ResourceName (Next State) -handleVtyEvent (send, trigger) previousState e = do - let state = event e previousState +handleVtyEvent :: + (DebouncedWrite, Trigger) -> ActionSets -> State -> Event -> EventM ResourceName (Next State) +handleVtyEvent (send, trigger) actions previousState e = do + let state = event actions e previousState case previousState ^. mode of Search _ _ -> invalidateCache (Modal MoveTo) -> clearAllTitles previousState @@ -97,20 +98,20 @@ handleEvent :: (DebouncedWrite, Trigger) + -> ActionSets -> State -> BrickEvent ResourceName e -> EventM ResourceName (Next State) -handleEvent _ state (VtyEvent (EvResize _ _)) = invalidateCache *> Brick.continue state -handleEvent db state (VtyEvent ev) = handleVtyEvent db state ev -handleEvent _ state _ = Brick.continue state +handleEvent _ _ state (VtyEvent (EvResize _ _)) = invalidateCache *> Brick.continue state +handleEvent db actions state (VtyEvent ev) = handleVtyEvent db actions state ev +handleEvent _ _ state _ = Brick.continue state -- | Runs when the app starts -- Adds paste support appStart :: State -> EventM ResourceName State appStart state = do - vty <- getVtyHandle - let output = outputIface vty - when (supportsMode output BracketedPaste) $ liftIO $ setMode output BracketedPaste True + output <- outputIface <$> getVtyHandle + when (supportsMode output BracketedPaste) . liftIO $ setMode output BracketedPaste True pure state -- | Sets up Brick @@ -119,11 +120,12 @@ attrMap' <- const <$> generateAttrMap today <- currentDay db <- debounce config initial + bindings <- getBindings let app = App - { appDraw = draw (layout config) today + { appDraw = draw (layout config) bindings today , appChooseCursor = chooseCursor - , appHandleEvent = handleEvent db + , appHandleEvent = handleEvent db (generateActions bindings) , appStartEvent = appStart , appAttrMap = attrMap' } diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -9,7 +9,7 @@ import Data.FileEmbed (embedFile) version :: Text -version = "1.3.6" +version = "1.4.0" usage :: Text usage = decodeUtf8 $(embedFile "templates/usage.txt") diff --git a/src/Events/Actions.hs b/src/Events/Actions.hs --- a/src/Events/Actions.hs +++ b/src/Events/Actions.hs @@ -2,6 +2,8 @@ module Events.Actions ( event + , generateActions + , ActionSets ) where import ClassyPrelude @@ -11,13 +13,18 @@ import Graphics.Vty.Input.Events (Event (..)) import Events.State.Types (State, Stateful, mode) -import Events.State.Types.Mode (Mode (..)) +import Events.State.Types.Mode (DetailMode (..), ModalType (..), Mode (..)) -import qualified Events.Actions.Insert as Insert -import qualified Events.Actions.Modal as Modal -import qualified Events.Actions.Normal as Normal -import qualified Events.Actions.Search as Search +import IO.Keyboard (generate) +import IO.Keyboard.Types (Bindings, BoundActions) +import qualified Events.Actions.Insert as Insert +import qualified Events.Actions.Modal as Modal +import qualified Events.Actions.Modal.Detail as Detail +import qualified Events.Actions.Modal.Help as Help +import qualified Events.Actions.Normal as Normal +import qualified Events.Actions.Search as Search + -- takes an event and returns a Maybe State event' :: Event -> Stateful -- for other events pass through to relevant modules @@ -30,5 +37,29 @@ _ -> pure state -- returns new state if successful -event :: Event -> State -> State -event e state = fromMaybe state $ event' e state +event :: ActionSets -> Event -> State -> State +event actions e state = do + let mEv = + case state ^. mode of + Normal -> lookup e $ normal actions + Modal (Detail _ DetailNormal) -> lookup e $ detail actions + Modal Help -> lookup e $ help actions + _ -> Nothing + fromMaybe state $ + case mEv of + Nothing -> event' e state + Just ev -> ev state + +data ActionSets = ActionSets + { normal :: BoundActions + , detail :: BoundActions + , help :: BoundActions + } + +generateActions :: Bindings -> ActionSets +generateActions bindings = + ActionSets + { normal = generate bindings Normal.events + , detail = generate bindings Detail.events + , help = generate bindings Help.events + } diff --git a/src/Events/Actions/Modal/Detail.hs b/src/Events/Actions/Modal/Detail.hs --- a/src/Events/Actions/Modal/Detail.hs +++ b/src/Events/Actions/Modal/Detail.hs @@ -1,7 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} module Events.Actions.Modal.Detail ( event + , events ) where import ClassyPrelude @@ -13,20 +16,25 @@ import Graphics.Vty.Input.Events import qualified UI.Field as F (event) +events :: Map Text Stateful +events + -- general + = + [ ("quit", quit) + , ("undo", (write =<<) . undo) + , ("previous", previousSubtask) + , ("next", nextSubtask) + , ("new", (Detail.insertMode =<<) . (Detail.lastSubtask =<<) . (Detail.newItem =<<) . store) + , ("edit", (Detail.insertMode =<<) . store) + , ("moveRight", (write =<<) . (setComplete =<<) . store) + , ("delete", (write =<<) . (Detail.remove =<<) . store) + , ("dueDate", (editDue =<<) . store) + , ("detail", (editDescription =<<) . store) + ] + normal :: Event -> Stateful -normal (EvKey (KChar 'q') _) = quit normal (EvKey KEsc _) = normalMode -normal (EvKey KEnter _) = (editDescription =<<) . store -normal (EvKey (KChar ' ') _) = (write =<<) . (setComplete =<<) . store -normal (EvKey (KChar 'k') _) = previousSubtask -normal (EvKey (KChar 'j') _) = nextSubtask -normal (EvKey (KChar 'a') _) = - (Detail.insertMode =<<) . (Detail.lastSubtask =<<) . (Detail.newItem =<<) . store -normal (EvKey (KChar 'e') _) = (Detail.insertMode =<<) . store -normal (EvKey (KChar 'D') _) = (write =<<) . (Detail.remove =<<) . store -normal (EvKey (KChar 'u') _) = (write =<<) . undo -normal (EvKey (KChar '@') _) = (editDue =<<) . store -normal _ = pure +normal _ = pure insert :: Event -> Stateful insert (EvKey KEsc _) s = do diff --git a/src/Events/Actions/Modal/Help.hs b/src/Events/Actions/Modal/Help.hs --- a/src/Events/Actions/Modal/Help.hs +++ b/src/Events/Actions/Modal/Help.hs @@ -1,7 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} module Events.Actions.Modal.Help ( event + , events ) where import ClassyPrelude @@ -9,7 +12,9 @@ import Events.State.Types (Stateful) import Graphics.Vty.Input.Events +events :: Map Text Stateful +events = [("quit", quit)] + event :: Event -> Stateful -event (EvKey (KChar 'q') _) = quit -event (EvKey _ _) = normalMode -event _ = pure +event (EvKey _ _) = normalMode +event _ = pure diff --git a/src/Events/Actions/Normal.hs b/src/Events/Actions/Normal.hs --- a/src/Events/Actions/Normal.hs +++ b/src/Events/Actions/Normal.hs @@ -1,60 +1,60 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedLists #-} module Events.Actions.Normal ( event + , events ) where import ClassyPrelude hiding (delete) import Data.Char (isDigit) +import Data.Map.Strict (Map) import Events.State import Events.State.Modal.Detail (editDue, showDetail) import Events.State.Types (Stateful) import Graphics.Vty.Input.Events +events :: Map Text Stateful +events + -- general + = + [ ("quit", quit) + , ("undo", (write =<<) . undo) + , ("search", searchMode) + , ("help", showHelp) + -- navigation + , ("previous", previous) + , ("next", next) + , ("left", left) + , ("right", right) + , ("bottom", bottom) + -- new tasks + , ("new", (startCreate =<<) . (newItem =<<) . store) + , ("newAbove", (startCreate =<<) . (above =<<) . store) + , ("newBelow", (startCreate =<<) . (below =<<) . store) + -- editing tasks + , ("edit", (startEdit =<<) . store) + , ("clear", (startEdit =<<) . (clearItem =<<) . store) + , ("delete", (write =<<) . (delete =<<) . store) + , ("detail", showDetail) + , ("dueDate", (editDue =<<) . (store =<<) . showDetail) + -- moving tasks + , ("moveUp", (write =<<) . (up =<<) . store) + , ("moveDown", (write =<<) . (down =<<) . store) + , ("moveLeft", (write =<<) . (bottom =<<) . (left =<<) . (moveLeft =<<) . store) + , ("moveRight", (write =<<) . (bottom =<<) . (right =<<) . (moveRight =<<) . store) + , ("moveMenu", showMoveTo) + -- lists + , ("listNew", (createListStart =<<) . store) + , ("listEdit", (editListStart =<<) . store) + , ("listDelete", (write =<<) . (deleteCurrentList =<<) . store) + , ("listRight", (write =<<) . (listRight =<<) . store) + , ("listLeft", (write =<<) . (listLeft =<<) . store) + ] + -- Normal event :: Event -> Stateful --- quit -event (EvKey (KChar 'q') _) = quit --- add/edit -event (EvKey (KChar 'e') _) = (startEdit =<<) . store -event (EvKey (KChar 'A') _) = (startEdit =<<) . store -event (EvKey (KChar 'i') _) = (startEdit =<<) . store -event (EvKey (KChar 'C') _) = (startEdit =<<) . (clearItem =<<) . store -event (EvKey (KChar 'a') _) = (startCreate =<<) . (newItem =<<) . store -event (EvKey (KChar 'O') _) = (startCreate =<<) . (above =<<) . store -event (EvKey (KChar 'o') _) = (startCreate =<<) . (below =<<) . store --- add list -event (EvKey (KChar 'N') _) = (createListStart =<<) . store -event (EvKey (KChar 'E') _) = (editListStart =<<) . store -event (EvKey (KChar 'X') _) = (write =<<) . (deleteCurrentList =<<) . store --- navigation -event (EvKey (KChar 'k') _) = previous -event (EvKey (KChar 'j') _) = next -event (EvKey (KChar 'h') _) = left -event (EvKey (KChar 'l') _) = right -event (EvKey (KChar 'G') _) = bottom --- moving items -event (EvKey (KChar 'K') _) = (write =<<) . (up =<<) . store -event (EvKey (KChar 'J') _) = (write =<<) . (down =<<) . store -event (EvKey (KChar 'H') _) = (write =<<) . (bottom =<<) . (left =<<) . (moveLeft =<<) . store -event (EvKey (KChar 'L') _) = (write =<<) . (bottom =<<) . (right =<<) . (moveRight =<<) . store -event (EvKey (KChar ' ') _) = (write =<<) . (moveRight =<<) . store -event (EvKey (KChar 'm') _) = showMoveTo --- removing items -event (EvKey (KChar 'D') _) = (write =<<) . (delete =<<) . store --- undo -event (EvKey (KChar 'u') _) = (write =<<) . undo --- moving lists -event (EvKey (KChar '>') _) = (write =<<) . (listRight =<<) . store -event (EvKey (KChar '<') _) = (write =<<) . (listLeft =<<) . store --- search -event (EvKey (KChar '/') _) = searchMode --- help -event (EvKey (KChar '?') _) = showHelp --- subtasks -event (EvKey KEnter _) = showDetail -event (EvKey (KChar '@') _) = (editDue =<<) . (store =<<) . showDetail -- selecting lists event (EvKey (KChar n) _) | isDigit n = selectList n diff --git a/src/IO/Config.hs b/src/IO/Config.hs --- a/src/IO/Config.hs +++ b/src/IO/Config.hs @@ -1,11 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} module IO.Config where import ClassyPrelude +import Data.Either (fromRight) import qualified Data.Text.IO as T (readFile) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getHomeDirectory) @@ -16,7 +18,9 @@ import Data.FileEmbed (embedFile) import Data.Ini.Config -import UI.Theme (defaultTheme) +import IO.Keyboard.Parser (bindings) +import IO.Keyboard.Types (Bindings) +import UI.Theme (defaultTheme) import qualified IO.Config.General as General import qualified IO.Config.GitHub as GitHub @@ -48,44 +52,39 @@ legacyConfigPath = ( "." <> directoryName) <$> getHomeDirectory xdgDefaultConfig :: IO FilePath -xdgDefaultConfig = ( ".config" directoryName) <$> getHomeDirectory +xdgDefaultConfig = ( ".config") <$> getHomeDirectory xdgConfigPath :: IO FilePath -xdgConfigPath = fromMaybe <$> xdgDefaultConfig <*> lookupEnv "XDG_CONFIG_HOME" +xdgConfigPath = + ( directoryName) <$> (fromMaybe <$> xdgDefaultConfig <*> lookupEnv "XDG_CONFIG_HOME") getDir :: IO FilePath getDir = legacyConfigPath >>= doesDirectoryExist >>= bool xdgConfigPath legacyConfigPath -getThemePath :: IO FilePath -getThemePath = (<> "/theme.ini") <$> getDir +themePath :: FilePath -> FilePath +themePath = ( "theme.ini") -getConfigPath :: IO FilePath -getConfigPath = (<> "/config.ini") <$> getDir +configPath :: FilePath -> FilePath +configPath = ( "config.ini") +bindingsPath :: FilePath -> FilePath +bindingsPath = ( "bindings.ini") + setup :: IO Config -setup = do - getDir >>= createDirectoryIfMissing True - createConfig - createTheme +setup + -- create config dir + = do + dir <- getDir + createDirectoryIfMissing True dir + -- create config files + create (configPath dir) $(embedFile "templates/config.ini") + create (themePath dir) $(embedFile "templates/theme.ini") + create (bindingsPath dir) $(embedFile "templates/bindings.ini") + -- get config getConfig -create :: IO FilePath -> (FilePath -> IO ()) -> IO () -create getPath write = do - path <- getPath - exists <- doesFileExist path - unless exists $ write path - -writeTheme :: FilePath -> IO () -writeTheme path = writeFile path $(embedFile "templates/theme.ini") - -createTheme :: IO () -createTheme = create getThemePath writeTheme - -writeConfig :: FilePath -> IO () -writeConfig path = writeFile path $(embedFile "templates/config.ini") - -createConfig :: IO () -createConfig = create getConfigPath writeConfig +create :: FilePath -> ByteString -> IO () +create path contents = doesFileExist path >>= flip unless (writeFile path contents) configParser :: IniParser Config configParser = @@ -94,15 +93,19 @@ getConfig :: IO Config getConfig = do - content <- getConfigPath >>= T.readFile + content <- T.readFile =<< (configPath <$> getDir) case parseIniFile content configParser of Right config -> pure config - Left s -> putStrLn (pack $ "config.ini: " <> s) *> pure defaultConfig + Left s -> putStrLn (pack $ "config.ini: " <> s) $> defaultConfig +getBindings :: IO Bindings +getBindings = fromRight [] . bindings <$> (T.readFile =<< (bindingsPath <$> getDir)) + -- generate theme generateAttrMap :: IO AttrMap generateAttrMap = do - customizedTheme <- flip loadCustomizations defaultTheme =<< getThemePath + dir <- getDir + customizedTheme <- loadCustomizations (themePath dir) defaultTheme case customizedTheme of Right theme -> pure $ themeToAttrMap theme Left s -> putStrLn (pack $ "theme.ini: " <> s) $> themeToAttrMap defaultTheme diff --git a/src/IO/HTTP/GitHub.hs b/src/IO/HTTP/GitHub.hs --- a/src/IO/HTTP/GitHub.hs +++ b/src/IO/HTTP/GitHub.hs @@ -96,9 +96,7 @@ pure $ columnToList column <$> cards addCards :: [Column] -> ReaderGitHubToken (Either Text Lists) -addCards columns = do - cols <- sequence (addCard <$> columns) - pure $ fromList <$> sequence cols +addCards columns = (fromList <$>) . sequence <$> traverse addCard columns getColumns :: Text -> ReaderGitHubToken (Either Text Lists) getColumns url = do diff --git a/src/IO/HTTP/Trello.hs b/src/IO/HTTP/Trello.hs --- a/src/IO/HTTP/Trello.hs +++ b/src/IO/HTTP/Trello.hs @@ -82,13 +82,13 @@ updateCard :: Card -> ReaderTrelloToken (Either Text Card) updateCard card = (setChecklists card . concat <$>) . sequence <$> checklists where - checklists = sequence $ getChecklist <$> (card ^. idChecklists) + checklists = traverse getChecklist (card ^. idChecklists) updateList :: List -> ReaderTrelloToken (Either Text List) -updateList l = (setCards l <$>) . sequence <$> sequence (updateCard <$> (l ^. cards)) +updateList l = (setCards l <$>) . sequence <$> traverse updateCard (l ^. cards) getChecklists :: [List] -> ReaderTrelloToken (Either Text [List]) -getChecklists ls = sequence <$> sequence (updateList <$> ls) +getChecklists ls = sequence <$> traverse updateList ls getLists :: TrelloBoardID -> ReaderTrelloToken (Either Text Lists) getLists board = do @@ -102,7 +102,6 @@ Right raw -> fmap (trelloListsToLists timezone) <$> getChecklists raw Left err -> pure . Left $ parseError err 404 -> - pure . Left $ - "Could not find Trello board " <> board <> ". Make sure the ID is correct" + pure . Left $ "Could not find Trello board " <> board <> ". Make sure the ID is correct" 401 -> pure . Left $ "You do not have permission to view Trello board " <> board _ -> pure . Left $ tshow status <> " error. Cannot fetch from Trello." diff --git a/src/IO/Keyboard.hs b/src/IO/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/IO/Keyboard.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module IO.Keyboard + ( generate + ) where + +import ClassyPrelude + +import Data.Bitraversable (bitraverse) + +import IO.Keyboard.Types + +generate :: Bindings -> Actions -> BoundActions +generate bindings actions = + mapFromList . catMaybes $ bitraverse bindingToEvent (`lookup` actions) <$> bindings diff --git a/src/IO/Keyboard/Parser.hs b/src/IO/Keyboard/Parser.hs new file mode 100644 --- /dev/null +++ b/src/IO/Keyboard/Parser.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module IO.Keyboard.Parser where + +import ClassyPrelude + +import Data.Attoparsec.Text + +import IO.Keyboard.Types + +-- utility functions +lexeme :: Parser a -> Parser a +lexeme p = skipSpace *> p <* skipSpace + +commentP :: Parser () +commentP = lexeme $ skipMany (char '#' *> manyTill anyChar endOfLine) + +stripComments :: Parser a -> Parser a +stripComments p = lexeme $ commentP *> p <* commentP + +word :: Parser Text +word = lexeme $ pack <$> many1 letter + +-- ini parser +keyP :: Parser Binding +keyP = lexeme $ BKey <$> (char '<' *> word <* char '>') + +charP :: Parser Binding +charP = lexeme $ BChar <$> anyChar + +bindingP :: Parser [Binding] +bindingP = lexeme $ (keyP <|> charP) `sepBy` char ',' + +line :: Parser [(Binding, Text)] +line = + stripComments $ do + name <- word + _ <- lexeme $ char '=' + binds <- bindingP + pure $ (, name) <$> binds + +bindingsP :: Parser Bindings +bindingsP = stripComments $ concat <$> many' line + +-- run parser +bindings :: Text -> Either Text Bindings +bindings ini = first (const "Could not parse keyboard bindings.") (parseOnly bindingsP ini) diff --git a/src/IO/Keyboard/Types.hs b/src/IO/Keyboard/Types.hs new file mode 100644 --- /dev/null +++ b/src/IO/Keyboard/Types.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module IO.Keyboard.Types where + +import ClassyPrelude + +import Data.Map.Strict (Map) +import Graphics.Vty.Input.Events (Event (..), Key (..)) + +import Events.State.Types (Stateful) + +data Binding + = BChar Char + | BKey Text + deriving (Eq, Ord, Show) + +type Bindings = [(Binding, Text)] + +type Actions = Map Text Stateful + +type BoundActions = Map Event Stateful + +bindingToText :: Binding -> Text +bindingToText (BChar c) = singleton c +bindingToText (BKey name) = "<" <> name <> ">" + +bindingsToText :: Bindings -> Text -> [Text] +bindingsToText bindings key = bindingToText . fst <$> toList (filterMap (== key) bindings) + +bindingToEvent :: Binding -> Maybe Event +bindingToEvent (BChar char) = pure $ EvKey (KChar char) [] +bindingToEvent (BKey "Space") = pure $ EvKey (KChar ' ') [] +bindingToEvent (BKey "Backspace") = pure $ EvKey KBS [] +bindingToEvent (BKey "Enter") = pure $ EvKey KEnter [] +bindingToEvent (BKey "Left") = pure $ EvKey KLeft [] +bindingToEvent (BKey "Right") = pure $ EvKey KRight [] +bindingToEvent (BKey "Up") = pure $ EvKey KUp [] +bindingToEvent (BKey "Down") = pure $ EvKey KDown [] +bindingToEvent _ = Nothing diff --git a/src/UI/Draw.hs b/src/UI/Draw.hs --- a/src/UI/Draw.hs +++ b/src/UI/Draw.hs @@ -26,10 +26,11 @@ import Events.State.Types.Mode (DetailMode (..), InsertType (..), ModalType (..), Mode (..)) import IO.Config.Layout (Config, columnPadding, columnWidth, descriptionIndicator) +import IO.Keyboard.Types (Bindings) import UI.Field (Field, field, textField, widgetFromMaybe) import UI.Modal (showModal) import UI.Theme -import UI.Types (ResourceName (..)) +import UI.Types (ListIndex (..), ResourceName (..), TaskIndex (..)) -- | Draw needs to know various pieces of information, so keep track of them in a record data DrawState = DrawState @@ -79,7 +80,7 @@ taskField <- dsField <$> ask -- get the field, if it's being edited after <- indicators task -- get the indicators widget let text = task ^. T.name - name = RNTask (listIndex, taskIndex) + name = RNTask (ListIndex listIndex, TaskIndex taskIndex) widget = textField text widget' = widgetFromMaybe widget taskField pure $ @@ -197,9 +198,10 @@ moveTo _ = False -- draw -draw :: Config -> Day -> State -> [Widget ResourceName] -draw layout today state = +draw :: Config -> Bindings -> Day -> State -> [Widget ResourceName] +draw layout bindings today state = showModal + bindings normalisedState today [ runReader diff --git a/src/UI/Modal.hs b/src/UI/Modal.hs --- a/src/UI/Modal.hs +++ b/src/UI/Modal.hs @@ -15,6 +15,7 @@ import Data.Taskell.Date (Day) import Events.State.Types (State, mode) import Events.State.Types.Mode (ModalType (..), Mode (..)) +import IO.Keyboard.Types (Bindings) import UI.Field (textField) import UI.Modal.Detail (detail) import UI.Modal.Help (help) @@ -31,10 +32,10 @@ where t = padBottom (Pad 1) . withAttr titleAttr $ textField title -showModal :: State -> Day -> [Widget ResourceName] -> [Widget ResourceName] -showModal state today view = +showModal :: Bindings -> State -> Day -> [Widget ResourceName] -> [Widget ResourceName] +showModal bindings state today view = case state ^. mode of - Modal Help -> surround help : view + Modal Help -> surround (help bindings) : view Modal Detail {} -> surround (detail state today) : view Modal MoveTo -> surround (moveTo state) : view _ -> view diff --git a/src/UI/Modal/Help.hs b/src/UI/Modal/Help.hs --- a/src/UI/Modal/Help.hs +++ b/src/UI/Modal/Help.hs @@ -9,23 +9,53 @@ import ClassyPrelude import Brick -import Data.FileEmbed (embedFile) -import Data.Text as T (breakOn, justifyRight, replace, strip) +import Data.Text as T (justifyRight) +import IO.Keyboard.Types (Bindings, bindingsToText) + import UI.Field (textField) import UI.Theme (taskCurrentAttr) import UI.Types (ResourceName) +descriptions :: [([Text], Text)] +descriptions = + [ (["help"], "Show this list of controls") + , (["previous", "next", "left", "right"], "Move down/up/left/right") + , (["bottom"], "Go to bottom of list") + , (["new"], "Add a task") + , (["newAbove", "newBelow"], "Add a task above/below") + , (["edit"], "Edit a task") + , (["clear"], "Change task") + , (["detail"], "Show task details / Edit task description") + , (["dueDate"], "Add/edit due date (yyyy-mm-dd)") + , (["moveUp", "moveDown"], "Shift task down/up") + , (["moveLeft", "moveRight"], "Shift task left/right") + , (["moveMenu"], "Move task to specific list") + , (["delete"], "Delete task") + , (["undo"], "Undo") + , (["listNew"], "New list") + , (["listEdit"], "Edit list title") + , (["listDelete"], "Delete list") + , (["listLeft", "listRight"], "Move list left/right") + , (["search"], "Search") + , (["quit"], "Quit") + ] + +generate :: Bindings -> [([Text], Text)] +generate bindings = first (intercalate ", " . bindingsToText bindings <$>) <$> descriptions + +format :: ([Text], Text) -> (Text, Text) +format = first (intercalate " / ") + line :: Int -> (Text, Text) -> Widget ResourceName line m (l, r) = left <+> right where left = padRight (Pad 2) . withAttr taskCurrentAttr . txt $ justifyRight m ' ' l - right = textField . T.strip . drop 1 $ r + right = textField r -help :: (Text, Widget ResourceName) -help = ("Controls", w) +help :: Bindings -> (Text, Widget ResourceName) +help bindings = ("Controls", w) where - ls = lines $ decodeUtf8 $(embedFile "templates/controls.md") - (l, r) = unzip $ breakOn ":" . T.replace "`" "" . T.strip . drop 1 <$> ls - m = foldl' max 0 $ length <$> l - w = vBox $ line m <$> zip l r + ls = format <$> generate bindings + m = foldl' max 0 $ length . fst <$> ls + w = vBox $ line m <$> ls diff --git a/src/UI/Types.hs b/src/UI/Types.hs --- a/src/UI/Types.hs +++ b/src/UI/Types.hs @@ -4,9 +4,17 @@ import ClassyPrelude (Eq, Int, Ord, Show) +newtype ListIndex = ListIndex + { showListIndex :: Int + } deriving (Show, Eq, Ord) + +newtype TaskIndex = TaskIndex + { showTaskIndex :: Int + } deriving (Show, Eq, Ord) + data ResourceName = RNCursor - | RNTask (Int, Int) + | RNTask (ListIndex, TaskIndex) | RNList Int | RNLists | RNModal diff --git a/taskell.cabal b/taskell.cabal --- a/taskell.cabal +++ b/taskell.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: taskell -version: 1.3.6.0 +version: 1.4.0.0 license: BSD3 license-file: LICENSE copyright: 2019 Mark Wales @@ -16,8 +16,8 @@ extra-source-files: README.md templates/api-error.txt + templates/bindings.ini templates/config.ini - templates/controls.md templates/github-token.txt templates/theme.ini templates/trello-token.txt @@ -50,6 +50,9 @@ IO.HTTP.GitHub IO.HTTP.Trello.List IO.HTTP.Trello.ChecklistItem + IO.Keyboard + IO.Keyboard.Parser + IO.Keyboard.Types UI.Field hs-source-dirs: src other-modules: @@ -87,25 +90,26 @@ default-language: Haskell2010 default-extensions: OverloadedStrings NoImplicitPrelude build-depends: - aeson >=1.3.1.1 && <1.4, - base >=4.11.1.0 && <=5, - brick >=0.37.2 && <0.38, + aeson >=1.4.2.0 && <1.5, + attoparsec >=0.13.2.2 && <0.14, + base >=4.12.0.0 && <=5, + brick ==0.47.*, bytestring >=0.10.8.2 && <0.11, - classy-prelude >=1.4.0 && <1.5, - config-ini >=0.2.2.0 && <0.3, - containers >=0.5.11.0 && <0.6, - directory >=1.3.1.5 && <1.4, - file-embed >=0.0.10.1 && <0.1, + classy-prelude >=1.5.0 && <1.6, + config-ini >=0.2.4.0 && <0.3, + containers >=0.6.0.1 && <0.7, + directory >=1.3.3.0 && <1.4, + file-embed >=0.0.11 && <0.1, fold-debounce >=0.2.0.8 && <0.3, http-client >=0.5.14 && <0.6, - http-conduit >=2.3.2 && <2.4, - http-types >=0.12.2 && <0.13, - lens >=4.16.1 && <4.17, + http-conduit >=2.3.6.1 && <2.4, + http-types >=0.12.3 && <0.13, + lens ==4.17.*, mtl >=2.2.2 && <2.3, - template-haskell >=2.13.0.0 && <2.14, + template-haskell >=2.14.0.0 && <2.15, text >=1.2.3.1 && <1.3, time >=1.8.0.2 && <1.9, - vty ==5.21.* + vty >=5.25.1 && <5.26 executable taskell main-is: Main.hs @@ -116,8 +120,8 @@ default-extensions: OverloadedStrings NoImplicitPrelude ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.11.1.0 && <4.12, - classy-prelude >=1.4.0 && <1.5, + base >=4.12.0.0 && <4.13, + classy-prelude >=1.5.0 && <1.6, taskell -any test-suite taskell-test @@ -133,6 +137,8 @@ Data.Taskell.TaskTest Events.StateTest IO.GitHubTest + IO.Keyboard.ParserTest + IO.KeyboardTest IO.MarkdownTest IO.TrelloTest UI.FieldTest @@ -141,16 +147,18 @@ default-extensions: OverloadedStrings NoImplicitPrelude ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson >=1.3.1.1 && <1.4, - base >=4.11.1.0 && <4.12, - classy-prelude >=1.4.0 && <1.5, - containers >=0.5.11.0 && <0.6, - file-embed >=0.0.10.1 && <0.1, - lens >=4.16.1 && <4.17, + aeson >=1.4.2.0 && <1.5, + base >=4.12.0.0 && <4.13, + classy-prelude >=1.5.0 && <1.6, + containers >=0.6.0.1 && <0.7, + file-embed >=0.0.11 && <0.1, + lens ==4.17.*, + raw-strings-qq ==1.1.*, taskell -any, - tasty >=1.1.0.4 && <1.2, + tasty ==1.2.*, tasty-discover >=4.2.1 && <4.3, tasty-expected-failure >=0.11.1.1 && <0.12, tasty-hunit >=0.10.0.1 && <0.11, text >=1.2.3.1 && <1.3, - time >=1.8.0.2 && <1.9 + time >=1.8.0.2 && <1.9, + vty >=5.25.1 && <5.26 diff --git a/templates/bindings.ini b/templates/bindings.ini new file mode 100644 --- /dev/null +++ b/templates/bindings.ini @@ -0,0 +1,38 @@ +# general +quit = q +undo = u +search = / +help = ? + +# navigation +previous = k +next = j +left = h +right = l +bottom = G + +# new tasks +new = a +newAbove = O +newBelow = o + +# editing tasks +edit = e, A, i +clear = C +delete = D +detail = +dueDate = @ + +# moving tasks +moveUp = K +moveDown = J +moveLeft = H +moveRight = L, +moveMenu = m + +# lists +listNew = N +listEdit = E +listDelete = X +listRight = > +listLeft = < diff --git a/templates/controls.md b/templates/controls.md deleted file mode 100644 --- a/templates/controls.md +++ /dev/null @@ -1,23 +0,0 @@ -- `?`: Show this list of controls -- `j` / `k` / `h` / `l`: Move down/up/left/right -- `G`: Go to bottom of list -- `1`-`9`: Select list -- `a`: Add a task -- `O` / `o`: Add a task above/below -- `e`, `i`, `A`: Edit a task -- `C`: Change task -- `Enter`: Show task details / Edit task description -- `@`: Add/edit due date (yyyy-mm-dd) -- `J` / `K`: Shift task down/up -- `H` / `L`: Shift task left/right -- `Space`: Shift task right -- `m`: Move task to specific list -- `D`: Delete task -- `u`: Undo -- `N`: New list -- `E`: Edit list title -- `X`: Delete list -- `<` / `>`: Move list left/right -- `/`: Search -- `Esc`: Return to lists -- `q`: Quit diff --git a/test/IO/Keyboard/ParserTest.hs b/test/IO/Keyboard/ParserTest.hs new file mode 100644 --- /dev/null +++ b/test/IO/Keyboard/ParserTest.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +module IO.Keyboard.ParserTest + ( test_parser + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.FileEmbed (embedFile) +import Text.RawString.QQ (r) + +import IO.Keyboard.Parser (bindings) +import IO.Keyboard.Types + +basic :: Text +basic = "quit = q" + +basicResult :: Bindings +basicResult = [(BChar 'q', "quit")] + +basicMulti :: Text +basicMulti = + [r| + quit = q + detail = + |] + +basicMultiResult :: Bindings +basicMultiResult = [(BChar 'q', "quit"), (BKey "Enter", "detail")] + +ini :: Text +ini = decodeUtf8 $(embedFile "test/IO/Keyboard/data/bindings.ini") + +iniResult :: Bindings +iniResult = + [ (BChar 'q', "quit") + , (BChar 'u', "undo") + , (BChar '/', "search") + , (BChar '?', "help") + , (BChar 'k', "previous") + , (BChar 'j', "next") + , (BChar 'h', "left") + , (BChar 'l', "right") + , (BChar 'g', "bottom") + , (BChar 'a', "new") + , (BChar 'O', "newAbove") + , (BChar 'o', "newBelow") + , (BChar 'e', "edit") + , (BChar 'A', "edit") + , (BChar 'i', "edit") + , (BChar 'C', "clear") + , (BChar 'D', "delete") + , (BKey "Enter", "detail") + , (BChar '@', "dueDate") + , (BChar 'K', "moveUp") + , (BChar 'J', "moveDown") + , (BChar 'H', "moveLeft") + , (BChar 'L', "moveRight") + , (BKey "Space", "moveRight") + , (BChar 'm', "moveMenu") + , (BChar 'N', "listNew") + , (BChar 'E', "listEdit") + , (BChar 'X', "listDelete") + , (BChar '>', "listRight") + , (BChar '<', "listLeft") + ] + +comma :: Text +comma = "quit = ," + +commaResult :: Bindings +commaResult = [(BChar ',', "quit")] + +test_parser :: TestTree +test_parser = + testGroup + "IO.Keyboard.Parser" + [ testCase "basic" (assertEqual "Parses quit" (Right basicResult) (bindings basic)) + , testCase + "basic multiline" + (assertEqual "Parses both" (Right basicMultiResult) (bindings basicMulti)) + , testCase "full ini file" (assertEqual "Parses all" (Right iniResult) (bindings ini)) + , testCase "comma" (assertEqual "Parses comma" (Right commaResult) (bindings comma)) + ] diff --git a/test/IO/KeyboardTest.hs b/test/IO/KeyboardTest.hs new file mode 100644 --- /dev/null +++ b/test/IO/KeyboardTest.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} + +module IO.KeyboardTest + ( test_keyboard + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Lens ((.~)) + +import Data.Taskell.Lists.Internal (initial) +import Events.State (create, quit) +import Events.State.Types (State, Stateful, mode) +import Events.State.Types.Mode (Mode (Shutdown)) +import Graphics.Vty.Input.Events (Event (..), Key (..)) +import IO.Keyboard (generate) +import IO.Keyboard.Types + +tester :: BoundActions -> Event -> Stateful +tester actions ev state = lookup ev actions >>= ($ state) + +cleanState :: State +cleanState = create "taskell.md" initial + +basicBindings :: Bindings +basicBindings = [(BChar 'q', "quit")] + +basicActions :: Actions +basicActions = [("quit", quit)] + +basicResult :: Maybe State +basicResult = Just $ (mode .~ Shutdown) cleanState + +test_keyboard :: TestTree +test_keyboard = + testGroup + "IO.Keyboard" + [ testCase + "generate" + (assertEqual + "Parses basic" + basicResult + (tester (generate basicBindings basicActions) (EvKey (KChar 'q') []) cleanState)) + ]