ContextSpec.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module System.Taffybar.ContextSpec
  ( spec
  -- * Utils
  , runTaffyDefault
  -- * Abstract Config
  , GenSimpleConfig(..)
  , toSimpleConfig
  , GenWidget(..)
  , toTaffyWidget
  , GenSpace(..)
  , GenCssPath(..)
  , toCssPaths
  , GenMonitorsAction(..)
  , toMonitorsAction
  ) where

import Control.Monad.Trans.Reader (runReaderT)
import Control.Exception (SomeException, catch)
import Data.Default (def)
import Data.Ratio ((%))
import GHC.Generics (Generic)
import GI.Gtk (Widget)
import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, removePathForcibly)
import System.FilePath ((</>))

import Test.Hspec hiding (context)
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.QuickCheck.Monadic

import System.Taffybar.Context
import System.Taffybar.SimpleConfig
import System.Taffybar.Widget.SimpleClock (textClockNewWith)
import System.Taffybar.Widget.Workspaces (workspacesNew)

import System.Taffybar.Test.DBusSpec (withTestDBus)
import System.Taffybar.Test.UtilSpec (logSetup, withSetEnv)
import System.Taffybar.Test.XvfbSpec (withXdummy, setDefaultDisplay_)

spec :: Spec
spec = logSetup $ sequential $ aroundAll_ withTestDBus $ aroundAll_ (withXdummy . flip setDefaultDisplay_) $ do
  describe "detectBackend" $ do
    it "falls back to X11 when WAYLAND_DISPLAY is set but the socket is missing" $ do
      tmp <- getTemporaryDirectory
      let runtime = tmp </> "taffybar-test-runtime-missing-socket"
          wl = "wayland-stale"
      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())
      createDirectoryIfMissing True runtime
      withSetEnv
        [ ("XDG_RUNTIME_DIR", runtime)
        , ("WAYLAND_DISPLAY", wl)
        , ("XDG_SESSION_TYPE", "wayland")
        ] $ do
          detectBackend `shouldReturn` BackendX11
      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())

    it "falls back to X11 when WAYLAND_DISPLAY points at a non-socket path" $ do
      tmp <- getTemporaryDirectory
      let runtime = tmp </> "taffybar-test-runtime-non-socket"
          wl = "wayland-stale"
          wlPath = runtime </> wl
      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())
      createDirectoryIfMissing True runtime
      writeFile wlPath "" -- exists but is not a socket
      withSetEnv
        [ ("XDG_RUNTIME_DIR", runtime)
        , ("WAYLAND_DISPLAY", wl)
        , ("XDG_SESSION_TYPE", "wayland")
        ] $ do
          detectBackend `shouldReturn` BackendX11
      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())

  describe "Fuzz tests" $ do
    prop "eval generators" prop_genSimpleConfig
    xprop "TaffybarConfig" prop_taffybarConfig

------------------------------------------------------------------------

runTaffyDefault :: TaffyIO a -> IO a
runTaffyDefault f = buildContext def >>= runReaderT f

------------------------------------------------------------------------

-- | Represents 'SimpleTaffyConfig' in a more abstract way, so that
-- it's easier to 'show', 'shrink', 'assert', etc.
data GenSimpleConfig = GenSimpleConfig
  { monitors :: GenMonitorsAction
  , size :: StrutSize
  , padding :: GenSpace
  , position :: Position
  , spacing :: GenSpace
  , start :: [GenWidget]
  , center :: [GenWidget]
  , end :: [GenWidget]
  , css :: [GenCssPath]
  } deriving (Show, Eq, Generic)

-- | Build an actual taffy config from the abstract form.
toSimpleConfig :: GenSimpleConfig -> SimpleTaffyConfig
toSimpleConfig GenSimpleConfig{..} = SimpleTaffyConfig
  { monitorsAction = toMonitorsAction monitors
  , barHeight = size
  , barPadding = unGenSpace padding
  , barPosition = position
  , widgetSpacing = unGenSpace spacing
  , startWidgets = map toTaffyWidget start
  , centerWidgets = map toTaffyWidget center
  , endWidgets = map toTaffyWidget end
  , cssPaths = toCssPaths css
  , startupHook = pure () -- TODO: add something
  }

toTaffyWidget :: GenWidget -> TaffyIO Widget
toTaffyWidget = \case
  WorkspacesWidget -> workspacesNew def
  ClockWidget -> textClockNewWith def

toCssPaths :: [GenCssPath] -> [FilePath]
toCssPaths = map (\p -> "fixme_" ++ show p ++ ".css")

toMonitorsAction :: GenMonitorsAction -> TaffyIO [Int]
toMonitorsAction = \case
  UsePrimaryMonitor -> usePrimaryMonitor
  UseAllMonitors -> useAllMonitors
  UseTheseMonitors xs -> pure xs

instance Arbitrary GenSimpleConfig where
  arbitrary = GenSimpleConfig <$> arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary
  shrink = genericShrink

instance Arbitrary StrutSize where
  arbitrary = oneof
    [ ExactSize . getSmall . getPositive <$> arbitrary
    , ScreenRatio <$> elements [ 1 % 27, 1 % 50, 1 % 2 ] -- TODO: more arbitrary
    ]
  shrink (ExactSize s) = ExactSize . getPositive <$> shrink (Positive (fromIntegral s))
  shrink (ScreenRatio r) = ScreenRatio <$> shrink r

instance Arbitrary Position where
  arbitrary = arbitraryBoundedEnum
  shrink Top = []
  shrink Bottom = [Top]

newtype GenSpace = GenSpace { unGenSpace :: Int }
  deriving (Show, Read, Eq, Generic)

instance Arbitrary GenSpace where
  arbitrary = GenSpace . getSmall . getPositive <$> arbitrary
  shrink = genericShrink

data GenWidget = WorkspacesWidget | ClockWidget
  deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic)

instance Arbitrary GenWidget where
  arbitrary = arbitraryBoundedEnum
  shrink = genericShrink

data GenCssPath = RedStyle | BlueStyle | MissingCss | FaultyCss
  deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic)

instance Arbitrary GenCssPath where
  arbitrary = arbitraryBoundedEnum
  shrink = genericShrink

data GenMonitorsAction = UsePrimaryMonitor
                       | UseAllMonitors
                       | UseTheseMonitors [Int]
  deriving (Show, Read, Eq, Generic)

instance Arbitrary GenMonitorsAction where
  arbitrary = oneof
    [ pure UsePrimaryMonitor
    , pure UseAllMonitors
    , wild ]
    where
      -- This could be a lot meaner.
      wild = do
        NonNegative (Small n) <- arbitrary
        pure (UseTheseMonitors [0..n])
  shrink = genericShrink

------------------------------------------------------------------------

prop_genSimpleConfig :: GenSimpleConfig -> Property
prop_genSimpleConfig cfg = checkCoverage $
  cover 25 (monitors cfg == UsePrimaryMonitor) "Primary monitor only" $
  cfg === cfg

prop_taffybarConfig :: GenSimpleConfig -> Property
prop_taffybarConfig cfg = within 1_000_000 $ monadicIO $
  pure (cfg =/= cfg)
  -- Some possible assertions:
  --   startupHook executed exactly once
  --   css rules are applied
  --   css files later in list have precedence
  --   missing css => exception
  --   error in css => warning and continue
  --   widgets are visible
  --   spacing/height/position/padding are observed
  --   appears on the correct monitor