Commits (15)
......@@ -3,3 +3,4 @@ dist/
dist-install
ghc.mk
.stack-work
myhist
......@@ -11,8 +11,8 @@ matrix:
addons: {apt: {packages: [cabal-install-2.0, ghc-8.2.2], sources: [hvr-ghc]}}
- env: CABALVER=2.2 GHCVER=8.4.3
addons: {apt: {packages: [cabal-install-2.2, ghc-8.4.3], sources: [hvr-ghc]}}
- env: CABALVER=2.4 GHCVER=8.6.1
addons: {apt: {packages: [cabal-install-2.4, ghc-8.6.1], sources: [hvr-ghc]}}
- env: CABALVER=2.4 GHCVER=8.6.3
addons: {apt: {packages: [cabal-install-2.4, ghc-8.6.3], sources: [hvr-ghc]}}
install:
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
......
Changed in version 0.8.0.1:
* Add a Cabal flag to disable the example executable as well as
the test that uses it.
Changed in version 0.8.0.0:
* Breaking changes:
* Add a `MonadFail` instance for `InputT`.
* Switch the LICENSE file from BSD2 to BSD3, to be consistent
with the .cabal file.
* Backwards-compatible changes
* Improve the documentation around when input functions return
`Nothing`.
* Allow binding keys to incremental search, as
`ReverseSearchHistory` and `ForwardSearchHistory`.
* Handling `STX`-wrapped control sequences on any lines of the
prompt, not just the last one.
* Add `debugTerminalKeys` to help debug input problems
* Add `waitForAnyKey` to wait for a single key press.
* Define test targest in the .cabal file
* Bump the upper bound to base-4.15.
Changed in version 0.7.5.0:
* Add the new function `fallbackCompletion` to combine
multiple `CompletionFunc`s
* Fix warnings
* Bump the lower bound to ghc-8.0
Changed in version 0.7.4.3:
* Bump upper bounds on base, containers, stm and unix
* Fix redundant "Category" field in haskeline.cabal
......
Copyright 2007-2009, Judah Jacobson.
All Rights Reserved.
Copyright 2007 Judah Jacobson
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
- Redistribution of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
- Redistribution in binary form must reproduce the above copyright notice,
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY
EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
3. Neither the name of the copyright holder nor the names of its contributors
may be used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
......@@ -47,6 +47,7 @@ module System.Console.Haskeline(
getInputLineWithInitial,
getInputChar,
getPassword,
waitForAnyKey,
-- ** Outputting text
-- $outputfncs
outputStr,
......@@ -91,6 +92,7 @@ import System.Console.Haskeline.RunCommand
import Control.Monad.Catch (MonadMask, handle)
import Data.Char (isSpace, isPrint)
import Data.Maybe (isJust)
import System.IO
......@@ -127,11 +129,13 @@ outputStrLn = outputStr . (++ "\n")
{- $inputfncs
The following functions read one line or character of input from the user.
When using terminal-style interaction, these functions return 'Nothing' if the user
pressed @Ctrl-D@ when the input text was empty.
They return `Nothing` if they encounter the end of input. More specifically:
When using file-style interaction, these functions return 'Nothing' if
an @EOF@ was encountered before any characters were read.
- When using terminal-style interaction, they return `Nothing` if the user
pressed @Ctrl-D@ when the input text was empty.
- When using file-style interaction, they return `Nothing` if an @EOF@ was
encountered before any characters were read.
-}
......@@ -169,7 +173,7 @@ getInputLineWithInitial prompt (left,right) = promptedInput (getInputCmdLine ini
where
initialIM = insertString left $ moveToStart $ insertString right $ emptyIM
getInputCmdLine :: (MonadIO m, MonadMask m) => InsertMode -> TermOps -> String -> InputT m (Maybe String)
getInputCmdLine :: (MonadIO m, MonadMask m) => InsertMode -> TermOps -> Prefix -> InputT m (Maybe String)
getInputCmdLine initialIM tops prefix = do
emode <- InputT $ asks editMode
result <- runInputCmdT tops $ case emode of
......@@ -216,7 +220,7 @@ getPrintableChar fops = do
Just False -> getPrintableChar fops
_ -> return c
getInputCmdChar :: (MonadIO m, MonadMask m) => TermOps -> String -> InputT m (Maybe Char)
getInputCmdChar :: (MonadIO m, MonadMask m) => TermOps -> Prefix -> InputT m (Maybe Char)
getInputCmdChar tops prefix = runInputCmdT tops
$ runCommandLoop tops prefix acceptOneChar emptyIM
......@@ -227,6 +231,32 @@ acceptOneChar = choiceCmd [useChar $ \c s -> change (insertChar c) s
keyCommand acceptOneChar
, ctrlChar 'd' +> failCmd]
----------
{- | Waits for one key to be pressed, then returns. Ignores the value
of the specific key.
Returns 'True' if it successfully accepted one key. Returns 'False'
if it encountered the end of input; i.e., an @EOF@ in file-style interaction,
or a @Ctrl-D@ in terminal-style interaction.
When using file-style interaction, consumes a single character from the input which may
be non-printable.
-}
waitForAnyKey :: (MonadIO m, MonadMask m)
=> String -- ^ The input prompt
-> InputT m Bool
waitForAnyKey = promptedInput getAnyKeyCmd
$ \fops -> fmap isJust . runMaybeT $ getLocaleChar fops
getAnyKeyCmd :: (MonadIO m, MonadMask m) => TermOps -> Prefix -> InputT m Bool
getAnyKeyCmd tops prefix = runInputCmdT tops
$ runCommandLoop tops prefix acceptAnyChar emptyIM
where
acceptAnyChar = choiceCmd
[ ctrlChar 'd' +> const (return False)
, KeyMap $ const $ Just (Consumed $ const $ return True)
]
----------
-- Passwords
......@@ -273,7 +303,7 @@ and 'historyFile' flags.
-- | Wrapper for input functions.
-- This is the function that calls "wrapFileInput" around file backend input
-- functions (see Term.hs).
promptedInput :: MonadIO m => (TermOps -> String -> InputT m a)
promptedInput :: MonadIO m => (TermOps -> Prefix -> InputT m a)
-> (FileOps -> IO a)
-> String -> InputT m a
promptedInput doTerm doFile prompt = do
......@@ -286,9 +316,13 @@ promptedInput doTerm doFile prompt = do
putStrOut rterm prompt
wrapFileInput fops $ doFile fops
Left tops -> do
-- Convert the full prompt to graphemes (not just the last line)
-- to account for the `\ESC...STX` appearing anywhere in it.
let prompt' = stringToGraphemes prompt
-- If the prompt contains newlines, print all but the last line.
let (lastLine,rest) = break (`elem` "\r\n") $ reverse prompt
outputStr $ reverse rest
let (lastLine,rest) = break (`elem` stringToGraphemes "\r\n")
$ reverse prompt'
outputStr $ graphemesToString $ reverse rest
doTerm tops $ reverse lastLine
{- | If Ctrl-C is pressed during the given action, throw an exception
......
......@@ -46,6 +46,8 @@ simpleActions = choiceCmd
, completionCmd (simpleChar '\t')
, simpleKey UpKey +> historyBack
, simpleKey DownKey +> historyForward
, simpleKey SearchReverse +> searchForPrefix Reverse
, simpleKey SearchForward +> searchForPrefix Forward
, searchHistory
]
......
......@@ -13,6 +13,7 @@ import System.Console.Haskeline.Term
import Control.Exception (IOException)
import Control.Monad.Catch
import Control.Monad.Fail as Fail
import Control.Monad.Fix
import Data.IORef
import System.Directory(getHomeDirectory)
......@@ -58,6 +59,9 @@ newtype InputT m a = InputT {unInputT ::
instance MonadTrans InputT where
lift = InputT . lift . lift . lift . lift . lift
instance ( Fail.MonadFail m ) => Fail.MonadFail (InputT m) where
fail = lift . Fail.fail
instance ( MonadFix m ) => MonadFix (InputT m) where
mfix f = InputT (mfix (unInputT . f))
......
module System.Console.Haskeline.Internal
( debugTerminalKeys ) where
import System.Console.Haskeline (defaultSettings, outputStrLn)
import System.Console.Haskeline.Command
import System.Console.Haskeline.InputT
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Monads
import System.Console.Haskeline.RunCommand
import System.Console.Haskeline.Term
-- | This function may be used to debug Haskeline's input.
--
-- It loops indefinitely; every time a key is pressed, it will
-- print that key as it was recognized by Haskeline.
-- Pressing Ctrl-C will stop the loop.
--
-- Haskeline's behavior may be modified by editing your @~/.haskeline@
-- file. For details, see: <https://github.com/judah/haskeline/wiki/CustomKeyBindings>
--
debugTerminalKeys :: IO a
debugTerminalKeys = runInputT defaultSettings $ do
outputStrLn
"Press any keys to debug Haskeline's input, or ctrl-c to exit:"
rterm <- InputT ask
case termOps rterm of
Right _ -> error "debugTerminalKeys: not run in terminal mode"
Left tops -> runInputCmdT tops $ runCommandLoop tops prompt
loop emptyIM
where
loop = KeyMap $ \k -> Just $ Consumed $
(const $ do
effect (LineChange $ const ([],[]))
effect (PrintLines [show k])
setState emptyIM)
>|> keyCommand loop
prompt = stringToGraphemes "> "
......@@ -11,19 +11,26 @@ module System.Console.Haskeline.Key(Key(..),
parseKey
) where
import Data.Bits
import Data.Char
import Control.Monad
import Data.Maybe
import Data.Bits
import Data.List (intercalate)
import Control.Monad
data Key = Key Modifier BaseKey
deriving (Show,Eq,Ord)
deriving (Eq,Ord)
instance Show Key where
show (Key modifier base)
| modifier == noModifier = show base
| otherwise = show modifier ++ "-" ++ show base
data Modifier = Modifier {hasControl, hasMeta, hasShift :: Bool}
deriving (Eq,Ord)
instance Show Modifier where
show m = show $ catMaybes [maybeUse hasControl "ctrl"
show m = intercalate "-"
$ catMaybes [maybeUse hasControl "ctrl"
, maybeUse hasMeta "meta"
, maybeUse hasShift "shift"
]
......@@ -33,13 +40,40 @@ instance Show Modifier where
noModifier :: Modifier
noModifier = Modifier False False False
-- Note: a few of these aren't really keys (e.g., KillLine),
-- but they provide useful enough binding points to include.
data BaseKey = KeyChar Char
| FunKey Int
| LeftKey | RightKey | DownKey | UpKey
-- TODO: is KillLine really a key?
| KillLine | Home | End | PageDown | PageUp
| Backspace | Delete
deriving (Show,Eq,Ord)
| SearchReverse | SearchForward
deriving (Eq, Ord)
instance Show BaseKey where
show (KeyChar '\n') = "Return"
show (KeyChar '\t') = "Tab"
show (KeyChar '\ESC') = "Esc"
show (KeyChar c)
| isPrint c = [c]
| isPrint unCtrld = "ctrl-" ++ [unCtrld]
| otherwise = show c
where
unCtrld = toEnum (fromEnum c .|. ctrlBits)
show (FunKey n) = 'f' : show n
show LeftKey = "Left"
show RightKey = "Right"
show DownKey = "Down"
show UpKey = "Up"
show KillLine = "KillLine"
show Home = "Home"
show End = "End"
show PageDown = "PageDown"
show PageUp = "PageUp"
show Backspace = "Backspace"
show Delete = "Delete"
show SearchReverse = "SearchReverse"
show SearchForward = "SearchForward"
simpleKey :: BaseKey -> Key
simpleKey = Key noModifier
......@@ -58,7 +92,10 @@ ctrlChar = simpleChar . setControlBits
setControlBits :: Char -> Char
setControlBits '?' = toEnum 127
setControlBits c = toEnum $ fromEnum c .&. complement (bit 5 .|. bit 6)
setControlBits c = toEnum $ fromEnum c .&. complement ctrlBits
ctrlBits :: Int
ctrlBits = bit 5 .|. bit 6
specialKeys :: [(String,BaseKey)]
specialKeys = [("left",LeftKey)
......@@ -77,6 +114,8 @@ specialKeys = [("left",LeftKey)
,("tab",KeyChar '\t')
,("esc",KeyChar '\ESC')
,("escape",KeyChar '\ESC')
,("reversesearchhistory",SearchReverse)
,("forwardsearchhistory",SearchForward)
]
parseModifiers :: [String] -> BaseKey -> Key
......
......@@ -12,13 +12,13 @@ import Control.Monad
import Control.Monad.Catch (handle, throwM)
runCommandLoop :: (CommandMonad m, MonadState Layout m, LineState s)
=> TermOps -> String -> KeyCommand m s a -> s -> m a
=> TermOps -> Prefix -> KeyCommand m s a -> s -> m a
runCommandLoop tops@TermOps{evalTerm = e} prefix cmds initState
= case e of -- NB: Need to separate this case out from the above pattern
-- in order to build on ghc-6.12.3
EvalTerm eval liftE
-> eval $ withGetEvent tops
$ runCommandLoop' liftE tops (stringToGraphemes prefix) initState
$ runCommandLoop' liftE tops prefix initState
cmds
runCommandLoop' :: forall m n s a . (Term n, CommandMonad n,
......
......@@ -61,6 +61,8 @@ simpleInsertions = choiceCmd
, ctrlChar 'l' +> clearScreenCmd
, simpleKey UpKey +> historyBack
, simpleKey DownKey +> historyForward
, simpleKey SearchReverse +> searchForPrefix Reverse
, simpleKey SearchForward +> searchForPrefix Forward
, searchHistory
, simpleKey KillLine +> killFromHelper (SimpleMove moveToStart)
, ctrlChar 'w' +> killFromHelper wordErase
......
......@@ -2,7 +2,6 @@ module Main where
import System.Console.Haskeline
import System.Environment
import Control.Exception (AsyncException(..))
{--
Testing the line-input functions and their interaction with ctrl-c signals.
......@@ -29,8 +28,9 @@ main = do
_ -> getInputLine
runInputT mySettings $ withInterrupt $ loop inputFunc 0
where
loop :: (String -> InputT IO (Maybe String)) -> Int -> InputT IO ()
loop inputFunc n = do
minput <- handle (\Interrupt -> return (Just "Caught interrupted"))
minput <- handleInterrupt (return (Just "Caught interrupted"))
$ inputFunc (show n ++ ":")
case minput of
Nothing -> return ()
......
Name: haskeline
Cabal-Version: >=1.10
Version: 0.8.0.0
Version: 0.8.0.1
Category: User Interfaces
License: BSD3
License-File: LICENSE
......@@ -38,11 +38,18 @@ flag terminfo
Default: True
Manual: True
-- Help the GHC build by making it possible to disable the extra binary.
-- TODO: Make GHC handle packages with both a library and an executable.
flag examples
Description: Enable executable components used for tests.
Default: True
Manual: True
Library
-- We require ghc>=7.4.1 (base>=4.5) to use the base library encodings, even
-- though it was implemented in earlier releases, due to GHC bug #5436 which
-- wasn't fixed until 7.4.1
Build-depends: base >=4.9 && < 4.13, containers>=0.4 && < 0.7,
Build-depends: base >=4.9 && < 4.15, containers>=0.4 && < 0.7,
directory>=1.1 && < 1.4, bytestring>=0.9 && < 0.11,
filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.6,
process >= 1.0 && < 1.7, stm >= 2.4 && < 2.6,
......@@ -63,6 +70,7 @@ Library
System.Console.Haskeline.Completion
System.Console.Haskeline.History
System.Console.Haskeline.IO
System.Console.Haskeline.Internal
Other-Modules:
System.Console.Haskeline.Backend
System.Console.Haskeline.Backend.WCWidth
......@@ -108,4 +116,31 @@ Library
cpp-options: -DUSE_TERMIOS_H
}
}
ghc-options: -Wall
test-suite haskeline-tests
type: exitcode-stdio-1.0
hs-source-dirs: tests
Default-Language: Haskell98
if os(windows) {
buildable: False
}
if !flag(examples) {
buildable: False
}
Main-Is: Unit.hs
Build-depends: base, containers, text, bytestring, HUnit, process, unix
Other-Modules: RunTTY, Pty
build-tool-depends: haskeline:haskeline-examples-Test
-- The following program is used by unit tests in `tests` executable
Executable haskeline-examples-Test
if !flag(examples) {
buildable: False
}
Build-depends: base, containers, haskeline
Default-Language: Haskell2010
hs-source-dirs: examples
Main-Is: Test.hs
cd tests # one of the tab completion tests is completing the dummy- dir in tests
stack exec haskeline-tests $(stack path --local-install-root)/bin/haskeline-examples-Test
resolver: lts-9.14
resolver: lts-13.6
packages:
- .
......
......@@ -18,9 +18,7 @@ import Foreign.Marshal.Alloc
import Foreign.C.Error
import Foreign.C.Types
import Foreign.Ptr
import Control.Exception
import Control.Concurrent
import Control.Monad (liftM2)
-- Run the given command in a pseudoterminal, and return its output chunks.
-- Read the initial output, then feed the given input to it
......@@ -38,7 +36,7 @@ runCommandInPty prog args env inputs = do
setFdOption fd NonBlockingRead True
outputs <- mapM (inputOutput fd) inputs
signalProcess killProcess pid
status <- getProcessStatus True False pid
_status <- getProcessStatus True False pid
closeFd fd
return (firstOutput : outputs)
......
{-# LANGUAGE RecordWildCards #-}
-- This module provides an interface for testing the output
-- of programs that expect to be run in a terminal.
module RunTTY (Invocation(..),
runInvocation,
module RunTTY (Invocation(..),
runInvocation,
assertInvocation,
testI,
setLang,
......@@ -11,14 +11,12 @@ module RunTTY (Invocation(..),
setUTF8
) where
import Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import System.Posix.Env.ByteString hiding (setEnv)
import System.Process
import Control.Concurrent
import Data.ByteString as B
import System.IO
import System.Process
import Test.HUnit
import Control.Monad (unless, liftM2, zipWithM_)
import qualified Data.ByteString.Char8 as BC
import Pty
......@@ -32,19 +30,23 @@ data Invocation = Invocation {
setEnv :: String -> String -> Invocation -> Invocation
setEnv var val Invocation {..} = Invocation{
environment = (var,val) : Prelude.filter ((/=var).fst) environment
environment = (var,val) : Prelude.filter ((/=var).fst) environment
,..
}
setLang :: String -> Invocation -> Invocation
setLang = setEnv "LANG"
setTerm :: String -> Invocation -> Invocation
setTerm = setEnv "TERM"
setUTF8 :: Invocation -> Invocation
setUTF8 = setLang "en_US.UTF-8"
setLatin1 :: Invocation -> Invocation
setLatin1 = setLang "en_US.ISO8859-1"
runInvocation :: Invocation
runInvocation :: Invocation
-> [B.ByteString] -- Input chunks. (We pause after each chunk to
-- simulate real user input and prevent Haskeline
-- from coalescing the changes.)
......@@ -65,7 +67,7 @@ runInvocation Invocation {..} inputs
hClose inH
lastOutput <- getOutput outH -- output triggered by EOF, if any
terminateProcess ph
waitForProcess ph
_ <- waitForProcess ph
return $ firstOutput : outputs
++ if B.null lastOutput then [] else [lastOutput]
......@@ -90,6 +92,7 @@ assertInvocation i input expectedOutput = do
-- Remove CRLFs from output, since tty translates all LFs into CRLF.
-- (TODO: I'd like to just unset ONLCR in the slave tty, but
-- System.Posix.Terminal doesn't support that flag.)
fixOutput :: B.ByteString -> B.ByteString
fixOutput = BC.pack . loop . BC.unpack
where
loop ('\r':'\n':rest) = '\n' : loop rest
......@@ -102,35 +105,5 @@ assertSameList (x:xs) (y:ys)
| x == y = assertSameList xs ys
assertSameList xs ys = xs @=? ys -- cause error to be thrown
assertSame :: B.ByteString -> B.ByteString -> Assertion
assertSame expected actual = do
let (same,expected',actual') = commonPrefix expected actual
unless (B.null expected' && B.null actual') $ assertFailure
$ "With common prefix " ++ show same ++ "\n"
++ " expected: " ++ show expected' ++ "\n"
++ " but got: " ++ show actual'
++ if normalizeErrs expected' == normalizeErrs actual'
then "\n (Same except for error chars)"
else ""
commonPrefix :: B.ByteString -> B.ByteString
-> (B.ByteString, B.ByteString,B.ByteString)
commonPrefix xs ys = loop 0
where
loop k
| k < B.length xs && k < B.length ys
&& xs `B.index` k == ys `B.index` k
= loop (k+1)
| otherwise = (B.take k xs, B.drop k xs, B.drop k ys)
normalizeErrs = BC.pack . loop . BC.unpack
where
loop ('\239':'\191':'\189':rest) = loop rest
loop ('?':rest) = loop rest
loop (c:cs) = c : loop cs
loop [] = []
testI :: Invocation -> [B.ByteString] -> [B.ByteString] -> Test
testI i inp outp = test $ assertInvocation i inp outp
{-# LANGUAGE OverloadedStrings #-}
-- Usage:
-- ghc ../examples/Test.hs
-- ghc Unit.hs
-- ./Unit ../examples/Test
-- Requirements:
-- - Empty ~/.haskeline (or set to defaults)
-- - Assumes the dummy folder is in the current folder
-- - On Mac OS X, may need to clear out /usr/lib/charset.alias
-- (In particular, the line "* UTF-8" which makes locale_charset()
-- always return UTF-8; otherwise we can't test latin-1.)
-- - On Mac OS X, the "dumb term" test may fail.
-- In particular, the line "* UTF-8" which makes locale_charset()
-- always return UTF-8; otherwise we can't test latin-1.
-- - NB: Window size isn't provided by screen so it's picked up from
-- terminfo or defaults (either way: 80x24), rather than the user's
-- terminal.
module Main where
import System.Environment
import Test.HUnit
import Control.Monad (when)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.Word
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Monoid ((<>))
import System.Exit (exitFailure)
import System.Process (readProcess)
import Test.HUnit
import RunTTY
......@@ -33,10 +31,13 @@ legacyEncoding = False
-- 2. if there's an incomplete sequence and no more input immediately
-- available (but not eof), then base will pause to wait for more input,
-- whereas legacy will immediately stop.
whenLegacy :: BC.ByteString -> BC.ByteString
whenLegacy s = if legacyEncoding then s else B.empty
main :: IO ()
main = do
[p] <- getArgs
-- forkProcess needs an absolute path to the binary.
p <- head . lines <$> readProcess "which" ["haskeline-examples-Test"] ""
let i = setTerm "xterm"
Invocation {
prog = p,
......@@ -44,9 +45,10 @@ main = do
runInTTY = True,
environment = []
}
runTestTT $ test [interactionTests i, fileStyleTests i]
result <- runTestTT $ test [interactionTests i, fileStyleTests i]
when (errors result > 0 || failures result > 0) exitFailure
interactionTests :: Invocation -> Test
interactionTests i = "interaction" ~: test
[ unicodeEncoding i
, unicodeMovement i
......@@ -57,6 +59,7 @@ interactionTests i = "interaction" ~: test
, dumbTests $ setTerm "dumb" i
]
unicodeEncoding :: Invocation -> Test
unicodeEncoding i = "Unicode encoding (valid)" ~:
[ utf8Test i [utf8 "xαβγy"]
[prompt 0, utf8 "xαβγy"]
......@@ -81,13 +84,14 @@ unicodeEncoding i = "Unicode encoding (valid)" ~:
where
l1 = utf8 $ T.replicate 30 "안" -- three bytes, width 60
unicodeMovement :: Invocation -> Test
unicodeMovement i = "Unicode movement" ~:
[ "separate" ~: utf8Test i [utf8 "α", utf8 "\ESC[Dx"]
[prompt 0, utf8 "α", utf8 "\b\b"]
, "coalesced" ~: utf8Test i [utf8 \ESC[Dx"]
[prompt 0, utf8 "xα\b"]
, "lineWrap" ~: utf8Test i
[ utf8 longWideChar
[ utf8 longWideChar
, raw [1]
, raw [5]
]
......@@ -101,24 +105,26 @@ unicodeMovement i = "Unicode movement" ~:
longWideChar = T.concat $ replicate 30 $ "안기영"
(lwc1,lwcs1) = T.splitAt ((80-2)`div`2) longWideChar
(lwc2,lwcs2) = T.splitAt (80`div`2) lwcs1
(lwc3,lwcs3) = T.splitAt (80`div`2) lwcs2
(lwc3,_lwcs3) = T.splitAt (80`div`2) lwcs2
-- lwc3 has length 90 - (80-2)/2 - 80/2 = 11,
-- so the last line as wide width 2*11=22.
tabCompletion :: Invocation -> Test
tabCompletion i = "tab completion" ~:
[ utf8Test i [ utf8 "dummy-μ\t\t" ]
[ prompt 0, utf8 "dummy-μασ/"
<> nl <> utf8 "bar ςερτ" <> nl
<> prompt' 0 <> utf8 "dummy-μασ/"
[ utf8Test i [ utf8 "tests/dummy-μ\t\t" ]
[ prompt 0, utf8 "tests/dummy-μασ/"
<> nl <> utf8 "ςερτ bar" <> nl
<> prompt' 0 <> utf8 "tests/dummy-μασ/"
]
]
incorrectInput :: Invocation -> Test
incorrectInput i = "incorrect input" ~:
[ utf8Test i [ utf8 "x" <> raw [206] ] -- needs one more byte
-- non-legacy encoder ignores the "206" since it's still waiting
-- for more input.
[ prompt 0, utf8 "x" <> whenLegacy err ]
, utf8Test i [ raw [206] <> utf8 "x" ]
, utf8Test i [ raw [206] <> utf8 "x" ]
-- 'x' is not valid after '\206', so both the legacy and
-- non-legacy encoders should handle the "x" correctly.
[ prompt 0, err <> utf8 "x"]
......@@ -126,6 +132,7 @@ incorrectInput i = "incorrect input" ~:
[prompt 0, err <> err <> utf8 "x"]
]
historyTests :: Invocation -> Test
historyTests i = "history encoding" ~:
[ utf8TestValidHist i [ "\ESC[A" ]
[prompt 0, utf8 "abcα" ]
......@@ -138,16 +145,19 @@ historyTests i = "history encoding" ~:
[prompt 0, utf8 "abc??x?x?" ]
]
invalidHist = utf8 "abcα"
invalidHist :: BC.ByteString
invalidHist = utf8 "abcα"
`B.append` raw [149] -- invalid start of UTF-8 sequence
`B.append` utf8 "x"
`B.append` raw [206] -- incomplete start
`B.append` raw [206] -- incomplete start
`B.append` utf8 "x"
-- incomplete at end of file
`B.append` raw [206]
validHist :: BC.ByteString
validHist = utf8 "abcα"
inputChar :: Invocation -> Test
inputChar i = "getInputChar" ~:
[ utf8Test i [utf8 "xαβ"]
[ prompt 0, utf8 "x" <> end <> output 0 (utf8 "x")
......@@ -155,14 +165,14 @@ inputChar i = "getInputChar" ~:
<> prompt 2 <> utf8 "β" <> end <> output 2 (utf8 "β")
<> prompt 3
]
, "bad encoding (separate)" ~:
, "bad encoding (separate)" ~:
utf8Test i [utf8 "α", raw [149], utf8 "x", raw [206]]
[ prompt 0, utf8 "α" <> end <> output 0 (utf8 "α") <> prompt 1
, err <> end <> output 1 err <> prompt 2
, utf8 "x" <> end <> output 2 (utf8 "x") <> prompt 3
, whenLegacy (err <> end <> output 3 err <> prompt 4)
]
, "bad encoding (together)" ~:
, "bad encoding (together)" ~:
utf8Test i [utf8 "α" <> raw [149] <> utf8 "x" <> raw [206]]
[ prompt 0, utf8 "α" <> end <> output 0 (utf8 "α")
<> prompt 1 <> err <> end <> output 1 err
......@@ -175,9 +185,11 @@ inputChar i = "getInputChar" ~:
]
]
setCharInput :: Invocation -> Invocation
setCharInput i = i { progArgs = ["chars"] }
fileStyleTests :: Invocation -> Test
fileStyleTests i = "file style" ~:
[ "line input" ~: utf8Test iFile
[utf8 "xαβyψ안기q영\nquit\n"]
......@@ -194,7 +206,7 @@ fileStyleTests i = "file style" ~:
-- NOTE: the 206 is an incomplete byte sequence,
-- but we MUST not pause since we're at EOF, not just
-- end of term.
--
--
-- Also recall GHC bug #5436 which caused a crash
-- if the last byte started an incomplete sequence.
[ utf8 "a" <> raw [149] <> utf8 "x" <> raw [206] ]
......@@ -234,6 +246,7 @@ fileStyleTests i = "file style" ~:
-- If all the above tests work for the terminfo backend,
-- then we just need to make sure the dumb term plugs into everything
-- correctly, i.e., encodes the input/output and doesn't double-encode.
dumbTests :: Invocation -> Test
dumbTests i = "dumb term" ~:
[ "line input" ~: utf8Test i
[ utf8 "xαβγy" ]
......@@ -283,9 +296,6 @@ output k s = utf8 (T.pack $ "line " ++ show k ++ ":")
wrap :: B.ByteString
wrap = utf8 " \b"
(<>) :: B.ByteString -> B.ByteString -> B.ByteString
(<>) = B.append
utf8 :: T.Text -> B.ByteString
utf8 = E.encodeUtf8
......@@ -299,16 +309,24 @@ err = if legacyEncoding
----------------------
utf8Test ::
Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test
utf8Test = testI . setUTF8
utf8TestInvalidHist i input output = test $ do
utf8TestInvalidHist ::
Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test
utf8TestInvalidHist i input output' = test $ do
B.writeFile "myhist" $ invalidHist
assertInvocation (setUTF8 i) input output
assertInvocation (setUTF8 i) input output'
utf8TestValidHist i input output = test $ do
utf8TestValidHist ::
Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test
utf8TestValidHist i input output' = test $ do
B.writeFile "myhist" validHist
assertInvocation (setUTF8 i) input output
assertInvocation (setUTF8 i) input output'
latin1TestInvalidHist i input output = test $ do
latin1TestInvalidHist ::
Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test
latin1TestInvalidHist i input output' = test $ do
B.writeFile "myhist" $ invalidHist
assertInvocation (setLatin1 i) input output
assertInvocation (setLatin1 i) input output'