Kass

packages/kass/kass.cabal

@@ -59,6 +59,7 @@ common warnings
   default-extensions:
     BlockArguments
     DataKinds
+    DerivingStrategies
     DuplicateRecordFields
     GADTs
     LambdaCase
@@ -70,6 +71,7 @@ common warnings
     OverloadedStrings
     PartialTypeSignatures
     QuasiQuotes
+    RecursiveDo
 
   default-language:   GHC2021
 

packages/kass/lib/Bluefin/Dialog.hs

@@ -1,21 +1,38 @@
 module Bluefin.Dialog where
 
+import Bluefin.Reflex
 import Maralude
 import Reflex
 
-newtype Page a = MkPage (List (List (Element a)))
-  deriving (Eq, Show)
+newtype Page a = MkPage {lines :: List (Line a)}
+  deriving newtype (Semigroup, Monoid)
+  deriving stock (Functor)
+
+newtype Line a = MkLine {elems :: List (Element a)}
+  deriving newtype (Semigroup, Monoid)
+  deriving stock (Functor)
 
 data Element a where
   TextElement :: Text -> Element a
   ButtonElement :: Text -> a -> Element a
-  FormElement :: (Text, a) -> Element (Text, a)
+  FormElement :: Text -> (Text -> a) -> Element a
+  deriving stock (Functor)
 
-deriving instance Eq a => Eq (Element a)
+showPage :: (Reflex t, e :> es) => Dialog t e -> Dynamic t (Page a) -> Eff es (Event t a)
+showPage MkDialog{run, r} page = do
+  pb <- reflex r getPostBuild
+  useImpl do run (leftmost [updated page, current page <@ pb])
 
-deriving instance Show a => Show (Element a)
+data Dialog t e = MkDialog
+  { run :: forall a. Event t (Page a) -> Eff e (Event t a)
+  , r :: ReflexE t e
+  }
 
-showPage :: e :> es => Dialog t e -> Event t (Page a) -> Eff es (Event t a)
-showPage (MkDialog impl) page = useImpl do impl page
+line :: Line a -> Page a
+line = MkPage . (: [])
 
-newtype Dialog t e = MkDialog (forall a. Event t (Page a) -> Eff e (Event t a))
+txt :: Text -> Line a
+txt = MkLine . (: []) . TextElement
+
+button :: Text -> a -> Line a
+button lbl val = MkLine [ButtonElement lbl val]

packages/kass/lib/Bluefin/Dialog/ReflexDom.hs

@@ -50,14 +50,19 @@ runDomDialogBody
   -> (forall e. Dialog t e -> Eff (e :& es) ())
   -> Eff es ()
 runDomDialogBody = \r d act ->
-  inContext' . act $ MkDialog @t @er \ePage ->
-    switchDyn <$> dom r d do networkHold (pure never) do ePage <&> renderPage
+  inContext'
+    . act
+    $ MkDialog
+      { run = \ePage ->
+          switchDyn <$> dom r d do networkHold (pure never) do ePage <&> renderPage
+      , r
+      }
 
 elClss :: DomBuilder t m => Text -> [Text] -> m a -> m a
 elClss tg clss = elClass tg (clss ^. re worded)
 
 renderPage :: (DomBuilder t m, MonadReflex t m) => Page a -> m (Event t a)
-renderPage = \(MkPage rows) -> elClss
+renderPage = \page -> elClss
   "div"
   [ "h-full"
   , "p-2"
@@ -70,8 +75,8 @@ renderPage = \(MkPage rows) -> elClss
   , "bg-indigo-950"
   ]
   do
-    evs <- forM rows \row ->
-      el "div" $ forM row \case
+    evs <- forM page.lines \line' ->
+      el "div" $ forM line'.elems \case
         TextElement t -> do
           el "span" $ text t
           pure never

packages/kass/lib/Bluefin/Dialog/Term.hs

@@ -5,7 +5,7 @@ import Bluefin.Reflex
 import Control.Concurrent.Async (Async)
 import Control.Concurrent.Async qualified as Async
 import Data.Char qualified as Char
-import Data.Map.Strict qualified as Map
+import Data.Map.Lazy qualified as LMap
 import Data.Set qualified as Set
 import Data.Text qualified as Text
 import Maralude
@@ -26,22 +26,29 @@ runTermDialog
   -> ReflexE t e2
   -> (forall e. Dialog t e -> Eff (e :& es) a)
   -> Eff es a
-runTermDialog = \io r act -> inContext' $ inContext' $ assoc1Eff $ act $ MkDialog @t @(e1 :& e2) \ev -> do
-  (retEv, hook) <- reflex r newTriggerEvent
-  _ <- runState Nothing $ \thread ->
-    performEffEvent r
-      $ ev
-      <&> \page -> do
-        whenJustM (get thread) (effIO io . Async.cancel)
-        put thread . Just =<< async io do
-          effIO io . hook =<< withEarlyReturn \ret -> forever do
-            effIO io $ do clearScreen; putStr resetColor
-
-            keybinds <- renderPage io page
-            effIO io do putStr [i|#{color Magenta}> |]; hFlush stdout
-            input <- effIO io getLine <&> preview (ix 0 % to (`Map.lookup` keybinds) % _Just)
-            whenJust input (returnEarly ret)
-  pure retEv
+runTermDialog = \io r act ->
+  inContext'
+    . inContext'
+    . assoc1Eff
+    . act @(e1 :& e2)
+    $ MkDialog
+      { run = \ev -> do
+          (retEv, hook) <- reflex r newTriggerEvent
+          _ <- runState Nothing $ \thread ->
+            performEffEvent r
+              $ ev
+              <&> \page -> do
+                whenJustM (get thread) (effIO io . Async.cancel)
+                put thread . Just =<< async io do
+                  effIO io . hook =<< withEarlyReturn \ret -> forever do
+                    effIO io $ do clearScreen; putStr resetColor
+                    keybinds <- renderPage io page
+                    effIO io do putStr [i|#{color Magenta}> |]; hFlush stdout
+                    input <- effIO io getLine <&> preview (ix 0 % to (`LMap.lookup` keybinds) % _Just)
+                    whenJust input (returnEarly ret)
+          pure retEv
+      , r = mapHandle r
+      }
 
 color :: Color -> String
 color c = setSGRCode [SetColor Foreground Vivid c]
@@ -53,17 +60,17 @@ async :: e :> es => IOE e -> Eff es a -> Eff es (Async a)
 async = \io act -> withEffToIO (\runInIO -> Async.async $ runInIO (const (useImpl act))) io
 
 renderPage :: e :> es => IOE e -> Page a -> Eff es (Map Char a)
-renderPage = \io (MkPage rows) -> do
+renderPage = \io page -> do
   execState mempty $ \st -> do
-    forM_ rows \row -> do
-      elems <- forM row \case
+    forM_ page.lines \row -> do
+      elems <- forM row.elems \case
         TextElement t -> pure t
         ButtonElement label value -> do
           keybinds <- get st
-          chooseHotkey (Map.keysSet keybinds) label & maybe
+          chooseHotkey (LMap.keysSet keybinds) label & maybe
             (pure label)
             \key -> do
-              put st $ Map.insert key value keybinds
+              put st $ LMap.insert key value keybinds
               pure
                 [i|#{color Magenta}#{Char.toUpper key}: #{color Blue}#{label}#{resetColor}|]
         _ -> error "not supported"

packages/kass/lib/Bluefin/Reflex.hs

@@ -1,8 +1,9 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Bluefin.Reflex (ReflexE (..), reflex, reflexIO, MonadReflex, performEffEvent, runRequesterT, runPerformEventT) where
 
 import Bluefin.Internal (Eff (UnsafeMkEff), unsafeUnEff)
 import Control.Concurrent (Chan)
-import Control.Monad.Fix (MonadFix)
 import Data.Dependent.Sum (DSum (..))
 import GHC.Base qualified as GHC
 import Maralude
@@ -10,6 +11,8 @@ import Reflex hiding (runRequesterT)
 import Reflex.Requester.Base.Internal (RequesterState)
 import Reflex.Spider.Internal (HasSpiderTimeline, SpiderHostFrame, runSpiderHostFrame, unEventM)
 
+deriving newtype instance MonadFix (Eff es)
+
 -- | Reflex Effect Handle
 data ReflexE t (es :: Effects) where
   MkReflex
@@ -21,6 +24,11 @@ data ReflexE t (es :: Effects) where
        }
     -> ReflexE (SpiderTimeline x) es
 
+instance Handle (ReflexE t) where
+  mapHandle = \case
+    MkReflex{triggerChan, postBuild, requesterStateHandle, requesterSelector} ->
+      MkReflex{triggerChan, postBuild, requesterStateHandle = mapHandle requesterStateHandle, requesterSelector}
+
 -- Uncommented: Other available type classes which I don’t want to expose.
 type MonadReflexIO t m =
   ( Adjustable t m

packages/kass/lib/Kass/App.hs

@@ -26,23 +26,29 @@ entryPoint = \io -> do
     ["web"] -> webApp
     _ -> error "not implemented"
 
+data NavState = StartPage | Numbers | Congrats | Disappointment
+
+type Update = NavState
+
+processUpdate :: Update -> NavState
+processUpdate = id
+
+viewState :: NavState -> Page Update
+viewState =
+  \case
+    StartPage -> line (txt "Hello World!") <> line (button "Start numbers game" Numbers)
+    Numbers ->
+      line (txt "What is the best number?")
+        <> line (txt "An even one?" <> button "70" Disappointment <> button "42" Disappointment)
+        <> line (txt "Or an ott one?" <> button "Twentythree" Disappointment <> button "Seventeeeeeen" Congrats)
+        <> footer
+    Congrats -> line (txt "Good choice") <> footer
+    Disappointment -> line (txt "Meh") <> footer
+ where
+  footer = line mempty <> line (button "Back to start" StartPage)
+
 app :: (e1 :> es, e2 :> es, e3 :> es, Reflex t) => IOE e1 -> ReflexE t e2 -> Dialog t e3 -> Eff es ()
-app = \io r dialog -> do
-  pb <- reflex r getPostBuild
-  ev <-
-    showPage dialog
-      $ pb
-      $> MkPage
-        [ [TextElement "Hello World!"]
-        , [TextElement "What is the best number?"]
-        , [TextElement "An even one?", ButtonElement "70" 70, ButtonElement "42" 42]
-        , [TextElement "Or an ott one?", ButtonElement "Twentythree" 23, ButtonElement "Seventeeeeeen" (17 :: Int)]
-        ]
-  _ <-
-    performEffEvent r
-      $ ev
-      <&> ( \case
-              17 -> effIO io (say "Good choice")
-              _ -> effIO io (say "Meh")
-          )
-  pure ()
+app = \_ r dialog -> mdo
+  state <- reflex r $ holdDyn StartPage (processUpdate <$> newState)
+  newState <- showPage dialog $ viewState <$> state
+  pass

packages/kass/lib/Maralude.hs

@@ -23,6 +23,7 @@ module Maralude
   , isomorph
   , worded
   , lined
+  , MonadFix
   )
 where
 
@@ -34,6 +35,7 @@ import Bluefin.IO
 import Bluefin.Internal (In, assoc1Eff, cmp, fstI, inContext, sndI, weakenEff)
 import Bluefin.Internal qualified as BF
 import Bluefin.State
+import Control.Monad.Fix (MonadFix)
 import Data.String.Interpolate
 import GHC.List (List)
 import Optics