packages feed

todos 0.2 → 0.3

raw patch · 42 files changed

+2440/−1851 lines, 42 filesdep +dyre

Dependencies added: dyre

Files

− CmdLine.hs 
@@ -1,260 +0,0 @@-{-# LANGUAGE UnicodeSyntax, PatternGuards #-}---- | Module for parsing command line options and build queries-module CmdLine-  (parseCmdLine,-   glob,-   buildQuery,-   composeAll,-   usage)-  where--import Prelude hiding (putStrLn,readFile,getContents,print)-import IO-import Codec.Binary.UTF8.String-import System (getArgs)-import System.Console.GetOpt-import System.FilePath.Glob-import Data.Maybe-import Data.List (sort)-import Control.Monad.Reader--import Unicode-import Types-import TodoTree-import Dates (parseDate)---- | Default limit for tree height-pruneByDefault ∷  Limit-pruneByDefault = Limit 20---- | Compose predicate from Composed-compose ∷ DateTime       -- ^ Current date/time-        → Composed       -- ^ Composed query-        → (TodoItem → 𝔹)-compose _ Empty             = const True-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-compose dt (Not p)           = not ∘ (compose dt p)-compose dt (And (Pred NoFilter) p) = compose dt p-compose dt (And p (Pred NoFilter)) = compose dt p-compose dt (And p1 p2)      = \item → (compose dt p1 item) ∧ (compose dt p2 item)-compose dt (Or (Pred NoFilter) p) = compose dt p-compose dt (Or p (Pred NoFilter)) = compose dt p-compose dt (Or p1 p2)       = \item → (compose dt p1 item) ∨ (compose dt p2 item)-compose _ x = error $ show x--concatMapM ∷ (Monad m) ⇒ m (t → [t]) → m ([t] → [t])-concatMapM = liftM concatMap---- | Make a list transformer-composeAll ∷ DateTime → ListTransformer-composeAll date = do-  pred ← asks ((compose date) ∘ query)-  concatMapM (pruneSelector pred)--appendC ∷ Composed → QueryFlag → Composed-appendC (Not (Pred NoFilter))   f = Not (Pred f)-appendC Empty OrCons              = (Pred NoFilter) `Or` (Pred NoFilter)-appendC Empty AndCons             = (Pred NoFilter) `And` (Pred NoFilter)-appendC Empty NotCons             = Not (Pred NoFilter)-appendC Empty f                   = Pred f-appendC c NoFilter                = c-appendC c AndCons                 = c `And` (Pred NoFilter)-appendC c OrCons                  = c `Or`  (Pred NoFilter)-appendC c NotCons                 = c `And` (Pred NoFilter)-appendC (And c (Pred NoFilter)) f = c `And` (Pred f) -appendC (And (Pred NoFilter) c) f = c `And` (Pred f) -appendC c@(And _ _)             f = c `And` (Pred f)-appendC (Or c (Pred NoFilter))  f = c `Or`  (Pred f)-appendC (Or (Pred NoFilter) c)  f = c `Or`  (Pred f)-appendC c@(Or _ _)              f = c `Or`  (Pred f)-appendC c@(Pred _)              f = c `And` (Pred f)-appendC c                       f = c `And` (Pred f)--appendF (O q m o l) (QF f) = O (f:q) m o l-appendF (O q m o l) (MF f) = O q (f:m) o l-appendF (O q m o l) (OF f) = O q m (f:o) l-appendF (O q m o l) (LF f) = O q m o (f:l)-appendF _ HelpF = Help--parseFlags ∷ [CmdLineFlag] → Options-parseFlags lst | HelpF ∈ lst = Help-parseFlags [] = O [] [] [] []-parseFlags (f:fs) = (parseFlags fs) `appendF` f---- | Build Config (with query etc) from Options-buildQuery ∷ Options → Config-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 | DotExport ∈ oflags = ShowAsDot-            | null cmdFlags      = JustShow-            | otherwise          = SystemCommand $ unExecute (last cmdFlags)--    prefixFlags = filter isPrefix mflags-    aprefix | null prefixFlags = Nothing-            | otherwise        = Just $ unPrefix (last prefixFlags)--    dflags = filter isDescribe mflags-    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-    isDescribe _            = False-    isCommand (Execute _) = True-    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)-  where-    pruneFlags = filter isPrune flags-    minFlags   = filter isMin flags--    limitP'       = foldl min Unlimited $ map (Limit ∘ unPrune) pruneFlags-    limitP | Unlimited ← limitP' = pruneByDefault-           | otherwise           = limitP'--    limitM'       = foldl max (Limit 0) $ map (Limit ∘ unMin) minFlags-    limitM | Unlimited ← limitM' = pruneByDefault-           | otherwise           = limitM'--    isPrune (Prune _) = True-    isPrune _         = False--    isMin   (Start x) = True-    isMin   _         = False--parseQuery ∷ [QueryFlag] → Composed-parseQuery flags = foldl appendC Empty flags---- | Parse command line-parseCmdLine ∷ DateTime              -- ^ Current date/time-             → [String]              -- ^ Command line args-             → (Options, [FilePath]) -- ^ (Options, list of files)-parseCmdLine currDate args = -  case getOpt Permute (options currDate) (map decodeString args) of-        (flags, [],      [])     → (parseFlags flags, ["TODO"])-        (flags, nonOpts, [])     → (parseFlags flags, nonOpts)-        (_,     _,       msgs)   → error $ concat msgs ⧺ usage--isPattern s = ('*' ∈ s) || ('?' ∈ s)--glob ∷ [FilePath] → IO [FilePath]-glob list = do-  let patterns = filter isPattern list-      files = filter (not ∘ isPattern) list-  (matches, _) ← globDir (map compile patterns) "." -  return $ sort $ files ⧺ concat matches--usage ∷  String-usage = usageInfo header (options undefined)-  where -    header = "Usage: todos [OPTION...] [INPUT FILES]"--options ∷ DateTime → [OptDescr CmdLineFlag]-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",-    Option ""  ["sort"]       (ReqArg mkSort "FIELD")                "specify sorting",-    Option "e" ["exec"]       (OptArg mkExecute "COMMAND")           "run COMMAND on each matching entry",-    Option "S" ["start-date"] (ReqArg (mkStartDate currDate) "DATE") "find items with start date bounded with DATE",-    Option "E" ["end-date"]   (ReqArg (mkEndDate currDate) "DATE")   "find items with end date bounded with DATE",-    Option "d" ["deadline"]   (ReqArg (mkDeadline currDate) "DATE")  "find items with deadline bounded with DATE",-    Option "h" ["help"]       (NoArg HelpF)                          "display this help"-  ]--mkSort s = OF $ Sort $ readSort s--mkTag ∷  String → CmdLineFlag-mkTag t = QF $ Tag t--mkName ∷  String → CmdLineFlag-mkName n = QF $ Name n--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 emptyConfig dt s--mkEndDate ∷  DateTime → String → CmdLineFlag-mkEndDate dt s = QF $ EndDateIs $ forceEither $ parseDate emptyConfig dt s--mkDeadline ∷  DateTime → String → CmdLineFlag-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)--mkMin ∷  String → CmdLineFlag-mkMin s = LF $ Start (read s)--mkPrefix ∷  Maybe [Char] → CmdLineFlag-mkPrefix = MF ∘ Prefix ∘ fromMaybe "TODO:"--mkExecute ∷  Maybe [Char] → CmdLineFlag-mkExecute = MF ∘ Execute ∘ fromMaybe "echo %n %d"
− Color.hs 
@@ -1,102 +0,0 @@-{-# 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-
− CommandParser.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}--module CommandParser where--import Unicode-import Types---- | Format item info-printfItem ∷ String      -- ^ Format string-           → TodoItem -           → String-printfItem pattern item = printf pattern-  where-    printf "" = ""-    printf [x] = [x]-    printf ('%':c:xs) = (itemPart c) ⧺ printf xs-    printf (x:xs) = x:printf xs--    itemPart 'L' = show $ itemLevel item-    itemPart 'n' = itemName item-    itemPart 't' = unwords $ itemTags item-    itemPart 's' = itemStatus item-    itemPart 'd' = itemDescr item-    itemPart 'f' = fileName item-    itemPart 'l' = show $ lineNr item-    itemPart x   = [x]
− Config.hs 
@@ -1,88 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}---- | Module for parsing config files-module Config-  (readConfig)-  where--import Prelude hiding (putStrLn,readFile,getContents,print)-import IO-import System.Environment-import System.FilePath -import System.Directory (doesFileExist)-import Data.Maybe-import Data.Either-import Text.ParserCombinators.Parsec--import Unicode-import Types--word ∷ Parser String-word = choice $ map try [quotedOption, simpleOption, quoted, simpleWord]--simpleWord = many1 $ noneOf " \t\r\n=\"'"--quotedOption = (try quotedLongOption) <|> quotedShortOption--quotedLongOption ∷ Parser String-quotedLongOption = do-  string "--"-  o ← simpleWord-  char '='-  v ← quoted-  return ("--" ⧺ o ⧺ "=" ⧺ v)--quotedShortOption ∷ Parser String-quotedShortOption = do-  string "-"-  o ← simpleWord-  v ← quoted-  return ("-" ⧺ o ⧺ v)--simpleOption = do-  o ← simpleWord-  optional $ char '='-  v ← simpleWord-  return (o ⧺ "=" ⧺ v)--quoted = quoted1 <|> quoted2--quoted1 = do-  char '\''-  s ← many1 $ noneOf "'"-  char '\''-  return s--quoted2 = do-  char '"'-  s ← many1 $ noneOf "\""-  char '"'-  return s--pConfig ∷ Parser [String]-pConfig = word `sepBy` space--parseConfig ∷ String → [String]-parseConfig str = -  case parse pConfig "config file" str of-    Right lst → lst-    Left err → error $ show err--readFile' ∷ FilePath → IO [String]-readFile' path = -  do b ← doesFileExist path-     if not b-       then return []-       else do-              str ← readFile path-              return $ parseConfig (unwords $ lines str)---- | Read list of options from config files-readConfig ∷ IO [String]-readConfig = do-  home ← getEnv "HOME"-  let homepath = home </> ".config" </> "todos"-  homecfg ← readFile' homepath-  localcfg ← readFile' ".todos.conf"-  return $ homecfg ⧺ localcfg-
− ConstrSet.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE UnicodeSyntax, DeriveDataTypeable, NoMonomorphismRestriction #-}--module ConstrSet -  (CSet,-   empty,-   fromList, toList,-   insert, append,-   elemC,-   selectByConstrOf,-   selectByConstrOf'-  ) where--import Data.Generics-import Data.Function (on)-import Data.List (nubBy)-import Data.Maybe (fromMaybe)--teq = (==) `on` toConstr--data (Data a) ⇒ CSet a = CSet [a]--empty = CSet []--fromList lst = CSet $ nubBy teq lst-toList (CSet lst) = lst--insert item (CSet []) = CSet [item]-insert item (CSet lst) = CSet $ nubBy teq (item:lst)--selectByConstrOf (CSet []) _ = Nothing-selectByConstrOf (CSet (x:xs)) y | x `teq` y = Just x-                                 | otherwise = selectByConstrOf (CSet xs) y--selectByConstrOf' def cset x = fromMaybe def $ selectByConstrOf cset x--elemC _ (CSet []) = False-elemC x (CSet (y:ys)) | x `teq` y = True-                      | otherwise = elemC x (CSet ys)--append (CSet xs) (CSet ys) = CSet $ nubBy teq (xs++ys)
− Dates.hs 
@@ -1,301 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}--- | Operations with dates-module Dates-  (parseDate, getCurrentDateTime,-   pSpecDates)-  where--import Data.Char (toUpper)-import Data.Function (on)-import Data.List-import Data.Time.Calendar-import Data.Time.Clock-import Data.Time.LocalTime-import Text.ParserCombinators.Parsec--import Types-import Unicode--getCurrentDateTime ∷  IO DateTime-getCurrentDateTime = do-  zt ← getZonedTime-  let lt = zonedTimeToLocalTime zt-      ld = localDay lt-      ltod = localTimeOfDay lt-      (y,m,d) = toGregorian ld-      h = todHour ltod-      min = todMin ltod-      s = round $ todSec ltod-  return $ DateTime (fromIntegral y) m d h min s--uppercase ∷ String → String-uppercase = map toUpper--isPrefixOfI ∷  String → String → Bool-p `isPrefixOfI` s = (uppercase p) `isPrefixOf` (uppercase s)--lookupS ∷ String → [(String,a)] → Maybe a-lookupS _ [] = Nothing-lookupS k ((k',v):other) | k `isPrefixOfI` k' = Just v-                         | otherwise          = lookupS k other--monthsN ∷ [(String,Int)]-monthsN = zip months [1..]--lookupMonth ∷ String → Maybe Int-lookupMonth n = lookupS n monthsN--date ∷  Int → Int → Int → DateTime-date y m d = DateTime y m d 0 0 0--addTime ∷  DateTime → Time → DateTime-addTime dt t = dt {-                 hour = tHour t + hour dt,-                 minute = tMinute t + minute dt,-                 second = tSecond t + second dt }--times ∷ Int → TParser t → TParser [t]-times 0 _ = return []-times n p = do-  ts ← times (n-1) p-  t ← optionMaybe p-  case t of-    Just t' → return (ts ++ [t'])-    Nothing → return ts-                               -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 ∷ TParser Int-pYear = do-  y ← number 4 10000-  if y < 2000-    then return (y+2000)-    else return y--pMonth ∷ TParser Int-pMonth = number 2 12--pDay ∷ TParser Int-pDay = number 2 31--euroNumDate ∷ TParser DateTime-euroNumDate = do-  d ← pDay-  char '.'-  m ← pMonth-  char '.'-  y ← pYear-  return $ date y m d--americanDate ∷ TParser DateTime-americanDate = do-  y ← pYear-  char '/'-  m ← pMonth-  char '/'-  d ← pDay-  return $ date y m d--euroNumDate' ∷ Int → TParser DateTime-euroNumDate' year = do-  d ← pDay-  char '.'-  m ← pMonth-  return $ date year m d--americanDate' ∷ Int → TParser DateTime-americanDate' year = do-  m ← pMonth-  char '/'-  d ← pDay-  return $ date year m d--strDate ∷ TParser DateTime-strDate = do-  d ← pDay-  space-  ms ← many1 letter-  case lookupMonth ms of-    Nothing → fail $ "unknown month: "++ms-    Just m  → do-      space-      y ← pYear-      notFollowedBy $ char ':'-      return $ date y m d--strDate' ∷ Int → TParser DateTime-strDate' year = do-  d ← pDay-  space-  ms ← many1 letter-  case lookupMonth ms of-    Nothing → fail $ "unknown month: "++ms-    Just m  → return $ date year m d--time24 ∷ TParser Time-time24 = do-  h ← number 2 23-  char ':'-  m ← number 2 59-  x ← optionMaybe $ char ':'-  case x of-    Nothing → return $ Time h m 0-    Just _ → do-      s ← number 2 59-      notFollowedBy letter-      return $ Time h m s--ampm ∷ TParser Int-ampm = do-  s ← many1 letter-  case map toUpper s of-    "AM" → return 0-    "PM" → return 12-    _ → fail "AM/PM expected"--time12 ∷ TParser Time-time12 = do-  h ← number 2 12-  char ':'-  m ← number 2 59-  x ← optionMaybe $ char ':'-  s ← case x of-            Nothing → return 0-            Just s' → number 2 59-  optional space-  hd ← ampm-  return $ Time (h+hd) m s--pAbsDate ∷ Int → TParser DateTime-pAbsDate year = do-  date ← choice $ map try $ map ($ year) $ [-                              const euroNumDate,-                              const americanDate,-                              const strDate,-                              strDate',-                              euroNumDate',-                              americanDate']-  optional $ char ','-  s ← optionMaybe space-  case s of-    Nothing → return date-    Just _ → do-      t ← choice $ map try [time12,time24]-      return $ date `addTime` t--data DateIntervalType = Day | Week | Month | Year-  deriving (Eq,Show,Read)--data DateInterval = Days ℤ-                  | Weeks ℤ-                  | Months ℤ-                  | Years ℤ-  deriving (Eq,Show)--convertTo ∷  DateTime → Day-convertTo dt = fromGregorian (fromIntegral $ year dt) (month dt) (day dt)--convertFrom ∷  Day → DateTime-convertFrom dt = -  let (y,m,d) = toGregorian dt-  in  date (fromIntegral y) m d--modifyDate ∷  (t → Day → Day) → t → DateTime → DateTime-modifyDate fn x dt = convertFrom $ fn x $ convertTo dt--addInterval ∷  DateTime → DateInterval → DateTime-addInterval dt (Days ds) = modifyDate addDays ds dt-addInterval dt (Weeks ws) = modifyDate addDays (ws*7) dt-addInterval dt (Months ms) = modifyDate addGregorianMonthsClip ms dt-addInterval dt (Years ys) = modifyDate addGregorianYearsClip ys dt--maybePlural ∷ String → TParser String-maybePlural str = do-  r ← string str-  optional $ char 's'-  return (capitalize r)--pDateInterval ∷ TParser DateIntervalType-pDateInterval = do-  s ← choice $ map maybePlural ["day", "week", "month", "year"]-  return $ read s--pRelDate ∷ DateTime → TParser DateTime-pRelDate date = do-  offs ← (try futureDate) <|> (try passDate) <|> (try today) <|> (try tomorrow) <|> yesterday-  return $ date `addInterval` offs--futureDate ∷ TParser DateInterval-futureDate = do-  string "in "-  n ← many1 digit-  char ' '-  tp ← pDateInterval-  case tp of-    Day →   return $ Days (read n)-    Week →  return $ Weeks (read n)-    Month → return $ Months (read n)-    Year →  return $ Years (read n)--passDate ∷ TParser DateInterval-passDate = do-  n ← many1 digit-  char ' '-  tp ← pDateInterval-  string " ago"-  case tp of-    Day →   return $ Days $ - (read n)-    Week →  return $ Weeks $ - (read n)-    Month → return $ Months $ - (read n)-    Year →  return $ Years $ - (read n)--today ∷ TParser DateInterval-today = do-  string "today"-  return $ Days 0--tomorrow ∷ TParser DateInterval-tomorrow = do-  string "tomorrow"-  return $ Days 1--yesterday ∷ TParser DateInterval-yesterday = do-  string "yesterday"-  return $ Days (-1)--pDate ∷ DateTime → TParser DateTime-pDate date =  (try $ pRelDate date) <|> (try $ pAbsDate $ year date)--dateType ∷ String → DateType-dateType "start" = StartDate-dateType "end"   = EndDate-dateType "deadline" = Deadline-dateType _ = error "unknown date type"--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 → TParser [(DateType, DateTime)]-pSpecDates date = do-  char '('-  pairs ← (pSpecDate date) `sepBy1` (string "; ")-  string ") "-  return pairs---- | Parse date/time-parseDate ∷ Config-          → DateTime  -- ^ Current date/time-          → String    -- ^ String to parse-          → Either ParseError DateTime-parseDate conf date s = runParser (pDate date) conf "" s-
− Dot.hs 
@@ -1,57 +0,0 @@-{-# 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)-
− IO.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE CPP #-}--- | Wrapper to support unicode IO with GHC 6.10 and 6.12-module IO -#if __GLASGOW_HASKELL__ < 612-  (module System.IO.UTF8)-#else-  (module Prelude)-#endif-  where--#if __GLASGOW_HASKELL__ < 612--   import Prelude hiding (putStr, putStrLn,readFile,getContents,print)-   import System.IO.UTF8--#else--  import Prelude--#endif
Makefile view
@@ -5,4 +5,6 @@ 	$(GHC) $(GHCFLAGS) --make todos.hs  clean:-	rm -f *.hi *.o *~+	find . -name \*.hi -delete+	find . -name \*.o -delete+	find . -name \*~ -delete
README view
@@ -28,8 +28,9 @@ (see below), «TAGS» is a comma-separated list of tags in brackets, «title» is title of record, «depends» — comma-separated list of depends (titles of other records) in parenthesis, «description» is description of the record. All fields-except status and title are optional. Description is separated from title with-not less than 2 spaces.+except status and title are optional. If «-w» option is specified, status field+is not read (it's optional; when it's present, it will be part of title).+Description is separated from title with not less than 2 spaces.   Using different indents one can create sub-records (and, so, trees of records). Moreover, depends are interpreted in same way as sub-records. So, one can@@ -40,37 +41,57 @@ Dates information is described in parenthesis, as not more than 3 records, separated with semicolon. Each records has format «date type: date». Date type can be one of: start, end, deadline. For dates, many formats are supported; for-example, «18 Feb», или «02/18/2010», «2010/02/18» are all valid dates. One can+example, «18 Feb», or «02/18/2010», «2010/02/18» are all valid dates. One can even use relative dates specification here, such as «in 2 weeks» or «2 days ago», but there is no point to this: all dates are counted from program start date.  Next commandline options are supported: -  -1           --only-first         show only first matching entry-  -c           --color              show colored output-  -A[PREFIX]   --prefix[=PREFIX]    use alternate parser: read only lines starting with PREFIX-  -D[FORMAT]   --describe[=FORMAT]  use FORMAT for descriptions-  -p N         --prune=N            limit tree height to N-  -m N         --min-depth=N        show first N levels of tree unconditionally-  -t TAG       --tag=TAG            find items marked with TAG-  -g PATTERN   --grep=PATTERN       find items with PATTERN in name-  -s STRING    --status=STRING      find items with status equal to STRING-  -a           --and                logical AND-  -o           --or                 logical OR-  -n           --not                logical NOT-               --sort=FIELD         specify sorting-  -e[COMMAND]  --exec[=COMMAND]     run COMMAND on each matching entry-  -S DATE      --start-date=DATE    find items with start date bounded with DATE-  -E DATE      --end-date=DATE      find items with end date bounded with DATE-  -d DATE      --deadline=DATE      find items with deadline bounded with DATE-  -h           --help               display this help+  -1           --only-first              show only first matching entry+  -c           --color                   show colored output+  -H           --highlight               instead of filtering TODOs, just highlight matching the query+  -I           --show-ids                show IDs of todos+  -A[PREFIX]   --prefix[=PREFIX]         use alternate parser: read only lines starting with PREFIX+               --dot                     output entries in DOT (graphviz) format+  -D[FORMAT]   --describe[=FORMAT]       use FORMAT for descriptions+  -w           --no-status               do not read status field from TODOs+               --set-status=STRING       force all TODOs status to be equal to STRING+               --set-root-status=STRING  force statuses of root TODOs to be equal to STRING+  -F           --by-file                 group TODOs by source file+  -T           --by-tag                  group TODOs by tag+  -Z           --by-status               group TODOs by status+  -p N         --prune=N                 limit tree height to N+  -m N         --min-depth=N             show first N levels of tree unconditionally+  -t TAG       --tag=TAG                 find items marked with TAG+  -g PATTERN   --grep=PATTERN            find items with PATTERN in name+  -G PATTERN   --description=PATTERN     find items with PATTERN in description+  -s STRING    --status=STRING           find items with status equal to STRING+  -i STRING    --id=STRING               find items with ID equal to STRING+  -a           --and                     logical AND+  -o           --or                      logical OR+  -n           --not                     logical NOT+               --sort=FIELD              specify sorting+  -e[COMMAND]  --exec[=COMMAND]          run COMMAND on each matching entry+  -S DATE      --start-date=DATE         find items with start date bounded with DATE+  -E DATE      --end-date=DATE           find items with end date bounded with DATE+  -d DATE      --deadline=DATE           find items with deadline bounded with DATE+  -h           --help                    display this help  Dates in the commandline are specified in any of supported formats. There relative dates specifications are useful: how about something like «todos --deadline=yesterday»? ;) -For --describe and --exec options, printf-style format strings should be+When «-H» option is specified, items are not filtered at all (all items will be+printed). Instead, items matching to your query will be highlighted. This works+only with «-c» option.++When «-I» option is specified, for each TODO it's unique identifier is shown.+That ID is simply hash  from item's title, status, tags and description, so+only identical items will have identical ID. One can ask todos to show item+with specified ID using «-i» option.++For «--describe» and «--exec» options, printf-style format strings should be specified. Following substitution sequences are supported:  %n :: title of the record@@ -83,9 +104,43 @@ For example, «todos -tBUG -e"vi %f +%l"» command for each record with «BUG» tag will open vi with corresponding file on corresponding line. -todos can read configuration files: ~/.config/todos («global») and-./.todos.conf («local»). Config files contain command line options, in the same+When «--dot» option is specified, todos will output a graph definition for DOT+(graphviz), instead of normal output. For example, you can try++  todos --dot | dot -Tpng -o todos.png++and then see the file todos.png. Items with status «GROUP» will become DOT's+clusters. More precisely, if one item have «GROUP» status, it will become a+cluster, and all it's children will be inside that cluster. There is a+limitation in DOT: it can not draw graphs where one item is in several clusters+properly, it will draw such item only in one cluster.++todos can read configuration files: `~/.config/todos/todos.conf` («global») and+`./.todos.conf` («local»). Config files contain command line options, in the same format as in the commandline. Resulting commandline is composed as: (options in global config) + (options in local config) + (options in the actual command line). If there is no one of configs, todos will ignore it.++Moreover, todos could be customized in «xmonad way». You write file+`~/.config/todos/todos.hs` and run todos. todos will compile and run that file.+Simplest example of `todos.hs` possible is `todos.hs` in this directory. A bit+more complex example:++.................................................................+    import System.Console.ANSI++    import Todos++    main :: IO ()+    main = todos $ defaultConfig {+                      itemConsoleColor = myItemColor+                   }++    myItemColor item =+      if itemStatus item == ":"+         then Just (Dull, Blue)+         else Nothing+.................................................................++So, items with ":" status will be printed in blue color.
README.ru view
@@ -27,7 +27,8 @@ информация о датах (см. ниже), TAGS — список тегов через пробел в квадратных скобках, title — заголовок записи, depends — список зависимостей (заголовков других записей) в скобках через запятую, description — описание записи. Все-поля кроме статуса и заголовка необязательны. Описание отделяется от заголовка+поля кроме статуса и заголовка необязательны. В случае, если указана опция+«-w», поле статуса не читается. Описание отделяется от заголовка не менее чем двумя пробелами.  С помощью разных отступов можно создавать вложенные записи. Кроме того,@@ -51,13 +52,24 @@  -1, --only-first :: показывать только первую запись из всех, что должны быть показаны -c, --color  ::     раскрашивать вывод todos (заголовки записей — полужирным, некоторые статусы выделяются цветом)+-H, --highlight ::  подсвечивать подходящие записи, вместо того чтобы фильтровать их+-I, --show-ids :: показывать идентификаторы записей -A, --prefix= ::    использовать альтернативный формат файлов, тут же указывается префикс+--dot :: вывести записи в виде графа для DOT (graphviz) -D, --describe ::   можно указать формат для выводимого описания (см. ниже)+-w, --no-status ::  не читать поле статуса из файлов+--set-status=STRING :: установить статус всех TODO равным STRING+--set-root-status=STRING :: установить статусы корневых TODO равным STRING+-F, --by-file :: группировать записи по исходному файлу+-T, --by-tag  :: группировать записи по тегам+-Z, --by-status :: группировать записи по статусам -p, --prune ::      ограничить максимальную высоту дерева (для каждой из отобранных записей будет показано не более чем N уровней вложенности) -m, --min-depth ::  ограничить минимальную высоту дерева -t, --tag ::        вывести только записи с заданным тегом и их вложенные записи -g, --grep ::       искать по заголовкам записей+-G, --description :: искать по описаниям записей -s, --status ::     искать по статусам записей+-i, --id ::  искать по идентификаторам записей -a, --and ::        логическое И; например, todos -s! -a -tBUG — искать записи со статусом «!» и тегом «BUG» -o, --or ::         логическое ИЛИ; -n, --not ::        логическое НЕ;@@ -75,6 +87,10 @@ «меньше или равно»; например, todos --start-date="in 2 weeks" будет искать записи с датой начала через 2 недели или раньше (в т.ч. и в прошлом). +С указанной опцией «-H» записи не фильтруются совсем. Вместо этого те записи,+которые подходят под ваш запрос, будут подсвечены цветом (только с включённой+опцией «-c»).+ Для опций --describe и --exec указываются строки формата с символами подстановки в стиле printf. Поддерживаются следующие символы подстановки: @@ -88,9 +104,44 @@ Например, todos -tBUG -e"vi %f +%l" для каждой записи с тегом BUG откроет vi на строчке с этой записью. -todos может читать конфигурационные файлы: ~/.config/todos (глобальный) и-.todos.conf в текущей директории (локальный). Конфигурационные файлы содержат+С опцией «--dot» todos выведет на стандартный выход описание графа для DOT+(graphviz) вместо обычного вывода. Можно попробовать, например, так:++  todos --dot | dot -Tpng -o todos.png++и см. получившийся файл todos.png. Записи со статусом «GROUP» становятся+кластерами. Точнее говоря, если какая-то запись имеет статус «GROUP», она будет+отображаться как кластер, а все её дочерние записи будут находиться внутри+этого кластера. При этом есть одно ограничение, накладываемое DOT: DOT не умеет+правильно рисовать графы, в которых один узел находится сразу в нескольких+кластерах; в таких случаях узел будет нарисован только в одном кластере.++todos может читать конфигурационные файлы: `~/.config/todos/todos.conf`  (глобальный) и+`.todos.conf` в текущей директории (локальный). Конфигурационные файлы содержат ключи командной строки. «Эффективная командная строка» составляется как (ключи в глобальном конфиге) + (ключи в локальном конфиге) + ключи в командной строке. Если какого-то из конфигов нет, todos это проигнорирует.++Кроме того, todos можно настраивать под себя «в стиле xmonad». Вы пишете файл+`~/.config/todos/todos.hs` и запускаете todos. todos компилирует и запускает+тот файл. Простейший возможный пример этого `todos.hs` — это файл `todos.hs` в+этой директории. Вот чуть более сложный пример:++.................................................................+    import System.Console.ANSI++    import Todos++    main :: IO ()+    main = todos $ defaultConfig {+                      itemConsoleColor = myItemColor+                   }++    myItemColor item =+      if itemStatus item == ":"+         then Just (Dull, Blue)+         else Nothing+.................................................................++Таким образом, записи со статусом «:» будут напечатаны синим цветом.
− Shapes.hs 
@@ -1,42 +0,0 @@-{-# 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 
@@ -1,104 +0,0 @@-{-# LANGUAGE UnicodeSyntax, PatternGuards #-}--- | Read TODOs from files and construct corresponding ADTs.-module TodoLoader-  (loadTodo)-  where--import Prelude hiding (putStrLn,readFile,getContents,print)-import IO-import Control.Monad (forM)-import qualified Data.Map as M-import Text.ParserCombinators.Parsec-import Data.Maybe-import Data.Tree--import Unicode-import Types-import TodoParser--todoName ∷ Todo → String-todoName todo = itemName ⋄ rootLabel todo--getDepends ∷ TodoMap → TodoItem → [Todo]-getDepends m item = catMaybes [M.lookup name m | name ← depends item] --normalizeItem ∷ TodoMap → TodoItem → Todo-normalizeItem m item = Node item (map (normalize m) ⋄ getDepends m item)--normalize ∷ TodoMap → Todo → Todo -normalize m todo = Node item' ((map (normalize m) subTodos) ⧺ (map (normalize m) deps))-  where-    item ∷ TodoItem-    item = rootLabel todo--    item' ∷ TodoItem-    item' = item {depends=[]}--    subTodos ∷ [Todo]-    subTodos = subForest todo--    deps ∷ [Todo]-    deps = getDepends m item--normalizeList ∷ TodoMap → [Todo] → [Todo]-normalizeList m todos = map (normalize m) todos--readFile' ∷ FilePath → IO String-readFile' "-"  = getContents-readFile' file = readFile file--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}--iszero ∷  TodoItem → 𝔹-iszero item = (itemLevel item)==0--group' ∷  [TodoItem] → [[TodoItem]]-group' [] = []-group' (x:xs) = let (one,other) = break iszero xs-                in (x:one):group' other--mkTodo ∷ [TodoItem] → [Todo]-mkTodo = (map mkTodo') ∘ group'--mkTodo' ∷ [TodoItem] → Todo-mkTodo' (x:xs) = Node x other-    where other = mkTodo ⋄ map (~-lvl) xs-          lvl = itemLevel (head xs)-          -consTodoMap ∷ [Todo] → TodoMap-consTodoMap todos = M.fromList (cons1 100 todos)-  where-    cons1 ∷ Int → [Todo] → [(String,Todo)]-    cons1 0 _ = []-    cons1 max trees = [(todoName todo, todo) | todo ← trees] ⧺ cons1 (max-1) (children trees)-    children ∷ [Todo] → [Todo]-    children trees = concatMap subForest trees--stitchTodos ∷ [TodoItem] → [Todo]-stitchTodos items = -  let m = consTodoMap t-      t = mkTodo items-  in  normalizeList m t---- | Load list of TODO trees from files-loadTodo ∷ Config-         → DateTime      -- ^ Current date/time-         → [FilePath]    -- ^ List of files-         → IO [Todo]-loadTodo conf date paths = do-    tss ← forM paths (loadFile conf date)-    return $ stitchTodos (concat tss)
− TodoParser.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE UnicodeSyntax, NoMonomorphismRestriction, TypeSynonymInstances, DeriveDataTypeable #-}-module TodoParser-    (parsePlain, parseAlternate)-    where--import Prelude hiding (putStrLn,readFile,getContents,print)-import IO-import Control.Monad-import Data.List-import Text.ParserCombinators.Parsec-import qualified Data.Map as M-import Data.Tree-import Data.Maybe-import Data.Char-import Data.Function--import Unicode-import Types-import Dates--strip ∷  String → String-strip = reverse ∘ p ∘ reverse ∘ p-  where-    p = dropWhile isSpace--pSpace ∷ TParser Char-pSpace = oneOf " \t"--pSpace' ∷ TParser String-pSpace' = do-    pSpace-    return " "--pSpaces ∷ TParser String-pSpaces = many pSpace--pDeps ∷ TParser [String]-pDeps = do-    string "("-    ws ← (many1 ⋄ noneOf ",)\n\r") `sepBy` (char ',')-    string ")"-    return $ map strip ws--pTags ∷ TParser [String]-pTags = do-    ts ← between (char '[') (char ']') $ word `sepBy1` pSpace-    pSpaces-    return ts-  where-    word = many1 (noneOf " \t\n\r]")--pItem ∷ DateTime → TParser TodoItem-pItem date = do-    pos ← getPosition-    s ← pSpaces-    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-    pSpaces-    deps ← (try pDeps <|> return [])-    pSpaces-    descr ← many (noneOf "\n\r")-    pSpaces-    many ⋄ oneOf "\n\r"-    return ⋄ Item {-        itemLevel = fromIntegral $ length s,-        itemName = unwords namew,-        itemTags = tags,-        depends = deps,-        itemStatus = stat,-        itemDescr = descr,-        startDate = lookup StartDate dates,-        endDate = lookup EndDate dates,-        deadline = lookup Deadline dates,-        fileName = sourceName pos,-        lineNr = sourceLine pos }--pWord ∷ TParser String-pWord = do-    w ← many1 (noneOf " \t\n\r")-    (try pSpace') <|> (return w)-    return w--pItems ∷ DateTime → TParser [TodoItem]-pItems date = do-  its ← many (pItem date)-  eof-  return its--unwords' ∷  String → [String] → String-unwords' prefix lst =-  let (hd:tl) = map (filter (/='\r')) lst-      addLines = filter (not ∘ (prefix `isPrefixOf`)) tl-  in  case addLines of-        [] → hd-        _  → hd ⧺ "    {" ++ (unwords addLines) ++ "}"--filterN ∷ (Num a, Enum a) ⇒ Int → String → [String] → ([a], [String])-filterN n prefix lst = -  let zipped = zip [0..] lst-      good   = filter (isGood ∘ snd) zipped-      lns    = map fst good-      sub k l = (take l) ∘ (drop k)-      ans = map (unwords' prefix) [sub j n lst | j ← lns]-      isGood x = prefix `isPrefixOf` x-      cut = drop (1+length prefix) -  in (map (+1) lns, map cut ans)--filterJoin ∷ Int → String → String → ([Int], String)-filterJoin n prefix str = -  let (ns, lns) = filterN n prefix (lines str)-  in  (ns, unlines lns)---- | Read list of TODO items from plain format -parsePlain ∷ Config-           → DateTime   -- ^ Current date/time-           → SourceName -- ^ Source file name-           → String     -- ^ String to parse-           → [TodoItem]-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 ∷ 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 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 runParser (pItems date) conf path filtered of-       Right items → renumber items-       Left e      → error $ show e-
− TodoTree.hs 
@@ -1,153 +0,0 @@-{-# LANGUAGE UnicodeSyntax, NoMonomorphismRestriction, FlexibleInstances, TypeSynonymInstances #-}-module TodoTree -  (delTag,-   pruneSelector,-   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-import Data.Generics-import Data.List-import Data.Function (on)-import Data.Tree-import Data.Maybe-import Text.Regex.PCRE-import Data.Hash-import Numeric--import Types-import TodoLoader-import Unicode--sortBy' s | s == DoNotSort = id-          | otherwise = sortBy sorter-  where-    sorter = compare `on` (f ∘ rootLabel)-    f = case s of-          ByTitle → itemName-          ByStatus → itemStatus-          ByTags → unwords ∘ itemTags-          ByStartDate → show ∘ startDate-          ByEndDate → show ∘ endDate-          ByDeadline → show ∘ deadline --showT ∷ SortingType → Int → Todo → [Formatter]-showT s n (Node item 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'' ∷ [Formatter] → Formatter-unlines'' lst = concat `fmap` (sequence $ intersperse newLine lst)--showTodo ∷ Todo → Formatter-showTodo t = do-  conf ← ask-  let f = case outOnlyFirst conf of-            False → unlines''-            True  → head-  f $ showT (sorting conf) 0 t--showTodos ∷ [Todo] → Formatter-showTodos lst = do-  conf ← ask-  let f = case outOnlyFirst conf of-            False → unlines''-            True  → head-  f $ map showTodo $ sortBy' (sorting conf) $ nub lst--printTodos ∷ Config → [Todo] → IO ()-printTodos conf lst = -  let lst' = runReader (showTodos lst) conf-  in  mapM_ outItem lst'--mapTags ∷  (Data a) ⇒ ([String] → [String]) → [a] → [a]-mapTags f = map ⋄ everywhere ⋄ mkT changeTags-  where-    changeTags item@(Item {itemTags=ts}) = item {itemTags = f ts}-        -addTag ∷  (Data a) ⇒ String → [a] → [a]-addTag t = mapTags (t:)--delTag ∷  (Data a) ⇒ String → [a] → [a]-delTag t = mapTags (delete t)--pruneSelector ∷ (TodoItem → 𝔹) → Transformer-pruneSelector pred = do-  (Limit n) ← asks pruneL-  (Limit m) ← asks minL-  return $ pruneSelector' n m pred-        -pruneSelector' ∷ ℤ → ℤ → (TodoItem → 𝔹) → (Todo → [Todo])-pruneSelector' n m pred = select n 0 False-    where-        select k t b (Node item trees) | t < m       = [Node item ⋄ concatMap (select (n-1) (t+1) True) trees]-                                       | pred item   = [Node item ⋄ concatMap (select (n-1) (t+1) True) trees]-                                       | (k > 0) ∧ b = [Node item ⋄ concatMap (select (k-1) (t+1) True) trees]-                                       | k > 0       = concatMap (select (k-1) (t+1) False) trees-                                       | otherwise   = []                                               --addS ∷  (Show a) ⇒ a → TodoItem → TodoItem-addS s item@(Item {itemName=name}) = item {itemName = name ⧺ " — " ⧺ show s}--tagPred ∷  String → TodoItem → 𝔹-tagPred tag = \item → tag ∈ itemTags item--statusPred ∷  String → TodoItem → 𝔹-statusPred st = \item → st == itemStatus item-        -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-isLT (Just x) y = x <= y--isGT ∷  (Ord t) ⇒ Maybe t → t → 𝔹-isGT Nothing _ = False-isGT (Just x) y = x >= y--datePred ∷  (Ord a) ⇒ (t → Maybe a) → a → a → t → 𝔹-datePred selector curr dt | dt >= curr = \item → selector item `isLT` dt-                          | otherwise  = \item → selector item `isGT` dt--flattern ∷ [Todo] → [Todo]-flattern = concatMap flat-    where-        flat ∷ Todo → [Todo]-        flat (Node item trees) = (Node item []):(concatMap flat trees)--forT ∷ (Monad m, Eq t) ⇒ [Tree t] → (t → m a) → m [b]-forT todos f = forM (nub todos) forT'-  where-    forT' (Node item trees) =-      do f item-         res ← forM trees forT'-         return $ last res--mapT ∷ (t → t) → [Tree t] → [Tree t]-mapT f todos = map mapT' todos-  where-    mapT' (Node item trees) = Node (f item) (mapT f trees)
+ Todos.hs view
@@ -0,0 +1,25 @@+module Todos +  (module Todos.Unicode,+   module Todos.Types,+   module Todos.Loader,+   module Todos.Tree,+   module Todos.CommandParser,+   module Todos.Config,+   module Todos.ConfigUtils,+   module Todos.CmdLine,+   module Todos.Dot,+   module Todos.Main,+   getCurrentDateTime) where++import Todos.Unicode+import Todos.Types+import Todos.Loader+import Todos.Tree+import Todos.CommandParser+import Todos.Config+import Todos.ConfigUtils+import Todos.CmdLine+import Todos.Dates (getCurrentDateTime)+import Todos.Dot+import Todos.Main+
+ Todos/CmdLine.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE UnicodeSyntax, PatternGuards #-}++-- | Module for parsing command line options and build queries+module Todos.CmdLine+  (parseCmdLine',+   glob,+   buildQuery,+   compose,+   usage)+  where++import Prelude hiding (putStrLn,readFile,getContents,print)+import Todos.IO+import System.Console.GetOpt+import System.FilePath.Glob+import Data.Maybe+import Data.List (sort)++import Todos.Unicode+import Todos.Types+import Todos.Tree+import Todos.Config+import Todos.Dates (parseDate)++-- | Compose predicate from Composed+compose ∷ DateTime       -- ^ Current date/time+        → Composed       -- ^ Composed query+        → (TodoItem → 𝔹)+compose _ Empty             = const True+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+compose dt (Not p)           = not ∘ (compose dt p)+compose dt (And (Pred NoFilter) p) = compose dt p+compose dt (And p (Pred NoFilter)) = compose dt p+compose dt (And p1 p2)      = \item → (compose dt p1 item) ∧ (compose dt p2 item)+compose dt (Or (Pred NoFilter) p) = compose dt p+compose dt (Or p (Pred NoFilter)) = compose dt p+compose dt (Or p1 p2)       = \item → (compose dt p1 item) ∨ (compose dt p2 item)+compose _ x = error $ show x++appendC ∷ Composed → QueryFlag → Composed+appendC (Not (Pred NoFilter))   f = Not (Pred f)+appendC Empty OrCons              = (Pred NoFilter) `Or` (Pred NoFilter)+appendC Empty AndCons             = (Pred NoFilter) `And` (Pred NoFilter)+appendC Empty NotCons             = Not (Pred NoFilter)+appendC Empty f                   = Pred f+appendC c NoFilter                = c+appendC c AndCons                 = c `And` (Pred NoFilter)+appendC c OrCons                  = c `Or`  (Pred NoFilter)+appendC c NotCons                 = c `And` (Pred NoFilter)+appendC (And c (Pred NoFilter)) f = c `And` (Pred f) +appendC (And (Pred NoFilter) c) f = c `And` (Pred f) +appendC c@(And _ _)             f = c `And` (Pred f)+appendC (Or c (Pred NoFilter))  f = c `Or`  (Pred f)+appendC (Or (Pred NoFilter) c)  f = c `Or`  (Pred f)+appendC c@(Or _ _)              f = c `Or`  (Pred f)+appendC c@(Pred _)              f = c `And` (Pred f)+appendC c                       f = c `And` (Pred f)++appendF ∷ Options → CmdLineFlag → Options+appendF (O q m o l) (QF f) = O (f:q) m o l+appendF (O q m o l) (MF f) = O q (f:m) o l+appendF (O q m o l) (OF f) = O q m (f:o) l+appendF (O q m o l) (LF f) = O q m o (f:l)+appendF _ HelpF = Help+appendF Help _  = Help++parseFlags ∷ [CmdLineFlag] → Options+parseFlags lst | HelpF ∈ lst = Help+parseFlags [] = O [] [] [] []+parseFlags (f:fs) = (parseFlags fs) `appendF` f++-- | Build DefaultConfig (with query etc) from Options+buildQuery ∷ BaseConfig    -- ^ Default config+           → Options       -- ^ Cmdline options+           → DefaultConfig+buildQuery _ Help = error "Internal error: buildQuery does no sense for Help!"+buildQuery dc (O qflags mflags oflags lflags) =+    DConfig {+      baseConfig = BConfig {+          outOnlyFirst = update outOnlyFirst onlyFirst,+          outColors    = update outColors    colors,+          outIds       = update outIds       showIds,+          outHighlight = update outHighlight highlight,+          sorting      = update sorting      srt,+          pruneL       = update pruneL       limitP,+          minL         = update minL         limitM,+          commandToRun = update commandToRun command,+          prefix       = update prefix       aprefix,+          descrFormat  = update descrFormat  dformat,+          skipStatus   = update skipStatus   noStatus,+          groupByFile  = update groupByFile  doGroupByFile,+          groupByTag   = update groupByTag   doGroupByTag,+          groupByStatus = update groupByStatus doGroupByStatus,+          forcedStatus = update forcedStatus setStatus,+          topStatus    = update topStatus    setTopStatus },+      query        = fromMaybe Empty composedFlags }+  where+    update fn Nothing  = fn dc+    update _  (Just x) = x++    x ? lst | x ∈ lst   = Just True+            | otherwise = Nothing++    composedFlags | null qflags = Nothing+                  | otherwise   = Just $ parseQuery qflags+    (limitP,limitM) | null lflags = (Nothing, Nothing)+                    | otherwise   = parseLimits (unLimit $ pruneL dc) (unLimit $ minL dc) lflags++    onlyFirst = OnlyFirst ? oflags+    colors    = Colors    ? oflags+    highlight = Highlight ? oflags+    showIds   = Ids       ? oflags++    srtFlags = filter isSort oflags+    srt | null srtFlags = Nothing+        | otherwise     = Just $ getSorting (last srtFlags)++    doGroupByFile   = GroupByFile   ? mflags+    doGroupByTag    = GroupByTag    ? mflags+    doGroupByStatus = GroupByStatus ? mflags++    cmdFlags  = filter isCommand mflags+    command | DotExport ∈ oflags = Just $ ShowAsDot+            | null cmdFlags      = Nothing+            | otherwise          = Just $ SystemCommand $ unExecute (last cmdFlags)++    prefixFlags = filter isPrefix mflags+    aprefix | null prefixFlags = Nothing+            | otherwise        = Just $ Just $ unPrefix (last prefixFlags)++    dflags = filter isDescribe mflags+    dformat | null dflags = Nothing+            | otherwise   = Just $unDescribe $ last dflags++    noStatus = DoNotReadStatus ? mflags+    newStatusFlags = filter isSetStatus mflags+    setStatus | null newStatusFlags = Nothing+              | otherwise           = Just $ Just $ newStatus $ last newStatusFlags++    topStatusFlags = filter isTopStatus mflags+    setTopStatus | null topStatusFlags = Nothing+                 | otherwise           = Just $ Just $ newTopStatus $ last topStatusFlags++    isSort (Sort _) = True+    isSort _        = False+    isDescribe (Describe _) = True+    isDescribe _            = False+    isCommand (Execute _) = True+    isCommand _           = False+    isPrefix (Prefix _) = True+    isPrefix _          = False+    isSetStatus (SetStatus _)  = True+    isSetStatus _              = False+    isTopStatus (SetTopStatus _) = True+    isTopStatus _                = False++parseLimits ∷ ℤ → ℤ → [LimitFlag] → (Maybe Limit,Maybe Limit)+parseLimits dlp dlm flags = (Just limitP, Just limitM)+  where+    pruneFlags = filter isPrune flags+    minFlags   = filter isMin flags++    limitP'       = foldl min Unlimited $ map (Limit ∘ unPrune) pruneFlags+    limitP | Unlimited ← limitP' = Limit dlp+           | otherwise           = limitP'++    limitM'       = foldl max (Limit 0) $ map (Limit ∘ unMin) minFlags+    limitM | Unlimited ← limitM' = Limit dlm+           | otherwise           = limitM'++    isPrune (Prune _) = True+    isPrune _         = False++    isMin   (Start _) = True+    isMin   _         = False++parseQuery ∷ [QueryFlag] → Composed+parseQuery flags = foldl appendC Empty flags++-- | Parse command line+parseCmdLine' ∷ DateTime             -- ^ Current date/time+             → [String]              -- ^ Command line args+             → Either String (Options, [FilePath]) -- ^ Error message or (Options, list of files)+parseCmdLine' currDate args = +  case getOpt Permute (options currDate) (map decodeString args) of+        (flags, [],      [])     → Right (parseFlags flags, ["TODO"])+        (flags, nonOpts, [])     → Right (parseFlags flags, nonOpts)+        (_,     _,       msgs)   → Left $ concat msgs ⧺ usage++isPattern s = ('*' ∈ s) || ('?' ∈ s)++-- | For given list of glob masks, return list of matching files+glob ∷ [FilePath] → IO [FilePath]+glob list = do+  let patterns = filter isPattern list+      files = filter (not ∘ isPattern) list+  (matches, _) ← globDir (map compile patterns) "." +  return $ sort $ files ⧺ concat matches++-- | Usage help for default command line options+usage ∷  String+usage = usageInfo header (options undefined)+  where +    header = "Usage: todos [OPTION...] [INPUT FILES]"++options ∷ DateTime → [OptDescr CmdLineFlag]+options currDate = [+    Option "1" ["only-first"] (NoArg (OF OnlyFirst))                 "show only first matching entry",+    Option "c" ["color"]      (NoArg (OF Colors))                    "show colored output",+    Option "H" ["highlight"]  (NoArg (OF Highlight))                 "instead of filtering TODOs, just highlight matching the query",+    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 ""  ["set-root-status"] (ReqArg mkTopStatus "STRING")     "force statuses of root TODOs to be equal to STRING",+    Option "F" ["by-file"]    (NoArg (MF GroupByFile))               "group TODOs by source file",+    Option "T" ["by-tag"]     (NoArg (MF GroupByTag))                "group TODOs by tag",+    Option "Z" ["by-status"]  (NoArg (MF GroupByStatus))             "group TODOs by status",+    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",+    Option ""  ["sort"]       (ReqArg mkSort "FIELD")                "specify sorting",+    Option "e" ["exec"]       (OptArg mkExecute "COMMAND")           "run COMMAND on each matching entry",+    Option "S" ["start-date"] (ReqArg (mkStartDate currDate) "DATE") "find items with start date bounded with DATE",+    Option "E" ["end-date"]   (ReqArg (mkEndDate currDate) "DATE")   "find items with end date bounded with DATE",+    Option "d" ["deadline"]   (ReqArg (mkDeadline currDate) "DATE")  "find items with deadline bounded with DATE",+    Option "h" ["help"]       (NoArg HelpF)                          "display this help"+  ]++mkSort s = OF $ Sort $ readSort s++mkTag ∷  String → CmdLineFlag+mkTag t = QF $ Tag t++mkName ∷  String → CmdLineFlag+mkName n = QF $ Name n++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 undefined dt s++mkEndDate ∷  DateTime → String → CmdLineFlag+mkEndDate dt s = QF $ EndDateIs $ forceEither $ parseDate undefined dt s++mkDeadline ∷  DateTime → String → CmdLineFlag+mkDeadline dt s = QF $ DeadlineIs $ forceEither $ parseDate undefined 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++mkTopStatus ∷ String → CmdLineFlag+mkTopStatus st = MF $ SetTopStatus st++mkPrune ∷  String → CmdLineFlag+mkPrune s = LF $ Prune (read s)++mkMin ∷  String → CmdLineFlag+mkMin s = LF $ Start (read s)++mkPrefix ∷  Maybe [Char] → CmdLineFlag+mkPrefix = MF ∘ Prefix ∘ fromMaybe "TODO:"++mkExecute ∷  Maybe [Char] → CmdLineFlag+mkExecute = MF ∘ Execute ∘ fromMaybe "echo %n %d"
+ Todos/Color.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE UnicodeSyntax #-}+module Todos.Color where++import qualified Data.Map as M+import Text.Printf+import Data.Word+import Data.Hash+import Data.List (minimumBy)+import Data.Function (on)+import qualified System.Console.ANSI as ANSI++import Todos.Types++-- | Hue, saturation and value; all are in [0; 1] range.+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++-- | Correspondence between console colors and HSV colors+consoleColors ∷ [((ANSI.ColorIntensity, ANSI.Color), HSV)]+consoleColors = +  [((ANSI.Dull, ANSI.Black),  HSV 0 0 0),+   ((ANSI.Dull, ANSI.Red),    HSV 0 1 0.67),+   ((ANSI.Dull, ANSI.Green),  HSV 0.333 1 0.67),+   ((ANSI.Dull, ANSI.Yellow), HSV (1.0/12.0) 1 0.67),+   ((ANSI.Dull, ANSI.Blue),   HSV 0.667 1 0.67),+   ((ANSI.Dull, ANSI.Magenta), HSV (5.0/6.0) 1 0.67),+   ((ANSI.Dull, ANSI.Cyan),   HSV 0.5 1 0.67),+   ((ANSI.Dull, ANSI.White),  HSV 0 0 0.67),+   ((ANSI.Vivid, ANSI.Black),  HSV 0 0 0.33),+   ((ANSI.Vivid, ANSI.Red),    HSV 0 0.67 1),+   ((ANSI.Vivid, ANSI.Green),  HSV 0.333 0.67 1),+   ((ANSI.Vivid, ANSI.Yellow), HSV (1.0/12.0) 0.67 1),+   ((ANSI.Vivid, ANSI.Blue),   HSV 0.667 0.67 1),+   ((ANSI.Vivid, ANSI.Magenta), HSV (5.0/6.0) 0.67 1),+   ((ANSI.Vivid, ANSI.Cyan),   HSV 0.5 0.67 1),+   ((ANSI.Vivid, ANSI.White),  HSV 0 0 1) ]++-- | Get console color which is nearest to given HSV color+consoleColor ∷ HSV → (ANSI.ColorIntensity, ANSI.Color)+consoleColor hsv = fst $ minimumBy (compare `on` ρ) consoleColors+  where ρ (_, clr) = sum $ map (^2) [colorHue hsv - colorHue clr,+                                     colorSaturation hsv - colorSaturation clr,+                                     colorValue hsv - colorValue clr ]++-- | Hue values for some common tags+tagHues ∷ M.Map String Double+tagHues = M.fromList $ [+  ("BUG",   0.07),+  ("NOTE",  0.25),+  ("ERROR", 0.0),+  ("TAG",   0.16),+  ("TODO",  0.55)]++hashAsDouble ∷ Hashable a ⇒ a → Double+hashAsDouble x = (fromIntegral $ asWord64 $ hash x) / (fromIntegral (maxBound :: Word64))++-- | Get color hue from tag name+tagHue ∷ String → Double+tagHue tag =+  case M.lookup tag tagHues of+    Nothing → hashAsDouble tag+    Just h  → h++-- | Color saturation values for some common statuses+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)]++-- | Get color saturation from item status+statusSat ∷ String → Double+statusSat st = +  case M.lookup st statusSats of+    Nothing → 0.4* hashAsDouble st+    Just s  → s++-- | Color hue values for some common item statuses+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)]++-- | Get color hue from item status+statusHue ∷ String → Double+statusHue st =+  case M.lookup st statusHues of+    Nothing → hashAsDouble st+    Just h  → h++-- | Get console color for item status+statusColor ∷ String → (ANSI.ColorIntensity, ANSI.Color)+statusColor st = consoleColor $ HSV (statusHue st) (statusSat st) 0.2++-- | Get console color for item name (this is const Nothing)+defItemConsoleColor ∷ TodoItem → Maybe (ANSI.ColorIntensity, ANSI.Color)+defItemConsoleColor _ = Nothing++-- | Get color for item (this is used in DOT output)+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+
+ Todos/CommandParser.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE UnicodeSyntax #-}++module Todos.CommandParser where++import Todos.Unicode+import Todos.Types++-- | Format item info+printfItem ∷ String      -- ^ Format string+           → TodoItem +           → String+printfItem pattern item = printf pattern+  where+    printf "" = ""+    printf [x] = [x]+    printf ('%':c:xs) = (itemPart c) ⧺ printf xs+    printf (x:xs) = x:printf xs++    itemPart 'L' = show $ itemLevel item+    itemPart 'n' = itemName item+    itemPart 't' = unwords $ itemTags item+    itemPart 's' = itemStatus item+    itemPart 'd' = itemDescr item+    itemPart 'f' = fileName item+    itemPart 'l' = show $ lineNr item+    itemPart x   = [x]
+ Todos/Config.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses #-}++module Todos.Config where++import Control.Monad.Reader++import Todos.Unicode+import Todos.Types+import Todos.Color+import Todos.Shapes+import qualified System.Console.ANSI as ANSI++-- | Any user-specified runtime config type should belong to this class+class RuntimeConfig c where+  -- | Does given TODO item match query?+  getPredicate ∷ DateTime → c → (TodoItem → 𝔹) +  -- | Get basic configuration+  toBaseConfig ∷ c → BaseConfig++-- | Any user-specified runtime config type should include at least this properties+data BaseConfig = BConfig {+      outOnlyFirst ∷ 𝔹,           -- ^ Output only first matching entry+      outColors ∷ 𝔹,              -- ^ Show colored output+      outIds :: 𝔹,                -- ^ Show IDs+      outHighlight ∷ 𝔹,           -- ^ Highlight matching items+      sorting ∷ SortingType,      -- ^ How to sort items+      pruneL ∷ Limit, +      minL   ∷ Limit,+      commandToRun ∷ TodoCommand,+      prefix ∷ Maybe String,      -- ^ Nothing — use default parser, Just p — use alternate parser with prefix «p»+      descrFormat ∷ String,+      skipStatus ∷ 𝔹,             -- ^ Skip status field in input+      groupByFile ∷ 𝔹,+      groupByTag ∷ 𝔹,+      groupByStatus ∷ 𝔹,+      forcedStatus ∷ Maybe String,+      topStatus ∷ Maybe String+      }+    deriving (Eq, Show)++-- | Default runtime configuration type. Is read from command line and configs.+data DefaultConfig = DConfig {+      baseConfig ∷ BaseConfig,+      query ∷ Composed }+    deriving (Eq,Show)++-- | Configuration for console output. Is generated in runtime from TodosConfig and Config.+data PrintConfig c = PConfig {+  printConfig ∷ c,+  printStatusColor ∷  String → (ANSI.ColorIntensity, ANSI.Color),       -- ^ Color of status field from status+  printItemColor ∷  TodoItem → Maybe (ANSI.ColorIntensity, ANSI.Color), -- ^ Color of item name+  printHighlightColor ∷ (ANSI.ColorIntensity, ANSI.Color),              -- ^ Color to use for highlighting+  doHighlight ∷ TodoItem → 𝔹                                            -- ^ Whether to highlight given item+  }++-- | User Todos config. User can specify it in @~/.config/todos/todos.hs@.+data TodosConfig c = Todos {+     parseCommandLine ∷ DateTime → c → [String] → CmdLineParseResult c,     -- ^ Function to parse command line+     filterTodos ∷ DateTime → c → [Todo] → [Todo],                          -- ^ Any function to be run to transform read TODOs tree+     statusConsoleColor ∷ String → (ANSI.ColorIntensity, ANSI.Color),       -- ^ Function to select a color of item's status field in console output+     itemConsoleColor ∷ TodoItem → Maybe (ANSI.ColorIntensity, ANSI.Color), -- ^ Function to select a color of item's name in console output+     highlightColor ∷ (ANSI.ColorIntensity, ANSI.Color),                    -- ^ Color to use for highlighting+     itemColor ∷ TodoItem → HSV,                                            -- ^ Function to select color for item's node in DOT output+     itemShape ∷ TodoItem → Shape,                                          -- ^ Function to select shape for item's node in DOT output+     printTodos ∷ PrintConfig c → [Todo] → IO (),                           -- ^ Any function to output TODOs list+     nullConfig ∷ c                                                         -- ^ Default Config (to be used without any options in command line and configs)+}++-- | Result of parsing command line+data CmdLineParseResult c = +     Parsed c [FilePath]       -- ^ Parsed successfully, got Config and list of source files+   | ParseError String         -- ^ Some error occured+   | CmdLineHelp               -- ^ User asked for help+   deriving (Eq,Show)++-- | ask field from BaseConfig+askBase ∷ (RuntimeConfig c) ⇒ (BaseConfig → a) → Reader c a+askBase field = asks (field ∘ toBaseConfig)+
+ Todos/ConfigInstances.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | This module contains instances of RuntimeConfig class for DefaultConfig and PrintConfig+module Todos.ConfigInstances where++import Todos.Unicode+import Todos.Config+import Todos.CmdLine++instance RuntimeConfig DefaultConfig where+  getPredicate dt conf = compose dt $ query conf+  toBaseConfig = baseConfig++instance (RuntimeConfig c) ⇒ RuntimeConfig (PrintConfig c) where+  getPredicate = const doHighlight+  toBaseConfig = toBaseConfig ∘ printConfig+
+ Todos/ConfigUtils.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses #-}+-- | This module contains some empty configs definitions and some function fields of defaultConfig+module Todos.ConfigUtils where++import System.Console.ANSI++import Todos.Types+import Todos.Config+import Todos.Color+import Todos.Shapes+import Todos.CmdLine+import Todos.Print+import Todos.Tree++-- | Empty BaseConfig+emptyBaseConfig ∷ BaseConfig+emptyBaseConfig = BConfig {+  outOnlyFirst = False,+  outColors = False,+  outIds = False,+  outHighlight = False,+  sorting = DoNotSort,+  pruneL = Limit 20,+  minL = Limit 0,+  commandToRun = JustShow,+  prefix = Nothing,+  descrFormat = "%d",+  skipStatus = False,+  groupByFile = False,+  groupByTag = False,+  groupByStatus = False,+  forcedStatus = Nothing,+  topStatus = Nothing+}++-- | Default empty DefaultConfig (nullConfig field of defaultConfig)+emptyConfig ∷ DefaultConfig+emptyConfig = DConfig {+  baseConfig = emptyBaseConfig,+  query = Empty }++-- | Default Todos config+defaultConfig ∷ TodosConfig DefaultConfig+defaultConfig = Todos {+  parseCommandLine = parseCmdLine,+  filterTodos = defaultTodosFilter,+  statusConsoleColor = statusColor,+  itemConsoleColor = defItemConsoleColor,+  highlightColor = (Vivid, Magenta),+  itemColor = getColor,+  itemShape = getShape,+  printTodos = defaultPrintTodos,+  nullConfig = emptyConfig+}++-- | Make a list transformer+composeAll ∷ DateTime → DefaultConfig → (Todo → [Todo])+composeAll date conf =+  let pred = compose date $ query conf+      bc = baseConfig conf+  in  pruneSelector bc pred++-- | Default filter for TODOs (filterTodos field of defaultConfig)+defaultTodosFilter ∷ DateTime → DefaultConfig → [Todo] → [Todo]+defaultTodosFilter dt conf todos =+  let t = delTag "-" todos+      bc = baseConfig conf+  in  if outHighlight bc+        then t+        else concatMap (composeAll dt conf) t++-- | Parse command line (default function)+parseCmdLine ∷ DateTime              -- ^ Current date/time+             → DefaultConfig         -- ^ Default config+             → [String]              -- ^ Command line args+             → CmdLineParseResult DefaultConfig+parseCmdLine currDate dc args = +  case parseCmdLine' currDate args of+    Right (opts, files) → case opts of+                           Help → CmdLineHelp+                           _    → Parsed (buildQuery (baseConfig dc) opts) files+    Left str            → ParseError str++-- | Prepare PrintConfig for console output functions. Is called from realTodos.+mkPrintConfig ∷ (RuntimeConfig c) ⇒ DateTime → c → TodosConfig c → PrintConfig c+mkPrintConfig dt conf tcfg = PConfig {+  printConfig      = conf,+  printStatusColor = statusConsoleColor tcfg,+  printItemColor   = itemConsoleColor tcfg,+  printHighlightColor = highlightColor tcfg,+  doHighlight      = getPredicate dt conf }+
+ Todos/Dates.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | Operations with dates+module Todos.Dates+  (parseDate, getCurrentDateTime,+   pSpecDates)+  where++import Data.Char (toUpper)+import Data.List+import Data.Time.Calendar+import Data.Time.LocalTime+import Text.ParserCombinators.Parsec++import Todos.Types+import Todos.Unicode+import Todos.Config+import Todos.ParserTypes++getCurrentDateTime ∷  IO DateTime+getCurrentDateTime = do+  zt ← getZonedTime+  let lt = zonedTimeToLocalTime zt+      ld = localDay lt+      ltod = localTimeOfDay lt+      (y,m,d) = toGregorian ld+      h = todHour ltod+      min = todMin ltod+      s = round $ todSec ltod+  return $ DateTime (fromIntegral y) m d h min s++uppercase ∷ String → String+uppercase = map toUpper++isPrefixOfI ∷  String → String → Bool+p `isPrefixOfI` s = (uppercase p) `isPrefixOf` (uppercase s)++lookupS ∷ String → [(String,a)] → Maybe a+lookupS _ [] = Nothing+lookupS k ((k',v):other) | k `isPrefixOfI` k' = Just v+                         | otherwise          = lookupS k other++monthsN ∷ [(String,Int)]+monthsN = zip months [1..]++lookupMonth ∷ String → Maybe Int+lookupMonth n = lookupS n monthsN++date ∷  Int → Int → Int → DateTime+date y m d = DateTime y m d 0 0 0++addTime ∷  DateTime → Time → DateTime+addTime dt t = dt {+                 hour = tHour t + hour dt,+                 minute = tMinute t + minute dt,+                 second = tSecond t + second dt }++times ∷ Int → TParser t → TParser [t]+times 0 _ = return []+times n p = do+  ts ← times (n-1) p+  t ← optionMaybe p+  case t of+    Just t' → return (ts ++ [t'])+    Nothing → return ts+                               +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 ∷ TParser Int+pYear = do+  y ← number 4 10000+  if y < 2000+    then return (y+2000)+    else return y++pMonth ∷ TParser Int+pMonth = number 2 12++pDay ∷ TParser Int+pDay = number 2 31++euroNumDate ∷ TParser DateTime+euroNumDate = do+  d ← pDay+  char '.'+  m ← pMonth+  char '.'+  y ← pYear+  return $ date y m d++americanDate ∷ TParser DateTime+americanDate = do+  y ← pYear+  char '/'+  m ← pMonth+  char '/'+  d ← pDay+  return $ date y m d++euroNumDate' ∷ Int → TParser DateTime+euroNumDate' year = do+  d ← pDay+  char '.'+  m ← pMonth+  return $ date year m d++americanDate' ∷ Int → TParser DateTime+americanDate' year = do+  m ← pMonth+  char '/'+  d ← pDay+  return $ date year m d++strDate ∷ TParser DateTime+strDate = do+  d ← pDay+  space+  ms ← many1 letter+  case lookupMonth ms of+    Nothing → fail $ "unknown month: "++ms+    Just m  → do+      space+      y ← pYear+      notFollowedBy $ char ':'+      return $ date y m d++strDate' ∷ Int → TParser DateTime+strDate' year = do+  d ← pDay+  space+  ms ← many1 letter+  case lookupMonth ms of+    Nothing → fail $ "unknown month: "++ms+    Just m  → return $ date year m d++time24 ∷ TParser Time+time24 = do+  h ← number 2 23+  char ':'+  m ← number 2 59+  x ← optionMaybe $ char ':'+  case x of+    Nothing → return $ Time h m 0+    Just _ → do+      s ← number 2 59+      notFollowedBy letter+      return $ Time h m s++ampm ∷ TParser Int+ampm = do+  s ← many1 letter+  case map toUpper s of+    "AM" → return 0+    "PM" → return 12+    _ → fail "AM/PM expected"++time12 ∷ TParser Time+time12 = do+  h ← number 2 12+  char ':'+  m ← number 2 59+  x ← optionMaybe $ char ':'+  s ← case x of+            Nothing → return 0+            Just s' → number 2 59+  optional space+  hd ← ampm+  return $ Time (h+hd) m s++pAbsDate ∷ Int → TParser DateTime+pAbsDate year = do+  date ← choice $ map try $ map ($ year) $ [+                              const euroNumDate,+                              const americanDate,+                              const strDate,+                              strDate',+                              euroNumDate',+                              americanDate']+  optional $ char ','+  s ← optionMaybe space+  case s of+    Nothing → return date+    Just _ → do+      t ← choice $ map try [time12,time24]+      return $ date `addTime` t++data DateIntervalType = Day | Week | Month | Year+  deriving (Eq,Show,Read)++data DateInterval = Days ℤ+                  | Weeks ℤ+                  | Months ℤ+                  | Years ℤ+  deriving (Eq,Show)++convertTo ∷  DateTime → Day+convertTo dt = fromGregorian (fromIntegral $ year dt) (month dt) (day dt)++convertFrom ∷  Day → DateTime+convertFrom dt = +  let (y,m,d) = toGregorian dt+  in  date (fromIntegral y) m d++modifyDate ∷  (t → Day → Day) → t → DateTime → DateTime+modifyDate fn x dt = convertFrom $ fn x $ convertTo dt++addInterval ∷  DateTime → DateInterval → DateTime+addInterval dt (Days ds) = modifyDate addDays ds dt+addInterval dt (Weeks ws) = modifyDate addDays (ws*7) dt+addInterval dt (Months ms) = modifyDate addGregorianMonthsClip ms dt+addInterval dt (Years ys) = modifyDate addGregorianYearsClip ys dt++maybePlural ∷ String → TParser String+maybePlural str = do+  r ← string str+  optional $ char 's'+  return (capitalize r)++pDateInterval ∷ TParser DateIntervalType+pDateInterval = do+  s ← choice $ map maybePlural ["day", "week", "month", "year"]+  return $ read s++pRelDate ∷ DateTime → TParser DateTime+pRelDate date = do+  offs ← (try futureDate) <|> (try passDate) <|> (try today) <|> (try tomorrow) <|> yesterday+  return $ date `addInterval` offs++futureDate ∷ TParser DateInterval+futureDate = do+  string "in "+  n ← many1 digit+  char ' '+  tp ← pDateInterval+  case tp of+    Day →   return $ Days (read n)+    Week →  return $ Weeks (read n)+    Month → return $ Months (read n)+    Year →  return $ Years (read n)++passDate ∷ TParser DateInterval+passDate = do+  n ← many1 digit+  char ' '+  tp ← pDateInterval+  string " ago"+  case tp of+    Day →   return $ Days $ - (read n)+    Week →  return $ Weeks $ - (read n)+    Month → return $ Months $ - (read n)+    Year →  return $ Years $ - (read n)++today ∷ TParser DateInterval+today = do+  string "today"+  return $ Days 0++tomorrow ∷ TParser DateInterval+tomorrow = do+  string "tomorrow"+  return $ Days 1++yesterday ∷ TParser DateInterval+yesterday = do+  string "yesterday"+  return $ Days (-1)++pDate ∷ DateTime → TParser DateTime+pDate date =  (try $ pRelDate date) <|> (try $ pAbsDate $ year date)++dateType ∷ String → DateType+dateType "start" = StartDate+dateType "end"   = EndDate+dateType "deadline" = Deadline+dateType _ = error "unknown date type"++-- | Parse date/time with date type+pSpecDate ∷ DateTime → TParser (DateType, DateTime)+pSpecDate date = do+  tp ← choice $ map string ["start","end","deadline"]+  string ": "+  dt ← pDate date+  return (dateType tp, dt)++-- | Parse set of dates with types (in parenthesis)+pSpecDates ∷ DateTime → TParser [(DateType, DateTime)]+pSpecDates date = do+  char '('+  pairs ← (pSpecDate date) `sepBy1` (string "; ")+  string ") "+  return pairs++-- | Parse date/time+parseDate ∷ BaseConfig+          → DateTime  -- ^ Current date/time+          → String    -- ^ String to parse+          → Either ParseError DateTime+parseDate conf date s = runParser (pDate date) conf "" s+
+ Todos/Dot.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE UnicodeSyntax, TypeSynonymInstances, FlexibleInstances #-}+module Todos.Dot+  (showAsDot)+  where++import Data.List+import Data.Tree+import Text.Printf++import Todos.Unicode+import Todos.Types+import Todos.Color+import Todos.Shapes++data Dot = Dot {+  dotVertices ∷ [TodoItem],+  dotEdges ∷ [(TodoItem, TodoItem)],+  dotSubgraphs ∷ [Subgraph]+  }++data Subgraph = Subgraph {+  subLabel ∷ String,+  subItems ∷ [TodoItem] }+  deriving (Eq)++toDot ∷ Todo → Dot+toDot todo = Dot (getVertices todo) (getEdges todo) (getSubgraphs todo)++getVertices ∷ Todo → [TodoItem]+getVertices (Node item forest) +  | itemStatus item == "GROUP" = concatMap getVertices forest+  | otherwise = [item] ⧺ concatMap getVertices forest++getEdges ∷ Todo → [(TodoItem, TodoItem)]+getEdges (Node item forest) +  | itemStatus item == "GROUP" = concatMap getEdges forest+  | otherwise = [(item, rootLabel child) | child ← forest] ⧺ concatMap getEdges forest++getSubgraphs ∷ Todo → [Subgraph]+getSubgraphs (Node item forest)+  | itemStatus item == "GROUP" = Subgraph (showItem item) (nub $ sort $ concatMap flattern forest) :+                                  concatMap getSubgraphs forest+  | otherwise = []+  where +    showItem item = showTags item ⧺ itemName item ⧺ "\\n" ⧺ itemDescr item+    showTags item | null (itemTags item) = ""+                  | otherwise = "[" ⧺ unwords (itemTags item) ⧺ "] "+    flattern (Node item children) = item: concatMap flattern children++instance Show Dot where+  show (Dot vs es subs) = "digraph Todo {\n"+                   ⧺ unlines (map (showDotNode getColor getShape) vs)+                   ⧺ unlines (map showDotEdge es)+                   ⧺ unlines (map showSubgraph subs)+                   ⧺ "}\n"++showD ∷ (TodoItem → HSV) → (TodoItem → Shape) → [Dot] → String+showD colorFn shapeFn dots+            = "digraph Todo {\n"+            ⧺ "  rankdir = \"RL\";\n"+            ⧺ "  node [shape=\"box\", style=\"filled\"];\n"+            ⧺ unlines (map (showDotNode colorFn shapeFn) $ nub $ sort $ concatMap dotVertices dots)+            ⧺ unlines (map showDotEdge $ nub $ sort $ concatMap dotEdges dots)+            ⧺ unlines (map showSubgraph $ nub $ concatMap dotSubgraphs dots)+            ⧺ "}\n"++makeName ∷ TodoItem → String+makeName item = "\"" ⧺ makeId item ⧺ "\""++showDotNode ∷ (TodoItem → HSV) → (TodoItem → Shape) → TodoItem → String+showDotNode colorFn shapeFn item =+  printf "  %s [label=\"%s\\n%s\\n%s\", fillcolor=%s, shape=\"%s\"];" (makeName item) (itemStatus item) (unwords $ itemTags item) (itemName item) (show $ colorFn item) (show $ shapeFn item)++showDotEdge ∷ (TodoItem, TodoItem) → String+showDotEdge (x,y) +  | itemStatus x == "GROUP" = ""+  | otherwise               = printf "  %s -> %s;" (makeName y) (makeName x)++showSubgraph ∷ Subgraph → String+showSubgraph (Subgraph label items) +  | null items = ""+  | otherwise = "  subgraph \"cluster_" ⧺ makeId label ⧺ "\" {\n" +              ⧺ "    label=\"" ⧺ label ⧺ "\";\n"+              ⧺ (unlines $ map ("    " ⧺) $ map showItem items)+              ⧺ "\n  }"+  where+    showItem item = makeName item ⧺ ";"++-- | Return DOT output for Todos+showAsDot ∷ (TodoItem → HSV)   -- ^ Function to determine node color+          → (TodoItem → Shape) -- ^ Function to determine node shape+          → [Todo]             -- ^ Todo list+          → String+showAsDot colorFn shapeFn todos = (showD colorFn shapeFn) (map toDot todos)+
+ Todos/Formatters.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE UnicodeSyntax, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables #-}+module Todos.Formatters +  (OutItem (..),+   Formatter,+   outItem,+   startFormat, newLine,+   ConfigShow (..),+   ConfigAdd (..)+  ) where++import Control.Monad+import Control.Monad.Reader+import System.Console.ANSI++import Todos.Unicode+import Todos.Types+import Todos.Config+import Todos.ConfigInstances ()++-- | Item which could be printed to the console+data OutItem = OutString String+             | OutSetColor ColorIntensity Color+             | SetBold+             | ResetAll+    deriving (Show)++-- | Produce a list of OutItem's depending on PrintConfig+type Formatter c = Reader (PrintConfig c) [OutItem]++-- | Empty Formatter+startFormat ∷ Formatter c+startFormat = return []++-- | Output given string+outString ∷ String → Formatter c+outString s = return [OutString s]++-- | Output new line+newLine ∷ Formatter c+newLine = outString "\n"++class ConfigAdd c a where+  -- | Execute Formatter and a consequently+  (<++>) ∷ Formatter c → a → Formatter c++instance ConfigAdd c (Formatter c) where+  (<++>) = liftM2 (⧺)++instance ConfigAdd c String where+  cm <++> s = cm <++> ((return [OutString s]) ∷ Formatter c)++setBold ∷  IO ()+setBold = setSGR [SetConsoleIntensity BoldIntensity]++setColor ∷ ColorIntensity → Color → IO ()+setColor int clr = setSGR [SetColor Foreground int clr]++-- | Reset all (color, bold, ...) attributes+reset ∷  IO ()+reset = setSGR []++-- | Print OutItem to console+outItem ∷  OutItem → IO ()+outItem (OutString s)   = putStr s+outItem (OutSetColor i c) = setColor i c+outItem SetBold         = setBold+outItem ResetAll        = reset++-- | Similar to Show, but output can depend on PrintConfig+class ConfigShow c s where+  configShow ∷ s → Formatter c++instance ConfigShow c String where+  configShow s = return [OutString s]++instance ConfigShow c (Formatter c) where+  configShow = id+  +-- | Output bold (and maybe colored) item name+bold ∷ (RuntimeConfig c) ⇒ TodoItem → Formatter c+bold item = do+  let s = itemName item+  showColors ← askBase outColors+  hlOn ← askBase outHighlight+  getclr ← asks printItemColor+  hlPred ← asks doHighlight+  (hlInt, hlClr) ← asks printHighlightColor+  return $ if showColors+              then if hlOn && hlPred item+                     then [SetBold, OutSetColor hlInt hlClr, OutString s, ResetAll]+                     else case getclr item of+                           Nothing        → [SetBold, OutString s, ResetAll]+                           Just (int,clr) → [SetBold, OutSetColor int clr, OutString s, ResetAll]+              else [OutString s]++-- | Output colored item status+colorStatus ∷ (RuntimeConfig c) ⇒ String → Formatter c+colorStatus st = do+  getclr ← asks printStatusColor+  let (int, clr) = getclr st+  col ← askBase outColors+  if col+    then return [OutSetColor int clr, OutString st, ResetAll]+    else return [OutString st]++instance (RuntimeConfig c) ⇒ ConfigShow c TodoItem where+    configShow item = sf <++> (colorStatus s ∷ Formatter c) <++> " " <++> dates <++> tags <++> title <++> (if null descr then "" else "    "⧺descr)+      where+        sf ∷ Formatter c+        sf = startFormat+        ts = filter (not ∘ null) $ itemTags item+        s = itemStatus item+        descr = itemDescr item+        dates | null dates' = ""+              | otherwise = "(" ⧺ dates' ⧺ ") "+        dates' = showDates [StartDate `is` startDate item, EndDate `is` endDate item, Deadline `is` deadline item]+        tags = if null ts+                 then ""+                 else "[" ⧺ (unwords ts) ⧺ "] "+        title ∷ Formatter c+        title = bold item+
+ Todos/IO.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}+-- | Wrapper to support unicode IO with GHC 6.10 and 6.12+module Todos.IO +  (putStr, putStrLn,readFile,getContents,print,+   encodeString, decodeString)+  where++import Codec.Binary.UTF8.String (encodeString, decodeString)++#if __GLASGOW_HASKELL__ < 612++import Prelude hiding (putStr, putStrLn,readFile,getContents,print)+import System.IO.UTF8++#else++import Prelude++#endif
+ Todos/Loader.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE UnicodeSyntax, PatternGuards #-}+-- | Read TODOs from files and construct corresponding ADTs.+module Todos.Loader+  (loadTodo)+  where++import Prelude hiding (putStrLn,readFile,getContents,print)+import Todos.IO+import Control.Monad (forM)+import qualified Data.Map as M+import System.FilePath+import Data.Maybe+import Data.Tree+import Data.List (nub, sort)++import Todos.Unicode+import Todos.Types+import Todos.Config+import Todos.Parser++todoName ∷ Todo → String+todoName todo = itemName ⋄ rootLabel todo++getDepends ∷ TodoMap → TodoItem → [Todo]+getDepends m item = catMaybes [M.lookup name m | name ← depends item] ++normalizeItem ∷ TodoMap → TodoItem → Todo+normalizeItem m item = Node item (map (normalize m) ⋄ getDepends m item)++normalize ∷ TodoMap → Todo → Todo +normalize m todo = Node item' ((map (normalize m) subTodos) ⧺ (map (normalize m) deps))+  where+    item ∷ TodoItem+    item = rootLabel todo++    item' ∷ TodoItem+    item' = item {depends=[]}++    subTodos ∷ [Todo]+    subTodos = subForest todo++    deps ∷ [Todo]+    deps = getDepends m item++normalizeList ∷ TodoMap → [Todo] → [Todo]+normalizeList m todos = map (normalize m) todos++-- | Almost same that readFile, but also works for special "-" file (stdin)+readFile' ∷ FilePath → IO String+readFile' "-"  = getContents+readFile' file = readFile file++-- | Load items from given file+loadFile ∷ BaseConfig+         → DateTime       -- ^ Current date/time+         → FilePath       -- ^ Path to file+         → 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++-- | Decrease item level+(~-) ∷  TodoItem → ℤ → TodoItem+i@(Item {itemLevel=n}) ~- k = i {itemLevel=n-k}++-- | Increase item level+(~+) ∷  TodoItem → ℤ → TodoItem+i@(Item {itemLevel=n}) ~+ k = i {itemLevel=n+k}++-- | Check if item level is 0+iszero ∷  TodoItem → 𝔹+iszero item = (itemLevel item)==0++group' ∷  [TodoItem] → [[TodoItem]]+group' [] = []+group' (x:xs) = let (one,other) = break iszero xs+                in (x:one):group' other++mkTodo ∷ [TodoItem] → [Todo]+mkTodo = (map mkTodo') ∘ group'++mkTodo' ∷ [TodoItem] → Todo+mkTodo' [] = error "Internal error: mkTodo' does not sense for empty list!"+mkTodo' (x:xs) = Node x other+    where other = mkTodo ⋄ map (~-lvl) xs+          lvl = itemLevel (head xs)+          +consTodoMap ∷ [Todo] → TodoMap+consTodoMap todos = M.fromList (cons1 100 todos)+  where+    cons1 ∷ Int → [Todo] → [(String,Todo)]+    cons1 0 _ = []+    cons1 max trees = [(todoName todo, todo) | todo ← trees] ⧺ cons1 (max-1) (children trees)+    children ∷ [Todo] → [Todo]+    children trees = concatMap subForest trees++stitchTodos ∷ [TodoItem] → [Todo]+stitchTodos items = +  let m = consTodoMap t+      t = mkTodo items+  in  normalizeList m t++-- | Get all (different) tags from Todo list+allTags ∷ [Todo] → [String]+allTags todos = nub $ sort $ concatMap getTags todos+  where+    getTags (Node item children) = itemTags item ⧺ concatMap getTags children++-- | Get all (different) statuses from Todo list+allStatuses ∷ [Todo] → [String]+allStatuses todos = nub $ sort $ concatMap getStatus todos+  where+    getStatus (Node item children) = itemStatus item: concatMap getStatus children++grepBy ∷ (TodoItem → 𝔹) → [Todo] → [Todo]+grepBy cond todos = concatMap grep todos+  where+    grep ∷ Todo → [Todo]+    grep n@(Node _ children) = test n ⧺ concatMap grep children++    test ∷ Todo → [Todo]+    test n@(Node item _)+      | cond item = [n]+      | otherwise = []++grepByTag ∷ String → [Todo] → [Todo]+grepByTag tag todos = grepBy (\item → tag ∈ itemTags item) todos++grepByStatus ∷ String → [Todo] → [Todo]+grepByStatus st todos = grepBy (\item → st == itemStatus item) todos++tagTodo ∷ String → [Todo] → Todo+tagTodo tag todos = Node item $ grepByTag tag todos+  where+    item = Item {+      itemLevel = 0,+      itemName = tag,+      itemTags = ["TAG"],+      depends = [],+      itemStatus = ":",+      itemDescr = "",+      startDate = Nothing,+      endDate = Nothing,+      deadline = Nothing,+      fileName = "(no file)",+      lineNr = 0 }++groupByTag' ∷ [Todo] → [Todo]+groupByTag' todos = +  map (\t → tagTodo t todos) (allTags todos) ⧺ todos++statusTodo ∷ String → [Todo] → Todo+statusTodo st todos = Node item $ grepByStatus st todos+  where+    item = Item {+      itemLevel = 0,+      itemName = st,+      itemTags = ["STATUS"],+      depends = [],+      itemStatus = ":",+      itemDescr = "",+      startDate = Nothing,+      endDate = Nothing,+      deadline = Nothing,+      fileName = "(no file)",+      lineNr = 0 }++groupByStatus' ∷ [Todo] → [Todo]+groupByStatus' todos =+  map (\s → statusTodo s todos) (allStatuses todos) ⧺ todos++dirname ∷ FilePath → FilePath+dirname path =+  case dropFileName path of+    [] → []+    dir → takeFileName (init dir)++fileTodo ∷ FilePath → TodoItem+fileTodo path = Item {+  itemLevel = 0,+  itemName = takeFileName path,+  itemTags = [dirname path],+  depends = [],+  itemStatus = ":",+  itemDescr = path,+  startDate = Nothing,+  endDate = Nothing,+  deadline = Nothing,+  fileName = path,+  lineNr = 0 }++todosGroup ∷ FilePath → [TodoItem] -> [TodoItem]+todosGroup path items =+  if null items+    then []+    else fileTodo path: map (~+ 1) items++changeTopStatus ∷ Maybe String → [Todo] → [Todo]+changeTopStatus Nothing   todos = todos+changeTopStatus (Just st) todos = map setStatus todos+  where+    setStatus (Node item children) = Node (item {itemStatus = st}) children++-- | Load list of TODO trees from files+loadTodo ∷ BaseConfig+         → DateTime      -- ^ Current date/time+         → [FilePath]    -- ^ List of files+         → IO [Todo]+loadTodo conf date paths = do+    let grp = if groupByFile conf+                then todosGroup+                else const id+    tss ← forM paths $ \path → grp path `fmap` loadFile conf date path+    let todos = stitchTodos (concat tss)+        byTag = if groupByTag conf+                  then groupByTag' todos+                  else todos+        byStatus = if groupByStatus conf+                     then groupByStatus' byTag+                     else byTag+    return $ changeTopStatus (topStatus conf) byStatus+
+ Todos/Main.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE UnicodeSyntax #-}++module Todos.Main (todos) where++import Prelude hiding (putStrLn,readFile,getContents,print)+import IO+import Data.Tree+import System.Exit+import System.Cmd (system)++import System.Environment+import Config.Dyre++import Todos.Types+import Todos.Unicode+import Todos.Dates+import Todos.Dot+import Todos.CmdLine+import Todos.Tree+import Todos.ReadConfig+import Todos.Loader+import Todos.CommandParser+import Todos.Config+import Todos.ConfigUtils++realTodos ∷ (RuntimeConfig c) ⇒ TodosConfig c → IO ()+realTodos tcfg = do+  currDate ← getCurrentDateTime +  config ← readConfig+  args ← getArgs+  let pres = (parseCommandLine tcfg) currDate (nullConfig tcfg) (config ⧺ args)+  case pres of+    Parsed q files' → do+      let bc = toBaseConfig q+      files ← glob files'+      todos ← loadTodo bc currDate files+      let queried  = (filterTodos tcfg) currDate q todos+          format item = item {itemDescr = printfItem (descrFormat bc) item}+      case commandToRun bc of+        JustShow  → printTodos tcfg (mkPrintConfig currDate q tcfg) (mapT format queried)+        ShowAsDot → +             putStrLn $ showAsDot (itemColor tcfg) (itemShape tcfg) (mapT format queried)+        SystemCommand cmd → do+             forT selected (\item → system $ printfItem cmd (format item))+             return ()+          where selected | outOnlyFirst bc = [Node (rootLabel $ head queried) []]+                         | otherwise       = queried++    ParseError str → error str+    CmdLineHelp → do putStrLn usage+                     exitWith ExitSuccess++-- | Main function to run. User can specify TodosConfig with any runtime config+-- type. By default (in todos.hs) defaultConfig is used, which uses DefaultConfig type.+todos ∷ (RuntimeConfig c) ⇒ TodosConfig c → IO ()+todos = wrapMain $ defaultParams {+    projectName = "todos",+    realMain    = realTodos,+    statusOut   = const (return ())+    }+
+ Todos/Parser.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE UnicodeSyntax, NoMonomorphismRestriction, TypeSynonymInstances, DeriveDataTypeable #-}+module Todos.Parser+    (parsePlain, parseAlternate)+    where++import Prelude hiding (putStrLn,readFile,getContents,print)+import Data.List+import Text.ParserCombinators.Parsec+import Data.Char++import Todos.Unicode+import Todos.Types+import Todos.Dates+import Todos.ParserTypes+import Todos.Config++strip ∷  String → String+strip = reverse ∘ p ∘ reverse ∘ p+  where+    p = dropWhile isSpace++pSpace ∷ TParser Char+pSpace = oneOf " \t"++pSpace' ∷ TParser String+pSpace' = do+    pSpace+    return " "++pSpaces ∷ TParser String+pSpaces = many pSpace++pDeps ∷ TParser [String]+pDeps = do+    string "("+    ws ← (many1 ⋄ noneOf ",)\n\r") `sepBy` (char ',')+    string ")"+    return $ map strip ws++pTags ∷ TParser [String]+pTags = do+    ts ← between (char '[') (char ']') $ word `sepBy1` pSpace+    pSpaces+    return ts+  where+    word = many1 (noneOf " \t\n\r]")++pItem ∷ DateTime → TParser TodoItem+pItem date = do+    pos ← getPosition+    s ← pSpaces+    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+    pSpaces+    deps ← (try pDeps <|> return [])+    pSpaces+    descr ← many (noneOf "\n\r")+    pSpaces+    many ⋄ oneOf "\n\r"+    return ⋄ Item {+        itemLevel = fromIntegral $ length s,+        itemName = unwords namew,+        itemTags = tags,+        depends = deps,+        itemStatus = stat,+        itemDescr = descr,+        startDate = lookup StartDate dates,+        endDate = lookup EndDate dates,+        deadline = lookup Deadline dates,+        fileName = sourceName pos,+        lineNr = sourceLine pos }++pWord ∷ TParser String+pWord = do+    w ← many1 (noneOf " \t\n\r")+    (try pSpace') <|> (return w)+    return w++pItems ∷ DateTime → TParser [TodoItem]+pItems date = do+  its ← many (pItem date)+  eof+  return its++unwords' ∷  String → [String] → String+unwords' prefix lst =+  let (hd:tl) = map (filter (/='\r')) lst+      addLines = filter (not ∘ (prefix `isPrefixOf`)) tl+  in  case addLines of+        [] → hd+        _  → hd ⧺ "    {" ++ (unwords addLines) ++ "}"++filterN ∷ (Num a, Enum a) ⇒ Int → String → [String] → ([a], [String])+filterN n prefix lst = +  let zipped = zip [0..] lst+      good   = filter (isGood ∘ snd) zipped+      lns    = map fst good+      sub k l = (take l) ∘ (drop k)+      ans = map (unwords' prefix) [sub j n lst | j ← lns]+      isGood x = prefix `isPrefixOf` x+      cut = drop (1+length prefix) +  in (map (+1) lns, map cut ans)++filterJoin ∷ Int → String → String → ([Int], String)+filterJoin n prefix str = +  let (ns, lns) = filterN n prefix (lines str)+  in  (ns, unlines lns)++-- | Read list of TODO items from plain format +parsePlain ∷ BaseConfig+           → DateTime   -- ^ Current date/time+           → SourceName -- ^ Source file name+           → String     -- ^ String to parse+           → [TodoItem]+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 ∷ BaseConfig +               → Int        -- ^ Number of lines 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 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 runParser (pItems date) conf path filtered of+       Right items → renumber items+       Left e      → error $ show e+
+ Todos/ParserTypes.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE UnicodeSyntax #-}+module Todos.ParserTypes where++import Text.ParserCombinators.Parsec++import Todos.Config+++type TParser a = GenParser Char BaseConfig a+
+ Todos/Print.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE UnicodeSyntax #-}+module Todos.Print+  (defaultPrintTodos, showTodos)+  where++import Control.Monad+import Control.Monad.Reader+import Data.List+import Data.Tree+import Data.Function (on)+import System.Console.ANSI++import Todos.Unicode+import Todos.Types+import Todos.Config+import Todos.ConfigInstances ()+import Todos.Formatters++sortBy' ∷ SortingType → [Todo] → [Todo]+sortBy' s | s == DoNotSort = id+          | otherwise = sortBy sorter+  where+    sorter = compare `on` (f ∘ rootLabel)+    f = case s of+          DoNotSort → error "Internal error: sortBy' should not be called when DoNotSort is specified!"+          ByTitle → itemName+          ByStatus → itemStatus+          ByTags → unwords ∘ itemTags+          ByStartDate → show ∘ startDate+          ByEndDate → show ∘ endDate+          ByDeadline → show ∘ deadline ++showT ∷ SortingType → Int → Todo → [Formatter DefaultConfig]+showT s n (Node item todos) = +    (sf <++> showId item <++> replicate n ' ' <++> item') :+      (concatMap (showT s (n+2)) $ sortBy' s todos)+  where+    sf ∷ Formatter DefaultConfig+    sf = startFormat++    item' ∷ Formatter DefaultConfig+    item' = configShow item++    showId :: TodoItem → Formatter DefaultConfig+    showId item = do+      s ← askBase outIds+      c ← askBase outColors+      if s+        then if c +               then return [OutSetColor Dull Yellow, OutString $ makeId item ++ " ", ResetAll]+               else return [OutString $ makeId item ++ " "]+        else return [OutString ""]++unlines'' ∷ [Formatter c] → Formatter c+unlines'' lst = concat `fmap` (sequence $ intersperse newLine lst)++showTodo ∷ Todo → Formatter DefaultConfig+showTodo t = do+  conf ← asks toBaseConfig+  let f = case outOnlyFirst conf of+            False → unlines''+            True  → head+  f $ showT (sorting conf) 0 t++-- | Prepare TODOs for console output+showTodos ∷ [Todo] → Formatter DefaultConfig+showTodos lst = do+  conf ← asks toBaseConfig+  let f = case outOnlyFirst conf of+            False → unlines''+            True  → head+  f $ map showTodo $ sortBy' (sorting conf) $ nub lst++-- | Default function to output TODOs to console+defaultPrintTodos ∷ PrintConfig DefaultConfig → [Todo] → IO ()+defaultPrintTodos cfg lst = +  let lst' = runReader (showTodos lst) cfg+  in  forM lst' outItem >> putStrLn ""+
+ Todos/ReadConfig.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE UnicodeSyntax #-}++-- | Module for parsing config files+module Todos.ReadConfig+  (readConfig)+  where++import Prelude hiding (putStrLn,readFile,getContents,print)+import Todos.IO+import System.Environment+import System.FilePath +import System.Directory (doesFileExist)+import Text.ParserCombinators.Parsec++import Todos.Unicode++word ∷ Parser String+word = choice $ map try [quotedOption, simpleOption, quoted, simpleWord]++simpleWord = many1 $ noneOf " \t\r\n=\"'"++quotedOption = (try quotedLongOption) <|> quotedShortOption++quotedLongOption ∷ Parser String+quotedLongOption = do+  string "--"+  o ← simpleWord+  char '='+  v ← quoted+  return ("--" ⧺ o ⧺ "=" ⧺ v)++quotedShortOption ∷ Parser String+quotedShortOption = do+  string "-"+  o ← simpleWord+  v ← quoted+  return ("-" ⧺ o ⧺ v)++simpleOption = do+  o ← simpleWord+  optional $ char '='+  v ← simpleWord+  return (o ⧺ "=" ⧺ v)++quoted = quoted1 <|> quoted2++quoted1 = do+  char '\''+  s ← many1 $ noneOf "'"+  char '\''+  return s++quoted2 = do+  char '"'+  s ← many1 $ noneOf "\""+  char '"'+  return s++pConfig ∷ Parser [String]+pConfig = word `sepBy` space++parseConfig ∷ String → [String]+parseConfig str = +  case parse pConfig "config file" str of+    Right lst → lst+    Left err → error $ show err++readFile' ∷ FilePath → IO [String]+readFile' path = +  do b ← doesFileExist path+     if not b+       then return []+       else do+              str ← readFile path+              return $ parseConfig (unwords $ lines str)++-- | Read list of options from config files+readConfig ∷ IO [String]+readConfig = do+  home ← getEnv "HOME"+  let homepath = home </> ".config" </> "todos" </> "todos.conf"+  homecfg ← readFile' homepath+  localcfg ← readFile' ".todos.conf"+  return $ homecfg ⧺ localcfg+
+ Todos/Shapes.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE UnicodeSyntax #-}+module Todos.Shapes where++import qualified Data.Map as M++import Todos.Types++-- | Supported node shapes for DOT output+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"++-- | Node shapes for some common item statuses+shapes ∷ M.Map String Shape+shapes = M.fromList $ [+  ("o", Ellipse),+  ("O", DCircle),+  (":", Folder),+  ("*", Diamond),+  ("/", Parallelogram),+  ("NOTE", Note) ]++-- | Get item shape for this item (default funciton)+getShape ∷ TodoItem → Shape+getShape item = +  case M.lookup (itemStatus item) shapes of+    Nothing → Box+    Just s  → s+
+ Todos/Tree.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE UnicodeSyntax, NoMonomorphismRestriction, FlexibleInstances, TypeSynonymInstances #-}+module Todos.Tree +  (delTag,+   pruneSelector,+   tagPred, statusPred, grepPred, descPred, datePred, idPred,+   forT, mapT)+  where++import Prelude hiding (putStrLn,readFile,getContents,print)+import Control.Monad+import Data.Generics+import Data.List+import Data.Tree+import Text.Regex.PCRE++import Todos.Types+import Todos.Unicode+import Todos.Config++mapTags ∷  (Data a) ⇒ ([String] → [String]) → [a] → [a]+mapTags f = map ⋄ everywhere ⋄ mkT changeTags+  where+    changeTags item@(Item {itemTags=ts}) = item {itemTags = f ts}+        +addTag ∷  (Data a) ⇒ String → [a] → [a]+addTag t = mapTags (t:)++delTag ∷  (Data a) ⇒ String → [a] → [a]+delTag t = mapTags (delete t)++pruneSelector ∷  BaseConfig → (TodoItem → 𝔹) → (Todo → [Todo])+pruneSelector bc pred =+  let Limit n = pruneL bc+      Limit m = minL   bc+  in  pruneSelector' n m pred+        +pruneSelector' ∷ ℤ → ℤ → (TodoItem → 𝔹) → (Todo → [Todo])+pruneSelector' n m pred = select n 0 False+    where+        select k t b (Node item trees) | t < m       = [Node item ⋄ concatMap (select (n-1) (t+1) True) trees]+                                       | pred item   = [Node item ⋄ concatMap (select (n-1) (t+1) True) trees]+                                       | (k > 0) ∧ b = [Node item ⋄ concatMap (select (k-1) (t+1) True) trees]+                                       | k > 0       = concatMap (select (k-1) (t+1) False) trees+                                       | otherwise   = []                                               ++addS ∷  (Show a) ⇒ a → TodoItem → TodoItem+addS s item@(Item {itemName=name}) = item {itemName = name ⧺ " — " ⧺ show s}++-- | Check if item has given tag+tagPred ∷  String → TodoItem → 𝔹+tagPred tag = \item → tag ∈ itemTags item++-- | Check if item has given status+statusPred ∷  String → TodoItem → 𝔹+statusPred st = \item → st == itemStatus item+        +-- | Check if item's title matches to given regexp+grepPred ∷ String → TodoItem → 𝔹+grepPred pattern = \item → itemName item =~ pattern++-- | Check if item's description matches to given regexp+descPred ∷ String → TodoItem → 𝔹+descPred pattern = \item → itemDescr item =~ pattern++-- | Check if item has given ID+idPred :: String → TodoItem → 𝔹+idPred hash = \item → makeId item == hash++isLT ∷  (Ord t) ⇒ Maybe t → t → 𝔹+isLT Nothing _ = False+isLT (Just x) y = x <= y++isGT ∷  (Ord t) ⇒ Maybe t → t → 𝔹+isGT Nothing _ = False+isGT (Just x) y = x >= y++datePred ∷  (Ord a) ⇒ (t → Maybe a) → a → a → t → 𝔹+datePred selector curr dt | dt >= curr = \item → selector item `isLT` dt+                          | otherwise  = \item → selector item `isGT` dt++-- | Flattern the tree+flattern ∷ [Todo] → [Todo]+flattern = concatMap flat+    where+        flat ∷ Todo → [Todo]+        flat (Node item trees) = (Node item []):(concatMap flat trees)++-- | For each item in the tree, execute given monadic action (this is similar+-- to forM, but for trees instead of lists).+forT ∷ (Monad m, Eq t) ⇒ [Tree t] → (t → m a) → m [b]+forT todos f = forM (nub todos) forT'+  where+    forT' (Node item trees) =+      do f item+         res ← forM trees forT'+         return $ last res++-- | Similar to map, but for trees instead of lists.+mapT ∷ (t → t) → [Tree t] → [Tree t]+mapT f todos = map mapT' todos+  where+    mapT' (Node item trees) = Node (f item) (mapT f trees)+
+ Todos/Types.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE UnicodeSyntax, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, NoMonomorphismRestriction #-}++module Todos.Types where++import Prelude hiding (putStr, putStrLn,readFile,getContents,print)+import Data.Hash++import Data.Function +import Data.Generics hiding (GT)+import Data.Char (toUpper)+import Data.Maybe+import Data.Tree+import Data.List+import qualified Data.Map as M+import Text.ParserCombinators.Parsec+import Numeric++import Todos.Unicode++-- | Kind of date+data DateType = StartDate+              | EndDate+              | Deadline+  deriving (Eq)++instance Show DateType where+  show StartDate = "start"+  show EndDate = "end"+  show Deadline = "deadline"++data DateTime =+  DateTime {+    year ∷ Int,+    month ∷ Int,+    day ∷ Int,+    hour ∷ Int,+    minute ∷ Int,+    second ∷ Int }+  deriving (Eq,Ord,Data,Typeable)++-- | 12 months names.+months ∷ [String]+months = ["january",+          "february",+          "march",+          "april",+          "may",+          "june",+          "july",+          "august",+          "september",+          "october",+          "november",+          "december"]++-- | capitalize first letter of the string+capitalize ∷ String → String+capitalize [] = []+capitalize (x:xs) = (toUpper x):xs++-- | Show name of given month+showMonth ∷  Int → String+showMonth i = capitalize $ months !! (i-1)++instance Show DateTime where+  show (DateTime y m d h min s) = +    show d ⧺ " " ⧺ showMonth m ⧺ " " ⧺ show y ⧺ ", " ⧺+      show h ⧺ ":" ⧺ show min ⧺ ":" ⧺ show s++-- | Only time, without date+data Time = +  Time {+    tHour ∷ Int,+    tMinute ∷ Int,+    tSecond ∷ Int }+  deriving (Eq,Ord,Show,Data,Typeable)++-- | TODO item itself.+data TodoItem = Item {+    itemLevel ∷ ℤ,               -- ^ Indentation level (from source file)+    itemName ∷ String,           -- ^ Name (title) of the item+    itemTags ∷ [String],         -- ^ Tags of the item+    depends ∷ [String],          -- ^ Names (titles) of item's depends+    itemStatus ∷ String,         -- ^ Status of the item+    itemDescr ∷ String,          -- ^ Description of the item+    startDate ∷ Maybe DateTime,  -- ^ Date when TODO is planned to start+    endDate ∷ Maybe DateTime,    -- ^ Date when TODO is planned to end+    deadline ∷ Maybe DateTime,   -- ^ Deadline for this TODO+    fileName ∷ FilePath,         -- ^ Path to the source file+    lineNr ∷ Line                -- ^ Line in the source file, where this item was defined+  }+  deriving (Eq,Data,Typeable)++instance Hashable TodoItem where+    hash item = foldl1 combine $ map ($ item) [hash ∘ itemName, hash ∘ itemDescr,+                                               hash ∘ itemTags, hash ∘ itemStatus]++-- | Make an ID for any hashable item. 16 hexadecimal digits.+makeId :: (Hashable a) ⇒ a → String+makeId item =+  let s = showHex (asWord64 $ hash item) ""+      l = length s +  in  if l < 16 +        then replicate (16-l) '0' ++ s+        else s++-- | Tree of TODO items.+type Todo = Tree TodoItem++type TodoMap = M.Map String Todo++data Limit = Unlimited+           | Limit {unLimit ∷ ℤ}+  deriving (Eq,Show)++instance Ord Limit where+    compare Unlimited Unlimited = EQ+    compare Unlimited _ = GT+    compare _ Unlimited = LT+    compare (Limit x) (Limit y) = compare x y++-- | Command line flag+data CmdLineFlag = QF {queryFlag ∷ QueryFlag}+                 | MF {modeFlag ∷ ModeFlag}+                 | OF {outFlag ∷ OutFlag}+                 | LF {limFlag ∷ LimitFlag}+                 | HelpF+    deriving (Eq,Show)++-- | Flags to specify query+data QueryFlag = Tag String+               | Name {unName ∷ String}+               | IdIs String+               | Status String+               | Description String+               | StartDateIs DateTime+               | EndDateIs DateTime+               | DeadlineIs DateTime+               | AndCons+               | OrCons+               | NotCons+               | NoFilter+     deriving (Eq,Ord,Show)        ++data LimitFlag = Prune {unPrune ∷ ℤ}+               | Start {unMin ∷ ℤ}+    deriving (Eq,Show)++-- | Flags to specify parsing mode+data ModeFlag = Execute {unExecute ∷ String}+              | Prefix {unPrefix ∷ String}+              | Describe {unDescribe ∷ String}+              | DoNotReadStatus+              | SetStatus {newStatus ∷ String}+              | SetTopStatus {newTopStatus ∷ String}+              | GroupByFile+              | GroupByTag+              | GroupByStatus+    deriving (Eq,Ord,Show)++-- | Flags to control output+data OutFlag = OnlyFirst +             | Colors+             | Highlight+             | Ids+             | DotExport+             | Sort {getSorting ∷ SortingType}+    deriving (Eq,Ord,Show)++-- | Type of sorting+data SortingType = DoNotSort+                 | ByTitle+                 | ByStatus+                 | ByTags +                 | ByStartDate+                 | ByEndDate+                 | ByDeadline+    deriving (Eq,Ord,Show)++readSort ∷ String → SortingType+readSort "no" = DoNotSort+readSort "title" = ByTitle+readSort "status" = ByStatus+readSort "tags" = ByTags+readSort "start-date" = ByStartDate+readSort "end-date" = ByEndDate+readSort "deadline" = ByDeadline+readSort s = error $ "Unknown sorting type: "++s++instance (Ord a) ⇒ Ord (Tree a) where+  compare = compare `on` rootLabel++-- TODO: - rename Options → QueryOptions or similar+-- | Result of parsing command line+data Options = O [QueryFlag] [ModeFlag] [OutFlag] [LimitFlag]+             | Help++-- | What to do with selected items+data TodoCommand =+    JustShow              -- ^ Just output items to console+  | ShowAsDot             -- ^ Output graph in DOT format+  | SystemCommand String  -- ^ Execute this system command for each item+  deriving (Eq, Show)++-- | Data type to store complex queries+data Composed = Pred QueryFlag            -- ^ Simple query+              | And Composed Composed     -- ^ Logical AND+              | Or Composed Composed      -- ^ Logical OR+              | Not Composed              -- ^ Logical NOT+              | Empty                     -- ^ Empty query+              | HelpC                     -- ^ User requests help+    deriving (Eq,Show)++is ∷  (Functor f) ⇒ t → f a → f (t, a)+t `is`  x = (\a → (t,a)) `fmap` x++showDate ∷  (DateType, DateTime) → String+showDate (t,d) = show t ⧺ ": " ⧺ show d++showDates ∷  [Maybe (DateType, DateTime)] → String+showDates = intercalate "; " ∘ map showDate ∘ catMaybes++instance Show TodoItem where+    show item = s ⧺ " " ⧺ dates ⧺ tags ⧺ name ⧺ (if null descr then "" else "    "⧺descr)+      where+        name = itemName item+        ts = itemTags item+        s = itemStatus item+        descr = itemDescr item+        dates | null dates' = ""+              | otherwise = "(" ⧺ dates' ⧺ ") "+        dates' = showDates [StartDate `is` startDate item, EndDate `is` endDate item, Deadline `is` deadline item]+        tags = if null ts+                 then ""+                 else "[" ⧺ (unwords ts) ⧺ "] "++instance Ord TodoItem where+  compare item1 item2 = +      let c1 = (compare `on` itemLevel) item1 item2+          c2 = (compare `on` itemStatus) item1 item2+          c3 = (compare `on` itemName) item1 item2+      in  if c1 == EQ+            then if c2 == EQ +                   then c3+                   else c2+            else c1+
+ Todos/Unicode.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE UnicodeSyntax #-}+module Todos.Unicode where++type ℝ = Float+type ℤ = Integer+type 𝔹 = Bool++-- | Concatenate lists +(⧺) ∷ [a] → [a] → [a]+(⧺) = (++)++(⋄) ∷ (a -> b) -> a -> b+(⋄) = ($)+infixr 0 ⋄++(∘) :: (b -> c) -> (a -> b) -> a -> c+(∘) = (.)++(∨) :: Bool -> Bool -> Bool+(∨) = (||)++(∧) :: Bool -> Bool -> Bool+(∧) = (&&)++(∈) :: (Eq a) => a -> [a] -> Bool+x ∈ lst = elem x lst+
− Types.hs 
@@ -1,373 +0,0 @@-{-# LANGUAGE UnicodeSyntax, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, NoMonomorphismRestriction #-}--module Types where--import Prelude hiding (putStr, putStrLn,readFile,getContents,print)-import IO-import System.Console.ANSI-import Data.Hash--import Control.Monad.Reader-import Data.Function -import Data.Generics hiding (GT)-import Data.Char (toUpper)-import Data.Maybe-import Data.Tree-import Data.List-import qualified Data.Map as M-import Text.ParserCombinators.Parsec-import Numeric--import Unicode--data DateType = StartDate-              | EndDate-              | Deadline-  deriving (Eq)--instance Show DateType where-  show StartDate = "start"-  show EndDate = "end"-  show Deadline = "deadline"--data DateTime =-  DateTime {-    year ∷ Int,-    month ∷ Int,-    day ∷ Int,-    hour ∷ Int,-    minute ∷ Int,-    second ∷ Int }-  deriving (Eq,Ord,Data,Typeable)--months ∷ [String]-months = ["january",-          "february",-          "march",-          "april",-          "may",-          "june",-          "july",-          "august",-          "september",-          "october",-          "november",-          "december"]--capitalize ∷ String → String-capitalize [] = []-capitalize (x:xs) = (toUpper x):xs--showMonth ∷  Int → String-showMonth i = capitalize $ months !! (i-1)--instance Show DateTime where-  show (DateTime y m d h min s) = -    show d ⧺ " " ⧺ showMonth m ⧺ " " ⧺ show y ⧺ ", " ⧺-      show h ⧺ ":" ⧺ show min ⧺ ":" ⧺ show s--data Time = -  Time {-    tHour ∷ Int,-    tMinute ∷ Int,-    tSecond ∷ Int }-  deriving (Eq,Ord,Show,Data,Typeable)--data TodoItem = Item {-    itemLevel ∷ ℤ,-    itemName ∷ String,-    itemTags ∷ [String],-    depends ∷ [String],-    itemStatus ∷ String,-    itemDescr ∷ String,-    startDate ∷ Maybe DateTime,-    endDate ∷ Maybe DateTime,-    deadline ∷ Maybe DateTime,-    fileName ∷ FilePath,-    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--data Limit = Unlimited-           | Limit ℤ-  deriving (Eq,Show)--instance Ord Limit where-    compare Unlimited Unlimited = EQ-    compare Unlimited _ = GT-    compare _ Unlimited = LT-    compare (Limit x) (Limit y) = compare x y--data CmdLineFlag = QF {queryFlag ∷ QueryFlag}-                 | MF {modeFlag ∷ ModeFlag}-                 | OF {outFlag ∷ OutFlag}-                 | LF {limFlag ∷ LimitFlag}-                 | HelpF-    deriving (Eq,Show)--data QueryFlag = Tag String-               | Name {unName ∷ String}-               | IdIs String-               | Status String-               | Description String-               | StartDateIs DateTime-               | EndDateIs DateTime-               | DeadlineIs DateTime-               | AndCons-               | OrCons-               | NotCons-               | NoFilter-     deriving (Eq,Ord,Show)        --data LimitFlag = Prune {unPrune ∷ ℤ}-               | Start {unMin ∷ ℤ}-    deriving (Eq,Show)--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)--data SortingType = DoNotSort-                 | ByTitle-                 | ByStatus-                 | ByTags -                 | ByStartDate-                 | ByEndDate-                 | ByDeadline-    deriving (Eq,Ord,Show)--readSort ∷ String → SortingType-readSort "no" = DoNotSort-readSort "title" = ByTitle-readSort "status" = ByStatus-readSort "tags" = ByTags-readSort "start-date" = ByStartDate-readSort "end-date" = ByEndDate-readSort "deadline" = ByDeadline-readSort s = error $ "Unknown sorting type: "++s--type Transformer = Reader Config (Todo → [Todo])-type ListTransformer = Reader Config ([Todo] → [Todo])--transformList ∷  r → Reader r (t → a) → t → a-transformList conf tr list = do-    f ← tr-    return (f list)-  `runReader` conf--data OutItem = OutString String-             | OutSetColor Color-             | SetBold-             | ResetAll-    deriving (Show)--type Formatter = Reader Config [OutItem]--newtype IOList = IOL [Formatter]--startFormat ∷ Formatter-startFormat = return []--outString ∷ String → Formatter-outString s = return [OutString s]--newLine ∷ Formatter-newLine = outString "\n"--class ConfigAdd a where-  (<++>) ∷ Formatter → a → Formatter--instance ConfigAdd Formatter where-  (<++>) = liftM2 (⧺)--instance ConfigAdd String where-  cm <++> s = cm <++> ((return [OutString s]) ∷ Formatter)--setBold ∷  IO ()-setBold = setSGR [SetConsoleIntensity BoldIntensity]--setColor ∷  Color → IO ()-setColor clr = setSGR [SetColor Foreground Dull clr]--reset ∷  IO ()-reset = setSGR []--outItem ∷  OutItem → IO ()-outItem (OutString s)   = putStr s-outItem (OutSetColor c) = setColor c-outItem SetBold         = setBold-outItem ResetAll        = reset--runFormatter ∷ Config → Formatter → IO ()-runFormatter conf cm = -  let lst = runReader cm conf-  in  mapM_ outItem lst--class ConfigShow s where-  configShow ∷ s → Formatter--instance ConfigShow String where-  configShow s = return [OutString s]--instance ConfigShow Formatter where-  configShow = id-  -showIO ∷ (ConfigShow a) ⇒ Config → a → IO ()-showIO conf = (runFormatter conf) ∘ configShow--instance (Ord a) ⇒ Ord (Tree a) where-  compare = compare `on` rootLabel---- TODO: - rename Options → QueryOptions or similar-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 ∷ TodoCommand,-      prefix ∷ Maybe String,-      descrFormat ∷ String,-      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-              | Not Composed-              | Empty-              | HelpC-    deriving (Eq,Show)--is ∷  (Functor f) ⇒ t → f a → f (t, a)-t `is`  x = (\a → (t,a)) `fmap` x--showDate ∷  (Show t, Show t1) ⇒ (t, t1) → [Char]-showDate (t,d) = show t ⧺ ": " ⧺ show d--showDates ∷  (Show t, Show t1) ⇒ [Maybe (t, t1)] → [Char]-showDates = intercalate "; " ∘ map showDate ∘ catMaybes--instance Show TodoItem where-    show item = s ⧺ " " ⧺ dates ⧺ tags ⧺ name ⧺ (if null descr then "" else "    "⧺descr)-      where-        n = itemLevel item-        name = itemName item-        ts = itemTags item-        s = itemStatus item-        descr = itemDescr item-        dates | null dates' = ""-              | otherwise = "(" ⧺ dates' ⧺ ") "-        dates' = showDates [StartDate `is` startDate item, EndDate `is` endDate item, Deadline `is` deadline item]-        tags = if null ts-                 then ""-                 else "[" ⧺ (unwords ts) ⧺ "] "--bold ∷ String → Formatter-bold s = do-  col ← asks outColors -  if col-    then return [SetBold, OutString s, ResetAll]-    else return [OutString s]--lookupC ∷  (Eq a1) ⇒ a1 → [([a1], a)] → Maybe a-lookupC k [] = Nothing-lookupC k ((lst,c):other) | k ∈ lst   = Just c-                          | otherwise = lookupC k other--statusColors ∷  [([String], Color)]-statusColors = -  [(["FIXED", "DONE"], Green),-   (["INVALID"],       Magenta),-   (["*"],             Red),-   (["?"],             Blue)]--colorStatus ∷ String → Formatter-colorStatus st =-  case lookupC st statusColors of-    Nothing → return [OutString st]-    Just clr → do-      col ← asks outColors -      if col-        then return [OutSetColor clr, OutString st, ResetAll]-        else return [OutString st]--instance ConfigShow TodoItem where-    configShow item = startFormat <++> colorStatus s <++> " " <++> dates <++> tags <++> bold name <++> (if null descr then "" else "    "⧺descr)-      where-        n = itemLevel item-        name = itemName item-        ts = itemTags item-        s = itemStatus item-        descr = itemDescr item-        dates | null dates' = ""-              | otherwise = "(" ⧺ dates' ⧺ ") "-        dates' = showDates [StartDate `is` startDate item, EndDate `is` endDate item, Deadline `is` deadline item]-        tags = if null ts-                 then ""-                 else "[" ⧺ (unwords ts) ⧺ "] "--instance Ord TodoItem where-  compare item1 item2 = -      let c1 = (compare `on` itemLevel) item1 item2-          c2 = (compare `on` itemStatus) item1 item2-          c3 = (compare `on` itemName) item1 item2-      in  if c1 == EQ-            then if c2 == EQ -                   then c3-                   else c2-            else c1--type TParser a = GenParser Char Config a-
− Unicode.hs 
@@ -1,13 +0,0 @@-module Unicode where--type ℝ = Float-type ℤ = Integer-type 𝔹 = Bool--(⧺) = (++)-(⋄) = ($)-infixr 0 ⋄-(∘) = (.)-(∨) = (||)-(∧) = (&&)-x ∈ lst = elem x lst
− test.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE UnicodeSyntax, PatternGuards #-}-module Test where--import Control.Monad.Reader-import Data.Maybe-import Data.Tree-import Data.List--import Unicode-import Types-import TodoLoader-import TodoTree-import CommandParser-import Config-import CmdLine--cfg = Config False False (Limit 20) (Limit 20) Nothing Nothing "%d" Empty--test file = do-  todos ← loadTodo Nothing [file]-  printTodos cfg todos-  putStrLn ""-
− test.txt 
@@ -1,11 +0,0 @@-Line of text-Text-TODO: * one todo-description-text-text-TODO: * another todo-descr-text-text-TODO: + last todo
todos.cabal view
@@ -1,5 +1,5 @@ Name:           todos-Version:        0.2+Version:        0.3 Cabal-Version:  >= 1.6 License:        BSD3 License-File:   LICENSE@@ -13,16 +13,60 @@                 plain-text file, and todos allows you to show only needed of                 them. So, todos works as specialized `grep' utility. -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 Dot.hs Color.hs Shapes.hs+Extra-source-files: Makefile README README.ru TODO -Executable todos-  Build-Depends:  base >= 3 && <= 5, haskell98, utf8-string, containers, parsec >= 2 && < 3,+library+  Exposed-Modules: Todos+                   Todos.CmdLine+                   Todos.Color+                   Todos.ParserTypes+                   Todos.Dates+                   Todos.CommandParser+                   Todos.Parser+                   Todos.Config+                   Todos.ConfigInstances+                   Todos.ConfigUtils+                   Todos.ReadConfig+                   Todos.Dot+                   Todos.IO+                   Todos.Main+                   Todos.Shapes+                   Todos.Loader+                   Todos.Tree+                   Todos.Types+                   Todos.Unicode+                   Todos.Formatters+                   Todos.Print++  Build-Depends:  base >= 3 && <= 5, haskell98, containers, parsec >= 2 && < 3,                   syb, mtl, ansi-terminal, Glob, time, regex-pcre, directory, filepath,-                  process, data-hash-  Main-Is:        todos.hs+                  process, data-hash, dyre, utf8-string++  ghc-options: -fwarn-unused-imports++Executable todos+  Main-Is:       todos.hs+  Other-Modules: Todos+                 Todos.CmdLine+                 Todos.Color+                 Todos.ParserTypes+                 Todos.Dates+                 Todos.CommandParser+                 Todos.Parser+                 Todos.Config+                 Todos.ConfigUtils+                 Todos.ConfigInstances+                 Todos.ReadConfig+                 Todos.Dot+                 Todos.IO+                 Todos.Main+                 Todos.Shapes+                 Todos.Loader+                 Todos.Tree+                 Todos.Types+                 Todos.Unicode+                 Todos.Formatters+                 Todos.Print  Source-repository head   type:     git
todos.hs view
@@ -1,55 +1,7 @@-{-# LANGUAGE UnicodeSyntax, PatternGuards #-}--import Prelude hiding (putStrLn,readFile,getContents,print)-import IO-import Codec.Binary.UTF8.String-import System (getArgs)-import System.Exit-import System.Cmd (system)--import Control.Monad.Reader-import Data.Maybe-import Data.Tree-import Data.List+{-# LANGUAGE UnicodeSyntax #-} -import Unicode-import Types-import TodoLoader-import TodoTree-import CommandParser-import Config-import CmdLine-import Dates (getCurrentDateTime)-import Dot+import Todos  main ∷  IO ()-main = do-  currDate ← getCurrentDateTime -  config ← readConfig-  args ← getArgs-  let (loptions, files') = parseCmdLine currDate (config ⧺ args)-  files ← glob files'-  case loptions of-    O qflags mflags oflags lflags → -      do-        let options = O qflags mflags oflags lflags-            q = buildQuery options-        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-          JustShow  → do-               printTodos q (mapT format queried)-               putStrLn ""-          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) []]-                           | otherwise       = queried--    Help → do putStrLn usage-              exitWith ExitSuccess+main = todos defaultConfig