diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StrictData #-} module Main where import Control.Concurrent @@ -18,6 +19,8 @@ import System.Posix.Files import System.Process +import ShowTDiff + pollPeriod = 5000 sleepThreshold = 1800000 @@ -48,7 +51,7 @@ case getOpt Permute options argv of (o,[],[] ) -> do home <- getAppUserDataDirectory "posplyu" - return $ foldl (flip id) (defaultOptions { optDatabaseFile = home ++ "/database" }) o + return $ foldl' (flip id) (defaultOptions { optDatabaseFile = home ++ "/database" }) o (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) where header = "Usage: posplyu" @@ -70,8 +73,13 @@ when (optExpect opts) $ do db <- readDB $ optDatabaseFile opts let sleepOffset = 60 * 60 * 15 - time <- utcToLocalZonedTime $ addUTCTime sleepOffset $ last $ head $ filter (not . isNap) $ reverse db - putStrLn $ "Sleepiness expected at " ++ (show time) + let expectedTime = addUTCTime sleepOffset $ last $ head $ filter (not . isNap) $ reverse db + expectedLocalTime <- utcToLocalZonedTime expectedTime + currentTime <- getCurrentTime + let relTimeS = if expectedTime > currentTime + then "in " ++ showTDiff (diffUTCTime expectedTime currentTime) + else showTDiff (diffUTCTime currentTime expectedTime) ++ " ago" + putStrLn $ "Sleepiness expected at " ++ show expectedLocalTime ++ " (" ++ relTimeS ++ ")" when (not $ or [0 < optEdit opts, optExpect opts, optList opts]) $ do let dirname = intercalate "/" $ init $ split (dropDelims $ whenElt (== '/')) $ optDatabaseFile opts createDirectoryIfMissing True dirname diff --git a/ShowTDiff.hs b/ShowTDiff.hs new file mode 100644 --- /dev/null +++ b/ShowTDiff.hs @@ -0,0 +1,66 @@ +{- +SBV: SMT Based Verification in Haskell + +Copyright (c) 2010-2025, Levent Erkok (erkokl@gmail.com) +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the developer (Levent Erkok) nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL LEVENT ERKOK BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +module ShowTDiff where + +import Data.List (intercalate) +import Data.Ratio +import Data.Time.Clock +import GHC.Real (Ratio((:%))) +import Numeric (showFFloat) + +-- | Show 'NominalDiffTime' in human readable form. 'NominalDiffTime' is +-- essentially picoseconds (10^-12 seconds). We show it so that +-- it's represented at the day:hour:minute:second.XXX granularity. +showTDiff :: NominalDiffTime -> String +showTDiff diff + | denom /= 1 -- Should never happen! But just in case. + = show diff + | True + = intercalate ":" fields + where total, denom :: Integer + total :% denom = (picoFactor % 1) * toRational diff + + -- there are 10^12 pico-seconds in a second + picoFactor :: Integer + picoFactor = (10 :: Integer) ^ (12 :: Integer) + + (s2p, m2s, h2m, d2h) = case drop 1 $ scanl (*) 1 [picoFactor, 60, 60, 24] of + (s2pv : m2sv : h2mv : d2hv : _) -> (s2pv, m2sv, h2mv, d2hv) + _ -> (0, 0, 0, 0) -- won't ever happen + + (days, days') = total `divMod` d2h + (hours, hours') = days' `divMod` h2m + (minutes, seconds') = hours' `divMod` m2s + (seconds, picos) = seconds' `divMod` s2p + secondsPicos = show seconds + ++ dropWhile (/= '.') (showFFloat (Just 3) (fromIntegral picos * (10**(-12) :: Double)) "s") + + aboveSeconds = map (\(t, v) -> show v ++ [t]) $ dropWhile (\p -> snd p == 0) [('d', days), ('h', hours), ('m', minutes)] + fields = aboveSeconds ++ [secondsPicos] diff --git a/posplyu.cabal b/posplyu.cabal --- a/posplyu.cabal +++ b/posplyu.cabal @@ -1,6 +1,6 @@ name: posplyu -- semver -version: 0.1.0.3 +version: 0.1.1 synopsis: Sleep tracker for X11, using XScreenSaver extension and manual input. description: posplyu is a sleep tracker for X11, using XScreenSaver extension and manual input, motivated by http://super-memory.com/articles/sleep.htm and designed to facilitate transitioning to the free running sleep regiment while living mostly with a GNU/Linux system handy. The tool allows you to measure and somewhat predict your sleeping cycle. For now it assumes a 24h cycle with one sleep period. category: Tools @@ -18,17 +18,17 @@ Source-repository this type: git location: https://github.com/l29ah/posplyu.git - tag: 0.1.0.3 + tag: 0.1.1 executable posplyu main-is: Main.hs - -- other-modules: + other-modules: ShowTDiff -- other-extensions: build-depends: base >= 4.11 && < 5, X11 >= 1.9 && < 1.11, transformers >= 0.5.5.0 && < 0.7, - time >= 1.8.0.2 && < 1.13, + time >= 1.8.0.2 && < 1.15, split >= 0.2.3.3 && < 0.3, unix >= 2.7.2.2 && < 2.9, process >= 1.6.3.0 && < 1.7, @@ -36,4 +36,4 @@ directory >= 1.3.1.5 && < 1.4 -- hs-source-dirs: default-language: Haskell2010 - ghc-options: -fno-warn-tabs + ghc-options: -fno-warn-tabs -fwrite-ide-info -hiedir=.hie