[commit: packages/haskeline] master: Adding threadsafe (in terminal-style interaction) ^Cternal print function. (53c735d)
git at git.haskell.org
git at git.haskell.org
Tue Dec 13 19:21:38 UTC 2016
Repository : ssh://git@git.haskell.org/haskeline
On branch : master
Link : http://git.haskell.org/packages/haskeline.git/commitdiff/53c735d48d79a703ca3d9faf548f391d03e9b68c
>---------------------------------------------------------------
commit 53c735d48d79a703ca3d9faf548f391d03e9b68c
Author: Bakhtiyar Neyman <bneymanov at gmail.com>
Date: Sat Feb 13 22:39:46 2016 -0800
Adding threadsafe (in terminal-style interaction) ^Cternal print function.
>---------------------------------------------------------------
53c735d48d79a703ca3d9faf548f391d03e9b68c
System/Console/Haskeline.hs | 11 +++++++++++
System/Console/Haskeline/Backend/Posix.hsc | 23 +++++++++++++++++++++--
System/Console/Haskeline/RunCommand.hs | 8 ++++++++
System/Console/Haskeline/Term.hs | 21 +++++++++++++--------
haskeline.cabal | 2 +-
5 files changed, 54 insertions(+), 11 deletions(-)
diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs
index 058ad8b..fe2cf5e 100644
--- a/System/Console/Haskeline.hs
+++ b/System/Console/Haskeline.hs
@@ -51,6 +51,7 @@ module System.Console.Haskeline(
-- $outputfncs
outputStr,
outputStrLn,
+ getExternalPrint,
-- * Customization
-- ** Settings
Settings(..),
@@ -318,3 +319,13 @@ withInterrupt act = do
-- > handleInterrupt f = handle $ \Interrupt -> f
handleInterrupt :: MonadException m => m a -> m a -> m a
handleInterrupt f = handle $ \Interrupt -> f
+
+-- | Return a print function, which is thread-safe and preserves prompt in terminal-style interaction.
+
+getExternalPrint :: MonadException m => InputT m (String -> IO ())
+getExternalPrint = do
+ rterm <- InputT ask
+ return $ case termOps rterm of
+ Right _ -> putStrOut rterm
+ Left tops -> externalPrint tops
+
\ No newline at end of file
diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc
index a028629..c8d7b14 100644
--- a/System/Console/Haskeline/Backend/Posix.hsc
+++ b/System/Console/Haskeline/Backend/Posix.hsc
@@ -281,8 +281,7 @@ posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do
fileRT <- posixFileRunTerm hs
(enc,dec) <- newEncoders
return fileRT
- { closeTerm = closeTerm fileRT
- , termOps = Left TermOps
+ { termOps = Left TermOps
{ getLayout = tryGetLayouts layoutGetters
, withGetEvent = wrapGetEvent
. withPosixGetEvent ch hs dec
@@ -292,9 +291,29 @@ posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do
(runPosixT enc hs)
(lift . lift)
evalBackend
+ , externalPrint = writeChan ch . ExternalPrint
}
+ , closeTerm = do
+ -- This hack is needed to grab latest writes from some other thread.
+ -- Without it, if you are using another thread to process the logging
+ -- and write on screen via exposed externalPrint, latest writes from
+ -- this thread are not able to cross the thread boundary in time.
+ threadDelay 1
+ flushEventQueue (putStrOut fileRT) ch
+ closeTerm fileRT
}
+flushEventQueue :: (String -> IO ()) -> Chan Event -> IO ()
+flushEventQueue print' eventChan = loop
+ where loop = do
+ flushed <- isEmptyChan eventChan
+ if flushed then return () else do
+ event <- readChan eventChan
+ case event of
+ ExternalPrint str -> do
+ print' (str ++ "\n") >> loop
+ _ -> do loop
+
type PosixT m = ReaderT Encoder (ReaderT Handles m)
runPosixT :: Monad m => Encoder -> Handles -> PosixT m a -> m a
diff --git a/System/Console/Haskeline/RunCommand.hs b/System/Console/Haskeline/RunCommand.hs
index 33c81dd..45472f6 100644
--- a/System/Console/Haskeline/RunCommand.hs
+++ b/System/Console/Haskeline/RunCommand.hs
@@ -40,6 +40,9 @@ runCommandLoop' liftE tops prefix initState cmds getEvent = do
KeyInput ks -> do
bound_ks <- mapM (asks . lookupKeyBinding) ks
loopCmd s $ applyKeysToMap (concat bound_ks) next
+ ExternalPrint str -> do
+ printPreservingLineChars s str
+ readMoreKeys s next
loopCmd :: LineChars -> CmdM m (a,[Key]) -> n a
loopCmd s (GetKey next) = readMoreKeys s next
@@ -57,6 +60,11 @@ runCommandLoop' liftE tops prefix initState cmds getEvent = do
moveToNextLine s
return x
+printPreservingLineChars :: Term m => LineChars -> String -> m ()
+printPreservingLineChars s str = do
+ clearLine s
+ printLines . lines $ str
+ drawLine s
drawReposition :: (Term n, MonadState Layout m)
=> (forall a . m a -> n a) -> TermOps -> LineChars -> n ()
diff --git a/System/Console/Haskeline/Term.hs b/System/Console/Haskeline/Term.hs
index 9689a16..0e60278 100644
--- a/System/Console/Haskeline/Term.hs
+++ b/System/Console/Haskeline/Term.hs
@@ -38,12 +38,13 @@ data RunTerm = RunTerm {
}
-- | Operations needed for terminal-style interaction.
-data TermOps = TermOps {
- getLayout :: IO Layout
- , withGetEvent :: forall m a . CommandMonad m => (m Event -> m a) -> m a
- , evalTerm :: forall m . CommandMonad m => EvalTerm m
- , saveUnusedKeys :: [Key] -> IO ()
- }
+data TermOps = TermOps
+ { getLayout :: IO Layout
+ , withGetEvent :: forall m a . CommandMonad m => (m Event -> m a) -> m a
+ , evalTerm :: forall m . CommandMonad m => EvalTerm m
+ , saveUnusedKeys :: [Key] -> IO ()
+ , externalPrint :: String -> IO ()
+ }
-- | Operations needed for file-style interaction.
--
@@ -96,8 +97,12 @@ matchInit :: Eq a => [a] -> [a] -> ([a],[a])
matchInit (x:xs) (y:ys) | x == y = matchInit xs ys
matchInit xs ys = (xs,ys)
-data Event = WindowResize | KeyInput [Key] | ErrorEvent SomeException
- deriving Show
+data Event
+ = WindowResize
+ | KeyInput [Key]
+ | ErrorEvent SomeException
+ | ExternalPrint String
+ deriving Show
keyEventLoop :: IO [Event] -> Chan Event -> IO Event
keyEventLoop readEvents eventChan = do
diff --git a/haskeline.cabal b/haskeline.cabal
index 7402b6d..a5fc2bc 100644
--- a/haskeline.cabal
+++ b/haskeline.cabal
@@ -1,6 +1,6 @@
Name: haskeline
Cabal-Version: >=1.10
-Version: 0.7.2.2
+Version: 0.7.2.3
Category: User Interfaces
License: BSD3
License-File: LICENSE
More information about the ghc-commits
mailing list