diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Mark Wales (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Mark Wales nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,289 @@ +# Taskell + +[![Build Status](https://travis-ci.org/smallhadroncollider/taskell.svg?branch=master)](https://travis-ci.org/smallhadroncollider/taskell) + +A CLI kanban board/task manager for Mac and Linux + +- Per project task lists +- `vim` style key-bindings +- Stored using Markdown +- Clean diffs for easy version control +- Support for sub-tasks and due dates +- Trello board imports +- GitHub project imports + +Buy Me A Coffee + +Follow [@taskellcli](https://twitter.com/taskellcli) on Twitter for updates + +![Demo](https://taskell.app/img/demo.gif) + +--- + +## Contents + +- [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) + - [Theming](#theming) +- [Roadmap](#roadmap) + +## Installation + +### Homebrew (Mac) + +You can install Taskell on your Mac using [Homebrew](https://brew.sh): + +```bash +brew install taskell +``` + +There are usually bottles (binaries) available. If these are not available for your computer, Homebrew will build Taskell from scratch, which can take a while, particularly on older machines. Occasionally the build fails the first time, but usually works on a second attempt. + +### Debian/Ubuntu + +[A `.deb` package is available for Debian/Ubuntu](https://github.com/smallhadroncollider/taskell/releases). Download it and install with `dpkg -i `. + +### Fedora + +Run `sudo dnf install ncurses-compat-libs` then download and run binary as described below. + +### Binaries + +[A binary is available for Mac and Linux](https://github.com/smallhadroncollider/taskell/releases). Download it and copy it to a directory in your `$PATH` (e.g. `/usr/local/bin` or `/usr/bin`). + +### Stack + +If none of the above options work you can build taskell using [Stack](https://docs.haskellstack.org/en/stable/README/). First [install Stack on your machine](https://docs.haskellstack.org/en/stable/README/#how-to-install). Then clone the repo and run `stack build && stack install`: this will build taskell and then install it in `~/.local/bin` (so make sure that directory is in your `$PATH`). Building from scratch can take a long time and occasionally doesn't work the first time (if this happens try running it again). + +## Using Taskell + +- `taskell`: will use `taskell.md` in the pwd - offers to create if not found +- `taskell filename.md`: will use `filename.md` in the pwd - offers to create if not found + +### Options + +- `-h`: show help +- `-v`: show version number +- `-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. + +### Storage + +By default stores in a `taskell.md` file in the working directory: + +```md +## To Do + +- Do this + +## Done + +- Do That +``` + +### Importing Trello Boards + +Taskell includes the ability to fetch a Trello board and store it as local taskell file. + +#### Authentication + +Before fetching a Trello board, you'll need to create an access token and store it in `~/.taskell/config.ini`. + +- First, [get a Trello token](https://trello.com/1/authorize?expiration=never&name=taskell&scope=read&response_type=token&key=80dbcf6f88f62cc5639774e13342c20b) +- Then add it to `~/.taskell/config.ini`: + + ```ini + [trello] + token = + ``` + +You can revoke access tokens [on Trello](https://trello.com/my/account) + +#### Fetching + +Running the following would pull down the Trello board with the ID "TRe1l0iD" into a file named `trello.md` and then open taskell with that file. + +```bash +taskell -t TRe1l0iD trello.md +``` + +Make sure you have permission to view the Trello board, otherwise you'll get an error. + +#### Limitations + +- This is a one-off procedure: it effectively imports a Trello board to taskell +- Currently imports: + - Lists + - Cards + - Card descriptions + - Card due dates + - Card checklists (merged into one list per card) + + +### Importing GitHub Projects + +Taskell includes the ability to fetch a GitHub project and store it as local taskell file. + +#### Authentication + +Before fetching a GitHub board, you'll need to create a person access token and store it in `~/.taskell/config.ini`. + +- First, [get a GitHub personal access token](https://github.com/settings/tokens/new) +- Make sure to tick the `repo` scope +- Then add it to `~/.taskell/config.ini`: + + ```ini + [github] + token = + ``` + +You can delete personal access tokens [on GitHub](https://github.com/settings/tokens/) + +#### Fetching + +Projects can belong to [organisations](#organisations) or to [individual repositories](#repositories). + +Make sure you have permission to view the GitHub project, otherwise you'll get an error. + +![GitHub Demo](https://taskell.app/img/github.gif) + +##### Organisations + +To import a project for an organisation called "test-org" you would use the following: + +```bash +taskell -g orgs/test-org github.md +``` + +This would then show you a list of possible projects to import. Enter the number of the project you wish to import. + +##### Repositories + +To import a project for the repository "test-repo" for the user "test-user": + +```bash +taskell -g repos/test-user/test-repo github.md +``` + +This would then show you a list of possible projects to import. Enter the number of the project you with to import. + +#### Limitations + +- This is a one-off procedure: it effectively imports a GitHub project to taskell +- Currently imports: + - Columns + - Cards + + + +## Configuration + +You can edit Taskell's settings by editing `~/.taskell/config.ini`: + +```ini +[general] +; the default filename to create/look for +filename = taskell.md + +[layout] +; the width of a column +column_width = 30 + +; the padding of a column +; for both sides, so 3 would give a gap of 6 between two columns +column_padding = 3 + +; the icon to use when a task has a description +; the default icon may not display on all systems +description_indicator = "≡" + +[markdown] +; the markdown to start a title line with +title = "##" + +; the markdown to start a task line with +task = "-" + +; the markdown to start a sub-task line with +subtask = " *" +``` + +Make sure that the values in the `[markdown]` section are surrounded by **double**-quotes. + +If you always use sub-tasks, an alternative setup for `[markdown]` might be: + +```ini +[markdown] +title = "##" + +; each task is a header +task = "###" + +; subtasks are list items under the header +subtask = "-" +``` + +**Warning**: currently if you change your `[markdown]` settings any older files stored with different settings will not be readable. + +### Theming + +You can edit Taskell's colour-scheme by editing `~/.taskell/theme.ini`: + +```ini +[other] + +; list title +title.fg = green + +; current list title +titleCurrent.fg = blue + +; current task +taskCurrent.fg = magenta +``` + +You can also change the background and default text colour: + +```ini +[default] + +; the app background colour +default.bg = brightBlack + +; the app text colour +default.fg = white +``` + +The available colours are: `black`, `red`, `green`, `yellow`, `blue`, `magenta`, `cyan`, `white`, `brightBlack`, `brightRed`, `brightGreen`, `brightYellow`, `brightBlue`, `brightMagenta`, `brightCyan`, `brightWhite`, or `default` + +--- + +## Roadmap + +See [roadmap.md](https://github.com/smallhadroncollider/taskell/blob/develop/roadmap.md) for planned features + +### Contributing + +Please check the [roadmap.md](https://github.com/smallhadroncollider/taskell/blob/develop/roadmap.md) before adding any bugs/feature requests to Issues. + +Anyone is welcome to contribute to the project, but please read through [CONTRIBUTING.md](https://github.com/smallhadroncollider/taskell/blob/master/CONTRIBUTING.md) and make sure that you agree with the [Code of Conduct](https://github.com/smallhadroncollider/taskell/blob/master/CODE_OF_CONDUCT.md) before getting involved. + +--- + +## Acknowledgements + +Built using [Brick](https://github.com/jtdaugherty/brick). Thanks to [Jonathan Daugherty](https://github.com/jtdaugherty) for answering all my questions and pointing me in the right direction. Also thanks to [Jack Leigh](https://github.com/leighman) and [Thom Wright](https://github.com/ThomWright) for helping me get started. Also thanks to [Katja Durrani](https://github.com/katjad) for submitting Taskell to [`homebrew-core`](https://github.com/Homebrew/homebrew-core). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Main where + +import ClassyPrelude + +import App (go) +import Events.State (create) +import IO.Config (setup) +import IO.Taskell (Next (..), load) + +main :: IO () +main = do + config <- setup + next <- runReaderT load config + case next of + Exit -> return () + Output text -> putStrLn text + Load path lists -> go config $ create path lists diff --git a/src/App.hs b/src/App.hs new file mode 100644 --- /dev/null +++ b/src/App.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module App + ( go + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick +import Graphics.Vty (Mode (BracketedPaste), outputIface, setMode, supportsMode) +import Graphics.Vty.Input.Events (Event (..)) + +import qualified Control.FoldDebounce as Debounce + +import Data.Taskell.Date (currentDay) +import Data.Taskell.Lists (Lists) +import Events.Actions (event) +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.Taskell (writeData) +import UI.Draw (chooseCursor, draw) +import UI.Types (ResourceName (..)) + +type DebouncedMessage = (Lists, FilePath) + +type DebouncedWrite = DebouncedMessage -> IO () + +type Trigger = Debounce.Trigger DebouncedMessage DebouncedMessage + +-- store +store :: Config -> DebouncedMessage -> IO () +store config (ls, pth) = writeData config ls pth + +next :: DebouncedWrite -> State -> EventM ResourceName (Next State) +next send state = + case state ^. io of + Just ls -> do + invalidateCache + liftIO $ send (ls, state ^. path) + Brick.continue $ Events.State.continue state + Nothing -> Brick.continue state + +-- debouncing +debounce :: Config -> State -> IO (DebouncedWrite, Trigger) +debounce config initial = do + trigger <- + Debounce.new + Debounce.Args + { Debounce.cb = store config + , Debounce.fold = \_ b -> b + , Debounce.init = (initial ^. lists, initial ^. path) + } + Debounce.def + let send = Debounce.send trigger + return (send, trigger) + +-- cache clearing +clearCache :: State -> EventM ResourceName () +clearCache state = do + let (li, ti) = state ^. current + invalidateCacheEntry (RNList li) + invalidateCacheEntry (RNTask (li, 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 + +clearList :: State -> EventM ResourceName () +clearList state = do + let (list, _) = state ^. current + let count = countCurrent state + let range = [0 .. (count - 1)] + invalidateCacheEntry $ RNList list + void . sequence $ invalidateCacheEntry . (\x -> RNTask (list, x)) <$> range + +-- event handling +handleVtyEvent :: (DebouncedWrite, Trigger) -> State -> Event -> EventM ResourceName (Next State) +handleVtyEvent (send, trigger) previousState e = do + let state = event e previousState + case previousState ^. mode of + Search _ _ -> invalidateCache + (Modal MoveTo) -> clearAllTitles previousState + (Insert ITask ICreate _) -> clearList previousState + _ -> return () + case state ^. mode of + Shutdown -> liftIO (Debounce.close trigger) >> Brick.halt state + (Modal MoveTo) -> clearAllTitles state >> next send state + (Insert ITask ICreate _) -> clearList state >> next send state + _ -> clearCache previousState >> clearCache state >> next send state + +handleEvent :: + (DebouncedWrite, Trigger) + -> 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 + +-- | 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 + return state + +-- | Sets up Brick +go :: Config -> State -> IO () +go config initial = do + attrMap' <- const <$> generateAttrMap + today <- currentDay + db <- debounce config initial + let app = + App + { appDraw = draw (layout config) today + , appChooseCursor = chooseCursor + , appHandleEvent = handleEvent db + , appStartEvent = appStart + , appAttrMap = attrMap' + } + void (defaultMain app initial) diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Config where + +import ClassyPrelude + +import Data.FileEmbed (embedFile) + +version :: Text +version = "1.3.5" + +usage :: Text +usage = decodeUtf8 $(embedFile "templates/usage.txt") diff --git a/src/Data/Taskell/Date.hs b/src/Data/Taskell/Date.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/Date.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.Date + ( Day + , Deadline(..) + , DeadlineFn + , dayToText + , dayToOutput + , textToDay + , utcToLocalDay + , currentDay + , deadline + ) where + +import ClassyPrelude + +import Data.Time (Day) +import Data.Time.Calendar (diffDays, toGregorian) +import Data.Time.Clock (secondsToDiffTime) +import Data.Time.Format (formatTime, parseTimeM) +import Data.Time.LocalTime (TimeZone, localDay, utcToZonedTime, zonedTimeToLocalTime) + +data Deadline + = Passed + | Today + | Tomorrow + | ThisWeek + | Plenty + deriving (Show, Eq) + +type DeadlineFn = Day -> Deadline + +dayToText :: Day -> Day -> Text +dayToText today day = pack $ formatTime defaultTimeLocale format (UTCTime day (secondsToDiffTime 0)) + where + (currentYear, _, _) = toGregorian today + (dateYear, _, _) = toGregorian day + format = + if currentYear == dateYear + then "%d-%b" + else "%d-%b %Y" + +dayToOutput :: Day -> Text +dayToOutput day = pack $ formatTime defaultTimeLocale "%Y-%m-%d" (UTCTime day (secondsToDiffTime 0)) + +utcToLocalDay :: TimeZone -> UTCTime -> Day +utcToLocalDay tz = localDay . zonedTimeToLocalTime . utcToZonedTime tz + +textToTime :: Text -> Maybe UTCTime +textToTime = parseTimeM False defaultTimeLocale "%Y-%m-%d" . unpack + +textToDay :: Text -> Maybe Day +textToDay = (utctDay <$>) . textToTime + +currentDay :: IO Day +currentDay = utctDay <$> getCurrentTime + +-- work out the deadline +deadline :: Day -> Day -> Deadline +deadline today date + | days < 0 = Passed + | days == 0 = Today + | days == 1 = Tomorrow + | days < 7 = ThisWeek + | otherwise = Plenty + where + days = diffDays date today diff --git a/src/Data/Taskell/List.hs b/src/Data/Taskell/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/List.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Taskell.List + ( List + , title + , tasks + , create + , empty + , new + , count + , newAt + , append + , extract + , updateFn + , update + , move + , deleteTask + , getTask + , searchFor + ) where + +import Data.Taskell.List.Internal diff --git a/src/Data/Taskell/List/Internal.hs b/src/Data/Taskell/List/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/List/Internal.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Taskell.List.Internal where + +import ClassyPrelude + +import Control.Lens (ix, makeLenses, (%%~), (%~), (&), (.~), (^.), (^?)) + +import Data.Sequence as S (adjust', deleteAt, insertAt, update, (|>)) + +import qualified Data.Taskell.Seq as S +import qualified Data.Taskell.Task as T (Task, Update, blank, contains) + +data List = List + { _title :: Text + , _tasks :: Seq T.Task + } deriving (Show, Eq) + +type Update = List -> List + +-- create lenses +$(makeLenses ''List) + +-- operations +create :: Text -> Seq T.Task -> List +create = List + +empty :: Text -> List +empty text = List text ClassyPrelude.empty + +new :: Update +new = append T.blank + +count :: List -> Int +count = length . (^. tasks) + +newAt :: Int -> Update +newAt idx = tasks %~ insertAt idx T.blank + +append :: T.Task -> Update +append task = tasks %~ (|> task) + +extract :: Int -> List -> Maybe (List, T.Task) +extract idx list = do + (xs, x) <- S.extract idx (list ^. tasks) + return (list & tasks .~ xs, x) + +updateFn :: Int -> T.Update -> Update +updateFn idx fn = tasks %~ adjust' fn idx + +update :: Int -> T.Task -> Update +update idx task = tasks %~ S.update idx task + +move :: Int -> Int -> List -> Maybe List +move from dir = tasks %%~ S.shiftBy from dir + +deleteTask :: Int -> Update +deleteTask idx = tasks %~ deleteAt idx + +getTask :: Int -> List -> Maybe T.Task +getTask idx = (^? tasks . ix idx) + +searchFor :: Text -> Update +searchFor text = tasks %~ filter (T.contains text) diff --git a/src/Data/Taskell/Lists.hs b/src/Data/Taskell/Lists.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/Lists.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Taskell.Lists + ( Lists + , initial + , updateLists + , count + , get + , changeList + , newList + , delete + , exists + , shiftBy + , search + , appendToLast + , analyse + ) where + +import Data.Taskell.Lists.Internal diff --git a/src/Data/Taskell/Lists/Internal.hs b/src/Data/Taskell/Lists/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/Lists/Internal.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.Lists.Internal where + +import ClassyPrelude hiding (empty) + +import Data.Sequence as S (deleteAt, update, (!?), (|>)) + +import Data.Taskell.List as L (List, append, count, empty, extract, searchFor) +import qualified Data.Taskell.Seq as S +import Data.Taskell.Task (Task) + +type Lists = Seq List + +type Update = Lists -> Lists + +initial :: Lists +initial = fromList [empty "To Do", empty "Done"] + +updateLists :: Int -> List -> Update +updateLists = S.update + +count :: Int -> Lists -> Int +count idx tasks = maybe 0 L.count (tasks !? idx) + +get :: Lists -> Int -> Maybe List +get = (!?) + +changeList :: (Int, Int) -> Lists -> Int -> Maybe Lists +changeList (list, idx) tasks dir = do + let next = list + dir + (from, task) <- extract idx =<< tasks !? list -- extract current task + to <- append task <$> tasks !? next -- get next list and append task + return . updateLists next to $ updateLists list from tasks -- update lists + +newList :: Text -> Update +newList title = (|> empty title) + +delete :: Int -> Update +delete = deleteAt + +exists :: Int -> Lists -> Bool +exists idx tasks = isJust $ tasks !? idx + +shiftBy :: Int -> Int -> Lists -> Maybe Lists +shiftBy = S.shiftBy + +search :: Text -> Update +search text = (searchFor text <$>) + +appendToLast :: Task -> Update +appendToLast task lists = + fromMaybe lists $ do + let idx = length lists - 1 + list <- append task <$> lists !? idx + return $ updateLists idx list lists + +analyse :: Text -> Lists -> Text +analyse filepath lists = + concat + [ filepath + , "\n" + , "Lists: " + , tshow $ length lists + , "\n" + , "Tasks: " + , tshow $ foldl' (+) 0 (L.count <$> lists) + ] diff --git a/src/Data/Taskell/Seq.hs b/src/Data/Taskell/Seq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/Seq.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Taskell.Seq where + +import ClassyPrelude + +import Data.Sequence (deleteAt, insertAt, (!?)) + +extract :: Int -> Seq a -> Maybe (Seq a, a) +extract idx xs = (,) (deleteAt idx xs) <$> xs !? idx + +shiftBy :: Int -> Int -> Seq a -> Maybe (Seq a) +shiftBy idx dir xs = do + (a, current) <- extract idx xs + return $ insertAt (idx + dir) current a diff --git a/src/Data/Taskell/Subtask.hs b/src/Data/Taskell/Subtask.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/Subtask.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Taskell.Subtask + ( Subtask + , Update + , new + , blank + , name + , complete + , toggle + ) where + +import Data.Taskell.Subtask.Internal diff --git a/src/Data/Taskell/Subtask/Internal.hs b/src/Data/Taskell/Subtask/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/Subtask/Internal.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.Subtask.Internal where + +import ClassyPrelude +import Control.Lens (makeLenses, (%~)) + +data Subtask = Subtask + { _name :: Text + , _complete :: Bool + } deriving (Show, Eq) + +type Update = Subtask -> Subtask + +-- create lenses +$(makeLenses ''Subtask) + +-- operations +blank :: Subtask +blank = Subtask "" False + +new :: Text -> Bool -> Subtask +new = Subtask + +toggle :: Update +toggle = complete %~ not diff --git a/src/Data/Taskell/Task.hs b/src/Data/Taskell/Task.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/Task.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Taskell.Task + ( Task + , Update + , name + , description + , due + , subtasks + , blank + , new + , setDescription + , appendDescription + , setDue + , getSubtask + , addSubtask + , hasSubtasks + , updateSubtask + , removeSubtask + , countSubtasks + , countCompleteSubtasks + , contains + , isBlank + ) where + +import Data.Taskell.Task.Internal diff --git a/src/Data/Taskell/Task/Internal.hs b/src/Data/Taskell/Task/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Taskell/Task/Internal.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.Task.Internal where + +import ClassyPrelude + +import Control.Lens (ix, makeLenses, (%~), (&), (.~), (^.), (^?)) + +import Data.Sequence as S (adjust', deleteAt, (|>)) +import Data.Taskell.Date (Day, textToDay) +import qualified Data.Taskell.Subtask as ST (Subtask, Update, complete, name) +import Data.Text (strip) + +data Task = Task + { _name :: Text + , _description :: Maybe Text + , _subtasks :: Seq ST.Subtask + , _due :: Maybe Day + } deriving (Show, Eq) + +type Update = Task -> Task + +-- create lenses +$(makeLenses ''Task) + +-- operations +blank :: Task +blank = Task "" Nothing empty Nothing + +new :: Text -> Task +new text = blank & (name .~ text) + +setDescription :: Text -> Update +setDescription text = + if null (strip text) + then id + else description .~ Just text + +maybeAppend :: Text -> Maybe Text -> Maybe Text +maybeAppend text (Just current) = Just (concat [current, "\n", text]) +maybeAppend text Nothing = Just text + +appendDescription :: Text -> Update +appendDescription text = + if null (strip text) + then id + else description %~ maybeAppend text + +setDue :: Text -> Update +setDue date = + case textToDay date of + Just day -> due .~ Just day + Nothing -> id + +getSubtask :: Int -> Task -> Maybe ST.Subtask +getSubtask idx = (^? subtasks . ix idx) + +addSubtask :: ST.Subtask -> Update +addSubtask subtask = subtasks %~ (|> subtask) + +hasSubtasks :: Task -> Bool +hasSubtasks = not . null . (^. subtasks) + +updateSubtask :: Int -> ST.Update -> Update +updateSubtask idx fn = subtasks %~ adjust' fn idx + +removeSubtask :: Int -> Update +removeSubtask idx = subtasks %~ S.deleteAt idx + +countSubtasks :: Task -> Int +countSubtasks = length . (^. subtasks) + +countCompleteSubtasks :: Task -> Int +countCompleteSubtasks = length . filter (^. ST.complete) . (^. subtasks) + +contains :: Text -> Task -> Bool +contains text task = text `isInfixOf` (task ^. name) || not (null sts) + where + sts = filter (isInfixOf text) $ (^. ST.name) <$> (task ^. subtasks) + +isBlank :: Task -> Bool +isBlank task = + null (task ^. name) && + isNothing (task ^. description) && null (task ^. subtasks) && isNothing (task ^. due) diff --git a/src/Events/Actions.hs b/src/Events/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Events/Actions.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.Actions + ( event + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Graphics.Vty.Input.Events (Event (..)) + +import Events.State.Types (State, Stateful, mode) +import Events.State.Types.Mode (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 + +-- takes an event and returns a Maybe State +event' :: Event -> Stateful +-- for other events pass through to relevant modules +event' e state = + case state ^. mode of + Normal -> Normal.event e state + Search {} -> Search.event e state + Insert {} -> Insert.event e state + Modal {} -> Modal.event e state + _ -> return state + +-- returns new state if successful +event :: Event -> State -> State +event e state = fromMaybe state $ event' e state diff --git a/src/Events/Actions/Insert.hs b/src/Events/Actions/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Events/Actions/Insert.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.Actions.Insert + ( event + ) where + +import ClassyPrelude + +import Control.Lens ((&), (.~), (^.)) + +import Events.State +import Events.State.Types +import Events.State.Types.Mode (InsertMode (..), InsertType (..), Mode (Insert)) +import Graphics.Vty.Input.Events (Event (EvKey), Key (KEnter, KEsc)) +import qualified UI.Field as F (event) + +event :: Event -> Stateful +event (EvKey KEnter _) state = + case state ^. mode of + Insert IList ICreate _ -> + (write =<<) . (startCreate =<<) . (newItem =<<) . (store =<<) $ createList state + Insert IList IEdit _ -> (write =<<) . (normalMode =<<) $ finishListTitle state + Insert ITask ICreate _ -> + (write =<<) . (below =<<) . (removeBlank =<<) . (store =<<) $ finishTask state + Insert ITask IEdit _ -> + (write =<<) . (removeBlank =<<) . (normalMode =<<) $ finishTask state + _ -> return state +event (EvKey KEsc _) state = + case state ^. mode of + Insert IList ICreate _ -> (normalMode =<<) . (write =<<) $ createList state + Insert IList IEdit _ -> (write =<<) . (normalMode =<<) $ finishListTitle state + Insert ITask _ _ -> (write =<<) . (removeBlank =<<) . (normalMode =<<) $ finishTask state + _ -> return state +event e state = + return $ + case state ^. mode of + Insert iType iMode field -> state & mode .~ Insert iType iMode (F.event e field) + _ -> state diff --git a/src/Events/Actions/Modal.hs b/src/Events/Actions/Modal.hs new file mode 100644 --- /dev/null +++ b/src/Events/Actions/Modal.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.Actions.Modal + ( event + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Events.State.Types (Stateful, mode) +import Events.State.Types.Mode (ModalType (..), Mode (Modal)) +import Graphics.Vty.Input.Events + +import qualified Events.Actions.Modal.Detail as Detail +import qualified Events.Actions.Modal.Help as Help +import qualified Events.Actions.Modal.MoveTo as MoveTo + +event :: Event -> Stateful +event e s = + case s ^. mode of + Modal Help -> Help.event e s + Modal (Detail _ _) -> Detail.event e s + Modal MoveTo -> MoveTo.event e s + _ -> return s diff --git a/src/Events/Actions/Modal/Detail.hs b/src/Events/Actions/Modal/Detail.hs new file mode 100644 --- /dev/null +++ b/src/Events/Actions/Modal/Detail.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.Actions.Modal.Detail + ( event + ) where + +import ClassyPrelude + +import Events.State +import Events.State.Modal.Detail as Detail +import Events.State.Types +import Events.State.Types.Mode (DetailItem (..), DetailMode (..)) +import Graphics.Vty.Input.Events +import qualified UI.Field as F (event) + +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 _ = return + +insert :: Event -> Stateful +insert (EvKey KEsc _) s = do + item <- getCurrentItem s + case item of + DetailDescription -> (write =<<) $ finishDescription s + DetailDate -> (write =<<) $ finishDue s + (DetailItem _) -> (write =<<) . (showDetail =<<) $ finishSubtask s +insert (EvKey KEnter _) s = do + item <- getCurrentItem s + case item of + DetailDescription -> (write =<<) $ finishDescription s + DetailDate -> (write =<<) $ finishDue s + (DetailItem _) -> + (Detail.lastSubtask =<<) . (Detail.newItem =<<) . (store =<<) . (write =<<) $ + finishSubtask s +insert e s = updateField (F.event e) s + +event :: Event -> Stateful +event e s = do + m <- getCurrentMode s + case m of + DetailNormal -> normal e s + (DetailInsert _) -> insert e s diff --git a/src/Events/Actions/Modal/Help.hs b/src/Events/Actions/Modal/Help.hs new file mode 100644 --- /dev/null +++ b/src/Events/Actions/Modal/Help.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.Actions.Modal.Help + ( event + ) where + +import ClassyPrelude +import Events.State +import Events.State.Types (Stateful) +import Graphics.Vty.Input.Events + +event :: Event -> Stateful +event (EvKey (KChar 'q') _) = quit +event (EvKey _ _) = normalMode +event _ = return diff --git a/src/Events/Actions/Modal/MoveTo.hs b/src/Events/Actions/Modal/MoveTo.hs new file mode 100644 --- /dev/null +++ b/src/Events/Actions/Modal/MoveTo.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.Actions.Modal.MoveTo + ( event + ) where + +import ClassyPrelude +import Events.State +import Events.State.Types (Stateful) +import Graphics.Vty.Input.Events + +event :: Event -> Stateful +event (EvKey KEsc _) = normalMode +event (EvKey KEnter _) = normalMode +event (EvKey (KChar c) _) = (normalMode =<<) . (write =<<) . (moveTo c =<<) . store +event _ = return diff --git a/src/Events/Actions/Normal.hs b/src/Events/Actions/Normal.hs new file mode 100644 --- /dev/null +++ b/src/Events/Actions/Normal.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.Actions.Normal + ( event + ) where + +import ClassyPrelude hiding (delete) + +import Data.Char (isDigit) +import Events.State +import Events.State.Modal.Detail (editDue, showDetail) +import Events.State.Types (Stateful) +import Graphics.Vty.Input.Events + +-- 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 + | otherwise = return +-- fallback +event _ = return diff --git a/src/Events/Actions/Search.hs b/src/Events/Actions/Search.hs new file mode 100644 --- /dev/null +++ b/src/Events/Actions/Search.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.Actions.Search + ( event + ) where + +import ClassyPrelude + +import Control.Lens ((&), (.~), (^.)) + +import Events.State +import Events.State.Types (Stateful, mode) +import Events.State.Types.Mode (Mode (Search)) +import Graphics.Vty.Input.Events +import qualified UI.Field as F (event) + +import qualified Events.Actions.Normal as Normal + +search :: Event -> Stateful +search (EvKey KEnter _) s = searchEntered s +search e s = + return $ + case s ^. mode of + Search ent field -> s & mode .~ Search ent (F.event e field) + _ -> s + +event :: Event -> Stateful +event (EvKey KEsc _) s = normalMode s +event e s = + case s ^. mode of + Search ent _ -> + (if ent + then search + else Normal.event) + e + s + _ -> return s diff --git a/src/Events/State.hs b/src/Events/State.hs new file mode 100644 --- /dev/null +++ b/src/Events/State.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Events.State + -- App + ( continue + , write + , countCurrent + -- UI.Main + , normalise + -- Main + , create + -- Events.Actions.Normal + , quit + , startEdit + , startCreate + , createListStart + , editListStart + , deleteCurrentList + , clearItem + , above + , below + , bottom + , previous + , next + , left + , right + , up + , down + , moveLeft + , moveRight + , delete + , selectList + , listLeft + , listRight + , undo + , store + , searchMode + -- Events.Actions.Search + , searchEntered + -- Events.Actions.Insert + , createList + , removeBlank + , newItem + , normalMode + , finishTask + , finishListTitle + -- Events.Actions.Modal + , showHelp + , showMoveTo + , moveTo + , getCurrentList + , getCurrentTask + , setCurrentTask + ) where + +import ClassyPrelude hiding (delete) + +import Control.Lens ((&), (.~), (^.)) + +import Data.Char (digitToInt, ord) + +import Data.Taskell.List (List, deleteTask, getTask, move, new, newAt, title, update) +import qualified Data.Taskell.Lists as Lists +import Data.Taskell.Task (Task, isBlank, name) + +import Events.State.Types +import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..)) +import UI.Field (blankField, getText, textToField) + +type InternalStateful = State -> State + +create :: FilePath -> Lists.Lists -> State +create p ls = + State {_mode = Normal, _lists = ls, _history = [], _current = (0, 0), _path = p, _io = Nothing} + +-- app state +quit :: Stateful +quit = Just . (mode .~ Shutdown) + +continue :: State -> State +continue = io .~ Nothing + +write :: Stateful +write state = Just $ state & io .~ Just (state ^. lists) + +store :: Stateful +store state = Just $ state & history .~ (state ^. current, state ^. lists) : state ^. history + +undo :: Stateful +undo state = + Just $ + case state ^. history of + [] -> state + ((c, l):xs) -> state & current .~ c & lists .~ l & history .~ xs + +-- createList +createList :: Stateful +createList state = + Just $ + case state ^. mode of + Insert IList ICreate f -> + updateListToLast . setLists state $ Lists.newList (getText f) $ state ^. lists + _ -> state + +updateListToLast :: InternalStateful +updateListToLast state = setCurrentList state (length (state ^. lists) - 1) + +createListStart :: Stateful +createListStart = Just . (mode .~ Insert IList ICreate blankField) + +-- editList +editListStart :: Stateful +editListStart state = do + f <- textToField . (^. title) <$> getList state + return $ state & mode .~ Insert IList IEdit f + +deleteCurrentList :: Stateful +deleteCurrentList state = + Just . fixIndex . setLists state $ Lists.delete (getCurrentList state) (state ^. lists) + +-- insert +getCurrentTask :: State -> Maybe Task +getCurrentTask state = getList state >>= getTask (getIndex state) + +setCurrentTask :: Task -> Stateful +setCurrentTask task state = setList state . update (getIndex state) task <$> getList state + +setCurrentTaskText :: Text -> Stateful +setCurrentTaskText text state = + flip setCurrentTask state =<< (name .~ text) <$> getCurrentTask state + +startCreate :: Stateful +startCreate = Just . (mode .~ Insert ITask ICreate blankField) + +startEdit :: Stateful +startEdit state = do + field <- textToField . (^. name) <$> getCurrentTask state + return $ state & mode .~ Insert ITask IEdit field + +finishTask :: Stateful +finishTask state = + case state ^. mode of + Insert ITask iMode f -> + setCurrentTaskText (getText f) $ state & (mode .~ Insert ITask iMode blankField) + _ -> Just state + +finishListTitle :: Stateful +finishListTitle state = + case state ^. mode of + Insert IList iMode f -> + setCurrentListTitle (getText f) $ state & (mode .~ Insert IList iMode blankField) + _ -> Just state + +normalMode :: Stateful +normalMode = Just . (mode .~ Normal) + +addToListAt :: Int -> Stateful +addToListAt offset state = do + let idx = getIndex state + offset + fixIndex . setList (setIndex state idx) . newAt idx <$> getList state + +above :: Stateful +above = addToListAt 0 + +below :: Stateful +below = addToListAt 1 + +newItem :: Stateful +newItem state = selectLast . setList state . new <$> getList state + +clearItem :: Stateful +clearItem = setCurrentTaskText "" + +bottom :: Stateful +bottom = return . selectLast + +selectLast :: InternalStateful +selectLast state = setIndex state (countCurrent state - 1) + +removeBlank :: Stateful +removeBlank state = do + currentTask <- getCurrentTask state + (if isBlank currentTask + then delete + else return) + state + +-- moving +up :: Stateful +up state = previous =<< setList state <$> (move (getIndex state) (-1) =<< getList state) + +down :: Stateful +down state = next =<< setList state <$> (move (getIndex state) 1 =<< getList state) + +move' :: Int -> State -> Maybe State +move' idx state = + fixIndex . setLists state <$> Lists.changeList (state ^. current) (state ^. lists) idx + +moveLeft :: Stateful +moveLeft = move' (-1) + +moveRight :: Stateful +moveRight = move' 1 + +selectList :: Char -> Stateful +selectList idx state = + Just $ + (if exists + then current .~ (list, 0) + else id) + state + where + list = digitToInt idx - 1 + exists = Lists.exists list (state ^. lists) + +-- removing +delete :: Stateful +delete state = fixIndex . setList state . deleteTask (getIndex state) <$> getList state + +-- list and index +countCurrent :: State -> Int +countCurrent state = Lists.count (getCurrentList state) (state ^. lists) + +setIndex :: State -> Int -> State +setIndex state idx = state & current .~ (getCurrentList state, idx) + +setCurrentList :: State -> Int -> State +setCurrentList state idx = state & current .~ (idx, getIndex state) + +getIndex :: State -> Int +getIndex = snd . (^. current) + +next :: Stateful +next state = Just $ setIndex state idx' + where + idx = getIndex state + count = countCurrent state + idx' = + if idx < (count - 1) + then succ idx + else idx + +previous :: Stateful +previous state = Just $ setIndex state idx' + where + idx = getIndex state + idx' = + if idx > 0 + then pred idx + else 0 + +left :: Stateful +left state = + Just . fixIndex . setCurrentList state $ + if list > 0 + then pred list + else 0 + where + list = getCurrentList state + +right :: Stateful +right state = + Just . fixIndex . setCurrentList state $ + if list < (count - 1) + then succ list + else list + where + list = getCurrentList state + count = length (state ^. lists) + +fixIndex :: InternalStateful +fixIndex state = + if getIndex state' > count + then setIndex state' count' + else state' + where + lists' = state ^. lists + idx = Lists.exists (getCurrentList state) lists' + state' = + if idx + then state + else setCurrentList state (length lists' - 1) + count = countCurrent state' - 1 + count' = + if count < 0 + then 0 + else count + +-- tasks +getCurrentList :: State -> Int +getCurrentList = fst . (^. current) + +getList :: State -> Maybe List +getList state = Lists.get (state ^. lists) (getCurrentList state) + +setList :: State -> List -> State +setList state list = setLists state (Lists.updateLists (getCurrentList state) list (state ^. lists)) + +setCurrentListTitle :: Text -> Stateful +setCurrentListTitle text state = setList state . (title .~ text) <$> getList state + +setLists :: State -> Lists.Lists -> State +setLists state lists' = state & lists .~ lists' + +moveTo :: Char -> Stateful +moveTo char state = do + let li = ord char - ord 'a' + cur = getCurrentList state + if li == cur || li < 0 || li >= length (state ^. lists) + then Nothing + else do + s <- move' (li - cur) state + return . selectLast $ setCurrentList s li + +-- move lists +listMove :: Int -> Stateful +listMove offset state = do + let currentList = getCurrentList state + let lists' = state ^. lists + if currentList + offset < 0 || currentList + offset >= length lists' + then Nothing + else do + let state' = fixIndex $ setCurrentList state (currentList + offset) + setLists state' <$> Lists.shiftBy currentList offset lists' + +listLeft :: Stateful +listLeft = listMove (-1) + +listRight :: Stateful +listRight = listMove 1 + +-- search +searchMode :: Stateful +searchMode state = + Just $ + case state ^. mode of + Search _ field -> state & mode .~ Search True field + _ -> state & mode .~ Search True blankField + +searchEntered :: Stateful +searchEntered state = + case state ^. mode of + Search _ field -> Just $ state & mode .~ Search False field + _ -> Nothing + +-- help +showHelp :: Stateful +showHelp = Just . (mode .~ Modal Help) + +showMoveTo :: Stateful +showMoveTo = Just . (mode .~ Modal MoveTo) + +-- view - maybe shouldn't be in here... +search :: State -> State +search state = + case state ^. mode of + Search _ field -> fixIndex . setLists state $ Lists.search (getText field) (state ^. lists) + _ -> state + +newList :: State -> State +newList state = + case state ^. mode of + Insert IList ICreate f -> + let ls = state ^. lists + in fixIndex $ setCurrentList (setLists state (Lists.newList (getText f) ls)) (length ls) + _ -> state + +normalise :: State -> State +normalise = newList . search diff --git a/src/Events/State/Modal/Detail.hs b/src/Events/State/Modal/Detail.hs new file mode 100644 --- /dev/null +++ b/src/Events/State/Modal/Detail.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Events.State.Modal.Detail + ( updateField + , finishSubtask + , finishDescription + , finishDue + , showDetail + , getCurrentItem + , getCurrentMode + , getField + , setComplete + , remove + , insertMode + , editDescription + , editDue + , newItem + , nextSubtask + , previousSubtask + , lastSubtask + ) where + +import ClassyPrelude + +import Control.Lens ((&), (.~), (^.)) + +import Data.Taskell.Date (dayToOutput) +import qualified Data.Taskell.Subtask as ST (blank, name, toggle) +import Data.Taskell.Task (Task, addSubtask, countSubtasks, description, due, + getSubtask, removeSubtask, setDescription, setDue, + updateSubtask) +import Events.State (getCurrentTask, setCurrentTask) +import Events.State.Types (State, Stateful, mode) +import Events.State.Types.Mode (DetailItem (..), DetailMode (..), ModalType (Detail), + Mode (Modal)) +import UI.Field (Field, blankField, getText, textToField) + +updateField :: (Field -> Field) -> Stateful +updateField fieldEvent s = + return $ + case s ^. mode of + Modal (Detail detailItem (DetailInsert field)) -> + s & mode .~ Modal (Detail detailItem (DetailInsert (fieldEvent field))) + _ -> s + +finishSubtask :: Stateful +finishSubtask state = do + text <- getText <$> getField state + i <- getCurrentSubtask state + task <- updateSubtask i (ST.name .~ text) <$> getCurrentTask state + setCurrentTask task $ state & mode .~ Modal (Detail (DetailItem i) (DetailInsert blankField)) + +finish :: (Text -> Task -> Task) -> Stateful +finish fn state = do + text <- getText <$> getField state + task <- fn text <$> getCurrentTask state + setCurrentTask task $ state & mode .~ Modal (Detail (DetailItem 0) DetailNormal) + +finishDescription :: Stateful +finishDescription = finish setDescription + +finishDue :: Stateful +finishDue = finish setDue + +showDetail :: Stateful +showDetail s = do + _ <- getCurrentTask s + let i = fromMaybe 0 $ getCurrentSubtask s + return $ s & mode .~ Modal (Detail (DetailItem i) DetailNormal) + +getCurrentSubtask :: State -> Maybe Int +getCurrentSubtask state = + case state ^. mode of + Modal (Detail (DetailItem i) _) -> Just i + _ -> Nothing + +getCurrentItem :: State -> Maybe DetailItem +getCurrentItem state = + case state ^. mode of + Modal (Detail item _) -> Just item + _ -> Nothing + +getCurrentMode :: State -> Maybe DetailMode +getCurrentMode state = + case state ^. mode of + Modal (Detail _ m) -> Just m + _ -> Nothing + +getField :: State -> Maybe Field +getField state = + case state ^. mode of + Modal (Detail _ (DetailInsert f)) -> Just f + _ -> Nothing + +setComplete :: Stateful +setComplete state = do + i <- getCurrentSubtask state + task <- updateSubtask i ST.toggle <$> getCurrentTask state + setCurrentTask task state + +remove :: Stateful +remove state = do + i <- getCurrentSubtask state + task <- removeSubtask i <$> getCurrentTask state + state' <- setCurrentTask task state + setIndex state' i + +insertMode :: Stateful +insertMode state = do + i <- getCurrentSubtask state + task <- getCurrentTask state + n <- (^. ST.name) <$> getSubtask i task + case state ^. mode of + Modal (Detail (DetailItem i') _) -> + Just (state & mode .~ Modal (Detail (DetailItem i') (DetailInsert (textToField n)))) + _ -> Nothing + +editDescription :: Stateful +editDescription state = do + summ <- (^. description) <$> getCurrentTask state + let summ' = fromMaybe "" summ + return $ state & mode .~ Modal (Detail DetailDescription (DetailInsert (textToField summ'))) + +editDue :: Stateful +editDue state = do + day <- (^. due) <$> getCurrentTask state + let day' = maybe "" dayToOutput day + return $ state & mode .~ Modal (Detail DetailDate (DetailInsert (textToField day'))) + +newItem :: Stateful +newItem state = do + task <- addSubtask ST.blank <$> getCurrentTask state + setCurrentTask task state + +-- list navigation +changeSubtask :: Int -> Stateful +changeSubtask inc state = do + i <- (+ inc) <$> getCurrentSubtask state + setIndex state i + +nextSubtask :: Stateful +nextSubtask = changeSubtask 1 + +previousSubtask :: Stateful +previousSubtask = changeSubtask (-1) + +lastSubtask :: Stateful +lastSubtask state = lastIndex state >>= setIndex state + +lastIndex :: State -> Maybe Int +lastIndex state = (+ (-1)) . countSubtasks <$> getCurrentTask state + +setIndex :: State -> Int -> Maybe State +setIndex state i = do + lst <- lastIndex state + m <- getCurrentMode state + let newIndex + | i > lst = lst + | i < 0 = 0 + | otherwise = i + return $ state & mode .~ Modal (Detail (DetailItem newIndex) m) diff --git a/src/Events/State/Types.hs b/src/Events/State/Types.hs new file mode 100644 --- /dev/null +++ b/src/Events/State/Types.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module Events.State.Types where + +import ClassyPrelude + +import Control.Lens (makeLenses) + +import Data.Taskell.Lists (Lists) + +import qualified Events.State.Types.Mode as M (Mode) + +type Pointer = (Int, Int) + +data State = State + { _mode :: M.Mode + , _lists :: Lists + , _history :: [(Pointer, Lists)] + , _current :: Pointer + , _path :: FilePath + , _io :: Maybe Lists + } deriving (Eq, Show) + +-- create lenses +$(makeLenses ''State) + +type Stateful = State -> Maybe State diff --git a/src/Events/State/Types/Mode.hs b/src/Events/State/Types/Mode.hs new file mode 100644 --- /dev/null +++ b/src/Events/State/Types/Mode.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.State.Types.Mode where + +import ClassyPrelude + +import UI.Field (Field) + +data DetailMode + = DetailNormal + | DetailInsert Field + deriving (Eq, Show) + +data DetailItem + = DetailItem Int + | DetailDescription + | DetailDate + deriving (Eq, Show) + +data ModalType + = Help + | MoveTo + | Detail DetailItem + DetailMode + deriving (Eq, Show) + +data InsertType + = ITask + | IList + deriving (Eq, Show) + +data InsertMode + = IEdit + | ICreate + deriving (Eq, Show) + +data Mode + = Normal + | Insert InsertType + InsertMode + Field + | Modal ModalType + | Search Bool + Field + | Shutdown + deriving (Eq, Show) diff --git a/src/IO/Config.hs b/src/IO/Config.hs new file mode 100644 --- /dev/null +++ b/src/IO/Config.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module IO.Config where + +import ClassyPrelude + +import qualified Data.Text.IO as T (readFile) +import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory) + +import Brick (AttrMap) +import Brick.Themes (loadCustomizations, themeToAttrMap) +import Data.FileEmbed (embedFile) +import Data.Ini.Config + +import UI.Theme (defaultTheme) + +import qualified IO.Config.General as General +import qualified IO.Config.GitHub as GitHub +import qualified IO.Config.Layout as Layout +import qualified IO.Config.Markdown as Markdown +import qualified IO.Config.Trello as Trello + +data Config = Config + { general :: General.Config + , layout :: Layout.Config + , markdown :: Markdown.Config + , trello :: Trello.Config + , github :: GitHub.Config + } + +defaultConfig :: Config +defaultConfig = + Config + { general = General.defaultConfig + , layout = Layout.defaultConfig + , markdown = Markdown.defaultConfig + , trello = Trello.defaultConfig + , github = GitHub.defaultConfig + } + +getDir :: IO FilePath +getDir = (++ "/.taskell") <$> getHomeDirectory + +getThemePath :: IO FilePath +getThemePath = (++ "/theme.ini") <$> getDir + +getConfigPath :: IO FilePath +getConfigPath = (++ "/config.ini") <$> getDir + +setup :: IO Config +setup = do + getDir >>= createDirectoryIfMissing True + createConfig + createTheme + 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 + +configParser :: IniParser Config +configParser = do + generalCf <- General.parser + layoutCf <- Layout.parser + markdownCf <- Markdown.parser + trelloCf <- Trello.parser + githubCf <- GitHub.parser + return + Config + { general = generalCf + , layout = layoutCf + , markdown = markdownCf + , trello = trelloCf + , github = githubCf + } + +getConfig :: IO Config +getConfig = do + content <- getConfigPath >>= T.readFile + let config = parseIniFile content configParser + case config of + Right c -> return c + Left s -> putStrLn (pack $ "config.ini: " ++ s) >> return defaultConfig + +-- generate theme +generateAttrMap :: IO AttrMap +generateAttrMap = do + path <- getThemePath + customizedTheme <- loadCustomizations path defaultTheme + case customizedTheme of + Right theme -> return $ themeToAttrMap theme + Left s -> do + putStrLn (pack $ "theme.ini: " ++ s) + return $ themeToAttrMap defaultTheme diff --git a/src/IO/Config/General.hs b/src/IO/Config/General.hs new file mode 100644 --- /dev/null +++ b/src/IO/Config/General.hs @@ -0,0 +1,23 @@ +module IO.Config.General where + +import ClassyPrelude + +import Data.Ini.Config + +import IO.Config.Parser (noEmpty) + +data Config = Config + { filename :: FilePath + } + +defaultConfig :: Config +defaultConfig = Config {filename = "taskell.md"} + +parser :: IniParser Config +parser = + fromMaybe defaultConfig <$> + sectionMb + "general" + (do filenameCf <- + maybe (filename defaultConfig) unpack . (noEmpty =<<) <$> fieldMb "filename" + return Config {filename = filenameCf}) diff --git a/src/IO/Config/GitHub.hs b/src/IO/Config/GitHub.hs new file mode 100644 --- /dev/null +++ b/src/IO/Config/GitHub.hs @@ -0,0 +1,22 @@ +module IO.Config.GitHub where + +import ClassyPrelude + +import Data.Ini.Config + +import IO.HTTP.GitHub (GitHubToken) + +data Config = Config + { token :: Maybe GitHubToken + } + +defaultConfig :: Config +defaultConfig = Config {token = Nothing} + +parser :: IniParser Config +parser = + fromMaybe defaultConfig <$> + sectionMb + "github" + (do tokenCf <- fieldMb "token" + return Config {token = tokenCf}) diff --git a/src/IO/Config/Layout.hs b/src/IO/Config/Layout.hs new file mode 100644 --- /dev/null +++ b/src/IO/Config/Layout.hs @@ -0,0 +1,35 @@ +module IO.Config.Layout where + +import ClassyPrelude + +import Data.Ini.Config + +import IO.Config.Parser (noEmpty, parseText) + +data Config = Config + { columnWidth :: Int + , columnPadding :: Int + , descriptionIndicator :: Text + } + +defaultConfig :: Config +defaultConfig = Config {columnWidth = 30, columnPadding = 3, descriptionIndicator = "≡"} + +parser :: IniParser Config +parser = + fromMaybe defaultConfig <$> + sectionMb + "layout" + (do columnWidthCf <- + fromMaybe (columnWidth defaultConfig) <$> fieldMbOf "column_width" number + columnPaddingCf <- + fromMaybe (columnPadding defaultConfig) <$> fieldMbOf "column_padding" number + descriptionIndicatorCf <- + fromMaybe (descriptionIndicator defaultConfig) . (noEmpty . parseText =<<) <$> + fieldMb "description_indicator" + return + Config + { columnWidth = columnWidthCf + , columnPadding = columnPaddingCf + , descriptionIndicator = descriptionIndicatorCf + }) diff --git a/src/IO/Config/Markdown.hs b/src/IO/Config/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/IO/Config/Markdown.hs @@ -0,0 +1,52 @@ +module IO.Config.Markdown where + +import ClassyPrelude + +import Data.Ini.Config + +import IO.Config.Parser (noEmpty, parseText) + +data Config = Config + { titleOutput :: Text + , taskOutput :: Text + , descriptionOutput :: Text + , dueOutput :: Text + , subtaskOutput :: Text + } + +defaultConfig :: Config +defaultConfig = + Config + { titleOutput = "##" + , taskOutput = "-" + , descriptionOutput = " >" + , dueOutput = " @" + , subtaskOutput = " *" + } + +parser :: IniParser Config +parser = + fromMaybe defaultConfig <$> + sectionMb + "markdown" + (do titleOutputCf <- + fromMaybe (titleOutput defaultConfig) . (noEmpty . parseText =<<) <$> + fieldMb "title" + taskOutputCf <- + fromMaybe (taskOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "task" + descriptionOutputCf <- + fromMaybe (descriptionOutput defaultConfig) . (noEmpty . parseText =<<) <$> + fieldMb "summary" + dueOutputCf <- + fromMaybe (dueOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "due" + subtaskOutputCf <- + fromMaybe (subtaskOutput defaultConfig) . (noEmpty . parseText =<<) <$> + fieldMb "subtask" + return + Config + { titleOutput = titleOutputCf + , taskOutput = taskOutputCf + , descriptionOutput = descriptionOutputCf + , dueOutput = dueOutputCf + , subtaskOutput = subtaskOutputCf + }) diff --git a/src/IO/Config/Parser.hs b/src/IO/Config/Parser.hs new file mode 100644 --- /dev/null +++ b/src/IO/Config/Parser.hs @@ -0,0 +1,12 @@ +module IO.Config.Parser where + +import ClassyPrelude + +import Data.Text as T (dropAround, strip) + +noEmpty :: Text -> Maybe Text +noEmpty "" = Nothing +noEmpty txt = Just txt + +parseText :: Text -> Text +parseText = dropAround (== '"') . strip diff --git a/src/IO/Config/Trello.hs b/src/IO/Config/Trello.hs new file mode 100644 --- /dev/null +++ b/src/IO/Config/Trello.hs @@ -0,0 +1,22 @@ +module IO.Config.Trello where + +import ClassyPrelude + +import Data.Ini.Config + +import IO.HTTP.Trello (TrelloToken) + +data Config = Config + { token :: Maybe TrelloToken + } + +defaultConfig :: Config +defaultConfig = Config {token = Nothing} + +parser :: IniParser Config +parser = + fromMaybe defaultConfig <$> + sectionMb + "trello" + (do tokenCf <- fieldMb "token" + return Config {token = tokenCf}) diff --git a/src/IO/HTTP/Aeson.hs b/src/IO/HTTP/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/IO/HTTP/Aeson.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module IO.HTTP.Aeson where + +import ClassyPrelude + +import Data.Aeson (defaultOptions, fieldLabelModifier) +import qualified Data.Aeson.TH as TH (deriveFromJSON) +import Language.Haskell.TH (Dec, Name, Q) + +import Data.FileEmbed (embedFile) + +deriveFromJSON :: Name -> Q [Dec] +deriveFromJSON = TH.deriveFromJSON defaultOptions {fieldLabelModifier = drop 1} + +parseError :: String -> Text +parseError err = decodeUtf8 $(embedFile "templates/api-error.txt") ++ "\n\n" ++ pack err diff --git a/src/IO/HTTP/GitHub.hs b/src/IO/HTTP/GitHub.hs new file mode 100644 --- /dev/null +++ b/src/IO/HTTP/GitHub.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module IO.HTTP.GitHub + ( GitHubToken + , GitHubIdentifier + , getNextLink + , getLists + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) +import Data.Either (lefts, rights) +import Data.Sequence (mapWithIndex, (!?)) +import Data.Text (splitOn, strip) + +import Data.Aeson +import UI.CLI (prompt) + +import Network.HTTP.Client (requestHeaders) +import Network.HTTP.Simple (getResponseBody, getResponseHeader, getResponseStatusCode, httpBS, + parseRequest) +import Network.HTTP.Types.Header (HeaderName) + +import IO.HTTP.Aeson (parseError) +import IO.HTTP.GitHub.Card (Card) +import IO.HTTP.GitHub.Column (Column, cardsURL, columnToList) +import IO.HTTP.GitHub.Project (Project, columnsURL, name) + +import Data.Taskell.List (List) +import Data.Taskell.Lists (Lists) + +type GitHubToken = Text + +type GitHubIdentifier = Text + +type ReaderGitHubToken a = ReaderT GitHubToken IO a + +concatEithers :: [Either String [a]] -> Either String [a] +concatEithers vals = + if null errors + then Right $ concat (rights vals) + else Left $ unlines errors + where + errors = lefts vals + +root :: Text +root = "https://api.github.com/" + +headers :: ReaderGitHubToken [(HeaderName, ByteString)] +headers = do + token <- ask + return + [ ("User-Agent", "smallhadroncollider/taskell") + , ("Accept", "application/vnd.github.inertia-preview+json") + , ("Authorization", encodeUtf8 ("token " ++ token)) + ] + +getNextLink :: [ByteString] -> Maybe Text +getNextLink bs = do + lnks <- splitOn "," . decodeUtf8 <$> headMay bs + let rel = "rel=\"next\"" + next <- find (isSuffixOf rel) lnks + stripPrefix "<" =<< stripSuffix (">; " ++ rel) (strip next) + +fetch' :: [ByteString] -> Text -> ReaderGitHubToken (Int, [ByteString]) +fetch' bs url = do + initialRequest <- lift $ parseRequest (unpack url) + rHeaders <- headers + let request = initialRequest {requestHeaders = rHeaders} + response <- lift $ httpBS request + let responses = bs ++ [getResponseBody response] + case getNextLink (getResponseHeader "Link" response) of + Nothing -> return (getResponseStatusCode response, responses) + Just lnk -> fetch' responses lnk + +fetch :: Text -> ReaderGitHubToken (Int, [ByteString]) +fetch = fetch' [] + +getCards :: Text -> ReaderGitHubToken (Either Text [Card]) +getCards url = do + (status, body) <- fetch url + return $ + case status of + 200 -> + case concatEithers (eitherDecodeStrict <$> body) of + Right cards -> Right cards + Left err -> Left (parseError err) + 429 -> Left "Too many cards" + _ -> Left $ tshow status ++ " error while fetching " ++ url + +addCard :: Column -> ReaderGitHubToken (Either Text List) +addCard column = do + cards <- getCards $ column ^. cardsURL + return $ columnToList column <$> cards + +addCards :: [Column] -> ReaderGitHubToken (Either Text Lists) +addCards columns = do + cols <- sequence (addCard <$> columns) + return $ fromList <$> sequence cols + +getColumns :: Text -> ReaderGitHubToken (Either Text Lists) +getColumns url = do + putStrLn "Fetching project from GitHub..." + (status, body) <- fetch url + case status of + 200 -> + case concatEithers (eitherDecodeStrict <$> body) of + Right columns -> addCards columns + Left err -> return $ Left (parseError err) + 404 -> return . Left $ "Could not find GitHub project ." + 401 -> return . Left $ "You do not have permission to view GitHub project " ++ url + _ -> return . Left $ tshow status ++ " error. Cannot fetch columns from GitHub." + +printProjects :: Seq Project -> Text +printProjects projects = unlines $ toList display + where + names = (^. name) <$> projects + line i nm = concat ["[", tshow (i + 1), "] ", nm] + display = line `mapWithIndex` names + +chooseProject :: [Project] -> ReaderGitHubToken (Either Text Lists) +chooseProject projects = do + let projects' = fromList projects + putStrLn $ printProjects projects' + chosen <- lift $ prompt "Import project" + let project = (projects' !?) =<< (-) 1 <$> readMay chosen + case project of + Nothing -> return $ Left "Invalid project selected" + Just proj -> getColumns (proj ^. columnsURL) + +getLists :: GitHubIdentifier -> ReaderGitHubToken (Either Text Lists) +getLists identifier = do + putStrLn "Fetching project list from GitHub...\n" + let url = concat [root, identifier, "/projects"] + (status, body) <- fetch url + case status of + 200 -> + case concatEithers (eitherDecodeStrict <$> body) of + Right projects -> + if null projects + then return . Left $ concat ["\nNo projects found for ", identifier, "\n"] + else chooseProject projects + Left err -> return $ Left (parseError err) + 404 -> + return . Left $ + "Could not find GitHub org/repo. For organisation make sure you use 'orgs/' and for repos use 'repos//'" + 401 -> + return . Left $ + "You do not have permission to view the GitHub projects for " ++ identifier + _ -> return . Left $ tshow status ++ " error. Cannot fetch projects from GitHub." diff --git a/src/IO/HTTP/GitHub/Card.hs b/src/IO/HTTP/GitHub/Card.hs new file mode 100644 --- /dev/null +++ b/src/IO/HTTP/GitHub/Card.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module IO.HTTP.GitHub.Card + ( Card + , cardToTask + ) where + +import ClassyPrelude + +import Control.Lens (makeLenses, (^.)) + +import Data.Text (replace) + +import qualified Data.Taskell.Task as T (Task, new) +import IO.HTTP.Aeson (deriveFromJSON) + +data Card = Card + { _note :: Text + } deriving (Eq, Show) + +-- strip underscores from field labels +$(deriveFromJSON ''Card) + +-- create lenses +$(makeLenses ''Card) + +-- operations +cardToTask :: Card -> T.Task +cardToTask card = T.new $ replace "\r" "" $ replace "\n" " " (card ^. note) diff --git a/src/IO/HTTP/GitHub/Column.hs b/src/IO/HTTP/GitHub/Column.hs new file mode 100644 --- /dev/null +++ b/src/IO/HTTP/GitHub/Column.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module IO.HTTP.GitHub.Column + ( Column + , columnToList + , cardsURL + ) where + +import ClassyPrelude + +import Control.Lens (Lens', makeLenses, (^.)) + +import IO.HTTP.Aeson (deriveFromJSON) +import IO.HTTP.GitHub.Card (Card, cardToTask) + +import qualified Data.Taskell.List as L (List, create) + +data Column = Column + { _name :: Text + , _cards_url :: Text + } deriving (Eq, Show) + +-- create Aeson code +$(deriveFromJSON ''Column) + +-- create lenses +$(makeLenses ''Column) + +-- operations +cardsURL :: Lens' Column Text +cardsURL = cards_url + +columnToList :: Column -> [Card] -> L.List +columnToList ls cards = L.create (ls ^. name) (fromList $ cardToTask <$> cards) diff --git a/src/IO/HTTP/GitHub/Project.hs b/src/IO/HTTP/GitHub/Project.hs new file mode 100644 --- /dev/null +++ b/src/IO/HTTP/GitHub/Project.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module IO.HTTP.GitHub.Project + ( Project + , columnsURL + , name + ) where + +import ClassyPrelude + +import Control.Lens (Lens', makeLenses) + +import IO.HTTP.Aeson (deriveFromJSON) + +data Project = Project + { _name :: Text + , _columns_url :: Text + } deriving (Eq, Show) + +-- create Aeson code +$(deriveFromJSON ''Project) + +-- create lenses +$(makeLenses ''Project) + +-- operations +columnsURL :: Lens' Project Text +columnsURL = columns_url diff --git a/src/IO/HTTP/Trello.hs b/src/IO/HTTP/Trello.hs new file mode 100644 --- /dev/null +++ b/src/IO/HTTP/Trello.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module IO.HTTP.Trello + ( TrelloToken + , TrelloBoardID + , getLists + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Data.Aeson +import Network.HTTP.Simple (getResponseBody, getResponseStatusCode, httpBS, parseRequest) + +import IO.HTTP.Aeson (parseError) +import IO.HTTP.Trello.Card (Card, idChecklists, setChecklists) +import IO.HTTP.Trello.ChecklistItem (ChecklistItem, checkItems) +import IO.HTTP.Trello.List (List, cards, listToList, setCards) + +import Data.Taskell.Lists (Lists) +import Data.Time.LocalTime (TimeZone, getCurrentTimeZone) + +type ReaderTrelloToken a = ReaderT TrelloToken IO a + +type TrelloToken = Text + +type TrelloBoardID = Text + +type TrelloChecklistID = Text + +key :: Text +key = "80dbcf6f88f62cc5639774e13342c20b" + +root :: Text +root = "https://api.trello.com/1/" + +fullURL :: Text -> ReaderTrelloToken String +fullURL uri = do + token <- ask + return . unpack $ concat [root, uri, "&key=", key, "&token=", token] + +boardURL :: TrelloBoardID -> ReaderTrelloToken String +boardURL board = + fullURL $ + concat + [ "boards/" + , board + , "/lists" + , "?cards=open" + , "&card_fields=name,due,desc,idChecklists" + , "&fields=name,cards" + ] + +checklistURL :: TrelloChecklistID -> ReaderTrelloToken String +checklistURL checklist = + fullURL $ concat ["checklists/", checklist, "?fields=id", "&checkItem_fields=name,state"] + +trelloListsToLists :: TimeZone -> [List] -> Lists +trelloListsToLists tz ls = fromList $ listToList tz <$> ls + +fetch :: String -> IO (Int, ByteString) +fetch url = do + request <- parseRequest url + response <- httpBS request + return (getResponseStatusCode response, getResponseBody response) + +getChecklist :: TrelloChecklistID -> ReaderTrelloToken (Either Text [ChecklistItem]) +getChecklist checklist = do + url <- checklistURL checklist + (status, body) <- lift $ fetch url + return $ + case status of + 200 -> + case (^. checkItems) <$> eitherDecodeStrict body of + Right ls -> Right ls + Left err -> Left $ parseError err + 429 -> Left "Too many checklists" + _ -> Left $ tshow status ++ " error while fetching checklist " ++ checklist + +updateCard :: Card -> ReaderTrelloToken (Either Text Card) +updateCard card = (setChecklists card . concat <$>) . sequence <$> checklists + where + checklists = sequence $ getChecklist <$> (card ^. idChecklists) + +updateList :: List -> ReaderTrelloToken (Either Text List) +updateList l = (setCards l <$>) . sequence <$> sequence (updateCard <$> (l ^. cards)) + +getChecklists :: [List] -> ReaderTrelloToken (Either Text [List]) +getChecklists ls = sequence <$> sequence (updateList <$> ls) + +getLists :: TrelloBoardID -> ReaderTrelloToken (Either Text Lists) +getLists board = do + putStrLn "Fetching from Trello..." + url <- boardURL board + (status, body) <- lift $ fetch url + timezone <- lift getCurrentTimeZone + case status of + 200 -> + case eitherDecodeStrict body of + Right raw -> fmap (trelloListsToLists timezone) <$> getChecklists raw + Left err -> return . Left $ parseError err + 404 -> + return . Left $ + "Could not find Trello board " ++ board ++ ". Make sure the ID is correct" + 401 -> return . Left $ "You do not have permission to view Trello board " ++ board + _ -> return . Left $ tshow status ++ " error. Cannot fetch from Trello." diff --git a/src/IO/HTTP/Trello/Card.hs b/src/IO/HTTP/Trello/Card.hs new file mode 100644 --- /dev/null +++ b/src/IO/HTTP/Trello/Card.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module IO.HTTP.Trello.Card + ( Card + , idChecklists + , cardToTask + , setChecklists + ) where + +import ClassyPrelude + +import Control.Lens (makeLenses, (&), (.~), (^.)) + +import Data.Taskell.Date (utcToLocalDay) +import qualified Data.Taskell.Task as T (Task, due, new, setDescription, subtasks) +import Data.Time.Format (iso8601DateFormat, parseTimeM) +import Data.Time.LocalTime (TimeZone) + +import IO.HTTP.Aeson (deriveFromJSON) +import IO.HTTP.Trello.ChecklistItem (ChecklistItem, checklistItemToSubTask) + +data Card = Card + { _name :: Text + , _desc :: Text + , _due :: Maybe Text + , _idChecklists :: [Text] + , _checklists :: Maybe [ChecklistItem] + } deriving (Eq, Show) + +-- strip underscores from field labels +$(deriveFromJSON ''Card) + +-- create lenses +$(makeLenses ''Card) + +-- operations +textToTime :: TimeZone -> Text -> Maybe Day +textToTime tz text = utcToLocalDay tz <$> utc + where + utc = parseTimeM False defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S%Q%Z")) $ unpack text + +cardToTask :: TimeZone -> Card -> T.Task +cardToTask tz card = + task & T.due .~ textToTime tz (fromMaybe "" (card ^. due)) & T.subtasks .~ + fromList (checklistItemToSubTask <$> fromMaybe [] (card ^. checklists)) + where + task = T.setDescription (card ^. desc) $ T.new (card ^. name) + +setChecklists :: Card -> [ChecklistItem] -> Card +setChecklists card cls = card & checklists .~ Just cls diff --git a/src/IO/HTTP/Trello/ChecklistItem.hs b/src/IO/HTTP/Trello/ChecklistItem.hs new file mode 100644 --- /dev/null +++ b/src/IO/HTTP/Trello/ChecklistItem.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module IO.HTTP.Trello.ChecklistItem + ( ChecklistItem + , checklistItemToSubTask + , checkItems + ) where + +import ClassyPrelude + +import Control.Lens (makeLenses, (^.)) +import qualified Data.Taskell.Subtask as ST (Subtask, new) +import IO.HTTP.Aeson (deriveFromJSON) + +data ChecklistItem = ChecklistItem + { _name :: Text + , _state :: Text + } deriving (Eq, Show) + +-- create Aeson code +$(deriveFromJSON ''ChecklistItem) + +-- create lenses +$(makeLenses ''ChecklistItem) + +-- operations +checklistItemToSubTask :: ChecklistItem -> ST.Subtask +checklistItemToSubTask cl = ST.new (cl ^. name) ((cl ^. state) == "complete") + +-- check list wrapper +newtype ChecklistWrapper = ChecklistWrapper + { _checkItems :: [ChecklistItem] + } deriving (Eq, Show) + +-- create Aeson code +$(deriveFromJSON ''ChecklistWrapper) + +-- create lenses +$(makeLenses ''ChecklistWrapper) diff --git a/src/IO/HTTP/Trello/List.hs b/src/IO/HTTP/Trello/List.hs new file mode 100644 --- /dev/null +++ b/src/IO/HTTP/Trello/List.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module IO.HTTP.Trello.List + ( List + , cards + , setCards + , listToList + ) where + +import ClassyPrelude + +import Control.Lens (makeLenses, (&), (.~), (^.)) + +import IO.HTTP.Aeson (deriveFromJSON) +import IO.HTTP.Trello.Card (Card, cardToTask) + +import qualified Data.Taskell.List as L (List, create) +import Data.Time.LocalTime (TimeZone) + +data List = List + { _name :: Text + , _cards :: [Card] + } deriving (Eq, Show) + +-- create Aeson code +$(deriveFromJSON ''List) + +-- create lenses +$(makeLenses ''List) + +-- operations +setCards :: List -> [Card] -> List +setCards list cs = list & cards .~ cs + +listToList :: TimeZone -> List -> L.List +listToList tz ls = L.create (ls ^. name) (fromList $ cardToTask tz <$> (ls ^. cards)) diff --git a/src/IO/Markdown.hs b/src/IO/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/IO/Markdown.hs @@ -0,0 +1,6 @@ +module IO.Markdown + ( parse + , stringify + ) where + +import IO.Markdown.Internal diff --git a/src/IO/Markdown/Internal.hs b/src/IO/Markdown/Internal.hs new file mode 100644 --- /dev/null +++ b/src/IO/Markdown/Internal.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module IO.Markdown.Internal where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Data.Sequence (adjust') +import Data.Text as T (dropAround, splitOn, strip) +import Data.Text.Encoding (decodeUtf8With) + +import Data.Taskell.Date (dayToOutput) +import Data.Taskell.List (List, count, tasks, title, updateFn) +import Data.Taskell.Lists (Lists, appendToLast, newList) +import qualified Data.Taskell.Subtask as ST (Subtask, complete, name, new) +import qualified Data.Taskell.Task as T (Task, addSubtask, appendDescription, description, due, + name, new, setDue, subtasks) + +import qualified IO.Config as C (Config, markdown) +import IO.Config.Markdown (Config, descriptionOutput, dueOutput, subtaskOutput, + taskOutput, titleOutput) + +-- parse code +trimTilde :: Text -> Text +trimTilde = strip . T.dropAround (== '~') + +addSubItem :: Text -> Lists -> Lists +addSubItem t ls = adjust' updateList i ls + where + i = length ls - 1 + st + | "[ ] " `isPrefixOf` t = ST.new (drop 4 t) False + | "[x] " `isPrefixOf` t = ST.new (drop 4 t) True + | "~" `isPrefixOf` t = ST.new (trimTilde t) True + | otherwise = ST.new t False + updateList l = updateFn j (T.addSubtask st) l + where + j = count l - 1 + +addDescription :: Text -> Lists -> Lists +addDescription t ls = adjust' updateList i ls + where + i = length ls - 1 + updateList l = updateFn j (T.appendDescription t) l + where + j = count l - 1 + +addDue :: Text -> Lists -> Lists +addDue t ls = adjust' updateList i ls + where + i = length ls - 1 + updateList l = updateFn j (T.setDue t) l + where + j = count l - 1 + +prefix :: Config -> Text -> (Config -> Text) -> (Text -> Lists -> Lists) -> Maybe (Lists -> Lists) +prefix config str get set + | pre `isPrefixOf` str = Just $ set (drop (length pre) str) + | otherwise = Nothing + where + pre = get config `snoc` ' ' + +matches :: [(Config -> Text, Text -> Lists -> Lists)] +matches = + [ (titleOutput, newList) + , (taskOutput, appendToLast . T.new) + , (descriptionOutput, addDescription) + , (dueOutput, addDue) + , (subtaskOutput, addSubItem) + ] + +start :: Config -> (Lists, [Int]) -> (Text, Int) -> (Lists, [Int]) +start config (current, errs) (text, line) = + case find isJust $ uncurry (prefix config text) <$> matches of + Just (Just set) -> (set current, errs) + _ -> + if not (null (strip text)) + then (current, errs ++ [line]) + else (current, errs) + +decodeError :: String -> Maybe Word8 -> Maybe Char +decodeError _ _ = Just '\65533' + +parse :: C.Config -> ByteString -> Either Text Lists +parse config s = do + let lns = lines $ decodeUtf8With decodeError s + let fn = start (C.markdown config) + let acc = (empty, []) + let (lists, errs) = foldl' fn acc $ zip lns [1 ..] + if null errs + then Right lists + else Left $ "could not parse line(s) " ++ intercalate ", " (tshow <$> errs) + +-- stringify code +subtaskStringify :: Config -> Text -> ST.Subtask -> Text +subtaskStringify config t st = + foldl' (++) t [subtaskOutput config, " ", pre, " ", st ^. ST.name, "\n"] + where + pre = + if st ^. ST.complete + then "[x]" + else "[ ]" + +descriptionStringify :: Config -> Text -> Text +descriptionStringify config desc = concat $ add <$> splitOn "\n" desc + where + add d = concat [descriptionOutput config, " ", d, "\n"] + +dueStringify :: Config -> Day -> Text +dueStringify config day = concat [dueOutput config, " ", dayToOutput day, "\n"] + +nameStringify :: Config -> Text -> Text +nameStringify config desc = concat [taskOutput config, " ", desc, "\n"] + +taskStringify :: Config -> Text -> T.Task -> Text +taskStringify config s t = + foldl' + (++) + s + [ nameStringify config (t ^. T.name) + , maybe "" (dueStringify config) (t ^. T.due) + , maybe "" (descriptionStringify config) (t ^. T.description) + , foldl' (subtaskStringify config) "" (t ^. T.subtasks) + ] + +listStringify :: Config -> Text -> List -> Text +listStringify config text list = + foldl' + (++) + text + [ if null text + then "" + else "\n" + , titleOutput config + , " " + , list ^. title + , "\n\n" + , foldl' (taskStringify config) "" (list ^. tasks) + ] + +stringify :: C.Config -> Lists -> ByteString +stringify config ls = encodeUtf8 $ foldl' (listStringify (C.markdown config)) "" ls diff --git a/src/IO/Taskell.hs b/src/IO/Taskell.hs new file mode 100644 --- /dev/null +++ b/src/IO/Taskell.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module IO.Taskell where + +import ClassyPrelude + +import Data.FileEmbed (embedFile) +import System.Directory (doesFileExist, getCurrentDirectory) + +import Config (usage, version) +import Data.Taskell.Lists (Lists, analyse, initial) + +import IO.Config (Config, general, github, trello) +import IO.Config.General (filename) +import qualified IO.Config.GitHub as GitHub (token) +import qualified IO.Config.Trello as Trello (token) + +import IO.Markdown (parse, stringify) + +import qualified IO.HTTP.GitHub as GitHub (GitHubIdentifier, getLists) +import qualified IO.HTTP.Trello as Trello (TrelloBoardID, getLists) + +import UI.CLI (promptYN) + +type ReaderConfig a = ReaderT Config IO a + +data Next + = Output Text + | Load FilePath + Lists + | Exit + +parseArgs :: [Text] -> ReaderConfig Next +parseArgs ["-v"] = return $ Output version +parseArgs ["-h"] = return $ Output usage +parseArgs ["-t", boardID, file] = loadTrello boardID file +parseArgs ["-g", identifier, file] = loadGitHub identifier file +parseArgs ["-i", file] = fileInfo file +parseArgs [file] = loadFile file +parseArgs [] = (pack . filename . general <$> ask) >>= loadFile +parseArgs _ = return $ Output (unlines ["Invalid options", "", usage]) + +load :: ReaderConfig Next +load = getArgs >>= parseArgs + +loadFile :: Text -> ReaderConfig Next +loadFile filepath = do + mPath <- exists filepath + case mPath of + Nothing -> return Exit + Just path -> do + content <- readData path + return $ + case content of + Right lists -> Load path lists + Left err -> Output $ pack path ++ ": " ++ err + +loadRemote :: (token -> FilePath -> ReaderConfig Next) -> token -> Text -> ReaderConfig Next +loadRemote createFn identifier filepath = do + let path = unpack filepath + exists' <- fileExists path + if exists' + then return $ Output (filepath ++ " already exists") + else createFn identifier path + +loadTrello :: Trello.TrelloBoardID -> Text -> ReaderConfig Next +loadTrello = loadRemote createTrello + +loadGitHub :: GitHub.GitHubIdentifier -> Text -> ReaderConfig Next +loadGitHub = loadRemote createGitHub + +fileInfo :: Text -> ReaderConfig Next +fileInfo filepath = do + let path = unpack filepath + exists' <- fileExists path + if exists' + then do + content <- readData path + return $ + case content of + Right lists -> Output $ analyse filepath lists + Left err -> Output $ pack path ++ ": " ++ err + else return Exit + +createRemote :: + (Config -> Maybe token) + -> Text + -> (token -> ReaderT token IO (Either Text Lists)) + -> token + -> FilePath + -> ReaderConfig Next +createRemote tokenFn missingToken getFn identifier path = do + config <- ask + let maybeToken = tokenFn config + case maybeToken of + Nothing -> return $ Output missingToken + Just token -> do + lists <- lift $ runReaderT (getFn identifier) token + case lists of + Left txt -> return $ Output txt + Right ls -> do + create <- promptCreate path + if create + then do + lift $ writeData config ls path + return $ Load path ls + else return Exit + +createTrello :: Trello.TrelloBoardID -> FilePath -> ReaderConfig Next +createTrello = + createRemote + (Trello.token . trello) + (decodeUtf8 $(embedFile "templates/trello-token.txt")) + Trello.getLists + +createGitHub :: GitHub.GitHubIdentifier -> FilePath -> ReaderConfig Next +createGitHub = + createRemote + (GitHub.token . github) + (decodeUtf8 $(embedFile "templates/github-token.txt")) + GitHub.getLists + +exists :: Text -> ReaderConfig (Maybe FilePath) +exists filepath = do + let path = unpack filepath + exists' <- fileExists path + if exists' + then return $ Just path + else do + create <- promptCreate path + if create + then do + createPath path + return $ Just path + else return Nothing + +fileExists :: FilePath -> ReaderConfig Bool +fileExists path = lift $ doesFileExist path + +promptCreate :: FilePath -> ReaderConfig Bool +promptCreate path = do + cwd <- lift $ pack <$> getCurrentDirectory + lift $ promptYN $ concat ["Create ", cwd, "/", pack path, "?"] + +-- creates taskell file +createPath :: FilePath -> ReaderConfig () +createPath path = do + config <- ask + lift (writeData config initial path) + +-- writes Tasks to json file +writeData :: Config -> Lists -> FilePath -> IO () +writeData config tasks path = void (writeFile path $ stringify config tasks) + +-- reads json file +readData :: FilePath -> ReaderConfig (Either Text Lists) +readData path = do + config <- ask + content <- readFile path + return $ parse config content diff --git a/src/UI/CLI.hs b/src/UI/CLI.hs new file mode 100644 --- /dev/null +++ b/src/UI/CLI.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.CLI + ( prompt + , promptYN + ) where + +import ClassyPrelude +import Data.Text.IO (hPutStrLn) +import System.Exit (exitFailure) + +prompt :: Text -> IO Text +prompt s = do + putStr $ s ++ ": " + hFlush stdout -- prevents buffering + getLine + +promptYN :: Text -> IO Bool +promptYN s = (==) "y" <$> prompt (s ++ " (y/n)") + +exitWithErrorMessage :: Text -> IO () +exitWithErrorMessage str = hPutStrLn stderr str >> void exitFailure diff --git a/src/UI/Draw.hs b/src/UI/Draw.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Draw + ( draw + , chooseCursor + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Control.Monad.Reader (runReader) +import Data.Char (chr, ord) +import Data.Sequence (mapWithIndex) + +import Brick + +import Data.Taskell.Date (Day, dayToText, deadline) +import Data.Taskell.List (List, tasks, title) +import Data.Taskell.Lists (Lists) +import qualified Data.Taskell.Task as T (Task, countCompleteSubtasks, countSubtasks, + description, due, hasSubtasks, name) +import Events.State (normalise) +import Events.State.Types (Pointer, State, current, lists, mode) +import Events.State.Types.Mode (DetailMode (..), InsertType (..), ModalType (..), + Mode (..)) +import IO.Config.Layout (Config, columnPadding, columnWidth, descriptionIndicator) +import UI.Field (Field, field, textField, widgetFromMaybe) +import UI.Modal (showModal) +import UI.Theme +import UI.Types (ResourceName (..)) + +-- | Draw needs to know various pieces of information, so keep track of them in a record +data DrawState = DrawState + { dsLists :: Lists + , dsMode :: Mode + , dsLayout :: Config + , dsToday :: Day + , dsCurrent :: Pointer + , dsField :: Maybe Field + , dsEditingTitle :: Bool + } + +-- | Use a Reader to pass around DrawState +type ReaderDrawState = ReaderT DrawState Identity + +-- | Takes a task's 'due' property and renders a date with appropriate styling (e.g. red if overdue) +renderDate :: Maybe Day -> ReaderDrawState (Maybe (Widget ResourceName)) +renderDate dueDay = do + today <- dsToday <$> ask -- get the value of `today` from DrawState + let attr = withAttr . dlToAttr . deadline today <$> dueDay -- create a `Maybe (Widget -> Widget)` attribute function + widget = txt . dayToText today <$> dueDay -- get the formatted due date `Maybe Text` + return $ attr <*> widget + +-- | Renders the appropriate completed sub task count e.g. "[2/3]" +renderSubtaskCount :: T.Task -> Widget ResourceName +renderSubtaskCount task = + txt $ concat ["[", tshow $ T.countCompleteSubtasks task, "/", tshow $ T.countSubtasks task, "]"] + +-- | Renders the appropriate indicators: description, sub task count, and due date +indicators :: T.Task -> ReaderDrawState (Widget ResourceName) +indicators task = do + dateWidget <- renderDate (task ^. T.due) -- get the due date widget + descIndicator <- descriptionIndicator . dsLayout <$> ask + return . hBox $ + padRight (Pad 1) <$> + catMaybes + [ const (txt descIndicator) <$> task ^. T.description -- show the description indicator if one is set + , bool Nothing (Just (renderSubtaskCount task)) (T.hasSubtasks task) -- if it has subtasks, render the sub task count + , dateWidget + ] + +-- | Renders an individual task +renderTask :: Int -> Int -> T.Task -> ReaderDrawState (Widget ResourceName) +renderTask listIndex taskIndex task = do + eTitle <- dsEditingTitle <$> ask -- is the title being edited? (for visibility) + selected <- (== (listIndex, taskIndex)) . dsCurrent <$> ask -- is the current task selected? + 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) + widget = textField text + widget' = widgetFromMaybe widget taskField + return $ + cached name . + (if selected && not eTitle + then visible + else id) . + padBottom (Pad 1) . + (<=> withAttr disabledAttr after) . + withAttr + (if selected + then taskCurrentAttr + else taskAttr) $ + if selected && not eTitle + then widget' + else widget + +-- | Gets the relevant column prefix - number in normal mode, letter in moveTo +columnPrefix :: Int -> Int -> ReaderDrawState Text +columnPrefix selectedList i = do + m <- dsMode <$> ask + if moveTo m + then do + let col = chr (i + ord 'a') + return $ + if i /= selectedList && i >= 0 && i <= 26 + then singleton col ++ ". " + else "" + else do + let col = i + 1 + return $ + if col >= 1 && col <= 9 + then tshow col ++ ". " + else "" + +-- | Renders the title for a list +renderTitle :: Int -> List -> ReaderDrawState (Widget ResourceName) +renderTitle listIndex list = do + (selectedList, selectedTask) <- dsCurrent <$> ask + editing <- (selectedList == listIndex &&) . dsEditingTitle <$> ask + titleField <- dsField <$> ask + col <- txt <$> columnPrefix selectedList listIndex + let text = list ^. title + attr = + if selectedList == listIndex + then titleCurrentAttr + else titleAttr + widget = textField text + widget' = widgetFromMaybe widget titleField + title' = + padBottom (Pad 1) . withAttr attr . (col <+>) $ + if editing + then widget' + else widget + return $ + if editing || selectedList /= listIndex || selectedTask == 0 + then visible title' + else title' + +-- | Renders a list +renderList :: Int -> List -> ReaderDrawState (Widget ResourceName) +renderList listIndex list = do + layout <- dsLayout <$> ask + eTitle <- dsEditingTitle <$> ask + titleWidget <- renderTitle listIndex list + (currentList, _) <- dsCurrent <$> ask + taskWidgets <- sequence $ renderTask listIndex `mapWithIndex` (list ^. tasks) + let widget = + (if not eTitle + then cached (RNList listIndex) + else id) . + padLeftRight (columnPadding layout) . + hLimit (columnWidth layout) . + viewport (RNList listIndex) Vertical . vBox . (titleWidget :) $ + toList taskWidgets + return $ + if currentList == listIndex + then visible widget + else widget + +-- | Renders the search area +renderSearch :: Widget ResourceName -> ReaderDrawState (Widget ResourceName) +renderSearch mainWidget = do + m <- dsMode <$> ask + case m of + Search editing searchField -> do + colPad <- columnPadding . dsLayout <$> ask + let attr = + withAttr $ + if editing + then taskCurrentAttr + else taskAttr + let widget = attr . padTopBottom 1 . padLeftRight colPad $ txt "/" <+> field searchField + return $ mainWidget <=> widget + _ -> return mainWidget + +-- | Renders the main widget +main :: ReaderDrawState (Widget ResourceName) +main = do + ls <- dsLists <$> ask + listWidgets <- toList <$> sequence (renderList `mapWithIndex` ls) + let mainWidget = viewport RNLists Horizontal . padTopBottom 1 $ hBox listWidgets + renderSearch mainWidget + +getField :: Mode -> Maybe Field +getField (Insert _ _ f) = Just f +getField _ = Nothing + +editingTitle :: Mode -> Bool +editingTitle (Insert IList _ _) = True +editingTitle _ = False + +moveTo :: Mode -> Bool +moveTo (Modal MoveTo) = True +moveTo _ = False + +-- draw +draw :: Config -> Day -> State -> [Widget ResourceName] +draw layout today state = + showModal + normalisedState + today + [ runReader + main + DrawState + { dsLists = normalisedState ^. lists + , dsMode = stateMode + , dsLayout = layout + , dsToday = today + , dsField = getField stateMode + , dsCurrent = normalisedState ^. current + , dsEditingTitle = editingTitle stateMode + } + ] + where + normalisedState = normalise state + stateMode = state ^. mode + +-- cursors +chooseCursor :: State -> [CursorLocation ResourceName] -> Maybe (CursorLocation ResourceName) +chooseCursor state = + case normalise state ^. mode of + Insert {} -> showCursorNamed RNCursor + Search True _ -> showCursorNamed RNCursor + Modal (Detail _ (DetailInsert _)) -> showCursorNamed RNCursor + _ -> neverShowCursor state diff --git a/src/UI/Field.hs b/src/UI/Field.hs new file mode 100644 --- /dev/null +++ b/src/UI/Field.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Field where + +import ClassyPrelude + +import qualified Data.List as L (scanl1) +import qualified Data.Text as T (splitAt, takeEnd) + +import qualified Brick as B (Location (Location), Size (Fixed), Widget (Widget), + availWidth, getContext, render, showCursor, txt, + vBox) +import qualified Brick.Widgets.Core as B (textWidth) +import qualified Graphics.Vty.Input.Events as V (Event (..), Key (..)) + +import qualified UI.Types as UI (ResourceName (RNCursor)) + +data Field = Field + { _text :: Text + , _cursor :: Int + } deriving (Eq, Show) + +blankField :: Field +blankField = Field "" 0 + +event :: V.Event -> Field -> Field +event (V.EvKey (V.KChar '\t') _) f = f +event (V.EvPaste bs) f = insertText (decodeUtf8 bs) f +event (V.EvKey V.KBS _) f = backspace f +event (V.EvKey V.KLeft _) f = updateCursor (-1) f +event (V.EvKey V.KRight _) f = updateCursor 1 f +event (V.EvKey (V.KChar char) _) f = insertCharacter char f +event _ f = f + +updateCursor :: Int -> Field -> Field +updateCursor dir (Field text cursor) = Field text newCursor + where + next = cursor + dir + limit = length text + newCursor + | next <= 0 = 0 + | next > limit = limit + | otherwise = next + +backspace :: Field -> Field +backspace (Field text cursor) = + let (start, end) = T.splitAt cursor text + in case fromNullable start of + Nothing -> Field end cursor + Just start' -> Field (init start' ++ end) (cursor - 1) + +insertCharacter :: Char -> Field -> Field +insertCharacter char (Field text cursor) = Field newText newCursor + where + (start, end) = T.splitAt cursor text + newText = snoc start char ++ end + newCursor = cursor + 1 + +insertText :: Text -> Field -> Field +insertText insert (Field text cursor) = Field newText newCursor + where + (start, end) = T.splitAt cursor text + newText = concat [start, insert, end] + newCursor = cursor + length insert + +cursorPosition :: [Text] -> Int -> Int -> (Int, Int) +cursorPosition text width cursor = + if x == width + then (0, y + 1) + else (x, y) + where + scanned = L.scanl1 (+) $ length <$> text + below = takeWhile (< cursor) scanned + x = cursor - maybe 0 last (fromNullable below) + y = length below + +getText :: Field -> Text +getText (Field text _) = text + +textToField :: Text -> Field +textToField text = Field text (length text) + +field :: Field -> B.Widget UI.ResourceName +field (Field text cursor) = + B.Widget B.Fixed B.Fixed $ do + width <- B.availWidth <$> B.getContext + let (wrapped, offset) = wrap width text + location = cursorPosition wrapped width (cursor - offset) + B.render $ + if null text + then B.showCursor UI.RNCursor (B.Location (0, 0)) $ B.txt " " + else B.showCursor UI.RNCursor (B.Location location) . B.vBox $ B.txt <$> wrapped + +widgetFromMaybe :: B.Widget UI.ResourceName -> Maybe Field -> B.Widget UI.ResourceName +widgetFromMaybe _ (Just f) = field f +widgetFromMaybe w Nothing = w + +textField :: Text -> B.Widget UI.ResourceName +textField text = + B.Widget B.Fixed B.Fixed $ do + width <- B.availWidth <$> B.getContext + let (wrapped, _) = wrap width text + B.render $ + if null text + then B.txt "---" + else B.vBox $ B.txt <$> wrapped + +-- wrap +wrap :: Int -> Text -> ([Text], Int) +wrap width = foldl' (combine width) ([""], 0) . spl + +spl' :: [Text] -> Char -> [Text] +spl' ts c + | c == ' ' = ts ++ [" "] ++ [""] + | otherwise = + case fromNullable ts of + Just ts' -> init ts' ++ [snoc (last ts') c] + Nothing -> [singleton c] + +spl :: Text -> [Text] +spl = foldl' spl' [""] + +combine :: Int -> ([Text], Int) -> Text -> ([Text], Int) +combine width (acc, offset) s + | newline && s == " " = (acc, offset + 1) + | T.takeEnd 1 l == " " && s == " " = (acc, offset + 1) + | newline = (acc ++ [s], offset) + | otherwise = (append (l ++ s) acc, offset) + where + l = maybe "" last (fromNullable acc) + newline = B.textWidth l + B.textWidth s > width + +append :: Text -> [Text] -> [Text] +append s l = + case fromNullable l of + Just l' -> init l' ++ [s] + Nothing -> l ++ [s] diff --git a/src/UI/Modal.hs b/src/UI/Modal.hs new file mode 100644 --- /dev/null +++ b/src/UI/Modal.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module UI.Modal + ( showModal + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center + +import Data.Taskell.Date (Day) +import Events.State.Types (State, mode) +import Events.State.Types.Mode (ModalType (..), Mode (..)) +import UI.Field (textField) +import UI.Modal.Detail (detail) +import UI.Modal.Help (help) +import UI.Modal.MoveTo (moveTo) +import UI.Theme (titleAttr) +import UI.Types (ResourceName (..)) + +surround :: (Text, Widget ResourceName) -> Widget ResourceName +surround (title, widget) = + padTopBottom 1 . + centerLayer . + border . padTopBottom 1 . padLeftRight 4 . hLimit 50 . (t <=>) . viewport RNModal Vertical $ + widget + where + t = padBottom (Pad 1) . withAttr titleAttr $ textField title + +showModal :: State -> Day -> [Widget ResourceName] -> [Widget ResourceName] +showModal state today view = + case state ^. mode of + Modal Help -> surround help : view + Modal Detail {} -> surround (detail state today) : view + Modal MoveTo -> surround (moveTo state) : view + _ -> view diff --git a/src/UI/Modal/Detail.hs b/src/UI/Modal/Detail.hs new file mode 100644 --- /dev/null +++ b/src/UI/Modal/Detail.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Modal.Detail + ( detail + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Data.Sequence (mapWithIndex) + +import Brick + +import Data.Taskell.Date (Day, dayToOutput, deadline) +import qualified Data.Taskell.Subtask as ST (Subtask, complete, name) +import Data.Taskell.Task (Task, description, due, name, subtasks) +import Events.State (getCurrentTask) +import Events.State.Modal.Detail (getCurrentItem, getField) +import Events.State.Types (State) +import Events.State.Types.Mode (DetailItem (..)) +import UI.Field (Field, textField, widgetFromMaybe) +import UI.Theme (disabledAttr, dlToAttr, taskCurrentAttr, + titleCurrentAttr) +import UI.Types (ResourceName (..)) + +renderSubtask :: Maybe Field -> DetailItem -> Int -> ST.Subtask -> Widget ResourceName +renderSubtask f current i subtask = padBottom (Pad 1) $ prefix <+> final + where + cur = + case current of + DetailItem c -> i == c + _ -> False + done = subtask ^. ST.complete + attr = + withAttr + (if cur + then taskCurrentAttr + else titleCurrentAttr) + prefix = + attr . txt $ + if done + then "[x] " + else "[ ] " + widget = textField (subtask ^. ST.name) + final + | cur = visible . attr $ widgetFromMaybe widget f + | not done = attr widget + | otherwise = widget + +renderSummary :: Maybe Field -> DetailItem -> Task -> Widget ResourceName +renderSummary f i task = padTop (Pad 1) $ padBottom (Pad 2) w' + where + w = textField $ fromMaybe "No description" (task ^. description) + w' = + case i of + DetailDescription -> visible $ widgetFromMaybe w f + _ -> w + +renderDate :: Day -> Maybe Field -> DetailItem -> Task -> Widget ResourceName +renderDate today field item task = + case item of + DetailDate -> visible $ prefix <+> widgetFromMaybe widget field + _ -> + case day of + Just d -> prefix <+> withAttr (dlToAttr (deadline today d)) widget + Nothing -> emptyWidget + where + day = task ^. due + prefix = txt "Due: " + widget = textField $ maybe "" dayToOutput day + +detail :: State -> Day -> (Text, Widget ResourceName) +detail state today = + fromMaybe ("Error", txt "Oops") $ do + task <- getCurrentTask state + i <- getCurrentItem state + let f = getField state + let sts = task ^. subtasks + w + | null sts = withAttr disabledAttr $ txt "No sub-tasks" + | otherwise = vBox . toList $ renderSubtask f i `mapWithIndex` sts + return (task ^. name, renderDate today f i task <=> renderSummary f i task <=> w) diff --git a/src/UI/Modal/Help.hs b/src/UI/Modal/Help.hs new file mode 100644 --- /dev/null +++ b/src/UI/Modal/Help.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Modal.Help + ( help + ) where + +import ClassyPrelude + +import Brick +import Data.FileEmbed (embedFile) +import Data.Text as T (breakOn, justifyRight, replace, strip) + +import UI.Field (textField) +import UI.Theme (taskCurrentAttr) +import UI.Types (ResourceName) + +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 + +help :: (Text, Widget ResourceName) +help = ("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 diff --git a/src/UI/Modal/MoveTo.hs b/src/UI/Modal/MoveTo.hs new file mode 100644 --- /dev/null +++ b/src/UI/Modal/MoveTo.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Modal.MoveTo + ( moveTo + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick + +import Data.Taskell.List (title) +import Events.State (getCurrentList) +import Events.State.Types (State, lists) +import UI.Field (textField) +import UI.Theme (taskCurrentAttr) +import UI.Types (ResourceName) + +moveTo :: State -> (Text, Widget ResourceName) +moveTo state = ("Move To:", widget) + where + skip = getCurrentList state + ls = toList $ state ^. lists + titles = textField . (^. title) <$> ls + letter a = + padRight (Pad 1) . hBox $ [txt "[", withAttr taskCurrentAttr $ txt (singleton a), txt "]"] + letters = letter <$> ['a' ..] + remove i l = take i l ++ drop (i + 1) l + output (l, t) = l <+> t + widget = vBox $ output <$> remove skip (zip letters titles) diff --git a/src/UI/Theme.hs b/src/UI/Theme.hs new file mode 100644 --- /dev/null +++ b/src/UI/Theme.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module UI.Theme + ( titleAttr + , titleCurrentAttr + , taskCurrentAttr + , taskAttr + , disabledAttr + , dlToAttr + , defaultTheme + ) where + +import Brick (AttrName, attrName) +import Brick.Themes (Theme, newTheme) +import Brick.Util (fg) +import Graphics.Vty (blue, defAttr, green, magenta, red, yellow) + +import Data.Taskell.Date (Deadline (..)) + +-- attrs +titleAttr :: AttrName +titleAttr = attrName "title" + +titleCurrentAttr :: AttrName +titleCurrentAttr = attrName "titleCurrent" + +taskCurrentAttr :: AttrName +taskCurrentAttr = attrName "taskCurrent" + +taskAttr :: AttrName +taskAttr = attrName "task" + +disabledAttr :: AttrName +disabledAttr = attrName "disabled" + +dlDue, dlSoon, dlFar :: AttrName +dlDue = attrName "dlDue" + +dlSoon = attrName "dlSoon" + +dlFar = attrName "dlFar" + +-- convert deadline into attribute +dlToAttr :: Deadline -> AttrName +dlToAttr dl = + case dl of + Plenty -> dlFar + ThisWeek -> dlSoon + Tomorrow -> dlSoon + Today -> dlDue + Passed -> dlDue + +-- default theme +defaultTheme :: Theme +defaultTheme = + newTheme + defAttr + [ (titleAttr, fg green) + , (titleCurrentAttr, fg blue) + , (taskCurrentAttr, fg magenta) + , (disabledAttr, fg yellow) + , (dlDue, fg red) + , (dlSoon, fg yellow) + , (dlFar, fg green) + ] diff --git a/src/UI/Types.hs b/src/UI/Types.hs new file mode 100644 --- /dev/null +++ b/src/UI/Types.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module UI.Types where + +import ClassyPrelude (Eq, Int, Ord, Show) + +data ResourceName + = RNCursor + | RNTask (Int, Int) + | RNList Int + | RNLists + | RNModal + deriving (Show, Eq, Ord) diff --git a/taskell.cabal b/taskell.cabal new file mode 100644 --- /dev/null +++ b/taskell.cabal @@ -0,0 +1,156 @@ +cabal-version: 1.12 +name: taskell +version: 1.3.5.0 +license: BSD3 +license-file: LICENSE +copyright: 2019 Mark Wales +maintainer: mark@smallhadroncollider.com +author: Mark Wales +homepage: https://github.com/smallhadroncollider/taskell#readme +bug-reports: https://github.com/smallhadroncollider/taskell/issues +synopsis: A command-line kanban board/task manager +description: + Please see the README on GitHub at +category: Command Line Tools +build-type: Simple +extra-source-files: + README.md + templates/api-error.txt + templates/config.ini + templates/controls.md + templates/github-token.txt + templates/theme.ini + templates/trello-token.txt + templates/usage.txt + +source-repository head + type: git + location: https://github.com/smallhadroncollider/taskell + +library + exposed-modules: + App + Events.State + IO.Config + IO.Taskell + Data.Taskell.Date + Data.Taskell.List + Data.Taskell.List.Internal + Data.Taskell.Lists + Data.Taskell.Lists.Internal + Data.Taskell.Seq + Data.Taskell.Subtask + Data.Taskell.Subtask.Internal + Data.Taskell.Task + Data.Taskell.Task.Internal + Events.State.Types + Events.State.Types.Mode + IO.Config.Markdown + IO.Markdown.Internal + IO.HTTP.GitHub + IO.HTTP.Trello.List + IO.HTTP.Trello.ChecklistItem + UI.Field + hs-source-dirs: src + other-modules: + Config + Events.Actions + Events.Actions.Insert + Events.Actions.Modal + Events.Actions.Modal.Detail + Events.Actions.Modal.Help + Events.Actions.Modal.MoveTo + Events.Actions.Normal + Events.Actions.Search + Events.State.Modal.Detail + IO.Config.General + IO.Config.GitHub + IO.Config.Layout + IO.Config.Parser + IO.Config.Trello + IO.HTTP.Aeson + IO.HTTP.GitHub.Card + IO.HTTP.GitHub.Column + IO.HTTP.GitHub.Project + IO.HTTP.Trello + IO.HTTP.Trello.Card + IO.Markdown + UI.CLI + UI.Draw + UI.Modal + UI.Modal.Detail + UI.Modal.Help + UI.Modal.MoveTo + UI.Theme + UI.Types + Paths_taskell + 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, + 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, + 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, + mtl >=2.2.2 && <2.3, + template-haskell >=2.13.0.0 && <2.14, + text >=1.2.3.1 && <1.3, + time >=1.8.0.2 && <1.9, + vty ==5.21.* + +executable taskell + main-is: Main.hs + hs-source-dirs: app + other-modules: + Paths_taskell + default-language: Haskell2010 + 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, + taskell -any + +test-suite taskell-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Data.Taskell.DateTest + Data.Taskell.ListsTest + Data.Taskell.ListTest + Data.Taskell.SeqTest + Data.Taskell.SubtaskTest + Data.Taskell.TaskTest + Events.StateTest + IO.GitHubTest + IO.MarkdownTest + IO.TrelloTest + UI.FieldTest + Paths_taskell + default-language: Haskell2010 + 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, + taskell -any, + tasty >=1.1.0.4 && <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 diff --git a/templates/api-error.txt b/templates/api-error.txt new file mode 100644 --- /dev/null +++ b/templates/api-error.txt @@ -0,0 +1,2 @@ +Could not parse response. Please file an Issue on GitHub: +https://github.com/smallhadroncollider/taskell/issues/new diff --git a/templates/config.ini b/templates/config.ini new file mode 100644 --- /dev/null +++ b/templates/config.ini @@ -0,0 +1,14 @@ +[general] +filename = taskell.md + +[layout] +column_width = 30 +column_padding = 3 +description_indicator = "≡" + +[markdown] +title = "##" +task = "-" +summary = " >" +due = " @" +subtask = " *" diff --git a/templates/controls.md b/templates/controls.md new file mode 100644 --- /dev/null +++ b/templates/controls.md @@ -0,0 +1,23 @@ +- `?`: 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/templates/github-token.txt b/templates/github-token.txt new file mode 100644 --- /dev/null +++ b/templates/github-token.txt @@ -0,0 +1,10 @@ +Please visit: + +https://github.com/settings/tokens/new + +Make sure to tick the "repo" scope. + +When you have your personal access token, add it to ~/.taskell/config.ini: + +[github] +token = diff --git a/templates/theme.ini b/templates/theme.ini new file mode 100644 --- /dev/null +++ b/templates/theme.ini @@ -0,0 +1,13 @@ +[other] + +; list title +title.fg = green + +; current list title +titleCurrent.fg = blue + +; current task +taskCurrent.fg = magenta + +; disabled +disabled.fg = yellow diff --git a/templates/trello-token.txt b/templates/trello-token.txt new file mode 100644 --- /dev/null +++ b/templates/trello-token.txt @@ -0,0 +1,8 @@ +Please visit: + +https://trello.com/1/authorize?expiration=never&name=taskell&scope=read&response_type=token&key=80dbcf6f88f62cc5639774e13342c20b + +When you have your access token, add it to ~/.taskell/config.ini: + +[trello] +token = diff --git a/templates/usage.txt b/templates/usage.txt new file mode 100644 --- /dev/null +++ b/templates/usage.txt @@ -0,0 +1,9 @@ +Usage: taskell ([options] | [-i | -t | -g [orgs/ | repos//]] file) + +Options: + +-h Help +-v Version number +-i file Display information about a file +-t file Create a new taskell file from the given Trello board ID +-g [orgs/ | repos//] file Create a new taskell file from the given GitHub identifier diff --git a/test/Data/Taskell/DateTest.hs b/test/Data/Taskell/DateTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Taskell/DateTest.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.DateTest + ( test_date + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Taskell.Date +import Data.Time + +testDate :: Day +testDate = fromGregorian 2018 05 18 + +-- tests +test_date :: TestTree +test_date = + testGroup + "Data.Taskell.Date" + [ testCase + "dayToOutput" + (assertEqual + "Date in yyyy-mm-dd format" + (Just "2018-05-18") + (dayToOutput <$> fromGregorianValid 2018 05 18)) + , testGroup + "dayToText" + [ testCase + "same year" + (assertEqual + "Date in 18-May format" + (Just "18-May") + (dayToText <$> fromGregorianValid 2018 08 18 <*> + fromGregorianValid 2018 05 18)) + , testCase + "different year" + (assertEqual + "Date in 18-May 2019 format" + (Just "18-May 2019") + (dayToText <$> fromGregorianValid 2018 08 18 <*> + fromGregorianValid 2019 05 18)) + , testCase + "different year" + (assertEqual + "Date in 18-May 2017 format" + (Just "18-May 2017") + (dayToText <$> fromGregorianValid 2018 08 18 <*> + fromGregorianValid 2017 05 18)) + ] + , testCase + "textToDay" + (assertEqual "A valid Day" (fromGregorianValid 2018 05 18) (textToDay "2018-05-18")) + , testGroup + "deadline" + [ testCase + "Plenty" + (assertEqual + "Plenty of time" + Plenty + (deadline testDate (fromGregorian 2018 05 28))) + , testCase + "ThisWeek" + (assertEqual "This week" ThisWeek (deadline testDate (fromGregorian 2018 05 24))) + , testCase + "Tomorrow" + (assertEqual "Tomorrow" Tomorrow (deadline testDate (fromGregorian 2018 05 19))) + , testCase "Today" (assertEqual "Today" Today (deadline testDate testDate)) + , testCase + "Passed" + (assertEqual "Passed" Passed (deadline testDate (fromGregorian 2018 05 17))) + ] + ] diff --git a/test/Data/Taskell/ListTest.hs b/test/Data/Taskell/ListTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Taskell/ListTest.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.ListTest + ( test_list + ) where + +import ClassyPrelude as CP + +import Control.Lens ((.~)) + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Taskell.List.Internal as L +import qualified Data.Taskell.Task as T (Task, blank, name, new) + +emptyList :: List +emptyList = L.empty "Test" + +taskSeq :: Seq T.Task +taskSeq = fromList [T.new "Hello", T.new "Blah", T.new "Fish"] + +populatedList :: List +populatedList = List "Populated" taskSeq + +-- tests +test_list :: TestTree +test_list = + testGroup + "Data.Taskell.List" + [ testCase + "create" + (assertEqual "Empty list with title" (List "Test" CP.empty) (create "Test" CP.empty)) + , testCase "empty" (assertEqual "Empty list with title" (List "Test" CP.empty) emptyList) + , testCase + "new" + (assertEqual + "List with title and blank Task" + (List "Test" (fromList [T.blank])) + (new emptyList)) + , testGroup + "count" + [ testCase "empty" (assertEqual "List length" 0 (count emptyList)) + , testCase "one item" (assertEqual "List length" 1 (count $ new emptyList)) + ] + , testCase + "newAt" + (assertEqual + "List with new item second position" + (List "Populated" (fromList [T.new "Hello", T.blank, T.new "Blah", T.new "Fish"])) + (newAt 1 populatedList)) + , testGroup + "append" + [ testCase + "populated" + (assertEqual + "List with new item" + (List + "Populated" + (fromList [T.new "Hello", T.new "Blah", T.new "Fish", T.new "Spoon"])) + (append (T.new "Spoon") populatedList)) + , testCase + "empty" + (assertEqual + "List with new item" + (List "Test" (fromList [T.new "Spoon"])) + (append (T.new "Spoon") emptyList)) + ] + , testCase + "extract" + (assertEqual + "List and extracted item" + (Just (List "Populated" (fromList [T.new "Hello", T.new "Fish"]), T.new "Blah")) + (extract 1 populatedList)) + , testCase + "updateFn" + (assertEqual + "List with updated item" + (List "Populated" (fromList [T.new "Hello", T.new "Monkey", T.new "Fish"])) + (updateFn 1 (T.name .~ "Monkey") populatedList)) + , testCase + "update" + (assertEqual + "List with updated item" + (List "Populated" (fromList [T.new "Hello", T.new "Monkey", T.new "Fish"])) + (update 1 (T.new "Monkey") populatedList)) + , testGroup + "move" + [ testCase + "up" + (assertEqual + "List with moved item" + (Just + (List + "Populated" + (fromList [T.new "Hello", T.new "Fish", T.new "Blah"]))) + (move 1 1 populatedList)) + , testCase + "down" + (assertEqual + "List with moved item" + (Just + (List + "Populated" + (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]))) + (move 1 (-1) populatedList)) + , testCase + "up - out of bounds" + (assertEqual + "List with moved item" + (Just + (List + "Populated" + (fromList [T.new "Hello", T.new "Fish", T.new "Blah"]))) + (move 1 10 populatedList)) + , testCase + "down - out of bounds" + (assertEqual + "List with moved item" + (Just + (List + "Populated" + (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]))) + (move 1 (-10) populatedList)) + ] + , testCase + "deleteTask" + (assertEqual + "List with removed item" + (List "Populated" (fromList [T.new "Hello", T.new "Fish"])) + (deleteTask 1 populatedList)) + , testGroup + "getTask" + [ testCase + "exists" + (assertEqual "Middle item" (Just (T.new "Blah")) (getTask 1 populatedList)) + , testCase "doesn't exist" (assertEqual "Nothing" Nothing (getTask 5 populatedList)) + ] + , testGroup + "searchFor" + [ testCase + "exists" + (assertEqual + "Blah item" + (List "Populated" (fromList [T.new "Blah"])) + (searchFor "Bl" populatedList)) + , testCase + "multiple" + (assertEqual + "Blah and Fish" + (List "Populated" (fromList [T.new "Blah", T.new "Fish"])) + (searchFor "h" populatedList)) + , testCase + "doesn't exist" + (assertEqual + "Empty list" + (List "Populated" CP.empty) + (searchFor "FFF" populatedList)) + ] + ] diff --git a/test/Data/Taskell/ListsTest.hs b/test/Data/Taskell/ListsTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Taskell/ListsTest.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.ListsTest + ( test_lists + ) where + +import ClassyPrelude hiding (delete) + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.Taskell.List as L +import Data.Taskell.Lists.Internal +import qualified Data.Taskell.Task as T + +-- test data +list1, list2, list3 :: L.List +list1 = foldl' (flip L.append) (L.empty "List 1") [T.new "One", T.new "Two", T.new "Three"] + +list2 = foldl' (flip L.append) (L.empty "List 2") [T.new "1", T.new "2", T.new "3"] + +list3 = foldl' (flip L.append) (L.empty "List 3") [T.new "01", T.new "10", T.new "11"] + +testLists :: Lists +testLists = fromList [list1, list2, list3] + +-- tests +test_lists :: TestTree +test_lists = + testGroup + "Data.Taskell.Lists" + [ testCase + "initial" + (assertEqual + "Returns To Do and Done lists" + (fromList [L.empty "To Do", L.empty "Done"]) + initial) + , testCase + "updateLists" + (assertEqual + "Replaces the middle list" + (fromList [list1, list1, list3]) + (updateLists 1 list1 testLists)) + , testGroup + "count" + [ testCase + "list exists" + (assertEqual "Returns length of middle list" 3 (count 1 testLists)) + , testCase "list does not exist" (assertEqual "Returns 0" 0 (count 10 testLists)) + ] + , testGroup + "get" + [ testCase + "list exists" + (assertEqual "Returns the list" (Just list2) (get testLists 1)) + , testCase "list does not exist" (assertEqual "Nothing" Nothing (get testLists 10)) + ] + , testGroup + "changeList" + [ testCase + "right" + (assertEqual + "Returns updated lists" + (Just + (fromList + [ list1 + , foldl' + (flip L.append) + (L.empty "List 2") + [T.new "1", T.new "3"] + , foldl' + (flip L.append) + (L.empty "List 3") + [T.new "01", T.new "10", T.new "11", T.new "2"] + ])) + (changeList (1, 1) testLists 1)) + , testCase + "left" + (assertEqual + "Returns updated lists" + (Just + (fromList + [ foldl' + (flip L.append) + (L.empty "List 1") + [T.new "One", T.new "Two", T.new "Three", T.new "2"] + , foldl' + (flip L.append) + (L.empty "List 2") + [T.new "1", T.new "3"] + , list3 + ])) + (changeList (1, 1) testLists (-1))) + , testCase + "out of bounds list" + (assertEqual "Nothing" Nothing (changeList (5, 1) testLists 1)) + , testCase + "out of bounds task" + (assertEqual "Nothing" Nothing (changeList (1, 10) testLists 1)) + ] + , testCase + "newList" + (assertEqual + "Returns lists with new list" + (fromList [list1, list2, list3, L.empty "Hello"]) + (newList "Hello" testLists)) + , testCase + "delete" + (assertEqual + "Returns lists with middle list removed" + (fromList [list1, list3]) + (delete 1 testLists)) + , testGroup + "exists" + [ testCase "list exists" (assertEqual "Returns True" True (exists 1 testLists)) + , testCase + "list does not exist" + (assertEqual "Returns False" False (exists 10 testLists)) + ] + , testGroup + "shiftBy" + [ testCase + "right" + (assertEqual + "Returns updated lists" + (Just (fromList [list1, list3, list2])) + (shiftBy 1 1 testLists)) + , testCase + "left" + (assertEqual + "Returns updated lists" + (Just (fromList [list2, list1, list3])) + (shiftBy 1 (-1) testLists)) + , testCase + "out of bounds list" + (assertEqual "Nothing" Nothing (shiftBy 5 1 testLists)) + , testCase + "out of bounds shift" + (assertEqual + "Returns updated lists" + (Just (fromList [list2, list1, list3])) + (shiftBy 1 (-10) testLists)) + ] + , testGroup + "search" + [ testCase + "term exists" + (assertEqual + "Returns filtered lists" + (fromList + [ foldl' (flip L.append) (L.empty "List 1") [T.new "One"] + , L.empty "List 2" + , L.empty "List 3" + ]) + (search "One" testLists)) + , testCase + "term doesn't exist" + (assertEqual + "Returns updated lists" + (fromList [L.empty "List 1", L.empty "List 2", L.empty "List 3"]) + (search "Fish" testLists)) + ] + , testGroup + "appendToLast" + [ testCase + "previous list exists" + (assertEqual + "Returns updated lists" + (fromList + [ list1 + , list2 + , foldl' + (flip L.append) + (L.empty "List 3") + [T.new "01", T.new "10", T.new "11", T.new "Blah"] + ]) + (appendToLast (T.new "Blah") testLists)) + , testCase + "previous list doesn't exist" + (assertEqual "Returns original list" empty (appendToLast (T.new "Blah") empty)) + ] + , testCase + "analyse" + (assertEqual + "Returns an analysis" + "test.md\nLists: 3\nTasks: 9" + (analyse "test.md" testLists)) + ] diff --git a/test/Data/Taskell/SeqTest.hs b/test/Data/Taskell/SeqTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Taskell/SeqTest.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.SeqTest + ( test_seq + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Taskell.Seq + +testSeq :: Seq Int +testSeq = fromList [1, 2, 3, 4, 5] + +-- tests +test_seq :: TestTree +test_seq = + testGroup + "Data.Taskell.Seq" + [ testGroup + "extract" + [ testCase + "Standard" + (assertEqual + "Extracts third item" + (Just (fromList [1, 2, 4, 5], 3)) + (extract 2 testSeq)) + , testCase + "First" + (assertEqual + "Extracts first item" + (Just (fromList [2, 3, 4, 5], 1)) + (extract 0 testSeq)) + , testCase + "Last" + (assertEqual + "Extracts last item" + (Just (fromList [1, 2, 3, 4], 5)) + (extract 4 testSeq)) + , testCase + "Out of range - positive" + (assertEqual "Nothing" Nothing (extract 5 testSeq)) + , testCase + "Out of range - negative" + (assertEqual "Nothing" Nothing (extract (-1) testSeq)) + ] + , testGroup + "shiftBy" + [ testCase + "To right" + (assertEqual + "Moves third item right" + (Just (fromList [1, 2, 4, 3, 5])) + (shiftBy 2 1 testSeq)) + , testCase + "To left" + (assertEqual + "Moves third item left" + (Just (fromList [1, 3, 2, 4, 5])) + (shiftBy 2 (-1) testSeq)) + , testCase + "First to right" + (assertEqual + "Moves first item right" + (Just (fromList [2, 1, 3, 4, 5])) + (shiftBy 0 1 testSeq)) + , testCase + "First to left" + (assertEqual "The original sequence" (Just testSeq) (shiftBy 0 (-1) testSeq)) + , testCase + "Last to right" + (assertEqual "The original sequence" (Just testSeq) (shiftBy 4 1 testSeq)) + , testCase + "Last to left" + (assertEqual + "Moves last item left" + (Just (fromList [1, 2, 3, 5, 4])) + (shiftBy 4 (-1) testSeq)) + , testCase + "Ridiculous right shift" + (assertEqual + "Moves to right-most" + (Just (fromList [1, 2, 4, 5, 3])) + (shiftBy 2 20 testSeq)) + , testCase + "Ridiculous left shift" + (assertEqual + "Moves to left-most" + (Just (fromList [3, 1, 2, 4, 5])) + (shiftBy 2 (-20) testSeq)) + ] + ] diff --git a/test/Data/Taskell/SubtaskTest.hs b/test/Data/Taskell/SubtaskTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Taskell/SubtaskTest.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.SubtaskTest + ( test_subtask + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Taskell.Subtask.Internal + +-- tests +test_subtask :: TestTree +test_subtask = + testGroup + "Data.Taskell.Subtask" + [ testCase "blank" (assertEqual "creates an empty sub-task" (Subtask "" False) blank) + , testGroup + "new" + [ testCase + "completed" + (assertEqual "creates a new sub-task" (Subtask "Blah" True) (new "Blah" True)) + , testCase + "not completed" + (assertEqual "creates a new sub-task" (Subtask "Blah" False) (new "Blah" False)) + ] + , testGroup + "toggle" + [ testCase + "false to true" + (assertEqual + "Sets completed to True" + (Subtask "Blah" True) + (toggle $ new "Blah" False)) + , testCase + "true to false" + (assertEqual + "Sets completed to False" + (Subtask "Blah" False) + (toggle $ new "Blah" True)) + ] + ] diff --git a/test/Data/Taskell/TaskTest.hs b/test/Data/Taskell/TaskTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Taskell/TaskTest.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Taskell.TaskTest + ( test_task + ) where + +import ClassyPrelude + +import Control.Lens ((.~)) + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Time (fromGregorianValid) + +import qualified Data.Taskell.Subtask as ST (name, new) +import Data.Taskell.Task.Internal + +testTask :: Task +testTask = + Task + { _name = "Test" + , _description = Nothing + , _subtasks = fromList [ST.new "One" True, ST.new "Two" False, ST.new "Three" False] + , _due = Nothing + } + +-- tests +test_task :: TestTree +test_task = + testGroup + "Data.Taskell.Task" + [ testCase "blank" (assertEqual "Returns empty task" (Task "" Nothing empty Nothing) blank) + , testCase + "new" + (assertEqual "Returns a new task" (Task "Hello" Nothing empty Nothing) (new "Hello")) + , testGroup + "getSubtask" + [ testCase + "exists" + (assertEqual + "Returns a the sub-task" + (Just (ST.new "Two" False)) + (getSubtask 1 testTask)) + , testCase + "doesn't exist" + (assertEqual "Returns Nothing" Nothing (getSubtask 10 testTask)) + ] + , testGroup + "setDescription" + [ testCase + "empty sub-tasks" + (assertEqual + "Updates description" + (Task "Test" (Just "Description") empty Nothing) + (setDescription "Description" (new "Test"))) + , testCase + "empty" + (assertEqual + "Keeps description as Nothing" + (new "Test") + (setDescription "" (new "Test"))) + , testCase + "blank" + (assertEqual + "Keeps description as Nothing" + (new "Test") + (setDescription " " (new "Test"))) + ] + , testGroup + "addSubtask" + [ testCase + "existing" + (assertEqual + "Returns the task with added subtask" + (Task + "Test" + Nothing + (fromList + [ ST.new "One" True + , ST.new "Two" False + , ST.new "Three" False + , ST.new "Four" True + ]) + Nothing) + (addSubtask (ST.new "Four" True) testTask)) + , testCase + "empty sub-tasks" + (assertEqual + "Returns the task with added subtask" + (Task "Test" Nothing (fromList [ST.new "One" False]) Nothing) + (addSubtask (ST.new "One" False) (new "Test"))) + ] + , testGroup + "hasSubtasks" + [ testCase "existing" (assertEqual "Returns True" True (hasSubtasks testTask)) + , testCase + "empty sub-tasks" + (assertEqual "Returns False" False (hasSubtasks (new "Test"))) + ] + , testGroup + "updateSubtask" + [ testCase + "exists" + (assertEqual + "Returns updated task" + (Task + "Test" + Nothing + (fromList + [ST.new "One" True, ST.new "Cow" False, ST.new "Three" False]) + Nothing) + (updateSubtask 1 (ST.name .~ "Cow") testTask)) + , testCase + "doesn't exist" + (assertEqual + "Returns task" + (Task + "Test" + Nothing + (fromList + [ST.new "One" True, ST.new "Two" False, ST.new "Three" False]) + Nothing) + (updateSubtask 10 (ST.name .~ "Cow") testTask)) + ] + , testGroup + "removeSubtask" + [ testCase + "exists" + (assertEqual + "Returns updated task" + (Task + "Test" + Nothing + (fromList [ST.new "One" True, ST.new "Three" False]) + Nothing) + (removeSubtask 1 testTask)) + , testCase + "doesn't exist" + (assertEqual + "Returns task" + (Task + "Test" + Nothing + (fromList + [ST.new "One" True, ST.new "Two" False, ST.new "Three" False]) + Nothing) + (removeSubtask 10 testTask)) + ] + , testCase "countSubtasks" (assertEqual "Returns 3" 3 (countSubtasks testTask)) + , testCase + "countCompleteSubtasks" + (assertEqual "Returns 1" 1 (countCompleteSubtasks testTask)) + , testGroup + "contains" + [ testCase "in task" (assertEqual "Finds in task" True (contains "Test" testTask)) + , testCase "in sub-task" (assertEqual "Find sub-task" True (contains "One" testTask)) + , testCase "missing" (assertEqual "Find sub-task" False (contains "Fish" testTask)) + ] + , testGroup + "isBlank" + [ testCase + "blank" + (assertEqual "Return True" True (isBlank (Task "" Nothing empty Nothing))) + , testCase "name not blank" (assertEqual "Returns False" False (isBlank testTask)) + , testCase + "description not blank" + (assertEqual + "Returns False" + False + (isBlank (Task "" (Just "Blah") empty Nothing))) + , testCase + "subtasks not blank" + (assertEqual + "Returns False" + False + (isBlank (Task "" Nothing (fromList [ST.new "One" True]) Nothing))) + , testCase + "due date not blank" + (assertEqual + "Returns False" + False + (isBlank (Task "" Nothing empty (fromGregorianValid 2018 05 18)))) + ] + ] diff --git a/test/Events/StateTest.hs b/test/Events/StateTest.hs new file mode 100644 --- /dev/null +++ b/test/Events/StateTest.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Events.StateTest + ( test_state + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Lens ((&), (.~), (^.)) + +import qualified Data.Sequence as S (lookup) +import qualified Data.Taskell.List as L (append, empty) +import qualified Data.Taskell.Task as T (new) +import Events.State +import Events.State.Types +import Events.State.Types.Mode + +testState :: State +testState = + State + { _mode = Normal + , _lists = empty + , _history = [] + , _current = (0, 0) + , _path = "test.md" + , _io = Nothing + } + +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 = (4, 0) + , _path = "test.md" + , _io = Nothing + } + +-- tests +test_state :: TestTree +test_state = + testGroup + "Events.State" + [ testCase + "quit" + (assertEqual + "Retuns Just with mode set to Shutdown" + (Just (testState & mode .~ Shutdown)) + (quit testState)) + , testCase + "continue" + (assertEqual "Retuns with io set to " (testState & io .~ Nothing) (continue testState)) + -- 1 - a, 2 - b, 3 - c, 4 - d, 5 - e, 6 - f, 7 - g, 8 - h, 9 - i + , testGroup + "moveTo" + [ testCase + "first" + (assertEqual + "Moves to first list" + (Just (L.append (T.new "Test Item") (L.empty "List 1"))) + (S.lookup 0 . (^. lists) =<< moveTo 'a' moveToState)) + , testCase + "second" + (assertEqual + "Moves to second list" + (Just (L.append (T.new "Test Item") (L.empty "List 2"))) + (S.lookup 1 . (^. lists) =<< moveTo 'b' moveToState)) + , testCase + "fourth" + (assertEqual + "Moves to fourth list" + (Just (L.append (T.new "Test Item") (L.empty "List 4"))) + (S.lookup 3 . (^. lists) =<< moveTo 'd' moveToState)) + , testCase + "sixth" + (assertEqual + "Moves to sixth list" + (Just (L.append (T.new "Test Item") (L.empty "List 6"))) + (S.lookup 5 . (^. lists) =<< moveTo 'f' moveToState)) + , testCase + "penultimate" + (assertEqual + "Moves to penultime list" + (Just (L.append (T.new "Test Item") (L.empty "List 8"))) + (S.lookup 7 . (^. lists) =<< moveTo 'h' moveToState)) + , testCase + "last" + (assertEqual + "Moves to last list" + (Just (L.append (T.new "Test Item") (L.empty "List 9"))) + (S.lookup 8 . (^. lists) =<< moveTo 'i' moveToState)) + , testCase + "current list" + (assertEqual "Doesn't do anything" Nothing (moveTo 'e' moveToState)) + , testCase + "invalid option" + (assertEqual "Doesn't do anything" Nothing (moveTo 'q' moveToState)) + ] + ] diff --git a/test/IO/GitHubTest.hs b/test/IO/GitHubTest.hs new file mode 100644 --- /dev/null +++ b/test/IO/GitHubTest.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module IO.GitHubTest + ( test_github + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import IO.HTTP.GitHub (getNextLink) + +-- tests +test_github :: TestTree +test_github = + testGroup + "IO.HTTP.GitHub" + [ testGroup + "getNextLink" + [ testCase + "next exists" + (assertEqual + "Parses next link" + (Just "https://api.github.com/projects/columns/3152155/cards?page=2") + (getNextLink + [ "; rel=\"next\", ; rel=\"last\"" + ])) + , testCase "empty" (assertEqual "Returns Nothing" Nothing (getNextLink [])) + , testCase + "no next" + (assertEqual + "Returns Nothing" + Nothing + (getNextLink + [ "; rel=\"prev\", ; rel=\"last\"" + ])) + , testCase + "next last" + (assertEqual + "Parses next link" + (Just "https://api.github.com/projects/columns/3152155/cards?page=2") + (getNextLink + [ "; rel=\"prev\", ; rel=\"next\", ; rel=\"last\"" + ])) + ] + ] diff --git a/test/IO/MarkdownTest.hs b/test/IO/MarkdownTest.hs new file mode 100644 --- /dev/null +++ b/test/IO/MarkdownTest.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module IO.MarkdownTest + ( test_markdown + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTest) +import Test.Tasty.HUnit + +import Data.Taskell.Lists (Lists, appendToLast, newList) +import qualified Data.Taskell.Subtask as ST (new) +import Data.Taskell.Task (Task, addSubtask, new, setDescription, setDue) +import qualified IO.Config as C (defaultConfig) +import IO.Config.Markdown (Config (..), defaultConfig) +import IO.Markdown.Internal (listStringify, parse, start) + +-- alternative markdown configs +alternativeConfig :: Config +alternativeConfig = + Config + { titleOutput = "##" + , taskOutput = "###" + , descriptionOutput = ">" + , dueOutput = "@" + , subtaskOutput = "-" + } + +-- useful records +task :: Task +task = new "Test Item" + +list :: Lists +list = newList "Test" empty + +listWithItem :: Lists +listWithItem = appendToLast task list + +makeSubTask :: Text -> Bool -> Lists +makeSubTask t b = appendToLast (addSubtask (ST.new t b) task) list + +taskWithSummary :: Task +taskWithSummary = setDescription "Summary" task + +taskWithMultiLineSummary :: Task +taskWithMultiLineSummary = setDescription "Summary Line 1\nSummary Line 2" task + +listWithSummaryItem :: Lists +listWithSummaryItem = appendToLast taskWithSummary list + +listWithMultiLineSummaryItem :: Lists +listWithMultiLineSummaryItem = appendToLast taskWithMultiLineSummary list + +taskWithDueDate :: Task +taskWithDueDate = setDue "2018-04-12" task + +listWithDueDateItem :: Lists +listWithDueDateItem = appendToLast taskWithDueDate list + +-- tests +test_markdown :: TestTree +test_markdown = + testGroup + "IO.Markdown" + [ testGroup + "Line Parsing" + [ testGroup + "Default Format" + [ testCase + "List Title" + (assertEqual + "One list" + (list, []) + (start defaultConfig (empty, []) ("## Test", 1))) + , testCase + "Blank line" + (assertEqual + "Nothing" + (empty, []) + (start defaultConfig (empty, []) ("", 1))) + , testCase + "Just spaces" + (assertEqual + "Nothing" + (empty, []) + (start defaultConfig (empty, []) (" ", 1))) + , testCase + "Error" + (assertEqual + "Error on line 1" + (empty, [1]) + (start defaultConfig (empty, []) ("Test", 1))) + , testCase + "List item" + (assertEqual + "List item" + (listWithItem, []) + (start defaultConfig (list, []) ("- Test Item", 1))) + , testCase + "Summary" + (assertEqual + "Summary" + (listWithSummaryItem, []) + (start defaultConfig (listWithItem, []) (" > Summary", 1))) + , testCase + "Due Date" + (assertEqual + "Due Date" + (listWithDueDateItem, []) + (start defaultConfig (listWithItem, []) (" @ 2018-04-12", 1))) + , testCase + "Sub-Task" + (assertEqual + "List item with Sub-Task" + (makeSubTask "Blah" False, []) + (start defaultConfig (listWithItem, []) (" * Blah", 1))) + , testCase + "Complete Sub-Task" + (assertEqual + "List item with Sub-Task" + (makeSubTask "Blah" True, []) + (start defaultConfig (listWithItem, []) (" * ~Blah~", 1))) + , ignoreTest $ + testCase + "List item without list" + (assertEqual + "Parse Error" + (empty, [1]) + (start defaultConfig (empty, []) ("- Test Item", 1))) + , ignoreTest $ + testCase + "Sub task without list item" + (assertEqual + "Parse Error" + (list, [1]) + (start defaultConfig (list, []) (" * Blah", 1))) + ] + , testGroup + "Alternative Format" + [ testCase + "List Title" + (assertEqual + "One list" + (list, []) + (start alternativeConfig (empty, []) ("## Test", 1))) + , testCase + "Blank line" + (assertEqual + "Nothing" + (empty, []) + (start alternativeConfig (empty, []) ("", 1))) + , testCase + "Just spaces" + (assertEqual + "Nothing" + (empty, []) + (start alternativeConfig (empty, []) (" ", 1))) + , testCase + "Error" + (assertEqual + "Error on line 1" + (empty, [1]) + (start alternativeConfig (empty, []) ("* Test", 1))) + , testCase + "List item" + (assertEqual + "List item" + (listWithItem, []) + (start alternativeConfig (list, []) ("### Test Item", 1))) + , testCase + "Sub-Task" + (assertEqual + "List item with Sub-Task" + (makeSubTask "Blah" False, []) + (start alternativeConfig (listWithItem, []) ("- [ ] Blah", 1))) + , testCase + "Complete Sub-Task" + (assertEqual + "List item with Sub-Task" + (makeSubTask "Blah" True, []) + (start alternativeConfig (listWithItem, []) ("- [x] Blah", 1))) + , testCase + "Blank Sub-Task" + (assertEqual + "List item with blank Sub-Task" + (makeSubTask "" True, []) + (start alternativeConfig (listWithItem, []) ("- [x] ", 1))) + , testCase + "Sub-Task (old style)" + (assertEqual + "List item with Sub-Task" + (makeSubTask "Blah" False, []) + (start alternativeConfig (listWithItem, []) ("- Blah", 1))) + , testCase + "Complete Sub-Task (old style)" + (assertEqual + "List item with Sub-Task" + (makeSubTask "Blah" True, []) + (start alternativeConfig (listWithItem, []) ("- ~Blah~", 1))) + ] + ] + , testGroup + "Parsing" + [ testCase + "List Title" + (assertEqual + "One empty list" + (Right list) + (parse C.defaultConfig (encodeUtf8 "## Test"))) + , testCase + "List Items" + (assertEqual + "List with item" + (Right listWithItem) + (parse C.defaultConfig (encodeUtf8 "## Test\n- Test Item"))) + , testCase + "List Item with Summary" + (assertEqual + "List item with a summary" + (Right listWithSummaryItem) + (parse C.defaultConfig (encodeUtf8 "## Test\n- Test Item\n > Summary"))) + , testCase + "Parsing Errors" + (assertEqual + "Errors" + (Left "could not parse line(s) 3, 5") + (parse + C.defaultConfig + (encodeUtf8 "## Test\n- Test Item\n* Spoon\n- Test Item\nCow"))) + , testCase + "List Item with multi-line Summary" + (assertEqual + "List item with a summary" + (Right listWithMultiLineSummaryItem) + (parse + C.defaultConfig + (encodeUtf8 + "## Test\n- Test Item\n > Summary Line 1\n > Summary Line 2"))) + ] + , testGroup + "Stringification" + [ testGroup + "Default Format" + [ testCase + "Standard list" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n" + (foldl' (listStringify defaultConfig) "" listWithItem)) + , testCase + "Standard list with summary" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n > Summary\n" + (foldl' (listStringify defaultConfig) "" listWithSummaryItem)) + , testCase + "Standard list with date" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n @ 2018-04-12\n" + (foldl' (listStringify defaultConfig) "" listWithDueDateItem)) + , testCase + "Standard list with sub-task" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n * [x] Blah\n" + (foldl' (listStringify defaultConfig) "" (makeSubTask "Blah" True))) + , testCase + "Standard list with multi-line summary" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n > Summary Line 1\n > Summary Line 2\n" + (foldl' (listStringify defaultConfig) "" listWithMultiLineSummaryItem)) + ] + , testGroup + "Alternative Format" + [ testCase + "Standard list" + (assertEqual + "Markdown formatted output" + "## Test\n\n### Test Item\n" + (foldl' (listStringify alternativeConfig) "" listWithItem)) + , testCase + "Standard list with sub-task" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n * [ ] Blah\n" + (foldl' (listStringify defaultConfig) "" (makeSubTask "Blah" False))) + ] + ] + ] diff --git a/test/IO/TrelloTest.hs b/test/IO/TrelloTest.hs new file mode 100644 --- /dev/null +++ b/test/IO/TrelloTest.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module IO.TrelloTest + ( test_trello + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Aeson (decodeStrict) +import Data.FileEmbed (embedFile) +import Data.Time.LocalTime (getCurrentTimeZone) + +import IO.HTTP.Trello.ChecklistItem (ChecklistItem, checkItems, checklistItemToSubTask) +import IO.HTTP.Trello.List (List, listToList) + +json :: Maybe [List] +json = decodeStrict $(embedFile "test/IO/data/trello.json") + +checklistJson :: Maybe [ChecklistItem] +checklistJson = (^. checkItems) <$> decodeStrict $(embedFile "test/IO/data/trello-checklists.json") + +-- tests +test_trello :: IO TestTree +test_trello = do + tz <- getCurrentTimeZone + return $ + testGroup + "IO.Trello" + [ testCase + "Lists" + (assertEqual "Parses list JSON" (Just 5) (length . (listToList tz <$>) <$> json)) + , testCase + "Checklists" + (assertEqual + "Parses checklist JSON" + (Just 5) + (length . (checklistItemToSubTask <$>) <$> checklistJson)) + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/UI/FieldTest.hs b/test/UI/FieldTest.hs new file mode 100644 --- /dev/null +++ b/test/UI/FieldTest.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.FieldTest + ( test_field + ) where + +import ClassyPrelude + +import UI.Field (Field (Field), backspace, cursorPosition, insertCharacter, insertText, + updateCursor, wrap) + +import Test.Tasty +import Test.Tasty.HUnit + +width :: Int +width = 30 + +cursorPosition' :: Text -> Int -> (Int, Int) +cursorPosition' text cursor = cursorPosition wrapped width (cursor - offset) + where + (wrapped, offset) = wrap width text + +test_field :: TestTree +test_field = + testGroup + "UI.Field" + [ testGroup + "Field cursor left" + [ testCase + "Standard" + (assertEqual + "Should move left" + (Field "Blah" 1) + (updateCursor (-1) (Field "Blah" 2))) + , testCase + "Out of bounds" + (assertEqual + "Should stay 0" + (Field "Blah" 0) + (updateCursor (-1) (Field "Blah" 0))) + ] + , testGroup + "Field cursor right" + [ testCase + "Standard" + (assertEqual + "Should move right" + (Field "Blah" 3) + (updateCursor 1 (Field "Blah" 2))) + , testCase + "At end" + (assertEqual + "Should move right" + (Field "Blah" 4) + (updateCursor 1 (Field "Blah" 3))) + , testCase + "Out of bounds" + (assertEqual "Should stay" (Field "Blah" 4) (updateCursor 1 (Field "Blah" 4))) + ] + , testGroup + "Field insert character" + [ testCase + "At end" + (assertEqual + "Should insert character at end" + (Field "Blahs" 5) + (insertCharacter 's' (Field "Blah" 4))) + , testCase + "At beginning" + (assertEqual + "Should insert character at beginning" + (Field "sBlah" 1) + (insertCharacter 's' (Field "Blah" 0))) + ] + , testGroup + "Field backspace" + [ testCase + "At end" + (assertEqual + "Should remove last character" + (Field "Bla" 3) + (backspace (Field "Blah" 4))) + , testCase + "At beginning" + (assertEqual + "Should stay the same" + (Field "Blah" 0) + (backspace (Field "Blah" 0))) + , testCase + "In middle" + (assertEqual "Should remove middle" (Field "Bah" 1) (backspace (Field "Blah" 2))) + ] + , testGroup + "Field insert text" + [ testCase + "At end" + (assertEqual + "Should insert text at end" + (Field "Blah hello" 10) + (insertText " hello" (Field "Blah" 4))) + , testCase + "At beginning" + (assertEqual + "Should insert text at beginning" + (Field "Hello Blah" 6) + (insertText "Hello " (Field "Blah" 0))) + ] + , testGroup + "Cursor position" + [ testCase + "Empty" + (assertEqual "Should be at beginning" (0, 0) (cursorPosition' "" 0)) + , testCase + "First line" + (assertEqual + "Should be on first line" + (14, 0) + (cursorPosition' "Blah blah blah" 14)) + , testCase + "Half way along" + (assertEqual + "Should be on first line" + (7, 0) + (cursorPosition' "Blah blah blah" 7)) + , testCase + "End of line" + (assertEqual + "Should be on first line" + (29, 0) + (cursorPosition' "Blah blah blah blah blah blah" 29)) + , testCase + "End of line wrap" + (assertEqual + "Should wrap" + (0, 1) + (cursorPosition' "Blah blah blah blah blah blahs" 30)) + , testCase + "End of line with space wrap" + (assertEqual + "Should wrap" + (0, 1) + (cursorPosition' "Blah blah blah blah blah blah " 30)) + , testCase + "Long words" + (assertEqual + "Should wrap to correct position" + (6, 1) + (cursorPosition' "Artichoke penguin astronaut wombat" 34)) + , testCase + "Long words with space" + (assertEqual + "Should ignore the space when counting" + (16, 1) + (cursorPosition' "Blah fish wombat monkey sponge catpult arsonist" 47)) + ] + ]