orgstat 0.1.8 → 0.1.9
raw patch · 7 files changed
+409/−9 lines, 7 filesdep +unordered-containersdep ~basedep ~exceptionsdep ~orgmode-parsenew-component:exe:orgstatarch
Dependencies added: unordered-containers
Dependency ranges changed: base, exceptions, orgmode-parse, text, time, turtle, universum
Files
- CHANGES.md +7/−0
- orgstat.cabal +28/−1
- src/OrgStat/Ast.hs +51/−2
- src/OrgStat/Helpers.hs +3/−2
- src/OrgStat/Outputs/Script.hs +14/−3
- src/OrgStat/Outputs/Timeline.hs +1/−1
- src/arch/Main.hs +305/−0
CHANGES.md view
@@ -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
orgstat.cabal view
@@ -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
src/OrgStat/Ast.hs view
@@ -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
src/OrgStat/Helpers.hs view
@@ -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
src/OrgStat/Outputs/Script.hs view
@@ -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
src/OrgStat/Outputs/Timeline.hs view
@@ -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
+ src/arch/Main.hs view
@@ -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 <YYYY-MM-DD>")+ 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"