haskeline (empty) → 0.2
raw patch · 23 files changed
+2584/−0 lines, 23 filesdep +Win32dep +basedep +bytestringsetup-changed
Dependencies added: Win32, base, bytestring, containers, directory, filepath, mtl, stm, template-haskell, terminfo, unix, utf8-string
Files
- LICENSE +23/−0
- Setup.lhs +31/−0
- System/Console/Haskeline.hs +228/−0
- System/Console/Haskeline/Backend.hs +23/−0
- System/Console/Haskeline/Backend/DumbTerm.hs +126/−0
- System/Console/Haskeline/Backend/Posix.hsc +181/−0
- System/Console/Haskeline/Backend/Terminfo.hs +266/−0
- System/Console/Haskeline/Backend/Win32.hsc +284/−0
- System/Console/Haskeline/Command.hs +164/−0
- System/Console/Haskeline/Command/Completion.hs +149/−0
- System/Console/Haskeline/Command/History.hs +145/−0
- System/Console/Haskeline/Completion.hs +131/−0
- System/Console/Haskeline/Emacs.hs +50/−0
- System/Console/Haskeline/InputT.hs +83/−0
- System/Console/Haskeline/LineState.hs +168/−0
- System/Console/Haskeline/MonadException.hs +59/−0
- System/Console/Haskeline/Monads.hs +72/−0
- System/Console/Haskeline/Prefs.hs +102/−0
- System/Console/Haskeline/Term.hs +56/−0
- System/Console/Haskeline/Vi.hs +152/−0
- cbits/win_console.c +5/−0
- haskeline.cabal +79/−0
- includes/win_console.h +7/−0
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright 2007, Judah Jacobson.+All Rights Reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistribution of source code must retain the above copyright notice,+this list of conditions and the following disclamer.++- Redistribution in binary form must reproduce the above copyright notice,+this list of conditions and the following disclamer in the documentation+and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,31 @@+#!/usr/local/bin/runhaskell++\begin{code}+import Distribution.Simple+import Distribution.Verbosity+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import Distribution.Simple.GHC as GHC+import Distribution.Simple.PreProcess++main = defaultMainWithHooks simpleUserHooks {runTests = buildTestProg}++buildTestProg :: [String] -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+buildTestProg _ _ pkgDescr lbi = do+ let newPkg = withTest pkgDescr+ preprocessSources newPkg lbi False normal [("hsc",ppHsc2hs)]+ GHC.build (withTest pkgDescr) lbi normal++withTest :: PackageDescription -> PackageDescription+withTest pkg@PackageDescription {library = Just lib} + = pkg {executables = [testProg],+ library = Nothing}+ where+ testProg = Executable {exeName = "Test",+ modulePath = "examples/Test.hs",+ buildInfo = alterBuildInfo (libBuildInfo lib)}++alterBuildInfo :: BuildInfo -> BuildInfo+alterBuildInfo bi = bi {options = (GHC,["-threaded"]) : options bi}++\end{code}
+ System/Console/Haskeline.hs view
@@ -0,0 +1,228 @@+module System.Console.Haskeline(+ -- * Main functions+ --+ -- $maindoc+ InputT,+ runInputT,+ runInputTWithPrefs,+ getInputLine,+ outputStr,+ outputStrLn,+ -- * Settings+ Settings(..),+ defaultSettings,+ setComplete,+ -- * Ctrl-C handling+ Interrupt(..),+ handleInterrupt,+ module System.Console.Haskeline.Completion,+ module System.Console.Haskeline.Prefs,+ module System.Console.Haskeline.MonadException)+ where++import System.Console.Haskeline.LineState+import System.Console.Haskeline.Command+import System.Console.Haskeline.Command.History+import System.Console.Haskeline.Vi+import System.Console.Haskeline.Emacs+import System.Console.Haskeline.Prefs+import System.Console.Haskeline.Monads+import System.Console.Haskeline.MonadException+import System.Console.Haskeline.InputT+import System.Console.Haskeline.Completion+import System.Console.Haskeline.Term++import System.IO+import Data.Char (isSpace)+import Control.Monad+import qualified Control.Exception as Exception+import Data.Dynamic++++{- $maindoc+++An example use of this library for a simple read-eval-print loop is the+following.++> import System.Console.Haskeline+> import Control.Monad.Trans+> +> main :: IO ()+> main = runInputT defaultSettings loop+> where +> loop :: InputT IO ()+> loop = do+> minput <- getInputLine "% "+> case minput of+> Nothing -> return ()+> Just "quit" -> return ()+> Just input -> do outputStrLn $ "Input was: " ++ input+> loop++-}+++-- | A useful default. In particular:+--+-- @+-- defaultSettings = Settings {+-- complete = completeFilename,+-- historyFile = Nothing,+-- handleSigINT = False+-- }+-- @+defaultSettings :: MonadIO m => Settings m+defaultSettings = Settings {complete = completeFilename,+ historyFile = Nothing,+ handleSigINT = False}++-- NOTE: If we set stdout to NoBuffering, there can be a flicker effect when many+-- characters are printed at once. We'll keep it buffered here, and let the Draw+-- monad manually flush outputs that don't print a newline.+wrapTerminalOps:: MonadException m => m a -> m a+wrapTerminalOps =+ bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering+ . bracketSet (hGetBuffering stdout) (hSetBuffering stdout) LineBuffering+ . bracketSet (hGetEcho stdout) (hSetEcho stdout) False++bracketSet :: (Eq a, MonadException m) => IO a -> (a -> IO ()) -> a -> m b -> m b+bracketSet getState set newState f = do+ oldState <- liftIO getState+ if oldState == newState+ then f+ else finally (liftIO (set newState) >> f) (liftIO (set oldState))+++-- | Write a string to the console output. Allows cross-platform display of+-- Unicode characters.+outputStr :: forall m . MonadIO m => String -> InputT m ()+outputStr xs = do+ run :: RunTerm (InputCmdT m) <- ask+ liftIO $ putStrTerm run xs++-- | Write a string to the console output, followed by a newline. Allows+-- cross-platform display of Unicode characters.+outputStrLn :: MonadIO m => String -> InputT m ()+outputStrLn xs = outputStr (xs++"\n")++{- | Read one line of input from the user, with a rich line-editing+user interface. Returns 'Nothing' if the user presses Ctrl-D when the input+text is empty. Otherwise, it returns the input line with the final newline+removed. + +If 'stdin' is not connected to a terminal (for example, piped from+another process), then this function is equivalent to 'getLine', except that+it returns 'Nothing' if an EOF is encountered before any characters are+read.++If signal handling is enabled in the 'Settings', then 'getInputLine' will+throw an 'Interrupt' exception when the user presses Ctrl-C.++-}+getInputLine :: forall m . MonadException m => String -- ^ The input prompt+ -> InputT m (Maybe String)+getInputLine prefix = do+ isTerm <- liftIO $ hIsTerminalDevice stdin+ if isTerm+ then getInputCmdLine prefix+ else do+ atEOF <- liftIO $ hIsEOF stdin+ if atEOF+ then return Nothing+ else liftM Just $ liftIO $ hGetLine stdin++getInputCmdLine :: forall m . MonadException m => String -> InputT m (Maybe String)+getInputCmdLine prefix = do+-- TODO: Cache the terminal, actions+ emode <- asks (\prefs -> case editMode prefs of+ Vi -> viActions+ Emacs -> emacsCommands)+ settings :: Settings m <- ask+ wrapTerminalOps $ do+ let ls = emptyIM+ RunTerm {withGetEvent = withGetEvent', runTerm=runTerm'} <- ask+ result <- runInputCmdT $ runTerm' $ withGetEvent' (handleSigINT settings) + $ \getEvent -> do+ drawLine prefix ls + repeatTillFinish getEvent prefix ls emode+ case result of + Just line | not (all isSpace line) -> addHistory line+ _ -> return ()+ return result++repeatTillFinish :: forall m s d + . (MonadTrans d, Term (d m), MonadIO m, LineState s, MonadReader Prefs m)+ => d m Event -> String -> s -> KeyMap m s + -> d m (Maybe String)+repeatTillFinish getEvent prefix = loop+ where + -- NOTE: since the functions in this mutually recursive binding group do not have the + -- same contexts, we need the -XGADTs flag (or -fglasgow-exts)+ loop :: forall t . LineState t => t -> KeyMap m t -> d m (Maybe String)+ loop s processor = do+ event <- getEvent+ case event of+ SigInt -> do+ moveToNextLine s+ liftIO $ Exception.evaluate (Exception.throwDyn Interrupt)+ WindowResize newLayout -> + withReposition newLayout (loop s processor)+ KeyInput k -> case lookupKM processor k of+ Nothing -> actBell >> loop s processor+ Just g -> case g s of+ Left r -> moveToNextLine s >> return r+ Right f -> do+ KeyAction effect next <- lift f+ drawEffect prefix s effect+ loop (effectState effect) next++{-- +Note why it is necessary to integrate ctrl-c handling with this module:+if the user is in the middle of a few wrapped lines, we want to clean up+by moving the cursor to the start of the following line.+--}++data Interrupt = Interrupt+ deriving (Show,Typeable,Eq)++-- | Catch and handle an exception of type 'Interrupt'.+handleInterrupt :: MonadException m => m a + -- ^ Handler to run if Ctrl-C is pressed+ -> m a -- ^ Computation to run+ -> m a+handleInterrupt f = handle $ \e -> case Exception.dynExceptions e of+ Just dyn | Just Interrupt <- fromDynamic dyn -> f+ _ -> throwIO e++++drawEffect :: (LineState s, LineState t, Term (d m), + MonadTrans d, MonadReader Prefs m) + => String -> s -> Effect t -> d m ()+drawEffect prefix s (Redraw shouldClear t) = if shouldClear+ then clearLayout >> drawLine prefix t+ else clearLine prefix s >> drawLine prefix t+drawEffect prefix s (Change t) = drawLineDiff prefix s t+drawEffect prefix s (PrintLines ls t) = do+ if isTemporary s+ then clearLine prefix s+ else moveToNextLine s+ printLines ls+ drawLine prefix t+drawEffect _ _ (RingBell _) = actBell++drawLine :: (LineState s, Term m) => String -> s -> m ()+drawLine prefix s = drawLineDiff prefix Cleared s++clearLine :: (LineState s, Term m) => String -> s -> m ()+clearLine prefix s = drawLineDiff 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
+ System/Console/Haskeline/Backend.hs view
@@ -0,0 +1,23 @@+module System.Console.Haskeline.Backend where++import System.Console.Haskeline.Term+import System.Console.Haskeline.Monads++#ifdef MINGW+import System.Console.Haskeline.Backend.Win32 as Win32+#else+import System.Console.Haskeline.Backend.Terminfo as Terminfo+import System.Console.Haskeline.Backend.DumbTerm as DumbTerm+#endif++myRunTerm :: (MonadException m, MonadLayout m) => IO (RunTerm m)++#ifdef MINGW+myRunTerm = return win32Term+#else+myRunTerm = do+ mRun <- runTerminfoDraw+ case mRun of + Nothing -> return runDumbTerm+ Just run -> return run+#endif
+ System/Console/Haskeline/Backend/DumbTerm.hs view
@@ -0,0 +1,126 @@+module System.Console.Haskeline.Backend.DumbTerm where++import System.Console.Haskeline.Backend.Posix+import System.Console.Haskeline.Term+import System.Console.Haskeline.LineState+import System.Console.Haskeline.Monads as Monads+import System.Console.Haskeline.Command++import System.IO+import qualified System.IO.UTF8 as UTF8++-- TODO: +---- Make this unicode-aware, too.+---- Put "<" and ">" at end of term if scrolls off.+---- Have a margin at the ends++data Window = Window {pos :: Int -- ^ # of visible chars to left of cursor+ }++initWindow :: Window+initWindow = Window {pos=0}++newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window m a}+ deriving (Monad,MonadIO, MonadState Window)++instance MonadReader Layout m => MonadReader Layout (DumbTerm m) where+ ask = lift ask+ local r = DumbTerm . local r . unDumbTerm++instance MonadException m => MonadException (DumbTerm m) where+ block = DumbTerm . block . unDumbTerm+ unblock = DumbTerm . unblock . unDumbTerm+ catch (DumbTerm f) g = DumbTerm $ Monads.catch f (unDumbTerm . g)++runDumbTerm :: (MonadLayout m, MonadException m) => RunTerm m+runDumbTerm = RunTerm {+ getLayout = getPosixLayout,+ withGetEvent = withPosixGetEvent Nothing,+ runTerm = evalStateT' initWindow . unDumbTerm,+ putStrTerm = UTF8.putStr+ }+ ++instance MonadTrans DumbTerm where+ lift = DumbTerm . lift++instance MonadLayout m => Term (DumbTerm m) where+ withReposition _ = id+ drawLineDiff = drawLineDiff'+ + printLines = mapM_ (\s -> printText (s ++ crlf))+ moveToNextLine = \_ -> printText crlf+ clearLayout = clearLayoutD+ ringBell True = printText "\a"+ ringBell False = return ()+ +printText :: MonadIO m => String -> m ()+printText str = liftIO $ UTF8.putStr str >> hFlush stdout++-- Things we can assume a dumb terminal knows how to do+cr,crlf :: String+crlf = "\r\n"+cr = "\r"++backs,spaces :: Int -> String+backs n = replicate n '\b'+spaces n = replicate n ' '+++clearLayoutD :: MonadLayout m => DumbTerm m ()+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 = asks (\lay -> width lay - 1)++drawLineDiff' :: (LineState s, LineState t, MonadLayout m)+ => String -> s -> t -> DumbTerm m ()+drawLineDiff' prefix s1 s2 = do+ let xs1 = beforeCursor prefix s1+ let ys1 = afterCursor s1+ let xs2 = beforeCursor prefix s2+ let ys2 = afterCursor s2+ Window {pos=p} <- get+ w <- maxWidth+ let (xs1',xs2') = matchInit xs1 xs2+ let newP = p + length xs2' - length xs1'+ let ys2' = take (w-newP) ys2+ if length xs1' > p || newP >= w+ then refitLine (xs2,ys2)+ else do -- we haven't moved outside the margins+ put Window {pos=newP}+ case (xs1',xs2') of+ ([],[]) | ys1 == ys2 -> return () -- no change+ (_,[]) | xs1' ++ ys1 == ys2 -> -- moved left+ printText $ backs (length xs1')+ ([],_) | ys1 == xs2' ++ ys2 -> -- moved right+ printText xs2'+ _ -> let+ extraLength = length xs1' + length ys1+ - length xs2' - length ys2+ in printText $ backs (length xs1')+ ++ xs2' ++ ys2' ++ clearDeadText extraLength+ ++ backs (length ys2')++refitLine :: MonadLayout m => (String,String) -> DumbTerm m ()+refitLine (xs,ys) = do+ w <- maxWidth+ let xs' = dropFrames w xs+ let p = length xs' + put Window {pos=p}+ let ys' = take (w - p) ys+ let k = length ys'+ printText $ cr ++ xs' ++ ys'+ ++ spaces (w-k-p)+ ++ backs (w-p)+ where+ dropFrames w zs = case splitAt w zs of+ (_,"") -> zs+ (_,zs') -> dropFrames w zs'+ +clearDeadText :: Int -> String+clearDeadText n | n > 0 = spaces n ++ backs n+ | otherwise = ""
+ System/Console/Haskeline/Backend/Posix.hsc view
@@ -0,0 +1,181 @@+module System.Console.Haskeline.Backend.Posix (+ withPosixGetEvent,+ getPosixLayout,+ mapLines+ ) where++import Foreign+import Foreign.C.Types+import qualified Data.Map as Map+import System.Console.Terminfo+import System.Posix (stdOutput)+import System.Posix.Terminal+import Control.Monad+import Control.Concurrent+import Control.Concurrent.STM+import Data.Maybe+import System.Posix.Signals.Exts+import System.Posix.IO(stdInput)+import Data.List+import System.IO+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as UTF8++import System.Console.Haskeline.Monads+import System.Console.Haskeline.Command+import System.Console.Haskeline.Term++#include <sys/ioctl.h>++-------------------+-- Window size++foreign import ccall ioctl :: CInt -> CULong -> Ptr a -> IO ()++getPosixLayout :: IO Layout+getPosixLayout = allocaBytes (#size struct winsize) $ \ws -> do+ ioctl 1 (#const TIOCGWINSZ) ws+ rows :: CUShort <- (#peek struct winsize,ws_row) ws+ cols :: CUShort <- (#peek struct winsize,ws_col) ws+ return Layout {height=fromEnum rows,width=fromEnum cols}++-- todo: make sure >=2+-- TODO: other ways of getting it:+-- env vars ROWS/COLUMNS+-- terminfo capabilities+++--------------------+-- Key sequences++-- TODO: What if term not found?+getKeySequences :: Maybe Terminal -> IO (TreeMap Char Key)+getKeySequences term = do+ sttys <- sttyKeys+ let tinfos = fromMaybe ansiKeys (term >>= terminfoKeys)+ -- note ++ acts as a union; so the below favors sttys over tinfos+ return $ listToTree $ tinfos ++ sttys+++ansiKeys :: [(String, Key)]+ansiKeys = [("\ESC[D", KeyLeft)+ ,("\ESC[C", KeyRight)+ ,("\ESC[A", KeyUp)+ ,("\ESC[B", KeyDown)+ ,("\b", Backspace)]++terminfoKeys :: Terminal -> Maybe [(String,Key)]+terminfoKeys term = getCapability term $ mapM getSequence keyCapabilities+ where + getSequence (cap,x) = do + keys <- cap+ return (keys,x)+ keyCapabilities = + [(keyLeft,KeyLeft),+ (keyRight,KeyRight),+ (keyUp,KeyUp),+ (keyDown,KeyDown),+ (keyBackspace,Backspace),+ (keyDeleteChar,DeleteForward)]++sttyKeys :: IO [(String, Key)]+sttyKeys = do+ attrs <- getTerminalAttributes stdOutput+ let getStty (k,c) = do {str <- controlChar attrs k; return ([str],c)}+ return $ catMaybes $ map getStty [(Erase,Backspace),(Kill,KillLine)]+ +newtype TreeMap a b = TreeMap (Map.Map a (Maybe b, TreeMap a b))+ deriving Show++emptyTreeMap :: TreeMap a b+emptyTreeMap = TreeMap Map.empty++insertIntoTree :: Ord a => ([a], b) -> TreeMap a b -> TreeMap a b+insertIntoTree ([],_) _ = error "Can't insert empty list into a treemap!"+insertIntoTree ((c:cs),k) (TreeMap m) = TreeMap (Map.alter f c m)+ where+ alterSubtree = insertIntoTree (cs,k)+ f Nothing = Just $ if null cs+ then (Just k, emptyTreeMap)+ else (Nothing, alterSubtree emptyTreeMap)+ f (Just (y,t)) = Just $ if null cs+ then (Just k, t)+ else (y, alterSubtree t)++listToTree :: Ord a => [([a],b)] -> TreeMap a b+listToTree = foldl' (flip insertIntoTree) emptyTreeMap++-- for debugging '+mapLines :: (Show a, Show b) => TreeMap a b -> [String]+mapLines (TreeMap m) = let+ m2 = Map.map (\(k,t) -> show k : mapLines t) m+ in concatMap (\(k,ls) -> show k : map (' ':) ls) $ Map.toList m2++lexKeys :: TreeMap Char Key -> [Char] -> [Key]+lexKeys _ [] = []+lexKeys baseMap cs+ | Just (k,ds) <- lookupChars baseMap cs+ = k : lexKeys baseMap ds+lexKeys baseMap ('\ESC':c:cs) = KeyMeta c : lexKeys baseMap cs+lexKeys baseMap (c:cs) = KeyChar c : lexKeys baseMap cs++lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key,[Char])+lookupChars _ [] = Nothing+lookupChars (TreeMap tm) (c:cs) = case Map.lookup c tm of+ Nothing -> Nothing+ Just (Nothing,t) -> lookupChars t cs+ Just (Just k, t@(TreeMap tm2))+ | not (null cs) && not (Map.null tm2) -- ?? lookup d tm2?+ -> lookupChars t cs+ | otherwise -> Just (k, cs)++-----------------------------++withPosixGetEvent :: MonadException m => Maybe Terminal -> Bool -> (m Event -> m a) -> m a+withPosixGetEvent term useSigINT f = do+ baseMap <- liftIO (getKeySequences term)+ eventChan <- liftIO $ newTChanIO+ wrapKeypad term + $ withWindowHandler eventChan+ $ withSigIntHandler useSigINT eventChan+ $ f $ liftIO $ getEvent baseMap eventChan++-- If the keypad on/off capabilities are defined, wrap the computation with them.+wrapKeypad :: MonadException m => Maybe Terminal -> m a -> m a+wrapKeypad Nothing f = f+wrapKeypad (Just term) f = (maybeOutput keypadOn >> f) + `finally` maybeOutput keypadOn+ where+ maybeOutput cap = liftIO $ runTermOutput term $+ fromMaybe mempty (getCapability term cap)++withWindowHandler :: MonadException m => TChan Event -> m a -> m a+withWindowHandler eventChan = withHandler windowChange $ Catch $+ getPosixLayout >>= atomically . writeTChan eventChan . WindowResize++withSigIntHandler :: MonadException m => Bool -> TChan Event -> m a -> m a+withSigIntHandler False _ = id+withSigIntHandler True eventChan = withHandler keyboardSignal $ CatchOnce $+ atomically $ writeTChan eventChan SigInt++withHandler :: MonadException m => Signal -> Handler -> m a -> m a+withHandler signal handler f = do+ old_handler <- liftIO $ installHandler signal handler Nothing+ f `finally` liftIO (installHandler signal old_handler Nothing)++getEvent :: TreeMap Char Key -> TChan Event -> IO Event+getEvent baseMap = keyEventLoop readKeyEvents+ where+ bufferSize = 100+ readKeyEvents eventChan = do+ -- 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+ bs <- B.hGetNonBlocking stdin bufferSize+ let cs = UTF8.toString bs+ let ks = map KeyInput $ lexKeys baseMap cs+ if null ks+ then readKeyEvents eventChan+ else atomically $ mapM_ (writeTChan eventChan) ks+
+ System/Console/Haskeline/Backend/Terminfo.hs view
@@ -0,0 +1,266 @@+module System.Console.Haskeline.Backend.Terminfo(+ Draw(),+ runTerminfoDraw+ )+ where++import System.Console.Terminfo+import Control.Monad+import Data.List(intersperse)+import System.IO (hFlush,stdout)+import qualified Control.Exception as Exception++import System.Console.Haskeline.Monads as Monads+import System.Console.Haskeline.LineState+import System.Console.Haskeline.Command+import System.Console.Haskeline.Term+import System.Console.Haskeline.Backend.Posix+import qualified Codec.Binary.UTF8.String as UTF8++-- | Keep track of all of the output capabilities we can use.+-- +-- We'll be frequently using the (automatic) 'Monoid' instance for +-- @Actions -> TermOutput@.+data Actions = Actions {leftA, rightA, upA :: Int -> TermOutput,+ clearToLineEnd :: TermOutput,+ nl, cr :: TermOutput,+ bellAudible,bellVisual :: TermOutput,+ clearAll :: LinesAffected -> TermOutput,+ wrapLine :: TermOutput}++getActions :: Capability Actions+getActions = do+ leftA' <- moveLeft+ rightA' <- moveRight+ upA' <- moveUp+ clearToLineEnd' <- clearEOL+ clearAll' <- clearScreen+ nl' <- newline+ cr' <- carriageReturn+ -- Don't require the bell capabilities+ bellAudible' <- bell `mplus` return mempty+ bellVisual' <- visualBell `mplus` return mempty+ wrapLine' <- getWrapLine nl' (leftA' 1)+ return Actions{leftA=leftA',rightA=rightA',upA=upA',+ clearToLineEnd=clearToLineEnd',nl=nl',cr=cr',+ bellAudible=bellAudible', bellVisual=bellVisual',+ clearAll=clearAll',+ wrapLine=wrapLine'}++text :: String -> Actions -> TermOutput+text str _ = termText (UTF8.encodeString str)++getWrapLine :: TermOutput -> TermOutput -> Capability TermOutput+getWrapLine nl' left1 = (autoRightMargin >>= guard >> withAutoMargin)+ `mplus` return nl'+ where + -- If the wraparound glitch is in effect, force a wrap by printing a space.+ -- Otherwise, it'll wrap automatically.+ withAutoMargin = (do+ wraparoundGlitch >>= guard+ return (termText " " <#> left1)+ )`mplus` return mempty+ +left,right,up :: Int -> Actions -> TermOutput+left = flip leftA+right = flip rightA+up = flip upA+++--------+++mreplicate :: Monoid m => Int -> m -> m+mreplicate n m+ | n <= 0 = mempty+ | otherwise = m `mappend` mreplicate (n-1) m++-- denote in modular arithmetic;+-- in particular, 0 <= termCol < width+data TermPos = TermPos {termRow,termCol :: Int}+ deriving Show++initTermPos :: TermPos+initTermPos = TermPos {termRow = 0, termCol = 0}+++--------------++newtype Draw m a = Draw {unDraw :: ReaderT Actions (ReaderT Terminal (StateT TermPos m)) a}+ deriving (Monad,MonadIO,MonadReader Actions,MonadReader Terminal,+ MonadState TermPos)++instance MonadReader Layout m => MonadReader Layout (Draw m) where+ ask = lift ask+ local r = Draw . local r . unDraw++instance MonadException m => MonadException (Draw m) where+ block = Draw . block . unDraw+ unblock = Draw . unblock . unDraw+ catch (Draw f) g = Draw $ Monads.catch f (unDraw . g)+++instance MonadTrans Draw where+ lift = Draw . lift . lift . lift+ +runTerminfoDraw :: (MonadException m, MonadLayout m) => IO (Maybe (RunTerm m))+runTerminfoDraw = do+ mterm <- Exception.try setupTermFromEnv+ case mterm of+ Left _ -> return Nothing+ Right term -> case getCapability term getActions of+ Nothing -> return Nothing+ Just actions -> return $ Just $ RunTerm {+ getLayout = getPosixLayout,+ withGetEvent = withPosixGetEvent (Just term),+ putStrTerm = putStr . UTF8.encodeString,+ runTerm = \(Draw f) -> evalStateT' initTermPos + $ runReaderT' term+ $ runReaderT' actions f+ }+ +output :: MonadIO m => (Actions -> TermOutput) -> Draw m ()+output f = do+ toutput <- asks f+ term <- ask+ liftIO $ runTermOutput term toutput+ liftIO $ hFlush stdout++++changeRight, changeLeft :: MonadLayout m => Int -> Draw m ()+changeRight n = do+ w <- asks width+ TermPos {termRow=r,termCol=c} <- get+ if c+n < w + then do+ put TermPos {termRow=r,termCol=c+n}+ output (right n)+ else do+ let m = c+n+ let linesDown = m `div` w+ let newCol = m `rem` w+ put TermPos {termRow=r+linesDown, termCol=newCol}+ output $ cr <#> mreplicate linesDown nl <#> right newCol+ +changeLeft n = do+ w <- asks width+ TermPos {termRow=r,termCol=c} <- get+ if c - n >= 0 + then do + put TermPos {termRow = r,termCol = c-n}+ output (left n)+ else do + let m = n - c+ let linesUp = 1 + ((m-1) `div` w)+ let newCol = (-m) `mod` w -- mod returns positive #+ put TermPos {termRow = r - linesUp, termCol=newCol}+ 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 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 str = do+ w <- asks width+ TermPos {termRow=r,termCol=c} <- get+ let roomLeft = w - c+ if length str < roomLeft+ then do+ output (text str)+ put TermPos{termRow=r, termCol=c+length str}+ return ""+ else do+ let (thisLine,rest) = splitAt roomLeft str+ output (text thisLine <#> wrapLine)+ put TermPos {termRow=r+1,termCol=0}+ return rest++drawLineDiffT :: (LineState s, LineState t, MonadLayout m) + => String -> s -> t -> Draw m ()+drawLineDiffT prefix s1 s2 = let + xs1 = beforeCursor prefix s1+ ys1 = afterCursor s1+ xs2 = beforeCursor prefix s2+ ys2 = afterCursor s2+ in case matchInit xs1 xs2 of+ ([],[]) | ys1 == ys2 -> return ()+ (xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (length xs1')+ ([],xs2') | ys1 == xs2' ++ ys2 -> changeRight (length xs2')+ (xs1',xs2') -> do+ changeLeft (length xs1')+ printText (xs2' ++ ys2)+ let m = length xs1' + length ys1 - (length xs2' + length ys2)+ clearDeadText m+ changeLeft (length ys2)++linesLeft :: Layout -> TermPos -> Int -> Int+linesLeft Layout {width=w} TermPos {termCol = c} n+ | c + n < w = 1+ | otherwise = 1 + div (c+n) w++lsLinesLeft :: LineState s => Layout -> TermPos -> s -> Int+lsLinesLeft layout pos s = linesLeft layout pos (lengthToEnd s)++clearDeadText :: MonadLayout m => Int -> Draw m ()+clearDeadText n+ | n <= 0 = return ()+ | otherwise = do+ layout <- ask+ pos <- get+ let numLinesToClear = linesLeft layout pos n+ output clearToLineEnd+ when (numLinesToClear > 1) $ output $ mconcat [+ mreplicate (numLinesToClear - 1) + $ nl <#> clearToLineEnd+ , up (numLinesToClear - 1)+ , right (termCol pos)]++clearLayoutT :: MonadLayout m => Draw m ()+clearLayoutT = do+ h <- asks height+ output (flip clearAll h)+ put initTermPos++moveToNextLineT :: (LineState s, MonadLayout m) => s -> Draw m ()+moveToNextLineT s = do+ pos <- get+ layout <- ask+ output $ mreplicate (lsLinesLeft layout pos s) nl+ put initTermPos+++posFromLength :: Layout -> Int -> TermPos+posFromLength Layout {width = w} n = TermPos + {termRow = n `div` w, termCol = n `mod` w}++posToLength :: Layout -> TermPos -> Int+posToLength Layout {width = w} TermPos {termRow = r, termCol = c}+ = r * w + c++reposition :: Layout -> Layout -> TermPos -> TermPos+reposition oldLayout newLayout oldPos = posFromLength newLayout $ + posToLength oldLayout oldPos++withRepositionT :: MonadReader Layout m => Layout -> Draw m a -> Draw m a+withRepositionT newLayout f = do+ oldPos <- get+ oldLayout <- ask+ let newPos = reposition oldLayout newLayout oldPos+ put newPos+ local newLayout f++instance MonadLayout m => Term (Draw m) where+ drawLineDiff = drawLineDiffT+ withReposition = withRepositionT+ + printLines [] = return ()+ printLines ls = output $ mconcat $ intersperse nl (map text ls) ++ [nl] + clearLayout = clearLayoutT+ moveToNextLine = moveToNextLineT+ ringBell True = output bellAudible+ ringBell False = output bellVisual
+ System/Console/Haskeline/Backend/Win32.hsc view
@@ -0,0 +1,284 @@+module System.Console.Haskeline.Backend.Win32( + Draw(), + win32Term + )where + + +import System.IO +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.C.Types +import Foreign.Marshal.Utils +import System.Win32.Types +import Graphics.Win32.Misc(getStdHandle, sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE) +import Data.List(intercalate) +import Control.Concurrent +import Control.Concurrent.STM + +import System.Console.Haskeline.Command +import System.Console.Haskeline.Monads +import System.Console.Haskeline.LineState +import System.Console.Haskeline.Term + +#include "win_console.h" + +foreign import stdcall "windows.h ReadConsoleInputW" c_ReadConsoleInput + :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool + +foreign import stdcall "windows.h WaitForSingleObject" c_WaitForSingleObject + :: HANDLE -> DWORD -> IO DWORD + +getEvent :: HANDLE -> TChan Event -> IO Event +getEvent h = keyEventLoop readKeyEvents + where + waitTime = 200 -- milliseconds + readKeyEvents eventChan = do + yield -- since the foreign call to WaitForSingleObject blocks the killThread + ret <- c_WaitForSingleObject h waitTime + if ret /= (#const WAIT_OBJECT_0) + then readKeyEvents eventChan + else do + e <- readEvent h + case eventToKey e of + Just k -> atomically $ writeTChan eventChan (KeyInput k) + Nothing -> readKeyEvents eventChan + + +eventToKey :: InputEvent -> Maybe Key +eventToKey KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc} + | c /= '\NUL' = Just (KeyChar c) + | otherwise = keyFromCode vc -- special character; see below. +eventToKey _ = Nothing + +keyFromCode :: WORD -> Maybe Key +keyFromCode (#const VK_BACK) = Just Backspace +keyFromCode (#const VK_LEFT) = Just KeyLeft +keyFromCode (#const VK_RIGHT) = Just KeyRight +keyFromCode (#const VK_UP) = Just KeyUp +keyFromCode (#const VK_DOWN) = Just KeyDown +keyFromCode (#const VK_DELETE) = Just DeleteForward +-- TODO: KeyMeta (option-x), KillLine +keyFromCode _ = Nothing + +data InputEvent = KeyEvent {keyDown :: BOOL, + repeatCount :: WORD, + virtualKeyCode :: WORD, + virtualScanCode :: WORD, + unicodeChar :: Char, + controlKeyState :: DWORD} + -- TODO: WINDOW_BUFFER_SIZE_RECORD + -- I cant figure out how the user generates them. + | OtherEvent + deriving Show + +readEvent :: HANDLE -> IO InputEvent +readEvent h = allocaBytes (#size INPUT_RECORD) $ \pRecord -> + alloca $ \numEventsPtr -> do + failIfFalse_ "ReadConsoleInput" + $ c_ReadConsoleInput h pRecord 1 numEventsPtr + -- useful? numEvents <- peek numEventsPtr + eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord + let eventPtr = (#ptr INPUT_RECORD, Event) pRecord + case eventType of + (#const KEY_EVENT) -> getKeyEvent eventPtr + _ -> return OtherEvent + +getKeyEvent :: Ptr () -> IO InputEvent +getKeyEvent p = do + kDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) p + repeat' <- (#peek KEY_EVENT_RECORD, wRepeatCount) p + keyCode <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) p + scanCode <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) p + char :: CWchar <- (#peek KEY_EVENT_RECORD, uChar) p + state <- (#peek KEY_EVENT_RECORD, dwControlKeyState) p + return KeyEvent {keyDown = kDown', + repeatCount = repeat', + virtualKeyCode = keyCode, + virtualScanCode = scanCode, + unicodeChar = toEnum (fromEnum char), + controlKeyState = state} + +data Coord = Coord {coordX, coordY :: Int} + deriving Show + +instance Storable Coord where + sizeOf _ = (#size COORD) + alignment = undefined -- ??? + peek p = do + x :: CShort <- (#peek COORD, X) p + y :: CShort <- (#peek COORD, Y) p + return Coord {coordX = fromEnum x, coordY = fromEnum y} + poke p c = do + (#poke COORD, X) p (toEnum (coordX c) :: CShort) + (#poke COORD, Y) p (toEnum (coordY c) :: CShort) + + +foreign import ccall "SetPosition" + c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool + +setPosition :: HANDLE -> Coord -> IO () +setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition" + . c_SetPosition h + +foreign import stdcall "windows.h GetConsoleScreenBufferInfo" + c_GetScreenBufferInfo :: HANDLE -> Ptr () -> IO Bool + +getPosition :: HANDLE -> IO Coord +getPosition = withScreenBufferInfo $ + (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) + +withScreenBufferInfo :: (Ptr () -> IO a) -> HANDLE -> IO a +withScreenBufferInfo f h = allocaBytes (#size CONSOLE_SCREEN_BUFFER_INFO) + $ \infoPtr -> do + failIfFalse_ "GetConsoleScreenBufferInfo" + $ c_GetScreenBufferInfo h infoPtr + f infoPtr + + +getDisplayWindow :: HANDLE -> IO (Coord,Coord) +getDisplayWindow = withScreenBufferInfo $ \p -> do + let windowPtr = (#ptr CONSOLE_SCREEN_BUFFER_INFO, srWindow) p + left <- (#peek SMALL_RECT, Left) windowPtr + top <- (#peek SMALL_RECT, Top) windowPtr + right <- (#peek SMALL_RECT, Right) windowPtr + bottom <- (#peek SMALL_RECT, Bottom) windowPtr + return (Coord (cvt left) (cvt top), Coord (cvt right) (cvt bottom)) + where + cvt :: CShort -> Int + cvt = fromEnum + +foreign import stdcall "windows.h WriteConsoleW" c_WriteConsoleW + :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool + +writeConsole :: HANDLE -> String -> IO () +writeConsole h str = withArray tstr $ \t_arr -> alloca $ \numWritten -> do + failIfFalse_ "WriteConsole" + $ c_WriteConsoleW h t_arr (toEnum $ length str) numWritten nullPtr + where + tstr = map (toEnum . fromEnum) str + +---------------------------- +-- Drawing + +newtype Draw m a = Draw {runDraw :: m a} + deriving (Monad,MonadIO,MonadException) + +instance MonadTrans Draw where + lift = Draw + +instance MonadReader Layout m => MonadReader Layout (Draw m) where + ask = lift ask + local r = Draw . local r . runDraw + +getInputHandle, getOutputHandle :: MonadIO m => m HANDLE +getInputHandle = liftIO $ getStdHandle sTD_INPUT_HANDLE +getOutputHandle = liftIO $ getStdHandle sTD_OUTPUT_HANDLE + +getDisplaySize :: IO Layout +getDisplaySize = do + h <- getOutputHandle + (topLeft,bottomRight) <- getDisplayWindow h + return Layout {width = coordX bottomRight - coordX topLeft+1, + height = coordY bottomRight - coordY topLeft+1 } + +getPos :: MonadIO m => Draw m Coord +getPos = getOutputHandle >>= liftIO . getPosition + +setPos :: MonadIO m => Coord -> Draw m () +setPos c = do + h <- getOutputHandle + liftIO (setPosition h c) + +printText :: MonadIO m => String -> m () +printText txt = do + h <- getOutputHandle + liftIO (writeConsole h txt) + +printAfter :: MonadLayout m => String -> Draw m () +printAfter str = do + p <- getPos + printText str + setPos p + +drawLineDiffWin :: (LineState s, LineState t, MonadLayout m) + => String -> s -> t -> Draw m () +drawLineDiffWin prefix s1 s2 = let + xs1 = beforeCursor prefix s1 + ys1 = afterCursor s1 + xs2 = beforeCursor prefix s2 + ys2 = afterCursor s2 + in case matchInit xs1 xs2 of + ([],[]) | ys1 == ys2 -> return () + (xs1',[]) | xs1' ++ ys1 == ys2 -> movePos $ negate $ length xs1' + ([],xs2') | ys1 == xs2' ++ ys2 -> movePos $ length xs2' + (xs1',xs2') -> do + movePos (negate $ length xs1') + let m = length xs1' + length ys1 - (length xs2' + length ys2) + let deadText = replicate m ' ' + printText xs2' + printAfter (ys2 ++ deadText) + +movePos :: MonadLayout m => Int -> Draw m () +movePos n = do + Coord {coordX = x, coordY = y} <- getPos + w <- asks width + let (h,x') = divMod (x+n) w + setPos Coord {coordX = x', coordY = y+h} + +crlf :: String +crlf = "\r\n" + +instance MonadLayout m => Term (Draw m) where + drawLineDiff = drawLineDiffWin + withReposition _ = id -- TODO + + printLines [] = return () + printLines ls = printText $ intercalate crlf ls ++ crlf + + clearLayout = do + lay <- ask + setPos (Coord 0 0) + printText (replicate (width lay * height lay) ' ') + setPos (Coord 0 0) + + moveToNextLine s = do + movePos (lengthToEnd s) + printText "\r\n" -- make the console take care of creating a new line + + ringBell _ = return () -- TODO + +win32Term :: (MonadLayout m, MonadException m) => RunTerm m +win32Term = RunTerm { + getLayout = getDisplaySize, + runTerm = runDraw, + withGetEvent = \useSigINT f -> do + h <- getInputHandle + eventChan <- liftIO $ newTChanIO + withCtrlCHandler useSigINT eventChan + $ f $ liftIO $ getEvent h eventChan, + putStrTerm = printText + } + +type Handler = DWORD -> IO BOOL + +foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler) + +foreign import stdcall "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler + :: FunPtr Handler -> BOOL -> IO BOOL + +-- sets the tv to True when ctrl-c is pressed. +withCtrlCHandler :: MonadException m => Bool -> TChan Event -> m a -> m a +withCtrlCHandler False _ f = f +withCtrlCHandler True eventChan f = bracket (liftIO $ do + fp <- wrapHandler handler + c_SetConsoleCtrlHandler fp True + return fp) + (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False) + (const f) + where + handler (#const CTRL_C_EVENT) = do + atomically $ writeTChan eventChan SigInt + return True + handler _ = return False
+ System/Console/Haskeline/Command.hs view
@@ -0,0 +1,164 @@+module System.Console.Haskeline.Command(+ Event(..),+ Key(..),+ controlKey,+ Layout(..),+ -- * Commands+ Effect(..),+ KeyMap(), + lookupKM,+ KeyAction(..),+ CmdAction(..),+ (>=>),+ Command(),+ runCommand,+ continue,+ (>|>),+ (>+>),+ acceptKey,+ acceptKeyM,+ acceptKeyOrFail,+ loopUntil,+ try,+ finish,+ failCmd,+ simpleCommand,+ charCommand,+ change,+ changeFromChar,+ changeWithoutKey,+ clearScreenCmd,+ (+>),+ choiceCmd+ ) where++import Data.Char(isPrint)+import Control.Monad(mplus)+import Data.Bits+import System.Console.Haskeline.LineState++data Layout = Layout {width, height :: Int}+ deriving Show++data Key = KeyChar Char | KeyMeta Char+ | KeyLeft | KeyRight | KeyUp | KeyDown+ | Backspace | DeleteForward | KillLine+ deriving (Eq,Ord,Show)++data Event = WindowResize Layout | KeyInput Key+ | SigInt+ deriving Show++-- Easy translation of control characters; e.g., Ctrl-G or Ctrl-g or ^G+controlKey :: Char -> Key+controlKey '?' = KeyChar (toEnum 127)+controlKey c = KeyChar $ toEnum $ fromEnum c .&. complement (bit 5 .|. bit 6)+++data Effect s = Change {effectState :: s} + | PrintLines {linesToPrint :: [String], effectState :: s}+ | Redraw {shouldClearScreen :: Bool, effectState :: s}+ | RingBell {effectState :: s}++newtype KeyMap m s = KeyMap {lookupKM :: Key -> Maybe + (s -> Either (Maybe String) (m (KeyAction m)))}++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 KeyAction m = forall t . LineState t => KeyAction (Effect t) (KeyMap m t)++nullKM :: KeyMap m s+nullKM = KeyMap $ const Nothing++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++newtype Command m s t = Command (KeyMap m t -> KeyMap m s)++runCommand :: Command m s s -> KeyMap m s+runCommand (Command f) = let m = f m in m++continue :: Command m s s+continue = Command id++infixl 6 >|>+(>|>) :: Command m s t -> Command m t u -> Command m s u+Command f >|> Command g = Command (f . g)++infixl 6 >+>+(>+>) :: (Monad m, LineState s) => Key -> Command m s t -> Command m s t+k >+> f = k +> change id >|> f++data CmdAction m s = forall t . LineState t => CmdAction (Effect t) (Command m t s)++(>=>) :: LineState t => Effect t -> Command m t s -> CmdAction m s+(>=>) = CmdAction++acceptKey :: (Monad m) => (s -> CmdAction m t) -> Key -> Command m s t+acceptKey f = acceptKeyFull (Just . return . f)++acceptKeyM :: Monad m => (s -> m (CmdAction m t)) -> Key -> Command m s t+acceptKeyM f = acceptKeyFull (Just . f)++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))++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]++try :: Command m s s -> Command m s s+try (Command f) = Command $ \next -> (f next) `orKM` next++finish :: forall s m t . (Result s, Monad m) => Key -> Command m s t+finish k = Command $ \_-> useKey k (Left . Just . toResult)++failCmd :: forall s m t . (LineState s, Monad m) => Key -> Command m s t+failCmd k = Command $ \_-> useKey k (const $ Left Nothing)++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)++charCommand :: (LineState t, Monad m) => (Char -> s -> m (Effect t))+ -> Command m s t+charCommand f = Command $ \next -> KeyMap $ \k -> case k of+ KeyChar c | isPrint c -> Just $ \s -> Right $ do+ effect <- f c s+ return (KeyAction effect next)+ _ -> Nothing+ ++change :: (LineState t, Monad m) => (s -> t) -> Key -> Command m s t+change f = simpleCommand (return . Change . f)++changeFromChar :: (Monad m, LineState t) => (Char -> s -> t) -> Command m s t+changeFromChar f = charCommand (\c s -> return $ Change (f c s))++changeWithoutKey :: (s -> t) -> Command m s t+changeWithoutKey f = Command $ \(KeyMap next) -> KeyMap $ fmap (. f) . next++clearScreenCmd :: (LineState s, Monad m) => Key -> Command m s s+clearScreenCmd k = k +> simpleCommand (\s -> return (Redraw True s))++infixl 7 +>+(+>) :: Key -> (Key -> a) -> a +k +> f = f k++choiceCmd :: [Command m s t] -> Command m s t+choiceCmd cmds = Command $ \next -> + choiceKM $ map (\(Command f) -> f next) cmds
+ System/Console/Haskeline/Command/Completion.hs view
@@ -0,0 +1,149 @@+module System.Console.Haskeline.Command.Completion(+ CompletionFunc,+ Completion,+ CompletionType(..),+ completionCmd+ ) where++import System.Console.Haskeline.Command+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)++makeCompletion :: Monad m => InsertMode -> InputCmdT m (InsertMode, [Completion])+makeCompletion (IMode xs ys) = do+ f <- asks complete+ (rest,completions) <- liftCmdT (f xs)+ return (IMode rest ys,completions)++-- | Create a 'Command' for word completion.+completionCmd :: Monad m => Key -> Command (InputCmdT m) InsertMode InsertMode+completionCmd k = k +> acceptKeyM (\s -> do+ prefs <- ask+ (rest,completions) <- makeCompletion s+ case completionType prefs of+ MenuCompletion -> return $ menuCompletion k s+ $ map (\c -> insertString (replacement c) rest) completions+ ListCompletion -> + pagingCompletion prefs s rest completions k)++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 (replacement 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))+ 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 [+ KeyChar 'y' +> acceptKey (const printingCmd)+ , KeyChar '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 [+ KeyChar ' ' +> acceptKeyM (printPage ws)+ ,KeyChar 'q' +> change messageState+ ,KeyChar '\n' +> acceptKey (printOneLine ws)+ ]+++printAll :: Monad m => [String] -> InsertMode + -> CmdAction (InputCmdT m) InsertMode+printAll ws im = PrintLines ws im >=> continue+++makeLines :: [String] -> Layout -> [String]+makeLines ws layout = let+ minColPad = 2+ printWidth = width layout+ maxLength = min printWidth (maximum (map length ws) + minColPad)+ numCols = printWidth `div` maxLength+ ls = if (maxLength >= printWidth)+ then map (\x -> [x]) ws+ else splitIntoGroups numCols ws+ in map (padWords maxLength) ls++-- Add spaces to the end of each word so that it takes up the given length.+-- Don't padd the word in the last column, since printing a space in the last column+-- causes a line wrap on some terminals.+padWords :: Int -> [String] -> String+padWords _ [x] = x+padWords _ [] = ""+padWords len (x:xs) = x ++ replicate (len - length x) ' '+ ++ padWords len xs++-- Split xs into rows of length n,+-- such that the list increases incrementally along the columns.+-- e.g.: splitIntoGroups 4 [1..11] ==+-- [[1,4,7,10]+-- ,[2,5,8,11]+-- ,[3,6,9]]+splitIntoGroups :: Int -> [a] -> [[a]]+splitIntoGroups n xs = transpose $ unfoldr f xs+ where+ f [] = Nothing+ f ys = Just (splitAt k ys)+ k = ceilDiv (length xs) n++-- ceilDiv m n is the smallest k such that k * n >= m.+ceilDiv :: Integral a => a -> a -> a+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
@@ -0,0 +1,145 @@+module System.Console.Haskeline.Command.History where++import System.Console.Haskeline.LineState+import System.Console.Haskeline.Command+import Control.Monad(liftM,mplus)+import System.Console.Haskeline.Monads+import Data.List+import Data.Maybe(fromMaybe)+import Control.Exception(evaluate)+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as UTF8++import System.Directory(doesFileExist)++data History = History {historyLines :: [String]} -- stored in reverse++data HistLog = HistLog {pastHistory, futureHistory :: [String]}+ deriving Show++prevHistoryM :: String -> HistLog -> Maybe (String,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 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 = []}++runHistoryFromFile :: MonadIO m => Maybe FilePath -> Maybe Int -> StateT History m a -> m a+runHistoryFromFile Nothing _ f = evalStateT' (History []) f+runHistoryFromFile (Just file) stifleAmt f = do+ contents <- liftIO $ do+ exists <- doesFileExist file+ if exists+ -- use binary file I/O to avoid Windows CRLF line endings+ -- which cause confusion when switching between systems.+ then fmap UTF8.toString (B.readFile file)+ else return ""+ liftIO $ evaluate (length contents) -- force file closed+ let oldHistory = History (lines contents)+ (x,newHistory) <- runStateT f oldHistory+ let stifle = case stifleAmt of+ Nothing -> id+ Just m -> take m+ liftIO $ B.writeFile file $ UTF8.fromString + $ unlines $ stifle $ historyLines newHistory+ return x++addHistory :: MonadState History m => String -> m ()+addHistory l = modify $ \(History ls) -> History (l:ls)++runHistLog :: Monad m => StateT HistLog m a -> StateT History m a+runHistLog f = do+ history <- get+ 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')++historyBack, historyForward :: (FromString s, MonadState HistLog m) => + Key -> Command m s s+historyBack = simpleCommand $ histUpdate prevHistory+historyForward = simpleCommand $ reverseHist $ histUpdate prevHistory++histUpdate :: MonadState HistLog m => (s -> HistLog -> (t,HistLog))+ -> s -> m (Effect t)+histUpdate f = liftM Change . update . f++reverseHist :: MonadState HistLog m => (a -> m b) -> a -> m b+reverseHist f x = do+ modify reverser+ y <- f x+ modify reverser+ return y+ where+ reverser h = HistLog {futureHistory=pastHistory h, + pastHistory=futureHistory h}++data SearchMode = SearchMode {searchTerm :: String,+ foundHistory :: InsertMode}+ deriving Show++instance LineState SearchMode where+ beforeCursor _ sm = beforeCursor prefix (foundHistory sm)+ where prefix = "(reverse-i-search)`" ++ searchTerm sm ++ "': "+ afterCursor = afterCursor . foundHistory++instance Result SearchMode where+ toResult = toResult . foundHistory++startSearchMode :: InsertMode -> SearchMode+startSearchMode im = SearchMode {searchTerm = "",foundHistory=im}++addChar :: Char -> SearchMode -> SearchMode+addChar c s = s {searchTerm = searchTerm s ++ [c]}++searchHistories :: String -> [(String,HistLog)] -> Maybe (SearchMode,HistLog)+searchHistories text = foldr mplus Nothing . map findIt+ where+ findIt (l,h) = do + im <- findInLine text l+ return (SearchMode text im,h)++findInLine :: String -> String -> Maybe InsertMode+findInLine text l = find' [] l+ where+ 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 sm h = let+ text = searchTerm sm+ l = toResult sm+ in (text,prevHistories l h)++searchHistory :: MonadState HistLog m => Command m InsertMode InsertMode+searchHistory = controlKey 'r' +> change startSearchMode >|> backSearching+ where+ backKey = controlKey 'r'+ backSearching = choiceCmd [+ choiceCmd [+ charCommand oneMoreChar+ , backKey +> simpleCommand searchBackMore+ , Backspace +> change delLastChar+ , KeyChar '\b' +> change delLastChar+ ] >|> backSearching+ , changeWithoutKey foundHistory -- abort+ ]+ delLastChar s = s {searchTerm = minit (searchTerm s)}+ minit xs = if null xs then "" else init xs+ oneMoreChar c = histUpdate (\s h -> let+ (text,hists) = prepSearch s h+ in fromMaybe (s,h) $ searchHistories text ((toResult s,h):hists)+ ) . addChar c+ searchBackMore = histUpdate $ \s h -> let+ (text,hists) = prepSearch s h+ in fromMaybe (s,h) $ searchHistories text hists
+ System/Console/Haskeline/Completion.hs view
@@ -0,0 +1,131 @@+module System.Console.Haskeline.Completion(+ CompletionFunc,+ Completion(..),+ completeWord,+ simpleCompletion,+ noCompletion,+ completeFilename,+ filenameWordBreakChars+ ) where+++import System.Directory+import System.FilePath+import Data.List(isPrefixOf)+import Control.Monad(forM)++import System.Console.Haskeline.Monads++-- | Performs completions from a reversed 'String'. +-- The output 'String' is also reversed.+-- Use 'completeWord' to build these functions.++type CompletionFunc m = String -> m (String, [Completion])+++data Completion = Completion {replacement :: String, -- ^ Text to insert in line.+ display :: String+ -- ^ Text to display when listing+ -- alternatives.+ }+ deriving Show++-- | Disable completion altogether.+noCompletion :: Monad m => CompletionFunc m+noCompletion s = return (s,[])++--------------+-- Word break functions++-- | The following function creates a custom 'CompletionFunc' for use in the 'Settings.'+completeWord :: Monad m => Maybe Char + -- ^ An optional escape character+ -> String -- ^ List of characters which count as whitespace+ -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions+ -> CompletionFunc m+completeWord esc ws f line = do+ let (word,rest) = case esc of+ Nothing -> break (`elem` ws) line+ Just e -> escapedBreak e line+ completions <- f (reverse word)+ return (rest,completions)+ where+ escapedBreak e (c:d:cs) | d == e+ = let (xs,ys) = escapedBreak e cs in (c:d:xs,ys)+ escapedBreak e (c:cs) | not (elem c ws)+ = let (xs,ys) = escapedBreak e cs in (c:xs,ys)+ escapedBreak _ cs = ("",cs)+ +-- | Adds a space after the word when inserting it after expansion.+simpleCompletion :: String -> Completion+simpleCompletion = setReplacement (++ " ") . completion++-- NOTE: this is the same as for readline, except that I took out the '\\'+-- so they can be used as a path separator.+filenameWordBreakChars :: String+filenameWordBreakChars = " \t\n`@$><=;|&{("++-- A completion command for file and folder names.+completeFilename :: MonadIO m => CompletionFunc m+completeFilename = completeWord (Just '\\') filenameWordBreakChars $ + (liftIO . quotedFilenames (`elem` "\"\'"))++completion :: String -> Completion+completion str = Completion str str++setReplacement :: (String -> String) -> Completion -> Completion+setReplacement f c = c {replacement = f $ replacement c}+++--------+-- Helper funcs for file completion++quotedFilenames :: (Char -> Bool) -> String -> IO [Completion]+quotedFilenames isQuote (q:file) | isQuote q = do+ files <- findFiles file+ return $ map (setReplacement ((q:) . appendIfNotDir [q,' '])) files+quotedFilenames _ file = do+ files <- findFiles file+ return $ map (setReplacement (appendIfNotDir " ")) files++appendIfNotDir :: String -> FilePath -> FilePath+appendIfNotDir str file | null (takeFileName file) = file+ | otherwise = file ++ str++findFiles :: FilePath -> IO [Completion]+-- NOTE: 'handle' catches exceptions from getDirectoryContents and getHomeDirectory.+findFiles path = handle (\_ -> return []) $ do+ fixedDir <- fixPath dir+ dirExists <- doesDirectoryExist fixedDir+ -- get all of the files in that directory, as basenames+ allFiles <- if not dirExists+ then return []+ else fmap (map completion . filterPrefix) + $ getDirectoryContents fixedDir+ -- The replacement text should include the directory part, and also + -- have a trailing slash if it's itself a directory.+ forM allFiles $ \c -> do+ isDir <- doesDirectoryExist (fixedDir </> replacement c)+ return $ setReplacement (fullName . maybeAddSlash isDir) c+ where+ (dir, file) = splitFileName path+ filterPrefix = filter (\f -> not (f `elem` [".",".."])+ && file `isPrefixOf` f)+ maybeAddSlash False = id+ maybeAddSlash True = addTrailingPathSeparator+ -- NOTE In order for completion to work properly, all of the alternatives+ -- must have the exact same prefix. As a result, </> is a little too clever;+ -- for example, it doesn't prepend the directory if the file looks like+ -- 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++-- turn a user-visible path into an internal version useable by System.FilePath.+fixPath :: String -> IO String+fixPath "" = return "."+fixPath ('~':c:path) | isPathSeparator c = do+ home <- getHomeDirectory+ return (home </> path)+fixPath path = return path+
+ System/Console/Haskeline/Emacs.hs view
@@ -0,0 +1,50 @@+module System.Console.Haskeline.Emacs where++import System.Console.Haskeline.Command+import System.Console.Haskeline.Command.Completion+import System.Console.Haskeline.Command.History+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++emacsCommands :: Monad m => KeyMap (InputCmdT m) InsertMode+emacsCommands = runCommand $ choiceCmd [simpleActions, controlActions]++simpleActions, controlActions :: InputCmd InsertMode InsertMode+simpleActions = choiceCmd + [ KeyChar '\n' +> finish+ , KeyChar '\r' +> finish+ , KeyLeft +> change goLeft+ , KeyRight +> change goRight+ , Backspace +> change deletePrev+ , KeyChar '\b' +> change deletePrev+ , DeleteForward +> change deleteNext + , changeFromChar insertChar+ , KeyChar '\t' +> completionCmd+ , KeyUp +> historyBack+ , KeyDown +> historyForward+ , searchHistory+ ] + +controlActions = choiceCmd+ [ controlKey 'a' +> change moveToStart + , controlKey 'e' +> change moveToEnd+ , controlKey 'b' +> change goLeft+ , controlKey 'c' +> change goRight+ , controlKey 'd' +> deleteCharOrEOF+ , controlKey 'l' +> clearScreenCmd+ , KeyMeta 'f' +> change (skipRight isAlphaNum+ . skipRight (not . isAlphaNum))+ , KeyMeta 'b' +> change (skipLeft isAlphaNum+ . skipLeft (not . isAlphaNum))+ ]++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)
+ System/Console/Haskeline/InputT.hs view
@@ -0,0 +1,83 @@+module System.Console.Haskeline.InputT where+++import System.Console.Haskeline.Command.History+import System.Console.Haskeline.Monads as Monads+import System.Console.Haskeline.Prefs+import System.Console.Haskeline.Command(Layout)+import System.Console.Haskeline.Completion+import System.Console.Haskeline.Backend+import System.Console.Haskeline.Term++import System.Directory(getHomeDirectory)+import System.FilePath++-- | Application-specific customizations to the user interface.+data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion+ historyFile :: Maybe FilePath,+ handleSigINT :: Bool -- ^ Throw an 'Interrupt'+ -- exception if the user presses Ctrl-C+ }++-- | Because 'complete' is the only field of 'Settings' depending on @m@,+-- the expression @defaultSettings {completionFunc = f}@ leads to a type error+-- from being too general. This function may become unnecessary if another field+-- depending on @m@ is added.++setComplete :: CompletionFunc m -> Settings m -> Settings m+setComplete f s = s {complete = f}+++-- | 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 (InputCmdT m))+ (StateT History (ReaderT Prefs + (ReaderT (Settings m) m))) a}+ deriving (Monad,MonadIO, MonadState History,+ MonadReader Prefs, MonadReader (Settings m),+ MonadReader (RunTerm (InputCmdT m)))+++instance MonadTrans InputT where+ lift = InputT . lift . lift . lift . lift++instance MonadException m => MonadException (InputT m) where+ block = InputT . block . unInputT+ unblock = InputT . unblock . unInputT+ catch f h = InputT $ Monads.catch (unInputT f) (unInputT . h)++-- for internal use only+type InputCmdT m = ReaderT Layout (StateT HistLog (ReaderT Prefs (ReaderT (Settings m) m)))++instance MonadIO m => MonadLayout (InputCmdT m) where++runInputCmdT :: forall m a . MonadIO m => InputCmdT m a -> InputT m a+runInputCmdT f = InputT $ do+ run :: RunTerm (InputCmdT m) <- ask+ layout <- liftIO $ getLayout run+ lift $ runHistLog $ runReaderT' layout f+++liftCmdT :: Monad m => m a -> InputCmdT m a+liftCmdT = lift . lift . lift . lift++runInputTWithPrefs :: MonadException m => Prefs -> Settings m -> InputT m a -> m a+runInputTWithPrefs prefs settings (InputT f) = liftIO myRunTerm >>= \run -> + runReaderT' settings $ runReaderT' prefs + $ runHistoryFromFile (historyFile settings) (maxHistorySize prefs) + $ runReaderT f run+ +-- | Run a line-reading application, reading user 'Prefs' from +-- @~/.haskeline@+runInputT :: MonadException m => Settings m -> InputT m a -> m a+runInputT settings f = do+ prefs <- liftIO readPrefsFromHome+ runInputTWithPrefs prefs settings f++-- | Read 'Prefs' from @~/.haskeline.@ If there is an error reading the file,+-- the 'defaultPrefs' will be returned.+readPrefsFromHome :: IO Prefs+readPrefsFromHome = handle (\_ -> return defaultPrefs) $ do+ home <- getHomeDirectory+ readPrefs (home </> ".haskeline")+
+ System/Console/Haskeline/LineState.hs view
@@ -0,0 +1,168 @@+module System.Console.Haskeline.LineState where+++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++class LineState s => Result s where+ toResult :: s -> String++lengthToEnd :: LineState s => s -> Int+lengthToEnd = length . afterCursor++class (Result s) => FromString s where+ fromString :: String -> s++class Move s where+ goLeft, goRight, moveToStart, moveToEnd :: s -> s+ ++data InsertMode = IMode String String + deriving (Show, Eq)++instance LineState InsertMode where+ beforeCursor prefix (IMode xs _) = prefix ++ reverse xs+ afterCursor (IMode _ ys) = ys++instance Result InsertMode where+ toResult (IMode xs ys) = reverse xs ++ ys++instance Move InsertMode where+ goLeft im@(IMode [] _) = im + goLeft (IMode (x:xs) ys) = IMode xs (x:ys)++ goRight im@(IMode _ []) = im+ goRight (IMode ys (x:xs)) = IMode (x:ys) xs++ 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 "" ""++insertChar :: Char -> InsertMode -> InsertMode+insertChar c (IMode xs ys) = IMode (c:xs) ys++insertString :: String -> InsertMode -> InsertMode+insertString s (IMode xs ys) = IMode (reverse s ++ xs) ys++deleteNext, deletePrev :: InsertMode -> InsertMode+deleteNext im@(IMode _ []) = im+deleteNext (IMode xs (_:ys)) = IMode xs ys++deletePrev im@(IMode [] _) = im+deletePrev (IMode (_:xs) ys) = IMode xs ys ++skipLeft, skipRight :: (Char -> Bool) -> InsertMode -> InsertMode+skipLeft f (IMode xs ys) = let (ws,zs) = span f xs + in IMode zs (reverse ws ++ ys)+skipRight f (IMode xs ys) = let (ws,zs) = span f ys + in IMode (reverse ws ++ xs) zs+++data CommandMode = CMode String Char String | CEmpty+ deriving Show++instance LineState CommandMode where+ beforeCursor prefix CEmpty = prefix+ beforeCursor prefix (CMode xs _ _) = 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)++instance Move CommandMode where+ goLeft (CMode (x:xs) c ys) = CMode xs x (c:ys)+ goLeft cm = cm++ goRight (CMode xs c (y:ys)) = CMode (c:xs) y ys+ goRight cm = cm++ moveToStart (CMode xs c ys) = let zs = reverse xs ++ (c:ys) in CMode [] (head zs) (tail zs)+ moveToStart CEmpty = CEmpty++ 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 _ CEmpty = CEmpty++++------------------------+-- Transitioning between modes++enterCommandMode :: InsertMode -> CommandMode+enterCommandMode (IMode (x:xs) ys) = CMode xs x ys+enterCommandMode (IMode [] (y:ys)) = CMode [] y ys+enterCommandMode _ = CEmpty++insertFromCommandMode, appendFromCommandMode :: CommandMode -> InsertMode++insertFromCommandMode CEmpty = emptyIM+insertFromCommandMode (CMode xs c ys) = IMode xs (c:ys)++appendFromCommandMode CEmpty = emptyIM+appendFromCommandMode (CMode xs c ys) = IMode (c:xs) ys+++----------------------+-- Supplementary modes++data ArgMode s = ArgMode {arg :: Int, argState :: s}++instance LineState s => LineState (ArgMode s) where+ beforeCursor _ am = beforeCursor ("(arg: " ++ show (arg am) ++ ") ")+ (argState am)+ afterCursor = afterCursor . argState++instance Result s => Result (ArgMode s) where+ toResult = toResult . argState++startArg :: Int -> s -> ArgMode s+startArg = ArgMode++addNum :: Int -> ArgMode s -> ArgMode s+addNum n am+ | arg am >= 1000 = am -- shouldn't ever need more than 4 digits+ | otherwise = am {arg = arg am * 10 + n} ++-- 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)++---------------+data Cleared = Cleared++instance LineState Cleared where+ beforeCursor _ Cleared = ""+ afterCursor Cleared = ""++data Message s = Message {messageState :: s, messageText :: String}++instance LineState s => LineState (Message s) where+ beforeCursor _ = messageText+ afterCursor _ = ""+ isTemporary _ = True
+ System/Console/Haskeline/MonadException.hs view
@@ -0,0 +1,59 @@+{- | This module redefines some of the functions in "Control.Exception" to+work for more general monads than only 'IO'.+-}++module System.Console.Haskeline.MonadException where++import qualified Control.Exception as E+import Prelude hiding (catch)+import Control.Exception(Exception)+import Control.Monad.Reader+import Control.Monad.State++class MonadIO m => MonadException m where+ catch :: m a -> (Exception -> m a) -> m a+ block :: m a -> m a+ unblock :: m a -> m a++handle :: MonadException m => (Exception -> m a) -> m a -> m a+handle = flip catch++finally :: MonadException m => m a -> m b -> m a+finally f ender = block (do+ r <- catch+ (unblock f)+ (\e -> do {ender; throwIO e})+ ender+ return r)++throwIO :: MonadIO m => Exception -> m a+throwIO = liftIO . E.throwIO++bracket :: MonadException m => m a -> (a -> m b) -> (a -> m c) -> m c+bracket before after thing =+ block (do+ a <- before + r <- catch + (unblock (thing a))+ (\e -> do { after a; throwIO e })+ after a+ return r+ )+++instance MonadException IO where+ catch = E.catch+ block = E.block+ unblock = E.unblock++instance MonadException m => MonadException (ReaderT r m) where+ catch f h = ReaderT $ \r -> catch (runReaderT f r) + (\e -> runReaderT (h e) r)+ block = mapReaderT block+ unblock = mapReaderT unblock++instance MonadException m => MonadException (StateT s m) where+ catch f h = StateT $ \s -> catch (runStateT f s)+ (\e -> runStateT (h e) s)+ block = mapStateT block+ unblock = mapStateT unblock
+ System/Console/Haskeline/Monads.hs view
@@ -0,0 +1,72 @@+module System.Console.Haskeline.Monads(+ module Control.Monad.Trans,+ module System.Console.Haskeline.MonadException,+ ReaderT(..),+ runReaderT',+ asks,+ StateT(..),+ evalStateT',+ modify,+ update,+ MonadReader(..),+ MonadState(..)+ ) where++import Control.Monad.Trans+import System.Console.Haskeline.MonadException++import Control.Monad.Reader hiding (MonadReader,ask,asks,local)+import qualified Control.Monad.Reader as Reader+import Control.Monad.State hiding (MonadState,get,put,modify)+import qualified Control.Monad.State as State++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+ ask = lift ask+ local r = mapStateT (local r)++asks :: MonadReader r m => (r -> a) -> m a+asks f = liftM f ask++class Monad m => MonadState s m where+ get :: m s+ put :: s -> m ()++instance Monad m => MonadState s (StateT s m) where+ get = State.get+ put = State.put++instance MonadState s m => MonadState s (StateT 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++update :: MonadState s m => (s -> (a,s)) -> m a+update f = do+ s <- get+ let (x,s') = f s+ put s'+ return x++runReaderT' :: Monad m => r -> ReaderT r m a -> m a+runReaderT' = flip runReaderT++evalStateT' :: Monad m => s -> StateT s m a -> m a+evalStateT' = flip evalStateT
+ System/Console/Haskeline/Prefs.hs view
@@ -0,0 +1,102 @@+{- |+'Prefs' allow the user to customize the line-editing interface. They are+read by default from @~/.haskeline@; to override that behavior, use+'readPrefs' and 'runInputTWithPrefs'. ++Each line of a @.haskeline@ file defines+one field of the 'Prefs' datatype; field names are case-insensitive and+unparseable lines are ignored. For example:++> editMode: Vi+> completionType: MenuCompletion+> maxhistorysize: Just 40++-}+module System.Console.Haskeline.Prefs where++import Language.Haskell.TH+import Data.Char(isSpace,toLower)+import Data.List(foldl')+import Control.Exception(handle)+++data Prefs = Prefs { bellStyle :: !BellStyle,+ editMode :: !EditMode,+ maxHistorySize :: !(Maybe Int),+ completionType :: !CompletionType,+ completionPaging :: !Bool, + -- ^ When listing completion alternatives, only display+ -- one screen of possibilities at a time.+ completionPromptLimit :: !(Maybe Int),+ -- ^ If more than this number of completion+ -- possibilities are found, then ask before listing+ -- them.+ listCompletionsImmediately :: !Bool+ -- ^ If 'False', completions with multiple possibilities+ -- will ring the bell and only display them if the user+ -- presses @TAB@ again.+ }+ deriving (Read,Show)++data CompletionType = ListCompletion | MenuCompletion+ deriving (Read,Show)+++data BellStyle = NoBell | VisualBell | AudibleBell+ deriving (Show, Read)++data EditMode = Vi | Emacs+ deriving (Show,Read)++{- | The default preferences which may be overwritten in the @.haskeline@ file:++> defaultPrefs = Prefs {bellStyle = AudibleBell,+> maxHistorySize = Nothing,+> editMode = Emacs,+> completionType = ListCompletion,+> completionPaging = True,+> completionPromptLimit = Just 100,+> listCompletionsImmediately = True+> }++-}+defaultPrefs :: Prefs+defaultPrefs = Prefs {bellStyle = AudibleBell,+ maxHistorySize = Nothing,+ editMode = Emacs,+ completionType = ListCompletion,+ completionPaging = True,+ completionPromptLimit = Just 100,+ listCompletionsImmediately = True+ }++mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs+mkSettor f str = case reads str of+ [(x,_)] -> f x+ _ -> id++settors :: [(String,String -> Prefs -> Prefs)]+settors = $(do+ DataConI _ _ prefsType _ <- reify 'Prefs+ TyConI (DataD _ _ _ [RecC _ fields] _) <- reify prefsType+ x <- newName "x"+ p <- newName "p"+ -- settor f => ("f", mkSettor (\x p -> p {f=x}))+ let settor (f,_,_) = TupE [LitE (StringL (map toLower $ nameBase f)),+ AppE (VarE 'mkSettor) $ LamE [VarP x,VarP p]+ $ RecUpdE (VarE p) [(f,VarE x)]]+ return $ ListE $ map settor fields)++-- | Read 'Prefs' from a given file. If there is an error reading the file,+-- the 'defaultPrefs' will be returned.+readPrefs :: FilePath -> IO Prefs+readPrefs file = handle (\_ -> return defaultPrefs) $ do+ ls <- fmap lines $ readFile file+ return $ foldl' applyField defaultPrefs ls+ where+ applyField p l = case break (==':') l of+ (name,val) -> case lookup (map toLower $ trimSpaces name) settors of+ Nothing -> p+ Just set -> set (drop 1 val) p -- drop initial ":", don't crash if val==""+ trimSpaces = dropWhile isSpace . reverse . dropWhile isSpace . reverse+
+ System/Console/Haskeline/Term.hs view
@@ -0,0 +1,56 @@+module System.Console.Haskeline.Term where++import System.Console.Haskeline.Monads+import System.Console.Haskeline.LineState+import System.Console.Haskeline.Command++import Control.Concurrent+import Control.Concurrent.STM++-- TODO: Cache the RunTerm in between runs?+-- If do this, should make sure in Terminfo and dumb terms that they +-- cache the input keymaps too.++class MonadIO m => Term m where+ withReposition :: Layout -> m a -> m a+ moveToNextLine :: LineState s => s -> m ()+ printLines :: [String] -> m ()+ drawLineDiff :: (LineState s, LineState r)+ => String -> s -> r -> m ()+ clearLayout :: m ()+ ringBell :: Bool -> m ()+ ++data RunTerm m = forall t . (Term (t m), MonadTrans t) => RunTerm {+ getLayout :: IO Layout,+ withGetEvent :: forall a . Bool -> (t m Event -> t m a) -> t m a,+ runTerm :: forall a . t m a -> m a,+ putStrTerm :: String -> IO ()+ }++-- Utility function for drawLineDiff instances.+matchInit :: Eq a => [a] -> [a] -> ([a],[a])+matchInit (x:xs) (y:ys) | x == y = matchInit xs ys+matchInit xs ys = (xs,ys)++keyEventLoop :: (TChan Event -> IO ()) -> TChan Event -> IO Event+keyEventLoop readKey eventChan = do+ -- first, see if any events are already queued up (from a key/ctrl-c+ -- event or from a previous call to getEvent where we read in multiple+ -- keys) + me <- atomically $ tryReadTChan eventChan+ case me of+ Just e -> return e+ Nothing -> do+ -- no events are queued yet, so fork off a thread to read keys.+ -- if we receive a different type of event before it's done,+ -- we'll kill it.+ tid <- forkIO (readKey eventChan)+ e <- atomically $ readTChan eventChan -- key or other event+ killThread tid+ return e++tryReadTChan :: TChan a -> STM (Maybe a)+tryReadTChan chan = fmap Just (readTChan chan) `orElse` return Nothing++class (MonadReader Layout m, MonadIO m) => MonadLayout m where
+ System/Console/Haskeline/Vi.hs view
@@ -0,0 +1,152 @@+module System.Console.Haskeline.Vi where++import System.Console.Haskeline.Command+import System.Console.Haskeline.Command.Completion+import System.Console.Haskeline.Command.History+import System.Console.Haskeline.LineState+import System.Console.Haskeline.InputT+++type InputCmd s t = forall m . Monad m => Command (InputCmdT m) s t++viActions :: Monad m => KeyMap (InputCmdT m) InsertMode+viActions = runCommand insertionCommands++insertionCommands :: InputCmd InsertMode InsertMode+insertionCommands = choiceCmd [startCommand, simpleInsertions]+ +simpleInsertions :: InputCmd InsertMode InsertMode+simpleInsertions = choiceCmd+ [ KeyChar '\n' +> finish+ , KeyChar '\r' +> finish+ , KeyLeft +> change goLeft + , KeyRight +> change goRight+ , Backspace +> change deletePrev + , KeyChar '\b' +> change deletePrev+ , DeleteForward +> change deleteNext + , changeFromChar insertChar+ , KeyChar '\t' +> completionCmd+ , KeyUp +> historyBack+ , KeyDown +> historyForward+ , controlKey 'd' +> eofIfEmpty+ , searchHistory+ ]++-- If we receive a ^D and the line is empty, return Nothing+-- otherwise, ignore it.+eofIfEmpty :: Key -> InputCmd InsertMode InsertMode+eofIfEmpty k = k +> acceptKeyOrFail (\s -> if s == emptyIM+ then Nothing+ else Just $ Change s >=> continue)++startCommand :: InputCmd InsertMode InsertMode+startCommand = KeyChar '\ESC' +> change enterCommandMode+ >|> viCommandActions++viCommandActions :: InputCmd CommandMode InsertMode+viCommandActions = simpleCmdActions `loopUntil` exitingCommands++exitingCommands :: InputCmd CommandMode InsertMode+exitingCommands = choiceCmd [ KeyChar 'i' +> change insertFromCommandMode+ , KeyChar 'I' +> change (moveToStart . insertFromCommandMode)+ , KeyChar 'a' +> change appendFromCommandMode+ , KeyChar 'A' +> change (moveToEnd . appendFromCommandMode)+ , KeyChar 's' +> change (insertFromCommandMode . deleteChar)+ , KeyChar 'S' +> change (const emptyIM)+ , deleteIOnce+ , repeated+ ]++simpleCmdActions :: InputCmd CommandMode CommandMode+simpleCmdActions = choiceCmd [ KeyChar '\n' +> finish+ , KeyChar '\ESC' +> change id -- helps break out of loops+ , KeyChar 'r' +> replaceOnce + , KeyChar 'R' +> loopReplace+ , KeyChar 'x' +> change deleteChar+ , KeyUp +> historyBack+ , KeyDown +> historyForward+ , deleteOnce+ , useMovements id+ ]++replaceOnce :: Key -> InputCmd CommandMode CommandMode+replaceOnce k = k >+> try (changeFromChar replaceChar)++loopReplace :: Key -> InputCmd CommandMode CommandMode+loopReplace k = k >+> loop+ where+ loop = choiceCmd [changeFromChar (\c -> goRight . replaceChar c) >|> loop+ , continue]++repeated :: InputCmd CommandMode InsertMode+repeated = let+ start = foreachDigit startArg ['1'..'9']+ addDigit = foreachDigit addNum ['0'..'9']+ deleteR = KeyChar 'd' + >+> choiceCmd [useMovements (deleteFromRepeatedMove),+ KeyChar 'd' +> change (const CEmpty)]+ deleteIR = KeyChar 'c'+ >+> choiceCmd [useMovements deleteAndInsertR,+ KeyChar 'c' +> change (const emptyIM)]+ loop = choiceCmd [addDigit >|> loop+ , useMovements applyArg >|> viCommandActions+ , deleteR >|> viCommandActions+ , deleteIR+ , KeyChar 'x' +> change (applyArg deleteChar)+ >|> viCommandActions+ , changeWithoutKey argState >|> viCommandActions+ ]+ in start >|> loop++movements :: [(Key,CommandMode -> CommandMode)]+movements = [ (KeyChar 'h', goLeft)+ , (KeyChar 'l', goRight)+ , (KeyChar ' ', goRight)+ , (KeyLeft, goLeft)+ , (KeyRight, goRight)+ , (KeyChar '0', moveToStart)+ , (KeyChar '$', moveToEnd)+ ]++useMovements :: LineState t => ((CommandMode -> CommandMode) -> s -> t) + -> InputCmd s t+useMovements f = choiceCmd $ map (\(k,g) -> k +> change (f g))+ movements++deleteOnce :: InputCmd CommandMode CommandMode+deleteOnce = KeyChar 'd'+ >+> choiceCmd [useMovements deleteFromMove,+ KeyChar 'd' +> change (const CEmpty)]++deleteIOnce :: InputCmd CommandMode InsertMode+deleteIOnce = KeyChar 'c'+ >+> choiceCmd [useMovements deleteAndInsert,+ KeyChar 'c' +> change (const emptyIM)]++deleteAndInsert :: (CommandMode -> CommandMode) -> CommandMode -> InsertMode+deleteAndInsert f = insertFromCommandMode . deleteFromMove f++deleteAndInsertR :: (CommandMode -> CommandMode) + -> ArgMode CommandMode -> InsertMode+deleteAndInsertR f = insertFromCommandMode . deleteFromRepeatedMove f+++foreachDigit :: (Monad m, LineState t) => (Int -> s -> t) -> [Char] + -> Command m s t+foreachDigit f ds = choiceCmd $ map digitCmd ds+ where digitCmd d = KeyChar d +> change (f (toDigit d))+ toDigit d = fromEnum d - fromEnum '0'+++deleteFromMove :: (CommandMode -> CommandMode) -> CommandMode -> CommandMode+deleteFromMove f = \x -> deleteFromDiff x (f x)++deleteFromRepeatedMove :: (CommandMode -> CommandMode)+ -> ArgMode CommandMode -> CommandMode+deleteFromRepeatedMove f am = deleteFromDiff (argState am) (applyArg f am)++deleteFromDiff :: CommandMode -> CommandMode -> CommandMode+deleteFromDiff (CMode xs1 c1 ys1) (CMode xs2 _ ys2)+ | length xs1 < length xs2 = enterCommandMode (IMode xs1 ys2)+ | otherwise = CMode xs2 c1 ys1+deleteFromDiff _ after = after
+ cbits/win_console.c view
@@ -0,0 +1,5 @@+#include "win_console.h"++BOOL SetPosition(HANDLE h, COORD* c) {+ return SetConsoleCursorPosition(h,*c);+}
+ haskeline.cabal view
@@ -0,0 +1,79 @@+Name: haskeline+Cabal-Version: >=1.2+Version: 0.2+Category: User Interfaces+License: BSD3+License-File: LICENSE+Copyright: (c) Judah Jacobson+Author: Judah Jacobson+Maintainer: Judah Jacobson <judah.jacobson@gmail.com>+Category: User Interfaces+Synopsis: A command-line interface for user input, written in Haskell.+Description: + Haskeline provides a user interface for line input in command-line+ programs. This library is similar in purpose to readline, but since+ it is written in Haskell it is (hopefully) more easily used in other+ Haskell programs.+ .+ Haskeline runs both on POSIX-compatible systems and on Windows+ (under MinGW).+Homepage: http://code.haskell.org/haskeline+Stability: Experimental+Build-Type: Simple++flag target-mingw+ Description: Use native Win32 Console functionality (suitable for MinGW)+ Default: False++flag old-base+ Description: Use the base packages from before version 6.8++Library+ if flag(old-base)+ Build-depends: base < 3+ else+ Build-depends: base>=3.0, containers>=0.1, directory>=1.0+ Build-depends: stm>=2.0, filepath>=1.1, template-haskell>=2.1, + mtl>=1.1, utf8-string>=0.3.1.1, bytestring>=0.9.0.1+ Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances,+ TypeSynonymInstances+ FlexibleContexts, ExistentialQuantification+ ScopedTypeVariables, GeneralizedNewtypeDeriving+ MultiParamTypeClasses, OverlappingInstances+ PatternSignatures, CPP, DeriveDataTypeable,+ PatternGuards, TemplateHaskell, StandaloneDeriving+ -- Note: GADTs are needed to allow contexts of different+ -- lengths (see code of Haskeline.repeatTillFinish)+ GADTs+ Exposed-Modules:+ System.Console.Haskeline+ System.Console.Haskeline.Completion+ System.Console.Haskeline.Prefs+ System.Console.Haskeline.MonadException+ Other-Modules:+ System.Console.Haskeline.Backend+ System.Console.Haskeline.Command+ System.Console.Haskeline.Command.Completion+ System.Console.Haskeline.Command.History+ System.Console.Haskeline.Emacs+ System.Console.Haskeline.InputT+ System.Console.Haskeline.LineState+ System.Console.Haskeline.Monads+ System.Console.Haskeline.Term+ System.Console.Haskeline.Vi+ include-dirs: includes+ if flag(target-mingw) {+ Build-depends: Win32>=2.0+ Other-modules: System.Console.Haskeline.Backend.Win32+ c-sources: cbits/win_console.c+ includes: win_console.h+ install-includes: win_console.h+ cpp-options: -DMINGW+ } else {+ Build-depends: terminfo>=0.2, unix>=2.0+ Other-modules: + System.Console.Haskeline.Backend.Posix+ System.Console.Haskeline.Backend.DumbTerm+ System.Console.Haskeline.Backend.Terminfo+ }+ ghc-options: -Wall
+ includes/win_console.h view
@@ -0,0 +1,7 @@+#ifndef _WIN_CONSOLE_H+#define _WIN_CONSOLE_H+#include <windows.h>++BOOL SetPosition(HANDLE h, COORD* c);++#endif