Ticket #81: Terminfo.hs

File Terminfo.hs, 12.4 kB (added by guest, 5 years ago)

Multi line wide char support.

Line 
1module System.Console.Haskeline.Backend.Terminfo(
2                            Draw(),
3                            runTerminfoDraw
4                            )
5                             where
6
7import System.Console.Terminfo
8import Control.Monad
9import Data.List(intersperse)
10import System.IO
11import qualified Control.Exception.Extensible as Exception
12import qualified Data.ByteString.Char8 as B
13import Data.Maybe (fromMaybe, mapMaybe)
14import Control.Concurrent.Chan
15
16import System.Console.Haskeline.Monads as Monads
17import System.Console.Haskeline.LineState
18import System.Console.Haskeline.Term
19import System.Console.Haskeline.Backend.Posix
20import System.Console.Haskeline.Key
21import qualified Data.IntMap as M
22-- | Keep track of all of the output capabilities we can use.
23--
24-- We'll be frequently using the (automatic) 'Monoid' instance for
25-- @Actions -> TermOutput@.
26data Actions = Actions {leftA, rightA, upA :: Int -> TermOutput,
27                        clearToLineEnd :: TermOutput,
28                        nl, cr :: TermOutput,
29                        bellAudible,bellVisual :: TermOutput,
30                        clearAllA :: LinesAffected -> TermOutput,
31                        wrapLine :: TermOutput}
32
33getActions :: Capability Actions
34getActions = do
35    leftA' <- moveLeft
36    rightA' <- moveRight
37    upA' <- moveUp
38    clearToLineEnd' <- clearEOL
39    clearAll' <- clearScreen
40    nl' <- newline
41    cr' <- carriageReturn
42    -- Don't require the bell capabilities
43    bellAudible' <- bell `mplus` return mempty
44    bellVisual' <- visualBell `mplus` return mempty
45    wrapLine' <- getWrapLine nl' (leftA' 1)
46    return Actions{leftA = leftA', rightA = rightA',upA = upA',
47                clearToLineEnd = clearToLineEnd', nl = nl',cr = cr',
48                bellAudible = bellAudible', bellVisual = bellVisual',
49                clearAllA = clearAll',
50                 wrapLine = wrapLine'}
51
52text :: B.ByteString -> Actions -> TermOutput
53text str _ = termText $ B.unpack str
54
55getWrapLine :: TermOutput -> TermOutput -> Capability TermOutput
56getWrapLine nl' left1 = (autoRightMargin >>= guard >> withAutoMargin)
57                    `mplus` return nl'
58  where 
59    -- If the wraparound glitch is in effect, force a wrap by printing a space.
60    -- Otherwise, it'll wrap automatically.
61    withAutoMargin = (do
62                        wraparoundGlitch >>= guard
63                        return (termText " " <#> left1)
64                     )`mplus` return mempty
65
66type TermAction = Actions -> TermOutput
67   
68left,right,up :: Int -> TermAction
69left = flip leftA
70right = flip rightA
71up = flip upA
72
73clearAll :: LinesAffected -> TermAction
74clearAll = flip clearAllA
75
76--------
77
78
79mreplicate :: Monoid m => Int -> m -> m
80mreplicate n m
81    | n <= 0    = mempty
82    | otherwise = m `mappend` mreplicate (n-1) m
83
84-- denote in modular arithmetic;
85-- in particular, 0 <= termCol < width
86--eolPos, End of Line Position, every on screen displaying line's end Char position.
87data TermPos = TermPos {termRow,termCol,termLastLine :: Int, eolPos :: M.IntMap Int}
88                deriving Show
89
90initTermPos :: TermPos
91initTermPos = TermPos {termRow = 0, termCol = 0, termLastLine=0 ,eolPos =(M.singleton 0 0)}
92
93
94--------------
95
96newtype Draw m a = Draw {unDraw :: (ReaderT Actions
97                                    (ReaderT Terminal (StateT TermPos
98                                    (PosixT m)))) a}
99    deriving (Monad, MonadIO, MonadException,
100              MonadReader Actions, MonadReader Terminal, MonadState TermPos,
101              MonadReader Handle, MonadReader Encoders)
102
103type DrawM a = forall m . (MonadReader Layout m, MonadIO m) => Draw m a
104
105instance MonadTrans Draw where
106    lift = Draw . lift . lift . lift . lift . lift
107   
108runTerminfoDraw :: IO (Maybe RunTerm)
109runTerminfoDraw = do
110    mterm <- Exception.try setupTermFromEnv
111    ch <- newChan
112    case mterm of
113        -- XXX narrow this: either an ioexception (from getenv) or a
114        -- usererror.
115        Left (_::SetupTermError) -> return Nothing
116        Right term -> case getCapability term getActions of
117            Nothing -> return Nothing
118            Just actions -> fmap Just $ posixRunTerm $ \enc h ->
119                TermOps {
120                    getLayout = tryGetLayouts (posixLayouts h
121                                                ++ [tinfoLayout term])
122                    , withGetEvent = wrapKeypad h term
123                                        . withPosixGetEvent ch h enc
124                                            (terminfoKeys term)
125                    , runTerm = \(RunTermType f) ->
126                             runPosixT enc h
127                              $ evalStateT' initTermPos
128                              $ runReaderT' term
129                              $ runReaderT' actions
130                              $ unDraw f
131                    }
132
133-- If the keypad on/off capabilities are defined, wrap the computation with them.
134wrapKeypad :: MonadException m => Handle -> Terminal -> m a -> m a
135wrapKeypad h term f = (maybeOutput keypadOn >> f)
136                            `finally` maybeOutput keypadOff
137  where
138    maybeOutput = liftIO . hRunTermOutput h term .
139                            fromMaybe mempty . getCapability term
140
141tinfoLayout :: Terminal -> IO (Maybe Layout)
142tinfoLayout term = return $ getCapability term $ do
143                        r <- termColumns
144                        c <- termLines
145                        return Layout {height=r,width=c}
146
147terminfoKeys :: Terminal -> [(String,Key)]
148terminfoKeys term = mapMaybe getSequence keyCapabilities
149    where
150        getSequence (cap,x) = do
151                            keys <- getCapability term cap
152                            return (keys,x)
153        keyCapabilities =
154                [(keyLeft,      simpleKey LeftKey)
155                ,(keyRight,      simpleKey RightKey)
156                ,(keyUp,         simpleKey UpKey)
157                ,(keyDown,       simpleKey DownKey)
158                ,(keyBackspace,  simpleKey Backspace)
159                ,(keyDeleteChar, simpleKey Delete)
160                ,(keyHome,       simpleKey Home)
161                ,(keyEnd,        simpleKey End)
162                ,(keyPageDown,   simpleKey PageDown)
163                ,(keyPageUp,     simpleKey PageUp)
164                ]
165
166   
167output :: MonadIO m => TermAction -> Draw m ()
168output f = do
169    toutput <- asks f
170    term <- ask
171    ttyh <- ask
172    liftIO $ hRunTermOutput ttyh term toutput
173
174
175
176changeRight, changeLeft :: Int -> DrawM ()
177changeRight n = do
178    w <- asks width
179    TermPos {termRow=r,termCol=c,termLastLine=l,eolPos=ep} <- get
180    if c+n < M.findWithDefault w r ep || r == l
181        -- Still not reach the EOL || This is the Last line on the screen
182        then do
183                put TermPos {termRow=r,termCol=c+n,termLastLine=l,eolPos=ep}
184                output (right n)
185        else do
186        -- Reach or Over EOL need mapRight to calculate.
187                let (r',c') = mapRight (r,c) w l ep n
188                let linesDown = r'-r
189                let newCol = c'
190                put TermPos {termRow=r+linesDown, termCol=newCol,termLastLine=l, eolPos=ep}
191                output $ cr <#> mreplicate linesDown nl <#> right newCol
192
193mapRight::(M.Key,Int) -> Int -> Int -> M.IntMap Int -> Int -> (M.Key,Int)
194mapRight (r,c) w l m n
195        |r >= 0 && c >= 0  = do
196                if c + n <= findD r m || r == l
197                        then (r,c+n)
198                        else mapRight (r+1,0) w l m (c + n-(findD r m)-1)
199        |True =  (0,0)
200        where
201                findD r' m' = M.findWithDefault (-1) r' m'
202                     
203changeLeft n = do
204    TermPos {termRow=r,termCol=c,termLastLine=l,eolPos=ep} <- get
205    if c - n >= 0
206        then do
207                put TermPos {termRow = r,termCol = c-n,termLastLine=l,eolPos=ep}
208                output (left n)
209        else do     
210                let (r',c') = mapLeft (r,c) n ep
211                let linesUp = r - r'
212                let newCol = c'
213                put TermPos {termRow = r - linesUp, termCol=newCol,termLastLine=l,eolPos=ep}
214                output $ cr <#> up linesUp <#> right newCol
215
216mapLeft::(M.Key,Int) -> Int -> M.IntMap Int -> (M.Key,Int)
217mapLeft (r,c) n m = do
218        if c-n >= 0
219                then do
220                        if r < 0
221                                then (0,0)
222                                else (r,c-n)
223                else do if r < 0
224                                then (0,0)
225                                else mapLeft (r-1,findD (r-1) m) (n-c-1) m
226        where
227                findD r' m' = M.findWithDefault (-1) r' m'
228             
229-- TODO: I think if we wrap this all up in one call to output, it'll be faster...
230printText :: [Grapheme] -> DrawM ()
231printText [] = return ()
232printText xs = fillLine xs >>= printText
233
234-- Draws as much of the string as possible in the line, and returns the rest.
235-- If we fill up the line completely, wrap to the next row.
236fillLine :: [Grapheme] -> DrawM [Grapheme]
237fillLine str = do
238    w <- asks width
239    TermPos {termRow=r,termCol=c,termLastLine=l,eolPos=ep} <- get
240    let roomLeft = w - c -- Cell Room still Left for Print
241    if graphemeWidth str < roomLeft
242        then do
243                posixEncode (graphemesToString str) >>= output . text
244                put TermPos{termRow=r, termCol=c+graphemeWidth str,termLastLine=r,eolPos=M.insert r (c + graphemeWidth str-1) ep}
245                return []
246        else do -- Line Changer, set or fix thisLine's eolPos, set termLastLine
247                let (thisLine,rest) = graphemeSplitAt roomLeft str --splitAt dosen't fit for variable width sting, use graphemeSplitAt here.
248                bstr <- posixEncode (graphemesToString thisLine)
249                output (text bstr <#> wrapLine)
250                case (thisLine,rest) of
251                        ([],_) ->  put TermPos {termRow=r+1,termCol=0,termLastLine=r+1,eolPos=M.insert r (w-roomLeft-1) ep}
252                        (ts,_) ->  put TermPos {termRow=r+1,termCol=0,termLastLine=r+1,eolPos=M.insert r (c + graphemeWidth ts - 1) ep}
253                return rest
254
255drawLineDiffT :: LineChars -> LineChars -> DrawM ()
256drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of
257    ([],[])     | ys1 == ys2            -> return ()
258    (xs1',[])   | xs1' ++ ys1 == ys2    -> changeLeft (graphemeWidth xs1')
259    ([],xs2')   | ys1 == xs2' ++ ys2    -> changeRight (graphemeWidth xs2')
260    (xs1',xs2')                         -> do
261        changeLeft (graphemeWidth xs1')
262        printText (xs2' ++ ys2)
263        let m = graphemeWidth xs1' + graphemeWidth ys1 - (graphemeWidth xs2' + graphemeWidth ys2)
264        clearDeadText m
265        changeLeft (graphemeWidth ys2)
266       
267graphemeWidth::[Grapheme]->Int
268graphemeWidth wc = sum $ map (wcwidth . baseChar) wc
269
270--Split String which contain Wide Char at a properly point,
271--Use room left as much as possible.
272graphemeSplitAt::Int -> [Grapheme] -> ([Grapheme],[Grapheme])
273graphemeSplitAt roomleft wcstr = (take splitPoint wcstr,drop splitPoint wcstr)
274        where
275                splitPoint = countWhileSumLQ roomleft widthMap 0
276                widthMap = map (wcwidth . baseChar) wcstr
277                countWhileSumLQ _ [] counter = counter -- Count while sum up width just less than or equal as 'n'
278                countWhileSumLQ n (x:xs) counter = if n-x >= 0
279                                                        then countWhileSumLQ (n-x) xs (counter + 1)
280                                                        else counter
281
282linesLeft :: Layout -> TermPos -> Int -> Int
283linesLeft Layout {width=w} TermPos {termCol = c} n
284    | c + n < w = 1
285    | otherwise = 1 + div (c+n) w
286
287lsLinesLeft :: Layout -> TermPos -> LineChars -> Int
288lsLinesLeft layout pos = linesLeft layout pos . lengthToEnd
289
290clearDeadText :: Int -> DrawM ()
291clearDeadText n
292    | n <= 0    = return ()
293    | otherwise = do
294        layout <- ask
295        pos <- get
296        let numLinesToClear = linesLeft layout pos n
297        output clearToLineEnd
298        when (numLinesToClear > 1) $ output $ mconcat [
299                    mreplicate (numLinesToClear - 1)
300                            $ nl <#> clearToLineEnd
301                    , up (numLinesToClear - 1)
302                    , right (termCol pos)]
303
304clearLayoutT :: DrawM ()
305clearLayoutT = do
306    h <- asks height
307    output (clearAll h)
308    put initTermPos
309
310moveToNextLineT :: LineChars -> DrawM ()
311moveToNextLineT s = do
312    pos <- get
313    layout <- ask
314    output $ mreplicate (lsLinesLeft layout pos s) nl
315    put initTermPos
316
317repositionT :: Layout -> LineChars -> DrawM ()
318repositionT oldLayout s = do
319    oldPos <- get
320    let l = lsLinesLeft oldLayout oldPos s - 1
321    output $ cr <#> mreplicate l nl
322            <#> mreplicate (l + termRow oldPos) (clearToLineEnd <#> up 1)
323    put initTermPos
324    drawLineDiffT ([],[]) s
325
326instance (MonadException m, MonadReader Layout m) => Term (Draw m) where
327    drawLineDiff = drawLineDiffT
328    reposition = repositionT
329   
330    printLines [] = return ()
331    printLines ls = do
332        bls <- mapM posixEncode ls
333        output $ mconcat $ intersperse nl (map text bls) ++ [nl]
334    clearLayout = clearLayoutT
335    moveToNextLine = moveToNextLineT
336    ringBell True = output bellAudible
337    ringBell False = output bellVisual