-- | Effect for AppleScript.
module Shrun.Notify.MonadAppleScript
  ( MonadAppleScript (..),
    notifyAppleScript,
  )
where

import Data.Text qualified as T
import Effects.Process.Typed qualified as P
import Shrun.Notify.MonadNotify
  ( NotifyException (MkNotifyException),
    ShrunNote,
    exitFailureToStderr,
  )
import Shrun.Notify.Types (NotifySystemP (AppleScript))
import Shrun.Prelude

-- | Effect for apple script.
class (Monad m) => MonadAppleScript m where
  -- | Sends a notification via apple script.
  notify :: (HasCallStack) => Text -> m (Maybe ByteString)

instance MonadAppleScript IO where
  notify :: HasCallStack => Text -> IO (Maybe ByteString)
notify =
    ((ExitCode, ByteString) -> Maybe ByteString)
-> IO (ExitCode, ByteString) -> IO (Maybe ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (ExitCode, ByteString) -> Maybe ByteString
exitFailureToStderr
      (IO (ExitCode, ByteString) -> IO (Maybe ByteString))
-> (Text -> IO (ExitCode, ByteString))
-> Text
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessConfig () () () -> IO (ExitCode, ByteString)
forall stdin stdout stderrIgnored.
HasCallStack =>
ProcessConfig stdin stdout stderrIgnored
-> IO (ExitCode, ByteString)
forall (m :: Type -> Type) stdin stdout stderrIgnored.
(MonadTypedProcess m, HasCallStack) =>
ProcessConfig stdin stdout stderrIgnored
-> m (ExitCode, ByteString)
P.readProcessStderr
      (ProcessConfig () () () -> IO (ExitCode, ByteString))
-> (Text -> ProcessConfig () () ())
-> Text
-> IO (ExitCode, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProcessConfig () () ()
P.shell
      (String -> ProcessConfig () () ())
-> (Text -> String) -> Text -> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance (MonadAppleScript m) => MonadAppleScript (ReaderT env m) where
  notify :: HasCallStack => Text -> ReaderT env m (Maybe ByteString)
notify = m (Maybe ByteString) -> ReaderT env m (Maybe ByteString)
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT env m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe ByteString) -> ReaderT env m (Maybe ByteString))
-> (Text -> m (Maybe ByteString))
-> Text
-> ReaderT env m (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m (Maybe ByteString)
forall (m :: Type -> Type).
(MonadAppleScript m, HasCallStack) =>
Text -> m (Maybe ByteString)
notify

notifyAppleScript ::
  ( HasCallStack,
    MonadAppleScript m
  ) =>
  ShrunNote ->
  m (Maybe NotifyException)
notifyAppleScript :: forall (m :: Type -> Type).
(HasCallStack, MonadAppleScript m) =>
ShrunNote -> m (Maybe NotifyException)
notifyAppleScript ShrunNote
note =
  Text -> m (Maybe ByteString)
forall (m :: Type -> Type).
(MonadAppleScript m, HasCallStack) =>
Text -> m (Maybe ByteString)
notify (ShrunNote -> Text
shrunToAppleScript ShrunNote
note) m (Maybe ByteString)
-> (ByteString -> NotifyException) -> m (Maybe NotifyException)
forall (f :: Type -> Type) (g :: Type -> Type) a b.
(Functor f, Functor g) =>
f (g a) -> (a -> b) -> f (g b)
<<&>> \ByteString
stderr ->
    ShrunNote -> NotifySystemMerged -> Text -> NotifyException
MkNotifyException ShrunNote
note NotifySystemMerged
forall (p :: ConfigPhase). NotifySystemP p
AppleScript (ByteString -> Text
decodeUtf8Lenient ByteString
stderr)

shrunToAppleScript :: ShrunNote -> Text
shrunToAppleScript :: ShrunNote -> Text
shrunToAppleScript ShrunNote
shrunNote = Text
txt
  where
    txt :: Text
txt =
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"osascript -e 'display notification ",
          Text -> Text
withDoubleQuotes (ShrunNote
shrunNote ShrunNote -> Optic' A_Getter NoIx ShrunNote Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx ShrunNote ShrunNote UnlinedText UnlinedText
#body Optic A_Lens NoIx ShrunNote ShrunNote UnlinedText UnlinedText
-> Optic A_Getter NoIx UnlinedText UnlinedText Text Text
-> Optic' A_Getter NoIx ShrunNote Text
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Getter NoIx UnlinedText UnlinedText Text Text
#unUnlinedText),
          Text
" with title \"Shrun\" ",
          Text
" subtitle ",
          Text -> Text
withDoubleQuotes (ShrunNote
shrunNote ShrunNote -> Optic' A_Getter NoIx ShrunNote Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx ShrunNote ShrunNote UnlinedText UnlinedText
#summary Optic A_Lens NoIx ShrunNote ShrunNote UnlinedText UnlinedText
-> Optic A_Getter NoIx UnlinedText UnlinedText Text Text
-> Optic' A_Getter NoIx ShrunNote Text
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Getter NoIx UnlinedText UnlinedText Text Text
#unUnlinedText),
          Text
"'"
        ]

withDoubleQuotes :: Text -> Text
withDoubleQuotes :: Text -> Text
withDoubleQuotes Text
s = Text
" \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" "