diff --git a/main/Main.hs b/main/Main.hs new file mode 100644 --- /dev/null +++ b/main/Main.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : GPL v3 +-- License : AllRightsReserved +-- +-- Maintainer : Ingolf Wagner +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Main ( + main +) where + +import qualified View + +main = View.main diff --git a/reheat.cabal b/reheat.cabal --- a/reheat.cabal +++ b/reheat.cabal @@ -1,5 +1,5 @@ name: reheat -version: 0.1.4 +version: 0.1.5 cabal-version: >=1.8 build-type: Simple license: GPL @@ -11,7 +11,7 @@ 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 +category: Tools author: Ingolf Wagner data-dir: "" @@ -19,19 +19,25 @@ type: git location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ +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, + build-depends: base >=4 && <5, 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 + hs-source-dirs: src main + other-modules: Context Main View Task Task.Modification + Task.Data test-suite test-reheat - build-depends: QuickCheck -any, base >= 2 && < 4, directory -any, + build-depends: QuickCheck -any, base >=4 && <5, 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 + hs-source-dirs: src test + other-modules: Tests Context Main View Task Task.Modification + Task.Data diff --git a/src/Context.hs b/src/Context.hs --- a/src/Context.hs +++ b/src/Context.hs @@ -91,14 +91,18 @@ 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 +swapTasks' :: Int -> Int -> Context -> IO () +swapTasks' a b context = do + modifyIORef (tasks context) $ swapTasks a b + updateLeftList context + + -- | clear list and set tasks to that value setList :: [Task] -> TaskViewList -> IO () setList tasks list = do @@ -122,6 +126,11 @@ (insertIntoList list t f 0) + + +{- write and read from and to file here -} + + -- | write tasks to file writeToFile :: FilePath -> IORef Tasks -> IO () writeToFile fileName wRef = do @@ -141,6 +150,9 @@ return $ readTasks $ read ls +{- render Task stuff here -} + + -- | create a rendarble Task newTask :: Task -> IO (Widget Task) newTask t = do @@ -162,7 +174,7 @@ --- | bread crumbs here +{- bread crumbs here -} updateBreadCrumbs :: Context -> IO () diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# 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/Data.hs b/src/Task/Data.hs --- a/src/Task/Data.hs +++ b/src/Task/Data.hs @@ -20,8 +20,8 @@ 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 Tasks = Tasks { actual :: [Task], history :: [FTask] } deriving (Eq,Show) +data FTask = FTask { focused :: Task, prev :: [Task], next :: [Task] } deriving (Eq,Show) -- | data types for saveing -- don't use getter and setter names, to not interfere with the diff --git a/src/Task/Modification.hs b/src/Task/Modification.hs --- a/src/Task/Modification.hs +++ b/src/Task/Modification.hs @@ -30,18 +30,22 @@ | a < 0 = tasks | b < 0 = tasks | a == b = tasks - | a > length (actual tasks) = tasks - | b > length (actual tasks) = 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) + Tasks (map (\l -> + if l == x then + y + else if l == y then + x + else + l) t) + (history tasks) -- | go into the children of some tasks diff --git a/src/View.hs b/src/View.hs --- a/src/View.hs +++ b/src/View.hs @@ -52,12 +52,12 @@ addToFocusGroup fg lList editor <- multiLineEditWidget - eFg <- newFocusGroup + eFg <- newFocusGroup addToFocusGroup eFg editor - d <- plainText "Header" <--> return editor >>= withBoxSpacing 1 + d <- plainText "Header" <--> return editor >>= withBoxSpacing 1 c <- newCollection - switchToMain <- addToCollection c box fg + switchToMain <- addToCollection c box fg switchToDialog <- addToCollection c d eFg editor `onKeyPressed` \this key mod -> case key of @@ -83,28 +83,16 @@ return False lList `onKeyPressed` \this key whatever -> case key of - KASCII 'q' -> do - writeToFile filePath (tasks context) - exitSuccess - return True + KASCII 'q' -> closeApp filePath context + KEsc -> closeApp filePath context 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 + KASCII 'j' -> manoverDown context + KASCII 'J' -> manoverSwap Down context + KASCII 'k' -> manoverUp context + KASCII 'K' -> manoverSwap Up context + KASCII 'd' -> deleteTask context KRight -> manoverRight context KASCII 'l' -> manoverRight context KASCII 'o' -> manoverLeft context @@ -124,6 +112,38 @@ runUi c defaultContext + +deleteTask context = 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 + +closeApp filePath context = do + writeToFile filePath (tasks context) + exitSuccess + return True + +data Direction = Up | Down + +manoverSwap direction context = do + item <- getSelected $ leftList context + case item of + Nothing -> return True + Just (itemNr, itemElem) -> do + swapTasks' itemNr (other direction itemNr) context + setSelected (leftList context) (other direction itemNr) + return True + where + other Up a = a - 1 + other Down a = a + 1 + + + manoverRight context = do item <- getSelected $ leftList context case item of @@ -136,5 +156,10 @@ moveOut context return True - +manoverDown context = do + scrollDown $ leftList context + return True +manoverUp context = do + scrollUp $ leftList context + return True diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : GPL v3 +-- License : AllRightsReserved +-- +-- Maintainer : Ingolf Wagner +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Main ( + main +) where + +import qualified Tests + +main = Tests.testMain diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +----------------------------------------------------------------------------- +-- +-- Module : Tests +-- Copyright : GPL +-- License : GPL Nothing +-- +-- Maintainer : Ingolf Wagner +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Tests where + +import Control.Monad (unless) +import Data.List (stripPrefix) +import System.Exit (exitFailure) +import Test.QuickCheck.All (quickCheckAll) + +import Task + +-- Entry point for unit tests. +testMain = do + allPass <- $quickCheckAll -- Run QuickCheck on all prop_ functions + unless allPass exitFailure + +t1 = Comment "t1" [] +t2 = Comment "t2" [] +t3 = Comment "t3" [] +t4 = Comment "t4" [] +t5 = Comment "t5" [] +t6 = Comment "t6" [] + +tasks1 = Tasks [t1,t2,t3,t4,t5,t6] [] +tasks2 = Tasks [t1,t3,t2,t4,t5,t6] [] +tasks3 = Tasks [t3,t2,t1,t4,t5,t6] [] + + +prop_testSwap1 :: Int -> Int -> Bool +prop_testSwap1 a b = (swapTasks a b (swapTasks a b tasks1)) == tasks1 + +prop_testSwap2 :: Int -> Int -> Bool +prop_testSwap2 a b = (swapTasks a b tasks1) == (swapTasks b a tasks1) + + +prop_testSwap3 :: Bool +prop_testSwap3 = (swapTasks 1 2 tasks1) == tasks2 + +prop_testSwap4 :: Bool +prop_testSwap4 = (swapTasks 1 2 tasks2) == tasks1 + +prop_testSwap5 :: Bool +prop_testSwap5 = (swapTasks 0 2 tasks1) == tasks3