haskeline 0.5.0.1 → 0.6
raw patch · 17 files changed
+599/−190 lines, 17 filesdep −stm
Dependencies removed: stm
Files
- LICENSE +1/−1
- System/Console/Haskeline.hs +13/−9
- System/Console/Haskeline/Backend.hs +6/−0
- System/Console/Haskeline/Backend/DumbTerm.hs +16/−15
- System/Console/Haskeline/Backend/IConv.hsc +130/−0
- System/Console/Haskeline/Backend/Posix.hsc +88/−66
- System/Console/Haskeline/Backend/Terminfo.hs +77/−37
- System/Console/Haskeline/Backend/Win32.hsc +77/−21
- System/Console/Haskeline/Command.hs +1/−1
- System/Console/Haskeline/Command/Completion.hs +1/−1
- System/Console/Haskeline/Completion.hs +2/−3
- System/Console/Haskeline/Directory.hsc +96/−0
- System/Console/Haskeline/Encoding.hs +40/−0
- System/Console/Haskeline/InputT.hs +4/−9
- System/Console/Haskeline/Term.hs +28/−20
- System/Console/Haskeline/Vi.hs +2/−2
- haskeline.cabal +17/−5
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2007-2008, Judah Jacobson.+Copyright 2007-2009, Judah Jacobson. All Rights Reserved. Redistribution and use in source and binary forms, with or without
System/Console/Haskeline.hs view
@@ -71,10 +71,10 @@ import System.Console.Haskeline.Key import System.IO-import qualified System.IO.UTF8 as UTF8 import Data.Char (isSpace) import Control.Monad import Data.Char(isPrint)+import qualified Data.ByteString.Char8 as B @@ -96,10 +96,6 @@ {- $outputfncs The following functions allow cross-platform output of text that may contain Unicode characters.--If 'stdout' is not connected to a terminal (for example,-piped to another process), Haskeline will treat it as a UTF-8-encoded file-handle. -} -- | Write a string to the standard output.@@ -122,8 +118,8 @@ They 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, it will be-treated as a UTF8-encoded file handle. These functions print the prompt to 'stdout',+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. -} @@ -181,6 +177,7 @@ loop [] s processor = do event <- handle (\(e::SomeException) -> movePast prefix s >> throwIO e) getEvent case event of+ ErrorEvent e -> movePast prefix s >> throwIO e WindowResize -> withReposition tops prefix s $ loop [] s processor KeyInput k -> do ks <- lift $ asks $ lookupKeyBinding k@@ -200,7 +197,14 @@ atEOF <- hIsEOF stdin if atEOF then return Nothing- else liftM Just UTF8.getLine+ 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 -> fmap B.pack System.IO.getLine+ _ -> B.getLine+ fmap Just $ decodeForTerm rterm line drawEffect :: (LineState s, LineState t, Term (d m), MonadTrans d, MonadReader Prefs m) @@ -268,7 +272,7 @@ atEOF <- hIsEOF stdin if atEOF then return Nothing- else liftM Just getChar -- TODO: utf8?+ else liftM Just $ getLocaleChar rterm -- TODO: it might be possible to unify this function with getInputCmdLine, -- maybe by calling repeatTillFinish here...
System/Console/Haskeline/Backend.hs view
@@ -5,7 +5,9 @@ #ifdef MINGW import System.Console.Haskeline.Backend.Win32 as Win32 #else+#ifdef TERMINFO import System.Console.Haskeline.Backend.Terminfo as Terminfo+#endif import System.Console.Haskeline.Backend.DumbTerm as DumbTerm #endif @@ -14,9 +16,13 @@ #ifdef MINGW myRunTerm = win32Term #else+#ifndef TERMINFO+myRunTerm = runDumbTerm+#else myRunTerm = do mRun <- runTerminfoDraw case mRun of Nothing -> runDumbTerm Just run -> return run+#endif #endif
System/Console/Haskeline/Backend/DumbTerm.hs view
@@ -6,6 +6,7 @@ import System.Console.Haskeline.Monads as Monads import System.IO+import qualified Data.ByteString as B -- TODO: ---- Put "<" and ">" at end of term if scrolls off.@@ -17,31 +18,28 @@ initWindow :: Window initWindow = Window {pos=0} -newtype DumbTerm m a = DumbTerm {unDumbTerm :: ReaderT Handle (StateT Window m) a}- deriving (Monad,MonadIO, MonadState Window,MonadReader Handle)+newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a}+ deriving (Monad, MonadIO, MonadException,+ MonadState Window,+ MonadReader Handle, MonadReader Encoders) instance MonadReader Layout m => MonadReader Layout (DumbTerm m) where ask = lift ask local r = DumbTerm . local r . unDumbTerm -instance MonadException m => MonadException (DumbTerm m) where- block = DumbTerm . block . unDumbTerm- unblock = DumbTerm . unblock . unDumbTerm- catch (DumbTerm f) g = DumbTerm $ Monads.catch f (unDumbTerm . g)+instance MonadTrans DumbTerm where+ lift = DumbTerm . lift . lift . lift runDumbTerm :: IO RunTerm-runDumbTerm = posixRunTerm $ \h -> +runDumbTerm = posixRunTerm $ \enc h -> TermOps {- getLayout = getPosixLayout h Nothing,+ getLayout = tryGetLayouts (posixLayouts h), runTerm = \f -> - evalStateT' initWindow- (runReaderT' h (unDumbTerm- (withPosixGetEvent h Nothing f)))+ runPosixT enc h $ evalStateT' initWindow+ $ unDumbTerm+ $ withPosixGetEvent enc [] f } -instance MonadTrans DumbTerm where- lift = DumbTerm . lift . lift- instance (MonadException m, MonadLayout m) => Term (DumbTerm m) where reposition _ s = refitLine s drawLineDiff = drawLineDiff'@@ -53,7 +51,10 @@ ringBell False = return () printText :: MonadIO m => String -> DumbTerm m ()-printText str = ask >>= liftIO . flip putTerm str+printText str = do+ h <- ask+ posixEncode str >>= liftIO . B.hPutStr h+ liftIO $ hFlush h -- Things we can assume a dumb terminal knows how to do cr,crlf :: String
+ System/Console/Haskeline/Backend/IConv.hsc view
@@ -0,0 +1,130 @@+module System.Console.Haskeline.Backend.IConv(+ setLocale,+ getCodeset,+ openEncoder,+ openDecoder,+ openPartialDecoder,+ Result(..)+ ) where++import Foreign.C+import Foreign+import Data.ByteString (ByteString, useAsCStringLen, append)+import Data.ByteString.Internal (createAndTrim')+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as UTF8++#include <locale.h>+#include <langinfo.h>+#include <iconv.h>++openEncoder :: String -> IO (String -> IO ByteString)+openEncoder codeset = do+ encodeT <- iconvOpen codeset "UTF-8"+ return $ simpleIConv encodeT . UTF8.fromString++openDecoder :: String -> IO (ByteString -> IO String)+openDecoder codeset = do+ decodeT <- iconvOpen "UTF-8" codeset+ return $ fmap UTF8.toString . simpleIConv decodeT++-- handle errors by dropping unuseable chars.+simpleIConv :: IConvT -> ByteString -> IO ByteString+simpleIConv t bs = do+ (cs,result) <- iconv t bs+ case result of+ Invalid rest -> fmap (cs `append`) $ simpleIConv t (B.drop 1 rest)+ _ -> return cs++openPartialDecoder :: String -> IO (ByteString -> IO (String, Result))+openPartialDecoder codeset = do+ decodeT <- iconvOpen "UTF-8" codeset+ return $ \bs -> do+ (s,result) <- iconv decodeT bs+ return (UTF8.toString s,result)++---------------------+-- Setting the locale++foreign import ccall "setlocale" c_setlocale :: CInt -> CString -> IO CString++setLocale :: Maybe String -> IO (Maybe String)+setLocale oldLocale = (maybeWith withCString) oldLocale $ \loc_p -> do+ c_setlocale (#const LC_CTYPE) loc_p >>= maybePeek peekCString++-----------------+-- Getting the encoding++type NLItem = #type nl_item++foreign import ccall nl_langinfo :: NLItem -> IO CString++getCodeset :: IO String+getCodeset = nl_langinfo (#const CODESET) >>= peekCString+----------------+-- Iconv++-- TODO: This may not work on platforms where iconv_t is not a pointer.+type IConvT = ForeignPtr ()+type IConvTPtr = Ptr ()++foreign import ccall iconv_open :: CString -> CString -> IO IConvTPtr++iconvOpen :: String -> String -> IO IConvT+iconvOpen destName srcName = withCString destName $ \dest ->+ withCString srcName $ \src -> do+ res <- iconv_open dest src+ if res == nullPtr `plusPtr` (-1)+ then throwErrno "iconvOpen"+ else newForeignPtr iconv_close res++-- really this returns a CInt, but it's easiest to just ignore that, I think.+foreign import ccall "&" iconv_close :: FunPtr (IConvTPtr -> IO ())++foreign import ccall "iconv" c_iconv :: IConvTPtr -> Ptr CString -> Ptr CSize+ -> Ptr CString -> Ptr CSize -> IO CSize++data Result = Successful+ | Invalid ByteString+ | Incomplete ByteString+ deriving Show++iconv :: IConvT -> ByteString -> IO (ByteString,Result)+iconv cd inStr = useAsCStringLen inStr $ \(inPtr, inBuffLen) ->+ with inPtr $ \inBuff ->+ with (toEnum inBuffLen) $ \inBytesLeft -> do+ out <- loop inBuffLen (castPtr inBuff) inBytesLeft+ return out+ where+ -- TODO: maybe a better algorithm for increasing the buffer size?+ -- and also maybe a different starting buffer size?+ biggerBuffer = (+1)+ loop outSize inBuff inBytesLeft = do+ (bs, errno) <- partialIconv cd outSize inBuff inBytesLeft+ inLeft <- fmap fromEnum $ peek inBytesLeft+ let rest = B.drop (B.length inStr - inLeft) inStr+ case errno of+ Nothing -> return (bs,Successful)+ Just err + | err == e2BIG -> do -- output buffer too small+ (bs',result) <- loop (biggerBuffer outSize) inBuff inBytesLeft+ -- TODO: is this efficient enough?+ return (bs `append` bs', result)+ | err == eINVAL -> return (bs,Incomplete rest)+ | otherwise -> return (bs, Invalid rest)++partialIconv :: IConvT -> Int -> Ptr CString -> Ptr CSize -> IO (ByteString, Maybe Errno)+partialIconv cd outSize inBuff inBytesLeft =+ withForeignPtr cd $ \cd_p ->+ createAndTrim' outSize $ \outPtr ->+ with outPtr $ \outBuff ->+ with (toEnum outSize) $ \outBytesLeft -> do+ c_iconv cd_p inBuff inBytesLeft+ (castPtr outBuff) outBytesLeft+ outLeft <- fmap fromEnum $ peek outBytesLeft+ inLeft <- peek inBytesLeft+ errno <- if inLeft > 0+ then fmap Just getErrno+ else return Nothing+ return (0,outSize - outLeft,errno)+
System/Console/Haskeline/Backend/Posix.hsc view
@@ -1,26 +1,29 @@ module System.Console.Haskeline.Backend.Posix ( withPosixGetEvent,- getPosixLayout,+ posixLayouts,+ tryGetLayouts,+ PosixT,+ runPosixT,+ Encoders(),+ posixEncode, mapLines,- putTerm, posixRunTerm ) where import Foreign import Foreign.C.Types import qualified Data.Map as Map-import System.Console.Terminfo import System.Posix.Terminal hiding (Interrupt) import Control.Monad import Control.Concurrent hiding (throwTo)-import Control.Concurrent.STM-import Data.Maybe+import Control.Concurrent.Chan+import Data.Maybe (catMaybes) import System.Posix.Signals.Exts import System.Posix.IO(stdInput) import Data.List import System.IO import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as UTF8+import Data.ByteString.Char8 as Char8 (pack) import System.Environment import System.Console.Haskeline.Monads@@ -28,6 +31,8 @@ import System.Console.Haskeline.Term import System.Console.Haskeline.Prefs +import System.Console.Haskeline.Backend.IConv+ import GHC.IOBase (haFD,FD) import GHC.Handle (withHandle_) @@ -38,8 +43,8 @@ foreign import ccall ioctl :: CInt -> CULong -> Ptr a -> IO CInt -getPosixLayout :: Handle -> Maybe Terminal -> IO Layout-getPosixLayout h term = tryGetLayouts [ioctlLayout h, envLayout, tinfoLayout term]+posixLayouts :: Handle -> [IO (Maybe Layout)]+posixLayouts h = [ioctlLayout h, envLayout] ioctlLayout :: Handle -> IO (Maybe Layout) ioctlLayout h = allocaBytes (#size struct winsize) $ \ws -> do@@ -61,12 +66,6 @@ c <- getEnv "COLUMNS" return $ Just $ Layout {height=read r,width=read c} -tinfoLayout :: Maybe Terminal -> IO (Maybe Layout)-tinfoLayout = maybe (return Nothing) $ \t -> return $ getCapability t $ do- r <- termColumns- c <- termLines- return Layout {height=r,width=c}- tryGetLayouts :: [IO (Maybe Layout)] -> IO Layout tryGetLayouts [] = return Layout {height=24,width=80} tryGetLayouts (f:fs) = do@@ -80,11 +79,10 @@ -- Key sequences getKeySequences :: (MonadIO m, MonadReader Prefs m)- => Maybe Terminal -> m (TreeMap Char Key)-getKeySequences term = do+ => [(String,Key)] -> m (TreeMap Char Key)+getKeySequences tinfos = do sttys <- liftIO sttyKeys customKeySeqs <- getCustomKeySeqs- let tinfos = maybe [] terminfoKeys term -- note ++ acts as a union; so the below favors sttys over tinfos return $ listToTree $ ansiKeys ++ tinfos ++ sttys ++ customKeySeqs@@ -105,22 +103,6 @@ ,("\ESC[B", simpleKey DownKey) ,("\b", simpleKey Backspace)] -terminfoKeys :: Terminal -> [(String,Key)]-terminfoKeys term = catMaybes $ map getSequence keyCapabilities- where - getSequence (cap,x) = do - keys <- getCapability term cap- return (keys,x)- keyCapabilities = - [(keyLeft, simpleKey LeftKey)- ,(keyRight, simpleKey RightKey)- ,(keyUp, simpleKey UpKey)- ,(keyDown, simpleKey DownKey)- ,(keyBackspace, simpleKey Backspace)- ,(keyDeleteChar, simpleKey Delete)- ,(keyHome, simpleKey Home)- ,(keyEnd, simpleKey End)- ] sttyKeys :: IO [(String, Key)] sttyKeys = do@@ -179,24 +161,16 @@ ----------------------------- withPosixGetEvent :: (MonadTrans t, MonadIO m, MonadException (t m), MonadReader Prefs m) - => Handle -> Maybe Terminal -> (t m Event -> t m a) -> t m a-withPosixGetEvent h term f = do- baseMap <- lift $ getKeySequences term- eventChan <- liftIO $ newTChanIO- wrapKeypad h term $ withWindowHandler eventChan- $ f $ liftIO $ getEvent baseMap eventChan---- If the keypad on/off capabilities are defined, wrap the computation with them.-wrapKeypad :: MonadException m => Handle -> Maybe Terminal -> m a -> m a-wrapKeypad h = maybe id $ \term f -> (maybeOutput term keypadOn >> f) - `finally` maybeOutput term keypadOff- where- maybeOutput term cap = liftIO $ hRunTermOutput h term $- fromMaybe mempty (getCapability term cap)+ => Encoders -> [(String,Key)] -> (t m Event -> t m a) -> t m a+withPosixGetEvent enc termKeys f = do+ baseMap <- lift $ getKeySequences termKeys+ evenChan <- liftIO $ newChan+ withWindowHandler evenChan+ $ f $ liftIO $ getEvent enc baseMap evenChan -withWindowHandler :: MonadException m => TChan Event -> m a -> m a+withWindowHandler :: MonadException m => Chan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $ - Catch $ atomically $ writeTChan eventChan WindowResize+ Catch $ writeChan eventChan WindowResize withSigIntHandler :: MonadException m => m a -> m a withSigIntHandler f = do@@ -210,10 +184,10 @@ old_handler <- liftIO $ installHandler signal handler Nothing f `finally` liftIO (installHandler signal old_handler Nothing) -getEvent :: TreeMap Char Key -> TChan Event -> IO Event-getEvent baseMap = keyEventLoop readKeyEvents+getEvent :: Encoders -> TreeMap Char Key -> Chan Event -> IO Event+getEvent enc baseMap = keyEventLoop readKeyEvents where- bufferSize = 100+ 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@@ -221,9 +195,34 @@ threadWaitRead stdInput -- hWaitForInput doesn't work with -threaded on -- ghc < 6.10 (#2363 in ghc's trac) bs <- B.hGetNonBlocking stdin bufferSize- let cs = UTF8.toString bs+ cs <- convert (localeToUnicode enc) bs return $ map KeyInput $ lexKeys baseMap cs +-- 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+ (cs,result) <- decoder bs+ case result of+ Incomplete rest -> do+ extra <- B.hGetNonBlocking stdin 1+ if B.null extra+ then return cs -- ignore the incomplete shift sequence+ -- since no more input is available.+ else fmap (cs ++) $ convert decoder (rest `B.append` extra)+ _ -> return cs++-- NOTE: relys on getChar reading only 8 bytes.+getMultiByteChar :: (B.ByteString -> IO (String,Result)) -> IO Char+getMultiByteChar decoder = do+ b <- getChar+ cs <- convert decoder (Char8.pack [b])+ case cs of+ [] -> getMultiByteChar decoder+ (c:_) -> return c++ -- fails if stdin is not a handle or if we couldn't access /dev/tty. openTTY :: IO (Maybe Handle) openTTY = do@@ -234,28 +233,51 @@ return (Just h) else return Nothing -posixRunTerm :: (Handle -> TermOps) -> IO RunTerm+posixRunTerm :: (Encoders -> Handle -> TermOps) -> IO RunTerm posixRunTerm tOps = do+ fileRT <- fileRunTerm+ codeset <- getCodeset ttyH <- openTTY+ encoders <- liftM2 Encoders (openEncoder codeset) (openPartialDecoder codeset) case ttyH of- Nothing -> return fileRunTerm- Just h -> return RunTerm {- putStrOut = putTerm stdout,- closeTerm = hClose h,- wrapInterrupt = withSigIntHandler,- termOps = Just (wrapRunTerm (wrapTerminalOps h) (tOps h))+ 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 (wrapRunTerm (wrapTerminalOps h) (tOps encoders h)) } -putTerm :: Handle -> String -> IO ()-putTerm h str = B.hPutStr h (UTF8.fromString str) >> hFlush h+type PosixT m = ReaderT Encoders (ReaderT Handle m) -fileRunTerm :: RunTerm-fileRunTerm = RunTerm {putStrOut = putTerm stdout,- closeTerm = return (),+data Encoders = Encoders {unicodeToLocale :: String -> IO B.ByteString,+ localeToUnicode :: B.ByteString -> IO (String, Result)}++posixEncode :: (MonadIO m, MonadReader Encoders m) => String -> m B.ByteString+posixEncode str = do+ encoder <- asks unicodeToLocale+ liftIO $ encoder str++runPosixT :: Monad m => Encoders -> Handle -> PosixT m a -> m a+runPosixT enc h = runReaderT' h . runReaderT' enc++putTerm :: B.ByteString -> IO ()+putTerm str = B.putStr str >> hFlush stdout++fileRunTerm :: IO RunTerm+fileRunTerm = do+ 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,+ closeTerm = setLocale oldLocale >> return (), wrapInterrupt = withSigIntHandler,+ encodeForTerm = encoder,+ decodeForTerm = decoder,+ getLocaleChar = getMultiByteChar decoder', termOps = Nothing }- -- 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
System/Console/Haskeline/Backend/Terminfo.hs view
@@ -9,12 +9,14 @@ import Data.List(intersperse) import System.IO import qualified Control.Exception.Extensible as Exception+import qualified Data.ByteString.Char8 as B+import Data.Maybe (fromMaybe, catMaybes) import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.LineState import System.Console.Haskeline.Term import System.Console.Haskeline.Backend.Posix-import qualified Codec.Binary.UTF8.String as UTF8+import System.Console.Haskeline.Key -- | Keep track of all of the output capabilities we can use. -- @@ -24,7 +26,7 @@ clearToLineEnd :: TermOutput, nl, cr :: TermOutput, bellAudible,bellVisual :: TermOutput,- clearAll :: LinesAffected -> TermOutput,+ clearAllA :: LinesAffected -> TermOutput, wrapLine :: TermOutput} getActions :: Capability Actions@@ -40,14 +42,14 @@ bellAudible' <- bell `mplus` return mempty bellVisual' <- visualBell `mplus` return mempty wrapLine' <- getWrapLine nl' (leftA' 1)- return Actions{leftA=leftA',rightA=rightA',upA=upA',- clearToLineEnd=clearToLineEnd',nl=nl',cr=cr',- bellAudible=bellAudible', bellVisual=bellVisual',- clearAll=clearAll',- wrapLine=wrapLine'}+ return Actions{leftA = leftA', rightA = rightA',upA = upA',+ clearToLineEnd = clearToLineEnd', nl = nl',cr = cr',+ bellAudible = bellAudible', bellVisual = bellVisual',+ clearAllA = clearAll',+ wrapLine = wrapLine'} -text :: String -> Actions -> TermOutput-text str _ = termText (UTF8.encodeString str)+text :: B.ByteString -> Actions -> TermOutput+text str _ = termText $ B.unpack str getWrapLine :: TermOutput -> TermOutput -> Capability TermOutput getWrapLine nl' left1 = (autoRightMargin >>= guard >> withAutoMargin)@@ -59,12 +61,16 @@ wraparoundGlitch >>= guard return (termText " " <#> left1) )`mplus` return mempty++type TermAction = Actions -> TermOutput -left,right,up :: Int -> Actions -> TermOutput-left = flip leftA-right = flip rightA-up = flip upA+left,right,up :: Int -> TermAction+left n = flip leftA n+right n = flip rightA n+up n = flip upA n +clearAll :: LinesAffected -> TermAction+clearAll la = flip clearAllA la -------- @@ -85,23 +91,19 @@ -------------- -newtype Draw m a = Draw {unDraw :: ReaderT Handle (ReaderT Actions - (ReaderT Terminal (StateT TermPos m))) a}- deriving (Monad,MonadIO,MonadReader Actions,MonadReader Terminal,- MonadState TermPos, MonadReader Handle)+newtype Draw m a = Draw {unDraw :: (ReaderT Actions+ (ReaderT Terminal (StateT TermPos+ (PosixT m)))) a}+ deriving (Monad, MonadIO, MonadException,+ MonadReader Actions, MonadReader Terminal, MonadState TermPos,+ MonadReader Handle, MonadReader Encoders) instance MonadReader Layout m => MonadReader Layout (Draw m) where ask = lift ask local r = Draw . local r . unDraw -instance MonadException m => MonadException (Draw m) where- block = Draw . block . unDraw- unblock = Draw . unblock . unDraw- catch (Draw f) g = Draw $ Monads.catch f (unDraw . g)-- instance MonadTrans Draw where- lift = Draw . lift . lift . lift . lift+ lift = Draw . lift . lift . lift . lift . lift runTerminfoDraw :: IO (Maybe RunTerm) runTerminfoDraw = do@@ -112,18 +114,53 @@ Left (_::SetupTermError) -> return Nothing Right term -> case getCapability term getActions of Nothing -> return Nothing- Just actions -> fmap Just $ posixRunTerm $ \h -> + Just actions -> fmap Just $ posixRunTerm $ \enc h -> TermOps {- getLayout = getPosixLayout h (Just term),- runTerm = \f -> - evalStateT' initTermPos- (runReaderT' term- (runReaderT' actions- (runReaderT' h (unDraw - (withPosixGetEvent h (Just term) f)))))+ getLayout = tryGetLayouts (posixLayouts h+ ++ [tinfoLayout term]),+ runTerm = \f ->+ runPosixT enc h+ $ evalStateT' initTermPos+ $ runReaderT' term+ $ runReaderT' actions+ $ unDraw+ $ wrapKeypad h term+ $ withPosixGetEvent enc (terminfoKeys term) f }++-- If the keypad on/off capabilities are defined, wrap the computation with them.+wrapKeypad :: MonadException m => Handle -> Terminal -> m a -> m a+wrapKeypad h term f = (maybeOutput keypadOn >> f)+ `finally` maybeOutput keypadOff+ where+ maybeOutput cap = liftIO $ hRunTermOutput h term $+ fromMaybe mempty (getCapability term cap)++tinfoLayout :: Terminal -> IO (Maybe Layout)+tinfoLayout term = return $ getCapability term $ do+ r <- termColumns+ c <- termLines+ return Layout {height=r,width=c}++terminfoKeys :: Terminal -> [(String,Key)]+terminfoKeys term = catMaybes $ map getSequence keyCapabilities+ where+ getSequence (cap,x) = do+ keys <- getCapability term cap+ return (keys,x)+ keyCapabilities =+ [(keyLeft, simpleKey LeftKey)+ ,(keyRight, simpleKey RightKey)+ ,(keyUp, simpleKey UpKey)+ ,(keyDown, simpleKey DownKey)+ ,(keyBackspace, simpleKey Backspace)+ ,(keyDeleteChar, simpleKey Delete)+ ,(keyHome, simpleKey Home)+ ,(keyEnd, simpleKey End)+ ]+ -output :: MonadIO m => (Actions -> TermOutput) -> Draw m ()+output :: MonadIO m => TermAction -> Draw m () output f = do toutput <- asks f term <- ask@@ -175,12 +212,13 @@ let roomLeft = w - c if length str < roomLeft then do- output (text str)+ posixEncode str >>= output . text put TermPos{termRow=r, termCol=c+length str} return "" else do let (thisLine,rest) = splitAt roomLeft str- output (text thisLine <#> wrapLine)+ bstr <- posixEncode thisLine+ output (text bstr <#> wrapLine) put TermPos {termRow=r+1,termCol=0} return rest @@ -221,7 +259,7 @@ clearLayoutT :: MonadLayout m => Draw m () clearLayoutT = do h <- asks height- output (flip clearAll h)+ output (clearAll h) put initTermPos moveToNextLineT :: MonadLayout m => LineChars -> Draw m ()@@ -246,7 +284,9 @@ reposition = repositionT printLines [] = return ()- printLines ls = output $ mconcat $ intersperse nl (map text ls) ++ [nl] + printLines ls = do+ bls <- mapM posixEncode ls+ output $ mconcat $ intersperse nl (map text bls) ++ [nl] clearLayout = clearLayoutT moveToNextLine = moveToNextLineT ringBell True = output bellAudible
System/Console/Haskeline/Backend/Win32.hsc view
@@ -4,21 +4,15 @@ import System.IO -import qualified System.IO.UTF8 as UTF8 -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import Foreign.C.Types -import Foreign.Marshal.Utils -import System.Win32.Types +import Foreign +import Foreign.C +import System.Win32 hiding (multiByteToWideChar) import Graphics.Win32.Misc(getStdHandle, sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE) -import System.Win32.File import Data.List(intercalate) import Control.Concurrent hiding (throwTo) -import Control.Concurrent.STM +import Control.Concurrent.Chan import Data.Bits -import Data.Char(isUpper) +import Data.Char(isPrint) import Data.Maybe(mapMaybe) import Control.Monad @@ -27,6 +21,9 @@ import System.Console.Haskeline.LineState import System.Console.Haskeline.Term +import Data.ByteString.Internal (createAndTrim) +import qualified Data.ByteString as B + #include "win_console.h" foreign import stdcall "windows.h ReadConsoleInputW" c_ReadConsoleInput @@ -45,7 +42,7 @@ fmap fromEnum $ peek numEventsPtr getEvent :: HANDLE -> IO Event -getEvent h = newTChanIO >>= keyEventLoop (eventReader h) +getEvent h = newChan >>= keyEventLoop (eventReader h) eventReader :: HANDLE -> IO [Event] eventReader h = do @@ -81,7 +78,7 @@ .|. (#const LEFT_CTRL_PRESSED)) && not (c > '\NUL' && c <= '\031') ,hasShift = testMod (#const SHIFT_PRESSED) - && not (isUpper c) + && not (isPrint c) } processEvent WindowEvent = Just WindowResize @@ -256,9 +253,8 @@ printAfter :: MonadLayout m => String -> Draw m () printAfter str = do - p <- getPos printText str - setPos p + movePos $ negate $ length str drawLineDiffWin :: MonadLayout m => LineChars -> LineChars -> Draw m () drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of @@ -307,16 +303,15 @@ win32Term :: IO RunTerm win32Term = do + fileRT <- fileRunTerm inIsTerm <- hIsTerminalDevice stdin - putter <- putOut if not inIsTerm - then fileRunTerm + then return fileRT else do oterm <- getConOut case oterm of - Nothing -> fileRunTerm - Just h -> return RunTerm { - putStrOut = putter, + Nothing -> return fileRT + Just h -> return fileRT { wrapInterrupt = withWindowMode . withCtrlCHandler, termOps = Just TermOps { getLayout = getBufferSize h, @@ -332,9 +327,13 @@ fileRunTerm :: IO RunTerm fileRunTerm = do putter <- putOut + cp <- getCodePage return RunTerm {termOps = Nothing, closeTerm = return (), putStrOut = putter, + encodeForTerm = unicodeToCodePage cp, + decodeForTerm = codePageToUnicode cp, + getLocaleChar = getMultiByteChar cp, wrapInterrupt = withCtrlCHandler} -- On Windows, Unicode written to the console must be written with the WriteConsole API call. @@ -346,7 +345,9 @@ then do h <- getStdHandle sTD_OUTPUT_HANDLE return (writeConsole h) - else return $ \str -> UTF8.putStr str >> hFlush stdout + else do + cp <- getCodePage + return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout @@ -371,3 +372,58 @@ throwTo tid Interrupt return True handler _ _ = return False + + +------------------------ +-- Multi-byte conversion + +foreign import stdcall "WideCharToMultiByte" wideCharToMultiByte + :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt + -> LPCSTR -> LPBOOL -> IO CInt + +unicodeToCodePage :: CodePage -> String -> IO B.ByteString +unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do + -- first, ask for the length without filling the buffer. + outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) + nullPtr 0 nullPtr nullPtr + -- then, actually perform the encoding. + createAndTrim (fromEnum outSize) $ \outBuff -> + fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) + (castPtr outBuff) outSize nullPtr nullPtr + +foreign import stdcall "MultiByteToWideChar" multiByteToWideChar + :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt + +codePageToUnicode :: CodePage -> B.ByteString -> IO String +codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do + -- first ask for the size without filling the buffer. + outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0 + -- then, actually perform the decoding. + allocaArray0 (fromEnum outSize) $ \outBuff -> do + outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize + peekCWStringLen (outBuff, fromEnum outSize') + + +getCodePage :: IO CodePage +getCodePage = do + conCP <- getConsoleCP + if conCP > 0 + then return conCP + else getACP + +foreign import stdcall "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx + :: CodePage -> BYTE -> BOOL + +getMultiByteChar :: CodePage -> IO Char +getMultiByteChar cp = 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 + where + -- NOTE: relies on getChar returning an 8-bit Char. + getByte = fmap (toEnum . fromEnum) getChar
System/Console/Haskeline/Command.hs view
@@ -100,7 +100,7 @@ loopUntil f g = choiceCmd [g, f >|> loopUntil f g] try :: Command m s s -> Command m s s-try (Command f) = Command $ \next -> (f next) `orKM` next+try (Command f) = Command $ \next -> f next `orKM` next finish :: forall s m t . (Result s, Monad m) => Key -> Command m s t finish k = Command $ \_-> useKey k (Left . Just . toResult)
System/Console/Haskeline/Command/Completion.hs view
@@ -113,7 +113,7 @@ printWidth = width layout maxLength = min printWidth (maximum (map length ws) + minColPad) numCols = printWidth `div` maxLength- ls = if (maxLength >= printWidth)+ ls = if maxLength >= printWidth then map (\x -> [x]) ws else splitIntoGroups numCols ws in map (padWords maxLength) ls
System/Console/Haskeline/Completion.hs view
@@ -13,11 +13,11 @@ ) where -import System.Directory import System.FilePath import Data.List(isPrefixOf) import Control.Monad(forM) +import System.Console.Haskeline.Directory import System.Console.Haskeline.Monads -- | Performs completions from the given line state.@@ -141,8 +141,7 @@ -- | List all of the files or folders beginning with this path. listFiles :: MonadIO m => FilePath -> m [Completion]--- NOTE: 'handle' catches exceptions from getDirectoryContents and getHomeDirectory.-listFiles path = liftIO $ handle (\(_::IOException) -> return []) $ do+listFiles path = liftIO $ do fixedDir <- fixPath dir dirExists <- doesDirectoryExist fixedDir -- get all of the files in that directory, as basenames
+ System/Console/Haskeline/Directory.hsc view
@@ -0,0 +1,96 @@+{- |+A Unicode-aware module for interacting with files. We just need enough to support+filename completion. In particular, these functions will silently handle all errors+(for example, file does not exist)+-}+module System.Console.Haskeline.Directory(+ getDirectoryContents,+ doesDirectoryExist,+ getHomeDirectory+ ) where++#ifdef MINGW++import Foreign+import Foreign.C+import System.Win32.Types+import Data.Bits++#include <windows.h>+#include <Shlobj.h>++foreign import stdcall "FindFirstFileW" c_FindFirstFile+ :: LPCTSTR -> Ptr () -> IO HANDLE++foreign import stdcall "FindNextFileW" c_FindNextFile+ :: HANDLE -> Ptr () -> IO Bool++foreign import stdcall "FindClose" c_FindClose :: HANDLE -> IO BOOL++getDirectoryContents :: FilePath -> IO [FilePath]+getDirectoryContents fp = allocaBytes (#size WIN32_FIND_DATA) $ \findP ->+ withCWString (fp ++ "\\*") $ \t_arr -> do+ h <- c_FindFirstFile t_arr findP+ if h == iNVALID_HANDLE_VALUE+ then return []+ else loop h findP+ where+ loop h findP = do+ f <- peekFileName findP+ isNext <- c_FindNextFile h findP+ if isNext+ then do {fs <- loop h findP; return (f:fs)}+ else c_FindClose h >> return [f]+ peekFileName = peekCWString . (#ptr WIN32_FIND_DATA, cFileName)++foreign import stdcall "GetFileAttributesW" c_GetFileAttributes+ :: LPCTSTR -> IO DWORD++doesDirectoryExist :: FilePath -> IO Bool+doesDirectoryExist file = do+ attrs <- withCWString file c_GetFileAttributes+ return $ attrs /= (#const INVALID_FILE_ATTRIBUTES)+ && (attrs .&. (#const FILE_ATTRIBUTE_DIRECTORY)) /= 0++type HRESULT = #type HRESULT++foreign import stdcall "SHGetFolderPathW" c_SHGetFolderPath+ :: Ptr () -> CInt -> HANDLE -> DWORD -> LPTSTR -> IO HRESULT++getHomeDirectory :: IO FilePath+getHomeDirectory = allocaBytes ((#const MAX_PATH) * (#size TCHAR)) $ \pathPtr -> do+ result <- c_SHGetFolderPath nullPtr (#const CSIDL_PROFILE) nullPtr 0 pathPtr+ if result /= (#const S_OK)+ then return ""+ else peekCWString pathPtr++#else++import Data.ByteString.Char8 (pack, unpack)+import qualified System.Directory as D+import Control.Exception.Extensible+import System.Console.Haskeline.Backend.IConv++getDirectoryContents :: FilePath -> IO [FilePath]+getDirectoryContents path = do+ codeset <- getCodeset+ encoder <- openEncoder codeset+ decoder <- openDecoder codeset+ dirEnc <- fmap unpack (encoder path)+ filesEnc <- handle (\(_::IOException) -> return [])+ $ D.getDirectoryContents dirEnc+ mapM (decoder . pack) filesEnc++doesDirectoryExist :: FilePath -> IO Bool+doesDirectoryExist file = do+ codeset <- getCodeset+ encoder <- openEncoder codeset+ encoder file >>= D.doesDirectoryExist . unpack++getHomeDirectory :: IO FilePath+getHomeDirectory = do+ codeset <- getCodeset+ decoder <- openDecoder codeset+ handle (\(_::IOException) -> return "")+ $ D.getHomeDirectory >>= decoder . pack+#endif
+ System/Console/Haskeline/Encoding.hs view
@@ -0,0 +1,40 @@+{- |++This module exposes the console Unicode API which is used by the functions+in "System.Console.Haskeline". On POSIX systems, it uses @iconv@ plus the+console\'s locale; on Windows it uses the console's current code page.++Characters or bytes which cannot be encoded/decoded (for example, not belonging+to the output range) will be ignored.+-}++module System.Console.Haskeline.Encoding (+ encode,+ decode,+ getEncoder,+ getDecoder+ ) where++import System.Console.Haskeline.InputT+import System.Console.Haskeline.Term+import System.Console.Haskeline.Monads+import Data.ByteString (ByteString)++-- | Encode a Unicode 'String' into a 'ByteString' suitable for the current+-- console.+encode :: MonadIO m => String -> InputT m ByteString+encode str = do+ encoder <- asks encodeForTerm+ liftIO $ encoder str++-- | Convert a 'ByteString' from the console's encoding into a Unicode 'String'.+decode :: MonadIO m => ByteString -> InputT m String+decode str = do+ decoder <- asks decodeForTerm+ liftIO $ decoder str++getEncoder :: Monad m => InputT m (String -> IO ByteString)+getEncoder = asks encodeForTerm++getDecoder :: Monad m => InputT m (ByteString -> IO String)+getDecoder = asks decodeForTerm
System/Console/Haskeline/InputT.hs view
@@ -37,11 +37,11 @@ -- | A monad transformer which carries all of the state and settings -- relevant to a line-reading application. newtype InputT m a = InputT {unInputT :: ReaderT RunTerm- (StateT History (ReaderT Prefs + (StateT History (ReaderT Prefs (ReaderT (Settings m) m))) a}- deriving (Monad,MonadIO, MonadState History,- MonadReader Prefs, MonadReader (Settings m),- MonadReader RunTerm)+ deriving (Monad, MonadIO, MonadException,+ MonadState History, MonadReader Prefs,+ MonadReader (Settings m), MonadReader RunTerm) instance Monad m => Functor (InputT m) where fmap = State.liftM@@ -52,11 +52,6 @@ instance MonadTrans InputT where lift = InputT . lift . lift . lift . lift--instance MonadException m => MonadException (InputT m) where- block = InputT . block . unInputT- unblock = InputT . unblock . unInputT- catch f h = InputT $ Monads.catch (unInputT f) (unInputT . h) instance Monad m => State.MonadState History (InputT m) where get = get
System/Console/Haskeline/Term.hs view
@@ -6,8 +6,10 @@ import System.Console.Haskeline.Prefs(Prefs) import Control.Concurrent-import Control.Concurrent.STM+import Control.Concurrent.Chan import Data.Typeable+import Data.ByteString (ByteString)+import Control.Exception.Extensible (fromException, AsyncException(..),bracket_) class (MonadReader Layout m, MonadException m) => Term m where reposition :: Layout -> LineChars -> m ()@@ -21,6 +23,9 @@ -- termOps being Nothing means we should read the input as a UTF-8 file. data RunTerm = RunTerm { putStrOut :: String -> IO (),+ encodeForTerm :: String -> IO ByteString,+ decodeForTerm :: ByteString -> IO String,+ getLocaleChar :: IO Char, termOps :: Maybe TermOps, wrapInterrupt :: MonadException m => m a -> m a, closeTerm :: IO ()@@ -39,33 +44,36 @@ matchInit (x:xs) (y:ys) | x == y = matchInit xs ys matchInit xs ys = (xs,ys) -data Event = WindowResize | KeyInput Key+data Event = WindowResize | KeyInput Key | ErrorEvent SomeException deriving Show -keyEventLoop :: IO [Event] -> TChan Event -> IO Event+keyEventLoop :: IO [Event] -> Chan Event -> IO Event keyEventLoop readEvents eventChan = do -- first, see if any events are already queued up (from a key/ctrl-c -- event or from a previous call to getEvent where we read in multiple- -- keys) - me <- atomically $ tryReadTChan eventChan- case me of- Just e -> return e- Nothing -> do- -- no events are queued yet, so fork off a thread to read keys.- -- if we receive a different type of event before it's done,- -- we'll kill it.- tid <- forkIO readerLoop- (atomically $ readTChan eventChan)- `finally` killThread tid+ -- keys)+ isEmpty <- isEmptyChan eventChan+ if not isEmpty+ then readChan eventChan+ else do+ lock <- newEmptyMVar+ tid <- forkIO $ handleErrorEvent (readerLoop lock)+ readChan eventChan `finally` do+ putMVar lock ()+ killThread tid where- readerLoop = do+ readerLoop lock = do es <- readEvents if null es- then readerLoop- else atomically $ mapM_ (writeTChan eventChan) es--tryReadTChan :: TChan a -> STM (Maybe a)-tryReadTChan chan = fmap Just (readTChan chan) `orElse` return Nothing+ then readerLoop lock+ 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) $ + writeList2Chan eventChan es+ handleErrorEvent = handle $ \e -> case fromException e of+ Just ThreadKilled -> return ()+ _ -> writeChan eventChan (ErrorEvent e) class (MonadReader Layout m, MonadIO m) => MonadLayout m where
System/Console/Haskeline/Vi.hs view
@@ -104,12 +104,12 @@ start = foreachDigit startArg ['1'..'9'] addDigit = foreachDigit addNum ['0'..'9'] deleteR = simpleChar 'd' - >+> choiceCmd [useMovements (deleteFromRepeatedMove),+ >+> choiceCmd [useMovements deleteFromRepeatedMove, simpleChar 'd' +> change (const CEmpty)] deleteIR = simpleChar 'c' >+> choiceCmd [useMovements deleteAndInsertR, simpleChar 'c' +> change (const emptyIM)]- applyArg' f am = enterCommandModeRight $ applyArg f $ fmap insertFromCommandMode am+ applyArg' f = enterCommandModeRight . applyArg f . fmap insertFromCommandMode loop = choiceCmd [addDigit >|> loop , useMovements applyArg' >|> viCommandActions , saveForUndo (deleteR >|> viCommandActions)
haskeline.cabal view
@@ -1,6 +1,6 @@ Name: haskeline-Cabal-Version: >=1.2-Version: 0.5.0.1+Cabal-Version: >=1.6+Version: 0.6 Category: User Interfaces License: BSD3 License-File: LICENSE@@ -25,12 +25,16 @@ flag old-base Description: Use the base packages from before version 6.8 +flag terminfo+ Description: Use the terminfo package for POSIX consoles.+ Default: True+ Library if flag(old-base) Build-depends: base < 3 else Build-depends: base>=3 && <5 , containers>=0.1, directory>=1.0- Build-depends: stm==2.1.*, filepath==1.1.*, mtl==1.1.*,+ Build-depends: filepath==1.1.*, mtl==1.1.*, bytestring==0.9.*, utf8-string==0.3.* && >=0.3.1.1, extensible-exceptions==0.1.* && >=0.1.1.0@@ -44,6 +48,7 @@ Exposed-Modules: System.Console.Haskeline System.Console.Haskeline.Completion+ System.Console.Haskeline.Encoding System.Console.Haskeline.MonadException System.Console.Haskeline.History System.Console.Haskeline.IO@@ -52,6 +57,7 @@ System.Console.Haskeline.Command System.Console.Haskeline.Command.Completion System.Console.Haskeline.Command.History+ System.Console.Haskeline.Directory System.Console.Haskeline.Emacs System.Console.Haskeline.InputT System.Console.Haskeline.Key@@ -70,11 +76,17 @@ install-includes: win_console.h cpp-options: -DMINGW } else {- Build-depends: terminfo==0.3.*, unix==2.2.* || ==2.3.*+ Build-depends: unix==2.2.* || ==2.3.* -- unix-2.3 doesn't build on ghc-6.8.1+ Extra-libraries: iconv Other-modules: System.Console.Haskeline.Backend.Posix+ System.Console.Haskeline.Backend.IConv System.Console.Haskeline.Backend.DumbTerm- System.Console.Haskeline.Backend.Terminfo+ if flag(terminfo) {+ Build-depends: terminfo==0.3.*+ Other-modules: System.Console.Haskeline.Backend.Terminfo+ cpp-options: -DTERMINFO+ } } ghc-options: -Wall