packages feed

reheat (empty) → 0.1.4

raw patch · 8 files changed

+631/−0 lines, 8 filesdep +QuickCheckdep +basedep +directorysetup-changed

Dependencies added: QuickCheck, base, directory, text, vty, vty-ui

Files

+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ reheat.cabal view
@@ -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 <palipalo9@gmail.com>+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
+ src/Context.hs view
@@ -0,0 +1,202 @@+-----------------------------------------------------------------------------+--+-- Module      :  Context+-- Copyright   :  GPL v3+-- License     :  AllRightsReserved+--+-- Maintainer  :  Ingolf Wagner <palipalo9@gmail.com>+-- 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)
+ src/Main.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP, TemplateHaskell #-}+-----------------------------------------------------------------------------+--+-- Module      :  Main+-- Copyright   :  GPL v3+-- License     :  AllRightsReserved+--+-- Maintainer  :  Ingolf Wagner <palipalo9@gmail.com>+-- 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+
+ src/Task.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+--+-- Module      :  Task+-- Copyright   :  GPL v3+-- License     :  AllRightsReserved+--+-- Maintainer  :  Ingolf Wagner <palipalo9@gmail.com>+-- 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
+ src/Task/Data.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+--+-- Module      :  Task.Data+-- Copyright   :  GPL v3+-- License     :  AllRightsReserved+--+-- Maintainer  :  Ingolf Wagner <palipalo9@gmail.com>+-- 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)
+ src/Task/Modification.hs view
@@ -0,0 +1,105 @@+-----------------------------------------------------------------------------+--+-- Module      :  Task.Modification+-- Copyright   :  GPL v3+-- License     :  AllRightsReserved+--+-- Maintainer  :  Ingolf Wagner <palipalo9@gmail.com>+-- 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
+ src/View.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+--+-- Module      :  VtyView+-- Copyright   :  GPL v3+-- License     :  AllRightsReserved+--+-- Maintainer  :  Ingolf Wagner <palipalo9@gmail.com>+-- 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+++