Main.hs

{- cabal:
default-language: Haskell2010
default-extensions:
    UnicodeSyntax BlockArguments TupleSections TypeApplications
    PartialTypeSignatures PatternSynonyms LiberalTypeSynonyms
    StandaloneDeriving DeriveFunctor DeriveFoldable DeriveTraversable
    DeriveGeneric FlexibleInstances FlexibleContexts
    MultiParamTypeClasses FunctionalDependencies RankNTypes DataKinds
    PolyKinds GADTs ConstraintKinds PolyKinds KindSignatures
    TypeOperators TypeFamilies TypeFamilyDependencies
    StandaloneKindSignatures
    OverloadedLabels OverloadedLists OverloadedStrings RecordWildCards

ghc-options: -Wpartial-type-signatures -fdefer-typed-holes -threaded
build-depends: base, base-unicode-symbols, containers, containers-unicode-symbols, pretty-show, fixed-vector, data-fix, generic-data, ghc-prim, logict, gi-gtk-declarative, gi-gtk, gi-gdk, gi-glib, async, haskell-gi-base, vector, Stream, text
-}

module Main where

import Prelude.Unicode
import Numeric.Natural.Unicode
import Data.Function (fix, (&))
import qualified Data.Vector as Vector
import Data.Vector (Vector)
import qualified Data.Stream as Stream
import Data.Stream (Stream (Cons))
import qualified Control.Concurrent.Async as Async
import qualified GI.Gtk as Gtk
import Control.Monad (void, when)
import qualified Data.Text as Text
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Control.Concurrent

import GI.Gtk.Declarative
import GI.Gtk.Declarative.State
import GI.Gtk.Declarative.EventSource
import GI.Gtk.Declarative.Container.Grid

for ∷ Functor f ⇒ f α → (α → β) → f β
for = flip fmap

type ℝ = Double

data Event = Add | Close | Remove ℕ deriving Show

data State = State
  { liveButtons ∷ Vector ℕ
  , availableLabels ∷ Stream ℕ
  } deriving Show

state₀ = State
  { liveButtons = [ ]
  , availableLabels = Stream.fromList [1..]
  }

update ∷ Event → State → State
update Add State {..} = let Cons label labels = availableLabels in State {liveButtons = liveButtons `Vector.snoc` label, availableLabels = labels}
update (Remove buttonId) state@State {..} = state {liveButtons = delete (≡ buttonId) liveButtons}

view ∷ State → Widget Event
view State {..} = bin Gtk.Window [#title := ""]
  $ container Gtk.Box [#orientation := Gtk.OrientationVertical]
  [ BoxChild {properties = defaultBoxChildProperties, child = widget Gtk.Button [#label := "add", on #clicked Add]}
  , BoxChild
    { properties = defaultBoxChildProperties
    , child = container Gtk.Box [ ]
      $ for liveButtons \ buttonId → BoxChild
      { properties = defaultBoxChildProperties
      , child = widget Gtk.Button [#label := ("remove " <> Text.pack (show buttonId)), on #clicked (Remove buttonId)]
      }
    }
  , BoxChild {properties = defaultBoxChildProperties, child = widget Gtk.Button [#label := "close", on #clicked Close]}
  ]

delete ∷ (α → Bool) → Vector α → Vector α
delete predicate vector = let (before, after) = Vector.break predicate vector in before <> Vector.drop 1 after

loop ∷ (Show state, Show event, EventSource widget, Patchable widget) ⇒ (state → widget event) → (event → state → state) → (state, widget event, IO SomeState) → IO ( )
loop view update = fix \ loopReplace (state, widget, getSomeState) → do
  print "replace"
  someState ← getSomeState
  gtk ← someStateWidget someState
  #showAll gtk
  (state, widget, someState) & fix \ loopModify (state, widget, someState) → do
    print "modify"
    fix \ loopKeep → do
      print "keep"
      print "subscription"
      event ← newEmptyMVar >>= \ eventMVar → do
        subscription ← subscribe widget someState \ event → void $ forkIO (putMVar eventMVar event)
        event ← takeMVar eventMVar
        cancel subscription
        print event
        return event
      let
        state' = update event state
        widget' = view state'
      case patch someState widget widget' of
        Keep → loopKeep
        Modify getSomeState' → do
          someState ← getSomeState'
          loopModify (state', widget', someState)
        Replace getSomeState' → do
          #destroy gtk
          print state'
          loopReplace (state', widget', getSomeState')

main ∷ IO ( )
main = do
  _ ← Gtk.init Nothing
  main ← Async.async Gtk.main
  loop view update (state₀, view state₀, (create ∘ view) state₀)
  Async.wait main
  return ( )