diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +0.1.9 +========== +* Introduced passing the list of report durations into the script type output. +* Added a simple archiving tool. +* Fixed a small bug with `mergeClocks` which was causing multiple irrelevant tasks to inter-merge improperly. +* Improved README. + 0.1.8 ========== * Switched to ghc 8.8 diff --git a/orgstat.cabal b/orgstat.cabal --- a/orgstat.cabal +++ b/orgstat.cabal @@ -1,5 +1,5 @@ name: orgstat -version: 0.1.8 +version: 0.1.9 synopsis: Statistics visualizer for org-mode license: GPL-3 license-file: LICENSE @@ -96,6 +96,33 @@ RecordWildCards TypeApplications +executable orgstatarch + main-is: Main.hs + other-modules: Paths_orgstat + build-depends: base + , attoparsec + , bytestring + , directory + , exceptions + , filepath + , formatting + , optparse-simple + , orgstat + , time + , turtle + , text + , orgmode-parse + , unordered-containers + , universum + hs-source-dirs: src/arch + default-language: Haskell2010 + ghc-options: -threaded -Wall -O2 + default-extensions: NoImplicitPrelude + OverloadedStrings + RecordWildCards + LambdaCase + TypeApplications + TupleSections test-suite orgstat-test main-is: Test.hs diff --git a/src/OrgStat/Ast.hs b/src/OrgStat/Ast.hs --- a/src/OrgStat/Ast.hs +++ b/src/OrgStat/Ast.hs @@ -11,7 +11,11 @@ , orgSubtrees , clockDuration + , orgDurations , orgTotalDuration + , orgMeanDuration + , orgMedianDuration + , orgPomodoroNum , filterHasClock , cutFromTo , fmapOrgLens @@ -21,6 +25,7 @@ ) where import Control.Lens (ASetter', makeLenses) +import Data.List ((!!)) import Data.Time (LocalTime, NominalDiffTime, diffUTCTime, localTimeToUTC, utc) import Universum @@ -54,15 +59,53 @@ -- Helpers and lenses ---------------------------------------------------------------------------- +-- | Merge adjacent clocks from the list into one, return sorted list. +glueAdjacent :: [Clock] -> [Clock] +glueAdjacent clocks = go (sort clocks) + where + go [] = [] + go [x] = [x] + go (a:b:xs) = if cTo a >= cFrom b then go (Clock (cFrom a) (cTo b) : xs) + else a : go (b:xs) + +-- | Duration of the clock clockDuration :: Clock -> NominalDiffTime clockDuration (Clock (localTimeToUTC utc -> from) (localTimeToUTC utc -> to)) = diffUTCTime to from +-- | All durations of a single org file +orgDurations :: Org -> [NominalDiffTime] +orgDurations org = + map clockDuration $ glueAdjacent $ concat $ org ^.. traverseTree . orgClocks + -- | Calculate total clocks duration in org tree. orgTotalDuration :: Org -> NominalDiffTime -orgTotalDuration org = - sum $ map clockDuration $ concat $ org ^.. traverseTree . orgClocks +orgTotalDuration = sum . orgDurations +-- | Calculate mean duration of clocks in the given org tree. +orgMeanDuration :: Org -> NominalDiffTime +orgMeanDuration = mean . orgDurations + where + mean [] = 0 + mean xs = sum xs / fromIntegral (length xs) + +-- | Calculate mean duration of clocks in the given org tree. +orgMedianDuration :: Org -> NominalDiffTime +orgMedianDuration = median . orgDurations + where + median [] = 0 + median [a] = a + median xs = let sorted = sort xs in + let n = length xs in + if odd n then sorted !! (n `div` 2) + else (sorted !! (n `div` 2 - 1) + sorted !! (n `div` 2)) / 2 + +-- | Number of intervals \geq 25min. Intervals that are (25 * n + p) +-- mins long with p < 25 count as n pomodoros. +orgPomodoroNum :: Org -> Int +orgPomodoroNum = + sum . map (\dur -> truncate dur `div` (25 * 60 :: Int)) . orgDurations + -- | Remove subtrees that have zero total duration. filterHasClock :: Org -> Org filterHasClock = orgSubtrees %~ mapMaybe dfs @@ -108,6 +151,12 @@ atDepth n f o = (\x -> o & orgSubtrees .~ x) <$> traverse (atDepth (n-1) f) (o ^. orgSubtrees) +-- TODO This should consider the following situation: +-- Task A: 00:03 - 00:10 +-- Task B: 00:10 - 00:11 +-- Task A: 00:11 - 00:12 +-- +-- It will merge A, and thus A will interlap with B, which is undesirable. -- | Merges task clocks that have less then 2m delta between them into -- one. mergeClocks :: Org -> Org diff --git a/src/OrgStat/Helpers.hs b/src/OrgStat/Helpers.hs --- a/src/OrgStat/Helpers.hs +++ b/src/OrgStat/Helpers.hs @@ -17,7 +17,7 @@ import Data.Time.Calendar (addGregorianMonthsRollOver) import Data.Time.Calendar.WeekDate (toWeekDate) -import OrgStat.Ast (Org(..), cutFromTo, mergeClocks, orgTitle) +import OrgStat.Ast (Org(..), cutFromTo, orgTitle) import OrgStat.Config (ConfDate(..), ConfOutput(..), ConfRange(..), ConfReport(..), ConfScope(..), ConfigException(..), OrgStatConfig(..)) @@ -124,7 +124,8 @@ withModifiers <- either throwM pure $ applyModifiers orgTop crModifiers - let finalOrg = cutFromTo fromto $ mergeClocks withModifiers + --let finalOrg = cutFromTo fromto $ mergeClocks withModifiers + let finalOrg = cutFromTo fromto withModifiers wdResolvedReports . at reportName .= Just finalOrg pure finalOrg diff --git a/src/OrgStat/Outputs/Script.hs b/src/OrgStat/Outputs/Script.hs --- a/src/OrgStat/Outputs/Script.hs +++ b/src/OrgStat/Outputs/Script.hs @@ -12,10 +12,9 @@ import System.Environment (lookupEnv, setEnv, unsetEnv) import System.Process (callCommand) -import OrgStat.Ast (filterHasClock, orgTotalDuration) +import OrgStat.Ast import OrgStat.Config (confReports, crName) import OrgStat.Helpers (resolveReport) -import OrgStat.Logging import OrgStat.Outputs.Types (ScriptParams(..)) import OrgStat.Util (timeF) import OrgStat.WorkMonad (WorkM, wcConfig) @@ -32,9 +31,20 @@ -- Set env variables prevVars <- forM allReports $ \(toString -> reportName,org) -> do let duration = timeF $ orgTotalDuration $ filterHasClock org - logDebug $ "Variable " <> show reportName <> " duration is " <> show duration + let mean = timeF $ orgMeanDuration $ filterHasClock org + let median = timeF $ orgMedianDuration $ filterHasClock org + let pomodoro = orgPomodoroNum $ filterHasClock org + let toMinutes x = round x `div` 60 +-- logWarning $ "1: " <> show org +-- logWarning $ "2: " <> show (filterHasClock org) +-- logWarning $ "3: " <> show (orgDurations $ filterHasClock org) + let durationsPyth :: [Int] = map toMinutes $ orgDurations $ filterHasClock org (prevVar :: Maybe String) <- liftIO $ lookupEnv reportName liftIO $ setEnv reportName (toString duration) + liftIO $ setEnv (reportName <> "Mean") (toString mean) + liftIO $ setEnv (reportName <> "Median") (toString median) + liftIO $ setEnv (reportName <> "Pomodoro") (show pomodoro) + liftIO $ setEnv (reportName <> "DurationsList") (show durationsPyth) pure $ (reportName,) <$> prevVar let prevVarsMap :: Map String String prevVarsMap = M.fromList $ catMaybes prevVars @@ -50,3 +60,4 @@ liftIO $ case M.lookup reportName prevVarsMap of Nothing -> unsetEnv reportName Just prevValue -> setEnv reportName prevValue + where diff --git a/src/OrgStat/Outputs/Timeline.hs b/src/OrgStat/Outputs/Timeline.hs --- a/src/OrgStat/Outputs/Timeline.hs +++ b/src/OrgStat/Outputs/Timeline.hs @@ -171,7 +171,7 @@ & D.fontSize 10 & D.fc (contrastFrom bgboxColour) & D.moveTo (D.p2 (5, -h/2)) - box = mconcat $ bool [] [label'] (fitLabelHeight params 14 h) ++ [bgbox] + box = mconcat $ bool [] [label'] (fitLabelHeight params 12 h) ++ [bgbox] in box & D.moveTo (D.p2 (0, -y)) -- timelines for several days, with top lists diff --git a/src/arch/Main.hs b/src/arch/Main.hs new file mode 100644 --- /dev/null +++ b/src/arch/Main.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE ApplicativeDo, OverloadedStrings, ScopedTypeVariables #-} + +module Main where + +import Universum + +import qualified Data.Attoparsec.Text as A +import qualified Data.HashMap.Strict as HM +import qualified Data.List as L +import qualified Data.OrgMode.Parse as O +import Data.OrgMode.Types +import qualified Data.OrgMode.Types as O +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time (LocalTime(..), TimeOfDay(..), fromGregorian) +import Data.Time.Format (defaultTimeLocale, parseTimeM) +import Data.Version (showVersion) +import Options.Applicative.Simple + (Parser, ReadM, help, long, maybeReader, metavar, option, simpleOptions, strOption, switch) +import Paths_orgstat (version) +import System.Directory (doesFileExist) +import System.FilePath (takeBaseName, takeExtension) +import System.FilePath (()) + +import OrgStat.Logging + +---------------------------------------------------------------------------- +-- Arguments/options +---------------------------------------------------------------------------- + +data Args = Args + { argsInputs :: ![String] + , argsOutDir :: !String + , argsTodoKeywords :: ![Text] + , argsDoneKeywords :: ![Text] + , argsDate :: !LocalTime + , argsDebug :: !Bool + } deriving Show + +argsParser :: Parser Args +argsParser = do + argsInputs <- + some $ + strOption + (long "input" <> metavar "FILEPATH" <> + help "Files to consider for input") + argsOutDir <- strOption (long "out-dir" <> metavar "FILENAME" <> help "Output directory") + argsTodoKeywords <- option (maybeReader $ pure . map fromString . L.words) + (long "todo-keywords" <> metavar "STRLIST" <> help "TODO keywords, space-separated list") + argsDoneKeywords <- option (maybeReader $ pure . map fromString . L.words) + (long "done-keywords" <> metavar "STRLIST" <> help "DONE keywords, space-separated list") + argsDate <- option dateReadM (long "archive-from" <> metavar "DATE ") + argsDebug <- switch (long "debug" <> help "Enable debug logging") + pure Args{..} + where + dateReadM :: ReadM LocalTime + dateReadM = maybeReader $ \s -> + case parseTimeM True defaultTimeLocale "%Y-%m-%d" s of + Nothing -> fail $ + "Couldn't read date " <> show s <> + ". Correct format is YYYY-MM-DD" + Just ut -> pure ut + + +getOptions :: IO Args +getOptions = do + (res, ()) <- + simpleOptions + ("orgarch-" <> showVersion version) + "----- OrgArch ------" + "The tool for creating org-mode archives" + argsParser + empty + pure res + + +---------------------------------------------------------------------------- +-- Parsing and processing +---------------------------------------------------------------------------- + +data LogicException = LogicException Text + deriving (Show, Typeable) + +instance Exception LogicException + + +-- | Analogous to readOrgFile from OrgStat.IO, but with original +-- orgmode-parse datatype. +readOrgFile + :: (MonadIO m, MonadCatch m) + => [Text] -> FilePath -> m (Text, O.Document) +readOrgFile todoKeywords fp = do + logDebug $ "Reading org file " <> fpt + unlessM (liftIO $ doesFileExist fp) $ + throwM $ LogicException $ "Org file " <> fpt <> " doesn't exist" + (content, fname) <- case takeExtension fp of + ".org" -> (,fp) <$> liftIO (TIO.readFile fp) + _ -> throwM $ LogicException $ + "File " <> fpt <> " has unknown extension. Need to be .org" + let filename = T.pack $ takeBaseName fname + logDebug $ "Parsing org file " <> fpt + parsed <- + case A.parseOnly (O.parseDocument todoKeywords) content of + Left err -> throwM $ LogicException $ T.pack err + Right res -> pure res + + pure (filename, parsed) + where + fpt = T.pack fp + +-- Nothing for DateTime without time-of-day +convertDateTime :: O.DateTime -> Maybe LocalTime +convertDateTime + O.DateTime + { yearMonthDay = O.YearMonthDay year month day + , hourMinute = Just (hour, minute) + } + = Just $ LocalTime + (fromGregorian (toInteger year) month day) + (TimeOfDay hour minute 0) +convertDateTime _ = Nothing + + +printDocument :: Document -> Text +printDocument Document{..} = + documentText <> "\n" <> T.intercalate "\n" (map printHeadline documentHeadlines) + where + prependSpace prefix s = if T.null s then "" else prefix <> s + + printStats (StatsPct i) = " [" <> show i <> "%]" + printStats (StatsOf i j) = " [" <> show i <> "/" <> show j <> "]" + + printHeadline :: Headline -> Text + printHeadline Headline{..} = + let Depth d = depth in + let prefix = + fromString (take d (Universum.repeat '*')) <> + maybe "" (\s -> " " <> unStateKeyword s) stateKeyword <> + maybe "" (\p -> " [#" <> show p <> "]") priority <> + maybe "" printStats stats <> + (prependSpace " " title) + in + let tagList = if null tags then "" else ":" <> T.intercalate ":" tags <> ":" in + let spaceLen = 77 - T.length prefix - T.length tagList in + let header = prefix <> + prependSpace (fromString (take spaceLen (Universum.repeat ' '))) tagList in + + let sec = printSection d section in + + let subHeadlinesStr = map printHeadline subHeadlines in + + header <> (prependSpace "\n" sec) <> + (if all T.null subHeadlinesStr + then "" else "\n" <> T.intercalate "\n" subHeadlinesStr) + + printSection :: Int -> Section -> Text + printSection depth Section{..} = + let indent = fromString (take (depth+1) (Universum.repeat ' ')) in + let Plns plns = sectionPlannings in + let planningsStr = + T.intercalate " " $ map (\(k,v) -> show k <> ": " <> printTs v) $ + HM.toList plns in + let clocksStr = map printClock sectionClocks in + let withDrawer name xs = [":" <> name <> ":"] <> xs <> [":END:"] in + let props = unProperties sectionProperties in + let propsStr = if HM.null props + then [] + else withDrawer "PROPERTIES" $ + map (\(k,v) -> ":" <> k <> ": " <> v) $ HM.toList props in + let logbook = unLogbook sectionLogbook in + let logbookStr = if logbook == [] then [] else + withDrawer "LOGBOOK" $ map printClock logbook in + let drawersStr = + concatMap (\(Drawer name contents) -> withDrawer name [contents]) sectionDrawers in + + let maybeInclude s = if T.null s then [] else [s] in + prependSpace indent $ + T.intercalate ("\n" <> indent) + (concat [ maybeInclude planningsStr + , clocksStr, propsStr + , logbookStr, drawersStr]) + <> T.stripEnd sectionParagraph + + printClock :: Clock -> Text + printClock (Clock (Just ts, Just (h,m))) = + let withSpace s = if T.length s == 1 then " " <> s else s in + let withZero s = if T.length s == 1 then "0" <> s else s in + "CLOCK: " <> printTs ts <> " => " <> withSpace (show h) <> ":" <> withZero (show m) + printClock (Clock (Just ts, Nothing)) = "CLOCK: " <> printTs ts + printClock c = error $ "printClock: not yet implemented " <> show c + + printTs :: Timestamp -> Text + printTs Timestamp{..} = + bracketOnActive tsActive (dateTime tsTime) <> + maybe "" (\end -> "--" <> bracketOnActive tsActive (dateTime end)) tsEndTime + where + maybePrepend a s = if s == "" then a else a <> " " <> s + withZero s = if T.length s == 1 then "0" <> s else s + dateTime DateTime{..} = + (show (ymdYear yearMonthDay) <> "-" <> + withZero (show (ymdMonth yearMonthDay)) <> "-" <> + withZero (show (ymdDay yearMonthDay))) `maybePrepend` + maybe "" id dayName `maybePrepend` + maybe "" (\(h,m) -> withZero (show h) <> ":" <> withZero (show m)) hourMinute `maybePrepend` + maybe "" printRepeater repeater `maybePrepend` + maybe "" printDelay delay + + bracketOnActive active s = if active == Active then "<" <> s <> ">" else "[" <> s <> "]" + + printTimeUnit = \case + UnitYear -> "y" + UnitMonth -> "m" + UnitWeek -> "w" + UnitDay -> "d" + UnitHour -> "h" + + printRepeater Repeater{..} = + (case repeaterType of + RepeatCumulate -> "++" + RepeatCatchUp -> "+" + RepeatRestart -> ".+") <> + show repeaterValue <> + printTimeUnit repeaterUnit + + printDelay Delay{..} = + (case delayType of + DelayAll -> "-" + DelayFirst -> "--") <> + show delayValue <> + printTimeUnit delayUnit + +-- TODO: repeated common tasks? +filterOrg :: [Text] -> LocalTime -> O.Document -> (O.Document, O.Document) +filterOrg doneKeywords archDate Document{..} = + let hlUpd = map go documentHeadlines in + (Document { documentHeadlines = mapMaybe fst hlUpd, ..}, + Document { documentHeadlines = mapMaybe snd hlUpd, ..}) + where + tsOlder :: Timestamp -> Bool + tsOlder ts = case convertDateTime (tsTime ts) of + Nothing -> False + Just locTime -> locTime <= archDate + + go :: Headline -> (Maybe Headline,Maybe Headline) + go hl@Headline{..} = + let subHls = map go subHeadlines in + -- Whether this headline was CLOSED before archive date + let isDone = stateKeyword `elem` (map (Just . StateKeyword) doneKeywords) in + let Plns plannings = sectionPlannings section in + let isRepeating = case HM.lookup SCHEDULED plannings of + Nothing -> False + Just ts -> isJust (repeater (tsTime ts)) in + let closedOld = case HM.lookup CLOSED plannings of + Nothing -> True + Just ts -> tsOlder ts in + + if isRepeating || stateKeyword == Nothing + then + let clocks = + reverse $ + L.sortOn (maybe (error "Couldn't convert datetime to sort") id . + convertDateTime . tsTime . fst) $ + map (\case Clock (Just x, y) -> (x,y) + c -> error $ "Have encountered a broken clock: " <> show c) $ + L.nub $ + concat [ sectionClocks section + , unLogbook (sectionLogbook section) + ] in + let (splitArch, splitRemain) = L.partition (tsOlder . fst) clocks in + + let toClock (a, b) = Clock (Just a, b) in + + let remainItem = all (isNothing . snd) subHls && splitArch == [] in + let hlLeft = + hl { section = section { sectionClocks = [] + , sectionLogbook = Logbook (map toClock splitRemain)} + , subHeadlines = mapMaybe fst subHls } in + + let hlRight = + hl { section = section { sectionClocks = [] + , sectionLogbook = Logbook (map toClock splitArch)} + , subHeadlines = mapMaybe snd subHls } in + + (Just hlLeft,if remainItem then Nothing else Just hlRight) + else (if isDone && closedOld then (Nothing, Just hl) else (Just hl, Nothing)) + + +main :: IO () +main = do + args@Args{..} <- getOptions + let sev = if argsDebug then Debug else Info + initLogging sev + logInfo $ show args + + orgFiles <- forM argsInputs $ readOrgFile $ argsTodoKeywords <> argsDoneKeywords + + logInfo $ show $ map fst orgFiles + + let filteredFiles = map (second $ filterOrg argsDoneKeywords argsDate) orgFiles + + forM_ filteredFiles $ \(fn,(remain,arch)) -> do + TIO.writeFile (argsOutDir (toString fn <> "_remain.org" )) $ printDocument remain + TIO.writeFile (argsOutDir (toString fn <> "_archive.org")) $ printDocument arch + + logInfo "Done"