diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -297,7 +297,7 @@ title.fg = green ; status bar -statusBar.bg = magenta +statusBar.bg = blue statusBar.fg = black ; current list title @@ -305,6 +305,17 @@ ; current task taskCurrent.fg = magenta + +; subtasks +; selected +subtaskCurrent.fg = magenta +; incomplete +subtaskIncomplete.fg = blue +; complete +subtaskComplete.fg = yellow + +; disabled +disabled.fg = yellow ``` You can also change the background and default text colour: diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} - module Main where import ClassyPrelude @@ -8,10 +6,10 @@ import Data.Time.Zones (loadLocalTZ) -import App (go) -import Events.State (create) -import IO.Config (setup) -import IO.Taskell (IOInfo (IOInfo), Next (..), load) +import Taskell (go) +import Taskell.Events.State (create) +import Taskell.IO (IOInfo (IOInfo), Next (..), load) +import Taskell.IO.Config (setup) main :: IO () main = do diff --git a/src/App.hs b/src/App.hs deleted file mode 100644 --- a/src/App.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TupleSections #-} - -module App - ( go - ) where - -import ClassyPrelude - -import Control.Concurrent (forkIO, threadDelay) - -import Control.Lens ((^.)) - -import Data.Time.Zones (TZ) - -import Brick -import Brick.BChan (BChan, newBChan, writeBChan) -import Graphics.Vty (Mode (BracketedPaste), defaultConfig, displayBounds, mkVty, - outputIface, setMode, supportsMode) -import Graphics.Vty.Input.Events (Event (..)) - -import qualified Control.FoldDebounce as Debounce - -import Data.Taskell.Lists (Lists) -import Events.Actions (ActionSets, event, generateActions) -import Events.State (continue, countCurrent, setHeight, setTime) -import Events.State.Types (State, current, io, lists, mode, path, searchTerm, timeZone) -import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..)) -import IO.Config (Config, debugging, generateAttrMap, getBindings, layout) -import IO.Taskell (writeData) -import Types (ListIndex (..), TaskIndex (..)) -import UI.Draw (chooseCursor, draw) -import UI.Types (ResourceName (..)) - -type DebouncedMessage = (Lists, FilePath, TZ) - -type DebouncedWrite = DebouncedMessage -> IO () - -type Trigger = Debounce.Trigger DebouncedMessage DebouncedMessage - --- tick -data TaskellEvent = - Tick - -oneSecond :: Int -oneSecond = 1000000 - -frequency :: Int -frequency = 60 * oneSecond - -timer :: BChan TaskellEvent -> IO () -timer chan = - void . forkIO . forever $ do - writeBChan chan Tick - threadDelay frequency - --- store -store :: Config -> DebouncedMessage -> IO () -store config (ls, pth, tz) = writeData tz 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, state ^. timeZone) - 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 = flip const - , Debounce.init = (initial ^. lists, initial ^. path, initial ^. timeZone) - } - Debounce.def - let send = Debounce.send trigger - pure (send, trigger) - --- cache clearing -clearCache :: State -> EventM ResourceName () -clearCache state = do - let (ListIndex li, TaskIndex ti) = state ^. current - invalidateCacheEntry (RNList li) - invalidateCacheEntry (RNTask (ListIndex li, TaskIndex ti)) - -clearAllTitles :: State -> EventM ResourceName () -clearAllTitles state = do - let count = length (state ^. lists) - let range = [0 .. (count - 1)] - traverse_ (invalidateCacheEntry . RNList) range - traverse_ (invalidateCacheEntry . RNTask . (, TaskIndex (-1)) . ListIndex) range - -clearList :: State -> EventM ResourceName () -clearList state = do - let (ListIndex list, _) = state ^. current - let count = countCurrent state - let range = [0 .. (count - 1)] - invalidateCacheEntry $ RNList list - traverse_ (invalidateCacheEntry . RNTask . (,) (ListIndex list) . TaskIndex) range - -clearDue :: State -> EventM ResourceName () -clearDue state = - case state ^. mode of - Modal (Due dues _) -> do - let range = [0 .. (length dues + 1)] - traverse_ (invalidateCacheEntry . RNDue) range - _ -> pure () - --- event handling -handleVtyEvent :: - (DebouncedWrite, Trigger) -> ActionSets -> State -> Event -> EventM ResourceName (Next State) -handleVtyEvent (send, trigger) actions previousState e = do - let state = event actions e previousState - when (previousState ^. searchTerm /= state ^. searchTerm) invalidateCache - case previousState ^. mode of - (Modal MoveTo) -> clearAllTitles previousState - (Insert ITask ICreate _) -> clearList previousState - _ -> pure () - case state ^. mode of - Shutdown -> liftIO (Debounce.close trigger) *> Brick.halt state - (Modal Due {}) -> clearDue state *> next send state - (Modal MoveTo) -> clearAllTitles state *> next send state - (Insert ITask ICreate _) -> clearList state *> next send state - _ -> clearCache previousState *> clearCache state *> next send state - -getHeight :: EventM ResourceName Int -getHeight = snd <$> (liftIO . displayBounds =<< outputIface <$> getVtyHandle) - -handleEvent :: - (DebouncedWrite, Trigger) - -> ActionSets - -> State - -> BrickEvent ResourceName TaskellEvent - -> EventM ResourceName (Next State) -handleEvent _ _ state (AppEvent Tick) = do - t <- liftIO getCurrentTime - Brick.continue $ setTime t state -handleEvent _ _ state (VtyEvent (EvResize _ _)) = do - invalidateCache - h <- getHeight - Brick.continue (setHeight h state) -handleEvent db actions state (VtyEvent ev) = handleVtyEvent db actions state ev -handleEvent _ _ state _ = Brick.continue state - --- | Runs when the app starts --- Adds paste support -appStart :: State -> EventM ResourceName State -appStart state = do - output <- outputIface <$> getVtyHandle - when (supportsMode output BracketedPaste) . liftIO $ setMode output BracketedPaste True - h <- getHeight - pure (setHeight h state) - --- | Sets up Brick -go :: Config -> State -> IO () -go config initial = do - attrMap' <- const <$> generateAttrMap - -- setup debouncing - db <- debounce config initial - -- get bindings - bindings <- getBindings - -- setup timer channel - timerChan <- newBChan 1 - timer timerChan - -- create app - let app = - App - { appDraw = draw (layout config) bindings (debugging config) - , appChooseCursor = chooseCursor - , appHandleEvent = handleEvent db (generateActions bindings) - , appStartEvent = appStart - , appAttrMap = attrMap' - } - -- start - let builder = mkVty defaultConfig - initialVty <- builder - void $ customMain initialVty builder (Just timerChan) app initial diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Config where - -import ClassyPrelude - -import Data.FileEmbed (embedFile) - -version :: Text -version = "1.9.2" - -usage :: Text -usage = decodeUtf8 $(embedFile "templates/usage.txt") diff --git a/src/Data/Taskell/Date.hs b/src/Data/Taskell/Date.hs deleted file mode 100644 --- a/src/Data/Taskell/Date.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Taskell.Date - ( Day - , Deadline(..) - , Due(..) - , timeToText - , timeToDisplay - , timeToOutput - , timeToOutputLocal - , textToTime - , inputToTime - , isoToTime - , deadline - ) where - -import ClassyPrelude - -import Control.Monad.Fail (MonadFail) - -import Data.Time.LocalTime (ZonedTime (ZonedTime)) -import Data.Time.Zones (TZ, localTimeToUTCTZ, timeZoneForUTCTime, utcToLocalTimeTZ) - -import Data.Time.Calendar (diffDays) -import Data.Time.Format (FormatTime, ParseTime, formatTime, iso8601DateFormat, parseTimeM) - -import Data.Taskell.Date.RelativeParser (parseRelative) -import Data.Taskell.Date.Types (Deadline (..), Due (..)) - --- formats -dateFormat :: String -dateFormat = "%Y-%m-%d" - -timeDisplayFormat :: String -timeDisplayFormat = "%Y-%m-%d %H:%M" - -timeFormat :: String -timeFormat = "%Y-%m-%d %H:%M %Z" - -isoFormat :: String -isoFormat = iso8601DateFormat (Just "%H:%M:%S%Q%Z") - --- utility functions -utcToZonedTime :: TZ -> UTCTime -> ZonedTime -utcToZonedTime tz time = ZonedTime (utcToLocalTimeTZ tz time) (timeZoneForUTCTime tz time) - -appendYear :: (FormatTime t, FormatTime s) => String -> t -> s -> String -appendYear txt t1 t2 = - if format "%Y" t1 == format "%Y" t2 - then txt - else txt <> " %Y" - --- output -format :: (FormatTime t) => String -> t -> Text -format fmt = pack . formatTime defaultTimeLocale fmt - -timeToText :: TZ -> UTCTime -> Due -> Text -timeToText _ now (DueDate day) = format fmt day - where - fmt = appendYear "%d-%b" now day -timeToText tz now (DueTime time) = format fmt local - where - local = utcToLocalTimeTZ tz time - fmt = appendYear "%H:%M %d-%b" now local - -timeToDisplay :: TZ -> Due -> Text -timeToDisplay _ (DueDate day) = format dateFormat day -timeToDisplay tz (DueTime time) = format timeDisplayFormat (utcToLocalTimeTZ tz time) - -timeToOutput :: Due -> Text -timeToOutput (DueDate day) = format dateFormat day -timeToOutput (DueTime time) = format timeFormat time - -timeToOutputLocal :: TZ -> Due -> Text -timeToOutputLocal _ (DueDate day) = format dateFormat day -timeToOutputLocal tz (DueTime time) = format timeFormat (utcToZonedTime tz time) - --- input -parseT :: (Monad m, MonadFail m, ParseTime t) => String -> Text -> m t -parseT fmt txt = parseTimeM False defaultTimeLocale fmt (unpack txt) - -parseDate :: Text -> Maybe Due -parseDate txt = DueDate <$> parseT dateFormat txt - -() :: Maybe a -> Maybe a -> Maybe a -() Nothing b = b -() a _ = a - -textToTime :: Text -> Maybe Due -textToTime txt = parseDate txt (DueTime <$> parseT timeFormat txt) - -inputToTime :: TZ -> UTCTime -> Text -> Maybe Due -inputToTime tz now txt = - parseDate txt (DueTime . localTimeToUTCTZ tz <$> parseT timeDisplayFormat txt) - case parseRelative now txt of - Right due -> Just due - Left _ -> Nothing - -isoToTime :: Text -> Maybe Due -isoToTime txt = DueTime <$> parseT isoFormat txt - --- deadlines -deadline :: UTCTime -> Due -> Deadline -deadline now date - | days < 0 = Passed - | days == 0 = Today - | days == 1 = Tomorrow - | days < 7 = ThisWeek - | otherwise = Plenty - where - days = - case date of - DueTime t -> diffDays (utctDay t) (utctDay now) - DueDate d -> diffDays d (utctDay now) diff --git a/src/Data/Taskell/Date/RelativeParser.hs b/src/Data/Taskell/Date/RelativeParser.hs deleted file mode 100644 --- a/src/Data/Taskell/Date/RelativeParser.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Taskell.Date.RelativeParser - ( parseRelative - ) where - -import ClassyPrelude - -import Data.Attoparsec.Text - -import Data.Time.Clock (addUTCTime) - -import Data.Taskell.Date.Types (Due (DueDate, DueTime)) -import Utility.Parser (lexeme, only) - --- utility functions -addP :: (Integral a) => Parser a -> UTCTime -> Parser UTCTime -addP p now = ($ now) . addUTCTime . fromIntegral . sum <$> many1 p - --- relative time parsing -minute :: Int -minute = 60 - -hour :: Int -hour = minute * 60 - -day :: Int -day = hour * 24 - -week :: Int -week = day * 7 - -timePeriodP :: Char -> Parser Int -timePeriodP c = lexeme decimal <* char c - -wP :: Parser Int -wP = (* week) <$> timePeriodP 'w' - -dP :: Parser Int -dP = (* day) <$> timePeriodP 'd' - -hP :: Parser Int -hP = (* hour) <$> timePeriodP 'h' - -mP :: Parser Int -mP = (* minute) <$> timePeriodP 'm' - -sP :: Parser Int -sP = timePeriodP 's' - -timeP :: UTCTime -> Parser (Maybe Due) -timeP now = only . lexeme $ Just . DueTime <$> addP (sP <|> mP <|> hP <|> dP <|> wP) now - --- relative date parsing -dateP :: UTCTime -> Parser (Maybe Due) -dateP now = only . lexeme $ Just . DueDate . utctDay <$> addP (dP <|> wP) now - --- relative parser -relativeP :: UTCTime -> Parser (Maybe Due) -relativeP now = dateP now <|> timeP now - -parseRelative :: UTCTime -> Text -> Either Text Due -parseRelative now text = - case parseOnly (relativeP now) text of - Right (Just due) -> Right due - _ -> Left "Could not parse date." diff --git a/src/Data/Taskell/Date/Types.hs b/src/Data/Taskell/Date/Types.hs deleted file mode 100644 --- a/src/Data/Taskell/Date/Types.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Taskell.Date.Types - ( Deadline(..) - , Due(..) - ) where - -import ClassyPrelude - -data Due - = DueTime UTCTime - | DueDate Day - deriving (Show, Eq) - -instance Ord Due where - compare (DueTime t) (DueDate d) = t `compare` UTCTime d 0 - compare (DueDate d) (DueTime t) = UTCTime d 0 `compare` t - compare (DueDate d1) (DueDate d2) = d1 `compare` d2 - compare (DueTime t1) (DueTime t2) = t1 `compare` t2 - -data Deadline - = Passed - | Today - | Tomorrow - | ThisWeek - | Plenty - deriving (Show, Eq) diff --git a/src/Data/Taskell/List.hs b/src/Data/Taskell/List.hs deleted file mode 100644 --- a/src/Data/Taskell/List.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Taskell.List - ( List - , Update - , title - , tasks - , create - , empty - , due - , clearDue - , new - , count - , newAt - , duplicate - , append - , extract - , updateFn - , update - , move - , deleteTask - , getTask - , searchFor - , nextTask - , prevTask - , nearest - ) where - -import Data.Taskell.List.Internal diff --git a/src/Data/Taskell/List/Internal.hs b/src/Data/Taskell/List/Internal.hs deleted file mode 100644 --- a/src/Data/Taskell/List/Internal.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -module Data.Taskell.List.Internal where - -import ClassyPrelude - -import Control.Lens (element, 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, clearDue, contains, due, duplicate) -import Types (TaskIndex (TaskIndex)) - -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) - -due :: List -> Seq (TaskIndex, T.Task) -due list = catMaybes (filt S.<#> (list ^. tasks)) - where - filt int task = const (TaskIndex int, task) <$> task ^. T.due - -clearDue :: TaskIndex -> Update -clearDue (TaskIndex int) = updateFn int T.clearDue - -newAt :: Int -> Update -newAt idx = tasks %~ S.insertAt idx T.blank - -duplicate :: Int -> List -> Maybe List -duplicate idx list = do - task <- T.duplicate <$> getTask idx list - pure $ list & tasks %~ S.insertAt idx task - -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) - pure (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 -> Maybe Text -> List -> Maybe (List, Int) -move current dir term list = - case term of - Nothing -> (, bound list (current + dir)) <$> (list & tasks %%~ S.shiftBy current dir) - Just _ -> do - idx <- changeTask dir current term list - (, idx) <$> (list & tasks %%~ S.shiftBy current (idx - current)) - -deleteTask :: Int -> Update -deleteTask idx = tasks %~ deleteAt idx - -getTask :: Int -> List -> Maybe T.Task -getTask idx = (^? tasks . element idx) - -searchFor :: Text -> Update -searchFor text = tasks %~ filter (T.contains text) - -changeTask :: Int -> Int -> Maybe Text -> List -> Maybe Int -changeTask dir current term list = do - let next = current + dir - tsk <- getTask next list - case term of - Nothing -> Just next - Just trm -> - if T.contains trm tsk - then Just next - else changeTask dir next term list - -nextTask :: Int -> Maybe Text -> List -> Int -nextTask idx text lst = fromMaybe idx $ changeTask 1 idx text lst - -prevTask :: Int -> Maybe Text -> List -> Int -prevTask idx text lst = fromMaybe idx $ changeTask (-1) idx text lst - -closest :: Int -> Int -> Int -> Int -closest current previous next = - if (next - current) < (current - previous) - then next - else previous - -bound :: List -> Int -> Int -bound lst = S.bound (lst ^. tasks) - -nearest' :: Int -> Maybe Text -> List -> Maybe Int -nearest' current term lst = do - let prev = changeTask (-1) current term lst - let nxt = changeTask 1 current term lst - let comp idx = Just $ maybe idx (closest current idx) nxt - maybe nxt comp prev - -nearest :: Int -> Maybe Text -> List -> Int -nearest current term lst = idx - where - near = fromMaybe (-1) $ nearest' current term lst - idx = - case term of - Nothing -> bound lst current - Just txt -> maybe near (bool near current . T.contains txt) $ getTask current lst diff --git a/src/Data/Taskell/Lists.hs b/src/Data/Taskell/Lists.hs deleted file mode 100644 --- a/src/Data/Taskell/Lists.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Taskell.Lists - ( Lists - , initial - , updateLists - , count - , due - , clearDue - , 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 deleted file mode 100644 --- a/src/Data/Taskell/Lists/Internal.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module Data.Taskell.Lists.Internal where - -import ClassyPrelude - -import Control.Lens ((^.)) -import Data.Sequence as S (adjust', deleteAt, update, (!?), (|>)) - -import qualified Data.Taskell.List as L (List, Update, append, clearDue, count, due, empty, extract, - searchFor) -import qualified Data.Taskell.Seq as S -import qualified Data.Taskell.Task as T (Task, due) -import Types (ListIndex (ListIndex), Pointer, TaskIndex (TaskIndex)) - -type Lists = Seq L.List - -type Update = Lists -> Lists - -initial :: Lists -initial = fromList [L.empty "To Do", L.empty "Done"] - -updateLists :: Int -> L.List -> Update -updateLists = S.update - -count :: Int -> Lists -> Int -count idx tasks = maybe 0 L.count (tasks !? idx) - -due :: Lists -> Seq (Pointer, T.Task) -due lists = sortOn ((^. T.due) . snd) dues - where - format x lst = (\(y, t) -> ((ListIndex x, y), t)) <$> L.due lst - dues = concat $ format S.<#> lists - -clearDue :: Pointer -> Update -clearDue (idx, tsk) = updateFn idx (L.clearDue tsk) - -updateFn :: ListIndex -> L.Update -> Update -updateFn (ListIndex idx) fn = adjust' fn idx - -get :: Lists -> Int -> Maybe L.List -get = (!?) - -changeList :: Pointer -> Lists -> Int -> Maybe Lists -changeList (ListIndex list, TaskIndex idx) tasks dir = do - let next = list + dir - (from, task) <- L.extract idx =<< tasks !? list -- extract current task - to <- L.append task <$> tasks !? next -- get next list and append task - pure . updateLists next to $ updateLists list from tasks -- update lists - -newList :: Text -> Update -newList title = (|> L.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 = (L.searchFor text <$>) - -appendToLast :: T.Task -> Update -appendToLast task lists = - fromMaybe lists $ do - let idx = length lists - 1 - list <- L.append task <$> lists !? idx - pure $ 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 deleted file mode 100644 --- a/src/Data/Taskell/Seq.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Taskell.Seq where - -import ClassyPrelude - -import Data.Sequence (deleteAt, insertAt, mapWithIndex, (!?)) - -(<#>) :: (Int -> a -> b) -> Seq a -> Seq b -(<#>) = mapWithIndex - -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 - pure $ insertAt (idx + dir) current a - -bound :: Seq a -> Int -> Int -bound s i - | i < 0 = 0 - | i >= length s = pred (length s) - | otherwise = i diff --git a/src/Data/Taskell/Subtask.hs b/src/Data/Taskell/Subtask.hs deleted file mode 100644 --- a/src/Data/Taskell/Subtask.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Taskell.Subtask - ( Subtask - , Update - , new - , blank - , name - , complete - , toggle - , duplicate - ) where - -import Data.Taskell.Subtask.Internal diff --git a/src/Data/Taskell/Subtask/Internal.hs b/src/Data/Taskell/Subtask/Internal.hs deleted file mode 100644 --- a/src/Data/Taskell/Subtask/Internal.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# 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 - -duplicate :: Subtask -> Subtask -duplicate (Subtask n c) = Subtask n c diff --git a/src/Data/Taskell/Task.hs b/src/Data/Taskell/Task.hs deleted file mode 100644 --- a/src/Data/Taskell/Task.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Taskell.Task - ( Task - , Update - , name - , description - , due - , subtasks - , blank - , new - , create - , duplicate - , setDescription - , appendDescription - , setDue - , clearDue - , 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 deleted file mode 100644 --- a/src/Data/Taskell/Task/Internal.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# 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 (Due (..), inputToTime) -import qualified Data.Taskell.Subtask as ST (Subtask, Update, complete, duplicate, name) -import Data.Text (strip) -import Data.Time.Zones (TZ) - -data Task = Task - { _name :: Text - , _description :: Maybe Text - , _subtasks :: Seq ST.Subtask - , _due :: Maybe Due - } deriving (Show, Eq) - -type Update = Task -> Task - --- create lenses -$(makeLenses ''Task) - --- operations -create :: Text -> Maybe Due -> Maybe Text -> Seq ST.Subtask -> Task -create name' due' description' subtasks' = Task name' description' subtasks' due' - -blank :: Task -blank = Task "" Nothing empty Nothing - -new :: Text -> Task -new text = blank & (name .~ text) - -setDescription :: Text -> Update -setDescription text = - description .~ - if null (strip text) - then Nothing - else 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 :: TZ -> UTCTime -> Text -> Task -> Maybe Task -setDue tz now date task = - if null date - then Just (task & due .~ Nothing) - else (\d -> task & due ?~ d) <$> inputToTime tz now (strip date) - -clearDue :: Update -clearDue task = task & due .~ Nothing - -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 = - check (task ^. name) || maybe False check (task ^. description) || not (null sts) - where - check = isInfixOf (toLower text) . toLower - sts = filter check $ (^. ST.name) <$> (task ^. subtasks) - -isBlank :: Task -> Bool -isBlank task = - null (task ^. name) && - isNothing (task ^. description) && null (task ^. subtasks) && isNothing (task ^. due) - -duplicate :: Task -> Task -duplicate (Task n d st du) = Task n d (ST.duplicate <$> st) du diff --git a/src/Events/Actions.hs b/src/Events/Actions.hs deleted file mode 100644 --- a/src/Events/Actions.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Events.Actions - ( event - , generateActions - , ActionSets - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Graphics.Vty.Input.Events (Event (..)) - -import Events.State.Types (State, Stateful, mode) -import Events.State.Types.Mode (DetailMode (..), ModalType (..), Mode (..)) - -import IO.Keyboard (generate) -import IO.Keyboard.Types (Bindings, BoundActions) - -import qualified Events.Actions.Insert as Insert -import qualified Events.Actions.Modal as Modal -import qualified Events.Actions.Modal.Detail as Detail -import qualified Events.Actions.Modal.Due as Due -import qualified Events.Actions.Modal.Help as Help -import qualified Events.Actions.Normal as Normal -import qualified Events.Actions.Search as Search - --- takes an event and returns a Maybe State -event' :: Event -> Stateful --- for other events pass through to relevant modules -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 - _ -> pure state - --- returns new state if successful -event :: ActionSets -> Event -> State -> State -event actions e state = do - let mEv = - case state ^. mode of - Normal -> lookup e $ normal actions - Modal (Detail _ DetailNormal) -> lookup e $ detail actions - Modal Due {} -> lookup e $ due actions - Modal Help -> lookup e $ help actions - _ -> Nothing - fromMaybe state $ - case mEv of - Nothing -> event' e state - Just ev -> ev state - -data ActionSets = ActionSets - { normal :: BoundActions - , detail :: BoundActions - , help :: BoundActions - , due :: BoundActions - } - -generateActions :: Bindings -> ActionSets -generateActions bindings = - ActionSets - { normal = generate bindings Normal.events - , detail = generate bindings Detail.events - , help = generate bindings Help.events - , due = generate bindings Due.events - } diff --git a/src/Events/Actions/Insert.hs b/src/Events/Actions/Insert.hs deleted file mode 100644 --- a/src/Events/Actions/Insert.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# 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.Draw.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 - _ -> pure 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 - _ -> pure state -event e state = - pure $ - 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 deleted file mode 100644 --- a/src/Events/Actions/Modal.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# 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.Due as Due -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 - Modal Due {} -> Due.event e s - _ -> pure s diff --git a/src/Events/Actions/Modal/Detail.hs b/src/Events/Actions/Modal/Detail.hs deleted file mode 100644 --- a/src/Events/Actions/Modal/Detail.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} - -module Events.Actions.Modal.Detail - ( event - , events - ) where - -import ClassyPrelude - -import Events.Actions.Types as A (ActionType (..)) -import Events.State (clearDate, normalMode, quit, store, undo, write) -import Events.State.Modal.Detail as Detail -import Events.State.Types -import Events.State.Types.Mode (DetailItem (..), DetailMode (..)) -import Graphics.Vty.Input.Events -import IO.Keyboard.Types (Actions) -import qualified UI.Draw.Field as F (event) - -events :: Actions -events - -- general - = - [ (A.Quit, quit) - , (A.Undo, (write =<<) . undo) - , (A.Previous, previousSubtask) - , (A.Next, nextSubtask) - , (A.MoveUp, (write =<<) . (up =<<) . store) - , (A.MoveDown, (write =<<) . (down =<<) . store) - , (A.New, (Detail.insertMode =<<) . (Detail.lastSubtask =<<) . (Detail.newItem =<<) . store) - , (A.Edit, (Detail.insertMode =<<) . store) - , (A.Complete, (write =<<) . (setComplete =<<) . store) - , (A.Delete, (write =<<) . (Detail.remove =<<) . store) - , (A.DueDate, (editDue =<<) . store) - , (A.ClearDate, (write =<<) . (clearDate =<<) . store) - , (A.Detail, (editDescription =<<) . store) - ] - -normal :: Event -> Stateful -normal (EvKey KEsc _) = normalMode -normal _ = pure - -insert :: Event -> Stateful -insert (EvKey KEsc _) s = do - item <- getCurrentItem s - case item of - DetailDescription -> (write =<<) $ finishDescription s - DetailDate -> showDetail 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/Due.hs b/src/Events/Actions/Modal/Due.hs deleted file mode 100644 --- a/src/Events/Actions/Modal/Due.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedLists #-} - -module Events.Actions.Modal.Due - ( event - , events - ) where - -import ClassyPrelude - -import Events.Actions.Types as A (ActionType (..)) -import Events.State (normalMode, store, write) -import Events.State.Modal.Detail (showDetail) -import Events.State.Modal.Due (clearDate, goto, next, previous) -import Events.State.Types (Stateful) -import Graphics.Vty.Input.Events (Event (EvKey)) -import IO.Keyboard.Types (Actions) - -events :: Actions -events = - [ (A.Previous, previous) - , (A.Next, next) - , (A.Detail, (showDetail =<<) . goto) - , (A.ClearDate, (write =<<) . (clearDate =<<) . store) - ] - -event :: Event -> Stateful -event (EvKey _ _) = normalMode -event _ = pure diff --git a/src/Events/Actions/Modal/Help.hs b/src/Events/Actions/Modal/Help.hs deleted file mode 100644 --- a/src/Events/Actions/Modal/Help.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} - -module Events.Actions.Modal.Help - ( event - , events - ) where - -import ClassyPrelude -import Events.Actions.Types as A (ActionType (..)) -import Events.State -import Events.State.Types (Stateful) -import Graphics.Vty.Input.Events -import IO.Keyboard.Types (Actions) - -events :: Actions -events = [(A.Quit, quit)] - -event :: Event -> Stateful -event (EvKey _ _) = normalMode -event _ = pure diff --git a/src/Events/Actions/Modal/MoveTo.hs b/src/Events/Actions/Modal/MoveTo.hs deleted file mode 100644 --- a/src/Events/Actions/Modal/MoveTo.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# 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 _ = pure diff --git a/src/Events/Actions/Normal.hs b/src/Events/Actions/Normal.hs deleted file mode 100644 --- a/src/Events/Actions/Normal.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedLists #-} - -module Events.Actions.Normal - ( event - , events - ) where - -import ClassyPrelude hiding (delete) - -import Data.Char (isDigit) -import Events.Actions.Types as A (ActionType (..)) -import Events.State -import Events.State.Modal.Detail (editDue, showDetail) -import Events.State.Modal.Due (showDue) -import Events.State.Types (Stateful) -import Graphics.Vty.Input.Events -import IO.Keyboard.Types (Actions) - -events :: Actions -events - -- general - = - [ (A.Quit, quit) - , (A.Undo, (write =<<) . undo) - , (A.Redo, (write =<<) . redo) - , (A.Search, searchMode) - , (A.Help, showHelp) - , (A.Due, showDue) - -- navigation - , (A.Previous, previous) - , (A.Next, next) - , (A.Left, left) - , (A.Right, right) - , (A.Bottom, bottom) - , (A.Top, top) - -- new tasks - , (A.New, (startCreate =<<) . (newItem =<<) . store) - , (A.NewAbove, (startCreate =<<) . (above =<<) . store) - , (A.NewBelow, (startCreate =<<) . (below =<<) . store) - , (A.Duplicate, (next =<<) . (write =<<) . (duplicate =<<) . store) - -- editing tasks - , (A.Edit, (startEdit =<<) . store) - , (A.Clear, (startEdit =<<) . (clearItem =<<) . store) - , (A.Delete, (write =<<) . (delete =<<) . store) - , (A.Detail, showDetail) - , (A.DueDate, (editDue =<<) . (store =<<) . showDetail) - , (A.ClearDate, (write =<<) . (clearDate =<<) . store) - -- moving tasks - , (A.MoveUp, (write =<<) . (up =<<) . store) - , (A.MoveDown, (write =<<) . (down =<<) . store) - , (A.MoveLeft, (write =<<) . (bottom =<<) . (left =<<) . (moveLeft =<<) . store) - , (A.MoveRight, (write =<<) . (bottom =<<) . (right =<<) . (moveRight =<<) . store) - , (A.Complete, (write =<<) . (moveToLast =<<) . (clearDate =<<) . store) - , (A.MoveMenu, showMoveTo) - -- lists - , (A.ListNew, (createListStart =<<) . store) - , (A.ListEdit, (editListStart =<<) . store) - , (A.ListDelete, (write =<<) . (deleteCurrentList =<<) . store) - , (A.ListRight, (write =<<) . (listRight =<<) . store) - , (A.ListLeft, (write =<<) . (listLeft =<<) . store) - ] - --- Normal -event :: Event -> Stateful --- selecting lists -event (EvKey (KChar n) _) - | isDigit n = selectList n - | otherwise = pure -event (EvKey KEsc _) = clearSearch --- fallback -event _ = pure diff --git a/src/Events/Actions/Search.hs b/src/Events/Actions/Search.hs deleted file mode 100644 --- a/src/Events/Actions/Search.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# 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.Draw.Field as F (event) - -event :: Event -> Stateful -event (EvKey KEsc _) s = clearSearch =<< normalMode s -event (EvKey KEnter _) s = normalMode s -event e s = - case s ^. mode of - Search -> appendSearch (F.event e) s - _ -> pure s diff --git a/src/Events/Actions/Types.hs b/src/Events/Actions/Types.hs deleted file mode 100644 --- a/src/Events/Actions/Types.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Events.Actions.Types where - -import ClassyPrelude hiding (Left, Nothing, Right) - -data ActionType - = Quit - | Undo - | Redo - | Search - | Due - | Help - | Previous - | Next - | Left - | Right - | Bottom - | Top - | New - | NewAbove - | NewBelow - | Duplicate - | Edit - | Clear - | Delete - | Detail - | DueDate - | ClearDate - | MoveUp - | MoveDown - | MoveLeft - | MoveRight - | Complete - | MoveMenu - | ListNew - | ListEdit - | ListDelete - | ListRight - | ListLeft - | Nothing - deriving (Show, Eq, Ord, Enum) - -allActions :: [ActionType] -allActions = [toEnum 0 ..] - -read :: Text -> ActionType -read "quit" = Quit -read "undo" = Undo -read "redo" = Redo -read "search" = Search -read "due" = Due -read "help" = Help -read "previous" = Previous -read "next" = Next -read "left" = Left -read "right" = Right -read "bottom" = Bottom -read "top" = Top -read "new" = New -read "newAbove" = NewAbove -read "newBelow" = NewBelow -read "duplicate" = Duplicate -read "edit" = Edit -read "clear" = Clear -read "delete" = Delete -read "detail" = Detail -read "dueDate" = DueDate -read "clearDate" = ClearDate -read "moveUp" = MoveUp -read "moveDown" = MoveDown -read "moveLeft" = MoveLeft -read "moveRight" = MoveRight -read "complete" = Complete -read "moveMenu" = MoveMenu -read "listNew" = ListNew -read "listEdit" = ListEdit -read "listDelete" = ListDelete -read "listRight" = ListRight -read "listLeft" = ListLeft -read _ = Nothing diff --git a/src/Events/State.hs b/src/Events/State.hs deleted file mode 100644 --- a/src/Events/State.hs +++ /dev/null @@ -1,414 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Events.State - -- App - ( continue - , write - , setTime - , countCurrent - , setHeight - -- UI.Main - , normalise - -- Main - , create - -- Events.Actions.Normal - , quit - , startEdit - , startCreate - , createListStart - , editListStart - , deleteCurrentList - , clearItem - , clearDate - , above - , below - , bottom - , top - , previous - , duplicate - , next - , left - , right - , up - , down - , moveLeft - , moveRight - , moveToLast - , delete - , selectList - , listLeft - , listRight - , undo - , redo - , store - , searchMode - , clearSearch - , appendSearch - -- 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.Time.Zones (TZ) - -import qualified Data.Taskell.List as L (List, deleteTask, duplicate, getTask, move, nearest, new, - newAt, nextTask, prevTask, title, update) -import qualified Data.Taskell.Lists as Lists -import Data.Taskell.Task (Task, isBlank, name) -import Types - -import qualified Events.State.History as History (redo, store, undo) -import Events.State.Types -import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), - Mode (..)) -import UI.Draw.Field (Field, blankField, getText, textToField) - -type InternalStateful = State -> State - -create :: TZ -> UTCTime -> FilePath -> Lists.Lists -> State -create tz t p ls = - State - { _mode = Normal - , _history = fresh ls - , _path = p - , _io = Nothing - , _height = 0 - , _searchTerm = Nothing - , _time = t - , _timeZone = tz - } - --- app state -quit :: Stateful -quit = pure . (mode .~ Shutdown) - -continue :: State -> State -continue = io .~ Nothing - -store :: Stateful -store state = pure $ state & history %~ History.store - -undo :: Stateful -undo state = pure $ state & history %~ History.undo - -redo :: Stateful -redo state = pure $ state & history %~ History.redo - -setTime :: UTCTime -> State -> State -setTime t = time .~ t - -write :: Stateful -write state = pure $ state & (io ?~ (state ^. lists)) - --- createList -createList :: Stateful -createList state = - pure $ - 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 = pure . (mode .~ Insert IList ICreate blankField) - --- editList -editListStart :: Stateful -editListStart state = do - f <- textToField . (^. L.title) <$> getList state - pure $ state & mode .~ Insert IList IEdit f - -deleteCurrentList :: Stateful -deleteCurrentList state = - pure . fixIndex . setLists state $ Lists.delete (getCurrentList state) (state ^. lists) - --- insert -getCurrentTask :: State -> Maybe Task -getCurrentTask state = getList state >>= L.getTask (getIndex state) - -setCurrentTask :: Task -> Stateful -setCurrentTask task state = setList state . L.update (getIndex state) task <$> getList state - -setCurrentTaskText :: Text -> Stateful -setCurrentTaskText text state = - flip setCurrentTask state =<< (name .~ text) <$> getCurrentTask state - -startCreate :: Stateful -startCreate = pure . (mode .~ Insert ITask ICreate blankField) - -startEdit :: Stateful -startEdit state = do - field <- textToField . (^. name) <$> getCurrentTask state - pure $ 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) - _ -> pure state - -finishListTitle :: Stateful -finishListTitle state = - case state ^. mode of - Insert IList iMode f -> - setCurrentListTitle (getText f) $ state & (mode .~ Insert IList iMode blankField) - _ -> pure state - -normalMode :: Stateful -normalMode = pure . (mode .~ Normal) - -addToListAt :: Int -> Stateful -addToListAt offset state = do - let idx = getIndex state + offset - fixIndex . setList (setIndex state idx) . L.newAt idx <$> getList state - -above :: Stateful -above = addToListAt 0 - -below :: Stateful -below = addToListAt 1 - -newItem :: Stateful -newItem state = selectLast . setList state . L.new <$> getList state - -duplicate :: Stateful -duplicate state = setList state <$> (L.duplicate (getIndex state) =<< getList state) - -clearItem :: Stateful -clearItem = setCurrentTaskText "" - -clearDate :: Stateful -clearDate state = pure $ state & lists .~ Lists.clearDue (state ^. current) (state ^. lists) - -bottom :: Stateful -bottom = pure . selectLast - -selectLast :: InternalStateful -selectLast state = setIndex state (countCurrent state - 1) - -top :: Stateful -top = pure . selectFirst - -selectFirst :: InternalStateful -selectFirst state = setIndex state (0) - -removeBlank :: Stateful -removeBlank state = do - currentTask <- getCurrentTask state - (if isBlank currentTask - then delete - else pure) - state - --- moving --- -moveVertical :: Int -> Stateful -moveVertical dir state = do - (lst, idx) <- L.move (getIndex state) dir (getText <$> state ^. searchTerm) =<< getList state - pure $ setIndex (setList state lst) idx - -up :: Stateful -up = moveVertical (-1) - -down :: Stateful -down = moveVertical 1 - -moveHorizontal :: Int -> State -> Maybe State -moveHorizontal idx state = - fixIndex . setLists state <$> Lists.changeList (state ^. current) (state ^. lists) idx - -moveLeft :: Stateful -moveLeft = moveHorizontal (-1) - -moveRight :: Stateful -moveRight = moveHorizontal 1 - -moveToLast :: Stateful -moveToLast state = - if idx == cur - then pure state - else moveHorizontal (idx - cur) state - where - idx = length (state ^. lists) - 1 - cur = getCurrentList state - -selectList :: Char -> Stateful -selectList idx state = - pure $ - (if exists - then current .~ (ListIndex list, TaskIndex 0) - else id) - state - where - list = digitToInt idx - 1 - exists = Lists.exists list (state ^. lists) - --- removing -delete :: Stateful -delete state = fixIndex . setList state . L.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 .~ (ListIndex (getCurrentList state), TaskIndex idx) - -setCurrentList :: State -> Int -> State -setCurrentList state idx = state & current .~ (ListIndex idx, TaskIndex (getIndex state)) - -getIndex :: State -> Int -getIndex = showTaskIndex . snd . (^. current) - -changeTask :: (Int -> Maybe Text -> L.List -> Int) -> Stateful -changeTask fn state = do - list <- getList state - let idx = getIndex state - let term = getText <$> state ^. searchTerm - pure $ setIndex state (fn idx term list) - -next :: Stateful -next = changeTask L.nextTask - -previous :: Stateful -previous = changeTask L.prevTask - -left :: Stateful -left state = - pure . fixIndex . setCurrentList state $ - if list > 0 - then pred list - else 0 - where - list = getCurrentList state - -right :: Stateful -right state = - pure . fixIndex . setCurrentList state $ - if list < (count - 1) - then succ list - else list - where - list = getCurrentList state - count = length (state ^. lists) - -fixListIndex :: InternalStateful -fixListIndex state = - if listIdx - then state - else setCurrentList state (length lists' - 1) - where - lists' = state ^. lists - listIdx = Lists.exists (getCurrentList state) lists' - -fixIndex :: InternalStateful -fixIndex state = - case getList state of - Just list -> setIndex state (L.nearest idx trm list) - Nothing -> fixListIndex state - where - trm = getText <$> state ^. searchTerm - idx = getIndex state - --- tasks -getCurrentList :: State -> Int -getCurrentList = showListIndex . fst . (^. current) - -getList :: State -> Maybe L.List -getList state = Lists.get (state ^. lists) (getCurrentList state) - -setList :: State -> L.List -> State -setList state list = setLists state (Lists.updateLists (getCurrentList state) list (state ^. lists)) - -setCurrentListTitle :: Text -> Stateful -setCurrentListTitle text state = setList state . (L.title .~ text) <$> getList state - -setLists :: State -> Lists.Lists -> State -setLists state lists' = state & lists .~ lists' - -moveTo' :: Int -> Stateful -moveTo' li state = do - let cur = getCurrentList state - if li == cur || li < 0 || li >= length (state ^. lists) - then Nothing - else do - s <- moveHorizontal (li - cur) state - pure . selectLast $ setCurrentList s li - -moveTo :: Char -> Stateful -moveTo char = moveTo' (ord char - ord 'a') - --- 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 = pure . fixIndex $ (state & mode .~ Search) & searchTerm .~ sTerm - where - sTerm = pure (fromMaybe blankField (state ^. searchTerm)) - -clearSearch :: Stateful -clearSearch state = pure $ state & searchTerm .~ Nothing - -appendSearch :: (Field -> Field) -> Stateful -appendSearch genField state = do - let field = fromMaybe blankField (state ^. searchTerm) - pure . fixIndex $ state & searchTerm .~ pure (genField field) - --- help -showHelp :: Stateful -showHelp = pure . (mode .~ Modal Help) - -showMoveTo :: Stateful -showMoveTo state = const (state & mode .~ Modal MoveTo) <$> getCurrentTask state - --- view -setHeight :: Int -> State -> State -setHeight = (.~) height - --- more view - maybe shouldn't be in here... -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 diff --git a/src/Events/State/History.hs b/src/Events/State/History.hs deleted file mode 100644 --- a/src/Events/State/History.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RankNTypes #-} - -module Events.State.History - ( undo - , redo - , store - ) where - -import ClassyPrelude - -import Control.Lens (Lens', (&), (.~), (^.)) - -import Events.State.Types (History (History), future, past, present) - -λstack :: Lens' (History a) [a] -> History a -> [a] -λstack fn history = history ^. present : (history ^. fn) - -store :: History a -> History a -store history = history & past .~ λstack past history & future .~ empty - -undo :: History a -> History a -undo history = - case history ^. past of - [] -> history - (moment:xs) -> History xs moment (λstack future history) - -redo :: History a -> History a -redo history = - case history ^. future of - [] -> history - (moment:xs) -> History (λstack past history) moment xs diff --git a/src/Events/State/Modal/Detail.hs b/src/Events/State/Modal/Detail.hs deleted file mode 100644 --- a/src/Events/State/Modal/Detail.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# 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 - , up - , down - ) where - -import ClassyPrelude - -import Control.Lens ((&), (.~), (^.)) - -import Data.Taskell.Date (timeToDisplay) -import qualified Data.Taskell.Seq as S -import qualified Data.Taskell.Subtask as ST (blank, name, toggle) -import Data.Taskell.Task (Task, addSubtask, countSubtasks, description, due, - getSubtask, removeSubtask, setDescription, setDue, - subtasks, updateSubtask) -import Events.State (getCurrentTask, setCurrentTask) -import Events.State.Types (State, Stateful, mode, time, timeZone) -import Events.State.Types.Mode (DetailItem (..), DetailMode (..), ModalType (Detail), - Mode (Modal)) -import UI.Draw.Field (Field, blankField, getText, textToField) - -updateField :: (Field -> Field) -> Stateful -updateField fieldEvent s = - pure $ - 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 state = do - let tz = state ^. timeZone - let now = state ^. time - text <- getText <$> getField state - task <- setDue tz now text =<< getCurrentTask state - setCurrentTask task $ state & mode .~ Modal (Detail (DetailItem 0) DetailNormal) - -showDetail :: Stateful -showDetail s = do - _ <- getCurrentTask s - let i = fromMaybe 0 $ getCurrentSubtask s - pure $ 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 - pure $ state & mode .~ Modal (Detail DetailDescription (DetailInsert (textToField summ'))) - -editDue :: Stateful -editDue state = do - day <- (^. due) <$> getCurrentTask state - let tz = state ^. timeZone - let day' = maybe "" (timeToDisplay tz) day - pure $ 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) - --- moving tasks -moveVertical :: Int -> Stateful -moveVertical dir state = do - task <- getCurrentTask state - let tasks = task ^. subtasks - i <- getCurrentSubtask state - shifted <- S.shiftBy i dir tasks - state' <- setCurrentTask (task & subtasks .~ shifted) state - changeSubtask dir state' - -up :: Stateful -up = moveVertical (-1) - -down :: Stateful -down = moveVertical 1 diff --git a/src/Events/State/Modal/Due.hs b/src/Events/State/Modal/Due.hs deleted file mode 100644 --- a/src/Events/State/Modal/Due.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Events.State.Modal.Due - ( showDue - , clearDate - , previous - , next - , goto - ) where - -import ClassyPrelude - -import Control.Lens ((&), (.~), (^.)) -import Data.Sequence ((!?)) - -import qualified Data.Taskell.Lists as L (clearDue, due) -import Data.Taskell.Seq (bound) -import Data.Taskell.Task (Task) -import Events.State.Types (Stateful, current, lists, mode) -import Events.State.Types.Mode (ModalType (Due), Mode (..)) -import Types (Pointer) - -type DueStateful = Seq (Pointer, Task) -> Int -> Stateful - -λfilter :: DueStateful -> Stateful -λfilter fn state = - case state ^. mode of - Modal (Due due cur) -> fn due cur state - _ -> pure state - -λsetMode :: DueStateful -λsetMode due pos state = pure $ state & mode .~ Modal (Due due pos) - -λprevious :: DueStateful -λprevious due cur = λsetMode due (bound due (cur - 1)) - -λnext :: DueStateful -λnext due cur = λsetMode due (bound due (cur + 1)) - -λgoto :: DueStateful -λgoto due cur state = - case due !? cur of - Just (pointer, _) -> pure $ state & current .~ pointer - Nothing -> Nothing - -λclearDate :: DueStateful -λclearDate due cur state = - case due !? cur of - Just (pointer, _) -> do - let new = L.clearDue pointer (state ^. lists) - let dues = L.due new - λsetMode dues (bound dues cur) (state & lists .~ new) - Nothing -> Nothing - -showDue :: Stateful -showDue state = λsetMode (L.due (state ^. lists)) 0 state - -previous :: Stateful -previous = λfilter λprevious - -next :: Stateful -next = λfilter λnext - -goto :: Stateful -goto = λfilter λgoto - -clearDate :: Stateful -clearDate = λfilter λclearDate diff --git a/src/Events/State/Types.hs b/src/Events/State/Types.hs deleted file mode 100644 --- a/src/Events/State/Types.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} - -module Events.State.Types where - -import ClassyPrelude - -import Control.Lens (Lens', makeLenses) -import Control.Lens.Combinators (_1, _2) - -import Data.Time.Zones (TZ) - -import Data.Taskell.Lists (Lists) -import Types (Pointer, startPointer) -import UI.Draw.Field (Field) - -import qualified Events.State.Types.Mode as M (Mode) - -type Moment = (Pointer, Lists) - -data History a = History - { _past :: [a] - , _present :: a - , _future :: [a] - } deriving (Eq, Show) - -fresh :: Lists -> History Moment -fresh ls = History empty (startPointer, ls) empty - -data State = State - { _mode :: M.Mode - , _history :: History Moment - , _path :: FilePath - , _io :: Maybe Lists - , _height :: Int - , _searchTerm :: Maybe Field - , _time :: UTCTime - , _timeZone :: TZ - } deriving (Eq, Show) - --- create lenses -$(makeLenses ''State) - -$(makeLenses ''History) - -type Stateful = State -> Maybe State - -current :: Lens' State Pointer -current = history . present . _1 - -lists :: Lens' State Lists -lists = history . present . _2 diff --git a/src/Events/State/Types/Mode.hs b/src/Events/State/Types/Mode.hs deleted file mode 100644 --- a/src/Events/State/Types/Mode.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Events.State.Types.Mode where - -import ClassyPrelude - -import Data.Taskell.Task (Task) -import Types (Pointer) -import UI.Draw.Field (Field) - -data DetailMode - = DetailNormal - | DetailInsert Field - deriving (Eq, Show) - -data DetailItem - = DetailItem Int - | DetailDescription - | DetailDate - deriving (Eq, Show) - -data ModalType - = Help - | MoveTo - | Due (Seq (Pointer, Task)) - Int - | 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 - | Shutdown - deriving (Eq, Show) diff --git a/src/IO/Config.hs b/src/IO/Config.hs deleted file mode 100644 --- a/src/IO/Config.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} - -module IO.Config where - -import ClassyPrelude - -import qualified Data.Text.IO as T (readFile) -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, - getHomeDirectory) -import System.Environment (lookupEnv) - -import Brick (AttrMap) -import Brick.Themes (loadCustomizations, themeToAttrMap) -import Data.FileEmbed (embedFile) -import Data.Ini.Config - -import IO.Keyboard (addMissing, badMapping, defaultBindings) -import IO.Keyboard.Parser (bindings) -import IO.Keyboard.Types (Bindings) -import UI.Theme (defaultTheme) - -import qualified IO.Config.General as General -import qualified IO.Config.GitHub as GitHub -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 - } - -debugging :: Config -> Bool -debugging config = General.debug (general config) - -defaultConfig :: Config -defaultConfig = - Config - General.defaultConfig - Layout.defaultConfig - Markdown.defaultConfig - Trello.defaultConfig - GitHub.defaultConfig - -directoryName :: FilePath -directoryName = "taskell" - -legacyConfigPath :: IO FilePath -legacyConfigPath = ( "." <> directoryName) <$> getHomeDirectory - -xdgDefaultConfig :: IO FilePath -xdgDefaultConfig = ( ".config") <$> getHomeDirectory - -xdgConfigPath :: IO FilePath -xdgConfigPath = - ( directoryName) <$> (fromMaybe <$> xdgDefaultConfig <*> lookupEnv "XDG_CONFIG_HOME") - -getDir :: IO FilePath -getDir = legacyConfigPath >>= doesDirectoryExist >>= bool xdgConfigPath legacyConfigPath - -themePath :: FilePath -> FilePath -themePath = ( "theme.ini") - -configPath :: FilePath -> FilePath -configPath = ( "config.ini") - -bindingsPath :: FilePath -> FilePath -bindingsPath = ( "bindings.ini") - -setup :: IO Config -setup - -- create config dir - = do - dir <- getDir - createDirectoryIfMissing True dir - -- create config files - create (configPath dir) $(embedFile "templates/config.ini") - create (themePath dir) $(embedFile "templates/theme.ini") - create (bindingsPath dir) $(embedFile "templates/bindings.ini") - -- get config - getConfig - -create :: FilePath -> ByteString -> IO () -create path contents = doesFileExist path >>= flip unless (writeFile path contents) - -configParser :: IniParser Config -configParser = - Config <$> General.parser <*> Layout.parser <*> Markdown.parser <*> Trello.parser <*> - GitHub.parser - -getConfig :: IO Config -getConfig = do - content <- T.readFile =<< (configPath <$> getDir) - case parseIniFile content configParser of - Right config -> pure config - Left s -> putStrLn (pack $ "config.ini: " <> s) $> defaultConfig - -getBindings :: IO Bindings -getBindings = do - bnds <- bindings <$> (T.readFile =<< (bindingsPath <$> getDir)) - case addMissing <$> (badMapping =<< bnds) of - Right b -> pure b - Left err -> - putStrLn ("bindings.ini: " <> err <> " - using default bindings") $> defaultBindings - --- generate theme -generateAttrMap :: IO AttrMap -generateAttrMap = do - dir <- getDir - customizedTheme <- loadCustomizations (themePath dir) defaultTheme - case customizedTheme of - Right theme -> pure $ themeToAttrMap theme - Left s -> putStrLn (pack $ "theme.ini: " <> s) $> themeToAttrMap defaultTheme diff --git a/src/IO/Config/General.hs b/src/IO/Config/General.hs deleted file mode 100644 --- a/src/IO/Config/General.hs +++ /dev/null @@ -1,30 +0,0 @@ -module IO.Config.General - ( Config - , defaultConfig - , parser - , filename - , debug - ) where - -import ClassyPrelude - -import Data.Ini.Config - -import IO.Config.Parser (noEmpty) - -data Config = Config - { filename :: FilePath - , debug :: Bool - } - -defaultConfig :: Config -defaultConfig = Config {filename = "taskell.md", debug = False} - -filenameP :: SectionParser String -filenameP = maybe (filename defaultConfig) unpack . (noEmpty =<<) <$> fieldMb "filename" - -debugP :: SectionParser Bool -debugP = fieldFlagDef "debug" False - -parser :: IniParser Config -parser = fromMaybe defaultConfig <$> sectionMb "general" (Config <$> filenameP <*> debugP) diff --git a/src/IO/Config/GitHub.hs b/src/IO/Config/GitHub.hs deleted file mode 100644 --- a/src/IO/Config/GitHub.hs +++ /dev/null @@ -1,25 +0,0 @@ -module IO.Config.GitHub - ( Config - , defaultConfig - , parser - , token - ) where - -import ClassyPrelude - -import Data.Ini.Config - -import IO.HTTP.GitHub (GitHubToken) - -data Config = Config - { token :: Maybe GitHubToken - } - -defaultConfig :: Config -defaultConfig = Config {token = Nothing} - -tokenP :: SectionParser (Maybe GitHubToken) -tokenP = fieldMb "token" - -parser :: IniParser Config -parser = fromMaybe defaultConfig <$> sectionMb "github" (Config <$> tokenP) diff --git a/src/IO/Config/Layout.hs b/src/IO/Config/Layout.hs deleted file mode 100644 --- a/src/IO/Config/Layout.hs +++ /dev/null @@ -1,54 +0,0 @@ -module IO.Config.Layout - ( Config - , defaultConfig - , parser - , padding - , columnWidth - , columnPadding - , descriptionIndicator - , statusBar - ) where - -import ClassyPrelude - -import Data.Ini.Config - -import IO.Config.Parser (noEmpty, parseText) - -data Config = Config - { padding :: Int - , columnWidth :: Int - , columnPadding :: Int - , descriptionIndicator :: Text - , statusBar :: Bool - } - -defaultConfig :: Config -defaultConfig = - Config - {padding = 1, columnWidth = 30, columnPadding = 3, descriptionIndicator = "≡", statusBar = True} - -paddingP :: SectionParser Int -paddingP = fromMaybe (padding defaultConfig) <$> fieldMbOf "padding" number - -columnWidthP :: SectionParser Int -columnWidthP = fromMaybe (columnWidth defaultConfig) <$> fieldMbOf "column_width" number - -columnPaddingP :: SectionParser Int -columnPaddingP = fromMaybe (columnPadding defaultConfig) <$> fieldMbOf "column_padding" number - -descriptionIndicatorP :: SectionParser Text -descriptionIndicatorP = - fromMaybe (descriptionIndicator defaultConfig) . (noEmpty . parseText =<<) <$> - fieldMb "description_indicator" - -statusBarP :: SectionParser Bool -statusBarP = fieldFlagDef "statusbar" (statusBar defaultConfig) - -parser :: IniParser Config -parser = - fromMaybe defaultConfig <$> - sectionMb - "layout" - (Config <$> paddingP <*> columnWidthP <*> columnPaddingP <*> descriptionIndicatorP <*> - statusBarP) diff --git a/src/IO/Config/Markdown.hs b/src/IO/Config/Markdown.hs deleted file mode 100644 --- a/src/IO/Config/Markdown.hs +++ /dev/null @@ -1,66 +0,0 @@ -module IO.Config.Markdown - ( Config(Config) - , defaultConfig - , parser - , titleOutput - , taskOutput - , descriptionOutput - , dueOutput - , subtaskOutput - , localTimes - ) 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 - , localTimes :: Bool - } - -defaultConfig :: Config -defaultConfig = - Config - { titleOutput = "##" - , taskOutput = "-" - , descriptionOutput = " >" - , dueOutput = " @" - , subtaskOutput = " *" - , localTimes = False - } - -titleOutputP :: SectionParser Text -titleOutputP = fromMaybe (titleOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "title" - -taskOutputP :: SectionParser Text -taskOutputP = fromMaybe (taskOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "task" - -descriptionOutputP :: SectionParser Text -descriptionOutputP = - fromMaybe (descriptionOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "summary" - -dueOutputP :: SectionParser Text -dueOutputP = fromMaybe (dueOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "due" - -subtaskOutputP :: SectionParser Text -subtaskOutputP = - fromMaybe (subtaskOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "subtask" - -localTimesP :: SectionParser Bool -localTimesP = fieldFlagDef "localTimes" (localTimes defaultConfig) - -parser :: IniParser Config -parser = - fromMaybe defaultConfig <$> - sectionMb - "markdown" - (Config <$> titleOutputP <*> taskOutputP <*> descriptionOutputP <*> dueOutputP <*> - subtaskOutputP <*> - localTimesP) diff --git a/src/IO/Config/Parser.hs b/src/IO/Config/Parser.hs deleted file mode 100644 --- a/src/IO/Config/Parser.hs +++ /dev/null @@ -1,12 +0,0 @@ -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 deleted file mode 100644 --- a/src/IO/Config/Trello.hs +++ /dev/null @@ -1,25 +0,0 @@ -module IO.Config.Trello - ( Config - , defaultConfig - , parser - , token - ) where - -import ClassyPrelude - -import Data.Ini.Config - -import IO.HTTP.Trello (TrelloToken) - -data Config = Config - { token :: Maybe TrelloToken - } - -defaultConfig :: Config -defaultConfig = Config {token = Nothing} - -tokenP :: SectionParser (Maybe TrelloToken) -tokenP = fieldMb "token" - -parser :: IniParser Config -parser = fromMaybe defaultConfig <$> sectionMb "trello" (Config <$> tokenP) diff --git a/src/IO/HTTP/Aeson.hs b/src/IO/HTTP/Aeson.hs deleted file mode 100644 --- a/src/IO/HTTP/Aeson.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/IO/HTTP/GitHub.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# 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.AutomatedCard (automatedCardToTask) -import IO.HTTP.GitHub.Card (MaybeCard, content_url, maybeCardToTask) -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) -import Data.Taskell.Task (Task) - -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 - pure - [ ("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 -> pure (getResponseStatusCode response, responses) - Just lnk -> fetch' responses lnk - -fetch :: Text -> ReaderGitHubToken (Int, [ByteString]) -fetch = fetch' [] - -fetchContent :: MaybeCard -> ReaderGitHubToken (Either Text Task) -fetchContent card = - case maybeCardToTask card of - Just tsk -> pure $ Right tsk - Nothing -> - case card ^. content_url of - Nothing -> pure $ Left "Could not parse card" - Just url -> do - (_, body) <- fetch url - case headMay body of - Nothing -> pure $ Left "Could not find card content" - Just is -> - pure . first parseError $ automatedCardToTask <$> eitherDecodeStrict is - -getCards :: Text -> ReaderGitHubToken (Either Text [Task]) -getCards url = do - (status, body) <- fetch url - case status of - 200 -> - case concatEithers (eitherDecodeStrict <$> body) of - Right cards -> do - cds <- sequence (fetchContent <$> cards) - let (ls, rs) = partitionEithers cds - pure $ - if null ls - then Right rs - else Left (unlines ls) - Left err -> pure $ Left (parseError err) - 429 -> pure $ Left "Too many cards" - _ -> pure . Left $ tshow status <> " error while fetching " <> url - -addCard :: Column -> ReaderGitHubToken (Either Text List) -addCard column = do - cards <- getCards $ column ^. cardsURL - pure $ columnToList column <$> cards - -addCards :: [Column] -> ReaderGitHubToken (Either Text Lists) -addCards columns = (fromList <$>) . sequence <$> traverse addCard columns - -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 -> pure $ Left (parseError err) - 404 -> pure . Left $ "Could not find GitHub project ." - 401 -> pure . Left $ "You do not have permission to view GitHub project " <> url - _ -> pure . 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 -> pure $ 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 pure . Left $ concat ["\nNo projects found for ", identifier, "\n"] - else chooseProject projects - Left err -> pure $ Left (parseError err) - 404 -> - pure . Left $ - "Could not find GitHub org/repo. For organisation make sure you use 'orgs/' and for repos use 'repos//'" - 401 -> - pure . Left $ - "You do not have permission to view the GitHub projects for " <> identifier - _ -> pure . Left $ tshow status <> " error. Cannot fetch projects from GitHub." diff --git a/src/IO/HTTP/GitHub/AutomatedCard.hs b/src/IO/HTTP/GitHub/AutomatedCard.hs deleted file mode 100644 --- a/src/IO/HTTP/GitHub/AutomatedCard.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module IO.HTTP.GitHub.AutomatedCard - ( AutomatedCard(AutomatedCard) - , automatedCardToTask - ) where - -import ClassyPrelude - -import Control.Lens (makeLenses, (^.)) - -import qualified Data.Taskell.Task as T (Task, new, setDescription) -import IO.HTTP.Aeson (deriveFromJSON) -import IO.HTTP.GitHub.Utility (cleanUp) - -data AutomatedCard = AutomatedCard - { _title :: Text - , _body :: Text - } deriving (Eq, Show) - --- strip underscores from field labels -$(deriveFromJSON ''AutomatedCard) - --- create lenses -$(makeLenses ''AutomatedCard) - --- operations -automatedCardToTask :: AutomatedCard -> T.Task -automatedCardToTask automatedCard = T.setDescription (cleanUp (automatedCard ^. body)) task - where - task = T.new $ cleanUp (automatedCard ^. title) diff --git a/src/IO/HTTP/GitHub/Card.hs b/src/IO/HTTP/GitHub/Card.hs deleted file mode 100644 --- a/src/IO/HTTP/GitHub/Card.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module IO.HTTP.GitHub.Card - ( MaybeCard(MaybeCard) - , maybeCardToTask - , content_url - ) where - -import ClassyPrelude - -import Control.Lens (makeLenses, (^.)) - -import qualified Data.Taskell.Task as T (Task, new) -import IO.HTTP.Aeson (deriveFromJSON) -import IO.HTTP.GitHub.Utility (cleanUp) - -data MaybeCard = MaybeCard - { _note :: Maybe Text - , _content_url :: Maybe Text - } deriving (Eq, Show) - --- strip underscores from field labels -$(deriveFromJSON ''MaybeCard) - --- create lenses -$(makeLenses ''MaybeCard) - --- operations -maybeCardToTask :: MaybeCard -> Maybe T.Task -maybeCardToTask card = T.new . cleanUp <$> card ^. note diff --git a/src/IO/HTTP/GitHub/Column.hs b/src/IO/HTTP/GitHub/Column.hs deleted file mode 100644 --- a/src/IO/HTTP/GitHub/Column.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# 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 qualified Data.Taskell.List as L (List, create) -import qualified Data.Taskell.Task as T (Task) - -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 -> [T.Task] -> L.List -columnToList ls tasks = L.create (ls ^. name) (fromList tasks) diff --git a/src/IO/HTTP/GitHub/Project.hs b/src/IO/HTTP/GitHub/Project.hs deleted file mode 100644 --- a/src/IO/HTTP/GitHub/Project.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# 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/GitHub/Utility.hs b/src/IO/HTTP/GitHub/Utility.hs deleted file mode 100644 --- a/src/IO/HTTP/GitHub/Utility.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module IO.HTTP.GitHub.Utility - ( cleanUp - ) where - -import ClassyPrelude - -import Data.Text (replace) - -cleanUp :: Text -> Text -cleanUp txt = replace "\r" "" $ replace "\n" " " txt diff --git a/src/IO/HTTP/Trello.hs b/src/IO/HTTP/Trello.hs deleted file mode 100644 --- a/src/IO/HTTP/Trello.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# 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) - -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 - pure . 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 :: [List] -> Lists -trelloListsToLists ls = fromList $ listToList <$> ls - -fetch :: String -> IO (Int, ByteString) -fetch url = do - request <- parseRequest url - response <- httpBS request - pure (getResponseStatusCode response, getResponseBody response) - -getChecklist :: TrelloChecklistID -> ReaderTrelloToken (Either Text [ChecklistItem]) -getChecklist checklist = do - url <- checklistURL checklist - (status, body) <- lift $ fetch url - pure $ - 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 = traverse getChecklist (card ^. idChecklists) - -updateList :: List -> ReaderTrelloToken (Either Text List) -updateList l = (setCards l <$>) . sequence <$> traverse updateCard (l ^. cards) - -getChecklists :: [List] -> ReaderTrelloToken (Either Text [List]) -getChecklists ls = sequence <$> traverse updateList ls - -getLists :: TrelloBoardID -> ReaderTrelloToken (Either Text Lists) -getLists board = do - putStrLn "Fetching from Trello..." - url <- boardURL board - (status, body) <- lift $ fetch url - case status of - 200 -> - case eitherDecodeStrict body of - Right raw -> fmap trelloListsToLists <$> getChecklists raw - Left err -> pure . Left $ parseError err - 404 -> - pure . Left $ "Could not find Trello board " <> board <> ". Make sure the ID is correct" - 401 -> pure . Left $ "You do not have permission to view Trello board " <> board - _ -> pure . Left $ tshow status <> " error. Cannot fetch from Trello." diff --git a/src/IO/HTTP/Trello/Card.hs b/src/IO/HTTP/Trello/Card.hs deleted file mode 100644 --- a/src/IO/HTTP/Trello/Card.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module IO.HTTP.Trello.Card - ( Card - , idChecklists - , cardToTask - , setChecklists - ) where - -import ClassyPrelude - -import Control.Lens (makeLenses, (&), (.~), (^.)) - -import IO.HTTP.Aeson (deriveFromJSON) -import IO.HTTP.Trello.ChecklistItem (ChecklistItem, checklistItemToSubTask) - -import Data.Taskell.Date (isoToTime) -import qualified Data.Taskell.Task as T (Task, due, new, setDescription, subtasks) - -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 -cardToTask :: Card -> T.Task -cardToTask card = - task & T.due .~ isoToTime (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 deleted file mode 100644 --- a/src/IO/HTTP/Trello/ChecklistItem.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/IO/HTTP/Trello/List.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# 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) - -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 :: List -> L.List -listToList ls = L.create (ls ^. name) (fromList $ cardToTask <$> (ls ^. cards)) diff --git a/src/IO/Keyboard.hs b/src/IO/Keyboard.hs deleted file mode 100644 --- a/src/IO/Keyboard.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module IO.Keyboard - ( generate - , defaultBindings - , badMapping - , addMissing - ) where - -import ClassyPrelude hiding ((\\)) - -import Data.Bitraversable (bitraverse) -import Data.List ((\\)) - -import qualified Events.Actions.Types as A -import IO.Keyboard.Types - -generate :: Bindings -> Actions -> BoundActions -generate bindings actions = - mapFromList . catMaybes $ bitraverse bindingToEvent (`lookup` actions) <$> bindings - -badMapping :: Bindings -> Either Text Bindings -badMapping bindings = - if null result - then Right bindings - else Left "invalid mapping" - where - result = filter ((== A.Nothing) . snd) bindings - -addMissing :: Bindings -> Bindings -addMissing bindings = bindings <> replaced - where - bnd = A.Nothing : (snd <$> bindings) - result = A.allActions \\ bnd - replaced = concat $ replace <$> result - -replace :: A.ActionType -> Bindings -replace action = filter ((==) action . snd) defaultBindings - -defaultBindings :: Bindings -defaultBindings = - [ (BChar 'q', A.Quit) - , (BChar 'u', A.Undo) - , (BChar 'r', A.Redo) - , (BChar '/', A.Search) - , (BChar '!', A.Due) - , (BChar '?', A.Help) - , (BChar 'k', A.Previous) - , (BChar 'j', A.Next) - , (BChar 'h', A.Left) - , (BChar 'l', A.Right) - , (BChar 'G', A.Bottom) - , (BChar 'g', A.Top) - , (BChar 'a', A.New) - , (BChar 'O', A.NewAbove) - , (BChar 'o', A.NewBelow) - , (BChar '+', A.Duplicate) - , (BChar 'e', A.Edit) - , (BChar 'A', A.Edit) - , (BChar 'i', A.Edit) - , (BChar 'C', A.Clear) - , (BChar 'D', A.Delete) - , (BKey "Enter", A.Detail) - , (BChar '@', A.DueDate) - , (BKey "Backspace", A.ClearDate) - , (BChar 'K', A.MoveUp) - , (BChar 'J', A.MoveDown) - , (BChar 'H', A.MoveLeft) - , (BChar 'L', A.MoveRight) - , (BKey "Space", A.Complete) - , (BChar 'm', A.MoveMenu) - , (BChar 'N', A.ListNew) - , (BChar 'E', A.ListEdit) - , (BChar 'X', A.ListDelete) - , (BChar '>', A.ListRight) - , (BChar '<', A.ListLeft) - ] diff --git a/src/IO/Keyboard/Parser.hs b/src/IO/Keyboard/Parser.hs deleted file mode 100644 --- a/src/IO/Keyboard/Parser.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module IO.Keyboard.Parser where - -import ClassyPrelude - -import Data.Attoparsec.Text - -import Utility.Parser - -import Events.Actions.Types (ActionType, read) -import IO.Keyboard.Types - --- utility functions -commentP :: Parser () -commentP = lexeme $ skipMany ((char '#' <|> char ';') *> manyTill anyChar endOfLine) - -stripComments :: Parser a -> Parser a -stripComments p = lexeme $ commentP *> p <* commentP - --- ini parser -keyP :: Parser Binding -keyP = lexeme $ BKey <$> (char '<' *> word <* char '>') - -charP :: Parser Binding -charP = lexeme $ BChar <$> anyChar - -bindingP :: Parser [Binding] -bindingP = lexeme $ (keyP <|> charP) `sepBy` char ',' - -lineP :: Parser [(Binding, ActionType)] -lineP = - stripComments $ do - name <- read <$> word - _ <- lexeme $ char '=' - binds <- bindingP - pure $ (, name) <$> binds - -bindingsP :: Parser Bindings -bindingsP = stripComments $ concat <$> many' lineP - --- run parser -bindings :: Text -> Either Text Bindings -bindings ini = first (const "Could not parse keyboard bindings.") (parseOnly bindingsP ini) diff --git a/src/IO/Keyboard/Types.hs b/src/IO/Keyboard/Types.hs deleted file mode 100644 --- a/src/IO/Keyboard/Types.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module IO.Keyboard.Types where - -import ClassyPrelude - -import Data.Map.Strict (Map) -import Graphics.Vty.Input.Events (Event (..), Key (..)) - -import qualified Events.Actions.Types as A (ActionType) -import Events.State.Types (Stateful) - -data Binding - = BChar Char - | BKey Text - deriving (Eq, Ord) - -type Bindings = [(Binding, A.ActionType)] - -type Actions = Map A.ActionType Stateful - -type BoundActions = Map Event Stateful - -instance Show Binding where - show (BChar c) = singleton c - show (BKey "Up") = "↑" - show (BKey "Down") = "↓" - show (BKey "Left") = "←" - show (BKey "Right") = "→" - show (BKey name) = "<" <> unpack name <> ">" - -bindingsToText :: Bindings -> A.ActionType -> [Text] -bindingsToText bindings key = tshow . fst <$> toList (filterMap (== key) bindings) - -bindingToEvent :: Binding -> Maybe Event -bindingToEvent (BChar char) = pure $ EvKey (KChar char) [] -bindingToEvent (BKey "Space") = pure $ EvKey (KChar ' ') [] -bindingToEvent (BKey "Backspace") = pure $ EvKey KBS [] -bindingToEvent (BKey "Enter") = pure $ EvKey KEnter [] -bindingToEvent (BKey "Left") = pure $ EvKey KLeft [] -bindingToEvent (BKey "Right") = pure $ EvKey KRight [] -bindingToEvent (BKey "Up") = pure $ EvKey KUp [] -bindingToEvent (BKey "Down") = pure $ EvKey KDown [] -bindingToEvent _ = Nothing diff --git a/src/IO/Markdown.hs b/src/IO/Markdown.hs deleted file mode 100644 --- a/src/IO/Markdown.hs +++ /dev/null @@ -1,8 +0,0 @@ -module IO.Markdown - ( parse - , serialize - , MarkdownInfo(MarkdownInfo) - ) where - -import IO.Markdown.Parser (parse) -import IO.Markdown.Serializer (MarkdownInfo (MarkdownInfo), serialize) diff --git a/src/IO/Markdown/Parser.hs b/src/IO/Markdown/Parser.hs deleted file mode 100644 --- a/src/IO/Markdown/Parser.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module IO.Markdown.Parser - ( parse - ) where - -import ClassyPrelude - -import Data.Attoparsec.Text hiding (parse) - -import qualified Data.Taskell.Date as D (Due, textToTime) -import qualified Data.Taskell.List as L (List, create) -import qualified Data.Taskell.Lists as LS (Lists) -import qualified Data.Taskell.Subtask as ST (Subtask, new) -import qualified Data.Taskell.Task as T (Task, create) - -import IO.Config.Markdown (Config, descriptionOutput, dueOutput, subtaskOutput, taskOutput, - titleOutput) -import Utility.Parser (lexeme, line) - --- config symbol parsing -type Symbol = (Config -> Text) -> Parser () - -symP :: Config -> Symbol -symP config fn = string (fn config) *> char ' ' $> () - --- utility functions -emptyMay :: (MonoFoldable a) => a -> Maybe a -emptyMay a = - if null a - then Nothing - else Just a - --- parsers -subtaskCompleteP :: Parser Bool -subtaskCompleteP = (== 'x') <$> (char '[' *> (char 'x' <|> char ' ') <* char ']' <* char ' ') - -subtaskP :: Symbol -> Parser ST.Subtask -subtaskP sym = flip ST.new <$> (sym subtaskOutput *> subtaskCompleteP) <*> line - -taskDescriptionP :: Symbol -> Parser (Maybe Text) -taskDescriptionP sym = emptyMay <$> (intercalate "\n" <$> many' (sym descriptionOutput *> line)) - -dueP :: Symbol -> Parser (Maybe D.Due) -dueP sym = (D.textToTime =<<) <$> optional (sym dueOutput *> line) - -taskNameP :: Symbol -> Parser Text -taskNameP sym = sym taskOutput *> line - -taskP :: Symbol -> Parser T.Task -taskP sym = - T.create <$> taskNameP sym <*> dueP sym <*> taskDescriptionP sym <*> - (fromList <$> many' (subtaskP sym)) - -listTitleP :: Symbol -> Parser Text -listTitleP sym = lexeme $ sym titleOutput *> line - -listP :: Symbol -> Parser L.List -listP sym = L.create <$> listTitleP sym <*> (fromList <$> many' (taskP sym)) - -markdownP :: Symbol -> Parser LS.Lists -markdownP sym = fromList <$> many1 (listP sym) <* endOfInput - --- parse -parse :: Config -> Text -> Either Text LS.Lists -parse config txt = first (const "Could not parse file.") (parseOnly (markdownP (symP config)) txt) diff --git a/src/IO/Markdown/Serializer.hs b/src/IO/Markdown/Serializer.hs deleted file mode 100644 --- a/src/IO/Markdown/Serializer.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module IO.Markdown.Serializer - ( serialize - , MarkdownInfo(MarkdownInfo) - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import qualified Data.Text as T (splitOn) - -import Data.Time.Zones (TZ) - -import Data.Taskell.Date (Due, timeToOutput, timeToOutputLocal) -import Data.Taskell.List (List, tasks, title) -import Data.Taskell.Lists (Lists) -import qualified Data.Taskell.Subtask as ST (Subtask, complete, name) -import qualified Data.Taskell.Task as T (Task, description, due, name, subtasks) - -import IO.Config.Markdown (Config, descriptionOutput, dueOutput, localTimes, subtaskOutput, - taskOutput, titleOutput) - -data MarkdownInfo = MarkdownInfo - { mdTZ :: TZ - , mdConfig :: Config - } - -type ReaderMarkdown = Reader MarkdownInfo - --- utility functions -askConf :: (Config -> a) -> ReaderMarkdown a -askConf fn = fn <$> asks mdConfig - -strMay :: (Applicative m) => (a -> m Text) -> Maybe a -> m Text -strMay _ Nothing = pure "" -strMay fn (Just a) = fn a - -space :: Text -> Text -> Text -space symbol txt = symbol <> " " <> txt - -timeFn :: ReaderMarkdown (Due -> Text) -timeFn = bool timeToOutput <$> (timeToOutputLocal <$> asks mdTZ) <*> askConf localTimes - --- serializers -subtaskCompleteS :: Bool -> Text -subtaskCompleteS True = "[x]" -subtaskCompleteS False = "[ ]" - -subtaskS :: ST.Subtask -> ReaderMarkdown Text -subtaskS st = do - symbol <- askConf subtaskOutput - pure $ unwords [symbol, subtaskCompleteS (st ^. ST.complete), st ^. ST.name] - -subtasksS :: Seq ST.Subtask -> ReaderMarkdown Text -subtasksS sts = intercalate "\n" <$> sequence (subtaskS <$> sts) - -descriptionS :: Text -> ReaderMarkdown Text -descriptionS desc = do - symbol <- askConf descriptionOutput - pure . intercalate "\n" $ space symbol <$> T.splitOn "\n" desc - -dueS :: Due -> ReaderMarkdown Text -dueS due = do - symbol <- askConf dueOutput - fn <- timeFn - pure $ space symbol (fn due) - -nameS :: Text -> ReaderMarkdown Text -nameS desc = space <$> askConf taskOutput <*> pure desc - -taskS :: T.Task -> ReaderMarkdown Text -taskS t = - unlines . filter (/= "") <$> - sequence - [ nameS (t ^. T.name) - , strMay dueS (t ^. T.due) - , strMay descriptionS (t ^. T.description) - , subtasksS (t ^. T.subtasks) - ] - -listS :: List -> ReaderMarkdown Text -listS list = do - symbol <- askConf titleOutput - taskString <- concat <$> sequence (taskS <$> list ^. tasks) - pure . space symbol $ concat [list ^. title, "\n\n", taskString] - --- serialize -serialize :: Lists -> ReaderMarkdown Text -serialize ls = intercalate "\n" <$> sequence (listS <$> ls) diff --git a/src/IO/Taskell.hs b/src/IO/Taskell.hs deleted file mode 100644 --- a/src/IO/Taskell.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module IO.Taskell where - -import ClassyPrelude - -import Control.Monad.Reader (runReader) -import Data.FileEmbed (embedFile) -import Data.Text.Encoding (decodeUtf8With) -import System.Directory (doesFileExist, getCurrentDirectory) - -import Data.Time.Zones (TZ) - -import Config (usage, version) -import Data.Taskell.Lists (Lists, analyse, initial) - -import IO.Config (Config, general, github, markdown, 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 (MarkdownInfo (MarkdownInfo), parse, serialize) - -import qualified IO.HTTP.GitHub as GitHub (GitHubIdentifier, getLists) -import qualified IO.HTTP.Trello as Trello (TrelloBoardID, getLists) - -import UI.CLI (PromptYN (PromptYes), promptYN) - -data IOInfo = IOInfo - { ioTZ :: TZ - , ioConfig :: Config - } - -type ReaderConfig a = ReaderT IOInfo IO a - -data Next - = Output Text - | Error Text - | Load FilePath - Lists - | Exit - -parseArgs :: [Text] -> ReaderConfig Next -parseArgs ["-v"] = pure $ Output version -parseArgs ["-h"] = pure $ 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 <$> asks ioConfig) >>= loadFile -parseArgs _ = pure $ Error (unlines ["Invalid options", "", usage]) - -load :: ReaderConfig Next -load = getArgs >>= parseArgs - -colonic :: FilePath -> Text -> Text -colonic path = ((pack path <> ": ") <>) - -loadFile :: Text -> ReaderConfig Next -loadFile filepath = do - mPath <- exists filepath - case mPath of - Nothing -> pure Exit - Just path -> either (Error . colonic path) (Load path) <$> readData path - -loadRemote :: (token -> FilePath -> ReaderConfig Next) -> token -> Text -> ReaderConfig Next -loadRemote createFn identifier filepath = do - let path = unpack filepath - exists' <- fileExists path - if exists' - then pure $ Error (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 either (Error . colonic path) (Output . analyse filepath) <$> readData path - else pure $ Error (filepath <> " does not exist") - -createRemote :: - (Config -> Maybe token) - -> Text - -> (token -> ReaderT token IO (Either Text Lists)) - -> token - -> FilePath - -> ReaderConfig Next -createRemote tokenFn missingToken getFn identifier path = do - config <- asks ioConfig - tz <- asks ioTZ - case tokenFn config of - Nothing -> pure $ Error missingToken - Just token -> do - lists <- lift $ runReaderT (getFn identifier) token - case lists of - Left txt -> pure $ Error txt - Right ls -> - promptCreate path >>= - bool (pure Exit) (Load path ls <$ lift (writeData tz config ls path)) - -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 pure $ Just path - else promptCreate path >>= bool (pure Nothing) (Just path <$ createPath path) - -fileExists :: FilePath -> ReaderConfig Bool -fileExists path = lift $ doesFileExist path - -promptCreate :: FilePath -> ReaderConfig Bool -promptCreate path = do - cwd <- lift $ pack <$> getCurrentDirectory - lift $ promptYN PromptYes $ concat ["Create ", cwd, "/", pack path, "?"] - --- creates taskell file -createPath :: FilePath -> ReaderConfig () -createPath path = do - config <- asks ioConfig - tz <- asks ioTZ - lift (writeData tz config initial path) - --- writes Tasks to json file -writeData :: TZ -> Config -> Lists -> FilePath -> IO () -writeData tz config tasks path = void (writeFile path output) - where - output = encodeUtf8 $ runReader (serialize tasks) (MarkdownInfo tz (markdown config)) - --- reads json file -decodeError :: String -> Maybe Word8 -> Maybe Char -decodeError _ _ = Just '\65533' - -readData :: FilePath -> ReaderConfig (Either Text Lists) -readData path = - parse <$> (markdown <$> asks ioConfig) <*> (decodeUtf8With decodeError <$> readFile path) diff --git a/src/Taskell.hs b/src/Taskell.hs new file mode 100644 --- /dev/null +++ b/src/Taskell.hs @@ -0,0 +1,179 @@ +module Taskell + ( go + ) where + +import ClassyPrelude + +import Control.Concurrent (forkIO, threadDelay) + +import Control.Lens ((^.)) + +import Data.Time.Zones (TZ) + +import Brick +import Brick.BChan (BChan, newBChan, writeBChan) +import Graphics.Vty (Mode (BracketedPaste), defaultConfig, displayBounds, mkVty, + outputIface, setMode, supportsMode) +import Graphics.Vty.Input.Events (Event (..)) + +import qualified Control.FoldDebounce as Debounce + +import Taskell.Data.Lists (Lists) +import Taskell.Events.Actions (ActionSets, event, generateActions) +import Taskell.Events.State (continue, countCurrent, setHeight, setTime) +import Taskell.Events.State.Types (State, current, io, lists, mode, path, searchTerm, timeZone) +import Taskell.Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..)) +import Taskell.IO (writeData) +import Taskell.IO.Config (Config, debugging, generateAttrMap, getBindings, layout) +import Taskell.Types (ListIndex (..), TaskIndex (..)) +import Taskell.UI.Draw (chooseCursor, draw) +import Taskell.UI.Types (ResourceName (..)) + +type DebouncedMessage = (Lists, FilePath, TZ) + +type DebouncedWrite = DebouncedMessage -> IO () + +type Trigger = Debounce.Trigger DebouncedMessage DebouncedMessage + +-- tick +data TaskellEvent = + Tick + +oneSecond :: Int +oneSecond = 1000000 + +frequency :: Int +frequency = 60 * oneSecond + +timer :: BChan TaskellEvent -> IO () +timer chan = + void . forkIO . forever $ do + writeBChan chan Tick + threadDelay frequency + +-- store +store :: Config -> DebouncedMessage -> IO () +store config (ls, pth, tz) = writeData tz 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, state ^. timeZone) + Brick.continue $ Taskell.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 = flip const + , Debounce.init = (initial ^. lists, initial ^. path, initial ^. timeZone) + } + Debounce.def + let send = Debounce.send trigger + pure (send, trigger) + +-- cache clearing +clearCache :: State -> EventM ResourceName () +clearCache state = do + let (ListIndex li, TaskIndex ti) = state ^. current + invalidateCacheEntry (RNList li) + invalidateCacheEntry (RNTask (ListIndex li, TaskIndex ti)) + +clearAllTitles :: State -> EventM ResourceName () +clearAllTitles state = do + let count = length (state ^. lists) + let range = [0 .. (count - 1)] + traverse_ (invalidateCacheEntry . RNList) range + traverse_ (invalidateCacheEntry . RNTask . (, TaskIndex (-1)) . ListIndex) range + +clearList :: State -> EventM ResourceName () +clearList state = do + let (ListIndex list, _) = state ^. current + let count = countCurrent state + let range = [0 .. (count - 1)] + invalidateCacheEntry $ RNList list + traverse_ (invalidateCacheEntry . RNTask . (,) (ListIndex list) . TaskIndex) range + +clearDue :: State -> EventM ResourceName () +clearDue state = + case state ^. mode of + Modal (Due dues _) -> do + let range = [0 .. (length dues + 1)] + traverse_ (invalidateCacheEntry . RNDue) range + _ -> pure () + +-- event handling +handleVtyEvent :: + (DebouncedWrite, Trigger) -> ActionSets -> State -> Event -> EventM ResourceName (Next State) +handleVtyEvent (send, trigger) actions previousState e = do + let state = event actions e previousState + when (previousState ^. searchTerm /= state ^. searchTerm) invalidateCache + case previousState ^. mode of + (Modal MoveTo) -> clearAllTitles previousState + (Insert ITask ICreate _) -> clearList previousState + _ -> pure () + case state ^. mode of + Shutdown -> liftIO (Debounce.close trigger) *> Brick.halt state + (Modal Due {}) -> clearDue state *> next send state + (Modal MoveTo) -> clearAllTitles state *> next send state + (Insert ITask ICreate _) -> clearList state *> next send state + _ -> clearCache previousState *> clearCache state *> next send state + +getHeight :: EventM ResourceName Int +getHeight = snd <$> (liftIO . displayBounds =<< outputIface <$> getVtyHandle) + +handleEvent :: + (DebouncedWrite, Trigger) + -> ActionSets + -> State + -> BrickEvent ResourceName TaskellEvent + -> EventM ResourceName (Next State) +handleEvent _ _ state (AppEvent Tick) = do + t <- liftIO getCurrentTime + Brick.continue $ setTime t state +handleEvent _ _ state (VtyEvent (EvResize _ _)) = do + invalidateCache + h <- getHeight + Brick.continue (setHeight h state) +handleEvent db actions state (VtyEvent ev) = handleVtyEvent db actions state ev +handleEvent _ _ state _ = Brick.continue state + +-- | Runs when the app starts +-- Adds paste support +appStart :: State -> EventM ResourceName State +appStart state = do + output <- outputIface <$> getVtyHandle + when (supportsMode output BracketedPaste) . liftIO $ setMode output BracketedPaste True + h <- getHeight + pure (setHeight h state) + +-- | Sets up Brick +go :: Config -> State -> IO () +go config initial = do + attrMap' <- const <$> generateAttrMap + -- setup debouncing + db <- debounce config initial + -- get bindings + bindings <- getBindings + -- setup timer channel + timerChan <- newBChan 1 + timer timerChan + -- create app + let app = + App + { appDraw = draw (layout config) bindings (debugging config) + , appChooseCursor = chooseCursor + , appHandleEvent = handleEvent db (generateActions bindings) + , appStartEvent = appStart + , appAttrMap = attrMap' + } + -- start + let builder = mkVty defaultConfig + initialVty <- builder + void $ customMain initialVty builder (Just timerChan) app initial diff --git a/src/Taskell/Config.hs b/src/Taskell/Config.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Config.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.Config where + +import ClassyPrelude + +import Data.FileEmbed (embedFile) + +version :: Text +version = "1.9.3" + +usage :: Text +usage = decodeUtf8 $(embedFile "templates/usage.txt") diff --git a/src/Taskell/Data/Date.hs b/src/Taskell/Data/Date.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Date.hs @@ -0,0 +1,112 @@ +module Taskell.Data.Date + ( Day + , Deadline(..) + , Due(..) + , timeToText + , timeToDisplay + , timeToOutput + , timeToOutputLocal + , textToTime + , inputToTime + , isoToTime + , deadline + ) where + +import ClassyPrelude + +import Control.Monad.Fail (MonadFail) + +import Data.Time.LocalTime (ZonedTime (ZonedTime)) +import Data.Time.Zones (TZ, localTimeToUTCTZ, timeZoneForUTCTime, utcToLocalTimeTZ) + +import Data.Time.Calendar (diffDays) +import Data.Time.Format (FormatTime, ParseTime, iso8601DateFormat) + +import Taskell.Data.Date.RelativeParser (parseRelative) +import Taskell.Data.Date.Types (Deadline (..), Due (..)) + +-- formats +dateFormat :: String +dateFormat = "%Y-%m-%d" + +timeDisplayFormat :: String +timeDisplayFormat = "%Y-%m-%d %H:%M" + +timeFormat :: String +timeFormat = "%Y-%m-%d %H:%M %Z" + +isoFormat :: String +isoFormat = iso8601DateFormat (Just "%H:%M:%S%Q%Z") + +-- utility functions +utcToZonedTime :: TZ -> UTCTime -> ZonedTime +utcToZonedTime tz time = ZonedTime (utcToLocalTimeTZ tz time) (timeZoneForUTCTime tz time) + +appendYear :: (FormatTime t, FormatTime s) => String -> t -> s -> String +appendYear txt t1 t2 = + if format "%Y" t1 == format "%Y" t2 + then txt + else txt <> " %Y" + +-- output +format :: (FormatTime t) => String -> t -> Text +format fmt = pack . formatTime defaultTimeLocale fmt + +timeToText :: TZ -> UTCTime -> Due -> Text +timeToText _ now (DueDate day) = format fmt day + where + fmt = appendYear "%d-%b" now day +timeToText tz now (DueTime time) = format fmt local + where + local = utcToLocalTimeTZ tz time + fmt = appendYear "%H:%M %d-%b" now local + +timeToDisplay :: TZ -> Due -> Text +timeToDisplay _ (DueDate day) = format dateFormat day +timeToDisplay tz (DueTime time) = format timeDisplayFormat (utcToLocalTimeTZ tz time) + +timeToOutput :: Due -> Text +timeToOutput (DueDate day) = format dateFormat day +timeToOutput (DueTime time) = format timeFormat time + +timeToOutputLocal :: TZ -> Due -> Text +timeToOutputLocal _ (DueDate day) = format dateFormat day +timeToOutputLocal tz (DueTime time) = format timeFormat (utcToZonedTime tz time) + +-- input +parseT :: (Monad m, MonadFail m, ParseTime t) => String -> Text -> m t +parseT fmt txt = parseTimeM False defaultTimeLocale fmt (unpack txt) + +parseDate :: Text -> Maybe Due +parseDate txt = DueDate <$> parseT dateFormat txt + +() :: Maybe a -> Maybe a -> Maybe a +() Nothing b = b +() a _ = a + +textToTime :: Text -> Maybe Due +textToTime txt = parseDate txt (DueTime <$> parseT timeFormat txt) + +inputToTime :: TZ -> UTCTime -> Text -> Maybe Due +inputToTime tz now txt = + parseDate txt (DueTime . localTimeToUTCTZ tz <$> parseT timeDisplayFormat txt) + case parseRelative now txt of + Right due -> Just due + Left _ -> Nothing + +isoToTime :: Text -> Maybe Due +isoToTime txt = DueTime <$> parseT isoFormat txt + +-- deadlines +deadline :: UTCTime -> Due -> Deadline +deadline now date + | days < 0 = Passed + | days == 0 = Today + | days == 1 = Tomorrow + | days < 7 = ThisWeek + | otherwise = Plenty + where + days = + case date of + DueTime t -> diffDays (utctDay t) (utctDay now) + DueDate d -> diffDays d (utctDay now) diff --git a/src/Taskell/Data/Date/RelativeParser.hs b/src/Taskell/Data/Date/RelativeParser.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Date/RelativeParser.hs @@ -0,0 +1,64 @@ +module Taskell.Data.Date.RelativeParser + ( parseRelative + ) where + +import ClassyPrelude + +import Data.Attoparsec.Text + +import Data.Time.Clock (addUTCTime) + +import Taskell.Data.Date.Types (Due (DueDate, DueTime)) +import Taskell.Utility.Parser (lexeme, only) + +-- utility functions +addP :: (Integral a) => Parser a -> UTCTime -> Parser UTCTime +addP p now = ($ now) . addUTCTime . fromIntegral . sum <$> many1 p + +-- relative time parsing +minute :: Int +minute = 60 + +hour :: Int +hour = minute * 60 + +day :: Int +day = hour * 24 + +week :: Int +week = day * 7 + +timePeriodP :: Char -> Parser Int +timePeriodP c = lexeme decimal <* char c + +wP :: Parser Int +wP = (* week) <$> timePeriodP 'w' + +dP :: Parser Int +dP = (* day) <$> timePeriodP 'd' + +hP :: Parser Int +hP = (* hour) <$> timePeriodP 'h' + +mP :: Parser Int +mP = (* minute) <$> timePeriodP 'm' + +sP :: Parser Int +sP = timePeriodP 's' + +timeP :: UTCTime -> Parser (Maybe Due) +timeP now = only . lexeme $ Just . DueTime <$> addP (sP <|> mP <|> hP <|> dP <|> wP) now + +-- relative date parsing +dateP :: UTCTime -> Parser (Maybe Due) +dateP now = only . lexeme $ Just . DueDate . utctDay <$> addP (dP <|> wP) now + +-- relative parser +relativeP :: UTCTime -> Parser (Maybe Due) +relativeP now = dateP now <|> timeP now + +parseRelative :: UTCTime -> Text -> Either Text Due +parseRelative now text = + case parseOnly (relativeP now) text of + Right (Just due) -> Right due + _ -> Left "Could not parse date." diff --git a/src/Taskell/Data/Date/Types.hs b/src/Taskell/Data/Date/Types.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Date/Types.hs @@ -0,0 +1,25 @@ +module Taskell.Data.Date.Types + ( Deadline(..) + , Due(..) + ) where + +import ClassyPrelude + +data Due + = DueTime UTCTime + | DueDate Day + deriving (Show, Eq) + +instance Ord Due where + compare (DueTime t) (DueDate d) = t `compare` UTCTime d 0 + compare (DueDate d) (DueTime t) = UTCTime d 0 `compare` t + compare (DueDate d1) (DueDate d2) = d1 `compare` d2 + compare (DueTime t1) (DueTime t2) = t1 `compare` t2 + +data Deadline + = Passed + | Today + | Tomorrow + | ThisWeek + | Plenty + deriving (Show, Eq) diff --git a/src/Taskell/Data/List.hs b/src/Taskell/Data/List.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/List.hs @@ -0,0 +1,28 @@ +module Taskell.Data.List + ( List + , Update + , title + , tasks + , create + , empty + , due + , clearDue + , new + , count + , newAt + , duplicate + , append + , prepend + , extract + , updateFn + , update + , move + , deleteTask + , getTask + , searchFor + , nextTask + , prevTask + , nearest + ) where + +import Taskell.Data.List.Internal diff --git a/src/Taskell/Data/List/Internal.hs b/src/Taskell/Data/List/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/List/Internal.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.Data.List.Internal where + +import ClassyPrelude + +import Control.Lens (element, makeLenses, (%%~), (%~), (&), (.~), (^.), (^?)) + +import Data.Sequence as S (adjust', deleteAt, insertAt, update, (<|), (|>)) + +import qualified Taskell.Data.Seq as S +import qualified Taskell.Data.Task as T (Task, Update, blank, clearDue, contains, due, duplicate) +import Taskell.Types (TaskIndex (TaskIndex)) + +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) + +due :: List -> Seq (TaskIndex, T.Task) +due list = catMaybes (filt S.<#> (list ^. tasks)) + where + filt int task = const (TaskIndex int, task) <$> task ^. T.due + +clearDue :: TaskIndex -> Update +clearDue (TaskIndex int) = updateFn int T.clearDue + +newAt :: Int -> Update +newAt idx = tasks %~ S.insertAt idx T.blank + +duplicate :: Int -> List -> Maybe List +duplicate idx list = do + task <- T.duplicate <$> getTask idx list + pure $ list & tasks %~ S.insertAt idx task + +append :: T.Task -> Update +append task = tasks %~ (S.|> task) + +prepend :: T.Task -> Update +prepend task = tasks %~ (task S.<|) + +extract :: Int -> List -> Maybe (List, T.Task) +extract idx list = do + (xs, x) <- S.extract idx (list ^. tasks) + pure (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 -> Maybe Text -> List -> Maybe (List, Int) +move current dir term list = + case term of + Nothing -> (, bound list (current + dir)) <$> (list & tasks %%~ S.shiftBy current dir) + Just _ -> do + idx <- changeTask dir current term list + (, idx) <$> (list & tasks %%~ S.shiftBy current (idx - current)) + +deleteTask :: Int -> Update +deleteTask idx = tasks %~ deleteAt idx + +getTask :: Int -> List -> Maybe T.Task +getTask idx = (^? tasks . element idx) + +searchFor :: Text -> Update +searchFor text = tasks %~ filter (T.contains text) + +changeTask :: Int -> Int -> Maybe Text -> List -> Maybe Int +changeTask dir current term list = do + let next = current + dir + tsk <- getTask next list + case term of + Nothing -> Just next + Just trm -> + if T.contains trm tsk + then Just next + else changeTask dir next term list + +nextTask :: Int -> Maybe Text -> List -> Int +nextTask idx text lst = fromMaybe idx $ changeTask 1 idx text lst + +prevTask :: Int -> Maybe Text -> List -> Int +prevTask idx text lst = fromMaybe idx $ changeTask (-1) idx text lst + +closest :: Int -> Int -> Int -> Int +closest current previous next = + if (next - current) < (current - previous) + then next + else previous + +bound :: List -> Int -> Int +bound lst = S.bound (lst ^. tasks) + +nearest' :: Int -> Maybe Text -> List -> Maybe Int +nearest' current term lst = do + let prev = changeTask (-1) current term lst + let nxt = changeTask 1 current term lst + let comp idx = Just $ maybe idx (closest current idx) nxt + maybe nxt comp prev + +nearest :: Int -> Maybe Text -> List -> Int +nearest current term lst = idx + where + near = fromMaybe (-1) $ nearest' current term lst + idx = + case term of + Nothing -> bound lst current + Just txt -> maybe near (bool near current . T.contains txt) $ getTask current lst diff --git a/src/Taskell/Data/Lists.hs b/src/Taskell/Data/Lists.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Lists.hs @@ -0,0 +1,20 @@ +module Taskell.Data.Lists + ( Lists + , ListPosition(..) + , initial + , updateLists + , count + , due + , clearDue + , get + , changeList + , newList + , delete + , exists + , shiftBy + , search + , appendToLast + , analyse + ) where + +import Taskell.Data.Lists.Internal diff --git a/src/Taskell/Data/Lists/Internal.hs b/src/Taskell/Data/Lists/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Lists/Internal.hs @@ -0,0 +1,89 @@ +module Taskell.Data.Lists.Internal where + +import ClassyPrelude + +import Control.Lens ((^.)) +import Data.Sequence as S (adjust', deleteAt, update, (!?), (|>)) + +import qualified Taskell.Data.List as L (List, Update, append, clearDue, count, due, empty, extract, + prepend, searchFor) +import qualified Taskell.Data.Seq as S +import qualified Taskell.Data.Task as T (Task, due) +import Taskell.Types (ListIndex (ListIndex), Pointer, TaskIndex (TaskIndex)) + +type Lists = Seq L.List + +type Update = Lists -> Lists + +data ListPosition + = Top + | Bottom + +initial :: Lists +initial = fromList [L.empty "To Do", L.empty "Done"] + +updateLists :: Int -> L.List -> Update +updateLists = S.update + +count :: Int -> Lists -> Int +count idx tasks = maybe 0 L.count (tasks !? idx) + +due :: Lists -> Seq (Pointer, T.Task) +due lists = sortOn ((^. T.due) . snd) dues + where + format x lst = (\(y, t) -> ((ListIndex x, y), t)) <$> L.due lst + dues = concat $ format S.<#> lists + +clearDue :: Pointer -> Update +clearDue (idx, tsk) = updateFn idx (L.clearDue tsk) + +updateFn :: ListIndex -> L.Update -> Update +updateFn (ListIndex idx) fn = adjust' fn idx + +get :: Lists -> Int -> Maybe L.List +get = (!?) + +changeList :: ListPosition -> Pointer -> Lists -> Int -> Maybe Lists +changeList pos (ListIndex list, TaskIndex idx) tasks dir = do + let next = list + dir + let fn = + case pos of + Top -> L.prepend + Bottom -> L.append + (from, task) <- L.extract idx =<< tasks !? list -- extract current task + to <- fn task <$> tasks !? next -- get next list and append task + pure . updateLists next to $ updateLists list from tasks -- update lists + +newList :: Text -> Update +newList title = (|> L.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 = (L.searchFor text <$>) + +appendToLast :: T.Task -> Update +appendToLast task lists = + fromMaybe lists $ do + let idx = length lists - 1 + list <- L.append task <$> lists !? idx + pure $ 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/Taskell/Data/Seq.hs b/src/Taskell/Data/Seq.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Seq.hs @@ -0,0 +1,22 @@ +module Taskell.Data.Seq where + +import ClassyPrelude + +import Data.Sequence (deleteAt, insertAt, mapWithIndex, (!?)) + +(<#>) :: (Int -> a -> b) -> Seq a -> Seq b +(<#>) = mapWithIndex + +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 + pure $ insertAt (idx + dir) current a + +bound :: Seq a -> Int -> Int +bound s i + | i < 0 = 0 + | i >= length s = pred (length s) + | otherwise = i diff --git a/src/Taskell/Data/Subtask.hs b/src/Taskell/Data/Subtask.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Subtask.hs @@ -0,0 +1,12 @@ +module Taskell.Data.Subtask + ( Subtask + , Update + , new + , blank + , name + , complete + , toggle + , duplicate + ) where + +import Taskell.Data.Subtask.Internal diff --git a/src/Taskell/Data/Subtask/Internal.hs b/src/Taskell/Data/Subtask/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Subtask/Internal.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.Data.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 + +duplicate :: Subtask -> Subtask +duplicate (Subtask n c) = Subtask n c diff --git a/src/Taskell/Data/Task.hs b/src/Taskell/Data/Task.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Task.hs @@ -0,0 +1,27 @@ +module Taskell.Data.Task + ( Task + , Update + , name + , description + , due + , subtasks + , blank + , new + , create + , duplicate + , setDescription + , appendDescription + , setDue + , clearDue + , getSubtask + , addSubtask + , hasSubtasks + , updateSubtask + , removeSubtask + , countSubtasks + , countCompleteSubtasks + , contains + , isBlank + ) where + +import Taskell.Data.Task.Internal diff --git a/src/Taskell/Data/Task/Internal.hs b/src/Taskell/Data/Task/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Data/Task/Internal.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.Data.Task.Internal where + +import ClassyPrelude + +import Control.Lens (ix, makeLenses, (%~), (&), (.~), (?~), (^.), (^?)) + +import Data.Sequence as S (adjust', deleteAt, (|>)) +import Data.Text (strip) +import Data.Time.Zones (TZ) +import Taskell.Data.Date (Due (..), inputToTime) +import qualified Taskell.Data.Subtask as ST (Subtask, Update, complete, duplicate, name) + +data Task = Task + { _name :: Text + , _description :: Maybe Text + , _subtasks :: Seq ST.Subtask + , _due :: Maybe Due + } deriving (Show, Eq) + +type Update = Task -> Task + +-- create lenses +$(makeLenses ''Task) + +-- operations +create :: Text -> Maybe Due -> Maybe Text -> Seq ST.Subtask -> Task +create name' due' description' subtasks' = Task name' description' subtasks' due' + +blank :: Task +blank = Task "" Nothing empty Nothing + +new :: Text -> Task +new text = blank & (name .~ text) + +setDescription :: Text -> Update +setDescription text = + description .~ + if null (strip text) + then Nothing + else 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 :: TZ -> UTCTime -> Text -> Task -> Maybe Task +setDue tz now date task = + if null date + then Just (task & due .~ Nothing) + else (\d -> task & due ?~ d) <$> inputToTime tz now (strip date) + +clearDue :: Update +clearDue task = task & due .~ Nothing + +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 = + check (task ^. name) || maybe False check (task ^. description) || not (null sts) + where + check = isInfixOf (toLower text) . toLower + sts = filter check $ (^. ST.name) <$> (task ^. subtasks) + +isBlank :: Task -> Bool +isBlank task = + null (task ^. name) && + isNothing (task ^. description) && null (task ^. subtasks) && isNothing (task ^. due) + +duplicate :: Task -> Task +duplicate (Task n d st du) = Task n d (ST.duplicate <$> st) du diff --git a/src/Taskell/Events/Actions.hs b/src/Taskell/Events/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions.hs @@ -0,0 +1,67 @@ +module Taskell.Events.Actions + ( event + , generateActions + , ActionSets + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Graphics.Vty.Input.Events (Event (..)) + +import Taskell.Events.State.Types (State, Stateful, mode) +import Taskell.Events.State.Types.Mode (DetailMode (..), ModalType (..), Mode (..)) + +import Taskell.IO.Keyboard (generate) +import Taskell.IO.Keyboard.Types (Bindings, BoundActions) + +import qualified Taskell.Events.Actions.Insert as Insert +import qualified Taskell.Events.Actions.Modal as Modal +import qualified Taskell.Events.Actions.Modal.Detail as Detail +import qualified Taskell.Events.Actions.Modal.Due as Due +import qualified Taskell.Events.Actions.Modal.Help as Help +import qualified Taskell.Events.Actions.Normal as Normal +import qualified Taskell.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 + _ -> pure state + +-- returns new state if successful +event :: ActionSets -> Event -> State -> State +event actions e state = do + let mEv = + case state ^. mode of + Normal -> lookup e $ normal actions + Modal (Detail _ DetailNormal) -> lookup e $ detail actions + Modal Due {} -> lookup e $ due actions + Modal Help -> lookup e $ help actions + _ -> Nothing + fromMaybe state $ + case mEv of + Nothing -> event' e state + Just ev -> ev state + +data ActionSets = ActionSets + { normal :: BoundActions + , detail :: BoundActions + , help :: BoundActions + , due :: BoundActions + } + +generateActions :: Bindings -> ActionSets +generateActions bindings = + ActionSets + { normal = generate bindings Normal.events + , detail = generate bindings Detail.events + , help = generate bindings Help.events + , due = generate bindings Due.events + } diff --git a/src/Taskell/Events/Actions/Insert.hs b/src/Taskell/Events/Actions/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions/Insert.hs @@ -0,0 +1,36 @@ +module Taskell.Events.Actions.Insert + ( event + ) where + +import ClassyPrelude + +import Control.Lens ((&), (.~), (^.)) + +import Graphics.Vty.Input.Events (Event (EvKey), Key (KEnter, KEsc)) +import Taskell.Events.State +import Taskell.Events.State.Types +import Taskell.Events.State.Types.Mode (InsertMode (..), InsertType (..), Mode (Insert)) +import qualified Taskell.UI.Draw.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 + _ -> pure 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 + _ -> pure state +event e state = + pure $ + case state ^. mode of + Insert iType iMode field -> state & mode .~ Insert iType iMode (F.event e field) + _ -> state diff --git a/src/Taskell/Events/Actions/Modal.hs b/src/Taskell/Events/Actions/Modal.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions/Modal.hs @@ -0,0 +1,25 @@ +module Taskell.Events.Actions.Modal + ( event + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Graphics.Vty.Input.Events +import Taskell.Events.State.Types (Stateful, mode) +import Taskell.Events.State.Types.Mode (ModalType (..), Mode (Modal)) + +import qualified Taskell.Events.Actions.Modal.Detail as Detail +import qualified Taskell.Events.Actions.Modal.Due as Due +import qualified Taskell.Events.Actions.Modal.Help as Help +import qualified Taskell.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 + Modal Due {} -> Due.event e s + _ -> pure s diff --git a/src/Taskell/Events/Actions/Modal/Detail.hs b/src/Taskell/Events/Actions/Modal/Detail.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions/Modal/Detail.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedLists #-} + +module Taskell.Events.Actions.Modal.Detail + ( event + , events + ) where + +import ClassyPrelude + +import Graphics.Vty.Input.Events +import Taskell.Events.Actions.Types as A (ActionType (..)) +import Taskell.Events.State (clearDate, normalMode, quit, store, undo, write) +import Taskell.Events.State.Modal.Detail as Detail +import Taskell.Events.State.Types +import Taskell.Events.State.Types.Mode (DetailItem (..), DetailMode (..)) +import Taskell.IO.Keyboard.Types (Actions) +import qualified Taskell.UI.Draw.Field as F (event) + +events :: Actions +events + -- general + = + [ (A.Quit, quit) + , (A.Undo, (write =<<) . undo) + , (A.Previous, previousSubtask) + , (A.Next, nextSubtask) + , (A.MoveUp, (write =<<) . (up =<<) . store) + , (A.MoveDown, (write =<<) . (down =<<) . store) + , (A.New, (Detail.insertMode =<<) . (Detail.lastSubtask =<<) . (Detail.newItem =<<) . store) + , (A.Edit, (Detail.insertMode =<<) . store) + , (A.Complete, (write =<<) . (setComplete =<<) . store) + , (A.Delete, (write =<<) . (Detail.remove =<<) . store) + , (A.DueDate, (editDue =<<) . store) + , (A.ClearDate, (write =<<) . (clearDate =<<) . store) + , (A.Detail, (editDescription =<<) . store) + ] + +normal :: Event -> Stateful +normal (EvKey KEsc _) = normalMode +normal _ = pure + +insert :: Event -> Stateful +insert (EvKey KEsc _) s = do + item <- getCurrentItem s + case item of + DetailDescription -> (write =<<) $ finishDescription s + DetailDate -> showDetail 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/Taskell/Events/Actions/Modal/Due.hs b/src/Taskell/Events/Actions/Modal/Due.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions/Modal/Due.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedLists #-} + +module Taskell.Events.Actions.Modal.Due + ( event + , events + ) where + +import ClassyPrelude + +import Graphics.Vty.Input.Events (Event (EvKey)) +import Taskell.Events.Actions.Types as A (ActionType (..)) +import Taskell.Events.State (normalMode, store, write) +import Taskell.Events.State.Modal.Detail (showDetail) +import Taskell.Events.State.Modal.Due (clearDate, goto, next, previous) +import Taskell.Events.State.Types (Stateful) +import Taskell.IO.Keyboard.Types (Actions) + +events :: Actions +events = + [ (A.Previous, previous) + , (A.Next, next) + , (A.Detail, (showDetail =<<) . goto) + , (A.ClearDate, (write =<<) . (clearDate =<<) . store) + ] + +event :: Event -> Stateful +event (EvKey _ _) = normalMode +event _ = pure diff --git a/src/Taskell/Events/Actions/Modal/Help.hs b/src/Taskell/Events/Actions/Modal/Help.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions/Modal/Help.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedLists #-} + +module Taskell.Events.Actions.Modal.Help + ( event + , events + ) where + +import ClassyPrelude +import Graphics.Vty.Input.Events +import Taskell.Events.Actions.Types as A (ActionType (..)) +import Taskell.Events.State +import Taskell.Events.State.Types (Stateful) +import Taskell.IO.Keyboard.Types (Actions) + +events :: Actions +events = [(A.Quit, quit)] + +event :: Event -> Stateful +event (EvKey _ _) = normalMode +event _ = pure diff --git a/src/Taskell/Events/Actions/Modal/MoveTo.hs b/src/Taskell/Events/Actions/Modal/MoveTo.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions/Modal/MoveTo.hs @@ -0,0 +1,14 @@ +module Taskell.Events.Actions.Modal.MoveTo + ( event + ) where + +import ClassyPrelude +import Graphics.Vty.Input.Events +import Taskell.Events.State +import Taskell.Events.State.Types (Stateful) + +event :: Event -> Stateful +event (EvKey KEsc _) = normalMode +event (EvKey KEnter _) = normalMode +event (EvKey (KChar c) _) = (normalMode =<<) . (write =<<) . (moveTo c =<<) . store +event _ = pure diff --git a/src/Taskell/Events/Actions/Normal.hs b/src/Taskell/Events/Actions/Normal.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions/Normal.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedLists #-} + +module Taskell.Events.Actions.Normal + ( event + , events + ) where + +import ClassyPrelude hiding (delete) + +import Data.Char (isDigit) +import Graphics.Vty.Input.Events +import Taskell.Events.Actions.Types as A (ActionType (..)) +import Taskell.Events.State +import Taskell.Events.State.Modal.Detail (editDue, showDetail) +import Taskell.Events.State.Modal.Due (showDue) +import Taskell.Events.State.Types (Stateful) +import Taskell.IO.Keyboard.Types (Actions) + +events :: Actions +events + -- general + = + [ (A.Quit, quit) + , (A.Undo, (write =<<) . undo) + , (A.Redo, (write =<<) . redo) + , (A.Search, searchMode) + , (A.Help, showHelp) + , (A.Due, showDue) + -- navigation + , (A.Previous, previous) + , (A.Next, next) + , (A.Left, left) + , (A.Right, right) + , (A.Bottom, bottom) + , (A.Top, top) + -- new tasks + , (A.New, (startCreate =<<) . (newItem =<<) . store) + , (A.NewAbove, (startCreate =<<) . (above =<<) . store) + , (A.NewBelow, (startCreate =<<) . (below =<<) . store) + , (A.Duplicate, (next =<<) . (write =<<) . (duplicate =<<) . store) + -- editing tasks + , (A.Edit, (startEdit =<<) . store) + , (A.Clear, (startEdit =<<) . (clearItem =<<) . store) + , (A.Delete, (write =<<) . (delete =<<) . store) + , (A.Detail, showDetail) + , (A.DueDate, (editDue =<<) . (store =<<) . showDetail) + , (A.ClearDate, (write =<<) . (clearDate =<<) . store) + -- moving tasks + , (A.MoveUp, (write =<<) . (up =<<) . store) + , (A.MoveDown, (write =<<) . (down =<<) . store) + , (A.MoveLeftTop, (write =<<) . (top =<<) . (left =<<) . (moveLeftTop =<<) . store) + , (A.MoveRightTop, (write =<<) . (top =<<) . (right =<<) . (moveRightTop =<<) . store) + , (A.MoveLeftBottom, (write =<<) . (bottom =<<) . (left =<<) . (moveLeftBottom =<<) . store) + , (A.MoveRightBottom, (write =<<) . (bottom =<<) . (right =<<) . (moveRightBottom =<<) . store) + , (A.Complete, (write =<<) . (moveToLast =<<) . (clearDate =<<) . store) + , (A.MoveMenu, showMoveTo) + -- lists + , (A.ListNew, (createListStart =<<) . store) + , (A.ListEdit, (editListStart =<<) . store) + , (A.ListDelete, (write =<<) . (deleteCurrentList =<<) . store) + , (A.ListRight, (write =<<) . (listRight =<<) . store) + , (A.ListLeft, (write =<<) . (listLeft =<<) . store) + ] + +-- Normal +event :: Event -> Stateful +-- selecting lists +event (EvKey (KChar n) _) + | isDigit n = selectList n + | otherwise = pure +event (EvKey KEsc _) = clearSearch +-- fallback +event _ = pure diff --git a/src/Taskell/Events/Actions/Search.hs b/src/Taskell/Events/Actions/Search.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions/Search.hs @@ -0,0 +1,21 @@ +module Taskell.Events.Actions.Search + ( event + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Graphics.Vty.Input.Events +import Taskell.Events.State +import Taskell.Events.State.Types (Stateful, mode) +import Taskell.Events.State.Types.Mode (Mode (Search)) +import qualified Taskell.UI.Draw.Field as F (event) + +event :: Event -> Stateful +event (EvKey KEsc _) s = clearSearch =<< normalMode s +event (EvKey KEnter _) s = normalMode s +event e s = + case s ^. mode of + Search -> appendSearch (F.event e) s + _ -> pure s diff --git a/src/Taskell/Events/Actions/Types.hs b/src/Taskell/Events/Actions/Types.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/Actions/Types.hs @@ -0,0 +1,85 @@ +module Taskell.Events.Actions.Types where + +import ClassyPrelude hiding (Left, Nothing, Right) + +data ActionType + = Quit + | Undo + | Redo + | Search + | Due + | Help + | Previous + | Next + | Left + | Right + | Bottom + | Top + | New + | NewAbove + | NewBelow + | Duplicate + | Edit + | Clear + | Delete + | Detail + | DueDate + | ClearDate + | MoveUp + | MoveDown + | MoveLeftTop + | MoveRightTop + | MoveLeftBottom + | MoveRightBottom + | Complete + | MoveMenu + | ListNew + | ListEdit + | ListDelete + | ListRight + | ListLeft + | Nothing + deriving (Show, Eq, Ord, Enum) + +allActions :: [ActionType] +allActions = [toEnum 0 ..] + +read :: Text -> ActionType +read "quit" = Quit +read "undo" = Undo +read "redo" = Redo +read "search" = Search +read "due" = Due +read "help" = Help +read "previous" = Previous +read "next" = Next +read "left" = Left +read "right" = Right +read "bottom" = Bottom +read "top" = Top +read "new" = New +read "newAbove" = NewAbove +read "newBelow" = NewBelow +read "duplicate" = Duplicate +read "edit" = Edit +read "clear" = Clear +read "delete" = Delete +read "detail" = Detail +read "dueDate" = DueDate +read "clearDate" = ClearDate +read "moveUp" = MoveUp +read "moveDown" = MoveDown +read "moveLeftTop" = MoveLeftTop +read "moveRightTop" = MoveRightTop +read "moveLeft" = MoveLeftBottom +read "moveRight" = MoveRightBottom +read "moveLeftBottom" = MoveLeftBottom +read "moveRightBottom" = MoveRightBottom +read "complete" = Complete +read "moveMenu" = MoveMenu +read "listNew" = ListNew +read "listEdit" = ListEdit +read "listDelete" = ListDelete +read "listRight" = ListRight +read "listLeft" = ListLeft +read _ = Nothing diff --git a/src/Taskell/Events/State.hs b/src/Taskell/Events/State.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/State.hs @@ -0,0 +1,419 @@ +module Taskell.Events.State + -- App + ( continue + , write + , setTime + , countCurrent + , setHeight + -- Taskell.UI.Main + , normalise + -- Main + , create + -- Taskell.Events.Actions.Normal + , quit + , startEdit + , startCreate + , createListStart + , editListStart + , deleteCurrentList + , clearItem + , clearDate + , above + , below + , bottom + , top + , previous + , duplicate + , next + , left + , right + , up + , down + , moveLeftTop + , moveRightTop + , moveLeftBottom + , moveRightBottom + , moveToLast + , delete + , selectList + , listLeft + , listRight + , undo + , redo + , store + , searchMode + , clearSearch + , appendSearch + -- Taskell.Events.Actions.Insert + , createList + , removeBlank + , newItem + , normalMode + , finishTask + , finishListTitle + -- Taskell.Events.Actions.Modal + , showHelp + , showMoveTo + , moveTo + , getCurrentList + , getCurrentTask + , setCurrentTask + ) where + +import ClassyPrelude hiding (delete) + +import Control.Lens ((%~), (&), (.~), (?~), (^.)) + +import Data.Char (digitToInt, ord) +import Data.Time.Zones (TZ) + +import qualified Taskell.Data.List as L (List, deleteTask, duplicate, getTask, move, nearest, new, + newAt, nextTask, prevTask, title, update) +import qualified Taskell.Data.Lists as Lists +import Taskell.Data.Task (Task, isBlank, name) +import Taskell.Types + +import qualified Taskell.Events.State.History as History (redo, store, undo) +import Taskell.Events.State.Types +import Taskell.Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), + Mode (..)) +import Taskell.UI.Draw.Field (Field, blankField, getText, textToField) + +type InternalStateful = State -> State + +create :: TZ -> UTCTime -> FilePath -> Lists.Lists -> State +create tz t p ls = + State + { _mode = Normal + , _history = fresh ls + , _path = p + , _io = Nothing + , _height = 0 + , _searchTerm = Nothing + , _time = t + , _timeZone = tz + } + +-- app state +quit :: Stateful +quit = pure . (mode .~ Shutdown) + +continue :: State -> State +continue = io .~ Nothing + +store :: Stateful +store state = pure $ state & history %~ History.store + +undo :: Stateful +undo state = pure $ state & history %~ History.undo + +redo :: Stateful +redo state = pure $ state & history %~ History.redo + +setTime :: UTCTime -> State -> State +setTime t = time .~ t + +write :: Stateful +write state = pure $ state & (io ?~ (state ^. lists)) + +-- createList +createList :: Stateful +createList state = + pure $ + 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 = pure . (mode .~ Insert IList ICreate blankField) + +-- editList +editListStart :: Stateful +editListStart state = do + f <- textToField . (^. L.title) <$> getList state + pure $ state & mode .~ Insert IList IEdit f + +deleteCurrentList :: Stateful +deleteCurrentList state = + pure . fixIndex . setLists state $ Lists.delete (getCurrentList state) (state ^. lists) + +-- insert +getCurrentTask :: State -> Maybe Task +getCurrentTask state = getList state >>= L.getTask (getIndex state) + +setCurrentTask :: Task -> Stateful +setCurrentTask task state = setList state . L.update (getIndex state) task <$> getList state + +setCurrentTaskText :: Text -> Stateful +setCurrentTaskText text state = + flip setCurrentTask state =<< (name .~ text) <$> getCurrentTask state + +startCreate :: Stateful +startCreate = pure . (mode .~ Insert ITask ICreate blankField) + +startEdit :: Stateful +startEdit state = do + field <- textToField . (^. name) <$> getCurrentTask state + pure $ 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) + _ -> pure state + +finishListTitle :: Stateful +finishListTitle state = + case state ^. mode of + Insert IList iMode f -> + setCurrentListTitle (getText f) $ state & (mode .~ Insert IList iMode blankField) + _ -> pure state + +normalMode :: Stateful +normalMode = pure . (mode .~ Normal) + +addToListAt :: Int -> Stateful +addToListAt offset state = do + let idx = getIndex state + offset + fixIndex . setList (setIndex state idx) . L.newAt idx <$> getList state + +above :: Stateful +above = addToListAt 0 + +below :: Stateful +below = addToListAt 1 + +newItem :: Stateful +newItem state = selectLast . setList state . L.new <$> getList state + +duplicate :: Stateful +duplicate state = setList state <$> (L.duplicate (getIndex state) =<< getList state) + +clearItem :: Stateful +clearItem = setCurrentTaskText "" + +clearDate :: Stateful +clearDate state = pure $ state & lists .~ Lists.clearDue (state ^. current) (state ^. lists) + +bottom :: Stateful +bottom = pure . selectLast + +selectLast :: InternalStateful +selectLast state = setIndex state (countCurrent state - 1) + +top :: Stateful +top = pure . selectFirst + +selectFirst :: InternalStateful +selectFirst state = setIndex state (0) + +removeBlank :: Stateful +removeBlank state = do + currentTask <- getCurrentTask state + (if isBlank currentTask + then delete + else pure) + state + +-- moving +-- +moveVertical :: Int -> Stateful +moveVertical dir state = do + (lst, idx) <- L.move (getIndex state) dir (getText <$> state ^. searchTerm) =<< getList state + pure $ setIndex (setList state lst) idx + +up :: Stateful +up = moveVertical (-1) + +down :: Stateful +down = moveVertical 1 + +moveHorizontal :: Int -> Lists.ListPosition -> State -> Maybe State +moveHorizontal idx pos state = + fixIndex . setLists state <$> Lists.changeList pos (state ^. current) (state ^. lists) idx + +moveLeftBottom :: Stateful +moveLeftBottom = moveHorizontal (-1) Lists.Bottom + +moveRightBottom :: Stateful +moveRightBottom = moveHorizontal 1 Lists.Bottom + +moveLeftTop :: Stateful +moveLeftTop = moveHorizontal (-1) Lists.Top + +moveRightTop :: Stateful +moveRightTop = moveHorizontal 1 Lists.Top + +moveToLast :: Stateful +moveToLast state = + if idx == cur + then pure state + else moveHorizontal (idx - cur) Lists.Bottom state + where + idx = length (state ^. lists) - 1 + cur = getCurrentList state + +selectList :: Char -> Stateful +selectList idx state = + pure $ + (if exists + then current .~ (ListIndex list, TaskIndex 0) + else id) + state + where + list = digitToInt idx - 1 + exists = Lists.exists list (state ^. lists) + +-- removing +delete :: Stateful +delete state = fixIndex . setList state . L.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 .~ (ListIndex (getCurrentList state), TaskIndex idx) + +setCurrentList :: State -> Int -> State +setCurrentList state idx = state & current .~ (ListIndex idx, TaskIndex (getIndex state)) + +getIndex :: State -> Int +getIndex = showTaskIndex . snd . (^. current) + +changeTask :: (Int -> Maybe Text -> L.List -> Int) -> Stateful +changeTask fn state = do + list <- getList state + let idx = getIndex state + let term = getText <$> state ^. searchTerm + pure $ setIndex state (fn idx term list) + +next :: Stateful +next = changeTask L.nextTask + +previous :: Stateful +previous = changeTask L.prevTask + +left :: Stateful +left state = + pure . fixIndex . setCurrentList state $ + if list > 0 + then pred list + else 0 + where + list = getCurrentList state + +right :: Stateful +right state = + pure . fixIndex . setCurrentList state $ + if list < (count - 1) + then succ list + else list + where + list = getCurrentList state + count = length (state ^. lists) + +fixListIndex :: InternalStateful +fixListIndex state = + if listIdx + then state + else setCurrentList state (length lists' - 1) + where + lists' = state ^. lists + listIdx = Lists.exists (getCurrentList state) lists' + +fixIndex :: InternalStateful +fixIndex state = + case getList state of + Just list -> setIndex state (L.nearest idx trm list) + Nothing -> fixListIndex state + where + trm = getText <$> state ^. searchTerm + idx = getIndex state + +-- tasks +getCurrentList :: State -> Int +getCurrentList = showListIndex . fst . (^. current) + +getList :: State -> Maybe L.List +getList state = Lists.get (state ^. lists) (getCurrentList state) + +setList :: State -> L.List -> State +setList state list = setLists state (Lists.updateLists (getCurrentList state) list (state ^. lists)) + +setCurrentListTitle :: Text -> Stateful +setCurrentListTitle text state = setList state . (L.title .~ text) <$> getList state + +setLists :: State -> Lists.Lists -> State +setLists state lists' = state & lists .~ lists' + +moveTo' :: Int -> Stateful +moveTo' li state = do + let cur = getCurrentList state + if li == cur || li < 0 || li >= length (state ^. lists) + then Nothing + else do + s <- moveHorizontal (li - cur) Lists.Bottom state + pure . selectLast $ setCurrentList s li + +moveTo :: Char -> Stateful +moveTo char = moveTo' (ord char - ord 'a') + +-- 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 = pure . fixIndex $ (state & mode .~ Search) & searchTerm .~ sTerm + where + sTerm = pure (fromMaybe blankField (state ^. searchTerm)) + +clearSearch :: Stateful +clearSearch state = pure $ state & searchTerm .~ Nothing + +appendSearch :: (Field -> Field) -> Stateful +appendSearch genField state = do + let field = fromMaybe blankField (state ^. searchTerm) + pure . fixIndex $ state & searchTerm .~ pure (genField field) + +-- help +showHelp :: Stateful +showHelp = pure . (mode .~ Modal Help) + +showMoveTo :: Stateful +showMoveTo state = const (state & mode .~ Modal MoveTo) <$> getCurrentTask state + +-- view +setHeight :: Int -> State -> State +setHeight = (.~) height + +-- more view - maybe shouldn't be in here... +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 diff --git a/src/Taskell/Events/State/History.hs b/src/Taskell/Events/State/History.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/State/History.hs @@ -0,0 +1,29 @@ +module Taskell.Events.State.History + ( undo + , redo + , store + ) where + +import ClassyPrelude + +import Control.Lens (Lens', (&), (.~), (^.)) + +import Taskell.Events.State.Types (History (History), future, past, present) + +λstack :: Lens' (History a) [a] -> History a -> [a] +λstack fn history = history ^. present : (history ^. fn) + +store :: History a -> History a +store history = history & past .~ λstack past history & future .~ empty + +undo :: History a -> History a +undo history = + case history ^. past of + [] -> history + (moment:xs) -> History xs moment (λstack future history) + +redo :: History a -> History a +redo history = + case history ^. future of + [] -> history + (moment:xs) -> History (λstack past history) moment xs diff --git a/src/Taskell/Events/State/Modal/Detail.hs b/src/Taskell/Events/State/Modal/Detail.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/State/Modal/Detail.hs @@ -0,0 +1,184 @@ +module Taskell.Events.State.Modal.Detail + ( updateField + , finishSubtask + , finishDescription + , finishDue + , showDetail + , getCurrentItem + , getCurrentMode + , getField + , setComplete + , remove + , insertMode + , editDescription + , editDue + , newItem + , nextSubtask + , previousSubtask + , lastSubtask + , up + , down + ) where + +import ClassyPrelude + +import Control.Lens ((&), (.~), (^.)) + +import Taskell.Data.Date (timeToDisplay) +import qualified Taskell.Data.Seq as S +import qualified Taskell.Data.Subtask as ST (blank, name, toggle) +import Taskell.Data.Task (Task, addSubtask, countSubtasks, description, due, + getSubtask, removeSubtask, setDescription, setDue, + subtasks, updateSubtask) +import Taskell.Events.State (getCurrentTask, setCurrentTask) +import Taskell.Events.State.Types (State, Stateful, mode, time, timeZone) +import Taskell.Events.State.Types.Mode (DetailItem (..), DetailMode (..), + ModalType (Detail), Mode (Modal)) +import Taskell.UI.Draw.Field (Field, blankField, getText, textToField) + +updateField :: (Field -> Field) -> Stateful +updateField fieldEvent s = + pure $ + 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 state = do + let tz = state ^. timeZone + let now = state ^. time + text <- getText <$> getField state + task <- setDue tz now text =<< getCurrentTask state + setCurrentTask task $ state & mode .~ Modal (Detail (DetailItem 0) DetailNormal) + +showDetail :: Stateful +showDetail s = do + _ <- getCurrentTask s + let i = fromMaybe 0 $ getCurrentSubtask s + pure $ 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 + pure $ state & mode .~ Modal (Detail DetailDescription (DetailInsert (textToField summ'))) + +editDue :: Stateful +editDue state = do + day <- (^. due) <$> getCurrentTask state + let tz = state ^. timeZone + let day' = maybe "" (timeToDisplay tz) day + pure $ 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) + +-- moving tasks +moveVertical :: Int -> Stateful +moveVertical dir state = do + task <- getCurrentTask state + let tasks = task ^. subtasks + i <- getCurrentSubtask state + shifted <- S.shiftBy i dir tasks + state' <- setCurrentTask (task & subtasks .~ shifted) state + changeSubtask dir state' + +up :: Stateful +up = moveVertical (-1) + +down :: Stateful +down = moveVertical 1 diff --git a/src/Taskell/Events/State/Modal/Due.hs b/src/Taskell/Events/State/Modal/Due.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/State/Modal/Due.hs @@ -0,0 +1,66 @@ +module Taskell.Events.State.Modal.Due + ( showDue + , clearDate + , previous + , next + , goto + ) where + +import ClassyPrelude + +import Control.Lens ((&), (.~), (^.)) +import Data.Sequence ((!?)) + +import qualified Taskell.Data.Lists as L (clearDue, due) +import Taskell.Data.Seq (bound) +import Taskell.Data.Task (Task) +import Taskell.Events.State.Types (Stateful, current, lists, mode) +import Taskell.Events.State.Types.Mode (ModalType (Due), Mode (..)) +import Taskell.Types (Pointer) + +type DueStateful = Seq (Pointer, Task) -> Int -> Stateful + +λfilter :: DueStateful -> Stateful +λfilter fn state = + case state ^. mode of + Modal (Due due cur) -> fn due cur state + _ -> pure state + +λsetMode :: DueStateful +λsetMode due pos state = pure $ state & mode .~ Modal (Due due pos) + +λprevious :: DueStateful +λprevious due cur = λsetMode due (bound due (cur - 1)) + +λnext :: DueStateful +λnext due cur = λsetMode due (bound due (cur + 1)) + +λgoto :: DueStateful +λgoto due cur state = + case due !? cur of + Just (pointer, _) -> pure $ state & current .~ pointer + Nothing -> Nothing + +λclearDate :: DueStateful +λclearDate due cur state = + case due !? cur of + Just (pointer, _) -> do + let new = L.clearDue pointer (state ^. lists) + let dues = L.due new + λsetMode dues (bound dues cur) (state & lists .~ new) + Nothing -> Nothing + +showDue :: Stateful +showDue state = λsetMode (L.due (state ^. lists)) 0 state + +previous :: Stateful +previous = λfilter λprevious + +next :: Stateful +next = λfilter λnext + +goto :: Stateful +goto = λfilter λgoto + +clearDate :: Stateful +clearDate = λfilter λclearDate diff --git a/src/Taskell/Events/State/Types.hs b/src/Taskell/Events/State/Types.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/State/Types.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.Events.State.Types where + +import ClassyPrelude + +import Control.Lens (Lens', makeLenses) +import Control.Lens.Combinators (_1, _2) + +import Data.Time.Zones (TZ) + +import Taskell.Data.Lists (Lists) +import Taskell.Types (Pointer, startPointer) +import Taskell.UI.Draw.Field (Field) + +import qualified Taskell.Events.State.Types.Mode as M (Mode) + +type Moment = (Pointer, Lists) + +data History a = History + { _past :: [a] + , _present :: a + , _future :: [a] + } deriving (Eq, Show) + +fresh :: Lists -> History Moment +fresh ls = History empty (startPointer, ls) empty + +data State = State + { _mode :: M.Mode + , _history :: History Moment + , _path :: FilePath + , _io :: Maybe Lists + , _height :: Int + , _searchTerm :: Maybe Field + , _time :: UTCTime + , _timeZone :: TZ + } deriving (Eq, Show) + +-- create lenses +$(makeLenses ''State) + +$(makeLenses ''History) + +type Stateful = State -> Maybe State + +current :: Lens' State Pointer +current = history . present . _1 + +lists :: Lens' State Lists +lists = history . present . _2 diff --git a/src/Taskell/Events/State/Types/Mode.hs b/src/Taskell/Events/State/Types/Mode.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Events/State/Types/Mode.hs @@ -0,0 +1,47 @@ +module Taskell.Events.State.Types.Mode where + +import ClassyPrelude + +import Taskell.Data.Task (Task) +import Taskell.Types (Pointer) +import Taskell.UI.Draw.Field (Field) + +data DetailMode + = DetailNormal + | DetailInsert Field + deriving (Eq, Show) + +data DetailItem + = DetailItem Int + | DetailDescription + | DetailDate + deriving (Eq, Show) + +data ModalType + = Help + | MoveTo + | Due (Seq (Pointer, Task)) + Int + | 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 + | Shutdown + deriving (Eq, Show) diff --git a/src/Taskell/IO.hs b/src/Taskell/IO.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO where + +import ClassyPrelude + +import Control.Monad.Reader (runReader) +import Data.FileEmbed (embedFile) +import Data.Text.Encoding (decodeUtf8With) +import System.Directory (doesFileExist, getCurrentDirectory) + +import Data.Time.Zones (TZ) + +import Taskell.Config (usage, version) +import Taskell.Data.Lists (Lists, analyse, initial) + +import Taskell.IO.Config (Config, general, github, markdown, trello) +import Taskell.IO.Config.General (filename) +import qualified Taskell.IO.Config.GitHub as GitHub (token) +import qualified Taskell.IO.Config.Trello as Trello (token) + +import Taskell.IO.Markdown (MarkdownInfo (MarkdownInfo), parse, serialize) + +import qualified Taskell.IO.HTTP.GitHub as GitHub (GitHubIdentifier, getLists) +import qualified Taskell.IO.HTTP.Trello as Trello (TrelloBoardID, getLists) + +import Taskell.UI.CLI (PromptYN (PromptYes), promptYN) + +data IOInfo = IOInfo + { ioTZ :: TZ + , ioConfig :: Config + } + +type ReaderConfig a = ReaderT IOInfo IO a + +data Next + = Output Text + | Error Text + | Load FilePath + Lists + | Exit + +parseArgs :: [Text] -> ReaderConfig Next +parseArgs ["-v"] = pure $ Output version +parseArgs ["-h"] = pure $ 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 <$> asks ioConfig) >>= loadFile +parseArgs _ = pure $ Error (unlines ["Invalid options", "", usage]) + +load :: ReaderConfig Next +load = getArgs >>= parseArgs + +colonic :: FilePath -> Text -> Text +colonic path = ((pack path <> ": ") <>) + +loadFile :: Text -> ReaderConfig Next +loadFile filepath = do + mPath <- exists filepath + case mPath of + Nothing -> pure Exit + Just path -> either (Error . colonic path) (Load path) <$> readData path + +loadRemote :: (token -> FilePath -> ReaderConfig Next) -> token -> Text -> ReaderConfig Next +loadRemote createFn identifier filepath = do + let path = unpack filepath + exists' <- fileExists path + if exists' + then pure $ Error (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 either (Error . colonic path) (Output . analyse filepath) <$> readData path + else pure $ Error (filepath <> " does not exist") + +createRemote :: + (Config -> Maybe token) + -> Text + -> (token -> ReaderT token IO (Either Text Lists)) + -> token + -> FilePath + -> ReaderConfig Next +createRemote tokenFn missingToken getFn identifier path = do + config <- asks ioConfig + tz <- asks ioTZ + case tokenFn config of + Nothing -> pure $ Error missingToken + Just token -> do + lists <- lift $ runReaderT (getFn identifier) token + case lists of + Left txt -> pure $ Error txt + Right ls -> + promptCreate path >>= + bool (pure Exit) (Load path ls <$ lift (writeData tz config ls path)) + +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 pure $ Just path + else promptCreate path >>= bool (pure Nothing) (Just path <$ createPath path) + +fileExists :: FilePath -> ReaderConfig Bool +fileExists path = lift $ doesFileExist path + +promptCreate :: FilePath -> ReaderConfig Bool +promptCreate path = do + cwd <- lift $ pack <$> getCurrentDirectory + lift $ promptYN PromptYes $ concat ["Create ", cwd, "/", pack path, "?"] + +-- creates taskell file +createPath :: FilePath -> ReaderConfig () +createPath path = do + config <- asks ioConfig + tz <- asks ioTZ + lift (writeData tz config initial path) + +-- writes Tasks to json file +writeData :: TZ -> Config -> Lists -> FilePath -> IO () +writeData tz config tasks path = void (writeFile path output) + where + output = encodeUtf8 $ runReader (serialize tasks) (MarkdownInfo tz (markdown config)) + +-- reads json file +decodeError :: String -> Maybe Word8 -> Maybe Char +decodeError _ _ = Just '\65533' + +readData :: FilePath -> ReaderConfig (Either Text Lists) +readData path = + parse <$> (markdown <$> asks ioConfig) <*> (decodeUtf8With decodeError <$> readFile path) diff --git a/src/Taskell/IO/Config.hs b/src/Taskell/IO/Config.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Config.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedLists #-} + +module Taskell.IO.Config where + +import ClassyPrelude + +import qualified Data.Text.IO as T (readFile) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, + getHomeDirectory) +import System.Environment (lookupEnv) + +import Brick (AttrMap) +import Brick.Themes (loadCustomizations, themeToAttrMap) +import Data.FileEmbed (embedFile) +import Data.Ini.Config + +import Taskell.IO.Keyboard (addMissing, badMapping, defaultBindings) +import Taskell.IO.Keyboard.Parser (bindings) +import Taskell.IO.Keyboard.Types (Bindings) +import Taskell.UI.Theme (defaultTheme) + +import qualified Taskell.IO.Config.General as General +import qualified Taskell.IO.Config.GitHub as GitHub +import qualified Taskell.IO.Config.Layout as Layout +import qualified Taskell.IO.Config.Markdown as Markdown +import qualified Taskell.IO.Config.Trello as Trello + +data Config = Config + { general :: General.Config + , layout :: Layout.Config + , markdown :: Markdown.Config + , trello :: Trello.Config + , github :: GitHub.Config + } + +debugging :: Config -> Bool +debugging config = General.debug (general config) + +defaultConfig :: Config +defaultConfig = + Config + General.defaultConfig + Layout.defaultConfig + Markdown.defaultConfig + Trello.defaultConfig + GitHub.defaultConfig + +directoryName :: FilePath +directoryName = "taskell" + +legacyConfigPath :: IO FilePath +legacyConfigPath = ( "." <> directoryName) <$> getHomeDirectory + +xdgDefaultConfig :: IO FilePath +xdgDefaultConfig = ( ".config") <$> getHomeDirectory + +xdgConfigPath :: IO FilePath +xdgConfigPath = + ( directoryName) <$> (fromMaybe <$> xdgDefaultConfig <*> lookupEnv "XDG_CONFIG_HOME") + +getDir :: IO FilePath +getDir = legacyConfigPath >>= doesDirectoryExist >>= bool xdgConfigPath legacyConfigPath + +themePath :: FilePath -> FilePath +themePath = ( "theme.ini") + +configPath :: FilePath -> FilePath +configPath = ( "config.ini") + +bindingsPath :: FilePath -> FilePath +bindingsPath = ( "bindings.ini") + +setup :: IO Config +setup + -- create config dir + = do + dir <- getDir + createDirectoryIfMissing True dir + -- create config files + create (configPath dir) $(embedFile "templates/config.ini") + create (themePath dir) $(embedFile "templates/theme.ini") + create (bindingsPath dir) $(embedFile "templates/bindings.ini") + -- get config + getConfig + +create :: FilePath -> ByteString -> IO () +create path contents = doesFileExist path >>= flip unless (writeFile path contents) + +configParser :: IniParser Config +configParser = + Config <$> General.parser <*> Layout.parser <*> Markdown.parser <*> Trello.parser <*> + GitHub.parser + +getConfig :: IO Config +getConfig = do + content <- T.readFile =<< (configPath <$> getDir) + case parseIniFile content configParser of + Right config -> pure config + Left s -> putStrLn (pack $ "config.ini: " <> s) $> defaultConfig + +getBindings :: IO Bindings +getBindings = do + bnds <- bindings <$> (T.readFile =<< (bindingsPath <$> getDir)) + case addMissing <$> (badMapping =<< bnds) of + Right b -> pure b + Left err -> + putStrLn ("bindings.ini: " <> err <> " - using default bindings") $> defaultBindings + +-- generate theme +generateAttrMap :: IO AttrMap +generateAttrMap = do + dir <- getDir + customizedTheme <- loadCustomizations (themePath dir) defaultTheme + case customizedTheme of + Right theme -> pure $ themeToAttrMap theme + Left s -> putStrLn (pack $ "theme.ini: " <> s) $> themeToAttrMap defaultTheme diff --git a/src/Taskell/IO/Config/General.hs b/src/Taskell/IO/Config/General.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Config/General.hs @@ -0,0 +1,30 @@ +module Taskell.IO.Config.General + ( Config + , defaultConfig + , parser + , filename + , debug + ) where + +import ClassyPrelude + +import Data.Ini.Config + +import Taskell.IO.Config.Parser (noEmpty) + +data Config = Config + { filename :: FilePath + , debug :: Bool + } + +defaultConfig :: Config +defaultConfig = Config {filename = "taskell.md", debug = False} + +filenameP :: SectionParser String +filenameP = maybe (filename defaultConfig) unpack . (noEmpty =<<) <$> fieldMb "filename" + +debugP :: SectionParser Bool +debugP = fieldFlagDef "debug" False + +parser :: IniParser Config +parser = fromMaybe defaultConfig <$> sectionMb "general" (Config <$> filenameP <*> debugP) diff --git a/src/Taskell/IO/Config/GitHub.hs b/src/Taskell/IO/Config/GitHub.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Config/GitHub.hs @@ -0,0 +1,25 @@ +module Taskell.IO.Config.GitHub + ( Config + , defaultConfig + , parser + , token + ) where + +import ClassyPrelude + +import Data.Ini.Config + +import Taskell.IO.HTTP.GitHub (GitHubToken) + +data Config = Config + { token :: Maybe GitHubToken + } + +defaultConfig :: Config +defaultConfig = Config {token = Nothing} + +tokenP :: SectionParser (Maybe GitHubToken) +tokenP = fieldMb "token" + +parser :: IniParser Config +parser = fromMaybe defaultConfig <$> sectionMb "github" (Config <$> tokenP) diff --git a/src/Taskell/IO/Config/Layout.hs b/src/Taskell/IO/Config/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Config/Layout.hs @@ -0,0 +1,54 @@ +module Taskell.IO.Config.Layout + ( Config + , defaultConfig + , parser + , padding + , columnWidth + , columnPadding + , descriptionIndicator + , statusBar + ) where + +import ClassyPrelude + +import Data.Ini.Config + +import Taskell.IO.Config.Parser (noEmpty, parseText) + +data Config = Config + { padding :: Int + , columnWidth :: Int + , columnPadding :: Int + , descriptionIndicator :: Text + , statusBar :: Bool + } + +defaultConfig :: Config +defaultConfig = + Config + {padding = 1, columnWidth = 30, columnPadding = 3, descriptionIndicator = "≡", statusBar = True} + +paddingP :: SectionParser Int +paddingP = fromMaybe (padding defaultConfig) <$> fieldMbOf "padding" number + +columnWidthP :: SectionParser Int +columnWidthP = fromMaybe (columnWidth defaultConfig) <$> fieldMbOf "column_width" number + +columnPaddingP :: SectionParser Int +columnPaddingP = fromMaybe (columnPadding defaultConfig) <$> fieldMbOf "column_padding" number + +descriptionIndicatorP :: SectionParser Text +descriptionIndicatorP = + fromMaybe (descriptionIndicator defaultConfig) . (noEmpty . parseText =<<) <$> + fieldMb "description_indicator" + +statusBarP :: SectionParser Bool +statusBarP = fieldFlagDef "statusbar" (statusBar defaultConfig) + +parser :: IniParser Config +parser = + fromMaybe defaultConfig <$> + sectionMb + "layout" + (Config <$> paddingP <*> columnWidthP <*> columnPaddingP <*> descriptionIndicatorP <*> + statusBarP) diff --git a/src/Taskell/IO/Config/Markdown.hs b/src/Taskell/IO/Config/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Config/Markdown.hs @@ -0,0 +1,66 @@ +module Taskell.IO.Config.Markdown + ( Config(Config) + , defaultConfig + , parser + , titleOutput + , taskOutput + , descriptionOutput + , dueOutput + , subtaskOutput + , localTimes + ) where + +import ClassyPrelude + +import Data.Ini.Config + +import Taskell.IO.Config.Parser (noEmpty, parseText) + +data Config = Config + { titleOutput :: Text + , taskOutput :: Text + , descriptionOutput :: Text + , dueOutput :: Text + , subtaskOutput :: Text + , localTimes :: Bool + } + +defaultConfig :: Config +defaultConfig = + Config + { titleOutput = "##" + , taskOutput = "-" + , descriptionOutput = " >" + , dueOutput = " @" + , subtaskOutput = " *" + , localTimes = False + } + +titleOutputP :: SectionParser Text +titleOutputP = fromMaybe (titleOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "title" + +taskOutputP :: SectionParser Text +taskOutputP = fromMaybe (taskOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "task" + +descriptionOutputP :: SectionParser Text +descriptionOutputP = + fromMaybe (descriptionOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "summary" + +dueOutputP :: SectionParser Text +dueOutputP = fromMaybe (dueOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "due" + +subtaskOutputP :: SectionParser Text +subtaskOutputP = + fromMaybe (subtaskOutput defaultConfig) . (noEmpty . parseText =<<) <$> fieldMb "subtask" + +localTimesP :: SectionParser Bool +localTimesP = fieldFlagDef "localTimes" (localTimes defaultConfig) + +parser :: IniParser Config +parser = + fromMaybe defaultConfig <$> + sectionMb + "markdown" + (Config <$> titleOutputP <*> taskOutputP <*> descriptionOutputP <*> dueOutputP <*> + subtaskOutputP <*> + localTimesP) diff --git a/src/Taskell/IO/Config/Parser.hs b/src/Taskell/IO/Config/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Config/Parser.hs @@ -0,0 +1,12 @@ +module Taskell.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/Taskell/IO/Config/Trello.hs b/src/Taskell/IO/Config/Trello.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Config/Trello.hs @@ -0,0 +1,25 @@ +module Taskell.IO.Config.Trello + ( Config + , defaultConfig + , parser + , token + ) where + +import ClassyPrelude + +import Data.Ini.Config + +import Taskell.IO.HTTP.Trello (TrelloToken) + +data Config = Config + { token :: Maybe TrelloToken + } + +defaultConfig :: Config +defaultConfig = Config {token = Nothing} + +tokenP :: SectionParser (Maybe TrelloToken) +tokenP = fieldMb "token" + +parser :: IniParser Config +parser = fromMaybe defaultConfig <$> sectionMb "trello" (Config <$> tokenP) diff --git a/src/Taskell/IO/HTTP/Aeson.hs b/src/Taskell/IO/HTTP/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/Aeson.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.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/Taskell/IO/HTTP/GitHub.hs b/src/Taskell/IO/HTTP/GitHub.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/GitHub.hs @@ -0,0 +1,161 @@ +module Taskell.IO.HTTP.GitHub + ( GitHubToken + , GitHubIdentifier + , getNextLink + , getLists + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) +import Data.Sequence (mapWithIndex, (!?)) +import Data.Text (splitOn, strip) + +import Data.Aeson +import Taskell.UI.CLI (prompt) + +import Network.HTTP.Client (requestHeaders) +import Network.HTTP.Simple (Response, getResponseBody, getResponseHeader, + getResponseStatusCode, httpBS, parseRequest) +import Network.HTTP.Types.Header (HeaderName) + +import Taskell.IO.HTTP.Aeson (parseError) +import Taskell.IO.HTTP.GitHub.AutomatedCard (automatedCardToTask) +import Taskell.IO.HTTP.GitHub.Card (MaybeCard, content_url, maybeCardToTask) +import Taskell.IO.HTTP.GitHub.Column (Column, cardsURL, columnToList) +import Taskell.IO.HTTP.GitHub.Project (Project, columnsURL, name) + +import Taskell.Data.List (List) +import Taskell.Data.Lists (Lists) +import Taskell.Data.Task (Task) + +type GitHubToken = Text + +type GitHubIdentifier = Text + +type ReaderGitHubToken a = ReaderT GitHubToken IO a + +concatEithers :: [Either String [a]] -> Either String [a] +concatEithers vals = bool (Left errs) (Right as) (null errs) + where + (errs, as) = bimap unlines concat $ partitionEithers vals + +root :: Text +root = "https://api.github.com/" + +headers :: ReaderGitHubToken [(HeaderName, ByteString)] +headers = do + token <- ask + pure + [ ("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) + +fetchURL :: Text -> ReaderGitHubToken (Response ByteString) +fetchURL url = do + initialRequest <- lift $ parseRequest (unpack url) + rHeaders <- headers + lift . httpBS $ initialRequest {requestHeaders = rHeaders} + +fetch' :: [ByteString] -> Text -> ReaderGitHubToken (Int, [ByteString]) +fetch' bs url = do + response <- fetchURL url + let responses = bs <> [getResponseBody response] + case getNextLink (getResponseHeader "Link" response) of + Nothing -> pure (getResponseStatusCode response, responses) + Just lnk -> fetch' responses lnk + +fetch :: Text -> ReaderGitHubToken (Int, [ByteString]) +fetch = fetch' [] + +fetchContent :: MaybeCard -> ReaderGitHubToken (Either Text Task) +fetchContent card = + case maybeCardToTask card of + Just tsk -> pure $ Right tsk + Nothing -> + case card ^. content_url of + Nothing -> pure $ Left "Could not parse card" + Just url -> do + body <- getResponseBody <$> fetchURL url + pure . first parseError $ automatedCardToTask <$> eitherDecodeStrict body + +getCards :: Text -> ReaderGitHubToken (Either Text [Task]) +getCards url = do + (status, body) <- fetch url + case status of + 200 -> + case concatEithers (eitherDecodeStrict <$> body) of + Right cards -> do + cds <- sequence (fetchContent <$> cards) + let (ls, rs) = first unlines $ partitionEithers cds + pure $ bool (Left ls) (Right rs) (null ls) + Left err -> pure $ Left (parseError err) + 429 -> pure $ Left "Too many cards" + _ -> pure . Left $ tshow status <> " error while fetching " <> url + +addCard :: Column -> ReaderGitHubToken (Either Text List) +addCard column = do + cards <- getCards $ column ^. cardsURL + pure $ columnToList column <$> cards + +addCards :: [Column] -> ReaderGitHubToken (Either Text Lists) +addCards columns = (fromList <$>) . sequence <$> traverse addCard columns + +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 -> pure $ Left (parseError err) + 404 -> pure . Left $ "Could not find GitHub project ." + 401 -> pure . Left $ "You do not have permission to view GitHub project " <> url + _ -> pure . 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 -> pure $ 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 pure . Left $ concat ["\nNo projects found for ", identifier, "\n"] + else chooseProject projects + Left err -> pure $ Left (parseError err) + 404 -> + pure . Left $ + "Could not find GitHub org/repo. For organisation make sure you use 'orgs/' and for repos use 'repos//'" + 401 -> + pure . Left $ + "You do not have permission to view the GitHub projects for " <> identifier + _ -> pure . Left $ tshow status <> " error. Cannot fetch projects from GitHub." diff --git a/src/Taskell/IO/HTTP/GitHub/AutomatedCard.hs b/src/Taskell/IO/HTTP/GitHub/AutomatedCard.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/GitHub/AutomatedCard.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO.HTTP.GitHub.AutomatedCard + ( AutomatedCard(AutomatedCard) + , automatedCardToTask + ) where + +import ClassyPrelude + +import Control.Lens (makeLenses, (^.)) + +import qualified Taskell.Data.Task as T (Task, new, setDescription) +import Taskell.IO.HTTP.Aeson (deriveFromJSON) +import Taskell.IO.HTTP.GitHub.Utility (cleanUp) + +data AutomatedCard = AutomatedCard + { _title :: Text + , _body :: Text + } deriving (Eq, Show) + +-- strip underscores from field labels +$(deriveFromJSON ''AutomatedCard) + +-- create lenses +$(makeLenses ''AutomatedCard) + +-- operations +automatedCardToTask :: AutomatedCard -> T.Task +automatedCardToTask automatedCard = T.setDescription (cleanUp (automatedCard ^. body)) task + where + task = T.new $ cleanUp (automatedCard ^. title) diff --git a/src/Taskell/IO/HTTP/GitHub/Card.hs b/src/Taskell/IO/HTTP/GitHub/Card.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/GitHub/Card.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO.HTTP.GitHub.Card + ( MaybeCard(MaybeCard) + , maybeCardToTask + , content_url + ) where + +import ClassyPrelude + +import Control.Lens (makeLenses, (^.)) + +import qualified Taskell.Data.Task as T (Task, new) +import Taskell.IO.HTTP.Aeson (deriveFromJSON) +import Taskell.IO.HTTP.GitHub.Utility (cleanUp) + +data MaybeCard = MaybeCard + { _note :: Maybe Text + , _content_url :: Maybe Text + } deriving (Eq, Show) + +-- strip underscores from field labels +$(deriveFromJSON ''MaybeCard) + +-- create lenses +$(makeLenses ''MaybeCard) + +-- operations +maybeCardToTask :: MaybeCard -> Maybe T.Task +maybeCardToTask card = T.new . cleanUp <$> card ^. note diff --git a/src/Taskell/IO/HTTP/GitHub/Column.hs b/src/Taskell/IO/HTTP/GitHub/Column.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/GitHub/Column.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO.HTTP.GitHub.Column + ( Column + , columnToList + , cardsURL + ) where + +import ClassyPrelude + +import Control.Lens (Lens', makeLenses, (^.)) + +import Taskell.IO.HTTP.Aeson (deriveFromJSON) + +import qualified Taskell.Data.List as L (List, create) +import qualified Taskell.Data.Task as T (Task) + +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 -> [T.Task] -> L.List +columnToList ls tasks = L.create (ls ^. name) (fromList tasks) diff --git a/src/Taskell/IO/HTTP/GitHub/Project.hs b/src/Taskell/IO/HTTP/GitHub/Project.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/GitHub/Project.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO.HTTP.GitHub.Project + ( Project + , columnsURL + , name + ) where + +import ClassyPrelude + +import Control.Lens (Lens', makeLenses) + +import Taskell.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/Taskell/IO/HTTP/GitHub/Utility.hs b/src/Taskell/IO/HTTP/GitHub/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/GitHub/Utility.hs @@ -0,0 +1,10 @@ +module Taskell.IO.HTTP.GitHub.Utility + ( cleanUp + ) where + +import ClassyPrelude + +import Data.Text (replace) + +cleanUp :: Text -> Text +cleanUp txt = replace "\r" "" $ replace "\n" " " txt diff --git a/src/Taskell/IO/HTTP/Trello.hs b/src/Taskell/IO/HTTP/Trello.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/Trello.hs @@ -0,0 +1,102 @@ +module Taskell.IO.HTTP.Trello + ( TrelloToken + , TrelloBoardID + , getLists + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Data.Aeson +import Network.HTTP.Simple (getResponseBody, getResponseStatusCode, httpBS, parseRequest) + +import Taskell.IO.HTTP.Aeson (parseError) +import Taskell.IO.HTTP.Trello.Card (Card, idChecklists, setChecklists) +import Taskell.IO.HTTP.Trello.ChecklistItem (ChecklistItem, checkItems) +import Taskell.IO.HTTP.Trello.List (List, cards, listToList, setCards) + +import Taskell.Data.Lists (Lists) + +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 + pure . 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 :: [List] -> Lists +trelloListsToLists ls = fromList $ listToList <$> ls + +fetch :: String -> IO (Int, ByteString) +fetch url = do + request <- parseRequest url + response <- httpBS request + pure (getResponseStatusCode response, getResponseBody response) + +getChecklist :: TrelloChecklistID -> ReaderTrelloToken (Either Text [ChecklistItem]) +getChecklist checklist = do + url <- checklistURL checklist + (status, body) <- lift $ fetch url + pure $ + 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 = traverse getChecklist (card ^. idChecklists) + +updateList :: List -> ReaderTrelloToken (Either Text List) +updateList l = (setCards l <$>) . sequence <$> traverse updateCard (l ^. cards) + +getChecklists :: [List] -> ReaderTrelloToken (Either Text [List]) +getChecklists ls = sequence <$> traverse updateList ls + +getLists :: TrelloBoardID -> ReaderTrelloToken (Either Text Lists) +getLists board = do + putStrLn "Fetching from Trello..." + url <- boardURL board + (status, body) <- lift $ fetch url + case status of + 200 -> + case eitherDecodeStrict body of + Right raw -> fmap trelloListsToLists <$> getChecklists raw + Left err -> pure . Left $ parseError err + 404 -> + pure . Left $ "Could not find Trello board " <> board <> ". Make sure the ID is correct" + 401 -> pure . Left $ "You do not have permission to view Trello board " <> board + _ -> pure . Left $ tshow status <> " error. Cannot fetch from Trello." diff --git a/src/Taskell/IO/HTTP/Trello/Card.hs b/src/Taskell/IO/HTTP/Trello/Card.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/Trello/Card.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO.HTTP.Trello.Card + ( Card + , idChecklists + , cardToTask + , setChecklists + ) where + +import ClassyPrelude + +import Control.Lens (makeLenses, (&), (.~), (^.)) + +import Taskell.IO.HTTP.Aeson (deriveFromJSON) +import Taskell.IO.HTTP.Trello.ChecklistItem (ChecklistItem, checklistItemToSubTask) + +import Taskell.Data.Date (isoToTime) +import qualified Taskell.Data.Task as T (Task, due, new, setDescription, subtasks) + +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 +cardToTask :: Card -> T.Task +cardToTask card = + task & T.due .~ isoToTime (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/Taskell/IO/HTTP/Trello/ChecklistItem.hs b/src/Taskell/IO/HTTP/Trello/ChecklistItem.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/Trello/ChecklistItem.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO.HTTP.Trello.ChecklistItem + ( ChecklistItem + , checklistItemToSubTask + , checkItems + ) where + +import ClassyPrelude + +import Control.Lens (makeLenses, (^.)) +import qualified Taskell.Data.Subtask as ST (Subtask, new) +import Taskell.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/Taskell/IO/HTTP/Trello/List.hs b/src/Taskell/IO/HTTP/Trello/List.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/HTTP/Trello/List.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO.HTTP.Trello.List + ( List + , cards + , setCards + , listToList + ) where + +import ClassyPrelude + +import Control.Lens (makeLenses, (&), (.~), (^.)) + +import Taskell.IO.HTTP.Aeson (deriveFromJSON) +import Taskell.IO.HTTP.Trello.Card (Card, cardToTask) + +import qualified Taskell.Data.List as L (List, create) + +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 :: List -> L.List +listToList ls = L.create (ls ^. name) (fromList $ cardToTask <$> (ls ^. cards)) diff --git a/src/Taskell/IO/Keyboard.hs b/src/Taskell/IO/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Keyboard.hs @@ -0,0 +1,77 @@ +module Taskell.IO.Keyboard + ( generate + , defaultBindings + , badMapping + , addMissing + ) where + +import ClassyPrelude hiding ((\\)) + +import Data.Bitraversable (bitraverse) +import Data.List ((\\)) + +import qualified Taskell.Events.Actions.Types as A +import Taskell.IO.Keyboard.Types + +generate :: Bindings -> Actions -> BoundActions +generate bindings actions = + mapFromList . catMaybes $ bitraverse bindingToEvent (`lookup` actions) <$> bindings + +badMapping :: Bindings -> Either Text Bindings +badMapping bindings = + if null result + then Right bindings + else Left "invalid mapping" + where + result = filter ((== A.Nothing) . snd) bindings + +addMissing :: Bindings -> Bindings +addMissing bindings = bindings <> replaced + where + bnd = A.Nothing : (snd <$> bindings) + result = A.allActions \\ bnd + replaced = concat $ replace <$> result + +replace :: A.ActionType -> Bindings +replace action = filter ((==) action . snd) defaultBindings + +defaultBindings :: Bindings +defaultBindings = + [ (BChar 'q', A.Quit) + , (BChar 'u', A.Undo) + , (BChar 'r', A.Redo) + , (BChar '/', A.Search) + , (BChar '!', A.Due) + , (BChar '?', A.Help) + , (BChar 'k', A.Previous) + , (BChar 'j', A.Next) + , (BChar 'h', A.Left) + , (BChar 'l', A.Right) + , (BChar 'G', A.Bottom) + , (BChar 'g', A.Top) + , (BChar 'a', A.New) + , (BChar 'O', A.NewAbove) + , (BChar 'o', A.NewBelow) + , (BChar '+', A.Duplicate) + , (BChar 'e', A.Edit) + , (BChar 'A', A.Edit) + , (BChar 'i', A.Edit) + , (BChar 'C', A.Clear) + , (BChar 'D', A.Delete) + , (BKey "Enter", A.Detail) + , (BChar '@', A.DueDate) + , (BKey "Backspace", A.ClearDate) + , (BChar 'K', A.MoveUp) + , (BChar 'J', A.MoveDown) + , (BChar '˙', A.MoveLeftTop) + , (BChar '¬', A.MoveRightTop) + , (BChar 'H', A.MoveLeftBottom) + , (BChar 'L', A.MoveRightBottom) + , (BKey "Space", A.Complete) + , (BChar 'm', A.MoveMenu) + , (BChar 'N', A.ListNew) + , (BChar 'E', A.ListEdit) + , (BChar 'X', A.ListDelete) + , (BChar '>', A.ListRight) + , (BChar '<', A.ListLeft) + ] diff --git a/src/Taskell/IO/Keyboard/Parser.hs b/src/Taskell/IO/Keyboard/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Keyboard/Parser.hs @@ -0,0 +1,42 @@ +module Taskell.IO.Keyboard.Parser where + +import ClassyPrelude + +import Data.Attoparsec.Text + +import Taskell.Utility.Parser + +import Taskell.Events.Actions.Types (ActionType, read) +import Taskell.IO.Keyboard.Types + +-- utility functions +commentP :: Parser () +commentP = lexeme $ skipMany ((char '#' <|> char ';') *> manyTill anyChar endOfLine) + +stripComments :: Parser a -> Parser a +stripComments p = lexeme $ commentP *> p <* commentP + +-- ini parser +keyP :: Parser Binding +keyP = lexeme $ BKey <$> (char '<' *> word <* char '>') + +charP :: Parser Binding +charP = lexeme $ BChar <$> anyChar + +bindingP :: Parser [Binding] +bindingP = lexeme $ (keyP <|> charP) `sepBy` char ',' + +lineP :: Parser [(Binding, ActionType)] +lineP = + stripComments $ do + name <- read <$> word + _ <- lexeme $ char '=' + binds <- bindingP + pure $ (, name) <$> binds + +bindingsP :: Parser Bindings +bindingsP = stripComments $ concat <$> many' lineP + +-- run parser +bindings :: Text -> Either Text Bindings +bindings ini = first (const "Could not parse keyboard bindings.") (parseOnly bindingsP ini) diff --git a/src/Taskell/IO/Keyboard/Types.hs b/src/Taskell/IO/Keyboard/Types.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Keyboard/Types.hs @@ -0,0 +1,41 @@ +module Taskell.IO.Keyboard.Types where + +import ClassyPrelude + +import Graphics.Vty.Input.Events (Event (..), Key (..)) + +import qualified Taskell.Events.Actions.Types as A (ActionType) +import Taskell.Events.State.Types (Stateful) + +data Binding + = BChar Char + | BKey Text + deriving (Eq, Ord) + +type Bindings = [(Binding, A.ActionType)] + +type Actions = Map A.ActionType Stateful + +type BoundActions = Map Event Stateful + +instance Show Binding where + show (BChar c) = singleton c + show (BKey "Up") = "↑" + show (BKey "Down") = "↓" + show (BKey "Left") = "←" + show (BKey "Right") = "→" + show (BKey name) = "<" <> unpack name <> ">" + +bindingsToText :: Bindings -> A.ActionType -> [Text] +bindingsToText bindings key = tshow . fst <$> toList (filterMap (== key) bindings) + +bindingToEvent :: Binding -> Maybe Event +bindingToEvent (BChar char) = pure $ EvKey (KChar char) [] +bindingToEvent (BKey "Space") = pure $ EvKey (KChar ' ') [] +bindingToEvent (BKey "Backspace") = pure $ EvKey KBS [] +bindingToEvent (BKey "Enter") = pure $ EvKey KEnter [] +bindingToEvent (BKey "Left") = pure $ EvKey KLeft [] +bindingToEvent (BKey "Right") = pure $ EvKey KRight [] +bindingToEvent (BKey "Up") = pure $ EvKey KUp [] +bindingToEvent (BKey "Down") = pure $ EvKey KDown [] +bindingToEvent _ = Nothing diff --git a/src/Taskell/IO/Markdown.hs b/src/Taskell/IO/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Markdown.hs @@ -0,0 +1,8 @@ +module Taskell.IO.Markdown + ( parse + , serialize + , MarkdownInfo(MarkdownInfo) + ) where + +import Taskell.IO.Markdown.Parser (parse) +import Taskell.IO.Markdown.Serializer (MarkdownInfo (MarkdownInfo), serialize) diff --git a/src/Taskell/IO/Markdown/Parser.hs b/src/Taskell/IO/Markdown/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Markdown/Parser.hs @@ -0,0 +1,64 @@ +module Taskell.IO.Markdown.Parser + ( parse + ) where + +import ClassyPrelude + +import Data.Attoparsec.Text hiding (parse) + +import qualified Taskell.Data.Date as D (Due, textToTime) +import qualified Taskell.Data.List as L (List, create) +import qualified Taskell.Data.Lists as LS (Lists) +import qualified Taskell.Data.Subtask as ST (Subtask, new) +import qualified Taskell.Data.Task as T (Task, create) + +import Taskell.IO.Config.Markdown (Config, descriptionOutput, dueOutput, subtaskOutput, taskOutput, + titleOutput) +import Taskell.Utility.Parser (lexeme, line) + +-- config symbol parsing +type Symbol = (Config -> Text) -> Parser () + +symP :: Config -> Symbol +symP config fn = string (fn config) *> char ' ' $> () + +-- utility functions +emptyMay :: (MonoFoldable a) => a -> Maybe a +emptyMay a = + if null a + then Nothing + else Just a + +-- parsers +subtaskCompleteP :: Parser Bool +subtaskCompleteP = (== 'x') <$> (char '[' *> (char 'x' <|> char ' ') <* char ']' <* char ' ') + +subtaskP :: Symbol -> Parser ST.Subtask +subtaskP sym = flip ST.new <$> (sym subtaskOutput *> subtaskCompleteP) <*> line + +taskDescriptionP :: Symbol -> Parser (Maybe Text) +taskDescriptionP sym = emptyMay <$> (intercalate "\n" <$> many' (sym descriptionOutput *> line)) + +dueP :: Symbol -> Parser (Maybe D.Due) +dueP sym = (D.textToTime =<<) <$> optional (sym dueOutput *> line) + +taskNameP :: Symbol -> Parser Text +taskNameP sym = sym taskOutput *> line + +taskP :: Symbol -> Parser T.Task +taskP sym = + T.create <$> taskNameP sym <*> dueP sym <*> taskDescriptionP sym <*> + (fromList <$> many' (subtaskP sym)) + +listTitleP :: Symbol -> Parser Text +listTitleP sym = lexeme $ sym titleOutput *> line + +listP :: Symbol -> Parser L.List +listP sym = L.create <$> listTitleP sym <*> (fromList <$> many' (taskP sym)) + +markdownP :: Symbol -> Parser LS.Lists +markdownP sym = fromList <$> many1 (listP sym) <* endOfInput + +-- parse +parse :: Config -> Text -> Either Text LS.Lists +parse config txt = first (const "Could not parse file.") (parseOnly (markdownP (symP config)) txt) diff --git a/src/Taskell/IO/Markdown/Serializer.hs b/src/Taskell/IO/Markdown/Serializer.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/IO/Markdown/Serializer.hs @@ -0,0 +1,89 @@ +module Taskell.IO.Markdown.Serializer + ( serialize + , MarkdownInfo(MarkdownInfo) + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import qualified Data.Text as T (splitOn) + +import Data.Time.Zones (TZ) + +import Taskell.Data.Date (Due, timeToOutput, timeToOutputLocal) +import Taskell.Data.List (List, tasks, title) +import Taskell.Data.Lists (Lists) +import qualified Taskell.Data.Subtask as ST (Subtask, complete, name) +import qualified Taskell.Data.Task as T (Task, description, due, name, subtasks) + +import Taskell.IO.Config.Markdown (Config, descriptionOutput, dueOutput, localTimes, subtaskOutput, + taskOutput, titleOutput) + +data MarkdownInfo = MarkdownInfo + { mdTZ :: TZ + , mdConfig :: Config + } + +type ReaderMarkdown = Reader MarkdownInfo + +-- utility functions +askConf :: (Config -> a) -> ReaderMarkdown a +askConf fn = fn <$> asks mdConfig + +strMay :: (Applicative m) => (a -> m Text) -> Maybe a -> m Text +strMay _ Nothing = pure "" +strMay fn (Just a) = fn a + +space :: Text -> Text -> Text +space symbol txt = symbol <> " " <> txt + +timeFn :: ReaderMarkdown (Due -> Text) +timeFn = bool timeToOutput <$> (timeToOutputLocal <$> asks mdTZ) <*> askConf localTimes + +-- serializers +subtaskCompleteS :: Bool -> Text +subtaskCompleteS True = "[x]" +subtaskCompleteS False = "[ ]" + +subtaskS :: ST.Subtask -> ReaderMarkdown Text +subtaskS st = do + symbol <- askConf subtaskOutput + pure $ unwords [symbol, subtaskCompleteS (st ^. ST.complete), st ^. ST.name] + +subtasksS :: Seq ST.Subtask -> ReaderMarkdown Text +subtasksS sts = intercalate "\n" <$> sequence (subtaskS <$> sts) + +descriptionS :: Text -> ReaderMarkdown Text +descriptionS desc = do + symbol <- askConf descriptionOutput + pure . intercalate "\n" $ space symbol <$> T.splitOn "\n" desc + +dueS :: Due -> ReaderMarkdown Text +dueS due = do + symbol <- askConf dueOutput + fn <- timeFn + pure $ space symbol (fn due) + +nameS :: Text -> ReaderMarkdown Text +nameS desc = space <$> askConf taskOutput <*> pure desc + +taskS :: T.Task -> ReaderMarkdown Text +taskS t = + unlines . filter (/= "") <$> + sequence + [ nameS (t ^. T.name) + , strMay dueS (t ^. T.due) + , strMay descriptionS (t ^. T.description) + , subtasksS (t ^. T.subtasks) + ] + +listS :: List -> ReaderMarkdown Text +listS list = do + symbol <- askConf titleOutput + taskString <- concat <$> sequence (taskS <$> list ^. tasks) + pure . space symbol $ concat [list ^. title, "\n\n", taskString] + +-- serialize +serialize :: Lists -> ReaderMarkdown Text +serialize ls = intercalate "\n" <$> sequence (listS <$> ls) diff --git a/src/Taskell/Types.hs b/src/Taskell/Types.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Types.hs @@ -0,0 +1,16 @@ +module Taskell.Types where + +import ClassyPrelude + +newtype ListIndex = ListIndex + { showListIndex :: Int + } deriving (Show, Eq, Ord) + +newtype TaskIndex = TaskIndex + { showTaskIndex :: Int + } deriving (Show, Eq, Ord) + +type Pointer = (ListIndex, TaskIndex) + +startPointer :: Pointer +startPointer = (ListIndex 0, TaskIndex 0) diff --git a/src/Taskell/UI/CLI.hs b/src/Taskell/UI/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/CLI.hs @@ -0,0 +1,21 @@ +module Taskell.UI.CLI + ( prompt + , promptYN + , PromptYN(PromptYes) + ) where + +import ClassyPrelude + +prompt :: Text -> IO Text +prompt s = do + putStr $ s <> ": " + hFlush stdout -- prevents buffering + getLine + +data PromptYN + = PromptYes + | PromptNo + +promptYN :: PromptYN -> Text -> IO Bool +promptYN PromptYes s = not . flip elem ["n", "no"] . toLower <$> prompt (s <> " (Y/n)") +promptYN PromptNo s = not . flip elem ["y", "yes"] . toLower <$> prompt (s <> " (y/N)") diff --git a/src/Taskell/UI/Draw.hs b/src/Taskell/UI/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw.hs @@ -0,0 +1,39 @@ +module Taskell.UI.Draw + ( draw + , chooseCursor + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Control.Monad.Reader (runReader) + +import Brick + +import Taskell.Events.State (normalise) +import Taskell.Events.State.Types (State, mode) +import Taskell.Events.State.Types.Mode (DetailMode (..), ModalType (..), Mode (..)) +import Taskell.IO.Config.Layout (Config) +import Taskell.IO.Keyboard.Types (Bindings) +import Taskell.UI.Draw.Main (renderMain) +import Taskell.UI.Draw.Modal (renderModal) +import Taskell.UI.Draw.Types (DrawState (DrawState), ReaderDrawState, TWidget) +import Taskell.UI.Types (ResourceName (..)) + +-- draw +renderApp :: ReaderDrawState [TWidget] +renderApp = sequence [renderModal, renderMain] + +draw :: Config -> Bindings -> Bool -> State -> [TWidget] +draw layout bindings debug state = + runReader renderApp (DrawState layout bindings debug (normalise state)) + +-- cursors +chooseCursor :: State -> [CursorLocation ResourceName] -> Maybe (CursorLocation ResourceName) +chooseCursor state = + case normalise state ^. mode of + Insert {} -> showCursorNamed RNCursor + Search -> showCursorNamed RNCursor + Modal (Detail _ (DetailInsert _)) -> showCursorNamed RNCursor + _ -> neverShowCursor state diff --git a/src/Taskell/UI/Draw/Field.hs b/src/Taskell/UI/Draw/Field.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Field.hs @@ -0,0 +1,143 @@ +module Taskell.UI.Draw.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.Text.Width as V (safeWcwidth) +import qualified Graphics.Vty.Input.Events as V (Event (..), Key (..)) + +import qualified Taskell.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 + +widthFold :: [Int] -> Char -> [Int] +widthFold l t = l <> [V.safeWcwidth t] + +cursorPosition :: [Text] -> Int -> Int -> (Int, Int) +cursorPosition lns width cursor = + if x == width + then (0, y + 1) -- go to next line if at end of line + else (x, y) + where + parts = foldl' widthFold [] <$> lns -- list of list of individual character lengths + lengths = length <$> parts -- list of line lengths + cumulative = L.scanl1 (+) lengths -- cumulative total of line lengths + above = takeWhile (< cursor) cumulative -- lines above the cursor + y = length above -- number of lines above + adjustedCursor = cursor - fromMaybe 0 (lastMay above) -- subtract lines above from cursor position + cumulativeWidths = L.scanl1 (+) <$> index parts y -- get cumulative widths for current line + x = fromMaybe 0 $ flip index (adjustedCursor - 1) =<< cumulativeWidths + +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/Taskell/UI/Draw/Main.hs b/src/Taskell/UI/Draw/Main.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Main.hs @@ -0,0 +1,26 @@ +module Taskell.UI.Draw.Main + ( renderMain + ) where + +import ClassyPrelude + +import Brick +import Control.Lens ((^.)) +import Data.Sequence (mapWithIndex) + +import Taskell.Events.State.Types (lists) +import Taskell.IO.Config.Layout (padding, statusBar) +import Taskell.UI.Draw.Main.List (renderList) +import Taskell.UI.Draw.Main.Search (renderSearch) +import Taskell.UI.Draw.Main.StatusBar (renderStatusBar) +import Taskell.UI.Draw.Types (DSWidget, DrawState (..)) +import Taskell.UI.Types (ResourceName (..)) + +renderMain :: DSWidget +renderMain = do + ls <- (^. lists) <$> asks dsState + listWidgets <- toList <$> sequence (renderList `mapWithIndex` ls) + pad <- padding <$> asks dsLayout + let mainWidget = viewport RNLists Horizontal . padTopBottom pad $ hBox listWidgets + sb <- bool emptyWidget <$> renderStatusBar <*> (statusBar <$> asks dsLayout) + renderSearch (mainWidget <=> sb) diff --git a/src/Taskell/UI/Draw/Main/List.hs b/src/Taskell/UI/Draw/Main/List.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Main/List.hs @@ -0,0 +1,89 @@ +module Taskell.UI.Draw.Main.List + ( renderList + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Data.Char (chr, ord) +import Data.Sequence (mapWithIndex) + +import Brick + +import Taskell.Data.List (List, tasks, title) +import Taskell.Events.State.Types (current, mode) +import Taskell.IO.Config.Layout (columnPadding, columnWidth) +import Taskell.Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) +import Taskell.UI.Draw.Field (textField, widgetFromMaybe) +import Taskell.UI.Draw.Mode +import Taskell.UI.Draw.Task (renderTask) +import Taskell.UI.Draw.Types (DSWidget, DrawState (..), ReaderDrawState) +import Taskell.UI.Theme +import Taskell.UI.Types (ResourceName (..)) + +-- | Gets the relevant column prefix - number in normal mode, letter in moveTo +columnPrefix :: Int -> Int -> ReaderDrawState Text +columnPrefix selectedList i = do + m <- (^. mode) <$> asks dsState + if moveTo m + then do + let col = chr (i + ord 'a') + pure $ + if i /= selectedList && i >= 0 && i <= 26 + then singleton col <> ". " + else "" + else do + let col = i + 1 + pure $ + if col >= 1 && col <= 9 + then tshow col <> ". " + else "" + +-- | Renders the title for a list +renderTitle :: Int -> List -> DSWidget +renderTitle listIndex list = do + (ListIndex selectedList, TaskIndex selectedTask) <- (^. current) <$> asks dsState + editing <- (selectedList == listIndex &&) . editingTitle . (^. mode) <$> asks dsState + titleField <- getField . (^. mode) <$> asks dsState + 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 + pure $ + if editing || selectedList /= listIndex || selectedTask == 0 + then visible title' + else title' + +-- | Renders a list +renderList :: Int -> List -> DSWidget +renderList listIndex list = do + layout <- dsLayout <$> ask + eTitle <- editingTitle . (^. mode) <$> asks dsState + titleWidget <- renderTitle listIndex list + (ListIndex currentList, _) <- (^. current) <$> asks dsState + taskWidgets <- + sequence $ + renderTask (RNTask . (ListIndex listIndex, ) . TaskIndex) 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 + pure $ + if currentList == listIndex + then visible widget + else widget diff --git a/src/Taskell/UI/Draw/Main/Search.hs b/src/Taskell/UI/Draw/Main/Search.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Main/Search.hs @@ -0,0 +1,31 @@ +module Taskell.UI.Draw.Main.Search + ( renderSearch + ) where + +import Brick +import ClassyPrelude +import Control.Lens ((^.)) + +import Taskell.Events.State.Types (mode, searchTerm) +import Taskell.Events.State.Types.Mode (Mode (..)) +import Taskell.IO.Config.Layout (columnPadding) +import Taskell.UI.Draw.Field (field) +import Taskell.UI.Draw.Types (DSWidget, DrawState (..)) +import Taskell.UI.Theme +import Taskell.UI.Types (ResourceName (..)) + +renderSearch :: Widget ResourceName -> DSWidget +renderSearch mainWidget = do + m <- (^. mode) <$> asks dsState + term <- (^. searchTerm) <$> asks dsState + case term of + Just searchField -> do + colPad <- columnPadding . dsLayout <$> ask + let attr = + withAttr $ + case m of + Search -> taskCurrentAttr + _ -> taskAttr + let widget = attr . padLeftRight colPad $ txt "/" <+> field searchField + pure $ mainWidget <=> widget + _ -> pure mainWidget diff --git a/src/Taskell/UI/Draw/Main/StatusBar.hs b/src/Taskell/UI/Draw/Main/StatusBar.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Main/StatusBar.hs @@ -0,0 +1,65 @@ +module Taskell.UI.Draw.Main.StatusBar + ( renderStatusBar + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick + +import Taskell.Data.Lists (count) +import Taskell.Events.State.Types (current, lists, mode, path, searchTerm) + +import Taskell.Events.State.Types.Mode (ModalType (..), Mode (..)) +import Taskell.IO.Config.Layout (columnPadding) +import Taskell.Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) +import Taskell.UI.Draw.Field (Field) +import Taskell.UI.Draw.Types (DSWidget, DrawState (..), ReaderDrawState) +import Taskell.UI.Theme + +getPosition :: ReaderDrawState Text +getPosition = do + (ListIndex col, TaskIndex pos) <- (^. current) <$> asks dsState + len <- count col . (^. lists) <$> asks dsState + let posNorm = + if len > 0 + then pos + 1 + else 0 + pure $ tshow posNorm <> "/" <> tshow len + +modeToText :: Maybe Field -> Mode -> ReaderDrawState Text +modeToText fld md = do + debug <- asks dsDebug + pure $ + if debug + then tshow md + else case md of + Normal -> + case fld of + Nothing -> "NORMAL" + Just _ -> "NORMAL + SEARCH" + Insert {} -> "INSERT" + Modal Help -> "HELP" + Modal MoveTo -> "MOVE" + Modal Detail {} -> "DETAIL" + Modal Due {} -> "DUE" + Search {} -> "SEARCH" + _ -> "" + +getMode :: ReaderDrawState Text +getMode = do + state <- asks dsState + modeToText (state ^. searchTerm) (state ^. mode) + +renderStatusBar :: DSWidget +renderStatusBar = do + topPath <- pack . (^. path) <$> asks dsState + colPad <- columnPadding <$> asks dsLayout + posTxt <- getPosition + modeTxt <- getMode + let titl = padLeftRight colPad $ txt topPath + let pos = padRight (Pad colPad) $ txt posTxt + let md = txt modeTxt + let bar = padRight Max (titl <+> md) <+> pos + pure . padTop (Pad 1) $ withAttr statusBarAttr bar diff --git a/src/Taskell/UI/Draw/Modal.hs b/src/Taskell/UI/Draw/Modal.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Modal.hs @@ -0,0 +1,44 @@ +module Taskell.UI.Draw.Modal + ( renderModal + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center + +import Taskell.Events.State.Types (height, mode) +import Taskell.Events.State.Types.Mode (ModalType (..), Mode (..)) +import Taskell.UI.Draw.Field (textField) +import Taskell.UI.Draw.Modal.Detail (detail) +import Taskell.UI.Draw.Modal.Due (due) +import Taskell.UI.Draw.Modal.Help (help) +import Taskell.UI.Draw.Modal.MoveTo (moveTo) +import Taskell.UI.Draw.Types (DSWidget, DrawState (dsState), TWidget) +import Taskell.UI.Theme (titleAttr) +import Taskell.UI.Types (ResourceName (..)) + +surround :: (Text, TWidget) -> DSWidget +surround (title, widget) = do + ht <- (^. height) <$> asks dsState + let t = padBottom (Pad 1) . withAttr titleAttr $ textField title + pure . + padTopBottom 1 . + centerLayer . + border . + padTopBottom 1 . + padLeftRight 4 . vLimit (ht - 9) . hLimit 50 . (t <=>) . viewport RNModal Vertical $ + widget + +renderModal :: DSWidget +renderModal = do + md <- (^. mode) <$> asks dsState + case md of + Modal Help -> surround =<< help + Modal Detail {} -> surround =<< detail + Modal MoveTo -> surround =<< moveTo + Modal (Due tasks selected) -> surround =<< due tasks selected + _ -> pure emptyWidget diff --git a/src/Taskell/UI/Draw/Modal/Detail.hs b/src/Taskell/UI/Draw/Modal/Detail.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Modal/Detail.hs @@ -0,0 +1,88 @@ +module Taskell.UI.Draw.Modal.Detail + ( detail + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Data.Sequence (mapWithIndex) + +import Brick + +import Data.Time.Zones (TZ) + +import Taskell.Data.Date (deadline, timeToDisplay) +import qualified Taskell.Data.Subtask as ST (Subtask, complete, name) +import Taskell.Data.Task (Task, description, due, name, subtasks) +import Taskell.Events.State (getCurrentTask) +import Taskell.Events.State.Modal.Detail (getCurrentItem, getField) +import Taskell.Events.State.Types (time, timeZone) +import Taskell.Events.State.Types.Mode (DetailItem (..)) +import Taskell.UI.Draw.Field (Field, textField, widgetFromMaybe) +import Taskell.UI.Draw.Types (DrawState (..), ModalWidget, TWidget) +import Taskell.UI.Theme (disabledAttr, dlToAttr, subtaskCompleteAttr, + subtaskCurrentAttr, subtaskIncompleteAttr) + +renderSubtask :: Maybe Field -> DetailItem -> Int -> ST.Subtask -> TWidget +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 subtaskCurrentAttr + else (if done + then subtaskCompleteAttr + else subtaskIncompleteAttr)) + prefix = + attr . txt $ + if done + then "[x] " + else "[ ] " + widget = textField (subtask ^. ST.name) + final + | cur = visible . attr $ widgetFromMaybe widget f + | otherwise = attr widget + +renderSummary :: Maybe Field -> DetailItem -> Task -> TWidget +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 :: TZ -> UTCTime -> Maybe Field -> DetailItem -> Task -> TWidget +renderDate tz now field item task = + case item of + DetailDate -> visible $ prefix <+> widgetFromMaybe widget field + _ -> + case day of + Just d -> prefix <+> withAttr (dlToAttr (deadline now d)) widget + Nothing -> emptyWidget + where + day = task ^. due + prefix = txt "Due: " + widget = textField $ maybe "" (timeToDisplay tz) day + +detail :: ModalWidget +detail = do + state <- asks dsState + let now = state ^. time + let tz = state ^. timeZone + pure $ + 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 + pure (task ^. name, renderDate tz now f i task <=> renderSummary f i task <=> w) diff --git a/src/Taskell/UI/Draw/Modal/Due.hs b/src/Taskell/UI/Draw/Modal/Due.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Modal/Due.hs @@ -0,0 +1,39 @@ +module Taskell.UI.Draw.Modal.Due + ( due + ) where + +import ClassyPrelude + +import Brick +import Taskell.Data.Seq ((<#>)) + +import qualified Taskell.Data.Task as T (Task) +import Taskell.Types (Pointer) +import Taskell.UI.Draw.Task (TaskWidget (..), parts) +import Taskell.UI.Draw.Types (DSWidget, ModalWidget) +import Taskell.UI.Theme (taskAttr, taskCurrentAttr) +import Taskell.UI.Types (ResourceName (RNDue)) + +renderTask :: Int -> Int -> T.Task -> DSWidget +renderTask current position task = do + (TaskWidget text date _ _) <- parts task + let selected = current == position + let attr = + if selected + then taskCurrentAttr + else taskAttr + let shw = + if selected + then visible + else id + pure . shw . cached (RNDue position) . padBottom (Pad 1) . withAttr attr $ vBox [date, text] + +due :: Seq (Pointer, T.Task) -> Int -> ModalWidget +due tasks selected = do + let items = snd <$> tasks + widgets <- sequence $ renderTask selected <#> items + pure + ( "Due Tasks" + , if null items + then txt "No due tasks" + else vBox $ toList widgets) diff --git a/src/Taskell/UI/Draw/Modal/Help.hs b/src/Taskell/UI/Draw/Modal/Help.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Modal/Help.hs @@ -0,0 +1,68 @@ +module Taskell.UI.Draw.Modal.Help + ( help + ) where + +import ClassyPrelude + +import Brick +import Data.Text as T (justifyRight) + +import Taskell.Events.Actions.Types as A (ActionType (..)) +import Taskell.IO.Keyboard.Types (bindingsToText) + +import Taskell.IO.Keyboard.Types (Bindings) +import Taskell.UI.Draw.Field (textField) +import Taskell.UI.Draw.Types (DrawState (dsBindings), ModalWidget, TWidget) +import Taskell.UI.Theme (taskCurrentAttr) + +descriptions :: [([ActionType], Text)] +descriptions = + [ ([A.Help], "Show this list of controls") + , ([A.Due], "Show tasks with due dates") + , ([A.Previous, A.Next, A.Left, A.Right], "Move down / up / left / right") + , ([A.Bottom], "Go to bottom of list") + , ([A.Top], "Go to top of list") + , ([A.New], "Add a task") + , ([A.NewAbove, A.NewBelow], "Add a task above / below") + , ([A.Duplicate], "Duplicate a task") + , ([A.Edit], "Edit a task") + , ([A.Clear], "Change task") + , ([A.Detail], "Show task details / Edit task description") + , ([A.DueDate], "Add/edit due date (yyyy-mm-dd)") + , ([A.ClearDate], "Removes due date") + , ([A.MoveUp, A.MoveDown], "Shift task down / up") + , ([A.MoveLeftBottom, A.MoveRightBottom], "Shift task left / right (to bottom of list)") + , ([A.MoveLeftTop, A.MoveRightTop], "Shift task left / right (to top of list)") + , ( [A.Complete] + , "Move task to last list and remove any due dates / Mark subtask as (in)complete") + , ([A.MoveMenu], "Move task to specific list") + , ([A.Delete], "Delete task") + , ([A.Undo], "Undo") + , ([A.Redo], "Redo") + , ([A.ListNew], "New list") + , ([A.ListEdit], "Edit list title") + , ([A.ListDelete], "Delete list") + , ([A.ListLeft, A.ListRight], "Move list left / right") + , ([A.Search], "Search") + , ([A.Quit], "Quit") + ] + +generate :: Bindings -> [([Text], Text)] +generate bindings = first (intercalate ", " . bindingsToText bindings <$>) <$> descriptions + +format :: ([Text], Text) -> (Text, Text) +format = first (intercalate " / ") + +line :: Int -> (Text, Text) -> TWidget +line m (l, r) = left <+> right + where + left = padRight (Pad 2) . withAttr taskCurrentAttr . txt $ justifyRight m ' ' l + right = textField r + +help :: ModalWidget +help = do + bindings <- asks dsBindings + let ls = format <$> generate bindings + let m = foldl' max 0 $ length . fst <$> ls + let w = vBox $ line m <$> ls + pure ("Controls", w) diff --git a/src/Taskell/UI/Draw/Modal/MoveTo.hs b/src/Taskell/UI/Draw/Modal/MoveTo.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Modal/MoveTo.hs @@ -0,0 +1,30 @@ +module Taskell.UI.Draw.Modal.MoveTo + ( moveTo + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick + +import Taskell.Data.List (title) +import Taskell.Events.State.Types (current, lists) +import Taskell.Types (showListIndex) +import Taskell.UI.Draw.Field (textField) +import Taskell.UI.Draw.Types (DrawState (dsState), ModalWidget) +import Taskell.UI.Theme (taskCurrentAttr) + +moveTo :: ModalWidget +moveTo = do + skip <- showListIndex . fst . (^. current) <$> asks dsState + ls <- toList . (^. lists) <$> asks dsState + let titles = textField . (^. title) <$> ls + let letter a = + padRight (Pad 1) . hBox $ + [txt "[", withAttr taskCurrentAttr $ txt (singleton a), txt "]"] + let letters = letter <$> ['a' ..] + let remove i l = take i l <> drop (i + 1) l + let output (l, t) = l <+> t + let widget = vBox $ output <$> remove skip (zip letters titles) + pure ("Move To:", widget) diff --git a/src/Taskell/UI/Draw/Mode.hs b/src/Taskell/UI/Draw/Mode.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Mode.hs @@ -0,0 +1,18 @@ +module Taskell.UI.Draw.Mode where + +import ClassyPrelude + +import Taskell.Events.State.Types.Mode (InsertType (..), ModalType (..), Mode (..)) +import Taskell.UI.Draw.Field (Field) + +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 diff --git a/src/Taskell/UI/Draw/Task.hs b/src/Taskell/UI/Draw/Task.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Task.hs @@ -0,0 +1,107 @@ +module Taskell.UI.Draw.Task + ( TaskWidget(..) + , renderTask + , parts + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick + +import Taskell.Data.Date (deadline, timeToText) +import qualified Taskell.Data.Task as T (Task, contains, countCompleteSubtasks, + countSubtasks, description, due, hasSubtasks, + name) +import Taskell.Events.State.Types (current, mode, searchTerm, time, timeZone) +import Taskell.IO.Config.Layout (descriptionIndicator) +import Taskell.Types (ListIndex (..), TaskIndex (..)) +import Taskell.UI.Draw.Field (getText, textField, widgetFromMaybe) +import Taskell.UI.Draw.Mode +import Taskell.UI.Draw.Types (DSWidget, DrawState (..), ReaderDrawState, TWidget) +import Taskell.UI.Theme +import Taskell.UI.Types (ResourceName) + +data TaskWidget = TaskWidget + { textW :: TWidget + , dateW :: TWidget + , summaryW :: TWidget + , subtasksW :: TWidget + } + +-- | Takes a task's 'due' property and renders a date with appropriate styling (e.g. red if overdue) +renderDate :: T.Task -> DSWidget +renderDate task = do + now <- (^. time) <$> asks dsState + tz <- (^. timeZone) <$> asks dsState + pure . fromMaybe emptyWidget $ + (\date -> withAttr (dlToAttr $ deadline now date) (txt $ timeToText tz now date)) <$> + task ^. T.due + +-- | Renders the appropriate completed sub task count e.g. "[2/3]" +renderSubtaskCount :: T.Task -> DSWidget +renderSubtaskCount task = + pure . fromMaybe emptyWidget $ bool Nothing (Just indicator) (T.hasSubtasks task) + where + complete = tshow $ T.countCompleteSubtasks task + total = tshow $ T.countSubtasks task + indicator = txt $ concat ["[", complete, "/", total, "]"] + +-- | Renders the description indicator +renderDescIndicator :: T.Task -> DSWidget +renderDescIndicator task = do + indicator <- descriptionIndicator <$> asks dsLayout + pure . fromMaybe emptyWidget $ const (txt indicator) <$> task ^. T.description -- show the description indicator if one is set + +-- | Renders the task text +renderText :: T.Task -> DSWidget +renderText task = pure $ textField (task ^. T.name) + +-- | Renders the appropriate indicators: description, sub task count, and due date +indicators :: T.Task -> DSWidget +indicators task = do + widgets <- sequence (($ task) <$> [renderDescIndicator, renderSubtaskCount, renderDate]) + pure . hBox $ padRight (Pad 1) <$> widgets + +-- | The individual parts of a task widget +parts :: T.Task -> ReaderDrawState TaskWidget +parts task = + TaskWidget <$> renderText task <*> renderDate task <*> renderDescIndicator task <*> + renderSubtaskCount task + +-- | Renders an individual task +renderTask' :: (Int -> ResourceName) -> Int -> Int -> T.Task -> DSWidget +renderTask' rn listIndex taskIndex task = do + eTitle <- editingTitle . (^. mode) <$> asks dsState -- is the title being edited? (for visibility) + selected <- (== (ListIndex listIndex, TaskIndex taskIndex)) . (^. current) <$> asks dsState -- is the current task selected? + taskField <- getField . (^. mode) <$> asks dsState -- get the field, if it's being edited + after <- indicators task -- get the indicators widget + widget <- renderText task + let name = rn taskIndex + widget' = widgetFromMaybe widget taskField + pure $ + 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 + +renderTask :: (Int -> ResourceName) -> Int -> Int -> T.Task -> DSWidget +renderTask rn listIndex taskIndex task = do + searchT <- (getText <$>) . (^. searchTerm) <$> asks dsState + let taskWidget = renderTask' rn listIndex taskIndex task + case searchT of + Nothing -> taskWidget + Just term -> + if T.contains term task + then taskWidget + else pure emptyWidget diff --git a/src/Taskell/UI/Draw/Types.hs b/src/Taskell/UI/Draw/Types.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Draw/Types.hs @@ -0,0 +1,27 @@ +module Taskell.UI.Draw.Types where + +import ClassyPrelude + +import Brick (Widget) + +import Taskell.Events.State.Types (State) +import Taskell.IO.Config.Layout (Config) +import Taskell.IO.Keyboard.Types (Bindings) +import Taskell.UI.Types (ResourceName) + +data DrawState = DrawState + { dsLayout :: Config + , dsBindings :: Bindings + , dsDebug :: Bool + , dsState :: State + } + +-- | Use a Reader to pass around DrawState +type ReaderDrawState = ReaderT DrawState Identity + +-- | Aliases for common combinations +type TWidget = Widget ResourceName + +type ModalWidget = ReaderDrawState (Text, TWidget) + +type DSWidget = ReaderDrawState TWidget diff --git a/src/Taskell/UI/Theme.hs b/src/Taskell/UI/Theme.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Theme.hs @@ -0,0 +1,84 @@ +module Taskell.UI.Theme + ( titleAttr + , statusBarAttr + , titleCurrentAttr + , taskCurrentAttr + , subtaskCurrentAttr + , subtaskCompleteAttr + , subtaskIncompleteAttr + , taskAttr + , disabledAttr + , dlToAttr + , defaultTheme + ) where + +import Brick (AttrName, attrName) +import Brick.Themes (Theme, newTheme) +import Brick.Util (fg, on) +import Graphics.Vty + +import Taskell.Data.Date (Deadline (..)) + +-- attrs +statusBarAttr :: AttrName +statusBarAttr = attrName "statusBar" + +titleAttr :: AttrName +titleAttr = attrName "title" + +titleCurrentAttr :: AttrName +titleCurrentAttr = attrName "titleCurrent" + +taskCurrentAttr :: AttrName +taskCurrentAttr = attrName "taskCurrent" + +taskAttr :: AttrName +taskAttr = attrName "task" + +subtaskCurrentAttr :: AttrName +subtaskCurrentAttr = attrName "subtaskCurrent" + +subtaskCompleteAttr :: AttrName +subtaskCompleteAttr = attrName "subtaskComplete" + +subtaskIncompleteAttr :: AttrName +subtaskIncompleteAttr = attrName "subtaskIncomplete" + +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 + [ (statusBarAttr, black `on` green) + , (titleAttr, fg green) + , (titleCurrentAttr, fg blue) + , (taskCurrentAttr, fg magenta) + , (subtaskCurrentAttr, fg magenta) + , (subtaskIncompleteAttr, fg blue) + , (subtaskCompleteAttr, fg yellow) + , (taskCurrentAttr, fg magenta) + , (disabledAttr, fg yellow) + , (dlDue, fg red) + , (dlSoon, fg yellow) + , (dlFar, fg green) + ] diff --git a/src/Taskell/UI/Types.hs b/src/Taskell/UI/Types.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/UI/Types.hs @@ -0,0 +1,14 @@ +module Taskell.UI.Types where + +import ClassyPrelude (Eq, Int, Ord, Show) + +import Taskell.Types (ListIndex, TaskIndex) + +data ResourceName + = RNCursor + | RNTask (ListIndex, TaskIndex) + | RNList Int + | RNLists + | RNModal + | RNDue Int + deriving (Show, Eq, Ord) diff --git a/src/Taskell/Utility/Parser.hs b/src/Taskell/Utility/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Taskell/Utility/Parser.hs @@ -0,0 +1,17 @@ +module Taskell.Utility.Parser where + +import ClassyPrelude + +import Data.Attoparsec.Text + +only :: Parser a -> Parser a +only p = p <* endOfInput + +lexeme :: Parser a -> Parser a +lexeme p = skipSpace *> p <* skipSpace + +line :: Parser Text +line = (takeTill isEndOfLine <* endOfLine) <|> takeText + +word :: Parser Text +word = lexeme $ pack <$> many1 letter diff --git a/src/Types.hs b/src/Types.hs deleted file mode 100644 --- a/src/Types.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Types where - -import ClassyPrelude - -newtype ListIndex = ListIndex - { showListIndex :: Int - } deriving (Show, Eq, Ord) - -newtype TaskIndex = TaskIndex - { showTaskIndex :: Int - } deriving (Show, Eq, Ord) - -type Pointer = (ListIndex, TaskIndex) - -startPointer :: Pointer -startPointer = (ListIndex 0, TaskIndex 0) diff --git a/src/UI/CLI.hs b/src/UI/CLI.hs deleted file mode 100644 --- a/src/UI/CLI.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.CLI - ( prompt - , promptYN - , PromptYN(PromptYes) - ) where - -import ClassyPrelude - -prompt :: Text -> IO Text -prompt s = do - putStr $ s <> ": " - hFlush stdout -- prevents buffering - getLine - -data PromptYN - = PromptYes - | PromptNo - -promptYN :: PromptYN -> Text -> IO Bool -promptYN PromptYes s = not . flip elem ["n", "no"] . toLower <$> prompt (s <> " (Y/n)") -promptYN PromptNo s = not . flip elem ["y", "yes"] . toLower <$> prompt (s <> " (y/N)") diff --git a/src/UI/Draw.hs b/src/UI/Draw.hs deleted file mode 100644 --- a/src/UI/Draw.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module UI.Draw - ( draw - , chooseCursor - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Control.Monad.Reader (runReader) - -import Brick - -import Events.State (normalise) -import Events.State.Types (State, mode) -import Events.State.Types.Mode (DetailMode (..), ModalType (..), Mode (..)) -import IO.Config.Layout (Config) -import IO.Keyboard.Types (Bindings) -import UI.Draw.Main (renderMain) -import UI.Draw.Modal (renderModal) -import UI.Draw.Types (DrawState (DrawState), ReaderDrawState, TWidget) -import UI.Types (ResourceName (..)) - --- draw -renderApp :: ReaderDrawState [TWidget] -renderApp = sequence [renderModal, renderMain] - -draw :: Config -> Bindings -> Bool -> State -> [TWidget] -draw layout bindings debug state = - runReader renderApp (DrawState layout bindings debug (normalise state)) - --- cursors -chooseCursor :: State -> [CursorLocation ResourceName] -> Maybe (CursorLocation ResourceName) -chooseCursor state = - case normalise state ^. mode of - Insert {} -> showCursorNamed RNCursor - Search -> showCursorNamed RNCursor - Modal (Detail _ (DetailInsert _)) -> showCursorNamed RNCursor - _ -> neverShowCursor state diff --git a/src/UI/Draw/Field.hs b/src/UI/Draw/Field.hs deleted file mode 100644 --- a/src/UI/Draw/Field.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Draw.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.Text.Width as V (safeWcwidth) -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 - -widthFold :: [Int] -> Char -> [Int] -widthFold l t = l <> [V.safeWcwidth t] - -cursorPosition :: [Text] -> Int -> Int -> (Int, Int) -cursorPosition lns width cursor = - if x == width - then (0, y + 1) -- go to next line if at end of line - else (x, y) - where - parts = foldl' widthFold [] <$> lns -- list of list of individual character lengths - lengths = length <$> parts -- list of line lengths - cumulative = L.scanl1 (+) lengths -- cumulative total of line lengths - above = takeWhile (< cursor) cumulative -- lines above the cursor - y = length above -- number of lines above - adjustedCursor = cursor - fromMaybe 0 (lastMay above) -- subtract lines above from cursor position - cumulativeWidths = L.scanl1 (+) <$> index parts y -- get cumulative widths for current line - x = fromMaybe 0 $ flip index (adjustedCursor - 1) =<< cumulativeWidths - -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/Draw/Main.hs b/src/UI/Draw/Main.hs deleted file mode 100644 --- a/src/UI/Draw/Main.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module UI.Draw.Main - ( renderMain - ) where - -import ClassyPrelude - -import Brick -import Control.Lens ((^.)) -import Data.Sequence (mapWithIndex) - -import Events.State.Types (lists) -import IO.Config.Layout (padding, statusBar) -import UI.Draw.Main.List (renderList) -import UI.Draw.Main.Search (renderSearch) -import UI.Draw.Main.StatusBar (renderStatusBar) -import UI.Draw.Types (DSWidget, DrawState (..)) -import UI.Types (ResourceName (..)) - -renderMain :: DSWidget -renderMain = do - ls <- (^. lists) <$> asks dsState - listWidgets <- toList <$> sequence (renderList `mapWithIndex` ls) - pad <- padding <$> asks dsLayout - let mainWidget = viewport RNLists Horizontal . padTopBottom pad $ hBox listWidgets - sb <- bool emptyWidget <$> renderStatusBar <*> (statusBar <$> asks dsLayout) - renderSearch (mainWidget <=> sb) diff --git a/src/UI/Draw/Main/List.hs b/src/UI/Draw/Main/List.hs deleted file mode 100644 --- a/src/UI/Draw/Main/List.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -module UI.Draw.Main.List - ( renderList - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Data.Char (chr, ord) -import Data.Sequence (mapWithIndex) - -import Brick - -import Data.Taskell.List (List, tasks, title) -import Events.State.Types (current, mode) -import IO.Config.Layout (columnPadding, columnWidth) -import Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) -import UI.Draw.Field (textField, widgetFromMaybe) -import UI.Draw.Mode -import UI.Draw.Task (renderTask) -import UI.Draw.Types (DSWidget, DrawState (..), ReaderDrawState) -import UI.Theme -import UI.Types (ResourceName (..)) - --- | Gets the relevant column prefix - number in normal mode, letter in moveTo -columnPrefix :: Int -> Int -> ReaderDrawState Text -columnPrefix selectedList i = do - m <- (^. mode) <$> asks dsState - if moveTo m - then do - let col = chr (i + ord 'a') - pure $ - if i /= selectedList && i >= 0 && i <= 26 - then singleton col <> ". " - else "" - else do - let col = i + 1 - pure $ - if col >= 1 && col <= 9 - then tshow col <> ". " - else "" - --- | Renders the title for a list -renderTitle :: Int -> List -> DSWidget -renderTitle listIndex list = do - (ListIndex selectedList, TaskIndex selectedTask) <- (^. current) <$> asks dsState - editing <- (selectedList == listIndex &&) . editingTitle . (^. mode) <$> asks dsState - titleField <- getField . (^. mode) <$> asks dsState - 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 - pure $ - if editing || selectedList /= listIndex || selectedTask == 0 - then visible title' - else title' - --- | Renders a list -renderList :: Int -> List -> DSWidget -renderList listIndex list = do - layout <- dsLayout <$> ask - eTitle <- editingTitle . (^. mode) <$> asks dsState - titleWidget <- renderTitle listIndex list - (ListIndex currentList, _) <- (^. current) <$> asks dsState - taskWidgets <- - sequence $ - renderTask (RNTask . (ListIndex listIndex, ) . TaskIndex) 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 - pure $ - if currentList == listIndex - then visible widget - else widget diff --git a/src/UI/Draw/Main/Search.hs b/src/UI/Draw/Main/Search.hs deleted file mode 100644 --- a/src/UI/Draw/Main/Search.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Draw.Main.Search - ( renderSearch - ) where - -import Brick -import ClassyPrelude -import Control.Lens ((^.)) - -import Events.State.Types (mode, searchTerm) -import Events.State.Types.Mode (Mode (..)) -import IO.Config.Layout (columnPadding) -import UI.Draw.Field (field) -import UI.Draw.Types (DSWidget, DrawState (..)) -import UI.Theme -import UI.Types (ResourceName (..)) - -renderSearch :: Widget ResourceName -> DSWidget -renderSearch mainWidget = do - m <- (^. mode) <$> asks dsState - term <- (^. searchTerm) <$> asks dsState - case term of - Just searchField -> do - colPad <- columnPadding . dsLayout <$> ask - let attr = - withAttr $ - case m of - Search -> taskCurrentAttr - _ -> taskAttr - let widget = attr . padLeftRight colPad $ txt "/" <+> field searchField - pure $ mainWidget <=> widget - _ -> pure mainWidget diff --git a/src/UI/Draw/Main/StatusBar.hs b/src/UI/Draw/Main/StatusBar.hs deleted file mode 100644 --- a/src/UI/Draw/Main/StatusBar.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} - -module UI.Draw.Main.StatusBar - ( renderStatusBar - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Brick - -import Data.Taskell.Lists (count) -import Events.State.Types (current, lists, mode, path, searchTerm) - -import Events.State.Types.Mode (ModalType (..), Mode (..)) -import IO.Config.Layout (columnPadding) -import Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) -import UI.Draw.Field (Field) -import UI.Draw.Types (DSWidget, DrawState (..), ReaderDrawState) -import UI.Theme - -getPosition :: ReaderDrawState Text -getPosition = do - (ListIndex col, TaskIndex pos) <- (^. current) <$> asks dsState - len <- count col . (^. lists) <$> asks dsState - let posNorm = - if len > 0 - then pos + 1 - else 0 - pure $ tshow posNorm <> "/" <> tshow len - -modeToText :: Maybe Field -> Mode -> ReaderDrawState Text -modeToText fld md = do - debug <- asks dsDebug - pure $ - if debug - then tshow md - else case md of - Normal -> - case fld of - Nothing -> "NORMAL" - Just _ -> "NORMAL + SEARCH" - Insert {} -> "INSERT" - Modal Help -> "HELP" - Modal MoveTo -> "MOVE" - Modal Detail {} -> "DETAIL" - Modal Due {} -> "DUE" - Search {} -> "SEARCH" - _ -> "" - -getMode :: ReaderDrawState Text -getMode = do - state <- asks dsState - modeToText (state ^. searchTerm) (state ^. mode) - -renderStatusBar :: DSWidget -renderStatusBar = do - topPath <- pack . (^. path) <$> asks dsState - colPad <- columnPadding <$> asks dsLayout - posTxt <- getPosition - modeTxt <- getMode - let titl = padLeftRight colPad $ txt topPath - let pos = padRight (Pad colPad) $ txt posTxt - let md = txt modeTxt - let bar = padRight Max (titl <+> md) <+> pos - pure . padTop (Pad 1) $ withAttr statusBarAttr bar diff --git a/src/UI/Draw/Modal.hs b/src/UI/Draw/Modal.hs deleted file mode 100644 --- a/src/UI/Draw/Modal.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module UI.Draw.Modal - ( renderModal - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Brick -import Brick.Widgets.Border -import Brick.Widgets.Center - -import Events.State.Types (height, mode) -import Events.State.Types.Mode (ModalType (..), Mode (..)) -import UI.Draw.Field (textField) -import UI.Draw.Modal.Detail (detail) -import UI.Draw.Modal.Due (due) -import UI.Draw.Modal.Help (help) -import UI.Draw.Modal.MoveTo (moveTo) -import UI.Draw.Types (DSWidget, DrawState (dsState), TWidget) -import UI.Theme (titleAttr) -import UI.Types (ResourceName (..)) - -surround :: (Text, TWidget) -> DSWidget -surround (title, widget) = do - ht <- (^. height) <$> asks dsState - let t = padBottom (Pad 1) . withAttr titleAttr $ textField title - pure . - padTopBottom 1 . - centerLayer . - border . - padTopBottom 1 . - padLeftRight 4 . vLimit (ht - 9) . hLimit 50 . (t <=>) . viewport RNModal Vertical $ - widget - -renderModal :: DSWidget -renderModal = do - md <- (^. mode) <$> asks dsState - case md of - Modal Help -> surround =<< help - Modal Detail {} -> surround =<< detail - Modal MoveTo -> surround =<< moveTo - Modal (Due tasks selected) -> surround =<< due tasks selected - _ -> pure emptyWidget diff --git a/src/UI/Draw/Modal/Detail.hs b/src/UI/Draw/Modal/Detail.hs deleted file mode 100644 --- a/src/UI/Draw/Modal/Detail.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Draw.Modal.Detail - ( detail - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Data.Sequence (mapWithIndex) - -import Brick - -import Data.Time.Zones (TZ) - -import Data.Taskell.Date (deadline, timeToDisplay) -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 (time, timeZone) -import Events.State.Types.Mode (DetailItem (..)) -import UI.Draw.Field (Field, textField, widgetFromMaybe) -import UI.Draw.Types (DrawState (..), ModalWidget, TWidget) -import UI.Theme (disabledAttr, dlToAttr, taskCurrentAttr, - titleCurrentAttr) - -renderSubtask :: Maybe Field -> DetailItem -> Int -> ST.Subtask -> TWidget -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 -> TWidget -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 :: TZ -> UTCTime -> Maybe Field -> DetailItem -> Task -> TWidget -renderDate tz now field item task = - case item of - DetailDate -> visible $ prefix <+> widgetFromMaybe widget field - _ -> - case day of - Just d -> prefix <+> withAttr (dlToAttr (deadline now d)) widget - Nothing -> emptyWidget - where - day = task ^. due - prefix = txt "Due: " - widget = textField $ maybe "" (timeToDisplay tz) day - -detail :: ModalWidget -detail = do - state <- asks dsState - let now = state ^. time - let tz = state ^. timeZone - pure $ - 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 - pure (task ^. name, renderDate tz now f i task <=> renderSummary f i task <=> w) diff --git a/src/UI/Draw/Modal/Due.hs b/src/UI/Draw/Modal/Due.hs deleted file mode 100644 --- a/src/UI/Draw/Modal/Due.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Draw.Modal.Due - ( due - ) where - -import ClassyPrelude - -import Brick -import Data.Taskell.Seq ((<#>)) - -import qualified Data.Taskell.Task as T (Task) -import Types (Pointer) -import UI.Draw.Task (TaskWidget (..), parts) -import UI.Draw.Types (DSWidget, ModalWidget) -import UI.Theme (taskAttr, taskCurrentAttr) -import UI.Types (ResourceName (RNDue)) - -renderTask :: Int -> Int -> T.Task -> DSWidget -renderTask current position task = do - (TaskWidget text date _ _) <- parts task - let selected = current == position - let attr = - if selected - then taskCurrentAttr - else taskAttr - let shw = - if selected - then visible - else id - pure . shw . cached (RNDue position) . padBottom (Pad 1) . withAttr attr $ vBox [date, text] - -due :: Seq (Pointer, T.Task) -> Int -> ModalWidget -due tasks selected = do - let items = snd <$> tasks - widgets <- sequence $ renderTask selected <#> items - pure - ( "Due Tasks" - , if null items - then txt "No due tasks" - else vBox $ toList widgets) diff --git a/src/UI/Draw/Modal/Help.hs b/src/UI/Draw/Modal/Help.hs deleted file mode 100644 --- a/src/UI/Draw/Modal/Help.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Draw.Modal.Help - ( help - ) where - -import ClassyPrelude - -import Brick -import Data.Text as T (justifyRight) - -import Events.Actions.Types as A (ActionType (..)) -import IO.Keyboard.Types (bindingsToText) - -import IO.Keyboard.Types (Bindings) -import UI.Draw.Field (textField) -import UI.Draw.Types (DrawState (dsBindings), ModalWidget, TWidget) -import UI.Theme (taskCurrentAttr) - -descriptions :: [([ActionType], Text)] -descriptions = - [ ([A.Help], "Show this list of controls") - , ([A.Due], "Show tasks with due dates") - , ([A.Previous, A.Next, A.Left, A.Right], "Move down / up / left / right") - , ([A.Bottom], "Go to bottom of list") - , ([A.Top], "Go to top of list") - , ([A.New], "Add a task") - , ([A.NewAbove, A.NewBelow], "Add a task above / below") - , ([A.Duplicate], "Duplicate a task") - , ([A.Edit], "Edit a task") - , ([A.Clear], "Change task") - , ([A.Detail], "Show task details / Edit task description") - , ([A.DueDate], "Add/edit due date (yyyy-mm-dd)") - , ([A.ClearDate], "Removes due date") - , ([A.MoveUp, A.MoveDown], "Shift task down / up") - , ([A.MoveLeft, A.MoveRight], "Shift task left / right") - , ( [A.Complete] - , "Move task to last list and remove any due dates / Mark subtask as (in)complete") - , ([A.MoveMenu], "Move task to specific list") - , ([A.Delete], "Delete task") - , ([A.Undo], "Undo") - , ([A.Redo], "Redo") - , ([A.ListNew], "New list") - , ([A.ListEdit], "Edit list title") - , ([A.ListDelete], "Delete list") - , ([A.ListLeft, A.ListRight], "Move list left / right") - , ([A.Search], "Search") - , ([A.Quit], "Quit") - ] - -generate :: Bindings -> [([Text], Text)] -generate bindings = first (intercalate ", " . bindingsToText bindings <$>) <$> descriptions - -format :: ([Text], Text) -> (Text, Text) -format = first (intercalate " / ") - -line :: Int -> (Text, Text) -> TWidget -line m (l, r) = left <+> right - where - left = padRight (Pad 2) . withAttr taskCurrentAttr . txt $ justifyRight m ' ' l - right = textField r - -help :: ModalWidget -help = do - bindings <- asks dsBindings - let ls = format <$> generate bindings - let m = foldl' max 0 $ length . fst <$> ls - let w = vBox $ line m <$> ls - pure ("Controls", w) diff --git a/src/UI/Draw/Modal/MoveTo.hs b/src/UI/Draw/Modal/MoveTo.hs deleted file mode 100644 --- a/src/UI/Draw/Modal/MoveTo.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Draw.Modal.MoveTo - ( moveTo - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Brick - -import Data.Taskell.List (title) -import Events.State.Types (current, lists) -import Types (showListIndex) -import UI.Draw.Field (textField) -import UI.Draw.Types (DrawState (dsState), ModalWidget) -import UI.Theme (taskCurrentAttr) - -moveTo :: ModalWidget -moveTo = do - skip <- showListIndex . fst . (^. current) <$> asks dsState - ls <- toList . (^. lists) <$> asks dsState - let titles = textField . (^. title) <$> ls - let letter a = - padRight (Pad 1) . hBox $ - [txt "[", withAttr taskCurrentAttr $ txt (singleton a), txt "]"] - let letters = letter <$> ['a' ..] - let remove i l = take i l <> drop (i + 1) l - let output (l, t) = l <+> t - let widget = vBox $ output <$> remove skip (zip letters titles) - pure ("Move To:", widget) diff --git a/src/UI/Draw/Mode.hs b/src/UI/Draw/Mode.hs deleted file mode 100644 --- a/src/UI/Draw/Mode.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module UI.Draw.Mode where - -import ClassyPrelude - -import Events.State.Types.Mode (InsertType (..), ModalType (..), Mode (..)) -import UI.Draw.Field (Field) - -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 diff --git a/src/UI/Draw/Task.hs b/src/UI/Draw/Task.hs deleted file mode 100644 --- a/src/UI/Draw/Task.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Draw.Task - ( TaskWidget(..) - , renderTask - , parts - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Brick - -import Data.Taskell.Date (deadline, timeToText) -import qualified Data.Taskell.Task as T (Task, contains, countCompleteSubtasks, countSubtasks, - description, due, hasSubtasks, name) -import Events.State.Types (current, mode, searchTerm, time, timeZone) -import IO.Config.Layout (descriptionIndicator) -import Types (ListIndex (..), TaskIndex (..)) -import UI.Draw.Field (getText, textField, widgetFromMaybe) -import UI.Draw.Mode -import UI.Draw.Types (DSWidget, DrawState (..), ReaderDrawState, TWidget) -import UI.Theme -import UI.Types (ResourceName) - -data TaskWidget = TaskWidget - { textW :: TWidget - , dateW :: TWidget - , summaryW :: TWidget - , subtasksW :: TWidget - } - --- | Takes a task's 'due' property and renders a date with appropriate styling (e.g. red if overdue) -renderDate :: T.Task -> DSWidget -renderDate task = do - now <- (^. time) <$> asks dsState - tz <- (^. timeZone) <$> asks dsState - pure . fromMaybe emptyWidget $ - (\date -> withAttr (dlToAttr $ deadline now date) (txt $ timeToText tz now date)) <$> - task ^. T.due - --- | Renders the appropriate completed sub task count e.g. "[2/3]" -renderSubtaskCount :: T.Task -> DSWidget -renderSubtaskCount task = - pure . fromMaybe emptyWidget $ bool Nothing (Just indicator) (T.hasSubtasks task) - where - complete = tshow $ T.countCompleteSubtasks task - total = tshow $ T.countSubtasks task - indicator = txt $ concat ["[", complete, "/", total, "]"] - --- | Renders the description indicator -renderDescIndicator :: T.Task -> DSWidget -renderDescIndicator task = do - indicator <- descriptionIndicator <$> asks dsLayout - pure . fromMaybe emptyWidget $ const (txt indicator) <$> task ^. T.description -- show the description indicator if one is set - --- | Renders the task text -renderText :: T.Task -> DSWidget -renderText task = pure $ textField (task ^. T.name) - --- | Renders the appropriate indicators: description, sub task count, and due date -indicators :: T.Task -> DSWidget -indicators task = do - widgets <- sequence (($ task) <$> [renderDescIndicator, renderSubtaskCount, renderDate]) - pure . hBox $ padRight (Pad 1) <$> widgets - --- | The individual parts of a task widget -parts :: T.Task -> ReaderDrawState TaskWidget -parts task = - TaskWidget <$> renderText task <*> renderDate task <*> renderDescIndicator task <*> - renderSubtaskCount task - --- | Renders an individual task -renderTask' :: (Int -> ResourceName) -> Int -> Int -> T.Task -> DSWidget -renderTask' rn listIndex taskIndex task = do - eTitle <- editingTitle . (^. mode) <$> asks dsState -- is the title being edited? (for visibility) - selected <- (== (ListIndex listIndex, TaskIndex taskIndex)) . (^. current) <$> asks dsState -- is the current task selected? - taskField <- getField . (^. mode) <$> asks dsState -- get the field, if it's being edited - after <- indicators task -- get the indicators widget - widget <- renderText task - let name = rn taskIndex - widget' = widgetFromMaybe widget taskField - pure $ - 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 - -renderTask :: (Int -> ResourceName) -> Int -> Int -> T.Task -> DSWidget -renderTask rn listIndex taskIndex task = do - searchT <- (getText <$>) . (^. searchTerm) <$> asks dsState - let taskWidget = renderTask' rn listIndex taskIndex task - case searchT of - Nothing -> taskWidget - Just term -> - if T.contains term task - then taskWidget - else pure emptyWidget diff --git a/src/UI/Draw/Types.hs b/src/UI/Draw/Types.hs deleted file mode 100644 --- a/src/UI/Draw/Types.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module UI.Draw.Types where - -import ClassyPrelude - -import Brick (Widget) - -import Events.State.Types (State) -import IO.Config.Layout (Config) -import IO.Keyboard.Types (Bindings) -import UI.Types (ResourceName) - -data DrawState = DrawState - { dsLayout :: Config - , dsBindings :: Bindings - , dsDebug :: Bool - , dsState :: State - } - --- | Use a Reader to pass around DrawState -type ReaderDrawState = ReaderT DrawState Identity - --- | Aliases for common combinations -type TWidget = Widget ResourceName - -type ModalWidget = ReaderDrawState (Text, TWidget) - -type DSWidget = ReaderDrawState TWidget diff --git a/src/UI/Theme.hs b/src/UI/Theme.hs deleted file mode 100644 --- a/src/UI/Theme.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module UI.Theme - ( titleAttr - , statusBarAttr - , titleCurrentAttr - , taskCurrentAttr - , taskAttr - , disabledAttr - , dlToAttr - , defaultTheme - ) where - -import Brick (AttrName, attrName) -import Brick.Themes (Theme, newTheme) -import Brick.Util (fg, on) -import Graphics.Vty - -import Data.Taskell.Date (Deadline (..)) - --- attrs -statusBarAttr :: AttrName -statusBarAttr = attrName "statusBar" - -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 - [ (statusBarAttr, black `on` green) - , (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 deleted file mode 100644 --- a/src/UI/Types.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module UI.Types where - -import ClassyPrelude (Eq, Int, Ord, Show) - -import Types (ListIndex, TaskIndex) - -data ResourceName - = RNCursor - | RNTask (ListIndex, TaskIndex) - | RNList Int - | RNLists - | RNModal - | RNDue Int - deriving (Show, Eq, Ord) diff --git a/src/Utility/Parser.hs b/src/Utility/Parser.hs deleted file mode 100644 --- a/src/Utility/Parser.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Utility.Parser where - -import ClassyPrelude - -import Data.Attoparsec.Text - -only :: Parser a -> Parser a -only p = p <* endOfInput - -lexeme :: Parser a -> Parser a -lexeme p = skipSpace *> p <* skipSpace - -line :: Parser Text -line = (takeTill isEndOfLine <* endOfLine) <|> takeText - -word :: Parser Text -word = lexeme $ pack <$> many1 letter diff --git a/taskell.cabal b/taskell.cabal --- a/taskell.cabal +++ b/taskell.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: taskell -version: 1.9.2.0 +version: 1.9.3.0 license: BSD3 license-file: LICENSE copyright: 2019 Mark Wales @@ -22,6 +22,9 @@ templates/theme.ini templates/trello-token.txt templates/usage.txt + test/Taskell/IO/data/trello-checklists.json + test/Taskell/IO/data/trello.json + test/Taskell/IO/Keyboard/data/bindings.ini source-repository head type: git @@ -29,106 +32,107 @@ library exposed-modules: - App - Events.State - IO.Config - IO.Taskell - Data.Taskell.Date - Data.Taskell.Date.RelativeParser - 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.Actions.Types - Events.State.History - Events.State.Types - Events.State.Types.Mode - IO.Config.Markdown - IO.Markdown.Parser - IO.Markdown.Serializer - IO.HTTP.GitHub - IO.HTTP.GitHub.Card - IO.HTTP.Trello.List - IO.HTTP.Trello.ChecklistItem - IO.Keyboard - IO.Keyboard.Parser - IO.Keyboard.Types - UI.Draw.Field - Types + Taskell + Taskell.Events.State + Taskell.IO.Config + Taskell.IO + Taskell.Data.Date + Taskell.Data.Date.RelativeParser + Taskell.Data.List + Taskell.Data.List.Internal + Taskell.Data.Lists + Taskell.Data.Lists.Internal + Taskell.Data.Seq + Taskell.Data.Subtask + Taskell.Data.Subtask.Internal + Taskell.Data.Task + Taskell.Data.Task.Internal + Taskell.Events.Actions.Types + Taskell.Events.State.History + Taskell.Events.State.Types + Taskell.Events.State.Types.Mode + Taskell.IO.Config.Markdown + Taskell.IO.Markdown.Parser + Taskell.IO.Markdown.Serializer + Taskell.IO.HTTP.GitHub + Taskell.IO.HTTP.GitHub.Card + Taskell.IO.HTTP.Trello.List + Taskell.IO.HTTP.Trello.ChecklistItem + Taskell.IO.Keyboard + Taskell.IO.Keyboard.Parser + Taskell.IO.Keyboard.Types + Taskell.UI.Draw.Field + Taskell.Types hs-source-dirs: src other-modules: - Config - Data.Taskell.Date.Types - Events.Actions - Events.Actions.Insert - Events.Actions.Modal - Events.Actions.Modal.Detail - Events.Actions.Modal.Due - Events.Actions.Modal.Help - Events.Actions.Modal.MoveTo - Events.Actions.Normal - Events.Actions.Search - Events.State.Modal.Detail - Events.State.Modal.Due - IO.Config.General - IO.Config.GitHub - IO.Config.Layout - IO.Config.Parser - IO.Config.Trello - IO.HTTP.Aeson - IO.HTTP.GitHub.AutomatedCard - IO.HTTP.GitHub.Column - IO.HTTP.GitHub.Project - IO.HTTP.GitHub.Utility - IO.HTTP.Trello - IO.HTTP.Trello.Card - IO.Markdown - UI.CLI - UI.Draw - UI.Draw.Main - UI.Draw.Main.List - UI.Draw.Main.Search - UI.Draw.Main.StatusBar - UI.Draw.Modal - UI.Draw.Modal.Detail - UI.Draw.Modal.Due - UI.Draw.Modal.Help - UI.Draw.Modal.MoveTo - UI.Draw.Mode - UI.Draw.Task - UI.Draw.Types - UI.Theme - UI.Types - Utility.Parser + Taskell.Config + Taskell.Data.Date.Types + Taskell.Events.Actions + Taskell.Events.Actions.Insert + Taskell.Events.Actions.Modal + Taskell.Events.Actions.Modal.Detail + Taskell.Events.Actions.Modal.Due + Taskell.Events.Actions.Modal.Help + Taskell.Events.Actions.Modal.MoveTo + Taskell.Events.Actions.Normal + Taskell.Events.Actions.Search + Taskell.Events.State.Modal.Detail + Taskell.Events.State.Modal.Due + Taskell.IO.Config.General + Taskell.IO.Config.GitHub + Taskell.IO.Config.Layout + Taskell.IO.Config.Parser + Taskell.IO.Config.Trello + Taskell.IO.HTTP.Aeson + Taskell.IO.HTTP.GitHub.AutomatedCard + Taskell.IO.HTTP.GitHub.Column + Taskell.IO.HTTP.GitHub.Project + Taskell.IO.HTTP.GitHub.Utility + Taskell.IO.HTTP.Trello + Taskell.IO.HTTP.Trello.Card + Taskell.IO.Markdown + Taskell.UI.CLI + Taskell.UI.Draw + Taskell.UI.Draw.Main + Taskell.UI.Draw.Main.List + Taskell.UI.Draw.Main.Search + Taskell.UI.Draw.Main.StatusBar + Taskell.UI.Draw.Modal + Taskell.UI.Draw.Modal.Detail + Taskell.UI.Draw.Modal.Due + Taskell.UI.Draw.Modal.Help + Taskell.UI.Draw.Modal.MoveTo + Taskell.UI.Draw.Mode + Taskell.UI.Draw.Task + Taskell.UI.Draw.Types + Taskell.UI.Theme + Taskell.UI.Types + Taskell.Utility.Parser Paths_taskell default-language: Haskell2010 default-extensions: OverloadedStrings NoImplicitPrelude + TupleSections LambdaCase RankNTypes build-depends: - aeson >=1.4.5.0 && <1.5, + aeson >=1.4.6.0 && <1.5, attoparsec >=0.13.2.3 && <0.14, - base >=4.12.0.0 && <=5, - brick ==0.50.*, - bytestring >=0.10.8.2 && <0.11, + base >=4.13.0.0 && <=5, + brick ==0.52.*, + bytestring >=0.10.10.0 && <0.11, classy-prelude >=1.5.0 && <1.6, config-ini >=0.2.4.0 && <0.3, - containers >=0.6.0.1 && <0.7, - directory >=1.3.3.0 && <1.4, - file-embed >=0.0.11 && <0.1, + containers >=0.6.2.1 && <0.7, + directory >=1.3.4.0 && <1.4, + file-embed >=0.0.11.1 && <0.1, fold-debounce >=0.2.0.9 && <0.3, http-client >=0.6.4 && <0.7, http-conduit >=2.3.7.3 && <2.4, http-types >=0.12.3 && <0.13, - lens >=4.17.1 && <4.18, + lens >=4.18.1 && <4.19, mtl >=2.2.2 && <2.3, - template-haskell >=2.14.0.0 && <2.15, - text >=1.2.3.1 && <1.3, - time >=1.8.0.2 && <1.9, - tz >=0.1.3.2 && <0.2, + template-haskell >=2.15.0.0 && <2.16, + text >=1.2.4.0 && <1.3, + time >=1.9.3 && <1.10, + tz >=0.1.3.3 && <0.2, vty ==5.26.* executable taskell @@ -138,48 +142,50 @@ Paths_taskell default-language: Haskell2010 default-extensions: OverloadedStrings NoImplicitPrelude + TupleSections LambdaCase RankNTypes ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.12.0.0 && <4.13, + base >=4.13.0.0 && <4.14, classy-prelude >=1.5.0 && <1.6, taskell -any, - tz >=0.1.3.2 && <0.2 + tz >=0.1.3.3 && <0.2 test-suite taskell-test type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test other-modules: - Data.Taskell.Date.RelativeParserTest - Data.Taskell.DateTest - Data.Taskell.ListNavigationTest - Data.Taskell.ListsTest - Data.Taskell.ListTest - Data.Taskell.SeqTest - Data.Taskell.SubtaskTest - Data.Taskell.TaskTest - Events.State.HistoryTest - Events.StateTest - IO.GitHub.CardsTest - IO.GitHubTest - IO.Keyboard.ParserTest - IO.Keyboard.TypesTest - IO.KeyboardTest - IO.Markdown.ParserTest - IO.Markdown.SerializerTest - IO.TrelloTest - UI.FieldTest + Taskell.Data.Date.RelativeParserTest + Taskell.Data.DateTest + Taskell.Data.ListNavigationTest + Taskell.Data.ListsTest + Taskell.Data.ListTest + Taskell.Data.SeqTest + Taskell.Data.SubtaskTest + Taskell.Data.TaskTest + Taskell.Events.State.HistoryTest + Taskell.Events.StateTest + Taskell.IO.GitHub.CardsTest + Taskell.IO.GitHubTest + Taskell.IO.Keyboard.ParserTest + Taskell.IO.Keyboard.TypesTest + Taskell.IO.KeyboardTest + Taskell.IO.Markdown.ParserTest + Taskell.IO.Markdown.SerializerTest + Taskell.IO.TrelloTest + Taskell.UI.FieldTest Paths_taskell default-language: Haskell2010 default-extensions: OverloadedStrings NoImplicitPrelude + TupleSections LambdaCase RankNTypes ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson >=1.4.5.0 && <1.5, - base >=4.12.0.0 && <4.13, + aeson >=1.4.6.0 && <1.5, + base >=4.13.0.0 && <4.14, classy-prelude >=1.5.0 && <1.6, - containers >=0.6.0.1 && <0.7, - file-embed >=0.0.11 && <0.1, - lens >=4.17.1 && <4.18, + containers >=0.6.2.1 && <0.7, + file-embed >=0.0.11.1 && <0.1, + lens >=4.18.1 && <4.19, mtl >=2.2.2 && <2.3, raw-strings-qq ==1.1.*, taskell -any, @@ -187,7 +193,7 @@ tasty-discover >=4.2.1 && <4.3, tasty-expected-failure >=0.11.1.2 && <0.12, tasty-hunit >=0.10.0.2 && <0.11, - text >=1.2.3.1 && <1.3, - time >=1.8.0.2 && <1.9, - tz >=0.1.3.2 && <0.2, + text >=1.2.4.0 && <1.3, + time >=1.9.3 && <1.10, + tz >=0.1.3.3 && <0.2, vty ==5.26.* diff --git a/templates/bindings.ini b/templates/bindings.ini --- a/templates/bindings.ini +++ b/templates/bindings.ini @@ -31,9 +31,17 @@ # moving tasks moveUp = K moveDown = J -moveLeft = H -moveRight = L +# move to top of previous list +moveLeftTop = ˙ +# move to top of next list +moveRightTop = ¬ +# move to bottom of previous list +moveLeftBottom = H +# move to bottom of next list +moveRightBottom = L +# move to bottom of last list complete = +# select a list to move to moveMenu = m # lists diff --git a/templates/theme.ini b/templates/theme.ini --- a/templates/theme.ini +++ b/templates/theme.ini @@ -13,5 +13,13 @@ ; current task taskCurrent.fg = magenta +; subtasks +; selected +subtaskCurrent.fg = magenta +; incomplete +subtaskIncomplete.fg = blue +; complete +subtaskComplete.fg = yellow + ; disabled disabled.fg = yellow diff --git a/test/Data/Taskell/Date/RelativeParserTest.hs b/test/Data/Taskell/Date/RelativeParserTest.hs deleted file mode 100644 --- a/test/Data/Taskell/Date/RelativeParserTest.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Taskell.Date.RelativeParserTest - ( test_relative_parser - ) where - -import ClassyPrelude - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (secondsToDiffTime) - -import Data.Taskell.Date (Due (DueDate, DueTime)) -import Data.Taskell.Date.RelativeParser (parseRelative) - -toTime :: (Integer, Int, Int) -> Integer -> Due -toTime (y, m, d) seconds = DueTime $ UTCTime (fromGregorian y m d) (secondsToDiffTime seconds) - -toDay :: (Integer, Int, Int) -> Due -toDay (y, m, d) = DueDate $ fromGregorian y m d - --- 08:53:03 18th December 2019 -time :: UTCTime -time = UTCTime (fromGregorian 2019 12 18) 31983 - --- tests -test_relative_parser :: TestTree -test_relative_parser = - testGroup - "Data.Taskell.Date.RelativeParser" - [ testCase - "Second" - (assertEqual - "Adds a second" - (Right (toTime (2019, 12, 18) 31984)) - (parseRelative time "1s")) - , testCase - "Minute" - (assertEqual - "Adds a minute" - (Right (toTime (2019, 12, 18) 32043)) - (parseRelative time "1m")) - , testCase - "Hour" - (assertEqual - "Adds an hour" - (Right (toTime (2019, 12, 18) 35583)) - (parseRelative time "1h")) - , testCase - "Day" - (assertEqual "Adds a day" (Right (toDay (2019, 12, 19))) (parseRelative time "1d")) - , testCase - "Days" - (assertEqual "Adds 29 days" (Right (toDay (2020, 1, 16))) (parseRelative time "29 d")) - , testCase - "Week" - (assertEqual "Adds a week" (Right (toDay (2019, 12, 25))) (parseRelative time "1w ")) - , testCase - "Mix" - (assertEqual - "Adds 1 week 2 days and 29 seconds" - (Right (toTime (2019, 12, 27) 32012)) - (parseRelative time " 1 w 2d 29 s ")) - , testCase - "Mix out of order" - (assertEqual - "Adds 1 week 2 days and 29 seconds" - (Right (toTime (2019, 12, 27) 32012)) - (parseRelative time " 2d 1 w 29 s")) - , testCase - "invalid format" - (assertEqual "Error" (Left "Could not parse date.") (parseRelative time "18/12/2019")) - , testCase - "invalid numbers" - (assertEqual "Error" (Left "Could not parse date.") (parseRelative time "2019-39-59")) - ] diff --git a/test/Data/Taskell/DateTest.hs b/test/Data/Taskell/DateTest.hs deleted file mode 100644 --- a/test/Data/Taskell/DateTest.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# 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 -import Data.Time.Zones (utcTZ) -import Data.Time.Zones.All (TZLabel (America__New_York), tzByLabel) - -testDate :: UTCTime -testDate = UTCTime (fromGregorian 2018 5 18) (secondsToDiffTime 0) - --- sorting test data -sort1 :: Due -sort1 = DueTime (UTCTime (fromGregorian 2017 2 4) 0) - -sort2 :: Due -sort2 = DueDate (fromGregorian 2016 12 15) - -sort3 :: Due -sort3 = DueTime (UTCTime (fromGregorian 2020 8 9) 44000) - -sort4 :: Due -sort4 = DueDate (fromGregorian 2019 8 30) - --- tests -test_date :: TestTree -test_date = - testGroup - "Data.Taskell.Date" - [ testCase - "Sorting" - (assertEqual - "Sorted in date order" - [sort2, sort1, sort4, sort3] - (sort [sort1, sort2, sort3, sort4])) - , testGroup - "Date Output" - [ testGroup - "timeToDisplay" - [ testCase - "timeToDisplay time" - (assertEqual - "Date in yyyy-mm-dd format" - "2018-05-18 00:00" - (timeToDisplay utcTZ (DueTime testDate))) - , testCase - "timeToDisplay time - non-utc" - (assertEqual - "Date in yyyy-mm-dd format" - "2018-05-17 20:00" - (timeToDisplay (tzByLabel America__New_York) (DueTime testDate))) - , testCase - "timeToDisplay date" - (assertEqual - "Date in yyyy-mm-dd format" - "2018-05-18" - (timeToDisplay utcTZ (DueDate (fromGregorian 2018 05 18)))) - ] - , testGroup - "timeToOutput" - [ testCase - "timeToOutput time" - (assertEqual - "Date in yyyy-mm-dd format" - "2018-05-18 00:00 UTC" - (timeToOutput (DueTime testDate))) - , testCase - "timeToOutput date" - (assertEqual - "Date in yyyy-mm-dd format" - "2018-05-18" - (timeToOutput (DueDate (fromGregorian 2018 05 18)))) - ] - , testGroup - "timeToOutputLocal" - [ testCase - "timeToOutputLocal time" - (assertEqual - "Date in yyyy-mm-dd format" - "2018-05-18 00:00 UTC" - (timeToOutputLocal utcTZ (DueTime testDate))) - , testCase - "timeToOutputLocal time - non-utc" - (assertEqual - "Date in yyyy-mm-dd format" - "2018-05-17 20:00 EDT" - (timeToOutputLocal (tzByLabel America__New_York) (DueTime testDate))) - , testCase - "timeToOutputLocal date" - (assertEqual - "Date in yyyy-mm-dd format" - "2018-05-18" - (timeToOutputLocal utcTZ (DueDate (fromGregorian 2018 05 18)))) - , testCase - "timeToOutputLocal date - non-utc" - (assertEqual - "Date in yyyy-mm-dd format" - "2018-05-18" - (timeToOutputLocal - (tzByLabel America__New_York) - (DueDate (fromGregorian 2018 05 18)))) - ] - , testGroup - "timeToText" - [ testCase - "time" - (assertEqual - "Date in 18-May format" - "00:00 18-May" - (timeToText utcTZ testDate (DueTime testDate))) - , testCase - "time - non-utc" - (assertEqual - "Date in 17-May format" - "20:00 17-May" - (timeToText (tzByLabel America__New_York) testDate (DueTime testDate))) - , testCase - "same year" - (assertEqual - "Date in 18-May format" - "18-May" - (timeToText utcTZ testDate (DueDate (fromGregorian 2018 5 18)))) - , testCase - "different year" - (assertEqual - "Date in 18-May 2019 format" - "18-May 2019" - (timeToText utcTZ testDate (DueDate (fromGregorian 2019 5 18)))) - , testCase - "different year" - (assertEqual - "Date in 18-May 2017 format" - "18-May 2017" - (timeToText utcTZ testDate (DueDate (fromGregorian 2017 5 18)))) - ] - ] - , testGroup - "Input" - [ testGroup - "textToTime" - [ testCase - "simple date" - (assertEqual - "A valid Day" - (DueDate <$> fromGregorianValid 2018 05 18) - (textToTime "2018-05-18")) - , testCase - "simple time" - (assertEqual - "A valid time" - (DueTime . flip UTCTime 64800 <$> fromGregorianValid 2018 05 18) - (textToTime "2018-05-18 18:00 UTC")) - , testCase - "time with timezone" - (assertEqual - "A valid time" - (DueTime . flip UTCTime 0 <$> fromGregorianValid 2018 05 18) - (textToTime "2018-05-17 20:00 EDT")) - ] - , testGroup - "inputToTime" - [ testCase - "simple date" - (assertEqual - "A valid Day" - (DueDate <$> fromGregorianValid 2018 05 18) - (inputToTime utcTZ testDate "2018-05-18")) - , testCase - "simple time" - (assertEqual - "A valid time" - (DueTime . flip UTCTime 64800 <$> fromGregorianValid 2018 05 18) - (inputToTime utcTZ testDate "2018-05-18 18:00")) - , testCase - "time with timezone" - (assertEqual - "A valid time" - (DueTime . flip UTCTime 79200 <$> fromGregorianValid 2018 05 18) - (inputToTime - (tzByLabel America__New_York) - testDate - "2018-05-18 18:00")) - , testCase - "relative time - seconds" - (assertEqual - "Adds 7 seconds" - (DueTime . flip UTCTime 7 <$> fromGregorianValid 2018 05 18) - (inputToTime utcTZ testDate "7s")) - , testCase - "relative time - days" - (assertEqual - "Adds 29 days, 12 hours" - (DueTime . flip UTCTime 43200 <$> fromGregorianValid 2018 06 16) - (inputToTime utcTZ testDate "29 d 12h")) - , testCase - "relative time - weeks" - (assertEqual - "Adds four weeks, two days, 12 hours" - (DueTime . flip UTCTime 43200 <$> fromGregorianValid 2018 06 17) - (inputToTime utcTZ testDate "4w 2d 12h")) - ] - , testCase - "isoToTime" - (assertEqual - "Gives back time" - (Just (DueTime (UTCTime (fromGregorian 2020 8 11) 82800))) - (isoToTime "2020-08-11T23:00:00.000Z")) - ] - , testGroup - "deadline" - [ testCase - "Plenty" - (assertEqual - "Plenty of time" - Plenty - (deadline testDate (DueDate (fromGregorian 2018 05 28)))) - , testCase - "ThisWeek" - (assertEqual - "This week" - ThisWeek - (deadline testDate (DueDate (fromGregorian 2018 05 24)))) - , testCase - "Tomorrow" - (assertEqual - "Tomorrow" - Tomorrow - (deadline testDate (DueDate (fromGregorian 2018 05 19)))) - , testCase "Today" (assertEqual "Today" Today (deadline testDate (DueTime testDate))) - , testCase - "Passed" - (assertEqual - "Passed" - Passed - (deadline testDate (DueDate (fromGregorian 2018 05 17)))) - ] - ] diff --git a/test/Data/Taskell/ListNavigationTest.hs b/test/Data/Taskell/ListNavigationTest.hs deleted file mode 100644 --- a/test/Data/Taskell/ListNavigationTest.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Taskell.ListNavigationTest - ( test_listNav - ) where - -import ClassyPrelude as CP - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.Taskell.List.Internal as L -import qualified Data.Taskell.Task as T (Task, new) - -taskSeq :: Seq T.Task -taskSeq = - fromList - [ T.new "Hello" - , T.new "Blah" - , T.new "Fish" - , T.new "Spoons" - , T.new "Hello Again!" - , T.new "Computers" - ] - -list :: List -list = List "Populated" taskSeq - --- tests -test_listNav :: TestTree -test_listNav = - testGroup - "Data.Taskell.List Navigation" - [ testGroup - "next" - [ testCase "no term" (assertEqual "1" 1 (L.nextTask 0 Nothing list)) - , testCase "with term" (assertEqual "4" 4 (L.nextTask 0 (Just "Hello") list)) - , testCase - "with term - no match" - (assertEqual "0" 0 (L.nextTask 0 (Just "Wombat") list)) - ] - , testGroup - "prev" - [ testCase "no term" (assertEqual "0" 0 (L.prevTask 1 Nothing list)) - , testCase "with term" (assertEqual "0" 0 (L.prevTask 4 (Just "Hello") list)) - , testCase - "with term - no match" - (assertEqual "4" 4 (L.prevTask 4 (Just "Wombat") list)) - ] - , testGroup - "nearest" - [ testCase "no term" (assertEqual "same task" 2 (L.nearest 2 Nothing list)) - , testCase "term matches" (assertEqual "same task" 2 (L.nearest 2 (Just "ish") list)) - , testCase "term after" (assertEqual "next task" 3 (L.nearest 2 (Just "oons") list)) - , testCase - "term before" - (assertEqual "previous task" 3 (L.nearest 5 (Just "oons") list)) - , testCase - "term both - before closer" - (assertEqual "previous task" 0 (L.nearest 2 (Just "Hello") list)) - , testCase - "term both - after closer" - (assertEqual "next task" 4 (L.nearest 3 (Just "Hello") list)) - , testCase - "no matches" - (assertEqual "nothing" (-1) (L.nearest 3 (Just "Penguins") list)) - , testCase - "nothing to match" - (assertEqual "nothing" 3 (L.nearest (-1) (Just "Spoon") list)) - , testCase - "nothing with no term" - (assertEqual "nothing" 0 (L.nearest (-1) Nothing list)) - , testCase - "out of bounds with no term" - (assertEqual "nothing" 5 (L.nearest 50 Nothing list)) - , testCase - "out of bounds by 1 with no term" - (assertEqual "nothing" 5 (L.nearest 6 Nothing list)) - ] - ] diff --git a/test/Data/Taskell/ListTest.hs b/test/Data/Taskell/ListTest.hs deleted file mode 100644 --- a/test/Data/Taskell/ListTest.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# 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"]) - , 2)) - (move 1 1 Nothing populatedList)) - , testCase - "down" - (assertEqual - "List with moved item" - (Just - ( List - "Populated" - (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]) - , 0)) - (move 1 (-1) Nothing populatedList)) - , testCase - "up - out of bounds" - (assertEqual - "List with moved item" - (Just - ( List - "Populated" - (fromList [T.new "Hello", T.new "Fish", T.new "Blah"]) - , 2)) - (move 1 10 Nothing populatedList)) - , testCase - "down - out of bounds" - (assertEqual - "List with moved item" - (Just - ( List - "Populated" - (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]) - , 0)) - (move 1 (-10) Nothing populatedList)) - , testCase - "up - with search" - (assertEqual - "List with moved item" - (Just - ( List - "Populated" - (fromList [T.new "Blah", T.new "Fish", T.new "Hello"]) - , 2)) - (move 0 1 (Just "Fish") populatedList)) - , testCase - "down - with search" - (assertEqual - "List with moved item" - (Just - ( List - "Populated" - (fromList [T.new "Fish", T.new "Hello", T.new "Blah"]) - , 0)) - (move 2 (-1) (Just "Hello") 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 - "Hello and Blah" - (List "Populated" (fromList [T.new "Hello", T.new "Blah"])) - (searchFor "l" populatedList)) - , testCase - "case-insensitive" - (assertEqual - "Hello" - (List "Populated" (fromList [T.new "Hello"])) - (searchFor "hello" 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 deleted file mode 100644 --- a/test/Data/Taskell/ListsTest.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Taskell.ListsTest - ( test_lists - ) where - -import ClassyPrelude hiding (delete) - -import Test.Tasty -import Test.Tasty.HUnit - -import Control.Lens ((.~)) - -import Data.Taskell.Date (textToTime) -import qualified Data.Taskell.List as L -import Data.Taskell.Lists.Internal -import qualified Data.Taskell.Task as T -import Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) - --- test data -list1, list2, list3 :: L.List -list1 = - foldl' - (flip L.append) - (L.empty "List 1") - [T.new "One", (T.due .~ textToTime "2019-08-14") (T.new "Two"), T.new "Three"] - -list2 = - foldl' - (flip L.append) - (L.empty "List 2") - [T.new "1", T.new "2", (T.due .~ textToTime "2018-12-03") (T.new "3")] - -list3 = - foldl' - (flip L.append) - (L.empty "List 3") - [(T.due .~ textToTime "2019-04-05") (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.due .~ textToTime "2018-12-03") (T.new "3")] - , foldl' - (flip L.append) - (L.empty "List 3") - [ (T.due .~ textToTime "2019-04-05") (T.new "01") - , T.new "10" - , T.new "11" - , T.new "2" - ] - ])) - (changeList (ListIndex 1, TaskIndex 1) testLists 1)) - , testCase - "left" - (assertEqual - "Returns updated lists" - (Just - (fromList - [ foldl' - (flip L.append) - (L.empty "List 1") - [ T.new "One" - , (T.due .~ textToTime "2019-08-14") (T.new "Two") - , T.new "Three" - , T.new "2" - ] - , foldl' - (flip L.append) - (L.empty "List 2") - [T.new "1", (T.due .~ textToTime "2018-12-03") (T.new "3")] - , list3 - ])) - (changeList (ListIndex 1, TaskIndex 1) testLists (-1))) - , testCase - "out of bounds list" - (assertEqual - "Nothing" - Nothing - (changeList (ListIndex 5, TaskIndex 1) testLists 1)) - , testCase - "out of bounds task" - (assertEqual - "Nothing" - Nothing - (changeList (ListIndex 1, TaskIndex 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.due .~ textToTime "2019-04-05") (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)) - , testCase - "due" - (assertEqual - "returns just due list" - (fromList - [ ( (ListIndex 1, TaskIndex 2) - , (T.due .~ textToTime "2018-12-03") (T.new "3")) - , ( (ListIndex 2, TaskIndex 0) - , (T.due .~ textToTime "2019-04-05") (T.new "01")) - , ( (ListIndex 0, TaskIndex 1) - , (T.due .~ textToTime "2019-08-14") (T.new "Two")) - ]) - (due testLists)) - ] diff --git a/test/Data/Taskell/SeqTest.hs b/test/Data/Taskell/SeqTest.hs deleted file mode 100644 --- a/test/Data/Taskell/SeqTest.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/Data/Taskell/SubtaskTest.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/Data/Taskell/TaskTest.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# 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.Calendar (fromGregorianValid) - -import Data.Taskell.Date (Due (DueDate)) -import qualified Data.Taskell.Subtask as ST (name, new) -import Data.Taskell.Task.Internal - -desc :: Maybe Text -desc = Just "A very boring description" - -testTask :: Task -testTask = - Task - { _name = "Test" - , _description = desc - , _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" - desc - (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" - desc - (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" - desc - (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" - desc - (fromList [ST.new "One" True, ST.new "Three" False]) - Nothing) - (removeSubtask 1 testTask)) - , testCase - "doesn't exist" - (assertEqual - "Returns task" - (Task - "Test" - desc - (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 - "case-insensitive" - (assertEqual "Find sub-task" True (contains "ONE" testTask)) - , testCase - "case-insensitive" - (assertEqual "Find sub-task" True (contains "two" testTask)) - , testCase "missing" (assertEqual "Find sub-task" False (contains "Fish" testTask)) - , testCase - "description" - (assertEqual "Finds in description" True (contains "boring" testTask)) - , testCase - "not in description" - (assertEqual "Doesn't find" False (contains "escapades" 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 (DueDate <$> (fromGregorianValid 2018 05 18))))) - ] - ] diff --git a/test/Events/State/HistoryTest.hs b/test/Events/State/HistoryTest.hs deleted file mode 100644 --- a/test/Events/State/HistoryTest.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Events.State.HistoryTest - ( test_history - ) where - -import ClassyPrelude - -import Test.Tasty -import Test.Tasty.HUnit - -import Events.State.History -import Events.State.Types - -make :: [Integer] -> Integer -> [Integer] -> History Integer -make = History - -testHistory :: History Integer -testHistory = make empty 0 empty - --- tests -test_history :: TestTree -test_history = - testGroup - "Events.State.History" - [ testGroup - "undo" - [ testCase "empty" (assertEqual "Nothing changes" testHistory (undo testHistory)) - , testCase - "one undo" - (assertEqual "Goes back" (make empty 0 [1]) (undo $ make [0] 1 empty)) - , testCase - "two undo" - (assertEqual - "Goes back" - (make empty 0 [1, 2]) - (undo . undo $ make [1, 0] 2 empty)) - , testCase - "three undo" - (assertEqual - "Goes back" - (make empty 0 [1, 2, 3]) - (undo . undo . undo $ make [2, 1, 0] 3 empty)) - ] - , testGroup - "redo" - [ testCase "empty" (assertEqual "Nothing changes" testHistory (redo testHistory)) - , testCase - "one redo" - (assertEqual "Goes forward" (make [0] 1 empty) (redo $ make empty 0 [1])) - , testCase - "two redo" - (assertEqual - "Goes forward" - (make [1, 0] 2 empty) - (redo . redo $ make empty 0 [1, 2])) - , testCase - "three redo" - (assertEqual - "Goes forward" - (make [2, 1, 0] 3 empty) - (redo . redo . redo $ make empty 0 [1, 2, 3])) - ] - , testGroup - "mix" - [ testCase - "empty" - (assertEqual - "Nothing changes" - testHistory - (undo . redo . undo . redo . undo $ testHistory)) - , testCase - "redo undo" - (assertEqual - "Nothing changes" - (make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10]) - (undo . redo $ make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10])) - , testCase - "undo redo" - (assertEqual - "Nothing changes" - (make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10]) - (redo . undo $ make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10])) - ] - , testGroup - "store" - [ testCase - "empty" - (assertEqual "Stores current value" (make [0] 0 empty) (store testHistory)) - , testCase - "undo store redo" - (assertEqual - "Clears redo" - (make [4, 3, 2, 1, 0] 4 empty) - (redo . store . undo $ make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10])) - ] - ] diff --git a/test/Events/StateTest.hs b/test/Events/StateTest.hs deleted file mode 100644 --- a/test/Events/StateTest.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} - -module Events.StateTest - ( test_state - ) where - -import ClassyPrelude - -import Test.Tasty -import Test.Tasty.HUnit - -import Control.Lens ((&), (.~), (^.)) - -import Data.Time.Clock (secondsToDiffTime) -import Data.Time.Zones (utcTZ) - -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 -import Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) - -mockTime :: UTCTime -mockTime = UTCTime (ModifiedJulianDay 20) (secondsToDiffTime 0) - -testState :: State -testState = - State - { _mode = Normal - , _history = fresh empty - , _path = "test.md" - , _io = Nothing - , _height = 0 - , _searchTerm = Nothing - , _time = mockTime - , _timeZone = utcTZ - } - -moveToState :: State -moveToState = - State - { _mode = Modal MoveTo - , _history = - History - { _past = empty - , _present = - ( (ListIndex 4, TaskIndex 0) - , [ L.empty "List 1" - , L.empty "List 2" - , L.empty "List 3" - , L.empty "List 4" - , L.append (T.new "Test Item") (L.empty "List 5") - , L.empty "List 6" - , L.empty "List 7" - , L.empty "List 8" - , L.empty "List 9" - ]) - , _future = empty - } - , _path = "test.md" - , _io = Nothing - , _height = 0 - , _searchTerm = Nothing - , _time = mockTime - , _timeZone = utcTZ - } - --- 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/GitHub/CardsTest.hs b/test/IO/GitHub/CardsTest.hs deleted file mode 100644 --- a/test/IO/GitHub/CardsTest.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module IO.GitHub.CardsTest - ( test_cards - ) where - -import ClassyPrelude - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.Aeson - -import IO.HTTP.GitHub.Card (MaybeCard (MaybeCard)) - -decodeCards :: Text -> Either String [MaybeCard] -decodeCards txt = eitherDecodeStrict $ encodeUtf8 txt - --- tests -test_cards :: TestTree -test_cards = - testGroup - "IO.HTTP.GitHub.Card" - [ testCase - "parses basic card" - (assertEqual - "Gives back card" - (Right [MaybeCard (Just "blah") Nothing]) - (decodeCards "[{\"note\": \"blah\"}]")) - , testCase - "parses basic card" - (assertEqual - "Gives back card" - (Right - [MaybeCard Nothing (Just "https://api.github.com/projects/columns/7850783")]) - (decodeCards - "[{\"note\": null, \"content_url\": \"https://api.github.com/projects/columns/7850783\"}]")) - ] diff --git a/test/IO/GitHubTest.hs b/test/IO/GitHubTest.hs deleted file mode 100644 --- a/test/IO/GitHubTest.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# 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/Keyboard/ParserTest.hs b/test/IO/Keyboard/ParserTest.hs deleted file mode 100644 --- a/test/IO/Keyboard/ParserTest.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} - -module IO.Keyboard.ParserTest - ( test_parser - ) where - -import ClassyPrelude - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.FileEmbed (embedFile) -import Text.RawString.QQ (r) - -import qualified Events.Actions.Types as A -import IO.Keyboard.Parser (bindings) -import IO.Keyboard.Types - -basic :: Text -basic = "quit = q" - -basicResult :: Bindings -basicResult = [(BChar 'q', A.Quit)] - -basicMulti :: Text -basicMulti = - [r| - quit = q - detail = - |] - -basicMultiResult :: Bindings -basicMultiResult = [(BChar 'q', A.Quit), (BKey "Enter", A.Detail)] - -ini :: Text -ini = decodeUtf8 $(embedFile "test/IO/Keyboard/data/bindings.ini") - -iniResult :: Bindings -iniResult = - [ (BChar 'q', A.Quit) - , (BChar 'u', A.Undo) - , (BChar 'r', A.Redo) - , (BChar '/', A.Search) - , (BChar '?', A.Help) - , (BChar '!', A.Due) - , (BChar 'k', A.Previous) - , (BChar 'j', A.Next) - , (BChar 'h', A.Left) - , (BChar 'l', A.Right) - , (BChar 'G', A.Bottom) - , (BChar 'a', A.New) - , (BChar 'O', A.NewAbove) - , (BChar 'o', A.NewBelow) - , (BChar '+', A.Duplicate) - , (BChar 'e', A.Edit) - , (BChar 'A', A.Edit) - , (BChar 'i', A.Edit) - , (BChar 'C', A.Clear) - , (BChar 'D', A.Delete) - , (BKey "Enter", A.Detail) - , (BChar '@', A.DueDate) - , (BKey "Backspace", A.ClearDate) - , (BChar 'K', A.MoveUp) - , (BChar 'J', A.MoveDown) - , (BChar 'H', A.MoveLeft) - , (BChar 'L', A.MoveRight) - , (BKey "Space", A.Complete) - , (BChar 'm', A.MoveMenu) - , (BChar 'N', A.ListNew) - , (BChar 'E', A.ListEdit) - , (BChar 'X', A.ListDelete) - , (BChar '>', A.ListRight) - , (BChar '<', A.ListLeft) - ] - -comma :: Text -comma = "quit = ," - -commaResult :: Bindings -commaResult = [(BChar ',', A.Quit)] - -test_parser :: TestTree -test_parser = - testGroup - "IO.Keyboard.Parser" - [ testCase "basic" (assertEqual "Parses quit" (Right basicResult) (bindings basic)) - , testCase - "basic multiline" - (assertEqual "Parses both" (Right basicMultiResult) (bindings basicMulti)) - , testCase "full ini file" (assertEqual "Parses all" (Right iniResult) (bindings ini)) - , testCase "comma" (assertEqual "Parses comma" (Right commaResult) (bindings comma)) - ] diff --git a/test/IO/Keyboard/TypesTest.hs b/test/IO/Keyboard/TypesTest.hs deleted file mode 100644 --- a/test/IO/Keyboard/TypesTest.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module IO.Keyboard.TypesTest - ( test_types - ) where - -import ClassyPrelude - -import Test.Tasty -import Test.Tasty.HUnit - -import qualified Events.Actions.Types as A (ActionType (..)) -import IO.Keyboard (addMissing, badMapping, defaultBindings) -import IO.Keyboard.Types (Binding (..), Bindings) - -notFull :: Bindings -notFull = [(BChar 'œ', A.Quit), (BChar 'U', A.Undo)] - -notFullResult :: Bindings -notFullResult = - [ (BChar 'œ', A.Quit) - , (BChar 'U', A.Undo) - , (BChar 'r', A.Redo) - , (BChar '/', A.Search) - , (BChar '!', A.Due) - , (BChar '?', A.Help) - , (BChar 'k', A.Previous) - , (BChar 'j', A.Next) - , (BChar 'h', A.Left) - , (BChar 'l', A.Right) - , (BChar 'G', A.Bottom) - , (BChar 'g', A.Top) - , (BChar 'a', A.New) - , (BChar 'O', A.NewAbove) - , (BChar 'o', A.NewBelow) - , (BChar '+', A.Duplicate) - , (BChar 'e', A.Edit) - , (BChar 'A', A.Edit) - , (BChar 'i', A.Edit) - , (BChar 'C', A.Clear) - , (BChar 'D', A.Delete) - , (BKey "Enter", A.Detail) - , (BChar '@', A.DueDate) - , (BKey "Backspace", A.ClearDate) - , (BChar 'K', A.MoveUp) - , (BChar 'J', A.MoveDown) - , (BChar 'H', A.MoveLeft) - , (BChar 'L', A.MoveRight) - , (BKey "Space", A.Complete) - , (BChar 'm', A.MoveMenu) - , (BChar 'N', A.ListNew) - , (BChar 'E', A.ListEdit) - , (BChar 'X', A.ListDelete) - , (BChar '>', A.ListRight) - , (BChar '<', A.ListLeft) - ] - -bad :: Bindings -bad = [(BChar 'q', A.Quit), (BChar 'u', A.Nothing), (BChar '>', A.Nothing), (BChar '<', A.ListLeft)] - --- tests -test_types :: TestTree -test_types = - testGroup - "Events.Actions.Types" - [ testCase - "not missing" - (assertEqual "Finds no missing items" defaultBindings (addMissing defaultBindings)) - , testCase - "not missing" - (assertEqual "Finds missing items" notFullResult (addMissing notFull)) - , testCase - "bad mapping" - (assertEqual "Finds bad mapping" (Left "invalid mapping") (badMapping bad)) - ] diff --git a/test/IO/KeyboardTest.hs b/test/IO/KeyboardTest.hs deleted file mode 100644 --- a/test/IO/KeyboardTest.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} - -module IO.KeyboardTest - ( test_keyboard - ) where - -import ClassyPrelude - -import Test.Tasty -import Test.Tasty.HUnit - -import Control.Lens ((.~)) - -import Data.Time.Clock (secondsToDiffTime) -import Data.Time.Zones (utcTZ) - -import Data.Taskell.Lists.Internal (initial) -import Events.Actions.Types as A -import Events.State (create, quit) -import Events.State.Types (State, Stateful, mode) -import Events.State.Types.Mode (Mode (Shutdown)) -import Graphics.Vty.Input.Events (Event (..), Key (..)) -import IO.Keyboard (generate) -import IO.Keyboard.Types - -mockTime :: UTCTime -mockTime = UTCTime (ModifiedJulianDay 20) (secondsToDiffTime 0) - -tester :: BoundActions -> Event -> Stateful -tester actions ev state = lookup ev actions >>= ($ state) - -cleanState :: State -cleanState = create utcTZ mockTime "taskell.md" initial - -basicBindings :: Bindings -basicBindings = [(BChar 'q', A.Quit)] - -basicActions :: Actions -basicActions = [(A.Quit, quit)] - -basicResult :: Maybe State -basicResult = Just $ (mode .~ Shutdown) cleanState - -test_keyboard :: TestTree -test_keyboard = - testGroup - "IO.Keyboard" - [ testCase - "generate" - (assertEqual - "Parses basic" - basicResult - (tester (generate basicBindings basicActions) (EvKey (KChar 'q') []) cleanState)) - ] diff --git a/test/IO/Markdown/ParserTest.hs b/test/IO/Markdown/ParserTest.hs deleted file mode 100644 --- a/test/IO/Markdown/ParserTest.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module IO.Markdown.ParserTest - ( test_parser - ) where - -import ClassyPrelude - -import Test.Tasty - -import Test.Tasty.HUnit - -import Control.Lens ((&), (.~)) -import Data.FileEmbed (embedFile) - -import Data.Taskell.Date (textToTime) -import Data.Taskell.List (create) -import Data.Taskell.Lists (Lists, analyse, appendToLast, newList) - -import qualified Data.Taskell.Subtask as ST (new) -import Data.Taskell.Task (Task, addSubtask, due, new, setDescription) -import IO.Config.Markdown (Config (Config), defaultConfig, descriptionOutput, dueOutput, - localTimes, subtaskOutput, taskOutput, titleOutput) -import IO.Markdown.Parser (parse) - --- error message -err :: Either Text Lists -err = Left "Could not parse file." - --- complete taskell file -file :: Text -file = decodeUtf8 $(embedFile "test/IO/data/roadmap.md") - --- alternative markdown configs -alternativeConfig :: Config -alternativeConfig = - Config - { titleOutput = "##" - , taskOutput = "###" - , descriptionOutput = ">" - , dueOutput = "@" - , subtaskOutput = "-" - , localTimes = True - } - --- useful records -task :: Task -task = new "Test Item" - -list :: Lists -list = newList "Test" empty - -listWithItem :: Lists -listWithItem = appendToLast task list - -multiList :: Lists -multiList = - fromList - [create "Test" (fromList [new "Test Item"]), create "Test 2" (fromList [new "Test Item 2"])] - -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 = task & due .~ textToTime "2018-04-12" - -listWithDueDateItem :: Lists -listWithDueDateItem = appendToLast taskWithDueDate list - --- tests -test_parser :: TestTree -test_parser = - testGroup - "IO.Markdown" - [ testGroup - "Default Format" - [ testCase - "List Title" - (assertEqual "One list" (Right list) (parse defaultConfig "## Test")) - , testCase - "List item" - (assertEqual - "List item" - (Right listWithItem) - (parse defaultConfig "## Test\n\n- Test Item")) - , testCase - "Multiple Lists" - (assertEqual - "List item" - (Right multiList) - (parse defaultConfig "## Test\n\n- Test Item\n\n## Test 2\n\n- Test Item 2")) - , testCase - "Summary" - (assertEqual - "Summary" - (Right listWithSummaryItem) - (parse defaultConfig "## Test\n\n- Test Item\n > Summary")) - , testCase - "List Item with multi-line Summary" - (assertEqual - "List item with a summary" - (Right listWithMultiLineSummaryItem) - (parse - defaultConfig - "## Test\n\n- Test Item\n > Summary Line 1\n > Summary Line 2")) - , testCase - "Due Date" - (assertEqual - "Due Date" - (Right listWithDueDateItem) - (parse defaultConfig "## Test\n\n- Test Item\n @ 2018-04-12")) - , testCase - "Sub-Task" - (assertEqual - "List item with Sub-Task" - (Right (makeSubTask "Blah" False)) - (parse defaultConfig "## Test\n\n- Test Item\n * [ ] Blah")) - , testCase - "Complete Sub-Task" - (assertEqual - "List item with Sub-Task" - (Right (makeSubTask "Blah" True)) - (parse defaultConfig "## Test\n\n- Test Item\n * [x] Blah")) - ] - , testGroup - "Alternative Format" - [ testCase - "List Title" - (assertEqual "One list" (Right list) (parse alternativeConfig "## Test")) - , testCase - "List item" - (assertEqual - "List item" - (Right listWithItem) - (parse alternativeConfig "## Test\n\n### Test Item")) - , testCase - "Multiple Lists" - (assertEqual - "List item" - (Right multiList) - (parse - alternativeConfig - "## Test\n\n### Test Item\n\n## Test 2\n\n### Test Item 2")) - , testCase - "Summary" - (assertEqual - "Summary" - (Right listWithSummaryItem) - (parse alternativeConfig "## Test\n\n### Test Item\n> Summary")) - , testCase - "List Item with multi-line Summary" - (assertEqual - "List item with a summary" - (Right listWithMultiLineSummaryItem) - (parse - alternativeConfig - "## Test\n\n### Test Item\n> Summary Line 1\n> Summary Line 2")) - , testCase - "Due Date" - (assertEqual - "Due Date" - (Right listWithDueDateItem) - (parse alternativeConfig "## Test\n\n### Test Item\n@ 2018-04-12")) - , testCase - "Sub-Task" - (assertEqual - "List item with Sub-Task" - (Right (makeSubTask "Blah" False)) - (parse alternativeConfig "## Test\n\n### Test Item\n- [ ] Blah")) - , testCase - "Complete Sub-Task" - (assertEqual - "List item with Sub-Task" - (Right (makeSubTask "Blah" True)) - (parse alternativeConfig "## Test\n\n### Test Item\n- [x] Blah")) - ] - , testGroup - "Errors" - [ testCase "Blank line" (assertEqual "Parse Error" err (parse defaultConfig "")) - , testCase - "Just spaces" - (assertEqual "Parse Error" err (parse defaultConfig " ")) - , testCase - "Just whitespace" - (assertEqual "Parse Error" err (parse defaultConfig " \n \n \t ")) - , testCase "Error" (assertEqual "Parse Error" err (parse defaultConfig "Test")) - , testCase - "List item without list" - (assertEqual "Parse Error" err (parse defaultConfig "- Test Item")) - , testCase - "Sub task without list item" - (assertEqual "Parse Error" err (parse defaultConfig "## Test\n * Blah")) - ] - , testCase - "File" - (assertEqual - "Parses whole file" - (Right "test\nLists: 6\nTasks: 202") - (analyse "test" <$> parse defaultConfig file)) - ] diff --git a/test/IO/Markdown/SerializerTest.hs b/test/IO/Markdown/SerializerTest.hs deleted file mode 100644 --- a/test/IO/Markdown/SerializerTest.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module IO.Markdown.SerializerTest - ( test_serializer - ) where - -import ClassyPrelude - -import Test.Tasty -import Test.Tasty.HUnit - -import Control.Lens ((&), (.~)) -import Control.Monad.Reader (runReader) -import Data.FileEmbed (embedFile) - -import Data.Time.Zones (utcTZ) -import Data.Time.Zones.All (TZLabel (America__New_York), tzByLabel) - -import Data.Taskell.Date (textToTime) -import qualified Data.Taskell.List as L (append, empty) -import Data.Taskell.Lists (Lists, appendToLast, newList) -import qualified Data.Taskell.Subtask as ST (new) -import Data.Taskell.Task (Task, addSubtask, due, new, setDescription) -import IO.Config.Markdown (Config (..), defaultConfig) -import IO.Markdown.Parser (parse) -import IO.Markdown.Serializer (MarkdownInfo (MarkdownInfo), serialize) - --- complete taskell file -file :: Text -file = decodeUtf8 $(embedFile "test/IO/data/roadmap.md") - --- alternative markdown configs -alternativeConfig :: Config -alternativeConfig = - Config - { titleOutput = "##" - , taskOutput = "###" - , descriptionOutput = ">" - , dueOutput = "@" - , subtaskOutput = "-" - , localTimes = True - } - --- useful records -task :: Task -task = new "Test Item" - -list :: Lists -list = newList "Test" empty - -lists :: Lists -lists = fromList [L.append task (L.empty "To Do"), L.append (new "Fish") (L.empty "Done")] - -listWithItem :: Lists -listWithItem = appendToLast task list - -makeSubTask :: Text -> Bool -> Lists -makeSubTask t b = appendToLast (addSubtask (ST.new t b) task) list - -makeSubTasks :: [Text] -> Bool -> Lists -makeSubTasks ts b = appendToLast (foldr addSubtask task subtasks) list - where - subtasks = flip ST.new b <$> ts - -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 = task & due .~ textToTime "2018-04-12" - -listWithDueDateItem :: Lists -listWithDueDateItem = appendToLast taskWithDueDate list - -taskWithDueTime :: Task -taskWithDueTime = task & due .~ textToTime "2018-04-12 12:00 UTC" - -listWithDueTimeItem :: Lists -listWithDueTimeItem = appendToLast taskWithDueTime list - --- reader -defaultReader :: MarkdownInfo -defaultReader = MarkdownInfo utcTZ defaultConfig - -alternativeReader :: MarkdownInfo -alternativeReader = MarkdownInfo utcTZ alternativeConfig - --- simplify tests -serialize' :: MarkdownInfo -> Lists -> Text -serialize' md ls = runReader (serialize ls) md - --- tests -test_serializer :: TestTree -test_serializer = - testGroup - "IO.Markdown" - [ testGroup - "Serialisation" - [ testGroup - "Default Format" - [ testCase - "Standard lists" - (assertEqual - "Markdown formatted output" - "## To Do\n\n- Test Item\n\n## Done\n\n- Fish\n" - (serialize' defaultReader lists)) - , testCase - "Standard list" - (assertEqual - "Markdown formatted output" - "## Test\n\n- Test Item\n" - (serialize' defaultReader listWithItem)) - , testCase - "Standard list with summary" - (assertEqual - "Markdown formatted output" - "## Test\n\n- Test Item\n > Summary\n" - (serialize' defaultReader listWithSummaryItem)) - , testCase - "Standard list with date" - (assertEqual - "Markdown formatted output" - "## Test\n\n- Test Item\n @ 2018-04-12\n" - (serialize' defaultReader listWithDueDateItem)) - , testCase - "Standard list with date - timezone" - (assertEqual - "Use UTC timezone" - "## Test\n\n- Test Item\n @ 2018-04-12 12:00 UTC\n" - (serialize' - (MarkdownInfo (tzByLabel America__New_York) defaultConfig) - listWithDueTimeItem)) - , testCase - "Standard list with sub-task" - (assertEqual - "Markdown formatted output" - "## Test\n\n- Test Item\n * [x] Blah\n" - (serialize' defaultReader (makeSubTask "Blah" True))) - , testCase - "Standard list with sub-tasks" - (assertEqual - "Markdown formatted output" - "## Test\n\n- Test Item\n * [x] Blah\n * [x] Cow\n * [x] Spoon\n" - (serialize' - defaultReader - (makeSubTasks ["Spoon", "Cow", "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" - (serialize' defaultReader listWithMultiLineSummaryItem)) - ] - , testGroup - "Alternative Format" - [ testCase - "Standard list" - (assertEqual - "Markdown formatted output" - "## Test\n\n### Test Item\n" - (serialize' alternativeReader listWithItem)) - , testCase - "Standard list with sub-task" - (assertEqual - "Markdown formatted output" - "## Test\n\n### Test Item\n- [ ] Blah\n" - (serialize' alternativeReader (makeSubTask "Blah" False))) - , testCase - "Standard list with date - timezone" - (assertEqual - "Uses local timezone" - "## Test\n\n### Test Item\n@ 2018-04-12 08:00 EDT\n" - (serialize' - (MarkdownInfo (tzByLabel America__New_York) alternativeConfig) - listWithDueTimeItem)) - ] - ] - , testCase - "Parse then serialize" - (assertEqual - "Returns same text" - (Right file) - (serialize' defaultReader <$> parse defaultConfig file)) - ] diff --git a/test/IO/TrelloTest.hs b/test/IO/TrelloTest.hs deleted file mode 100644 --- a/test/IO/TrelloTest.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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 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 :: TestTree -test_trello = - testGroup - "IO.Trello" - [ testCase - "Lists" - (assertEqual "Parses list JSON" (Just 5) (length . (listToList <$>) <$> json)) - , testCase - "Checklists" - (assertEqual - "Parses checklist JSON" - (Just 5) - (length . (checklistItemToSubTask <$>) <$> checklistJson)) - ] diff --git a/test/Taskell/Data/Date/RelativeParserTest.hs b/test/Taskell/Data/Date/RelativeParserTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Data/Date/RelativeParserTest.hs @@ -0,0 +1,75 @@ +module Taskell.Data.Date.RelativeParserTest + ( test_relative_parser + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Time.Clock (secondsToDiffTime) + +import Taskell.Data.Date (Due (DueDate, DueTime)) +import Taskell.Data.Date.RelativeParser (parseRelative) + +toTime :: (Integer, Int, Int) -> Integer -> Due +toTime (y, m, d) seconds = DueTime $ UTCTime (fromGregorian y m d) (secondsToDiffTime seconds) + +toDay :: (Integer, Int, Int) -> Due +toDay (y, m, d) = DueDate $ fromGregorian y m d + +-- 08:53:03 18th December 2019 +time :: UTCTime +time = UTCTime (fromGregorian 2019 12 18) 31983 + +-- tests +test_relative_parser :: TestTree +test_relative_parser = + testGroup + "Data.Taskell.Date.RelativeParser" + [ testCase + "Second" + (assertEqual + "Adds a second" + (Right (toTime (2019, 12, 18) 31984)) + (parseRelative time "1s")) + , testCase + "Minute" + (assertEqual + "Adds a minute" + (Right (toTime (2019, 12, 18) 32043)) + (parseRelative time "1m")) + , testCase + "Hour" + (assertEqual + "Adds an hour" + (Right (toTime (2019, 12, 18) 35583)) + (parseRelative time "1h")) + , testCase + "Day" + (assertEqual "Adds a day" (Right (toDay (2019, 12, 19))) (parseRelative time "1d")) + , testCase + "Days" + (assertEqual "Adds 29 days" (Right (toDay (2020, 1, 16))) (parseRelative time "29 d")) + , testCase + "Week" + (assertEqual "Adds a week" (Right (toDay (2019, 12, 25))) (parseRelative time "1w ")) + , testCase + "Mix" + (assertEqual + "Adds 1 week 2 days and 29 seconds" + (Right (toTime (2019, 12, 27) 32012)) + (parseRelative time " 1 w 2d 29 s ")) + , testCase + "Mix out of order" + (assertEqual + "Adds 1 week 2 days and 29 seconds" + (Right (toTime (2019, 12, 27) 32012)) + (parseRelative time " 2d 1 w 29 s")) + , testCase + "invalid format" + (assertEqual "Error" (Left "Could not parse date.") (parseRelative time "18/12/2019")) + , testCase + "invalid numbers" + (assertEqual "Error" (Left "Could not parse date.") (parseRelative time "2019-39-59")) + ] diff --git a/test/Taskell/Data/DateTest.hs b/test/Taskell/Data/DateTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Data/DateTest.hs @@ -0,0 +1,243 @@ +module Taskell.Data.DateTest + ( test_date + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Time +import Data.Time.Zones (utcTZ) +import Data.Time.Zones.All (TZLabel (America__New_York), tzByLabel) +import Taskell.Data.Date + +testDate :: UTCTime +testDate = UTCTime (fromGregorian 2018 5 18) (secondsToDiffTime 0) + +-- sorting test data +sort1 :: Due +sort1 = DueTime (UTCTime (fromGregorian 2017 2 4) 0) + +sort2 :: Due +sort2 = DueDate (fromGregorian 2016 12 15) + +sort3 :: Due +sort3 = DueTime (UTCTime (fromGregorian 2020 8 9) 44000) + +sort4 :: Due +sort4 = DueDate (fromGregorian 2019 8 30) + +-- tests +test_date :: TestTree +test_date = + testGroup + "Data.Taskell.Date" + [ testCase + "Sorting" + (assertEqual + "Sorted in date order" + [sort2, sort1, sort4, sort3] + (sort [sort1, sort2, sort3, sort4])) + , testGroup + "Date Output" + [ testGroup + "timeToDisplay" + [ testCase + "timeToDisplay time" + (assertEqual + "Date in yyyy-mm-dd format" + "2018-05-18 00:00" + (timeToDisplay utcTZ (DueTime testDate))) + , testCase + "timeToDisplay time - non-utc" + (assertEqual + "Date in yyyy-mm-dd format" + "2018-05-17 20:00" + (timeToDisplay (tzByLabel America__New_York) (DueTime testDate))) + , testCase + "timeToDisplay date" + (assertEqual + "Date in yyyy-mm-dd format" + "2018-05-18" + (timeToDisplay utcTZ (DueDate (fromGregorian 2018 05 18)))) + ] + , testGroup + "timeToOutput" + [ testCase + "timeToOutput time" + (assertEqual + "Date in yyyy-mm-dd format" + "2018-05-18 00:00 UTC" + (timeToOutput (DueTime testDate))) + , testCase + "timeToOutput date" + (assertEqual + "Date in yyyy-mm-dd format" + "2018-05-18" + (timeToOutput (DueDate (fromGregorian 2018 05 18)))) + ] + , testGroup + "timeToOutputLocal" + [ testCase + "timeToOutputLocal time" + (assertEqual + "Date in yyyy-mm-dd format" + "2018-05-18 00:00 UTC" + (timeToOutputLocal utcTZ (DueTime testDate))) + , testCase + "timeToOutputLocal time - non-utc" + (assertEqual + "Date in yyyy-mm-dd format" + "2018-05-17 20:00 EDT" + (timeToOutputLocal (tzByLabel America__New_York) (DueTime testDate))) + , testCase + "timeToOutputLocal date" + (assertEqual + "Date in yyyy-mm-dd format" + "2018-05-18" + (timeToOutputLocal utcTZ (DueDate (fromGregorian 2018 05 18)))) + , testCase + "timeToOutputLocal date - non-utc" + (assertEqual + "Date in yyyy-mm-dd format" + "2018-05-18" + (timeToOutputLocal + (tzByLabel America__New_York) + (DueDate (fromGregorian 2018 05 18)))) + ] + , testGroup + "timeToText" + [ testCase + "time" + (assertEqual + "Date in 18-May format" + "00:00 18-May" + (timeToText utcTZ testDate (DueTime testDate))) + , testCase + "time - non-utc" + (assertEqual + "Date in 17-May format" + "20:00 17-May" + (timeToText (tzByLabel America__New_York) testDate (DueTime testDate))) + , testCase + "same year" + (assertEqual + "Date in 18-May format" + "18-May" + (timeToText utcTZ testDate (DueDate (fromGregorian 2018 5 18)))) + , testCase + "different year" + (assertEqual + "Date in 18-May 2019 format" + "18-May 2019" + (timeToText utcTZ testDate (DueDate (fromGregorian 2019 5 18)))) + , testCase + "different year" + (assertEqual + "Date in 18-May 2017 format" + "18-May 2017" + (timeToText utcTZ testDate (DueDate (fromGregorian 2017 5 18)))) + ] + ] + , testGroup + "Input" + [ testGroup + "textToTime" + [ testCase + "simple date" + (assertEqual + "A valid Day" + (DueDate <$> fromGregorianValid 2018 05 18) + (textToTime "2018-05-18")) + , testCase + "simple time" + (assertEqual + "A valid time" + (DueTime . flip UTCTime 64800 <$> fromGregorianValid 2018 05 18) + (textToTime "2018-05-18 18:00 UTC")) + , testCase + "time with timezone" + (assertEqual + "A valid time" + (DueTime . flip UTCTime 0 <$> fromGregorianValid 2018 05 18) + (textToTime "2018-05-17 20:00 EDT")) + ] + , testGroup + "inputToTime" + [ testCase + "simple date" + (assertEqual + "A valid Day" + (DueDate <$> fromGregorianValid 2018 05 18) + (inputToTime utcTZ testDate "2018-05-18")) + , testCase + "simple time" + (assertEqual + "A valid time" + (DueTime . flip UTCTime 64800 <$> fromGregorianValid 2018 05 18) + (inputToTime utcTZ testDate "2018-05-18 18:00")) + , testCase + "time with timezone" + (assertEqual + "A valid time" + (DueTime . flip UTCTime 79200 <$> fromGregorianValid 2018 05 18) + (inputToTime + (tzByLabel America__New_York) + testDate + "2018-05-18 18:00")) + , testCase + "relative time - seconds" + (assertEqual + "Adds 7 seconds" + (DueTime . flip UTCTime 7 <$> fromGregorianValid 2018 05 18) + (inputToTime utcTZ testDate "7s")) + , testCase + "relative time - days" + (assertEqual + "Adds 29 days, 12 hours" + (DueTime . flip UTCTime 43200 <$> fromGregorianValid 2018 06 16) + (inputToTime utcTZ testDate "29 d 12h")) + , testCase + "relative time - weeks" + (assertEqual + "Adds four weeks, two days, 12 hours" + (DueTime . flip UTCTime 43200 <$> fromGregorianValid 2018 06 17) + (inputToTime utcTZ testDate "4w 2d 12h")) + ] + , testCase + "isoToTime" + (assertEqual + "Gives back time" + (Just (DueTime (UTCTime (fromGregorian 2020 8 11) 82800))) + (isoToTime "2020-08-11T23:00:00.000Z")) + ] + , testGroup + "deadline" + [ testCase + "Plenty" + (assertEqual + "Plenty of time" + Plenty + (deadline testDate (DueDate (fromGregorian 2018 05 28)))) + , testCase + "ThisWeek" + (assertEqual + "This week" + ThisWeek + (deadline testDate (DueDate (fromGregorian 2018 05 24)))) + , testCase + "Tomorrow" + (assertEqual + "Tomorrow" + Tomorrow + (deadline testDate (DueDate (fromGregorian 2018 05 19)))) + , testCase "Today" (assertEqual "Today" Today (deadline testDate (DueTime testDate))) + , testCase + "Passed" + (assertEqual + "Passed" + Passed + (deadline testDate (DueDate (fromGregorian 2018 05 17)))) + ] + ] diff --git a/test/Taskell/Data/ListNavigationTest.hs b/test/Taskell/Data/ListNavigationTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Data/ListNavigationTest.hs @@ -0,0 +1,78 @@ +module Taskell.Data.ListNavigationTest + ( test_listNav + ) where + +import ClassyPrelude as CP + +import Test.Tasty +import Test.Tasty.HUnit + +import Taskell.Data.List.Internal as L +import qualified Taskell.Data.Task as T (Task, new) + +taskSeq :: Seq T.Task +taskSeq = + fromList + [ T.new "Hello" + , T.new "Blah" + , T.new "Fish" + , T.new "Spoons" + , T.new "Hello Again!" + , T.new "Computers" + ] + +list :: List +list = List "Populated" taskSeq + +-- tests +test_listNav :: TestTree +test_listNav = + testGroup + "Data.Taskell.List Navigation" + [ testGroup + "next" + [ testCase "no term" (assertEqual "1" 1 (L.nextTask 0 Nothing list)) + , testCase "with term" (assertEqual "4" 4 (L.nextTask 0 (Just "Hello") list)) + , testCase + "with term - no match" + (assertEqual "0" 0 (L.nextTask 0 (Just "Wombat") list)) + ] + , testGroup + "prev" + [ testCase "no term" (assertEqual "0" 0 (L.prevTask 1 Nothing list)) + , testCase "with term" (assertEqual "0" 0 (L.prevTask 4 (Just "Hello") list)) + , testCase + "with term - no match" + (assertEqual "4" 4 (L.prevTask 4 (Just "Wombat") list)) + ] + , testGroup + "nearest" + [ testCase "no term" (assertEqual "same task" 2 (L.nearest 2 Nothing list)) + , testCase "term matches" (assertEqual "same task" 2 (L.nearest 2 (Just "ish") list)) + , testCase "term after" (assertEqual "next task" 3 (L.nearest 2 (Just "oons") list)) + , testCase + "term before" + (assertEqual "previous task" 3 (L.nearest 5 (Just "oons") list)) + , testCase + "term both - before closer" + (assertEqual "previous task" 0 (L.nearest 2 (Just "Hello") list)) + , testCase + "term both - after closer" + (assertEqual "next task" 4 (L.nearest 3 (Just "Hello") list)) + , testCase + "no matches" + (assertEqual "nothing" (-1) (L.nearest 3 (Just "Penguins") list)) + , testCase + "nothing to match" + (assertEqual "nothing" 3 (L.nearest (-1) (Just "Spoon") list)) + , testCase + "nothing with no term" + (assertEqual "nothing" 0 (L.nearest (-1) Nothing list)) + , testCase + "out of bounds with no term" + (assertEqual "nothing" 5 (L.nearest 50 Nothing list)) + , testCase + "out of bounds by 1 with no term" + (assertEqual "nothing" 5 (L.nearest 6 Nothing list)) + ] + ] diff --git a/test/Taskell/Data/ListTest.hs b/test/Taskell/Data/ListTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Data/ListTest.hs @@ -0,0 +1,188 @@ +module Taskell.Data.ListTest + ( test_list + ) where + +import ClassyPrelude as CP + +import Control.Lens ((.~)) + +import Test.Tasty +import Test.Tasty.HUnit + +import Taskell.Data.List.Internal as L +import qualified Taskell.Data.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"]) + , 2)) + (move 1 1 Nothing populatedList)) + , testCase + "down" + (assertEqual + "List with moved item" + (Just + ( List + "Populated" + (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]) + , 0)) + (move 1 (-1) Nothing populatedList)) + , testCase + "up - out of bounds" + (assertEqual + "List with moved item" + (Just + ( List + "Populated" + (fromList [T.new "Hello", T.new "Fish", T.new "Blah"]) + , 2)) + (move 1 10 Nothing populatedList)) + , testCase + "down - out of bounds" + (assertEqual + "List with moved item" + (Just + ( List + "Populated" + (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]) + , 0)) + (move 1 (-10) Nothing populatedList)) + , testCase + "up - with search" + (assertEqual + "List with moved item" + (Just + ( List + "Populated" + (fromList [T.new "Blah", T.new "Fish", T.new "Hello"]) + , 2)) + (move 0 1 (Just "Fish") populatedList)) + , testCase + "down - with search" + (assertEqual + "List with moved item" + (Just + ( List + "Populated" + (fromList [T.new "Fish", T.new "Hello", T.new "Blah"]) + , 0)) + (move 2 (-1) (Just "Hello") 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 + "Hello and Blah" + (List "Populated" (fromList [T.new "Hello", T.new "Blah"])) + (searchFor "l" populatedList)) + , testCase + "case-insensitive" + (assertEqual + "Hello" + (List "Populated" (fromList [T.new "Hello"])) + (searchFor "hello" populatedList)) + , testCase + "doesn't exist" + (assertEqual + "Empty list" + (List "Populated" CP.empty) + (searchFor "FFF" populatedList)) + ] + ] diff --git a/test/Taskell/Data/ListsTest.hs b/test/Taskell/Data/ListsTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Data/ListsTest.hs @@ -0,0 +1,233 @@ +module Taskell.Data.ListsTest + ( test_lists + ) where + +import ClassyPrelude hiding (delete) + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Lens ((.~)) + +import Taskell.Data.Date (textToTime) +import qualified Taskell.Data.List as L +import Taskell.Data.Lists.Internal +import qualified Taskell.Data.Task as T +import Taskell.Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) + +-- test data +list1, list2, list3 :: L.List +list1 = + foldl' + (flip L.append) + (L.empty "List 1") + [T.new "One", (T.due .~ textToTime "2019-08-14") (T.new "Two"), T.new "Three"] + +list2 = + foldl' + (flip L.append) + (L.empty "List 2") + [T.new "1", T.new "2", (T.due .~ textToTime "2018-12-03") (T.new "3")] + +list3 = + foldl' + (flip L.append) + (L.empty "List 3") + [(T.due .~ textToTime "2019-04-05") (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.due .~ textToTime "2018-12-03") (T.new "3")] + , foldl' + (flip L.append) + (L.empty "List 3") + [ (T.due .~ textToTime "2019-04-05") (T.new "01") + , T.new "10" + , T.new "11" + , T.new "2" + ] + ])) + (changeList Bottom (ListIndex 1, TaskIndex 1) testLists 1)) + , testCase + "left" + (assertEqual + "Returns updated lists" + (Just + (fromList + [ foldl' + (flip L.append) + (L.empty "List 1") + [ T.new "One" + , (T.due .~ textToTime "2019-08-14") (T.new "Two") + , T.new "Three" + , T.new "2" + ] + , foldl' + (flip L.append) + (L.empty "List 2") + [T.new "1", (T.due .~ textToTime "2018-12-03") (T.new "3")] + , list3 + ])) + (changeList Bottom (ListIndex 1, TaskIndex 1) testLists (-1))) + , testCase + "out of bounds list" + (assertEqual + "Nothing" + Nothing + (changeList Bottom (ListIndex 5, TaskIndex 1) testLists 1)) + , testCase + "out of bounds task" + (assertEqual + "Nothing" + Nothing + (changeList Bottom (ListIndex 1, TaskIndex 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.due .~ textToTime "2019-04-05") (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)) + , testCase + "due" + (assertEqual + "returns just due list" + (fromList + [ ( (ListIndex 1, TaskIndex 2) + , (T.due .~ textToTime "2018-12-03") (T.new "3")) + , ( (ListIndex 2, TaskIndex 0) + , (T.due .~ textToTime "2019-04-05") (T.new "01")) + , ( (ListIndex 0, TaskIndex 1) + , (T.due .~ textToTime "2019-08-14") (T.new "Two")) + ]) + (due testLists)) + ] diff --git a/test/Taskell/Data/SeqTest.hs b/test/Taskell/Data/SeqTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Data/SeqTest.hs @@ -0,0 +1,92 @@ +module Taskell.Data.SeqTest + ( test_seq + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Taskell.Data.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/Taskell/Data/SubtaskTest.hs b/test/Taskell/Data/SubtaskTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Data/SubtaskTest.hs @@ -0,0 +1,42 @@ +module Taskell.Data.SubtaskTest + ( test_subtask + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Taskell.Data.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/Taskell/Data/TaskTest.hs b/test/Taskell/Data/TaskTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Data/TaskTest.hs @@ -0,0 +1,200 @@ +module Taskell.Data.TaskTest + ( test_task + ) where + +import ClassyPrelude + +import Control.Lens ((.~)) + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Time.Calendar (fromGregorianValid) + +import Taskell.Data.Date (Due (DueDate)) +import qualified Taskell.Data.Subtask as ST (name, new) +import Taskell.Data.Task.Internal + +desc :: Maybe Text +desc = Just "A very boring description" + +testTask :: Task +testTask = + Task + { _name = "Test" + , _description = desc + , _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" + desc + (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" + desc + (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" + desc + (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" + desc + (fromList [ST.new "One" True, ST.new "Three" False]) + Nothing) + (removeSubtask 1 testTask)) + , testCase + "doesn't exist" + (assertEqual + "Returns task" + (Task + "Test" + desc + (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 + "case-insensitive" + (assertEqual "Find sub-task" True (contains "ONE" testTask)) + , testCase + "case-insensitive" + (assertEqual "Find sub-task" True (contains "two" testTask)) + , testCase "missing" (assertEqual "Find sub-task" False (contains "Fish" testTask)) + , testCase + "description" + (assertEqual "Finds in description" True (contains "boring" testTask)) + , testCase + "not in description" + (assertEqual "Doesn't find" False (contains "escapades" 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 (DueDate <$> (fromGregorianValid 2018 05 18))))) + ] + ] diff --git a/test/Taskell/Events/State/HistoryTest.hs b/test/Taskell/Events/State/HistoryTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Events/State/HistoryTest.hs @@ -0,0 +1,95 @@ +module Taskell.Events.State.HistoryTest + ( test_history + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Taskell.Events.State.History +import Taskell.Events.State.Types + +make :: [Integer] -> Integer -> [Integer] -> History Integer +make = History + +testHistory :: History Integer +testHistory = make empty 0 empty + +-- tests +test_history :: TestTree +test_history = + testGroup + "Events.State.History" + [ testGroup + "undo" + [ testCase "empty" (assertEqual "Nothing changes" testHistory (undo testHistory)) + , testCase + "one undo" + (assertEqual "Goes back" (make empty 0 [1]) (undo $ make [0] 1 empty)) + , testCase + "two undo" + (assertEqual + "Goes back" + (make empty 0 [1, 2]) + (undo . undo $ make [1, 0] 2 empty)) + , testCase + "three undo" + (assertEqual + "Goes back" + (make empty 0 [1, 2, 3]) + (undo . undo . undo $ make [2, 1, 0] 3 empty)) + ] + , testGroup + "redo" + [ testCase "empty" (assertEqual "Nothing changes" testHistory (redo testHistory)) + , testCase + "one redo" + (assertEqual "Goes forward" (make [0] 1 empty) (redo $ make empty 0 [1])) + , testCase + "two redo" + (assertEqual + "Goes forward" + (make [1, 0] 2 empty) + (redo . redo $ make empty 0 [1, 2])) + , testCase + "three redo" + (assertEqual + "Goes forward" + (make [2, 1, 0] 3 empty) + (redo . redo . redo $ make empty 0 [1, 2, 3])) + ] + , testGroup + "mix" + [ testCase + "empty" + (assertEqual + "Nothing changes" + testHistory + (undo . redo . undo . redo . undo $ testHistory)) + , testCase + "redo undo" + (assertEqual + "Nothing changes" + (make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10]) + (undo . redo $ make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10])) + , testCase + "undo redo" + (assertEqual + "Nothing changes" + (make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10]) + (redo . undo $ make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10])) + ] + , testGroup + "store" + [ testCase + "empty" + (assertEqual "Stores current value" (make [0] 0 empty) (store testHistory)) + , testCase + "undo store redo" + (assertEqual + "Clears redo" + (make [4, 3, 2, 1, 0] 4 empty) + (redo . store . undo $ make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10])) + ] + ] diff --git a/test/Taskell/Events/StateTest.hs b/test/Taskell/Events/StateTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/Events/StateTest.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedLists #-} + +module Taskell.Events.StateTest + ( test_state + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Lens ((&), (.~), (^.)) + +import Data.Time.Clock (secondsToDiffTime) +import Data.Time.Zones (utcTZ) + +import qualified Data.Sequence as S (lookup) +import qualified Taskell.Data.List as L (append, empty) +import qualified Taskell.Data.Task as T (new) +import Taskell.Events.State +import Taskell.Events.State.Types +import Taskell.Events.State.Types.Mode +import Taskell.Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) + +mockTime :: UTCTime +mockTime = UTCTime (ModifiedJulianDay 20) (secondsToDiffTime 0) + +testState :: State +testState = + State + { _mode = Normal + , _history = fresh empty + , _path = "test.md" + , _io = Nothing + , _height = 0 + , _searchTerm = Nothing + , _time = mockTime + , _timeZone = utcTZ + } + +moveToState :: State +moveToState = + State + { _mode = Modal MoveTo + , _history = + History + { _past = empty + , _present = + ( (ListIndex 4, TaskIndex 0) + , [ L.empty "List 1" + , L.empty "List 2" + , L.empty "List 3" + , L.empty "List 4" + , L.append (T.new "Test Item") (L.empty "List 5") + , L.empty "List 6" + , L.empty "List 7" + , L.empty "List 8" + , L.empty "List 9" + ]) + , _future = empty + } + , _path = "test.md" + , _io = Nothing + , _height = 0 + , _searchTerm = Nothing + , _time = mockTime + , _timeZone = utcTZ + } + +-- 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/Taskell/IO/GitHub/CardsTest.hs b/test/Taskell/IO/GitHub/CardsTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/GitHub/CardsTest.hs @@ -0,0 +1,36 @@ +module Taskell.IO.GitHub.CardsTest + ( test_cards + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Aeson + +import Taskell.IO.HTTP.GitHub.Card (MaybeCard (MaybeCard)) + +decodeCards :: Text -> Either String [MaybeCard] +decodeCards txt = eitherDecodeStrict $ encodeUtf8 txt + +-- tests +test_cards :: TestTree +test_cards = + testGroup + "IO.HTTP.GitHub.Card" + [ testCase + "parses basic card" + (assertEqual + "Gives back card" + (Right [MaybeCard (Just "blah") Nothing]) + (decodeCards "[{\"note\": \"blah\"}]")) + , testCase + "parses basic card" + (assertEqual + "Gives back card" + (Right + [MaybeCard Nothing (Just "https://api.github.com/projects/columns/7850783")]) + (decodeCards + "[{\"note\": null, \"content_url\": \"https://api.github.com/projects/columns/7850783\"}]")) + ] diff --git a/test/Taskell/IO/GitHubTest.hs b/test/Taskell/IO/GitHubTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/GitHubTest.hs @@ -0,0 +1,45 @@ +module Taskell.IO.GitHubTest + ( test_github + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Taskell.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/Taskell/IO/Keyboard/ParserTest.hs b/test/Taskell/IO/Keyboard/ParserTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/Keyboard/ParserTest.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +module Taskell.IO.Keyboard.ParserTest + ( test_parser + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.FileEmbed (embedFile) +import Text.RawString.QQ (r) + +import qualified Taskell.Events.Actions.Types as A +import Taskell.IO.Keyboard.Parser (bindings) +import Taskell.IO.Keyboard.Types + +basic :: Text +basic = "quit = q" + +basicResult :: Bindings +basicResult = [(BChar 'q', A.Quit)] + +basicMulti :: Text +basicMulti = + [r| + quit = q + detail = + |] + +basicMultiResult :: Bindings +basicMultiResult = [(BChar 'q', A.Quit), (BKey "Enter", A.Detail)] + +ini :: Text +ini = decodeUtf8 $(embedFile "test/Taskell/IO/Keyboard/data/bindings.ini") + +iniResult :: Bindings +iniResult = + [ (BChar 'q', A.Quit) + , (BChar 'u', A.Undo) + , (BChar 'r', A.Redo) + , (BChar '/', A.Search) + , (BChar '?', A.Help) + , (BChar '!', A.Due) + , (BChar 'k', A.Previous) + , (BChar 'j', A.Next) + , (BChar 'h', A.Left) + , (BChar 'l', A.Right) + , (BChar 'G', A.Bottom) + , (BChar 'a', A.New) + , (BChar 'O', A.NewAbove) + , (BChar 'o', A.NewBelow) + , (BChar '+', A.Duplicate) + , (BChar 'e', A.Edit) + , (BChar 'A', A.Edit) + , (BChar 'i', A.Edit) + , (BChar 'C', A.Clear) + , (BChar 'D', A.Delete) + , (BKey "Enter", A.Detail) + , (BChar '@', A.DueDate) + , (BKey "Backspace", A.ClearDate) + , (BChar 'K', A.MoveUp) + , (BChar 'J', A.MoveDown) + , (BChar 'H', A.MoveLeftBottom) + , (BChar 'L', A.MoveRightBottom) + , (BKey "Space", A.Complete) + , (BChar 'm', A.MoveMenu) + , (BChar 'N', A.ListNew) + , (BChar 'E', A.ListEdit) + , (BChar 'X', A.ListDelete) + , (BChar '>', A.ListRight) + , (BChar '<', A.ListLeft) + ] + +comma :: Text +comma = "quit = ," + +commaResult :: Bindings +commaResult = [(BChar ',', A.Quit)] + +test_parser :: TestTree +test_parser = + testGroup + "IO.Keyboard.Parser" + [ testCase "basic" (assertEqual "Parses quit" (Right basicResult) (bindings basic)) + , testCase + "basic multiline" + (assertEqual "Parses both" (Right basicMultiResult) (bindings basicMulti)) + , testCase "full ini file" (assertEqual "Parses all" (Right iniResult) (bindings ini)) + , testCase "comma" (assertEqual "Parses comma" (Right commaResult) (bindings comma)) + ] diff --git a/test/Taskell/IO/Keyboard/TypesTest.hs b/test/Taskell/IO/Keyboard/TypesTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/Keyboard/TypesTest.hs @@ -0,0 +1,37 @@ +module Taskell.IO.Keyboard.TypesTest + ( test_types + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Taskell.Events.Actions.Types as A (ActionType (..)) +import Taskell.IO.Keyboard (addMissing, badMapping, defaultBindings) +import Taskell.IO.Keyboard.Types (Binding (..), Bindings) + +notFull :: Bindings +notFull = [(BChar 'œ', A.Quit), (BChar 'U', A.Undo)] + +notFullResult :: Bindings +notFullResult = notFull <> (drop 2 defaultBindings) + +bad :: Bindings +bad = [(BChar 'q', A.Quit), (BChar 'u', A.Nothing), (BChar '>', A.Nothing), (BChar '<', A.ListLeft)] + +-- tests +test_types :: TestTree +test_types = + testGroup + "Events.Actions.Types" + [ testCase + "not missing" + (assertEqual "Finds no missing items" defaultBindings (addMissing defaultBindings)) + , testCase + "not missing" + (assertEqual "Finds missing items" notFullResult (addMissing notFull)) + , testCase + "bad mapping" + (assertEqual "Finds bad mapping" (Left "invalid mapping") (badMapping bad)) + ] diff --git a/test/Taskell/IO/Keyboard/data/bindings.ini b/test/Taskell/IO/Keyboard/data/bindings.ini new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/Keyboard/data/bindings.ini @@ -0,0 +1,43 @@ +# general +quit = q +undo = u +redo = r +search = / +help = ? +due = ! + +# navigation +previous = k +next = j +left = h +right = l +bottom = G + +# new tasks +new = a +newAbove = O +newBelow = o +duplicate = + + +# editing tasks +edit = e, A, i +clear = C +delete = D +detail = +dueDate = @ +clearDate = + +# moving tasks +moveUp = K +moveDown = J +moveLeft = H +moveRight = L +complete = +moveMenu = m + +# lists +listNew = N +listEdit = E +listDelete = X +listRight = > +listLeft = < diff --git a/test/Taskell/IO/KeyboardTest.hs b/test/Taskell/IO/KeyboardTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/KeyboardTest.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedLists #-} + +module Taskell.IO.KeyboardTest + ( test_keyboard + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Lens ((.~)) + +import Data.Time.Clock (secondsToDiffTime) +import Data.Time.Zones (utcTZ) + +import Graphics.Vty.Input.Events (Event (..), Key (..)) +import Taskell.Data.Lists.Internal (initial) +import Taskell.Events.Actions.Types as A +import Taskell.Events.State (create, quit) +import Taskell.Events.State.Types (State, Stateful, mode) +import Taskell.Events.State.Types.Mode (Mode (Shutdown)) +import Taskell.IO.Keyboard (generate) +import Taskell.IO.Keyboard.Types + +mockTime :: UTCTime +mockTime = UTCTime (ModifiedJulianDay 20) (secondsToDiffTime 0) + +tester :: BoundActions -> Event -> Stateful +tester actions ev state = lookup ev actions >>= ($ state) + +cleanState :: State +cleanState = create utcTZ mockTime "taskell.md" initial + +basicBindings :: Bindings +basicBindings = [(BChar 'q', A.Quit)] + +basicActions :: Actions +basicActions = [(A.Quit, quit)] + +basicResult :: Maybe State +basicResult = Just $ (mode .~ Shutdown) cleanState + +test_keyboard :: TestTree +test_keyboard = + testGroup + "IO.Keyboard" + [ testCase + "generate" + (assertEqual + "Parses basic" + basicResult + (tester (generate basicBindings basicActions) (EvKey (KChar 'q') []) cleanState)) + ] diff --git a/test/Taskell/IO/Markdown/ParserTest.hs b/test/Taskell/IO/Markdown/ParserTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/Markdown/ParserTest.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO.Markdown.ParserTest + ( test_parser + ) where + +import ClassyPrelude + +import Test.Tasty + +import Test.Tasty.HUnit + +import Control.Lens ((&), (.~)) +import Data.FileEmbed (embedFile) + +import Taskell.Data.Date (textToTime) +import Taskell.Data.List (create) +import Taskell.Data.Lists (Lists, analyse, appendToLast, newList) + +import qualified Taskell.Data.Subtask as ST (new) +import Taskell.Data.Task (Task, addSubtask, due, new, setDescription) +import Taskell.IO.Config.Markdown (Config (Config), defaultConfig, descriptionOutput, + dueOutput, localTimes, subtaskOutput, taskOutput, + titleOutput) +import Taskell.IO.Markdown.Parser (parse) + +-- error message +err :: Either Text Lists +err = Left "Could not parse file." + +-- complete taskell file +file :: Text +file = decodeUtf8 $(embedFile "test/Taskell/IO/data/roadmap.md") + +-- alternative markdown configs +alternativeConfig :: Config +alternativeConfig = + Config + { titleOutput = "##" + , taskOutput = "###" + , descriptionOutput = ">" + , dueOutput = "@" + , subtaskOutput = "-" + , localTimes = True + } + +-- useful records +task :: Task +task = new "Test Item" + +list :: Lists +list = newList "Test" empty + +listWithItem :: Lists +listWithItem = appendToLast task list + +multiList :: Lists +multiList = + fromList + [create "Test" (fromList [new "Test Item"]), create "Test 2" (fromList [new "Test Item 2"])] + +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 = task & due .~ textToTime "2018-04-12" + +listWithDueDateItem :: Lists +listWithDueDateItem = appendToLast taskWithDueDate list + +-- tests +test_parser :: TestTree +test_parser = + testGroup + "IO.Markdown" + [ testGroup + "Default Format" + [ testCase + "List Title" + (assertEqual "One list" (Right list) (parse defaultConfig "## Test")) + , testCase + "List item" + (assertEqual + "List item" + (Right listWithItem) + (parse defaultConfig "## Test\n\n- Test Item")) + , testCase + "Multiple Lists" + (assertEqual + "List item" + (Right multiList) + (parse defaultConfig "## Test\n\n- Test Item\n\n## Test 2\n\n- Test Item 2")) + , testCase + "Summary" + (assertEqual + "Summary" + (Right listWithSummaryItem) + (parse defaultConfig "## Test\n\n- Test Item\n > Summary")) + , testCase + "List Item with multi-line Summary" + (assertEqual + "List item with a summary" + (Right listWithMultiLineSummaryItem) + (parse + defaultConfig + "## Test\n\n- Test Item\n > Summary Line 1\n > Summary Line 2")) + , testCase + "Due Date" + (assertEqual + "Due Date" + (Right listWithDueDateItem) + (parse defaultConfig "## Test\n\n- Test Item\n @ 2018-04-12")) + , testCase + "Sub-Task" + (assertEqual + "List item with Sub-Task" + (Right (makeSubTask "Blah" False)) + (parse defaultConfig "## Test\n\n- Test Item\n * [ ] Blah")) + , testCase + "Complete Sub-Task" + (assertEqual + "List item with Sub-Task" + (Right (makeSubTask "Blah" True)) + (parse defaultConfig "## Test\n\n- Test Item\n * [x] Blah")) + ] + , testGroup + "Alternative Format" + [ testCase + "List Title" + (assertEqual "One list" (Right list) (parse alternativeConfig "## Test")) + , testCase + "List item" + (assertEqual + "List item" + (Right listWithItem) + (parse alternativeConfig "## Test\n\n### Test Item")) + , testCase + "Multiple Lists" + (assertEqual + "List item" + (Right multiList) + (parse + alternativeConfig + "## Test\n\n### Test Item\n\n## Test 2\n\n### Test Item 2")) + , testCase + "Summary" + (assertEqual + "Summary" + (Right listWithSummaryItem) + (parse alternativeConfig "## Test\n\n### Test Item\n> Summary")) + , testCase + "List Item with multi-line Summary" + (assertEqual + "List item with a summary" + (Right listWithMultiLineSummaryItem) + (parse + alternativeConfig + "## Test\n\n### Test Item\n> Summary Line 1\n> Summary Line 2")) + , testCase + "Due Date" + (assertEqual + "Due Date" + (Right listWithDueDateItem) + (parse alternativeConfig "## Test\n\n### Test Item\n@ 2018-04-12")) + , testCase + "Sub-Task" + (assertEqual + "List item with Sub-Task" + (Right (makeSubTask "Blah" False)) + (parse alternativeConfig "## Test\n\n### Test Item\n- [ ] Blah")) + , testCase + "Complete Sub-Task" + (assertEqual + "List item with Sub-Task" + (Right (makeSubTask "Blah" True)) + (parse alternativeConfig "## Test\n\n### Test Item\n- [x] Blah")) + ] + , testGroup + "Errors" + [ testCase "Blank line" (assertEqual "Parse Error" err (parse defaultConfig "")) + , testCase + "Just spaces" + (assertEqual "Parse Error" err (parse defaultConfig " ")) + , testCase + "Just whitespace" + (assertEqual "Parse Error" err (parse defaultConfig " \n \n \t ")) + , testCase "Error" (assertEqual "Parse Error" err (parse defaultConfig "Test")) + , testCase + "List item without list" + (assertEqual "Parse Error" err (parse defaultConfig "- Test Item")) + , testCase + "Sub task without list item" + (assertEqual "Parse Error" err (parse defaultConfig "## Test\n * Blah")) + ] + , testCase + "File" + (assertEqual + "Parses whole file" + (Right "test\nLists: 6\nTasks: 202") + (analyse "test" <$> parse defaultConfig file)) + ] diff --git a/test/Taskell/IO/Markdown/SerializerTest.hs b/test/Taskell/IO/Markdown/SerializerTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/Markdown/SerializerTest.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.IO.Markdown.SerializerTest + ( test_serializer + ) where + +import ClassyPrelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Lens ((&), (.~)) +import Control.Monad.Reader (runReader) +import Data.FileEmbed (embedFile) + +import Data.Time.Zones (utcTZ) +import Data.Time.Zones.All (TZLabel (America__New_York), tzByLabel) + +import Taskell.Data.Date (textToTime) +import qualified Taskell.Data.List as L (append, empty) +import Taskell.Data.Lists (Lists, appendToLast, newList) +import qualified Taskell.Data.Subtask as ST (new) +import Taskell.Data.Task (Task, addSubtask, due, new, setDescription) +import Taskell.IO.Config.Markdown (Config (..), defaultConfig) +import Taskell.IO.Markdown.Parser (parse) +import Taskell.IO.Markdown.Serializer (MarkdownInfo (MarkdownInfo), serialize) + +-- complete taskell file +file :: Text +file = decodeUtf8 $(embedFile "test/Taskell/IO/data/roadmap.md") + +-- alternative markdown configs +alternativeConfig :: Config +alternativeConfig = + Config + { titleOutput = "##" + , taskOutput = "###" + , descriptionOutput = ">" + , dueOutput = "@" + , subtaskOutput = "-" + , localTimes = True + } + +-- useful records +task :: Task +task = new "Test Item" + +list :: Lists +list = newList "Test" empty + +lists :: Lists +lists = fromList [L.append task (L.empty "To Do"), L.append (new "Fish") (L.empty "Done")] + +listWithItem :: Lists +listWithItem = appendToLast task list + +makeSubTask :: Text -> Bool -> Lists +makeSubTask t b = appendToLast (addSubtask (ST.new t b) task) list + +makeSubTasks :: [Text] -> Bool -> Lists +makeSubTasks ts b = appendToLast (foldr addSubtask task subtasks) list + where + subtasks = flip ST.new b <$> ts + +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 = task & due .~ textToTime "2018-04-12" + +listWithDueDateItem :: Lists +listWithDueDateItem = appendToLast taskWithDueDate list + +taskWithDueTime :: Task +taskWithDueTime = task & due .~ textToTime "2018-04-12 12:00 UTC" + +listWithDueTimeItem :: Lists +listWithDueTimeItem = appendToLast taskWithDueTime list + +-- reader +defaultReader :: MarkdownInfo +defaultReader = MarkdownInfo utcTZ defaultConfig + +alternativeReader :: MarkdownInfo +alternativeReader = MarkdownInfo utcTZ alternativeConfig + +-- simplify tests +serialize' :: MarkdownInfo -> Lists -> Text +serialize' md ls = runReader (serialize ls) md + +-- tests +test_serializer :: TestTree +test_serializer = + testGroup + "IO.Markdown" + [ testGroup + "Serialisation" + [ testGroup + "Default Format" + [ testCase + "Standard lists" + (assertEqual + "Markdown formatted output" + "## To Do\n\n- Test Item\n\n## Done\n\n- Fish\n" + (serialize' defaultReader lists)) + , testCase + "Standard list" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n" + (serialize' defaultReader listWithItem)) + , testCase + "Standard list with summary" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n > Summary\n" + (serialize' defaultReader listWithSummaryItem)) + , testCase + "Standard list with date" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n @ 2018-04-12\n" + (serialize' defaultReader listWithDueDateItem)) + , testCase + "Standard list with date - timezone" + (assertEqual + "Use UTC timezone" + "## Test\n\n- Test Item\n @ 2018-04-12 12:00 UTC\n" + (serialize' + (MarkdownInfo (tzByLabel America__New_York) defaultConfig) + listWithDueTimeItem)) + , testCase + "Standard list with sub-task" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n * [x] Blah\n" + (serialize' defaultReader (makeSubTask "Blah" True))) + , testCase + "Standard list with sub-tasks" + (assertEqual + "Markdown formatted output" + "## Test\n\n- Test Item\n * [x] Blah\n * [x] Cow\n * [x] Spoon\n" + (serialize' + defaultReader + (makeSubTasks ["Spoon", "Cow", "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" + (serialize' defaultReader listWithMultiLineSummaryItem)) + ] + , testGroup + "Alternative Format" + [ testCase + "Standard list" + (assertEqual + "Markdown formatted output" + "## Test\n\n### Test Item\n" + (serialize' alternativeReader listWithItem)) + , testCase + "Standard list with sub-task" + (assertEqual + "Markdown formatted output" + "## Test\n\n### Test Item\n- [ ] Blah\n" + (serialize' alternativeReader (makeSubTask "Blah" False))) + , testCase + "Standard list with date - timezone" + (assertEqual + "Uses local timezone" + "## Test\n\n### Test Item\n@ 2018-04-12 08:00 EDT\n" + (serialize' + (MarkdownInfo (tzByLabel America__New_York) alternativeConfig) + listWithDueTimeItem)) + ] + ] + , testCase + "Parse then serialize" + (assertEqual + "Returns same text" + (Right file) + (serialize' defaultReader <$> parse defaultConfig file)) + ] diff --git a/test/Taskell/IO/TrelloTest.hs b/test/Taskell/IO/TrelloTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/TrelloTest.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Taskell.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 Taskell.IO.HTTP.Trello.ChecklistItem (ChecklistItem, checkItems, checklistItemToSubTask) +import Taskell.IO.HTTP.Trello.List (List, listToList) + +json :: Maybe [List] +json = decodeStrict $(embedFile "test/Taskell/IO/data/trello.json") + +checklistJson :: Maybe [ChecklistItem] +checklistJson = + (^. checkItems) <$> decodeStrict $(embedFile "test/Taskell/IO/data/trello-checklists.json") + +-- tests +test_trello :: TestTree +test_trello = + testGroup + "IO.Trello" + [ testCase + "Lists" + (assertEqual "Parses list JSON" (Just 5) (length . (listToList <$>) <$> json)) + , testCase + "Checklists" + (assertEqual + "Parses checklist JSON" + (Just 5) + (length . (checklistItemToSubTask <$>) <$> checklistJson)) + ] diff --git a/test/Taskell/IO/data/trello-checklists.json b/test/Taskell/IO/data/trello-checklists.json new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/data/trello-checklists.json @@ -0,0 +1,35 @@ +{ + "id": "5b04450ff88a64205bf04939", + "checkItems": [ + { + "state": "incomplete", + "idChecklist": "5b04450ff88a64205bf04939", + "id": "5b044511abc222721a03a478", + "name": "Sub-item 1" + }, + { + "state": "incomplete", + "idChecklist": "5b04450ff88a64205bf04939", + "id": "5b0445123561ce689e3827b4", + "name": "Sub-item 2" + }, + { + "state": "incomplete", + "idChecklist": "5b04450ff88a64205bf04939", + "id": "5b044513fe0a46480d6bcc87", + "name": "Sub-item 3" + }, + { + "state": "incomplete", + "idChecklist": "5b04450ff88a64205bf04939", + "id": "5b04451489b89cde3b7a3af1", + "name": "Sub-item 4" + }, + { + "state": "incomplete", + "idChecklist": "5b04450ff88a64205bf04939", + "id": "5b044516152060b914e3fa2f", + "name": "Sub-item 5" + } + ] +} diff --git a/test/Taskell/IO/data/trello.json b/test/Taskell/IO/data/trello.json new file mode 100644 --- /dev/null +++ b/test/Taskell/IO/data/trello.json @@ -0,0 +1,146 @@ +[ + { + "id": "5b04449b124fd7d02a6700ac", + "name": "List 1", + "cards": [ + { + "id": "5b0444a892cac8a91ce4ac63", + "name": "Item 1", + "desc": "", + "due": null, + "idChecklists": [] + }, + { + "id": "5b0444aa28c4fade8972564a", + "name": "Item 2", + "desc": "", + "due": null, + "idChecklists": [ + "5b04450ff88a64205bf04939", + "5b0445196d92125a52c5af19", + "5b044524cd09c4cfcf17a7e1" + ] + }, + { + "id": "5b0444acb5d32e68affe0fbc", + "name": "Item 3", + "desc": "", + "due": null, + "idChecklists": [] + }, + { + "id": "5b0444bba2b49880d3cf5ef4", + "name": "Item 4", + "desc": "", + "due": null, + "idChecklists": [] + } + ] + }, + { + "id": "5b04449c4a149b7886795834", + "name": "List 2", + "cards": [ + { + "id": "5b0444be54ac75e4315f8c75", + "name": "Item 1", + "desc": "", + "due": null, + "idChecklists": [ + "5b0444def123ada312ce7b61" + ] + }, + { + "id": "5b0444bfcf2ae87de87efff6", + "name": "Item 2", + "desc": "", + "due": null, + "idChecklists": [] + }, + { + "id": "5b0444c05b48f5803fb6fbe6", + "name": "Item 3", + "desc": "", + "due": null, + "idChecklists": [] + } + ] + }, + { + "id": "5b04449e55eeab1a57d78284", + "name": "List 3", + "cards": [ + { + "id": "5b0444c56eb336a91504b5e4", + "name": "Item 1", + "desc": "", + "due": null, + "idChecklists": [] + }, + { + "id": "5b0444c60af8bc226f9efcd9", + "name": "Item 2", + "desc": "", + "due": null, + "idChecklists": [] + }, + { + "id": "5b0444c875057fa8ab6e516c", + "name": "Item 3", + "desc": "", + "due": null, + "idChecklists": [ + "5b0444f2ac1dcba5f3803f70", + "5b0444fcaafc8fd6f5a49071" + ] + }, + { + "id": "5b0444ca8650ff18224ea71d", + "name": "Item 4", + "desc": "", + "due": null, + "idChecklists": [] + }, + { + "id": "5b0444cc368a78a8bded6c90", + "name": "Item 5", + "desc": "", + "due": null, + "idChecklists": [] + } + ] + }, + { + "id": "5b0444a16c17cd686e07b76c", + "name": "List 4", + "cards": [ + { + "id": "5b0444d02e30881629179287", + "name": "Item 1", + "desc": "", + "due": null, + "idChecklists": [] + } + ] + }, + { + "id": "5b0444a4a3565ea909f506ee", + "name": "List 5", + "cards": [ + { + "id": "5b0444d34f5a66ec48672bdb", + "name": "Item 1", + "desc": "", + "due": null, + "idChecklists": [] + }, + { + "id": "5b0444d522f50607e73595b1", + "name": "Item 2", + "desc": "", + "due": null, + "idChecklists": [] + } + ] + } +] diff --git a/test/Taskell/UI/FieldTest.hs b/test/Taskell/UI/FieldTest.hs new file mode 100644 --- /dev/null +++ b/test/Taskell/UI/FieldTest.hs @@ -0,0 +1,171 @@ +module Taskell.UI.FieldTest + ( test_field + ) where + +import ClassyPrelude + +import Taskell.UI.Draw.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.Draw.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 + "Triple line" + (assertEqual + "Should wrap to correct position" + (11, 2) + (cursorPosition' + "Artichoke penguin astronaut wombat artichoke penguin astronaut wombat" + 64)) + , testCase + "Long words with space" + (assertEqual + "Should ignore the space when counting" + (16, 1) + (cursorPosition' "Blah fish wombat monkey sponge catpult arsonist" 47)) + , testCase + "Multibyte string single line" + (assertEqual "Should move in twos" (4, 0) (cursorPosition' "乤乭亍乫" 2)) + , testCase + "Multibyte string multi-line" + (assertEqual + "Should move in twos" + (4, 1) + (cursorPosition' "乤乭亍乫 乤乭亍乫 乤乭亍乫 乤乭亍乫" 17)) + ] + ] diff --git a/test/UI/FieldTest.hs b/test/UI/FieldTest.hs deleted file mode 100644 --- a/test/UI/FieldTest.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.FieldTest - ( test_field - ) where - -import ClassyPrelude - -import UI.Draw.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.Draw.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 - "Triple line" - (assertEqual - "Should wrap to correct position" - (11, 2) - (cursorPosition' - "Artichoke penguin astronaut wombat artichoke penguin astronaut wombat" - 64)) - , testCase - "Long words with space" - (assertEqual - "Should ignore the space when counting" - (16, 1) - (cursorPosition' "Blah fish wombat monkey sponge catpult arsonist" 47)) - , testCase - "Multibyte string single line" - (assertEqual "Should move in twos" (4, 0) (cursorPosition' "乤乭亍乫" 2)) - , testCase - "Multibyte string multi-line" - (assertEqual - "Should move in twos" - (4, 1) - (cursorPosition' "乤乭亍乫 乤乭亍乫 乤乭亍乫 乤乭亍乫" 17)) - ] - ]