# Ticket #81: Terminfo.hs

File Terminfo.hs, 12.4 kB (added by guest, 6 years ago) |
---|

Line | |
---|---|

1 | module System.Console.Haskeline.Backend.Terminfo( |

2 | Draw(), |

3 | runTerminfoDraw |

4 | ) |

5 | where |

6 | |

7 | import System.Console.Terminfo |

8 | import Control.Monad |

9 | import Data.List(intersperse) |

10 | import System.IO |

11 | import qualified Control.Exception.Extensible as Exception |

12 | import qualified Data.ByteString.Char8 as B |

13 | import Data.Maybe (fromMaybe, mapMaybe) |

14 | import Control.Concurrent.Chan |

15 | |

16 | import System.Console.Haskeline.Monads as Monads |

17 | import System.Console.Haskeline.LineState |

18 | import System.Console.Haskeline.Term |

19 | import System.Console.Haskeline.Backend.Posix |

20 | import System.Console.Haskeline.Key |

21 | import 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@. |

26 | data 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 | |

33 | getActions :: Capability Actions |

34 | getActions = 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 | |

52 | text :: B.ByteString -> Actions -> TermOutput |

53 | text str _ = termText $ B.unpack str |

54 | |

55 | getWrapLine :: TermOutput -> TermOutput -> Capability TermOutput |

56 | getWrapLine 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 | |

66 | type TermAction = Actions -> TermOutput |

67 | |

68 | left,right,up :: Int -> TermAction |

69 | left = flip leftA |

70 | right = flip rightA |

71 | up = flip upA |

72 | |

73 | clearAll :: LinesAffected -> TermAction |

74 | clearAll = flip clearAllA |

75 | |

76 | -------- |

77 | |

78 | |

79 | mreplicate :: Monoid m => Int -> m -> m |

80 | mreplicate 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. |

87 | data TermPos = TermPos {termRow,termCol,termLastLine :: Int, eolPos :: M.IntMap Int} |

88 | deriving Show |

89 | |

90 | initTermPos :: TermPos |

91 | initTermPos = TermPos {termRow = 0, termCol = 0, termLastLine=0 ,eolPos =(M.singleton 0 0)} |

92 | |

93 | |

94 | -------------- |

95 | |

96 | newtype 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 | |

103 | type DrawM a = forall m . (MonadReader Layout m, MonadIO m) => Draw m a |

104 | |

105 | instance MonadTrans Draw where |

106 | lift = Draw . lift . lift . lift . lift . lift |

107 | |

108 | runTerminfoDraw :: IO (Maybe RunTerm) |

109 | runTerminfoDraw = 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. |

134 | wrapKeypad :: MonadException m => Handle -> Terminal -> m a -> m a |

135 | wrapKeypad h term f = (maybeOutput keypadOn >> f) |

136 | `finally` maybeOutput keypadOff |

137 | where |

138 | maybeOutput = liftIO . hRunTermOutput h term . |

139 | fromMaybe mempty . getCapability term |

140 | |

141 | tinfoLayout :: Terminal -> IO (Maybe Layout) |

142 | tinfoLayout term = return $ getCapability term $ do |

143 | r <- termColumns |

144 | c <- termLines |

145 | return Layout {height=r,width=c} |

146 | |

147 | terminfoKeys :: Terminal -> [(String,Key)] |

148 | terminfoKeys 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 | |

167 | output :: MonadIO m => TermAction -> Draw m () |

168 | output f = do |

169 | toutput <- asks f |

170 | term <- ask |

171 | ttyh <- ask |

172 | liftIO $ hRunTermOutput ttyh term toutput |

173 | |

174 | |

175 | |

176 | changeRight, changeLeft :: Int -> DrawM () |

177 | changeRight 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 | |

193 | mapRight::(M.Key,Int) -> Int -> Int -> M.IntMap Int -> Int -> (M.Key,Int) |

194 | mapRight (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 | |

203 | changeLeft 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 | |

216 | mapLeft::(M.Key,Int) -> Int -> M.IntMap Int -> (M.Key,Int) |

217 | mapLeft (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... |

230 | printText :: [Grapheme] -> DrawM () |

231 | printText [] = return () |

232 | printText 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. |

236 | fillLine :: [Grapheme] -> DrawM [Grapheme] |

237 | fillLine 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 | |

255 | drawLineDiffT :: LineChars -> LineChars -> DrawM () |

256 | drawLineDiffT (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 | |

267 | graphemeWidth::[Grapheme]->Int |

268 | graphemeWidth 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. |

272 | graphemeSplitAt::Int -> [Grapheme] -> ([Grapheme],[Grapheme]) |

273 | graphemeSplitAt 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 | |

282 | linesLeft :: Layout -> TermPos -> Int -> Int |

283 | linesLeft Layout {width=w} TermPos {termCol = c} n |

284 | | c + n < w = 1 |

285 | | otherwise = 1 + div (c+n) w |

286 | |

287 | lsLinesLeft :: Layout -> TermPos -> LineChars -> Int |

288 | lsLinesLeft layout pos = linesLeft layout pos . lengthToEnd |

289 | |

290 | clearDeadText :: Int -> DrawM () |

291 | clearDeadText 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 | |

304 | clearLayoutT :: DrawM () |

305 | clearLayoutT = do |

306 | h <- asks height |

307 | output (clearAll h) |

308 | put initTermPos |

309 | |

310 | moveToNextLineT :: LineChars -> DrawM () |

311 | moveToNextLineT s = do |

312 | pos <- get |

313 | layout <- ask |

314 | output $ mreplicate (lsLinesLeft layout pos s) nl |

315 | put initTermPos |

316 | |

317 | repositionT :: Layout -> LineChars -> DrawM () |

318 | repositionT 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 | |

326 | instance (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 |