diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/reheat.cabal b/reheat.cabal new file mode 100644 --- /dev/null +++ b/reheat.cabal @@ -0,0 +1,37 @@ +name: reheat +version: 0.1.4 +cabal-version: >=1.8 +build-type: Simple +license: GPL +license-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt +copyright: GPL +maintainer: Ingolf Wagner +stability: experimental +homepage: https://github.com/mrVanDalo/reheat +bug-reports: https://github.com/mrVanDalo/reheat/issues +synopsis: to make notes and reduce impact on idle time on writing other programms. +description: a programm to make notes and reduce impact on idle time on writing other programms. +category: Todo +author: Ingolf Wagner +data-dir: "" + +source-repository head + type: git + location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ + +executable reheat + build-depends: QuickCheck -any, base >= 2 && < 4, directory -any, + text -any, vty -any, vty-ui -any + main-is: Main.hs + buildable: True + hs-source-dirs: src + other-modules: Context Main View Task Task.Modification Task.Data + +test-suite test-reheat + build-depends: QuickCheck -any, base >= 2 && < 4, directory -any, + text -any, vty -any, vty-ui -any + type: exitcode-stdio-1.0 + main-is: Main.hs + buildable: True + cpp-options: -DMAIN_FUNCTION=testMain + hs-source-dirs: src diff --git a/src/Context.hs b/src/Context.hs new file mode 100644 --- /dev/null +++ b/src/Context.hs @@ -0,0 +1,202 @@ +----------------------------------------------------------------------------- +-- +-- Module : Context +-- Copyright : GPL v3 +-- License : AllRightsReserved +-- +-- Maintainer : Ingolf Wagner +-- Stability : experimental +-- Portability : +-- +-- | Holds all the objects and functions for manipulating them. +-- It should be used as a real programm while View should wire this module to create +-- the UI. +-- +----------------------------------------------------------------------------- + +module Context where + +import Graphics.Vty.Widgets.All +import Graphics.Vty.Attributes +import Graphics.Vty +import Control.Monad +import System.IO +import System.Directory +import Data.IORef +import qualified Data.Text as T + +import Task + +type TaskViewList = Widget (List Task Task) +type TaskDescription = Widget FormattedText +type BreadCrumbWidget = Widget BreadCrumb +type BreadCrumb = [Task] + + +data Context = Context { + description :: TaskDescription, + bread :: BreadCrumbWidget, + leftList :: TaskViewList, + rightList :: TaskViewList, + tasks :: IORef Tasks + } + +-- | create Context out of a file +createContext :: FilePath -> IO Context +createContext filePath = do + tasks <- newIORef =<< readFromFile filePath + leftList <- newTaskList [] + fullText <- textWidget wrap $ T.pack "Welcome to Reheat" + bread <- newBreadCrumb [] + rightList <- newTaskList [] + return $ Context fullText bread leftList rightList tasks + +-- | creates a new task list +newTaskList :: [Task] -> IO TaskViewList +newTaskList tasks = do + list <- newList (green `on` black) + appendTasksToList list tasks + return list + + +-- | Append single task to list +appendTask :: Context -> Task -> IO () +appendTask context task = do + modifyIORef (tasks context) $ addTask task + updateLeftList context + +-- | updates left list in context +updateLeftList :: Context -> IO () +updateLeftList context = do + t <- readIORef $ tasks context + let ts = actual t + setList ts (leftList context) + updateBreadCrumbs context + return () + +-- | unwrapps the actual task list from the context +actualTaskList :: Context -> IO [Task] +actualTaskList context = do + t <- readIORef $ tasks context + return $ actual t + +unappendTask :: Int -> Context -> IO () +unappendTask index context = do + modifyIORef (tasks context) $ removeTask index + updateLeftList context + +-- | move into task +moveInto :: Task -> Context -> IO () +moveInto task context = do + modifyIORef (tasks context) $ goInto task + updateLeftList context + + + +-- | move out of the actual task list +moveOut :: Context -> IO () +moveOut context = do + modifyIORef (tasks context) goOut + updateLeftList context + +-- | clear list and set tasks to that value +setList :: [Task] -> TaskViewList -> IO () +setList tasks list = do + clearList list + appendTasksToList list (reverse tasks) + setSelected list 0 + return () + +-- | returns the active tasks right now +activeTasks :: Context -> IO [Task] +activeTasks context = do + l <- readIORef $ tasks context + return $ actual l + + +-- | append some tasks to the list +appendTasksToList list tasks = + forM_ tasks $ \t -> do + f <- newTask t + b <- bordered f + (insertIntoList list t f 0) + + +-- | write tasks to file +writeToFile :: FilePath -> IORef Tasks -> IO () +writeToFile fileName wRef = do + tasks <- readIORef wRef + withFile fileName WriteMode $ \h -> do + hPutStr h (show $ saveTasks tasks) + +-- | read from file +readFromFile :: FilePath -> IO Tasks +readFromFile f = do + exist <- doesFileExist f + case exist of -- | if is not working here + False -> do return $ emptyTasks + True -> do + withFile f ReadMode $ \h -> do + ls <- hGetLine h + return $ readTasks $ read ls + + +-- | create a rendarble Task +newTask :: Task -> IO (Widget Task) +newTask t = do + newWidget t $ \w -> + w { render_ = \this region ctx -> do + elem <- getState this + renderTask region ctx elem + } + + + +-- | Task to Image Renderer +renderTask :: DisplayRegion -> RenderContext -> Task -> IO Image +renderTask region ctx task = do + let header = T.pack $ head . lines . text $ task + width = (fromEnum $ region_width region) + (truncated, _, _) = clip1d (Phys 0) (Phys width) header + return $ string (getNormalAttr ctx) $ T.unpack truncated + + + +-- | bread crumbs here + + +updateBreadCrumbs :: Context -> IO () +updateBreadCrumbs ctx = do + t <- readIORef $ tasks ctx + let newCrumbs = breadCrumbs t + crumbObject = bread ctx + setBreadCrumbs newCrumbs crumbObject + return () + + +setBreadCrumbs :: [Task] -> Widget BreadCrumb -> IO () +setBreadCrumbs t bread = do + updateWidgetState bread (\a -> t) + +newBreadCrumb :: [Task] -> IO (Widget BreadCrumb) +newBreadCrumb tasks = newWidget tasks $ \w -> + w { render_ = \this region ctx -> do + listOfTasks <- getState this + renderBreadCrumb region ctx listOfTasks + } + +renderBreadCrumb :: DisplayRegion -> RenderContext -> BreadCrumb -> IO Image +renderBreadCrumb region ctx bread = do + + return $ string (getNormalAttr ctx) $ renderBread bread "" + where + width = (fromEnum $ region_width region) + renderBread bread acc + | width <= (length acc)= drop ((length acc) - width) acc + | bread == [] && acc == [] = "/" + | bread == [] = acc + | otherwise = + let header = T.pack $ head . lines . text . head $ bread + (truncated, _, _) = clip1d (Phys 0) (Phys width) header + str = T.unpack truncated + in renderBread (tail bread) (str ++ " > " ++ acc) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : GPL v3 +-- License : AllRightsReserved +-- +-- Maintainer : Ingolf Wagner +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Main ( + main +) where + +import Control.Monad (unless) +import Data.List (stripPrefix) +import System.Exit (exitFailure) +import Test.QuickCheck.All (quickCheckAll) + +import qualified View + +-- Simple function to create a hello message. +hello s = "Hello " ++ s + +-- Tell QuickCheck that if you strip "Hello " from the start of +-- hello s you will be left with s (for any s). +prop_hello s = stripPrefix "Hello " (hello s) == Just s + +-- Hello World +exeMain = do + putStrLn (hello "World") + +-- Entry point for unit tests. +testMain = do + allPass <- $quickCheckAll -- Run QuickCheck on all prop_ functions + unless allPass exitFailure + +-- This is a clunky, but portable, way to use the same Main module file +-- for both an application and for unit tests. +-- MAIN_FUNCTION is preprocessor macro set to exeMain or testMain. +-- That way we can use the same file for both an application and for tests. +#ifndef MAIN_FUNCTION +#define MAIN_FUNCTION View.main +#endif +main = MAIN_FUNCTION + diff --git a/src/Task.hs b/src/Task.hs new file mode 100644 --- /dev/null +++ b/src/Task.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- +-- Module : Task +-- Copyright : GPL v3 +-- License : AllRightsReserved +-- +-- Maintainer : Ingolf Wagner +-- Stability : experimental +-- Portability : +-- +-- | The Task interaction Module +-- +----------------------------------------------------------------------------- +-- module Task where + +module Task ( + -- | data + Task(..), + Tasks(..), + emptyTasks, + + -- | movement + goInto, + goOut, + + -- | manipulation + addTask, + addTasks, + removeTask, + swapTasks, + + -- | serialization + readTasks, + saveTasks, + + -- | information + breadCrumbs, +) where + +import Task.Data +import Task.Modification diff --git a/src/Task/Data.hs b/src/Task/Data.hs new file mode 100644 --- /dev/null +++ b/src/Task/Data.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- +-- Module : Task.Data +-- Copyright : GPL v3 +-- License : AllRightsReserved +-- +-- Maintainer : Ingolf Wagner +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Task.Data where + +-- | The empty Task version. +-- use this to create an Empty Tasks Element +emptyTasks :: Tasks +emptyTasks = Tasks [] [] + +data Task = Comment { text :: String , children :: [Task] } deriving (Eq,Show) +data Tasks = Tasks { actual :: [Task], history :: [FTask] } deriving (Show) +data FTask = FTask { focused :: Task, prev :: [Task], next :: [Task] } deriving (Show) + +-- | data types for saveing +-- don't use getter and setter names, to not interfere with the +-- original data objects. These types are just for saving and nothing more +data SaveTasks = Version1 [SaveTask] [SaveFTask] deriving (Show,Read) +data SaveTask = Task1 String [SaveTask] deriving (Show,Read) +data SaveFTask = FTask1 SaveTask [SaveTask] [SaveTask] deriving (Show,Read) + +readTasks :: SaveTasks -> Tasks +readTasks (Version1 sTasks sFTasks) = Tasks (map readTask sTasks) (map readFTask sFTasks) + +saveTasks :: Tasks -> SaveTasks +saveTasks (Tasks tasks fTasks) = Version1 (map saveTask tasks) (map saveFTask fTasks) + +readTask :: SaveTask -> Task +readTask (Task1 a rest) = Comment a (map readTask rest) + +saveTask :: Task -> SaveTask +saveTask (Comment a h) = Task1 a (map saveTask h) + +readFTask :: SaveFTask -> FTask +readFTask (FTask1 f l r) = FTask (readTask f) (map readTask l) (map readTask r) + +saveFTask :: FTask -> SaveFTask +saveFTask (FTask f l r) = FTask1 (saveTask f) (map saveTask l) (map saveTask r) diff --git a/src/Task/Modification.hs b/src/Task/Modification.hs new file mode 100644 --- /dev/null +++ b/src/Task/Modification.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- +-- Module : Task.Modification +-- Copyright : GPL v3 +-- License : AllRightsReserved +-- +-- Maintainer : Ingolf Wagner +-- Stability : experimental +-- Portability : +-- +-- | This package contains all the manipulation you can do to the +-- Task objects. +-- +----------------------------------------------------------------------------- + +module Task.Modification where + + +import Control.Arrow +import Data.List +import Task.Data + +-- | bread crumbs +breadCrumbs :: Tasks -> [Task] +breadCrumbs (Tasks _ ftasks) = map (\f -> focused f) ftasks + +-- | swap tasks on the actual path of the Tasks object +swapTasks :: Int -> Int -> Tasks -> Tasks +swapTasks a b tasks + | a < 0 = tasks + | b < 0 = tasks + | a == b = tasks + | a > length (actual tasks) = tasks + | b > length (actual tasks) = tasks + | otherwise = + let t = actual tasks + x = t !! a + y = t !! b + in if x == y then tasks + else + Tasks (map (\l -> case l of + x -> y + y -> x + _ -> l ) t) (history tasks) + + +-- | go into the children of some tasks +goInto :: Task-> Tasks-> Tasks +goInto task (Tasks ys xs) = + let pos = task `elemIndex` ys + elem = case pos of + Nothing -> FTask task ys [] + Just n -> FTask task (take n ys) (drop (n + 1) ys) + in Tasks (children task) (elem:xs) + +-- | go out of actual task list and go one level up +goOut :: Tasks -> Tasks +goOut (Tasks a []) = Tasks a [] +goOut (Tasks _ ((FTask a b c):xs)) = + let actual = b ++ a:c + rest = case xs of + [] -> [] + ((FTask n w v):ks) -> (FTask n { children = actual } w v):ks + in + Tasks actual rest + +-- | Add Task to Tasks +addTask :: Task -> Tasks -> Tasks +addTask t (Tasks a []) = Tasks (t:a) [] +addTask t (Tasks a ((FTask parent b c):bs)) = + Tasks (t:a) ((FTask parent { children = t:(children parent)} b c):bs) + +-- | Add Tasks to Tasks +addTasks :: [Task] -> Tasks -> Tasks +addTasks t (Tasks a []) = Tasks (t++a) [] +addTasks t (Tasks a ((FTask parent b c):bs)) = + Tasks (t ++ a) ((FTask parent { children = t ++ (children parent)} b c):bs) + + + +-- | removes Task from Tasks +removeTask :: Int -> Tasks -> Tasks +removeTask index tasks + | index < 0 = tasks + | index > (length $ actual tasks) = tasks + | otherwise = + let (ys,zs) = splitAt index (actual tasks) + c = ys ++ (tail zs) + rest = case (history tasks) of + [] -> [] + (FTask p x y):xs -> (FTask p { children = c } x y):xs + in Tasks c rest + +-- | depth of the actual focused tasks 0 for top level +depth :: Tasks -> Int +depth (Tasks _ xs) = (length xs) - 1 + +-- | unrolls the tasks untill we have the toplevel +asList :: Tasks -> [Task] +asList = actual . unroll + +-- | unrolls the tasks untill we have the toplevel +unroll :: Tasks -> Tasks +unroll (Tasks a []) = Tasks a [] +unroll f = unroll . goOut $ f diff --git a/src/View.hs b/src/View.hs new file mode 100644 --- /dev/null +++ b/src/View.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- +-- Module : VtyView +-- Copyright : GPL v3 +-- License : AllRightsReserved +-- +-- Maintainer : Ingolf Wagner +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module View ( + main +) where + +import System.Exit +import Graphics.Vty.Widgets.All +import Graphics.Vty.Attributes +import Graphics.Vty +import Control.Monad +import System.IO +import System.Directory + +import Task +import Data.IORef + +import Context + +import qualified Data.Text as T + +-- | To be interpreted by the Main +data Action = Exit | OpenCreateTaskDialog | MoveInto Task | MoveOut | CreateTask Task + +main = do + let filePath = ".todo.rht" + + context <- createContext filePath + + let lList = leftList context + fullText = description context + rList = rightList context + b = bread context + + box <- (bordered b) <--> bordered lList <++> + (bordered fullText <--> bordered rList) + + fg <- newFocusGroup + addToFocusGroup fg lList + + editor <- multiLineEditWidget + eFg <- newFocusGroup + addToFocusGroup eFg editor + d <- plainText "Header" <--> return editor >>= withBoxSpacing 1 + + c <- newCollection + switchToMain <- addToCollection c box fg + switchToDialog <- addToCollection c d eFg + + editor `onKeyPressed` \this key mod -> case key of + KEsc -> do + switchToMain + return True + _ -> return False + + editor `onKeyPressed` \_ key _ -> case key of + KEsc -> do + text <- getEditText editor + case text of + "" -> do + switchToMain + return True + _ -> do + appendTask context (Comment (T.unpack text) []) + setEditText editor "" + focus editor + switchToMain + return True + _ -> do + return False + + lList `onKeyPressed` \this key whatever -> case key of + KASCII 'q' -> do + writeToFile filePath (tasks context) + exitSuccess + return True + KASCII 'a' -> do + switchToDialog + return True + KASCII 'j' -> do + scrollDown $ leftList context + return True + KASCII 'k' -> do + scrollUp $ leftList context + return True + KASCII 'd' -> do + item <- getSelected $ leftList context + case item of + Nothing -> return True + Just (itemNr, itemElem) -> do + full <- getListSize $ leftList context + -- unappendTask (full - 1 - itemNr) tasks leftList + unappendTask itemNr context + return True + KRight -> manoverRight context + KASCII 'l' -> manoverRight context + KASCII 'o' -> manoverLeft context + KLeft -> manoverLeft context + + _ -> return False + + lList `onSelectionChange` \event -> case event of + SelectionOff -> do + clearList rList + SelectionOn _ task renderedTask -> do + clearList rList + appendTasksToList rList (reverse (children task)) + setText fullText $ T.pack (text task) + + updateLeftList context + + runUi c defaultContext + +manoverRight context = do + item <- getSelected $ leftList context + case item of + Nothing -> return True + Just (itemNr, itemElem) -> do + moveInto (fst itemElem) context + return True + +manoverLeft context = do + moveOut context + return True + + +