module Todos.Default.CmdLine
(parseCmdLine',
glob,
buildQuery,
compose,
usage)
where
import Prelude hiding (putStrLn,readFile,getContents,print)
import Prelude.Unicode
import System.Console.GetOpt
import System.FilePath.Glob hiding (glob)
import Data.Maybe
import Data.List (sort)
import Todos.IO
import Todos.Types
import Todos.Tree
import Todos.Default.Config
import Todos.Dates (parseDate)
compose โท DateTime
โ Composed
โ (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
buildQuery โท BaseConfig
โ 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
parseCmdLine' โท DateTime
โ [String]
โ Either String (Options, [FilePath])
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 โท String โ ๐น
isPattern s = ('*' โ s) || ('?' โ s)
glob โท [FilePath] โ IO [FilePath]
glob list = do
let patterns = filter isPattern list
files = filter (not โ isPattern) list
(matches, _) โ globDir (map compile patterns) "."
return $ sort $ files โงบ concat matches
usage โท String
usage = usageInfo header (options undefined)
where
header = "Usage: todos [OPTION...] [INPUT FILES]"
options โท DateTime โ [OptDescr CmdLineFlag]
options currDate = [
Option "1" ["only-first"] (NoArg (OF OnlyFirst)) "show only first matching entry",
Option "c" ["color"] (NoArg (OF Colors)) "show colored output",
Option "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 โท String โ CmdLineFlag
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"