First commit

.gitignore

@@ -0,0 +1,34 @@
+.DS_Store
+.idea
+*.log
+tmp/
+
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.hie
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+cabal.project.local~
+.HTF/
+.ghc.environment.*
+
+result
+result/
+
+.envrc
+.direnv/

CHANGELOG.md

@@ -0,0 +1,6 @@
+# Revision history for swankybar
+
+## 0.1.0.0 -- 2023-07-28
+
+* First version. Released on an unsuspecting world!
+* Supports Adaptive Sync toggling with `swankybar-as`

README.md

@@ -1,2 +1,42 @@
 # swankybar
-Sway + Waybar custom plugin to toggle Adaptive Sync
+
+Sway + Waybar custom plugin to toggle Adaptive Sync from Waybar.
+
+Made this custom plugin because Sway with adaptive sync on causes my monitors to flicker, so I only want to use it when gaming. But I can never remember the magical invocation and `swaymsg --help` is not very helpful.
+
+Static-linked Haskell release binary lovingly built with Nix flakes! See `flake-static.nix`.
+
+## Requirements
+
+- Sway
+- Waybar > v 0.9.5
+- (Optional) DBus notifications through `org.freedesktop.Notifications`
+- A font with the following Glyphs: 󰓦 󱆢 󰓨 󰓧
+
+## Installation
+
+ 1. Download `swankybar-as`
+ 2. `chmod +x swankybar-as`
+ 3. Add this to your Waybar config (usually in `~/.config/waybar/config`)
+
+ ```json
+ "custom/swankybar-as" : {
+   "format": "{}",
+   "format-alt": "{}",
+   "on-click": "PATH/TO/swankybar-as", // UPDATE THIS
+   "on-click-middle": "PATH/TO/swankybar-as toggle --all", // UPDATE THIS
+   "on-click-right": "PATH/TO/swankybar-as toggle", // UPDATE THIS
+   "return-type": "json",
+   "tooltip": true,
+   "exec": "PATH/TO/swankybar-as", // UPDATE THIS
+   "exec-on-event": true,
+   "interval": 60 // Set this to whatever you like
+ }
+ ```
+
+## Installation on NixOS
+
+ 1. Add to an overlay with 
+ ```nix
+ super.haskellPackages.callPackage
+ ```

app/AdaptiveSync.hs

@@ -0,0 +1,156 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module AdaptiveSync where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.ByteString (ByteString)
+import Data.Maybe (fromMaybe)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map.Strict as M
+import Control.Monad.Trans.Maybe
+import Data.Aeson (decode)
+import Data.List (intersperse)
+
+import Outputs
+import SwayIPC
+import DbusHelper
+
+
+data AdaptiveSyncStatus = ASActive
+                        | ASInactive
+                        | ASPartial
+                        | ASError
+                        deriving (Eq, Ord)
+
+instance Show AdaptiveSyncStatus where
+  show ASActive = "Active"
+  show ASInactive = "Inactive"
+  show ASPartial = "Partial"
+  show ASError = "ERROR"
+
+interpretAdaptiveSync :: Text -> Bool
+interpretAdaptiveSync "enabled" = True
+interpretAdaptiveSync _ = False
+
+
+ipcCommandWasSuccessful :: Maybe ByteString -> Bool
+ipcCommandWasSuccessful Nothing = False
+ipcCommandWasSuccessful (Just msg) =
+  case (decode . BL.fromStrict $ msg :: Maybe [M.Map String Bool]) of
+    Nothing -> False
+    Just listMap ->
+      case listMap of
+        [] -> False
+        [x] -> fromMaybe False $ M.lookup "success" x
+        x@(_:_) -> all id $ fromMaybe False . M.lookup "success" <$> x
+
+getOutputs :: MaybeT IO [Output]
+getOutputs = MaybeT ipcGetOutputs >>=
+              MaybeT . return . decode . BL.fromStrict
+
+getFocusedOutputName :: [Output] -> Maybe Text
+getFocusedOutputName outs =
+  case filter o_focused outs of
+    [] -> Nothing
+    [x] -> Just $ o_name x
+    (x:_) -> Nothing
+
+ipcGetFocusedOutputName :: MaybeT IO Text
+ipcGetFocusedOutputName =
+  getOutputs >>= MaybeT . return . getFocusedOutputName
+
+adaptiveSyncStatusByName :: [Output] -> Text -> Maybe Bool
+adaptiveSyncStatusByName outs name =
+  case filter (\x -> o_name x == name) outs of
+    [] -> Nothing
+    [x] -> Just . interpretAdaptiveSync . o_adaptive_sync_status $ x
+    _ -> Nothing
+
+toggleFocusedOutputAdaptiveSync :: IO Bool
+toggleFocusedOutputAdaptiveSync = do
+  maybeOuts <- runMaybeT getOutputs
+  case maybeOuts of
+    Nothing -> return False
+    Just outs ->
+      case getFocusedOutputName outs of
+        Nothing -> return False
+        Just focusedOutput ->
+          case adaptiveSyncStatusByName outs focusedOutput of
+            Nothing -> return False
+            Just currentStatus ->
+              let commandMessage = BS.concat [
+                      "output "
+                    , TE.encodeUtf8 focusedOutput
+                    , " adaptive_sync "
+                    , syncStatusToCommand (not currentStatus)
+                    ]
+               in ipcSendCommand commandMessage >>=
+                   return . ipcCommandWasSuccessful >>=
+                    \success -> safeConnectAndNotify success (Just focusedOutput) currentStatus >>
+                     return success
+
+toggleAllOutputsAdaptiveSync :: IO Bool
+toggleAllOutputsAdaptiveSync = do
+  maybeOuts <- runMaybeT getOutputs
+  syncStatus <- getSingleAdaptiveSyncStatus
+  case maybeOuts of
+    Nothing -> return False
+    Just outs ->
+      case syncStatus of
+        ASError -> return False
+        _       ->
+          let currentStatus = not (syncStatus == ASInactive)
+              commandMessage = BS.concat [
+                  "output * adaptive_sync "
+                , syncStatusToCommand (not currentStatus)
+                ]
+           in ipcSendCommand commandMessage >>=
+               return . ipcCommandWasSuccessful >>=
+                \success -> safeConnectAndNotify success Nothing currentStatus >>
+                 return success
+
+
+
+syncStatusToCommand :: Bool -> ByteString
+syncStatusToCommand True = "on"
+syncStatusToCommand False = "off"
+
+getSyncStatusIcon :: AdaptiveSyncStatus -> String
+getSyncStatusIcon ASActive = "\xf04e6"
+getSyncStatusIcon ASPartial = "\xf11a2"
+getSyncStatusIcon ASInactive = "\xf04e8"
+getSyncStatusIcon ASError = "\xf04e7"
+
+makeDetailedOutputMessage :: Output -> String
+makeDetailedOutputMessage out = "\xf0379" ++ " " ++
+                                 (T.unpack . o_name $ out) ++
+                                 ": " ++ (T.unpack . o_model $ out ) ++ " - " ++
+                                 (T.unpack . o_adaptive_sync_status $ out)
+
+makeDetailedAdaptiveSyncMessage :: AdaptiveSyncStatus -> [Output] -> String
+makeDetailedAdaptiveSyncMessage ASError _ = "<big>ERROR</big>"
+makeDetailedAdaptiveSyncMessage status outs = "<big>" ++ show status ++ "</big>\n\n" ++
+                                                (concat . intersperse "\n" . fmap makeDetailedOutputMessage $ outs)
+
+getAllAdaptiveSyncStatus :: MaybeT IO (Bool, Bool)
+getAllAdaptiveSyncStatus = do
+  outs <- getOutputs
+  let allAS = all (interpretAdaptiveSync . o_adaptive_sync_status) outs
+      anyAS = any (interpretAdaptiveSync . o_adaptive_sync_status) outs
+  return (allAS, anyAS)
+
+multipleASToSingle :: (Bool, Bool) -> AdaptiveSyncStatus
+multipleASToSingle (True, True) = ASActive
+multipleASToSingle (False, True) = ASPartial
+multipleASToSingle (False, False) = ASInactive
+multipleASToSingle (True, False) = ASError
+
+getSingleAdaptiveSyncStatus :: IO AdaptiveSyncStatus
+getSingleAdaptiveSyncStatus = do
+  allASStatus <- runMaybeT getAllAdaptiveSyncStatus
+  case allASStatus of
+    Nothing -> return ASError
+    Just x -> return $ multipleASToSingle x

app/CmdArgs.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module CmdArgs where
+
+import System.Console.CmdArgs
+
+version :: String
+version = "0.1.0.0"
+
+data WaybarAdaptive = Toggle { all_ :: Bool }
+                    | Display
+                    deriving (Data, Typeable, Show, Eq)
+
+display = Display &= help "Displays the current adaptive sync status in Sway"
+                  &= auto
+
+toggle = Toggle { all_ = False &= help "Toggles all outputs' adaptive sync\n\nDefaults to false"
+                  } &= help "Toggle adaptive sync on or off on the focused display"
+
+swankybarAdaptiveCli = cmdArgsMode $ modes [display, toggle]
+                                   &= helpArg [help "Display or toggle adaptive sync in Sway", name "h"]
+                                   &= program "swankybar-as"
+                                   &= summary ("swankybar-as v." ++ version ++ "\nHelper tool to toggle adaptive sync on and off\nand print a nice Waybar JSON")
+
+runSwankybarAdaptiveCli = cmdArgsRun swankybarAdaptiveCli

app/DbusHelper.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module DbusHelper where
+
+import DBus.Notify
+import DBus.Client (ClientError)
+import Data.Text (Text)
+import qualified Data.Text as T (unpack)
+import Control.Monad.Reader
+import Control.Exception
+
+data NotifyMessage = NotifyMessage {
+    toggleSuccess :: Bool
+  , notifyClient :: Client
+  , focusedOutputName :: Maybe Text
+  , previousSyncStatus :: Bool
+  }
+
+thisAppName :: String
+thisAppName = "swankybar - Adaptive Sync"
+
+errorNote :: Note
+errorNote = blankNote {
+    appName = thisAppName
+  , summary = "Error"
+  , body = Just $ Bold (Text "ERROR: Toggling adaptive sync failed")
+  }
+
+-- makeToggleStatusNote focusedNameOrAll previousStatusWasActive
+makeToggleStatusNote :: Maybe Text -> Bool -> Note
+makeToggleStatusNote Nothing True = blankNote {
+    appName = thisAppName
+  , summary = "Disabled"
+  , body = Just $ Text "Successfully disabled adaptive sync on all outputs"
+  }
+makeToggleStatusNote Nothing False = blankNote {
+    appName = thisAppName
+  , summary = "Enabled"
+  , body = Just $ Text "Successfully enabled adaptive sync on all outputs"
+  }
+makeToggleStatusNote (Just outputName) True = blankNote {
+    appName = thisAppName
+  , summary = "Disabled"
+  , body = Just $ Text $ "Successfully disabled adaptive sync on output: " ++ T.unpack outputName
+  }
+makeToggleStatusNote (Just outputName) False = blankNote {
+    appName = thisAppName
+  , summary = "Enabled"
+  , body = Just $ Text $ "Successfully enabled adaptive sync on output: " ++ T.unpack outputName
+  }
+
+notifyToggleError :: ReaderT NotifyMessage IO ()
+notifyToggleError = do
+  client <- asks notifyClient
+  liftIO $ notify client errorNote
+  return ()
+
+notifyToggleSuccess :: ReaderT NotifyMessage IO ()
+notifyToggleSuccess = do
+  client <- asks notifyClient
+  foName <- asks focusedOutputName
+  prev <- asks previousSyncStatus
+  liftIO $ notify client $ makeToggleStatusNote foName prev
+  return ()
+
+connectAndNotify :: Bool -> Maybe Text -> Bool -> IO ()
+connectAndNotify False _ _ = do
+  client <- connectSession
+  let env = NotifyMessage False client Nothing False
+  runReaderT notifyToggleError env
+connectAndNotify True foName prevStatus = do
+  client <- connectSession
+  let env = NotifyMessage True client foName prevStatus
+  runReaderT notifyToggleSuccess env
+
+
+-- If we cannot connect to the dbus session, just ignore it
+-- DBus notifications are not required
+safeConnectAndNotify :: Bool -> Maybe Text -> Bool -> IO ()
+safeConnectAndNotify a b c = catch (connectAndNotify a b c) ((\e -> return ()) :: ClientError -> IO ())
+