diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/TerminalSimple.hs b/TerminalSimple.hs --- a/TerminalSimple.hs +++ b/TerminalSimple.hs @@ -1,16 +1,18 @@ -{- | Example application for the @rhine-terminal@ library. -} - {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | Example application for the @rhine-terminal@ library. +module Main where + -- base -import Prelude hiding (putChar) + import System.Exit (exitSuccess) import System.IO hiding (putChar) +import Prelude hiding (putChar) -- text import Data.Text (Text) @@ -40,18 +42,19 @@ type InputClock = SelectClock TerminalEventClock Input inputClock :: InputClock -inputClock = SelectClock - { mainClock = TerminalEventClock - , select = \case - Right (KeyEvent (CharKey k) m) - -- Don't display Ctrl-J https://github.com/lpeterse/haskell-terminal/issues/17 - | k /= 'J' || m /= ctrlKey -> Just (Char k m) - Right (KeyEvent SpaceKey _) -> Just Space - Right (KeyEvent BackspaceKey _) -> Just Backspace - Right (KeyEvent EnterKey _) -> Just Enter - Left _ -> Just Exit - _ -> Nothing - } +inputClock = + SelectClock + { mainClock = TerminalEventClock + , select = \case + Right (KeyEvent (CharKey k) m) + -- Don't display Ctrl-J https://github.com/lpeterse/haskell-terminal/issues/17 + | k /= 'J' || m /= ctrlKey -> Just (Char k m) + Right (KeyEvent SpaceKey _) -> Just Space + Right (KeyEvent BackspaceKey _) -> Just Backspace + Right (KeyEvent EnterKey _) -> Just Enter + Left _ -> Just Exit + _ -> Nothing + } type PromptClock = LiftClock IO (TerminalT LocalTerminal) (Millisecond 1000) @@ -65,13 +68,13 @@ promptSource :: ClSF App PromptClock () Text promptSource = flip T.cons " > " . (cycle " ." !!) <$> count -inputSink :: ClSF App cl Input () +inputSink :: ClSF App cl Input () inputSink = arrMCl $ \case - Char c _ -> putChar c >> flush - Space -> putChar ' ' >> flush + Char c _ -> putChar c >> flush + Space -> putChar ' ' >> flush Backspace -> moveCursorBackward 1 >> deleteChars 1 >> flush - Enter -> putLn >> changePrompt " > " >> flush - Exit -> do + Enter -> putLn >> changePrompt " > " >> flush + Exit -> do putLn putStringLn "Exiting program." flush @@ -80,11 +83,12 @@ changePrompt :: MonadScreen m => Text -> m () changePrompt prmpt = do Position _ column <- getCursorPosition - if column /= 0 then do - moveCursorBackward column - putText prmpt - setCursorColumn column - else putText prmpt + if column /= 0 + then do + moveCursorBackward column + putText prmpt + setCursorColumn column + else putText prmpt flush promptSink :: ClSF App cl Text () diff --git a/rhine-terminal.cabal b/rhine-terminal.cabal --- a/rhine-terminal.cabal +++ b/rhine-terminal.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: rhine-terminal -version: 0.8.1.1 +version: 0.9 synopsis: Terminal backend for Rhine description: This package provides an example of a `terminal` based program using rhine. @@ -15,7 +15,7 @@ build-type: Simple extra-source-files: ChangeLog.md extra-doc-files: README.md -cabal-version: 1.18 +cabal-version: 2.0 source-repository head type: git @@ -24,7 +24,7 @@ source-repository this type: git location: https://github.com/turion/rhine.git - tag: v0.8.1.1 + tag: v0.9 library exposed-modules: @@ -32,8 +32,8 @@ build-depends: base >= 4.11 && < 4.18 , exceptions >= 0.10.4 , transformers >= 0.5 - , rhine == 0.8.1.1 - , dunai >= 0.8 + , rhine == 0.9 + , dunai ^>= 0.9 , terminal >= 0.2.0.0 , time >= 1.9.3 hs-source-dirs: src @@ -48,7 +48,7 @@ main-is: TerminalSimple.hs ghc-options: -threaded build-depends: base >= 4.14 && < 4.18 - , rhine == 0.8.1.1 + , rhine == 0.9 , rhine-terminal , terminal >= 0.2.0.0 , text >= 1.2.5.0 @@ -66,7 +66,7 @@ main-is: tests/Main.hs ghc-options: -threaded build-depends: base >= 4.14 && < 4.18 - , rhine == 0.8.1.1 + , rhine == 0.9 , rhine-terminal , exceptions >= 0.10.4 , transformers >= 0.5 diff --git a/src/FRP/Rhine/Terminal.hs b/src/FRP/Rhine/Terminal.hs --- a/src/FRP/Rhine/Terminal.hs +++ b/src/FRP/Rhine/Terminal.hs @@ -1,35 +1,36 @@ -{- | Wrapper to write @terminal@ applications in Rhine, using concurrency. --} - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RecordWildCards #-} -module FRP.Rhine.Terminal - ( TerminalEventClock (..) - , flowTerminal - , terminalConcurrently - ) where +-- | Wrapper to write @terminal@ applications in Rhine, using concurrency. +module FRP.Rhine.Terminal ( + TerminalEventClock (..), + flowTerminal, + terminalConcurrently, +) where + -- base -import Prelude hiding (putChar) + import Unsafe.Coerce (unsafeCoerce) +import Prelude hiding (putChar) -- exceptions import Control.Monad.Catch (MonadMask) -- time -import Data.Time.Clock ( getCurrentTime ) +import Data.Time.Clock (getCurrentTime) -- terminal -import System.Terminal ( awaitEvent, runTerminalT, Event, Interrupt, TerminalT, MonadInput ) -import System.Terminal.Internal ( Terminal ) +import System.Terminal (Event, Interrupt, MonadInput, TerminalT, awaitEvent, runTerminalT) +import System.Terminal.Internal (Terminal) -- transformers -import Control.Monad.Trans.Reader + import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader -- rhine import FRP.Rhine @@ -37,68 +38,69 @@ -- | A clock that ticks whenever events or interrupts on the terminal arrive. data TerminalEventClock = TerminalEventClock -instance (MonadInput m, MonadIO m) => Clock m TerminalEventClock - where - type Time TerminalEventClock = UTCTime - type Tag TerminalEventClock = Either Interrupt Event +instance (MonadInput m, MonadIO m) => Clock m TerminalEventClock where + type Time TerminalEventClock = UTCTime + type Tag TerminalEventClock = Either Interrupt Event - initClock TerminalEventClock = do - initialTime <- liftIO getCurrentTime - return - ( constM $ do - event <- awaitEvent - time <- liftIO getCurrentTime - return (time, event) - , initialTime - ) + initClock TerminalEventClock = do + initialTime <- liftIO getCurrentTime + return + ( constM $ do + event <- awaitEvent + time <- liftIO getCurrentTime + return (time, event) + , initialTime + ) instance GetClockProxy TerminalEventClock instance Semigroup TerminalEventClock where t <> _ = t --- | A function wrapping `flow` to use at the top level --- in order to run a `Rhine (TerminalT t m) cl ()` --- --- Example: --- --- @ --- mainRhine :: MonadIO m => Rhine (TerminalT LocalTerminal m) TerminalEventClock () () --- mainRhine = tagS >-> arrMCl (liftIO . print) @@ TerminalEventClock --- --- main :: IO () --- main = withTerminal $ \term -> `flowTerminal` term mainRhine --- @ +{- | A function wrapping `flow` to use at the top level + in order to run a `Rhine (TerminalT t m) cl ()` -flowTerminal - :: ( MonadIO m - , MonadMask m - , Terminal t - , Clock (TerminalT t m) cl - , GetClockProxy cl - , Time cl ~ Time (In cl) - , Time cl ~ Time (Out cl) - ) - => t - -> Rhine (TerminalT t m) cl () () - -> m () + Example: + + @ + mainRhine :: MonadIO m => Rhine (TerminalT LocalTerminal m) TerminalEventClock () () + mainRhine = tagS >-> arrMCl (liftIO . print) @@ TerminalEventClock + + main :: IO () + main = withTerminal $ \term -> `flowTerminal` term mainRhine + @ +-} +flowTerminal :: + ( MonadIO m + , MonadMask m + , Terminal t + , Clock (TerminalT t m) cl + , GetClockProxy cl + , Time cl ~ Time (In cl) + , Time cl ~ Time (Out cl) + ) => + t -> + Rhine (TerminalT t m) cl () () -> + m () flowTerminal term clsf = flip runTerminalT term $ flow clsf --- | A schedule in the 'TerminalT LocalTerminal' transformer, --- supplying the same backend connection to its scheduled clocks. -terminalConcurrently - :: forall t cl1 cl2. ( - Terminal t - , Clock (TerminalT t IO) cl1 - , Clock (TerminalT t IO) cl2 - , Time cl1 ~ Time cl2 - ) - => Schedule (TerminalT t IO) cl1 cl2 -terminalConcurrently - = Schedule $ \cl1 cl2 -> do - term <- terminalT ask - lift $ first liftTransS <$> - initSchedule concurrently (runTerminalClock term cl1) (runTerminalClock term cl2) +{- | A schedule in the 'TerminalT LocalTerminal' transformer, + supplying the same backend connection to its scheduled clocks. +-} +terminalConcurrently :: + forall t cl1 cl2. + ( Terminal t + , Clock (TerminalT t IO) cl1 + , Clock (TerminalT t IO) cl2 + , Time cl1 ~ Time cl2 + ) => + Schedule (TerminalT t IO) cl1 cl2 +terminalConcurrently = + Schedule $ \cl1 cl2 -> do + term <- terminalT ask + lift $ + first liftTransS + <$> initSchedule concurrently (runTerminalClock term cl1) (runTerminalClock term cl2) -- Workaround TerminalT constructor not being exported. Should be safe in practice. -- See PR upstream https://github.com/lpeterse/haskell-terminal/pull/18 @@ -107,12 +109,13 @@ type RunTerminalClock m t cl = HoistClock (TerminalT t m) m cl -runTerminalClock - :: Terminal t - => t - -> cl - -> RunTerminalClock IO t cl -runTerminalClock term unhoistedClock = HoistClock - { monadMorphism = flip runTerminalT term - , .. - } +runTerminalClock :: + Terminal t => + t -> + cl -> + RunTerminalClock IO t cl +runTerminalClock term unhoistedClock = + HoistClock + { monadMorphism = flip runTerminalT term + , .. + } diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + module Main where -- base -import Prelude hiding (putChar) -import GHC.Conc (retry, readTVarIO, atomically) import Control.Concurrent (forkIO, threadDelay) import Control.Monad (void) +import GHC.Conc (atomically, readTVarIO, retry) +import Prelude hiding (putChar) -- rhine import FRP.Rhine @@ -25,19 +26,20 @@ type KeyClock = SelectClock TerminalEventClock Char keyClock :: KeyClock -keyClock = SelectClock { mainClock = TerminalEventClock , select } +keyClock = SelectClock {mainClock = TerminalEventClock, select} where select :: Tag TerminalEventClock -> Maybe Char select (Right (KeyEvent (CharKey k) _)) = Just k - select _ = Nothing + select _ = Nothing defaultSettings :: TQueue Event -> VirtualTerminalSettings -defaultSettings eventQueue = VirtualTerminalSettings - { virtualType = "xterm" - , virtualWindowSize = pure (Size 3 10) - , virtualEvent = readTQueue eventQueue - , virtualInterrupt = retry - } +defaultSettings eventQueue = + VirtualTerminalSettings + { virtualType = "xterm" + , virtualWindowSize = pure (Size 3 10) + , virtualEvent = readTQueue eventQueue + , virtualInterrupt = retry + } displayDot :: MonadScreen m => ClSF m KeyClock () () displayDot = constMCl $ do @@ -65,8 +67,9 @@ charEvent eventQueue t '3' threadDelay $ 200 * 1000 readTVarIO (virtualWindow t) `shouldReturn` expWindow - where - expWindow = - [ "... " - , " " - , " " ] + where + expWindow = + [ "... " + , " " + , " " + ]