diff --git a/README b/README --- a/README +++ b/README @@ -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. diff --git a/README.ru b/README.ru --- a/README.ru +++ b/README.ru @@ -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) вместо обычного вывода. Можно попробовать, например, так: diff --git a/Todos.hs b/Todos.hs --- a/Todos.hs +++ b/Todos.hs @@ -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 + diff --git a/Todos/CmdLine.hs b/Todos/CmdLine.hs deleted file mode 100644 --- a/Todos/CmdLine.hs +++ /dev/null @@ -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" diff --git a/Todos/Color.hs b/Todos/Color.hs deleted file mode 100644 --- a/Todos/Color.hs +++ /dev/null @@ -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 - diff --git a/Todos/CommandParser.hs b/Todos/CommandParser.hs --- a/Todos/CommandParser.hs +++ b/Todos/CommandParser.hs @@ -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] + diff --git a/Todos/Config.hs b/Todos/Config.hs --- a/Todos/Config.hs +++ b/Todos/Config.hs @@ -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 { diff --git a/Todos/ConfigInstances.hs b/Todos/ConfigInstances.hs deleted file mode 100644 --- a/Todos/ConfigInstances.hs +++ /dev/null @@ -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 - diff --git a/Todos/ConfigUtils.hs b/Todos/ConfigUtils.hs deleted file mode 100644 --- a/Todos/ConfigUtils.hs +++ /dev/null @@ -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 } - diff --git a/Todos/Dates.hs b/Todos/Dates.hs --- a/Todos/Dates.hs +++ b/Todos/Dates.hs @@ -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 diff --git a/Todos/Default.hs b/Todos/Default.hs new file mode 100644 --- /dev/null +++ b/Todos/Default.hs @@ -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 + diff --git a/Todos/Default/CmdLine.hs b/Todos/Default/CmdLine.hs new file mode 100644 --- /dev/null +++ b/Todos/Default/CmdLine.hs @@ -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" diff --git a/Todos/Default/Config.hs b/Todos/Default/Config.hs new file mode 100644 --- /dev/null +++ b/Todos/Default/Config.hs @@ -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) + diff --git a/Todos/Default/Instances.hs b/Todos/Default/Instances.hs new file mode 100644 --- /dev/null +++ b/Todos/Default/Instances.hs @@ -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 + diff --git a/Todos/Default/Print.hs b/Todos/Default/Print.hs new file mode 100644 --- /dev/null +++ b/Todos/Default/Print.hs @@ -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 "" + diff --git a/Todos/Default/Utils.hs b/Todos/Default/Utils.hs new file mode 100644 --- /dev/null +++ b/Todos/Default/Utils.hs @@ -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 } + diff --git a/Todos/Dot.hs b/Todos/Dot.hs --- a/Todos/Dot.hs +++ b/Todos/Dot.hs @@ -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 diff --git a/Todos/Dot/Color.hs b/Todos/Dot/Color.hs new file mode 100644 --- /dev/null +++ b/Todos/Dot/Color.hs @@ -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 + diff --git a/Todos/Dot/Render.hs b/Todos/Dot/Render.hs new file mode 100644 --- /dev/null +++ b/Todos/Dot/Render.hs @@ -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) + diff --git a/Todos/Dot/Shapes.hs b/Todos/Dot/Shapes.hs new file mode 100644 --- /dev/null +++ b/Todos/Dot/Shapes.hs @@ -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 + diff --git a/Todos/Formatters.hs b/Todos/Formatters.hs --- a/Todos/Formatters.hs +++ b/Todos/Formatters.hs @@ -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) diff --git a/Todos/Main.hs b/Todos/Main.hs --- a/Todos/Main.hs +++ b/Todos/Main.hs @@ -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 diff --git a/Todos/Parser.hs b/Todos/Parser.hs --- a/Todos/Parser.hs +++ b/Todos/Parser.hs @@ -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 diff --git a/Todos/ParserTypes.hs b/Todos/ParserTypes.hs deleted file mode 100644 --- a/Todos/ParserTypes.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE UnicodeSyntax #-} -module Todos.ParserTypes where - -import Text.ParserCombinators.Parsec - -import Todos.Config - - -type TParser a = GenParser Char BaseConfig a - diff --git a/Todos/Print.hs b/Todos/Print.hs deleted file mode 100644 --- a/Todos/Print.hs +++ /dev/null @@ -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 "" - diff --git a/Todos/Shapes.hs b/Todos/Shapes.hs deleted file mode 100644 --- a/Todos/Shapes.hs +++ /dev/null @@ -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 - diff --git a/Todos/Types.hs b/Todos/Types.hs --- a/Todos/Types.hs +++ b/Todos/Types.hs @@ -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) diff --git a/todos.cabal b/todos.cabal --- a/todos.cabal +++ b/todos.cabal @@ -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