haskeline 0.2.1 → 0.3
raw patch · 15 files changed
+445/−230 lines, 15 filesdep ~basedep ~terminfodep ~utf8-stringPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, terminfo, utf8-string
API changes (from Hackage documentation)
- System.Console.Haskeline.Prefs: mkSettor :: (Read a) => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
- System.Console.Haskeline.Prefs: settors :: [(String, String -> Prefs -> Prefs)]
Files
- System/Console/Haskeline.hs +89/−79
- System/Console/Haskeline/Backend.hs +3/−4
- System/Console/Haskeline/Backend/DumbTerm.hs +15/−16
- System/Console/Haskeline/Backend/Posix.hsc +111/−27
- System/Console/Haskeline/Backend/Terminfo.hs +18/−15
- System/Console/Haskeline/Backend/Win32.hsc +83/−32
- System/Console/Haskeline/Command.hs +4/−1
- System/Console/Haskeline/Emacs.hs +14/−5
- System/Console/Haskeline/InputT.hs +9/−9
- System/Console/Haskeline/LineState.hs +20/−3
- System/Console/Haskeline/Prefs.hs +9/−2
- System/Console/Haskeline/Term.hs +14/−10
- System/Console/Haskeline/Vi.hs +29/−18
- examples/Test.hs +21/−0
- haskeline.cabal +6/−9
System/Console/Haskeline.hs view
@@ -1,7 +1,36 @@+{- | ++A rich user interface for line input in command-line programs. Haskeline is+Unicode-aware and runs both on POSIX-compatible systems and on Windows. ++Users may customize the interface with a @~/.haskeline@ file; see the+"System.Console.Haskeline.Prefs" module for more details.++An example use of this library for a simple read-eval-print loop is the+following:++> import System.Console.Haskeline+> +> 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++If either 'stdin' or 'stdout' is not connected to a terminal (for example, piped from another+process), Haskeline will treat it as a UTF-8-encoded file handle. ++-}++ module System.Console.Haskeline( -- * Main functions- --- -- $maindoc InputT, runInputT, runInputTWithPrefs,@@ -33,6 +62,7 @@ import System.Console.Haskeline.Term import System.IO+import qualified System.IO.UTF8 as UTF8 import Data.Char (isSpace) import Control.Monad import qualified Control.Exception as Exception@@ -40,30 +70,7 @@ -{- $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: -- -- @@@ -78,79 +85,59 @@ 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 ()+-- | Write a string to the standard output. Allows cross-platform display of Unicode+-- characters.+outputStr :: MonadIO m => String -> InputT m () outputStr xs = do- run :: RunTerm (InputCmdT m) <- ask- liftIO $ putStrTerm run xs+ putter <- asks putStrOut+ liftIO $ putter xs --- | Write a string to the console output, followed by a newline. Allows+-- | Write a string to the standard 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.+{- | Read one line of input. The final newline (if any) is removed. -If signal handling is enabled in the 'Settings', then 'getInputLine' will-throw an 'Interrupt' exception when the user presses Ctrl-C.+If 'stdin' is connected to a terminal, 'getInputLine' provides a rich line-editing+user interface. It returns 'Nothing' if the user presses @Ctrl-D@ when the input+text is empty. All user interaction, including display of the input prompt, will occur+on the user's output terminal (which may differ from 'stdout'). +If 'stdin' is not connected to a terminal, 'getInputLine' reads one line of input, and+prints the prompt and input to 'stdout'. It returns 'Nothing' if an @EOF@ is+encountered before any characters are read. -} 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+ -- If other parts of the program have written text, make sure that it + -- appears before we interact with the user on the terminal.+ liftIO $ hFlush stdout+ rterm <- ask+ case termOps rterm of+ Nothing -> simpleFileLoop prefix rterm+ Just tops -> getInputCmdLine tops prefix -getInputCmdLine :: forall m . MonadException m => String -> InputT m (Maybe String)-getInputCmdLine prefix = do--- TODO: Cache the terminal, actions+getInputCmdLine :: forall m . MonadException m => TermOps -> String -> InputT m (Maybe String)+getInputCmdLine tops prefix = do+ -- Load the necessary settings/prefs+ -- TODO: Cache the actions emode <- asks (\prefs -> case editMode prefs of Vi -> viActions Emacs -> emacsCommands) settings :: Settings m <- ask- wrapTerminalOps $ do- let ls = emptyIM- RunTerm {withGetEvent = withGetEvent', runTerm=runTerm'} <- ask- result <- runInputCmdT $ runTerm' $ withGetEvent' (handleSigINT settings) + -- Run the main event processing loop+ result <- runInputCmdT tops $ flip (runTerm tops) (handleSigINT settings) $ \getEvent -> do+ let ls = emptyIM drawLine prefix ls repeatTillFinish getEvent prefix ls emode- case result of - Just line | not (all isSpace line) -> addHistory line- _ -> return ()- return result+ -- Add the line to the history if it's nonempty.+ 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)@@ -166,7 +153,7 @@ case event of SigInt -> do moveToNextLine s- liftIO $ Exception.evaluate (Exception.throwDyn Interrupt)+ throwInterrupt WindowResize newLayout -> withReposition newLayout (loop s processor) KeyInput k -> case lookupKM processor k of@@ -179,6 +166,27 @@ loop (effectState effect) next {-- +When stdin is not a console, just read in one line of input.++NOTE: this behavior "breaks" when we run for example "cat | Test":+Printing the input to stdout is redundant because cat already echoes what the user has+typed.+Given the tradeoffs of all of the different ways of piping to/from stdin/stdout,+I think it's fine because this case seems least likely to occur in practice.+-}++simpleFileLoop :: MonadIO m => String -> RunTerm -> m (Maybe String)+simpleFileLoop prefix rterm = liftIO $ do+ putStrOut rterm prefix+ atEOF <- hIsEOF stdin+ if atEOF+ then return Nothing+ else do+ l <- UTF8.getLine+ putStrOut rterm (l++"\n")+ return (Just l)++{-- Note why it is necessary to integrate ctrl-c handling with this module: if the user is in the middle of a few wrapped lines, we want to clean up by moving the cursor to the start of the following line.@@ -196,6 +204,8 @@ Just dyn | Just Interrupt <- fromDynamic dyn -> f _ -> throwIO e +throwInterrupt :: MonadIO m => m a+throwInterrupt = liftIO $ Exception.evaluate $ Exception.throwDyn Interrupt drawEffect :: (LineState s, LineState t, Term (d m),
System/Console/Haskeline/Backend.hs view
@@ -1,7 +1,6 @@ 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@@ -10,14 +9,14 @@ import System.Console.Haskeline.Backend.DumbTerm as DumbTerm #endif -myRunTerm :: (MonadException m, MonadLayout m) => IO (RunTerm m)+myRunTerm :: IO RunTerm #ifdef MINGW-myRunTerm = return win32Term+myRunTerm = win32Term #else myRunTerm = do mRun <- runTerminfoDraw case mRun of - Nothing -> return runDumbTerm+ Nothing -> runDumbTerm Just run -> return run #endif
System/Console/Haskeline/Backend/DumbTerm.hs view
@@ -7,10 +7,8 @@ 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 @@ -20,8 +18,8 @@ initWindow :: Window initWindow = Window {pos=0} -newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window m a}- deriving (Monad,MonadIO, MonadState Window)+newtype DumbTerm m a = DumbTerm {unDumbTerm :: ReaderT Handle (StateT Window m) a}+ deriving (Monad,MonadIO, MonadState Window,MonadReader Handle) instance MonadReader Layout m => MonadReader Layout (DumbTerm m) where ask = lift ask@@ -32,17 +30,18 @@ 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- }- -+runDumbTerm :: IO RunTerm+runDumbTerm = posixRunTerm $ \h -> + TermOps {+ getLayout = getPosixLayout h Nothing,+ runTerm = \f useSigINT -> + evalStateT' initWindow+ (runReaderT' h (unDumbTerm+ (withPosixGetEvent h Nothing useSigINT f)))+ }+ instance MonadTrans DumbTerm where- lift = DumbTerm . lift+ lift = DumbTerm . lift . lift instance MonadLayout m => Term (DumbTerm m) where withReposition _ = id@@ -54,8 +53,8 @@ ringBell True = printText "\a" ringBell False = return () -printText :: MonadIO m => String -> m ()-printText str = liftIO $ UTF8.putStr str >> hFlush stdout+printText :: MonadIO m => String -> DumbTerm m ()+printText str = ask >>= liftIO . flip putTerm str -- Things we can assume a dumb terminal knows how to do cr,crlf :: String
System/Console/Haskeline/Backend/Posix.hsc view
@@ -1,14 +1,15 @@ module System.Console.Haskeline.Backend.Posix ( withPosixGetEvent, getPosixLayout,- mapLines+ mapLines,+ putTerm,+ posixRunTerm ) 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@@ -20,35 +21,64 @@ import System.IO import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8+import System.Environment import System.Console.Haskeline.Monads import System.Console.Haskeline.Command import System.Console.Haskeline.Term +import GHC.IOBase (haFD,FD)+import GHC.Handle (withHandle_)+ #include <sys/ioctl.h> ------------------- -- Window size -foreign import ccall ioctl :: CInt -> CULong -> Ptr a -> IO ()+foreign import ccall ioctl :: CInt -> CULong -> Ptr a -> IO CInt -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}+getPosixLayout :: Handle -> Maybe Terminal -> IO Layout+getPosixLayout h term = tryGetLayouts [ioctlLayout h, envLayout, tinfoLayout term] --- todo: make sure >=2--- TODO: other ways of getting it:--- env vars ROWS/COLUMNS--- terminfo capabilities+ioctlLayout :: Handle -> IO (Maybe Layout)+ioctlLayout h = allocaBytes (#size struct winsize) $ \ws -> do+ fd <- unsafeHandleToFD h+ ret <- ioctl fd (#const TIOCGWINSZ) ws+ rows :: CUShort <- (#peek struct winsize,ws_row) ws+ cols :: CUShort <- (#peek struct winsize,ws_col) ws+ if ret >= 0+ then return $ Just Layout {height=fromEnum rows,width=fromEnum cols}+ else return Nothing +unsafeHandleToFD :: Handle -> IO FD+unsafeHandleToFD h = withHandle_ "unsafeHandleToFd" h (return . haFD) +envLayout :: IO (Maybe Layout)+envLayout = handle (\_ -> return Nothing) $ do+ -- note the handle catches both undefined envs and bad reads+ r <- getEnv "ROWS"+ c <- getEnv "COLUMNS"+ return $ Just $ Layout {height=read r,width=read c}++tinfoLayout :: Maybe Terminal -> IO (Maybe Layout)+tinfoLayout Nothing = return Nothing+tinfoLayout (Just t) = return $ getCapability t $ do+ r <- termColumns+ c <- termLines+ return Layout {height=r,width=c}++tryGetLayouts :: [IO (Maybe Layout)] -> IO Layout+tryGetLayouts [] = return Layout {height=24,width=80}+tryGetLayouts (f:fs) = do+ ml <- f+ case ml of+ Just l | height l > 2 && width l > 2 -> return l+ _ -> tryGetLayouts fs++ -------------------- -- Key sequences --- TODO: What if term not found? getKeySequences :: Maybe Terminal -> IO (TreeMap Char Key) getKeySequences term = do sttys <- sttyKeys@@ -80,7 +110,7 @@ sttyKeys :: IO [(String, Key)] sttyKeys = do- attrs <- getTerminalAttributes stdOutput+ attrs <- getTerminalAttributes stdInput let getStty (k,c) = do {str <- controlChar attrs k; return ([str],c)} return $ catMaybes $ map getStty [(Erase,Backspace),(Kill,KillLine)] @@ -116,7 +146,9 @@ 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 ('\ESC':cs)+ | (k:ks) <- lexKeys baseMap cs+ = KeyMeta k : ks lexKeys baseMap (c:cs) = KeyChar c : lexKeys baseMap cs lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key,[Char])@@ -131,27 +163,27 @@ ----------------------------- -withPosixGetEvent :: MonadException m => Maybe Terminal -> Bool -> (m Event -> m a) -> m a-withPosixGetEvent term useSigINT f = do+withPosixGetEvent :: MonadException m => Handle -> Maybe Terminal -> Bool -> (m Event -> m a) -> m a+withPosixGetEvent h term useSigINT f = do baseMap <- liftIO (getKeySequences term) eventChan <- liftIO $ newTChanIO- wrapKeypad term - $ withWindowHandler eventChan+ wrapKeypad h term . withWindowHandler h term 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) +wrapKeypad :: MonadException m => Handle -> Maybe Terminal -> m a -> m a+wrapKeypad _ Nothing f = f+wrapKeypad h (Just term) f = (maybeOutput keypadOn >> f) `finally` maybeOutput keypadOff where- maybeOutput cap = liftIO $ runTermOutput term $+ maybeOutput cap = liftIO $ hRunTermOutput h 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+withWindowHandler :: MonadException m => Handle -> Maybe Terminal -> TChan Event -> m a -> m a+withWindowHandler h term eventChan = withHandler windowChange $ + Catch $ getPosixLayout h term + >>= atomically . writeTChan eventChan . WindowResize withSigIntHandler :: MonadException m => Bool -> TChan Event -> m a -> m a withSigIntHandler False _ = id@@ -178,4 +210,56 @@ if null ks then readKeyEvents eventChan else atomically $ mapM_ (writeTChan eventChan) ks++-- fails if stdin is not a handle or if we couldn't access /dev/tty.+openTTY :: IO (Maybe Handle)+openTTY = do+ inIsTerm <- hIsTerminalDevice stdin+ if inIsTerm+ then handle (\_ -> return Nothing) $ do+ h <- openFile "/dev/tty" WriteMode+ return (Just h)+ else return Nothing++posixRunTerm :: (Handle -> TermOps) -> IO RunTerm+posixRunTerm tOps = do+ ttyH <- openTTY+ case ttyH of+ Nothing -> return fileRunTerm+ Just h -> return RunTerm {+ putStrOut = putTerm stdout,+ closeTerm = hClose h,+ termOps = Just (wrapRunTerm (wrapTerminalOps h) (tOps h))+ }++putTerm :: Handle -> String -> IO ()+putTerm h str = B.hPutStr h (UTF8.fromString str) >> hFlush h++fileRunTerm :: RunTerm+fileRunTerm = RunTerm {putStrOut = putTerm stdout,+ closeTerm = return (),+ termOps = Nothing+ }+++-- 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 => Handle -> m a -> m a+wrapTerminalOps outH =+ 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 useSigINT -> + wrap (runTerm tops getE useSigINT)+ }++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))
System/Console/Haskeline/Backend/Terminfo.hs view
@@ -7,7 +7,7 @@ import System.Console.Terminfo import Control.Monad import Data.List(intersperse)-import System.IO (hFlush,stdout)+import System.IO import qualified Control.Exception as Exception import System.Console.Haskeline.Monads as Monads@@ -86,9 +86,10 @@ -------------- -newtype Draw m a = Draw {unDraw :: ReaderT Actions (ReaderT Terminal (StateT TermPos m)) a}+newtype Draw m a = Draw {unDraw :: ReaderT Handle (ReaderT Actions + (ReaderT Terminal (StateT TermPos m))) a} deriving (Monad,MonadIO,MonadReader Actions,MonadReader Terminal,- MonadState TermPos)+ MonadState TermPos, MonadReader Handle) instance MonadReader Layout m => MonadReader Layout (Draw m) where ask = lift ask@@ -101,30 +102,32 @@ instance MonadTrans Draw where- lift = Draw . lift . lift . lift+ lift = Draw . lift . lift . lift . lift -runTerminfoDraw :: (MonadException m, MonadLayout m) => IO (Maybe (RunTerm m))+runTerminfoDraw :: IO (Maybe RunTerm) 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- }+ Just actions -> fmap Just $ posixRunTerm $ \h -> + TermOps {+ getLayout = getPosixLayout h (Just term),+ runTerm = \f useSigINT -> + evalStateT' initTermPos+ (runReaderT' term+ (runReaderT' actions+ (runReaderT' h (unDraw + (withPosixGetEvent h (Just term) useSigINT f)))))+ } output :: MonadIO m => (Actions -> TermOutput) -> Draw m () output f = do toutput <- asks f term <- ask- liftIO $ runTermOutput term toutput- liftIO $ hFlush stdout+ ttyh <- ask+ liftIO $ hRunTermOutput ttyh term toutput
System/Console/Haskeline/Backend/Win32.hsc view
@@ -1,10 +1,10 @@ module System.Console.Haskeline.Backend.Win32( - Draw(), win32Term )where import System.IO +import qualified System.IO.UTF8 as UTF8 import Foreign.Ptr import Foreign.Storable import Foreign.Marshal.Alloc @@ -13,9 +13,11 @@ import Foreign.Marshal.Utils import System.Win32.Types import Graphics.Win32.Misc(getStdHandle, sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE) +import System.Win32.File import Data.List(intercalate) import Control.Concurrent import Control.Concurrent.STM +import Data.Bits import System.Console.Haskeline.Command import System.Console.Haskeline.Monads @@ -45,11 +47,23 @@ Just k -> atomically $ writeTChan eventChan (KeyInput k) Nothing -> readKeyEvents eventChan - +getConOut :: IO (Maybe HANDLE) +getConOut = handle (\_ -> return Nothing) $ fmap Just + $ createFile "CONOUT$" (gENERIC_READ .|. gENERIC_WRITE) + (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing + oPEN_EXISTING 0 Nothing + + 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 KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc, + controlKeyState = cstate} + = if isMeta then fmap KeyMeta maybeKey else maybeKey + where + maybeKey = if c /= '\NUL' + then Just (KeyChar c) + else keyFromCode vc + isMeta = 0 /= (cstate .&. (#const RIGHT_ALT_PRESSED + .|. #const LEFT_ALT_PRESSED) ) eventToKey _ = Nothing keyFromCode :: WORD -> Maybe Key @@ -59,7 +73,7 @@ keyFromCode (#const VK_UP) = Just KeyUp keyFromCode (#const VK_DOWN) = Just KeyDown keyFromCode (#const VK_DELETE) = Just DeleteForward --- TODO: KeyMeta (option-x), KillLine +-- TODO: KillLine keyFromCode _ = Nothing data InputEvent = KeyEvent {keyDown :: BOOL, @@ -153,47 +167,50 @@ :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool writeConsole :: HANDLE -> String -> IO () +-- For some reason, Wine returns False when WriteConsoleW is called on an empty +-- string. Easiest fix: just don't call that function. +writeConsole _ "" = return () 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 +foreign import stdcall "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool + +messageBeep :: IO () +messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures. + ---------------------------- -- Drawing -newtype Draw m a = Draw {runDraw :: m a} - deriving (Monad,MonadIO,MonadException) +newtype Draw m a = Draw {runDraw :: ReaderT HANDLE m a} + deriving (Monad,MonadIO,MonadException, MonadReader HANDLE) instance MonadTrans Draw where - lift = Draw + lift = Draw . lift 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 +getDisplaySize :: HANDLE -> IO Layout +getDisplaySize h = do (topLeft,bottomRight) <- getDisplayWindow h return Layout {width = coordX bottomRight - coordX topLeft+1, height = coordY bottomRight - coordY topLeft+1 } getPos :: MonadIO m => Draw m Coord -getPos = getOutputHandle >>= liftIO . getPosition +getPos = ask >>= liftIO . getPosition setPos :: MonadIO m => Coord -> Draw m () setPos c = do - h <- getOutputHandle + h <- ask liftIO (setPosition h c) -printText :: MonadIO m => String -> m () +printText :: MonadIO m => String -> Draw m () printText txt = do - h <- getOutputHandle + h <- ask liftIO (writeConsole h txt) printAfter :: MonadLayout m => String -> Draw m () @@ -247,19 +264,53 @@ movePos (lengthToEnd s) printText "\r\n" -- make the console take care of creating a new line - ringBell _ = return () -- TODO + ringBell True = liftIO messageBeep + ringBell False = 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 - } +win32Term :: IO RunTerm +win32Term = do + inIsTerm <- hIsTerminalDevice stdin + putter <- putOut + if not inIsTerm + then fileRunTerm + else do + oterm <- getConOut + case oterm of + Nothing -> fileRunTerm + Just h -> return RunTerm { + putStrOut = putter, + termOps = Just TermOps { + getLayout = getDisplaySize h, + runTerm = consoleRunTerm h}, + closeTerm = closeHandle h} + +consoleRunTerm :: HANDLE -> RunTermType +consoleRunTerm conOut f useSigINT = do + inH <- liftIO $ getStdHandle sTD_INPUT_HANDLE + eventChan <- liftIO $ newTChanIO + runReaderT' conOut $ runDraw $ withCtrlCHandler useSigINT 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 +fileRunTerm = do + putter <- putOut + return RunTerm {termOps = Nothing, + closeTerm = return (), + putStrOut = putter} + +-- On Windows, Unicode written to the console must be written with the WriteConsole API call. +-- And to make the API cross-platform consistent, Unicode to a file should be UTF-8. +putOut :: IO (String -> IO ()) +putOut = do + outIsTerm <- hIsTerminalDevice stdout + if outIsTerm + then do + h <- getStdHandle sTD_OUTPUT_HANDLE + return (writeConsole h) + else return $ \str -> UTF8.putStr str >> hFlush stdout + + type Handler = DWORD -> IO BOOL
System/Console/Haskeline/Command.hs view
@@ -2,6 +2,7 @@ Event(..), Key(..), controlKey,+ metaChar, Layout(..), -- * Commands Effect(..),@@ -40,7 +41,7 @@ data Layout = Layout {width, height :: Int} deriving Show -data Key = KeyChar Char | KeyMeta Char+data Key = KeyChar Char | KeyMeta Key | KeyLeft | KeyRight | KeyUp | KeyDown | Backspace | DeleteForward | KillLine deriving (Eq,Ord,Show)@@ -54,6 +55,8 @@ controlKey '?' = KeyChar (toEnum 127) controlKey c = KeyChar $ toEnum $ fromEnum c .&. complement (bit 5 .|. bit 6) +metaChar :: Char -> Key+metaChar = KeyMeta . KeyChar data Effect s = Change {effectState :: s} | PrintLines {linesToPrint :: [String], effectState :: s}
System/Console/Haskeline/Emacs.hs view
@@ -33,13 +33,17 @@ [ controlKey 'a' +> change moveToStart , controlKey 'e' +> change moveToEnd , controlKey 'b' +> change goLeft- , controlKey 'c' +> change goRight+ , controlKey 'f' +> change goRight , controlKey 'd' +> deleteCharOrEOF , controlKey 'l' +> clearScreenCmd- , KeyMeta 'f' +> change (skipRight isAlphaNum- . skipRight (not . isAlphaNum))- , KeyMeta 'b' +> change (skipLeft isAlphaNum- . skipLeft (not . isAlphaNum))+ , metaChar 'f' +> change wordRight+ , metaChar 'b' +> change wordLeft+ , controlKey 'w' +> change (deleteFromMove bigWordLeft)+ , KeyMeta Backspace +> change (deleteFromMove wordLeft)+ , KeyMeta (KeyChar '\b') +> change (deleteFromMove wordLeft)+ , metaChar 'd' +> change (deleteFromMove wordRight)+ , controlKey 'k' +> change (deleteFromMove moveToEnd)+ , KillLine +> change (deleteFromMove moveToStart) ] deleteCharOrEOF :: Key -> InputCmd InsertMode InsertMode@@ -48,3 +52,8 @@ else Just $ Change (deleteNext s) >=> justDelete) where justDelete = try (change deleteNext k >|> justDelete)++wordRight, wordLeft, bigWordLeft :: InsertMode -> InsertMode+wordRight = skipRight isAlphaNum . skipRight (not . isAlphaNum)+wordLeft = skipLeft isAlphaNum . skipLeft (not . isAlphaNum)+bigWordLeft = skipLeft (not . isSpace) . skipLeft isSpace
System/Console/Haskeline/InputT.hs view
@@ -23,7 +23,7 @@ -- | 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+-- from being too general. This function works around that issue, and may become unnecessary if another field -- depending on @m@ is added. setComplete :: CompletionFunc m -> Settings m -> Settings m@@ -32,12 +32,12 @@ -- | 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))+newtype InputT m a = InputT {unInputT :: ReaderT RunTerm (StateT History (ReaderT Prefs (ReaderT (Settings m) m))) a} deriving (Monad,MonadIO, MonadState History, MonadReader Prefs, MonadReader (Settings m),- MonadReader (RunTerm (InputCmdT m)))+ MonadReader RunTerm) instance Monad m => Functor (InputT m) where fmap = liftM@@ -59,10 +59,9 @@ 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+runInputCmdT :: forall m a . MonadIO m => TermOps -> InputCmdT m a -> InputT m a+runInputCmdT tops f = InputT $ do+ layout <- liftIO $ getLayout tops lift $ runHistLog $ runReaderT' layout f @@ -70,8 +69,9 @@ 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 +runInputTWithPrefs prefs settings (InputT f) = bracket (liftIO myRunTerm)+ (liftIO . closeTerm)+ $ \run -> runReaderT' settings $ runReaderT' prefs $ runHistoryFromFile (historyFile settings) (maxHistorySize prefs) $ runReaderT f run
System/Console/Haskeline/LineState.hs view
@@ -106,16 +106,19 @@ replaceChar c (CMode xs _ ys) = CMode xs c ys replaceChar _ CEmpty = CEmpty -- ------------------------ -- Transitioning between modes -enterCommandMode :: InsertMode -> CommandMode+enterCommandMode, enterCommandModeRight :: InsertMode -> CommandMode enterCommandMode (IMode (x:xs) ys) = CMode xs x ys enterCommandMode (IMode [] (y:ys)) = CMode [] y ys enterCommandMode _ = CEmpty +enterCommandModeRight (IMode xs (y:ys)) = CMode xs y ys+enterCommandModeRight (IMode (x:xs) []) = CMode xs x []+enterCommandModeRight _ = CEmpty++ insertFromCommandMode, appendFromCommandMode :: CommandMode -> InsertMode insertFromCommandMode CEmpty = emptyIM@@ -124,12 +127,17 @@ appendFromCommandMode CEmpty = emptyIM appendFromCommandMode (CMode xs c ys) = IMode (c:xs) ys +withCommandMode :: (InsertMode -> InsertMode) -> CommandMode -> CommandMode+withCommandMode f = enterCommandModeRight . f . insertFromCommandMode ---------------------- -- Supplementary modes data ArgMode s = ArgMode {arg :: Int, argState :: s} +instance Functor ArgMode where+ fmap f (ArgMode n s) = ArgMode n (f s)+ instance LineState s => LineState (ArgMode s) where beforeCursor _ am = beforeCursor ("(arg: " ++ show (arg am) ++ ") ") (argState am)@@ -166,3 +174,12 @@ beforeCursor _ = messageText afterCursor _ = "" isTemporary _ = True++-----------------+deleteFromDiff :: InsertMode -> InsertMode -> InsertMode+deleteFromDiff (IMode xs1 ys1) (IMode xs2 ys2)+ | length xs1 < length xs2 = IMode xs1 ys2+ | otherwise = IMode xs2 ys1++deleteFromMove :: (InsertMode -> InsertMode) -> InsertMode -> InsertMode+deleteFromMove f = \x -> deleteFromDiff x (f x)
System/Console/Haskeline/Prefs.hs view
@@ -1,7 +1,7 @@ {- | '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'. +'readPrefs' and @runInputTWithPrefs@. Each line of a @.haskeline@ file defines one field of the 'Prefs' datatype; field names are case-insensitive and@@ -12,7 +12,14 @@ > maxhistorysize: Just 40 -}-module System.Console.Haskeline.Prefs where+module System.Console.Haskeline.Prefs(+ Prefs(..),+ defaultPrefs,+ readPrefs,+ CompletionType(..),+ BellStyle(..),+ EditMode(..)+ ) where import Language.Haskell.TH import Data.Char(isSpace,toLower)
System/Console/Haskeline/Term.hs view
@@ -7,10 +7,6 @@ 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 ()@@ -20,13 +16,21 @@ 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 ()+-- 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.+data RunTerm = RunTerm {+ putStrOut :: String -> IO (),+ termOps :: Maybe TermOps,+ closeTerm :: IO () }++data TermOps = TermOps {runTerm :: RunTermType,+ getLayout :: IO Layout}++type RunTermType = forall m a . (MonadLayout m, MonadException m) + => (forall t . (MonadTrans t, Term (t m), MonadException (t m)) + => (t m Event -> t m a)) -> Bool -> m a+ -- Utility function for drawLineDiff instances. matchInit :: Eq a => [a] -> [a] -> ([a],[a])
System/Console/Haskeline/Vi.hs view
@@ -6,6 +6,7 @@ import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT +import Data.Char(isAlphaNum,isSpace) type InputCmd s t = forall m . Monad m => Command (InputCmdT m) s t @@ -66,7 +67,7 @@ , KeyUp +> historyBack , KeyDown +> historyForward , deleteOnce- , useMovements id+ , useMovements withCommandMode ] replaceOnce :: Key -> InputCmd CommandMode CommandMode@@ -88,8 +89,9 @@ deleteIR = KeyChar 'c' >+> choiceCmd [useMovements deleteAndInsertR, KeyChar 'c' +> change (const emptyIM)]+ applyArg' f am = enterCommandModeRight $ applyArg f $ fmap insertFromCommandMode am loop = choiceCmd [addDigit >|> loop- , useMovements applyArg >|> viCommandActions+ , useMovements applyArg' >|> viCommandActions , deleteR >|> viCommandActions , deleteIR , KeyChar 'x' +> change (applyArg deleteChar)@@ -98,9 +100,13 @@ ] in start >|> loop -movements :: [(Key,CommandMode -> CommandMode)]+movements :: [(Key,InsertMode -> InsertMode)] movements = [ (KeyChar 'h', goLeft) , (KeyChar 'l', goRight)+ , (KeyChar 'w', skipRight isSpace . (\s -> skipRight (cmdChar s) s))+ , (KeyChar 'b', (\s -> skipLeft (cmdChar s) s) . goLeft . skipLeft isSpace)+ , (KeyChar 'W', skipRight isSpace . skipRight (not . isSpace))+ , (KeyChar 'B', skipLeft (not . isSpace) . skipLeft isSpace) , (KeyChar ' ', goRight) , (KeyLeft, goLeft) , (KeyRight, goRight)@@ -108,14 +114,22 @@ , (KeyChar '$', moveToEnd) ] -useMovements :: LineState t => ((CommandMode -> CommandMode) -> s -> t) +cmdChar :: InsertMode -> (Char -> Bool)+cmdChar (IMode _ (c:_))+ | isWordChar c = isWordChar+cmdChar _ = \d -> not (isWordChar d) && not (isSpace d)++isWordChar :: Char -> Bool+isWordChar d = isAlphaNum d || d == '_'++useMovements :: LineState t => ((InsertMode -> InsertMode) -> 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,+ >+> choiceCmd [useMovements deleteFromCmdMove, KeyChar 'd' +> change (const CEmpty)] deleteIOnce :: InputCmd CommandMode InsertMode@@ -123,10 +137,10 @@ >+> choiceCmd [useMovements deleteAndInsert, KeyChar 'c' +> change (const emptyIM)] -deleteAndInsert :: (CommandMode -> CommandMode) -> CommandMode -> InsertMode-deleteAndInsert f = insertFromCommandMode . deleteFromMove f+deleteAndInsert :: (InsertMode -> InsertMode) -> CommandMode -> InsertMode+deleteAndInsert f = insertFromCommandMode . deleteFromCmdMove f -deleteAndInsertR :: (CommandMode -> CommandMode) +deleteAndInsertR :: (InsertMode -> InsertMode) -> ArgMode CommandMode -> InsertMode deleteAndInsertR f = insertFromCommandMode . deleteFromRepeatedMove f @@ -138,15 +152,12 @@ toDigit d = fromEnum d - fromEnum '0' -deleteFromMove :: (CommandMode -> CommandMode) -> CommandMode -> CommandMode-deleteFromMove f = \x -> deleteFromDiff x (f x)+deleteFromCmdMove :: (InsertMode -> InsertMode) -> CommandMode -> CommandMode+deleteFromCmdMove f = withCommandMode $ \x -> deleteFromDiff x (f x) -deleteFromRepeatedMove :: (CommandMode -> CommandMode)+deleteFromRepeatedMove :: (InsertMode -> InsertMode) -> 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+deleteFromRepeatedMove f am = let+ am' = fmap insertFromCommandMode am+ in enterCommandModeRight $ + deleteFromDiff (argState am') (applyArg f am')
+ examples/Test.hs view
@@ -0,0 +1,21 @@+module Main where++import System.Console.Haskeline++mySettings :: Settings IO+mySettings = defaultSettings {historyFile = Just "myhist",+ handleSigINT = True}++main :: IO ()+main = runInputT mySettings (loop 0)+ where+ loop :: Int -> InputT IO ()+ loop n = do+ minput <- handleInterrupt (return (Just "Caught interrupted"))+ (getInputLine (show n ++ ":"))+ case minput of+ Nothing -> return ()+ Just "quit" -> return ()+ Just s -> do+ outputStrLn ("line " ++ show n ++ ":" ++ s)+ loop (n+1)
haskeline.cabal view
@@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.2-Version: 0.2.1+Version: 0.3 Category: User Interfaces License: BSD3 License-File: LICENSE@@ -20,10 +20,7 @@ Homepage: http://trac.haskell.org/haskeline Stability: Experimental Build-Type: Simple--flag target-mingw- Description: Use native Win32 Console functionality (suitable for MinGW)- Default: False+extra-source-files: examples/Test.hs flag old-base Description: Use the base packages from before version 6.8@@ -32,10 +29,10 @@ if flag(old-base) Build-depends: base < 3 else- Build-depends: base>=3.0, containers>=0.1, directory>=1.0+ Build-depends: base>=3 && <4 , containers>=0.1, directory>=1.0 Build-depends: stm>=2.0, filepath>=1.1, template-haskell>=2.1, mtl>=1.1, utf8-string>=0.3.1.1, bytestring>=0.9.0.1- Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances,+ Extensions: ForeignFunctionInterface, RankNTypes, FlexibleInstances, TypeSynonymInstances FlexibleContexts, ExistentialQuantification ScopedTypeVariables, GeneralizedNewtypeDeriving@@ -62,7 +59,7 @@ System.Console.Haskeline.Term System.Console.Haskeline.Vi include-dirs: includes- if flag(target-mingw) {+ if os(windows) { Build-depends: Win32>=2.0 Other-modules: System.Console.Haskeline.Backend.Win32 c-sources: cbits/win_console.c@@ -70,7 +67,7 @@ install-includes: win_console.h cpp-options: -DMINGW } else {- Build-depends: terminfo>=0.2, unix>=2.0+ Build-depends: terminfo>=0.2.2, unix>=2.0 Other-modules: System.Console.Haskeline.Backend.Posix System.Console.Haskeline.Backend.DumbTerm