haskeline 0.3.1 → 0.3.2
raw patch · 14 files changed
+274/−166 lines, 14 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- System.Console.Haskeline: instance [overlap ok] Eq Interrupt
- System.Console.Haskeline: instance [overlap ok] Show Interrupt
- System.Console.Haskeline: instance [overlap ok] Typeable Interrupt
Files
- System/Console/Haskeline.hs +33/−25
- System/Console/Haskeline/Backend/DumbTerm.hs +6/−11
- System/Console/Haskeline/Backend/Posix.hsc +14/−11
- System/Console/Haskeline/Backend/Terminfo.hs +24/−30
- System/Console/Haskeline/Backend/Win32.hsc +44/−45
- System/Console/Haskeline/Command.hs +10/−6
- System/Console/Haskeline/Command/Undo.hs +67/−0
- System/Console/Haskeline/Emacs.hs +14/−7
- System/Console/Haskeline/InputT.hs +6/−4
- System/Console/Haskeline/LineState.hs +8/−3
- System/Console/Haskeline/MonadException.hs +1/−1
- System/Console/Haskeline/Term.hs +15/−9
- System/Console/Haskeline/Vi.hs +29/−13
- haskeline.cabal +3/−1
System/Console/Haskeline.hs view
@@ -65,7 +65,6 @@ import qualified System.IO.UTF8 as UTF8 import Data.Char (isSpace) import Control.Monad-import Data.Dynamic @@ -118,17 +117,17 @@ Nothing -> simpleFileLoop prefix rterm Just tops -> getInputCmdLine tops prefix -getInputCmdLine :: forall m . MonadException m => TermOps -> String -> InputT m (Maybe String)+getInputCmdLine :: MonadException m => TermOps -> String -> InputT m (Maybe String) getInputCmdLine tops prefix = do -- Load the necessary settings/prefs -- TODO: Cache the actions emode <- asks (\prefs -> case editMode prefs of Vi -> viActions Emacs -> emacsCommands)- settings :: Settings m <- ask+ wrapper <- sigINTWrapper -- Run the main event processing loop- result <- runInputCmdT tops $ flip (runTerm tops) (handleSigINT settings)- $ \getEvent -> do+ result <- runInputCmdT tops $ wrapper $ runTerm tops+ $ \getEvent -> do let ls = emptyIM drawLine prefix ls repeatTillFinish getEvent prefix ls emode@@ -138,8 +137,16 @@ _ -> 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), MonadIO m, LineState s, MonadReader Prefs m)+ . (MonadTrans d, Term (d m), LineState s, MonadReader Prefs m) => d m Event -> String -> s -> KeyMap m s -> d m (Maybe String) repeatTillFinish getEvent prefix = loop@@ -148,17 +155,17 @@ -- 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 <- getEvent+ event <- handle (\e -> movePast prefix s >> throwIO e) getEvent case event of- SigInt -> do- moveToNextLine s- throwInterrupt- WindowResize newLayout -> - withReposition newLayout (loop s processor)+ WindowResize newLayout -> do+ oldLayout <- ask+ 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- Left r -> moveToNextLine s >> return r+ Left r -> movePast prefix s >> return r Right f -> do KeyAction effect next <- lift f drawEffect prefix s effect@@ -191,9 +198,6 @@ by moving the cursor to the start of the following line. --} -data Interrupt = Interrupt- deriving (Show,Typeable,Eq)- -- | Catch and handle an exception of type 'Interrupt'. handleInterrupt :: MonadException m => m a -- ^ Handler to run if Ctrl-C is pressed@@ -201,30 +205,31 @@ -> m a handleInterrupt f = handle (const f) -throwInterrupt :: MonadIO m => m a-throwInterrupt = throwDynIO Interrupt-- drawEffect :: (LineState s, LineState t, Term (d m), MonadTrans d, MonadReader Prefs m) => String -> s -> Effect t -> d m () drawEffect prefix s (Redraw shouldClear t) = if shouldClear then clearLayout >> drawLine prefix t else clearLine prefix s >> drawLine prefix t-drawEffect prefix s (Change t) = drawLineDiff prefix s t+drawEffect prefix s (Change t) = drawLineStateDiff prefix s t drawEffect prefix s (PrintLines ls t) = do if isTemporary s then clearLine prefix s- else moveToNextLine s+ else movePast prefix s printLines ls drawLine prefix t-drawEffect prefix s (RingBell t) = drawLineDiff prefix s t >> actBell+drawEffect prefix s (RingBell t) = drawLineStateDiff prefix s t >> actBell drawLine :: (LineState s, Term m) => String -> s -> m ()-drawLine prefix s = drawLineDiff prefix Cleared s+drawLine prefix s = drawLineStateDiff prefix Cleared s +drawLineStateDiff :: (LineState s, LineState t, Term m) + => String -> s -> t -> m ()+drawLineStateDiff prefix s t = drawLineDiff (lineChars prefix s) + (lineChars prefix t)+ clearLine :: (LineState s, Term m) => String -> s -> m ()-clearLine prefix s = drawLineDiff prefix s Cleared+clearLine prefix s = drawLineStateDiff prefix s Cleared actBell :: (Term (d m), MonadTrans d, MonadReader Prefs m) => d m () actBell = do@@ -233,3 +238,6 @@ NoBell -> return () VisualBell -> ringBell False AudibleBell -> ringBell True++movePast :: (LineState s, Term m) => String -> s -> m ()+movePast prefix s = moveToNextLine (lineChars prefix s)
System/Console/Haskeline/Backend/DumbTerm.hs view
@@ -34,17 +34,17 @@ runDumbTerm = posixRunTerm $ \h -> TermOps { getLayout = getPosixLayout h Nothing,- runTerm = \f useSigINT -> + runTerm = \f -> evalStateT' initWindow (runReaderT' h (unDumbTerm- (withPosixGetEvent h Nothing useSigINT f)))+ (withPosixGetEvent h Nothing f))) } instance MonadTrans DumbTerm where lift = DumbTerm . lift . lift -instance MonadLayout m => Term (DumbTerm m) where- withReposition _ = id+instance (MonadException m, MonadLayout m) => Term (DumbTerm m) where+ reposition _ s = refitLine s drawLineDiff = drawLineDiff' printLines = mapM_ (\s -> printText (s ++ crlf))@@ -75,13 +75,8 @@ maxWidth :: MonadLayout m => DumbTerm m Int maxWidth = asks (\lay -> width lay - 1) -drawLineDiff' :: (LineState s, LineState t, MonadLayout m)- => String -> s -> t -> DumbTerm m ()-drawLineDiff' prefix s1 s2 = do- let xs1 = beforeCursor prefix s1- let ys1 = afterCursor s1- let xs2 = beforeCursor prefix s2- let ys2 = afterCursor s2+drawLineDiff' :: MonadLayout m => LineChars -> LineChars -> DumbTerm m ()+drawLineDiff' (xs1,ys1) (xs2,ys2) = do Window {pos=p} <- get w <- maxWidth let (xs1',xs2') = matchInit xs1 xs2
System/Console/Haskeline/Backend/Posix.hsc view
@@ -10,7 +10,7 @@ import Foreign.C.Types import qualified Data.Map as Map import System.Console.Terminfo-import System.Posix.Terminal+import System.Posix.Terminal hiding (Interrupt) import Control.Monad import Control.Concurrent import Control.Concurrent.STM@@ -22,6 +22,7 @@ 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@@ -163,12 +164,11 @@ ----------------------------- -withPosixGetEvent :: MonadException m => Handle -> Maybe Terminal -> Bool -> (m Event -> m a) -> m a-withPosixGetEvent h term useSigINT f = do+withPosixGetEvent :: MonadException m => Handle -> Maybe Terminal -> (m Event -> m a) -> m a+withPosixGetEvent h term f = do baseMap <- liftIO (getKeySequences term) eventChan <- liftIO $ newTChanIO- wrapKeypad h term . withWindowHandler h term eventChan- $ withSigIntHandler useSigINT eventChan+ wrapKeypad h term $ withWindowHandler h term eventChan $ f $ liftIO $ getEvent baseMap eventChan -- If the keypad on/off capabilities are defined, wrap the computation with them.@@ -185,10 +185,12 @@ Catch $ getPosixLayout h term >>= atomically . writeTChan eventChan . WindowResize -withSigIntHandler :: MonadException m => Bool -> TChan Event -> m a -> m a-withSigIntHandler False _ = id-withSigIntHandler True eventChan = withHandler keyboardSignal $ CatchOnce $- atomically $ writeTChan eventChan SigInt+withSigIntHandler :: MonadException m => m a -> m a+withSigIntHandler f = do+ tid <- liftIO myThreadId + withHandler keyboardSignal + (CatchOnce (throwDynTo tid Interrupt))+ f withHandler :: MonadException m => Signal -> Handler -> m a -> m a withHandler signal handler f = do@@ -229,6 +231,7 @@ Just h -> return RunTerm { putStrOut = putTerm stdout, closeTerm = hClose h,+ wrapInterrupt = withSigIntHandler, termOps = Just (wrapRunTerm (wrapTerminalOps h) (tOps h)) } @@ -238,6 +241,7 @@ fileRunTerm :: RunTerm fileRunTerm = RunTerm {putStrOut = putTerm stdout, closeTerm = return (),+ wrapInterrupt = withSigIntHandler, termOps = Nothing } @@ -252,8 +256,7 @@ . bracketSet (hGetEcho stdin) (hSetEcho stdin) False wrapRunTerm :: (forall m a . MonadException m => m a -> m a) -> TermOps -> TermOps-wrapRunTerm wrap tops = tops {runTerm = \getE useSigINT -> - wrap (runTerm tops getE useSigINT)+wrapRunTerm wrap tops = tops {runTerm = \getE -> wrap (runTerm tops getE) } bracketSet :: (Eq a, MonadException m) => IO a -> (a -> IO ()) -> a -> m b -> m b
System/Console/Haskeline/Backend/Terminfo.hs view
@@ -114,12 +114,12 @@ Just actions -> fmap Just $ posixRunTerm $ \h -> TermOps { getLayout = getPosixLayout h (Just term),- runTerm = \f useSigINT -> + runTerm = \f -> evalStateT' initTermPos (runReaderT' term (runReaderT' actions (runReaderT' h (unDraw - (withPosixGetEvent h (Just term) useSigINT f)))))+ (withPosixGetEvent h (Just term) f))))) } output :: MonadIO m => (Actions -> TermOutput) -> Draw m ()@@ -183,30 +183,24 @@ put TermPos {termRow=r+1,termCol=0} return rest -drawLineDiffT :: (LineState s, LineState t, MonadLayout m) - => String -> s -> t -> Draw m ()-drawLineDiffT prefix s1 s2 = let - xs1 = beforeCursor prefix s1- ys1 = afterCursor s1- xs2 = beforeCursor prefix s2- ys2 = afterCursor s2- in case matchInit xs1 xs2 of- ([],[]) | ys1 == ys2 -> return ()- (xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (length xs1')- ([],xs2') | ys1 == xs2' ++ ys2 -> changeRight (length xs2')- (xs1',xs2') -> do- changeLeft (length xs1')- printText (xs2' ++ ys2)- let m = length xs1' + length ys1 - (length xs2' + length ys2)- clearDeadText m- changeLeft (length ys2)+drawLineDiffT :: MonadLayout m => LineChars -> LineChars -> Draw m ()+drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of+ ([],[]) | ys1 == ys2 -> return ()+ (xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (length xs1')+ ([],xs2') | ys1 == xs2' ++ ys2 -> changeRight (length xs2')+ (xs1',xs2') -> do+ changeLeft (length xs1')+ printText (xs2' ++ ys2)+ let m = length xs1' + length ys1 - (length xs2' + length ys2)+ clearDeadText m+ changeLeft (length ys2) linesLeft :: Layout -> TermPos -> Int -> Int linesLeft Layout {width=w} TermPos {termCol = c} n | c + n < w = 1 | otherwise = 1 + div (c+n) w -lsLinesLeft :: LineState s => Layout -> TermPos -> s -> Int+lsLinesLeft :: Layout -> TermPos -> LineChars -> Int lsLinesLeft layout pos s = linesLeft layout pos (lengthToEnd s) clearDeadText :: MonadLayout m => Int -> Draw m ()@@ -229,7 +223,7 @@ output (flip clearAll h) put initTermPos -moveToNextLineT :: (LineState s, MonadLayout m) => s -> Draw m ()+moveToNextLineT :: MonadLayout m => LineChars -> Draw m () moveToNextLineT s = do pos <- get layout <- ask@@ -245,21 +239,21 @@ posToLength Layout {width = w} TermPos {termRow = r, termCol = c} = r * w + c -reposition :: Layout -> Layout -> TermPos -> TermPos-reposition oldLayout newLayout oldPos = posFromLength newLayout $ +repositionPos :: Layout -> Layout -> TermPos -> TermPos+repositionPos oldLayout newLayout oldPos = posFromLength newLayout $ posToLength oldLayout oldPos -withRepositionT :: MonadReader Layout m => Layout -> Draw m a -> Draw m a-withRepositionT newLayout f = do+repositionT :: (MonadLayout m, MonadException m) =>+ Layout -> LineChars -> Draw m ()+repositionT oldLayout _ = do oldPos <- get- oldLayout <- ask- let newPos = reposition oldLayout newLayout oldPos+ newLayout <- ask+ let newPos = repositionPos oldLayout newLayout oldPos put newPos- local newLayout f -instance MonadLayout m => Term (Draw m) where+instance (MonadException m, MonadLayout m) => Term (Draw m) where drawLineDiff = drawLineDiffT- withReposition = withRepositionT+ reposition = repositionT printLines [] = return () printLines ls = output $ mconcat $ intersperse nl (map text ls) ++ [nl]
System/Console/Haskeline/Backend/Win32.hsc view
@@ -18,6 +18,7 @@ import Control.Concurrent import Control.Concurrent.STM import Data.Bits +import Control.Exception (throwDynTo) import System.Console.Haskeline.Command import System.Console.Haskeline.Monads @@ -32,21 +33,25 @@ foreign import stdcall "windows.h WaitForSingleObject" c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD -getEvent :: HANDLE -> TChan Event -> IO Event -getEvent h = keyEventLoop readKeyEvents +getEvent :: HANDLE -> IO Event +getEvent h = newTChanIO >>= keyEventLoop eventIntoChan where - waitTime = 200 -- milliseconds - readKeyEvents eventChan = do - yield -- since the foreign call to WaitForSingleObject blocks the killThread - ret <- c_WaitForSingleObject h waitTime - if ret /= (#const WAIT_OBJECT_0) - then readKeyEvents eventChan - else do - e <- readEvent h - case eventToKey e of - Just k -> atomically $ writeTChan eventChan (KeyInput k) - Nothing -> readKeyEvents eventChan + eventIntoChan tchan = eventLoop h >>= atomically . writeTChan tchan +eventLoop :: HANDLE -> IO Event +eventLoop h = do + let waitTime = 500 -- milliseconds + ret <- c_WaitForSingleObject h waitTime + yield -- otherwise, the above foreign call causes the loop to never + -- respond to the killThread + if ret /= (#const WAIT_OBJECT_0) + then eventLoop h + else do + e <- readEvent h + case eventToKey e of + Just k -> return (KeyInput k) + Nothing -> eventLoop h + getConOut :: IO (Maybe HANDLE) getConOut = handle (\_ -> return Nothing) $ fmap Just $ createFile "CONOUT$" (gENERIC_READ .|. gENERIC_WRITE) @@ -219,23 +224,17 @@ printText str setPos p -drawLineDiffWin :: (LineState s, LineState t, MonadLayout m) - => String -> s -> t -> Draw m () -drawLineDiffWin prefix s1 s2 = let - xs1 = beforeCursor prefix s1 - ys1 = afterCursor s1 - xs2 = beforeCursor prefix s2 - ys2 = afterCursor s2 - in case matchInit xs1 xs2 of - ([],[]) | ys1 == ys2 -> return () - (xs1',[]) | xs1' ++ ys1 == ys2 -> movePos $ negate $ length xs1' - ([],xs2') | ys1 == xs2' ++ ys2 -> movePos $ length xs2' - (xs1',xs2') -> do - movePos (negate $ length xs1') - let m = length xs1' + length ys1 - (length xs2' + length ys2) - let deadText = replicate m ' ' - printText xs2' - printAfter (ys2 ++ deadText) +drawLineDiffWin :: MonadLayout m => LineChars -> LineChars -> Draw m () +drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of + ([],[]) | ys1 == ys2 -> return () + (xs1',[]) | xs1' ++ ys1 == ys2 -> movePos $ negate $ length xs1' + ([],xs2') | ys1 == xs2' ++ ys2 -> movePos $ length xs2' + (xs1',xs2') -> do + movePos (negate $ length xs1') + let m = length xs1' + length ys1 - (length xs2' + length ys2) + let deadText = replicate m ' ' + printText xs2' + printAfter (ys2 ++ deadText) movePos :: MonadLayout m => Int -> Draw m () movePos n = do @@ -247,9 +246,9 @@ crlf :: String crlf = "\r\n" -instance MonadLayout m => Term (Draw m) where +instance (MonadException m, MonadLayout m) => Term (Draw m) where drawLineDiff = drawLineDiffWin - withReposition _ = id -- TODO + reposition _ _ = return () -- TODO when we capture resize events. printLines [] = return () printLines ls = printText $ intercalate crlf ls ++ crlf @@ -279,25 +278,25 @@ Nothing -> fileRunTerm Just h -> return RunTerm { putStrOut = putter, + wrapInterrupt = withCtrlCHandler, termOps = Just TermOps { getLayout = getDisplaySize h, runTerm = consoleRunTerm h}, closeTerm = closeHandle h} consoleRunTerm :: HANDLE -> RunTermType -consoleRunTerm conOut f useSigINT = do +consoleRunTerm conOut f = do inH <- liftIO $ getStdHandle sTD_INPUT_HANDLE - eventChan <- liftIO $ newTChanIO - runReaderT' conOut $ runDraw $ withCtrlCHandler useSigINT eventChan - $ f $ liftIO $ getEvent inH eventChan + runReaderT' conOut $ runDraw $ f $ liftIO $ getEvent inH -- stdin is not a terminal, but we still need to check the right way to output unicode to stdout. fileRunTerm :: IO RunTerm fileRunTerm = do putter <- putOut return RunTerm {termOps = Nothing, - closeTerm = return (), - putStrOut = putter} + closeTerm = return (), + putStrOut = putter, + wrapInterrupt = withCtrlCHandler} -- On Windows, Unicode written to the console must be written with the WriteConsole API call. -- And to make the API cross-platform consistent, Unicode to a file should be UTF-8. @@ -320,16 +319,16 @@ :: FunPtr Handler -> BOOL -> IO BOOL -- sets the tv to True when ctrl-c is pressed. -withCtrlCHandler :: MonadException m => Bool -> TChan Event -> m a -> m a -withCtrlCHandler False _ f = f -withCtrlCHandler True eventChan f = bracket (liftIO $ do - fp <- wrapHandler handler +withCtrlCHandler :: MonadException m => m a -> m a +withCtrlCHandler f = bracket (liftIO $ do + tid <- myThreadId + fp <- wrapHandler (handler tid) c_SetConsoleCtrlHandler fp True return fp) (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False) (const f) where - handler (#const CTRL_C_EVENT) = do - atomically $ writeTChan eventChan SigInt + handler tid (#const CTRL_C_EVENT) = do + throwDynTo tid Interrupt return True - handler _ = return False + handler _ _ = return False
System/Console/Haskeline/Command.hs view
@@ -1,5 +1,4 @@ module System.Console.Haskeline.Command(- Event(..), Key(..), controlKey, metaChar,@@ -30,7 +29,8 @@ changeWithoutKey, clearScreenCmd, (+>),- choiceCmd+ choiceCmd,+ withState ) where import Data.Char(isPrint)@@ -46,10 +46,6 @@ | Backspace | DeleteForward | KillLine deriving (Eq,Ord,Show) -data Event = WindowResize Layout | KeyInput Key- | SigInt- deriving Show- -- Easy translation of control characters; e.g., Ctrl-G or Ctrl-g or ^G controlKey :: Char -> Key controlKey '?' = KeyChar (toEnum 127)@@ -165,3 +161,11 @@ choiceCmd :: [Command m s t] -> Command m s t choiceCmd cmds = Command $ \next -> choiceKM $ map (\(Command f) -> f next) cmds++withState :: Monad m => (s -> m a) -> Command m s t -> Command m s t+withState act (Command thisCmd) = Command $ \next -> KeyMap $ \k -> + case lookupKM (thisCmd next) k of+ Nothing -> Nothing+ Just f -> Just $ \s -> case f s of+ Left r -> Left r+ Right effect -> Right $ act s >> effect
+ System/Console/Haskeline/Command/Undo.hs view
@@ -0,0 +1,67 @@+module System.Console.Haskeline.Command.Undo where++import System.Console.Haskeline.Command+import System.Console.Haskeline.LineState+import System.Console.Haskeline.Monads++import Control.Monad+++class LineState s => Save s where+ save :: s -> InsertMode+ restore :: InsertMode -> s++instance Save InsertMode where+ save = id+ restore = id++instance Save CommandMode where+ save = insertFromCommandMode+ restore = enterCommandModeRight++instance Save s => Save (ArgMode s) where+ save = save . argState+ restore = ArgMode 0 . restore+++data Undo = Undo {pastUndo, futureRedo :: [InsertMode]}++type UndoT = StateT Undo++runUndoT :: Monad m => UndoT m a -> m a+runUndoT = evalStateT' initialUndo++initialUndo :: Undo+initialUndo = Undo {pastUndo = [emptyIM], futureRedo = []}+++saveToUndo :: Save s => s -> Undo -> Undo+saveToUndo s undo+ | not isSame = Undo {pastUndo = toSave:pastUndo undo,futureRedo=[]}+ | otherwise = undo+ where+ toSave = save s+ isSame = case pastUndo undo of+ u:_ | u == toSave -> True+ _ -> False++undoPast, redoFuture :: Save s => s -> Undo -> (s,Undo)+undoPast ls u@Undo {pastUndo = []} = (ls,u)+undoPast ls u@Undo {pastUndo = (pastLS:lss)}+ = (restore pastLS, u {pastUndo = lss, futureRedo = save ls : futureRedo u})++redoFuture ls u@Undo {futureRedo = []} = (ls,u)+redoFuture ls u@Undo {futureRedo = (futureLS:lss)}+ = (restore futureLS, u {futureRedo = lss, pastUndo = save ls : pastUndo u})++++saveForUndo :: (Save s, MonadState Undo m)+ => Command m s t -> Command m s t+saveForUndo = withState $ modify . saveToUndo++commandUndo, commandRedo :: (MonadState Undo m, Save s)+ => Key -> Command m s s+commandUndo = simpleCommand $ liftM Change . update . undoPast+commandRedo = simpleCommand $ liftM Change . update . redoFuture+
System/Console/Haskeline/Emacs.hs view
@@ -3,6 +3,7 @@ import System.Console.Haskeline.Command import System.Console.Haskeline.Command.Completion import System.Console.Haskeline.Command.History+import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT @@ -23,7 +24,7 @@ , KeyChar '\b' +> change deletePrev , DeleteForward +> change deleteNext , changeFromChar insertChar- , KeyChar '\t' +> completionCmd+ , saveForUndo $ KeyChar '\t' +> completionCmd , KeyUp +> historyBack , KeyDown +> historyForward , searchHistory@@ -38,12 +39,18 @@ , controlKey 'l' +> clearScreenCmd , metaChar 'f' +> change wordRight , metaChar 'b' +> change wordLeft- , controlKey 'w' +> change (deleteFromMove bigWordLeft)- , KeyMeta Backspace +> change (deleteFromMove wordLeft)- , KeyMeta (KeyChar '\b') +> change (deleteFromMove wordLeft)- , metaChar 'd' +> change (deleteFromMove wordRight)- , controlKey 'k' +> change (deleteFromMove moveToEnd)- , KillLine +> change (deleteFromMove moveToStart)+ , controlKey '_' +> commandUndo+ , controlKey 'x' +> change id + >|> choiceCmd [controlKey 'u' +> commandUndo+ , continue]+ , saveForUndo $ choiceCmd+ [ controlKey 'w' +> change (deleteFromMove bigWordLeft)+ , KeyMeta Backspace +> change (deleteFromMove wordLeft)+ , KeyMeta (KeyChar '\b') +> change (deleteFromMove wordLeft)+ , metaChar 'd' +> change (deleteFromMove wordRight)+ , controlKey 'k' +> change (deleteFromMove moveToEnd)+ , KillLine +> change (deleteFromMove moveToStart)+ ] ] deleteCharOrEOF :: Key -> InputCmd InsertMode InsertMode
System/Console/Haskeline/InputT.hs view
@@ -2,6 +2,7 @@ import System.Console.Haskeline.Command.History+import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.Prefs import System.Console.Haskeline.Command(Layout)@@ -55,18 +56,19 @@ catch f h = InputT $ Monads.catch (unInputT f) (unInputT . h) -- for internal use only-type InputCmdT m = ReaderT Layout (StateT HistLog (ReaderT Prefs (ReaderT (Settings m) m)))+type InputCmdT m = ReaderT Layout (UndoT (StateT HistLog + (ReaderT Prefs (ReaderT (Settings m) m)))) instance MonadIO m => MonadLayout (InputCmdT m) where -runInputCmdT :: forall m a . MonadIO m => TermOps -> InputCmdT m a -> InputT m a+runInputCmdT :: MonadIO m => TermOps -> InputCmdT m a -> InputT m a runInputCmdT tops f = InputT $ do layout <- liftIO $ getLayout tops- lift $ runHistLog $ runReaderT' layout f+ lift $ runHistLog $ runUndoT $ runReaderT' layout f liftCmdT :: Monad m => m a -> InputCmdT m a-liftCmdT = lift . lift . lift . lift+liftCmdT = lift . lift . lift . lift . lift runInputTWithPrefs :: MonadException m => Prefs -> Settings m -> InputT m a -> m a runInputTWithPrefs prefs settings (InputT f) = bracket (liftIO myRunTerm)
System/Console/Haskeline/LineState.hs view
@@ -7,11 +7,16 @@ isTemporary :: s -> Bool isTemporary _ = False +type LineChars = (String,String)++lineChars :: LineState s => String -> s -> LineChars+lineChars prefix s = (beforeCursor prefix s, afterCursor s)++lengthToEnd :: LineChars -> Int+lengthToEnd = length . snd+ class LineState s => Result s where toResult :: s -> String--lengthToEnd :: LineState s => s -> Int-lengthToEnd = length . afterCursor class (Result s) => FromString s where fromString :: String -> s
System/Console/Haskeline/MonadException.hs view
@@ -42,7 +42,7 @@ ) throwDynIO :: (Typeable exception, MonadIO m) => exception -> m a-throwDynIO = liftIO . E.evaluate . E.throwDyn+throwDynIO = liftIO . E.throwIO . E.DynException . toDyn handleDyn :: (Typeable exception, MonadException m) => (exception -> m a) -> m a -> m a
System/Console/Haskeline/Term.hs view
@@ -6,13 +6,13 @@ import Control.Concurrent import Control.Concurrent.STM+import Data.Typeable -class MonadIO m => Term m where- withReposition :: Layout -> m a -> m a- moveToNextLine :: LineState s => s -> m ()+class (MonadReader Layout m, MonadException m) => Term m where+ reposition :: Layout -> LineChars -> m ()+ moveToNextLine :: LineChars -> m () printLines :: [String] -> m ()- drawLineDiff :: (LineState s, LineState r)- => String -> s -> r -> m ()+ drawLineDiff :: LineChars -> LineChars -> m () clearLayout :: m () ringBell :: Bool -> m () @@ -21,6 +21,7 @@ data RunTerm = RunTerm { putStrOut :: String -> IO (), termOps :: Maybe TermOps,+ wrapInterrupt :: MonadException m => m a -> m a, closeTerm :: IO () } @@ -29,7 +30,7 @@ type RunTermType = forall m a . (MonadLayout m, MonadException m) => (forall t . (MonadTrans t, Term (t m), MonadException (t m)) - => (t m Event -> t m a)) -> Bool -> m a+ => (t m Event -> t m a)) -> m a -- Utility function for drawLineDiff instances.@@ -37,6 +38,9 @@ matchInit (x:xs) (y:ys) | x == y = matchInit xs ys matchInit xs ys = (xs,ys) +data Event = WindowResize Layout | KeyInput Key+ deriving Show+ keyEventLoop :: (TChan Event -> IO ()) -> TChan Event -> IO Event keyEventLoop readKey eventChan = do -- first, see if any events are already queued up (from a key/ctrl-c@@ -50,11 +54,13 @@ -- if we receive a different type of event before it's done, -- we'll kill it. tid <- forkIO (readKey eventChan)- e <- atomically $ readTChan eventChan -- key or other event- killThread tid- return e+ (atomically $ readTChan eventChan)+ `finally` killThread tid tryReadTChan :: TChan a -> STM (Maybe a) tryReadTChan chan = fmap Just (readTChan chan) `orElse` return Nothing class (MonadReader Layout m, MonadIO m) => MonadLayout m where++data Interrupt = Interrupt+ deriving (Show,Typeable,Eq)
System/Console/Haskeline/Vi.hs view
@@ -3,6 +3,7 @@ import System.Console.Haskeline.Command import System.Console.Haskeline.Command.Completion import System.Console.Haskeline.Command.History+import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT @@ -26,17 +27,21 @@ , KeyChar '\b' +> change deletePrev , DeleteForward +> change deleteNext , changeFromChar insertChar- , KeyChar '\t' +> completionCmd+ , controlKey 'l' +> clearScreenCmd+ , controlKey 'd' +> eofIfEmpty , KeyUp +> historyBack , KeyDown +> historyForward- , controlKey 'd' +> eofIfEmpty , searchHistory+ , saveForUndo $ choiceCmd+ [ KillLine +> change (deleteFromMove moveToStart)+ , KeyChar '\t' +> completionCmd+ ] ] -- If we receive a ^D and the line is empty, return Nothing -- otherwise, ignore it.-eofIfEmpty :: Key -> InputCmd InsertMode InsertMode-eofIfEmpty k = k +> acceptKeyOrFail (\s -> if s == emptyIM+eofIfEmpty :: Save s => Key -> InputCmd s s+eofIfEmpty k = k +> acceptKeyOrFail (\s -> if save s == emptyIM then Nothing else Just $ Change s >=> continue) @@ -53,21 +58,32 @@ , KeyChar 'a' +> change appendFromCommandMode , KeyChar 'A' +> change (moveToEnd . appendFromCommandMode) , KeyChar 's' +> change (insertFromCommandMode . deleteChar)- , KeyChar 'S' +> change (const emptyIM)- , deleteIOnce , repeated+ , saveForUndo $ choiceCmd+ [ KeyChar 'S' +> change (const emptyIM)+ , deleteIOnce+ ] ] simpleCmdActions :: InputCmd CommandMode CommandMode simpleCmdActions = choiceCmd [ KeyChar '\n' +> finish , KeyChar '\ESC' +> change id -- helps break out of loops+ , controlKey 'd' +> eofIfEmpty , KeyChar 'r' +> replaceOnce , KeyChar 'R' +> loopReplace , KeyChar 'x' +> change deleteChar- , KeyUp +> historyBack- , KeyDown +> historyForward- , deleteOnce+ , controlKey 'l' +> clearScreenCmd+ , KeyChar 'u' +> commandUndo+ , controlKey 'r' +> commandRedo+ , KeyChar '.' +> commandRedo , useMovements withCommandMode+ , KeyDown +> historyForward+ , KeyUp +> historyBack+ , saveForUndo $ choiceCmd+ [ KillLine +> change (withCommandMode+ $ deleteFromMove moveToStart)+ , deleteOnce+ ] ] replaceOnce :: Key -> InputCmd CommandMode CommandMode@@ -92,10 +108,10 @@ applyArg' f am = enterCommandModeRight $ applyArg f $ fmap insertFromCommandMode am loop = choiceCmd [addDigit >|> loop , useMovements applyArg' >|> viCommandActions- , deleteR >|> viCommandActions- , deleteIR- , KeyChar 'x' +> change (applyArg deleteChar)- >|> viCommandActions+ , saveForUndo (deleteR >|> viCommandActions)+ , saveForUndo deleteIR+ , saveForUndo (KeyChar 'x' +> change (applyArg deleteChar)+ >|> viCommandActions) , changeWithoutKey argState >|> viCommandActions ] in start >|> loop
haskeline.cabal view
@@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.2-Version: 0.3.1+Version: 0.3.2 Category: User Interfaces License: BSD3 License-File: LICENSE@@ -42,6 +42,7 @@ -- Note: GADTs are needed to allow contexts of different -- lengths (see code of Haskeline.repeatTillFinish) GADTs+ FunctionalDependencies Exposed-Modules: System.Console.Haskeline System.Console.Haskeline.Completion@@ -57,6 +58,7 @@ System.Console.Haskeline.LineState System.Console.Haskeline.Monads System.Console.Haskeline.Term+ System.Console.Haskeline.Command.Undo System.Console.Haskeline.Vi include-dirs: includes if os(windows) {