rhine-terminal (empty) → 0.8.1
raw patch · 8 files changed
+429/−0 lines, 8 filesdep +basedep +dunaidep +exceptionssetup-changed
Dependencies added: base, dunai, exceptions, hspec, rhine, rhine-terminal, stm, terminal, text, time, transformers
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +9/−0
- Setup.hs +2/−0
- TerminalSimple.hs +110/−0
- rhine-terminal.cabal +83/−0
- src/FRP/Rhine/Terminal.hs +118/−0
- tests/Main.hs +72/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for rhine-terminal++## 0.8.1 -- 2022-05-21++* First version. Version numbers follow rhine.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Manuel Bärenz, Jun Matsushita++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Manuel Bärenz nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,9 @@+# README++This package provides an interface for the [`haskell-terminal` library](https://github.com/lpeterse/haskell-terminal), enabling you to write `terminal` applications as signal functions.++It consists of a `TerminalEventClock` which provides terminal events, a `flowTerminal` allowing you to run `Rhine`s which can receive terminal events and display to a terminal, as well as a `terminalConcurrently` schedule to coordinate multiple `Rhine`s.++It also probides a simple example program,+which you can run as `cabal run rhine-terminal-simple`+or `nix build .#rhine-terminal && result/bin/rhine-terminal-simple`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TerminalSimple.hs view
@@ -0,0 +1,110 @@+{- | Example application for the @rhine-terminal@ library. -}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- base+import Prelude hiding (putChar)+import System.Exit (exitSuccess)+import System.IO hiding (putChar)++-- text+import Data.Text (Text)+import qualified Data.Text as T++-- terminal+import System.Terminal+import System.Terminal.Internal++-- rhine+import FRP.Rhine++-- rhine-terminal+import FRP.Rhine.Terminal++type App = TerminalT LocalTerminal IO++-- Clocks++data Input+ = Char Char Modifiers+ | Space+ | Backspace+ | Enter+ | Exit++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+ }++type PromptClock = LiftClock IO (TerminalT LocalTerminal) (Millisecond 1000)++type AppClock = ParallelClock App InputClock PromptClock++-- ClSFs++inputSource :: ClSF App InputClock () Input+inputSource = tagS++promptSource :: ClSF App PromptClock () Text+promptSource = flip T.cons " > " . (cycle " ." !!) <$> count++inputSink :: ClSF App cl Input ()+inputSink = arrMCl $ \case+ Char c _ -> putChar c >> flush+ Space -> putChar ' ' >> flush+ Backspace -> moveCursorBackward 1 >> deleteChars 1 >> flush+ Enter -> putLn >> changePrompt " > " >> flush+ Exit -> do+ putLn+ putStringLn "Exiting program."+ flush+ liftIO exitSuccess++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+ flush++promptSink :: ClSF App cl Text ()+promptSink = arrMCl changePrompt++-- Rhines++mainRhine :: Rhine App AppClock () ()+mainRhine = inputRhine ||@ terminalConcurrently @|| promptRhine+ where+ inputRhine :: Rhine App InputClock () ()+ inputRhine = inputSource >-> inputSink @@ inputClock++ promptRhine :: Rhine App PromptClock () ()+ promptRhine = promptSource >-> promptSink @@ liftClock waitClock++-- Main++main :: IO ()+main = do+ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ withTerminal $ \term -> flowTerminal term mainRhine
+ rhine-terminal.cabal view
@@ -0,0 +1,83 @@+-- Initial rhine-gloss.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: rhine-terminal+version: 0.8.1+synopsis: Terminal backend for Rhine+description:+ This package provides an example of a `terminal` based program using rhine.+license: BSD3+license-file: LICENSE+author: Manuel Bärenz, Jun Matsushita+maintainer: programming@manuelbaerenz.de, jun@iilab.org+-- copyright:+category: FRP+build-type: Simple+extra-source-files: ChangeLog.md+extra-doc-files: README.md+cabal-version: 1.18++source-repository head+ type: git+ location: https://github.com/turion/rhine.git++source-repository this+ type: git+ location: https://github.com/turion/rhine.git+ tag: v0.8.1++library+ exposed-modules:+ FRP.Rhine.Terminal+ build-depends: base >= 4.11 && < 4.17+ , exceptions >= 0.10.4+ , transformers >= 0.5+ , rhine == 0.8.1+ , dunai >= 0.6+ , terminal >= 0.2.0.0+ , time >= 1.9.3+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -W+ if flag(dev)+ ghc-options: -Werror++executable rhine-terminal-simple+ main-is: TerminalSimple.hs+ ghc-options: -threaded+ build-depends: base >= 4.11 && < 4.17+ , rhine == 0.8.1+ , rhine-terminal+ , terminal >= 0.2.0.0+ , text >= 1.2.5.0+ , time >= 1.9.3++ default-language: Haskell2010+ ghc-options: -W -threaded -rtsopts -with-rtsopts=-N+ if flag(dev)+ ghc-options: -Werror++test-suite rhine-terminal-tests+ type: exitcode-stdio-1.0+ main-is: tests/Main.hs+ ghc-options: -threaded+ build-depends: base >= 4.11 && < 4.17+ , rhine == 0.8.1+ , rhine-terminal+ , exceptions >= 0.10.4+ , transformers >= 0.5+ , terminal >= 0.2.0.0+ , text >= 1.2.5.0+ , time >= 1.9.3+ , stm >= 2.5.0+ , hspec++ default-language: Haskell2010+ ghc-options: -W -threaded -rtsopts -with-rtsopts=-N+ if flag(dev)+ ghc-options: -Werror++flag dev+ description: Enable warnings as errors. Active on ci.+ default: False+ manual: True
+ src/FRP/Rhine/Terminal.hs view
@@ -0,0 +1,118 @@+{- | Wrapper to write @terminal@ applications in Rhine, using concurrency.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+module FRP.Rhine.Terminal+ ( TerminalEventClock (..)+ , flowTerminal+ , terminalConcurrently+ ) where++-- base+import Prelude hiding (putChar)+import Unsafe.Coerce (unsafeCoerce)++-- exceptions+import Control.Monad.Catch (MonadMask)++-- time+import Data.Time.Clock ( getCurrentTime )++-- terminal+import System.Terminal ( awaitEvent, runTerminalT, Event, Interrupt, TerminalT, MonadInput )+import System.Terminal.Internal ( Terminal )++-- transformers+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class (lift)++-- rhine+import FRP.Rhine++-- | 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++ 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+-- @++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)++-- Workaround TerminalT constructor not being exported. Should be safe in practice.+-- See PR upstream https://github.com/lpeterse/haskell-terminal/pull/18+terminalT :: ReaderT t m a -> TerminalT t m a+terminalT = unsafeCoerce++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+ , ..+ }
+ tests/Main.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-}+module Main where++-- base+import Prelude hiding (putChar)+import GHC.Conc (retry, readTVarIO, atomically)+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (void)++-- rhine+import FRP.Rhine+import FRP.Rhine.Terminal++-- terminal+import System.Terminal+import System.Terminal.Internal++-- stm+import Control.Concurrent.STM.TQueue++-- hspec+import Test.Hspec++type KeyClock = SelectClock TerminalEventClock Char++keyClock :: KeyClock+keyClock = SelectClock { mainClock = TerminalEventClock , select }+ where+ select :: Tag TerminalEventClock -> Maybe Char+ select (Right (KeyEvent (CharKey k) _)) = Just k+ select _ = Nothing++defaultSettings :: TQueue Event -> VirtualTerminalSettings+defaultSettings eventQueue = VirtualTerminalSettings+ { virtualType = "xterm"+ , virtualWindowSize = pure (Size 3 10)+ , virtualEvent = readTQueue eventQueue+ , virtualInterrupt = retry+ }++displayDot :: MonadScreen m => ClSF m KeyClock () ()+displayDot = constMCl $ do+ putChar '.'+ flush++testRhine :: Terminal t => Rhine (TerminalT t IO) KeyClock () ()+testRhine = displayDot @@ keyClock++charEvent :: TQueue Event -> t -> Char -> IO ()+charEvent eventQueue _ char = do+ atomically $ writeTQueue eventQueue $ KeyEvent (CharKey char) mempty++main :: IO ()+main = hspec $ do+ describe "rhine-terminal with VirtualTerminal" $ do+ it "reaplces virtual inputs by dots" $ do+ eventQueue <- newTQueueIO+ withVirtualTerminal (defaultSettings eventQueue) $ \t -> do+ void $ liftIO $ forkIO $ flowTerminal t testRhine+ charEvent eventQueue t '1'+ threadDelay $ 200 * 1000+ charEvent eventQueue t '2'+ threadDelay $ 200 * 1000+ charEvent eventQueue t '3'+ threadDelay $ 200 * 1000+ readTVarIO (virtualWindow t) `shouldReturn` expWindow+ where+ expWindow =+ [ "... "+ , " "+ , " " ]