diff --git a/CmdLine.hs b/CmdLine.hs new file mode 100644 --- /dev/null +++ b/CmdLine.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE UnicodeSyntax, PatternGuards #-} + +-- | Module for parsing command line options and build queries +module CmdLine + (parseCmdLine, + glob, + buildQuery, + composeAll, + usage) + where + +import Prelude hiding (putStrLn,readFile,getContents,print) +import IO +import Codec.Binary.UTF8.String +import System (getArgs) +import System.Console.GetOpt +import System.FilePath.Glob +import Data.Maybe +import Data.List (sort) +import Control.Monad.Reader + +import Unicode +import Types +import TodoTree +import Dates (parseDate) + +-- | Default limit for tree height +pruneByDefault ∷ Limit +pruneByDefault = Limit 20 + +-- | Compose predicate from Composed +compose ∷ DateTime -- ^ Current date/time + → Composed -- ^ Composed query + → (TodoItem → 𝔹) +compose _ Empty = const True +compose _ (Pred NoFilter) = const True +compose _ (Pred (Tag s)) = tagPred s +compose _ (Pred (Name s)) = grepPred s +compose _ (Pred (Status s)) = statusPred s +compose dt (Pred (StartDateIs d)) = datePred startDate dt d +compose dt (Pred (EndDateIs d)) = datePred endDate dt d +compose dt (Pred (DeadlineIs d)) = datePred deadline dt d +compose dt (Not p) = not ∘ (compose dt p) +compose dt (And (Pred NoFilter) p) = compose dt p +compose dt (And p (Pred NoFilter)) = compose dt p +compose dt (And p1 p2) = \item → (compose dt p1 item) ∧ (compose dt p2 item) +compose dt (Or (Pred NoFilter) p) = compose dt p +compose dt (Or p (Pred NoFilter)) = compose dt p +compose dt (Or p1 p2) = \item → (compose dt p1 item) ∨ (compose dt p2 item) +compose _ x = error $ show x + +concatMapM ∷ (Monad m) ⇒ m (t → [t]) → m ([t] → [t]) +concatMapM = liftM concatMap + +-- | Make a list transformer +composeAll ∷ DateTime → ListTransformer +composeAll date = do + pred ← asks ((compose date) ∘ query) + concatMapM (pruneSelector pred) + +appendC ∷ Composed → QueryFlag → Composed +appendC (Not (Pred NoFilter)) f = Not (Pred f) +appendC Empty OrCons = (Pred NoFilter) `Or` (Pred NoFilter) +appendC Empty AndCons = (Pred NoFilter) `And` (Pred NoFilter) +appendC Empty NotCons = Not (Pred NoFilter) +appendC Empty f = Pred f +appendC c NoFilter = c +appendC c AndCons = c `And` (Pred NoFilter) +appendC c OrCons = c `Or` (Pred NoFilter) +appendC c NotCons = c `And` (Pred NoFilter) +appendC (And c (Pred NoFilter)) f = c `And` (Pred f) +appendC (And (Pred NoFilter) c) f = c `And` (Pred f) +appendC c@(And _ _) f = c `And` (Pred f) +appendC (Or c (Pred NoFilter)) f = c `Or` (Pred f) +appendC (Or (Pred NoFilter) c) f = c `Or` (Pred f) +appendC c@(Or _ _) f = c `Or` (Pred f) +appendC c@(Pred _) f = c `And` (Pred f) +appendC c f = c `And` (Pred f) + +appendF (O q m o l) (QF f) = O (f:q) m o l +appendF (O q m o l) (MF f) = O q (f:m) o l +appendF (O q m o l) (OF f) = O q m (f:o) l +appendF (O q m o l) (LF f) = O q m o (f:l) +appendF _ HelpF = Help + +parseFlags ∷ [CmdLineFlag] → Options +parseFlags lst | HelpF ∈ lst = Help +parseFlags [] = O [] [] [] [] +parseFlags (f:fs) = (parseFlags fs) `appendF` f + +-- | Build Config (with query etc) from Options +buildQuery ∷ Options → Config +buildQuery (O qflags mflags oflags lflags) = Config onlyFirst colors srt limitP limitM command aprefix dformat composedFlags + where + composedFlags = parseQuery qflags + (limitP,limitM) = parseLimits lflags + + onlyFirst = OnlyFirst ∈ oflags + colors = Colors ∈ oflags + srtFlags = filter isSort oflags + srt | null srtFlags = DoNotSort + | otherwise = getSorting (last srtFlags) + + cmdFlags = filter isCommand mflags + command | null cmdFlags = Nothing + | otherwise = Just $ unExecute (last cmdFlags) + + prefixFlags = filter isPrefix mflags + aprefix | null prefixFlags = Nothing + | otherwise = Just $ unPrefix (last prefixFlags) + + dflags = filter isDescribe mflags + dformat | null dflags = "%d" + | otherwise = unDescribe $ last dflags + + isSort (Sort _) = True + isSort _ = False + isDescribe (Describe _) = True + isDescribe _ = False + isCommand (Execute _) = True + isCommand _ = False + isPrefix (Prefix _) = True + isPrefix _ = False + +parseLimits ∷ [LimitFlag] → (Limit,Limit) +parseLimits flags = (limitP,limitM) + where + pruneFlags = filter isPrune flags + minFlags = filter isMin flags + + limitP' = foldl min Unlimited $ map (Limit ∘ unPrune) pruneFlags + limitP | Unlimited ← limitP' = pruneByDefault + | otherwise = limitP' + + limitM' = foldl max (Limit 0) $ map (Limit ∘ unMin) minFlags + limitM | Unlimited ← limitM' = pruneByDefault + | otherwise = limitM' + + isPrune (Prune _) = True + isPrune _ = False + + isMin (Start x) = True + isMin _ = False + +parseQuery ∷ [QueryFlag] → Composed +parseQuery flags = foldl appendC Empty flags + +-- | Parse command line +parseCmdLine ∷ DateTime -- ^ Current date/time + → [String] -- ^ Command line args + → (Options, [FilePath]) -- ^ (Options, list of files) +parseCmdLine currDate args = + case getOpt Permute (options currDate) (map decodeString args) of + (flags, [], []) → (parseFlags flags, ["TODO"]) + (flags, nonOpts, []) → (parseFlags flags, nonOpts) + (_, _, msgs) → error $ concat msgs ⧺ usage + +isPattern s = ('*' ∈ s) || ('?' ∈ s) + +glob ∷ [FilePath] → IO [FilePath] +glob list = do + let patterns = filter isPattern list + files = filter (not ∘ isPattern) list + (matches, _) ← globDir (map compile patterns) "." + return $ sort $ files ⧺ concat matches + +usage ∷ String +usage = usageInfo header (options undefined) + where + header = "Usage: todos [OPTION...] [INPUT FILES]" + +options ∷ DateTime → [OptDescr CmdLineFlag] +options currDate = [ + Option "1" ["only-first"] (NoArg (OF OnlyFirst)) "show only first matching entry", + Option "c" ["color"] (NoArg (OF Colors)) "show colored output", + Option "A" ["prefix"] (OptArg mkPrefix "PREFIX") "use alternate parser: read only lines starting with PREFIX", + Option "D" ["describe"] (OptArg mkDescribe "FORMAT") "use FORMAT for descriptions", + 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 "s" ["status"] (ReqArg mkStatus "STRING") "find items with status 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 + +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 + +mkDescribe ∷ Maybe String → CmdLineFlag +mkDescribe Nothing = MF $ Describe "%d" +mkDescribe (Just f) = MF $ Describe f + +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/CommandParser.hs b/CommandParser.hs new file mode 100644 --- /dev/null +++ b/CommandParser.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE UnicodeSyntax #-} + +module CommandParser where + +import Unicode +import Types + +-- | Format item info +printfItem ∷ String -- ^ Format string + → TodoItem + → String +printfItem pattern item = printf pattern + where + printf "" = "" + printf [x] = [x] + printf ('%':c:xs) = (itemPart c) ⧺ printf xs + printf (x:xs) = x:printf xs + + itemPart 'L' = show $ itemLevel item + itemPart 'n' = itemName item + itemPart 't' = unwords $ itemTags item + itemPart 's' = itemStatus item + itemPart 'd' = itemDescr item + itemPart 'f' = fileName item + itemPart 'l' = show $ lineNr item + itemPart x = [x] diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE UnicodeSyntax #-} + +-- | Module for parsing config files +module Config + (readConfig) + where + +import Prelude hiding (putStrLn,readFile,getContents,print) +import IO +import System.Environment +import System.FilePath +import System.Directory (doesFileExist) +import Data.Maybe +import Data.Either +import Text.ParserCombinators.Parsec + +import Unicode +import Types + +word ∷ Parser String +word = choice $ map try [quotedOption, simpleOption, quoted, simpleWord] + +simpleWord = many1 $ noneOf " \t\r\n=\"'" + +quotedOption = (try quotedLongOption) <|> quotedShortOption + +quotedLongOption ∷ Parser String +quotedLongOption = do + string "--" + o ← simpleWord + char '=' + v ← quoted + return ("--" ⧺ o ⧺ "=" ⧺ v) + +quotedShortOption ∷ Parser String +quotedShortOption = do + string "-" + o ← simpleWord + v ← quoted + return ("-" ⧺ o ⧺ v) + +simpleOption = do + o ← simpleWord + optional $ char '=' + v ← simpleWord + return (o ⧺ "=" ⧺ v) + +quoted = quoted1 <|> quoted2 + +quoted1 = do + char '\'' + s ← many1 $ noneOf "'" + char '\'' + return s + +quoted2 = do + char '"' + s ← many1 $ noneOf "\"" + char '"' + return s + +pConfig ∷ Parser [String] +pConfig = word `sepBy` space + +parseConfig ∷ String → [String] +parseConfig str = + case parse pConfig "config file" str of + Right lst → lst + Left err → error $ show err + +readFile' ∷ FilePath → IO [String] +readFile' path = + do b ← doesFileExist path + if not b + then return [] + else do + str ← readFile path + return $ parseConfig (unwords $ lines str) + +-- | Read list of options from config files +readConfig ∷ IO [String] +readConfig = do + home ← getEnv "HOME" + let homepath = home ".config" "todos" + homecfg ← readFile' homepath + localcfg ← readFile' ".todos.conf" + return $ homecfg ⧺ localcfg + diff --git a/ConstrSet.hs b/ConstrSet.hs new file mode 100644 --- /dev/null +++ b/ConstrSet.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE UnicodeSyntax, DeriveDataTypeable, NoMonomorphismRestriction #-} + +module ConstrSet + (CSet, + empty, + fromList, toList, + insert, append, + elemC, + selectByConstrOf, + selectByConstrOf' + ) where + +import Data.Generics +import Data.Function (on) +import Data.List (nubBy) +import Data.Maybe (fromMaybe) + +teq = (==) `on` toConstr + +data (Data a) ⇒ CSet a = CSet [a] + +empty = CSet [] + +fromList lst = CSet $ nubBy teq lst +toList (CSet lst) = lst + +insert item (CSet []) = CSet [item] +insert item (CSet lst) = CSet $ nubBy teq (item:lst) + +selectByConstrOf (CSet []) _ = Nothing +selectByConstrOf (CSet (x:xs)) y | x `teq` y = Just x + | otherwise = selectByConstrOf (CSet xs) y + +selectByConstrOf' def cset x = fromMaybe def $ selectByConstrOf cset x + +elemC _ (CSet []) = False +elemC x (CSet (y:ys)) | x `teq` y = True + | otherwise = elemC x (CSet ys) + +append (CSet xs) (CSet ys) = CSet $ nubBy teq (xs++ys) diff --git a/Dates.hs b/Dates.hs new file mode 100644 --- /dev/null +++ b/Dates.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE UnicodeSyntax #-} +-- | Operations with dates +module Dates + (parseDate, getCurrentDateTime, + pSpecDates) + where + +import Data.Char (toUpper) +import Data.Function (on) +import Data.List +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.LocalTime +import Text.ParserCombinators.Parsec + +import Types +import Unicode + +getCurrentDateTime ∷ IO DateTime +getCurrentDateTime = do + zt ← getZonedTime + let lt = zonedTimeToLocalTime zt + ld = localDay lt + ltod = localTimeOfDay lt + (y,m,d) = toGregorian ld + h = todHour ltod + min = todMin ltod + s = round $ todSec ltod + return $ DateTime (fromIntegral y) m d h min s + +uppercase ∷ String → String +uppercase = map toUpper + +isPrefixOfI ∷ String → String → Bool +p `isPrefixOfI` s = (uppercase p) `isPrefixOf` (uppercase s) + +lookupS ∷ String → [(String,a)] → Maybe a +lookupS _ [] = Nothing +lookupS k ((k',v):other) | k `isPrefixOfI` k' = Just v + | otherwise = lookupS k other + +monthsN ∷ [(String,Int)] +monthsN = zip months [1..] + +lookupMonth ∷ String → Maybe Int +lookupMonth n = lookupS n monthsN + +date ∷ Int → Int → Int → DateTime +date y m d = DateTime y m d 0 0 0 + +addTime ∷ DateTime → Time → DateTime +addTime dt t = dt { + hour = tHour t + hour dt, + minute = tMinute t + minute dt, + second = tSecond t + second dt } + +times ∷ Int → Parser t → Parser [t] +times 0 _ = return [] +times n p = do + ts ← times (n-1) p + t ← optionMaybe p + case t of + Just t' → return (ts ++ [t']) + Nothing → return ts + +number ∷ Int → Int → Parser Int +number n m = do + t ← read `fmap` (n `times` digit) + if t > m + then fail "number too large" + else return t + +pYear ∷ Parser Int +pYear = do + y ← number 4 10000 + if y < 2000 + then return (y+2000) + else return y + +pMonth ∷ Parser Int +pMonth = number 2 12 + +pDay ∷ Parser Int +pDay = number 2 31 + +euroNumDate ∷ Parser DateTime +euroNumDate = do + d ← pDay + char '.' + m ← pMonth + char '.' + y ← pYear + return $ date y m d + +americanDate ∷ Parser DateTime +americanDate = do + y ← pYear + char '/' + m ← pMonth + char '/' + d ← pDay + return $ date y m d + +euroNumDate' ∷ Int → Parser DateTime +euroNumDate' year = do + d ← pDay + char '.' + m ← pMonth + return $ date year m d + +americanDate' ∷ Int → Parser DateTime +americanDate' year = do + m ← pMonth + char '/' + d ← pDay + return $ date year m d + +strDate ∷ Parser DateTime +strDate = do + d ← pDay + space + ms ← many1 letter + case lookupMonth ms of + Nothing → fail $ "unknown month: "++ms + Just m → do + space + y ← pYear + notFollowedBy $ char ':' + return $ date y m d + +strDate' ∷ Int → Parser DateTime +strDate' year = do + d ← pDay + space + ms ← many1 letter + case lookupMonth ms of + Nothing → fail $ "unknown month: "++ms + Just m → return $ date year m d + +time24 ∷ Parser Time +time24 = do + h ← number 2 23 + char ':' + m ← number 2 59 + x ← optionMaybe $ char ':' + case x of + Nothing → return $ Time h m 0 + Just _ → do + s ← number 2 59 + notFollowedBy letter + return $ Time h m s + +ampm ∷ Parser Int +ampm = do + s ← many1 letter + case map toUpper s of + "AM" → return 0 + "PM" → return 12 + _ → fail "AM/PM expected" + +time12 ∷ Parser Time +time12 = do + h ← number 2 12 + char ':' + m ← number 2 59 + x ← optionMaybe $ char ':' + s ← case x of + Nothing → return 0 + Just s' → number 2 59 + optional space + hd ← ampm + return $ Time (h+hd) m s + +pAbsDate ∷ Int → Parser DateTime +pAbsDate year = do + date ← choice $ map try $ map ($ year) $ [ + const euroNumDate, + const americanDate, + const strDate, + strDate', + euroNumDate', + americanDate'] + optional $ char ',' + s ← optionMaybe space + case s of + Nothing → return date + Just _ → do + t ← choice $ map try [time12,time24] + return $ date `addTime` t + +data DateIntervalType = Day | Week | Month | Year + deriving (Eq,Show,Read) + +data DateInterval = Days ℤ + | Weeks ℤ + | Months ℤ + | Years ℤ + deriving (Eq,Show) + +convertTo ∷ DateTime → Day +convertTo dt = fromGregorian (fromIntegral $ year dt) (month dt) (day dt) + +convertFrom ∷ Day → DateTime +convertFrom dt = + let (y,m,d) = toGregorian dt + in date (fromIntegral y) m d + +modifyDate ∷ (t → Day → Day) → t → DateTime → DateTime +modifyDate fn x dt = convertFrom $ fn x $ convertTo dt + +addInterval ∷ DateTime → DateInterval → DateTime +addInterval dt (Days ds) = modifyDate addDays ds dt +addInterval dt (Weeks ws) = modifyDate addDays (ws*7) dt +addInterval dt (Months ms) = modifyDate addGregorianMonthsClip ms dt +addInterval dt (Years ys) = modifyDate addGregorianYearsClip ys dt + +maybePlural ∷ String → Parser String +maybePlural str = do + r ← string str + optional $ char 's' + return (capitalize r) + +pDateInterval ∷ Parser DateIntervalType +pDateInterval = do + s ← choice $ map maybePlural ["day", "week", "month", "year"] + return $ read s + +pRelDate ∷ DateTime → Parser DateTime +pRelDate date = do + offs ← (try futureDate) <|> (try passDate) <|> (try today) <|> (try tomorrow) <|> yesterday + return $ date `addInterval` offs + +futureDate ∷ Parser DateInterval +futureDate = do + string "in " + n ← many1 digit + char ' ' + tp ← pDateInterval + case tp of + Day → return $ Days (read n) + Week → return $ Weeks (read n) + Month → return $ Months (read n) + Year → return $ Years (read n) + +passDate ∷ Parser DateInterval +passDate = do + n ← many1 digit + char ' ' + tp ← pDateInterval + string " ago" + case tp of + Day → return $ Days $ - (read n) + Week → return $ Weeks $ - (read n) + Month → return $ Months $ - (read n) + Year → return $ Years $ - (read n) + +today ∷ Parser DateInterval +today = do + string "today" + return $ Days 0 + +tomorrow ∷ Parser DateInterval +tomorrow = do + string "tomorrow" + return $ Days 1 + +yesterday ∷ Parser DateInterval +yesterday = do + string "yesterday" + return $ Days (-1) + +pDate ∷ DateTime → Parser DateTime +pDate date = (try $ pRelDate date) <|> (try $ pAbsDate $ year date) + +dateType ∷ String → DateType +dateType "start" = StartDate +dateType "end" = EndDate +dateType "deadline" = Deadline +dateType _ = error "unknown date type" + +pSpecDate ∷ DateTime → Parser (DateType, DateTime) +pSpecDate date = do + tp ← choice $ map string ["start","end","deadline"] + string ": " + dt ← pDate date + return (dateType tp, dt) + +pSpecDates ∷ DateTime → Parser [(DateType, DateTime)] +pSpecDates date = do + char '(' + pairs ← (pSpecDate date) `sepBy1` (string "; ") + string ") " + return pairs + +-- | Parse date/time +parseDate ∷ DateTime -- ^ Current date/time + → String -- ^ String to parse + → Either ParseError DateTime +parseDate date s = parse (pDate date) "" s + diff --git a/IO.hs b/IO.hs new file mode 100644 --- /dev/null +++ b/IO.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +-- | Wrapper to support unicode IO with GHC 6.10 and 6.12 +module IO +#if __GLASGOW_HASKELL__ < 612 + (module System.IO.UTF8) +#else + (module Prelude) +#endif + where + +#if __GLASGOW_HASKELL__ < 612 + + import Prelude hiding (putStr, putStrLn,readFile,getContents,print) + import System.IO.UTF8 + +#else + + import Prelude + +#endif diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ilya V. Portnov 2010 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of me nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,8 @@ +GHC=ghc +GHCFLAGS=-O2 + +todos: *.hs + $(GHC) $(GHCFLAGS) --make todos.hs + +clean: + rm -f *.hi *.o *~ diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,91 @@ +todos README +============ +Ilya V. Portnov + +todos is a simple TODO manager. TODO records theirself are described in +plain-text file, and todos allows you to show only needed of them. So, todos +works as specialized `grep' utility. + +By default, output format is the same as input; so, you can combine several +`todos' instances into unix pipes. + +If source files are not given in the commandline, file with name "TODO" in +current directory is used. If "-" is given as file name, todos will read +standart input. + +todos supports two formats of input files. In first case, file contains TODOS +records and only them. In «alternative» format, source files can contain any +text, but it's ignored; only lines starting with given prefix ("TODO: " by +default) are parsed. So, alternative format enable you to grep TODO records +from any files, for example, program source files. + +Following is format of TODO record: + + [spaces]status (dates) [TAGS] title (depends) description + +Here [spaces] is optional indent with spaces, «status» — is status of record +(for example, URGENT or DONE; can be any word), «dates» give info about dates +(see below), «TAGS» is a comma-separated list of tags in brackets, «title» is +title of record, «depends» — comma-separated list of depends (titles of other +records) in parenthesis, «description» is description of the record. All fields +except status and title are optional. Description is separated from title with +not less than 2 spaces. + +Using different indents one can create sub-records (and, so, trees of records). +Moreover, depends are interpreted in same way as sub-records. So, one can +create not only trees of records, but arbitrary graphs of records (even +cycled). When cycled graphs are used, user should control for rational level of +hierarchy (for example, one can bound height of output tree using -p option). + +Dates information is described in parenthesis, as not more than 3 records, +separated with semicolon. Each records has format «date type: date». Date type +can be one of: start, end, deadline. For dates, many formats are supported; for +example, «18 Feb», или «02/18/2010», «2010/02/18» are all valid dates. One can +even use relative dates specification here, such as «in 2 weeks» or «2 days +ago», but there is no point to this: all dates are counted from program start +date. + +Next commandline options are supported: + + -1 --only-first show only first matching entry + -c --color show colored output + -A[PREFIX] --prefix[=PREFIX] use alternate parser: read only lines starting with PREFIX + -D[FORMAT] --describe[=FORMAT] use FORMAT for descriptions + -p N --prune=N limit tree height to N + -m N --min-depth=N show first N levels of tree unconditionally + -t TAG --tag=TAG find items marked with TAG + -g PATTERN --grep=PATTERN find items with PATTERN in name + -s STRING --status=STRING find items with status equal to STRING + -a --and logical AND + -o --or logical OR + -n --not logical NOT + --sort=FIELD specify sorting + -e[COMMAND] --exec[=COMMAND] run COMMAND on each matching entry + -S DATE --start-date=DATE find items with start date bounded with DATE + -E DATE --end-date=DATE find items with end date bounded with DATE + -d DATE --deadline=DATE find items with deadline bounded with DATE + -h --help display this help + +Dates in the commandline are specified in any of supported formats. There +relative dates specifications are useful: how about something like «todos +--deadline=yesterday»? ;) + +For --describe and --exec options, printf-style format strings should be +specified. Following substitution sequences are supported: + +%n :: title of the record +%t :: list of record's tags +%s :: status of the record +%d :: description of the record +%f :: name of file, in which record was found +%l :: number of line in source file + +For example, «todos -tBUG -e"vi %f +%l"» command for each record with «BUG» tag +will open vi with corresponding file on corresponding line. + +todos can read configuration files: ~/.config/todos («global») and +./.todos.conf («local»). Config files contain command line options, in the same +format as in the commandline. Resulting commandline is composed as: (options in +global config) + (options in local config) + (options in the actual command +line). If there is no one of configs, todos will ignore it. + diff --git a/README.ru b/README.ru new file mode 100644 --- /dev/null +++ b/README.ru @@ -0,0 +1,96 @@ +todos README +============ +Ilya V. Portnov + +todos — это простой TODO-менеджер. Сами записи TODO описываются в простом +текстовом файле, а todos позволяет показывать из них только нужные, работая как +специализированная утилита grep. При этом формат вывода по умолчанию совпадает +с форматом входных файлов, поэтому вывод todos можно опять подавать на вход +todos через конвейер. Если входные файлы не указаны в командной строке, +читается файл TODO в текущей директории. Если вместо имени файла указано «-», +читается стандартный ввод. + +todos поддерживает два формата входных файлов. В первом случае файл содержит +только сами записи TODO и ничего больше. В «альтернативном» формате входные +файлы могут содержать произвольный текст, но он игнорируется, а читаются только +строки, начинающиеся с заданного префикса (по умолчанию TODO:), при этом формат +строки после префикса тот же, что в первом случае. Альтернативный формат +позволяет отбирать записи TODO из произвольных файлов, например исходных +текстов программы. + +Формат записи TODO следующий: + + [spaces]status (dates) [TAGS] title (depends) description + +Здесь [spaces] — это необязательный отступ пробелами, status — статус записи +(например URGENT или DONE, но может быть произвольным словом), dates — +информация о датах (см. ниже), TAGS — список тегов через пробел в квадратных +скобках, title — заголовок записи, depends — список зависимостей (заголовков +других записей) в скобках через запятую, description — описание записи. Все +поля кроме статуса и заголовка необязательны. Описание отделяется от заголовка +не менее чем двумя пробелами. + +С помощью разных отступов можно создавать вложенные записи. Кроме того, +зависимости интерпретируются также как вложенные записи; они позволяют +создавать не только дерево записей, но и произвольный граф, в том числе и с +циклами. В случае наличия циклов (когда задача A зависит от B, а B — от A) +контроль за разумным выводом программы возлагается на пользователя (например, +можно ограничить высоту выводимого дерева опцией -p). + +Информация о датах записывается в скобках, в виде не более чем трёх записей +через точку с запятой, каждая запись имеет вид «тип_даты: дата». Тип даты может +быть start, end, или deadline (предполагается, что так обозначаются +соответственно дата начала выполнения задачи, планируемая дата окончания и +дедлайн соответственно). Для дат поддерживается довольно много форматов; +например, «18 Feb», или «02/18/2010», и мн. др. Тут могут указываться и +относительные даты (вида «in 2 weeks», «2 days ago» или просто «tomorrow»), но +это имеет мало смысла — относительные даты считаются от момента запуска +программы. + +Поддерживаются следующие опции командной строки: + +-1, --only-first :: показывать только первую запись из всех, что должны быть показаны +-c, --color :: раскрашивать вывод todos (заголовки записей — полужирным, некоторые статусы выделяются цветом) +-A, --prefix= :: использовать альтернативный формат файлов, тут же указывается префикс +-D, --describe :: можно указать формат для выводимого описания (см. ниже) +-p, --prune :: ограничить максимальную высоту дерева (для каждой из отобранных записей будет показано не более чем N уровней вложенности) +-m, --min-depth :: ограничить минимальную высоту дерева +-t, --tag :: вывести только записи с заданным тегом и их вложенные записи +-g, --grep :: искать по заголовкам записей +-s, --status :: искать по статусам записей +-a, --and :: логическое И; например, todos -s! -a -tBUG — искать записи со статусом «!» и тегом «BUG» +-o, --or :: логическое ИЛИ; +-n, --not :: логическое НЕ; +-e, --exec :: вместо того, чтобы показывать записи, для каждой записи выполнить заданную команду; в строке для команды можно использовать символы подстановки, см. ниже +-S, --start-date :: искать по дате начала +-E, --end-date :: искать по планируемой дате завершения +-d, --deadline :: искать по дедлайну +-h, --help :: показать краткую справку по опциям командной строки + +Даты в командной строке могут быть во всех тех же форматах, что и во входных +файлах. Тут как раз обычно более удобны относительные даты. Если указана дата в +прошлом, записи ищутся по признаку «больше или равно», например, todos +--deadline=yesterday будет искать записи с дедлайном вчера, сегодня или где +угодно в будущем. Если указана дата в будущем, записи ищутся по признаку +«меньше или равно»; например, todos --start-date="in 2 weeks" будет искать +записи с датой начала через 2 недели или раньше (в т.ч. и в прошлом). + +Для опций --describe и --exec указываются строки формата с символами +подстановки в стиле printf. Поддерживаются следующие символы подстановки: + +%n :: заменяется на заголовок записи +%t :: список тегов записи +%s :: статус записи +%d :: описание записи +%f :: имя файла, в котором встретилась запись +%l :: номер строки в файле, где встретилась запись + +Например, todos -tBUG -e"vi %f +%l" для каждой записи с тегом BUG откроет vi на +строчке с этой записью. + +todos может читать конфигурационные файлы: ~/.config/todos (глобальный) и +.todos.conf в текущей директории (локальный). Конфигурационные файлы содержат +ключи командной строки. «Эффективная командная строка» составляется как (ключи +в глобальном конфиге) + (ключи в локальном конфиге) + ключи в командной строке. +Если какого-то из конфигов нет, todos это проигнорирует. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,62 @@ +X [TODO] Написать TodoManager todos.hs + ? (start: 13 Feb) [TODO] Даты Поддержка дат + - Дата начала, предполагаемая дата завершения, дедлайн + + все даты опциональны + + разные форматы дат + + (end: 15 Feb) отбор по датам + ? Какую-нибудь более умную логику для дат в будущем/прошлом + ? вычисление недостающих дат по зависимостям + ? Поддержка ресурсов + ? Формат описания в тудушках + ? Тогда уж и распределение по ресурсам + + [queries] Запросы TodoTree.hs + + По глубине вложенности + + По тегам + + По тексту + + в т.ч. по регэкспам + + По статусу + * комбинации Комбинации запросов (and/or/not) + * Тогда надо какие-то комбинаторы делать для selector-ов + DONE Отрефакторить слишком много промежуточных стадий + DONE Not ещё приделать + - улучшить поведение -a, -o + - или нормально задокументировать текущее + DONE научить пропускать первые N уровней чтобы первые уровни показывать, а остальные только по условию + ? Язык запросов (комбинации) + + или ключи ком.строки + - Отключение -A итп с ком. строки + + Всякие сортировки + + Раскраски + + Сделать раскраску отключаемой + : Формат тудушек (Даты) + DONE всё кроме описания сделать необязательным + - [BUG] баги с синтаксисом + FIXED spaces Trailing spaces !? + : [BUG TODO] Баги + - [BUG] синтаксис (spaces) + FIXED [BUG] ссылки на произвольное место + INVALID [BUG] grep не ищет по верхнему уровню + ? [BUG] что-то странное с grep-ом видимо, из-за юникода. + - Prune не работает, если не задано условие +: First + Y [Tag2] Second' + + [Tag2] THird + Y [Tag1] Second +DONE [НГ Tag1] Купить конфет +X [Tag1] Fyy + ! [Tag2] Sxx + X [TODO] Tyy + Y [Tag1] Tzz +X [Tag2] Last +o [Test] Test Todo + o Test 1 (Баги) + o Test 2 + o [Test] Test 21 + T Todo test + T Yet another Todo test + o [Test] Subtest 1 + o [Test] Subtest 11 + o [Test] Subtest 12 + o [Test] Subtest 2 + o [Test] Subtest 21 + T [Test] Test 3 diff --git a/TodoLoader.hs b/TodoLoader.hs new file mode 100644 --- /dev/null +++ b/TodoLoader.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE UnicodeSyntax, PatternGuards #-} +-- | Read TODOs from files and construct corresponding ADTs. +module TodoLoader + (loadTodo) + where + +import Prelude hiding (putStrLn,readFile,getContents,print) +import IO +import Control.Monad (forM) +import qualified Data.Map as M +import Text.ParserCombinators.Parsec +import Data.Maybe +import Data.Tree + +import Unicode +import Types +import TodoParser + +todoName ∷ Todo → String +todoName todo = itemName ⋄ rootLabel todo + +getDepends ∷ TodoMap → TodoItem → [Todo] +getDepends m item = catMaybes [M.lookup name m | name ← depends item] + +normalizeItem ∷ TodoMap → TodoItem → Todo +normalizeItem m item = Node item (map (normalize m) ⋄ getDepends m item) + +normalize ∷ TodoMap → Todo → Todo +normalize m todo = Node item' ((map (normalize m) subTodos) ⧺ (map (normalize m) deps)) + where + item ∷ TodoItem + item = rootLabel todo + + item' ∷ TodoItem + item' = item {depends=[]} + + subTodos ∷ [Todo] + subTodos = subForest todo + + deps ∷ [Todo] + deps = getDepends m item + +normalizeList ∷ TodoMap → [Todo] → [Todo] +normalizeList m todos = map (normalize m) todos + +readFile' ∷ FilePath → IO String +readFile' "-" = getContents +readFile' file = readFile file + +loadFile ∷ Maybe String → DateTime → FilePath → IO [TodoItem] +loadFile Nothing year path = do + text ← readFile' path + return $ parsePlain year path text +loadFile (Just p) year path = do + text ← readFile' path + return $ parseAlternate 2 p year path text + +(~-) ∷ TodoItem → ℤ → TodoItem +i@(Item {itemLevel=n}) ~- k = i {itemLevel=n-k} + +iszero ∷ TodoItem → 𝔹 +iszero item = (itemLevel item)==0 + +group' ∷ [TodoItem] → [[TodoItem]] +group' [] = [] +group' (x:xs) = let (one,other) = break iszero xs + in (x:one):group' other + +mkTodo ∷ [TodoItem] → [Todo] +mkTodo = (map mkTodo') ∘ group' + +mkTodo' ∷ [TodoItem] → Todo +mkTodo' (x:xs) = Node x other + where other = mkTodo ⋄ map (~-lvl) xs + lvl = itemLevel (head xs) + +consTodoMap ∷ [Todo] → TodoMap +consTodoMap todos = M.fromList (cons1 100 todos) + where + cons1 ∷ Int → [Todo] → [(String,Todo)] + cons1 0 _ = [] + cons1 max trees = [(todoName todo, todo) | todo ← trees] ⧺ cons1 (max-1) (children trees) + children ∷ [Todo] → [Todo] + children trees = concatMap subForest trees + +stitchTodos ∷ [TodoItem] → [Todo] +stitchTodos items = + let m = consTodoMap t + t = mkTodo items + in normalizeList m t + +-- | Load list of TODO trees from files +loadTodo ∷ Maybe String -- ^ Nothing for plain format, Just prefix for alternate format + → DateTime -- ^ Current date/time + → [FilePath] -- ^ List of files + → IO [Todo] +loadTodo maybePrefix date paths = do + tss ← forM paths (loadFile maybePrefix date) + return $ stitchTodos (concat tss) diff --git a/TodoParser.hs b/TodoParser.hs new file mode 100644 --- /dev/null +++ b/TodoParser.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE UnicodeSyntax, NoMonomorphismRestriction, TypeSynonymInstances, DeriveDataTypeable #-} +module TodoParser + (parsePlain, parseAlternate) + where + +import Prelude hiding (putStrLn,readFile,getContents,print) +import IO +import Control.Monad +import Data.List +import Text.ParserCombinators.Parsec +import qualified Data.Map as M +import Data.Tree +import Data.Maybe +import Data.Char +import Data.Function + +import Unicode +import Types +import Dates + +strip ∷ String → String +strip = reverse ∘ p ∘ reverse ∘ p + where + p = dropWhile isSpace + +pSpace ∷ Parser Char +pSpace = oneOf " \t" + +pSpace' ∷ Parser String +pSpace' = do + pSpace + return " " + +pSpaces ∷ Parser String +pSpaces = many pSpace + +pDeps ∷ Parser [String] +pDeps = do + string "(" + ws ← (many1 ⋄ noneOf ",)\n\r") `sepBy` (char ',') + string ")" + return $ map strip ws + +pTags ∷ Parser [String] +pTags = do + ts ← between (char '[') (char ']') $ word `sepBy1` pSpace + pSpaces + return ts + where + word = many1 (noneOf " \t\n\r]") + +pItem ∷ DateTime → Parser TodoItem +pItem date = do + pos ← getPosition + s ← pSpaces + stat ← pWord + dates ← (try (pSpecDates date) <|> return []) + tags ← (try pTags <|> return []) + namew ← many1 pWord + pSpaces + deps ← (try pDeps <|> return []) + pSpaces + descr ← many (noneOf "\n\r") + pSpaces + many ⋄ oneOf "\n\r" + return ⋄ Item { + itemLevel = fromIntegral $ length s, + itemName = unwords namew, + itemTags = tags, + depends = deps, + itemStatus = stat, + itemDescr = descr, + startDate = lookup StartDate dates, + endDate = lookup EndDate dates, + deadline = lookup Deadline dates, + fileName = sourceName pos, + lineNr = sourceLine pos } + +pWord ∷ Parser String +pWord = do + w ← many1 (noneOf " \t\n\r") + (try pSpace') <|> (return w) + return w + +pItems ∷ DateTime → Parser [TodoItem] +pItems date = do + its ← many (pItem date) + eof + return its + +unwords' ∷ String → [String] → String +unwords' prefix lst = + let (hd:tl) = map (filter (/='\r')) lst + addLines = filter (not ∘ (prefix `isPrefixOf`)) tl + in case addLines of + [] → hd + _ → hd ⧺ " {" ++ (unwords addLines) ++ "}" + +filterN ∷ (Num a, Enum a) ⇒ Int → String → [String] → ([a], [String]) +filterN n prefix lst = + let zipped = zip [0..] lst + good = filter (isGood ∘ snd) zipped + lns = map fst good + sub k l = (take l) ∘ (drop k) + ans = map (unwords' prefix) [sub j n lst | j ← lns] + isGood x = prefix `isPrefixOf` x + cut = drop (1+length prefix) + in (map (+1) lns, map cut ans) + +filterJoin ∷ Int → String → String → ([Int], String) +filterJoin n prefix str = + let (ns, lns) = filterN n prefix (lines str) + in (ns, unlines lns) + +-- | Read list of TODO items from plain format +parsePlain ∷ DateTime -- ^ Current date/time + → SourceName -- ^ Source file name + → String -- ^ String to parse + → [TodoItem] +parsePlain date path text = + case parse (pItems date) path text of + Right items → items + Left e → error $ show e + +-- | Read list of TODO items from alternate format +parseAlternate ∷ Int -- ^ Number of lones after matching to include to item's description + → String -- ^ Prefix to match + → DateTime -- ^ Current date/time + → SourceName -- ^ Source file name + → String -- ^ String to parse + → [TodoItem] +parseAlternate next prefix date path text = + let (ns, filtered) = filterJoin next prefix text + renumber lst = zipWith renumber1 ns lst + renumber1 n item = item {lineNr=n} + in case parse (pItems date) path filtered of + Right items → renumber items + Left e → error $ show e + diff --git a/TodoTree.hs b/TodoTree.hs new file mode 100644 --- /dev/null +++ b/TodoTree.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE UnicodeSyntax, NoMonomorphismRestriction, FlexibleInstances, TypeSynonymInstances #-} +module TodoTree + (delTag, + pruneSelector, + tagPred, statusPred, grepPred, datePred, + forT, mapT, + printTodos) + where + +import Prelude hiding (putStrLn,readFile,getContents,print) +import IO +import Control.Monad +import Control.Monad.Reader +import qualified Data.Map as M +import Data.Generics +import Data.List +import Data.Function (on) +import Data.Tree +import Data.Maybe +import Text.Regex.PCRE + +import Types +import TodoLoader +import Unicode + +sortBy' s | s == DoNotSort = id + | otherwise = sortBy sorter + where + sorter = compare `on` (f ∘ rootLabel) + f = case s of + ByTitle → itemName + ByStatus → itemStatus + ByTags → unwords ∘ itemTags + ByStartDate → show ∘ startDate + ByEndDate → show ∘ endDate + ByDeadline → show ∘ deadline + +showT ∷ SortingType → Int → Todo → [ConfigM] +showT s n (Node item todos) = + (configM <++> (replicate n ' ') <++> (configShow item)) : + (concatMap (showT s (n+2)) $ sortBy' s todos) + +unlines'' ∷ [ConfigM] → ConfigM +unlines'' lst = concat `fmap` (sequence $ intersperse newLine lst) + +showTodo ∷ Todo → ConfigM +showTodo t = do + conf ← ask + let f = case outOnlyFirst conf of + False → unlines'' + True → head + f $ showT (sorting conf) 0 t + +showTodos ∷ [Todo] → ConfigM +showTodos lst = do + conf ← ask + let f = case outOnlyFirst conf of + False → unlines'' + True → head + f $ map showTodo $ sortBy' (sorting conf) $ nub lst + +printTodos ∷ Config → [Todo] → IO () +printTodos conf lst = + let lst' = runReader (showTodos lst) conf + in mapM_ outItem lst' + +mapTags ∷ (Data a) ⇒ ([String] → [String]) → [a] → [a] +mapTags f = map ⋄ everywhere ⋄ mkT changeTags + where + changeTags item@(Item {itemTags=ts}) = item {itemTags = f ts} + +addTag ∷ (Data a) ⇒ String → [a] → [a] +addTag t = mapTags (t:) + +delTag ∷ (Data a) ⇒ String → [a] → [a] +delTag t = mapTags (delete t) + +pruneSelector ∷ (TodoItem → 𝔹) → Transformer +pruneSelector pred = do + (Limit n) ← asks pruneL + (Limit m) ← asks minL + return $ pruneSelector' n m pred + +pruneSelector' ∷ ℤ → ℤ → (TodoItem → 𝔹) → (Todo → [Todo]) +pruneSelector' n m pred = select n 0 False + where + select k t b (Node item trees) | t < m = [Node item ⋄ concatMap (select (n-1) (t+1) True) trees] + | pred item = [Node item ⋄ concatMap (select (n-1) (t+1) True) trees] + | (k > 0) ∧ b = [Node item ⋄ concatMap (select (k-1) (t+1) True) trees] + | k > 0 = concatMap (select (k-1) (t+1) False) trees + | otherwise = [] + +addS ∷ (Show a) ⇒ a → TodoItem → TodoItem +addS s item@(Item {itemName=name}) = item {itemName = name ⧺ " — " ⧺ show s} + +tagPred ∷ String → TodoItem → 𝔹 +tagPred tag = \item → tag ∈ itemTags item + +statusPred ∷ String → TodoItem → 𝔹 +statusPred st = \item → st == itemStatus item + +grepPred ∷ String → TodoItem → 𝔹 +grepPred pattern = \item → itemName item =~ pattern + +isLT ∷ (Ord t) ⇒ Maybe t → t → 𝔹 +isLT Nothing _ = False +isLT (Just x) y = x <= y + +isGT ∷ (Ord t) ⇒ Maybe t → t → 𝔹 +isGT Nothing _ = False +isGT (Just x) y = x >= y + +datePred ∷ (Ord a) ⇒ (t → Maybe a) → a → a → t → 𝔹 +datePred selector curr dt | dt >= curr = \item → selector item `isLT` dt + | otherwise = \item → selector item `isGT` dt + +flattern ∷ [Todo] → [Todo] +flattern = concatMap flat + where + flat ∷ Todo → [Todo] + flat (Node item trees) = (Node item []):(concatMap flat trees) + +forT ∷ (Monad m, Eq t) ⇒ [Tree t] → (t → m a) → m [b] +forT todos f = forM (nub todos) forT' + where + forT' (Node item trees) = + do f item + res ← forM trees forT' + return $ last res + +mapT ∷ (t → t) → [Tree t] → [Tree t] +mapT f todos = map mapT' todos + where + mapT' (Node item trees) = Node (f item) (mapT f trees) diff --git a/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE UnicodeSyntax, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, NoMonomorphismRestriction #-} + +module Types where + +import Prelude hiding (putStr, putStrLn,readFile,getContents,print) +import IO +import System.Console.ANSI + +import Control.Monad.Reader +import Data.Function +import Data.Generics hiding (GT) +import Data.Char (toUpper) +import Data.Maybe +import Data.Tree +import Data.List +import qualified Data.Map as M +import Text.ParserCombinators.Parsec + +import Unicode + +data DateType = StartDate + | EndDate + | Deadline + deriving (Eq) + +instance Show DateType where + show StartDate = "start" + show EndDate = "end" + show Deadline = "deadline" + +data DateTime = + DateTime { + year ∷ Int, + month ∷ Int, + day ∷ Int, + hour ∷ Int, + minute ∷ Int, + second ∷ Int } + deriving (Eq,Ord,Data,Typeable) + +months ∷ [String] +months = ["january", + "february", + "march", + "april", + "may", + "june", + "july", + "august", + "september", + "october", + "november", + "december"] + +capitalize ∷ String → String +capitalize [] = [] +capitalize (x:xs) = (toUpper x):xs + +showMonth ∷ Int → String +showMonth i = capitalize $ months !! (i-1) + +instance Show DateTime where + show (DateTime y m d h min s) = + show d ⧺ " " ⧺ showMonth m ⧺ " " ⧺ show y ⧺ ", " ⧺ + show h ⧺ ":" ⧺ show min ⧺ ":" ⧺ show s + +data Time = + Time { + tHour ∷ Int, + tMinute ∷ Int, + tSecond ∷ Int } + deriving (Eq,Ord,Show,Data,Typeable) + +data TodoItem = Item { + itemLevel ∷ ℤ, + itemName ∷ String, + itemTags ∷ [String], + depends ∷ [String], + itemStatus ∷ String, + itemDescr ∷ String, + startDate ∷ Maybe DateTime, + endDate ∷ Maybe DateTime, + deadline ∷ Maybe DateTime, + fileName ∷ FilePath, + lineNr ∷ Line} + deriving (Eq,Data,Typeable) + +type Todo = Tree TodoItem + +type TodoMap = M.Map String Todo + +data Limit = Unlimited + | Limit ℤ + deriving (Eq,Show) + +instance Ord Limit where + compare Unlimited Unlimited = EQ + compare Unlimited _ = GT + compare _ Unlimited = LT + compare (Limit x) (Limit y) = compare x y + +data CmdLineFlag = QF {queryFlag ∷ QueryFlag} + | MF {modeFlag ∷ ModeFlag} + | OF {outFlag ∷ OutFlag} + | LF {limFlag ∷ LimitFlag} + | HelpF + deriving (Eq,Show) + +data QueryFlag = Tag String + | Name {unName ∷ String} + | Status String + | StartDateIs DateTime + | EndDateIs DateTime + | DeadlineIs DateTime + | AndCons + | OrCons + | NotCons + | NoFilter + deriving (Eq,Ord,Show) + +data LimitFlag = Prune {unPrune ∷ ℤ} + | Start {unMin ∷ ℤ} + deriving (Eq,Show) + +data ModeFlag = Execute {unExecute ∷ String} + | Prefix {unPrefix ∷ String} + | Describe {unDescribe ∷ String} + deriving (Eq,Ord,Show) + +data OutFlag = OnlyFirst + | Colors + | Sort {getSorting ∷ SortingType} + deriving (Eq,Ord,Show) + +data SortingType = DoNotSort + | ByTitle + | ByStatus + | ByTags + | ByStartDate + | ByEndDate + | ByDeadline + deriving (Eq,Ord,Show) + +readSort ∷ String → SortingType +readSort "no" = DoNotSort +readSort "title" = ByTitle +readSort "status" = ByStatus +readSort "tags" = ByTags +readSort "start-date" = ByStartDate +readSort "end-date" = ByEndDate +readSort "deadline" = ByDeadline +readSort s = error $ "Unknown sorting type: "++s + +type Transformer = Reader Config (Todo → [Todo]) +type ListTransformer = Reader Config ([Todo] → [Todo]) + +transformList ∷ r → Reader r (t → a) → t → a +transformList conf tr list = do + f ← tr + return (f list) + `runReader` conf + +data OutItem = OutString String + | OutSetColor Color + | SetBold + | ResetAll + deriving (Show) + +type ConfigM = Reader Config [OutItem] + +newtype IOList = IOL [ConfigM] + +configM ∷ ConfigM +configM = return [] + +outString ∷ String → ConfigM +outString s = return [OutString s] + +newLine ∷ ConfigM +newLine = outString "\n" + +class ConfigAdd a where + (<++>) ∷ ConfigM → a → ConfigM + +instance ConfigAdd ConfigM where + (<++>) = liftM2 (⧺) + +instance ConfigAdd String where + cm <++> s = cm <++> ((return [OutString s]) ∷ ConfigM) + +setBold ∷ IO () +setBold = setSGR [SetConsoleIntensity BoldIntensity] + +setColor ∷ Color → IO () +setColor clr = setSGR [SetColor Foreground Dull clr] + +reset ∷ IO () +reset = setSGR [] + +outItem ∷ OutItem → IO () +outItem (OutString s) = putStr s +outItem (OutSetColor c) = setColor c +outItem SetBold = setBold +outItem ResetAll = reset + +runConfigM ∷ Config → ConfigM → IO () +runConfigM conf cm = + let lst = runReader cm conf + in mapM_ outItem lst + +class ConfigShow s where + configShow ∷ s → ConfigM + +instance ConfigShow String where + configShow s = return [OutString s] + +instance ConfigShow ConfigM where + configShow = id + +showIO ∷ (ConfigShow a) ⇒ Config → a → IO () +showIO conf = (runConfigM conf) ∘ configShow + +instance (Ord a) ⇒ Ord (Tree a) where + compare = compare `on` rootLabel + +-- TODO: - rename Options → QueryOptions or similar +data Options = O [QueryFlag] [ModeFlag] [OutFlag] [LimitFlag] + | Help + +data Config = Config { + outOnlyFirst ∷ 𝔹, + outColors ∷ 𝔹, + sorting ∷ SortingType, + pruneL ∷ Limit, + minL ∷ Limit, + commandToRun ∷ Maybe String, + prefix ∷ Maybe String, + descrFormat ∷ String, + query ∷ Composed} + deriving (Eq,Show) + +data Composed = Pred QueryFlag + | And Composed Composed + | Or Composed Composed + | Not Composed + | Empty + | HelpC + deriving (Eq,Show) + +is ∷ (Functor f) ⇒ t → f a → f (t, a) +t `is` x = (\a → (t,a)) `fmap` x + +showDate ∷ (Show t, Show t1) ⇒ (t, t1) → [Char] +showDate (t,d) = show t ⧺ ": " ⧺ show d + +showDates ∷ (Show t, Show t1) ⇒ [Maybe (t, t1)] → [Char] +showDates = intercalate "; " ∘ map showDate ∘ catMaybes + +instance Show TodoItem where + show item = s ⧺ " " ⧺ dates ⧺ tags ⧺ name ⧺ (if null descr then "" else " "⧺descr) + where + n = itemLevel item + name = itemName item + ts = itemTags item + s = itemStatus item + descr = itemDescr item + dates | null dates' = "" + | otherwise = "(" ⧺ dates' ⧺ ") " + dates' = showDates [StartDate `is` startDate item, EndDate `is` endDate item, Deadline `is` deadline item] + tags = if null ts + then "" + else "[" ⧺ (unwords ts) ⧺ "] " + +bold ∷ String → ConfigM +bold s = do + col ← asks outColors + if col + then return [SetBold, OutString s, ResetAll] + else return [OutString s] + +lookupC ∷ (Eq a1) ⇒ a1 → [([a1], a)] → Maybe a +lookupC k [] = Nothing +lookupC k ((lst,c):other) | k ∈ lst = Just c + | otherwise = lookupC k other + +statusColors ∷ [([String], Color)] +statusColors = + [(["FIXED", "DONE"], Green), + (["INVALID"], Magenta), + (["*"], Red), + (["?"], Blue)] + +colorStatus ∷ String → ConfigM +colorStatus st = + case lookupC st statusColors of + Nothing → return [OutString st] + Just clr → do + col ← asks outColors + if col + then return [OutSetColor clr, OutString st, ResetAll] + else return [OutString st] + +instance ConfigShow TodoItem where + configShow item = configM <++> colorStatus s <++> " " <++> dates <++> tags <++> bold name <++> (if null descr then "" else " "⧺descr) + where + n = itemLevel item + name = itemName item + ts = itemTags item + s = itemStatus item + descr = itemDescr item + dates | null dates' = "" + | otherwise = "(" ⧺ dates' ⧺ ") " + dates' = showDates [StartDate `is` startDate item, EndDate `is` endDate item, Deadline `is` deadline item] + tags = if null ts + then "" + else "[" ⧺ (unwords ts) ⧺ "] " + +instance Ord TodoItem where + compare item1 item2 = + let c1 = (compare `on` itemLevel) item1 item2 + c2 = (compare `on` itemStatus) item1 item2 + c3 = (compare `on` itemName) item1 item2 + in if c1 == EQ + then if c2 == EQ + then c3 + else c2 + else c1 + diff --git a/Unicode.hs b/Unicode.hs new file mode 100644 --- /dev/null +++ b/Unicode.hs @@ -0,0 +1,13 @@ +module Unicode where + +type ℝ = Float +type ℤ = Integer +type 𝔹 = Bool + +(⧺) = (++) +(⋄) = ($) +infixr 0 ⋄ +(∘) = (.) +(∨) = (||) +(∧) = (&&) +x ∈ lst = elem x lst diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UnicodeSyntax, PatternGuards #-} +module Test where + +import Control.Monad.Reader +import Data.Maybe +import Data.Tree +import Data.List + +import Unicode +import Types +import TodoLoader +import TodoTree +import CommandParser +import Config +import CmdLine + +cfg = Config False False (Limit 20) (Limit 20) Nothing Nothing "%d" Empty + +test file = do + todos ← loadTodo Nothing [file] + printTodos cfg todos + putStrLn "" + diff --git a/test.txt b/test.txt new file mode 100644 --- /dev/null +++ b/test.txt @@ -0,0 +1,11 @@ +Line of text +Text +TODO: * one todo +description +text +text +TODO: * another todo +descr +text +text +TODO: + last todo diff --git a/todos.cabal b/todos.cabal new file mode 100644 --- /dev/null +++ b/todos.cabal @@ -0,0 +1,30 @@ +Name: todos +Version: 0.1 +Cabal-Version: >= 1.6 +License: BSD3 +License-File: LICENSE +Author: Ilya V. Portnov +Maintainer: portnov84@rambler.ru +Homepage: http://gitorious.org/todos +Synopsis: Easy-to-use TODOs manager. +Category: Utils,Desktop +Build-Type: Simple +Description: todos is a simple TODO manager. TODO records theirself are described in + plain-text file, and todos allows you to show only needed of + them. So, todos works as specialized `grep' utility. + +Extra-source-files: CmdLine.hs CommandParser.hs Config.hs ConstrSet.hs Dates.hs IO.hs + Makefile README README.ru Setup.hs test.hs test.txt TODO + TodoLoader.hs TodoParser.hs todos.hs TodoTree.hs Types.hs + Unicode.hs + +Executable todos + Build-Depends: base >= 3 && <= 5, haskell98, utf8-string, containers, parsec >= 2 && < 3, + syb, mtl, ansi-terminal, Glob, time, regex-pcre, directory, filepath, + process + Main-Is: todos.hs + +Source-repository head + type: git + location: git://gitorious.org/todos/todos.git + diff --git a/todos.hs b/todos.hs new file mode 100644 --- /dev/null +++ b/todos.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE UnicodeSyntax, PatternGuards #-} + +import Prelude hiding (putStrLn,readFile,getContents,print) +import IO +import Codec.Binary.UTF8.String +import System (getArgs) +import System.Exit +import System.Cmd (system) + +import Control.Monad.Reader +import Data.Maybe +import Data.Tree +import Data.List + +import Unicode +import Types +import TodoLoader +import TodoTree +import CommandParser +import Config +import CmdLine +import Dates (getCurrentDateTime) + +main ∷ IO () +main = do + currDate ← getCurrentDateTime + config ← readConfig + args ← getArgs + let (loptions, files') = parseCmdLine currDate (config ⧺ args) + files ← glob files' + case loptions of + O qflags mflags oflags lflags → + do + let options = O qflags mflags oflags lflags + q = buildQuery options + todos ← loadTodo (prefix q) currDate files + let todos' = delTag "-" todos + queried = transformList q (composeAll currDate) todos' + format item = item {itemDescr = printfItem (descrFormat q) item} + case commandToRun q of + Nothing → do + printTodos q (mapT format queried) + putStrLn "" + Just cmd → do + forT selected (\item → system $ printfItem cmd (format item)) + return () + where selected | outOnlyFirst q = [Node (rootLabel $ head queried) []] + | otherwise = queried + + Help → do putStrLn usage + exitWith ExitSuccess +