todos 0.3 → 0.4
raw patch · 28 files changed
+1007/−879 lines, 28 files
Files
- README +9/−2
- README.ru +17/−4
- Todos.hs +1/−14
- Todos/CmdLine.hs +0/−297
- Todos/Color.hs +0/−145
- Todos/CommandParser.hs +5/−0
- Todos/Config.hs +3/−9
- Todos/ConfigInstances.hs +0/−16
- Todos/ConfigUtils.hs +0/−92
- Todos/Dates.hs +28/−31
- Todos/Default.hs +16/−0
- Todos/Default/CmdLine.hs +309/−0
- Todos/Default/Config.hs +17/−0
- Todos/Default/Instances.hs +17/−0
- Todos/Default/Print.hs +84/−0
- Todos/Default/Utils.hs +92/−0
- Todos/Dot.hs +8/−90
- Todos/Dot/Color.hs +147/−0
- Todos/Dot/Render.hs +96/−0
- Todos/Dot/Shapes.hs +89/−0
- Todos/Formatters.hs +34/−20
- Todos/Main.hs +10/−7
- Todos/Parser.hs +2/−1
- Todos/ParserTypes.hs +0/−10
- Todos/Print.hs +0/−79
- Todos/Shapes.hs +0/−44
- Todos/Types.hs +2/−1
- todos.cabal +21/−17
README view
@@ -54,7 +54,8 @@ -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+ -D FORMAT --format=FORMAT use FORMAT to format items+ -k[STRING] --indent-with[=STRING] use STRING instead of two spaces for items indentation -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@@ -91,7 +92,12 @@ 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+With «-k» option one can specify another indentation string instead of default+two spaces. For example, `todos -k"| "` will print vertical lines between items+of same level. «-k» option without argument will force todos to not use+indentation at all.++For «--format» and «--exec» options, printf-style format strings should be specified. Following substitution sequences are supported: %n :: title of the record@@ -100,6 +106,7 @@ %d :: description of the record %f :: name of file, in which record was found %l :: number of line in source file+%D :: dates of item For example, «todos -tBUG -e"vi %f +%l"» command for each record with «BUG» tag will open vi with corresponding file on corresponding line.
README.ru view
@@ -56,7 +56,8 @@ -I, --show-ids :: показывать идентификаторы записей -A, --prefix= :: использовать альтернативный формат файлов, тут же указывается префикс --dot :: вывести записи в виде графа для DOT (graphviz)--D, --describe :: можно указать формат для выводимого описания (см. ниже)+-D, --format :: можно указать формат вывода записей (см. ниже)+-k, --indent-string :: использовать указанную строку для создания отступов, вместо двух пробелов -w, --no-status :: не читать поле статуса из файлов --set-status=STRING :: установить статус всех TODO равным STRING --set-root-status=STRING :: установить статусы корневых TODO равным STRING@@ -91,7 +92,18 @@ которые подходят под ваш запрос, будут подсвечены цветом (только с включённой опцией «-c»). -Для опций --describe и --exec указываются строки формата с символами+Если указана опция «-I», перед каждой записью будет напечатан её идентификатор.+Идентификатор записи — это просто хэш от заголовка, описания, статуса, тегов и+описания; так что только одинаковые записи будут иметь одинаковые+идентификаторы. Можно попросить вывести только запись с данным идентификатором+при помощи опции «-i».++С помощью опции «-k» можно указать другую строку для формирования отступов при+выводе записей в консоль. По умолчанию используются два пробела. Попробуйте,+например, `todos -k"| "`. Опция «-k» без аргумента отключает формирование+отступов совсем.++Для опций --format и --exec указываются строки формата с символами подстановки в стиле printf. Поддерживаются следующие символы подстановки: %n :: заменяется на заголовок записи@@ -100,9 +112,10 @@ %d :: описание записи %f :: имя файла, в котором встретилась запись %l :: номер строки в файле, где встретилась запись+%D :: даты, связанные с записью -Например, todos -tBUG -e"vi %f +%l" для каждой записи с тегом BUG откроет vi на-строчке с этой записью.+Например, `todos -tBUG -e"vi %f +%l"` для каждой записи с тегом BUG откроет vi+на строчке с этой записью. С опцией «--dot» todos выведет на стандартный выход описание графа для DOT (graphviz) вместо обычного вывода. Можно попробовать, например, так:
Todos.hs view
@@ -1,25 +1,12 @@ 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
@@ -1,297 +0,0 @@-{-# 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
@@ -1,145 +0,0 @@-{-# 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
@@ -23,4 +23,9 @@ itemPart 'd' = itemDescr item itemPart 'f' = fileName item itemPart 'l' = show $ lineNr item+ itemPart 'D' | null dates = ""+ | otherwise = "(" ⧺ dates ⧺ ") " itemPart x = [x]++ dates = showDates [StartDate `is` startDate item, EndDate `is` endDate item, Deadline `is` deadline item]+
Todos/Config.hs view
@@ -6,8 +6,7 @@ import Todos.Unicode import Todos.Types-import Todos.Color-import Todos.Shapes+import Todos.Dot import qualified System.Console.ANSI as ANSI -- | Any user-specified runtime config type should belong to this class@@ -28,7 +27,8 @@ minL ∷ Limit, commandToRun ∷ TodoCommand, prefix ∷ Maybe String, -- ^ Nothing — use default parser, Just p — use alternate parser with prefix «p»- descrFormat ∷ String,+ outputFormat ∷ String,+ indentString ∷ String, -- ^ String to use for output tree indenting (two spaces by default) skipStatus ∷ 𝔹, -- ^ Skip status field in input groupByFile ∷ 𝔹, groupByTag ∷ 𝔹,@@ -37,12 +37,6 @@ 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 {
− Todos/ConfigInstances.hs
@@ -1,16 +0,0 @@-{-# 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
@@ -1,92 +0,0 @@-{-# 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
@@ -13,8 +13,6 @@ import Todos.Types import Todos.Unicode-import Todos.Config-import Todos.ParserTypes getCurrentDateTime ∷ IO DateTime getCurrentDateTime = do@@ -54,7 +52,7 @@ minute = tMinute t + minute dt, second = tSecond t + second dt } -times ∷ Int → TParser t → TParser [t]+times ∷ Int → CharParser st t → CharParser st [t] times 0 _ = return [] times n p = do ts ← times (n-1) p@@ -63,27 +61,27 @@ Just t' → return (ts ++ [t']) Nothing → return ts -number ∷ Int → Int → TParser Int+number ∷ Int → Int → CharParser st 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 ∷ CharParser st Int pYear = do y ← number 4 10000 if y < 2000 then return (y+2000) else return y -pMonth ∷ TParser Int+pMonth ∷ CharParser st Int pMonth = number 2 12 -pDay ∷ TParser Int+pDay ∷ CharParser st Int pDay = number 2 31 -euroNumDate ∷ TParser DateTime+euroNumDate ∷ CharParser st DateTime euroNumDate = do d ← pDay char '.'@@ -92,7 +90,7 @@ y ← pYear return $ date y m d -americanDate ∷ TParser DateTime+americanDate ∷ CharParser st DateTime americanDate = do y ← pYear char '/'@@ -101,21 +99,21 @@ d ← pDay return $ date y m d -euroNumDate' ∷ Int → TParser DateTime+euroNumDate' ∷ Int → CharParser st DateTime euroNumDate' year = do d ← pDay char '.' m ← pMonth return $ date year m d -americanDate' ∷ Int → TParser DateTime+americanDate' ∷ Int → CharParser st DateTime americanDate' year = do m ← pMonth char '/' d ← pDay return $ date year m d -strDate ∷ TParser DateTime+strDate ∷ CharParser st DateTime strDate = do d ← pDay space@@ -128,7 +126,7 @@ notFollowedBy $ char ':' return $ date y m d -strDate' ∷ Int → TParser DateTime+strDate' ∷ Int → CharParser st DateTime strDate' year = do d ← pDay space@@ -137,7 +135,7 @@ Nothing → fail $ "unknown month: "++ms Just m → return $ date year m d -time24 ∷ TParser Time+time24 ∷ CharParser st Time time24 = do h ← number 2 23 char ':'@@ -150,7 +148,7 @@ notFollowedBy letter return $ Time h m s -ampm ∷ TParser Int+ampm ∷ CharParser st Int ampm = do s ← many1 letter case map toUpper s of@@ -158,7 +156,7 @@ "PM" → return 12 _ → fail "AM/PM expected" -time12 ∷ TParser Time+time12 ∷ CharParser st Time time12 = do h ← number 2 12 char ':'@@ -171,7 +169,7 @@ hd ← ampm return $ Time (h+hd) m s -pAbsDate ∷ Int → TParser DateTime+pAbsDate ∷ Int → CharParser st DateTime pAbsDate year = do date ← choice $ map try $ map ($ year) $ [ const euroNumDate,@@ -214,23 +212,23 @@ addInterval dt (Months ms) = modifyDate addGregorianMonthsClip ms dt addInterval dt (Years ys) = modifyDate addGregorianYearsClip ys dt -maybePlural ∷ String → TParser String+maybePlural ∷ String → CharParser st String maybePlural str = do r ← string str optional $ char 's' return (capitalize r) -pDateInterval ∷ TParser DateIntervalType+pDateInterval ∷ CharParser st DateIntervalType pDateInterval = do s ← choice $ map maybePlural ["day", "week", "month", "year"] return $ read s -pRelDate ∷ DateTime → TParser DateTime+pRelDate ∷ DateTime → CharParser st DateTime pRelDate date = do offs ← (try futureDate) <|> (try passDate) <|> (try today) <|> (try tomorrow) <|> yesterday return $ date `addInterval` offs -futureDate ∷ TParser DateInterval+futureDate ∷ CharParser st DateInterval futureDate = do string "in " n ← many1 digit@@ -242,7 +240,7 @@ Month → return $ Months (read n) Year → return $ Years (read n) -passDate ∷ TParser DateInterval+passDate ∷ CharParser st DateInterval passDate = do n ← many1 digit char ' '@@ -254,22 +252,22 @@ Month → return $ Months $ - (read n) Year → return $ Years $ - (read n) -today ∷ TParser DateInterval+today ∷ CharParser st DateInterval today = do string "today" return $ Days 0 -tomorrow ∷ TParser DateInterval+tomorrow ∷ CharParser st DateInterval tomorrow = do string "tomorrow" return $ Days 1 -yesterday ∷ TParser DateInterval+yesterday ∷ CharParser st DateInterval yesterday = do string "yesterday" return $ Days (-1) -pDate ∷ DateTime → TParser DateTime+pDate ∷ DateTime → CharParser st DateTime pDate date = (try $ pRelDate date) <|> (try $ pAbsDate $ year date) dateType ∷ String → DateType@@ -279,7 +277,7 @@ dateType _ = error "unknown date type" -- | Parse date/time with date type-pSpecDate ∷ DateTime → TParser (DateType, DateTime)+pSpecDate ∷ DateTime → CharParser st (DateType, DateTime) pSpecDate date = do tp ← choice $ map string ["start","end","deadline"] string ": "@@ -287,7 +285,7 @@ return (dateType tp, dt) -- | Parse set of dates with types (in parenthesis)-pSpecDates ∷ DateTime → TParser [(DateType, DateTime)]+pSpecDates ∷ DateTime → CharParser st [(DateType, DateTime)] pSpecDates date = do char '(' pairs ← (pSpecDate date) `sepBy1` (string "; ")@@ -295,9 +293,8 @@ return pairs -- | Parse date/time-parseDate ∷ BaseConfig- → DateTime -- ^ Current date/time+parseDate ∷ DateTime -- ^ Current date/time → String -- ^ String to parse → Either ParseError DateTime-parseDate conf date s = runParser (pDate date) conf "" s+parseDate date s = runParser (pDate date) () "" s
+ Todos/Default.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE UnicodeSyntax #-}++-- | Todos.Default.* modules contain implementation of RuntimeConfig instance for DefaultConfig type.++module Todos.Default+ (module Todos.Default.CmdLine,+ module Todos.Default.Instances,+ module Todos.Default.Utils,+ module Todos.Default.Print)+ where++import Todos.Default.CmdLine+import Todos.Default.Instances ()+import Todos.Default.Utils+import Todos.Default.Print+
+ Todos/Default/CmdLine.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE UnicodeSyntax, PatternGuards #-}++-- | Module for parsing command line options and build queries. These functions+-- are used by default, but user can supply his own functions.+module Todos.Default.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.Default.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,+ outputFormat = update outputFormat dformat,+ indentString = update indentString indent,+ 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 isFormat mflags+ dformat | null dflags = Nothing+ | otherwise = Just $ getFormat $ last dflags++ iflags = filter isIndent oflags+ indent | null iflags = Nothing+ | otherwise = Just $ getIndentString $ last iflags++ 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+ isFormat (Format _) = True+ isFormat _ = False+ isIndent (IndentWith _) = True+ isIndent _ = 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" ["format"] (ReqArg mkFormat "FORMAT") "use FORMAT to format items",+ Option "k" ["indent-with"] (OptArg mkIndent "STRING") "use STRING instead of two spaces for items indentation",+ 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 dt s++mkEndDate ∷ DateTime → String → CmdLineFlag+mkEndDate dt s = QF $ EndDateIs $ forceEither $ parseDate dt s++mkDeadline ∷ DateTime → String → CmdLineFlag+mkDeadline dt s = QF $ DeadlineIs $ forceEither $ parseDate dt s++mkFormat ∷ String → CmdLineFlag+mkFormat f = MF $ Format f++mkIndent ∷ Maybe String → CmdLineFlag+mkIndent Nothing = OF $ IndentWith ""+mkIndent (Just s) = OF $ IndentWith s++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/Default/Config.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | This module contains declaration of DefaultConfig data type, which is used+-- by default to store runtime config.+module Todos.Default.Config+ (module Todos.Config,+ DefaultConfig (..)+ ) where++import Todos.Types+import Todos.Config++-- | Default runtime configuration type. Is read from command line and configs.+data DefaultConfig = DConfig {+ baseConfig ∷ BaseConfig,+ query ∷ Composed }+ deriving (Eq,Show)+
+ Todos/Default/Instances.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | This module contains instances of RuntimeConfig class for DefaultConfig and PrintConfig+module Todos.Default.Instances where++import Todos.Unicode+import Todos.Config+import Todos.Default.Config+import Todos.Default.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/Default/Print.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | This module implements printing TODOs tree to console. Here is default+-- function, but user can supply his own.+module Todos.Default.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.Default.Config+import Todos.Default.Instances ()+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 → String → Todo → [Formatter DefaultConfig]+showT s n sep (Node item todos) = + (sf <++> showId item <++> seps <++> item') :+ (concatMap (showT s (n+1) sep) $ sortBy' s todos)+ where+ sf ∷ Formatter DefaultConfig+ sf = startFormat++ seps = concat (replicate n sep)++ 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+ sep ← askBase indentString+ let f = case outOnlyFirst conf of+ False → unlines''+ True → head+ f $ showT (sorting conf) 0 sep 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/Default/Utils.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses #-}+-- | This module contains some empty configs definitions and some function fields of defaultConfig+module Todos.Default.Utils where++import System.Console.ANSI++import Todos.Types+import Todos.Dot+import Todos.Default.CmdLine+import Todos.Default.Config+import Todos.Default.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,+ outputFormat = "%s %D%t%n %d",+ indentString = " ",+ 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/Dot.hs view
@@ -1,95 +1,13 @@ {-# LANGUAGE UnicodeSyntax, TypeSynonymInstances, FlexibleInstances #-}+-- | Todos.Dot.* modules implement output of TODOs trees as DOT graph module Todos.Dot- (showAsDot)+ (module Todos.Dot.Color,+ module Todos.Dot.Shapes,+ module Todos.Dot.Render+ ) 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)+import Todos.Dot.Color+import Todos.Dot.Shapes+import Todos.Dot.Render
+ Todos/Dot/Color.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | This module contains data type for storing HSV color, used in DOT output,+-- and some default functions to calculate items' colors.+module Todos.Dot.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/Dot/Render.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE UnicodeSyntax, TypeSynonymInstances, FlexibleInstances #-}+-- | Output TODOs tree as DOT graph+module Todos.Dot.Render+ (showAsDot)+ where++import Data.List+import Data.Tree+import Text.Printf++import Todos.Unicode+import Todos.Types+import Todos.Dot.Color+import Todos.Dot.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/Dot/Shapes.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE UnicodeSyntax #-}+-- | Support for DOT node shapes+module Todos.Dot.Shapes where++import qualified Data.Map as M++import Todos.Types++-- | Supported node shapes for DOT output+data Shape = + Box + | Box3D+ | Component+ | Square+ | MSquare+ | Ellipse+ | Diamond+ | MDiamond+ | Circle+ | DCircle+ | MCircle+ | Note+ | Parallelogram+ | Tab+ | Folder+ | Polygon Int+ | Point+ | Egg+ | Triangle Bool -- ^ Inverted?+ | PlainText+ | Trapezium Bool -- ^ Inverted?+ | House Bool -- ^ Inverted?+ | Pentagon+ | Hexagon+ | Septagon+ | Octagon Int -- ^ Simple, double, triple?+ deriving (Eq)++instance Show Shape where+ show DCircle = "doublecircle"+ show (Polygon k) = "polygon\", sides=\"" ++ show k + show (Triangle True) = "invtriangle"+ show (Triangle False) = "triangle"+ show (Trapezium True) = "invtrapezium"+ show (Trapezium False) = "trapezium"+ show (House True) = "invhouse"+ show (House False) = "house"+ show (Octagon 1) = "octagon"+ show (Octagon 2) = "doubleoctagon"+ show (Octagon 3) = "tripleoctagon"+ show (Octagon _) = error "Only 1,2 or 3 are supported as Octagon arguments!"+ show Box = "box"+ show Box3D = "box3d"+ show Component = "component"+ show Square = "square"+ show MSquare = "Msquare"+ show Ellipse = "ellipse"+ show Diamond = "diamond"+ show Circle = "circle"+ show MDiamond = "Mdiamond"+ show MCircle = "Mcircle"+ show Note = "note"+ show Parallelogram = "parallelogram"+ show Tab = "tab"+ show Folder = "folder"+ show Point = "point"+ show Egg = "egg"+ show PlainText = "plaintext"+ show Pentagon = "pentagon"+ show Hexagon = "hexagon"+ show Septagon = "septagon"++-- | 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/Formatters.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE UnicodeSyntax, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances #-} module Todos.Formatters (OutItem (..), Formatter,@@ -15,7 +15,7 @@ import Todos.Unicode import Todos.Types import Todos.Config-import Todos.ConfigInstances ()+-- import Todos.Default.ConfigInstances () -- | Item which could be printed to the console data OutItem = OutString String@@ -77,7 +77,7 @@ configShow = id -- | Output bold (and maybe colored) item name-bold ∷ (RuntimeConfig c) ⇒ TodoItem → Formatter c+bold ∷ (RuntimeConfig (PrintConfig c)) ⇒ TodoItem → Formatter c bold item = do let s = itemName item showColors ← askBase outColors@@ -94,7 +94,7 @@ else [OutString s] -- | Output colored item status-colorStatus ∷ (RuntimeConfig c) ⇒ String → Formatter c+colorStatus ∷ (RuntimeConfig (PrintConfig c)) ⇒ String → Formatter c colorStatus st = do getclr ← asks printStatusColor let (int, clr) = getclr st@@ -103,20 +103,34 @@ 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+printM ∷ (RuntimeConfig (PrintConfig c)) ⇒ TodoItem → Formatter c+printM item = askBase outputFormat >>= printf+ where+ printf :: (RuntimeConfig (PrintConfig c)) ⇒ String → Formatter c+ printf "" = return []+ printf [c] = return [OutString [c]]+ printf ('%':c:xs) = liftM2 (⧺) (itemPart c) (printf xs)+ printf (x:xs) = do r ← printf xs+ return $ (OutString [x]):r + tags = filter (not ∘ null) $ itemTags item+ string s = return [OutString s]++ itemPart ∷ (RuntimeConfig (PrintConfig c)) ⇒ Char → Formatter c+ itemPart 'L' = string (show $ itemLevel item)+ itemPart 'n' = bold item + itemPart 't' = if null tags+ then return []+ else string ("[" ⧺ unwords tags ⧺ "] ")+ itemPart 's' = colorStatus (itemStatus item)+ itemPart 'd' = string (itemDescr item)+ itemPart 'f' = string (fileName item)+ itemPart 'l' = string (show $ lineNr item)+ itemPart 'D' | null dates' = return []+ | otherwise = string $ "(" ⧺ dates' ⧺ ") "+ itemPart c = string [c]++ dates' = showDates [StartDate `is` startDate item, EndDate `is` endDate item, Deadline `is` deadline item]++instance (RuntimeConfig (PrintConfig c)) ⇒ ConfigShow c TodoItem where+ configShow item = (startFormat ∷ Formatter c) <++> (printM item ∷ Formatter c)
Todos/Main.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE UnicodeSyntax #-} -module Todos.Main (todos) where+module Todos.Main+ (module Todos.Default,+ module Todos.Config,+ module Todos.Dot,+ todos+ ) where import Prelude hiding (putStrLn,readFile,getContents,print) import IO@@ -15,13 +20,12 @@ 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+import Todos.Default realTodos ∷ (RuntimeConfig c) ⇒ TodosConfig c → IO () realTodos tcfg = do@@ -35,13 +39,12 @@ 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)+ JustShow → printTodos tcfg (mkPrintConfig currDate q tcfg) queried ShowAsDot → - putStrLn $ showAsDot (itemColor tcfg) (itemShape tcfg) (mapT format queried)+ putStrLn $ showAsDot (itemColor tcfg) (itemShape tcfg) queried SystemCommand cmd → do- forT selected (\item → system $ printfItem cmd (format item))+ forT selected (\item → system $ printfItem cmd item) return () where selected | outOnlyFirst bc = [Node (rootLabel $ head queried) []] | otherwise = queried
Todos/Parser.hs view
@@ -11,8 +11,9 @@ import Todos.Unicode import Todos.Types import Todos.Dates-import Todos.ParserTypes import Todos.Config++type TParser a = GenParser Char BaseConfig a strip ∷ String → String strip = reverse ∘ p ∘ reverse ∘ p
− Todos/ParserTypes.hs
@@ -1,10 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}-module Todos.ParserTypes where--import Text.ParserCombinators.Parsec--import Todos.Config---type TParser a = GenParser Char BaseConfig a-
− Todos/Print.hs
@@ -1,79 +0,0 @@-{-# 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/Shapes.hs
@@ -1,44 +0,0 @@-{-# 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/Types.hs view
@@ -149,7 +149,7 @@ -- | Flags to specify parsing mode data ModeFlag = Execute {unExecute ∷ String} | Prefix {unPrefix ∷ String}- | Describe {unDescribe ∷ String}+ | Format {getFormat ∷ String} | DoNotReadStatus | SetStatus {newStatus ∷ String} | SetTopStatus {newTopStatus ∷ String}@@ -164,6 +164,7 @@ | Highlight | Ids | DotExport+ | IndentWith {getIndentString ∷ String} | Sort {getSorting ∷ SortingType} deriving (Eq,Ord,Show)
todos.cabal view
@@ -1,5 +1,5 @@ Name: todos-Version: 0.3+Version: 0.4 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE@@ -17,26 +17,28 @@ library Exposed-Modules: Todos- Todos.CmdLine- Todos.Color- Todos.ParserTypes+ Todos.Default+ Todos.Default.CmdLine+ Todos.Default.Instances+ Todos.Default.Utils+ Todos.Default.Print+ Todos.Default.Config+ Todos.Dot+ Todos.Dot.Color+ Todos.Dot.Shapes+ Todos.Dot.Render 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,@@ -47,26 +49,28 @@ Executable todos Main-Is: todos.hs Other-Modules: Todos- Todos.CmdLine- Todos.Color- Todos.ParserTypes+ Todos.Default+ Todos.Default.CmdLine+ Todos.Default.Instances+ Todos.Default.Utils+ Todos.Default.Print+ Todos.Default.Config+ Todos.Dot+ Todos.Dot.Color+ Todos.Dot.Shapes+ Todos.Dot.Render 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