rhine-terminal backend with haskell-terminal library and Repl like example

flake.nix

@@ -33,6 +33,6 @@ outputs = { self, nixpkgs, flake-utils, haskell-flake-utils, flake-compat, ... }
     ];
 
     name = "rhine";
-    packageNames = [ "rhine-gloss" "rhine-examples" ];
+    packageNames = [ "rhine-gloss" "rhine-terminal" "rhine-examples" ];
   };
 }

rhine-terminal/ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for rhine-terminal
+
+## 0.8.0.1 -- 2022-05-21
+
+* First version. Version numbers follow rhine.

rhine-terminal/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.

rhine-terminal/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`.

rhine-terminal/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

rhine-terminal/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

rhine-terminal/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.0.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: git@github.com:turion/rhine.git
+
+source-repository this
+  type:     git
+  location: git@github.com:turion/rhine.git
+  tag:      v0.8.0.1
+
+library
+  exposed-modules:
+    FRP.Rhine.Terminal
+  build-depends:       base         >= 4.11 && < 4.16
+                     , exceptions   >= 0.10.4
+                     , transformers >= 0.5
+                     , rhine        == 0.8.0.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.16
+                     , rhine        == 0.8.0.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.16
+                     , rhine        == 0.8.0.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

rhine-terminal/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
+  , ..
+  }