Commit 3600181d authored by judah's avatar judah
Browse files

Merge branch 'master' into bump-lower-dep

Conflicts:
	README.md
	System/Console/Haskeline/Backend/Posix.hsc
	haskeline.cabal
parents a89ecc15 cec24a1a
......@@ -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:
......
{- |
{- |
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
......@@ -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
......
......@@ -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
......@@ -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
......
......@@ -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 ()
......
......@@ -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
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment