CustomWidgetTest.hs

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedLabels    #-}
{-# LANGUAGE OverloadedLists     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module GI.Gtk.Declarative.CustomWidgetTest where

import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Exception.Safe
import           Control.Monad                  ( replicateM_ )
import           Control.Monad.IO.Class
import           Data.Function                  ( (&) )
import qualified Data.HashSet                  as HashSet
import qualified Data.Text                     as Text
import           Data.Vector                    ( Vector )
import qualified GI.GObject                    as GI
import qualified GI.Gtk                        as Gtk

import           Hedgehog
import qualified Hedgehog.Gen                  as Gen
import qualified Hedgehog.Range                as Range

import           GI.Gtk.Declarative
import           GI.Gtk.Declarative.EventSource
import           GI.Gtk.Declarative.State

import           GI.Gtk.Declarative.TestUtils

prop_sets_the_button_label = property $ do
  start       <- forAll (Gen.int (Range.linear 0 10))
  clicks      <- forAll (Gen.int (Range.linear 0 10))

  buttonLabel <- runUI . bracket (Gtk.new Gtk.Window []) #destroy $ \window ->
    do
      let markup = testWidget [] start
      first <- create markup
      btn   <- someStateWidget first >>= Gtk.unsafeCastTo Gtk.Button & liftIO
      #add window btn
      sub <- subscribe markup first (const (pure ()))
      Gtk.widgetShowAll window
      replicateM_ clicks (Gtk.buttonClicked btn)
      cancel sub
      Gtk.get btn #label

  let expectedLabel = Text.pack (show (start + clicks))
  expectedLabel === buttonLabel

prop_emits_correct_number_of_click_events = property $ do
  start  <- forAll (Gen.int (Range.linear 0 10))
  clicks <- forAll (Gen.int (Range.linear 0 10))

  values <- liftIO (newTBQueueIO (fromIntegral clicks))
  runUI . bracket (Gtk.new Gtk.Window []) #destroy $ \window -> do
    let markup = testWidget [] start
    first <- create markup
    btn   <- someStateWidget first >>= Gtk.unsafeCastTo Gtk.Button & liftIO
    #add window btn
    sub <- subscribe markup first (atomically . writeTBQueue values)
    Gtk.widgetShowAll window
    replicateM_ clicks (Gtk.buttonClicked btn)
    cancel sub

  let expectedValues = take clicks [succ start ..]
  actualValues <- liftIO (atomically (flushTBQueue values))
  expectedValues === actualValues

prop_sets_classes = property $ do
  let genClasses =
        Gen.list (Range.linear 0 5) (Gen.text (Range.linear 1 5) Gen.alphaNum)
  initialClasses                <- forAll genClasses
  finalClasses                  <- forAll genClasses

  (classesBefore, classesAfter) <-
    runUI . bracket (Gtk.new Gtk.Window []) #destroy $ \window -> do
      let markup1 = testWidget [classes initialClasses] 0
          markup2 = testWidget [classes finalClasses] 0
      first <- create markup1
      btn   <- liftIO (someStateWidget first >>= Gtk.unsafeCastTo Gtk.Button)
      #add window btn
      Gtk.widgetShowAll window
      sc           <- #getStyleContext btn
      beforeUpdate <- #listClasses sc
      _second      <- patch' first markup1 markup2
      afterUpdate  <- #listClasses sc
      pure (beforeUpdate, afterUpdate)

  HashSet.fromList ("text-button" : initialClasses)
    === HashSet.fromList classesBefore
  HashSet.fromList ("text-button" : finalClasses)
    === HashSet.fromList classesAfter

-- * Test widget and helpers

testWidget :: Vector (Attribute Gtk.Button Int) -> Int -> Widget Int
testWidget customAttributes customParams = Widget (CustomWidget { .. })
 where
  customWidget = Gtk.Button
  customCreate start = do
    clicks <- newMVar start
    btn    <- Gtk.new Gtk.Button [#label Gtk.:= Text.pack (show start)]
    return (btn, clicks)

  customPatch :: Int -> Int -> MVar Int -> CustomPatch Gtk.Button (MVar Int)
  customPatch _ new clicks = CustomModify $ \btn -> do
    -- putMVar clicks new
    Gtk.set btn [#label Gtk.:= Text.pack (show new)]
    return clicks

  customSubscribe
    :: Int -> MVar Int -> Gtk.Button -> (Int -> IO ()) -> IO Subscription
  customSubscribe _params clicks btn cb = do
    h <- Gtk.on btn #clicked $ do
      current <- modifyMVar clicks $ \x -> pure (succ x, succ x)
      cb current
      Gtk.set btn [#label Gtk.:= Text.pack (show current)]
    return (fromCancellation (GI.signalHandlerDisconnect btn h))

-- * Test collection

tests :: IO Bool
tests = checkParallel $$(discover)