diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -36,7 +36,9 @@ compose _ (Pred NoFilter) = const True compose _ (Pred (Tag s)) = tagPred s compose _ (Pred (Name s)) = grepPred s +compose _ (Pred (Description s)) = descPred s compose _ (Pred (Status s)) = statusPred s +compose _ (Pred (IdIs s)) = idPred s compose dt (Pred (StartDateIs d)) = datePred startDate dt d compose dt (Pred (EndDateIs d)) = datePred endDate dt d compose dt (Pred (DeadlineIs d)) = datePred deadline dt d @@ -90,20 +92,22 @@ -- | Build Config (with query etc) from Options buildQuery ∷ Options → Config -buildQuery (O qflags mflags oflags lflags) = Config onlyFirst colors srt limitP limitM command aprefix dformat composedFlags +buildQuery (O qflags mflags oflags lflags) = Config onlyFirst colors showIds srt limitP limitM command aprefix dformat noStatus setStatus composedFlags where composedFlags = parseQuery qflags (limitP,limitM) = parseLimits lflags onlyFirst = OnlyFirst ∈ oflags colors = Colors ∈ oflags + showIds = Ids ∈ oflags srtFlags = filter isSort oflags srt | null srtFlags = DoNotSort | otherwise = getSorting (last srtFlags) cmdFlags = filter isCommand mflags - command | null cmdFlags = Nothing - | otherwise = Just $ unExecute (last cmdFlags) + command | DotExport ∈ oflags = ShowAsDot + | null cmdFlags = JustShow + | otherwise = SystemCommand $ unExecute (last cmdFlags) prefixFlags = filter isPrefix mflags aprefix | null prefixFlags = Nothing @@ -113,6 +117,11 @@ dformat | null dflags = "%d" | otherwise = unDescribe $ last dflags + noStatus = not $ null $ filter isNoStatus mflags + newStatusFlags = filter isSetStatus mflags + setStatus | null newStatusFlags = Nothing + | otherwise = Just $ newStatus $ last newStatusFlags + isSort (Sort _) = True isSort _ = False isDescribe (Describe _) = True @@ -121,6 +130,10 @@ isCommand _ = False isPrefix (Prefix _) = True isPrefix _ = False + isNoStatus DoNotReadStatus = True + isNoStatus _ = False + isSetStatus (SetStatus _) = True + isSetStatus _ = False parseLimits ∷ [LimitFlag] → (Limit,Limit) parseLimits flags = (limitP,limitM) @@ -173,13 +186,19 @@ options currDate = [ Option "1" ["only-first"] (NoArg (OF OnlyFirst)) "show only first matching entry", Option "c" ["color"] (NoArg (OF Colors)) "show colored output", + Option "I" ["show-ids"] (NoArg (OF Ids)) "show IDs of todos", Option "A" ["prefix"] (OptArg mkPrefix "PREFIX") "use alternate parser: read only lines starting with PREFIX", + Option "" ["dot"] (NoArg (OF DotExport)) "output entries in DOT (graphviz) format", Option "D" ["describe"] (OptArg mkDescribe "FORMAT") "use FORMAT for descriptions", + Option "w" ["no-status"] (NoArg (MF DoNotReadStatus)) "do not read status field from TODOs", + Option "" ["set-status"] (ReqArg mkSetStatus "STRING") "force all TODOs status to be equal to STRING", Option "p" ["prune"] (ReqArg mkPrune "N") "limit tree height to N", Option "m" ["min-depth"] (ReqArg mkMin "N") "show first N levels of tree unconditionally", Option "t" ["tag"] (ReqArg mkTag "TAG") "find items marked with TAG", Option "g" ["grep"] (ReqArg mkName "PATTERN") "find items with PATTERN in name", + Option "G" ["description"] (ReqArg mkDescr "PATTERN") "find items with PATTERN in description", Option "s" ["status"] (ReqArg mkStatus "STRING") "find items with status equal to STRING", + Option "i" ["id"] (ReqArg mkIdQ "STRING") "find items with ID equal to STRING", Option "a" ["and"] (NoArg (QF AndCons)) "logical AND", Option "o" ["or"] (NoArg (QF OrCons)) "logical OR", Option "n" ["not"] (NoArg (QF NotCons)) "logical NOT", @@ -202,22 +221,31 @@ mkStatus ∷ String → CmdLineFlag mkStatus s = QF $ Status s +mkIdQ ∷ String → CmdLineFlag +mkIdQ s = QF $ IdIs s + +mkDescr ∷ String → CmdLineFlag +mkDescr s = QF $ Description s + forceEither ∷ (Show t) ⇒ Either t b → b forceEither (Right x) = x forceEither (Left x) = error $ show x mkStartDate ∷ DateTime → String → CmdLineFlag -mkStartDate dt s = QF $ StartDateIs $ forceEither $ parseDate dt s +mkStartDate dt s = QF $ StartDateIs $ forceEither $ parseDate emptyConfig dt s mkEndDate ∷ DateTime → String → CmdLineFlag -mkEndDate dt s = QF $ EndDateIs $ forceEither $ parseDate dt s +mkEndDate dt s = QF $ EndDateIs $ forceEither $ parseDate emptyConfig dt s mkDeadline ∷ DateTime → String → CmdLineFlag -mkDeadline dt s = QF $ DeadlineIs $ forceEither $ parseDate dt s +mkDeadline dt s = QF $ DeadlineIs $ forceEither $ parseDate emptyConfig dt s mkDescribe ∷ Maybe String → CmdLineFlag mkDescribe Nothing = MF $ Describe "%d" mkDescribe (Just f) = MF $ Describe f + +mkSetStatus ∷ String → CmdLineFlag +mkSetStatus st = MF $ SetStatus st mkPrune ∷ String → CmdLineFlag mkPrune s = LF $ Prune (read s) diff --git a/Color.hs b/Color.hs new file mode 100644 --- /dev/null +++ b/Color.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE UnicodeSyntax #-} +module Color where + +import qualified Data.Map as M +import Text.Printf +import Data.Word +import Data.Hash + +import Unicode +import Types + +data HSV = HSV { + colorHue ∷ Double, + colorSaturation ∷ Double, + colorValue ∷ Double } + deriving (Eq) + +instance Show HSV where + show (HSV h s v) = printf "\"%.3f %.3f %.3f\"" h s v + +(<#>) ∷ HSV → HSV → HSV +(HSV h1 s1 v1) <#> (HSV h2 s2 v2) = HSV ((h1+h2)/2) ((s1+s2)/2) ((v1+v2)/2) + +tagHues ∷ M.Map String Double +tagHues = M.fromList $ [ + ("BUG", 0.07), + ("NOTE", 0.25), + ("ERROR", 0.0), + ("TODO", 0.55)] + +hashAsDouble ∷ Hashable a ⇒ a → Double +hashAsDouble x = (fromIntegral $ asWord64 $ hash x) / (fromIntegral (maxBound :: Word64)) + +tagHue ∷ String → Double +tagHue tag = + case M.lookup tag tagHues of + Nothing → hashAsDouble tag + Just h → h + +statusSats ∷ M.Map String Double +statusSats = M.fromList $ [ + ("*", 1.0), + ("URGENT", 1.0), + ("+", 0.9), + ("W", 0.9), + ("?", 0.8), + ("Q", 0.8), + ("M", 0.7), + ("L", 0.6), + ("DONE", 0.5), + ("FIXED", 0.5), + ("WORKSFORME", 0.45), + (":", 0.4), + ("-", 0.3), + ("INVALID", 0.3), + ("o", 0.3), + ("x", 0.2)] + +statusSat ∷ String → Double +statusSat st = + case M.lookup st statusSats of + Nothing → 0.4* hashAsDouble st + Just s → s + +statusHues ∷ M.Map String Double +statusHues = M.fromList $ [ + ("*", 0.0), + ("URGENT", 0.0), + ("+", 0.16), + ("W", 0.08), + ("?", 0.7), + ("Q", 0.8), + ("M", 0.2), + ("L", 0.6), + ("DONE", 0.25), + ("FIXED", 0.25), + ("NOTE", 0.3), + ("WORKSFORME", 0.1), + ("INVALID", 0.45), + (":", 0.4), + ("-", 0.09), + ("o", 0.8), + ("x", 0.2)] + +statusHue ∷ String → Double +statusHue st = + case M.lookup st statusHues of + Nothing → hashAsDouble st + Just h → h + +getColor ∷ TodoItem → HSV +getColor item = HSV h s v + where + tags = itemTags item + n = length tags + st = itemStatus item + h = case n of + 0 → statusHue st + _ → (statusHue st + sum (map tagHue tags))/fromIntegral (n+1) + s = statusSat st + v = 0.8 + diff --git a/Dates.hs b/Dates.hs --- a/Dates.hs +++ b/Dates.hs @@ -54,7 +54,7 @@ minute = tMinute t + minute dt, second = tSecond t + second dt } -times ∷ Int → Parser t → Parser [t] +times ∷ Int → TParser t → TParser [t] times 0 _ = return [] times n p = do ts ← times (n-1) p @@ -63,27 +63,27 @@ Just t' → return (ts ++ [t']) Nothing → return ts -number ∷ Int → Int → Parser Int +number ∷ Int → Int → TParser Int number n m = do t ← read `fmap` (n `times` digit) if t > m then fail "number too large" else return t -pYear ∷ Parser Int +pYear ∷ TParser Int pYear = do y ← number 4 10000 if y < 2000 then return (y+2000) else return y -pMonth ∷ Parser Int +pMonth ∷ TParser Int pMonth = number 2 12 -pDay ∷ Parser Int +pDay ∷ TParser Int pDay = number 2 31 -euroNumDate ∷ Parser DateTime +euroNumDate ∷ TParser DateTime euroNumDate = do d ← pDay char '.' @@ -92,7 +92,7 @@ y ← pYear return $ date y m d -americanDate ∷ Parser DateTime +americanDate ∷ TParser DateTime americanDate = do y ← pYear char '/' @@ -101,21 +101,21 @@ d ← pDay return $ date y m d -euroNumDate' ∷ Int → Parser DateTime +euroNumDate' ∷ Int → TParser DateTime euroNumDate' year = do d ← pDay char '.' m ← pMonth return $ date year m d -americanDate' ∷ Int → Parser DateTime +americanDate' ∷ Int → TParser DateTime americanDate' year = do m ← pMonth char '/' d ← pDay return $ date year m d -strDate ∷ Parser DateTime +strDate ∷ TParser DateTime strDate = do d ← pDay space @@ -128,7 +128,7 @@ notFollowedBy $ char ':' return $ date y m d -strDate' ∷ Int → Parser DateTime +strDate' ∷ Int → TParser DateTime strDate' year = do d ← pDay space @@ -137,7 +137,7 @@ Nothing → fail $ "unknown month: "++ms Just m → return $ date year m d -time24 ∷ Parser Time +time24 ∷ TParser Time time24 = do h ← number 2 23 char ':' @@ -150,7 +150,7 @@ notFollowedBy letter return $ Time h m s -ampm ∷ Parser Int +ampm ∷ TParser Int ampm = do s ← many1 letter case map toUpper s of @@ -158,7 +158,7 @@ "PM" → return 12 _ → fail "AM/PM expected" -time12 ∷ Parser Time +time12 ∷ TParser Time time12 = do h ← number 2 12 char ':' @@ -171,7 +171,7 @@ hd ← ampm return $ Time (h+hd) m s -pAbsDate ∷ Int → Parser DateTime +pAbsDate ∷ Int → TParser DateTime pAbsDate year = do date ← choice $ map try $ map ($ year) $ [ const euroNumDate, @@ -214,23 +214,23 @@ addInterval dt (Months ms) = modifyDate addGregorianMonthsClip ms dt addInterval dt (Years ys) = modifyDate addGregorianYearsClip ys dt -maybePlural ∷ String → Parser String +maybePlural ∷ String → TParser String maybePlural str = do r ← string str optional $ char 's' return (capitalize r) -pDateInterval ∷ Parser DateIntervalType +pDateInterval ∷ TParser DateIntervalType pDateInterval = do s ← choice $ map maybePlural ["day", "week", "month", "year"] return $ read s -pRelDate ∷ DateTime → Parser DateTime +pRelDate ∷ DateTime → TParser DateTime pRelDate date = do offs ← (try futureDate) <|> (try passDate) <|> (try today) <|> (try tomorrow) <|> yesterday return $ date `addInterval` offs -futureDate ∷ Parser DateInterval +futureDate ∷ TParser DateInterval futureDate = do string "in " n ← many1 digit @@ -242,7 +242,7 @@ Month → return $ Months (read n) Year → return $ Years (read n) -passDate ∷ Parser DateInterval +passDate ∷ TParser DateInterval passDate = do n ← many1 digit char ' ' @@ -254,22 +254,22 @@ Month → return $ Months $ - (read n) Year → return $ Years $ - (read n) -today ∷ Parser DateInterval +today ∷ TParser DateInterval today = do string "today" return $ Days 0 -tomorrow ∷ Parser DateInterval +tomorrow ∷ TParser DateInterval tomorrow = do string "tomorrow" return $ Days 1 -yesterday ∷ Parser DateInterval +yesterday ∷ TParser DateInterval yesterday = do string "yesterday" return $ Days (-1) -pDate ∷ DateTime → Parser DateTime +pDate ∷ DateTime → TParser DateTime pDate date = (try $ pRelDate date) <|> (try $ pAbsDate $ year date) dateType ∷ String → DateType @@ -278,14 +278,14 @@ dateType "deadline" = Deadline dateType _ = error "unknown date type" -pSpecDate ∷ DateTime → Parser (DateType, DateTime) +pSpecDate ∷ DateTime → TParser (DateType, DateTime) pSpecDate date = do tp ← choice $ map string ["start","end","deadline"] string ": " dt ← pDate date return (dateType tp, dt) -pSpecDates ∷ DateTime → Parser [(DateType, DateTime)] +pSpecDates ∷ DateTime → TParser [(DateType, DateTime)] pSpecDates date = do char '(' pairs ← (pSpecDate date) `sepBy1` (string "; ") @@ -293,8 +293,9 @@ return pairs -- | Parse date/time -parseDate ∷ DateTime -- ^ Current date/time +parseDate ∷ Config + → DateTime -- ^ Current date/time → String -- ^ String to parse → Either ParseError DateTime -parseDate date s = parse (pDate date) "" s +parseDate conf date s = runParser (pDate date) conf "" s diff --git a/Dot.hs b/Dot.hs new file mode 100644 --- /dev/null +++ b/Dot.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE UnicodeSyntax, TypeSynonymInstances, FlexibleInstances #-} +module Dot + (showAsDot) + where + +import Data.List +import Data.Tree +import Text.Printf + +import Unicode +import Types +import Color +import Shapes + +data Dot = Dot { + dotVertices ∷ [TodoItem], + dotEdges ∷ [(TodoItem, TodoItem)] + } + +toDot ∷ Todo → Dot +toDot todo = Dot (getVertices todo) (getEdges todo) + +getVertices ∷ Todo → [TodoItem] +getVertices (Node item forest) = + [item] ⧺ concatMap getVertices forest + +getEdges ∷ Todo → [(TodoItem, TodoItem)] +getEdges (Node item forest) = + [(item, rootLabel child) | child ← forest] ⧺ concatMap getEdges forest + +instance Show Dot where + show (Dot vs es) = "digraph Todo {\n" + ⧺ unlines (map showDotNode vs) + ⧺ unlines (map showDotEdge es) + ⧺ "}\n" + +showD ∷ [Dot] → String +showD dots = "digraph Todo {\n" + ⧺ " rankdir = \"RL\";\n" + ⧺ " node [shape=\"box\", style=\"filled\"];\n" + ⧺ unlines (map showDotNode $ nub $ sort $ concatMap dotVertices dots) + ⧺ unlines (map showDotEdge $ nub $ sort $ concatMap dotEdges dots) + ⧺ "}\n" + +makeName ∷ TodoItem → String +makeName item = "\"" ⧺ makeId item ⧺ "\"" + +showDotNode ∷ TodoItem → String +showDotNode item = + printf " %s [label=\"%s\\n%s\\n%s\", fillcolor=%s, shape=\"%s\"];" (makeName item) (itemStatus item) (unwords $ itemTags item) (itemName item) (show $ getColor item) (show $ getShape item) + +showDotEdge ∷ (TodoItem, TodoItem) → String +showDotEdge (x,y) = printf " %s -> %s;" (makeName y) (makeName x) + +showAsDot ∷ [Todo] → String +showAsDot todos = showD (map toDot todos) + diff --git a/Shapes.hs b/Shapes.hs new file mode 100644 --- /dev/null +++ b/Shapes.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE UnicodeSyntax #-} +module Shapes where + +import qualified Data.Map as M + +import Unicode +import Types + +data Shape = + Box + | Ellipse + | Diamond + | DCircle + | Note + | Parallelogram + | Folder + deriving (Eq) + +instance Show Shape where + show Box = "box" + show Ellipse = "ellipse" + show Diamond = "diamond" + show DCircle = "doublecircle" + show Note = "note" + show Parallelogram = "parallelogram" + show Folder = "folder" + +shapes ∷ M.Map String Shape +shapes = M.fromList $ [ + ("o", Ellipse), + ("O", DCircle), + (":", Folder), + ("*", Diamond), + ("/", Parallelogram), + ("NOTE", Note) ] + +getShape ∷ TodoItem → Shape +getShape item = + case M.lookup (itemStatus item) shapes of + Nothing → Box + Just s → s + diff --git a/TodoLoader.hs b/TodoLoader.hs --- a/TodoLoader.hs +++ b/TodoLoader.hs @@ -44,16 +44,21 @@ normalizeList m todos = map (normalize m) todos readFile' ∷ FilePath → IO String -readFile' "-" = getContents +readFile' "-" = getContents readFile' file = readFile file -loadFile ∷ Maybe String → DateTime → FilePath → IO [TodoItem] -loadFile Nothing year path = do - text ← readFile' path - return $ parsePlain year path text -loadFile (Just p) year path = do - text ← readFile' path - return $ parseAlternate 2 p year path text +loadFile ∷ Config + → DateTime + → FilePath + → IO [TodoItem] +loadFile conf year path = + case prefix conf of + Nothing → do + text ← readFile' path + return $ parsePlain conf year path text + Just p → do + text ← readFile' path + return $ parseAlternate conf 2 p year path text (~-) ∷ TodoItem → ℤ → TodoItem i@(Item {itemLevel=n}) ~- k = i {itemLevel=n-k} @@ -90,10 +95,10 @@ in normalizeList m t -- | Load list of TODO trees from files -loadTodo ∷ Maybe String -- ^ Nothing for plain format, Just prefix for alternate format +loadTodo ∷ Config → DateTime -- ^ Current date/time → [FilePath] -- ^ List of files → IO [Todo] -loadTodo maybePrefix date paths = do - tss ← forM paths (loadFile maybePrefix date) +loadTodo conf date paths = do + tss ← forM paths (loadFile conf date) return $ stitchTodos (concat tss) diff --git a/TodoParser.hs b/TodoParser.hs --- a/TodoParser.hs +++ b/TodoParser.hs @@ -23,25 +23,25 @@ where p = dropWhile isSpace -pSpace ∷ Parser Char +pSpace ∷ TParser Char pSpace = oneOf " \t" -pSpace' ∷ Parser String +pSpace' ∷ TParser String pSpace' = do pSpace return " " -pSpaces ∷ Parser String +pSpaces ∷ TParser String pSpaces = many pSpace -pDeps ∷ Parser [String] +pDeps ∷ TParser [String] pDeps = do string "(" ws ← (many1 ⋄ noneOf ",)\n\r") `sepBy` (char ',') string ")" return $ map strip ws -pTags ∷ Parser [String] +pTags ∷ TParser [String] pTags = do ts ← between (char '[') (char ']') $ word `sepBy1` pSpace pSpaces @@ -49,11 +49,20 @@ where word = many1 (noneOf " \t\n\r]") -pItem ∷ DateTime → Parser TodoItem +pItem ∷ DateTime → TParser TodoItem pItem date = do pos ← getPosition s ← pSpaces - stat ← pWord + conf ← getState + stat ← if skipStatus conf + then case forcedStatus conf of + Just fs → return fs + Nothing → return "*" + else do + rs ← pWord + case forcedStatus conf of + Just fs → return fs + Nothing → return rs dates ← (try (pSpecDates date) <|> return []) tags ← (try pTags <|> return []) namew ← many1 pWord @@ -76,13 +85,13 @@ fileName = sourceName pos, lineNr = sourceLine pos } -pWord ∷ Parser String +pWord ∷ TParser String pWord = do w ← many1 (noneOf " \t\n\r") (try pSpace') <|> (return w) return w -pItems ∷ DateTime → Parser [TodoItem] +pItems ∷ DateTime → TParser [TodoItem] pItems date = do its ← many (pItem date) eof @@ -113,27 +122,29 @@ in (ns, unlines lns) -- | Read list of TODO items from plain format -parsePlain ∷ DateTime -- ^ Current date/time +parsePlain ∷ Config + → DateTime -- ^ Current date/time → SourceName -- ^ Source file name → String -- ^ String to parse → [TodoItem] -parsePlain date path text = - case parse (pItems date) path text of +parsePlain conf date path text = + case runParser (pItems date) conf path text of Right items → items Left e → error $ show e -- | Read list of TODO items from alternate format -parseAlternate ∷ Int -- ^ Number of lones after matching to include to item's description +parseAlternate ∷ Config + → Int -- ^ Number of lones after matching to include to item's description → String -- ^ Prefix to match → DateTime -- ^ Current date/time → SourceName -- ^ Source file name → String -- ^ String to parse → [TodoItem] -parseAlternate next prefix date path text = +parseAlternate conf next prefix date path text = let (ns, filtered) = filterJoin next prefix text renumber lst = zipWith renumber1 ns lst renumber1 n item = item {lineNr=n} - in case parse (pItems date) path filtered of + in case runParser (pItems date) conf path filtered of Right items → renumber items Left e → error $ show e diff --git a/TodoTree.hs b/TodoTree.hs --- a/TodoTree.hs +++ b/TodoTree.hs @@ -2,13 +2,14 @@ module TodoTree (delTag, pruneSelector, - tagPred, statusPred, grepPred, datePred, + tagPred, statusPred, grepPred, descPred, datePred, idPred, forT, mapT, printTodos) where import Prelude hiding (putStrLn,readFile,getContents,print) import IO +import System.Console.ANSI import Control.Monad import Control.Monad.Reader import qualified Data.Map as M @@ -18,6 +19,8 @@ import Data.Tree import Data.Maybe import Text.Regex.PCRE +import Data.Hash +import Numeric import Types import TodoLoader @@ -35,15 +38,25 @@ ByEndDate → show ∘ endDate ByDeadline → show ∘ deadline -showT ∷ SortingType → Int → Todo → [ConfigM] +showT ∷ SortingType → Int → Todo → [Formatter] showT s n (Node item todos) = - (configM <++> (replicate n ' ') <++> (configShow item)) : - (concatMap (showT s (n+2)) $ sortBy' s todos) + (startFormat <++> showId item <++> replicate n ' ' <++> configShow item) : + (concatMap (showT s (n+2)) $ sortBy' s todos) + where + showId :: TodoItem → Formatter + showId item = do + s ← asks outIds + c ← asks outColors + if s + then if c + then return [OutSetColor Yellow, OutString $ makeId item ++ " ", ResetAll] + else return [OutString $ makeId item ++ " "] + else return [OutString ""] -unlines'' ∷ [ConfigM] → ConfigM +unlines'' ∷ [Formatter] → Formatter unlines'' lst = concat `fmap` (sequence $ intersperse newLine lst) -showTodo ∷ Todo → ConfigM +showTodo ∷ Todo → Formatter showTodo t = do conf ← ask let f = case outOnlyFirst conf of @@ -51,7 +64,7 @@ True → head f $ showT (sorting conf) 0 t -showTodos ∷ [Todo] → ConfigM +showTodos ∷ [Todo] → Formatter showTodos lst = do conf ← ask let f = case outOnlyFirst conf of @@ -101,6 +114,12 @@ grepPred ∷ String → TodoItem → 𝔹 grepPred pattern = \item → itemName item =~ pattern + +descPred ∷ String → TodoItem → 𝔹 +descPred pattern = \item → itemDescr item =~ pattern + +idPred :: String → TodoItem → 𝔹 +idPred hash = \item → makeId item == hash isLT ∷ (Ord t) ⇒ Maybe t → t → 𝔹 isLT Nothing _ = False diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -5,6 +5,7 @@ import Prelude hiding (putStr, putStrLn,readFile,getContents,print) import IO import System.Console.ANSI +import Data.Hash import Control.Monad.Reader import Data.Function @@ -15,6 +16,7 @@ import Data.List import qualified Data.Map as M import Text.ParserCombinators.Parsec +import Numeric import Unicode @@ -85,6 +87,18 @@ lineNr ∷ Line} deriving (Eq,Data,Typeable) +instance Hashable TodoItem where + hash item = foldl1 combine $ map ($ item) [hash ∘ itemName, hash ∘ itemDescr, + hash ∘ itemTags, hash ∘ itemStatus] + +makeId :: TodoItem → String +makeId item = + let s = showHex (asWord64 $ hash item) "" + l = length s + in if l < 16 + then replicate (16-l) '0' ++ s + else s + type Todo = Tree TodoItem type TodoMap = M.Map String Todo @@ -108,7 +122,9 @@ data QueryFlag = Tag String | Name {unName ∷ String} + | IdIs String | Status String + | Description String | StartDateIs DateTime | EndDateIs DateTime | DeadlineIs DateTime @@ -125,10 +141,14 @@ data ModeFlag = Execute {unExecute ∷ String} | Prefix {unPrefix ∷ String} | Describe {unDescribe ∷ String} + | DoNotReadStatus + | SetStatus {newStatus ∷ String} deriving (Eq,Ord,Show) data OutFlag = OnlyFirst | Colors + | Ids + | DotExport | Sort {getSorting ∷ SortingType} deriving (Eq,Ord,Show) @@ -166,27 +186,27 @@ | ResetAll deriving (Show) -type ConfigM = Reader Config [OutItem] +type Formatter = Reader Config [OutItem] -newtype IOList = IOL [ConfigM] +newtype IOList = IOL [Formatter] -configM ∷ ConfigM -configM = return [] +startFormat ∷ Formatter +startFormat = return [] -outString ∷ String → ConfigM +outString ∷ String → Formatter outString s = return [OutString s] -newLine ∷ ConfigM +newLine ∷ Formatter newLine = outString "\n" class ConfigAdd a where - (<++>) ∷ ConfigM → a → ConfigM + (<++>) ∷ Formatter → a → Formatter -instance ConfigAdd ConfigM where +instance ConfigAdd Formatter where (<++>) = liftM2 (⧺) instance ConfigAdd String where - cm <++> s = cm <++> ((return [OutString s]) ∷ ConfigM) + cm <++> s = cm <++> ((return [OutString s]) ∷ Formatter) setBold ∷ IO () setBold = setSGR [SetConsoleIntensity BoldIntensity] @@ -203,22 +223,22 @@ outItem SetBold = setBold outItem ResetAll = reset -runConfigM ∷ Config → ConfigM → IO () -runConfigM conf cm = +runFormatter ∷ Config → Formatter → IO () +runFormatter conf cm = let lst = runReader cm conf in mapM_ outItem lst class ConfigShow s where - configShow ∷ s → ConfigM + configShow ∷ s → Formatter instance ConfigShow String where configShow s = return [OutString s] -instance ConfigShow ConfigM where +instance ConfigShow Formatter where configShow = id showIO ∷ (ConfigShow a) ⇒ Config → a → IO () -showIO conf = (runConfigM conf) ∘ configShow +showIO conf = (runFormatter conf) ∘ configShow instance (Ord a) ⇒ Ord (Tree a) where compare = compare `on` rootLabel @@ -227,18 +247,41 @@ data Options = O [QueryFlag] [ModeFlag] [OutFlag] [LimitFlag] | Help +data TodoCommand = + JustShow + | ShowAsDot + | SystemCommand String + deriving (Eq, Show) + data Config = Config { outOnlyFirst ∷ 𝔹, outColors ∷ 𝔹, + outIds :: 𝔹, sorting ∷ SortingType, pruneL ∷ Limit, minL ∷ Limit, - commandToRun ∷ Maybe String, + commandToRun ∷ TodoCommand, prefix ∷ Maybe String, descrFormat ∷ String, - query ∷ Composed} + skipStatus ∷ 𝔹, + forcedStatus ∷ Maybe String, + query ∷ Composed } deriving (Eq,Show) +emptyConfig = Config { + outOnlyFirst = False, + outColors = False, + outIds = False, + sorting = DoNotSort, + pruneL = Unlimited, + minL = Unlimited, + commandToRun = JustShow, + prefix = Nothing, + descrFormat = "%d", + skipStatus = False, + forcedStatus = Nothing, + query = Empty } + data Composed = Pred QueryFlag | And Composed Composed | Or Composed Composed @@ -271,7 +314,7 @@ then "" else "[" ⧺ (unwords ts) ⧺ "] " -bold ∷ String → ConfigM +bold ∷ String → Formatter bold s = do col ← asks outColors if col @@ -290,7 +333,7 @@ (["*"], Red), (["?"], Blue)] -colorStatus ∷ String → ConfigM +colorStatus ∷ String → Formatter colorStatus st = case lookupC st statusColors of Nothing → return [OutString st] @@ -301,7 +344,7 @@ else return [OutString st] instance ConfigShow TodoItem where - configShow item = configM <++> colorStatus s <++> " " <++> dates <++> tags <++> bold name <++> (if null descr then "" else " "⧺descr) + configShow item = startFormat <++> colorStatus s <++> " " <++> dates <++> tags <++> bold name <++> (if null descr then "" else " "⧺descr) where n = itemLevel item name = itemName item @@ -325,4 +368,6 @@ then c3 else c2 else c1 + +type TParser a = GenParser Char Config a diff --git a/todos.cabal b/todos.cabal --- a/todos.cabal +++ b/todos.cabal @@ -1,5 +1,5 @@ Name: todos -Version: 0.1 +Version: 0.2 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE @@ -16,12 +16,12 @@ Extra-source-files: CmdLine.hs CommandParser.hs Config.hs ConstrSet.hs Dates.hs IO.hs Makefile README README.ru Setup.hs test.hs test.txt TODO TodoLoader.hs TodoParser.hs todos.hs TodoTree.hs Types.hs - Unicode.hs + Unicode.hs Dot.hs Color.hs Shapes.hs Executable todos Build-Depends: base >= 3 && <= 5, haskell98, utf8-string, containers, parsec >= 2 && < 3, syb, mtl, ansi-terminal, Glob, time, regex-pcre, directory, filepath, - process + process, data-hash Main-Is: todos.hs Source-repository head diff --git a/todos.hs b/todos.hs --- a/todos.hs +++ b/todos.hs @@ -20,6 +20,7 @@ import Config import CmdLine import Dates (getCurrentDateTime) +import Dot main ∷ IO () main = do @@ -33,15 +34,17 @@ do let options = O qflags mflags oflags lflags q = buildQuery options - todos ← loadTodo (prefix q) currDate files + todos ← loadTodo q currDate files let todos' = delTag "-" todos queried = transformList q (composeAll currDate) todos' format item = item {itemDescr = printfItem (descrFormat q) item} case commandToRun q of - Nothing → do + JustShow → do printTodos q (mapT format queried) putStrLn "" - Just cmd → do + ShowAsDot → + putStrLn $ showAsDot (mapT format queried) + SystemCommand cmd → do forT selected (\item → system $ printfItem cmd (format item)) return () where selected | outOnlyFirst q = [Node (rootLabel $ head queried) []]