# 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` (-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

# LANGUAGE OverloadedStrings #
 | 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
 need to sort here to allow accurate comparisons of the children
 * Generators
 In lack of `subtermN` (-hedgehog/issues/119), we use this terrible hack:
# LANGUAGE LambdaCase #
# LANGUAGE OverloadedLabels #
# LANGUAGE OverloadedLists #
# 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

  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
        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)


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]
  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
