todos 0.1 → 0.2
raw patch · 11 files changed
+405/−92 lines, 11 filesdep +data-hash
Dependencies added: data-hash
Files
- CmdLine.hs +34/−6
- Color.hs +102/−0
- Dates.hs +29/−28
- Dot.hs +57/−0
- Shapes.hs +42/−0
- TodoLoader.hs +16/−11
- TodoParser.hs +26/−15
- TodoTree.hs +26/−7
- Types.hs +64/−19
- todos.cabal +3/−3
- todos.hs +6/−3
CmdLine.hs view
@@ -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)
+ Color.hs view
@@ -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+
Dates.hs view
@@ -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
+ Dot.hs view
@@ -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)+
+ Shapes.hs view
@@ -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+
TodoLoader.hs view
@@ -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)
TodoParser.hs view
@@ -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
TodoTree.hs view
@@ -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
Types.hs view
@@ -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
todos.cabal view
@@ -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
todos.hs view
@@ -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) []]