haskeline 0.3.2 → 0.4

raw patch · 14 files changed

+214/−178 lines, 14 filesdep +extensible-exceptionsdep −template-haskelldep ~basedep ~stmdep ~utf8-stringPVP ok

version bump matches the API change (PVP)

Dependencies added: extensible-exceptions

Dependencies removed: template-haskell

Dependency ranges changed: base, stm, utf8-string

API changes (from Hackage documentation)

Files

• System/Console/Haskeline.hs +51/−45
• System/Console/Haskeline/Backend/Posix.hsc +8/−10
• System/Console/Haskeline/Backend/Terminfo.hs +10/−19
• System/Console/Haskeline/Backend/Win32.hsc +8/−23
• System/Console/Haskeline/Command.hs +1/−1
• System/Console/Haskeline/Command/Completion.hs +6/−2
• System/Console/Haskeline/Command/History.hs +1/−1
• System/Console/Haskeline/Completion.hs +72/−27
• System/Console/Haskeline/InputT.hs +2/−4
• System/Console/Haskeline/MonadException.hs +29/−16
• System/Console/Haskeline/Prefs.hs +14/−16
• System/Console/Haskeline/Term.hs +3/−1
• examples/Test.hs +3/−4
• haskeline.cabal +6/−9

@@ -42,7 +42,9 @@                     defaultSettings,                     setComplete,                     -- * Ctrl-C handling+                    -- $ctrlc                     Interrupt(..),+                    withInterrupt,                     handleInterrupt,                     module System.Console.Haskeline.Completion,                     module System.Console.Haskeline.Prefs,@@ -75,13 +77,11 @@ -- defaultSettings = Settings { --           complete = completeFilename, --           historyFile = Nothing,---           handleSigINT = False --           } -- @ defaultSettings :: MonadIO m => Settings m defaultSettings = Settings {complete = completeFilename,-                        historyFile = Nothing,-                        handleSigINT = False}+                        historyFile = Nothing}  -- | Write a string to the standard output.  Allows cross-platform display of Unicode -- characters.@@ -97,13 +97,13 @@  {- | Read one line of input.  The final newline (if any) is removed. -If 'stdin' is connected to a terminal, 'getInputLine' provides a rich line-editing+If 'stdin' is connected to a terminal with echoing enabled, 'getInputLine' provides a rich line-editing user interface.  It returns 'Nothing' if the user presses @Ctrl-D@ when the input text is empty.  All user interaction, including display of the input prompt, will occur on the user's output terminal (which may differ from 'stdout'). -If 'stdin' is not connected to a terminal, 'getInputLine' reads one line of input, and-prints the prompt and input to 'stdout'. It returns 'Nothing'  if an @EOF@ is+If 'stdin' is not connected to a terminal, 'getInputLine' prints the prompt to 'stdout'+and reads one line of input. It returns 'Nothing'  if an @EOF@ is encountered before any characters are read. -} getInputLine :: forall m . MonadException m => String -- ^ The input prompt@@ -113,9 +113,10 @@     -- appears before we interact with the user on the terminal.     liftIO $ hFlush stdout     rterm <- ask+    echo <- liftIO $ hGetEcho stdin     case termOps rterm of-        Nothing -> simpleFileLoop prefix rterm-        Just tops -> getInputCmdLine tops prefix+        Just tops | echo -> getInputCmdLine tops prefix+        _ -> simpleFileLoop prefix rterm  getInputCmdLine :: MonadException m => TermOps -> String -> InputT m (Maybe String) getInputCmdLine tops prefix = do@@ -124,44 +125,36 @@     emode <- asks (\prefs -> case editMode prefs of                     Vi -> viActions                     Emacs -> emacsCommands)-    wrapper <- sigINTWrapper     -- Run the main event processing loop-    result <- runInputCmdT tops $ wrapper $ runTerm tops+    result <- runInputCmdT tops $ runTerm tops                     $ \getEvent -> do                             let ls = emptyIM                             drawLine prefix ls -                            repeatTillFinish getEvent prefix ls emode+                            repeatTillFinish tops getEvent prefix ls emode     -- Add the line to the history if it's nonempty.     case result of          Just line | not (all isSpace line) -> addHistory line         _ -> return ()     return result -sigINTWrapper :: forall m n a . (Monad m, MonadException n) => InputT m (n a -> n a)-sigINTWrapper = do-    settings :: Settings m <- ask-    rterm <- ask-    return $ if handleSigINT settings-                then wrapInterrupt rterm-                else id- repeatTillFinish :: forall m s d      . (MonadTrans d, Term (d m), LineState s, MonadReader Prefs m)-            => d m Event -> String -> s -> KeyMap m s +            => TermOps -> d m Event -> String -> s -> KeyMap m s              -> d m (Maybe String)-repeatTillFinish getEvent prefix = loop+repeatTillFinish tops getEvent prefix = loop     where -        -- NOTE: since the functions in this mutually recursive binding group do not have the -        -- same contexts, we need the -XGADTs flag (or -fglasgow-exts)         loop :: forall t . LineState t => t -> KeyMap m t -> d m (Maybe String)         loop s processor = do-                event <- handle (\e -> movePast prefix s >> throwIO e) getEvent+                event <- handle (\(e::SomeException) -> movePast prefix s >> throwIO e) getEvent                 case event of-                    WindowResize newLayout -> do+                    WindowResize -> do                         oldLayout <- ask-                        local newLayout $ do-                            reposition oldLayout (lineChars prefix s)-                            loop s processor+                        newLayout <- liftIO $ getLayout tops+                        if oldLayout == newLayout+                            then loop s processor+                            else local newLayout $ do+                                reposition oldLayout (lineChars prefix s)+                                loop s processor                     KeyInput k -> case lookupKM processor k of                         Nothing -> actBell >> loop s processor                         Just g -> case g s of@@ -187,23 +180,7 @@     atEOF <- hIsEOF stdin     if atEOF         then return Nothing-        else do-                l <- UTF8.getLine-                putStrOut rterm (l++"\n")-                return (Just l)--{-- -Note why it is necessary to integrate ctrl-c handling with this module:-if the user is in the middle of a few wrapped lines, we want to clean up-by moving the cursor to the start of the following line.---}---- | 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 = handle (const f)+        else liftM Just UTF8.getLine  drawEffect :: (LineState s, LineState t, Term (d m),                  MonadTrans d, MonadReader Prefs m) @@ -241,3 +218,32 @@  movePast :: (LineState s, Term m) => String -> s -> m () movePast prefix s = moveToNextLine (lineChars prefix s)++++------------+-- 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 computation, throw an exception of type +-- 'Interrupt'.+withInterrupt :: MonadException m => InputT m a -> InputT m a+withInterrupt f = do+    rterm <- ask+    wrapInterrupt rterm f++-- | 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+++

@@ -12,7 +12,7 @@ import System.Console.Terminfo import System.Posix.Terminal hiding (Interrupt) import Control.Monad-import Control.Concurrent+import Control.Concurrent hiding (throwTo) import Control.Concurrent.STM import Data.Maybe import System.Posix.Signals.Exts@@ -22,7 +22,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8 import System.Environment-import Control.Exception (throwDynTo)  import System.Console.Haskeline.Monads import System.Console.Haskeline.Command@@ -55,7 +54,7 @@ unsafeHandleToFD h = withHandle_ "unsafeHandleToFd" h (return . haFD)  envLayout :: IO (Maybe Layout)-envLayout = handle (\_ -> return Nothing) $ do+envLayout = handle (\(_::IOException) -> return Nothing) $ do     -- note the handle catches both undefined envs and bad reads     r <- getEnv "ROWS"     c <- getEnv "COLUMNS"@@ -168,7 +167,7 @@ withPosixGetEvent h term f = do     baseMap <- liftIO (getKeySequences term)     eventChan <- liftIO $ newTChanIO-    wrapKeypad h term $ withWindowHandler h term eventChan+    wrapKeypad h term $ withWindowHandler eventChan         $ f $ liftIO $ getEvent baseMap eventChan  -- If the keypad on/off capabilities are defined, wrap the computation with them.@@ -180,16 +179,15 @@     maybeOutput cap = liftIO $ hRunTermOutput h term $                             fromMaybe mempty (getCapability term cap) -withWindowHandler :: MonadException m => Handle -> Maybe Terminal -> TChan Event -> m a -> m a-withWindowHandler h term eventChan = withHandler windowChange $ -    Catch $ getPosixLayout h term -                >>= atomically . writeTChan eventChan . WindowResize+withWindowHandler :: MonadException m => TChan Event -> m a -> m a+withWindowHandler eventChan = withHandler windowChange $ +    Catch $ atomically $ writeTChan eventChan WindowResize  withSigIntHandler :: MonadException m => m a -> m a withSigIntHandler f = do     tid <- liftIO myThreadId      withHandler keyboardSignal -            (CatchOnce (throwDynTo tid Interrupt))+            (Catch (throwTo tid Interrupt))             f  withHandler :: MonadException m => Signal -> Handler -> m a -> m a@@ -218,7 +216,7 @@ openTTY = do     inIsTerm <- hIsTerminalDevice stdin     if inIsTerm-        then handle (\_ -> return Nothing) $ do+        then handle (\(_::IOException) -> return Nothing) $ do                 h <- openFile "/dev/tty" WriteMode                 return (Just h)         else return Nothing

@@ -8,7 +8,7 @@ import Control.Monad import Data.List(intersperse) import System.IO-import qualified Control.Exception as Exception+import qualified Control.Exception.Extensible as Exception  import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.LineState@@ -108,7 +108,9 @@ runTerminfoDraw = do     mterm <- Exception.try setupTermFromEnv     case mterm of-        Left _ -> return Nothing+        -- XXX narrow this: either an ioexception (from getenv) or a +        -- usererror.+        Left (_::SomeException) -> return Nothing         Right term -> case getCapability term getActions of             Nothing -> return Nothing             Just actions -> fmap Just $ posixRunTerm $ \h -> @@ -230,26 +232,15 @@     output $ mreplicate (lsLinesLeft layout pos s) nl     put initTermPos --posFromLength :: Layout -> Int -> TermPos-posFromLength Layout {width = w} n = TermPos -                            {termRow = n `div` w, termCol = n `mod` w}--posToLength :: Layout -> TermPos -> Int-posToLength Layout {width = w} TermPos {termRow = r, termCol = c}-    = r * w + c--repositionPos :: Layout -> Layout -> TermPos -> TermPos-repositionPos oldLayout newLayout oldPos = posFromLength newLayout $-                                            posToLength oldLayout oldPos- repositionT :: (MonadLayout m, MonadException m) =>                 Layout -> LineChars -> Draw m ()-repositionT oldLayout _ = do+repositionT oldLayout s = do     oldPos <- get-    newLayout <- ask-    let newPos = repositionPos oldLayout newLayout oldPos-    put newPos+    let l = lsLinesLeft oldLayout oldPos s - 1+    output $ cr <#> mreplicate l nl+            <#> mreplicate (l + termRow oldPos) (clearToLineEnd <#> up 1)+    put initTermPos+    drawLineDiffT ("","") s  instance (MonadException m, MonadLayout m) => Term (Draw m) where     drawLineDiff = drawLineDiffT

@@ -15,10 +15,9 @@ import Graphics.Win32.Misc(getStdHandle, sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE)
 import System.Win32.File
 import Data.List(intercalate)
-import Control.Concurrent
+import Control.Concurrent hiding (throwTo)
 import Control.Concurrent.STM
 import Data.Bits
-import Control.Exception (throwDynTo)
 
 import System.Console.Haskeline.Command
 import System.Console.Haskeline.Monads
@@ -53,7 +52,7 @@     	        Nothing -> eventLoop h
                        
 getConOut :: IO (Maybe HANDLE)
-getConOut = handle (\_ -> return Nothing) $ fmap Just
+getConOut = handle (\(_::IOException) -> return Nothing) $ fmap Just
     $ createFile "CONOUT$" (gENERIC_READ .|. gENERIC_WRITE)
                         (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing
                     oPEN_EXISTING 0 Nothing
@@ -155,18 +154,10 @@             $ c_GetScreenBufferInfo h infoPtr
         f infoPtr
 
-
-getDisplayWindow :: HANDLE -> IO (Coord,Coord)
-getDisplayWindow = withScreenBufferInfo $ \p -> do
-    let windowPtr = (#ptr CONSOLE_SCREEN_BUFFER_INFO, srWindow) p
-    left <- (#peek SMALL_RECT, Left) windowPtr
-    top <- (#peek SMALL_RECT, Top) windowPtr
-    right <- (#peek SMALL_RECT, Right) windowPtr
-    bottom <- (#peek SMALL_RECT, Bottom) windowPtr
-    return (Coord (cvt left) (cvt top), Coord (cvt right) (cvt bottom))
-  where
-    cvt :: CShort -> Int
-    cvt = fromEnum
+getBufferSize :: HANDLE -> IO Layout
+getBufferSize = withScreenBufferInfo $ \p -> do
+    c <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) p
+    return Layout {width = coordX c, height = coordY c}
 
 foreign import stdcall "windows.h WriteConsoleW" c_WriteConsoleW
     :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool
@@ -199,12 +190,6 @@     ask = lift ask
     local r = Draw . local r . runDraw
 
-getDisplaySize :: HANDLE -> IO Layout
-getDisplaySize h = do
-    (topLeft,bottomRight) <- getDisplayWindow h
-    return Layout {width = coordX bottomRight - coordX topLeft+1, 
-                    height = coordY bottomRight - coordY topLeft+1 }
-    
 getPos :: MonadIO m => Draw m Coord
 getPos = ask >>= liftIO . getPosition
     
@@ -280,7 +265,7 @@                             putStrOut = putter,
                             wrapInterrupt = withCtrlCHandler,
                             termOps = Just TermOps {
-                                            getLayout = getDisplaySize h,
+                                            getLayout = getBufferSize h,
                                             runTerm = consoleRunTerm h},
                             closeTerm = closeHandle h}
 
@@ -329,6 +314,6 @@                                 (const f)
   where
     handler tid (#const CTRL_C_EVENT) = do
-        throwDynTo tid Interrupt
+        throwTo tid Interrupt
         return True
     handler _ _ = return False

@@ -39,7 +39,7 @@ import System.Console.Haskeline.LineState  data Layout = Layout {width, height :: Int}-                    deriving Show+                    deriving (Show,Eq)  data Key = KeyChar Char | KeyMeta Key             | KeyLeft | KeyRight | KeyUp | KeyDown

@@ -14,6 +14,10 @@  import Data.List(transpose, unfoldr) +fullReplacement :: Completion -> String+fullReplacement c   | isFinished c  = replacement c ++ " "+                    | otherwise     = replacement c+ makeCompletion :: Monad m => InsertMode -> InputCmdT m (InsertMode, [Completion]) makeCompletion (IMode xs ys) = do     f <- asks complete@@ -27,7 +31,7 @@     (rest,completions) <- makeCompletion s     case completionType prefs of         MenuCompletion -> return $ menuCompletion k s-                        $ map (\c -> insertString (replacement c) rest) completions+                        $ map (\c -> insertString (fullReplacement c) rest) completions         ListCompletion ->                  pagingCompletion prefs s rest completions k) @@ -36,7 +40,7 @@                 -> Key -> InputCmdT m (CmdAction (InputCmdT m) InsertMode) pagingCompletion _ oldIM _ [] _ = return $ RingBell oldIM >=> continue pagingCompletion _ _ im [newWord] _ -        = return $ (Change $ insertString (replacement newWord) im) >=> continue+        = return $ (Change $ insertString (fullReplacement newWord) im) >=> continue pagingCompletion prefs oldIM im completions k     | oldIM /= withPartial = return $ Change withPartial >=> continue     | otherwise = do

@@ -6,7 +6,7 @@ import System.Console.Haskeline.Monads import Data.List import Data.Maybe(fromMaybe)-import Control.Exception(evaluate)+import Control.Exception.Extensible(evaluate) import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8 

@@ -2,9 +2,13 @@                             CompletionFunc,                             Completion(..),                             completeWord,-                            simpleCompletion,+                            completeQuotedWord,+                            -- * Building 'CompletionFunc's                             noCompletion,+                            simpleCompletion,+                            -- * Filename completion                             completeFilename,+                            listFiles,                             filenameWordBreakChars                         ) where @@ -24,9 +28,12 @@   data Completion = Completion {replacement  :: String, -- ^ Text to insert in line.-                        display  :: String+                        display  :: String,                                 -- ^ Text to display when listing                                 -- alternatives.+                        isFinished :: Bool+                            -- ^ Whether this word should be followed by a+                            -- space, end quote, etc.                             }                     deriving Show @@ -48,17 +55,17 @@                         Nothing -> break (`elem` ws) line                         Just e -> escapedBreak e line     completions <- f (reverse word)-    return (rest,completions)+    return (rest,map (escapeReplacement esc ws) completions)   where-    escapedBreak e (c:d:cs) | d == e-            = let (xs,ys) = escapedBreak e cs in (c:d:xs,ys)+    escapedBreak e (c:d:cs) | d == e && c `elem` (e:ws)+            = let (xs,ys) = escapedBreak e cs in (c:xs,ys)     escapedBreak e (c:cs) | not (elem c ws)             = let (xs,ys) = escapedBreak e cs in (c:xs,ys)     escapedBreak _ cs = ("",cs)     --- | Adds a space after the word when inserting it after expansion.+-- | Create a finished completion out of the given word. simpleCompletion :: String -> Completion-simpleCompletion = setReplacement (++ " ") . completion+simpleCompletion = completion  -- NOTE: this is the same as for readline, except that I took out the '\\' -- so they can be used as a path separator.@@ -67,34 +74,71 @@  -- A completion command for file and folder names. completeFilename :: MonadIO m => CompletionFunc m-completeFilename  = completeWord (Just '\\') filenameWordBreakChars $ -                        (liftIO . quotedFilenames (`elem` "\"\'"))+completeFilename  = completeQuotedWord (Just '\\') "\"'" listFiles+                        $ completeWord (Just '\\') ("\"\'" ++ filenameWordBreakChars)+                                listFiles  completion :: String -> Completion-completion str = Completion str str+completion str = Completion str str True  setReplacement :: (String -> String) -> Completion -> Completion setReplacement f c = c {replacement = f $ replacement c} +escapeReplacement :: Maybe Char -> String -> Completion -> Completion+escapeReplacement esc ws f = case esc of+    Nothing -> f+    Just e -> f {replacement = escape e (replacement f)}+  where+    escape e (c:cs) | c `elem` (e:ws)     = e : c : escape e cs+                    | otherwise = c : escape e cs+    escape _ "" = "" ------------ Helper funcs for file completion -quotedFilenames :: (Char -> Bool) -> String -> IO [Completion]-quotedFilenames isQuote (q:file) | isQuote q = do-    files <- findFiles file-    return $ map (setReplacement ((q:) . appendIfNotDir [q,' '])) files-quotedFilenames _ file = do-    files <- findFiles file-    return $ map (setReplacement (appendIfNotDir " ")) files+---------+-- Quoted completion+completeQuotedWord :: Monad m => Maybe Char -- ^ An optional escape character+                            -> String -- List of characters which set off quotes+                            -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions+                            -> CompletionFunc m -- ^ Alternate completion to perform if the +                                            -- cursor is not at a quoted word+                            -> CompletionFunc m+completeQuotedWord esc qs completer alterative = \line -> case splitAtQuote esc qs line of+    Just (w,rest) | isUnquoted esc qs rest -> do+        cs <- completer (reverse w)+        return (rest, map (addQuotes . escapeReplacement esc qs) cs)+    _ -> alterative line -appendIfNotDir :: String -> FilePath -> FilePath-appendIfNotDir str file | null (takeFileName file) = file-                        | otherwise = file ++ str+addQuotes :: Completion -> Completion+addQuotes c = if isFinished c+    then c {replacement = "\"" ++ replacement c ++ "\""}+    else c {replacement = "\"" ++ replacement c} -findFiles :: FilePath -> IO [Completion]+splitAtQuote :: Maybe Char -> String -> String -> Maybe (String,String)+splitAtQuote esc qs line = case line of+    c:e:cs | isEscape e && isEscapable c  +                        -> do+                            (w,rest) <- splitAtQuote esc qs cs+                            return (c:w,rest)+    q:cs   | isQuote q  -> Just ("",cs)+    c:cs                -> do+                            (w,rest) <- splitAtQuote esc qs cs+                            return (c:w,rest)+    ""                  -> Nothing+  where+    isQuote = (`elem` qs)+    isEscape c = Just c == esc+    isEscapable c = isEscape c || isQuote c++isUnquoted :: Maybe Char -> String -> String -> Bool+isUnquoted esc qs s = case splitAtQuote esc qs s of+    Just (_,s') -> not (isUnquoted esc qs s')+    _ -> True+++-- | List all of the files or folders beginning with this path.+listFiles :: MonadIO m => FilePath -> m [Completion] -- NOTE: 'handle' catches exceptions from getDirectoryContents and getHomeDirectory.-findFiles path = handle (\_ -> return []) $ do+listFiles path = liftIO $ handle (\(_::IOException) -> return []) $ do     fixedDir <- fixPath dir     dirExists <- doesDirectoryExist fixedDir     -- get all of the files in that directory, as basenames@@ -106,13 +150,14 @@     -- have a trailing slash if it's itself a directory.     forM allFiles $ \c -> do             isDir <- doesDirectoryExist (fixedDir </> replacement c)-            return $ setReplacement (fullName . maybeAddSlash isDir) c+            return $ setReplacement fullName $ alterIfDir isDir c   where     (dir, file) = splitFileName path     filterPrefix = filter (\f -> not (f `elem` [".",".."])                                         && file `isPrefixOf` f)-    maybeAddSlash False = id-    maybeAddSlash True = addTrailingPathSeparator+    alterIfDir False c = c+    alterIfDir True c = c {replacement = addTrailingPathSeparator (replacement c),+                            isFinished = False}     -- NOTE In order for completion to work properly, all of the alternatives     -- must have the exact same prefix.  As a result, </> is a little too clever;     -- for example, it doesn't prepend the directory if the file looks like

@@ -17,9 +17,7 @@  -- | Application-specific customizations to the user interface. data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion-                            historyFile :: Maybe FilePath,-                            handleSigINT :: Bool -- ^ Throw an 'Interrupt'-                            -- exception if the user presses Ctrl-C+                            historyFile :: Maybe FilePath                             }  -- | Because 'complete' is the only field of 'Settings' depending on @m@,@@ -87,7 +85,7 @@ -- | Read 'Prefs' from @~/.haskeline.@   If there is an error reading the file, -- the 'defaultPrefs' will be returned. readPrefsFromHome :: IO Prefs-readPrefsFromHome = handle (\_ -> return defaultPrefs) $ do+readPrefsFromHome = handle (\(_::IOException) -> return defaultPrefs) $ do     home <- getHomeDirectory     readPrefs (home </> ".haskeline") 

@@ -1,54 +1,67 @@-{- | This module redefines some of the functions in "Control.Exception" to+{- | This module redefines some of the functions in "Control.Exception.Extensible" to work for more general monads than only 'IO'. -} -module System.Console.Haskeline.MonadException where+module System.Console.Haskeline.MonadException(+    MonadException(..),+    handle,+    finally,+    throwIO,+    throwTo,+    bracket,+    throwDynIO,+    handleDyn,+    Exception,+    SomeException(..),+    E.IOException())+     where -import qualified Control.Exception as E+import qualified Control.Exception.Extensible as E+import Control.Exception.Extensible(Exception,SomeException) import Prelude hiding (catch)-import Control.Exception(Exception) import Control.Monad.Reader import Control.Monad.State-import Data.Dynamic+import Control.Concurrent(ThreadId)  class MonadIO m => MonadException m where-    catch :: m a -> (Exception -> m a) -> m a+    catch :: Exception e => m a -> (e -> m a) -> m a     block :: m a -> m a     unblock :: m a -> m a -handle :: MonadException m => (Exception -> m a) -> m a -> m a+handle :: (MonadException m, Exception e) => (e -> m a) -> m a -> m a handle = flip catch  finally :: MonadException m => m a -> m b -> m a finally f ender = block (do     r <- catch             (unblock f)-            (\e -> do {ender; throwIO e})+            (\(e::SomeException) -> do {ender; throwIO e})     ender     return r) -throwIO :: MonadIO m => Exception -> m a+throwIO :: (MonadIO m, Exception e) => e -> m a throwIO = liftIO . E.throwIO +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 -> do { after a; throwIO e })+	   (\(e::SomeException) -> do { after a; throwIO e })     after a     return r  ) -throwDynIO :: (Typeable exception, MonadIO m) => exception -> m a-throwDynIO = liftIO . E.throwIO . E.DynException . toDyn+throwDynIO :: (Exception exception, MonadIO m) => exception -> m a+throwDynIO = throwIO -handleDyn :: (Typeable exception, MonadException m) => (exception -> m a)+handleDyn :: (Exception exception, MonadException m) => (exception -> m a)                     -> m a -> m a-handleDyn f = handle $ \ex -> case E.dynExceptions ex of-                        Just dyn | Just e <- fromDynamic dyn -> f e-                        _ -> throwIO ex+handleDyn = handle    instance MonadException IO where

@@ -21,10 +21,9 @@                         EditMode(..)                         ) where -import Language.Haskell.TH import Data.Char(isSpace,toLower) import Data.List(foldl')-import Control.Exception(handle)+import System.Console.Haskeline.MonadException(handle,IOException)   data Prefs = Prefs { bellStyle :: !BellStyle,@@ -58,7 +57,7 @@ {- | The default preferences which may be overwritten in the @.haskeline@ file:  > defaultPrefs = Prefs {bellStyle = AudibleBell,->                      maxHistorySize = Nothing,+>                      maxHistorySize = Just 100, >                      editMode = Emacs, >                      completionType = ListCompletion, >                      completionPaging = True,@@ -69,7 +68,7 @@ -} defaultPrefs :: Prefs defaultPrefs = Prefs {bellStyle = AudibleBell,-                      maxHistorySize = Nothing,+                      maxHistorySize = Just 100,                       editMode = Emacs,                       completionType = ListCompletion,                       completionPaging = True,@@ -82,22 +81,21 @@                 [(x,_)] -> f x                 _ -> id -settors :: [(String,String -> Prefs -> Prefs)]-settors = $(do-    DataConI _ _ prefsType _ <- reify 'Prefs-    TyConI (DataD _ _ _ [RecC _ fields] _) <- reify prefsType-    x <- newName "x"-    p <- newName "p"-    -- settor f => ("f", mkSettor (\x p -> p {f=x}))-    let settor (f,_,_) = TupE [LitE (StringL (map toLower $ nameBase f)),-                        AppE (VarE 'mkSettor) $ LamE [VarP x,VarP p]-                        $ RecUpdE (VarE p) [(f,VarE x)]]-    return $ ListE $ map settor fields)+settors :: [(String, String -> Prefs -> Prefs)]+settors = [("bellstyle", mkSettor $ \x p -> p {bellStyle = x})+          ,("editmode", mkSettor $ \x p -> p {editMode = x})+          ,("maxhistorysize", mkSettor $ \x p -> p {maxHistorySize = x})+          ,("completiontype", mkSettor $ \x p -> p {completionType = x})+          ,("completionpaging", mkSettor $ \x p -> p {completionPaging = x})+          ,("completionpromptlimit", mkSettor $ \x p -> p {completionPromptLimit = x})+          ,("listcompletionsimmediately", mkSettor $ \x p -> p {listCompletionsImmediately = x}) +          ]+ -- | Read 'Prefs' from a given file.  If there is an error reading the file, -- the 'defaultPrefs' will be returned. readPrefs :: FilePath -> IO Prefs-readPrefs file = handle (\_ -> return defaultPrefs) $ do+readPrefs file = handle (\(_::IOException) -> return defaultPrefs) $ do     ls <- fmap lines $ readFile file     return $ foldl' applyField defaultPrefs ls   where

@@ -38,7 +38,7 @@ matchInit (x:xs) (y:ys)  | x == y = matchInit xs ys matchInit xs ys = (xs,ys) -data Event = WindowResize Layout | KeyInput Key+data Event = WindowResize | KeyInput Key                 deriving Show  keyEventLoop :: (TChan Event -> IO ()) -> TChan Event -> IO Event@@ -64,3 +64,5 @@  data Interrupt = Interrupt                 deriving (Show,Typeable,Eq)++instance Exception Interrupt where

@@ -3,16 +3,15 @@ import System.Console.Haskeline  mySettings :: Settings IO-mySettings = defaultSettings {historyFile = Just "myhist",-                        handleSigINT = True}+mySettings = defaultSettings {historyFile = Just "myhist"}  main :: IO ()-main = runInputT mySettings (loop 0)+main = runInputT mySettings $ withInterrupt $ loop 0     where         loop :: Int -> InputT IO ()         loop n = do             minput <-  handleInterrupt (return (Just "Caught interrupted"))-                        (getInputLine (show n ++ ":"))+                        $ getInputLine (show n ++ ":")             case minput of                 Nothing -> return ()                 Just "quit" -> return ()

@@ -1,6 +1,6 @@ Name:           haskeline Cabal-Version:  >=1.2-Version:        0.3.2+Version:        0.4 Category:       User Interfaces License:        BSD3 License-File:   LICENSE@@ -29,20 +29,17 @@     if flag(old-base)         Build-depends: base < 3     else-        Build-depends: base>=3 && <4 , containers>=0.1, directory>=1.0-    Build-depends:  stm>=2.0, filepath>=1.1, template-haskell>=2.1, -                    mtl>=1.1, utf8-string>=0.3.1.1, bytestring>=0.9.0.1+        Build-depends: base>=3 && <5 , containers>=0.1, directory>=1.0+    Build-depends:  stm>=2.0, filepath>=1.1, +                    mtl>=1.1, utf8-string>=0.3.1.1, bytestring>=0.9.0.1,+                    extensible-exceptions>=0.1.1.0     Extensions:     ForeignFunctionInterface, RankNTypes, FlexibleInstances,                 TypeSynonymInstances                 FlexibleContexts, ExistentialQuantification                 ScopedTypeVariables, GeneralizedNewtypeDeriving                 MultiParamTypeClasses, OverlappingInstances                 PatternSignatures, CPP, DeriveDataTypeable,-                PatternGuards, TemplateHaskell, StandaloneDeriving-                -- Note: GADTs are needed to allow contexts of different-                -- lengths (see code of Haskeline.repeatTillFinish)-                GADTs-                FunctionalDependencies+                PatternGuards, StandaloneDeriving     Exposed-Modules:                 System.Console.Haskeline                 System.Console.Haskeline.Completion