haskeline 0.6.4.7 → 0.7.0.0
raw patch · 30 files changed
+1207/−687 lines, 30 filesdep +transformersdep −extensible-exceptionsdep −mtldep ~basedep ~unixsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: transformers
Dependencies removed: extensible-exceptions, mtl
Dependency ranges changed: base, unix
API changes (from Hackage documentation)
- System.Console.Haskeline.Encoding: decode :: MonadIO m => ByteString -> InputT m String
- System.Console.Haskeline.Encoding: encode :: MonadIO m => String -> InputT m ByteString
- System.Console.Haskeline.Encoding: getDecoder :: Monad m => InputT m (ByteString -> IO String)
- System.Console.Haskeline.Encoding: getEncoder :: Monad m => InputT m (String -> IO ByteString)
- System.Console.Haskeline.MonadException: block :: MonadException m => m a -> m a
- System.Console.Haskeline.MonadException: handleDyn :: (Exception exception, MonadException m) => (exception -> m a) -> m a -> m a
- System.Console.Haskeline.MonadException: throwDynIO :: (Exception exception, MonadIO m) => exception -> m a
- System.Console.Haskeline.MonadException: unblock :: MonadException m => m a -> m a
+ System.Console.Haskeline: getHistory :: MonadIO m => InputT m History
+ System.Console.Haskeline: mapInputT :: (forall b. m b -> m b) -> InputT m a -> InputT m a
+ System.Console.Haskeline: modifyHistory :: MonadIO m => (History -> History) -> InputT m ()
+ System.Console.Haskeline: putHistory :: MonadIO m => History -> InputT m ()
+ System.Console.Haskeline.MonadException: RunIO :: (forall b. m b -> IO (m b)) -> RunIO m
+ System.Console.Haskeline.MonadException: controlIO :: MonadException m => (RunIO m -> IO (m a)) -> m a
+ System.Console.Haskeline.MonadException: instance [overlap ok] (MonadException m, Error e) => MonadException (ErrorT e m)
+ System.Console.Haskeline.MonadException: instance [overlap ok] (Monoid w, MonadException m) => MonadException (RWST r w s m)
+ System.Console.Haskeline.MonadException: instance [overlap ok] (Monoid w, MonadException m) => MonadException (WriterT w m)
+ System.Console.Haskeline.MonadException: instance [overlap ok] MonadException m => MonadException (ListT m)
+ System.Console.Haskeline.MonadException: instance [overlap ok] MonadException m => MonadException (MaybeT m)
+ System.Console.Haskeline.MonadException: liftIOOp :: MonadException m => ((a -> IO (m b)) -> IO (m c)) -> (a -> m b) -> m c
+ System.Console.Haskeline.MonadException: liftIOOp_ :: MonadException m => (IO (m a) -> IO (m a)) -> m a -> m a
+ System.Console.Haskeline.MonadException: newtype RunIO m
Files
- CHANGES +27/−0
- Setup.hs +22/−12
- System/Console/Haskeline.hs +54/−35
- System/Console/Haskeline/Backend/DumbTerm.hs +9/−17
- System/Console/Haskeline/Backend/IConv.hsc +0/−156
- System/Console/Haskeline/Backend/Posix.hsc +89/−115
- System/Console/Haskeline/Backend/Posix/Encoder.hs +211/−0
- System/Console/Haskeline/Backend/Posix/IConv.hsc +177/−0
- System/Console/Haskeline/Backend/Posix/Recover.hs +22/−0
- System/Console/Haskeline/Backend/Terminfo.hs +27/−27
- System/Console/Haskeline/Backend/Win32.hsc +145/−56
- System/Console/Haskeline/Command.hs +1/−1
- System/Console/Haskeline/Command/Completion.hs +1/−1
- System/Console/Haskeline/Command/History.hs +13/−10
- System/Console/Haskeline/Command/KillRing.hs +5/−2
- System/Console/Haskeline/Directory.hsc +15/−7
- System/Console/Haskeline/Emacs.hs +2/−2
- System/Console/Haskeline/Encoding.hs +0/−40
- System/Console/Haskeline/History.hs +46/−7
- System/Console/Haskeline/IO.hs +1/−1
- System/Console/Haskeline/InputT.hs +39/−16
- System/Console/Haskeline/MonadException.hs +133/−49
- System/Console/Haskeline/Monads.hs +34/−30
- System/Console/Haskeline/RunCommand.hs +29/−29
- System/Console/Haskeline/Term.hs +50/−42
- System/Console/Haskeline/Vi.hs +5/−5
- cbits/win_console.c +8/−0
- examples/Test.hs +2/−1
- haskeline.cabal +38/−26
- includes/win_console.h +2/−0
CHANGES view
@@ -1,3 +1,30 @@+Changed in version 0.7.0.0:+ API changes:+ * Remove System.Console.Haskeline.Encoding+ * Make the MonadException class more general (similar to monad-control)+ * Don't make InputT an instance of MonadState/MonadReader+ * #117: Implement mapInputT++ Internal changes:+ * Bump dependencies and general compatibility for ghc-7.6.1+ * Depend on the transformers package instead of mtl+ * Don't depend on the extensible-exceptions package+ * Don't depend on the utf8-string package (except with ghc<7.4.1)+ * Bump the minimum GHC version to 6.10.1+ * Use ScopedTypeVariables instead of PatternSignatures++ Internal fixes:+ * Prevent crashes on Windows when writing too many characters at once+ or ctrl-L on large window (GHC ticket #4415)+ * Remember the user's history and kill ring state after ctrl-c+ * Use ccall on Win64+ * Fix terminfo's guess of the window size++Changed in version 0.6.4.7:+ * Bump dependencies to allow mtl-2.1, containers-0.5 and bytestring-0.10.+ * Prefix C functions with "haskeline_" so we don't clash with other packages+ * Prevent cursor flicker when outputting in the terminfo backend+ Changed in version 0.6.4.6: * Build with ghc-7.4.1.
Setup.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} import Distribution.System import Distribution.Verbosity import Distribution.PackageDescription@@ -35,8 +36,27 @@ libBuildInfo = bi'}}} } +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."+ ,""+ ]++hasFlagSet :: ConfigFlags -> FlagName -> Bool+hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags)++ -- Test whether compiling a c program that links against libiconv needs -liconv.+-- (Not needed for ghc>=7.4.1, even for the legacy POSIX backend, since+-- the base library always links against iconv .) maybeSetLibiconv :: ConfigFlags -> BuildInfo -> LocalBuildInfo -> IO BuildInfo++#if __GLASGOW_HASKELL__ >= 704+maybeSetLibiconv _ bi _ = return bi+#else maybeSetLibiconv flags bi lbi = do let biWithIconv = addIconv bi let verb = fromFlag (configVerbosity flags)@@ -60,9 +80,6 @@ return biWithIconv else error "Unable to link against the iconv library." -hasFlagSet :: ConfigFlags -> FlagName -> Bool-hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags)- tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool tryCompile program bi lbi verb = handle processExit $ handle processException $ do tempDir <- getTemporaryDirectory@@ -105,12 +122,5 @@ , " return 0;" , "}" ]- -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."- ,""- ]+#endif+
System/Console/Haskeline.hs view
@@ -32,6 +32,7 @@ InputT, runInputT, haveTerminalUI,+ mapInputT, -- ** Behaviors Behavior, runInputTBehavior,@@ -61,11 +62,16 @@ defaultPrefs, runInputTWithPrefs, runInputTBehaviorWithPrefs,+ -- ** History+ -- $history+ getHistory,+ putHistory,+ modifyHistory, -- * Ctrl-C handling- -- $ctrlc- Interrupt(..), withInterrupt,+ Interrupt(..), handleInterrupt,+ -- * Additional submodules module System.Console.Haskeline.Completion, module System.Console.Haskeline.MonadException) where@@ -110,7 +116,7 @@ -- | Write a Unicode string to the user's standard output. outputStr :: MonadIO m => String -> InputT m () outputStr xs = do- putter <- asks putStrOut+ putter <- InputT $ asks putStrOut liftIO $ putter xs -- | Write a string to the user's standard output, followed by a newline.@@ -136,7 +142,7 @@ -} getInputLine :: MonadException m => String -- ^ The input prompt -> InputT m (Maybe String)-getInputLine = promptedInput (getInputCmdLine emptyIM) $ unMaybeT . getLocaleLine+getInputLine = promptedInput (getInputCmdLine emptyIM) $ runMaybeT . getLocaleLine {- | Reads one line of input and fills the insertion space with initial text. When using terminal-style interaction, this function provides a rich line-editing user interface with the@@ -158,13 +164,13 @@ -> (String, String) -- ^ The initial value left and right of the cursor -> InputT m (Maybe String) getInputLineWithInitial prompt (left,right) = promptedInput (getInputCmdLine initialIM)- (unMaybeT . getLocaleLine) prompt+ (runMaybeT . getLocaleLine) prompt where initialIM = insertString left $ moveToStart $ insertString right $ emptyIM getInputCmdLine :: MonadException m => InsertMode -> TermOps -> String -> InputT m (Maybe String) getInputCmdLine initialIM tops prefix = do- emode <- asks editMode+ emode <- InputT $ asks editMode result <- runInputCmdT tops $ case emode of Emacs -> runCommandLoop tops prefix emacsCommands initialIM Vi -> evalStateT' emptyViState $@@ -172,17 +178,17 @@ maybeAddHistory result return result -maybeAddHistory :: forall m . Monad m => Maybe String -> InputT m ()+maybeAddHistory :: forall m . MonadIO m => Maybe String -> InputT m () maybeAddHistory result = do- settings :: Settings m <- ask- histDupes <- asks historyDuplicates+ settings :: Settings m <- InputT ask+ histDupes <- InputT $ asks historyDuplicates case result of Just line | autoAddHistory settings && not (all isSpace line) -> let adder = case histDupes of AlwaysAdd -> addHistory IgnoreConsecutive -> addHistoryUnlessConsecutiveDupe IgnoreAll -> addHistoryRemovingAllDupes- in modify (adder line)+ in modifyHistory (adder line) _ -> return () ----------@@ -204,7 +210,7 @@ getPrintableChar :: FileOps -> IO (Maybe Char) getPrintableChar fops = do- c <- unMaybeT $ getLocaleChar fops+ c <- runMaybeT $ getLocaleChar fops case fmap isPrint c of Just False -> getPrintableChar fops _ -> return c@@ -238,7 +244,7 @@ $ Password [] x) (\fops -> let h_in = inputHandle fops in bracketSet (hGetEcho h_in) (hSetEcho h_in) False- $ unMaybeT $ getLocaleLine fops)+ $ runMaybeT $ getLocaleLine fops) where loop = choiceCmd [ simpleChar '\n' +> finish , simpleKey Backspace +> change deletePasswordChar@@ -251,10 +257,19 @@ ] loop' = keyCommand loop +{- $history+The 'InputT' monad transformer provides direct, low-level access to the user's line history state. +However, for most applications, it should suffice to just use the 'autoAddHistory'+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) -> (FileOps -> IO a) -> String -> InputT m a@@ -262,40 +277,44 @@ -- 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+ rterm <- InputT ask case termOps rterm of Right fops -> liftIO $ do putStrOut rterm prompt- doFile fops+ wrapFileInput fops $ 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--{- $ctrlc-The following functions provide portable handling of Ctrl-C events. --These functions are not necessary on GHC version 6.10 or later, which-processes Ctrl-C events as exceptions by default.--}+{- | If Ctrl-C is pressed during the given action, throw an exception+of type 'Interrupt'. For example: --- | If Ctrl-C is pressed during the given computation, throw an exception of type --- 'Interrupt'.-withInterrupt :: MonadException m => InputT m a -> InputT m a-withInterrupt f = do- rterm <- ask- wrapInterrupt rterm f+> tryAction :: InputT IO ()+> tryAction = handle (\Interrupt -> outputStrLn "Cancelled.")+> $ wrapInterrupt $ someLongAction --- | Catch and handle an exception of type 'Interrupt'.-handleInterrupt :: MonadException m => m a - -- ^ Handler to run if Ctrl-C is pressed- -> m a -- ^ Computation to run- -> m a-handleInterrupt f = handleDyn $ \Interrupt -> f+The action can handle the interrupt itself; a new 'Interrupt' exception will be thrown+every time Ctrl-C is pressed. +> tryAction :: InputT IO ()+> tryAction = wrapInterrupt loop+> where loop = handle (\Interrupt -> outputStrLn "Cancelled; try again." >> loop)+> someLongAction+ +This behavior differs from GHC's built-in Ctrl-C handling, which+may immediately terminate the program after the second time that the user presses+Ctrl-C. +-}+withInterrupt :: MonadException m => InputT m a -> InputT m a+withInterrupt act = do+ rterm <- InputT ask+ liftIOOp_ (wrapInterrupt rterm) act +-- | Catch and handle an exception of type 'Interrupt'. +--+-- > handleInterrupt f = handle $ \Interrupt -> f+handleInterrupt :: MonadException m => m a -> m a -> m a+handleInterrupt f = handle $ \Interrupt -> f
System/Console/Haskeline/Backend/DumbTerm.hs view
@@ -1,14 +1,13 @@ module System.Console.Haskeline.Backend.DumbTerm where import System.Console.Haskeline.Backend.Posix+import System.Console.Haskeline.Backend.Posix.Encoder (putEncodedStr) import System.Console.Haskeline.Backend.WCWidth import System.Console.Haskeline.Term import System.Console.Haskeline.LineState import System.Console.Haskeline.Monads as Monads import System.IO-import qualified Data.ByteString as B-import Control.Concurrent.Chan import Control.Monad(liftM) -- TODO: @@ -24,26 +23,18 @@ newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a} deriving (Monad, MonadIO, MonadException, MonadState Window,- MonadReader Handles, MonadReader Encoders)+ MonadReader Handles, MonadReader Encoder) type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a instance MonadTrans DumbTerm where lift = DumbTerm . lift . lift . lift +evalDumb :: (MonadReader Layout m, CommandMonad m) => EvalTerm (PosixT m)+evalDumb = EvalTerm (evalStateT' initWindow . unDumbTerm) (DumbTerm . lift)+ runDumbTerm :: Handles -> MaybeT IO RunTerm-runDumbTerm h = do- ch <- liftIO newChan- posixRunTerm h $ \enc ->- TermOps {- getLayout = tryGetLayouts (posixLayouts h)- , withGetEvent = withPosixGetEvent ch h enc []- , saveUnusedKeys = saveKeys ch- , runTerm = \(RunTermType f) -> - runPosixT enc h- $ evalStateT' initWindow- $ unDumbTerm f- }+runDumbTerm h = liftIO $ posixRunTerm h (posixLayouts h) [] id evalDumb instance (MonadException m, MonadReader Layout m) => Term (DumbTerm m) where reposition _ s = refitLine s@@ -57,8 +48,9 @@ printText :: MonadIO m => String -> DumbTerm m () printText str = do- h <- liftM hOut ask- posixEncode str >>= liftIO . B.hPutStr h+ h <- liftM ehOut ask+ encode <- ask+ liftIO $ putEncodedStr encode h str liftIO $ hFlush h -- Things we can assume a dumb terminal knows how to do
− System/Console/Haskeline/Backend/IConv.hsc
@@ -1,156 +0,0 @@-module System.Console.Haskeline.Backend.IConv(- setLocale,- getCodeset,- openEncoder,- openDecoder,- openPartialDecoder,- Result(..)- ) where--import Foreign.C-import Foreign-import Data.ByteString (ByteString, useAsCStringLen, append)--- TODO: Base or Internal, depending on whether base>=3.-#ifdef OLD_BASE-import Data.ByteString.Base (createAndTrim')-#else-import Data.ByteString.Internal (createAndTrim')-#endif-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as UTF8-import Data.Maybe (fromMaybe)--#include <locale.h>-#include <langinfo.h>-#include "h_iconv.h"--openEncoder :: String -> IO (String -> IO ByteString)-openEncoder codeset = do- encodeT <- iconvOpen codeset "UTF-8"- return $ simpleIConv dropUTF8Char encodeT . UTF8.fromString--openDecoder :: String -> IO (ByteString -> IO String)-openDecoder codeset = do- decodeT <- iconvOpen "UTF-8" codeset- return $ fmap UTF8.toString . simpleIConv (B.drop 1) decodeT--dropUTF8Char :: ByteString -> ByteString-dropUTF8Char = fromMaybe B.empty . fmap snd . UTF8.uncons--replacement :: Word8-replacement = toEnum (fromEnum '?')---- handle errors by dropping unuseable chars.-simpleIConv :: (ByteString -> ByteString) -> IConvT -> ByteString -> IO ByteString-simpleIConv dropper t bs = do- (cs,result) <- iconv t bs- case result of- Invalid rest -> continueOnError cs rest- Incomplete rest -> continueOnError cs rest- _ -> return cs- where- continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`))- $ simpleIConv dropper t (dropper rest)--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 withCAString) oldLocale $ \loc_p -> do- c_setlocale (#const LC_CTYPE) loc_p >>= maybePeek peekCAString---------------------- Getting the encoding--type NLItem = #type nl_item--foreign import ccall nl_langinfo :: NLItem -> IO CString--getCodeset :: IO String-getCodeset = do- str <- nl_langinfo (#const CODESET) >>= peekCAString- -- check for codesets which may be returned by Solaris, but not understood- -- by GNU iconv.- if str `elem` ["","646"]- then return "ISO-8859-1"- else return str--------------------- Iconv---- TODO: This may not work on platforms where iconv_t is not a pointer.-type IConvT = ForeignPtr ()-type IConvTPtr = Ptr ()--foreign import ccall "haskeline_iconv_open" iconv_open- :: CString -> CString -> IO IConvTPtr--iconvOpen :: String -> String -> IO IConvT-iconvOpen destName srcName = withCAString destName $ \dest ->- withCAString srcName $ \src -> do- res <- iconv_open dest src- if res == nullPtr `plusPtr` (-1)- then throwErrno $ "iconvOpen "- ++ show (srcName,destName)- -- list the two it couldn't convert between?- else newForeignPtr iconv_close res---- really this returns a CInt, but it's easiest to just ignore that, I think.-foreign import ccall "& haskeline_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ())--foreign import ccall "haskeline_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- -- ignore the return value; checking the errno is more reliable.- _ <- 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
@@ -3,10 +3,11 @@ posixLayouts, tryGetLayouts, PosixT,- runPosixT,- Handles(..),- Encoders(),- posixEncode,+ Handles(),+ ehIn,+ ehOut,+ Encoder,+ Decoder, mapLines, stdinTTYHandles, ttyHandles,@@ -25,7 +26,6 @@ import System.Posix.Types(Fd(..)) import Data.List import System.IO-import qualified Data.ByteString as B import System.Environment import System.Console.Haskeline.Monads@@ -33,7 +33,7 @@ import System.Console.Haskeline.Term as Term import System.Console.Haskeline.Prefs -import System.Console.Haskeline.Backend.IConv+import System.Console.Haskeline.Backend.Posix.Encoder #if __GLASGOW_HASKELL__ >= 611 import GHC.IO.FD (fdFD)@@ -55,16 +55,20 @@ ----------------------------------------------- -- Input/output handles-data Handles = Handles {hIn, hOut :: Handle,- closeHandles :: IO ()}+data Handles = Handles {hIn, hOut :: ExternalHandle+ , closeHandles :: IO ()} +ehIn, ehOut :: Handles -> Handle+ehIn = eH . hIn+ehOut = eH . hOut+ ------------------- -- Window size foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt posixLayouts :: Handles -> [IO (Maybe Layout)]-posixLayouts h = [ioctlLayout $ hOut h, envLayout]+posixLayouts h = [ioctlLayout $ ehOut h, envLayout] ioctlLayout :: Handle -> IO (Maybe Layout) ioctlLayout h = allocaBytes (#size struct winsize) $ \ws -> do@@ -109,7 +113,7 @@ -- Key sequences getKeySequences :: (MonadIO m, MonadReader Prefs m)- => Handles -> [(String,Key)] -> m (TreeMap Char Key)+ => Handle -> [(String,Key)] -> m (TreeMap Char Key) getKeySequences h tinfos = do sttys <- liftIO $ sttyKeys h customKeySeqs <- getCustomKeySeqs@@ -150,9 +154,9 @@ ] -sttyKeys :: Handles -> IO [(String, Key)]+sttyKeys :: Handle -> IO [(String, Key)] sttyKeys h = do- fd <- unsafeHandleToFD $ hIn h+ fd <- unsafeHandleToFD 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)]@@ -208,12 +212,12 @@ ----------------------------- withPosixGetEvent :: (MonadException m, MonadReader Prefs m) - => Chan Event -> Handles -> Encoders -> [(String,Key)]+ => Chan Event -> Handles -> Decoder -> [(String,Key)] -> (m Event -> m a) -> m a withPosixGetEvent eventChan h enc termKeys f = wrapTerminalOps h $ do- baseMap <- getKeySequences h termKeys+ baseMap <- getKeySequences (ehIn h) termKeys withWindowHandler eventChan- $ f $ liftIO $ getEvent h enc baseMap eventChan+ $ f $ liftIO $ getEvent (ehIn h) enc baseMap eventChan withWindowHandler :: MonadException m => Chan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $ @@ -231,139 +235,109 @@ old_handler <- liftIO $ installHandler signal handler Nothing f `finally` liftIO (installHandler signal old_handler Nothing) -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 h- bs <- B.hGetNonBlocking h bufferSize- cs <- convert h (localeToUnicode enc) bs+getEvent :: Handle -> Decoder -> TreeMap Char Key -> Chan Event -> IO Event+getEvent h dec baseMap = keyEventLoop $ do+ cs <- getBlockOfChars h dec return [KeyInput $ lexKeys baseMap cs] --- Different versions of ghc work better using different functions.-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 h = hWaitForInput h (-1) >> return ()-#else--- hWaitForInput doesn't work with -threaded on ghc < 6.10--- (#2363 in ghc's trac)-blockUntilInput h = unsafeHandleToFD h >>= threadWaitRead . Fd-#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 :: 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 h 1- if B.null extra- then return (cs ++ "?")- else fmap (cs ++)- $ convert h decoder (rest `B.append` extra)- Invalid rest -> fmap ((cs ++) . ('?':)) $ convert h decoder (B.drop 1 rest)- _ -> return cs--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-- 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 }+ return Handles+ { hIn = externalHandle stdin+ , hOut = h+ , closeHandles = hClose $ eH h+ } ttyHandles = do- -- Open the input and output separately, since they need different buffering.+ -- Open the input and output as two separate Handles, 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 }+ return Handles+ { hIn = h_in+ , hOut = h_out+ , closeHandles = hClose (eH h_in) >> hClose (eH h_out)+ } -openTerm :: IOMode -> MaybeT IO Handle+openTerm :: IOMode -> MaybeT IO ExternalHandle 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.- $ liftIO $ openBinaryFile "/dev/tty" mode+ $ liftIO $ openInCodingMode "/dev/tty" mode -posixRunTerm :: MonadIO m => Handles -> (Encoders -> TermOps) -> m RunTerm-posixRunTerm hs tOps = liftIO $ do- codeset <- getCodeset- 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 Handles m)--data Encoders = Encoders {unicodeToLocale :: String -> IO B.ByteString,- localeToUnicode :: B.ByteString -> IO (String, Result)}+posixRunTerm :: + Handles+ -> [IO (Maybe Layout)]+ -> [(String,Key)]+ -> (forall m b . MonadException m => m b -> m b)+ -> (forall m . (MonadException m, CommandMonad m) => EvalTerm (PosixT m))+ -> IO RunTerm+posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do+ ch <- newChan+ fileRT <- posixFileRunTerm hs+ (enc,dec) <- newEncoders+ return fileRT+ { closeTerm = closeTerm fileRT+ , termOps = Left TermOps+ { getLayout = tryGetLayouts layoutGetters+ , withGetEvent = wrapGetEvent + . withPosixGetEvent ch hs dec+ keys+ , saveUnusedKeys = saveKeys ch+ , evalTerm = mapEvalTerm+ (runPosixT enc hs)+ (lift . lift)+ evalBackend+ }+ } -posixEncode :: (MonadIO m, MonadReader Encoders m) => String -> m B.ByteString-posixEncode str = do- encoder <- asks unicodeToLocale- liftIO $ encoder str+type PosixT m = ReaderT Encoder (ReaderT Handles m) -runPosixT :: Monad m => Encoders -> Handles -> PosixT m a -> m a+runPosixT :: Monad m => Encoder -> Handles -> PosixT m a -> m a runPosixT enc h = runReaderT' h . runReaderT' enc -putTerm :: Handle -> B.ByteString -> IO ()-putTerm h str = B.hPutStr h str >> hFlush h- 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 = encoder >=> putTerm h_out,- closeTerm = setLocale oldLocale >> return (),- wrapInterrupt = withSigIntHandler,- encodeForTerm = encoder,- decodeForTerm = decoder,- termOps = Right FileOps {- inputHandle = h_in,- getLocaleChar = getMultiByteChar h_in decoder',- maybeReadNewline = hMaybeReadNewline h_in,- getLocaleLine = Term.hGetLine h_in- >>= liftIO . decoder+fileRunTerm h_in = posixFileRunTerm Handles+ { hIn = externalHandle h_in+ , hOut = externalHandle stdout+ , closeHandles = return () } +posixFileRunTerm :: Handles -> IO RunTerm+posixFileRunTerm hs = do+ (enc,dec) <- newEncoders+ return RunTerm+ { putStrOut = \str -> withCodingMode (hOut hs) $ do+ putEncodedStr enc (ehOut hs) str+ hFlush (ehOut hs)+ , closeTerm = closeHandles hs+ , wrapInterrupt = withSigIntHandler+ , termOps = Right FileOps+ { inputHandle = ehIn hs+ , wrapFileInput = withCodingMode (hIn hs)+ , getLocaleChar = getDecodedChar (ehIn hs) dec+ , maybeReadNewline = hMaybeReadNewline (ehIn hs)+ , getLocaleLine = getDecodedLine (ehIn hs) dec+ } } -- 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 => Handles -> m a -> m a-wrapTerminalOps Handles {hIn = h_in, hOut = h_out} = +wrapTerminalOps hs = 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 h_out) (hSetBuffering h_out) LineBuffering . bracketSet (hGetEcho h_in) (hSetEcho h_in) False- . hWithBinaryMode h_in+ . liftIOOp_ (withCodingMode $ hIn hs)+ . liftIOOp_ (withCodingMode $ hOut hs)+ where+ h_in = ehIn hs+ h_out = ehOut hs
+ System/Console/Haskeline/Backend/Posix/Encoder.hs view
@@ -0,0 +1,211 @@+{- | This module provides a wrapper for I/O encoding for the "old" and "new" ways.+The "old" way uses iconv+utf8-string.+The "new" way uses the base library's built-in encoding functionality.+For the "new" way, we require ghc>=7.4.1 due to GHC bug #5436.++This module exports opaque Encoder/Decoder datatypes, along with several helper+functions that wrap the old/new ways.+-}+module System.Console.Haskeline.Backend.Posix.Encoder (+ Encoder,+ Decoder,+ newEncoders,+ ExternalHandle(eH),+ externalHandle,+ withCodingMode,+ openInCodingMode,+ putEncodedStr,+#ifdef TERMINFO+ getTermText,+#endif+ getBlockOfChars,+ getDecodedChar,+ getDecodedLine,+ ) where++import System.IO+import System.Console.Haskeline.Monads+import System.Console.Haskeline.Term+#ifdef TERMINFO+import qualified System.Console.Terminfo.Base as Terminfo+#endif++-- Way-dependent imports+#ifdef USE_GHC_ENCODINGS+import GHC.IO.Encoding (initLocaleEncoding)+import System.Console.Haskeline.Backend.Posix.Recover+#else+import System.Console.Haskeline.Backend.Posix.IConv+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+#ifdef TERMINFO+import qualified Data.ByteString.Char8 as BC+#endif+import Control.Monad (liftM2)+#endif++++#ifdef USE_GHC_ENCODINGS+data Encoder = Encoder+data Decoder = Decoder+#else+type Decoder = PartialDecoder+type Encoder = String -> IO ByteString+#endif++newEncoders :: IO (Encoder,Decoder)+#ifdef USE_GHC_ENCODINGS+newEncoders = return (Encoder,Decoder)+#else+newEncoders = do+ codeset <- bracket (setLocale (Just "")) setLocale $ const $ getCodeset+ liftM2 (,) (openEncoder codeset)+ (openPartialDecoder codeset)+#endif++-- | An 'ExternalHandle' is a handle which may or may not be in the correct+-- mode for Unicode input/output. When the POSIX backend opens a file+-- (or /dev/tty) it sets it permanently to the correct mode.+-- However, when it uses an existing handle like stdin, it only temporarily+-- sets it to the correct mode (e.g., for the duration of getInputLine);+-- otherwise, we might interfere with the rest of the Haskell program.+--+-- For the legacy backend, the correct mode is BinaryMode.+-- For the new backend, the correct mode is the locale encoding, set to+-- transliterate errors (rather than crashing, as is the base library's+-- default.) (See Posix/Recover.hs)+data ExternalHandle = ExternalHandle+ { externalMode :: ExternalMode+ , eH :: Handle+ }++data ExternalMode = CodingMode | OtherMode++externalHandle :: Handle -> ExternalHandle+externalHandle = ExternalHandle OtherMode++-- | Use to ensure that an external handle is in the correct mode+-- for the duration of the given action.+withCodingMode :: ExternalHandle -> IO a -> IO a+withCodingMode ExternalHandle {externalMode=CodingMode} act = act+#ifdef USE_GHC_ENCODINGS+withCodingMode (ExternalHandle OtherMode h) act = do+ bracket (liftIO $ hGetEncoding h)+ (liftIO . hSetBinOrEncoding h)+ $ const $ do+ hSetEncoding h haskelineEncoding+ act++hSetBinOrEncoding :: Handle -> Maybe TextEncoding -> IO ()+hSetBinOrEncoding h Nothing = hSetBinaryMode h True+hSetBinOrEncoding h (Just enc) = hSetEncoding h enc+#else+withCodingMode (ExternalHandle OtherMode h) act = hWithBinaryMode h act+#endif++#ifdef USE_GHC_ENCODINGS+haskelineEncoding :: TextEncoding+haskelineEncoding = transliterateFailure initLocaleEncoding+#endif++-- Open a file and permanently set it to the correct mode.+openInCodingMode :: FilePath -> IOMode -> IO ExternalHandle+#ifdef USE_GHC_ENCODINGS+openInCodingMode path iomode = do+ h <- openFile path iomode+ hSetEncoding h haskelineEncoding+ return $ ExternalHandle CodingMode h+#else+openInCodingMode path iomode+ = fmap (ExternalHandle CodingMode) $ openBinaryFile path iomode+#endif++++-----------------------+-- Output+putEncodedStr :: Encoder -> Handle -> String -> IO ()+#ifdef USE_GHC_ENCODINGS+putEncodedStr _ h = hPutStr h+#else+putEncodedStr enc h s = enc s >>= B.hPutStr h+#endif++#ifdef TERMINFO+getTermText :: Encoder -> String -> IO Terminfo.TermOutput+#ifdef USE_GHC_ENCODINGS+getTermText _ = return . Terminfo.termText+#else+getTermText enc s = enc s >>= return . Terminfo.termText . BC.unpack+#endif+#endif++++-- Read at least one character of input, and more if immediately+-- available. In particular the characters making up a control sequence+-- will all be available at once, so they can be processed together+-- (with Posix.lexKeys).+getBlockOfChars :: Handle -> Decoder -> IO String+#ifdef USE_GHC_ENCODINGS+getBlockOfChars h _ = do+ c <- hGetChar h+ loop [c]+ where+ loop cs = do+ isReady <- hReady h+ if not isReady+ then return $ reverse cs+ else do+ c <- hGetChar h+ loop (c:cs)+#else+getBlockOfChars h decode = do+ let bufferSize = 32+ blockUntilInput h+ bs <- B.hGetNonBlocking h bufferSize+ decodeAndMore decode h bs++#endif++-- Read in a single character, or Nothing if eof.+-- Assumes the handle is "prepared".+getDecodedChar :: Handle -> Decoder -> MaybeT IO Char+#ifdef USE_GHC_ENCODINGS+getDecodedChar h _ = guardedEOF hGetChar h+#else+getDecodedChar h decode = do+ b <- hGetByte h+ cs <- liftIO $ decodeAndMore decode h (B.pack [b])+ case cs of+ [] -> return '?' -- shouldn't happen, but doesn't hurt to be careful.+ (c:_) -> return c+#endif++-- Read in a single line, or Nothing if eof.+getDecodedLine :: Handle -> Decoder -> MaybeT IO String+#ifdef USE_GHC_ENCODINGS+getDecodedLine h _ = guardedEOF hGetLine h+#else+getDecodedLine h decode+ = hGetLocaleLine h >>= liftIO . decodeAndMore decode h++#endif++-- Helper functions for iconv encoding+#ifndef USE_GHC_ENCODINGS+blockUntilInput :: Handle -> IO ()+#if __GLASGOW_HASKELL__ >= 611+-- threadWaitRead doesn't work with the new (ghc-6.12) IO library,+-- because it keeps a buffer even when NoBuffering is set.+blockUntilInput h = hWaitForInput h (-1) >> return ()+#else+-- hWaitForInput doesn't work with -threaded on ghc < 6.10+-- (#2363 in ghc's trac)+blockUntilInput h = unsafeHandleToFD h >>= threadWaitRead . Fd+#endif++#endif -- USE_GHC_ENCODINGS++
+ System/Console/Haskeline/Backend/Posix/IConv.hsc view
@@ -0,0 +1,177 @@+{- | This module exports iconv-based encoding/decoding, for use on+older versions of GHC. +-}+module System.Console.Haskeline.Backend.Posix.IConv(+ setLocale,+ getCodeset,+ openEncoder,+ openDecoder,+ openPartialDecoder,+ PartialDecoder,+ decodeAndMore,+ ) where++import Foreign.C+import Foreign+import Data.ByteString (ByteString, useAsCStringLen, append )+-- TODO: Base or Internal, depending on whether base>=3.+import Data.ByteString.Internal (createAndTrim')+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as UTF8+import Data.Maybe (fromMaybe)+import System.IO (Handle)++#include <locale.h>+#include <langinfo.h>+#include "h_iconv.h"++openEncoder :: String -> IO (String -> IO ByteString)+openEncoder codeset = do+ encodeT <- iconvOpen codeset "UTF-8"+ return $ simpleIConv dropUTF8Char encodeT . UTF8.fromString++openDecoder :: String -> IO (ByteString -> IO String)+openDecoder codeset = do+ decodeT <- iconvOpen "UTF-8" codeset+ return $ fmap UTF8.toString . simpleIConv (B.drop 1) decodeT++dropUTF8Char :: ByteString -> ByteString+dropUTF8Char = fromMaybe B.empty . fmap snd . UTF8.uncons++replacement :: Word8+replacement = toEnum (fromEnum '?')++-- handle errors by dropping unuseable chars.+simpleIConv :: (ByteString -> ByteString) -> IConvT -> ByteString -> IO ByteString+simpleIConv dropper t bs = do+ (cs,result) <- iconv t bs+ case result of+ Invalid rest -> continueOnError cs rest+ Incomplete rest -> continueOnError cs rest+ _ -> return cs+ where+ continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`))+ $ simpleIConv dropper t (dropper rest)++type PartialDecoder = ByteString -> IO (String,Result)++openPartialDecoder :: String -> IO PartialDecoder+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 withCAString) oldLocale $ \loc_p -> do+ c_setlocale (#const LC_CTYPE) loc_p >>= maybePeek peekCAString++-----------------+-- Getting the encoding++type NLItem = #type nl_item++foreign import ccall nl_langinfo :: NLItem -> IO CString++getCodeset :: IO String+getCodeset = do+ str <- nl_langinfo (#const CODESET) >>= peekCAString+ -- check for codesets which may be returned by Solaris, but not understood+ -- by GNU iconv.+ if str `elem` ["","646"]+ then return "ISO-8859-1"+ else return str++----------------+-- Iconv++-- TODO: This may not work on platforms where iconv_t is not a pointer.+type IConvT = ForeignPtr ()+type IConvTPtr = Ptr ()++foreign import ccall "haskeline_iconv_open" iconv_open+ :: CString -> CString -> IO IConvTPtr++iconvOpen :: String -> String -> IO IConvT+iconvOpen destName srcName = withCAString destName $ \dest ->+ withCAString srcName $ \src -> do+ res <- iconv_open dest src+ if res == nullPtr `plusPtr` (-1)+ then throwErrno $ "iconvOpen "+ ++ show (srcName,destName)+ -- list the two it couldn't convert between?+ else newForeignPtr iconv_close res++-- really this returns a CInt, but it's easiest to just ignore that, I think.+foreign import ccall "& haskeline_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ())++foreign import ccall "haskeline_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+ -- ignore the return value; checking the errno is more reliable.+ _ <- 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)++-------------+-- Decode the given ByteString. If necessary, finish decoding it+-- by reading more bytes one at a time from the given handle.+-- (This assumes that the handle is in BinaryMode.)+decodeAndMore:: PartialDecoder+ -> Handle -> B.ByteString -> IO String+decodeAndMore decoder h bs = do+ (cs,result) <- decoder bs+ case result of+ Incomplete rest -> do+ extra <- B.hGetNonBlocking h 1+ if B.null extra+ then return (cs ++ "?")+ else fmap (cs++)+ $ decodeAndMore decoder h (rest `B.append` extra)+ Invalid rest -> fmap ((cs ++) . ('?':))+ $ decodeAndMore decoder h (B.drop 1 rest)+ Successful -> return cs
+ System/Console/Haskeline/Backend/Posix/Recover.hs view
@@ -0,0 +1,22 @@+module System.Console.Haskeline.Backend.Posix.Recover where++import GHC.IO.Encoding+import GHC.IO.Encoding.Failure++transliterateFailure :: TextEncoding -> TextEncoding+transliterateFailure+ TextEncoding+ { mkTextEncoder = mkEncoder+ , mkTextDecoder = mkDecoder+ , textEncodingName = name+ } = TextEncoding+ { mkTextDecoder = fmap (setRecover+ $ recoverDecode TransliterateCodingFailure)+ mkDecoder+ , mkTextEncoder = fmap (setRecover+ $ recoverEncode TransliterateCodingFailure)+ mkEncoder+ , textEncodingName = name+ }+ where+ setRecover r x = x { recover = r }
System/Console/Haskeline/Backend/Terminfo.hs view
@@ -8,20 +8,19 @@ import Control.Monad import Data.List(foldl') import System.IO-import qualified Control.Exception.Extensible as Exception-import qualified Data.ByteString.Char8 as B+import qualified Control.Exception as Exception import Data.Maybe (fromMaybe, mapMaybe)-import Control.Concurrent.Chan import qualified Data.IntMap as Map import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.LineState import System.Console.Haskeline.Term import System.Console.Haskeline.Backend.Posix+import System.Console.Haskeline.Backend.Posix.Encoder (getTermText) import System.Console.Haskeline.Backend.WCWidth import System.Console.Haskeline.Key -import qualified Control.Monad.Writer as Writer+import qualified Control.Monad.Trans.Writer as Writer ---------------------------------------------------------------- -- Low-level terminal output@@ -107,35 +106,33 @@ deriving (Monad, MonadIO, MonadException, MonadReader Actions, MonadReader Terminal, MonadState TermPos, MonadState TermRows,- MonadReader Handles, MonadReader Encoders)+ MonadReader Handles, MonadReader Encoder) instance MonadTrans Draw where lift = Draw . lift . lift . lift . lift . lift . lift- ++evalDraw :: forall m . (MonadReader Layout m, CommandMonad m) => Terminal -> Actions -> EvalTerm (PosixT m)+evalDraw term actions = EvalTerm eval liftE+ where+ liftE = Draw . lift . lift . lift . lift+ eval = evalStateT' initTermPos+ . evalStateT' initTermRows+ . runReaderT' term+ . runReaderT' actions+ . unDraw + + runTerminfoDraw :: Handles -> MaybeT IO RunTerm runTerminfoDraw h = do mterm <- liftIO $ Exception.try setupTermFromEnv- ch <- liftIO newChan case mterm of Left (_::SetupTermError) -> mzero Right term -> do actions <- MaybeT $ return $ getCapability term getActions- posixRunTerm h $ \enc ->- TermOps {- getLayout = tryGetLayouts (posixLayouts h- ++ [tinfoLayout term])- , withGetEvent = wrapKeypad (hOut h) term- . withPosixGetEvent ch h enc- (terminfoKeys term)- , saveUnusedKeys = saveKeys ch- , runTerm = \(RunTermType f) -> - runPosixT enc h- $ evalStateT' initTermPos- $ evalStateT' initTermRows- $ runReaderT' term- $ runReaderT' actions- $ unDraw f- }+ liftIO $ posixRunTerm h (posixLayouts h ++ [tinfoLayout term])+ (terminfoKeys term)+ (wrapKeypad (ehOut h) term)+ (evalDraw term actions) -- If the keypad on/off capabilities are defined, wrap the computation with them. wrapKeypad :: MonadException m => Handle -> Terminal -> m a -> m a@@ -147,8 +144,8 @@ tinfoLayout :: Terminal -> IO (Maybe Layout) tinfoLayout term = return $ getCapability term $ do- r <- termColumns- c <- termLines+ c <- termColumns+ r <- termLines return Layout {height=r,width=c} terminfoKeys :: Terminal -> [(String,Key)]@@ -192,7 +189,7 @@ (x,action) <- Writer.runWriterT m toutput <- asks action term <- ask- ttyh <- liftM hOut ask+ ttyh <- liftM ehOut ask liftIO $ hRunTermOutput ttyh term toutput return x @@ -200,7 +197,10 @@ output = Writer.tell outputText :: String -> ActionM ()-outputText str = posixEncode str >>= output . const . termText . B.unpack+outputText str = do+ encode <- lift ask+ liftIO (getTermText encode str)+ >>= output . const left,right,up :: Int -> TermAction left = flip leftA
System/Console/Haskeline/Backend/Win32.hsc view
@@ -19,20 +19,29 @@ import System.Console.Haskeline.Key import System.Console.Haskeline.Monads import System.Console.Haskeline.LineState -import System.Console.Haskeline.Term as Term +import System.Console.Haskeline.Term +import System.Console.Haskeline.Backend.WCWidth import Data.ByteString.Internal (createAndTrim) import qualified Data.ByteString as B +##if defined(i386_HOST_ARCH) +## define WINDOWS_CCONV stdcall +##elif defined(x86_64_HOST_ARCH) +## define WINDOWS_CCONV ccall +##else +## error Unknown mingw32 arch +##endif + #include "win_console.h" -foreign import stdcall "windows.h ReadConsoleInputW" c_ReadConsoleInput +foreign import WINDOWS_CCONV "windows.h ReadConsoleInputW" c_ReadConsoleInput :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool -foreign import stdcall "windows.h WaitForSingleObject" c_WaitForSingleObject +foreign import WINDOWS_CCONV "windows.h WaitForSingleObject" c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD -foreign import stdcall "windows.h GetNumberOfConsoleInputEvents" +foreign import WINDOWS_CCONV "windows.h GetNumberOfConsoleInputEvents" c_GetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO Bool getNumberOfEvents :: HANDLE -> IO Int @@ -177,7 +186,7 @@ setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition" . c_SetPosition h -foreign import stdcall "windows.h GetConsoleScreenBufferInfo" +foreign import WINDOWS_CCONV "windows.h GetConsoleScreenBufferInfo" c_GetScreenBufferInfo :: HANDLE -> Ptr () -> IO Bool getPosition :: HANDLE -> IO Coord @@ -196,20 +205,28 @@ c <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) p return Layout {width = coordX c, height = coordY c} -foreign import stdcall "windows.h WriteConsoleW" c_WriteConsoleW +foreign import WINDOWS_CCONV "windows.h WriteConsoleW" c_WriteConsoleW :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool writeConsole :: HANDLE -> String -> IO () -- For some reason, Wine returns False when WriteConsoleW is called on an empty -- string. Easiest fix: just don't call that function. writeConsole _ "" = return () -writeConsole h str = withArray tstr $ \t_arr -> alloca $ \numWritten -> do - failIfFalse_ "WriteConsole" - $ c_WriteConsoleW h t_arr (toEnum $ length str) numWritten nullPtr +writeConsole h str = writeConsole' >> writeConsole h ys where - tstr = map (toEnum . fromEnum) str - -foreign import stdcall "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool + (xs,ys) = splitAt limit str + -- WriteConsoleW has a buffer limit which is documented as 32768 word8's, + -- but bug reports from online suggest that the limit may be lower (~25000). + -- To be safe, we pick a round number we know to be less than the limit. + limit = 20000 -- known to be less than WriteConsoleW's buffer limit + writeConsole' + = withArray (map (toEnum . fromEnum) xs) + $ \t_arr -> alloca $ \numWritten -> do + failIfFalse_ "WriteConsoleW" + $ c_WriteConsoleW h t_arr (toEnum $ length xs) + numWritten nullPtr + +foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool messageBeep :: IO () messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures. @@ -217,10 +234,10 @@ ---------- -- Console mode -foreign import stdcall "windows.h GetConsoleMode" c_GetConsoleMode +foreign import WINDOWS_CCONV "windows.h GetConsoleMode" c_GetConsoleMode :: HANDLE -> Ptr DWORD -> IO Bool -foreign import stdcall "windows.h SetConsoleMode" c_SetConsoleMode +foreign import WINDOWS_CCONV "windows.h SetConsoleMode" c_SetConsoleMode :: HANDLE -> DWORD -> IO Bool withWindowMode :: MonadException m => Handles -> m a -> m a @@ -245,7 +262,7 @@ 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 () +type DrawM a = (MonadIO m, MonadReader Layout m) => Draw m a instance MonadTrans Draw where lift = Draw . lift @@ -253,40 +270,79 @@ getPos :: MonadIO m => Draw m Coord getPos = asks hOut >>= liftIO . getPosition -setPos :: MonadIO m => Coord -> Draw m () +setPos :: Coord -> DrawM () setPos c = do h <- asks hOut - liftIO (setPosition h c) + -- SetPosition will fail if you give it something out of bounds of + -- the window buffer (i.e., the input line doesn't fit in the window). + -- So we do a simple guard against that uncommon case. + -- However, we don't throw away the x coord since it produces sensible + -- results for some cases. + maxY <- liftM (subtract 1) $ asks height + liftIO $ setPosition h c { coordY = max 0 $ min maxY $ coordY c } printText :: MonadIO m => String -> Draw m () printText txt = do h <- asks hOut liftIO (writeConsole h txt) -printAfter :: String -> DrawM () -printAfter str = do - printText str - movePos $ negate $ length str +printAfter :: [Grapheme] -> DrawM () +printAfter gs = do + -- NOTE: you may be tempted to write + -- do {p <- getPos; printText (...); setPos p} + -- Unfortunately, that would be WRONG, because if printText wraps + -- a line at the bottom of the window, causing the window to scroll, + -- then the old value of p will be incorrect. + printText (graphemesToString gs) + movePosLeft gs drawLineDiffWin :: LineChars -> LineChars -> DrawM () drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of ([],[]) | ys1 == ys2 -> return () - (xs1',[]) | xs1' ++ ys1 == ys2 -> movePos $ negate $ length xs1' - ([],xs2') | ys1 == xs2' ++ ys2 -> movePos $ length xs2' + (xs1',[]) | xs1' ++ ys1 == ys2 -> movePosLeft xs1' + ([],xs2') | ys1 == xs2' ++ ys2 -> movePosRight xs2' (xs1',xs2') -> do - movePos (negate $ length xs1') - let m = length xs1' + length ys1 - (length xs2' + length ys2) - let deadText = replicate m ' ' + movePosLeft xs1' + let m = gsWidth xs1' + gsWidth ys1 - (gsWidth xs2' + gsWidth ys2) + let deadText = stringToGraphemes $ replicate m ' ' printText (graphemesToString xs2') - printAfter (graphemesToString ys2 ++ deadText) + printAfter (ys2 ++ deadText) -movePos :: Int -> DrawM () -movePos n = do - Coord {coordX = x, coordY = y} <- getPos +movePosRight, movePosLeft :: [Grapheme] -> DrawM () +movePosRight str = do + p <- getPos w <- asks width - let (h,x') = divMod (x+n) w - setPos Coord {coordX = x', coordY = y+h} + setPos $ moveCoord w p str + where + moveCoord _ p [] = p + moveCoord w p cs = case splitAtWidth (w - coordX p) cs of + (_,[],len) | len < w - coordX p -- stayed on same line + -> Coord { coordY = coordY p, + coordX = coordX p + len + } + (_,cs',_) -- moved to next line + -> moveCoord w Coord { + coordY = coordY p + 1, + coordX = 0 + } cs' +movePosLeft str = do + p <- getPos + w <- asks width + setPos $ moveCoord w p str + where + moveCoord _ p [] = p + moveCoord w p cs = case splitAtWidth (coordX p) cs of + (_,[],len) -- stayed on same line + -> Coord { coordY = coordY p, + coordX = coordX p - len + } + (_,_:cs',_) -- moved to previous line + -> moveCoord w Coord { + coordY = coordY p - 1, + coordX = w-1 + } cs' + crlf :: String crlf = "\r\n" @@ -302,14 +358,10 @@ printLines [] = return () printLines ls = printText $ intercalate crlf ls ++ crlf - clearLayout = do - lay <- ask - setPos (Coord 0 0) - printText (replicate (width lay * height lay) ' ') - setPos (Coord 0 0) + clearLayout = clearScreen moveToNextLine s = do - movePos (lengthToEnd s) + movePosRight (snd s) printText "\r\n" -- make the console take care of creating a new line ringBell True = liftIO messageBeep @@ -331,8 +383,8 @@ , withGetEvent = withWindowMode hs . win32WithEvent hs ch , saveUnusedKeys = saveKeys ch - , runTerm = \(RunTermType f) -> - runReaderT' hs $ runDraw f + , evalTerm = EvalTerm (runReaderT' hs . runDraw) + (Draw . lift) }, closeTerm = closeHandles hs } @@ -349,16 +401,15 @@ return RunTerm { closeTerm = return (), putStrOut = putter, - encodeForTerm = unicodeToCodePage cp, - decodeForTerm = codePageToUnicode cp, wrapInterrupt = withCtrlCHandler, - termOps = Right FileOps { - inputHandle = h_in, - getLocaleChar = getMultiByteChar cp h_in, - maybeReadNewline = hMaybeReadNewline h_in, - getLocaleLine = Term.hGetLine h_in + termOps = Right FileOps + { inputHandle = h_in + , wrapFileInput = hWithBinaryMode h_in + , getLocaleChar = getMultiByteChar cp h_in + , maybeReadNewline = hMaybeReadNewline h_in + , getLocaleLine = hGetLocaleLine h_in >>= liftIO . codePageToUnicode cp - } + } } @@ -376,7 +427,6 @@ return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout - type Handler = DWORD -> IO BOOL foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler) @@ -402,10 +452,11 @@ handler _ _ = return False + ------------------------ -- Multi-byte conversion -foreign import stdcall "WideCharToMultiByte" wideCharToMultiByte +foreign import WINDOWS_CCONV "WideCharToMultiByte" wideCharToMultiByte :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt -> LPCSTR -> LPBOOL -> IO CInt @@ -419,7 +470,7 @@ fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) (castPtr outBuff) outSize nullPtr nullPtr -foreign import stdcall "MultiByteToWideChar" multiByteToWideChar +foreign import WINDOWS_CCONV "MultiByteToWideChar" multiByteToWideChar :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt codePageToUnicode :: CodePage -> B.ByteString -> IO String @@ -439,18 +490,56 @@ then return conCP else getACP -foreign import stdcall "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx +foreign import WINDOWS_CCONV "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx :: CodePage -> BYTE -> BOOL getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char -getMultiByteChar cp h = hWithBinaryMode h loop - where - loop = do +getMultiByteChar cp h = 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 + [] -> getMultiByteChar cp h (c:_) -> return c + +---------------------------------- +-- Clearing screen +-- WriteConsole has a limit of ~20,000-30000 characters, which is +-- less than a 200x200 window, for example. +-- So we'll use other Win32 functions to clear the screen. + +getAttribute :: HANDLE -> IO WORD +getAttribute = withScreenBufferInfo $ + (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) + +fillConsoleChar :: HANDLE -> Char -> Int -> Coord -> IO () +fillConsoleChar h c n start = with start $ \startPtr -> alloca $ \numWritten -> do + failIfFalse_ "FillConsoleOutputCharacter" + $ c_FillConsoleCharacter h (toEnum $ fromEnum c) + (toEnum n) startPtr numWritten + +foreign import ccall "haskeline_FillConsoleCharacter" c_FillConsoleCharacter + :: HANDLE -> TCHAR -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL + +fillConsoleAttribute :: HANDLE -> WORD -> Int -> Coord -> IO () +fillConsoleAttribute h a n start = with start $ \startPtr -> alloca $ \numWritten -> do + failIfFalse_ "FillConsoleOutputAttribute" + $ c_FillConsoleAttribute h a + (toEnum n) startPtr numWritten + +foreign import ccall "haskeline_FillConsoleAttribute" c_FillConsoleAttribute + :: HANDLE -> WORD -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL + +clearScreen :: DrawM () +clearScreen = do + lay <- ask + h <- asks hOut + let windowSize = width lay * height lay + let origin = Coord 0 0 + attr <- liftIO $ getAttribute h + liftIO $ fillConsoleChar h ' ' windowSize origin + liftIO $ fillConsoleAttribute h attr windowSize origin + setPos origin +
System/Console/Haskeline/Command.hs view
@@ -30,7 +30,7 @@ import Data.Char(isPrint) import Control.Monad(mplus, liftM)-import Control.Monad.Trans+import Control.Monad.Trans.Class import System.Console.Haskeline.LineState import System.Console.Haskeline.Key
System/Console/Haskeline/Command/Completion.hs view
@@ -24,7 +24,7 @@ askIMCompletions :: CommandMonad m => Command m InsertMode (InsertMode, [Completion]) askIMCompletions (IMode xs ys) = do- (rest, completions) <- runCompletion (withRev graphemesToString xs,+ (rest, completions) <- lift $ runCompletion (withRev graphemesToString xs, graphemesToString ys) return (IMode (withRev stringToGraphemes rest) ys, completions) where
System/Console/Haskeline/Command/History.hs view
@@ -8,6 +8,7 @@ import Data.List import Data.Maybe(fromMaybe) import System.Console.Haskeline.History+import Data.IORef data HistLog = HistLog {pastHistory, futureHistory :: [[Grapheme]]} deriving Show@@ -26,19 +27,21 @@ histLog hist = HistLog {pastHistory = map stringToGraphemes $ historyLines hist, futureHistory = []} -runHistoryFromFile :: MonadIO m => Maybe FilePath -> Maybe Int -> StateT History m a -> m a-runHistoryFromFile Nothing _ f = evalStateT' emptyHistory f+runHistoryFromFile :: MonadException m => Maybe FilePath -> Maybe Int+ -> ReaderT (IORef History) m a -> m a+runHistoryFromFile Nothing _ f = do+ historyRef <- liftIO $ newIORef emptyHistory+ runReaderT f historyRef runHistoryFromFile (Just file) stifleAmt f = do oldHistory <- liftIO $ readHistory file- (x,newHistory) <- runStateT f (stifleHistory stifleAmt oldHistory)- liftIO $ writeHistory file newHistory+ historyRef <- liftIO $ newIORef $ stifleHistory stifleAmt oldHistory+ -- Run the action and then write the new history, even on an exception.+ -- For example, if there's an unhandled ctrl-c, we don't want to lose+ -- the user's previously-entered commands.+ -- (Note that this requires using ReaderT (IORef History) instead of StateT.+ x <- runReaderT f historyRef+ `finally` (liftIO $ readIORef historyRef >>= writeHistory file) return x--runHistLog :: Monad m => StateT HistLog m a -> StateT History m a-runHistLog f = do- history <- get- lift (evalStateT' (histLog history) f)- prevHistory, firstHistory :: Save s => s -> HistLog -> (s, HistLog) prevHistory s h = let (s',h') = fromMaybe (listSave s,h)
System/Console/Haskeline/Command/KillRing.hs view
@@ -5,6 +5,7 @@ import System.Console.Haskeline.Monads import System.Console.Haskeline.Command.Undo import Control.Monad+import Data.IORef -- standard trick for a purely functional queue: data Stack a = Stack [a] [a]@@ -28,8 +29,10 @@ type KillRing = Stack [Grapheme] -runKillRing :: Monad m => StateT KillRing m a -> m a-runKillRing = evalStateT' emptyStack+runKillRing :: MonadIO m => ReaderT (IORef KillRing) m a -> m a+runKillRing act = do+ ringRef <- liftIO $ newIORef emptyStack+ runReaderT act ringRef pasteCommand :: (Save s, MonadState KillRing m, MonadState Undo m)
System/Console/Haskeline/Directory.hsc view
@@ -21,13 +21,21 @@ #include <windows.h> #include <Shlobj.h> -foreign import stdcall "FindFirstFileW" c_FindFirstFile+##if defined(i386_HOST_ARCH)+## define WINDOWS_CCONV stdcall+##elif defined(x86_64_HOST_ARCH)+## define WINDOWS_CCONV ccall+##else+## error Unknown mingw32 arch+##endif++foreign import WINDOWS_CCONV "FindFirstFileW" c_FindFirstFile :: LPCTSTR -> Ptr () -> IO HANDLE -foreign import stdcall "FindNextFileW" c_FindNextFile+foreign import WINDOWS_CCONV "FindNextFileW" c_FindNextFile :: HANDLE -> Ptr () -> IO Bool -foreign import stdcall "FindClose" c_FindClose :: HANDLE -> IO BOOL+foreign import WINDOWS_CCONV "FindClose" c_FindClose :: HANDLE -> IO BOOL getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents fp = allocaBytes (#size WIN32_FIND_DATA) $ \findP ->@@ -45,7 +53,7 @@ else c_FindClose h >> return [f] peekFileName = peekCWString . (#ptr WIN32_FIND_DATA, cFileName) -foreign import stdcall "GetFileAttributesW" c_GetFileAttributes+foreign import WINDOWS_CCONV "GetFileAttributesW" c_GetFileAttributes :: LPCTSTR -> IO DWORD doesDirectoryExist :: FilePath -> IO Bool@@ -60,7 +68,7 @@ #else type HRESULT = #type HRESULT -foreign import stdcall "SHGetFolderPathW" c_SHGetFolderPath+foreign import WINDOWS_CCONV "SHGetFolderPathW" c_SHGetFolderPath :: Ptr () -> CInt -> HANDLE -> DWORD -> LPTSTR -> IO HRESULT getHomeDirectory :: IO FilePath@@ -83,8 +91,8 @@ import Data.ByteString.Char8 (pack, unpack) import qualified System.Directory as D-import Control.Exception.Extensible-import System.Console.Haskeline.Backend.IConv+import Control.Exception+import System.Console.Haskeline.Backend.Posix.IConv getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path = do
System/Console/Haskeline/Emacs.hs view
@@ -12,8 +12,8 @@ import Data.Char -type InputCmd s t = forall m . Monad m => Command (InputCmdT m) s t-type InputKeyCmd s t = forall m . Monad m => KeyCommand (InputCmdT m) s t+type InputCmd s t = forall m . MonadException m => Command (InputCmdT m) s t+type InputKeyCmd s t = forall m . MonadException m => KeyCommand (InputCmdT m) s t emacsCommands :: InputKeyCmd InsertMode (Maybe String) emacsCommands = choiceCmd [
− System/Console/Haskeline/Encoding.hs
@@ -1,40 +0,0 @@-{- |--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/History.hs view
@@ -28,12 +28,18 @@ import Data.Sequence ( Seq, (<|), ViewL(..), ViewR(..), viewl, viewr ) import Data.Foldable (toList) -import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as UTF8-import Control.Exception.Extensible+import Control.Exception import System.Directory(doesFileExist) +#ifdef USE_GHC_ENCODINGS+import qualified System.IO as IO+import System.Console.Haskeline.Backend.Posix.Recover+#else+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as UTF8+#endif+ data History = History {histLines :: Seq String, stifleAmt :: Maybe Int} -- stored in reverse@@ -58,9 +64,7 @@ readHistory file = handle (\(_::IOException) -> return emptyHistory) $ do exists <- doesFileExist file contents <- if exists- -- use binary file I/O to avoid Windows CRLF line endings- -- which cause confusion when switching between systems.- then fmap UTF8.toString (B.readFile file)+ then readUTF8File file else return "" _ <- evaluate (length contents) -- force file closed return History {histLines = Seq.fromList $ lines contents,@@ -70,7 +74,7 @@ -- error when writing the file, it will be ignored. writeHistory :: FilePath -> History -> IO () writeHistory file = handle (\(_::IOException) -> return ())- . B.writeFile file . UTF8.fromString+ . writeUTF8File file . unlines . historyLines -- | Limit the number of lines stored in the history.@@ -108,3 +112,38 @@ addHistoryRemovingAllDupes h hs = addHistory h hs {histLines = filteredHS} where filteredHS = Seq.fromList $ filter (/= h) $ toList $ histLines hs++---------+-- UTF-8 file I/O, for old versions of GHC++readUTF8File :: FilePath -> IO String+#ifdef USE_GHC_ENCODINGS+readUTF8File file = do+ h <- IO.openFile file IO.ReadMode+ IO.hSetEncoding h $ transliterateFailure IO.utf8+ IO.hSetNewlineMode h IO.noNewlineTranslation+ contents <- IO.hGetContents h+ _ <- evaluate (length contents)+ IO.hClose h+ return contents+#else+readUTF8File file = do+ contents <- fmap UTF8.toString $ B.readFile file+ _ <- evaluate (length contents)+ return contents+#endif++writeUTF8File :: FilePath -> String -> IO ()+#ifdef USE_GHC_ENCODINGS+writeUTF8File file contents = do+ h <- IO.openFile file IO.WriteMode+ IO.hSetEncoding h IO.utf8+ -- Write a file which is portable between systems.+ IO.hSetNewlineMode h IO.noNewlineTranslation+ IO.hPutStr h contents+ IO.hClose h+#else+-- use binary file I/O to avoid Windows CRLF line endings+-- which cause confusion when switching between systems.+writeUTF8File file = B.writeFile file . UTF8.fromString+#endif
System/Console/Haskeline/IO.hs view
@@ -42,7 +42,7 @@ import System.Console.Haskeline hiding (completeFilename) import Control.Concurrent -import Control.Monad.Trans+import Control.Monad.IO.Class -- Providing a non-monadic API for haskeline -- A process is forked off which runs the monadic InputT API
System/Console/Haskeline/InputT.hs view
@@ -14,8 +14,9 @@ import System.Directory(getHomeDirectory) import System.FilePath import Control.Applicative-import qualified Control.Monad.State as State+import Control.Monad (liftM, ap) import System.IO+import Data.IORef -- | Application-specific customizations to the user interface. data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion.@@ -38,38 +39,55 @@ -- | 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- (StateT KillRing (ReaderT Prefs+newtype InputT m a = InputT {unInputT :: + ReaderT RunTerm+ -- Use ReaderT (IO _) vs StateT so that exceptions (e.g., ctrl-c)+ -- don't cause us to lose the existing state.+ (ReaderT (IORef History)+ (ReaderT (IORef KillRing)+ (ReaderT Prefs (ReaderT (Settings m) m)))) a}- deriving (Monad, MonadIO, MonadException,- MonadState History, MonadReader Prefs,- MonadReader (Settings m), MonadReader RunTerm)+ deriving (Monad, MonadIO, MonadException)+ -- NOTE: we're explicitly *not* making InputT an instance of our+ -- internal MonadState/MonadReader classes. Otherwise haddock+ -- displays those instances to the user, and it makes it seem like+ -- we implement the mtl versions of those classes. instance Monad m => Functor (InputT m) where- fmap = State.liftM+ fmap = liftM instance Monad m => Applicative (InputT m) where pure = return- (<*>) = State.ap+ (<*>) = ap instance MonadTrans InputT where lift = InputT . lift . lift . lift . lift . lift -instance Monad m => State.MonadState History (InputT m) where- get = get- put = put+-- | Get the current line input history.+getHistory :: MonadIO m => InputT m History+getHistory = InputT get +-- | Set the line input history.+putHistory :: MonadIO m => History -> InputT m ()+putHistory = InputT . put++-- | Change the current line input history.+modifyHistory :: MonadIO m => (History -> History) -> InputT m ()+modifyHistory = InputT . modify+ -- for internal use only-type InputCmdT m = StateT Layout (UndoT (StateT HistLog (StateT KillRing+type InputCmdT m = StateT Layout (UndoT (StateT HistLog (ReaderT (IORef KillRing)+ -- HistLog can be just StateT, since its final state+ -- isn't used outside of InputCmdT. (ReaderT Prefs (ReaderT (Settings m) m))))) runInputCmdT :: MonadIO m => TermOps -> InputCmdT m a -> InputT m a runInputCmdT tops f = InputT $ do layout <- liftIO $ getLayout tops- lift $ runHistLog $ runUndoT $ evalStateT' layout f+ history <- get+ lift $ lift $ evalStateT' (histLog history) $ runUndoT $ evalStateT' layout f -instance Monad m => CommandMonad (InputCmdT m) where+instance MonadException m => CommandMonad (InputCmdT m) where runCompletion lcs = do settings <- ask lift $ lift $ lift $ lift $ lift $ lift $ complete settings lcs@@ -93,7 +111,7 @@ -- | Returns 'True' if the current session uses terminal-style interaction. (See 'Behavior'.) haveTerminalUI :: Monad m => InputT m Bool-haveTerminalUI = asks isTerminalStyle+haveTerminalUI = InputT $ asks isTerminalStyle {- | Haskeline has two ways of interacting with the user:@@ -142,6 +160,11 @@ $ runHistoryFromFile (historyFile settings) (maxHistorySize prefs) $ runReaderT f run +-- | Map a user interaction by modifying the base monad computation.+mapInputT :: (forall b . m b -> m b) -> InputT m a -> InputT m a+mapInputT f = InputT . mapReaderT (mapReaderT (mapReaderT+ (mapReaderT (mapReaderT f))))+ . unInputT -- | Read input from 'stdin'. -- Use terminal-style interaction if 'stdin' is connected to
System/Console/Haskeline/MonadException.hs view
@@ -1,43 +1,116 @@-{- | This module redefines some of the functions in "Control.Exception.Extensible" to-work for more general monads than only 'IO'.+{- | This module redefines some of the functions in "Control.Exception" to+work for more general monads built on top of 'IO'. -} module System.Console.Haskeline.MonadException(+ -- * The MonadException class MonadException(..),+ -- * Generalizations of Control.Exception+ catch, handle, finally, throwIO, throwTo, bracket,- throwDynIO,- handleDyn,+ -- * Helpers for defining \"wrapper\" functions+ liftIOOp,+ liftIOOp_,+ -- * Internal implementation+ RunIO(..),+ -- * Extensible Exceptions Exception, SomeException(..),- E.IOException())+ E.IOException(),+ ) where -import qualified Control.Exception.Extensible as E-import Control.Exception.Extensible(Exception,SomeException)+import qualified Control.Exception as E+import Control.Exception (Exception,SomeException)+#if __GLASGOW_HASKELL__ < 705 import Prelude hiding (catch)-import Control.Monad.Reader-import Control.Monad.State+#endif+import Control.Monad(liftM, join)+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Error+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.RWS+import Control.Monad.Trans.Writer+import Data.Monoid import Control.Concurrent(ThreadId) +-- This approach is based on that of the monad-control package.+-- Since we want to use haskeline to bootstrap GHC, we reimplement+-- a simplified version here. +-- Additionally, we avoid TypeFamilies (which are used in the latest version of+-- monad-control) so that we're still compatible with older versions of GHC.++-- | A 'RunIO' function takes a monadic action @m@ as input,+-- and outputs an IO action which performs the underlying impure part of @m@+-- and returns the ''pure'' part of @m@.+--+-- Note that @(RunIO return)@ is an incorrect implementation, since it does not+-- separate the pure and impure parts of the monadic action. This module defines+-- implementations for several common monad transformers.+newtype RunIO m = RunIO (forall b . m b -> IO (m b))+-- Uses a newtype so we don't need RankNTypes.++-- | An instance of 'MonadException' is generally made up of monad transformers+-- layered on top of the IO monad. +-- +-- The 'controlIO' method enables us to \"lift\" a function that manages IO actions (such+-- as 'bracket' or 'catch') into a function that wraps arbitrary monadic actions. class MonadIO m => MonadException m where- catch :: Exception e => m a -> (e -> m a) -> m a- block :: m a -> m a- unblock :: m a -> m a+ controlIO :: (RunIO m -> IO (m a)) -> m a +-- | Lift a IO operation+-- +-- > wrap :: (a -> IO b) -> IO b+-- +-- to a more general monadic operation+-- +-- > liftIOOp wrap :: MonadException m => (a -> m b) -> m b+--+-- For example: +--+-- @+-- 'liftIOOp' ('System.IO.withFile' f m) :: MonadException m => (Handle -> m r) -> m r+-- 'liftIOOp' 'Foreign.Marshal.Alloc.alloca' :: (MonadException m, Storable a) => (Ptr a -> m b) -> m b+-- 'liftIOOp' (`Foreign.ForeignPtr.withForeignPtr` fp) :: MonadException m => (Ptr a -> m b) -> m b+-- @+liftIOOp :: MonadException m => ((a -> IO (m b)) -> IO (m c)) -> (a -> m b) -> m c+liftIOOp f g = controlIO $ \(RunIO run) -> f (run . g)++-- | Lift an IO operation+-- +-- > wrap :: IO a -> IO a+-- +-- to a more general monadic operation+-- +-- > liftIOOp_ wrap :: MonadException m => m a -> m a+liftIOOp_ :: MonadException m => (IO (m a) -> IO (m a)) -> m a -> m a+liftIOOp_ f act = controlIO $ \(RunIO run) -> f (run act)+++catch :: (MonadException m, E.Exception e) => m a -> (e -> m a) -> m a+catch act handler = controlIO $ \(RunIO run) -> E.catch+ (run act)+ (run . handler)+ handle :: (MonadException m, Exception e) => (e -> m a) -> m a -> m a handle = flip catch +bracket :: MonadException m => m a -> (a -> m b) -> (a -> m c) -> m c+bracket before after thing + = controlIO $ \(RunIO run) -> E.bracket+ (run before)+ (\m -> run (m >>= after))+ (\m -> run (m >>= thing))+ finally :: MonadException m => m a -> m b -> m a-finally f ender = block (do- r <- catch- (unblock f)- (\(e::SomeException) -> do {_ <- ender; throwIO e})- _ <- ender- return r)+finally thing ender = controlIO $ \(RunIO run) -> E.finally (run thing) (run ender) throwIO :: (MonadIO m, Exception e) => e -> m a throwIO = liftIO . E.throwIO@@ -45,40 +118,51 @@ throwTo :: (MonadIO m, Exception e) => ThreadId -> e -> m () throwTo tid = liftIO . E.throwTo tid -bracket :: MonadException m => m a -> (a -> m b) -> (a -> m c) -> m c-bracket before after thing =- block (do- a <- before - r <- catch - (unblock (thing a))- (\(e::SomeException) -> do { _ <- after a; throwIO e })- _ <- after a- return r- )--throwDynIO :: (Exception exception, MonadIO m) => exception -> m a-throwDynIO = throwIO--handleDyn :: (Exception exception, MonadException m) => (exception -> m a)- -> m a -> m a-handleDyn = handle -+----------+-- Instances of MonadException.+-- Since implementations of this class are non-obvious to a casual user,+-- we provide instances for nearly everything in the transformers package. instance MonadException IO where- catch = E.catch- block = E.block- unblock = E.unblock+ controlIO f = join $ f (RunIO (liftM return))+ -- Note: it's crucial that we use "liftM return" instead of "return" here.+ -- For example, in "finally thing end", this ensures that "end" will always run, + -- regardless of whether an mzero occurred inside of "thing". instance MonadException m => MonadException (ReaderT r m) where- catch f h = ReaderT $ \r -> catch (runReaderT f r) - (\e -> runReaderT (h e) r)- block = mapReaderT block- unblock = mapReaderT unblock+ controlIO f = ReaderT $ \r -> controlIO $ \(RunIO run) -> let+ run' = RunIO (fmap (ReaderT . const) . run . flip runReaderT r)+ in fmap (flip runReaderT r) $ f run' --- Not needed anymore by our code (we have a custom StateT monad),--- but we should follow the PVP and not remove this in a point release. instance MonadException m => MonadException (StateT s m) where- catch f h = StateT $ \s -> catch (runStateT f s)- (\e -> runStateT (h e) s)- block = mapStateT block- unblock = mapStateT unblock+ controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let+ run' = RunIO (fmap (StateT . const) . run . flip runStateT s)+ in fmap (flip runStateT s) $ f run'++instance MonadException m => MonadException (MaybeT m) where+ controlIO f = MaybeT $ controlIO $ \(RunIO run) -> let+ run' = RunIO (fmap MaybeT . run . runMaybeT)+ in fmap runMaybeT $ f run' ++instance (MonadException m, Error e) => MonadException (ErrorT e m) where+ controlIO f = ErrorT $ controlIO $ \(RunIO run) -> let+ run' = RunIO (fmap ErrorT . run . runErrorT)+ in fmap runErrorT $ f run'++instance MonadException m => MonadException (ListT m) where+ controlIO f = ListT $ controlIO $ \(RunIO run) -> let+ run' = RunIO (fmap ListT . run . runListT)+ in fmap runListT $ f run'++instance (Monoid w, MonadException m) => MonadException (WriterT w m) where+ controlIO f = WriterT $ controlIO $ \(RunIO run) -> let+ run' = RunIO (fmap WriterT . run . runWriterT)+ in fmap runWriterT $ f run'++instance (Monoid w, MonadException m) => MonadException (RWST r w s m) where+ controlIO f = RWST $ \r s -> controlIO $ \(RunIO run) -> let+ run' = RunIO (fmap (\act -> RWST (\_ _ -> act))+ . run . (\m -> runRWST m r s))+ in fmap (\m -> runRWST m r s) $ f run'++
System/Console/Haskeline/Monads.hs view
@@ -1,12 +1,15 @@ module System.Console.Haskeline.Monads(- module Control.Monad.Trans, module System.Console.Haskeline.MonadException,+ MonadTrans(..),+ MonadIO(..), ReaderT(..), runReaderT',+ mapReaderT, asks, StateT, runStateT, evalStateT',+ mapStateT, gets, modify, update,@@ -16,12 +19,18 @@ orElse ) where -import Control.Monad.Trans-import System.Console.Haskeline.MonadException+import Control.Monad (liftM)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Trans.Reader hiding (ask,asks)+import qualified Control.Monad.Trans.Reader as Reader+import Data.IORef+#if __GLASGOW_HASKELL__ < 705 import Prelude hiding (catch)+#endif -import Control.Monad.Reader hiding (MonadReader,ask,asks,local)-import qualified Control.Monad.Reader as Reader+import System.Console.Haskeline.MonadException class Monad m => MonadReader r m where ask :: m r@@ -75,11 +84,19 @@ instance MonadIO m => MonadIO (StateT s m) where liftIO = lift . liftIO +mapStateT :: (forall b . m b -> n b) -> StateT s m a -> StateT s n a+mapStateT f (StateT m) = StateT (\s -> f (m s))+ runStateT :: Monad m => StateT s m a -> s -> m (a, s) runStateT f s = do useXS <- getStateTFunc f s return $ useXS $ \x s' -> (x,s') +makeStateT :: Monad m => (s -> m (a,s)) -> StateT s m a+makeStateT f = StateT $ \s -> do+ (x,s') <- f s+ return $ \g -> g x s'+ instance Monad m => MonadState s (StateT s m) where get = StateT $ \s -> return $ \f -> f s s put s = s `seq` StateT $ \_ -> return $ \f -> f () s@@ -88,35 +105,22 @@ get = lift get put = lift . put +-- ReaderT (IORef s) is better than StateT s for some applications,+-- since StateT loses its state after an exception such as ctrl-c.+instance MonadIO m => MonadState s (ReaderT (IORef s) m) where+ get = ask >>= liftIO . readIORef+ put s = ask >>= liftIO . flip writeIORef s+ evalStateT' :: Monad m => s -> StateT s m a -> m a evalStateT' s f = liftM fst $ runStateT f s instance MonadException m => MonadException (StateT s m) where- block m = StateT $ \s -> block $ getStateTFunc m s- 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+ controlIO f = makeStateT $ \s -> controlIO $ \run ->+ fmap (flip runStateT s) $ f $ stateRunIO s run+ where+ stateRunIO :: s -> RunIO m -> RunIO (StateT s m)+ stateRunIO s (RunIO run) = RunIO (\m -> fmap (makeStateT . const)+ $ run (runStateT m s)) 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)
System/Console/Haskeline/RunCommand.hs view
@@ -9,34 +9,36 @@ import Control.Monad -runCommandLoop :: (MonadException m, CommandMonad m, MonadState Layout m,- LineState s)+runCommandLoop :: (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 tops@TermOps{evalTerm = EvalTerm eval liftE} prefix cmds initState+ = eval $ withGetEvent tops+ $ runCommandLoop' liftE tops (stringToGraphemes prefix) initState + cmds -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+runCommandLoop' :: forall m n s a . (Term n, CommandMonad n,+ MonadState Layout m, MonadReader Prefs n, LineState s)+ => (forall b . m b -> n b) -> TermOps -> Prefix -> s -> KeyCommand m s a -> n Event+ -> n a+runCommandLoop' liftE tops prefix initState cmds getEvent = do let s = lineChars prefix initState drawLine s readMoreKeys s (fmap (liftM (\x -> (x,[])) . ($ initState)) cmds) where- readMoreKeys :: LineChars -> KeyMap (CmdM m (a,[Key])) -> t m a+ readMoreKeys :: LineChars -> KeyMap (CmdM m (a,[Key])) -> n a readMoreKeys s next = do event <- handle (\(e::SomeException) -> moveToNextLine s >> throwIO e) getEvent case event of ErrorEvent e -> moveToNextLine s >> throwIO e- WindowResize -> drawReposition tops s- >> readMoreKeys s next+ WindowResize -> do+ drawReposition liftE tops s+ readMoreKeys s next KeyInput ks -> do- bound_ks <- mapM (lift . asks . lookupKeyBinding) ks+ bound_ks <- mapM (asks . lookupKeyBinding) ks loopCmd s $ applyKeysToMap (concat bound_ks) next - loopCmd :: LineChars -> CmdM m (a,[Key]) -> t m a+ loopCmd :: LineChars -> CmdM m (a,[Key]) -> n a loopCmd s (GetKey next) = readMoreKeys s next -- If there are multiple consecutive LineChanges, only render the diff -- to the last one, and skip the rest. This greatly improves speed when@@ -46,15 +48,23 @@ loopCmd s (DoEffect e next) = do t <- drawEffect prefix s e loopCmd t next- loopCmd s (CmdM next) = lift next >>= loopCmd s+ loopCmd s (CmdM next) = liftE next >>= loopCmd s loopCmd s (Result (x,ks)) = do liftIO (saveUnusedKeys tops ks) moveToNextLine s return x -drawEffect :: (MonadTrans t, Term (t m), MonadReader Prefs m)- => Prefix -> LineChars -> Effect -> t m LineChars+drawReposition :: (Term n, MonadState Layout m)+ => (forall a . m a -> n a) -> TermOps -> LineChars -> n ()+drawReposition liftE tops s = do+ oldLayout <- liftE get+ newLayout <- liftIO (getLayout tops)+ liftE (put newLayout)+ when (oldLayout /= newLayout) $ reposition oldLayout s++drawEffect :: (Term m, MonadReader Prefs m)+ => Prefix -> LineChars -> Effect -> m LineChars drawEffect prefix s (LineChange ch) = do let t = ch prefix drawLineDiff s t@@ -70,23 +80,13 @@ return s drawEffect _ s RingBell = actBell >> return s -actBell :: (MonadTrans t, Term (t m), MonadReader Prefs m) => t m ()+actBell :: (Term m, MonadReader Prefs m) => m () actBell = do- style <- lift $ asks bellStyle+ style <- asks bellStyle case style of NoBell -> return () VisualBell -> ringBell False AudibleBell -> ringBell True--drawReposition :: (MonadTrans t, Term (t m), MonadState Layout m)- => TermOps -> LineChars -> t m ()-drawReposition tops s = do- -- explicit lifts prevent the need for IncoherentInstances.- oldLayout <- lift get- newLayout <- liftIO $ getLayout tops- when (oldLayout /= newLayout) $ do- lift $ put newLayout- reposition oldLayout s ---------------
System/Console/Haskeline/Term.hs view
@@ -7,14 +7,14 @@ import System.Console.Haskeline.Completion(Completion) import Control.Concurrent-import Data.Typeable-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B import Data.Word-import Control.Exception.Extensible (fromException, AsyncException(..),bracket_)+import Control.Exception (fromException, AsyncException(..),bracket_)+import Data.Typeable import System.IO import Control.Monad(liftM,when,guard) import System.IO.Error (isEOFError)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BC class (MonadReader Layout m, MonadException m) => Term m where reposition :: Layout -> LineChars -> m ()@@ -32,25 +32,26 @@ data RunTerm = RunTerm { -- | Write unicode characters to stdout. putStrOut :: String -> IO (),- encodeForTerm :: String -> IO ByteString,- decodeForTerm :: ByteString -> IO String, termOps :: Either TermOps FileOps,- wrapInterrupt :: MonadException m => m a -> m a,+ wrapInterrupt :: forall a . IO a -> IO a, closeTerm :: IO () } -- | Operations needed for terminal-style interaction. data TermOps = TermOps { getLayout :: IO Layout- , withGetEvent :: (MonadException m, CommandMonad m)- => (m Event -> m a) -> m a- , runTerm :: (MonadException m, CommandMonad m) => RunTermType m a -> m a+ , withGetEvent :: CommandMonad m => (m Event -> m a) -> m a+ , evalTerm :: forall m . CommandMonad m => EvalTerm m , saveUnusedKeys :: [Key] -> IO () } -- | Operations needed for file-style interaction.+-- +-- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline+-- are "wrapped" by wrapFileInput. data FileOps = FileOps { inputHandle :: Handle, -- ^ e.g. for turning off echoing.+ wrapFileInput :: forall a . IO a -> IO a, getLocaleLine :: MaybeT IO String, getLocaleChar :: MaybeT IO Char, maybeReadNewline :: IO ()@@ -62,17 +63,30 @@ Left TermOps{} -> True _ -> False +-- Specific, hidden terminal action type -- 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 . - (MonadTrans t, Term (t m), MonadException (t m), CommandMonad (t m))- => t m a)+data EvalTerm m+ = forall n . (Term n, CommandMonad n)+ => EvalTerm (forall a . n a -> m a) (forall a . m a -> n a) -class (MonadReader Prefs m , MonadReader Layout m)+mapEvalTerm :: (forall a . n a -> m a) -> (forall a . m a -> n a)+ -> EvalTerm n -> EvalTerm m+mapEvalTerm eval liftE (EvalTerm eval' liftE')+ = EvalTerm (eval . eval') (liftE' . liftE)++data Interrupt = Interrupt+ deriving (Show,Typeable,Eq)++instance Exception Interrupt where++++class (MonadReader Prefs m , MonadReader Layout m, MonadException m) => CommandMonad m where runCompletion :: (String,String) -> m (String,[Completion]) instance (MonadTrans t, CommandMonad m, MonadReader Prefs (t m),+ MonadException (t m), MonadReader Layout (t m)) => CommandMonad (t m) where runCompletion = lift . runCompletion@@ -116,11 +130,6 @@ saveKeys :: Chan Event -> [Key] -> IO () saveKeys ch = writeChan ch . KeyInput -data Interrupt = Interrupt- deriving (Show,Typeable,Eq)--instance Exception Interrupt where- data Layout = Layout {width, height :: Int} deriving (Show,Eq) @@ -144,39 +153,27 @@ (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-+hGetByte = guardedEOF $ liftM (toEnum . fromEnum) . hGetChar --- | 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+guardedEOF :: (Handle -> IO a) -> Handle -> MaybeT IO a+guardedEOF f h = do+ eof <- lift $ hIsEOF h+ guard (not eof)+ lift $ f h -- If another character is immediately available, and it is a newline, consume it. -- -- Two portability fixes:+--+-- 1) By itself, this (by using hReady) might crash on invalid characters.+-- The handle should be set to binary mode or a TextEncoder that+-- transliterates or ignores invalid input. -- -- 1) Note that in ghc-6.8.3 and earlier, hReady returns False at an EOF, -- whereas in ghc-6.10.1 and later it throws an exception. (GHC trac #1063). -- This code handles both of those cases.------ 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@@ -188,3 +185,14 @@ returnOnEOF x = handle $ \e -> if isEOFError e then return x else throwIO e++-- | Utility function to correctly get a line of input as an undecoded ByteString.+hGetLocaleLine :: Handle -> MaybeT IO ByteString+hGetLocaleLine = guardedEOF $ \h -> do+ -- 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 fmap BC.pack $ System.IO.hGetLine h+ else BC.hGetLine h+
System/Console/Haskeline/Vi.hs view
@@ -30,8 +30,8 @@ type ViT m = StateT (ViState m) (InputCmdT m) -type InputCmd s t = forall m . Monad m => Command (ViT m) s t-type InputKeyCmd s t = forall m . Monad m => KeyCommand (ViT m) s t+type InputCmd s t = forall m . MonadException m => Command (ViT m) s t+type InputKeyCmd s t = forall m . MonadException m => KeyCommand (ViT m) s t viKeyCommands :: InputKeyCmd InsertMode (Maybe String) viKeyCommands = choiceCmd [@@ -382,13 +382,13 @@ -> Command (ViT m) (ArgMode CommandMode) InsertMode storedIAction act = storeLastCmd (liftM Right . act) >|> act -killAndStoreCmd :: Monad m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode+killAndStoreCmd :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode killAndStoreCmd = storedCmdAction . killFromArgHelper -killAndStoreI :: Monad m => KillHelper -> Command (ViT m) (ArgMode CommandMode) InsertMode+killAndStoreI :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) InsertMode killAndStoreI = storedIAction . killFromArgHelper -killAndStoreIE :: Monad m => KillHelper -> Command (ViT m) (ArgMode CommandMode) EitherMode+killAndStoreIE :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) EitherMode killAndStoreIE helper = storedAction (killFromArgHelper helper >|> return . Right) noArg :: Monad m => Command m s (ArgMode s)
cbits/win_console.c view
@@ -3,3 +3,11 @@ BOOL haskeline_SetPosition(HANDLE h, COORD* c) { return SetConsoleCursorPosition(h,*c); }++BOOL haskeline_FillConsoleCharacter(HANDLE h, TCHAR c, DWORD l, COORD *p, LPDWORD n) {+ return FillConsoleOutputCharacter(h,c,l,*p,n);+}++BOOL haskeline_FillConsoleAttribute(HANDLE h, WORD a, DWORD l, COORD *p, LPDWORD n) {+ return FillConsoleOutputAttribute(h,a,l,*p,n);+}
examples/Test.hs view
@@ -2,6 +2,7 @@ import System.Console.Haskeline import System.Environment+import Control.Exception (AsyncException(..)) {-- Testing the line-input functions and their interaction with ctrl-c signals.@@ -29,7 +30,7 @@ runInputT mySettings $ withInterrupt $ loop inputFunc 0 where loop inputFunc n = do- minput <- handleInterrupt (return (Just "Caught interrupted"))+ minput <- handle (\Interrupt -> return (Just "Caught interrupted")) $ inputFunc (show n ++ ":") case minput of Nothing -> return ()
haskeline.cabal view
@@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.6-Version: 0.6.4.7+Version: 0.7.0.0 Category: User Interfaces License: BSD3 License-File: LICENSE@@ -21,8 +21,9 @@ Build-Type: Custom extra-source-files: examples/Test.hs CHANGES -flag base2- Description: Use the base packages from before version 6.8+source-repository head+ type: darcs+ location: http://code.haskell.org/haskeline -- There are three main advantages to the terminfo backend over the portable, -- "dumb" alternative. First, it enables more efficient control sequences@@ -43,41 +44,38 @@ Description: Explicitly link against the libiconv library. Default: False +flag legacy-encoding+ Description: Use the legacy iconv encoding for POSIX, even on ghc>=7.4.1.+ (Intended for testing only.)+ Default: False+ Library- if flag(base2) {- Build-depends: base == 2.*- cpp-options: -DOLD_BASE+ if impl(ghc>=6.11) {+ Build-depends: base >=4.1 && < 4.7, containers>=0.1 && < 0.6, directory>=1.0 && < 1.2,+ bytestring>=0.9 && < 0.11 } else {- if impl(ghc>=6.11) {- Build-depends: base >=4.1 && < 4.6, containers>=0.1 && < 0.6, directory>=1.0 && < 1.2,- bytestring>=0.9 && < 0.11- }- else {- Build-depends: base>=3 && <4.1 , containers>=0.1 && < 0.3, directory==1.0.*,- bytestring==0.9.*- }+ Build-depends: base>=3 && <4.1 , containers>=0.1 && < 0.3, directory==1.0.*,+ bytestring==0.9.* }- Build-depends: filepath >= 1.1 && < 1.4, mtl >= 1.1 && < 2.2,- utf8-string==0.3.* && >=0.3.6,- extensible-exceptions==0.1.* && >=0.1.1.0+ Build-depends: filepath >= 1.1 && < 1.4, transformers >= 0.2 && < 0.4 Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances, TypeSynonymInstances FlexibleContexts, ExistentialQuantification ScopedTypeVariables, GeneralizedNewtypeDeriving MultiParamTypeClasses, OverlappingInstances UndecidableInstances- PatternSignatures, CPP, DeriveDataTypeable,+ ScopedTypeVariables, CPP, DeriveDataTypeable, PatternGuards 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 Other-Modules: System.Console.Haskeline.Backend+ System.Console.Haskeline.Backend.WCWidth System.Console.Haskeline.Command System.Console.Haskeline.Command.Completion System.Console.Haskeline.Command.History@@ -94,6 +92,16 @@ System.Console.Haskeline.Command.Undo System.Console.Haskeline.Vi include-dirs: includes+ c-sources: cbits/h_wcwidth.c++ -- We require ghc>=7.4.1 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+ if !flag(legacy-encoding) && impl(ghc>=7.4) {+ cpp-options: -DUSE_GHC_ENCODINGS+ } else {+ Build-depends: utf8-string==0.3.* && >=0.3.6+ } if os(windows) { Build-depends: Win32>=2.0 Other-modules: System.Console.Haskeline.Backend.Win32@@ -102,16 +110,20 @@ install-includes: win_console.h cpp-options: -DMINGW } else {- Build-depends: unix>=2.0 && < 2.6+ Build-depends: unix>=2.0 && < 2.7 -- unix-2.3 doesn't build on ghc-6.8.1 or earlier- c-sources: cbits/h_iconv.c- cbits/h_wcwidth.c- includes: h_iconv.h- install-includes: h_iconv.h+ -- Use manual encoding/decoding on ghc<7.4+ if flag (legacy-encoding) || impl(ghc<7.4) {+ c-sources: cbits/h_iconv.c+ includes: h_iconv.h+ install-includes: h_iconv.h+ Other-modules: System.Console.Haskeline.Backend.Posix.IConv+ } else {+ Other-modules: System.Console.Haskeline.Backend.Posix.Recover+ } Other-modules: - System.Console.Haskeline.Backend.WCWidth System.Console.Haskeline.Backend.Posix- System.Console.Haskeline.Backend.IConv+ System.Console.Haskeline.Backend.Posix.Encoder System.Console.Haskeline.Backend.DumbTerm if flag(terminfo) { Build-depends: terminfo>=0.3.1.3 && <0.4
includes/win_console.h view
@@ -3,5 +3,7 @@ #include <windows.h> BOOL haskeline_SetPosition(HANDLE h, COORD* c);+BOOL haskeline_FillConsoleCharacter(HANDLE h, TCHAR c, DWORD l, COORD *p, LPDWORD n);+BOOL haskeline_FillConsoleAttribute(HANDLE h, WORD c, DWORD l, COORD *p, LPDWORD n); #endif