haskeline 0.6.1.6 → 0.6.2
raw patch · 29 files changed
+1424/−716 lines, 29 filesdep ~basedep ~containersdep ~directorysetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, containers, directory, terminfo
API changes (from Hackage documentation)
+ System.Console.Haskeline.History: addHistoryRemovingAllDupes :: String -> History -> History
+ System.Console.Haskeline.History: addHistoryUnlessConsecutiveDupe :: String -> History -> History
Files
- CHANGES +23/−0
- Setup.hs +14/−17
- System/Console/Haskeline.hs +22/−111
- System/Console/Haskeline/Backend/DumbTerm.hs +18/−19
- System/Console/Haskeline/Backend/IConv.hsc +2/−2
- System/Console/Haskeline/Backend/Posix.hsc +43/−14
- System/Console/Haskeline/Backend/Terminfo.hs +32/−32
- System/Console/Haskeline/Backend/Win32.hsc +21/−18
- System/Console/Haskeline/Command.hs +108/−102
- System/Console/Haskeline/Command/Completion.hs +94/−88
- System/Console/Haskeline/Command/History.hs +81/−30
- System/Console/Haskeline/Command/KillRing.hs +89/−0
- System/Console/Haskeline/Command/Undo.hs +7/−25
- System/Console/Haskeline/Completion.hs +3/−3
- System/Console/Haskeline/Directory.hsc +9/−1
- System/Console/Haskeline/Emacs.hs +59/−25
- System/Console/Haskeline/History.hs +30/−10
- System/Console/Haskeline/IO.hs +0/−2
- System/Console/Haskeline/InputT.hs +13/−11
- System/Console/Haskeline/Key.hs +3/−1
- System/Console/Haskeline/LineState.hs +241/−53
- System/Console/Haskeline/MonadException.hs +4/−4
- System/Console/Haskeline/Monads.hs +5/−12
- System/Console/Haskeline/Prefs.hs +10/−3
- System/Console/Haskeline/RunCommand.hs +84/−0
- System/Console/Haskeline/Term.hs +25/−8
- System/Console/Haskeline/Vi.hs +364/−113
- configure +0/−2
- haskeline.cabal +20/−10
+ CHANGES view
@@ -0,0 +1,23 @@+Changed in version 0.6.2:++ User interface changes:+ * A multitude of new emacs and vi commands++ * New preference 'historyDuplicates' to prevent storage of duplicate lines++ * Support PageUp and PageDown keys++ * Let ctrl-L (clear-screen) work during getInputChar++ Internal/API changes:+ * Compatibility with ghc-6.12++ * Calculate the correct width for Unicode combining characters++ * Removed RankNTypes requirement; added Rank2Types and UndecidableInstances++ * Use simpleUserHooks instead of autoconfUserHooks in the Setup script++ * Internal refactoring to make command declaration more flexible++ * Read the .haskeline file completely before starting the UI (laziness issue)
Setup.hs view
@@ -14,24 +14,25 @@ import System.Exit import System.Directory import Control.Exception.Extensible+import Control.Monad(when) --- TODO: it's a hack that we use the autoconfUserHooks when we're not actually--- using autoconf... main :: IO () main = defaultMainWithHooks myHooks myHooks :: UserHooks myHooks | buildOS == Windows = simpleUserHooks- | otherwise = autoconfUserHooks {- postConf = \args flags pkgDescr lbi -> do- let Just lib = library pkgDescr- let bi = libBuildInfo lib- bi' <- maybeSetLibiconv flags bi lbi- let pkgDescr' = pkgDescr {+ | 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'}}- postConf simpleUserHooks args flags pkgDescr' lbi+ libBuildInfo = bi'}}} } -- Test whether compiling a c program that links against libiconv needs -liconv.@@ -42,7 +43,6 @@ if hasFlagSet flags (FlagName "libiconv") then do putStrLn "Using -liconv."- writeBuildInfo "iconv" return biWithIconv else do putStr "checking whether to use -liconv... "@@ -51,20 +51,14 @@ if worksWithout then do putStrLn "not needed."- writeBuildInfo "" return bi else do worksWith <- tryCompile iconv_prog biWithIconv lbi verb if worksWith then do putStrLn "using -liconv."- writeBuildInfo "iconv" return biWithIconv else error "Unable to link against the iconv library."- where- -- Cabal (at least 1.6.0.1) won't parse an empty buildinfo file.- writeBuildInfo libs = writeFile "haskeline.buildinfo"- $ unlines ["extra-libraries: " ++ libs] hasFlagSet :: ConfigFlags -> FlagName -> Bool hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags)@@ -112,3 +106,6 @@ , "}" ] +warnIfNotTerminfo flags = when (not (hasFlagSet flags (FlagName "terminfo"))) $+ putStrLn $+ "*** Warning: running on POSIX but not building the terminfo backend. ***"
System/Console/Haskeline.hs view
@@ -69,11 +69,11 @@ import System.Console.Haskeline.Completion import System.Console.Haskeline.Term import System.Console.Haskeline.Key+import System.Console.Haskeline.RunCommand import System.IO-import Data.Char (isSpace)+import Data.Char (isSpace, isPrint) import Control.Monad-import Data.Char(isPrint) import qualified Data.ByteString.Char8 as B import System.IO.Error (isEOFError) @@ -105,7 +105,7 @@ -- | Write a string to the standard output, followed by a newline. outputStrLn :: MonadIO m => String -> InputT m ()-outputStrLn xs = outputStr (xs++"\n")+outputStrLn = outputStr . (++ "\n") {- $inputfncs@@ -143,53 +143,27 @@ 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)- -- Run the main event processing loop- result <- runInputCmdT tops $ runTerm tops- $ \getEvent -> do- let ls = emptyIM- drawLine prefix ls - repeatTillFinish tops getEvent prefix ls emode+ emode <- asks editMode+ result <- runInputCmdT tops $ case emode of+ Emacs -> runCommandLoop tops prefix emacsCommands+ Vi -> evalStateT' emptyViState $+ runCommandLoop tops prefix viKeyCommands maybeAddHistory result return result maybeAddHistory :: forall m . Monad m => Maybe String -> InputT m () maybeAddHistory result = do settings :: Settings m <- ask+ histDupes <- asks historyDuplicates case result of Just line | autoAddHistory settings && not (all isSpace line) - -> modify (addHistory line)+ -> let adder = case histDupes of+ AlwaysAdd -> addHistory+ IgnoreConsecutive -> addHistoryUnlessConsecutiveDupe+ IgnoreAll -> addHistoryRemovingAllDupes+ in modify (adder line) _ -> return () -repeatTillFinish :: forall m s d - . (MonadTrans d, Term (d m), LineState s, MonadReader Prefs m)- => TermOps -> d m Event -> String -> s -> KeyMap m s - -> d m (Maybe String)-repeatTillFinish tops getEvent prefix = loop []- where - loop :: forall t . LineState t- => [Key] -> t -> KeyMap m t -> d m (Maybe String)- loop [] s processor = do- event <- handle (\(e::SomeException) -> movePast prefix s >> throwIO e) getEvent- case event of- ErrorEvent e -> movePast prefix s >> throwIO e- WindowResize -> withReposition tops prefix s $ loop [] s processor- KeyInput k -> do- ks <- lift $ asks $ lookupKeyBinding k- loop ks s processor- loop (k:ks) s processor = case lookupKM processor k of- Nothing -> actBell >> loop [] s processor- Just g -> case g s of- Left r -> movePast prefix s >> return r- Right f -> do- KeyAction effect next <- lift f- drawEffect prefix s effect- loop ks (effectState effect) next- simpleFileLoop :: MonadIO m => String -> RunTerm -> m (Maybe String) simpleFileLoop prefix rterm = liftIO $ do putStrOut rterm prefix@@ -205,52 +179,7 @@ _ -> B.getLine fmap Just $ decodeForTerm rterm line -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) = drawLineStateDiff prefix s t-drawEffect prefix s (PrintLines ls t) = do- if isTemporary s- then clearLine prefix s- else movePast prefix s- printLines ls- drawLine prefix t-drawEffect prefix s (RingBell t) = drawLineStateDiff prefix s t >> actBell -drawLine :: (LineState s, Term m) => String -> s -> m ()-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 = drawLineStateDiff prefix s Cleared- -actBell :: (Term (d m), MonadTrans d, MonadReader Prefs m) => d m ()-actBell = do- style <- lift (asks bellStyle)- case style of- NoBell -> return ()- VisualBell -> ringBell False- AudibleBell -> ringBell True--movePast :: (LineState s, Term m) => String -> s -> m ()-movePast prefix s = moveToNextLine (lineChars prefix s)--withReposition :: (LineState s, Term m) => TermOps -> String -> s -> m a -> m a-withReposition tops prefix s f = do- oldLayout <- ask- newLayout <- liftIO $ getLayout tops- if oldLayout == newLayout- then f- else local newLayout $ do- reposition oldLayout (lineChars prefix s)- f ---------- {- | Reads one character of input. Ignores non-printable characters.@@ -305,34 +234,16 @@ then return x else throwIO e --- TODO: it might be possible to unify this function with getInputCmdLine,--- maybe by calling repeatTillFinish here...--- It shouldn't be too hard to make Commands parametrized over a return--- value (which would be Maybe Char in this case).--- My primary obstacle is that there's currently no way to have a--- single character input cause a character to be printed and then--- immediately exit without waiting for Return to be pressed. getInputCmdChar :: MonadException m => TermOps -> String -> InputT m (Maybe Char)-getInputCmdChar tops prefix = runInputCmdT tops $ runTerm tops $ \getEvent -> do- drawLine prefix emptyIM- loop getEvent- where- s = emptyIM- loop :: Term m => m Event -> m (Maybe Char)- loop getEvent = do- event <- handle (\(e::SomeException) -> movePast prefix emptyIM >> throwIO e) getEvent- case event of- KeyInput (Key m (KeyChar c))- | m /= noModifier -> loop getEvent- | c == '\EOT' -> movePast prefix s >> return Nothing- | isPrint c -> do- let s' = insertChar c s- drawLineStateDiff prefix s s'- movePast prefix s'- return (Just c)- WindowResize -> withReposition tops prefix emptyIM $ loop getEvent- _ -> loop getEvent+getInputCmdChar tops prefix = runInputCmdT tops + $ runCommandLoop tops prefix acceptOneChar +acceptOneChar :: Monad m => KeyCommand m InsertMode (Maybe Char)+acceptOneChar = choiceCmd [useChar $ \c s -> change (insertChar c) s+ >> return (Just c)+ , ctrlChar 'l' +> clearScreenCmd >|>+ keyCommand acceptOneChar+ , ctrlChar 'd' +> failCmd] ------------ -- Interrupt
System/Console/Haskeline/Backend/DumbTerm.hs view
@@ -24,9 +24,7 @@ MonadState Window, MonadReader Handle, MonadReader Encoders) -instance MonadReader Layout m => MonadReader Layout (DumbTerm m) where- ask = lift ask- local r = DumbTerm . local r . unDumbTerm+type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a instance MonadTrans DumbTerm where lift = DumbTerm . lift . lift . lift@@ -36,19 +34,20 @@ ch <- newChan posixRunTerm $ \enc h -> TermOps {- getLayout = tryGetLayouts (posixLayouts h),- runTerm = \f -> - runPosixT enc h $ evalStateT' initWindow- $ unDumbTerm- $ withPosixGetEvent ch enc [] f+ getLayout = tryGetLayouts (posixLayouts h)+ , withGetEvent = withPosixGetEvent ch h enc []+ , runTerm = \(RunTermType f) -> + runPosixT enc h+ $ evalStateT' initWindow+ $ unDumbTerm f } -instance (MonadException m, MonadLayout m) => Term (DumbTerm m) where+instance (MonadException m, MonadReader Layout m) => Term (DumbTerm m) where reposition _ s = refitLine s drawLineDiff = drawLineDiff' - printLines = mapM_ (\s -> printText (s ++ crlf))- moveToNextLine = \_ -> printText crlf+ printLines = mapM_ (printText . (++ crlf))+ moveToNextLine _ = printText crlf clearLayout = clearLayoutD ringBell True = printText "\a" ringBell False = return ()@@ -69,16 +68,16 @@ spaces n = replicate n ' ' -clearLayoutD :: MonadLayout m => DumbTerm m ()+clearLayoutD :: DumbTermM () clearLayoutD = do w <- maxWidth printText (cr ++ spaces w ++ cr) -- Don't want to print in the last column, as that may wrap to the next line.-maxWidth :: MonadLayout m => DumbTerm m Int+maxWidth :: DumbTermM Int maxWidth = asks (\lay -> width lay - 1) -drawLineDiff' :: MonadLayout m => LineChars -> LineChars -> DumbTerm m ()+drawLineDiff' :: LineChars -> LineChars -> DumbTermM () drawLineDiff' (xs1,ys1) (xs2,ys2) = do Window {pos=p} <- get w <- maxWidth@@ -94,15 +93,15 @@ (_,[]) | xs1' ++ ys1 == ys2 -> -- moved left printText $ backs (length xs1') ([],_) | ys1 == xs2' ++ ys2 -> -- moved right- printText xs2'+ printText (graphemesToString xs2') _ -> let extraLength = length xs1' + length ys1 - length xs2' - length ys2 in printText $ backs (length xs1')- ++ xs2' ++ ys2' ++ clearDeadText extraLength+ ++ graphemesToString (xs2' ++ ys2') ++ clearDeadText extraLength ++ backs (length ys2') -refitLine :: MonadLayout m => (String,String) -> DumbTerm m ()+refitLine :: ([Grapheme],[Grapheme]) -> DumbTermM () refitLine (xs,ys) = do w <- maxWidth let xs' = dropFrames w xs@@ -110,12 +109,12 @@ put Window {pos=p} let ys' = take (w - p) ys let k = length ys'- printText $ cr ++ xs' ++ ys'+ printText $ cr ++ graphemesToString (xs' ++ ys') ++ spaces (w-k-p) ++ backs (w-p) where dropFrames w zs = case splitAt w zs of- (_,"") -> zs+ (_,[]) -> zs (_,zs') -> dropFrames w zs' clearDeadText :: Int -> String
System/Console/Haskeline/Backend/IConv.hsc view
@@ -145,8 +145,8 @@ createAndTrim' outSize $ \outPtr -> with outPtr $ \outBuff -> with (toEnum outSize) $ \outBytesLeft -> do- c_iconv cd_p inBuff inBytesLeft- (castPtr outBuff) outBytesLeft+ -- 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
System/Console/Haskeline/Backend/Posix.hsc view
@@ -16,7 +16,6 @@ import System.Posix.Terminal hiding (Interrupt) import Control.Monad import Control.Concurrent hiding (throwTo)-import Control.Concurrent.Chan import Data.Maybe (catMaybes) import System.Posix.Signals.Exts import System.Posix.IO(stdInput)@@ -33,8 +32,18 @@ import System.Console.Haskeline.Backend.IConv -import GHC.IOBase (haFD,FD)+#if __GLASGOW_HASKELL__ >= 611+import GHC.IO.FD (fdFD)+import Data.Dynamic (cast)+import System.IO.Error+import GHC.IO.Exception+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 #ifdef USE_TERMIOS_H #include <termios.h>@@ -60,7 +69,17 @@ else return Nothing unsafeHandleToFD :: Handle -> IO FD+#if __GLASGOW_HASKELL__ >= 611+unsafeHandleToFD h =+ withHandle_ "unsafeHandleToFd" h $ \Handle__{haDevice=dev} -> do+ case cast dev of+ Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation+ "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@@ -163,10 +182,11 @@ ----------------------------- -withPosixGetEvent :: (MonadTrans t, MonadIO m, MonadException (t m), MonadReader Prefs m) - => Chan Event -> Encoders -> [(String,Key)] -> (t m Event -> t m a) -> t m a-withPosixGetEvent eventChan enc termKeys f = do- baseMap <- lift $ getKeySequences termKeys+withPosixGetEvent :: (MonadException m, MonadReader Prefs m) + => Chan Event -> Handle -> Encoders -> [(String,Key)]+ -> (m Event -> m a) -> m a+withPosixGetEvent eventChan h enc termKeys f = wrapTerminalOps h $ do+ baseMap <- getKeySequences termKeys withWindowHandler eventChan $ f $ liftIO $ getEvent enc baseMap eventChan @@ -194,12 +214,23 @@ -- Read at least one character of input, and more if available. -- In particular, the characters making up a control sequence will all -- be available at once, so we can process them together with lexKeys.- threadWaitRead stdInput -- hWaitForInput doesn't work with -threaded on- -- ghc < 6.10 (#2363 in ghc's trac)+ blockUntilInput bs <- B.hGetNonBlocking stdin bufferSize cs <- convert (localeToUnicode enc) bs return $ map KeyInput $ lexKeys baseMap cs +-- Different versions of ghc work better using different functions.+blockUntilInput :: IO ()+#if __GLASGOW_HASKELL__ >= 611+-- threadWaitRead doesn't work with the new ghc IO library,+-- because it keeps a buffer even when NoBuffering is set.+blockUntilInput = hWaitForInput stdin (-1) >> return ()+#else+-- hWaitForInput doesn't work with -threaded on ghc < 6.10+-- (#2363 in ghc's trac)+blockUntilInput = threadWaitRead stdInput+#endif+ -- try to convert to the locale encoding using iconv. -- if the buffer has an incomplete shift sequence, -- read another byte of input and try again.@@ -231,7 +262,9 @@ inIsTerm <- hIsTerminalDevice stdin if inIsTerm then handle (\(_::IOException) -> return Nothing) $ do- h <- openFile "/dev/tty" WriteMode+ -- NB: we open the tty as a binary file since otherwise the terminfo+ -- backend, which writes output as Chars, would double-encode on ghc-6.12.+ h <- openBinaryFile "/dev/tty" WriteMode return (Just h) else return Nothing @@ -246,7 +279,7 @@ Just h -> return fileRT { closeTerm = closeTerm fileRT >> hClose h, -- NOTE: could also alloc Encoders once for each call to wrapRunTerm- termOps = Just (wrapRunTerm (wrapTerminalOps h) (tOps encoders h))+ termOps = Just $ tOps encoders h } type PosixT m = ReaderT Encoders (ReaderT Handle m)@@ -289,10 +322,6 @@ bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering . bracketSet (hGetBuffering outH) (hSetBuffering outH) LineBuffering . bracketSet (hGetEcho stdin) (hSetEcho stdin) False--wrapRunTerm :: (forall m a . MonadException m => m a -> m a) -> TermOps -> TermOps-wrapRunTerm wrap tops = tops {runTerm = \getE -> wrap (runTerm tops getE)- } bracketSet :: (Eq a, MonadException m) => IO a -> (a -> IO ()) -> a -> m b -> m b bracketSet getState set newState f = bracket (liftIO getState)
System/Console/Haskeline/Backend/Terminfo.hs view
@@ -10,7 +10,7 @@ import System.IO import qualified Control.Exception.Extensible as Exception import qualified Data.ByteString.Char8 as B-import Data.Maybe (fromMaybe, catMaybes)+import Data.Maybe (fromMaybe, mapMaybe) import Control.Concurrent.Chan import System.Console.Haskeline.Monads as Monads@@ -66,12 +66,12 @@ type TermAction = Actions -> TermOutput left,right,up :: Int -> TermAction-left n = flip leftA n-right n = flip rightA n-up n = flip upA n+left = flip leftA+right = flip rightA+up = flip upA clearAll :: LinesAffected -> TermAction-clearAll la = flip clearAllA la+clearAll = flip clearAllA -------- @@ -99,9 +99,7 @@ MonadReader Actions, MonadReader Terminal, MonadState TermPos, MonadReader Handle, MonadReader Encoders) -instance MonadReader Layout m => MonadReader Layout (Draw m) where- ask = lift ask- local r = Draw . local r . unDraw+type DrawM a = forall m . (MonadReader Layout m, MonadIO m) => Draw m a instance MonadTrans Draw where lift = Draw . lift . lift . lift . lift . lift@@ -119,15 +117,16 @@ Just actions -> fmap Just $ posixRunTerm $ \enc h -> TermOps { getLayout = tryGetLayouts (posixLayouts h- ++ [tinfoLayout term]),- runTerm = \f ->+ ++ [tinfoLayout term])+ , withGetEvent = wrapKeypad h term+ . withPosixGetEvent ch h enc+ (terminfoKeys term)+ , runTerm = \(RunTermType f) -> runPosixT enc h $ evalStateT' initTermPos $ runReaderT' term $ runReaderT' actions- $ unDraw- $ wrapKeypad h term- $ withPosixGetEvent ch enc (terminfoKeys term) f+ $ unDraw f } -- If the keypad on/off capabilities are defined, wrap the computation with them.@@ -135,8 +134,8 @@ wrapKeypad h term f = (maybeOutput keypadOn >> f) `finally` maybeOutput keypadOff where- maybeOutput cap = liftIO $ hRunTermOutput h term $- fromMaybe mempty (getCapability term cap)+ maybeOutput = liftIO . hRunTermOutput h term .+ fromMaybe mempty . getCapability term tinfoLayout :: Terminal -> IO (Maybe Layout) tinfoLayout term = return $ getCapability term $ do@@ -145,7 +144,7 @@ return Layout {height=r,width=c} terminfoKeys :: Terminal -> [(String,Key)]-terminfoKeys term = catMaybes $ map getSequence keyCapabilities+terminfoKeys term = mapMaybe getSequence keyCapabilities where getSequence (cap,x) = do keys <- getCapability term cap@@ -159,6 +158,8 @@ ,(keyDeleteChar, simpleKey Delete) ,(keyHome, simpleKey Home) ,(keyEnd, simpleKey End)+ ,(keyPageDown, simpleKey PageDown)+ ,(keyPageUp, simpleKey PageUp) ] @@ -171,7 +172,7 @@ -changeRight, changeLeft :: MonadLayout m => Int -> Draw m ()+changeRight, changeLeft :: Int -> DrawM () changeRight n = do w <- asks width TermPos {termRow=r,termCol=c} <- get@@ -201,30 +202,30 @@ output $ cr <#> up linesUp <#> right newCol -- TODO: I think if we wrap this all up in one call to output, it'll be faster...-printText :: MonadLayout m => String -> Draw m ()-printText "" = return ()+printText :: [Grapheme] -> DrawM ()+printText [] = return () printText xs = fillLine xs >>= printText -- Draws as much of the string as possible in the line, and returns the rest. -- If we fill up the line completely, wrap to the next row.-fillLine :: MonadLayout m => String -> Draw m String+fillLine :: [Grapheme] -> DrawM [Grapheme] fillLine str = do w <- asks width TermPos {termRow=r,termCol=c} <- get let roomLeft = w - c if length str < roomLeft then do- posixEncode str >>= output . text+ posixEncode (graphemesToString str) >>= output . text put TermPos{termRow=r, termCol=c+length str}- return ""+ return [] else do let (thisLine,rest) = splitAt roomLeft str- bstr <- posixEncode thisLine+ bstr <- posixEncode (graphemesToString thisLine) output (text bstr <#> wrapLine) put TermPos {termRow=r+1,termCol=0} return rest -drawLineDiffT :: MonadLayout m => LineChars -> LineChars -> Draw m ()+drawLineDiffT :: LineChars -> LineChars -> DrawM () drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of ([],[]) | ys1 == ys2 -> return () (xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (length xs1')@@ -242,9 +243,9 @@ | otherwise = 1 + div (c+n) w lsLinesLeft :: Layout -> TermPos -> LineChars -> Int-lsLinesLeft layout pos s = linesLeft layout pos (lengthToEnd s)+lsLinesLeft layout pos = linesLeft layout pos . lengthToEnd -clearDeadText :: MonadLayout m => Int -> Draw m ()+clearDeadText :: Int -> DrawM () clearDeadText n | n <= 0 = return () | otherwise = do@@ -258,30 +259,29 @@ , up (numLinesToClear - 1) , right (termCol pos)] -clearLayoutT :: MonadLayout m => Draw m ()+clearLayoutT :: DrawM () clearLayoutT = do h <- asks height output (clearAll h) put initTermPos -moveToNextLineT :: MonadLayout m => LineChars -> Draw m ()+moveToNextLineT :: LineChars -> DrawM () moveToNextLineT s = do pos <- get layout <- ask output $ mreplicate (lsLinesLeft layout pos s) nl put initTermPos -repositionT :: (MonadLayout m, MonadException m) =>- Layout -> LineChars -> Draw m ()+repositionT :: Layout -> LineChars -> DrawM () repositionT oldLayout s = do oldPos <- get let l = lsLinesLeft oldLayout oldPos s - 1 output $ cr <#> mreplicate l nl <#> mreplicate (l + termRow oldPos) (clearToLineEnd <#> up 1) put initTermPos- drawLineDiffT ("","") s+ drawLineDiffT ([],[]) s -instance (MonadException m, MonadLayout m) => Term (Draw m) where+instance (MonadException m, MonadReader Layout m) => Term (Draw m) where drawLineDiff = drawLineDiffT reposition = repositionT
System/Console/Haskeline/Backend/Win32.hsc view
@@ -10,8 +10,6 @@ import Graphics.Win32.Misc(getStdHandle, sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE) import Data.List(intercalate) import Control.Concurrent hiding (throwTo) -import Control.Concurrent.Chan -import Data.Bits import Data.Char(isPrint) import Data.Maybe(mapMaybe) import Control.Monad @@ -93,6 +91,8 @@ keyFromCode (#const VK_DELETE) = Just Delete keyFromCode (#const VK_HOME) = Just Home keyFromCode (#const VK_END) = Just End +keyFromCode (#const VK_PRIOR) = Just PageUp +keyFromCode (#const VK_NEXT) = Just PageDown -- The Windows console will return '\r' when return is pressed. keyFromCode (#const VK_RETURN) = Just (KeyChar '\n') -- TODO: KillLine? @@ -232,13 +232,11 @@ newtype Draw m a = Draw {runDraw :: ReaderT HANDLE m a} deriving (Monad,MonadIO,MonadException, MonadReader HANDLE) +type DrawM a = (MonadIO m, MonadReader Layout m) => Draw m () + instance MonadTrans Draw where lift = Draw . lift -instance MonadReader Layout m => MonadReader Layout (Draw m) where - ask = lift ask - local r = Draw . local r . runDraw - getPos :: MonadIO m => Draw m Coord getPos = ask >>= liftIO . getPosition @@ -252,12 +250,12 @@ h <- ask liftIO (writeConsole h txt) -printAfter :: MonadLayout m => String -> Draw m () +printAfter :: String -> DrawM () printAfter str = do printText str movePos $ negate $ length str -drawLineDiffWin :: MonadLayout m => LineChars -> LineChars -> Draw m () +drawLineDiffWin :: LineChars -> LineChars -> DrawM () drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of ([],[]) | ys1 == ys2 -> return () (xs1',[]) | xs1' ++ ys1 == ys2 -> movePos $ negate $ length xs1' @@ -266,10 +264,10 @@ movePos (negate $ length xs1') let m = length xs1' + length ys1 - (length xs2' + length ys2) let deadText = replicate m ' ' - printText xs2' - printAfter (ys2 ++ deadText) + printText (graphemesToString xs2') + printAfter (graphemesToString ys2 ++ deadText) -movePos :: MonadLayout m => Int -> Draw m () +movePos :: Int -> DrawM () movePos n = do Coord {coordX = x, coordY = y} <- getPos w <- asks width @@ -279,7 +277,7 @@ crlf :: String crlf = "\r\n" -instance (MonadException m, MonadLayout m) => Term (Draw m) where +instance (MonadException m, MonadReader Layout m) => Term (Draw m) where drawLineDiff = drawLineDiffWin -- TODO now that we capture resize events. -- first, looks like the cursor stays on the same line but jumps @@ -317,14 +315,17 @@ return fileRT { wrapInterrupt = withWindowMode . withCtrlCHandler, termOps = Just TermOps { - getLayout = getBufferSize h, - runTerm = consoleRunTerm h ch}, + getLayout = getBufferSize h + , withGetEvent = win32WithEvent ch + , runTerm = \(RunTermType f) -> + runReaderT' h $ runDraw f + }, closeTerm = closeHandle h} -consoleRunTerm :: HANDLE -> Chan Event -> RunTermType -consoleRunTerm conOut eventChan f = do +win32WithEvent :: MonadException m => Chan Event -> (m Event -> m a) -> m a +win32WithEvent eventChan f = do inH <- liftIO $ getStdHandle sTD_INPUT_HANDLE - runReaderT' conOut $ runDraw $ f $ liftIO $ getEvent inH eventChan + f $ liftIO $ getEvent inH eventChan -- stdin is not a terminal, but we still need to check the right way to output unicode to stdout. fileRunTerm :: IO RunTerm @@ -366,7 +367,9 @@ withCtrlCHandler f = bracket (liftIO $ do tid <- myThreadId fp <- wrapHandler (handler tid) - c_SetConsoleCtrlHandler fp True + -- don't fail if we can't set the ctrl-c handler + -- for example, we might not be attached to a console? + _ <- c_SetConsoleCtrlHandler fp True return fp) (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False) (const f)
System/Console/Haskeline/Command.hs view
@@ -1,152 +1,158 @@ module System.Console.Haskeline.Command( -- * Commands Effect(..),- KeyMap(), - lookupKM,- KeyAction(..),- CmdAction(..),- (>=>),- Command(),- runCommand,- continue,+ KeyMap(..), + CmdM(..),+ Command,+ KeyCommand,+ KeyConsumed(..),+ withoutConsuming,+ keyCommand, (>|>), (>+>),- acceptKey,- acceptKeyM,- acceptKeyOrFail,- loopUntil, try,+ effect,+ clearScreenCmd, finish, failCmd, simpleCommand, charCommand,+ setState, change, changeFromChar,- changeWithoutKey,- clearScreenCmd, (+>),+ useChar, choiceCmd,- withState+ keyChoiceCmd,+ keyChoiceCmdM,+ doBefore ) where import Data.Char(isPrint)-import Control.Monad(mplus)+import Control.Monad(mplus, liftM)+import Control.Monad.Trans import System.Console.Haskeline.LineState import System.Console.Haskeline.Key +data Effect = LineChange (String -> LineChars)+ | PrintLines [String]+ | ClearScreen+ | RingBell -data Effect s = Change {effectState :: s} - | PrintLines {linesToPrint :: [String], effectState :: s}- | Redraw {shouldClearScreen :: Bool, effectState :: s}- | RingBell {effectState :: s}+lineChange :: LineState s => s -> Effect+lineChange = LineChange . flip lineChars -newtype KeyMap m s = KeyMap {lookupKM :: Key -> Maybe - (s -> Either (Maybe String) (m (KeyAction m)))}+data KeyMap a = KeyMap {lookupKM :: Key -> Maybe (KeyConsumed a)} -useKey :: Key -> (s -> Either (Maybe String) (m (KeyAction m))) -> KeyMap m s-useKey k f = KeyMap $ \k' -> if k==k' then Just f else Nothing+data KeyConsumed a = NotConsumed a | Consumed a -data KeyAction m = forall t . LineState t => KeyAction (Effect t) (KeyMap m t)+instance Functor KeyMap where+ fmap f km = KeyMap $ fmap (fmap f) . lookupKM km -nullKM :: KeyMap m s-nullKM = KeyMap $ const Nothing+instance Functor KeyConsumed where+ fmap f (NotConsumed x) = NotConsumed (f x)+ fmap f (Consumed x) = Consumed (f x) -orKM :: KeyMap m s -> KeyMap m s -> KeyMap m s-orKM (KeyMap m) (KeyMap n) = KeyMap $ \k -> m k `mplus` n k -choiceKM :: [KeyMap m s] -> KeyMap m s-choiceKM = foldl orKM nullKM+data CmdM m a = GetKey (KeyMap (CmdM m a))+ | DoEffect Effect (CmdM m a)+ | CmdM (m (CmdM m a))+ | Result a -newtype Command m s t = Command (KeyMap m t -> KeyMap m s)+type Command m s t = s -> CmdM m t -runCommand :: Command m s s -> KeyMap m s-runCommand (Command f) = let m = f m in m+instance Monad m => Monad (CmdM m) where+ return = Result -continue :: Command m s s-continue = Command id+ GetKey km >>= g = GetKey $ fmap (>>= g) km+ DoEffect e f >>= g = DoEffect e (f >>= g)+ CmdM f >>= g = CmdM $ liftM (>>= g) f+ Result x >>= g = g x -infixl 6 >|>-(>|>) :: Command m s t -> Command m t u -> Command m s u-Command f >|> Command g = Command (f . g)+type KeyCommand m s t = KeyMap (Command m s t) -infixl 6 >+>-(>+>) :: (Monad m, LineState s) => Key -> Command m s t -> Command m s t-k >+> f = k +> change id >|> f+instance MonadTrans CmdM where+ lift m = CmdM $ do+ x <- m+ return $ Result x -data CmdAction m s = forall t . LineState t => CmdAction (Effect t) (Command m t s)+keyCommand :: KeyCommand m s t -> Command m s t+keyCommand km = \s -> GetKey $ fmap ($ s) km -(>=>) :: LineState t => Effect t -> Command m t s -> CmdAction m s-(>=>) = CmdAction+useKey :: Key -> a -> KeyMap a+useKey k x = KeyMap $ \k' -> if k==k' then Just (Consumed x) else Nothing -acceptKey :: (Monad m) => (s -> CmdAction m t) -> Key -> Command m s t-acceptKey f = acceptKeyFull (Just . return . f)+-- TODO: could just be a monadic action that returns a Char.+useChar :: (Char -> Command m s t) -> KeyCommand m s t+useChar act = KeyMap $ \k -> case k of+ Key m (KeyChar c) | isPrint c && m==noModifier+ -> Just $ Consumed (act c)+ _ -> Nothing -acceptKeyM :: Monad m => (s -> m (CmdAction m t)) -> Key -> Command m s t-acceptKeyM f = acceptKeyFull (Just . f)+withoutConsuming :: Command m s t -> KeyCommand m s t+withoutConsuming = KeyMap . const . Just . NotConsumed -acceptKeyFull :: Monad m => (s -> Maybe (m (CmdAction m t)))- -> Key -> Command m s t-acceptKeyFull f k = Command $ \next -> useKey k $ \s -> case f s of- Nothing -> Left Nothing- Just act -> Right $ do- CmdAction effect (Command g) <- act- return (KeyAction effect (g next))+choiceCmd :: [KeyMap a] -> KeyMap a+choiceCmd = foldl orKM nullKM+ where+ nullKM = KeyMap $ const Nothing+ orKM (KeyMap f) (KeyMap g) = KeyMap $ \k -> f k `mplus` g k -acceptKeyOrFail :: Monad m => (s -> Maybe (CmdAction m t)) -> Key- -> Command m s t-acceptKeyOrFail f = acceptKeyFull (fmap return . f)- -loopUntil :: Command m s s -> Command m s t -> Command m s t-loopUntil f g = choiceCmd [g, f >|> loopUntil f g]+keyChoiceCmd :: [KeyCommand m s t] -> Command m s t+keyChoiceCmd = keyCommand . choiceCmd -try :: Command m s s -> Command m s s-try (Command f) = Command $ \next -> f next `orKM` next+keyChoiceCmdM :: [KeyMap (CmdM m a)] -> CmdM m a+keyChoiceCmdM = GetKey . choiceCmd -finish :: forall s m t . (Result s, Monad m) => Key -> Command m s t-finish k = Command $ \_-> useKey k (Left . Just . toResult)+infixr 6 >|>+(>|>) :: Monad m => Command m s t -> Command m t u -> Command m s u+f >|> g = \x -> f x >>= g -failCmd :: forall s m t . (LineState s, Monad m) => Key -> Command m s t-failCmd k = Command $ \_-> useKey k (const $ Left Nothing)+infixr 6 >+>+(>+>) :: Monad m => KeyCommand m s t -> Command m t u -> KeyCommand m s u+km >+> g = fmap (>|> g) km -simpleCommand :: (LineState t, Monad m) => (s -> m (Effect t)) - -> Key -> Command m s t-simpleCommand f = acceptKeyM $ \s -> do- act <- f s- return (act >=> continue)+-- attempt to run the command (predicated on getting a valid key); but if it fails, just keep+-- going.+try :: Monad m => KeyCommand m s s -> Command m s s+try f = keyChoiceCmd [f,withoutConsuming return] -charCommand :: (LineState t, Monad m) => (Char -> s -> m (Effect t))- -> Command m s t-charCommand f = Command $ \next -> KeyMap $ \k -> case k of- Key m (KeyChar c) | isPrint c && m==noModifier-> Just $ \s -> Right $ do- effect <- f c s- return (KeyAction effect next)- _ -> Nothing- +infixr 6 +>+(+>) :: Key -> a -> KeyMap a+(+>) = useKey -change :: (LineState t, Monad m) => (s -> t) -> Key -> Command m s t-change f = simpleCommand (return . Change . f)+finish :: (Monad m, Result s) => Command m s (Maybe String)+finish = return . Just . toResult -changeFromChar :: (Monad m, LineState t) => (Char -> s -> t) -> Command m s t-changeFromChar f = charCommand (\c s -> return $ Change (f c s))+failCmd :: Monad m => Command m s (Maybe a)+failCmd _ = return Nothing -changeWithoutKey :: (s -> t) -> Command m s t-changeWithoutKey f = Command $ \(KeyMap next) -> KeyMap $ fmap (. f) . next+effect :: Effect -> CmdM m ()+effect e = DoEffect e $ Result () -clearScreenCmd :: (LineState s, Monad m) => Key -> Command m s s-clearScreenCmd k = k +> simpleCommand (\s -> return (Redraw True s))+clearScreenCmd :: Command m s s+clearScreenCmd = DoEffect ClearScreen . Result -infixl 7 +>-(+>) :: Key -> (Key -> a) -> a -k +> f = f k+simpleCommand :: (LineState s, Monad m) => (s -> m (Either Effect s))+ -> Command m s s+simpleCommand f = \s -> do+ et <- lift (f s)+ case et of+ Left e -> effect e >> return s+ Right t -> setState t -choiceCmd :: [Command m s t] -> Command m s t-choiceCmd cmds = Command $ \next -> - choiceKM $ map (\(Command f) -> f next) cmds+charCommand :: (LineState s, Monad m) => (Char -> s -> m (Either Effect s))+ -> KeyCommand m s s+charCommand f = useChar $ simpleCommand . f -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+setState :: (Monad m, LineState s) => Command m s s+setState s = effect (lineChange s) >> return s++change :: (LineState t, Monad m) => (s -> t) -> Command m s t+change = (setState .)++changeFromChar :: (LineState t, Monad m) => (Char -> s -> t) -> KeyCommand m s t+changeFromChar f = useChar $ change . f++doBefore :: Monad m => Command m s t -> KeyCommand m t u -> KeyCommand m s u+doBefore cmd = fmap (cmd >|>)
System/Console/Haskeline/Command/Completion.hs view
@@ -6,107 +6,115 @@ ) where import System.Console.Haskeline.Command+import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.Key-import System.Console.Haskeline.Term(Layout(..))+import System.Console.Haskeline.Term (Layout(..), CommandMonad(..)) import System.Console.Haskeline.LineState-import System.Console.Haskeline.InputT import System.Console.Haskeline.Prefs import System.Console.Haskeline.Completion import System.Console.Haskeline.Monads import Data.List(transpose, unfoldr) -fullReplacement :: Completion -> String-fullReplacement c | isFinished c = replacement c ++ " "- | otherwise = replacement c+useCompletion :: InsertMode -> Completion -> InsertMode+useCompletion im c = insertString r im+ where r | isFinished c = replacement c ++ " "+ | otherwise = replacement c -makeCompletion :: Monad m => InsertMode -> InputCmdT m (InsertMode, [Completion])-makeCompletion (IMode xs ys) = do- f <- asks complete- (rest,completions) <- liftCmdT (f (xs, ys))- return (IMode rest ys,completions)+askIMCompletions :: CommandMonad m => + Command m InsertMode (InsertMode, [Completion])+askIMCompletions (IMode xs ys) = do+ (rest, completions) <- runCompletion (withRev graphemesToString xs,+ graphemesToString ys)+ return (IMode (withRev stringToGraphemes rest) ys, completions)+ where+ withRev f = reverse . f . reverse -- | Create a 'Command' for word completion.-completionCmd :: Monad m => Key -> Command (InputCmdT m) InsertMode InsertMode-completionCmd k = k +> acceptKeyM (\s -> do+completionCmd :: (MonadState Undo m, CommandMonad m)+ => Key -> KeyCommand m InsertMode InsertMode+completionCmd k = k +> saveForUndo >|> \oldIM -> do+ (rest,cs) <- askIMCompletions oldIM+ case cs of+ [] -> effect RingBell >> return oldIM+ [c] -> setState $ useCompletion rest c+ _ -> presentCompletions k oldIM rest cs++presentCompletions :: (MonadReader Prefs m, MonadReader Layout m)+ => Key -> InsertMode -> InsertMode+ -> [Completion] -> CmdM m InsertMode+presentCompletions k oldIM rest cs = do prefs <- ask- (rest,completions) <- makeCompletion s case completionType prefs of- MenuCompletion -> return $ menuCompletion k s- $ map (\c -> insertString (fullReplacement c) rest) completions- ListCompletion -> - pagingCompletion prefs s rest completions k)+ MenuCompletion -> menuCompletion k (map (useCompletion rest) cs) oldIM+ ListCompletion -> do+ withPartial <- setState $ makePartialCompletion rest cs+ if withPartial /= oldIM+ then return withPartial+ else pagingCompletion k prefs cs withPartial -pagingCompletion :: Monad m => Prefs- -> InsertMode -> InsertMode -> [Completion] - -> Key -> InputCmdT m (CmdAction (InputCmdT m) InsertMode)-pagingCompletion _ oldIM _ [] _ = return $ RingBell oldIM >=> continue-pagingCompletion _ _ im [newWord] _ - = return $ (Change $ insertString (fullReplacement newWord) im) >=> continue-pagingCompletion prefs oldIM im completions k- | oldIM /= withPartial = return $ Change withPartial >=> continue- | otherwise = do- layout <- ask- let wordLines = makeLines (map display completions) layout- printingCmd <- if completionPaging prefs- then printPage wordLines moreMessage- else return $ printAll wordLines withPartial- let pageAction = askFirst (completionPromptLimit prefs) (length completions) - withPartial printingCmd- if listCompletionsImmediately prefs- then return pageAction- else return $ RingBell withPartial >=> - try (k +> acceptKey (const pageAction))+menuCompletion :: Monad m => Key -> [InsertMode] -> Command m InsertMode InsertMode+menuCompletion k = loop+ where+ loop [] = setState+ loop (c:cs) = change (const c) >|> try (k +> loop cs)++makePartialCompletion :: InsertMode -> [Completion] -> InsertMode+makePartialCompletion im completions = insertString partial im where- withPartial = insertString partial im partial = foldl1 commonPrefix (map replacement completions) commonPrefix (c:cs) (d:ds) | c == d = c : commonPrefix cs ds commonPrefix _ _ = ""- moreMessage = Message withPartial "----More----" -askFirst :: Monad m => Maybe Int -> Int -> InsertMode- -> CmdAction (InputCmdT m) InsertMode- -> CmdAction (InputCmdT m) InsertMode-askFirst mlimit numCompletions im printingCmd = case mlimit of- Just limit | limit < numCompletions -> - Change (Message im ("Display all " ++ show numCompletions- ++ " possibilities? (y or n)"))- >=> choiceCmd [- simpleChar 'y' +> acceptKey (const printingCmd)- , simpleChar 'n' +> change messageState- ]- _ -> printingCmd--printOneLine :: Monad m => [String] -> Message InsertMode -> CmdAction (InputCmdT m) InsertMode-printOneLine (w:ws) im | not (null ws) =- PrintLines [w] im >=> pagingCommands ws-printOneLine _ im = Change (messageState im) >=> continue--printPage :: Monad m => [String] -> Message InsertMode- -> InputCmdT m (CmdAction (InputCmdT m) InsertMode)-printPage ws im = do- layout <- ask- return $ case splitAt (height layout - 1) ws of- (_,[]) -> PrintLines ws (messageState im) >=> continue- (zs,rest) -> PrintLines zs im- >=> pagingCommands rest----- TODO: move testing of nullity into here-pagingCommands :: Monad m => [String] -> Command (InputCmdT m) (Message InsertMode) InsertMode-pagingCommands ws = choiceCmd [- simpleChar ' ' +> acceptKeyM (printPage ws)- ,simpleChar 'q' +> change messageState- ,simpleChar '\n' +> acceptKey (printOneLine ws)- ,simpleKey DownKey +> acceptKey (printOneLine ws)- ]+pagingCompletion :: MonadReader Layout m => Key -> Prefs+ -> [Completion] -> Command m InsertMode InsertMode+pagingCompletion k prefs completions = \im -> do+ ls <- asks $ makeLines (map display completions)+ let pageAction = do+ askFirst prefs (length completions) $ + if completionPaging prefs+ then printPage ls+ else effect (PrintLines ls)+ setState im+ if listCompletionsImmediately prefs+ then pageAction+ else effect RingBell >> try (k +> const pageAction) im +askFirst :: Monad m => Prefs -> Int -> CmdM m ()+ -> CmdM m ()+askFirst prefs n cmd+ | maybe False (< n) (completionPromptLimit prefs) = do+ _ <- setState (Message () $ "Display all " ++ show n+ ++ " possibilities? (y or n)")+ keyChoiceCmdM [+ simpleChar 'y' +> cmd+ , simpleChar 'n' +> return ()+ ]+ | otherwise = cmd -printAll :: Monad m => [String] -> InsertMode - -> CmdAction (InputCmdT m) InsertMode-printAll ws im = PrintLines ws im >=> continue+pageCompletions :: MonadReader Layout m => [String] -> CmdM m ()+pageCompletions [] = return ()+pageCompletions wws@(w:ws) = do+ _ <- setState $ Message () "----More----"+ keyChoiceCmdM [+ simpleChar '\n' +> oneLine+ , simpleKey DownKey +> oneLine+ , simpleChar 'q' +> return ()+ , simpleChar ' ' +> (clearMessage >> printPage wws)+ ]+ where+ oneLine = clearMessage >> effect (PrintLines [w]) >> pageCompletions ws+ clearMessage = effect $ LineChange $ const ([],[]) +printPage :: MonadReader Layout m => [String] -> CmdM m ()+printPage ls = do+ layout <- ask+ let (ps,rest) = splitAt (height layout - 1) ls+ effect $ PrintLines ps+ pageCompletions rest +-----------------------------------------------+-- Splitting the list of completions into lines for paging. makeLines :: [String] -> Layout -> [String] makeLines ws layout = let minColPad = 2@@ -114,7 +122,7 @@ maxLength = min printWidth (maximum (map length ws) + minColPad) numCols = printWidth `div` maxLength ls = if maxLength >= printWidth- then map (\x -> [x]) ws+ then map (: []) ws else splitIntoGroups numCols ws in map (padWords maxLength) ls @@ -124,8 +132,14 @@ padWords :: Int -> [String] -> String padWords _ [x] = x padWords _ [] = ""-padWords len (x:xs) = x ++ replicate (len - length x) ' '+padWords len (x:xs) = x ++ replicate (len - glength x) ' ' ++ padWords len xs+ where+ -- kludge: compute the length in graphemes, not chars.+ -- but don't use graphemes for the max length, since I'm not convinced+ -- that would work correctly. (This way, the worst that can happen is+ -- that columns are longer than necessary.)+ glength = length . stringToGraphemes -- Split xs into rows of length n, -- such that the list increases incrementally along the columns.@@ -145,12 +159,4 @@ ceilDiv m n | m `rem` n == 0 = m `div` n | otherwise = m `div` n + 1 -menuCompletion :: forall m . Monad m => Key -> InsertMode -> [InsertMode] - -> CmdAction m InsertMode-menuCompletion _ oldState [] = RingBell oldState >=> continue-menuCompletion _ _ [c] = Change c >=> continue-menuCompletion k oldState (c:cs) = Change c >=> loop cs- where- loop [] = choiceCmd [change (const oldState) k,continue]- loop (d:ds) = choiceCmd [change (const d) k >|> loop ds,continue]
System/Console/Haskeline/Command/History.hs view
@@ -9,21 +9,22 @@ import Data.Maybe(fromMaybe) import System.Console.Haskeline.History -data HistLog = HistLog {pastHistory, futureHistory :: [String]}+data HistLog = HistLog {pastHistory, futureHistory :: [[Grapheme]]} deriving Show -prevHistoryM :: String -> HistLog -> Maybe (String,HistLog)+prevHistoryM :: [Grapheme] -> HistLog -> Maybe ([Grapheme],HistLog) prevHistoryM _ HistLog {pastHistory = []} = Nothing prevHistoryM s HistLog {pastHistory=ls:past, futureHistory=future} = Just (ls, HistLog {pastHistory=past, futureHistory= s:future}) -prevHistories :: String -> HistLog -> [(String,HistLog)]+prevHistories :: [Grapheme] -> HistLog -> [([Grapheme],HistLog)] prevHistories s h = flip unfoldr (s,h) $ \(s',h') -> fmap (\r -> (r,r)) $ prevHistoryM s' h' histLog :: History -> HistLog-histLog hist = HistLog {pastHistory = historyLines hist, futureHistory = []}+histLog hist = HistLog {pastHistory = map stringToGraphemes $ historyLines hist,+ futureHistory = []} runHistoryFromFile :: MonadIO m => Maybe FilePath -> Maybe Int -> StateT History m a -> m a runHistoryFromFile Nothing _ f = evalStateT' emptyHistory f@@ -39,18 +40,27 @@ lift (evalStateT' (histLog history) f) -prevHistory :: FromString s => s -> HistLog -> (s, HistLog)-prevHistory s h = let (s',h') = fromMaybe (toResult s,h) $ prevHistoryM (toResult s) h- in (fromString s',h')+prevHistory, firstHistory :: Save s => s -> HistLog -> (s, HistLog)+prevHistory s h = let (s',h') = fromMaybe (listSave s,h) + $ prevHistoryM (listSave s) h+ in (listRestore s',h') -historyBack, historyForward :: (FromString s, MonadState HistLog m) => - Key -> Command m s s+firstHistory s h = let prevs = (listSave s,h):prevHistories (listSave s) h+ -- above makes sure we don't take the last of an empty list.+ (s',h') = last prevs+ in (listRestore s',h')++historyBack, historyForward :: (Save s, MonadState HistLog m) => Command m s s historyBack = simpleCommand $ histUpdate prevHistory historyForward = simpleCommand $ reverseHist . histUpdate prevHistory +historyStart, historyEnd :: (Save s, MonadState HistLog m) => Command m s s+historyStart = simpleCommand $ histUpdate firstHistory+historyEnd = simpleCommand $ reverseHist . histUpdate firstHistory+ histUpdate :: MonadState HistLog m => (s -> HistLog -> (t,HistLog))- -> s -> m (Effect t)-histUpdate f = liftM Change . update . f+ -> s -> m (Either Effect t)+histUpdate f = liftM Right . update . f reverseHist :: MonadState HistLog m => m b -> m b reverseHist f = do@@ -62,7 +72,7 @@ reverser h = HistLog {futureHistory=pastHistory h, pastHistory=futureHistory h} -data SearchMode = SearchMode {searchTerm :: String,+data SearchMode = SearchMode {searchTerm :: [Grapheme], foundHistory :: InsertMode, direction :: Direction} deriving Show@@ -78,46 +88,51 @@ beforeCursor _ sm = beforeCursor prefix (foundHistory sm) where prefix = "(" ++ directionName (direction sm) ++ ")`" - ++ searchTerm sm ++ "': "+ ++ graphemesToString (searchTerm sm) ++ "': " afterCursor = afterCursor . foundHistory instance Result SearchMode where toResult = toResult . foundHistory +saveSM :: SearchMode -> [Grapheme]+saveSM = listSave . foundHistory+ startSearchMode :: Direction -> InsertMode -> SearchMode-startSearchMode dir im = SearchMode {searchTerm = "",foundHistory=im, direction=dir}+startSearchMode dir im = SearchMode {searchTerm = [],foundHistory=im, direction=dir} addChar :: Char -> SearchMode -> SearchMode-addChar c s = s {searchTerm = searchTerm s ++ [c]}+addChar c s = s {searchTerm = listSave $ insertChar c + $ listRestore $ searchTerm s} -searchHistories :: Direction -> String -> [(String,HistLog)] -> Maybe (SearchMode,HistLog)+searchHistories :: Direction -> [Grapheme] -> [([Grapheme],HistLog)]+ -> Maybe (SearchMode,HistLog) searchHistories dir text = foldr mplus Nothing . map findIt where findIt (l,h) = do im <- findInLine text l return (SearchMode text im dir,h) -findInLine :: String -> String -> Maybe InsertMode+findInLine :: [Grapheme] -> [Grapheme] -> Maybe InsertMode findInLine text l = find' [] l where- find' _ "" = Nothing+ find' _ [] = Nothing find' prev ccs@(c:cs) | text `isPrefixOf` ccs = Just (IMode prev ccs) | otherwise = find' (c:prev) cs -prepSearch :: SearchMode -> HistLog -> (String,[(String,HistLog)])+prepSearch :: SearchMode -> HistLog -> ([Grapheme],[([Grapheme],HistLog)]) prepSearch sm h = let text = searchTerm sm- l = toResult sm+ l = saveSM sm in (text,prevHistories l h) searchBackwards :: Bool -> SearchMode -> HistLog -> Maybe (SearchMode, HistLog) searchBackwards useCurrent s h = let (text,hists) = prepSearch s h- hists' = if useCurrent then (toResult s,h):hists else hists+ hists' = if useCurrent then (saveSM s,h):hists else hists in searchHistories (direction s) text hists' -doSearch :: MonadState HistLog m => Bool -> SearchMode -> m (Effect SearchMode)+doSearch :: MonadState HistLog m => Bool -> SearchMode -> m (Either Effect SearchMode) doSearch useCurrent sm = case direction sm of Reverse -> searchHist Forward -> reverseHist searchHist@@ -125,27 +140,63 @@ searchHist = do hist <- get case searchBackwards useCurrent sm hist of- Just (sm',hist') -> put hist' >> return (Change sm')- Nothing -> return (RingBell sm)+ Just (sm',hist') -> put hist' >> return (Right sm')+ Nothing -> return $ Left RingBell -searchHistory :: MonadState HistLog m => Command m InsertMode InsertMode+searchHistory :: MonadState HistLog m => KeyCommand m InsertMode InsertMode searchHistory = choiceCmd [+ metaChar 'j' +> searchForPrefix Forward+ , metaChar 'k' +> searchForPrefix Reverse+ , choiceCmd [ backKey +> change (startSearchMode Reverse) , forwardKey +> change (startSearchMode Forward)- ] >|> keepSearching+ ] >+> keepSearching+ ] where backKey = ctrlChar 'r' forwardKey = ctrlChar 's'- keepSearching = choiceCmd [+ keepSearching = keyChoiceCmd [ choiceCmd [ charCommand oneMoreChar , backKey +> simpleCommand (searchMore Reverse) , forwardKey +> simpleCommand (searchMore Forward) , simpleKey Backspace +> change delLastChar- ] >|> keepSearching- , changeWithoutKey foundHistory -- abort+ ] >+> keepSearching+ , withoutConsuming (change foundHistory) -- abort ] delLastChar s = s {searchTerm = minit (searchTerm s)}- minit xs = if null xs then "" else init xs+ minit xs = if null xs then [] else init xs oneMoreChar c = doSearch True . addChar c searchMore d s = doSearch False s {direction=d}+++searchForPrefix :: MonadState HistLog m => Direction+ -> Command m InsertMode InsertMode+searchForPrefix dir s@(IMode xs _) = do+ next <- findFirst prefixed dir s+ maybe (return s) setState next+ where+ prefixed gs = if rxs `isPrefixOf` gs+ then Just $ IMode xs (drop (length xs) gs)+ else Nothing+ rxs = reverse xs++-- Search for the first entry in the history which satisfies the constraint.+-- If it succeeds, the HistLog is updated and the result is returned.+-- If it fails, the HistLog is unchanged.+-- TODO: make the other history searching functions use this instead.+findFirst :: forall s m . (Save s, MonadState HistLog m)+ => ([Grapheme] -> Maybe s) -> Direction -> s -> m (Maybe s)+findFirst cond Forward s = reverseHist $ findFirst cond Reverse s+findFirst cond Reverse s = do+ hist <- get+ case search (prevHistories (listSave s) hist) of+ Nothing -> return Nothing+ Just (s',hist') -> put hist' >> return (Just s')+ where+ search :: [([Grapheme],HistLog)] -> Maybe (s,HistLog)+ search [] = Nothing+ search ((g,h):gs) = case cond g of+ Nothing -> search gs+ Just s' -> Just (s',h)+
+ System/Console/Haskeline/Command/KillRing.hs view
@@ -0,0 +1,89 @@+module System.Console.Haskeline.Command.KillRing where++import System.Console.Haskeline.LineState+import System.Console.Haskeline.Command+import System.Console.Haskeline.Monads+import System.Console.Haskeline.Command.Undo+import Control.Monad++-- standard trick for a purely functional queue:+data Stack a = Stack [a] [a]+ deriving Show++emptyStack :: Stack a+emptyStack = Stack [] []++peek :: Stack a -> Maybe a+peek (Stack [] []) = Nothing+peek (Stack (x:_) _) = Just x+peek (Stack [] ys) = peek (Stack (reverse ys) [])++rotate :: Stack a -> Stack a+rotate s@(Stack [] []) = s+rotate (Stack (x:xs) ys) = Stack xs (x:ys)+rotate (Stack [] ys) = rotate (Stack (reverse ys) [])++push :: a -> Stack a -> Stack a+push x (Stack xs ys) = Stack (x:xs) ys++type KillRing = Stack [Grapheme]++runKillRing :: Monad m => StateT KillRing m a -> m a+runKillRing = evalStateT' emptyStack+++pasteCommand :: (Save s, MonadState KillRing m, MonadState Undo m)+ => ([Grapheme] -> s -> s) -> Command m (ArgMode s) s+pasteCommand use = \s -> do+ ms <- liftM peek get+ case ms of+ Nothing -> return $ argState s+ Just p -> do+ modify $ saveToUndo $ argState s+ setState $ applyArg (use p) s++deleteFromDiff' :: InsertMode -> InsertMode -> ([Grapheme],InsertMode)+deleteFromDiff' (IMode xs1 ys1) (IMode xs2 ys2)+ | posChange >= 0 = (take posChange ys1, IMode xs1 ys2)+ | otherwise = (take (negate posChange) ys2 ,IMode xs2 ys1)+ where+ posChange = length xs2 - length xs1++killFromHelper :: (MonadState KillRing m, MonadState Undo m,+ Save s, Save t)+ => KillHelper -> Command m s t+killFromHelper helper = saveForUndo >|> \oldS -> do+ let (gs,newIM) = applyHelper helper (save oldS)+ modify (push gs)+ setState (restore newIM)++killFromArgHelper :: (MonadState KillRing m, MonadState Undo m, Save s, Save t)+ => KillHelper -> Command m (ArgMode s) t+killFromArgHelper helper = saveForUndo >|> \oldS -> do+ let (gs,newIM) = applyArgHelper helper (fmap save oldS)+ modify (push gs)+ setState (restore newIM)++copyFromArgHelper :: (MonadState KillRing m, Save s)+ => KillHelper -> Command m (ArgMode s) s+copyFromArgHelper helper = \oldS -> do+ let (gs,_) = applyArgHelper helper (fmap save oldS)+ modify (push gs)+ setState (argState oldS)+++data KillHelper = SimpleMove (InsertMode -> InsertMode)+ | GenericKill (InsertMode -> ([Grapheme],InsertMode))+ -- a generic kill gives more flexibility, but isn't repeatable.+ -- for example: dd,cc, %++killAll :: KillHelper+killAll = GenericKill $ \(IMode xs ys) -> (reverse xs ++ ys, emptyIM)++applyHelper :: KillHelper -> InsertMode -> ([Grapheme],InsertMode)+applyHelper (SimpleMove move) im = deleteFromDiff' im (move im)+applyHelper (GenericKill act) im = act im++applyArgHelper :: KillHelper -> ArgMode InsertMode -> ([Grapheme],InsertMode)+applyArgHelper (SimpleMove move) im = deleteFromDiff' (argState im) (applyArg move im)+applyArgHelper (GenericKill act) im = act (argState im)
System/Console/Haskeline/Command/Undo.hs view
@@ -1,30 +1,11 @@ module System.Console.Haskeline.Command.Undo where import System.Console.Haskeline.Command-import System.Console.Haskeline.Key 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@@ -58,11 +39,12 @@ saveForUndo :: (Save s, MonadState Undo m)- => Command m s t -> Command m s t-saveForUndo = withState $ modify . saveToUndo+ => Command m s s+saveForUndo s = do+ modify (saveToUndo s)+ return s -commandUndo, commandRedo :: (MonadState Undo m, Save s)- => Key -> Command m s s-commandUndo = simpleCommand $ liftM Change . update . undoPast-commandRedo = simpleCommand $ liftM Change . update . redoFuture+commandUndo, commandRedo :: (MonadState Undo m, Save s) => Command m s s+commandUndo = simpleCommand $ liftM Right . update . undoPast+commandRedo = simpleCommand $ liftM Right . update . redoFuture
System/Console/Haskeline/Completion.hs view
@@ -62,7 +62,7 @@ where 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)+ escapedBreak e (c:cs) | notElem c ws = let (xs,ys) = escapedBreak e cs in (c:xs,ys) escapedBreak _ cs = ("",cs) @@ -156,7 +156,7 @@ return $ setReplacement fullName $ alterIfDir isDir c where (dir, file) = splitFileName path- filterPrefix = filter (\f -> not (f `elem` [".",".."])+ filterPrefix = filter (\f -> notElem f [".",".."] && file `isPrefixOf` f) alterIfDir False c = c alterIfDir True c = c {replacement = addTrailingPathSeparator (replacement c),@@ -167,7 +167,7 @@ -- an absolute path (strange, but it can happen). -- The FilePath docs state that (++) is an exact inverse of splitFileName, so -- that's the right function to user here.- fullName f = dir ++ f+ fullName = (dir ++) -- turn a user-visible path into an internal version useable by System.FilePath. fixPath :: String -> IO String
System/Console/Haskeline/Directory.hsc view
@@ -14,7 +14,9 @@ import Foreign import Foreign.C import System.Win32.Types-import Data.Bits+#if __GLASGOW_HASKELL__ >= 611+import qualified System.Directory+#endif #include <windows.h> #include <Shlobj.h>@@ -52,6 +54,10 @@ 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 stdcall "SHGetFolderPathW" c_SHGetFolderPath@@ -60,9 +66,11 @@ 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
System/Console/Haskeline/Emacs.hs view
@@ -1,29 +1,45 @@ module System.Console.Haskeline.Emacs where import System.Console.Haskeline.Command+import System.Console.Haskeline.Monads import System.Console.Haskeline.Key import System.Console.Haskeline.Command.Completion import System.Console.Haskeline.Command.History import System.Console.Haskeline.Command.Undo+import System.Console.Haskeline.Command.KillRing import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT import Data.Char type InputCmd s t = forall m . Monad m => Command (InputCmdT m) s t+type InputKeyCmd s t = forall m . Monad m => KeyCommand (InputCmdT m) s t -emacsCommands :: Monad m => KeyMap (InputCmdT m) InsertMode-emacsCommands = runCommand $ choiceCmd [simpleActions, controlActions]+emacsCommands :: InputKeyCmd InsertMode (Maybe String)+emacsCommands = choiceCmd [+ choiceCmd [simpleActions, controlActions] >+> + keyCommand emacsCommands+ , enders] -simpleActions, controlActions :: InputCmd InsertMode InsertMode+enders :: InputKeyCmd InsertMode (Maybe String)+enders = choiceCmd [simpleChar '\n' +> finish, eotKey +> deleteCharOrEOF]+ where+ eotKey = ctrlChar 'd'+ deleteCharOrEOF s+ | s == emptyIM = return Nothing+ | otherwise = change deleteNext s >>= justDelete+ justDelete = keyChoiceCmd [eotKey +> change deleteNext >|> justDelete+ , emacsCommands]+++simpleActions, controlActions :: InputKeyCmd InsertMode InsertMode simpleActions = choiceCmd - [ simpleChar '\n' +> finish- , simpleKey LeftKey +> change goLeft+ [ simpleKey LeftKey +> change goLeft , simpleKey RightKey +> change goRight , simpleKey Backspace +> change deletePrev , simpleKey Delete +> change deleteNext , changeFromChar insertChar- , saveForUndo $ simpleChar '\t' +> completionCmd+ , completionCmd (simpleChar '\t') , simpleKey UpKey +> historyBack , simpleKey DownKey +> historyForward , searchHistory@@ -34,33 +50,51 @@ , ctrlChar 'e' +> change moveToEnd , ctrlChar 'b' +> change goLeft , ctrlChar 'f' +> change goRight- , ctrlChar 'd' +> deleteCharOrEOF , ctrlChar 'l' +> clearScreenCmd , metaChar 'f' +> change wordRight , metaChar 'b' +> change wordLeft+ , metaChar 'c' +> change (modifyWord capitalize)+ , metaChar 'l' +> change (modifyWord (mapBaseChars toLower))+ , metaChar 'u' +> change (modifyWord (mapBaseChars toUpper)) , ctrlChar '_' +> commandUndo- , ctrlChar 'x' +> change id + , ctrlChar 'x' +> try (ctrlChar 'u' +> commandUndo)+ , ctrlChar 't' +> change transposeChars+ , ctrlChar 'p' +> historyBack+ , ctrlChar 'n' +> historyForward+ , metaChar '<' +> historyStart+ , metaChar '>' +> historyEnd , simpleKey Home +> change moveToStart , simpleKey End +> change moveToEnd- >|> choiceCmd [ctrlChar 'u' +> commandUndo- , continue]- , saveForUndo $ choiceCmd- [ ctrlChar 'w' +> change (deleteFromMove bigWordLeft)- , metaKey (simpleKey Backspace) +> change (deleteFromMove wordLeft)- , metaChar 'd' +> change (deleteFromMove wordRight)- , ctrlChar 'k' +> change (deleteFromMove moveToEnd)- , simpleKey KillLine +> change (deleteFromMove moveToStart)+ , choiceCmd+ [ ctrlChar 'w' +> killFromHelper (SimpleMove bigWordLeft)+ , metaKey (simpleKey Backspace) +> killFromHelper (SimpleMove wordLeft)+ , metaChar 'd' +> killFromHelper (SimpleMove wordRight)+ , ctrlChar 'k' +> killFromHelper (SimpleMove moveToEnd)+ , simpleKey KillLine +> killFromHelper (SimpleMove moveToStart) ]+ , ctrlChar 'y' +> rotatePaste ] -deleteCharOrEOF :: Key -> InputCmd InsertMode InsertMode-deleteCharOrEOF k = k +> acceptKeyOrFail (\s -> if s == emptyIM- then Nothing- else Just $ Change (deleteNext s) >=> justDelete)- where- justDelete = try (change deleteNext k >|> justDelete)+rotatePaste :: InputCmd InsertMode InsertMode+rotatePaste im = get >>= loop+ where+ loop kr = case peek kr of+ Nothing -> return im+ Just s -> setState (insertGraphemes s im)+ >>= try (metaChar 'y' +> \_ -> loop (rotate kr)) + wordRight, wordLeft, bigWordLeft :: InsertMode -> InsertMode-wordRight = skipRight isAlphaNum . skipRight (not . isAlphaNum)-wordLeft = skipLeft isAlphaNum . skipLeft (not . isAlphaNum)-bigWordLeft = skipLeft (not . isSpace) . skipLeft isSpace+wordRight = goRightUntil (atStart (not . isAlphaNum))+wordLeft = goLeftUntil (atStart isAlphaNum)+bigWordLeft = goLeftUntil (atStart isSpace)++modifyWord :: ([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode+modifyWord f im = IMode (reverse (f ys1) ++ xs) ys2+ where+ IMode xs ys = skipRight (not . isAlphaNum) im+ (ys1,ys2) = span (isAlphaNum . baseChar) ys++capitalize :: [Grapheme] -> [Grapheme]+capitalize [] = []+capitalize (c:cs) = modifyBaseChar toUpper c : cs
System/Console/Haskeline/History.hs view
@@ -15,6 +15,8 @@ History(), emptyHistory, addHistory,+ addHistoryUnlessConsecutiveDupe,+ addHistoryRemovingAllDupes, historyLines, readHistory, writeHistory,@@ -23,7 +25,8 @@ ) where import qualified Data.Sequence as Seq-import Data.Foldable+import Data.Sequence ( Seq, (<|), ViewL(..), ViewR(..), viewl, viewr )+import Data.Foldable (toList) import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8@@ -31,7 +34,7 @@ import System.Directory(doesFileExist) -data History = History {histLines :: Seq.Seq String,+data History = History {histLines :: Seq String, stifleAmt :: Maybe Int} -- stored in reverse @@ -59,8 +62,8 @@ -- which cause confusion when switching between systems. then fmap UTF8.toString (B.readFile file) else return ""- evaluate (length contents) -- force file closed- return $ History {histLines = Seq.fromList $ lines contents,+ _ <- evaluate (length contents) -- force file closed+ return History {histLines = Seq.fromList $ lines contents, stifleAmt = Nothing} -- | Writes the line history to the given file. If there is an@@ -81,10 +84,27 @@ else Seq.fromList . take n . toList addHistory :: String -> History -> History-addHistory s h = h {histLines = s Seq.<| stifledLines}+addHistory s h = h {histLines = maybeDropLast (stifleAmt h) (s <| (histLines h))}++-- If the sequence is too big, drop the last entry.+maybeDropLast :: Ord a => Maybe Int -> Seq a -> Seq a+maybeDropLast maxAmt hs+ | rightSize = hs+ | otherwise = case Seq.viewr hs of+ EmptyR -> hs+ hs' :> _ -> hs' where- stifledLines = if maybe True (> Seq.length (histLines h)) (stifleAmt h)- then histLines h- else case Seq.viewr (histLines h) of- Seq.EmptyR -> histLines h -- shouldn't ever happen- ls Seq.:> _ -> ls+ rightSize = maybe True (>= Seq.length hs) maxAmt++-- | Add a line to the history unless it matches the previously recorded line.+addHistoryUnlessConsecutiveDupe :: String -> History -> History+addHistoryUnlessConsecutiveDupe h hs = case viewl (histLines hs) of+ h1 :< _ | h==h1 -> hs+ _ -> addHistory h hs++-- | Add a line to the history, and remove all previous entries which are the +-- same as it.+addHistoryRemovingAllDupes :: String -> History -> History+addHistoryRemovingAllDupes h hs = addHistory h hs {histLines = filteredHS}+ where+ filteredHS = Seq.fromList $ filter (/= h) $ toList $ histLines hs
System/Console/Haskeline/IO.hs view
@@ -41,8 +41,6 @@ import System.Console.Haskeline hiding (completeFilename) import Control.Concurrent-import Control.Concurrent.MVar-import System.IO import Control.Monad.Trans
System/Console/Haskeline/InputT.hs view
@@ -4,6 +4,7 @@ import System.Console.Haskeline.History import System.Console.Haskeline.Command.History import System.Console.Haskeline.Command.Undo+import System.Console.Haskeline.Command.KillRing import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.Prefs import System.Console.Haskeline.Completion@@ -37,8 +38,9 @@ -- | A monad transformer which carries all of the state and settings -- relevant to a line-reading application. newtype InputT m a = InputT {unInputT :: ReaderT RunTerm- (StateT History (ReaderT Prefs- (ReaderT (Settings m) m))) a}+ (StateT History+ (StateT KillRing (ReaderT Prefs+ (ReaderT (Settings m) m)))) a} deriving (Monad, MonadIO, MonadException, MonadState History, MonadReader Prefs, MonadReader (Settings m), MonadReader RunTerm)@@ -51,31 +53,31 @@ (<*>) = State.ap instance MonadTrans InputT where- lift = InputT . lift . lift . lift . lift+ lift = InputT . lift . lift . lift . lift . lift instance Monad m => State.MonadState History (InputT m) where get = get put = put -- for internal use only-type InputCmdT m = ReaderT Layout (UndoT (StateT HistLog - (ReaderT Prefs (ReaderT (Settings m) m))))--instance MonadIO m => MonadLayout (InputCmdT m) where+type InputCmdT m = StateT Layout (UndoT (StateT HistLog (StateT KillRing+ (ReaderT Prefs (ReaderT (Settings m) m))))) runInputCmdT :: MonadIO m => TermOps -> InputCmdT m a -> InputT m a runInputCmdT tops f = InputT $ do layout <- liftIO $ getLayout tops- lift $ runHistLog $ runUndoT $ runReaderT' layout f-+ lift $ runHistLog $ runUndoT $ evalStateT' layout f -liftCmdT :: Monad m => m a -> InputCmdT m a-liftCmdT = lift . lift . lift . lift . lift+instance Monad m => CommandMonad (InputCmdT m) where+ runCompletion lcs = do+ settings <- ask+ lift $ lift $ lift $ lift $ lift $ lift $ complete settings lcs runInputTWithPrefs :: MonadException m => Prefs -> Settings m -> InputT m a -> m a runInputTWithPrefs prefs settings (InputT f) = bracket (liftIO myRunTerm) (liftIO . closeTerm) $ \run -> runReaderT' settings $ runReaderT' prefs + $ runKillRing $ runHistoryFromFile (historyFile settings) (maxHistorySize prefs) $ runReaderT f run
System/Console/Haskeline/Key.hs view
@@ -36,7 +36,7 @@ | FunKey Int | LeftKey | RightKey | DownKey | UpKey -- TODO: is KillLine really a key?- | KillLine | Home | End+ | KillLine | Home | End | PageDown | PageUp | Backspace | Delete deriving (Show,Eq,Ord) @@ -64,6 +64,8 @@ ,("killline",KillLine) ,("home",Home) ,("end",End)+ ,("pagedown",PageDown)+ ,("pageup",PageUp) ,("backspace",Backspace) ,("delete",Delete) ,("return",KeyChar '\n')
System/Console/Haskeline/LineState.hs view
@@ -1,40 +1,170 @@-module System.Console.Haskeline.LineState where+{- |+This module contains the various datatypes which model the state of the line; that is, the characters displayed and the position of the cursor.+-}+module System.Console.Haskeline.LineState(+ -- * Graphemes+ Grapheme(),+ baseChar,+ stringToGraphemes,+ graphemesToString,+ modifyBaseChar,+ mapBaseChars,+ -- * Line State class+ LineState(..),+ -- ** Convenience functions for the drawing backends+ LineChars,+ lineChars,+ lengthToEnd,+ -- ** Supplementary classes+ Result(..),+ Save(..),+ listSave,+ listRestore,+ Move(..),+ -- * Instances+ -- ** InsertMode+ InsertMode(..),+ emptyIM,+ insertChar,+ insertString,+ replaceCharIM,+ insertGraphemes,+ deleteNext,+ deletePrev,+ skipLeft,+ skipRight,+ transposeChars,+ -- *** Moving to word boundaries+ goRightUntil,+ goLeftUntil,+ atStart,+ atEnd,+ beforeChar,+ afterChar,+ overChar,+ -- ** CommandMode+ CommandMode(..),+ deleteChar,+ replaceChar,+ pasteGraphemesBefore,+ pasteGraphemesAfter,+ -- *** Transitioning between modes+ enterCommandMode,+ enterCommandModeRight,+ insertFromCommandMode,+ appendFromCommandMode,+ withCommandMode,+ -- ** ArgMode+ ArgMode(..),+ startArg,+ addNum,+ applyArg,+ applyCmdArg,+ -- ** Other line state types+ Message(..),+ ) where +import Data.Char +-- | A 'Grapheme' is a fundamental unit of display for the UI. Several characters in sequence+-- can represent one grapheme; for example, an @a@ followed by the diacritic @\'\\768\'@ should+-- be treated as one unit.+data Grapheme = Grapheme {gBaseChar :: Char,+ combiningChars :: [Char]}+ deriving Eq++instance Show Grapheme where+ show g = show (gBaseChar g : combiningChars g)++baseChar :: Grapheme -> Char+baseChar = gBaseChar++modifyBaseChar :: (Char -> Char) -> Grapheme -> Grapheme+modifyBaseChar f g = g {gBaseChar = f (gBaseChar g)}++mapBaseChars :: (Char -> Char) -> [Grapheme] -> [Grapheme]+mapBaseChars f = map (modifyBaseChar f)++-- | Create a 'Grapheme' from a single base character.+--+-- NOTE: Careful, don't use outside this module; and inside, make sure this is only+-- ever called on non-combining characters.+baseGrapheme :: Char -> Grapheme+baseGrapheme c = Grapheme {gBaseChar = c, combiningChars = []}++-- | Add a combining character to the given 'Grapheme'.+addCombiner :: Grapheme -> Char -> Grapheme+addCombiner g c = g {combiningChars = combiningChars g ++ [c]}++isCombiningChar :: Char -> Bool+isCombiningChar c = generalCategory c == NonSpacingMark++-- | Converts a string into a sequence of graphemes.+--+-- NOTE: Drops any initial, unattached combining characters.+stringToGraphemes :: String -> [Grapheme]+stringToGraphemes = mkString . dropWhile isCombiningChar+ where+ mkString [] = []+ mkString (c:cs) = Grapheme c (takeWhile isCombiningChar cs)+ : mkString (dropWhile isCombiningChar cs)++graphemesToString :: [Grapheme] -> String+graphemesToString = concatMap (\g -> (baseChar g : combiningChars g))++-- | This class abstracts away the internal representations of the line state,+-- for use by the drawing actions. Line state is generally stored in a zipper format. class LineState s where- beforeCursor :: String -> s -> String -- text to left of cursor- afterCursor :: s -> String -- text under and to right of cursor- isTemporary :: s -> Bool- isTemporary _ = False+ beforeCursor :: String -- ^ The input prefix.+ -> s -- ^ The current line state.+ -> [Grapheme] -- ^ The text to the left of the cursor, reversed. (This + -- includes the prefix.)+ afterCursor :: s -> [Grapheme] -- ^ The text under and to the right of the cursor. -type LineChars = (String,String)+-- | The characters in the line (with the cursor in the middle). NOT in a zippered format;+-- both lists are in the order left->right that appears on the screen.+type LineChars = ([Grapheme],[Grapheme]) +-- | Accessor function for the various backends. lineChars :: LineState s => String -> s -> LineChars lineChars prefix s = (beforeCursor prefix s, afterCursor s) +-- | Compute the number of characters under and to the right of the cursor. lengthToEnd :: LineChars -> Int lengthToEnd = length . snd class LineState s => Result s where toResult :: s -> String -class (Result s) => FromString s where- fromString :: String -> s+class LineState s => Save s where+ save :: s -> InsertMode+ restore :: InsertMode -> s +listSave :: Save s => s -> [Grapheme]+listSave s = case save s of IMode xs ys -> reverse xs ++ ys++listRestore :: Save s => [Grapheme] -> s+listRestore xs = restore $ IMode (reverse xs) []+ class Move s where goLeft, goRight, moveToStart, moveToEnd :: s -> s --data InsertMode = IMode String String +-- | The standard line state representation; considers the cursor to be located+-- between two characters. The first list is reversed.+data InsertMode = IMode [Grapheme] [Grapheme] deriving (Show, Eq) instance LineState InsertMode where- beforeCursor prefix (IMode xs _) = prefix ++ reverse xs+ beforeCursor prefix (IMode xs _) = stringToGraphemes prefix ++ reverse xs afterCursor (IMode _ ys) = ys instance Result InsertMode where- toResult (IMode xs ys) = reverse xs ++ ys+ toResult (IMode xs ys) = graphemesToString $ reverse xs ++ ys +instance Save InsertMode where+ save = id+ restore = id+ instance Move InsertMode where goLeft im@(IMode [] _) = im goLeft (IMode (x:xs) ys) = IMode xs (x:ys)@@ -45,17 +175,22 @@ moveToStart (IMode xs ys) = IMode [] (reverse xs ++ ys) moveToEnd (IMode xs ys) = IMode (reverse ys ++ xs) [] -instance FromString InsertMode where- fromString s = IMode (reverse s) []- emptyIM :: InsertMode-emptyIM = IMode "" ""+emptyIM = IMode [] [] +-- | Insert one character, which may be combining, to the left of the cursor.+-- insertChar :: Char -> InsertMode -> InsertMode-insertChar c (IMode xs ys) = IMode (c:xs) ys+insertChar c im@(IMode xs ys)+ | isCombiningChar c = case xs of+ [] -> im -- drop a combining character if it+ -- appears at the start of the line.+ z:zs -> IMode (addCombiner z c : zs) ys+ | otherwise = IMode (baseGrapheme c : xs) ys +-- | Insert a sequence of characters to the left of the cursor. insertString :: String -> InsertMode -> InsertMode-insertString s (IMode xs ys) = IMode (reverse s ++ xs) ys+insertString s (IMode xs ys) = IMode (reverse (stringToGraphemes s) ++ xs) ys deleteNext, deletePrev :: InsertMode -> InsertMode deleteNext im@(IMode _ []) = im@@ -65,25 +200,51 @@ deletePrev (IMode (_:xs) ys) = IMode xs ys skipLeft, skipRight :: (Char -> Bool) -> InsertMode -> InsertMode-skipLeft f (IMode xs ys) = let (ws,zs) = span f xs +skipLeft f (IMode xs ys) = let (ws,zs) = span (f . baseChar) xs in IMode zs (reverse ws ++ ys)-skipRight f (IMode xs ys) = let (ws,zs) = span f ys +skipRight f (IMode xs ys) = let (ws,zs) = span (f . baseChar) ys in IMode (reverse ws ++ xs) zs +transposeChars :: InsertMode -> InsertMode+transposeChars (IMode (x:xs) (y:ys)) = IMode (x:y:xs) ys+transposeChars (IMode (y:x:xs) []) = IMode (x:y:xs) []+transposeChars im = im -data CommandMode = CMode String Char String | CEmpty+insertGraphemes :: [Grapheme] -> InsertMode -> InsertMode+insertGraphemes s (IMode xs ys) = IMode (reverse s ++ xs) ys++-- For the 'R' command.+replaceCharIM :: Char -> InsertMode -> InsertMode+replaceCharIM c im+ | isCombiningChar c = case im of+ IMode [] [] -> im+ IMode [] (y:ys) -> IMode [] (addCombiner y c:ys)+ IMode (x:xs) ys -> IMode (addCombiner x c:xs) ys+ | otherwise = let g = baseGrapheme c+ in case im of+ IMode xs [] -> IMode (g:xs) []+ IMode xs (_:ys) -> IMode (g:xs) ys+++-- | Used by vi mode. Considers the cursor to be located over some specific character.+-- The first list is reversed.+data CommandMode = CMode [Grapheme] Grapheme [Grapheme] | CEmpty deriving Show instance LineState CommandMode where- beforeCursor prefix CEmpty = prefix- beforeCursor prefix (CMode xs _ _) = prefix ++ reverse xs- afterCursor CEmpty = ""+ beforeCursor prefix CEmpty = stringToGraphemes prefix+ beforeCursor prefix (CMode xs _ _) = stringToGraphemes prefix ++ reverse xs+ afterCursor CEmpty = [] afterCursor (CMode _ c ys) = c:ys instance Result CommandMode where toResult CEmpty = ""- toResult (CMode xs c ys) = reverse xs ++ (c:ys)+ toResult (CMode xs c ys) = graphemesToString $ reverse xs ++ (c:ys) +instance Save CommandMode where+ save = insertFromCommandMode+ restore = enterCommandModeRight+ instance Move CommandMode where goLeft (CMode (x:xs) c ys) = CMode xs x (c:ys) goLeft cm = cm@@ -97,20 +258,24 @@ moveToEnd (CMode xs c ys) = let zs = reverse ys ++ (c:xs) in CMode (tail zs) (head zs) [] moveToEnd CEmpty = CEmpty -instance FromString CommandMode where- fromString s = case reverse s of- [] -> CEmpty- (c:cs) -> CMode cs c []- deleteChar :: CommandMode -> CommandMode deleteChar (CMode xs _ (y:ys)) = CMode xs y ys deleteChar (CMode (x:xs) _ []) = CMode xs x [] deleteChar _ = CEmpty replaceChar :: Char -> CommandMode -> CommandMode-replaceChar c (CMode xs _ ys) = CMode xs c ys+replaceChar c (CMode xs d ys)+ | not (isCombiningChar c) = CMode xs (baseGrapheme c) ys+ | otherwise = CMode xs (addCombiner d c) ys replaceChar _ CEmpty = CEmpty +pasteGraphemesBefore, pasteGraphemesAfter :: [Grapheme] -> CommandMode -> CommandMode+pasteGraphemesBefore [] = id+pasteGraphemesBefore s = enterCommandMode . insertGraphemes s . insertFromCommandMode++pasteGraphemesAfter [] = id+pasteGraphemesAfter s = enterCommandMode . insertGraphemes s . appendFromCommandMode+ ------------------------ -- Transitioning between modes @@ -138,19 +303,24 @@ ---------------------- -- Supplementary modes +-- | Used for commands which take an integer argument. data ArgMode s = ArgMode {arg :: Int, argState :: s} instance Functor ArgMode where- fmap f (ArgMode n s) = ArgMode n (f s)+ fmap f am = am {argState = f (argState am)} instance LineState s => LineState (ArgMode s) where- beforeCursor _ am = beforeCursor ("(arg: " ++ show (arg am) ++ ") ")- (argState am)+ beforeCursor _ am = let pre = "(arg: " ++ show (arg am) ++ ") "+ in beforeCursor pre (argState am) afterCursor = afterCursor . argState instance Result s => Result (ArgMode s) where toResult = toResult . argState +instance Save s => Save (ArgMode s) where+ save = save . argState+ restore = startArg 0 . restore+ startArg :: Int -> s -> ArgMode s startArg = ArgMode @@ -161,30 +331,48 @@ -- todo: negatives applyArg :: (s -> s) -> ArgMode s -> s-applyArg f am = repeatN (arg am) (argState am)- where- repeatN n | n <= 1 = f- | otherwise = f . repeatN (n-1)+applyArg f am = repeatN (arg am) f (argState am) -----------------data Cleared = Cleared+repeatN :: Int -> (a -> a) -> a -> a+repeatN n f | n <= 1 = f+ | otherwise = f . repeatN (n-1) f -instance LineState Cleared where- beforeCursor _ Cleared = ""- afterCursor Cleared = ""+applyCmdArg :: (InsertMode -> InsertMode) -> ArgMode CommandMode -> CommandMode+applyCmdArg f am = withCommandMode (repeatN (arg am) f) (argState am) +---------------+-- TODO: messageState param not needed anymore. data Message s = Message {messageState :: s, messageText :: String} -instance LineState s => LineState (Message s) where- beforeCursor _ = messageText- afterCursor _ = ""- isTemporary _ = True+instance LineState (Message s) where+ beforeCursor _ = stringToGraphemes . messageText+ afterCursor _ = [] ------------------deleteFromDiff :: InsertMode -> InsertMode -> InsertMode-deleteFromDiff (IMode xs1 ys1) (IMode xs2 ys2)- | length xs1 < length xs2 = IMode xs1 ys2- | otherwise = IMode xs2 ys1+atStart, atEnd :: (Char -> Bool) -> InsertMode -> Bool+atStart f (IMode (x:_) (y:_)) = not (f (baseChar x)) && f (baseChar y)+atStart _ _ = False -deleteFromMove :: (InsertMode -> InsertMode) -> InsertMode -> InsertMode-deleteFromMove f = \x -> deleteFromDiff x (f x)+atEnd f (IMode _ (y1:y2:_)) = f (baseChar y1) && not (f (baseChar y2))+atEnd _ _ = False++overChar, beforeChar, afterChar :: (Char -> Bool) -> InsertMode -> Bool+overChar f (IMode _ (y:_)) = f (baseChar y)+overChar _ _ = False++beforeChar f (IMode _ (_:y:_)) = f (baseChar y)+beforeChar _ _ = False++afterChar f (IMode (x:_) _) = f (baseChar x)+afterChar _ _ = False++goRightUntil, goLeftUntil :: (InsertMode -> Bool) -> InsertMode -> InsertMode+goRightUntil f = loop . goRight+ where+ loop im@(IMode _ ys) | null ys || f im = im+ | otherwise = loop (goRight im)+goLeftUntil f = loop . goLeft+ where+ loop im@(IMode xs _) | null xs || f im = im+ | otherwise = loop (goLeft im)+
System/Console/Haskeline/MonadException.hs view
@@ -35,8 +35,8 @@ finally f ender = block (do r <- catch (unblock f)- (\(e::SomeException) -> do {ender; throwIO e})- ender+ (\(e::SomeException) -> do {_ <- ender; throwIO e})+ _ <- ender return r) throwIO :: (MonadIO m, Exception e) => e -> m a@@ -51,8 +51,8 @@ a <- before r <- catch (unblock (thing a))- (\(e::SomeException) -> do { after a; throwIO e })- after a+ (\(e::SomeException) -> do { _ <- after a; throwIO e })+ _ <- after a return r )
System/Console/Haskeline/Monads.hs view
@@ -22,19 +22,15 @@ class Monad m => MonadReader r m where ask :: m r- local :: r -> m a -> m a instance Monad m => MonadReader r (ReaderT r m) where ask = Reader.ask- local r = Reader.local (const r) -instance MonadReader r m => MonadReader r (ReaderT t m) where- ask = lift ask- local r = mapReaderT (local r)- -instance MonadReader r m => MonadReader r (StateT s m) where+instance Monad m => MonadReader s (StateT s m) where+ ask = get++instance (MonadReader r m, MonadTrans t, Monad (t m)) => MonadReader r (t m) where ask = lift ask- local r = mapStateT (local r) asks :: MonadReader r m => (r -> a) -> m a asks f = liftM f ask@@ -47,13 +43,10 @@ get = State.get put = State.put -instance MonadState s m => MonadState s (StateT t m) where+instance (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where get = lift get put = lift . put -instance MonadState s m => MonadState s (ReaderT r m) where- get = lift get- put = lift . put modify :: MonadState s m => (s -> s) -> m () modify f = get >>= put . f
System/Console/Haskeline/Prefs.hs view
@@ -5,6 +5,7 @@ CompletionType(..), BellStyle(..), EditMode(..),+ HistoryDuplicates(..), lookupKeyBinding ) where @@ -31,6 +32,7 @@ data Prefs = Prefs { bellStyle :: !BellStyle, editMode :: !EditMode, maxHistorySize :: !(Maybe Int),+ historyDuplicates :: HistoryDuplicates, completionType :: !CompletionType, completionPaging :: !Bool, -- ^ When listing completion alternatives, only display@@ -59,6 +61,9 @@ data EditMode = Vi | Emacs deriving (Show,Read) +data HistoryDuplicates = AlwaysAdd | IgnoreConsecutive | IgnoreAll+ deriving (Show,Read)+ -- | The default preferences which may be overwritten in the -- @.haskeline@ file. defaultPrefs :: Prefs@@ -69,6 +74,7 @@ completionPaging = True, completionPromptLimit = Just 100, listCompletionsImmediately = True,+ historyDuplicates = AlwaysAdd, customBindings = Map.empty, customKeySequences = [] }@@ -90,17 +96,18 @@ ,("completionpaging", mkSettor $ \x p -> p {completionPaging = x}) ,("completionpromptlimit", mkSettor $ \x p -> p {completionPromptLimit = x}) ,("listcompletionsimmediately", mkSettor $ \x p -> p {listCompletionsImmediately = x})+ ,("historyduplicates", mkSettor $ \x p -> p {historyDuplicates = x}) ,("bind", addCustomBinding) ,("keyseq", addCustomKeySequence) ] addCustomBinding :: String -> Prefs -> Prefs-addCustomBinding str p = case sequence $ map parseKey (words str) of+addCustomBinding str p = case mapM parseKey (words str) of Just (k:ks) -> p {customBindings = Map.insert k ks (customBindings p)} _ -> p addCustomKeySequence :: String -> Prefs -> Prefs-addCustomKeySequence str = maybe id addKS $ maybeParse+addCustomKeySequence str = maybe id addKS maybeParse where maybeParse :: Maybe (Maybe String, String,Key) maybeParse = case words str of@@ -121,7 +128,7 @@ readPrefs :: FilePath -> IO Prefs readPrefs file = handle (\(_::IOException) -> return defaultPrefs) $ do ls <- fmap lines $ readFile file- return $ foldl' applyField defaultPrefs ls+ return $! foldl' applyField defaultPrefs ls where applyField p l = case break (==':') l of (name,val) -> case lookup (map toLower $ trimSpaces name) settors of
+ System/Console/Haskeline/RunCommand.hs view
@@ -0,0 +1,84 @@+module System.Console.Haskeline.RunCommand (runCommandLoop) where++import System.Console.Haskeline.Command+import System.Console.Haskeline.Term+import System.Console.Haskeline.LineState+import System.Console.Haskeline.Monads+import System.Console.Haskeline.Prefs+import System.Console.Haskeline.Key++import Control.Monad++runCommandLoop :: (MonadException m, CommandMonad m, MonadState Layout m)+ => TermOps -> String -> KeyCommand m InsertMode a -> m a+runCommandLoop tops prefix cmds = runTerm tops $ + RunTermType (withGetEvent tops $ runCommandLoop' tops prefix cmds)++runCommandLoop' :: forall t m a . (MonadTrans t, Term (t m), CommandMonad (t m),+ MonadState Layout m, MonadReader Prefs m)+ => TermOps -> String -> KeyCommand m InsertMode a -> t m Event -> t m a+runCommandLoop' tops prefix cmds getEvent = do+ let s = lineChars prefix emptyIM+ drawLine s+ loopKeys [] s (fmap ($ emptyIM) cmds)+ where + loopKeys :: [Key] -> LineChars -> KeyMap (CmdM m a) -> t m a+ loopKeys [] s processor = do -- no keys left, so read some more+ event <- handle (\(e::SomeException) -> moveToNextLine s+ >> throwIO e) getEvent+ case event of+ ErrorEvent e -> moveToNextLine s >> throwIO e+ WindowResize -> drawReposition tops s+ >> loopKeys [] s processor+ KeyInput k -> do+ ks <- lift $ asks $ lookupKeyBinding k+ loopKeys ks s processor+ loopKeys (k:ks) s processor = case lookupKM processor k of+ Nothing -> actBell >> loopKeys [] s processor+ Just (Consumed cmd) -> loopCmd ks s cmd+ Just (NotConsumed cmd) -> loopCmd (k:ks) s cmd++ loopCmd :: [Key] -> LineChars -> CmdM m a -> t m a+ loopCmd ks s (GetKey next) = loopKeys ks s next+ loopCmd ks s (DoEffect e next) = do+ t <- drawEffect prefix s e+ loopCmd ks t next+ loopCmd ks s (CmdM next) = lift next >>= loopCmd ks s+ loopCmd _ s (Result x) = moveToNextLine s >> return x++drawEffect :: (MonadTrans t, Term (t m), MonadReader Prefs m)+ => String -> LineChars -> Effect -> t m LineChars+drawEffect prefix s (LineChange ch) = do+ let t = ch prefix+ drawLineDiff s t+ return t+drawEffect _ s ClearScreen = do+ clearLayout+ drawLine s+ return s+drawEffect _ s (PrintLines ls) = do+ when (s /= ([],[])) $ moveToNextLine s+ printLines ls+ drawLine s+ return s+drawEffect _ s RingBell = actBell >> return s++actBell :: (MonadTrans t, Term (t m), MonadReader Prefs m) => t m ()+actBell = do+ style <- lift $ asks bellStyle+ case style of+ NoBell -> return ()+ VisualBell -> ringBell False+ AudibleBell -> ringBell True++drawReposition :: (MonadTrans t, Term (t m), MonadState Layout m)+ => TermOps -> LineChars -> t m ()+drawReposition tops s = do+ -- explicit lifts prevent the need for IncoherentInstances.+ oldLayout <- lift get+ newLayout <- liftIO $ getLayout tops+ when (oldLayout /= newLayout) $ do+ lift $ put newLayout+ reposition oldLayout s++
System/Console/Haskeline/Term.hs view
@@ -4,9 +4,9 @@ import System.Console.Haskeline.LineState import System.Console.Haskeline.Key import System.Console.Haskeline.Prefs(Prefs)+import System.Console.Haskeline.Completion(Completion) import Control.Concurrent-import Control.Concurrent.Chan import Data.Typeable import Data.ByteString (ByteString) import Control.Exception.Extensible (fromException, AsyncException(..),bracket_)@@ -18,6 +18,11 @@ drawLineDiff :: LineChars -> LineChars -> m () clearLayout :: m () ringBell :: Bool -> m ()++drawLine, clearLine :: Term m => LineChars -> m ()+drawLine = drawLineDiff ([],[])++clearLine = flip drawLineDiff ([],[]) -- putStrOut is the right way to send unicode chars to stdout. -- termOps being Nothing means we should read the input as a UTF-8 file.@@ -31,14 +36,28 @@ closeTerm :: IO () } -data TermOps = TermOps {runTerm :: RunTermType,- getLayout :: IO Layout}+data TermOps = TermOps {+ getLayout :: IO Layout+ , withGetEvent :: (MonadException m, CommandMonad m)+ => (m Event -> m a) -> m a+ , runTerm :: (MonadException m, CommandMonad m) => RunTermType m a -> m a+ } -type RunTermType = forall m a . (MonadLayout m, MonadException m, MonadReader Prefs m) - => (forall t . (MonadTrans t, Term (t m), MonadException (t m)) - => (t m Event -> t m a)) -> m a+-- Generic terminal actions which are independent of the Term being used.+-- Wrapped in a newtype so that we don't need RankNTypes.+newtype RunTermType m a = RunTermType (forall t . + (MonadTrans t, Term (t m), MonadException (t m), CommandMonad (t m))+ => t m a) +class (MonadReader Prefs m , MonadReader Layout m)+ => CommandMonad m where+ runCompletion :: (String,String) -> m (String,[Completion]) +instance (MonadTrans t, CommandMonad m, MonadReader Prefs (t m),+ MonadReader Layout (t m))+ => CommandMonad (t m) where+ runCompletion = lift . runCompletion+ -- Utility function for drawLineDiff instances. matchInit :: Eq a => [a] -> [a] -> ([a],[a]) matchInit (x:xs) (y:ys) | x == y = matchInit xs ys@@ -75,7 +94,6 @@ Just ThreadKilled -> return () _ -> writeChan eventChan (ErrorEvent e) -class (MonadReader Layout m, MonadIO m) => MonadLayout m where data Interrupt = Interrupt deriving (Show,Typeable,Eq)@@ -84,4 +102,3 @@ data Layout = Layout {width, height :: Int} deriving (Show,Eq)-
System/Console/Haskeline/Vi.hs view
@@ -1,59 +1,100 @@ module System.Console.Haskeline.Vi where import System.Console.Haskeline.Command+import System.Console.Haskeline.Monads import System.Console.Haskeline.Key import System.Console.Haskeline.Command.Completion import System.Console.Haskeline.Command.History+import System.Console.Haskeline.Command.KillRing import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT -import Data.Char(isAlphaNum,isSpace)+import Data.Char+import Control.Monad(liftM) -type InputCmd s t = forall m . Monad m => Command (InputCmdT m) s t+type EitherMode = Either CommandMode InsertMode -viActions :: Monad m => KeyMap (InputCmdT m) InsertMode-viActions = runCommand insertionCommands+type SavedCommand m = Command (ViT m) (ArgMode CommandMode) EitherMode -insertionCommands :: InputCmd InsertMode InsertMode-insertionCommands = choiceCmd [startCommand, simpleInsertions]- -simpleInsertions :: InputCmd InsertMode InsertMode+data ViState m = ViState { + lastCommand :: SavedCommand m,+ lastSearch :: [Grapheme]+ }++emptyViState :: Monad m => ViState m+emptyViState = ViState {+ lastCommand = return . Left . argState,+ lastSearch = []+ }++type ViT m = StateT (ViState m) (InputCmdT m)++type InputCmd s t = forall m . Monad m => Command (ViT m) s t+type InputKeyCmd s t = forall m . Monad m => KeyCommand (ViT m) s t++viKeyCommands :: InputKeyCmd InsertMode (Maybe String)+viKeyCommands = choiceCmd [+ simpleChar '\n' +> finish+ , ctrlChar 'd' +> eofIfEmpty+ , simpleInsertions >+> viCommands+ , simpleChar '\ESC' +> change enterCommandMode+ >|> viCommandActions+ ]++viCommands :: InputCmd InsertMode (Maybe String)+viCommands = keyCommand viKeyCommands++simpleInsertions :: InputKeyCmd InsertMode InsertMode simpleInsertions = choiceCmd- [ simpleChar '\n' +> finish- , simpleKey LeftKey +> change goLeft + [ simpleKey LeftKey +> change goLeft , simpleKey RightKey +> change goRight , simpleKey Backspace +> change deletePrev , simpleKey Delete +> change deleteNext , simpleKey Home +> change moveToStart , simpleKey End +> change moveToEnd- , changeFromChar insertChar+ , insertChars , ctrlChar 'l' +> clearScreenCmd- , ctrlChar 'd' +> eofIfEmpty , simpleKey UpKey +> historyBack , simpleKey DownKey +> historyForward , searchHistory- , saveForUndo $ choiceCmd- [ simpleKey KillLine +> change (deleteFromMove moveToStart)- , simpleChar '\t' +> completionCmd- ]+ , simpleKey KillLine +> killFromHelper (SimpleMove moveToStart)+ , ctrlChar 'w' +> killFromHelper wordErase+ , completionCmd (simpleChar '\t') ] --- If we receive a ^D and the line is empty, return Nothing--- otherwise, ignore it.-eofIfEmpty :: Save s => Key -> InputCmd s s-eofIfEmpty k = k +> acceptKeyOrFail (\s -> if save s == emptyIM- then Nothing- else Just $ Change s >=> continue)+insertChars :: InputKeyCmd InsertMode InsertMode+insertChars = useChar $ loop []+ where+ loop ds d = change (insertChar d) >|> keyChoiceCmd [+ useChar $ loop (d:ds)+ , withoutConsuming (storeCharInsertion (reverse ds))+ ]+ storeCharInsertion s = storeLastCmd $ change (applyArg + $ withCommandMode $ insertString s)+ >|> return . Left -startCommand :: InputCmd InsertMode InsertMode-startCommand = simpleChar '\ESC' +> change enterCommandMode- >|> viCommandActions+-- If we receive a ^D and the line is empty, return Nothing+-- otherwise, act like '\n' (mimicing how Readline behaves)+eofIfEmpty :: (Monad m, Save s, Result s) => Command m s (Maybe String)+eofIfEmpty s+ | save s == emptyIM = return Nothing+ | otherwise = finish s -viCommandActions :: InputCmd CommandMode InsertMode-viCommandActions = simpleCmdActions `loopUntil` exitingCommands+viCommandActions :: InputCmd CommandMode (Maybe String)+viCommandActions = keyChoiceCmd [+ simpleChar '\n' +> finish+ , ctrlChar 'd' +> eofIfEmpty+ , simpleCmdActions >+> viCommandActions+ , exitingCommands >+> viCommands+ , repeatedCommands >+> chooseEitherMode+ ]+ where+ chooseEitherMode :: InputCmd EitherMode (Maybe String)+ chooseEitherMode (Left cm) = viCommandActions cm+ chooseEitherMode (Right im) = viCommands im -exitingCommands :: InputCmd CommandMode InsertMode+exitingCommands :: InputKeyCmd CommandMode InsertMode exitingCommands = choiceCmd [ simpleChar 'i' +> change insertFromCommandMode , simpleChar 'I' +> change (moveToStart . insertFromCommandMode)@@ -62,122 +103,332 @@ , simpleChar 'A' +> change (moveToEnd . appendFromCommandMode) , simpleKey End +> change (moveToStart . insertFromCommandMode) , simpleChar 's' +> change (insertFromCommandMode . deleteChar)- , repeated- , saveForUndo $ choiceCmd- [ simpleChar 'S' +> change (const emptyIM)- , deleteIOnce- ]+ , simpleChar 'S' +> noArg >|> killAndStoreI killAll+ , simpleChar 'C' +> noArg >|> killAndStoreI (SimpleMove moveToEnd) ] -simpleCmdActions :: InputCmd CommandMode CommandMode-simpleCmdActions = choiceCmd [ simpleChar '\n' +> finish- , simpleChar '\ESC' +> change id -- helps break out of loops- , ctrlChar 'd' +> eofIfEmpty+simpleCmdActions :: InputKeyCmd CommandMode CommandMode+simpleCmdActions = choiceCmd [ + simpleChar '\ESC' +> change id -- helps break out of loops , simpleChar 'r' +> replaceOnce - , simpleChar 'R' +> loopReplace- , simpleChar 'x' +> change deleteChar+ , simpleChar 'R' +> replaceLoop+ , simpleChar 'D' +> noArg >|> killAndStoreCmd (SimpleMove moveToEnd) , ctrlChar 'l' +> clearScreenCmd , simpleChar 'u' +> commandUndo , ctrlChar 'r' +> commandRedo- , simpleChar '.' +> commandRedo- , useMovements withCommandMode- , simpleKey DownKey +> historyForward- , simpleKey UpKey +> historyBack- , saveForUndo $ choiceCmd- [ simpleKey KillLine +> change (withCommandMode- $ deleteFromMove moveToStart)- , deleteOnce+ -- vi-mode quirk: history is put at the start of the line.+ , simpleChar 'j' +> historyForward >|> change moveToStart+ , simpleChar 'k' +> historyBack >|> change moveToStart+ , simpleKey DownKey +> historyForward >|> change moveToStart+ , simpleKey UpKey +> historyBack >|> change moveToStart+ , simpleChar '/' +> viEnterSearch '/' Reverse+ , simpleChar '?' +> viEnterSearch '?' Forward+ , simpleChar 'n' +> viSearchHist Reverse []+ , simpleChar 'N' +> viSearchHist Forward []+ , simpleKey KillLine +> noArg >|> killAndStoreCmd (SimpleMove moveToStart)+ ]++replaceOnce :: InputCmd CommandMode CommandMode+replaceOnce = try $ changeFromChar replaceChar++repeatedCommands :: InputKeyCmd CommandMode EitherMode+repeatedCommands = choiceCmd [argumented, doBefore noArg repeatableCommands]+ where+ start = foreachDigit startArg ['1'..'9']+ addDigit = foreachDigit addNum ['0'..'9']+ argumented = start >+> loop+ loop = keyChoiceCmd [addDigit >+> loop+ , repeatableCommands+ -- if no match, bail out.+ , withoutConsuming (change argState) >+> return . Left+ ]++pureMovements :: InputKeyCmd (ArgMode CommandMode) CommandMode+pureMovements = choiceCmd $+ map mkCharCommand charMovements+ ++ map mkSimpleCommand movements+ where+ mkSimpleCommand (k,move) = k +> change (applyCmdArg move)+ mkCharCommand (k,move) = k +> keyChoiceCmd [+ useChar (change . applyCmdArg . move)+ , withoutConsuming (change argState)+ ]++useMovementsForKill :: Command m s t -> (KillHelper -> Command m s t) -> KeyCommand m s t+useMovementsForKill alternate useHelper = choiceCmd $+ map mkCharCommand charMovements+ ++ specialCases+ ++ map (\(k,move) -> k +> useHelper (SimpleMove move)) movements+ where+ specialCases = [ simpleChar 'e' +> useHelper (SimpleMove goToWordDelEnd)+ , simpleChar 'E' +> useHelper (SimpleMove goToBigWordDelEnd)+ , simpleChar '%' +> useHelper (GenericKill deleteMatchingBrace)+ ]+ mkCharCommand (k,move) = k +> keyChoiceCmd [+ useChar (useHelper . SimpleMove . move)+ , withoutConsuming alternate]+++repeatableCommands :: InputKeyCmd (ArgMode CommandMode) EitherMode+repeatableCommands = choiceCmd+ [ repeatableCmdToIMode+ , repeatableCmdMode >+> return . Left+ , simpleChar '.' +> saveForUndo >|> runLastCommand ]+ where+ runLastCommand s = liftM lastCommand get >>= ($ s)++repeatableCmdMode :: InputKeyCmd (ArgMode CommandMode) CommandMode+repeatableCmdMode = choiceCmd+ [ simpleChar 'x' +> repeatableChange deleteChar+ , simpleChar 'X' +> repeatableChange (withCommandMode deletePrev)+ , simpleChar '~' +> repeatableChange (goRight . flipCase)+ , simpleChar 'p' +> storedCmdAction (pasteCommand pasteGraphemesAfter)+ , simpleChar 'P' +> storedCmdAction (pasteCommand pasteGraphemesBefore)+ , simpleChar 'd' +> deletionCmd+ , simpleChar 'y' +> yankCommand+ , ctrlChar 'w' +> killAndStoreCmd wordErase+ , pureMovements ]+ where+ repeatableChange f = storedCmdAction (saveForUndo >|> change (applyArg f)) -replaceOnce :: Key -> InputCmd CommandMode CommandMode-replaceOnce k = k >+> try (changeFromChar replaceChar)+flipCase :: CommandMode -> CommandMode+flipCase CEmpty = CEmpty+flipCase (CMode xs y zs) = CMode xs (modifyBaseChar flipCaseG y) zs+ where+ flipCaseG c | isLower c = toUpper c+ | otherwise = toLower c -loopReplace :: Key -> InputCmd CommandMode CommandMode-loopReplace k = k >+> loop+repeatableCmdToIMode :: InputKeyCmd (ArgMode CommandMode) EitherMode+repeatableCmdToIMode = simpleChar 'c' +> deletionToInsertCmd++deletionCmd :: InputCmd (ArgMode CommandMode) CommandMode+deletionCmd = keyChoiceCmd+ [simpleChar 'd' +> killAndStoreCmd killAll+ , useMovementsForKill (change argState) killAndStoreCmd+ , withoutConsuming (change argState)+ ]++deletionToInsertCmd :: InputCmd (ArgMode CommandMode) EitherMode+deletionToInsertCmd = keyChoiceCmd+ [simpleChar 'c' +> killAndStoreIE killAll+ -- vim, for whatever reason, treats cw same as ce and cW same as cE.+ -- readline does this too, so we should also.+ , simpleChar 'w' +> killAndStoreIE (SimpleMove goToWordDelEnd)+ , simpleChar 'W' +> killAndStoreIE (SimpleMove goToBigWordDelEnd)+ , withoutConsuming (return . Left . argState)+ ]+++yankCommand :: InputCmd (ArgMode CommandMode) CommandMode+yankCommand = keyChoiceCmd+ [simpleChar 'y' +> copyAndStore killAll+ , useMovementsForKill (change argState) copyAndStore+ , withoutConsuming (change argState)+ ] where- loop = choiceCmd [changeFromChar (\c -> goRight . replaceChar c) >|> loop- , continue]+ copyAndStore = storedCmdAction . copyFromArgHelper -repeated :: InputCmd CommandMode InsertMode-repeated = let- start = foreachDigit startArg ['1'..'9']- addDigit = foreachDigit addNum ['0'..'9']- deleteR = simpleChar 'd' - >+> choiceCmd [useMovements deleteFromRepeatedMove,- simpleChar 'd' +> change (const CEmpty)]- deleteIR = simpleChar 'c'- >+> choiceCmd [useMovements deleteAndInsertR,- simpleChar 'c' +> change (const emptyIM)]- applyArg' f = enterCommandModeRight . applyArg f . fmap insertFromCommandMode- loop = choiceCmd [addDigit >|> loop- , useMovements applyArg' >|> viCommandActions- , saveForUndo (deleteR >|> viCommandActions)- , saveForUndo deleteIR- , saveForUndo (simpleChar 'x' +> change (applyArg deleteChar)- >|> viCommandActions)- , changeWithoutKey argState >|> viCommandActions- ]- in start >|> loop+goToWordDelEnd, goToBigWordDelEnd :: InsertMode -> InsertMode+goToWordDelEnd = goRightUntil $ atStart (not . isWordChar)+ .||. atStart (not . isOtherChar)+goToBigWordDelEnd = goRightUntil $ atStart (not . isBigWordChar) + movements :: [(Key,InsertMode -> InsertMode)] movements = [ (simpleChar 'h', goLeft) , (simpleChar 'l', goRight)- , (simpleChar 'w', skipRight isSpace . (\s -> skipRight (cmdChar s) s))- , (simpleChar 'b', (\s -> skipLeft (cmdChar s) s) . goLeft . skipLeft isSpace)- , (simpleChar 'W', skipRight isSpace . skipRight (not . isSpace))- , (simpleChar 'B', skipLeft (not . isSpace) . skipLeft isSpace) , (simpleChar ' ', goRight) , (simpleKey LeftKey, goLeft) , (simpleKey RightKey, goRight) , (simpleChar '0', moveToStart) , (simpleChar '$', moveToEnd)+ , (simpleChar '^', skipRight isSpace . moveToStart)+ , (simpleChar '%', findMatchingBrace)+ ------------------+ -- Word movements+ -- move to the start of the next word+ , (simpleChar 'w', goRightUntil $+ atStart isWordChar .||. atStart isOtherChar)+ , (simpleChar 'W', goRightUntil (atStart isBigWordChar))+ -- move to the beginning of the previous word+ , (simpleChar 'b', goLeftUntil $+ atStart isWordChar .||. atStart isOtherChar)+ , (simpleChar 'B', goLeftUntil (atStart isBigWordChar))+ -- move to the end of the current word+ , (simpleChar 'e', goRightUntil $+ atEnd isWordChar .||. atEnd isOtherChar)+ , (simpleChar 'E', goRightUntil (atEnd isBigWordChar)) ] -cmdChar :: InsertMode -> (Char -> Bool)-cmdChar (IMode _ (c:_))- | isWordChar c = isWordChar-cmdChar _ = \d -> not (isWordChar d) && not (isSpace d)+charMovements :: [(Key, Char -> InsertMode -> InsertMode)]+charMovements = [ (simpleChar 'f', \c -> goRightUntil $ overChar (==c))+ , (simpleChar 'F', \c -> goLeftUntil $ overChar (==c))+ , (simpleChar 't', \c -> goRightUntil $ beforeChar (==c))+ , (simpleChar 'T', \c -> goLeftUntil $ afterChar (==c))+ ] -isWordChar :: Char -> Bool-isWordChar d = isAlphaNum d || d == '_'+{- +From IEEE 1003.1:+A "bigword" consists of: a maximal sequence of non-blanks preceded and followed by blanks+A "word" consists of either:+ - a maximal sequence of wordChars, delimited at both ends by non-wordchars+ - a maximal sequence of non-blank non-wordchars, delimited at both ends by either blanks+ or a wordchar.+-} +isBigWordChar, isWordChar, isOtherChar :: Char -> Bool+isBigWordChar = not . isSpace+isWordChar = isAlphaNum .||. (=='_')+isOtherChar = not . (isSpace .||. isWordChar) -useMovements :: LineState t => ((InsertMode -> InsertMode) -> s -> t) - -> InputCmd s t-useMovements f = choiceCmd $ map (\(k,g) -> k +> change (f g))- movements+(.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool+(f .||. g) x = f x || g x -deleteOnce :: InputCmd CommandMode CommandMode-deleteOnce = simpleChar 'd'- >+> choiceCmd [useMovements deleteFromCmdMove,- simpleChar 'd' +> change (const CEmpty)]+foreachDigit :: (Monad m, LineState t) => (Int -> s -> t) -> [Char] + -> KeyCommand m s t+foreachDigit f ds = choiceCmd $ map digitCmd ds+ where digitCmd d = simpleChar d +> change (f (toDigit d))+ toDigit d = fromEnum d - fromEnum '0' -deleteIOnce :: InputCmd CommandMode InsertMode-deleteIOnce = simpleChar 'c'- >+> choiceCmd [useMovements deleteAndInsert,- simpleChar 'c' +> change (const emptyIM)] -deleteAndInsert :: (InsertMode -> InsertMode) -> CommandMode -> InsertMode-deleteAndInsert f = insertFromCommandMode . deleteFromCmdMove f+-- This mimics the ctrl-w command in readline's vi mode, which corresponds to+-- the tty's werase character.+wordErase :: KillHelper+wordErase = SimpleMove $ goLeftUntil $ atStart isBigWordChar -deleteAndInsertR :: (InsertMode -> InsertMode) - -> ArgMode CommandMode -> InsertMode-deleteAndInsertR f = insertFromCommandMode . deleteFromRepeatedMove f+------------------+-- Matching braces +findMatchingBrace :: InsertMode -> InsertMode+findMatchingBrace (IMode xs (y:ys))+ | Just b <- matchingRightBrace yc,+ Just ((b':bs),ys') <- scanBraces yc b ys = IMode (bs++[y]++xs) (b':ys')+ | Just b <- matchingLeftBrace yc,+ Just (bs,xs') <- scanBraces yc b xs = IMode xs' (bs ++ [y]++ys)+ where yc = baseChar y+findMatchingBrace im = im -foreachDigit :: (Monad m, LineState t) => (Int -> s -> t) -> [Char] - -> Command m s t-foreachDigit f ds = choiceCmd $ map digitCmd ds- where digitCmd d = simpleChar d +> change (f (toDigit d))- toDigit d = fromEnum d - fromEnum '0'+deleteMatchingBrace :: InsertMode -> ([Grapheme],InsertMode)+deleteMatchingBrace (IMode xs (y:ys))+ | Just b <- matchingRightBrace yc,+ Just (bs,ys') <- scanBraces yc b ys = (y : reverse bs, IMode xs ys')+ | Just b <- matchingLeftBrace yc,+ Just (bs,xs') <- scanBraces yc b xs = (bs ++ [y], IMode xs' ys)+ where yc = baseChar y+deleteMatchingBrace im = ([],im) -deleteFromCmdMove :: (InsertMode -> InsertMode) -> CommandMode -> CommandMode-deleteFromCmdMove f = withCommandMode $ \x -> deleteFromDiff x (f x)+scanBraces :: Char -> Char -> [Grapheme] -> Maybe ([Grapheme],[Grapheme])+scanBraces c d = scanBraces' (1::Int) []+ where+ scanBraces' 0 bs xs = Just (bs,xs)+ scanBraces' _ _ [] = Nothing+ scanBraces' n bs (x:xs) = scanBraces' m (x:bs) xs+ where m | baseChar x == c = n+1+ | baseChar x == d = n-1+ | otherwise = n -deleteFromRepeatedMove :: (InsertMode -> InsertMode)- -> ArgMode CommandMode -> CommandMode-deleteFromRepeatedMove f am = let- am' = fmap insertFromCommandMode am- in enterCommandModeRight $ - deleteFromDiff (argState am') (applyArg f am')+matchingRightBrace, matchingLeftBrace :: Char -> Maybe Char +matchingRightBrace = flip lookup braceList+matchingLeftBrace = flip lookup (map (\(c,d) -> (d,c)) braceList)++braceList :: [(Char,Char)]+braceList = [('(',')'), ('[',']'), ('{','}')]++---------------+-- Replace mode+replaceLoop :: InputCmd CommandMode CommandMode+replaceLoop = saveForUndo >|> change insertFromCommandMode >|> loop+ >|> change enterCommandModeRight+ where+ loop = try (oneReplaceCmd >+> loop)+ oneReplaceCmd = choiceCmd [+ simpleKey LeftKey +> change goLeft+ , simpleKey RightKey +> change goRight+ , changeFromChar replaceCharIM+ ]+++---------------------------+-- Saving previous commands++storeLastCmd :: Monad m => SavedCommand m -> Command (ViT m) s s+storeLastCmd act = \s -> do+ modify $ \vs -> vs {lastCommand = act}+ return s++storedAction :: Monad m => SavedCommand m -> SavedCommand m+storedAction act = storeLastCmd act >|> act++storedCmdAction :: Monad m => Command (ViT m) (ArgMode CommandMode) CommandMode+ -> Command (ViT m) (ArgMode CommandMode) CommandMode+storedCmdAction act = storeLastCmd (liftM Left . act) >|> act++storedIAction :: Monad m => Command (ViT m) (ArgMode CommandMode) InsertMode+ -> Command (ViT m) (ArgMode CommandMode) InsertMode+storedIAction act = storeLastCmd (liftM Right . act) >|> act++killAndStoreCmd :: Monad m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode+killAndStoreCmd = storedCmdAction . killFromArgHelper++killAndStoreI :: Monad m => KillHelper -> Command (ViT m) (ArgMode CommandMode) InsertMode+killAndStoreI = storedIAction . killFromArgHelper++killAndStoreIE :: Monad m => KillHelper -> Command (ViT m) (ArgMode CommandMode) EitherMode+killAndStoreIE helper = storedAction (killFromArgHelper helper >|> return . Right)++noArg :: Monad m => Command m s (ArgMode s)+noArg = return . startArg 1++-------------------+-- Vi-style searching++data SearchEntry = SearchEntry {+ entryState :: InsertMode,+ searchChar :: Char+ }++searchText :: SearchEntry -> [Grapheme]+searchText SearchEntry {entryState = IMode xs ys} = reverse xs ++ ys++instance LineState SearchEntry where+ beforeCursor prefix se = beforeCursor (prefix ++ [searchChar se])+ (entryState se)+ afterCursor = afterCursor . entryState++viEnterSearch :: Monad m => Char -> Direction+ -> Command (ViT m) CommandMode CommandMode+viEnterSearch c dir s = setState (SearchEntry emptyIM c) >>= loopEntry+ where+ modifySE f se = se {entryState = f (entryState se)}+ loopEntry = keyChoiceCmd [+ editEntry >+> loopEntry+ , simpleChar '\n' +> \se -> + viSearchHist dir (searchText se) s+ , withoutConsuming (change (const s))+ ]+ editEntry = choiceCmd [+ useChar (change . modifySE . insertChar)+ , simpleKey LeftKey +> change (modifySE goLeft)+ , simpleKey RightKey +> change (modifySE goRight)+ , simpleKey Backspace +> change (modifySE deletePrev)+ , simpleKey Delete +> change (modifySE deleteNext)+ ] ++viSearchHist :: forall m . Monad m+ => Direction -> [Grapheme] -> Command (ViT m) CommandMode CommandMode+viSearchHist dir toSearch cm = do+ vstate :: ViState m <- get+ let toSearch' = if null toSearch+ then lastSearch vstate+ else toSearch+ result <- doSearch False SearchMode {+ searchTerm = toSearch',+ foundHistory = save cm, -- TODO: not needed+ direction = dir}+ case result of+ Left e -> effect e >> setState cm+ Right sm -> do+ put vstate {lastSearch = toSearch'}+ setState (restore (foundHistory sm))
− configure
@@ -1,2 +0,0 @@-#!/bin/sh-# Dummy file to be run by autoconfUserHooks.
haskeline.cabal view
@@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.6-Version: 0.6.1.6+Version: 0.6.2 Category: User Interfaces License: BSD3 License-File: LICENSE@@ -19,10 +19,9 @@ Homepage: http://trac.haskell.org/haskeline Stability: Experimental Build-Type: Custom-extra-source-files: configure examples/Test.hs-extra-tmp-files: haskeline.buildinfo+extra-source-files: examples/Test.hs CHANGES -flag old-base+flag base2 Description: Use the base packages from before version 6.8 flag terminfo@@ -34,20 +33,29 @@ Default: False Library- if flag(old-base)+ if flag(base2) { Build-depends: base == 2.* cpp-options: -DOLD_BASE- else- Build-depends: base>=3 && <5 , containers>=0.1, directory>=1.0,- bytestring==0.9.*+ }+ else {+ if impl(ghc>=6.11) {+ Build-depends: base >=4.1 && < 4.3, containers>=0.1 && < 0.3, directory==1.0.*,+ bytestring==0.9.*+ }+ else {+ Build-depends: base>=3 && <4.1 , containers>=0.1 && < 0.3, directory==1.0.*,+ bytestring==0.9.*+ }+ } Build-depends: filepath==1.1.*, mtl==1.1.*, utf8-string==0.3.* && >=0.3.1.1, extensible-exceptions==0.1.* && >=0.1.1.0- Extensions: ForeignFunctionInterface, RankNTypes, FlexibleInstances,+ Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances, TypeSynonymInstances FlexibleContexts, ExistentialQuantification ScopedTypeVariables, GeneralizedNewtypeDeriving MultiParamTypeClasses, OverlappingInstances+ UndecidableInstances PatternSignatures, CPP, DeriveDataTypeable, PatternGuards Exposed-Modules:@@ -62,6 +70,7 @@ System.Console.Haskeline.Command System.Console.Haskeline.Command.Completion System.Console.Haskeline.Command.History+ System.Console.Haskeline.Command.KillRing System.Console.Haskeline.Directory System.Console.Haskeline.Emacs System.Console.Haskeline.InputT@@ -69,6 +78,7 @@ System.Console.Haskeline.LineState System.Console.Haskeline.Monads System.Console.Haskeline.Prefs+ System.Console.Haskeline.RunCommand System.Console.Haskeline.Term System.Console.Haskeline.Command.Undo System.Console.Haskeline.Vi@@ -91,7 +101,7 @@ System.Console.Haskeline.Backend.IConv System.Console.Haskeline.Backend.DumbTerm if flag(terminfo) {- Build-depends: terminfo==0.3.*+ Build-depends: terminfo>=0.3.1.1 && <0.4 Other-modules: System.Console.Haskeline.Backend.Terminfo cpp-options: -DTERMINFO }