diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,30 +1,30 @@ -# Changelog - -All notable changes to this project will be documented in this file. +## [0.4.0] - 2022-07-16 -The format is based on [Keep a Changelog](http://keepachangelog.com/) -and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +- Parameterize `TermboxEvent` (now `Event`) by user event +- Add `Program` type alias for readability +- Remove `TermboxEvent` alias +- Drop GHC 8.2 support ## [0.3.1] - 2022-04-02 -- Removed example executables +- Remove example executables ## [0.3.0] - 2020-09-20 - Support GHC 8.8, GHC 8.10 - Depend on `termbox ==0.3` -- Removed `Scene` +- Remove `Scene` ## [0.2.0] - 2019-06-28 -- Added `run` -- Renamed `main` to `run_` -- Bumped `termbox` lower bound +- Add `run` +- Rename `main` to `run_` +- Bump `termbox` lower bound ## [0.1.1] - 2019-04-19 -- Removed unnecessary `stm` dependency -- Bumped `base` upper bound +- Remov unnecessary `stm` dependency +- Bump `base` upper bound ## [0.1.0] - 2018-07-22 diff --git a/src/Termbox/Banana.hs b/src/Termbox/Banana.hs --- a/src/Termbox/Banana.hs +++ b/src/Termbox/Banana.hs @@ -2,11 +2,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Termbox.Banana - ( -- $intro - TermboxEvent, + ( -- * Introduction + -- $intro + + -- * Core API + Event (..), + Program, run, - -- * Re-exports + -- * Re-exports from @termbox@ Termbox.black, Termbox.blue, Termbox.bold, @@ -23,7 +27,6 @@ Termbox.Cell (..), Termbox.Cells, Termbox.Cursor (..), - Termbox.Event (..), Termbox.InitError (..), Termbox.Key (..), pattern Termbox.KeyCtrl2, @@ -38,125 +41,36 @@ pattern Termbox.KeyCtrlUnderscore, Termbox.Mouse (..), Termbox.PollError (..), - - -- * Example - -- $example ) where import Control.Concurrent.MVar +import Control.Monad.IO.Class (liftIO) import Data.Function (fix) -import Reactive.Banana -import Reactive.Banana.Frameworks +import qualified Reactive.Banana as Banana +import qualified Reactive.Banana.Frameworks as Banana import qualified Termbox -- $intro --- See the bottom of this module for a simple, runnable example to get started. -- --- This module is intended to be imported qualified. +-- This module is intended to be imported qualified: -- -- @ -- import qualified Termbox.Banana as Termbox -- @ - --- | A @termbox@ event. This type alias exists only for Haddock readability; --- in code, you are encouraged to use -- --- * @Event@ for @reactive-banana@ events --- * @Termbox.Event@ for @termbox@ events -type TermboxEvent = - Termbox.Event - -type EventSource a = - (AddHandler a, a -> IO ()) - --- | Run a @termbox@ program with the specified input and output modes. --- --- Given --- --- * the terminal event stream --- * the time-varying terminal size (width, then height) --- --- return --- --- * a time-varying scene to render --- * an event stream of arbitrary values, only the first of which is relevant, --- which ends the @termbox@ program and returns from the @main@ action. -run :: - ( Event TermboxEvent -> - Behavior (Int, Int) -> - MomentIO (Behavior (Termbox.Cells, Termbox.Cursor), Event a) - ) -> - IO a -run program = - Termbox.run $ \width height render poll -> do - doneVar :: MVar a <- - newEmptyMVar - - (eventAddHandler, fireEvent) :: EventSource TermboxEvent <- - newAddHandler - - network :: EventNetwork <- - compile $ do - eEvent :: Event TermboxEvent <- - fromAddHandler eventAddHandler - - let eResize :: Event (Int, Int) - eResize = - filterJust - ( ( \case - Termbox.EventResize w h -> Just (w, h) - _ -> Nothing - ) - <$> eEvent - ) - - bSize :: Behavior (Int, Int) <- - flip stepper eResize (width, height) - - moment (uncurry render) program eEvent bSize (putMVar doneVar) - - actuate network - - fix $ \loop -> do - poll >>= fireEvent - tryReadMVar doneVar >>= maybe loop pure - -moment :: - ((Termbox.Cells, Termbox.Cursor) -> IO ()) -> - ( Event TermboxEvent -> - Behavior (Int, Int) -> - MomentIO (Behavior (Termbox.Cells, Termbox.Cursor), Event a) - ) -> - Event TermboxEvent -> - Behavior (Int, Int) -> - (a -> IO ()) -> - MomentIO () -moment render program eEvent bSize abort = do - (bScene, eDone) :: (Behavior (Termbox.Cells, Termbox.Cursor), Event a) <- - program eEvent bSize - - eScene :: Event (Future (Termbox.Cells, Termbox.Cursor)) <- - changes bScene - - liftIO . render =<< valueB bScene - reactimate (abort <$> eDone) - reactimate' ((fmap . fmap) render eScene) - --- $example +-- ==== __👉 Quick start example__ -- --- Below is a sample program that simply displays the last key pressed, and --- quits on @Esc@: +-- This is a program that displays the last key pressed, and quits on @Esc@: -- -- @ --- {-\# LANGUAGE LambdaCase \#-} --- {-\# LANGUAGE ScopedTypeVariables \#-} +-- {-\# LANGUAGE LambdaCase \#-} -- -- module Main where -- +-- import Data.Void (Void) -- import Reactive.Banana -- import Reactive.Banana.Frameworks --- -- import qualified Termbox.Banana as Termbox -- -- main :: IO () @@ -164,42 +78,94 @@ -- Termbox.'run' moment -- -- moment --- :: Event Termbox.'Termbox.Event' +-- :: (Void -> IO ()) +-- -> Event (Termbox.'Event' Void) -- -> Behavior (Int, Int) -- -> MomentIO (Behavior (Termbox.'Termbox.Cells', Termbox.'Termbox.Cursor'), Event ()) --- moment eEvent _bSize = do --- let --- eQuit :: Event () --- eQuit = --- () <$ filterE isKeyEsc eEvent --- --- bLatestEvent :: Behavior (Maybe Termbox.'Termbox.Event') <- --- stepper --- Nothing --- (Just \<$\> eEvent) --- --- let --- bCells :: Behavior Termbox.'Termbox.Cells' --- bCells = --- maybe mempty renderEvent \<$\> bLatestEvent --- --- let --- bScene :: Behavior (Termbox.'Termbox.Cells', Termbox.'Termbox.Cursor') --- bScene = --- (,) --- \<$\> bCells --- \<*\> pure Termbox.'Termbox.NoCursor' --- +-- moment _fireUserEvent eEvent _bSize = do +-- let eQuit = () <$ filterE isKeyEsc eEvent +-- bLatestEvent <- stepper Nothing (Just \<$\> eEvent) +-- let bCells = maybe mempty renderEvent \<$\> bLatestEvent +-- let bScene = (,) \<$\> bCells \<*\> pure Termbox.'Termbox.NoCursor' -- pure (bScene, eQuit) -- --- renderEvent :: Termbox.'Termbox.Event' -> Termbox.'Termbox.Cells' +-- renderEvent :: Show a => Termbox.'Event' a -> Termbox.'Termbox.Cells' -- renderEvent = -- foldMap (\\(i, c) -> Termbox.set i 0 (Termbox.'Termbox.Cell' c mempty mempty)) -- . zip [0..] -- . show -- --- isKeyEsc :: Termbox.'Termbox.Event' -> Bool +-- isKeyEsc :: Termbox.'Event' a -> Bool -- isKeyEsc = \\case --- Termbox.'Termbox.EventKey' Termbox.'Termbox.KeyEsc' _ -> True +-- Termbox.'EventKey' Termbox.'Termbox.KeyEsc' -> True -- _ -> False -- @ + +-- | A key press, terminal resize, mouse click, or a user event. +data Event a + = EventKey !Termbox.Key + | EventResize !Int !Int + | EventMouse !Termbox.Mouse !Int !Int + | EventUser a + deriving stock (Eq, Ord, Show) + +type Program a b = + -- | Callback that produces a user event. + (a -> IO ()) -> + -- | Event stream. + Banana.Event (Event a) -> + -- | Time-varying terminal size (width, then height). + Banana.Behavior (Int, Int) -> + -- | The time-varying scene to render, and an event stream of arbitrary values, only the first of which is relevant, + -- which ends the @termbox@ program and returns from 'run'. + Banana.MomentIO (Banana.Behavior (Termbox.Cells, Termbox.Cursor), Banana.Event b) + +-- | Run a @termbox@ program. +run :: Program a b -> IO b +run program = + Termbox.run $ \initialWidth initialHeight render poll -> do + doneVar <- newEmptyMVar + (eventAddHandler, fireEvent) <- Banana.newAddHandler + (userEventAddHandler, fireUserEvent) <- Banana.newAddHandler + + network <- + Banana.compile $ do + eEvent <- Banana.fromAddHandler eventAddHandler + eUserEvent <- Banana.fromAddHandler userEventAddHandler + let eTermboxEvent = + Banana.unionWith + const + ( ( \case + Termbox.EventKey key -> EventKey key + Termbox.EventResize width height -> EventResize width height + Termbox.EventMouse mouse col row -> EventMouse mouse col row + ) + <$> eEvent + ) + (EventUser <$> eUserEvent) + + let eResize :: Banana.Event (Int, Int) + eResize = + Banana.filterJust + ( ( \case + Termbox.EventResize w h -> Just (w, h) + _ -> Nothing + ) + <$> eEvent + ) + + bSize <- Banana.stepper (initialWidth, initialHeight) eResize + (bScene, eDone) <- program fireUserEvent eTermboxEvent bSize + let bRender = (\(cells, cursor) -> render cells cursor) <$> bScene + eRender <- Banana.changes bRender + do + action <- Banana.valueB bRender + liftIO action + Banana.reactimate (putMVar doneVar <$> eDone) + Banana.reactimate' eRender + + Banana.actuate network + + fix $ \loop -> do + poll >>= fireEvent + tryReadMVar doneVar >>= maybe loop pure diff --git a/termbox-banana.cabal b/termbox-banana.cabal --- a/termbox-banana.cabal +++ b/termbox-banana.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: termbox-banana -version: 0.3.1 +version: 0.4.0 category: User Interfaces description: A @reactive-banana@-based interface to writing @termbox@ programs. @@ -29,10 +29,11 @@ library build-depends: - base ^>= 4.10 || ^>= 4.11 || ^>= 4.12 || ^>= 4.13 || ^>= 4.14 || ^>= 4.15 || ^>= 4.16, + base ^>= 4.11 || ^>= 4.12 || ^>= 4.13 || ^>= 4.14 || ^>= 4.15 || ^>= 4.16, reactive-banana ^>= 1.2 || ^>= 1.3, termbox ^>= 0.3, default-extensions: + DerivingStrategies GeneralizedNewtypeDeriving InstanceSigs LambdaCase @@ -50,4 +51,7 @@ ghc-options: -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + if impl(ghc >= 9.2) + ghc-options: + -Wno-missing-kind-signatures hs-source-dirs: src