diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for rhine-terminal + +## 0.8.1 -- 2022-05-21 + +* First version. Version numbers follow rhine. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TerminalSimple.hs b/TerminalSimple.hs new file mode 100644 --- /dev/null +++ b/TerminalSimple.hs @@ -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 diff --git a/rhine-terminal.cabal b/rhine-terminal.cabal new file mode 100644 --- /dev/null +++ b/rhine-terminal.cabal @@ -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 diff --git a/src/FRP/Rhine/Terminal.hs b/src/FRP/Rhine/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Terminal.hs @@ -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 + , .. + } diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 = + [ "... " + , " " + , " " ]