diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs --- a/System/Console/Haskeline.hs +++ b/System/Console/Haskeline.hs @@ -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 + + + 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 @@ -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 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,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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 diff --git a/System/Console/Haskeline/Completion.hs b/System/Console/Haskeline/Completion.hs --- a/System/Console/Haskeline/Completion.hs +++ b/System/Console/Haskeline/Completion.hs @@ -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 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 @@ -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") 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,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 diff --git a/System/Console/Haskeline/Prefs.hs b/System/Console/Haskeline/Prefs.hs --- a/System/Console/Haskeline/Prefs.hs +++ b/System/Console/Haskeline/Prefs.hs @@ -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 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 @@ -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 diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -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 () diff --git a/haskeline.cabal b/haskeline.cabal --- a/haskeline.cabal +++ b/haskeline.cabal @@ -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