diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 + diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs --- a/System/Console/Haskeline.hs +++ b/System/Console/Haskeline.hs @@ -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 diff --git a/System/Console/Haskeline/Backend/DumbTerm.hs b/System/Console/Haskeline/Backend/DumbTerm.hs --- a/System/Console/Haskeline/Backend/DumbTerm.hs +++ b/System/Console/Haskeline/Backend/DumbTerm.hs @@ -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 diff --git a/System/Console/Haskeline/Backend/IConv.hsc b/System/Console/Haskeline/Backend/IConv.hsc deleted file mode 100644 --- a/System/Console/Haskeline/Backend/IConv.hsc +++ /dev/null @@ -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 -#include -#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) - diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc --- a/System/Console/Haskeline/Backend/Posix.hsc +++ b/System/Console/Haskeline/Backend/Posix.hsc @@ -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 diff --git a/System/Console/Haskeline/Backend/Posix/Encoder.hs b/System/Console/Haskeline/Backend/Posix/Encoder.hs new file mode 100644 --- /dev/null +++ b/System/Console/Haskeline/Backend/Posix/Encoder.hs @@ -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 + + diff --git a/System/Console/Haskeline/Backend/Posix/IConv.hsc b/System/Console/Haskeline/Backend/Posix/IConv.hsc new file mode 100644 --- /dev/null +++ b/System/Console/Haskeline/Backend/Posix/IConv.hsc @@ -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 +#include +#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 diff --git a/System/Console/Haskeline/Backend/Posix/Recover.hs b/System/Console/Haskeline/Backend/Posix/Recover.hs new file mode 100644 --- /dev/null +++ b/System/Console/Haskeline/Backend/Posix/Recover.hs @@ -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 } diff --git a/System/Console/Haskeline/Backend/Terminfo.hs b/System/Console/Haskeline/Backend/Terminfo.hs --- a/System/Console/Haskeline/Backend/Terminfo.hs +++ b/System/Console/Haskeline/Backend/Terminfo.hs @@ -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 diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc --- a/System/Console/Haskeline/Backend/Win32.hsc +++ b/System/Console/Haskeline/Backend/Win32.hsc @@ -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 + diff --git a/System/Console/Haskeline/Command.hs b/System/Console/Haskeline/Command.hs --- a/System/Console/Haskeline/Command.hs +++ b/System/Console/Haskeline/Command.hs @@ -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 diff --git a/System/Console/Haskeline/Command/Completion.hs b/System/Console/Haskeline/Command/Completion.hs --- a/System/Console/Haskeline/Command/Completion.hs +++ b/System/Console/Haskeline/Command/Completion.hs @@ -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 diff --git a/System/Console/Haskeline/Command/History.hs b/System/Console/Haskeline/Command/History.hs --- a/System/Console/Haskeline/Command/History.hs +++ b/System/Console/Haskeline/Command/History.hs @@ -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) diff --git a/System/Console/Haskeline/Command/KillRing.hs b/System/Console/Haskeline/Command/KillRing.hs --- a/System/Console/Haskeline/Command/KillRing.hs +++ b/System/Console/Haskeline/Command/KillRing.hs @@ -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) diff --git a/System/Console/Haskeline/Directory.hsc b/System/Console/Haskeline/Directory.hsc --- a/System/Console/Haskeline/Directory.hsc +++ b/System/Console/Haskeline/Directory.hsc @@ -21,13 +21,21 @@ #include #include -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 diff --git a/System/Console/Haskeline/Emacs.hs b/System/Console/Haskeline/Emacs.hs --- a/System/Console/Haskeline/Emacs.hs +++ b/System/Console/Haskeline/Emacs.hs @@ -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 [ diff --git a/System/Console/Haskeline/Encoding.hs b/System/Console/Haskeline/Encoding.hs deleted file mode 100644 --- a/System/Console/Haskeline/Encoding.hs +++ /dev/null @@ -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 diff --git a/System/Console/Haskeline/History.hs b/System/Console/Haskeline/History.hs --- a/System/Console/Haskeline/History.hs +++ b/System/Console/Haskeline/History.hs @@ -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 diff --git a/System/Console/Haskeline/IO.hs b/System/Console/Haskeline/IO.hs --- a/System/Console/Haskeline/IO.hs +++ b/System/Console/Haskeline/IO.hs @@ -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 diff --git a/System/Console/Haskeline/InputT.hs b/System/Console/Haskeline/InputT.hs --- a/System/Console/Haskeline/InputT.hs +++ b/System/Console/Haskeline/InputT.hs @@ -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 diff --git a/System/Console/Haskeline/MonadException.hs b/System/Console/Haskeline/MonadException.hs --- a/System/Console/Haskeline/MonadException.hs +++ b/System/Console/Haskeline/MonadException.hs @@ -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' + + diff --git a/System/Console/Haskeline/Monads.hs b/System/Console/Haskeline/Monads.hs --- a/System/Console/Haskeline/Monads.hs +++ b/System/Console/Haskeline/Monads.hs @@ -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) diff --git a/System/Console/Haskeline/RunCommand.hs b/System/Console/Haskeline/RunCommand.hs --- a/System/Console/Haskeline/RunCommand.hs +++ b/System/Console/Haskeline/RunCommand.hs @@ -9,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 --------------- diff --git a/System/Console/Haskeline/Term.hs b/System/Console/Haskeline/Term.hs --- a/System/Console/Haskeline/Term.hs +++ b/System/Console/Haskeline/Term.hs @@ -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 + diff --git a/System/Console/Haskeline/Vi.hs b/System/Console/Haskeline/Vi.hs --- a/System/Console/Haskeline/Vi.hs +++ b/System/Console/Haskeline/Vi.hs @@ -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) diff --git a/cbits/win_console.c b/cbits/win_console.c --- a/cbits/win_console.c +++ b/cbits/win_console.c @@ -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); +} diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -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 () diff --git a/haskeline.cabal b/haskeline.cabal --- a/haskeline.cabal +++ b/haskeline.cabal @@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.6 -Version: 0.6.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 diff --git a/includes/win_console.h b/includes/win_console.h --- a/includes/win_console.h +++ b/includes/win_console.h @@ -3,5 +3,7 @@ #include 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