rhine-terminal 0.8.1.1 → 0.9
raw patch · 5 files changed
+135/−124 lines, 5 filesdep ~dunaidep ~rhinesetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: dunai, rhine
API changes (from Hackage documentation)
Files
- Setup.hs +1/−0
- TerminalSimple.hs +30/−26
- rhine-terminal.cabal +7/−7
- src/FRP/Rhine/Terminal.hs +78/−75
- tests/Main.hs +19/−16
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
TerminalSimple.hs view
@@ -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 ()
rhine-terminal.cabal view
@@ -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
src/FRP/Rhine/Terminal.hs view
@@ -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+ , ..+ }
tests/Main.hs view
@@ -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 =+ [ "... "+ , " "+ , " "+ ]