← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/haskeline/System/Console/Haskeline/Term.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libraries/haskeline/System/Console/Haskeline/Term.hs
 
1
module System.Console.Haskeline.Term where
 
2
 
 
3
import System.Console.Haskeline.Monads
 
4
import System.Console.Haskeline.LineState
 
5
import System.Console.Haskeline.Key
 
6
import System.Console.Haskeline.Prefs(Prefs)
 
7
import System.Console.Haskeline.Completion(Completion)
 
8
 
 
9
import Control.Concurrent
 
10
import Data.Typeable
 
11
import Data.ByteString.Char8 (ByteString)
 
12
import qualified Data.ByteString.Char8 as B
 
13
import Data.Word
 
14
import Control.Exception.Extensible (fromException, AsyncException(..),bracket_)
 
15
import System.IO
 
16
import Control.Monad(liftM,when,guard)
 
17
import System.IO.Error (isEOFError)
 
18
 
 
19
class (MonadReader Layout m, MonadException m) => Term m where
 
20
    reposition :: Layout -> LineChars -> m ()
 
21
    moveToNextLine :: LineChars -> m ()
 
22
    printLines :: [String] -> m ()
 
23
    drawLineDiff :: LineChars -> LineChars -> m ()
 
24
    clearLayout :: m ()
 
25
    ringBell :: Bool -> m ()
 
26
 
 
27
drawLine, clearLine :: Term m => LineChars -> m ()
 
28
drawLine = drawLineDiff ([],[])
 
29
 
 
30
clearLine = flip drawLineDiff ([],[])
 
31
    
 
32
data RunTerm = RunTerm {
 
33
            -- | Write unicode characters to stdout.
 
34
            putStrOut :: String -> IO (),
 
35
            encodeForTerm :: String -> IO ByteString,
 
36
            decodeForTerm :: ByteString -> IO String,
 
37
            termOps :: Either TermOps FileOps,
 
38
            wrapInterrupt :: MonadException m => m a -> m a,
 
39
            closeTerm :: IO ()
 
40
    }
 
41
 
 
42
-- | Operations needed for terminal-style interaction.
 
43
data TermOps = TermOps {
 
44
            getLayout :: IO Layout
 
45
            , withGetEvent :: (MonadException m, CommandMonad m)
 
46
                                => (m Event -> m a) -> m a
 
47
            , runTerm :: (MonadException m, CommandMonad m) => RunTermType m a -> m a
 
48
        }
 
49
 
 
50
-- | Operations needed for file-style interaction.
 
51
data FileOps = FileOps {
 
52
            inputHandle :: Handle, -- ^ e.g. for turning off echoing.
 
53
            getLocaleLine :: MaybeT IO String,
 
54
            getLocaleChar :: MaybeT IO Char,
 
55
            maybeReadNewline :: IO ()
 
56
        }
 
57
 
 
58
-- | Are we using terminal-style interaction?
 
59
isTerminalStyle :: RunTerm -> Bool
 
60
isTerminalStyle r = case termOps r of
 
61
                    Left TermOps{} -> True
 
62
                    _ -> False
 
63
 
 
64
-- Generic terminal actions which are independent of the Term being used.
 
65
-- Wrapped in a newtype so that we don't need RankNTypes.
 
66
newtype RunTermType m a = RunTermType (forall t . 
 
67
            (MonadTrans t, Term (t m), MonadException (t m), CommandMonad (t m))
 
68
                            => t m a)
 
69
 
 
70
class (MonadReader Prefs m , MonadReader Layout m)
 
71
        => CommandMonad m where
 
72
    runCompletion :: (String,String) -> m (String,[Completion])
 
73
 
 
74
instance (MonadTrans t, CommandMonad m, MonadReader Prefs (t m),
 
75
        MonadReader Layout (t m))
 
76
            => CommandMonad (t m) where
 
77
    runCompletion = lift . runCompletion
 
78
 
 
79
-- Utility function for drawLineDiff instances.
 
80
matchInit :: Eq a => [a] -> [a] -> ([a],[a])
 
81
matchInit (x:xs) (y:ys)  | x == y = matchInit xs ys
 
82
matchInit xs ys = (xs,ys)
 
83
 
 
84
data Event = WindowResize | KeyInput [Key] | ErrorEvent SomeException
 
85
                deriving Show
 
86
 
 
87
keyEventLoop :: IO [Event] -> Chan Event -> IO Event
 
88
keyEventLoop readEvents eventChan = do
 
89
    -- first, see if any events are already queued up (from a key/ctrl-c
 
90
    -- event or from a previous call to getEvent where we read in multiple
 
91
    -- keys)
 
92
    isEmpty <- isEmptyChan eventChan
 
93
    if not isEmpty
 
94
        then readChan eventChan
 
95
        else do
 
96
            lock <- newEmptyMVar
 
97
            tid <- forkIO $ handleErrorEvent (readerLoop lock)
 
98
            readChan eventChan `finally` do
 
99
                            putMVar lock ()
 
100
                            killThread tid
 
101
  where
 
102
    readerLoop lock = do
 
103
        es <- readEvents
 
104
        if null es
 
105
            then readerLoop lock
 
106
            else -- Use the lock to work around the fact that writeList2Chan
 
107
                 -- isn't atomic.  Otherwise, some events could be ignored if
 
108
                 -- the subthread is killed before it saves them in the chan.
 
109
                 bracket_ (putMVar lock ()) (takeMVar lock) $ 
 
110
                    writeList2Chan eventChan es
 
111
    handleErrorEvent = handle $ \e -> case fromException e of
 
112
                                Just ThreadKilled -> return ()
 
113
                                _ -> writeChan eventChan (ErrorEvent e)
 
114
 
 
115
 
 
116
data Interrupt = Interrupt
 
117
                deriving (Show,Typeable,Eq)
 
118
 
 
119
instance Exception Interrupt where
 
120
 
 
121
data Layout = Layout {width, height :: Int}
 
122
                    deriving (Show,Eq)
 
123
 
 
124
-----------------------------------
 
125
-- Utility functions for the various backends.
 
126
 
 
127
-- | Utility function since we're not using the new IO library yet.
 
128
hWithBinaryMode :: MonadException m => Handle -> m a -> m a
 
129
#if __GLASGOW_HASKELL__ >= 611
 
130
hWithBinaryMode h = bracket (liftIO $ hGetEncoding h)
 
131
                        (maybe (return ()) (liftIO . hSetEncoding h))
 
132
                        . const . (liftIO (hSetBinaryMode h True) >>)
 
133
#else
 
134
hWithBinaryMode _ = id
 
135
#endif
 
136
 
 
137
-- | Utility function for changing a property of a terminal for the duration of
 
138
-- a computation.
 
139
bracketSet :: (Eq a, MonadException m) => IO a -> (a -> IO ()) -> a -> m b -> m b
 
140
bracketSet getState set newState f = bracket (liftIO getState)
 
141
                            (liftIO . set)
 
142
                            (\_ -> liftIO (set newState) >> f)
 
143
 
 
144
 
 
145
-- | Returns one 8-bit word.  Needs to be wrapped by hWithBinaryMode.
 
146
hGetByte :: Handle -> MaybeT IO Word8
 
147
hGetByte h = do
 
148
    eof <- liftIO $ hIsEOF h
 
149
    guard (not eof)
 
150
    liftIO $ liftM (toEnum . fromEnum) $ hGetChar h
 
151
 
 
152
 
 
153
-- | Utility function to correctly get a ByteString line of input.
 
154
hGetLine :: Handle -> MaybeT IO ByteString
 
155
hGetLine h = do
 
156
    atEOF <- liftIO $ hIsEOF h
 
157
    guard (not atEOF)
 
158
    -- It's more efficient to use B.getLine, but that function throws an
 
159
    -- error if the Handle (e.g., stdin) is set to NoBuffering.
 
160
    buff <- liftIO $ hGetBuffering h
 
161
    liftIO $ if buff == NoBuffering
 
162
        then hWithBinaryMode h $ fmap B.pack $ System.IO.hGetLine h
 
163
        else B.hGetLine h
 
164
 
 
165
-- If another character is immediately available, and it is a newline, consume it.
 
166
--
 
167
-- Two portability fixes:
 
168
-- 
 
169
-- 1) Note that in ghc-6.8.3 and earlier, hReady returns False at an EOF,
 
170
-- whereas in ghc-6.10.1 and later it throws an exception.  (GHC trac #1063).
 
171
-- This code handles both of those cases.
 
172
--
 
173
-- 2) Also note that on Windows with ghc<6.10, hReady may not behave correctly (#1198)
 
174
-- The net result is that this might cause
 
175
-- But this function will generally only be used when reading buffered input
 
176
-- (since stdin isn't a terminal), so it should probably be OK.
 
177
hMaybeReadNewline :: Handle -> IO ()
 
178
hMaybeReadNewline h = returnOnEOF () $ do
 
179
    ready <- hReady h
 
180
    when ready $ do
 
181
        c <- hLookAhead h
 
182
        when (c == '\n') $ getChar >> return ()
 
183
 
 
184
returnOnEOF :: MonadException m => a -> m a -> m a
 
185
returnOnEOF x = handle $ \e -> if isEOFError e
 
186
                                then return x
 
187
                                else throwIO e