diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +0.1.5 +========== + +* Support selecting multiple outputs in cli: --select-output can be used several times, + also it's renamed into --output. +* Remove log-warper dependency replacing with simple local logging. +* Update deps: universum-1.4.0, fmt-0.6, orgmode-parse-0.2.2, also update lts to 12.5 + 0.1.4 ===== diff --git a/orgstat.cabal b/orgstat.cabal --- a/orgstat.cabal +++ b/orgstat.cabal @@ -1,5 +1,5 @@ name: orgstat -version: 0.1.4 +version: 0.1.5 synopsis: Statistics visualizer for org-mode license: GPL-3 license-file: LICENSE @@ -16,6 +16,7 @@ , OrgStat.CLI , OrgStat.Helpers , OrgStat.IO + , OrgStat.Logging , OrgStat.Logic , OrgStat.Parser , OrgStat.Scope @@ -30,7 +31,8 @@ , Paths_orgstat build-depends: aeson >= 0.11.2.0 , attoparsec - , base >=4.9 && <4.11 + , ansi-terminal + , base >=4.11 && <4.12 , boxes >= 0.1.4 , bytestring , colour >= 2.3.3 @@ -42,17 +44,17 @@ , exceptions >= 0.8.3 , filepath , formatting + , fmt , hashable >= 1.2.4.0 , lens >= 4.14 , linear - , log-warper >= 1.7.1 , mtl >= 2.2.1 , optparse-simple , orgmode-parse >= 0.2.1 , text >= 1.2.2.1 , time >= 1.6.0.1 , turtle >= 1.2.8 - , universum >= 0.8.0 + , universum >= 1.4.0 , yaml >= 0.8.21.1 hs-source-dirs: src default-language: Haskell2010 @@ -76,13 +78,12 @@ executable orgstat main-is: Main.hs other-modules: Paths_orgstat - build-depends: base >=4.9 && <4.11 + build-depends: base , bytestring , directory , exceptions , filepath , formatting - , log-warper , optparse-simple , orgstat , universum @@ -101,7 +102,7 @@ , GlobalSpec build-depends: HUnit >= 1.3.1.2 , QuickCheck - , base >=4.9 && <4.11 + , base , colour >= 2.3.3 , hspec , orgstat diff --git a/src/OrgStat/CLI.hs b/src/OrgStat/CLI.hs --- a/src/OrgStat/CLI.hs +++ b/src/OrgStat/CLI.hs @@ -12,11 +12,11 @@ -- | Read-only arguments that inner application needs (in contrast to, -- say, logging severity). data CommonArgs = CommonArgs - { xdgOpen :: !Bool + { caXdgOpen :: !Bool -- ^ Open report types using xdg-open - , selectOutput :: !(Maybe Text) + , caOutputs :: ![Text] -- ^ Single output can be selected instead of running all of them. - , outputDir :: !(Maybe FilePath) + , caOutputDir :: !(Maybe FilePath) -- ^ Output directory for all ... outputs. } deriving Show @@ -24,11 +24,12 @@ parseCommonArgs = CommonArgs <$> switch (long "xdg-open" <> help "Open each report using xdg-open") <*> - optional ( + many ( fromString <$> - strOption (long "select-output" <> - help ("Output name you want to process " <> - "(by default all outputs from conf are processed"))) <*> + strOption (long "output" <> + long "select-output" <> + help ("Output name(s) you want to process " <> + "(by default all outputs from conf are selected)"))) <*> optional ( strOption (long "output-dir" <> metavar "FILEPATH" <> diff --git a/src/OrgStat/IO.hs b/src/OrgStat/IO.hs --- a/src/OrgStat/IO.hs +++ b/src/OrgStat/IO.hs @@ -7,19 +7,20 @@ , readConfig ) where -import qualified Base as Base +import qualified Prelude +import Universum + import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.IO as TIO -import Data.Yaml (decodeEither) +import Data.Yaml (decodeEither') import System.Directory (doesFileExist) import System.FilePath (takeBaseName, takeExtension) -import System.Wlog (WithLogger, logDebug) import Turtle (ExitCode (..), procStrict) -import Universum import OrgStat.Ast (Org) import OrgStat.Config (ConfigException (ConfigParseException), OrgStatConfig) +import OrgStat.Logging import OrgStat.Parser (runParser) import OrgStat.Util (dropEnd) @@ -30,7 +31,7 @@ -- ^ Failed to run some external app (gpg) deriving (Typeable) -instance Base.Show OrgIOException where +instance Show OrgIOException where show (OrgIOException r) = "IOException: " <> T.unpack r show (ExternalException r) = "ExternalException: " <> T.unpack r @@ -40,7 +41,7 @@ -- decrypt it first. Returns a pair @(filename, content)@. It also -- takes a list of TODO-keywords to take header names correctly. readOrgFile - :: (MonadIO m, MonadCatch m, WithLogger m) + :: (MonadIO m, MonadCatch m) => [Text] -> FilePath -> m (Text, Org) readOrgFile todoKeywords fp = do logDebug $ "Reading org file " <> fpt @@ -75,6 +76,6 @@ unlessM (liftIO $ doesFileExist fp) $ throwM $ OrgIOException $ "Config file " <> fpt <> " doesn't exist" res <- liftIO $ BS.readFile fp - either (throwM . ConfigParseException . T.pack) pure $ decodeEither res + either (throwM . ConfigParseException . show) pure $ decodeEither' res where fpt = T.pack fp diff --git a/src/OrgStat/Logging.hs b/src/OrgStat/Logging.hs new file mode 100644 --- /dev/null +++ b/src/OrgStat/Logging.hs @@ -0,0 +1,107 @@ +-- | Basic logging, copied from log-warper (it has too many +-- dependencies). +module OrgStat.Logging + ( + Severity (..) + , initLogging + + , logDebug + , logInfo + , logNotice + , logWarning + , logError + + , logMessage + ) where + +import Universum + +import Control.Concurrent.MVar (modifyMVar_, withMVar) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Fmt (fmt, padRightF, (+|), (|+), (|++|)) +import Fmt.Time (dateDashF, hmsF, subsecondF, tzNameF) +import System.Console.ANSI (Color (Blue, Green, Magenta, Red, Yellow), ColorIntensity (Vivid), + ConsoleLayer (Foreground), SGR (Reset, SetColor), setSGRCode) +import System.IO.Unsafe (unsafePerformIO) + + +-- | Severity is level of log message importance. It uniquely +-- determines which messages to print. +data Severity + = Debug -- ^ Debug messages + | Info -- ^ Information + | Notice -- ^ Important (more than average) information + | Warning -- ^ General warnings + | Error -- ^ General errors/severe errors + deriving (Eq, Ord, Show) + +-- | Internal information about logging. +data LogInternalState = LogInternalState + { lisMinSeverity :: Severity + } deriving Show + +-- | Internal logging state. +{-# NOINLINE loggingState #-} +loggingState :: MVar LogInternalState +loggingState = unsafePerformIO $ newMVar $ LogInternalState Debug + +-- | Initialise logging state. +initLogging :: Severity -> IO () +initLogging sev = modifyMVar_ loggingState $ const $ pure $ LogInternalState sev + +-- | Colorizes "Text". +colorizer :: Severity -> Text -> Text +colorizer pr s = + let (before, after) = table pr + in toText before <> s <> toText after + where + -- | Defines pre- and post-printed characters for printing colorized text. + table :: Severity -> (String, String) + table severity = case severity of + Error -> (setColor Red , reset) + Debug -> (setColor Green , reset) + Notice -> (setColor Magenta , reset) + Warning -> (setColor Yellow , reset) + Info -> (setColor Blue , reset) + where + setColor color = setSGRCode [SetColor Foreground Vivid color] + reset = setSGRCode [Reset] + +-- | Formats UTC time in next format: "%Y-%m-%d %H:%M:%S%Q %Z" +-- but %Q part show only in centiseconds (always 2 digits). +centiUtcTimeF :: UTCTime -> Text +centiUtcTimeF t = + dateDashF t |+ " " +| hmsF t |++| centiSecondF t |+ " " +| tzNameF t |+ "" + where + centiSecondF = padRightF 3 '0' . T.take 3 . fmt . subsecondF + +-- | Logs message with specified severity using logger name in context. +logMessage + :: (MonadIO m) + => Severity + -> Text + -> m () +logMessage severity msg = + liftIO $ withMVar loggingState $ \LogInternalState{..} -> do + time <- liftIO $ getCurrentTime + let text = format time + when (severity >= lisMinSeverity) $ putStrLn text + where + format time = mconcat + [ colorizer severity $ "[" <> show severity <> "]" + , " [" + , centiUtcTimeF time + , "] " + , msg + ] + +-- | Shortcuts for 'logMessage' to use according severity. +logDebug, logInfo, logNotice, logWarning, logError + :: MonadIO m + => Text -> m () +logDebug = logMessage Debug +logInfo = logMessage Info +logNotice = logMessage Notice +logWarning = logMessage Warning +logError = logMessage Error diff --git a/src/OrgStat/Logic.hs b/src/OrgStat/Logic.hs --- a/src/OrgStat/Logic.hs +++ b/src/OrgStat/Logic.hs @@ -13,12 +13,12 @@ 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.Logging (logDebug, logInfo) import OrgStat.Outputs (genBlockOutput, genSummaryOutput, processTimeline, tpColorSalt, writeReport) import OrgStat.WorkMonad (WorkM, wcCommonArgs, wcConfig) @@ -35,12 +35,12 @@ formatTime defaultTimeLocale "%F-%H-%M-%S" curTime liftIO $ createDirectoryIfMissing True reportDir pure reportDir - reportDir <- maybe createDir pure =<< views wcCommonArgs outputDir + reportDir <- maybe createDir pure =<< views wcCommonArgs caOutputDir logInfo $ "This report set will be put into: " <> fromString reportDir + cliOuts <- views wcCommonArgs caOutputs outputsToProcess <- - maybe (pure confOutputs) (fmap one . resolveOutput) =<< - views wcCommonArgs selectOutput + bool (mapM resolveOutput cliOuts) (pure confOutputs) (null cliOuts) forM_ outputsToProcess $ \ConfOutput{..} -> do logInfo $ "Processing output " <> coName let prePath = reportDir T.unpack coName @@ -59,7 +59,7 @@ resolved <- resolveReport boReport let res = genBlockOutput boParams resolved writeReport prePath res - whenM (views wcCommonArgs xdgOpen) $ do + whenM (views wcCommonArgs caXdgOpen) $ do 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/Block.hs b/src/OrgStat/Outputs/Block.hs --- a/src/OrgStat/Outputs/Block.hs +++ b/src/OrgStat/Outputs/Block.hs @@ -6,8 +6,8 @@ ) where import Universum -import Unsafe (unsafeLast) +import qualified Data.List as L import qualified Data.Text as T import Text.PrettyPrint.Boxes (center1, hsep, left, render, right, text, vcat) @@ -34,10 +34,10 @@ where BlockFrames{..} = if _bpUnicode then unicodeBlockFrames else asciiBlockFrames text' = text . toString - elems = withDepth (0::Int) o0 - col1 = vcat left $ map (text' . trimTitle . fst) elems - col2 = vcat right $ map (text' . snd) elems - vsep = vcat center1 $ replicate (length elems) (text $ toString bfVertical) + elems' = withDepth (0::Int) o0 + col1 = vcat left $ map (text' . trimTitle . fst) elems' + col2 = vcat right $ map (text' . snd) elems' + vsep = vcat center1 $ replicate (length elems') (text $ toString bfVertical) trimTitle t | T.length t > _bpMaxLength = T.take (_bpMaxLength - 3) t <> "..." | otherwise = t @@ -64,5 +64,5 @@ | otherwise = concat $ map processChild (dropEnd 1 children) ++ - [processLastChild (unsafeLast children)] + [processLastChild (L.last children)] (name,dur) : childrenProcessed 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 @@ -69,9 +69,11 @@ if def ^. l == rhs ^. l then x else x & l .~ (rhs ^. l) -instance Monoid TimelineParams where - mempty = def - mappend = mergeParams +instance Semigroup TimelineParams where + (<>) = mergeParams + +--instance Monoid TimelineParams where +-- mempty = def -- | SVG timeline image. newtype TimelineOutput = TimelineOutput (D.Diagram B) diff --git a/src/OrgStat/Parser.hs b/src/OrgStat/Parser.hs --- a/src/OrgStat/Parser.hs +++ b/src/OrgStat/Parser.hs @@ -13,7 +13,7 @@ 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 (LocalTime (..), TimeOfDay (..), fromGregorian, getZonedTime, zonedTimeToLocalTime) import Data.Time.Calendar () import OrgStat.Ast (Clock (..), Org (..)) @@ -32,8 +32,8 @@ -- Parsing ---------------------------------------------------------------------------- -parseOrg :: [Text] -> A.Parser Org -parseOrg todoKeywords = convertDocument <$> O.parseDocument todoKeywords +parseOrg :: LocalTime -> [Text] -> A.Parser Org +parseOrg curTime todoKeywords = convertDocument <$> O.parseDocument todoKeywords where convertDocument :: O.Document -> Org convertDocument (O.Document _ headings) = Org @@ -70,6 +70,8 @@ convertClock :: O.Clock -> Maybe Clock convertClock (O.Clock (Just (O.Timestamp start _active (Just end)), _duration)) = Clock <$> convertDateTime start <*> convertDateTime end + convertClock (O.Clock (Just (O.Timestamp start _active Nothing), _duration)) = + Clock <$> convertDateTime start <*> pure curTime convertClock _ = Nothing -- Nothing for DateTime without time-of-day @@ -85,8 +87,9 @@ convertDateTime _ = Nothing -- Throw parsing exception if it can't be parsed (use Control.Monad.Catch#throwM) -runParser :: (MonadThrow m) => [Text] -> Text -> m Org -runParser todoKeywords t = - case A.parseOnly (parseOrg todoKeywords) t of +runParser :: (MonadIO m, MonadThrow m) => [Text] -> Text -> m Org +runParser todoKeywords t = do + localTime <- liftIO $ zonedTimeToLocalTime <$> getZonedTime + case A.parseOnly (parseOrg localTime todoKeywords) t of Left err -> throwM $ ParsingException $ T.pack err Right res -> pure res diff --git a/src/OrgStat/Scope.hs b/src/OrgStat/Scope.hs --- a/src/OrgStat/Scope.hs +++ b/src/OrgStat/Scope.hs @@ -13,11 +13,12 @@ , applyModifiers ) where -import qualified Base as Base +import qualified Prelude +import Universum + import Control.Lens (to) import Control.Monad.Except (throwError) import qualified Data.Text as T -import Universum import OrgStat.Ast (Org, atDepth, orgClocks, orgSubtrees, orgTags, orgTitle, traverseTree) @@ -27,7 +28,7 @@ { getAstPath :: [Text] } deriving (Eq, Ord) -instance Base.Show AstPath where +instance Show AstPath where show (AstPath path) | null path = "" | otherwise = intercalate "/" (map T.unpack path) @@ -44,7 +45,7 @@ atPathDo (x:xs) org = let match = find ((== x) . view orgTitle) $ org ^. orgSubtrees modified foo = org & orgSubtrees %~ foo . filter ((/= match) . Just) - fmapFoo Nothing = modified identity + fmapFoo Nothing = modified id fmapFoo (Just o') = modified (o' :) in case (xs,match) of (_,Nothing) -> f Nothing $> org diff --git a/src/OrgStat/Util.hs b/src/OrgStat/Util.hs --- a/src/OrgStat/Util.hs +++ b/src/OrgStat/Util.hs @@ -80,7 +80,7 @@ -- | Maybe setter that does nothing on Nothing. (??~) :: ASetter s s a b -> Maybe b -> s -> s -(??~) _ Nothing = identity +(??~) _ Nothing = id (??~) l (Just k) = l .~ k -- | Time formatter in form HH:MM diff --git a/src/OrgStat/WorkMonad.hs b/src/OrgStat/WorkMonad.hs --- a/src/OrgStat/WorkMonad.hs +++ b/src/OrgStat/WorkMonad.hs @@ -18,7 +18,6 @@ import Control.Lens (makeLenses) import Data.Default (Default (def)) -import qualified System.Wlog as W import OrgStat.Ast (Org) import OrgStat.CLI (CommonArgs) @@ -57,14 +56,9 @@ , MonadIO , MonadReader WorkConfig , MonadState WorkData - , W.CanLog , MonadThrow , MonadCatch ) - -instance W.HasLoggerName WorkM where - askLoggerName = pure $ W.LoggerName "OrgStat" - modifyLoggerName _ = identity runWorkM :: MonadIO m => WorkConfig -> WorkM a -> m a runWorkM config action = diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -11,11 +11,10 @@ import Paths_orgstat (version) import System.Directory (getHomeDirectory) import System.FilePath (()) -import System.Wlog (Severity (..), logDebug, logError, productionB, setupLogging, severityPlus, - termSeveritiesOutB) import OrgStat.CLI (CommonArgs, parseCommonArgs) import OrgStat.IO (readConfig) +import OrgStat.Logging (Severity (..), initLogging, logDebug, logError) import OrgStat.Logic (runOrgStat) import OrgStat.WorkMonad (WorkConfig (..), runWorkM) @@ -53,7 +52,7 @@ main = do args@Args{..} <- getNodeOptions =<< getHomeDirectory let sev = if debug then Debug else Info - setupLogging Nothing $ productionB <> termSeveritiesOutB (severityPlus sev) + initLogging sev config <- readConfig configPath runWorkM (WorkConfig config commonArgs) $ do logDebug $ "Just started with options: " <> show args diff --git a/test/GlobalSpec.hs b/test/GlobalSpec.hs --- a/test/GlobalSpec.hs +++ b/test/GlobalSpec.hs @@ -2,26 +2,23 @@ module GlobalSpec (spec) where -import Control.Lens (to) -import Data.Colour.SRGB (sRGB24show) -import qualified Data.Text as T -import Data.Text.Arbitrary () -import Data.Time (LocalTime (..), TimeOfDay (..), getZonedTime, - zonedTimeToLocalTime) -import Data.Time.Calendar (addGregorianMonthsClip, fromGregorian) -import Test.Hspec (Spec, describe, runIO) -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Arbitrary (arbitrary), Gen, NonNegative (..), - Positive (..), Small (..), choose, forAll, - ioProperty, oneof, (.&&.), (===), (==>)) -import Universum -import Unsafe (unsafeTail) +import Control.Lens (to) +import Data.Colour.SRGB (sRGB24show) +import qualified Data.List as L +import qualified Data.Text as T +import Data.Text.Arbitrary () +import Data.Time (LocalTime (..), TimeOfDay (..), getZonedTime, zonedTimeToLocalTime) +import Data.Time.Calendar (addGregorianMonthsClip, fromGregorian) +import Test.Hspec (Spec, describe, runIO) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary (arbitrary), Gen, NonNegative (..), Positive (..), Small (..), + choose, forAll, ioProperty, oneof, (.&&.), (===), (==>)) +import Universum -import OrgStat.Ast (Clock (..), Org (..), atDepth, mergeClocks, - orgClocks) -import OrgStat.Config (ConfDate (..), ConfRange (..)) -import OrgStat.Helpers (convertRange) -import OrgStat.Util (addLocalTime, parseColour) +import OrgStat.Ast (Clock (..), Org (..), atDepth, mergeClocks, orgClocks) +import OrgStat.Config (ConfDate (..), ConfRange (..)) +import OrgStat.Helpers (convertRange) +import OrgStat.Util (addLocalTime, parseColour) spec :: Spec @@ -71,7 +68,7 @@ contOrg dfrom dto = do (Positive i) <- arbitrary (checkpoints :: [LocalTime]) <- sort <$> replicateM (i+1) arbitrary - pairs <- forM (checkpoints `zip` unsafeTail checkpoints) $ \(c,c') -> do + pairs <- forM (checkpoints `zip` L.tail checkpoints) $ \(c,c') -> do delta <- choose (dfrom,dto) pure (c, negate delta `addLocalTime` c') let clocks = map (uncurry Clock) pairs diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,6 +1,6 @@ -import Spec (spec) -import Test.Hspec (hspec) -import Universum +import Spec (spec) +import Test.Hspec (hspec) +import Universum main :: IO () main = hspec spec