{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use maybe" #-} {-| Several utility functions (e.g for parsing & serializing UTC stamps) -} module Utils where import Protolude ( Alternative ((<|>)), Applicative (pure), Char, Double, Eq, Fractional (fromRational, (/)), Functor (fmap), IO, Int, Integer, Integral (div, mod), Maybe (..), Num ((*), (+)), Ord ((<), (>)), Rational, Real (toRational), RealFrac (properFraction, truncate), Semigroup ((<>)), Show, Word16, flip, fromIntegral, fromMaybe, fst, mempty, otherwise, readMaybe, realToFrac, show, stderr, ($), (&), (.), (<&>), (==), ) import Protolude qualified as P import Base32 (decode) import Control.Arrow ((>>>)) import Control.Monad.Catch (catchAll) import Data.Colour.RGBSpace (RGB (..)) import Data.Hourglass ( DateTime, Elapsed (Elapsed), ElapsedP (..), ISO8601_DateAndTime (ISO8601_DateAndTime), NanoSeconds (NanoSeconds), Seconds (Seconds), Time (timeFromElapsedP), TimeFormat (toFormat), TimeFormatString, Timeable (timeGetElapsedP), timeGetDateTimeOfDay, timeParse, timePrint, ) import Data.Text (Text, unpack) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Time (UTCTime, ZonedTime, addUTCTime, zonedTimeToUTC) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.ULID (ULID (ULID, random, timeStamp)) import Data.ULID.Random (ULIDRandom, mkULIDRandom) import Data.ULID.TimeStamp (ULIDTimeStamp, mkULIDTimeStamp) import Prettyprinter (Doc, hardline, softline) import Prettyprinter.Internal.Type (Doc (Empty)) import Prettyprinter.Render.Terminal ( AnsiStyle, Color (Black), bgColorDull, color, colorDull, ) import System.Console.ANSI (ConsoleLayer (..), hGetLayerColor) import System.Random (mkStdGen) import Config (Config (..)) type IdText = Text type TagText = Text data Filter a = NoFilter | Only a deriving (Eq, Ord, Show) data ListModifiedFlag = AllItems | ModifiedItemsOnly deriving (Eq, Show) -- | Always add a hardline after non-empty documents () :: Doc ann -> Doc ann -> Doc ann Empty y = y x y = x <> hardline <> y -- | Combine documents with 2 newlines (<++>) :: Doc ann -> Doc ann -> Doc ann x <++> y = x <> softline <> softline <> y -- | Combine documents with 2 newlines if both documents are non-empty (<$$>) :: Doc ann -> Doc ann -> Doc ann Empty <$$> y = y x <$$> Empty = x x <$$> y = x <++> y infixr 6 <$$> vsepCollapse :: [Doc ann] -> Doc ann vsepCollapse = P.foldr (<$$>) Empty zeroTime :: DateTime zeroTime = timeFromElapsedP 0 emptyUlid :: ULID emptyUlid = ULID { timeStamp = mkULIDTimeStamp 0 , random = mkULIDRandom (mkStdGen 0) & P.fst } -- | ULID time section if timestamp == 1970-01-01 00:00:00.000 zeroUlidTxt :: Text zeroUlidTxt = "0000000000" utcFormatReadable :: TimeFormatString utcFormatReadable = toFormat ("YYYY-MM-DD H:MI:S" :: [Char]) parseUtcNum :: Int -> Maybe DateTime parseUtcNum number = parseUtc (show number) parseUtc :: Text -> Maybe DateTime parseUtc utcText = let utcString = unpack $ T.toLower utcText -- TODO: Remove after https://github.com/vincenthz/hs-hourglass/issues/50 addSpaceAfter10 = T.intercalate " " . T.chunksOf 10 addSpaceAfter13 = T.intercalate " " . T.chunksOf 13 unixMicro = "EPOCH ms us" :: [Char] unixMilli = "EPOCH ms" :: [Char] tParse :: [Char] -> Maybe DateTime tParse formatString = timeParse (toFormat formatString) utcString in -- From long (specific) to short (unspecific) timeParse ISO8601_DateAndTime utcString -- <|> tParse "YYYY-MM-DDtH:MI:S.ns" <|> tParse "YYYY-MM-DDtH:MI:S.msusns" <|> tParse "YYYY-MM-DDtH:MI:S.msus" <|> tParse "YYYY-MM-DDtH:MI:S.ms" <|> tParse "YYYY-MM-DDtH:MI:S" <|> tParse "YYYY-MM-DDtH:MI" <|> tParse "YYYYMMDDtHMIS" <|> tParse "YYYY-MM-DD H:MI:S" <|> tParse "YYYY-MM-DD H:MI" <|> tParse "YYYY-MM-DD" <|> timeParse (toFormat unixMicro) (unpack $ (addSpaceAfter10 . addSpaceAfter13) utcText) <|> timeParse (toFormat unixMilli) (unpack $ addSpaceAfter10 utcText) <|> tParse "EPOCH" parseUlidUtcSection :: Text -> Maybe DateTime parseUlidUtcSection encodedUtc = do let decodedUtcMaybe = Base32.decode encodedUtc getElapsed val = Elapsed $ Seconds $ val `div` 1000 elapsed <- fmap getElapsed decodedUtcMaybe milliSecPart <- fmap (`mod` 1000) decodedUtcMaybe let nanoSeconds = NanoSeconds $ milliSecPart * 1000000 pure $ timeGetDateTimeOfDay $ ElapsedP elapsed nanoSeconds ulidTextToDateTime :: Text -> Maybe DateTime ulidTextToDateTime = T.take 10 >>> parseUlidUtcSection {-| `ulidText2utc` converts a ULID to a UTC timestamp >>> ulidText2utc "01hq68smfe0r9entg3x4rb9441" Just "2024-02-21 16:43:17.358" -} ulidText2utc :: Text -> Maybe Text ulidText2utc ulid = ulid & ulidTextToDateTime <&> (timePrint (toFormat ("YYYY-MM-DD H:MI:S.ms" :: [Char])) >>> T.pack) parseUlidText :: Text -> Maybe ULID parseUlidText ulidText = do let mkUlidTimeMaybe text = text & ulidTextToDateTime <&> toUlidTime mkUlidRandomMaybe :: Text -> Maybe ULIDRandom mkUlidRandomMaybe = readMaybe . T.unpack . T.drop 10 ulidTime <- mkUlidTimeMaybe ulidText ulidRandom <- mkUlidRandomMaybe ulidText pure $ ULID ulidTime ulidRandom -- TODO: Remove after https://github.com/vincenthz/hs-hourglass/issues/52 rationalToElapsedP :: Rational -> ElapsedP rationalToElapsedP secondsFrac = let (sec, nanoSec) = properFraction secondsFrac in ElapsedP (Elapsed (Seconds sec)) (NanoSeconds $ truncate $ nanoSec * 1e9) -- TODO: Remove after https://github.com/vincenthz/hs-hourglass/issues/45 elapsedPToRational :: ElapsedP -> Rational elapsedPToRational (ElapsedP (Elapsed (Seconds s)) (NanoSeconds ns)) = ((1e9 * fromIntegral s) + fromIntegral ns) / 1e9 formatElapsedP :: Config -> IO ElapsedP -> IO Text formatElapsedP conf = fmap (timePrint conf.utcFormat >>> T.pack) toUlidTime :: DateTime -> ULIDTimeStamp toUlidTime = timeGetElapsedP >>> elapsedPToRational >>> realToFrac >>> mkULIDTimeStamp setDateTime :: ULID -> DateTime -> ULID setDateTime ulid dateTime = ULID (toUlidTime dateTime) (random ulid) {-| Currently not needed addStartUtc :: DateTime -> Iso8601.Interval -> Iso8601.Interval addStartUtc utc interval = case interval of Iso8601.Interval (Iso8601.JustDuration duration) -> Iso8601.Interval (Iso8601.StartDuration (dateTimeToUtcTime utc) duration) _ -> interval -} zonedTimeToDateTime :: ZonedTime -> DateTime zonedTimeToDateTime zTime = zTime & zonedTimeToUTC & utcTimeToPOSIXSeconds & toRational & rationalToElapsedP & timeFromElapsedP utcTimeToDateTime :: UTCTime -> DateTime utcTimeToDateTime utcTime = utcTime & utcTimeToPOSIXSeconds & toRational & rationalToElapsedP & timeFromElapsedP dateTimeToUtcTime :: DateTime -> UTCTime dateTimeToUtcTime dateTime = dateTime & timeGetElapsedP & elapsedPToRational & fromRational & flip addUTCTime (posixSecondsToUTCTime 0) -- From https://mail.haskell.org/pipermail/haskell-cafe/2009-August/065854.html numDigits :: Integer -> Integer -> Integer numDigits base num = let ilog b n | n < b = (0, n) | otherwise = let (e, r) = ilog (b * b) n in if r < b then (2 * e, r) else (2 * e + 1, r `div` b) in 1 + fst (ilog base num) colr :: Config -> Color -> AnsiStyle colr conf newColor = if conf.noColor then mempty else color newColor colrDull :: Config -> Color -> AnsiStyle colrDull conf newColor = if conf.noColor then mempty else colorDull newColor bgColrDull :: Config -> Color -> AnsiStyle bgColrDull conf newColor = if conf.noColor then mempty else bgColorDull newColor removeColorsIfNecessary :: Config -> IO Config removeColorsIfNecessary conf = do if conf.noColor then pure conf { idStyle = mempty , priorityStyle = mempty , dateStyle = mempty , bodyStyle = mempty , bodyClosedStyle = mempty , closedStyle = mempty , dueStyle = mempty , overdueStyle = mempty , tagStyle = mempty } else pure conf applyColorMode :: Config -> IO Config applyColorMode conf = do layerColorBgMb <- catchAll (hGetLayerColor stderr Background) (\_ -> pure Nothing) let calcLuminance :: RGB Word16 -> Double calcLuminance (RGB{..}) = ( 0.3 * fromIntegral channelRed + 0.6 * fromIntegral channelGreen + 0.1 * fromIntegral channelBlue ) / 65536 isLightMode = layerColorBgMb <&> calcLuminance & fromMaybe 0 -- Default to dark mode & (> 0.5) pure $ if isLightMode then conf{bodyStyle = colrDull conf Black} else conf countCharTL :: Char -> TL.Text -> P.Int64 countCharTL char = TL.filter (== char) >>> TL.length countChar :: Char -> Text -> P.Int countChar char = T.filter (== char) >>> T.length