diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,17 @@ +Changed in version 0.6.3: + * #111: Correct width calculations when the prompt contains newlines. + + * #109: Add function completeWordWithPrev. + + * #101, #44: Extend the API with Behaviors, which control the choice between + terminal-style and file-style interaction. + + * #78: Correct width calculations for escape sequences ("\ESC...\STX") + + * Better warning message when -fterminfo doesn't work. + + * Added getPassword as a new input function. + Changed in version 0.6.2.4: * Added back a MonadException instance for mtl's StateT. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -106,6 +106,11 @@ , "}" ] -warnIfNotTerminfo flags = when (not (hasFlagSet flags (FlagName "terminfo"))) $ - putStrLn $ - "*** Warning: running on POSIX but not building the terminfo backend. ***" +warnIfNotTerminfo flags = when (not (hasFlagSet flags (FlagName "terminfo"))) + $ mapM_ putStrLn + [ "*** Warning: running on POSIX but not building the terminfo backend. ***" + , "You may need to install the terminfo package manually, e.g. with" + , "\"cabal install terminfo\"; or, use \"-fterminfo\" when configuring or" + , "installing this package." + ,"" + ] diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs --- a/System/Console/Haskeline.hs +++ b/System/Console/Haskeline.hs @@ -6,7 +6,7 @@ Users may customize the interface with a @~/.haskeline@ file; see for more information. -An example use of this library for a simple read-eval-print loop is the +An example use of this library for a simple read-eval-print loop (REPL) is the following: > import System.Console.Haskeline @@ -27,27 +27,39 @@ module System.Console.Haskeline( - -- * Main functions + -- * Interactive sessions -- ** The InputT monad transformer InputT, runInputT, - runInputTWithPrefs, + haveTerminalUI, + -- ** Behaviors + Behavior, + runInputTBehavior, + defaultBehavior, + useFileHandle, + useFile, + preferTerm, + -- * User interaction functions -- ** Reading user input -- $inputfncs getInputLine, getInputChar, + getPassword, -- ** Outputting text -- $outputfncs outputStr, outputStrLn, - -- * Settings + -- * Customization + -- ** Settings Settings(..), defaultSettings, setComplete, - -- * User preferences + -- ** User preferences Prefs(), readPrefs, defaultPrefs, + runInputTWithPrefs, + runInputTBehaviorWithPrefs, -- * Ctrl-C handling -- $ctrlc Interrupt(..), @@ -73,9 +85,6 @@ import System.IO import Data.Char (isSpace, isPrint) -import Control.Monad -import qualified Data.ByteString.Char8 as B -import System.IO.Error (isEOFError) -- | A useful default. In particular: @@ -93,17 +102,17 @@ autoAddHistory = True} {- $outputfncs -The following functions allow cross-platform output of text that may contain +The following functions enable cross-platform output of text that may contain Unicode characters. -} --- | Write a string to the standard output. +-- | Write a Unicode string to the user's standard output. outputStr :: MonadIO m => String -> InputT m () outputStr xs = do putter <- asks putStrOut liftIO $ putter xs --- | Write a string to the standard output, followed by a newline. +-- | Write a string to the user's standard output, followed by a newline. outputStrLn :: MonadIO m => String -> InputT m () outputStrLn = outputStr . (++ "\n") @@ -111,43 +120,30 @@ {- $inputfncs The following functions read one line or character of input from the user. -If 'stdin' is connected to a terminal, then these functions perform all user interaction, -including display of the prompt text, on the user's output terminal (which may differ from -'stdout'). -They return 'Nothing' if the user pressed @Ctrl-D@ when the -input text was empty. +When using terminal-style interaction, these functions return 'Nothing' if the user +pressed @Ctrl-D@ when the input text was empty. -If 'stdin' is not connected to a terminal or does not have echoing enabled, -then these functions print the prompt to 'stdout', -and they return 'Nothing' if an @EOF@ was encountered before any characters were read. +When using file-style interaction, these functions return 'Nothing' if +an @EOF@ was encountered before any characters were read. -} -{- | Reads one line of input. The final newline (if any) is removed. Provides a rich -line-editing user interface if 'stdin' is a terminal. +{- | Reads one line of input. The final newline (if any) is removed. When using terminal-style interaction, this function provides a rich line-editing user interface. If @'autoAddHistory' == 'True'@ and the line input is nonblank (i.e., is not all spaces), it will be automatically added to the history. -} -getInputLine :: forall m . MonadException m => String -- ^ The input prompt +getInputLine :: MonadException m => String -- ^ The input prompt -> InputT m (Maybe String) -getInputLine prefix = do - -- If other parts of the program have written text, make sure that it - -- appears before we interact with the user on the terminal. - liftIO $ hFlush stdout - rterm <- ask - echo <- liftIO $ hGetEcho stdin - case termOps rterm of - Just tops | echo -> getInputCmdLine tops prefix - _ -> simpleFileLoop prefix rterm +getInputLine = promptedInput getInputCmdLine $ unMaybeT . getLocaleLine getInputCmdLine :: MonadException m => TermOps -> String -> InputT m (Maybe String) getInputCmdLine tops prefix = do emode <- asks editMode result <- runInputCmdT tops $ case emode of - Emacs -> runCommandLoop tops prefix emacsCommands + Emacs -> runCommandLoop tops prefix emacsCommands emptyIM Vi -> evalStateT' emptyViState $ - runCommandLoop tops prefix viKeyCommands + runCommandLoop tops prefix viKeyCommands emptyIM maybeAddHistory result return result @@ -164,80 +160,33 @@ in modify (adder line) _ -> return () -simpleFileLoop :: MonadIO m => String -> RunTerm -> m (Maybe String) -simpleFileLoop prefix rterm = liftIO $ do - putStrOut rterm prefix - atEOF <- hIsEOF stdin - if atEOF - then return Nothing - else do - -- It's more efficient to use B.getLine, but that function throws an - -- error if stdin is set to NoBuffering. - buff <- hGetBuffering stdin - line <- case buff of - NoBuffering -> hWithBinaryMode stdin - $ fmap B.pack System.IO.getLine - _ -> B.getLine - fmap Just $ decodeForTerm rterm line - - ---------- {- | Reads one character of input. Ignores non-printable characters. -If stdin is a terminal, the character will be read without waiting for a newline. +When using terminal-style interaction, the character will be read without waiting +for a newline. -If stdin is not a terminal, a newline will be read if it is immediately +When using file-style interaction, a newline will be read if it is immediately available after the input character. -} getInputChar :: MonadException m => String -- ^ The input prompt -> InputT m (Maybe Char) -getInputChar prefix = do - liftIO $ hFlush stdout - rterm <- ask - echo <- liftIO $ hGetEcho stdin - case termOps rterm of - Just tops | echo -> getInputCmdChar tops prefix - _ -> simpleFileChar prefix rterm - -simpleFileChar :: MonadIO m => String -> RunTerm -> m (Maybe Char) -simpleFileChar prefix rterm = liftIO $ do - putStrOut rterm prefix - c <- getPrintableChar - maybeReadNewline - return c - where - getPrintableChar = returnOnEOF Nothing $ do - c <- getLocaleChar rterm - if isPrint c - then return (Just c) - else getPrintableChar - --- If another character is immediately available, and it is a newline, consume it. --- --- 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. --- --- Also note that on Windows with ghc<6.10, hReady may not behave correctly (#1198) --- The net result is that this might cause --- But this function will generally only be used when reading buffered input --- (since stdin isn't a terminal), so it should probably be OK. -maybeReadNewline :: IO () -maybeReadNewline = returnOnEOF () $ do - ready <- hReady stdin - when ready $ do - c <- hLookAhead stdin - when (c == '\n') $ getChar >> return () - -returnOnEOF :: a -> IO a -> IO a -returnOnEOF x = handle $ \e -> if isEOFError e - then return x - else throwIO e +getInputChar = promptedInput getInputCmdChar $ \fops -> do + c <- getPrintableChar fops + maybeReadNewline fops + return c +getPrintableChar :: FileOps -> IO (Maybe Char) +getPrintableChar fops = do + c <- unMaybeT $ getLocaleChar fops + 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 - $ runCommandLoop tops prefix acceptOneChar + $ runCommandLoop tops prefix acceptOneChar emptyIM acceptOneChar :: Monad m => KeyCommand m InsertMode (Maybe Char) acceptOneChar = choiceCmd [useChar $ \c s -> change (insertChar c) s @@ -245,6 +194,59 @@ , ctrlChar 'l' +> clearScreenCmd >|> keyCommand acceptOneChar , ctrlChar 'd' +> failCmd] + +---------- +-- Passwords + +{- | Reads one line of input, without displaying the input while it is being typed. +When using terminal-style interaction, the masking character (if given) will replace each typed character. + +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 + (\tops prefix -> runInputCmdT tops + $ runCommandLoop tops prefix loop + $ Password [] x) + (\fops -> let h_in = inputHandle fops + in bracketSet (hGetEcho h_in) (hSetEcho h_in) False + $ unMaybeT $ getLocaleLine fops) + where + loop = choiceCmd [ simpleChar '\n' +> finish + , simpleKey Backspace +> change deletePasswordChar + >|> loop' + , useChar $ \c -> change (addPasswordChar c) >|> loop' + , ctrlChar 'd' +> \p -> if null (passwordState p) + then failCmd p + else finish p + , ctrlChar 'l' +> clearScreenCmd >|> loop' + ] + loop' = keyCommand loop + + + +------- +-- | Wrapper for input functions. +promptedInput :: MonadIO m => (TermOps -> String -> InputT m a) + -> (FileOps -> IO a) + -> String -> InputT m a +promptedInput doTerm doFile prompt = do + -- If other parts of the program have written text, make sure that it + -- appears before we interact with the user on the terminal. + liftIO $ hFlush stdout + rterm <- ask + case termOps rterm of + Right fops -> liftIO $ do + putStrOut rterm prompt + doFile fops + Left tops -> do + -- If the prompt contains newlines, print all but the last line. + let (lastLine,rest) = break (`elem` "\r\n") $ reverse prompt + outputStr $ reverse rest + doTerm tops $ reverse lastLine ------------ -- Interrupt diff --git a/System/Console/Haskeline/Backend.hs b/System/Console/Haskeline/Backend.hs --- a/System/Console/Haskeline/Backend.hs +++ b/System/Console/Haskeline/Backend.hs @@ -1,28 +1,55 @@ module System.Console.Haskeline.Backend where import System.Console.Haskeline.Term +import System.Console.Haskeline.Monads +import Control.Monad +import System.IO (stdin, hGetEcho, Handle) #ifdef MINGW import System.Console.Haskeline.Backend.Win32 as Win32 #else +import System.Console.Haskeline.Backend.Posix as Posix #ifdef TERMINFO import System.Console.Haskeline.Backend.Terminfo as Terminfo #endif import System.Console.Haskeline.Backend.DumbTerm as DumbTerm #endif -myRunTerm :: IO RunTerm +defaultRunTerm :: IO RunTerm +defaultRunTerm = (liftIO (hGetEcho stdin) >>= guard >> stdinTTY) + `orElse` fileHandleRunTerm stdin + +terminalRunTerm :: IO RunTerm +terminalRunTerm = directTTY `orElse` fileHandleRunTerm stdin + +stdinTTY :: MaybeT IO RunTerm #ifdef MINGW -myRunTerm = win32Term +stdinTTY = win32TermStdin #else +stdinTTY = stdinTTYHandles >>= runDraw +#endif + +directTTY :: MaybeT IO RunTerm +#ifdef MINGW +directTTY = win32Term +#else +directTTY = ttyHandles >>= runDraw +#endif + + +#ifndef MINGW +runDraw :: Handles -> MaybeT IO RunTerm #ifndef TERMINFO -myRunTerm = runDumbTerm +runDraw = runDumbTerm #else -myRunTerm = do - mRun <- runTerminfoDraw - case mRun of - Nothing -> runDumbTerm - Just run -> return run +runDraw h = runTerminfoDraw h `mplus` runDumbTerm h #endif +#endif + +fileHandleRunTerm :: Handle -> IO RunTerm +#ifdef MINGW +fileHandleRunTerm = Win32.fileRunTerm +#else +fileHandleRunTerm = Posix.fileRunTerm #endif diff --git a/System/Console/Haskeline/Backend/DumbTerm.hs b/System/Console/Haskeline/Backend/DumbTerm.hs --- a/System/Console/Haskeline/Backend/DumbTerm.hs +++ b/System/Console/Haskeline/Backend/DumbTerm.hs @@ -9,6 +9,7 @@ import System.IO import qualified Data.ByteString as B import Control.Concurrent.Chan +import Control.Monad(liftM) -- TODO: ---- Put "<" and ">" at end of term if scrolls off. @@ -23,17 +24,17 @@ newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a} deriving (Monad, MonadIO, MonadException, MonadState Window, - MonadReader Handle, MonadReader Encoders) + MonadReader Handles, MonadReader Encoders) type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a instance MonadTrans DumbTerm where lift = DumbTerm . lift . lift . lift -runDumbTerm :: IO RunTerm -runDumbTerm = do - ch <- newChan - posixRunTerm $ \enc h -> +runDumbTerm :: Handles -> MaybeT IO RunTerm +runDumbTerm h = do + ch <- liftIO newChan + posixRunTerm h $ \enc -> TermOps { getLayout = tryGetLayouts (posixLayouts h) , withGetEvent = withPosixGetEvent ch h enc [] @@ -55,7 +56,7 @@ printText :: MonadIO m => String -> DumbTerm m () printText str = do - h <- ask + h <- liftM hOut ask posixEncode str >>= liftIO . B.hPutStr h liftIO $ hFlush h diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc --- a/System/Console/Haskeline/Backend/Posix.hsc +++ b/System/Console/Haskeline/Backend/Posix.hsc @@ -4,10 +4,14 @@ tryGetLayouts, PosixT, runPosixT, + Handles(..), Encoders(), posixEncode, mapLines, - posixRunTerm + stdinTTYHandles, + ttyHandles, + posixRunTerm, + fileRunTerm ) where import Foreign @@ -18,16 +22,15 @@ import Control.Concurrent hiding (throwTo) import Data.Maybe (catMaybes) import System.Posix.Signals.Exts -import System.Posix.IO(stdInput) +import System.Posix.Types(Fd(..)) import Data.List import System.IO import qualified Data.ByteString as B -import Data.ByteString.Char8 as Char8 (pack) import System.Environment import System.Console.Haskeline.Monads import System.Console.Haskeline.Key -import System.Console.Haskeline.Term +import System.Console.Haskeline.Term as Term import System.Console.Haskeline.Prefs import System.Console.Haskeline.Backend.IConv @@ -50,13 +53,18 @@ #endif #include +----------------------------------------------- +-- Input/output handles +data Handles = Handles {hIn, hOut :: Handle, + closeHandles :: IO ()} + ------------------- -- Window size foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt -posixLayouts :: Handle -> [IO (Maybe Layout)] -posixLayouts h = [ioctlLayout h, envLayout] +posixLayouts :: Handles -> [IO (Maybe Layout)] +posixLayouts h = [ioctlLayout $ hOut h, envLayout] ioctlLayout :: Handle -> IO (Maybe Layout) ioctlLayout h = allocaBytes (#size struct winsize) $ \ws -> do @@ -101,9 +109,9 @@ -- Key sequences getKeySequences :: (MonadIO m, MonadReader Prefs m) - => [(String,Key)] -> m (TreeMap Char Key) -getKeySequences tinfos = do - sttys <- liftIO sttyKeys + => Handles -> [(String,Key)] -> m (TreeMap Char Key) +getKeySequences h tinfos = do + sttys <- liftIO $ sttyKeys h customKeySeqs <- getCustomKeySeqs -- note ++ acts as a union; so the below favors sttys over tinfos return $ listToTree @@ -142,9 +150,10 @@ ] -sttyKeys :: IO [(String, Key)] -sttyKeys = do - attrs <- getTerminalAttributes stdInput +sttyKeys :: Handles -> IO [(String, Key)] +sttyKeys h = do + fd <- unsafeHandleToFD $ hIn h + 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)] @@ -199,12 +208,12 @@ ----------------------------- withPosixGetEvent :: (MonadException m, MonadReader Prefs m) - => Chan Event -> Handle -> Encoders -> [(String,Key)] + => Chan Event -> Handles -> Encoders -> [(String,Key)] -> (m Event -> m a) -> m a withPosixGetEvent eventChan h enc termKeys f = wrapTerminalOps h $ do - baseMap <- getKeySequences termKeys + baseMap <- getKeySequences h termKeys withWindowHandler eventChan - $ f $ liftIO $ getEvent enc baseMap eventChan + $ f $ liftIO $ getEvent h enc baseMap eventChan withWindowHandler :: MonadException m => Chan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $ @@ -222,82 +231,92 @@ old_handler <- liftIO $ installHandler signal handler Nothing f `finally` liftIO (installHandler signal old_handler Nothing) -getEvent :: Encoders -> TreeMap Char Key -> Chan Event -> IO Event -getEvent enc baseMap = keyEventLoop readKeyEvents +getEvent :: Handles -> Encoders -> TreeMap Char Key -> Chan Event -> IO Event +getEvent Handles {hIn=h} enc baseMap = keyEventLoop readKeyEvents where bufferSize = 32 readKeyEvents = do -- Read at least one character of input, and more if available. -- In particular, the characters making up a control sequence will all -- be available at once, so we can process them together with lexKeys. - blockUntilInput - bs <- B.hGetNonBlocking stdin bufferSize - cs <- convert (localeToUnicode enc) bs + blockUntilInput h + bs <- B.hGetNonBlocking h bufferSize + cs <- convert h (localeToUnicode enc) bs return [KeyInput $ lexKeys baseMap cs] -- Different versions of ghc work better using different functions. -blockUntilInput :: IO () +blockUntilInput :: Handle -> IO () #if __GLASGOW_HASKELL__ >= 611 -- threadWaitRead doesn't work with the new ghc IO library, -- because it keeps a buffer even when NoBuffering is set. -blockUntilInput = hWaitForInput stdin (-1) >> return () +blockUntilInput h = hWaitForInput h (-1) >> return () #else -- hWaitForInput doesn't work with -threaded on ghc < 6.10 -- (#2363 in ghc's trac) -blockUntilInput = threadWaitRead stdInput +blockUntilInput h = unsafeHandleToFd h >>= threadWaitRead #endif -- try to convert to the locale encoding using iconv. -- if the buffer has an incomplete shift sequence, -- read another byte of input and try again. -convert :: (B.ByteString -> IO (String,Result)) -> B.ByteString -> IO String -convert decoder bs = do +convert :: Handle -> (B.ByteString -> IO (String,Result)) + -> B.ByteString -> IO String +convert h decoder bs = do (cs,result) <- decoder bs case result of Incomplete rest -> do - extra <- B.hGetNonBlocking stdin 1 + extra <- B.hGetNonBlocking h 1 if B.null extra then return (cs ++ "?") - else fmap (cs ++) $ convert decoder (rest `B.append` extra) - Invalid rest -> fmap ((cs ++) . ('?':)) $ convert decoder (B.drop 1 rest) + else fmap (cs ++) + $ convert h decoder (rest `B.append` extra) + Invalid rest -> fmap ((cs ++) . ('?':)) $ convert h decoder (B.drop 1 rest) _ -> return cs -getMultiByteChar :: (B.ByteString -> IO (String,Result)) -> IO Char -getMultiByteChar decoder = hWithBinaryMode stdin $ do - b <- getChar - cs <- convert decoder (Char8.pack [b]) +getMultiByteChar :: Handle -> (B.ByteString -> IO (String,Result)) + -> MaybeT IO Char +getMultiByteChar h decoder = hWithBinaryMode h $ do + b <- hGetByte h + cs <- liftIO $ convert h decoder (B.pack [b]) case cs of [] -> return '?' -- shouldn't happen, but doesn't hurt to be careful. (c:_) -> return c --- fails if stdin is not a handle or if we couldn't access /dev/tty. -openTTY :: IO (Maybe Handle) -openTTY = do - inIsTerm <- hIsTerminalDevice stdin - if inIsTerm - then handle (\(_::IOException) -> return Nothing) $ do +stdinTTYHandles, ttyHandles :: MaybeT IO Handles +stdinTTYHandles = do + isInTerm <- liftIO $ hIsTerminalDevice stdin + guard isInTerm + h <- openTerm WriteMode + -- Don't close stdin, since a different part of the program may use it later. + return Handles { hIn = stdin, hOut = h, closeHandles = hClose h } + +ttyHandles = do + -- Open the input and output separately, since they need different buffering. + h_in <- openTerm ReadMode + h_out <- openTerm WriteMode + return Handles { hIn = h_in, hOut = h_out, + closeHandles = hClose h_in >> hClose h_out } + +openTerm :: IOMode -> MaybeT IO Handle +openTerm mode = handle (\(_::IOException) -> mzero) -- NB: we open the tty as a binary file since otherwise the terminfo -- backend, which writes output as Chars, would double-encode on ghc-6.12. - h <- openBinaryFile "/dev/tty" WriteMode - return (Just h) - else return Nothing + $ liftIO $ openBinaryFile "/dev/tty" mode -posixRunTerm :: (Encoders -> Handle -> TermOps) -> IO RunTerm -posixRunTerm tOps = do - fileRT <- fileRunTerm +posixRunTerm :: MonadIO m => Handles -> (Encoders -> TermOps) -> m RunTerm +posixRunTerm hs tOps = liftIO $ do codeset <- getCodeset - ttyH <- openTTY - encoders <- liftM2 Encoders (openEncoder codeset) (openPartialDecoder codeset) - case ttyH of - Nothing -> return fileRT - Just h -> return fileRT { - closeTerm = closeTerm fileRT >> hClose h, - -- NOTE: could also alloc Encoders once for each call to wrapRunTerm - termOps = Just $ tOps encoders h - } + encoders <- liftM2 Encoders (openEncoder codeset) + (openPartialDecoder codeset) + fileRT <- fileRunTerm $ hIn hs + return fileRT { + closeTerm = closeTerm fileRT >> closeHandles hs, + -- NOTE: could also alloc Encoders once for each call to wrapRunTerm + termOps = Left $ tOps encoders + } -type PosixT m = ReaderT Encoders (ReaderT Handle m) +type PosixT m = ReaderT Encoders (ReaderT Handles m) data Encoders = Encoders {unicodeToLocale :: String -> IO B.ByteString, localeToUnicode :: B.ByteString -> IO (String, Result)} @@ -307,42 +326,44 @@ encoder <- asks unicodeToLocale liftIO $ encoder str -runPosixT :: Monad m => Encoders -> Handle -> PosixT m a -> m a +runPosixT :: Monad m => Encoders -> Handles -> PosixT m a -> m a runPosixT enc h = runReaderT' h . runReaderT' enc -putTerm :: B.ByteString -> IO () -putTerm str = B.putStr str >> hFlush stdout +putTerm :: Handle -> B.ByteString -> IO () +putTerm h str = B.hPutStr h str >> hFlush h -fileRunTerm :: IO RunTerm -fileRunTerm = do +fileRunTerm :: Handle -> IO RunTerm +fileRunTerm h_in = do + let h_out = stdout oldLocale <- setLocale (Just "") codeset <- getCodeset let encoder str = join $ fmap ($ str) $ openEncoder codeset let decoder str = join $ fmap ($ str) $ openDecoder codeset decoder' <- openPartialDecoder codeset - return RunTerm {putStrOut = \str -> encoder str >>= putTerm, + return RunTerm {putStrOut = encoder >=> putTerm h_out, closeTerm = setLocale oldLocale >> return (), wrapInterrupt = withSigIntHandler, encodeForTerm = encoder, decodeForTerm = decoder, - getLocaleChar = getMultiByteChar decoder', - termOps = Nothing + termOps = Right FileOps { + inputHandle = h_in, + getLocaleChar = getMultiByteChar h_in decoder', + maybeReadNewline = hMaybeReadNewline h_in, + getLocaleLine = Term.hGetLine h_in + >>= liftIO . decoder + } + } -- NOTE: If we set stdout to NoBuffering, there can be a flicker effect when many -- characters are printed at once. We'll keep it buffered here, and let the Draw -- monad manually flush outputs that don't print a newline. -wrapTerminalOps:: MonadException m => Handle -> m a -> m a -wrapTerminalOps outH = - bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering +wrapTerminalOps :: MonadException m => Handles -> m a -> m a +wrapTerminalOps Handles {hIn = h_in, hOut = h_out} = + bracketSet (hGetBuffering h_in) (hSetBuffering h_in) NoBuffering -- TODO: block buffering? Certain \r and \n's are causing flicker... -- - moving to the right -- - breaking line after offset widechar? - . bracketSet (hGetBuffering outH) (hSetBuffering outH) LineBuffering - . bracketSet (hGetEcho stdin) (hSetEcho stdin) False - . hWithBinaryMode stdin - -bracketSet :: (Eq a, MonadException m) => IO a -> (a -> IO ()) -> a -> m b -> m b -bracketSet getState set newState f = bracket (liftIO getState) - (liftIO . set) - (\_ -> liftIO (set newState) >> f) + . bracketSet (hGetBuffering h_out) (hSetBuffering h_out) LineBuffering + . bracketSet (hGetEcho h_in) (hSetEcho h_in) False + . hWithBinaryMode h_in diff --git a/System/Console/Haskeline/Backend/Terminfo.hs b/System/Console/Haskeline/Backend/Terminfo.hs --- a/System/Console/Haskeline/Backend/Terminfo.hs +++ b/System/Console/Haskeline/Backend/Terminfo.hs @@ -131,26 +131,26 @@ deriving (Monad, MonadIO, MonadException, MonadReader Actions, MonadReader Terminal, MonadState TermPos, MonadState TermRows, - MonadReader Handle, MonadReader Encoders) + MonadReader Handles, MonadReader Encoders) type DrawM a = forall m . (MonadReader Layout m, MonadIO m) => Draw m a instance MonadTrans Draw where lift = Draw . lift . lift . lift . lift . lift . lift -runTerminfoDraw :: IO (Maybe RunTerm) -runTerminfoDraw = do - mterm <- Exception.try setupTermFromEnv - ch <- newChan +runTerminfoDraw :: Handles -> MaybeT IO RunTerm +runTerminfoDraw h = do + mterm <- liftIO $ Exception.try setupTermFromEnv + ch <- liftIO newChan case mterm of - Left (_::SetupTermError) -> return Nothing - Right term -> case getCapability term getActions of - Nothing -> return Nothing - Just actions -> fmap Just $ posixRunTerm $ \enc h -> + Left (_::SetupTermError) -> mzero + Right term -> do + actions <- MaybeT $ return $ getCapability term getActions + posixRunTerm h $ \enc -> TermOps { getLayout = tryGetLayouts (posixLayouts h ++ [tinfoLayout term]) - , withGetEvent = wrapKeypad h term + , withGetEvent = wrapKeypad (hOut h) term . withPosixGetEvent ch h enc (terminfoKeys term) , runTerm = \(RunTermType f) -> @@ -201,7 +201,7 @@ output f = do toutput <- asks f term <- ask - ttyh <- ask + ttyh <- liftM hOut ask liftIO $ hRunTermOutput ttyh term toutput diff --git a/System/Console/Haskeline/Backend/WCWidth.hs b/System/Console/Haskeline/Backend/WCWidth.hs --- a/System/Console/Haskeline/Backend/WCWidth.hs +++ b/System/Console/Haskeline/Backend/WCWidth.hs @@ -17,8 +17,8 @@ wcwidth :: Char -> Int wcwidth c = case mk_wcwidth $ toEnum $ fromEnum c of - -1 -> 0 -- shouldn't happen, since control characters - -- aren't turned into graphemes; but better to be safe. + -1 -> 0 -- Control characters have zero width. (Used by the + -- "\SOH...\STX" hack in LineState.stringToGraphemes.) w -> w gWidth :: Grapheme -> Int diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc --- a/System/Console/Haskeline/Backend/Win32.hsc +++ b/System/Console/Haskeline/Backend/Win32.hsc @@ -1,5 +1,7 @@ module System.Console.Haskeline.Backend.Win32( - win32Term + win32Term, + win32TermStdin, + fileRunTerm )where @@ -7,7 +9,7 @@ import Foreign import Foreign.C import System.Win32 hiding (multiByteToWideChar) -import Graphics.Win32.Misc(getStdHandle, sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE) +import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE) import Data.List(intercalate) import Control.Concurrent hiding (throwTo) import Data.Char(isPrint) @@ -17,7 +19,7 @@ import System.Console.Haskeline.Key import System.Console.Haskeline.Monads import System.Console.Haskeline.LineState -import System.Console.Haskeline.Term +import System.Console.Haskeline.Term as Term import Data.ByteString.Internal (createAndTrim) import qualified Data.ByteString as B @@ -53,13 +55,19 @@ else do es <- readEvents h return $ mapMaybe processEvent es - -getConOut :: IO (Maybe HANDLE) -getConOut = handle (\(_::IOException) -> return Nothing) $ fmap Just - $ createFile "CONOUT$" (gENERIC_READ .|. gENERIC_WRITE) + +consoleHandles :: MaybeT IO Handles +consoleHandles = do + h_in <- open "CONIN$" + h_out <- open "CONOUT$" + return Handles { hIn = h_in, hOut = h_out } + where + open file = handle (\(_::IOException) -> mzero) $ liftIO + $ createFile file (gENERIC_READ .|. gENERIC_WRITE) (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing - oPEN_EXISTING 0 Nothing + oPEN_EXISTING 0 Nothing + processEvent :: InputEvent -> Maybe Event processEvent KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc, controlKeyState = cstate} @@ -215,9 +223,9 @@ foreign import stdcall "windows.h SetConsoleMode" c_SetConsoleMode :: HANDLE -> DWORD -> IO Bool -withWindowMode :: MonadException m => m a -> m a -withWindowMode f = do - h <- liftIO $ getStdHandle sTD_INPUT_HANDLE +withWindowMode :: MonadException m => Handles -> m a -> m a +withWindowMode hs f = do + let h = hIn hs bracket (getConsoleMode h) (setConsoleMode h) $ \m -> setConsoleMode h (m .|. (#const ENABLE_WINDOW_INPUT)) >> f where @@ -229,25 +237,30 @@ ---------------------------- -- Drawing -newtype Draw m a = Draw {runDraw :: ReaderT HANDLE m a} - deriving (Monad,MonadIO,MonadException, MonadReader HANDLE) +data Handles = Handles { hIn, hOut :: HANDLE } +closeHandles :: Handles -> IO () +closeHandles hs = closeHandle (hIn hs) >> closeHandle (hOut hs) + +newtype Draw m a = Draw {runDraw :: ReaderT Handles m a} + deriving (Monad,MonadIO,MonadException, MonadReader Handles) + type DrawM a = (MonadIO m, MonadReader Layout m) => Draw m () instance MonadTrans Draw where lift = Draw . lift getPos :: MonadIO m => Draw m Coord -getPos = ask >>= liftIO . getPosition +getPos = asks hOut >>= liftIO . getPosition setPos :: MonadIO m => Coord -> Draw m () setPos c = do - h <- ask + h <- asks hOut liftIO (setPosition h c) printText :: MonadIO m => String -> Draw m () printText txt = do - h <- ask + h <- asks hOut liftIO (writeConsole h txt) printAfter :: String -> DrawM () @@ -278,7 +291,9 @@ crlf = "\r\n" instance (MonadException m, MonadReader Layout m) => Term (Draw m) where - drawLineDiff = drawLineDiffWin + drawLineDiff (xs1,ys1) (xs2,ys2) = let + fixEsc = filter ((/= '\ESC') . baseChar) + in drawLineDiffWin (fixEsc xs1, fixEsc ys1) (fixEsc xs2, fixEsc ys2) -- TODO now that we capture resize events. -- first, looks like the cursor stays on the same line but jumps -- to the beginning if cut off. @@ -300,46 +315,52 @@ ringBell True = liftIO messageBeep ringBell False = return () -- TODO -win32Term :: IO RunTerm +win32TermStdin :: MaybeT IO RunTerm +win32TermStdin = do + liftIO (hIsTerminalDevice stdin) >>= guard + win32Term + +win32Term :: MaybeT IO RunTerm win32Term = do - fileRT <- fileRunTerm - inIsTerm <- hIsTerminalDevice stdin - if not inIsTerm - then return fileRT - else do - oterm <- getConOut - case oterm of - Nothing -> return fileRT - Just h -> do - ch <- newChan - return fileRT { - wrapInterrupt = withWindowMode . withCtrlCHandler, - termOps = Just TermOps { - getLayout = getBufferSize h - , withGetEvent = win32WithEvent ch + hs <- consoleHandles + ch <- liftIO newChan + fileRT <- liftIO $ fileRunTerm stdin + return fileRT { + termOps = Left TermOps { + getLayout = getBufferSize (hOut hs) + , withGetEvent = withWindowMode hs + . win32WithEvent hs ch , runTerm = \(RunTermType f) -> - runReaderT' h $ runDraw f + runReaderT' hs $ runDraw f }, - closeTerm = closeHandle h} + closeTerm = closeHandles hs + } -win32WithEvent :: MonadException m => Chan Event -> (m Event -> m a) -> m a -win32WithEvent eventChan f = do - inH <- liftIO $ getStdHandle sTD_INPUT_HANDLE - f $ liftIO $ getEvent inH eventChan +win32WithEvent :: MonadException m => Handles -> Chan Event + -> (m Event -> m a) -> m a +win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan -- stdin is not a terminal, but we still need to check the right way to output unicode to stdout. -fileRunTerm :: IO RunTerm -fileRunTerm = do +fileRunTerm :: Handle -> IO RunTerm +fileRunTerm h_in = do putter <- putOut cp <- getCodePage - return RunTerm {termOps = Nothing, + return RunTerm { closeTerm = return (), putStrOut = putter, encodeForTerm = unicodeToCodePage cp, decodeForTerm = codePageToUnicode cp, - getLocaleChar = getMultiByteChar cp, - wrapInterrupt = withCtrlCHandler} + wrapInterrupt = withCtrlCHandler, + termOps = Right FileOps { + inputHandle = h_in, + getLocaleChar = getMultiByteChar cp h_in, + maybeReadNewline = hMaybeReadNewline h_in, + getLocaleLine = Term.hGetLine h_in + >>= liftIO . codePageToUnicode cp + } + } + -- On Windows, Unicode written to the console must be written with the WriteConsole API call. -- And to make the API cross-platform consistent, Unicode to a file should be UTF-8. putOut :: IO (String -> IO ()) @@ -352,9 +373,9 @@ else do cp <- getCodePage return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout - - + + type Handler = DWORD -> IO BOOL foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler) @@ -420,16 +441,15 @@ foreign import stdcall "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx :: CodePage -> BYTE -> BOOL -getMultiByteChar :: CodePage -> IO Char -getMultiByteChar cp = hWithBinaryMode stdin $ do - b1 <- getByte - bs <- if c_IsDBCSLeadByteEx cp b1 - then getByte >>= \b2 -> return [b1,b2] - else return [b1] - cs <- codePageToUnicode cp (B.pack bs) - case cs of - [] -> getMultiByteChar cp - (c:_) -> return c +getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char +getMultiByteChar cp h = hWithBinaryMode h loop where - -- NOTE: relies on getChar returning an 8-bit Char. - getByte = fmap (toEnum . fromEnum) getChar + loop = do + b1 <- hGetByte h + bs <- if c_IsDBCSLeadByteEx cp b1 + then hGetByte h >>= \b2 -> return [b1,b2] + else return [b1] + cs <- liftIO $ codePageToUnicode cp (B.pack bs) + case cs of + [] -> loop + (c:_) -> return c diff --git a/System/Console/Haskeline/Command.hs b/System/Console/Haskeline/Command.hs --- a/System/Console/Haskeline/Command.hs +++ b/System/Console/Haskeline/Command.hs @@ -34,7 +34,7 @@ import System.Console.Haskeline.LineState import System.Console.Haskeline.Key -data Effect = LineChange (String -> LineChars) +data Effect = LineChange (Prefix -> LineChars) | PrintLines [String] | ClearScreen | RingBell diff --git a/System/Console/Haskeline/Command/History.hs b/System/Console/Haskeline/Command/History.hs --- a/System/Console/Haskeline/Command/History.hs +++ b/System/Console/Haskeline/Command/History.hs @@ -87,8 +87,8 @@ instance LineState SearchMode where beforeCursor _ sm = beforeCursor prefix (foundHistory sm) where - prefix = "(" ++ directionName (direction sm) ++ ")`" - ++ graphemesToString (searchTerm sm) ++ "': " + prefix = stringToGraphemes ("(" ++ directionName (direction sm) ++ ")`") + ++ searchTerm sm ++ stringToGraphemes "': " afterCursor = afterCursor . foundHistory instance Result SearchMode where diff --git a/System/Console/Haskeline/Completion.hs b/System/Console/Haskeline/Completion.hs --- a/System/Console/Haskeline/Completion.hs +++ b/System/Console/Haskeline/Completion.hs @@ -1,11 +1,12 @@ module System.Console.Haskeline.Completion( CompletionFunc, Completion(..), - completeWord, - completeQuotedWord, - -- * Building 'CompletionFunc's noCompletion, simpleCompletion, + -- * Word completion + completeWord, + completeWordWithPrev, + completeQuotedWord, -- * Filename completion completeFilename, listFiles, @@ -47,17 +48,33 @@ -------------- -- Word break functions --- | The following function creates a custom 'CompletionFunc' for use in the 'Settings.' +-- | A custom 'CompletionFunc' which completes the word immediately to the left of the cursor. +-- +-- A word begins either at the start of the line or after an unescaped whitespace character. completeWord :: Monad m => Maybe Char -- ^ An optional escape character - -> String -- ^ List of characters which count as whitespace + -> [Char]-- ^ Characters which count as whitespace -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions -> CompletionFunc m -completeWord esc ws f (line, _) = do +completeWord esc ws = completeWordWithPrev esc ws . const + +-- | A custom 'CompletionFunc' which completes the word immediately to the left of the cursor, +-- and takes into account the line contents to the left of the word. +-- +-- A word begins either at the start of the line or after an unescaped whitespace character. +completeWordWithPrev :: Monad m => Maybe Char + -- ^ An optional escape character + -> [Char]-- ^ Characters which count as whitespace + -> (String -> String -> m [Completion]) + -- ^ Function to produce a list of possible completions. The first argument is the + -- line contents to the left of the word, reversed. The second argument is the word + -- to be completed. + -> CompletionFunc m +completeWordWithPrev esc ws f (line, _) = do let (word,rest) = case esc of Nothing -> break (`elem` ws) line Just e -> escapedBreak e line - completions <- f (reverse word) + completions <- f rest (reverse word) return (rest,map (escapeReplacement esc ws) completions) where escapedBreak e (c:d:cs) | d == e && c `elem` (e:ws) @@ -65,7 +82,7 @@ escapedBreak e (c:cs) | notElem c ws = let (xs,ys) = escapedBreak e cs in (c:xs,ys) escapedBreak _ cs = ("",cs) - + -- | Create a finished completion out of the given word. simpleCompletion :: String -> Completion simpleCompletion = completion @@ -100,7 +117,7 @@ --------- -- Quoted completion completeQuotedWord :: Monad m => Maybe Char -- ^ An optional escape character - -> String -- ^ List of characters which set off quotes + -> [Char] -- ^ Characters which set off quotes -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions -> CompletionFunc m -- ^ Alternate completion to perform if the -- cursor is not at a quoted word diff --git a/System/Console/Haskeline/InputT.hs b/System/Console/Haskeline/InputT.hs --- a/System/Console/Haskeline/InputT.hs +++ b/System/Console/Haskeline/InputT.hs @@ -15,6 +15,7 @@ import System.FilePath import Control.Applicative import qualified Control.Monad.State as State +import System.IO -- | Application-specific customizations to the user interface. data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion. @@ -73,20 +74,102 @@ settings <- ask lift $ lift $ lift $ lift $ lift $ lift $ complete settings lcs +-- | Run a line-reading application. Uses 'defaultBehavior' to determine the +-- interaction behavior. runInputTWithPrefs :: MonadException m => Prefs -> Settings m -> InputT m a -> m a -runInputTWithPrefs prefs settings (InputT f) = bracket (liftIO myRunTerm) - (liftIO . closeTerm) - $ \run -> runReaderT' settings $ runReaderT' prefs - $ runKillRing - $ runHistoryFromFile (historyFile settings) (maxHistorySize prefs) - $ runReaderT f run - --- | Run a line-reading application, reading user 'Prefs' from --- @~/.haskeline@ +runInputTWithPrefs = runInputTBehaviorWithPrefs defaultBehavior + +-- | Run a line-reading application. This function should suffice for most applications. +-- +-- This function is equivalent to @'runInputTBehavior' 'defaultBehavior'@. It +-- uses terminal-style interaction if 'stdin' is connected to a terminal and has +-- echoing enabled. Otherwise (e.g., if 'stdin' is a pipe), it uses file-style interaction. +-- +-- If it uses terminal-style interaction, 'Prefs' will be read from the user's @~/.haskeline@ file +-- (if present). +-- If it uses file-style interaction, 'Prefs' are not relevant and will not be read. runInputT :: MonadException m => Settings m -> InputT m a -> m a -runInputT settings f = do - prefs <- liftIO readPrefsFromHome - runInputTWithPrefs prefs settings f +runInputT = runInputTBehavior defaultBehavior + +-- | Returns 'True' if the current session uses terminal-style interaction. (See 'Behavior'.) +haveTerminalUI :: Monad m => InputT m Bool +haveTerminalUI = asks isTerminalStyle + + +{- | Haskeline has two ways of interacting with the user: + + * \"Terminal-style\" interaction provides an rich user interface by connecting + to the user's terminal (which may be different than 'stdin' or 'stdout'). + + * \"File-style\" interaction treats the input as a simple stream of characters, for example + when reading from a file or pipe. Input functions (e.g., @getInputLine@) print the prompt to 'stdout'. + + A 'Behavior' is a method for deciding at run-time which type of interaction to use. + + For most applications (e.g., a REPL), 'defaultBehavior' should have the correct effect. +-} +data Behavior = Behavior (IO RunTerm) + +-- | Create and use a RunTerm, ensuring that it will be closed even if +-- an async exception occurs during the creation or use. +withBehavior :: MonadException m => Behavior -> (RunTerm -> m a) -> m a +withBehavior (Behavior run) f = bracket (liftIO run) (liftIO . closeTerm) f + +-- | Run a line-reading application according to the given behavior. +-- +-- If it uses terminal-style interaction, 'Prefs' will be read from the +-- user's @~/.haskeline@ file (if present). +-- If it uses file-style interaction, 'Prefs' are not relevant and will not be read. +runInputTBehavior :: MonadException m => Behavior -> Settings m -> InputT m a -> m a +runInputTBehavior behavior settings f = withBehavior behavior $ \run -> do + prefs <- if isTerminalStyle run + then liftIO readPrefsFromHome + else return defaultPrefs + execInputT prefs settings run f + +-- | Run a line-reading application. +runInputTBehaviorWithPrefs :: MonadException m + => Behavior -> Prefs -> Settings m -> InputT m a -> m a +runInputTBehaviorWithPrefs behavior prefs settings f + = withBehavior behavior $ flip (execInputT prefs settings) f + +-- | Helper function to feed the parameters into an InputT. +execInputT :: MonadException m => Prefs -> Settings m -> RunTerm + -> InputT m a -> m a +execInputT prefs settings run (InputT f) + = runReaderT' settings $ runReaderT' prefs + $ runKillRing + $ runHistoryFromFile (historyFile settings) (maxHistorySize prefs) + $ runReaderT f run + + +-- | Read input from 'stdin'. +-- Use terminal-style interaction if 'stdin' is connected to +-- a terminal and has echoing enabled. Otherwise (e.g., if 'stdin' is a pipe), use +-- file-style interaction. +-- +-- This behavior should suffice for most applications. +defaultBehavior :: Behavior +defaultBehavior = Behavior defaultRunTerm + +-- | Use file-style interaction, reading input from the given 'Handle'. +useFileHandle :: Handle -> Behavior +useFileHandle = Behavior . fileHandleRunTerm + +-- | Use file-style interaction, reading input from the given file. +useFile :: FilePath -> Behavior +useFile file = Behavior $ do + h <- openBinaryFile file ReadMode + rt <- fileHandleRunTerm h + return rt { closeTerm = closeTerm rt >> hClose h} + +-- | Use terminal-style interaction whenever possible, even if 'stdin' and/or 'stdout' are not +-- terminals. +-- +-- If it cannot open the user's terminal, use file-style interaction, reading input from 'stdin'. +preferTerm :: Behavior +preferTerm = Behavior terminalRunTerm + -- | Read 'Prefs' from @~/.haskeline.@ If there is an error reading the file, -- the 'defaultPrefs' will be returned. diff --git a/System/Console/Haskeline/LineState.hs b/System/Console/Haskeline/LineState.hs --- a/System/Console/Haskeline/LineState.hs +++ b/System/Console/Haskeline/LineState.hs @@ -11,6 +11,7 @@ mapBaseChars, -- * Line State class LineState(..), + Prefix, -- ** Convenience functions for the drawing backends LineChars, lineChars, @@ -62,6 +63,9 @@ applyCmdArg, -- ** Other line state types Message(..), + Password(..), + addPasswordChar, + deletePasswordChar, ) where import Data.Char @@ -106,6 +110,15 @@ stringToGraphemes = mkString . dropWhile isCombiningChar where mkString [] = [] + -- Minor hack: "\ESC...\STX" or "\SOH\ESC...\STX", where "\ESC..." is some + -- control sequence (e.g., ANSI colors), is represented as a grapheme + -- of zero length with '\ESC' as the base character. + -- Note that this won't round-trip correctly with graphemesToString. + -- In practice, however, that's fine since control characters can only occur + -- in the prompt. + mkString ('\SOH':cs) = stringToGraphemes cs + mkString ('\ESC':cs) | (ctrl,'\STX':rest) <- break (=='\STX') cs + = Grapheme '\ESC' ctrl : stringToGraphemes rest mkString (c:cs) = Grapheme c (takeWhile isCombiningChar cs) : mkString (dropWhile isCombiningChar cs) @@ -115,18 +128,20 @@ -- | This class abstracts away the internal representations of the line state, -- for use by the drawing actions. Line state is generally stored in a zipper format. class LineState s where - beforeCursor :: String -- ^ The input prefix. + beforeCursor :: Prefix -- ^ The input prefix. -> s -- ^ The current line state. - -> [Grapheme] -- ^ The text to the left of the cursor, reversed. (This - -- includes the prefix.) + -> [Grapheme] -- ^ The text to the left of the cursor + -- (including the prefix). afterCursor :: s -> [Grapheme] -- ^ The text under and to the right of the cursor. +type Prefix = [Grapheme] + -- | The characters in the line (with the cursor in the middle). NOT in a zippered format; -- both lists are in the order left->right that appears on the screen. type LineChars = ([Grapheme],[Grapheme]) -- | Accessor function for the various backends. -lineChars :: LineState s => String -> s -> LineChars +lineChars :: LineState s => Prefix -> s -> LineChars lineChars prefix s = (beforeCursor prefix s, afterCursor s) -- | Compute the number of characters under and to the right of the cursor. @@ -155,7 +170,7 @@ deriving (Show, Eq) instance LineState InsertMode where - beforeCursor prefix (IMode xs _) = stringToGraphemes prefix ++ reverse xs + beforeCursor prefix (IMode xs _) = prefix ++ reverse xs afterCursor (IMode _ ys) = ys instance Result InsertMode where @@ -232,8 +247,8 @@ deriving Show instance LineState CommandMode where - beforeCursor prefix CEmpty = stringToGraphemes prefix - beforeCursor prefix (CMode xs _ _) = stringToGraphemes prefix ++ reverse xs + beforeCursor prefix CEmpty = prefix + beforeCursor prefix (CMode xs _ _) = prefix ++ reverse xs afterCursor CEmpty = [] afterCursor (CMode _ c ys) = c:ys @@ -310,7 +325,7 @@ fmap f am = am {argState = f (argState am)} instance LineState s => LineState (ArgMode s) where - beforeCursor _ am = let pre = "(arg: " ++ show (arg am) ++ ") " + beforeCursor _ am = let pre = map baseGrapheme $ "(arg: " ++ show (arg am) ++ ") " in beforeCursor pre (argState am) afterCursor = afterCursor . argState @@ -347,6 +362,29 @@ instance LineState (Message s) where beforeCursor _ = stringToGraphemes . messageText afterCursor _ = [] + +---------------- + +data Password = Password {passwordState :: [Char], -- ^ reversed + passwordChar :: Maybe Char} + +instance LineState Password where + beforeCursor prefix p + = prefix ++ (stringToGraphemes + $ case passwordChar p of + Nothing -> [] + Just c -> replicate (length $ passwordState p) c) + afterCursor _ = [] + +instance Result Password where + toResult = reverse . passwordState + +addPasswordChar :: Char -> Password -> Password +addPasswordChar c p = p {passwordState = c : passwordState p} + +deletePasswordChar :: Password -> Password +deletePasswordChar (Password (_:cs) m) = Password cs m +deletePasswordChar p = p ----------------- atStart, atEnd :: (Char -> Bool) -> InsertMode -> Bool diff --git a/System/Console/Haskeline/Monads.hs b/System/Console/Haskeline/Monads.hs --- a/System/Console/Haskeline/Monads.hs +++ b/System/Console/Haskeline/Monads.hs @@ -11,7 +11,9 @@ modify, update, MonadReader(..), - MonadState(..) + MonadState(..), + MaybeT(..), + orElse ) where import Control.Monad.Trans @@ -94,3 +96,27 @@ unblock m = StateT $ \s -> unblock $ getStateTFunc m s catch f h = StateT $ \s -> catch (getStateTFunc f s) $ \e -> getStateTFunc (h e) s + +newtype MaybeT m a = MaybeT { unMaybeT :: m (Maybe a) } + +instance Monad m => Monad (MaybeT m) where + return x = MaybeT $ return $ Just x + MaybeT f >>= g = MaybeT $ f >>= maybe (return Nothing) (unMaybeT . g) + +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = lift . liftIO + +instance MonadTrans MaybeT where + lift = MaybeT . liftM Just + +instance MonadException m => MonadException (MaybeT m) where + block = MaybeT . block . unMaybeT + unblock = MaybeT . unblock . unMaybeT + catch f h = MaybeT $ catch (unMaybeT f) $ unMaybeT . h + +orElse :: Monad m => MaybeT m a -> m a -> m a +orElse (MaybeT f) g = f >>= maybe g return + +instance Monad m => MonadPlus (MaybeT m) where + mzero = MaybeT $ return Nothing + MaybeT f `mplus` MaybeT g = MaybeT $ f >>= maybe g (return . Just) diff --git a/System/Console/Haskeline/Prefs.hs b/System/Console/Haskeline/Prefs.hs --- a/System/Console/Haskeline/Prefs.hs +++ b/System/Console/Haskeline/Prefs.hs @@ -16,7 +16,7 @@ import System.Console.Haskeline.Key {- | -'Prefs' allow the user to customize the line-editing interface. They are +'Prefs' allow the user to customize the terminal-style line-editing interface. They are read by default from @~/.haskeline@; to override that behavior, use 'readPrefs' and @runInputTWithPrefs@. diff --git a/System/Console/Haskeline/RunCommand.hs b/System/Console/Haskeline/RunCommand.hs --- a/System/Console/Haskeline/RunCommand.hs +++ b/System/Console/Haskeline/RunCommand.hs @@ -9,18 +9,20 @@ import Control.Monad -runCommandLoop :: (MonadException m, CommandMonad m, MonadState Layout m) - => TermOps -> String -> KeyCommand m InsertMode a -> m a -runCommandLoop tops prefix cmds = runTerm tops $ - RunTermType (withGetEvent tops $ runCommandLoop' tops prefix cmds) +runCommandLoop :: (MonadException m, CommandMonad m, MonadState Layout m, + LineState s) + => TermOps -> String -> KeyCommand m s a -> s -> m a +runCommandLoop tops prefix cmds initState = runTerm tops $ + RunTermType (withGetEvent tops + $ runCommandLoop' tops (stringToGraphemes prefix) initState cmds) -runCommandLoop' :: forall t m a . (MonadTrans t, Term (t m), CommandMonad (t m), - MonadState Layout m, MonadReader Prefs m) - => TermOps -> String -> KeyCommand m InsertMode a -> t m Event -> t m a -runCommandLoop' tops prefix cmds getEvent = do - let s = lineChars prefix emptyIM +runCommandLoop' :: forall t m s a . (MonadTrans t, Term (t m), CommandMonad (t m), + MonadState Layout m, MonadReader Prefs m, LineState s) + => TermOps -> Prefix -> s -> KeyCommand m s a -> t m Event -> t m a +runCommandLoop' tops prefix initState cmds getEvent = do + let s = lineChars prefix initState drawLine s - readMoreKeys s (fmap ($ emptyIM) cmds) + readMoreKeys s (fmap ($ initState) cmds) where readMoreKeys :: LineChars -> KeyMap (CmdM m a) -> t m a readMoreKeys s next = do @@ -49,7 +51,7 @@ drawEffect :: (MonadTrans t, Term (t m), MonadReader Prefs m) - => String -> LineChars -> Effect -> t m LineChars + => Prefix -> LineChars -> Effect -> t m LineChars drawEffect prefix s (LineChange ch) = do let t = ch prefix drawLineDiff s t diff --git a/System/Console/Haskeline/Term.hs b/System/Console/Haskeline/Term.hs --- a/System/Console/Haskeline/Term.hs +++ b/System/Console/Haskeline/Term.hs @@ -8,13 +8,13 @@ import Control.Concurrent import Data.Typeable -import Data.ByteString (ByteString) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Word import Control.Exception.Extensible (fromException, AsyncException(..),bracket_) -import System.IO(Handle) - -#if __GLASGOW_HASKELL__ >= 611 -import System.IO (hGetEncoding, hSetEncoding, hSetBinaryMode) -#endif +import System.IO +import Control.Monad(liftM,when,guard) +import System.IO.Error (isEOFError) class (MonadReader Layout m, MonadException m) => Term m where reposition :: Layout -> LineChars -> m () @@ -29,18 +29,17 @@ clearLine = flip drawLineDiff ([],[]) --- putStrOut is the right way to send unicode chars to stdout. --- termOps being Nothing means we should read the input as a UTF-8 file. data RunTerm = RunTerm { + -- | Write unicode characters to stdout. putStrOut :: String -> IO (), encodeForTerm :: String -> IO ByteString, decodeForTerm :: ByteString -> IO String, - getLocaleChar :: IO Char, - termOps :: Maybe TermOps, + termOps :: Either TermOps FileOps, wrapInterrupt :: MonadException m => m a -> m a, closeTerm :: IO () } +-- | Operations needed for terminal-style interaction. data TermOps = TermOps { getLayout :: IO Layout , withGetEvent :: (MonadException m, CommandMonad m) @@ -48,6 +47,20 @@ , runTerm :: (MonadException m, CommandMonad m) => RunTermType m a -> m a } +-- | Operations needed for file-style interaction. +data FileOps = FileOps { + inputHandle :: Handle, -- ^ e.g. for turning off echoing. + getLocaleLine :: MaybeT IO String, + getLocaleChar :: MaybeT IO Char, + maybeReadNewline :: IO () + } + +-- | Are we using terminal-style interaction? +isTerminalStyle :: RunTerm -> Bool +isTerminalStyle r = case termOps r of + Left TermOps{} -> True + _ -> False + -- Generic terminal actions which are independent of the Term being used. -- Wrapped in a newtype so that we don't need RankNTypes. newtype RunTermType m a = RunTermType (forall t . @@ -108,8 +121,10 @@ data Layout = Layout {width, height :: Int} deriving (Show,Eq) --------- --- Utility function since we're not using the new IO library yet. +----------------------------------- +-- Utility functions for the various backends. + +-- | Utility function since we're not using the new IO library yet. hWithBinaryMode :: MonadException m => Handle -> m a -> m a #if __GLASGOW_HASKELL__ >= 611 hWithBinaryMode h = bracket (liftIO $ hGetEncoding h) @@ -118,3 +133,55 @@ #else hWithBinaryMode _ = id #endif + +-- | Utility function for changing a property of a terminal for the duration of +-- a computation. +bracketSet :: (Eq a, MonadException m) => IO a -> (a -> IO ()) -> a -> m b -> m b +bracketSet getState set newState f = bracket (liftIO getState) + (liftIO . set) + (\_ -> liftIO (set newState) >> f) + + +-- | Returns one 8-bit word. Needs to be wrapped by hWithBinaryMode. +hGetByte :: Handle -> MaybeT IO Word8 +hGetByte h = do + eof <- liftIO $ hIsEOF h + guard (not eof) + liftIO $ liftM (toEnum . fromEnum) $ hGetChar h + + +-- | Utility function to correctly get a ByteString line of input. +hGetLine :: Handle -> MaybeT IO ByteString +hGetLine h = do + atEOF <- liftIO $ hIsEOF h + guard (not atEOF) + -- It's more efficient to use B.getLine, but that function throws an + -- error if the Handle (e.g., stdin) is set to NoBuffering. + buff <- liftIO $ hGetBuffering h + liftIO $ if buff == NoBuffering + then hWithBinaryMode h $ fmap B.pack $ System.IO.hGetLine h + else B.hGetLine h + +-- If another character is immediately available, and it is a newline, consume it. +-- +-- Two portability fixes: +-- +-- 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. +-- +-- 2) Also note that on Windows with ghc<6.10, hReady may not behave correctly (#1198) +-- The net result is that this might cause +-- But this function will generally only be used when reading buffered input +-- (since stdin isn't a terminal), so it should probably be OK. +hMaybeReadNewline :: Handle -> IO () +hMaybeReadNewline h = returnOnEOF () $ do + ready <- hReady h + when ready $ do + c <- hLookAhead h + when (c == '\n') $ getChar >> return () + +returnOnEOF :: MonadException m => a -> m a -> m a +returnOnEOF x = handle $ \e -> if isEOFError e + then return x + else throwIO e diff --git a/System/Console/Haskeline/Vi.hs b/System/Console/Haskeline/Vi.hs --- a/System/Console/Haskeline/Vi.hs +++ b/System/Console/Haskeline/Vi.hs @@ -406,7 +406,7 @@ searchText SearchEntry {entryState = IMode xs ys} = reverse xs ++ ys instance LineState SearchEntry where - beforeCursor prefix se = beforeCursor (prefix ++ [searchChar se]) + beforeCursor prefix se = beforeCursor (prefix ++ stringToGraphemes [searchChar se]) (entryState se) afterCursor = afterCursor . entryState diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -9,6 +9,8 @@ Usage: ./Test (line input) ./Test chars (character input) +./Test password (no masking characters) +./Test password \* --} mySettings :: Settings IO @@ -19,6 +21,8 @@ args <- getArgs let inputFunc = case args of ["chars"] -> fmap (fmap (\c -> [c])) . getInputChar + ["password"] -> getPassword Nothing + ["password", [c]] -> getPassword (Just c) _ -> getInputLine runInputT mySettings $ withInterrupt $ loop inputFunc 0 where diff --git a/haskeline.cabal b/haskeline.cabal --- a/haskeline.cabal +++ b/haskeline.cabal @@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.6 -Version: 0.6.2.4 +Version: 0.6.3 Category: User Interfaces License: BSD3 License-File: LICENSE @@ -50,7 +50,7 @@ } else { if impl(ghc>=6.11) { - Build-depends: base >=4.1 && < 4.4, containers>=0.1 && < 0.4, directory==1.0.*, + Build-depends: base >=4.1 && < 4.4, containers>=0.1 && < 0.5, directory==1.0.*, bytestring==0.9.* } else {