orgstat 0.0.4 → 0.1.0

raw patch · 23 files changed

+987/−610 lines, 23 filesdep ~exceptionsdep ~log-warperdep ~orgmode-parsePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: exceptions, log-warper, orgmode-parse, universum

API changes (from Hackage documentation)

Files

• orgstat.cabal +17/−12
• src/OrgStat/Ast.hs +45/−2
• src/OrgStat/CLI.hs +37/−0
• src/OrgStat/Config.hs +78/−56
• src/OrgStat/Helpers.hs +146/−0
• src/OrgStat/IO.hs +1/−2
• src/OrgStat/Logic.hs +48/−117
• src/OrgStat/Outputs.hs +11/−0
• src/OrgStat/Outputs/Block.hs +34/−0
• src/OrgStat/Outputs/Class.hs +34/−0
• src/OrgStat/Outputs/Summary.hs +54/−0
• src/OrgStat/Outputs/Timeline.hs +267/−0
• src/OrgStat/Outputs/Types.hs +100/−0
• src/OrgStat/Parser.hs +20/−26
• src/OrgStat/Report.hs +0/−9
• src/OrgStat/Report/Class.hs +0/−23
• src/OrgStat/Report/Timeline.hs +0/−315
• src/OrgStat/Report/Types.hs +0/−13
• src/OrgStat/Scope.hs +11/−3
• src/OrgStat/Util.hs +13/−2
• src/OrgStat/WorkMonad.hs +51/−14
• src/cli/Main.hs +19/−15
• test/GlobalSpec.hs +1/−1

@@ -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

@@ -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

@@ -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!")))

@@ -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

@@ -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)

@@ -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

@@ -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"

@@ -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

@@ -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+                   ]

@@ -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

@@ -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

@@ -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 <heuristic param n depending on font>, 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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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 <heuristic param n depending on font>, 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

@@ -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)

@@ -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'.

@@ -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

@@ -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

@@ -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

@@ -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)