TestWidget.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module GI.Gtk.Declarative.TestWidget where

import           Control.Applicative
import           Control.Monad.Except
import           Data.Int                           ( Int32 )
import           Data.Text                          ( Text )
import           Data.Traversable                   ( for )
import           Data.List                          ( sortOn )
import           Data.Vector                        ( Vector )
import qualified Data.Vector                       as Vector
import           Data.Void
import qualified GI.Gtk                            as Gtk
import           GI.Gtk.Declarative
import           GI.Gtk.Declarative.Container.Grid  ( GridChild (..), GridChildProperties (..) )
import           GI.Gtk.Declarative.Container.Grid as Grid
import           GI.Gtk.Declarative.EventSource
import           Hedgehog                    hiding ( label )
import qualified Hedgehog.Gen                      as Gen
import qualified Hedgehog.Range                    as Range
import           Prelude

-- | GTK widgets cannot (in any practical, generic sense) be compared and shown
-- in tests, so we represent widgets in property tests using this data
-- structure. We convert between this representation, declarative widgets, and
-- instantiated GTK widgets.
data TestWidget
  = TestButton Text (Maybe Bool)
  | TestCustomWidget (Maybe Text)
  | TestScrolledWindow (Maybe Gtk.PolicyType) TestWidget
  | TestBox (Maybe Gtk.Orientation) [TestBoxChild]
  | TestGrid [TestGridChild]
  deriving (Eq, Show)

data TestBoxChild = TestBoxChild BoxChildProperties TestWidget
  deriving (Eq, Show)

data TestGridChild = TestGridChild GridChildProperties TestWidget
  deriving (Eq, Show)

isNested :: TestWidget -> Bool
isNested = \case
  TestButton{}                  -> False
  TestCustomWidget{}            -> False
  TestScrolledWindow _ _        -> True
  TestBox            _ children -> not (null children)
  TestGrid children             -> not (null children)

class HasGtkDefaults a where
  setDefaults :: a -> a

instance HasGtkDefaults TestWidget where
  setDefaults = \case
    TestButton label useUnderline ->
      TestButton label (useUnderline <|> Just False)
    TestCustomWidget fontName -> TestCustomWidget (fontName <|> Just "Sans 12")
    TestScrolledWindow policy child -> TestScrolledWindow
      (policy <|> Just Gtk.PolicyTypeAutomatic)
      (setDefaults child)
    TestBox orientation children -> TestBox
      (orientation <|> Just Gtk.OrientationHorizontal)
      (map setDefaults children)
    TestGrid children ->
      TestGrid (map setDefaults children)

instance HasGtkDefaults TestBoxChild where
  setDefaults = \case
    TestBoxChild props child -> TestBoxChild props (setDefaults child)

instance HasGtkDefaults TestGridChild where
  setDefaults = \case
    TestGridChild props child -> TestGridChild props (setDefaults child)

onlyJusts :: Vector (Maybe a) -> Vector a
onlyJusts = Vector.concatMap (maybe Vector.empty Vector.singleton)

toTestWidget :: TestWidget -> Widget Void
toTestWidget = \case
  TestCustomWidget fontName -> Widget (CustomWidget { .. })
   where
    customParams     = ()
    customAttributes = case fontName of
      Just t  -> [#fontName := t]
      Nothing -> []
    customWidget = Gtk.FontButton
    customCreate () = do
      btn <- Gtk.new Gtk.FontButton []
      return (btn, ())
    customPatch :: () -> () -> () -> CustomPatch Gtk.FontButton ()
    customPatch _ () () = CustomKeep
    customSubscribe
      :: () -> () -> Gtk.FontButton -> (Void -> IO ()) -> IO Subscription
    customSubscribe () () _lbl _cb = do
      return (fromCancellation (pure ()))
  TestButton label useUnderline -> widget
    Gtk.Button
    (onlyJusts [Just (#label := label), (#useUnderline :=) <$> useUnderline])
  TestScrolledWindow policy child -> bin
    Gtk.ScrolledWindow
    (onlyJusts [(#vscrollbarPolicy :=) <$> policy])
    (toTestWidget child)
  TestBox orientation children -> container
    Gtk.Box
    (onlyJusts [(#orientation :=) <$> orientation])
    (Vector.map
      (\(TestBoxChild props child) -> BoxChild props (toTestWidget child))
      (Vector.fromList children)
    )
  TestGrid children -> container
    Gtk.Grid
    []
    (Vector.map
      (\(TestGridChild props child) -> GridChild props (toTestWidget child))
      (Vector.fromList children)
    )

fromGtkWidget :: (MonadIO m) => Gtk.Widget -> m (Either Text TestWidget)
fromGtkWidget = runExceptT . go
 where
  go :: (MonadIO m) => Gtk.Widget -> ExceptT Text m TestWidget
  go w = do
    name <- #getName w
    case name of
      "GtkButton" -> withCast
        w
        Gtk.Button
        (\btn ->
          TestButton
            <$> Gtk.get btn #label
            <*> (Just <$> Gtk.get btn #useUnderline)
        )
      "GtkFontButton" -> withCast
        w
        Gtk.FontButton
        (\btn -> TestCustomWidget . Just <$> Gtk.get btn #fontName)
      "GtkScrolledWindow" -> withCast w Gtk.ScrolledWindow $ \win -> do
        w' <-
          #getChild win
            >>= maybe (throwError "No viewport in scrolled window") pure
        vscrollbarPolicy <- Just <$> Gtk.get win #vscrollbarPolicy
        withCast w' Gtk.Viewport $ \viewport -> do
          child <-
            #getChild viewport
              >>= maybe (throwError "No child in scrolled window") pure
          TestScrolledWindow vscrollbarPolicy <$> go child
      "GtkBox" -> withCast w Gtk.Box $ \box -> do
        childGtkWidgets <- #getChildren box
        boxChildProps   <- for childGtkWidgets $ \childGtkWidget -> do
          (expand, fill, padding, _) <- #queryChildPacking box childGtkWidget
          pure (BoxChildProperties expand fill padding)
        childWidgets <- traverse go childGtkWidgets
        orientation  <- Just <$> Gtk.get box #orientation
        pure
          (TestBox orientation (zipWith TestBoxChild boxChildProps childWidgets)
          )
      "GtkGrid" -> withCast w Gtk.Grid $ \grid -> do
        childGtkWidgets <- #getChildren grid
        gridChildren    <- for childGtkWidgets $ \childGtkWidget -> do
          let prop = getGridChildProp grid childGtkWidget
          height     <- prop "height"
          width      <- prop "width"
          leftAttach <- prop "left-attach"
          topAttach  <- prop "top-attach"
          child      <- go childGtkWidget
          pure (TestGridChild GridChildProperties {..} child)
        -- the order of the children is not maintained by the Grid, so we
        -- need to sort here to allow accurate comparisons of the children
        let sortedChildren =
              sortOn (\(TestGridChild p _) -> topAttach p) gridChildren
        pure (TestGrid sortedChildren)
      _ -> throwError ("Unsupported TestWidget: " <> name)
  withCast
    :: (MonadIO m, Gtk.GObject w, Gtk.GObject w')
    => w
    -> (Gtk.ManagedPtr w' -> w')
    -> (w' -> ExceptT Text m a)
    -> ExceptT Text m a
  withCast w ctor f = liftIO (Gtk.castTo ctor w) >>= \case
    Just w' -> f w'
    Nothing -> throwError "Failed to cast widget"

getGridChildProp
  :: (MonadIO m) => Gtk.Grid -> Gtk.Widget -> Text -> ExceptT Text m Int32
getGridChildProp grid child prop = do
  gValue <- liftIO (Gtk.toGValue (0 :: Int32))
  Gtk.containerChildGetProperty grid child prop gValue
  liftIO (Gtk.fromGValue gValue)

-- * Generators

genTestWidget :: Gen TestWidget
genTestWidget = Gen.frequency
  (map (3, ) leaves <> pure
    ( 2
    , Gen.recursive
      Gen.choice
      leaves
      (  subwidgets genTestBoxFrom
      <> subwidgets getTestGridFrom
      <> [ Gen.subtermM
             genTestWidget
             (\c -> TestScrolledWindow <$> Gen.maybe genPolicyType <*> pure c)
         ]
      )
    )
  )
 where
  leaves = [genCustomWidget, genButton]
  -- In lack of `subtermN` (https://github.com/hedgehogqa/haskell-hedgehog/issues/119), we use this terrible hack:
  subwidgets :: ([TestWidget] -> Gen TestWidget) -> [Gen TestWidget]
  subwidgets f =
    [ f []
    , Gen.subtermM genTestWidget (\w -> f [w])
    , Gen.subtermM2 genTestWidget genTestWidget (\w1 w2 -> f [w1, w2])
    , Gen.subtermM3 genTestWidget
                    genTestWidget
                    genTestWidget
                    (\w1 w2 w3 -> f [w1, w2, w3])
    ]
  genTestBoxFrom ws = do
    children <- for ws $ \w -> do
      props <- genBoxChildProperties
      pure (TestBoxChild props w)
    o <- Gen.maybe genOrientation
    pure (TestBox o children)
  getTestGridFrom ws = do
    children <- for (zip [0 ..] ws) $ \(i, w) -> do
      props <- genGridChildProperties i
      pure (TestGridChild props w)
    pure (TestGrid children)

genOrientation :: Gen Gtk.Orientation
genOrientation =
  Gen.choice [pure Gtk.OrientationVertical, pure Gtk.OrientationHorizontal]

genPolicyType :: Gen Gtk.PolicyType
genPolicyType = Gen.choice
  (map
    pure
    [ Gtk.PolicyTypeAlways
    , Gtk.PolicyTypeAutomatic
    , Gtk.PolicyTypeExternal
    , Gtk.PolicyTypeNever
    ]
  )

genBoxChildProperties :: Gen BoxChildProperties
genBoxChildProperties =
  BoxChildProperties <$> Gen.bool <*> Gen.bool <*> Gen.word32
    (Range.linear 0 10)

genGridChildProperties :: Int32 -> Gen GridChildProperties
genGridChildProperties rowN = do
  width      <- Gen.int32 (Range.linear 1 10)
  height     <- Gen.int32 (Range.linear 1 5)
  leftAttach <- Gen.int32 (Range.linear 0 10)
  topAttach  <- Gen.int32 (Range.constant (rowN * 5) (rowN * 5 + 5 - height))
  pure GridChildProperties {..}

genCustomWidget :: Gen TestWidget
genCustomWidget = do
  TestCustomWidget <$> Gen.maybe (Gen.choice [pure "Sans 10"])

genButton :: Gen TestWidget
genButton = do
  TestButton <$> Gen.text (Range.linear 0 10) Gen.unicode <*> Gen.maybe Gen.bool