diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for reflex-vty +## 1.1.0.0 + +* *Breaking change*: reflex-vty now builds on Windows. OS signals are handled through a platform-agnostic type called `AppSignal`. This changes `VtyApp`'s signal argument (`Event t AppSignal` instead of `Event t Signal` (synonym for `CInt`)). + ## 1.0.0.1 * Add some more examples, especially of the new canvas features diff --git a/reflex-vty.cabal b/reflex-vty.cabal --- a/reflex-vty.cabal +++ b/reflex-vty.cabal @@ -1,11 +1,11 @@ cabal-version: 3.0 name: reflex-vty -version: 1.0.0.1 +version: 1.1.0.0 synopsis: Reflex FRP host and widgets for VTY applications description: Build terminal applications using functional reactive programming (FRP) with Reflex FRP (). . - <> + <> license: BSD-3-Clause license-file: LICENSE author: Obsidian Systems LLC @@ -44,7 +44,8 @@ , Reflex.Vty.Widget.Text , Data.Text.Zipper , Control.Monad.NodeId - other-modules: Reflex.Vty.Host.Trigger + other-modules: Reflex.Vty.Host.Signal + , Reflex.Vty.Host.Trigger build-depends: base >= 4.10.0 && < 4.22, bimap >= 0.3.3 && < 0.6, @@ -65,9 +66,10 @@ ref-tf >= 0.4.0 && < 0.6, reflex >= 0.9.2 && < 1, time >= 1.8.0 && < 1.15, - unix >= 2.7 && < 2.10, - vty >= 6.0 && < 6.5, - vty-crossplatform >= 0.1 && < 0.5 + vty >= 6.0 && < 6.7, + vty-crossplatform >= 0.1 && < 0.6 + if !os(windows) + build-depends: unix >= 2.7 && < 2.10 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Reflex/Vty/Host.hs b/src/Reflex/Vty/Host.hs --- a/src/Reflex/Vty/Host.hs +++ b/src/Reflex/Vty/Host.hs @@ -11,7 +11,7 @@ , setCursorStyle , ScreenMode (..) , setScreenMode - , Signal + , AppSignal (..) , getDefaultVty , runVtyApp , runVtyAppWithHandle @@ -38,15 +38,11 @@ import qualified Graphics.Vty.CrossPlatform as V import Reflex import Reflex.Host.Class -import System.Posix.Signals - ( Handler (..) - , Signal - , installHandler - , sigHUP - , sigINT - , sigTERM - ) +import Reflex.Vty.Host.Signal + ( AppSignal (..) + , installAppSignalHandlers + ) import Reflex.Vty.Host.Trigger ( closeBoundedEventQueue , drainBoundedEventQueue @@ -101,9 +97,10 @@ -- ^ The initial display size (updates to this come as events) -> Event t V.Event -- ^ Vty input events. - -> Event t Signal - -- ^ POSIX signal events (SIGINT, SIGTERM, SIGHUP). All three automatically - -- trigger shutdown; apps can observe them for custom handling before exit. + -> Event t AppSignal + -- ^ OS signal events, normalized across platforms. 'AppSignal_Interrupt', + -- 'AppSignal_Terminate', and 'AppSignal_Hangup' all trigger shutdown. + -- NOTE: This behavior will be configurable in the future. -> m (VtyResult t) -- ^ The output of the 'VtyApp'. The application runs in a context that, -- among other things, allows new events to be created and triggered @@ -159,7 +156,7 @@ -- once, when the application starts. (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef - -- Create an 'Event' for POSIX signals. + -- Create an 'Event' for OS signals. (signalEvent, signalTriggerRef) <- newEventWithTriggerRef -- A bounded, closeable queue into which external triggers write their @@ -194,7 +191,7 @@ -- The guest app is provided the -- initial display region, an -- 'Event' of vty inputs, and an - -- 'Event' of POSIX signals. + -- 'Event' of OS signals. -- Reads the current value of the 'Picture' behavior and updates the -- display with it. This will be called whenever we determine that a @@ -219,7 +216,7 @@ -- request application shutdown. We'll check whether this 'Event' is firing -- to determine whether to terminate. SIGINT, SIGTERM, and SIGHUP from the -- host also trigger shutdown. - let sigShutdown = () <$ ffilter (\s -> s == sigINT || s == sigTERM || s == sigHUP) signalEvent + let sigShutdown = () <$ ffilter (\s -> s == AppSignal_Interrupt || s == AppSignal_Terminate || s == AppSignal_Hangup) signalEvent shutdown <- subscribeEvent $ leftmost [_vtyResult_shutdown vtyResult, sigShutdown] -- Fork a thread and continuously get the next vty input event, and then @@ -241,11 +238,9 @@ -- practice input never saturates it.) atomically $ writeBoundedEventQueue pending [triggerRef :=> triggerInvocation] - -- Install POSIX signal handlers. Each handler writes the signal value - -- into the bounded FRP event queue. The RTS runs 'Catch' actions in a - -- separate thread, so the STM write is safe here. - liftIO $ forM_ [sigINT, sigTERM, sigHUP] $ \sig -> - installHandler sig (Catch $ atomically $ writeBoundedEventQueue pending [EventTriggerRef signalTriggerRef :=> TriggerInvocation sig (return ())]) Nothing + -- Install OS signal handlers. + liftIO $ installAppSignalHandlers $ \appSignal -> + atomically $ writeBoundedEventQueue pending [EventTriggerRef signalTriggerRef :=> TriggerInvocation appSignal (return ())] -- The main application loop. We block until at least one batch of events -- is available, then drain every other batch that has accumulated in the diff --git a/src/Reflex/Vty/Host/Signal.hs b/src/Reflex/Vty/Host/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Host/Signal.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module: Reflex.Vty.Host.Signal +-- Description: Cross-platform OS signal handling for reflex-vty. +module Reflex.Vty.Host.Signal + ( AppSignal (..) + , installAppSignalHandlers + ) where + +import Foreign.C.Types (CInt) + +#if defined(mingw32_HOST_OS) +import Control.Monad (void) +import qualified GHC.ConsoleHandler as Console +#else +import Control.Monad (forM_) +import System.Posix.Signals (Handler (Catch), installHandler, sigHUP, sigINT, sigTERM) +#endif + +-- | An OS-level signal delivered to a running application. +-- +-- * 'AppSignal_Interrupt': POSIX @SIGINT@ or Windows @ControlC@ +-- * 'AppSignal_Terminate': POSIX @SIGTERM@ or Windows @Shutdown@ +-- * 'AppSignal_Hangup': POSIX @SIGHUP@ or Windows @Close@ or Windows @Logoff@ +-- +-- All other signals can be shoved into the 'AppSignal_Platform' escape hatch. +data AppSignal + = AppSignal_Interrupt + | AppSignal_Terminate + | AppSignal_Hangup + | AppSignal_Platform CInt + deriving (Eq, Show) + +-- | Install handlers for OS signals +installAppSignalHandlers :: (AppSignal -> IO ()) -> IO () + +#if defined(mingw32_HOST_OS) + +-- via 'GHC.ConsoleHandler' +installAppSignalHandlers fire = + void $ Console.installHandler $ Console.Catch (fire . toAppSignal) + where + toAppSignal :: Console.ConsoleEvent -> AppSignal + toAppSignal ev = case ev of + Console.ControlC -> AppSignal_Interrupt -- Ctrl-C: same intent as SIGINT. + Console.Break -> AppSignal_Interrupt -- Ctrl-Break: closest to an interrupt. + Console.Close -> AppSignal_Hangup -- console window closed: terminal going away. + Console.Logoff -> AppSignal_Hangup -- user logging off: session going away. + Console.Shutdown -> AppSignal_Terminate -- system shutting down: clean termination. + +#else + +installAppSignalHandlers fire = + forM_ signals $ \(sig, appSignal) -> + installHandler sig (Catch (fire appSignal)) Nothing + where + signals = + [ (sigINT, AppSignal_Interrupt) + , (sigTERM, AppSignal_Terminate) + , (sigHUP, AppSignal_Hangup) + ] + +#endif