diff --git a/orgstat.cabal b/orgstat.cabal --- a/orgstat.cabal +++ b/orgstat.cabal @@ -1,5 +1,5 @@ name: orgstat -version: 0.0.4 +version: 0.1.0 synopsis: Statistics visualizer for org-mode license: GPL-3 license-file: LICENSE @@ -12,14 +12,18 @@ library exposed-modules: OrgStat.Ast , OrgStat.Config + , OrgStat.CLI + , OrgStat.Helpers , OrgStat.IO , OrgStat.Logic , OrgStat.Parser , OrgStat.Scope - , OrgStat.Report - , OrgStat.Report.Types - , OrgStat.Report.Class - , OrgStat.Report.Timeline + , OrgStat.Outputs + , OrgStat.Outputs.Block + , OrgStat.Outputs.Class + , OrgStat.Outputs.Summary + , OrgStat.Outputs.Timeline + , OrgStat.Outputs.Types , OrgStat.Util , OrgStat.WorkMonad build-depends: aeson >= 0.11.2.0 @@ -38,14 +42,14 @@ , hashable >= 1.2.4.0 , lens >= 4.14 , linear - , log-warper >= 1.1.4 + , log-warper >= 1.3.1 , mtl >= 2.2.1 , optparse-simple - , orgmode-parse + , orgmode-parse >= 0.2.0 , text >= 1.2.2.1 , time >= 1.6.0.1 , turtle >= 1.2.8 - , universum >= 0.5.1.1 + , universum >= 0.6.1 , yaml >= 0.8.21.1 hs-source-dirs: src default-language: Haskell2010 @@ -58,6 +62,7 @@ FunctionalDependencies NoImplicitPrelude OverloadedStrings + ScopedTypeVariables RecordWildCards TypeApplications TupleSections @@ -70,16 +75,16 @@ build-depends: base >=4.9 && <4.10 , bytestring , directory - , exceptions >= 0.8.3 + , exceptions , filepath , formatting - , log-warper >= 1.1.4 + , log-warper , optparse-simple , orgstat - , universum >= 0.5.1.1 + , universum hs-source-dirs: src/cli default-language: Haskell2010 - ghc-options: -threaded -Wall -O2 + ghc-options: -threaded -Wall -O2 default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards diff --git a/src/OrgStat/Ast.hs b/src/OrgStat/Ast.hs --- a/src/OrgStat/Ast.hs +++ b/src/OrgStat/Ast.hs @@ -10,6 +10,11 @@ , orgTags , orgClocks , orgSubtrees + + , clockDuration + , orgTotalDuration + , filterHasClock + , cutFromTo , fmapOrgLens , traverseTree , atDepth @@ -17,7 +22,8 @@ ) where import Control.Lens (ASetter', makeLenses) -import Data.Time (LocalTime, diffUTCTime, localTimeToUTC, utc) +import Data.Time (LocalTime, NominalDiffTime, diffUTCTime, localTimeToUTC, + localTimeToUTC, utc) import Universum @@ -50,11 +56,48 @@ -- Helpers and lenses ---------------------------------------------------------------------------- +clockDuration :: Clock -> NominalDiffTime +clockDuration (Clock (localTimeToUTC utc -> from) (localTimeToUTC utc -> to)) = + diffUTCTime to from + +-- | Calculate total clocks duration in org tree. +orgTotalDuration :: Org -> NominalDiffTime +orgTotalDuration org = + sum $ map clockDuration $ concat $ org ^.. traverseTree . orgClocks + +-- | Remove subtrees that have zero total duration. +filterHasClock :: Org -> Org +filterHasClock = orgSubtrees %~ mapMaybe dfs + where + dfs :: Org -> Maybe Org + dfs o = do + let children = mapMaybe dfs (o ^. orgSubtrees) + let ownDur = sum $ map clockDuration (o ^. orgClocks) + if ownDur == 0 && null children + then Nothing + else Just $ o & orgSubtrees .~ children + +cutFromTo :: (LocalTime, LocalTime) -> Org -> Org +cutFromTo (from, to) o + | from >= to = error "cutFromTo: from >= to" + | otherwise = o & traverseTree %~ filterClocks + where + -- Cuts clock relatively to from/to or discards if it's not in the + -- interval. + fitClock :: Clock -> Maybe Clock + fitClock Clock{..} = do + guard $ cFrom <= to + guard $ cTo >= from + pure $ Clock (max cFrom from) (min cTo to) + + filterClocks :: Org -> Org + filterClocks = orgClocks %~ mapMaybe fitClock + -- | Functor-like 'fmap' on field chosen by lens. fmapOrgLens :: ASetter' Org a -> (a -> a) -> Org -> Org fmapOrgLens l f o = o & l %~ f & orgSubtrees %~ map (fmapOrgLens l f) --- | Traverses node and subnodes, all recursively +-- | Traverses node and subnodes, all recursively. Bottom-top. traverseTree :: Traversal' Org Org traverseTree f o = o' where diff --git a/src/OrgStat/CLI.hs b/src/OrgStat/CLI.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/CLI.hs @@ -0,0 +1,37 @@ +-- | Common args and parser. + +module OrgStat.CLI + ( CommonArgs (..) + , parseCommonArgs + ) where + +import Universum + +import Options.Applicative.Simple (Parser, help, long, metavar, strOption, + switch) + +-- | Read-only arguments that inner application needs (in contrast to, +-- say, logging severity). +data CommonArgs = CommonArgs + { xdgOpen :: !Bool + -- ^ Open report types using xdg-open + , selectOutput :: !(Maybe Text) + -- ^ Single output can be selected instead of running all of them. + , outputDir :: !(Maybe FilePath) + -- ^ Output directory for all ... outputs. + } deriving Show + +parseCommonArgs :: Parser CommonArgs +parseCommonArgs = + CommonArgs <$> + switch (long "xdg-open" <> help "Open each report using xdg-open") <*> + optional ( + fromString <$> + strOption (long "select-output" <> + help ("Output name you want to process " <> + "(by default all outputs from conf are processed"))) <*> + optional ( + strOption (long "output-dir" <> + metavar "FILEPATH" <> + help ("Final output directory that overrides one in config. " <> + "No extra subdirectories will be created!"))) diff --git a/src/OrgStat/Config.hs b/src/OrgStat/Config.hs --- a/src/OrgStat/Config.hs +++ b/src/OrgStat/Config.hs @@ -7,28 +7,30 @@ module OrgStat.Config ( ConfigException (..) - , ConfDate(..) - , ConfRange(..) - , ConfReportType(..) + , ConfDate (..) + , ConfRange (..) + , ConfOutputType (..) + , ConfOutput (..) , ConfScope (..) , ConfReport (..) , OrgStatConfig (..) ) where -import Data.Aeson (FromJSON (..), Value (Object, String), (.!=), - (.:), (.:?)) -import Data.Aeson.Types (typeMismatch) -import Data.Default (def) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Text as T -import Data.Time (LocalTime) -import Data.Time.Format (defaultTimeLocale, parseTimeM) +import Data.Aeson (FromJSON (..), Value (Object, String), withObject, + withText, (.!=), (.:), (.:?)) +import Data.Aeson.Types (typeMismatch) +import Data.Default (def) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Text as T +import Data.Time (LocalTime) +import Data.Time.Format (defaultTimeLocale, parseTimeM) import Universum -import OrgStat.Report.Timeline (TimelineParams, tpBackground, tpColumnHeight, - tpColumnWidth, tpLegend, tpTopDay) -import OrgStat.Scope (AstPath (..), ScopeModifier (..)) -import OrgStat.Util (parseColour, (??~)) +import OrgStat.Outputs.Types (BlockParams (..), SummaryParams (..), + TimelineParams, tpBackground, tpColumnHeight, + tpColumnWidth, tpLegend, tpTopDay) +import OrgStat.Scope (AstPath (..), ScopeModifier (..)) +import OrgStat.Util (parseColour, (??~)) -- | Exception type for everything bad that happens with config, -- starting from parsing to logic errors. @@ -51,26 +53,35 @@ | ConfBlockMonth !Integer deriving (Show) -data ConfReportType = Timeline - { timelineRange :: !ConfRange - , timelineScope :: !Text - , timelineParams :: !TimelineParams - } deriving (Show) +data ConfOutputType + = TimelineOutput { toParams :: !TimelineParams + , toReport :: !Text } + | SummaryOutput !SummaryParams + | BlockOutput { boParams :: !BlockParams + , boReport :: !Text } + deriving (Show) data ConfScope = ConfScope { csName :: !Text -- default is "default" , csPaths :: !(NonEmpty FilePath) } deriving (Show) +data ConfOutput = ConfOutput + { coType :: !ConfOutputType + , coName :: !Text + } deriving (Show) + data ConfReport = ConfReport - { crType :: !ConfReportType -- includes config - , crName :: !Text + { crName :: !Text + , crScope :: !Text + , crRange :: !ConfRange , crModifiers :: ![ScopeModifier] } deriving (Show) data OrgStatConfig = OrgStatConfig { confScopes :: ![ConfScope] , confReports :: ![ConfReport] + , confOutputs :: ![ConfOutput] , confBaseTimelineParams :: !TimelineParams , confTodoKeywords :: ![Text] , confOutputDir :: !FilePath -- default is "./orgstat" @@ -78,16 +89,16 @@ } deriving (Show) instance FromJSON AstPath where - parseJSON (String s) = pure $ AstPath $ filter (not . T.null) $ T.splitOn "/" s - parseJSON invalid = typeMismatch "AstPath" invalid + parseJSON = withText "AstPath" $ \s -> + pure $ AstPath $ filter (not . T.null) $ T.splitOn "/" s instance FromJSON ScopeModifier where - parseJSON (Object v) = do - v .: "type" >>= \case - (String "prune") -> ModPruneSubtree <$> v .: "path" <*> v .:? "depth" .!= 0 - (String "select") -> ModSelectSubtree <$> v .: "path" + parseJSON = withObject "ScopeModifier" $ \o -> do + o .: "type" >>= \case + (String "prune") -> ModPruneSubtree <$> o .: "path" <*> o .:? "depth" .!= 0 + (String "select") -> ModSelectSubtree <$> o .: "path" + (String "filterbytag") -> ModFilterTag <$> o .: "tag" other -> fail $ "Unsupported scope modifier type: " ++ show other - parseJSON invalid = typeMismatch "ScopeModifier" invalid instance FromJSON ConfDate where parseJSON (String "now") = pure $ ConfNow @@ -123,7 +134,7 @@ parseJSON invalid = typeMismatch "ConfRange" invalid instance FromJSON TimelineParams where - parseJSON (Object v) = do + parseJSON = withObject "TimelineParams" $ \v -> do legend <- v .:? "legend" topDay <- v .:? "topDay" colWidth <- v .:? "colWidth" @@ -134,36 +145,47 @@ & tpColumnWidth ??~ colWidth & tpColumnHeight ??~ colHeight & tpBackground ??~ (T.strip <$> bgColorRaw >>= parseColour @Text) - parseJSON invalid = typeMismatch "TimelineParams" invalid -instance FromJSON ConfReportType where - parseJSON o@(Object v) = do - v .: "type" >>= \case - (String "timeline") -> - Timeline <$> v .: "range" - <*> v .:? "scope" .!= "default" - <*> parseJSON o - other -> fail $ "Unsupported scope modifier type: " ++ show other - parseJSON invalid = typeMismatch "ConfReportType" invalid +instance FromJSON ConfOutputType where + parseJSON = withObject "ConfOutputType" $ \o -> + o .: "type" >>= \case + (String "timeline") -> do + toReport <- o .: "report" + toParams <- parseJSON (Object o) + pure $ TimelineOutput {..} + (String "summary") -> do + soTemplate <- o .: "template" + pure $ SummaryOutput $ SummaryParams soTemplate + (String "block") -> do + boReport <- o .: "report" + let boParams = BlockParams + pure $ BlockOutput {..} + other -> fail $ "Unsupported output type: " ++ show other +instance FromJSON ConfOutput where + parseJSON = withObject "ConfOutput" $ \o -> do + coName <- o .: "name" + coType <- parseJSON (Object o) + pure $ ConfOutput{..} + instance FromJSON ConfScope where - parseJSON (Object v) = do - ConfScope <$> v .:? "name" .!= "default" <*> v .: "paths" - parseJSON invalid = typeMismatch "ConfScope" invalid + parseJSON = withObject "ConfScope" $ \o -> + ConfScope <$> o .:? "name" .!= "default" + <*> o .: "paths" instance FromJSON ConfReport where - parseJSON (Object v) = do - ConfReport <$> v .: "type" - <*> v .:? "name" .!= "default" - <*> v .:? "modifiers" .!= [] - parseJSON invalid = typeMismatch "ConfReport" invalid + parseJSON = withObject "ConfReport" $ \o -> + ConfReport <$> o .: "name" + <*> o .:? "scope" .!= "default" + <*> o .: "range" + <*> o .:? "modifiers" .!= [] instance FromJSON OrgStatConfig where - parseJSON (Object v) = do - OrgStatConfig <$> v .: "scopes" - <*> v .: "reports" - <*> v .:? "timelineDefault" .!= def - <*> v .:? "todoKeywords" .!= [] - <*> v .:? "output" .!= "./orgstat" - <*> v .:? "colorSalt" .!= 0 - parseJSON invalid = typeMismatch "ConfReport" invalid + parseJSON = withObject "OrgStatConfig" $ \o -> + OrgStatConfig <$> o .: "scopes" + <*> o .: "reports" + <*> o .: "outputs" + <*> o .:? "timelineDefault" .!= def + <*> o .:? "todoKeywords" .!= [] + <*> (o .:? "outputDir" <|> o .:? "output") .!= "./orgstat" + <*> o .:? "colorSalt" .!= 0 diff --git a/src/OrgStat/Helpers.hs b/src/OrgStat/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/Helpers.hs @@ -0,0 +1,146 @@ +-- | Different logic-related components. + +module OrgStat.Helpers + ( convertRange + , resolveInputOrg + , resolveScope + , resolveReport + , resolveOutput + ) where + +import Universum + +import Control.Lens (at, views, (.=)) +import qualified Data.List.NonEmpty as NE +import Data.Time (LocalTime (..), TimeOfDay (..), addDays, + getZonedTime, toGregorian, + zonedTimeToLocalTime) +import Data.Time.Calendar (addGregorianMonthsRollOver) +import Data.Time.Calendar.WeekDate (toWeekDate) + +import OrgStat.Ast (Org (..), cutFromTo, mergeClocks, orgTitle) +import OrgStat.Config (ConfDate (..), ConfOutput (..), + ConfRange (..), ConfReport (..), + ConfScope (..), ConfigException (..), + OrgStatConfig (..)) +import OrgStat.IO (readOrgFile) +import OrgStat.Scope (applyModifiers) +import OrgStat.WorkMonad (WorkM, wcConfig, wdReadFiles, + wdResolvedReports, wdResolvedScopes) + + +-- | Converts config range to a pair of 'UTCTime', right bound not inclusive. +convertRange :: (MonadIO m) => ConfRange -> m (LocalTime, LocalTime) +convertRange range = case range of + (ConfFromTo f t) -> (,) <$> fromConfDate f <*> fromConfDate t + (ConfBlockDay i) | i < 0 -> error $ "ConfBlockDay i is <0: " <> show i + (ConfBlockDay 0) -> (,) <$> (localFromDay <$> startOfDay) <*> curTime + (ConfBlockDay i) -> do + d <- (negate (i - 1) `addDays`) <$> startOfDay + pure $ localFromDayPair ((negate 1) `addDays` d, d) + (ConfBlockWeek i) | i < 0 -> error $ "ConfBlockWeek i is <0: " <> show i + (ConfBlockWeek 0) -> (,) <$> (localFromDay <$> startOfWeek) <*> curTime + (ConfBlockWeek i) -> do + d <- (negate (i - 1) `addWeeks`) <$> startOfWeek + pure $ localFromDayPair ((negate 1) `addWeeks` d, d) + (ConfBlockMonth i) | i < 0 -> error $ "ConfBlockMonth i is <0: " <> show i + (ConfBlockMonth 0) -> (,) <$> (localFromDay <$> startOfMonth) <*> curTime + (ConfBlockMonth i) -> do + d <- addGregorianMonthsRollOver (negate $ i-1) <$> startOfMonth + pure $ localFromDayPair ((negate 1) `addGregorianMonthsRollOver` d, d) + where + localFromDay d = LocalTime d $ TimeOfDay 0 0 0 + localFromDayPair = bimap localFromDay localFromDay + curTime = liftIO $ zonedTimeToLocalTime <$> getZonedTime + curDay = localDay <$> curTime + addWeeks i d = (i*7) `addDays` d + startOfDay = curDay + startOfWeek = do + d <- curDay + let weekDay = pred $ view _3 $ toWeekDate d + pure $ fromIntegral (negate weekDay) `addDays` d + startOfMonth = do + d <- curDay + let monthDate = pred $ view _3 $ toGregorian d + pure $ fromIntegral (negate monthDate) `addDays` d + fromConfDate ConfNow = curTime + fromConfDate (ConfLocal x) = pure x + +-- | Resolves org file: reads from path and puts into state or just +-- gets out of state if was read before. +resolveInputOrg :: FilePath -> WorkM (Text, Org) +resolveInputOrg fp = use (wdReadFiles . at fp) >>= \case + Just x -> pure x + Nothing -> do + todoKeywords <- views wcConfig confTodoKeywords + o <- readOrgFile todoKeywords fp + wdReadFiles . at fp .= Just o + pure o + +-- A lot of copy-paste here... 2 bad, though no time to fix + +-- | Return scope with requested name or fail. It will be either +-- constructed on the spot or taken from the state if it had been +-- created previously. +resolveScope :: Text -> WorkM Org +resolveScope scopeName = use (wdResolvedScopes . at scopeName) >>= \case + Just x -> pure x + Nothing -> constructScope + where + constructScope = do + let filterScopes = filter (\x -> csName x == scopeName) + views wcConfig (filterScopes . confScopes) >>= \case + [] -> + throwM $ ConfigLogicException $ + "Scope "<> scopeName <> " is not declared" + [sc] -> resolveFoundScope sc + scopes -> + throwM $ ConfigLogicException $ + "Multple scopes with name "<> scopeName <> + " are declared " <> show scopes + resolveFoundScope ConfScope{..} = do + orgs <- NE.toList <$> forM csPaths resolveInputOrg + let orgTop = Org "/" [] [] $ map (\(fn,o) -> o & orgTitle .~ fn) orgs + wdResolvedScopes . at scopeName .= Just orgTop + pure orgTop + +-- | Same as resolveScope but related to reports. +resolveReport :: Text -> WorkM Org +resolveReport reportName = use (wdResolvedReports . at reportName) >>= \case + Just x -> pure x + Nothing -> constructReport + where + constructReport = do + let filterReports = filter (\x -> crName x == reportName) + views wcConfig (filterReports . confReports) >>= \case + [] -> + throwM $ ConfigLogicException $ + "Report " <> reportName <> " is not declared" + [rep] -> resolveFoundReport rep + reports -> + throwM $ ConfigLogicException $ + "Multple reports with name "<> reportName <> + " are declared " <> show reports + resolveFoundReport ConfReport{..} = do + orgTop <- resolveScope crScope + fromto <- convertRange crRange + withModifiers <- + either throwM pure $ + applyModifiers orgTop crModifiers + let finalOrg = cutFromTo fromto $ mergeClocks withModifiers + wdResolvedReports . at reportName .= Just finalOrg + pure finalOrg + +resolveOutput :: Text -> WorkM ConfOutput +resolveOutput outputName = + views wcConfig (filterOutputs . confOutputs) >>= \case + [] -> + throwM $ ConfigLogicException $ + "Report " <> outputName <> " is not declared" + [rep] -> pure rep + reports -> + throwM $ ConfigLogicException $ + "Multple outputs with name "<> outputName <> + " are declared " <> show reports + where + filterOutputs = filter (\x -> coName x == outputName) diff --git a/src/OrgStat/IO.hs b/src/OrgStat/IO.hs --- a/src/OrgStat/IO.hs +++ b/src/OrgStat/IO.hs @@ -70,9 +70,8 @@ pure output -- | Reads yaml config -readConfig :: (MonadIO m, MonadThrow m, WithLogger m) => FilePath -> m OrgStatConfig +readConfig :: (MonadIO m, MonadThrow m) => FilePath -> m OrgStatConfig readConfig fp = do - logDebug $ "Reading config file from: " <> fpt unlessM (liftIO $ doesFileExist fp) $ throwM $ OrgIOException $ "Config file " <> fpt <> " doesn't exist" res <- liftIO $ BS.readFile fp diff --git a/src/OrgStat/Logic.hs b/src/OrgStat/Logic.hs --- a/src/OrgStat/Logic.hs +++ b/src/OrgStat/Logic.hs @@ -3,134 +3,65 @@ -- | Main logic combining all components module OrgStat.Logic - ( convertRange - , runOrgStat + ( runOrgStat ) where -import Data.List (notElem, nub, nubBy) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Time (LocalTime (..), TimeOfDay (..), addDays, - defaultTimeLocale, formatTime, getZonedTime, - toGregorian, zonedTimeToLocalTime) -import Data.Time.Calendar (addGregorianMonthsRollOver) -import Data.Time.Calendar.WeekDate (toWeekDate) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (()) -import System.Wlog (logDebug, logInfo) import Universum -import Unsafe (unsafeHead) -import OrgStat.Ast (Org (..), mergeClocks, orgTitle) -import OrgStat.Config (ConfDate (..), ConfRange (..), - ConfReport (..), ConfReportType (..), - ConfScope (..), ConfigException (..), - OrgStatConfig (..)) -import OrgStat.IO (readConfig, readOrgFile) -import OrgStat.Report (processTimeline, tpColorSalt, writeReport) -import OrgStat.Scope (applyModifiers) -import OrgStat.Util (fromJustM) -import OrgStat.WorkMonad (WorkM, wConfigFile, wXdgOpen) -import Turtle (shell) - - --- Converts config range to a pair of 'UTCTime', right bound not inclusive. -convertRange :: (MonadIO m) => ConfRange -> m (LocalTime, LocalTime) -convertRange range = case range of - (ConfFromTo f t) -> (,) <$> fromConfDate f <*> fromConfDate t - (ConfBlockDay i) | i < 0 -> error $ "ConfBlockDay i is <0: " <> show i - (ConfBlockDay 0) -> (,) <$> (localFromDay <$> startOfDay) <*> curTime - (ConfBlockDay i) -> do - d <- (negate (i - 1) `addDays`) <$> startOfDay - pure $ localFromDayPair ((negate 1) `addDays` d, d) - (ConfBlockWeek i) | i < 0 -> error $ "ConfBlockWeek i is <0: " <> show i - (ConfBlockWeek 0) -> (,) <$> (localFromDay <$> startOfWeek) <*> curTime - (ConfBlockWeek i) -> do - d <- (negate (i - 1) `addWeeks`) <$> startOfWeek - pure $ localFromDayPair ((negate 1) `addWeeks` d, d) - (ConfBlockMonth i) | i < 0 -> error $ "ConfBlockMonth i is <0: " <> show i - (ConfBlockMonth 0) -> (,) <$> (localFromDay <$> startOfMonth) <*> curTime - (ConfBlockMonth i) -> do - d <- addGregorianMonthsRollOver (negate $ i-1) <$> startOfMonth - pure $ localFromDayPair ((negate 1) `addGregorianMonthsRollOver` d, d) - where - localFromDay d = LocalTime d $ TimeOfDay 0 0 0 - localFromDayPair = bimap localFromDay localFromDay - curTime = liftIO $ zonedTimeToLocalTime <$> getZonedTime - curDay = localDay <$> curTime - addWeeks i d = (i*7) `addDays` d - startOfDay = curDay - startOfWeek = do - d <- curDay - let weekDay = pred $ view _3 $ toWeekDate d - pure $ fromIntegral (negate weekDay) `addDays` d - startOfMonth = do - d <- curDay - let monthDate = pred $ view _3 $ toGregorian d - pure $ fromIntegral (negate monthDate) `addDays` d - fromConfDate ConfNow = curTime - fromConfDate (ConfLocal x) = pure x +import Control.Lens (views) +import qualified Data.Text as T +import Data.Time (defaultTimeLocale, formatTime, getZonedTime) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.Wlog (logDebug, logInfo) +import Turtle (shell) +import OrgStat.CLI (CommonArgs (..)) +import OrgStat.Config (ConfOutput (..), ConfOutputType (..), + OrgStatConfig (..)) +import OrgStat.Helpers (resolveOutput, resolveReport) +import OrgStat.Outputs (genBlockOutput, genSummaryOutput, processTimeline, + tpColorSalt, writeReport) +import OrgStat.WorkMonad (WorkM, wcCommonArgs, wcConfig) +-- | Main application logic. runOrgStat :: WorkM () runOrgStat = do - conf@OrgStatConfig{..} <- readConfig =<< view wConfigFile + conf@OrgStatConfig{..} <- view wcConfig logDebug $ "Config: \n" <> show conf curTime <- liftIO getZonedTime - let reportDir = confOutputDir formatTime defaultTimeLocale "%F-%H-%M-%S" curTime - liftIO $ createDirectoryIfMissing True reportDir - logInfo $ "This report set will be put into: " <> T.pack reportDir - logInfo $ "Parsing files..." - allParsedOrgs <- parseNeededFiles conf - forM_ confReports $ \ConfReport{..} -> case crType of - Timeline {..} -> do - logDebug $ "Processing report " <> crName - scope <- getScope conf timelineScope crName - let scopeFiles = NE.toList $ csPaths scope - neededOrgs = - map (\f -> fromMaybe (error $ scopeNotFound (T.pack f) crName) $ - M.lookup f allParsedOrgs) - scopeFiles - let orgTop = Org "/" [] [] $ map (\(fn,o) -> o & orgTitle .~ fn) neededOrgs - withModifiers <- mergeClocks <$> applyMods crModifiers orgTop - let timelineParamsFinal = - (confBaseTimelineParams <> timelineParams) & tpColorSalt .~ confColorSalt - logDebug $ "Launching timeline report with params: " <> show timelineParamsFinal - fromto <- convertRange timelineRange - logDebug $ "Using range: " <> show fromto - res <- processTimeline timelineParamsFinal withModifiers fromto - logInfo $ "Generating report " <> crName <> "..." - writeReport reportDir (T.unpack crName) res - whenM (view wXdgOpen) $ do + let createDir = do + let reportDir = confOutputDir + formatTime defaultTimeLocale "%F-%H-%M-%S" curTime + liftIO $ createDirectoryIfMissing True reportDir + pure reportDir + reportDir <- maybe createDir pure =<< views wcCommonArgs outputDir + logInfo $ "This report set will be put into: " <> fromString reportDir + + outputsToProcess <- + maybe (pure confOutputs) (fmap one . resolveOutput) =<< + views wcCommonArgs selectOutput + forM_ outputsToProcess $ \ConfOutput{..} -> do + logInfo $ "Processing output " <> coName + let prePath = reportDir T.unpack coName + case coType of + TimelineOutput {..} -> do + resolved <- resolveReport toReport + let timelineParamsFinal = + (confBaseTimelineParams <> toParams) & tpColorSalt .~ confColorSalt + let res = processTimeline timelineParamsFinal resolved + logInfo $ "Generating timeline report " <> coName <> "..." + writeReport prePath res + SummaryOutput params -> do + summary <- genSummaryOutput params + writeReport prePath summary + BlockOutput {..} -> do + resolved <- resolveReport boReport + let res = genBlockOutput boParams resolved + writeReport prePath res + whenM (views wcCommonArgs xdgOpen) $ do logInfo "Opening reports using xdg-open..." void $ shell ("for i in $(ls "<>T.pack reportDir<>"/*); do xdg-open $i; done") empty - where - applyMods mods o = case applyModifiers o mods of - Left k -> throwM k - Right r -> pure r - scopeNotFound scope report = - mconcat ["Scope ", scope, " is requested for config report ", - report, ", but is not present in scopes section"] - throwLogic = throwM . ConfigLogicException - getScope OrgStatConfig{..} scopeName reportName = - fromJustM (throwLogic $ scopeNotFound scopeName reportName) $ - pure $ find ((== scopeName) . csName) confScopes - getScopes (Timeline _ s _) = [s] - -- Reads needed org files and returns a map - parseNeededFiles :: OrgStatConfig -> WorkM (Map FilePath (Text, Org)) - parseNeededFiles conf@OrgStatConfig{..} = do - let neededScopes = - nubBy ((==) `on` snd) $ - concatMap (\cr -> map (crName cr,) $ getScopes (crType cr)) confReports - let availableScopes = map csName confScopes - let notAvailableScopes = filter (\(_,s) -> s `notElem` availableScopes) neededScopes - unless (null notAvailableScopes) $ do - let (r,s) = unsafeHead notAvailableScopes - throwLogic $ scopeNotFound s r - neededFiles <- - nub . concatMap (NE.toList . csPaths) <$> - mapM (\(r,s) -> getScope conf s r) neededScopes - fmap M.fromList $ forM neededFiles (\f -> (f,) <$> readOrgFile confTodoKeywords f) + logInfo "Done" diff --git a/src/OrgStat/Outputs.hs b/src/OrgStat/Outputs.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/Outputs.hs @@ -0,0 +1,11 @@ +-- | Re-exporting output functionality + +module OrgStat.Outputs + ( module Exports + ) where + +import OrgStat.Outputs.Block as Exports +import OrgStat.Outputs.Class as Exports +import OrgStat.Outputs.Summary as Exports +import OrgStat.Outputs.Timeline as Exports +import OrgStat.Outputs.Types as Exports diff --git a/src/OrgStat/Outputs/Block.hs b/src/OrgStat/Outputs/Block.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/Outputs/Block.hs @@ -0,0 +1,34 @@ +-- | Block output similar to default org reporting. This is stub +-- version which is to be improved later. + +module OrgStat.Outputs.Block + ( genBlockOutput + ) where + +import Universum + +import qualified Data.Text as T + +import OrgStat.Ast (Org, filterHasClock, orgTitle, orgTotalDuration, + traverseTree) +import OrgStat.Outputs.Types (BlockOutput (..), BlockParams) +import OrgStat.Util (timeF) + +-- Stub. Used for debug mostly. +genBlockOutput :: BlockParams -> Org -> BlockOutput +genBlockOutput _ (filterHasClock -> o0) = do + BlockOutput $ T.unlines $ map formatter (o0 ^.. traverseTree) + where + -- todo implement it with boxes package instead, this is just as stub + cutLen = 50 + margin = 2 + genPad n = fromString (replicate n ' ') + formatter o = + let dur = orgTotalDuration o + titleRaw = T.take cutLen $ o ^. orgTitle + padding = cutLen - length titleRaw + titlePadded = titleRaw <> genPad padding + in mconcat [ titlePadded + , genPad margin <> " | " <> genPad margin + , timeF dur + ] diff --git a/src/OrgStat/Outputs/Class.hs b/src/OrgStat/Outputs/Class.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/Outputs/Class.hs @@ -0,0 +1,34 @@ +-- | Common things among reports + +module OrgStat.Outputs.Class + ( ReportOutput (..) + ) where + +import Universum + +import qualified Data.Text.IO as T +import qualified Diagrams.Backend.SVG as DB +import qualified Diagrams.Prelude as D +import System.FilePath (replaceExtension) + +import OrgStat.Outputs.Types (BlockOutput (..), SummaryOutput (..), + TimelineOutput (..)) + +-- | Things that reporters output an what we can do with them. +class ReportOutput a where + -- | Writes report to the disk, given path to file. + writeReport :: (MonadIO m) => FilePath -> a -> m () + +instance ReportOutput TimelineOutput where + writeReport path (TimelineOutput diagram) = + liftIO $ DB.renderSVG (replaceExtension path "svg") size diagram + where + size = D.dims2D (D.width diagram) (D.height diagram) + +instance ReportOutput SummaryOutput where + writeReport path (SummaryOutput text) = + liftIO $ T.writeFile (replaceExtension path "txt") text + +instance ReportOutput BlockOutput where + writeReport path (BlockOutput text) = + liftIO $ T.writeFile (replaceExtension path "txt") text diff --git a/src/OrgStat/Outputs/Summary.hs b/src/OrgStat/Outputs/Summary.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/Outputs/Summary.hs @@ -0,0 +1,54 @@ +-- | Summary output type. + +module OrgStat.Outputs.Summary + ( genSummaryOutput + ) where + +import Universum + +import Control.Lens (views) +import qualified Data.Attoparsec.ByteString.Char8 as A + +import OrgStat.Ast (orgTotalDuration) +import OrgStat.Config (confReports, crName) +import OrgStat.Helpers (resolveReport) +import OrgStat.Outputs.Types (SummaryOutput (..), SummaryParams (..)) +import OrgStat.Util (timeF) +import OrgStat.WorkMonad (WorkM, wcConfig) + + +-- | Tokenizes summary template string. +data InputToken + = ReportTemplate Text -- ^ Valid template name surrounded by two '%' + | OtherInfo Text -- ^ Anything in between + deriving Show + +tokenize :: [Text] -> Text -> [InputToken] +tokenize keywords (encodeUtf8 -> input) = + case A.parseOnly toplvl input of + Left err -> error $ fromString err + Right res -> res + where + keyword = A.try $ do + void $ A.char '%' + between <- fromString <$> some (A.satisfy (/= '%')) + void $ A.char '%' + guard $ between `elem` keywords + pure $ ReportTemplate between + randomtext = do + h <- A.anyChar + t <- fromString <$> many (A.satisfy (/= '%')) + pure $ OtherInfo $ fromString $ h:t + toplvl = many (keyword <|> randomtext) + +-- | Generates summary using provided params. +genSummaryOutput :: SummaryParams -> WorkM SummaryOutput +genSummaryOutput SummaryParams{..} = do + declaredReports <- views wcConfig $ map crName . confReports + let tokens = tokenize declaredReports spTemplate + res <- fmap mconcat $ forM tokens $ \case + OtherInfo t -> pure t + ReportTemplate reportName -> do + report <- resolveReport reportName + pure $ timeF $ orgTotalDuration report + pure $ SummaryOutput res diff --git a/src/OrgStat/Outputs/Timeline.hs b/src/OrgStat/Outputs/Timeline.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/Outputs/Timeline.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Timeline reporting output. Prouces a svg with columns. + +module OrgStat.Outputs.Timeline + ( processTimeline + ) where + +import Data.Colour.CIE (luminance) +import Data.List (lookup, nub) +import qualified Data.Text as T +import Data.Time (Day, DiffTime, LocalTime (..), defaultTimeLocale, + formatTime, timeOfDayToTime) +import Diagrams.Backend.SVG (B) +import qualified Diagrams.Prelude as D +import qualified Prelude +import Text.Printf (printf) +import Universum + +import OrgStat.Ast (Clock (..), Org (..), orgClocks, traverseTree) +import OrgStat.Outputs.Types (TimelineOutput (..), TimelineParams, tpBackground, + tpColorSalt, tpColumnHeight, tpColumnWidth, + tpLegend, tpTopDay) +import OrgStat.Util (addLocalTime, hashColour) + + + +---------------------------------------------------------------------------- +-- Processing clocks +---------------------------------------------------------------------------- + +-- [(a, [b])] -> [(a, b)] +allClocks :: [(Text, [(DiffTime, DiffTime)])] -> [(Text, (DiffTime, DiffTime))] +allClocks tasks = do + (label, clocks) <- tasks + clock <- clocks + pure (label, clock) + +-- separate list for each day +selectDays :: [Day] -> [(Text, [Clock])] -> [[(Text, [(DiffTime, DiffTime)])]] +selectDays days tasks = + flip map days $ \day -> + filter (not . null . snd) $ + map (second (selectDay day)) tasks + where + selectDay :: Day -> [Clock] -> [(DiffTime, DiffTime)] + selectDay day clocks = do + Clock (LocalTime dFrom tFrom) (LocalTime dTo tTo) <- clocks + guard $ any (== day) [dFrom, dTo] + let tFrom' = if dFrom == day then timeOfDayToTime tFrom else fromInteger 0 + let tTo' = if dTo == day then timeOfDayToTime tTo else fromInteger (24*60*60) + pure (tFrom', tTo') + +-- total time for each task +totalTimes :: [(Text, [(DiffTime, DiffTime)])] -> [(Text, DiffTime)] +totalTimes tasks = map (second clocksSum) tasks + where + clocksSum :: [(DiffTime, DiffTime)] -> DiffTime + clocksSum clocks = sum $ map (\(start, end) -> end - start) clocks + +-- list of leaves +orgToList :: Org -> [(Text, [Clock])] +orgToList = orgToList' "" + where + orgToList' :: Text -> Org -> [(Text, [Clock])] + orgToList' _pr org = + --let path = pr <> "/" <> _orgTitle org + let path = _orgTitle org + in (path, _orgClocks org) : concatMap (orgToList' path) (_orgSubtrees org) + + +---------------------------------------------------------------------------- +-- Drawing +---------------------------------------------------------------------------- + + +diffTimeSeconds :: DiffTime -> Integer +diffTimeSeconds time = floor $ toRational time + +diffTimeMinutes :: DiffTime -> Integer +diffTimeMinutes time = diffTimeSeconds time `div` 60 + +-- diffTimeHours :: DiffTime -> Integer +-- diffTimeHours time = diffTimeMinutes time `div` 60 + + +labelColour :: TimelineParams -> Text -> D.Colour Double +labelColour params _label = hashColour (params ^. tpColorSalt) _label + +-- | Returns if the label is to be shown. Second param is font-related +-- heuristic constant, third is length of interval. +fitLabelHeight :: TimelineParams -> Double -> Double -> Bool +fitLabelHeight params n h = h >= (params ^. tpColumnHeight) * n + +-- | Decides by , width of column +-- and string, should it be truncated. And returns modified string. +fitLabelWidth :: TimelineParams -> Double -> Text -> Text +fitLabelWidth params n s = + if T.length s <= toTake then s else T.take toTake s <> ".." + where + toTake = floor $ n * ((params ^. tpColumnWidth) ** 1.2) + +-- timeline for a single day +timelineDay :: TimelineParams -> Day -> [(Text, (DiffTime, DiffTime))] -> D.Diagram B +timelineDay params day clocks = + (D.strutY 5 D.===) $ + (dateLabel D.===) $ + D.scaleUToY height $ + (timeticks D.|||) $ + mconcat + [ mconcat (map showClock clocks) + , background + ] + where + width = 140 * (totalHeight / height) * (params ^. tpColumnWidth) + ticksWidth = 20 * (totalHeight / height) + height = 700 * (params ^. tpColumnHeight) + + totalHeight :: Double + totalHeight = 24*60 + + timeticks :: D.Diagram B + timeticks = + mconcat $ + flip map [(0::Int)..23] $ \hour -> + mconcat + [ D.alignedText 0.5 1 (show hour) + & D.font "DejaVu Sans" + & D.fontSize 8 + & D.moveTo (D.p2 (0, -5)) + , D.rect ticksWidth 1 + & D.lw D.none + ] + & D.fc (D.sRGB24 150 150 150) + & D.moveTo (D.p2 (0, totalHeight - fromIntegral hour * 60)) + + dateLabel :: D.Diagram B + dateLabel = + mconcat + [ D.strutY 20 + , D.alignedText 0 0.65 (formatTime defaultTimeLocale "%a, %d.%m.%Y" day) + & D.font "DejaVu Sans" + & D.fontSize 12 + & D.moveTo (D.p2 (25, 0)) + ] + + background :: D.Diagram B + background = + D.rect width totalHeight + & D.lw D.none + & D.fc (params ^. tpBackground) + & D.moveOriginTo (D.p2 (-width/2, totalHeight/2)) + & D.moveTo (D.p2 (0, totalHeight)) + + contrastFrom c = if luminance c < 0.14 then D.sRGB24 224 224 224 else D.black + + showClock :: (Text, (DiffTime, DiffTime)) -> D.Diagram B + showClock (label, (start, end)) = + let + w = width + h = fromInteger $ diffTimeMinutes $ end - start + bgboxColour = labelColour params label + bgbox = D.rect w h + & D.lw D.none + & D.fc bgboxColour + label' = D.alignedText 0 0.5 (T.unpack $ fitLabelWidth params 21 label) + & D.font "DejaVu Sans" + & D.fontSize 10 + & D.fc (contrastFrom bgboxColour) + & D.moveTo (D.p2 (-w/2+10, 0)) + box = mconcat $ bool [] [label'] (fitLabelHeight params 14 h) ++ [bgbox] + in box & D.moveOriginTo (D.p2 (-w/2, h/2)) + & D.moveTo (D.p2 (0, totalHeight - fromInteger (diffTimeMinutes start))) +-- timelines for several days, with top lists +timelineDays + :: TimelineParams + -> [Day] + -> [[(Text, (DiffTime, DiffTime))]] + -> [[(Text, DiffTime)]] + -> D.Diagram B +timelineDays params days clocks topLists = + D.hcat $ + flip map (days `zip` (clocks `zip` topLists)) $ \(day, (dayClocks, topList)) -> + D.vsep 5 + [ timelineDay params day dayClocks + , taskList params topList True + ] + +-- task list, with durations and colours +taskList :: TimelineParams -> [(Text, DiffTime)] -> Bool -> D.Diagram B +taskList params labels fit = D.vsep 5 $ map oneTask $ reverse $ sortOn snd labels + where + oneTask :: (Text, DiffTime) -> D.Diagram B + oneTask (label, time) = + D.hsep 3 + [ D.alignedText 1 0.5 (showTime time) + & D.font "DejaVu Sans" + & D.fontSize 10 + & D.translateX 30 + , D.rect 12 12 + & D.fc (labelColour params label) + & D.lw D.none + , D.alignedText 0 0.5 (T.unpack $ bool label (fitLabelWidth params 18 label) fit) + & D.font "DejaVu Sans" + & D.fontSize 10 + ] + + showTime :: DiffTime -> Prelude.String + showTime time = printf "%d:%02d" hours minutes + where + (hours, minutes) = diffTimeMinutes time `divMod` 60 + +timelineReport :: TimelineParams -> Org -> TimelineOutput +timelineReport params org = TimelineOutput pic + where + lookupDef :: Eq a => b -> a -> [(a, b)] -> b + lookupDef d a xs = fromMaybe d $ lookup a xs + + -- These two should be taken from the Org itself (min/max). + (from,to) = + let c = concat $ org ^.. traverseTree . orgClocks + in (minimum (map cFrom c), maximum (map cTo c)) + + -- period to show. Right border is -1min, we assume it's non-inclusive + daysToShow = [localDay from .. + localDay ((negate 120 :: Int) `addLocalTime` to)] + + -- unfiltered leaves + tasks :: [(Text, [Clock])] + tasks = orgToList org + + -- tasks from the given period, split by days + byDay :: [[(Text, [(DiffTime, DiffTime)])]] + byDay = selectDays daysToShow tasks + + -- total durations for each task, split by days + byDayDurations :: [[(Text, DiffTime)]] + byDayDurations = map totalTimes byDay + + -- total durations for the whole period + allDaysDurations :: [(Text, DiffTime)] + allDaysDurations = + let allTasks = nub $ map fst $ concat byDayDurations in + flip map allTasks $ \task -> + (task,) $ sum $ flip map byDayDurations $ \durations -> + lookupDef (fromInteger 0) task durations + + -- split clocks + clocks :: [[(Text, (DiffTime, DiffTime))]] + clocks = map allClocks byDay + + -- top list for each day + topLists :: [[(Text, DiffTime)]] + topLists = + map (take (params ^. tpTopDay) . reverse . sortOn (\(_task, time) -> time)) + byDayDurations + + optLegend | params ^. tpLegend = [taskList params allDaysDurations False] + | otherwise = [] + + pic = + D.vsep 30 $ [ timelineDays params daysToShow clocks topLists ] ++ optLegend + +processTimeline :: TimelineParams -> Org -> TimelineOutput +processTimeline params org = timelineReport params org diff --git a/src/OrgStat/Outputs/Types.hs b/src/OrgStat/Outputs/Types.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/Outputs/Types.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Types common among reports. + +module OrgStat.Outputs.Types + ( TimelineParams (..) + , tpColorSalt + , tpLegend + , tpTopDay + , tpColumnWidth + , tpColumnHeight + , tpBackground + , TimelineOutput (..) + + , SummaryParams (..) + , SummaryOutput (..) + + , BlockParams (..) + , BlockOutput (..) + ) where + +import Universum + +import Control.Lens (makeLenses) + +import Data.Default (Default (..)) +import Diagrams.Backend.SVG (B) +import qualified Diagrams.Prelude as D + +---------------------------------------------------------------------------- +-- Timeline +---------------------------------------------------------------------------- + +data TimelineParams = TimelineParams + { _tpColorSalt :: !Int + -- ^ Salt added when getting color out of task name. + , _tpLegend :: !Bool + -- ^ Include map legend? + , _tpTopDay :: !Int + -- ^ How many items to include in top day (under column) + , _tpColumnWidth :: !Double + -- ^ Column width in percent + , _tpColumnHeight :: !Double + -- ^ Column height + , _tpBackground :: !(D.Colour Double) + -- ^ Color of background + } deriving (Show) + +instance Default TimelineParams where + def = TimelineParams 0 True 5 1 1 (D.sRGB24 0xf2 0xf2 0xf2) + +makeLenses ''TimelineParams + +-- | For all non-default field values of RHS, override LHS with them. +mergeParams :: TimelineParams -> TimelineParams -> TimelineParams +mergeParams lhs rhs = mods lhs + where + mods = foldr1 (.) + [ asId tpColorSalt + , asId tpLegend + , asId tpTopDay + , asId tpColumnWidth + , asId tpColumnHeight + , asId tpBackground ] + asId :: forall b. (Eq b) => Lens' TimelineParams b -> TimelineParams -> TimelineParams + asId l x = + if def ^. l == rhs ^. l + then x else x & l .~ (rhs ^. l) + +instance Monoid TimelineParams where + mempty = def + mappend = mergeParams + +-- | SVG timeline image. +newtype TimelineOutput = TimelineOutput (D.Diagram B) + +---------------------------------------------------------------------------- +-- Summary +---------------------------------------------------------------------------- + +-- | Parameters of the summary output +data SummaryParams = SummaryParams + { spTemplate :: !Text + -- ^ Formatting template. + } deriving Show + +-- | Some text (supposed to be single line or something). +newtype SummaryOutput = SummaryOutput Text + +---------------------------------------------------------------------------- +-- Block +---------------------------------------------------------------------------- + +-- | Parameters for block output. Stub (for now). +data BlockParams = BlockParams + { + } deriving (Show) + +-- | Output of block type is text file, basically. +newtype BlockOutput = BlockOutput Text diff --git a/src/OrgStat/Parser.hs b/src/OrgStat/Parser.hs --- a/src/OrgStat/Parser.hs +++ b/src/OrgStat/Parser.hs @@ -6,13 +6,15 @@ , runParser ) where +import Universum + import Control.Exception (Exception) import qualified Data.Attoparsec.Text as A -import qualified Data.OrgMode.Parse as OP +import qualified Data.OrgMode.Parse as O +import qualified Data.OrgMode.Types as O import qualified Data.Text as T import Data.Time (LocalTime (..), TimeOfDay (..), fromGregorian) import Data.Time.Calendar () -import Universum import OrgStat.Ast (Clock (..), Org (..)) @@ -31,48 +33,40 @@ ---------------------------------------------------------------------------- parseOrg :: [Text] -> A.Parser Org -parseOrg todoKeywords = convertDocument <$> OP.parseDocument todoKeywords +parseOrg todoKeywords = convertDocument <$> O.parseDocument todoKeywords where - convertDocument :: OP.Document -> Org - convertDocument (OP.Document _ headings) = Org + convertDocument :: O.Document -> Org + convertDocument (O.Document _ headings) = Org { _orgTitle = "" , _orgTags = [] , _orgClocks = [] , _orgSubtrees = map convertHeading headings } - convertHeading :: OP.Heading -> Org - convertHeading heading = Org - { _orgTitle = OP.title heading - , _orgTags = OP.tags heading - , _orgClocks = getClocks $ OP.section heading - , _orgSubtrees = map convertHeading $ OP.subHeadings heading + convertHeading :: O.Headline -> Org + convertHeading headline = Org + { _orgTitle = O.title headline + , _orgTags = O.tags headline + , _orgClocks = getClocks $ O.section headline + , _orgSubtrees = map convertHeading $ O.subHeadlines headline } - mapEither :: (a -> Either e b) -> ([a] -> [b]) - mapEither f xs = rights $ map f xs - - getClocks :: OP.Section -> [Clock] + getClocks :: O.Section -> [Clock] getClocks section = - mapMaybe convertClock $ concat - [ OP.sectionClocks section - , mapEither (A.parseOnly OP.parseClock) $ - lines $ - OP.sectionParagraph section - ] + mapMaybe convertClock $ O.sectionClocks section -- convert clocks from orgmode-parse format, returns Nothing for clocks -- without end time or time-of-day - convertClock :: (Maybe OP.Timestamp, Maybe OP.Duration) -> Maybe Clock - convertClock (Just (OP.Timestamp start _active (Just end)), _duration) = + convertClock :: O.Clock -> Maybe Clock + convertClock (O.Clock (Just (O.Timestamp start _active (Just end)), _duration)) = Clock <$> convertDateTime start <*> convertDateTime end convertClock _ = Nothing -- Nothing for DateTime without time-of-day - convertDateTime :: OP.DateTime -> Maybe LocalTime + convertDateTime :: O.DateTime -> Maybe LocalTime convertDateTime - OP.DateTime - { yearMonthDay = OP.YMD' (OP.YearMonthDay year month day) + O.DateTime + { yearMonthDay = O.YearMonthDay year month day , hourMinute = Just (hour, minute) } = Just $ LocalTime diff --git a/src/OrgStat/Report.hs b/src/OrgStat/Report.hs deleted file mode 100644 --- a/src/OrgStat/Report.hs +++ /dev/null @@ -1,9 +0,0 @@ --- | Re-exporting report functionality - -module OrgStat.Report - ( module Exports - ) where - -import OrgStat.Report.Class as Exports -import OrgStat.Report.Timeline as Exports -import OrgStat.Report.Types as Exports diff --git a/src/OrgStat/Report/Class.hs b/src/OrgStat/Report/Class.hs deleted file mode 100644 --- a/src/OrgStat/Report/Class.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | Common things among reports - -module OrgStat.Report.Class - ( Report (..) - ) where - -import qualified Diagrams.Backend.SVG as DB -import qualified Diagrams.Prelude as D -import System.FilePath (replaceExtension, ()) -import Universum - -import OrgStat.Report.Types (SVGImageReport (..)) - --- | Things that reporters output an what we can do with them. -class Report a where - -- | Writes report to the disk, given directory and filename. - writeReport :: (MonadIO m) => FilePath -> FilePath -> a -> m () - -instance Report SVGImageReport where - writeReport dir filename (SVGImage diagram) = - liftIO $ DB.renderSVG (replaceExtension (dir filename) "svg") size diagram - where - size = D.dims2D (D.width diagram) (D.height diagram) diff --git a/src/OrgStat/Report/Timeline.hs b/src/OrgStat/Report/Timeline.hs deleted file mode 100644 --- a/src/OrgStat/Report/Timeline.hs +++ /dev/null @@ -1,315 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - --- | Timeline reporting. Prouces a svg with columns. - -module OrgStat.Report.Timeline - ( TimelineParams (..) - , tpColorSalt - , tpLegend - , tpTopDay - , tpColumnWidth - , tpColumnHeight - , tpBackground - - , processTimeline - ) where - -import Control.Lens (makeLenses) -import Data.Colour.CIE (luminance) -import Data.Default (Default (..)) -import Data.List (lookup, nub) -import qualified Data.Text as T -import Data.Time (Day, DiffTime, LocalTime (..), defaultTimeLocale, - formatTime, timeOfDayToTime) -import Diagrams.Backend.SVG (B) -import qualified Diagrams.Prelude as D -import qualified Prelude -import Text.Printf (printf) -import Universum - -import OrgStat.Ast (Clock (..), Org (..)) -import OrgStat.Report.Types (SVGImageReport (..)) -import OrgStat.Util (addLocalTime, hashColour) - - ----------------------------------------------------------------------------- --- Parameters ----------------------------------------------------------------------------- - -data TimelineParams = TimelineParams - { _tpColorSalt :: !Int - -- ^ Salt added when getting color out of task name. - , _tpLegend :: !Bool - -- ^ Include map legend? - , _tpTopDay :: !Int - -- ^ How many items to include in top day (under column) - , _tpColumnWidth :: !Double - -- ^ Column width in percent - , _tpColumnHeight :: !Double - -- ^ Column height - , _tpBackground :: !(D.Colour Double) - -- ^ Color of background - } deriving (Show) - -instance Default TimelineParams where - def = TimelineParams 0 True 5 1 1 (D.sRGB24 0xf2 0xf2 0xf2) - -makeLenses ''TimelineParams - --- | For all non-default field values of RHS, override LHS with them. -mergeParams :: TimelineParams -> TimelineParams -> TimelineParams -mergeParams lhs rhs = mods lhs - where - mods = foldr1 (.) - [ asId tpColorSalt - , asId tpLegend - , asId tpTopDay - , asId tpColumnWidth - , asId tpColumnHeight - , asId tpBackground ] - asId :: forall b. (Eq b) => Lens' TimelineParams b -> TimelineParams -> TimelineParams - asId l x = - if def ^. l == rhs ^. l - then x else x & l .~ (rhs ^. l) - -instance Monoid TimelineParams where - mempty = def - mappend = mergeParams - ----------------------------------------------------------------------------- --- Processing clocks ----------------------------------------------------------------------------- - --- [(a, [b])] -> [(a, b)] -allClocks :: [(Text, [(DiffTime, DiffTime)])] -> [(Text, (DiffTime, DiffTime))] -allClocks tasks = do - (label, clocks) <- tasks - clock <- clocks - pure (label, clock) - --- separate list for each day -selectDays :: [Day] -> [(Text, [Clock])] -> [[(Text, [(DiffTime, DiffTime)])]] -selectDays days tasks = - flip map days $ \day -> - filter (not . null . snd) $ - map (second (selectDay day)) tasks - where - selectDay :: Day -> [Clock] -> [(DiffTime, DiffTime)] - selectDay day clocks = do - Clock (LocalTime dFrom tFrom) (LocalTime dTo tTo) <- clocks - guard $ any (== day) [dFrom, dTo] - let tFrom' = if dFrom == day then timeOfDayToTime tFrom else fromInteger 0 - let tTo' = if dTo == day then timeOfDayToTime tTo else fromInteger (24*60*60) - pure (tFrom', tTo') - --- total time for each task -totalTimes :: [(Text, [(DiffTime, DiffTime)])] -> [(Text, DiffTime)] -totalTimes tasks = map (second clocksSum) tasks - where - clocksSum :: [(DiffTime, DiffTime)] -> DiffTime - clocksSum clocks = sum $ map (\(start, end) -> end - start) clocks - --- list of leaves -orgToList :: Org -> [(Text, [Clock])] -orgToList = orgToList' "" - where - orgToList' :: Text -> Org -> [(Text, [Clock])] - orgToList' _pr org = - --let path = pr <> "/" <> _orgTitle org - let path = _orgTitle org - in (path, _orgClocks org) : concatMap (orgToList' path) (_orgSubtrees org) - - ----------------------------------------------------------------------------- --- Drawing ----------------------------------------------------------------------------- - - -diffTimeSeconds :: DiffTime -> Integer -diffTimeSeconds time = floor $ toRational time - -diffTimeMinutes :: DiffTime -> Integer -diffTimeMinutes time = diffTimeSeconds time `div` 60 - --- diffTimeHours :: DiffTime -> Integer --- diffTimeHours time = diffTimeMinutes time `div` 60 - - -labelColour :: TimelineParams -> Text -> D.Colour Double -labelColour params _label = hashColour (params ^. tpColorSalt) _label - --- | Returns if the label is to be shown. Second param is font-related --- heuristic constant, third is length of interval. -fitLabelHeight :: TimelineParams -> Double -> Double -> Bool -fitLabelHeight params n h = h >= (params ^. tpColumnHeight) * n - --- | Decides by , width of column --- and string, should it be truncated. And returns modified string. -fitLabelWidth :: TimelineParams -> Double -> Text -> Text -fitLabelWidth params n s = - if T.length s <= toTake then s else T.take toTake s <> ".." - where - toTake = floor $ n * ((params ^. tpColumnWidth) ** 1.2) - --- timeline for a single day -timelineDay :: TimelineParams -> Day -> [(Text, (DiffTime, DiffTime))] -> D.Diagram B -timelineDay params day clocks = - (D.strutY 5 D.===) $ - (dateLabel D.===) $ - D.scaleUToY height $ - (timeticks D.|||) $ - mconcat - [ mconcat (map showClock clocks) - , background - ] - where - width = 140 * (totalHeight / height) * (params ^. tpColumnWidth) - ticksWidth = 20 * (totalHeight / height) - height = 700 * (params ^. tpColumnHeight) - - totalHeight :: Double - totalHeight = 24*60 - - timeticks :: D.Diagram B - timeticks = - mconcat $ - flip map [(0::Int)..23] $ \hour -> - mconcat - [ D.alignedText 0.5 1 (show hour) - & D.font "DejaVu Sans" - & D.fontSize 8 - & D.moveTo (D.p2 (0, -5)) - , D.rect ticksWidth 1 - & D.lw D.none - ] - & D.fc (D.sRGB24 150 150 150) - & D.moveTo (D.p2 (0, totalHeight - fromIntegral hour * 60)) - - dateLabel :: D.Diagram B - dateLabel = - mconcat - [ D.strutY 20 - , D.alignedText 0 0.65 (formatTime defaultTimeLocale "%a, %d.%m.%Y" day) - & D.font "DejaVu Sans" - & D.fontSize 12 - & D.moveTo (D.p2 (25, 0)) - ] - - background :: D.Diagram B - background = - D.rect width totalHeight - & D.lw D.none - & D.fc (params ^. tpBackground) - & D.moveOriginTo (D.p2 (-width/2, totalHeight/2)) - & D.moveTo (D.p2 (0, totalHeight)) - - contrastFrom c = if luminance c < 0.14 then D.sRGB24 224 224 224 else D.black - - showClock :: (Text, (DiffTime, DiffTime)) -> D.Diagram B - showClock (label, (start, end)) = - let - w = width - h = fromInteger $ diffTimeMinutes $ end - start - bgboxColour = labelColour params label - bgbox = D.rect w h - & D.lw D.none - & D.fc bgboxColour - label' = D.alignedText 0 0.5 (T.unpack $ fitLabelWidth params 21 label) - & D.font "DejaVu Sans" - & D.fontSize 10 - & D.fc (contrastFrom bgboxColour) - & D.moveTo (D.p2 (-w/2+10, 0)) - box = mconcat $ bool [] [label'] (fitLabelHeight params 14 h) ++ [bgbox] - in box & D.moveOriginTo (D.p2 (-w/2, h/2)) - & D.moveTo (D.p2 (0, totalHeight - fromInteger (diffTimeMinutes start))) --- timelines for several days, with top lists -timelineDays - :: TimelineParams - -> [Day] - -> [[(Text, (DiffTime, DiffTime))]] - -> [[(Text, DiffTime)]] - -> D.Diagram B -timelineDays params days clocks topLists = - D.hcat $ - flip map (days `zip` (clocks `zip` topLists)) $ \(day, (dayClocks, topList)) -> - D.vsep 5 - [ timelineDay params day dayClocks - , taskList params topList True - ] - --- task list, with durations and colours -taskList :: TimelineParams -> [(Text, DiffTime)] -> Bool -> D.Diagram B -taskList params labels fit = D.vsep 5 $ map oneTask $ reverse $ sortOn snd labels - where - oneTask :: (Text, DiffTime) -> D.Diagram B - oneTask (label, time) = - D.hsep 3 - [ D.alignedText 1 0.5 (showTime time) - & D.font "DejaVu Sans" - & D.fontSize 10 - & D.translateX 30 - , D.rect 12 12 - & D.fc (labelColour params label) - & D.lw D.none - , D.alignedText 0 0.5 (T.unpack $ bool label (fitLabelWidth params 18 label) fit) - & D.font "DejaVu Sans" - & D.fontSize 10 - ] - - showTime :: DiffTime -> Prelude.String - showTime time = printf "%d:%02d" hours minutes - where - (hours, minutes) = diffTimeMinutes time `divMod` 60 - -timelineReport :: TimelineParams -> Org -> (LocalTime, LocalTime) -> SVGImageReport -timelineReport params org (from,to) = SVGImage pic - where - lookupDef :: Eq a => b -> a -> [(a, b)] -> b - lookupDef d a xs = fromMaybe d $ lookup a xs - - -- period to show. Right border is -1min, we assume it's non-inclusive - daysToShow = [localDay from .. - localDay ((negate 120 :: Int) `addLocalTime` to)] - - -- unfiltered leaves - tasks :: [(Text, [Clock])] - tasks = orgToList org - - -- tasks from the given period, split by days - byDay :: [[(Text, [(DiffTime, DiffTime)])]] - byDay = selectDays daysToShow tasks - - -- total durations for each task, split by days - byDayDurations :: [[(Text, DiffTime)]] - byDayDurations = map totalTimes byDay - - -- total durations for the whole period - allDaysDurations :: [(Text, DiffTime)] - allDaysDurations = - let allTasks = nub $ map fst $ concat byDayDurations in - flip map allTasks $ \task -> - (task,) $ sum $ flip map byDayDurations $ \durations -> - lookupDef (fromInteger 0) task durations - - -- split clocks - clocks :: [[(Text, (DiffTime, DiffTime))]] - clocks = map allClocks byDay - - -- top list for each day - topLists :: [[(Text, DiffTime)]] - topLists = - map (take (params ^. tpTopDay) . reverse . sortOn (\(_task, time) -> time)) - byDayDurations - - optLegend | params ^. tpLegend = [taskList params allDaysDurations False] - | otherwise = [] - - pic = - D.vsep 30 $ [ timelineDays params daysToShow clocks topLists ] ++ optLegend - -processTimeline - :: (MonadThrow m) - => TimelineParams -> Org -> (LocalTime, LocalTime) -> m SVGImageReport -processTimeline params org fromto = pure $ timelineReport params org fromto diff --git a/src/OrgStat/Report/Types.hs b/src/OrgStat/Report/Types.hs deleted file mode 100644 --- a/src/OrgStat/Report/Types.hs +++ /dev/null @@ -1,13 +0,0 @@ --- | Types common among reports. - -module OrgStat.Report.Types - ( SVGImageReport (..) - ) where - -import Diagrams.Backend.SVG (B) -import qualified Diagrams.Prelude as D - --- Also thing to think about is how we output settings (time ranges --- etc.) -- on the plot, in the corner, in the file name, as a --- description file ? -data SVGImageReport = SVGImage (D.Diagram B) diff --git a/src/OrgStat/Scope.hs b/src/OrgStat/Scope.hs --- a/src/OrgStat/Scope.hs +++ b/src/OrgStat/Scope.hs @@ -19,8 +19,8 @@ import qualified Data.Text as T import Universum -import OrgStat.Ast (Org, atDepth, orgClocks, orgSubtrees, orgTitle, - traverseTree) +import OrgStat.Ast (Org, atDepth, orgClocks, orgSubtrees, orgTags, + orgTitle, traverseTree) -- | Path in org AST is just a list of paths, head ~ closer to tree -- root. @@ -62,7 +62,7 @@ -- ^ Turns all subtrees starting with @path@ and then on depth @d@ into leaves. | ModFilterTag Text -- ^ Given text tag name, it leaves only those subtrees that - -- have this tag (tags inherit). + -- have this tag (tags are inherited). | ModSquash AstPath -- ^ Starting at node on path A and depth n, turn A into set of -- nodes A/a1/a2/.../an. Doesn't work/make sense for empty path. @@ -96,6 +96,14 @@ pure $ fromMaybe (error "applyModifier@ModSelectSubtree is broken") $ org ^. atPath path +applyModifier (ModFilterTag tag) o0 = do + let matchesTag o = any (== tag) (o ^. orgTags) + let dfs :: Org -> Maybe Org + dfs o | matchesTag o = Just o + | otherwise = case mapMaybe dfs (o ^. orgSubtrees) of + [] -> Nothing + xs -> Just $ o & orgSubtrees .~ xs + Right $ o0 & orgSubtrees %~ mapMaybe dfs applyModifier _ org = pure org -- TODO -- | Generates an org to be processed by report generators from 'Scope'. diff --git a/src/OrgStat/Util.hs b/src/OrgStat/Util.hs --- a/src/OrgStat/Util.hs +++ b/src/OrgStat/Util.hs @@ -9,6 +9,7 @@ , parseColour , hashColour , (??~) + , timeF ) where import Control.Lens (ASetter, ix) @@ -21,8 +22,8 @@ import Data.Hashable (hashWithSalt) import Data.List (nub) import Data.List ((!!)) -import Data.Time (LocalTime (..), addUTCTime, localTimeToUTC, utc, - utcToLocalTime) +import Data.Time (LocalTime (..), NominalDiffTime, addUTCTime, + localTimeToUTC, utc, utcToLocalTime) import Universum -- | JSON/Yaml TH modifier. Each field of type "aoeuKek" turns into @@ -82,3 +83,13 @@ (??~) :: ASetter s s a b -> Maybe b -> s -> s (??~) _ Nothing = identity (??~) l (Just k) = l .~ k + +-- | Time formatter in form HH:MM +timeF :: NominalDiffTime -> Text +timeF n = do + let totalTimeMin :: Integer + totalTimeMin = round $ (/ 60) $ toRational n + let hours = totalTimeMin `div` 60 + let minutes = totalTimeMin `mod` 60 + let showTwo x = (if x < 10 then "0" else "") <> show x + fromString $ show hours <> ":" <> showTwo minutes diff --git a/src/OrgStat/WorkMonad.hs b/src/OrgStat/WorkMonad.hs --- a/src/OrgStat/WorkMonad.hs +++ b/src/OrgStat/WorkMonad.hs @@ -3,32 +3,69 @@ -- | Definition for main work scope module OrgStat.WorkMonad - ( WorkScope (..) - , wConfigFile - , wXdgOpen + ( WorkConfig (..) + , wcConfig + , wcCommonArgs + , WorkData + , wdReadFiles + , wdResolvedScopes + , wdResolvedReports , WorkM (..) , runWorkM ) where -import Control.Lens (makeLenses) -import qualified System.Wlog as W import Universum -data WorkScope = WorkScope - { _wConfigFile :: FilePath - , _wXdgOpen :: Bool +import Control.Lens (makeLenses) +import Data.Default (Default (def)) +import qualified System.Wlog as W + +import OrgStat.Ast (Org) +import OrgStat.CLI (CommonArgs) +import OrgStat.Config (OrgStatConfig) + +-- | Read-only app configuration. +data WorkConfig = WorkConfig + { _wcConfig :: OrgStatConfig + , _wcCommonArgs :: CommonArgs } -makeLenses ''WorkScope +makeLenses ''WorkConfig +-- | State component of application. +data WorkData = WorkData + { _wdReadFiles :: HashMap FilePath (Text, Org) + -- ^ Org files that were read. Elements are pairs of type (file + -- basename, content). Keys are paths. + , _wdResolvedScopes :: HashMap Text Org + -- ^ Scope is just plain read files. + , _wdResolvedReports :: HashMap Text Org + -- ^ Report is a filtered (with scope modifiers and clock + -- limitations) scope. + } + +makeLenses ''WorkData + +instance Default WorkData where + def = WorkData mempty mempty mempty + newtype WorkM a = WorkM - { getWorkM :: ReaderT WorkScope IO a - } deriving (Functor, Applicative, Monad, MonadIO, MonadReader WorkScope, - W.CanLog, MonadThrow, MonadCatch) + { getWorkM :: StateT WorkData (ReaderT WorkConfig IO) a + } deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader WorkConfig + , MonadState WorkData + , W.CanLog + , MonadThrow + , MonadCatch + ) instance W.HasLoggerName WorkM where getLoggerName = pure $ W.LoggerName "OrgStat" modifyLoggerName _ = identity -runWorkM :: MonadIO m => WorkScope -> WorkM a -> m a -runWorkM scope action = liftIO $ runReaderT (getWorkM action) scope +runWorkM :: MonadIO m => WorkConfig -> WorkM a -> m a +runWorkM config action = + liftIO $ runReaderT (evalStateT (getWorkM action) def) config diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where -import Control.Monad.Catch (catch) import Data.Version (showVersion) import Options.Applicative.Simple (Parser, help, long, metavar, simpleOptions, strOption, switch, value) @@ -13,26 +13,29 @@ logDebug, logError, setupLogging) import Universum +import OrgStat.CLI (CommonArgs, parseCommonArgs) +import OrgStat.IO (readConfig) import OrgStat.Logic (runOrgStat) -import OrgStat.WorkMonad (WorkScope (..), runWorkM) +import OrgStat.WorkMonad (WorkConfig (..), runWorkM) data Args = Args { configPath :: !FilePath -- ^ Path to configuration file. - , xdgOpen :: Bool - -- ^ Open report types using xdg-open - , debug :: Bool - -- ^ Enable debug logging + , debug :: !Bool + -- ^ Enable debug logging. + , commonArgs :: CommonArgs + -- ^ Other arguments. } deriving Show argsParser :: FilePath -> Parser Args -argsParser homeDir = - Args <$> - strOption - (long "conf-path" <> metavar "FILEPATH" <> value (homeDir ".orgstat.yaml") <> - help "Path to the configuration file") <*> - switch (long "xdg-open" <> help "Open each report using xdg-open") <*> - switch (long "debug" <> help "Enable debug logging") +argsParser homeDir = do + configPath <- + strOption + (long "conf-path" <> metavar "FILEPATH" <> value (homeDir ".orgstat.yaml") <> + help "Path to the configuration file") + debug <- switch (long "debug" <> help "Enable debug logging") + commonArgs <- parseCommonArgs + pure Args {..} getNodeOptions :: FilePath -> IO Args getNodeOptions homeDir = do @@ -49,8 +52,9 @@ main = do args@Args{..} <- getNodeOptions =<< getHomeDirectory let sev = if debug then Debug else Info - setupLogging $ consoleOutB & lcTermSeverity .~ Just sev - runWorkM (WorkScope configPath xdgOpen) $ do + setupLogging Nothing $ consoleOutB & lcTermSeverity .~ Just sev + config <- readConfig configPath + runWorkM (WorkConfig config commonArgs) $ do logDebug $ "Just started with options: " <> show args runOrgStat `catch` topHandler where diff --git a/test/GlobalSpec.hs b/test/GlobalSpec.hs --- a/test/GlobalSpec.hs +++ b/test/GlobalSpec.hs @@ -20,7 +20,7 @@ import OrgStat.Ast (Clock (..), Org (..), atDepth, mergeClocks, orgClocks) import OrgStat.Config (ConfDate (..), ConfRange (..)) -import OrgStat.Logic (convertRange) +import OrgStat.Helpers (convertRange) import OrgStat.Util (addLocalTime, parseColour)