tasklite-core-0.5.0.0: source/Utils.hs

{-# 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