haskeline 0.7.2.3 → 0.7.3.0
raw patch · 17 files changed
+153/−646 lines, 17 filesdep −utf8-stringdep ~basedep ~directorysetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies removed: utf8-string
Dependency ranges changed: base, directory
API changes (from Hackage documentation)
+ System.Console.Haskeline: getExternalPrint :: MonadException m => InputT m (String -> IO ())
Files
- Changelog +6/−0
- Setup.hs +1/−97
- System/Console/Haskeline.hs +24/−13
- System/Console/Haskeline/Backend/DumbTerm.hs +3/−6
- System/Console/Haskeline/Backend/Posix.hsc +42/−38
- System/Console/Haskeline/Backend/Posix/Encoder.hs +3/−146
- System/Console/Haskeline/Backend/Posix/IConv.hsc +0/−177
- System/Console/Haskeline/Backend/Terminfo.hs +3/−8
- System/Console/Haskeline/Backend/Win32.hsc +14/−12
- System/Console/Haskeline/Directory.hsc +0/−50
- System/Console/Haskeline/History.hs +0/−18
- System/Console/Haskeline/InputT.hs +4/−0
- System/Console/Haskeline/RunCommand.hs +8/−0
- System/Console/Haskeline/Term.hs +34/−18
- cbits/h_iconv.c +0/−18
- haskeline.cabal +11/−36
- includes/h_iconv.h +0/−9
Changelog view
@@ -1,3 +1,9 @@+Changed in version 0.7.3.0:+ * Require ghc version of at least 7.4.1, and clean up obsolete code+ * Add thread-safe (in terminal-style interaction) external print function+ * Add a MonadFix instance for InputT+ * Bump upper bounds on `base` and `directory` to support ghc-8.0.2+ Changed in version 0.7.2.3: * Fix hsc2hs-related warning on ghc-8 * Fix the behavior of ctrl-W in the emacs bindings
Setup.hs view
@@ -1,20 +1,8 @@-{-# LANGUAGE CPP #-} import Distribution.System-import Distribution.Verbosity import Distribution.PackageDescription import Distribution.Simple-import Distribution.Simple.Program import Distribution.Simple.Setup-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Utils -import Distribution.Simple.PackageIndex-import qualified Distribution.InstalledPackageInfo as Installed--import System.IO-import System.Exit-import System.Directory-import Control.Exception import Control.Monad(when) main :: IO ()@@ -26,14 +14,7 @@ | otherwise = simpleUserHooks { confHook = \genericDescript flags -> do warnIfNotTerminfo flags- lbi <- confHook simpleUserHooks genericDescript flags- let pkgDescr = localPkgDescr lbi- let Just lib = library pkgDescr- let bi = libBuildInfo lib- bi' <- maybeSetLibiconv flags bi lbi- return lbi {localPkgDescr = pkgDescr {- library = Just lib {- libBuildInfo = bi'}}}+ confHook simpleUserHooks genericDescript flags } warnIfNotTerminfo flags = when (not (hasFlagSet flags (FlagName "terminfo")))@@ -47,80 +28,3 @@ 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)- if hasFlagSet flags (FlagName "libiconv")- then do- putStrLn "Using -liconv."- return biWithIconv- else do- putStr "checking whether to use -liconv... "- hFlush stdout- worksWithout <- tryCompile iconv_prog bi lbi verb- if worksWithout- then do- putStrLn "not needed."- return bi- else do- worksWith <- tryCompile iconv_prog biWithIconv lbi verb- if worksWith- then do- putStrLn "using -liconv."- return biWithIconv- else error "Unable to link against the iconv library."--tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool-tryCompile program bi lbi verb = handle processExit $ handle processException $ do- tempDir <- getTemporaryDirectory- withTempFile tempDir ".c" $ \fname cH ->- withTempFile tempDir "" $ \execName oH -> do- hPutStr cH program- hClose cH- hClose oH- -- TODO take verbosity from the args.- rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi)- (fname : "-o" : execName : args)- return True- where- processException :: IOException -> IO Bool- processException e = return False- processExit = return . (==ExitSuccess)- -- Mimicing Distribution.Simple.Configure- deps = topologicalOrder (installedPkgs lbi)- args = concat- [ ccOptions bi- , cppOptions bi- , ldOptions bi- -- --extra-include-dirs and --extra-lib-dirs are included- -- in the below fields.- -- Also sometimes a dependency like rts points to a nonstandard- -- include/lib directory where iconv can be found. - , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps)- , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps)- , map ("-l" ++) (extraLibs bi)- ]--addIconv :: BuildInfo -> BuildInfo-addIconv bi = bi {extraLibs = "iconv" : extraLibs bi}--iconv_prog :: String-iconv_prog = unlines $- [ "#include <iconv.h>"- , "int main(void) {"- , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");"- , " return 0;"- , "}"- ]-#endif-
System/Console/Haskeline.hs view
@@ -1,7 +1,7 @@-{- | +{- | A rich user interface for line input in command-line programs. Haskeline is-Unicode-aware and runs both on POSIX-compatible systems and on Windows. +Unicode-aware and runs both on POSIX-compatible systems and on Windows. Users may customize the interface with a @~/.haskeline@ file; see <http://trac.haskell.org/haskeline/wiki/UserPrefs> for more information.@@ -10,10 +10,10 @@ following: > import System.Console.Haskeline-> +> > main :: IO () > main = runInputT defaultSettings loop-> where +> where > loop :: InputT IO () > loop = do > minput <- getInputLine "% "@@ -51,6 +51,7 @@ -- $outputfncs outputStr, outputStrLn,+ getExternalPrint, -- * Customization -- ** Settings Settings(..),@@ -183,7 +184,7 @@ settings :: Settings m <- InputT ask histDupes <- InputT $ asks historyDuplicates case result of- Just line | autoAddHistory settings && not (all isSpace line) + Just line | autoAddHistory settings && not (all isSpace line) -> let adder = case histDupes of AlwaysAdd -> addHistory IgnoreConsecutive -> addHistoryUnlessConsecutiveDupe@@ -214,9 +215,9 @@ case fmap isPrint c of Just False -> getPrintableChar fops _ -> return c- + getInputCmdChar :: MonadException m => TermOps -> String -> InputT m (Maybe Char)-getInputCmdChar tops prefix = runInputCmdT tops +getInputCmdChar tops prefix = runInputCmdT tops $ runCommandLoop tops prefix acceptOneChar emptyIM acceptOneChar :: Monad m => KeyCommand m InsertMode (Maybe Char)@@ -235,7 +236,7 @@ When using file-style interaction, this function turns off echoing while reading the line of input. -}- + getPassword :: MonadException m => Maybe Char -- ^ A masking character; e.g., @Just \'*\'@ -> String -> InputT m (Maybe String) getPassword x = promptedInput@@ -256,7 +257,7 @@ , ctrlChar 'l' +> clearScreenCmd >|> loop' ] loop' = keyCommand loop- + {- $history The 'InputT' monad transformer provides direct, low-level access to the user's line history state. @@ -293,16 +294,16 @@ > tryAction :: InputT IO () > tryAction = handle (\Interrupt -> outputStrLn "Cancelled.")-> $ wrapInterrupt $ someLongAction+> $ withInterrupt $ someLongAction 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+> tryAction = withInterrupt 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.@@ -313,8 +314,18 @@ rterm <- InputT ask liftIOOp_ (wrapInterrupt rterm) act --- | Catch and handle an exception of type 'Interrupt'. +-- | 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++{- | Return a printing function, which in terminal-style interactions is+thread-safe and may be run concurrently with user input without affecting the+prompt. -}+getExternalPrint :: MonadException m => InputT m (String -> IO ())+getExternalPrint = do+ rterm <- InputT ask+ return $ case termOps rterm of+ Right _ -> putStrOut rterm+ Left tops -> externalPrint tops
System/Console/Haskeline/Backend/DumbTerm.hs view
@@ -1,7 +1,6 @@ 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@@ -23,13 +22,12 @@ newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a} deriving (Functor, Applicative, Monad, MonadIO, MonadException,- MonadState Window,- MonadReader Handles, MonadReader Encoder)+ MonadState Window, MonadReader Handles) type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a instance MonadTrans DumbTerm where- lift = DumbTerm . lift . lift . lift+ lift = DumbTerm . lift . lift evalDumb :: (MonadReader Layout m, CommandMonad m) => EvalTerm (PosixT m) evalDumb = EvalTerm (evalStateT' initWindow . unDumbTerm) (DumbTerm . lift)@@ -50,8 +48,7 @@ printText :: MonadIO m => String -> DumbTerm m () printText str = do h <- liftM ehOut ask- encode <- ask- liftIO $ putEncodedStr encode h str+ liftIO $ hPutStr h str liftIO $ hFlush h -- Things we can assume a dumb terminal knows how to do
System/Console/Haskeline/Backend/Posix.hsc view
@@ -6,8 +6,6 @@ Handles(), ehIn, ehOut,- Encoder,- Decoder, mapLines, stdinTTYHandles, ttyHandles,@@ -35,7 +33,6 @@ import System.Console.Haskeline.Backend.Posix.Encoder -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO.FD (fdFD) import Data.Dynamic (cast) import System.IO.Error@@ -43,10 +40,6 @@ import GHC.IO.Handle.Types hiding (getState) import GHC.IO.Handle.Internals import System.Posix.Internals (FD)-#else-import GHC.IOBase(haFD,FD)-import GHC.Handle (withHandle_)-#endif #if defined(USE_TERMIOS_H) || defined(__ANDROID__) #include <termios.h>@@ -81,7 +74,6 @@ else return Nothing unsafeHandleToFD :: Handle -> IO FD-#if __GLASGOW_HASKELL__ >= 611 unsafeHandleToFD h = withHandle_ "unsafeHandleToFd" h $ \Handle__{haDevice=dev} -> do case cast dev of@@ -89,9 +81,6 @@ "unsafeHandleToFd" (Just h) Nothing) "handle is not a file descriptor") Just fd -> return (fdFD fd)-#else-unsafeHandleToFD h = withHandle_ "unsafeHandleToFd" h (return . haFD)-#endif envLayout :: IO (Maybe Layout) envLayout = handle (\(_::IOException) -> return Nothing) $ do@@ -160,7 +149,7 @@ 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)]- + newtype TreeMap a b = TreeMap (Map.Map a (Maybe b, TreeMap a b)) deriving Show @@ -211,22 +200,22 @@ ----------------------------- -withPosixGetEvent :: (MonadException m, MonadReader Prefs m) - => Chan Event -> Handles -> Decoder -> [(String,Key)]+withPosixGetEvent :: (MonadException m, MonadReader Prefs m)+ => Chan Event -> Handles -> [(String,Key)] -> (m Event -> m a) -> m a-withPosixGetEvent eventChan h enc termKeys f = wrapTerminalOps h $ do+withPosixGetEvent eventChan h termKeys f = wrapTerminalOps h $ do baseMap <- getKeySequences (ehIn h) termKeys withWindowHandler eventChan- $ f $ liftIO $ getEvent (ehIn h) enc baseMap eventChan+ $ f $ liftIO $ getEvent (ehIn h) baseMap eventChan withWindowHandler :: MonadException m => Chan Event -> m a -> m a-withWindowHandler eventChan = withHandler windowChange $ +withWindowHandler eventChan = withHandler windowChange $ Catch $ writeChan eventChan WindowResize withSigIntHandler :: MonadException m => m a -> m a withSigIntHandler f = do- tid <- liftIO myThreadId - withHandler keyboardSignal + tid <- liftIO myThreadId+ withHandler keyboardSignal (Catch (throwTo tid Interrupt)) f @@ -235,11 +224,27 @@ old_handler <- liftIO $ installHandler signal handler Nothing f `finally` liftIO (installHandler signal old_handler Nothing) -getEvent :: Handle -> Decoder -> TreeMap Char Key -> Chan Event -> IO Event-getEvent h dec baseMap = keyEventLoop $ do- cs <- getBlockOfChars h dec+getEvent :: Handle -> TreeMap Char Key -> Chan Event -> IO Event+getEvent h baseMap = keyEventLoop $ do+ cs <- getBlockOfChars h return [KeyInput $ lexKeys baseMap cs] +-- 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 -> IO String+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) stdinTTYHandles, ttyHandles :: MaybeT IO Handles stdinTTYHandles = do@@ -269,7 +274,7 @@ $ liftIO $ openInCodingMode "/dev/tty" mode -posixRunTerm :: +posixRunTerm :: Handles -> [IO (Maybe Layout)] -> [(String,Key)]@@ -279,26 +284,26 @@ posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do ch <- newChan fileRT <- posixFileRunTerm hs- (enc,dec) <- newEncoders return fileRT- { closeTerm = closeTerm fileRT- , termOps = Left TermOps+ { termOps = Left TermOps { getLayout = tryGetLayouts layoutGetters- , withGetEvent = wrapGetEvent - . withPosixGetEvent ch hs dec+ , withGetEvent = wrapGetEvent+ . withPosixGetEvent ch hs keys , saveUnusedKeys = saveKeys ch , evalTerm = mapEvalTerm- (runPosixT enc hs)- (lift . lift)- evalBackend+ (runPosixT hs) lift evalBackend+ , externalPrint = writeChan ch . ExternalPrint }+ , closeTerm = do+ flushEventQueue (putStrOut fileRT) ch+ closeTerm fileRT } -type PosixT m = ReaderT Encoder (ReaderT Handles m)+type PosixT m = ReaderT Handles m -runPosixT :: Monad m => Encoder -> Handles -> PosixT m a -> m a-runPosixT enc h = runReaderT' h . runReaderT' enc+runPosixT :: Monad m => Handles -> PosixT m a -> m a+runPosixT h = runReaderT' h fileRunTerm :: Handle -> IO RunTerm fileRunTerm h_in = posixFileRunTerm Handles@@ -309,19 +314,18 @@ posixFileRunTerm :: Handles -> IO RunTerm posixFileRunTerm hs = do- (enc,dec) <- newEncoders return RunTerm { putStrOut = \str -> withCodingMode (hOut hs) $ do- putEncodedStr enc (ehOut hs) str+ hPutStr (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+ , getLocaleChar = guardedEOF hGetChar (ehIn hs) , maybeReadNewline = hMaybeReadNewline (ehIn hs)- , getLocaleLine = getDecodedLine (ehIn hs) dec+ , getLocaleLine = guardedEOF hGetLine (ehIn hs) } }
System/Console/Haskeline/Backend/Posix/Encoder.hs view
@@ -7,63 +7,19 @@ 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+ ) 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.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.@@ -71,10 +27,8 @@ -- 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)+-- The correct mode is the locale encoding, set to transliterate errors (rather+-- than crashing, as is the base library's default). See Recover.hs. data ExternalHandle = ExternalHandle { externalMode :: ExternalMode , eH :: Handle@@ -89,7 +43,6 @@ -- 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)@@ -100,112 +53,16 @@ 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
− System/Console/Haskeline/Backend/Posix/IConv.hsc
@@ -1,177 +0,0 @@-{- | This module exports iconv-based encoding/decoding, for use on-older versions of GHC. --}-module System.Console.Haskeline.Backend.Posix.IConv(- setLocale,- getCodeset,- openEncoder,- openDecoder,- openPartialDecoder,- PartialDecoder,- decodeAndMore,- ) where--import Foreign.C-import Foreign-import Data.ByteString (ByteString, useAsCStringLen, append )--- TODO: Base or Internal, depending on whether base>=3.-import Data.ByteString.Internal (createAndTrim')-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as UTF8-import Data.Maybe (fromMaybe)-import System.IO (Handle)--#include <locale.h>-#include <langinfo.h>-#include "h_iconv.h"--openEncoder :: String -> IO (String -> IO ByteString)-openEncoder codeset = do- encodeT <- iconvOpen codeset "UTF-8"- return $ simpleIConv dropUTF8Char encodeT . UTF8.fromString--openDecoder :: String -> IO (ByteString -> IO String)-openDecoder codeset = do- decodeT <- iconvOpen "UTF-8" codeset- return $ fmap UTF8.toString . simpleIConv (B.drop 1) decodeT--dropUTF8Char :: ByteString -> ByteString-dropUTF8Char = fromMaybe B.empty . fmap snd . UTF8.uncons--replacement :: Word8-replacement = toEnum (fromEnum '?')---- handle errors by dropping unuseable chars.-simpleIConv :: (ByteString -> ByteString) -> IConvT -> ByteString -> IO ByteString-simpleIConv dropper t bs = do- (cs,result) <- iconv t bs- case result of- Invalid rest -> continueOnError cs rest- Incomplete rest -> continueOnError cs rest- _ -> return cs- where- continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`))- $ simpleIConv dropper t (dropper rest)--type PartialDecoder = ByteString -> IO (String,Result)--openPartialDecoder :: String -> IO PartialDecoder-openPartialDecoder codeset = do- decodeT <- iconvOpen "UTF-8" codeset- return $ \bs -> do- (s,result) <- iconv decodeT bs- return (UTF8.toString s,result)-------------------------- Setting the locale--foreign import ccall "setlocale" c_setlocale :: CInt -> CString -> IO CString--setLocale :: Maybe String -> IO (Maybe String)-setLocale oldLocale = (maybeWith withCAString) oldLocale $ \loc_p -> do- c_setlocale (#const LC_CTYPE) loc_p >>= maybePeek peekCAString---------------------- Getting the encoding--type NLItem = #type nl_item--foreign import ccall nl_langinfo :: NLItem -> IO CString--getCodeset :: IO String-getCodeset = do- str <- nl_langinfo (#const CODESET) >>= peekCAString- -- check for codesets which may be returned by Solaris, but not understood- -- by GNU iconv.- if str `elem` ["","646"]- then return "ISO-8859-1"- else return str--------------------- Iconv---- TODO: This may not work on platforms where iconv_t is not a pointer.-type IConvT = ForeignPtr ()-type IConvTPtr = Ptr ()--foreign import ccall "haskeline_iconv_open" iconv_open- :: CString -> CString -> IO IConvTPtr--iconvOpen :: String -> String -> IO IConvT-iconvOpen destName srcName = withCAString destName $ \dest ->- withCAString srcName $ \src -> do- res <- iconv_open dest src- if res == nullPtr `plusPtr` (-1)- then throwErrno $ "iconvOpen "- ++ show (srcName,destName)- -- list the two it couldn't convert between?- else newForeignPtr iconv_close res---- really this returns a CInt, but it's easiest to just ignore that, I think.-foreign import ccall "& haskeline_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ())--foreign import ccall "haskeline_iconv" c_iconv :: IConvTPtr -> Ptr CString -> Ptr CSize- -> Ptr CString -> Ptr CSize -> IO CSize--data Result = Successful- | Invalid ByteString- | Incomplete ByteString- deriving Show--iconv :: IConvT -> ByteString -> IO (ByteString,Result)-iconv cd inStr = useAsCStringLen inStr $ \(inPtr, inBuffLen) ->- with inPtr $ \inBuff ->- with (toEnum inBuffLen) $ \inBytesLeft -> do- out <- loop inBuffLen (castPtr inBuff) inBytesLeft- return out- where- -- TODO: maybe a better algorithm for increasing the buffer size?- -- and also maybe a different starting buffer size?- biggerBuffer = (+1)- loop outSize inBuff inBytesLeft = do- (bs, errno) <- partialIconv cd outSize inBuff inBytesLeft- inLeft <- fmap fromEnum $ peek inBytesLeft- let rest = B.drop (B.length inStr - inLeft) inStr- case errno of- Nothing -> return (bs,Successful)- Just err - | err == e2BIG -> do -- output buffer too small- (bs',result) <- loop (biggerBuffer outSize) inBuff inBytesLeft- -- TODO: is this efficient enough?- return (bs `append` bs', result)- | err == eINVAL -> return (bs,Incomplete rest)- | otherwise -> return (bs, Invalid rest)--partialIconv :: IConvT -> Int -> Ptr CString -> Ptr CSize -> IO (ByteString, Maybe Errno)-partialIconv cd outSize inBuff inBytesLeft =- withForeignPtr cd $ \cd_p ->- createAndTrim' outSize $ \outPtr ->- with outPtr $ \outBuff ->- with (toEnum outSize) $ \outBytesLeft -> do- -- ignore the return value; checking the errno is more reliable.- _ <- c_iconv cd_p inBuff inBytesLeft (castPtr outBuff) outBytesLeft- outLeft <- fmap fromEnum $ peek outBytesLeft- inLeft <- peek inBytesLeft- errno <- if inLeft > 0- then fmap Just getErrno- else return Nothing- return (0,outSize - outLeft,errno)------------------ Decode the given ByteString. If necessary, finish decoding it--- by reading more bytes one at a time from the given handle.--- (This assumes that the handle is in BinaryMode.)-decodeAndMore:: PartialDecoder- -> Handle -> B.ByteString -> IO String-decodeAndMore decoder h bs = do- (cs,result) <- decoder bs- case result of- Incomplete rest -> do- extra <- B.hGetNonBlocking h 1- if B.null extra- then return (cs ++ "?")- else fmap (cs++)- $ decodeAndMore decoder h (rest `B.append` extra)- Invalid rest -> fmap ((cs ++) . ('?':))- $ decodeAndMore decoder h (B.drop 1 rest)- Successful -> return cs
System/Console/Haskeline/Backend/Terminfo.hs view
@@ -17,7 +17,6 @@ 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 @@ -106,11 +105,10 @@ (PosixT m))))) a} deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadReader Actions, MonadReader Terminal, MonadState TermPos,- MonadState TermRows,- MonadReader Handles, MonadReader Encoder)+ MonadState TermRows, MonadReader Handles) instance MonadTrans Draw where- lift = Draw . lift . lift . lift . lift . lift . lift+ lift = Draw . lift . lift . lift . lift . lift evalDraw :: forall m . (MonadReader Layout m, CommandMonad m) => Terminal -> Actions -> EvalTerm (PosixT m) evalDraw term actions = EvalTerm eval liftE@@ -200,10 +198,7 @@ -- see GHC ticket #1749). outputText :: String -> ActionM ()-outputText str = do- encode <- lift ask- liftIO (getTermText encode str)- >>= output . const+outputText = output . const . termText left,right,up :: Int -> TermAction left = flip leftA
System/Console/Haskeline/Backend/Win32.hsc view
@@ -380,17 +380,20 @@ hs <- consoleHandles ch <- liftIO newChan fileRT <- liftIO $ fileRunTerm stdin- return fileRT {- termOps = Left TermOps {- getLayout = getBufferSize (hOut hs)- , withGetEvent = withWindowMode hs- . win32WithEvent hs ch- , saveUnusedKeys = saveKeys ch- , evalTerm = EvalTerm (runReaderT' hs . runDraw)- (Draw . lift)- },- closeTerm = closeHandles hs- }+ return fileRT+ { termOps = Left TermOps {+ getLayout = getBufferSize (hOut hs)+ , withGetEvent = withWindowMode hs+ . win32WithEvent hs ch+ , saveUnusedKeys = saveKeys ch+ , evalTerm = EvalTerm (runReaderT' hs . runDraw)+ (Draw . lift)+ , externalPrint = writeChan ch . ExternalPrint+ }+ , closeTerm = do+ flushEventQueue (putStrOut fileRT) ch+ closeHandles hs+ } win32WithEvent :: MonadException m => Handles -> Chan Event -> (m Event -> m a) -> m a@@ -545,4 +548,3 @@ liftIO $ fillConsoleChar h ' ' windowSize origin liftIO $ fillConsoleAttribute h attr windowSize origin setPos origin-
System/Console/Haskeline/Directory.hsc view
@@ -14,9 +14,7 @@ import Foreign import Foreign.C import System.Win32.Types-#if __GLASGOW_HASKELL__ >= 611 import qualified System.Directory-#endif #include <windows.h> #include <shlobj.h>@@ -62,59 +60,11 @@ return $ attrs /= (#const INVALID_FILE_ATTRIBUTES) && (attrs .&. (#const FILE_ATTRIBUTE_DIRECTORY)) /= 0 -#if __GLASGOW_HASKELL__ >= 611 getHomeDirectory :: IO FilePath getHomeDirectory = System.Directory.getHomeDirectory-#else-type HRESULT = #type HRESULT -foreign import WINDOWS_CCONV "SHGetFolderPathW" c_SHGetFolderPath- :: Ptr () -> CInt -> HANDLE -> DWORD -> LPTSTR -> IO HRESULT--getHomeDirectory :: IO FilePath-getHomeDirectory = allocaBytes ((#const MAX_PATH) * (#size TCHAR)) $ \pathPtr -> do- result <- c_SHGetFolderPath nullPtr (#const CSIDL_PROFILE) nullPtr 0 pathPtr-- if result /= (#const S_OK)- then return ""- else peekCWString pathPtr-#endif- #else --- POSIX--- On 7.2.1 and later, getDirectoryContents uses the locale encoding--- But previous version don't, so we need to decode manually. -#if __GLASGOW_HASKELL__ >= 701 import System.Directory-#else -import Data.ByteString.Char8 (pack, unpack)-import qualified System.Directory as D-import Control.Exception-import System.Console.Haskeline.Backend.Posix.IConv--getDirectoryContents :: FilePath -> IO [FilePath]-getDirectoryContents path = do- codeset <- getCodeset- encoder <- openEncoder codeset- decoder <- openDecoder codeset- dirEnc <- fmap unpack (encoder path)- filesEnc <- handle (\(_::IOException) -> return [])- $ D.getDirectoryContents dirEnc- mapM (decoder . pack) filesEnc--doesDirectoryExist :: FilePath -> IO Bool-doesDirectoryExist file = do- codeset <- getCodeset- encoder <- openEncoder codeset- encoder file >>= D.doesDirectoryExist . unpack--getHomeDirectory :: IO FilePath-getHomeDirectory = do- codeset <- getCodeset- decoder <- openDecoder codeset- handle (\(_::IOException) -> return "")- $ D.getHomeDirectory >>= decoder . pack-#endif #endif
System/Console/Haskeline/History.hs view
@@ -32,13 +32,8 @@ import System.Directory(doesFileExist) -#ifdef USE_GHC_ENCODINGS import qualified System.IO as IO import System.Console.Haskeline.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}@@ -117,7 +112,6 @@ -- 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@@ -126,15 +120,8 @@ _ <- 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@@ -142,8 +129,3 @@ IO.hSetNewlineMode h IO.noNewlineTranslation IO.hPutStr h contents IO.hClose h-#else--- use binary file I/O to avoid Windows CRLF line endings--- which cause confusion when switching between systems.-writeUTF8File file = B.writeFile file . UTF8.fromString-#endif
System/Console/Haskeline/InputT.hs view
@@ -15,6 +15,7 @@ import System.FilePath import Control.Applicative import Control.Monad (liftM, ap)+import Control.Monad.Fix import System.IO import Data.IORef @@ -55,6 +56,9 @@ instance MonadTrans InputT where lift = InputT . lift . lift . lift . lift . lift++instance ( MonadFix m ) => MonadFix (InputT m) where+ mfix f = InputT (mfix (unInputT . f)) -- | Get the current line input history. getHistory :: MonadIO m => InputT m History
System/Console/Haskeline/RunCommand.hs view
@@ -40,6 +40,9 @@ KeyInput ks -> do bound_ks <- mapM (asks . lookupKeyBinding) ks loopCmd s $ applyKeysToMap (concat bound_ks) next+ ExternalPrint str -> do+ printPreservingLineChars s str+ readMoreKeys s next loopCmd :: LineChars -> CmdM m (a,[Key]) -> n a loopCmd s (GetKey next) = readMoreKeys s next@@ -57,6 +60,11 @@ moveToNextLine s return x +printPreservingLineChars :: Term m => LineChars -> String -> m ()+printPreservingLineChars s str = do+ clearLine s+ printLines . lines $ str+ drawLine s drawReposition :: (Term n, MonadState Layout m) => (forall a . m a -> n a) -> TermOps -> LineChars -> n ()
System/Console/Haskeline/Term.hs view
@@ -28,25 +28,42 @@ drawLine = drawLineDiff ([],[]) clearLine = flip drawLineDiff ([],[])- + data RunTerm = RunTerm { -- | Write unicode characters to stdout. putStrOut :: String -> IO (), termOps :: Either TermOps FileOps,- wrapInterrupt :: forall a . IO a -> IO a, + wrapInterrupt :: forall a . IO a -> IO a, closeTerm :: IO () } -- | Operations needed for terminal-style interaction.-data TermOps = TermOps {- getLayout :: IO Layout- , withGetEvent :: forall m a . CommandMonad m => (m Event -> m a) -> m a- , evalTerm :: forall m . CommandMonad m => EvalTerm m- , saveUnusedKeys :: [Key] -> IO ()- }+data TermOps = TermOps+ { getLayout :: IO Layout+ , withGetEvent :: forall m a . CommandMonad m => (m Event -> m a) -> m a+ , evalTerm :: forall m . CommandMonad m => EvalTerm m+ , saveUnusedKeys :: [Key] -> IO ()+ , externalPrint :: String -> IO ()+ } +-- This hack is needed to grab latest writes from some other thread.+-- Without it, if you are using another thread to process the logging+-- and write on screen via exposed externalPrint, latest writes from+-- this thread are not able to cross the thread boundary in time.+flushEventQueue :: (String -> IO ()) -> Chan Event -> IO ()+flushEventQueue print' eventChan = yield >> loopUntilFlushed+ where loopUntilFlushed = do+ flushed <- isEmptyChan eventChan+ if flushed then return () else do+ event <- readChan eventChan+ case event of+ ExternalPrint str -> do+ print' (str ++ "\n") >> loopUntilFlushed+ -- We don't want to raise exceptions when doing cleanup.+ _ -> loopUntilFlushed+ -- | Operations needed for file-style interaction.--- +-- -- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline -- are "wrapped" by wrapFileInput. data FileOps = FileOps {@@ -96,8 +113,12 @@ matchInit (x:xs) (y:ys) | x == y = matchInit xs ys matchInit xs ys = (xs,ys) -data Event = WindowResize | KeyInput [Key] | ErrorEvent SomeException- deriving Show+data Event+ = WindowResize+ | KeyInput [Key]+ | ErrorEvent SomeException+ | ExternalPrint String+ deriving Show keyEventLoop :: IO [Event] -> Chan Event -> IO Event keyEventLoop readEvents eventChan = do@@ -121,7 +142,7 @@ else -- Use the lock to work around the fact that writeList2Chan -- isn't atomic. Otherwise, some events could be ignored if -- the subthread is killed before it saves them in the chan.- bracket_ (putMVar lock ()) (takeMVar lock) $ + bracket_ (putMVar lock ()) (takeMVar lock) $ writeList2Chan eventChan es handleErrorEvent = handle $ \e -> case fromException e of Just ThreadKilled -> return ()@@ -138,13 +159,9 @@ -- | Utility function since we're not using the new IO library yet. hWithBinaryMode :: MonadException m => Handle -> m a -> m a-#if __GLASGOW_HASKELL__ >= 611 hWithBinaryMode h = bracket (liftIO $ hGetEncoding h) (maybe (return ()) (liftIO . hSetEncoding h)) . const . (liftIO (hSetBinaryMode h True) >>)-#else-hWithBinaryMode _ = id-#endif -- | Utility function for changing a property of a terminal for the duration of -- a computation.@@ -170,7 +187,7 @@ -- 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.@@ -195,4 +212,3 @@ liftIO $ if buff == NoBuffering then fmap BC.pack $ System.IO.hGetLine h else BC.hGetLine h-
− cbits/h_iconv.c
@@ -1,18 +0,0 @@-#include "h_iconv.h"--// Wrapper functions, since iconv_open et al are macros in libiconv.-iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode) {- return iconv_open(tocode, fromcode);-}--void haskeline_iconv_close(iconv_t cd) {- iconv_close(cd);-}--size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft,- char **outbuf, size_t *outbytesleft) {- // Cast inbuf to (void*) so that it works both on Solaris, which expects- // a (const char**), and on other platforms (e.g. Linux), which expect- // a (char **).- return iconv(cd, (void*)inbuf, inbytesleft, outbuf, outbytesleft);-}
haskeline.cabal view
@@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.10-Version: 0.7.2.3+Version: 0.7.3.0 Category: User Interfaces License: BSD3 License-File: LICENSE@@ -9,16 +9,16 @@ Maintainer: Judah Jacobson <judah.jacobson@gmail.com> Category: User Interfaces Synopsis: A command-line interface for user input, written in Haskell.-Description: +Description: Haskeline provides a user interface for line input in command-line programs. This library is similar in purpose to readline, but since it is written in Haskell it is (hopefully) more easily used in other Haskell programs. . Haskeline runs both on POSIX-compatible systems and on Windows.-Homepage: https://github.com/judah/haskeline+Homepage: http://trac.haskell.org/haskeline Bug-Reports: https://github.com/judah/haskeline/issues-Stability: Experimental+Stability: Stable Build-Type: Custom extra-source-files: examples/Test.hs Changelog @@ -38,24 +38,15 @@ Description: Use the terminfo package for POSIX consoles. Default: True --- Note that the Setup script checks whether -liconv is necessary. This flag--- lets us override that decision. When it is True, we use -liconv. When it--- is False, we run tests to decide.-flag libiconv- 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- Build-depends: base >=4.3 && < 4.10, containers>=0.4 && < 0.6,- directory>=1.1 && < 1.3, bytestring>=0.9 && < 0.11,+ -- We require ghc>=7.4.1 (base>=4.5) to use the base library encodings, even+ -- though it was implemented in earlier releases, due to GHC bug #5436 which+ -- wasn't fixed until 7.4.1+ Build-depends: base >=4.5 && < 4.11, containers>=0.4 && < 0.6,+ directory>=1.1 && < 1.4, bytestring>=0.9 && < 0.11, filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.6 Default-Language: Haskell98- Default-Extensions: + Default-Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances, TypeSynonymInstances FlexibleContexts, ExistentialQuantification@@ -84,6 +75,7 @@ System.Console.Haskeline.LineState System.Console.Haskeline.Monads System.Console.Haskeline.Prefs+ System.Console.Haskeline.Recover System.Console.Haskeline.RunCommand System.Console.Haskeline.Term System.Console.Haskeline.Command.Undo@@ -91,15 +83,6 @@ 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- Other-modules: System.Console.Haskeline.Recover- } 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@@ -109,14 +92,6 @@ cpp-options: -DMINGW } else { Build-depends: unix>=2.0 && < 2.8- -- unix-2.3 doesn't build on ghc-6.8.1 or earlier- -- 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- } Other-modules: System.Console.Haskeline.Backend.Posix System.Console.Haskeline.Backend.Posix.Encoder
− includes/h_iconv.h
@@ -1,9 +0,0 @@-#include <iconv.h>--iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode);--void haskeline_iconv_close(iconv_t cd);--size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft,- char **outbuf, size_t *outbytesleft);-