Merge branch 'master' into bump-lower-dep

Conflicts:
	README.md
	System/Console/Haskeline/Backend/Posix.hsc
	haskeline.cabal

README.md

@@ -12,7 +12,7 @@ The most recent development source code can be downloaded with:
     git clone https://github.com/judah/haskeline
 
 Further documentation is also available at
-[[https://github.com/judah/haskeline/wiki]].
+[https://github.com/judah/haskeline/wiki](https://github.com/judah/haskeline/wiki)
 
 
 ##Features:

System/Console/Haskeline.hs

-{- | 
+{- |
 
 A rich user interface for line input in command-line programs.  Haskeline is
-Unicode-aware and runs both on POSIX-compatible systems and on Windows.  
+Unicode-aware and runs both on POSIX-compatible systems and on Windows.
 
 Users may customize the interface with a @~/.haskeline@ file; see
 <http://trac.haskell.org/haskeline/wiki/UserPrefs> for more information.
@@ -10,10 +10,10 @@ An example use of this library for a simple read-eval-print loop (REPL) is the
 following:
 
 > import System.Console.Haskeline
-> 
+>
 > main :: IO ()
 > main = runInputT defaultSettings loop
->    where 
+>    where
 >        loop :: InputT IO ()
 >        loop = do
 >            minput <- getInputLine "% "
@@ -51,6 +51,7 @@ module System.Console.Haskeline(
                     -- $outputfncs
                     outputStr,
                     outputStrLn,
+                    getExternalPrint,
                     -- * Customization
                     -- ** Settings
                     Settings(..),
@@ -183,7 +184,7 @@ maybeAddHistory result = do
     settings :: Settings m <- InputT ask
     histDupes <- InputT $ asks historyDuplicates
     case result of
-        Just line | autoAddHistory settings && not (all isSpace line) 
+        Just line | autoAddHistory settings && not (all isSpace line)
             -> let adder = case histDupes of
                         AlwaysAdd -> addHistory
                         IgnoreConsecutive -> addHistoryUnlessConsecutiveDupe
@@ -214,9 +215,9 @@ getPrintableChar fops = do
     case fmap isPrint c of
         Just False -> getPrintableChar fops
         _ -> return c
-        
+
 getInputCmdChar :: MonadException m => TermOps -> String -> InputT m (Maybe Char)
-getInputCmdChar tops prefix = runInputCmdT tops 
+getInputCmdChar tops prefix = runInputCmdT tops
         $ runCommandLoop tops prefix acceptOneChar emptyIM
 
 acceptOneChar :: Monad m => KeyCommand m InsertMode (Maybe Char)
@@ -235,7 +236,7 @@ When using terminal-style interaction, the masking character (if given) will rep
 When using file-style interaction, this function turns off echoing while reading
 the line of input.
 -}
- 
+
 getPassword :: MonadException m => Maybe Char -- ^ A masking character; e.g., @Just \'*\'@
                             -> String -> InputT m (Maybe String)
 getPassword x = promptedInput
@@ -256,7 +257,7 @@ getPassword x = promptedInput
                      , ctrlChar 'l' +> clearScreenCmd >|> loop'
                      ]
     loop' = keyCommand loop
-                        
+
 {- $history
 The 'InputT' monad transformer provides direct, low-level access to the user's line history state.
 
@@ -302,7 +303,7 @@ every time Ctrl-C is pressed.
 > tryAction = wrapInterrupt loop
 >     where loop = handle (\Interrupt -> outputStrLn "Cancelled; try again." >> loop)
 >                    someLongAction
- 
+
 This behavior differs from GHC's built-in Ctrl-C handling, which
 may immediately terminate the program after the second time that the user presses
 Ctrl-C.
@@ -313,8 +314,18 @@ withInterrupt act = do
     rterm <- InputT ask
     liftIOOp_ (wrapInterrupt rterm) act
 
--- | Catch and handle an exception of type 'Interrupt'.  
+-- | Catch and handle an exception of type 'Interrupt'.
 --
 -- > handleInterrupt f = handle $ \Interrupt -> f
 handleInterrupt :: MonadException m => m a -> m a -> m a
 handleInterrupt f = handle $ \Interrupt -> f
+
+{- | Return a printing function, which in terminal-style interactions is
+thread-safe and may be run concurrently with user input without affecting the
+prompt. -}
+getExternalPrint :: MonadException m => InputT m (String -> IO ())
+getExternalPrint = do
+    rterm <- InputT ask
+    return $ case termOps rterm of
+        Right _ -> putStrOut rterm
+        Left tops -> externalPrint tops

System/Console/Haskeline/Backend/Posix.hsc

@@ -149,7 +149,7 @@ sttyKeys h = do
     attrs <- getTerminalAttributes (Fd fd)
     let getStty (k,c) = do {str <- controlChar attrs k; return ([str],c)}
     return $ catMaybes $ map getStty [(Erase,simpleKey Backspace),(Kill,simpleKey KillLine)]
-                        
+
 newtype TreeMap a b = TreeMap (Map.Map a (Maybe b, TreeMap a b))
                         deriving Show
 
@@ -200,7 +200,7 @@ lookupChars (TreeMap tm) (c:cs) = case Map.lookup c tm of
 
 -----------------------------
 
-withPosixGetEvent :: (MonadException m, MonadReader Prefs m) 
+withPosixGetEvent :: (MonadException m, MonadReader Prefs m)
         => Chan Event -> Handles -> [(String,Key)]
                 -> (m Event -> m a) -> m a
 withPosixGetEvent eventChan h termKeys f = wrapTerminalOps h $ do
@@ -209,13 +209,13 @@ withPosixGetEvent eventChan h termKeys f = wrapTerminalOps h $ do
         $ f $ liftIO $ getEvent (ehIn h) baseMap eventChan
 
 withWindowHandler :: MonadException m => Chan Event -> m a -> m a
-withWindowHandler eventChan = withHandler windowChange $ 
+withWindowHandler eventChan = withHandler windowChange $
     Catch $ writeChan eventChan WindowResize
 
 withSigIntHandler :: MonadException m => m a -> m a
 withSigIntHandler f = do
-    tid <- liftIO myThreadId 
-    withHandler keyboardSignal 
+    tid <- liftIO myThreadId
+    withHandler keyboardSignal
             (Catch (throwTo tid Interrupt))
             f
 
@@ -274,7 +274,7 @@ openTerm mode = handle (\(_::IOException) -> mzero)
             $ liftIO $ openInCodingMode "/dev/tty" mode
 
 
-posixRunTerm :: 
+posixRunTerm ::
     Handles
     -> [IO (Maybe Layout)]
     -> [(String,Key)]
@@ -285,16 +285,19 @@ posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do
     ch <- newChan
     fileRT <- posixFileRunTerm hs
     return fileRT
-                { closeTerm = closeTerm fileRT
-                , termOps = Left TermOps
+                { termOps = Left TermOps
                             { getLayout = tryGetLayouts layoutGetters
-                            , withGetEvent = wrapGetEvent 
+                            , withGetEvent = wrapGetEvent
                                             . withPosixGetEvent ch hs
                                                 keys
                             , saveUnusedKeys = saveKeys ch
-                            , evalTerm =
-                                    mapEvalTerm (runPosixT hs) lift evalBackend
+                            , evalTerm = mapEvalTerm
+                                            (runPosixT hs) lift evalBackend
+                            , externalPrint = writeChan ch . ExternalPrint
                             }
+                , closeTerm = do
+                    flushEventQueue (putStrOut fileRT) ch
+                    closeTerm fileRT
                 }
 
 type PosixT m = ReaderT Handles m

System/Console/Haskeline/Backend/Win32.hsc

@@ -380,17 +380,20 @@ win32Term = do
     hs <- consoleHandles
     ch <- liftIO newChan
     fileRT <- liftIO $ fileRunTerm stdin
-    return fileRT {
-                            termOps = Left TermOps {
-                                getLayout = getBufferSize (hOut hs)
-                                , withGetEvent = withWindowMode hs
-                                                    . win32WithEvent hs ch
-                                , saveUnusedKeys = saveKeys ch
-                                , evalTerm = EvalTerm (runReaderT' hs . runDraw)
-                                                    (Draw . lift)
-                                },
-                            closeTerm = closeHandles hs
-                        }
+    return fileRT
+      { termOps = Left TermOps {
+          getLayout = getBufferSize (hOut hs)
+          , withGetEvent = withWindowMode hs
+                              . win32WithEvent hs ch
+          , saveUnusedKeys = saveKeys ch
+          , evalTerm = EvalTerm (runReaderT' hs . runDraw)
+                              (Draw . lift)
+          , externalPrint = writeChan ch . ExternalPrint
+          }
+      , closeTerm = do
+          flushEventQueue (putStrOut fileRT) ch
+          closeHandles hs
+      }
 
 win32WithEvent :: MonadException m => Handles -> Chan Event
                                         -> (m Event -> m a) -> m a
@@ -545,4 +548,3 @@ clearScreen = do
     liftIO $ fillConsoleChar h ' ' windowSize origin
     liftIO $ fillConsoleAttribute h attr windowSize origin
     setPos origin
-

System/Console/Haskeline/Emacs.hs

@@ -89,7 +89,7 @@ rotatePaste im = get >>= loop
 wordRight, wordLeft, bigWordLeft :: InsertMode -> InsertMode
 wordRight = goRightUntil (atStart (not . isAlphaNum))
 wordLeft = goLeftUntil (atStart isAlphaNum)
-bigWordLeft = goLeftUntil (atStart isSpace)
+bigWordLeft = goLeftUntil (atStart (not . isSpace))
 
 modifyWord :: ([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode
 modifyWord f im = IMode (reverse (f ys1) ++ xs) ys2

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 ()

System/Console/Haskeline/Term.hs

@@ -28,25 +28,42 @@ drawLine, clearLine :: Term m => LineChars -> m ()
 drawLine = drawLineDiff ([],[])
 
 clearLine = flip drawLineDiff ([],[])
-    
+
 data RunTerm = RunTerm {
             -- | Write unicode characters to stdout.
             putStrOut :: String -> IO (),
             termOps :: Either TermOps FileOps,
-            wrapInterrupt :: forall a . IO a -> IO a,            
+            wrapInterrupt :: forall a . IO a -> IO a,
             closeTerm :: IO ()
     }
 
 -- | 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 ()
+    }
+
+-- 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.
+flushEventQueue :: (String -> IO ()) -> Chan Event -> IO ()
+flushEventQueue print' eventChan = yield >> loopUntilFlushed
+    where loopUntilFlushed = do
+              flushed <- isEmptyChan eventChan
+              if flushed then return () else do
+                  event <- readChan eventChan
+                  case event of
+                      ExternalPrint str -> do
+                          print' (str ++ "\n") >> loopUntilFlushed
+                      -- We don't want to raise exceptions when doing cleanup.
+                      _ -> loopUntilFlushed
 
 -- | Operations needed for file-style interaction.
--- 
+--
 -- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline
 -- are "wrapped" by wrapFileInput.
 data FileOps = FileOps {
@@ -96,8 +113,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
@@ -121,7 +142,7 @@ keyEventLoop readEvents eventChan = do
             else -- Use the lock to work around the fact that writeList2Chan
                  -- isn't atomic.  Otherwise, some events could be ignored if
                  -- the subthread is killed before it saves them in the chan.
-                 bracket_ (putMVar lock ()) (takeMVar lock) $ 
+                 bracket_ (putMVar lock ()) (takeMVar lock) $
                     writeList2Chan eventChan es
     handleErrorEvent = handle $ \e -> case fromException e of
                                 Just ThreadKilled -> return ()
@@ -166,7 +187,7 @@ guardedEOF f h = do
 -- 1) By itself, this (by using hReady) might crash on invalid characters.
 -- The handle should be set to binary mode or a TextEncoder that
 -- transliterates or ignores invalid input.
--- 
+--
 -- 1) Note that in ghc-6.8.3 and earlier, hReady returns False at an EOF,
 -- whereas in ghc-6.10.1 and later it throws an exception.  (GHC trac #1063).
 -- This code handles both of those cases.
@@ -191,4 +212,3 @@ hGetLocaleLine = guardedEOF $ \h -> do
     liftIO $ if buff == NoBuffering
         then fmap BC.pack $ System.IO.hGetLine h
         else BC.hGetLine h
-

haskeline.cabal

@@ -9,7 +9,7 @@ Author:         Judah Jacobson
 Maintainer:     Judah Jacobson <judah.jacobson@gmail.com>
 Category:       User Interfaces
 Synopsis:       A command-line interface for user input, written in Haskell.
-Description:    
+Description:
                 Haskeline provides a user interface for line input in command-line
                 programs.  This library is similar in purpose to readline, but since
                 it is written in Haskell it is (hopefully) more easily used in other
@@ -17,6 +17,7 @@ Description:
                 .
                 Haskeline runs both on POSIX-compatible systems and on Windows.
 Homepage:       http://trac.haskell.org/haskeline
+Bug-Reports:    https://github.com/judah/haskeline/issues
 Stability:      Stable
 Build-Type:     Custom
 extra-source-files: examples/Test.hs Changelog
@@ -45,7 +46,7 @@ Library
                    directory>=1.1 && < 1.3, bytestring>=0.9 && < 0.11,
                    filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.6
     Default-Language: Haskell98
-    Default-Extensions: 
+    Default-Extensions:
                 ForeignFunctionInterface, Rank2Types, FlexibleInstances,
                 TypeSynonymInstances
                 FlexibleContexts, ExistentialQuantification