module System.Console.Haskeline.Backend.Terminfo(
Draw(),
runTerminfoDraw
)
where
import System.Console.Terminfo
import Control.Monad
import Data.List(intersperse, foldl')
import System.IO
import qualified Control.Exception.Extensible as Exception
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromMaybe, mapMaybe)
import Control.Concurrent.Chan
import qualified Data.IntMap as Map
import System.Console.Haskeline.Monads as Monads
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Term
import System.Console.Haskeline.Backend.Posix
import System.Console.Haskeline.Backend.WCWidth
import System.Console.Haskeline.Key
data Actions = Actions {leftA, rightA, upA :: Int -> TermOutput,
clearToLineEnd :: TermOutput,
nl, cr :: TermOutput,
bellAudible,bellVisual :: TermOutput,
clearAllA :: LinesAffected -> TermOutput,
wrapLine :: TermOutput}
getActions :: Capability Actions
getActions = do
autoRightMargin >>= guard
leftA' <- moveLeft
rightA' <- moveRight
upA' <- moveUp
clearToLineEnd' <- clearEOL
clearAll' <- clearScreen
nl' <- newline
cr' <- carriageReturn
bellAudible' <- bell `mplus` return mempty
bellVisual' <- visualBell `mplus` return mempty
wrapLine' <- getWrapLine (leftA' 1)
return Actions{leftA = leftA', rightA = rightA',upA = upA',
clearToLineEnd = clearToLineEnd', nl = nl',cr = cr',
bellAudible = bellAudible', bellVisual = bellVisual',
clearAllA = clearAll',
wrapLine = wrapLine'}
getWrapLine :: TermOutput -> Capability TermOutput
getWrapLine left1 = (do
wraparoundGlitch >>= guard
return (termText " " <#> left1)
) `mplus` return mempty
type TermAction = Actions -> TermOutput
text :: B.ByteString -> TermAction
text str _ = termText $ B.unpack str
left,right,up :: Int -> TermAction
left = flip leftA
right = flip rightA
up = flip upA
clearAll :: LinesAffected -> TermAction
clearAll = flip clearAllA
mreplicate :: Monoid m => Int -> m -> m
mreplicate n m
| n <= 0 = mempty
| otherwise = m `mappend` mreplicate (n1) m
spaces :: Int -> TermAction
spaces 0 = mempty
spaces 1 = const $ termText " "
spaces n = const $ termText $ replicate n ' '
data TermPos = TermPos {termRow,termCol :: !Int}
deriving Show
initTermPos :: TermPos
initTermPos = TermPos {termRow = 0, termCol = 0}
data TermRows = TermRows {
rowLengths :: !(Map.IntMap Int),
lastRow :: !Int
}
deriving Show
initTermRows :: TermRows
initTermRows = TermRows {rowLengths = Map.empty, lastRow=0}
setRow :: Int -> Int -> TermRows -> TermRows
setRow r len rs = TermRows {rowLengths = Map.insert r len (rowLengths rs),
lastRow=r}
lookupCells :: TermRows -> Int -> Int
lookupCells (TermRows rc _) r = Map.findWithDefault 0 r rc
sum' :: [Int] -> Int
newtype Draw m a = Draw {unDraw :: (ReaderT Actions
(ReaderT Terminal
(StateT TermRows
(StateT TermPos
(PosixT m))))) a}
deriving (Monad, MonadIO, MonadException,
MonadReader Actions, MonadReader Terminal, MonadState TermPos,
MonadState TermRows,
MonadReader Handles, MonadReader Encoders)
type DrawM a = forall m . (MonadReader Layout m, MonadIO m) => Draw m a
instance MonadTrans Draw where
lift = Draw . lift . lift . lift . lift . lift . lift
runTerminfoDraw :: Handles -> MaybeT IO RunTerm
runTerminfoDraw h = do
mterm <- liftIO $ Exception.try setupTermFromEnv
ch <- liftIO newChan
case mterm of
Left (_::SetupTermError) -> mzero
Right term -> do
actions <- MaybeT $ return $ getCapability term getActions
posixRunTerm h $ \enc ->
TermOps {
getLayout = tryGetLayouts (posixLayouts h
++ [tinfoLayout term])
, withGetEvent = wrapKeypad (hOut h) term
. withPosixGetEvent ch h enc
(terminfoKeys term)
, saveUnusedKeys = saveKeys ch
, runTerm = \(RunTermType f) ->
runPosixT enc h
$ evalStateT' initTermPos
$ evalStateT' initTermRows
$ runReaderT' term
$ runReaderT' actions
$ unDraw f
}
wrapKeypad :: MonadException m => Handle -> Terminal -> m a -> m a
wrapKeypad h term f = (maybeOutput keypadOn >> f)
`finally` maybeOutput keypadOff
where
maybeOutput = liftIO . hRunTermOutput h term .
fromMaybe mempty . getCapability term
tinfoLayout :: Terminal -> IO (Maybe Layout)
tinfoLayout term = return $ getCapability term $ do
r <- termColumns
c <- termLines
return Layout {height=r,width=c}
terminfoKeys :: Terminal -> [(String,Key)]
terminfoKeys term = mapMaybe getSequence keyCapabilities
where
getSequence (cap,x) = do
keys <- getCapability term cap
return (keys,x)
keyCapabilities =
[(keyLeft, simpleKey LeftKey)
,(keyRight, simpleKey RightKey)
,(keyUp, simpleKey UpKey)
,(keyDown, simpleKey DownKey)
,(keyBackspace, simpleKey Backspace)
,(keyDeleteChar, simpleKey Delete)
,(keyHome, simpleKey Home)
,(keyEnd, simpleKey End)
,(keyPageDown, simpleKey PageDown)
,(keyPageUp, simpleKey PageUp)
,(keyEnter, simpleKey $ KeyChar '\n')
]
output :: MonadIO m => TermAction -> Draw m ()
output f = do
toutput <- asks f
term <- ask
ttyh <- liftM hOut ask
liftIO $ hRunTermOutput ttyh term toutput
changePos :: TermPos -> TermPos -> TermAction
changePos TermPos {termRow=r1, termCol=c1} TermPos {termRow=r2, termCol=c2}
| r1 == r2 = if c1 < c2 then right (c2c1) else left (c1c2)
| r1 > r2 = cr <#> up (r1r2) <#> right c2
| otherwise = cr <#> mreplicate (r2r1) nl <#> right c2
moveToPos :: TermPos -> DrawM TermAction
moveToPos p = do
oldP <- get
put p
return $ changePos oldP p
moveRelative :: Int -> DrawM ()
moveRelative n = liftM3 (advancePos n) ask get get
>>= moveToPos >>= output
changeRight, changeLeft :: Int -> DrawM ()
changeRight n | n <= 0 = return ()
| otherwise = moveRelative n
changeLeft n | n <= 0 = return ()
| otherwise = moveRelative (negate n)
advancePos :: Int -> Layout -> TermRows -> TermPos -> TermPos
advancePos k Layout {width=w} rs p = indexToPos $ k + posIndex
where
posIndex = termCol p + sum' (map (lookupCells rs)
[0..termRow p1])
indexToPos n = loopFindRow 0 n
loopFindRow r m = r `seq` m `seq` let
thisRowSize = lookupCells rs r
in if m < thisRowSize
|| (m == thisRowSize && m < w)
|| thisRowSize <= 0
then TermPos {termRow=r, termCol=m}
else loopFindRow (r+1) (mthisRowSize)
sum' = foldl' (+) 0
encodeGraphemes :: MonadIO m => [Grapheme] -> Draw m TermAction
encodeGraphemes = liftM text . posixEncode . graphemesToString
printText :: [Grapheme] -> DrawM TermAction
printText = textAction mempty
textAction :: TermAction -> [Grapheme] -> DrawM TermAction
textAction prevOutput [] = return prevOutput
textAction prevOutput gs = do
w <- asks width
TermPos {termRow=r, termCol=c} <- get
let (thisLine,rest,thisWidth) = splitAtWidth (wc) gs
let lineWidth = c + thisWidth
ts <- encodeGraphemes thisLine
modify $ setRow r lineWidth
if null rest && lineWidth < w
then do
put TermPos {termRow=r, termCol=lineWidth}
return (prevOutput <#> ts)
else do
put TermPos {termRow=r+1,termCol=0}
let wrap = if lineWidth == w then wrapLine else spaces (wlineWidth)
textAction (prevOutput <#> ts <#> wrap) rest
drawLineDiffT :: LineChars -> LineChars -> DrawM ()
drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of
([],[]) | ys1 == ys2 -> return ()
(xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (gsWidth xs1')
([],xs2') | ys1 == xs2' ++ ys2 -> changeRight (gsWidth xs2')
(xs1',xs2') -> do
oldRS <- get
changeLeft (gsWidth xs1')
xsOut <- printText xs2'
p <- get
restOut <- liftM mconcat $ sequence
[ printText ys2
, clearDeadText oldRS
, moveToPos p
]
output (xsOut <#> restOut)
getLinesLeft :: DrawM Int
getLinesLeft = do
p <- get
rc <- get
return $ max 0 (lastRow rc termRow p)
clearDeadText :: TermRows -> DrawM TermAction
clearDeadText oldRS = do
TermPos {termRow = r, termCol = c} <- get
let extraRows = lastRow oldRS r
if extraRows < 0
|| (extraRows == 0 && lookupCells oldRS r <= c)
then return mempty
else do
modify $ setRow r c
when (extraRows /= 0)
$ put TermPos {termRow = r + extraRows, termCol=0}
return $ clearToLineEnd <#> mreplicate extraRows (nl <#> clearToLineEnd)
clearLayoutT :: DrawM ()
clearLayoutT = do
h <- asks height
output (clearAll h)
put initTermPos
moveToNextLineT :: LineChars -> DrawM ()
moveToNextLineT _ = do
lleft <- getLinesLeft
output $ mreplicate (lleft+1) nl
put initTermPos
put initTermRows
repositionT :: Layout -> LineChars -> DrawM ()
repositionT _ s = do
oldPos <- get
l <- getLinesLeft
output $ cr <#> mreplicate l nl
<#> mreplicate (l + termRow oldPos) (clearToLineEnd <#> up 1)
put initTermPos
put initTermRows
drawLineDiffT ([],[]) s
instance (MonadException m, MonadReader Layout m) => Term (Draw m) where
drawLineDiff = drawLineDiffT
reposition = repositionT
printLines [] = return ()
printLines ls = do
bls <- mapM posixEncode ls
output $ mconcat $ intersperse nl (map text bls) ++ [nl]
clearLayout = clearLayoutT
moveToNextLine = moveToNextLineT
ringBell True = output bellAudible
ringBell False = output bellVisual