diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,20 @@ -0.1.5 +0.1.6 ========== +* Support "or" tags -- now it's possible to specify "t1 | t2 | t3" as a modifier by + providing a list of tags in config. +* Support of file-level tags: "#+FILETAGS: :tagA:tagB:tagC:" is correctly parsed + and tags are propagated to all the file tree headers. +* Added new output type -- script output. +* Improved documentation, in particular in the orgstatExample.yaml. +* Breaking: Configuration changes: + * Simplifed the configuration, now there's only one default timeline config, + which cannot be overriden on a per-output basis. + * Config parameter `colorSalt` was removed, use `timelineDefault.colorSalt` instead. + * Timeline default color is now white. + * timelineDefault renamed into timelineParams. + +0.1.5 +===== * Support selecting multiple outputs in cli: --select-output can be used several times, also it's renamed into --output. diff --git a/orgstat.cabal b/orgstat.cabal --- a/orgstat.cabal +++ b/orgstat.cabal @@ -1,5 +1,5 @@ name: orgstat -version: 0.1.5 +version: 0.1.6 synopsis: Statistics visualizer for org-mode license: GPL-3 license-file: LICENSE @@ -24,6 +24,7 @@ , OrgStat.Outputs.Block , OrgStat.Outputs.Class , OrgStat.Outputs.Summary + , OrgStat.Outputs.Script , OrgStat.Outputs.Timeline , OrgStat.Outputs.Types , OrgStat.Util @@ -44,13 +45,13 @@ , exceptions >= 0.8.3 , filepath , formatting - , fmt + , fmt >= 0.6 , hashable >= 1.2.4.0 , lens >= 4.14 - , linear , mtl >= 2.2.1 , optparse-simple - , orgmode-parse >= 0.2.1 + , orgmode-parse >= 0.2.1 && < 0.3 + , process >= 1.6.3.0 , text >= 1.2.2.1 , time >= 1.6.0.1 , turtle >= 1.2.8 diff --git a/src/OrgStat/CLI.hs b/src/OrgStat/CLI.hs --- a/src/OrgStat/CLI.hs +++ b/src/OrgStat/CLI.hs @@ -29,9 +29,9 @@ strOption (long "output" <> long "select-output" <> help ("Output name(s) you want to process " <> - "(by default all outputs from conf are selected)"))) <*> + "(default: all outputs are processed)"))) <*> optional ( strOption (long "output-dir" <> metavar "FILEPATH" <> help ("Final output directory that overrides one in config. " <> - "No extra subdirectories will be created!"))) + "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 @@ -18,18 +18,16 @@ 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.Outputs.Types (BlockParams, SummaryParams (..), TimelineParams, bpMaxLength, - bpUnicode, tpBackground, tpColumnHeight, tpColumnWidth, tpLegend, - tpTopDay) +import OrgStat.Outputs.Types (BlockParams (..), ScriptParams (..), SummaryParams (..), + TimelineParams (..)) import OrgStat.Scope (AstPath (..), ScopeModifier (..)) -import OrgStat.Util (parseColour, (??~)) +import OrgStat.Util (parseColour) -- | Exception type for everything bad that happens with config, -- starting from parsing to logic errors. @@ -56,6 +54,7 @@ = TimelineOutput { toParams :: !TimelineParams , toReport :: !Text } | SummaryOutput !SummaryParams + | ScriptOutput !ScriptParams | BlockOutput { boParams :: !BlockParams , boReport :: !Text } deriving (Show) @@ -78,13 +77,12 @@ } deriving (Show) data OrgStatConfig = OrgStatConfig - { confScopes :: ![ConfScope] - , confReports :: ![ConfReport] - , confOutputs :: ![ConfOutput] - , confBaseTimelineParams :: !TimelineParams - , confTodoKeywords :: ![Text] - , confOutputDir :: !FilePath -- default is "./orgstat" - , confColorSalt :: !Int + { confScopes :: ![ConfScope] + , confReports :: ![ConfReport] + , confOutputs :: ![ConfOutput] + , confTimelineParams :: !TimelineParams + , confTodoKeywords :: ![Text] + , confOutputDir :: !FilePath -- default is "./orgstat" } deriving (Show) instance FromJSON AstPath where @@ -96,7 +94,9 @@ o .: "type" >>= \case (String "prune") -> ModPruneSubtree <$> o .: "path" <*> o .:? "depth" .!= 0 (String "select") -> ModSelectSubtree <$> o .: "path" - (String "filterbytag") -> ModFilterTag <$> o .: "tag" + (String "filterbytag") -> + (ModFilterTags . (\x -> [x]) <$> o .: "tag") <|> + (ModFilterTags <$> o .: "tags") other -> fail $ "Unsupported scope modifier type: " ++ show other instance FromJSON ConfDate where @@ -134,16 +134,15 @@ instance FromJSON TimelineParams where parseJSON = withObject "TimelineParams" $ \v -> do - legend <- v .:? "legend" - topDay <- v .:? "topDay" - colWidth <- v .:? "colWidth" - colHeight <- v .:? "colHeight" - bgColorRaw <- v .:? "background" - pure $ def & tpLegend ??~ legend - & tpTopDay ??~ topDay - & tpColumnWidth ??~ colWidth - & tpColumnHeight ??~ colHeight - & tpBackground ??~ (T.strip <$> bgColorRaw >>= parseColour @Text) + _tpColorSalt <- v .:? "colorSalt" .!= 0 + _tpLegend <- v .:? "legend" .!= True + _tpTopDay <- v .:? "topDay" .!= 5 + _tpColumnWidth <- v .:? "colWidth" .!= 1.0 + _tpColumnHeight <- v .:? "colHeight" .!= 1.0 + _tpBackground <- + (fromMaybe (error "Can't parse colour") . parseColour @Text . T.strip) <$> + v .:? "background" .!= "#ffffff" + pure TimelineParams{..} instance FromJSON ConfOutputType where parseJSON = withObject "ConfOutputType" $ \o -> @@ -155,19 +154,24 @@ (String "summary") -> do soTemplate <- o .: "template" pure $ SummaryOutput $ SummaryParams soTemplate + (String "script") -> do + spScript <- + fmap Left (o .: "scriptPath") <|> + fmap Right (o .: "inline") + spReports <- o .: "reports" + pure $ ScriptOutput $ ScriptParams spScript spReports (String "block") -> do boReport <- o .: "report" - maxLength <- o .: "maxLength" - unicode <- o .: "unicode" - let boParams = def & bpMaxLength ??~ maxLength - & bpUnicode ??~ unicode + _bpMaxLength <- o .:? "maxLength" .!= 80 + _bpUnicode <- o .:? "unicode" .!= True + 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) + coName <- o .: "name" + coType <- parseJSON (Object o) pure $ ConfOutput{..} instance FromJSON ConfScope where @@ -187,7 +191,8 @@ OrgStatConfig <$> o .: "scopes" <*> o .: "reports" <*> o .: "outputs" - <*> o .:? "timelineDefault" .!= def + -- timelineDefault is deprecated + <*> ((o .: "timelineParams" <|> o .: "timelineDefault") + <|> parseJSON (Object mempty)) <*> o .:? "todoKeywords" .!= [] <*> (o .:? "outputDir" <|> o .:? "output") .!= "./orgstat" - <*> o .:? "colorSalt" .!= 0 diff --git a/src/OrgStat/Logic.hs b/src/OrgStat/Logic.hs --- a/src/OrgStat/Logic.hs +++ b/src/OrgStat/Logic.hs @@ -19,7 +19,8 @@ import OrgStat.Config (ConfOutput (..), ConfOutputType (..), OrgStatConfig (..)) import OrgStat.Helpers (resolveOutput, resolveReport) import OrgStat.Logging (logDebug, logInfo) -import OrgStat.Outputs (genBlockOutput, genSummaryOutput, processTimeline, tpColorSalt, writeReport) +import OrgStat.Outputs (genBlockOutput, genSummaryOutput, processScriptOutput, processTimeline, + writeReport) import OrgStat.WorkMonad (WorkM, wcCommonArgs, wcConfig) -- | Main application logic. @@ -29,37 +30,44 @@ logDebug $ "Config: \n" <> show conf curTime <- liftIO getZonedTime - - let createDir = do - let reportDir = confOutputDir + let getOutputDir = 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 caOutputDir - logInfo $ "This report set will be put into: " <> fromString reportDir + liftIO $ createDirectoryIfMissing True reportDir + pure reportDir + maybe createDir pure =<< views wcCommonArgs caOutputDir + let writeOutput coName res = do + reportDir <- getOutputDir + let prePath = reportDir T.unpack coName + logInfo $ "This output will be written into: " <> fromString reportDir + writeReport prePath res cliOuts <- views wcCommonArgs caOutputs outputsToProcess <- bool (mapM resolveOutput cliOuts) (pure confOutputs) (null cliOuts) + 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 + let timeline = processTimeline confTimelineParams resolved + logDebug $ "Generating timeline report " <> coName <> "..." + writeOutput coName timeline SummaryOutput params -> do summary <- genSummaryOutput params - writeReport prePath summary + writeOutput coName summary + ScriptOutput params -> + processScriptOutput params BlockOutput {..} -> do resolved <- resolveReport boReport let res = genBlockOutput boParams resolved - writeReport prePath res + writeOutput coName res + whenM (views wcCommonArgs caXdgOpen) $ do + reportDir <- getOutputDir logInfo "Opening reports using xdg-open..." void $ shell ("for i in $(ls "<>T.pack reportDir<>"/*); do xdg-open $i; done") empty logInfo "Done" diff --git a/src/OrgStat/Outputs.hs b/src/OrgStat/Outputs.hs --- a/src/OrgStat/Outputs.hs +++ b/src/OrgStat/Outputs.hs @@ -6,6 +6,7 @@ import OrgStat.Outputs.Block as Exports import OrgStat.Outputs.Class as Exports +import OrgStat.Outputs.Script 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/Script.hs b/src/OrgStat/Outputs/Script.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/Outputs/Script.hs @@ -0,0 +1,49 @@ +-- | Script output type. We launch the executable asked after +-- injecting the environment variables related to the report. + +module OrgStat.Outputs.Script + ( processScriptOutput + ) where + +import Universum + +import Control.Lens (views) +import qualified Data.Map.Strict as M +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.Process (callCommand) + +import OrgStat.Ast (filterHasClock, orgTotalDuration) +import OrgStat.Config (confReports, crName) +import OrgStat.Helpers (resolveReport) +import OrgStat.Outputs.Types (ScriptParams (..)) +import OrgStat.Util (timeF) +import OrgStat.WorkMonad (WorkM, wcConfig) + +-- | Processes script output. +processScriptOutput :: ScriptParams -> WorkM () +processScriptOutput ScriptParams{..} = do + -- Considering all the reports if none are specified. + reportsToConsider <- case spReports of + [] -> views wcConfig (map crName . confReports) + xs -> pure xs + allReports <- mapM (\r -> (r,) <$> resolveReport r) reportsToConsider + + -- Set env variables + prevVars <- forM allReports $ \(toString -> reportName,org) -> do + let duration = timeF $ orgTotalDuration $ filterHasClock org + (prevVar :: Maybe String) <- liftIO $ lookupEnv reportName + liftIO $ setEnv reportName (toString duration) + pure $ (reportName,) <$> prevVar + let prevVarsMap :: Map String String + prevVarsMap = M.fromList $ catMaybes prevVars + + -- Execute script + let cmdArgument = either id (\t -> "-c \"" <> toString t <> "\"") spScript + liftIO $ callCommand $ + "sh " <> cmdArgument + + -- Restore the old variables, clean new. + forM_ (map fst allReports) $ \(toString -> reportName) -> do + liftIO $ case M.lookup reportName prevVarsMap of + Nothing -> unsetEnv reportName + Just prevValue -> setEnv reportName prevValue diff --git a/src/OrgStat/Outputs/Types.hs b/src/OrgStat/Outputs/Types.hs --- a/src/OrgStat/Outputs/Types.hs +++ b/src/OrgStat/Outputs/Types.hs @@ -15,6 +15,8 @@ , SummaryParams (..) , SummaryOutput (..) + , ScriptParams (..) + , BlockParams (..) , bpMaxLength , bpUnicode @@ -48,33 +50,9 @@ -- ^ 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 Semigroup TimelineParams where - (<>) = mergeParams - ---instance Monoid TimelineParams where --- mempty = def - -- | SVG timeline image. newtype TimelineOutput = TimelineOutput (D.Diagram B) @@ -92,14 +70,27 @@ newtype SummaryOutput = SummaryOutput Text ---------------------------------------------------------------------------- +-- Script +---------------------------------------------------------------------------- + +-- | Parameters of the summary output +data ScriptParams = ScriptParams + { spScript :: !(Either FilePath Text) + -- ^ Either path to the script to execute, or a script text itself. + , spReports :: ![Text] + -- ^ Reports to consider. + } deriving Show + +---------------------------------------------------------------------------- -- Block ---------------------------------------------------------------------------- -- | Parameters for block output. Stub (for now). data BlockParams = BlockParams - { _bpMaxLength :: Int + { _bpMaxLength :: !Int -- ^ Maximum title length (together with indentation). - , _bpUnicode :: Bool + , _bpUnicode :: !Bool + -- ^ Should unicode symbols be used for box borders. } deriving (Show) makeLenses ''BlockParams diff --git a/src/OrgStat/Parser.hs b/src/OrgStat/Parser.hs --- a/src/OrgStat/Parser.hs +++ b/src/OrgStat/Parser.hs @@ -10,13 +10,14 @@ import Control.Exception (Exception) import qualified Data.Attoparsec.Text as A +import Data.Char (isSpace) 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, getZonedTime, zonedTimeToLocalTime) import Data.Time.Calendar () -import OrgStat.Ast (Clock (..), Org (..)) +import OrgStat.Ast (Clock (..), Org (..), orgTags, traverseTree) ---------------------------------------------------------------------------- -- Exceptions @@ -36,12 +37,15 @@ parseOrg curTime todoKeywords = convertDocument <$> O.parseDocument todoKeywords where convertDocument :: O.Document -> Org - convertDocument (O.Document _ headings) = Org - { _orgTitle = "" - , _orgTags = [] - , _orgClocks = [] - , _orgSubtrees = map convertHeading headings - } + convertDocument (O.Document textBefore headings) = + let fileLvlTags = extractFileTags textBefore + addTags t = ordNub $ fileLvlTags <> t + o = Org { _orgTitle = "" + , _orgTags = [] + , _orgClocks = [] + , _orgSubtrees = map convertHeading headings + } + in o & traverseTree . orgTags %~ addTags convertHeading :: O.Headline -> Org convertHeading headline = Org @@ -85,6 +89,18 @@ (fromGregorian (toInteger year) month day) (TimeOfDay hour minute 0) convertDateTime _ = Nothing + + extractFileTags (T.lines -> inputLines) = + let prfx = "#+FILETAGS: " + matching = + map (T.drop (length prfx)) $ + (filter (prfx `T.isPrefixOf`) inputLines) + toTags (T.strip -> line) = + let parts = filter (not . T.null) $ T.splitOn ":" line + -- Correct tag shouldn't contain spaces inside + correctPart p = not $ T.any isSpace p + in if all correctPart parts then parts else [] + in ordNub $ concatMap toTags matching -- Throw parsing exception if it can't be parsed (use Control.Monad.Catch#throwM) runParser :: (MonadIO m, MonadThrow m) => [Text] -> Text -> m Org diff --git a/src/OrgStat/Scope.hs b/src/OrgStat/Scope.hs --- a/src/OrgStat/Scope.hs +++ b/src/OrgStat/Scope.hs @@ -60,9 +60,9 @@ data ScopeModifier = ModPruneSubtree AstPath Int -- ^ 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 are inherited). + | ModFilterTags [Text] + -- ^ Given text tag names, it leaves only those subtrees that + -- have one of these 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,8 +96,8 @@ pure $ fromMaybe (error "applyModifier@ModSelectSubtree is broken") $ org ^. atPath path -applyModifier (ModFilterTag tag) o0 = do - let matchesTag o = any (== tag) (o ^. orgTags) +applyModifier (ModFilterTags tags) o0 = do + let matchesTag o = any (`elem` tags) (o ^. orgTags) let dfs :: Org -> Maybe Org dfs o | matchesTag o = Just o | otherwise = case mapMaybe dfs (o ^. orgSubtrees) of