{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Provides type for notifications.
module Shrun.Notify.Types
  ( -- * Notify system
    NotifySystemP (..),
    NotifySystemArgs,
    NotifySystemToml,
    NotifySystemMerged,
    NotifySystemEnv,
    parseNotifySystem,
    notifySystemStr,
    showNotifySystem,
    displayNotifySystem,
    DBusF,
    mergeNotifySystem,

    -- * Notify actions
    NotifyAction (..),
    parseNotifyAction,
    notifyActionStr,

    -- * Notify timeout
    NotifyTimeout (..),
    parseNotifyTimeout,
    notifyTimeoutStr,

    -- * Exceptions
    OsxNotifySystemMismatch (..),
    LinuxNotifySystemMismatch (..),
  )
where

import DBus.Client (Client)
import Data.Bits (toIntegralSized)
import Data.String (IsString)
import Data.Text qualified as T
import Data.Word (Word16)
import GHC.Num (Num (fromInteger))
import Shrun.Configuration.Data.ConfigPhase
  ( ConfigPhase
      ( ConfigPhaseArgs,
        ConfigPhaseEnv,
        ConfigPhaseMerged,
        ConfigPhaseToml
      ),
  )
import Shrun.Configuration.Data.WithDisabled
  ( WithDisabled (Disabled, With, Without),
  )
import Shrun.Configuration.Default (Default (def))
import Shrun.Prelude
import Shrun.Utils qualified as U
import TOML (Value (Integer, String))

-- | Determines for which actions we should send notifications.
data NotifyAction
  = -- | Send a notification after all commands are completed.
    NotifyFinal
  | -- | Send notifications when each command completes.
    NotifyCommand
  | -- | NotifyFinal and NotifyCommand.
    NotifyAll
  deriving stock (NotifyAction -> NotifyAction -> Bool
(NotifyAction -> NotifyAction -> Bool)
-> (NotifyAction -> NotifyAction -> Bool) -> Eq NotifyAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotifyAction -> NotifyAction -> Bool
== :: NotifyAction -> NotifyAction -> Bool
$c/= :: NotifyAction -> NotifyAction -> Bool
/= :: NotifyAction -> NotifyAction -> Bool
Eq, Int -> NotifyAction -> ShowS
[NotifyAction] -> ShowS
NotifyAction -> String
(Int -> NotifyAction -> ShowS)
-> (NotifyAction -> String)
-> ([NotifyAction] -> ShowS)
-> Show NotifyAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotifyAction -> ShowS
showsPrec :: Int -> NotifyAction -> ShowS
$cshow :: NotifyAction -> String
show :: NotifyAction -> String
$cshowList :: [NotifyAction] -> ShowS
showList :: [NotifyAction] -> ShowS
Show)

instance DecodeTOML NotifyAction where
  tomlDecoder :: Decoder NotifyAction
tomlDecoder = Decoder Text -> Decoder NotifyAction
forall (m :: Type -> Type). MonadFail m => m Text -> m NotifyAction
parseNotifyAction Decoder Text
forall a. DecodeTOML a => Decoder a
tomlDecoder

-- | Parses 'NotifyAction'.
parseNotifyAction :: (MonadFail m) => m Text -> m NotifyAction
parseNotifyAction :: forall (m :: Type -> Type). MonadFail m => m Text -> m NotifyAction
parseNotifyAction m Text
getTxt =
  m Text
getTxt m Text -> (Text -> m NotifyAction) -> m NotifyAction
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Text
"final" -> NotifyAction -> m NotifyAction
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NotifyAction
NotifyFinal
    Text
"command" -> NotifyAction -> m NotifyAction
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NotifyAction
NotifyCommand
    Text
"all" -> NotifyAction -> m NotifyAction
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NotifyAction
NotifyAll
    Text
other ->
      String -> m NotifyAction
forall a. String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail
        (String -> m NotifyAction) -> String -> m NotifyAction
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
          [ String
"Unrecognized notify action: '",
            Text -> String
T.unpack Text
other,
            String
"'. Expected one of ",
            String
forall a. IsString a => a
notifyActionStr
          ]

-- | Available 'NotifyAction' strings.
notifyActionStr :: (IsString a) => a
notifyActionStr :: forall a. IsString a => a
notifyActionStr = a
"(final |command | all)"

-- | Maps DBus to its phased param.
type DBusF :: ConfigPhase -> Type
type family DBusF p where
  DBusF ConfigPhaseArgs = ()
  DBusF ConfigPhaseToml = ()
  DBusF ConfigPhaseMerged = ()
  DBusF ConfigPhaseEnv = Client

type NotifySystemArgs = NotifySystemP ConfigPhaseArgs

type NotifySystemToml = NotifySystemP ConfigPhaseToml

type NotifySystemMerged = NotifySystemP ConfigPhaseMerged

type NotifySystemEnv = NotifySystemP ConfigPhaseEnv

-- | Notification systems.
type NotifySystemP :: ConfigPhase -> Type
data NotifySystemP p
  = -- | Uses DBus.
    DBus (DBusF p)
  | -- | Uses notify-send.
    NotifySend
  | -- | Uses apple-script.
    AppleScript

deriving stock instance Eq NotifySystemArgs

deriving stock instance Show NotifySystemArgs

deriving stock instance Eq NotifySystemToml

deriving stock instance Show NotifySystemToml

deriving stock instance Eq NotifySystemMerged

deriving stock instance Show NotifySystemMerged

-- | "Merges" notify systems.
mergeNotifySystem ::
  WithDisabled NotifySystemArgs ->
  Maybe NotifySystemToml ->
  NotifySystemMerged
mergeNotifySystem :: WithDisabled NotifySystemArgs
-> Maybe NotifySystemToml -> NotifySystemMerged
mergeNotifySystem WithDisabled NotifySystemArgs
mArgs Maybe NotifySystemToml
mToml =
  case WithDisabled NotifySystemArgs
mArgs of
    WithDisabled NotifySystemArgs
Disabled -> NotifySystemMerged
forall a. Default a => a
def
    With (DBus ()) -> DBusF 'ConfigPhaseMerged -> NotifySystemMerged
forall (p :: ConfigPhase). DBusF p -> NotifySystemP p
DBus ()
    With NotifySystemArgs
NotifySend -> NotifySystemMerged
forall (p :: ConfigPhase). NotifySystemP p
NotifySend
    With NotifySystemArgs
AppleScript -> NotifySystemMerged
forall (p :: ConfigPhase). NotifySystemP p
AppleScript
    WithDisabled NotifySystemArgs
Without -> case Maybe NotifySystemToml
mToml of
      Just (DBus ()) -> DBusF 'ConfigPhaseMerged -> NotifySystemMerged
forall (p :: ConfigPhase). DBusF p -> NotifySystemP p
DBus ()
      Just NotifySystemToml
NotifySend -> NotifySystemMerged
forall (p :: ConfigPhase). NotifySystemP p
NotifySend
      Just NotifySystemToml
AppleScript -> NotifySystemMerged
forall (p :: ConfigPhase). NotifySystemP p
AppleScript
      Maybe NotifySystemToml
Nothing -> NotifySystemMerged
forall a. Default a => a
def

showNotifySystem :: (IsString a) => NotifySystemP p -> a
showNotifySystem :: forall a (p :: ConfigPhase). IsString a => NotifySystemP p -> a
showNotifySystem (DBus DBusF p
_) = a
"DBus"
showNotifySystem NotifySystemP p
NotifySend = a
"NotifySend"
showNotifySystem NotifySystemP p
AppleScript = a
"AppleScript"

displayNotifySystem :: (IsString a) => NotifySystemP p -> a
displayNotifySystem :: forall a (p :: ConfigPhase). IsString a => NotifySystemP p -> a
displayNotifySystem (DBus DBusF p
_) = a
"dbus"
displayNotifySystem NotifySystemP p
NotifySend = a
"notify-send"
displayNotifySystem NotifySystemP p
AppleScript = a
"apple-script"

instance DecodeTOML NotifySystemToml where
  tomlDecoder :: Decoder NotifySystemToml
tomlDecoder = Decoder Text -> Decoder NotifySystemToml
forall (p :: ConfigPhase) (m :: Type -> Type).
(DBusF p ~ (), MonadFail m) =>
m Text -> m (NotifySystemP p)
parseNotifySystem Decoder Text
forall a. DecodeTOML a => Decoder a
tomlDecoder

-- | Parses 'NotifySystem'.
parseNotifySystem :: (DBusF p ~ (), MonadFail m) => m Text -> m (NotifySystemP p)
parseNotifySystem :: forall (p :: ConfigPhase) (m :: Type -> Type).
(DBusF p ~ (), MonadFail m) =>
m Text -> m (NotifySystemP p)
parseNotifySystem m Text
getTxt =
  m Text
getTxt m Text -> (Text -> m (NotifySystemP p)) -> m (NotifySystemP p)
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Text
"dbus" -> NotifySystemP p -> m (NotifySystemP p)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NotifySystemP p -> m (NotifySystemP p))
-> NotifySystemP p -> m (NotifySystemP p)
forall a b. (a -> b) -> a -> b
$ DBusF p -> NotifySystemP p
forall (p :: ConfigPhase). DBusF p -> NotifySystemP p
DBus ()
    Text
"notify-send" -> NotifySystemP p -> m (NotifySystemP p)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NotifySystemP p
forall (p :: ConfigPhase). NotifySystemP p
NotifySend
    Text
"apple-script" -> NotifySystemP p -> m (NotifySystemP p)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NotifySystemP p
forall (p :: ConfigPhase). NotifySystemP p
AppleScript
    Text
other ->
      String -> m (NotifySystemP p)
forall a. String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail
        (String -> m (NotifySystemP p)) -> String -> m (NotifySystemP p)
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
          [ String
"Unrecognized notify system: '",
            Text -> String
T.unpack Text
other,
            String
"'. Expected one of ",
            String
forall a. IsString a => a
notifySystemStr
          ]

-- | Available 'NotifySystem' strings.
notifySystemStr :: (IsString a) => a
notifySystemStr :: forall a. IsString a => a
notifySystemStr = a
"(dbus | notify-send | apple-script)"

#if OSX
instance Default (NotifySystemP p) where
  def = AppleScript
#else
instance (DBusF p ~ ()) => Default (NotifySystemP p) where
  def :: NotifySystemP p
def = DBusF p -> NotifySystemP p
forall (p :: ConfigPhase). DBusF p -> NotifySystemP p
DBus ()
#endif

-- | Determines notification timeout.
data NotifyTimeout
  = -- | Times out after the given seconds.
    NotifyTimeoutSeconds Word16
  | -- | Never times out.
    NotifyTimeoutNever
  deriving stock (NotifyTimeout -> NotifyTimeout -> Bool
(NotifyTimeout -> NotifyTimeout -> Bool)
-> (NotifyTimeout -> NotifyTimeout -> Bool) -> Eq NotifyTimeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotifyTimeout -> NotifyTimeout -> Bool
== :: NotifyTimeout -> NotifyTimeout -> Bool
$c/= :: NotifyTimeout -> NotifyTimeout -> Bool
/= :: NotifyTimeout -> NotifyTimeout -> Bool
Eq, Int -> NotifyTimeout -> ShowS
[NotifyTimeout] -> ShowS
NotifyTimeout -> String
(Int -> NotifyTimeout -> ShowS)
-> (NotifyTimeout -> String)
-> ([NotifyTimeout] -> ShowS)
-> Show NotifyTimeout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotifyTimeout -> ShowS
showsPrec :: Int -> NotifyTimeout -> ShowS
$cshow :: NotifyTimeout -> String
show :: NotifyTimeout -> String
$cshowList :: [NotifyTimeout] -> ShowS
showList :: [NotifyTimeout] -> ShowS
Show)

instance Default NotifyTimeout where
  def :: NotifyTimeout
def = Word16 -> NotifyTimeout
NotifyTimeoutSeconds Word16
10

instance FromInteger NotifyTimeout where
  afromInteger :: HasCallStack => Integer -> NotifyTimeout
afromInteger = Word16 -> NotifyTimeout
NotifyTimeoutSeconds (Word16 -> NotifyTimeout)
-> (Integer -> Word16) -> Integer -> NotifyTimeout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word16
forall a. Num a => Integer -> a
fromInteger

-- DecodeTOML instance does not reuse parseNotifyTimeout as we want to
-- enforce the integer type.

instance DecodeTOML NotifyTimeout where
  tomlDecoder :: Decoder NotifyTimeout
tomlDecoder = (Value -> DecodeM NotifyTimeout) -> Decoder NotifyTimeout
forall a. (Value -> DecodeM a) -> Decoder a
makeDecoder ((Value -> DecodeM NotifyTimeout) -> Decoder NotifyTimeout)
-> (Value -> DecodeM NotifyTimeout) -> Decoder NotifyTimeout
forall a b. (a -> b) -> a -> b
$ \case
    String Text
"never" -> NotifyTimeout -> DecodeM NotifyTimeout
forall a. a -> DecodeM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NotifyTimeout
NotifyTimeoutNever
    String Text
bad -> Text -> Value -> DecodeM NotifyTimeout
forall a. Text -> Value -> DecodeM a
invalidValue Text
strErr (Text -> Value
String Text
bad)
    Integer Integer
i -> case Integer -> Maybe Word16
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
toIntegralSized Integer
i of
      Just Word16
i' -> NotifyTimeout -> DecodeM NotifyTimeout
forall a. a -> DecodeM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NotifyTimeout -> DecodeM NotifyTimeout)
-> NotifyTimeout -> DecodeM NotifyTimeout
forall a b. (a -> b) -> a -> b
$ Word16 -> NotifyTimeout
NotifyTimeoutSeconds Word16
i'
      Maybe Word16
Nothing -> Text -> Value -> DecodeM NotifyTimeout
forall a. Text -> Value -> DecodeM a
invalidValue Text
tooLargeErr (Integer -> Value
Integer Integer
i)
    Value
badTy -> Value -> DecodeM NotifyTimeout
forall a. Value -> DecodeM a
typeMismatch Value
badTy
    where
      tooLargeErr :: Text
tooLargeErr = Text
"Timeout integer too large. Max is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
forall a. Show a => a -> Text
showt Word16
maxW16
      strErr :: Text
strErr = Text
"Unexpected timeout. Only valid string is 'never'."
      maxW16 :: Word16
maxW16 = forall a. Bounded a => a
maxBound @Word16

-- | Parses 'NotifyTimeout'.
parseNotifyTimeout :: (MonadFail m) => m Text -> m NotifyTimeout
parseNotifyTimeout :: forall (m :: Type -> Type).
MonadFail m =>
m Text -> m NotifyTimeout
parseNotifyTimeout m Text
getTxt =
  m Text
getTxt m Text -> (Text -> m NotifyTimeout) -> m NotifyTimeout
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Text
"never" -> NotifyTimeout -> m NotifyTimeout
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NotifyTimeout
NotifyTimeoutNever
    Text
other -> Word16 -> NotifyTimeout
NotifyTimeoutSeconds (Word16 -> NotifyTimeout) -> m Word16 -> m NotifyTimeout
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m Word16
forall (m :: Type -> Type) a. (MonadFail m, Read a) => Text -> m a
U.readStripUnderscores Text
other

-- | Available 'NotifyTimeout' strings.
notifyTimeoutStr :: (IsString a) => a
notifyTimeoutStr :: forall a. IsString a => a
notifyTimeoutStr = a
"(never | NATURAL)"

data OsxNotifySystemMismatch
  = OsxNotifySystemMismatchDBus
  | OsxNotifySystemMismatchNotifySend
  deriving stock (OsxNotifySystemMismatch -> OsxNotifySystemMismatch -> Bool
(OsxNotifySystemMismatch -> OsxNotifySystemMismatch -> Bool)
-> (OsxNotifySystemMismatch -> OsxNotifySystemMismatch -> Bool)
-> Eq OsxNotifySystemMismatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OsxNotifySystemMismatch -> OsxNotifySystemMismatch -> Bool
== :: OsxNotifySystemMismatch -> OsxNotifySystemMismatch -> Bool
$c/= :: OsxNotifySystemMismatch -> OsxNotifySystemMismatch -> Bool
/= :: OsxNotifySystemMismatch -> OsxNotifySystemMismatch -> Bool
Eq, Int -> OsxNotifySystemMismatch -> ShowS
[OsxNotifySystemMismatch] -> ShowS
OsxNotifySystemMismatch -> String
(Int -> OsxNotifySystemMismatch -> ShowS)
-> (OsxNotifySystemMismatch -> String)
-> ([OsxNotifySystemMismatch] -> ShowS)
-> Show OsxNotifySystemMismatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OsxNotifySystemMismatch -> ShowS
showsPrec :: Int -> OsxNotifySystemMismatch -> ShowS
$cshow :: OsxNotifySystemMismatch -> String
show :: OsxNotifySystemMismatch -> String
$cshowList :: [OsxNotifySystemMismatch] -> ShowS
showList :: [OsxNotifySystemMismatch] -> ShowS
Show)

instance Exception OsxNotifySystemMismatch where
  displayException :: OsxNotifySystemMismatch -> String
displayException OsxNotifySystemMismatch
OsxNotifySystemMismatchDBus =
    String
"Detected osx, but DBus is only available on linux!"
  displayException OsxNotifySystemMismatch
OsxNotifySystemMismatchNotifySend =
    String
"Detected osx, but NotifySend is only available on linux!"

data LinuxNotifySystemMismatch = LinuxNotifySystemMismatchAppleScript
  deriving stock (LinuxNotifySystemMismatch -> LinuxNotifySystemMismatch -> Bool
(LinuxNotifySystemMismatch -> LinuxNotifySystemMismatch -> Bool)
-> (LinuxNotifySystemMismatch -> LinuxNotifySystemMismatch -> Bool)
-> Eq LinuxNotifySystemMismatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LinuxNotifySystemMismatch -> LinuxNotifySystemMismatch -> Bool
== :: LinuxNotifySystemMismatch -> LinuxNotifySystemMismatch -> Bool
$c/= :: LinuxNotifySystemMismatch -> LinuxNotifySystemMismatch -> Bool
/= :: LinuxNotifySystemMismatch -> LinuxNotifySystemMismatch -> Bool
Eq, Int -> LinuxNotifySystemMismatch -> ShowS
[LinuxNotifySystemMismatch] -> ShowS
LinuxNotifySystemMismatch -> String
(Int -> LinuxNotifySystemMismatch -> ShowS)
-> (LinuxNotifySystemMismatch -> String)
-> ([LinuxNotifySystemMismatch] -> ShowS)
-> Show LinuxNotifySystemMismatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LinuxNotifySystemMismatch -> ShowS
showsPrec :: Int -> LinuxNotifySystemMismatch -> ShowS
$cshow :: LinuxNotifySystemMismatch -> String
show :: LinuxNotifySystemMismatch -> String
$cshowList :: [LinuxNotifySystemMismatch] -> ShowS
showList :: [LinuxNotifySystemMismatch] -> ShowS
Show)

instance Exception LinuxNotifySystemMismatch where
  displayException :: LinuxNotifySystemMismatch -> String
displayException LinuxNotifySystemMismatch
LinuxNotifySystemMismatchAppleScript =
    String
"Detected linux, but AppleScript is only available on osx!"