module System.Console.Haskeline.Backend.Terminfo( Draw(), runTerminfoDraw ) where import System.Console.Terminfo import Control.Monad import Data.List(intersperse) import System.IO import qualified Control.Exception.Extensible as Exception import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.LineState import System.Console.Haskeline.Command import System.Console.Haskeline.Term import System.Console.Haskeline.Backend.Posix import qualified Codec.Binary.UTF8.String as UTF8 -- | Keep track of all of the output capabilities we can use. -- -- We'll be frequently using the (automatic) 'Monoid' instance for -- @Actions -> TermOutput@. data Actions = Actions {leftA, rightA, upA :: Int -> TermOutput, clearToLineEnd :: TermOutput, nl, cr :: TermOutput, bellAudible,bellVisual :: TermOutput, clearAll :: LinesAffected -> TermOutput, wrapLine :: TermOutput} getActions :: Capability Actions getActions = do leftA' <- moveLeft rightA' <- moveRight upA' <- moveUp clearToLineEnd' <- clearEOL clearAll' <- clearScreen nl' <- newline cr' <- carriageReturn -- Don't require the bell capabilities bellAudible' <- bell `mplus` return mempty bellVisual' <- visualBell `mplus` return mempty wrapLine' <- getWrapLine nl' (leftA' 1) return Actions{leftA=leftA',rightA=rightA',upA=upA', clearToLineEnd=clearToLineEnd',nl=nl',cr=cr', bellAudible=bellAudible', bellVisual=bellVisual', clearAll=clearAll', wrapLine=wrapLine'} text :: String -> Actions -> TermOutput text str _ = termText (UTF8.encodeString str) getWrapLine :: TermOutput -> TermOutput -> Capability TermOutput getWrapLine nl' left1 = (autoRightMargin >>= guard >> withAutoMargin) `mplus` return nl' where -- If the wraparound glitch is in effect, force a wrap by printing a space. -- Otherwise, it'll wrap automatically. withAutoMargin = (do wraparoundGlitch >>= guard return (termText " " <#> left1) )`mplus` return mempty left,right,up :: Int -> Actions -> TermOutput left = flip leftA right = flip rightA up = flip upA -------- mreplicate :: Monoid m => Int -> m -> m mreplicate n m | n <= 0 = mempty | otherwise = m `mappend` mreplicate (n-1) m -- denote in modular arithmetic; -- in particular, 0 <= termCol < width data TermPos = TermPos {termRow,termCol :: Int} deriving Show initTermPos :: TermPos initTermPos = TermPos {termRow = 0, termCol = 0} -------------- 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, MonadReader Handle) instance MonadReader Layout m => MonadReader Layout (Draw m) where ask = lift ask local r = Draw . local r . unDraw instance MonadException m => MonadException (Draw m) where block = Draw . block . unDraw unblock = Draw . unblock . unDraw catch (Draw f) g = Draw $ Monads.catch f (unDraw . g) instance MonadTrans Draw where lift = Draw . lift . lift . lift . lift runTerminfoDraw :: IO (Maybe RunTerm) runTerminfoDraw = do mterm <- Exception.try setupTermFromEnv case mterm of -- XXX narrow this: either an ioexception (from getenv) or a -- usererror. Left (_::SomeException) -> return Nothing Right term -> case getCapability term getActions of Nothing -> return Nothing Just actions -> fmap Just $ posixRunTerm $ \h -> TermOps { getLayout = getPosixLayout h (Just term), runTerm = \f -> evalStateT' initTermPos (runReaderT' term (runReaderT' actions (runReaderT' h (unDraw (withPosixGetEvent h (Just term) f))))) } output :: MonadIO m => (Actions -> TermOutput) -> Draw m () output f = do toutput <- asks f term <- ask ttyh <- ask liftIO $ hRunTermOutput ttyh term toutput changeRight, changeLeft :: MonadLayout m => Int -> Draw m () changeRight n = do w <- asks width TermPos {termRow=r,termCol=c} <- get if c+n < w then do put TermPos {termRow=r,termCol=c+n} output (right n) else do let m = c+n let linesDown = m `div` w let newCol = m `rem` w put TermPos {termRow=r+linesDown, termCol=newCol} output $ cr <#> mreplicate linesDown nl <#> right newCol changeLeft n = do w <- asks width TermPos {termRow=r,termCol=c} <- get if c - n >= 0 then do put TermPos {termRow = r,termCol = c-n} output (left n) else do let m = n - c let linesUp = 1 + ((m-1) `div` w) let newCol = (-m) `mod` w -- mod returns positive # put TermPos {termRow = r - linesUp, termCol=newCol} output $ cr <#> up linesUp <#> right newCol -- TODO: I think if we wrap this all up in one call to output, it'll be faster... printText :: MonadLayout m => String -> Draw m () printText "" = return () printText xs = fillLine xs >>= printText -- Draws as much of the string as possible in the line, and returns the rest. -- If we fill up the line completely, wrap to the next row. fillLine :: MonadLayout m => String -> Draw m String fillLine str = do w <- asks width TermPos {termRow=r,termCol=c} <- get let roomLeft = w - c if length str < roomLeft then do output (text str) put TermPos{termRow=r, termCol=c+length str} return "" else do let (thisLine,rest) = splitAt roomLeft str output (text thisLine <#> wrapLine) put TermPos {termRow=r+1,termCol=0} return rest drawLineDiffT :: MonadLayout m => LineChars -> LineChars -> Draw m () drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of ([],[]) | ys1 == ys2 -> return () (xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (length xs1') ([],xs2') | ys1 == xs2' ++ ys2 -> changeRight (length xs2') (xs1',xs2') -> do changeLeft (length xs1') printText (xs2' ++ ys2) let m = length xs1' + length ys1 - (length xs2' + length ys2) clearDeadText m changeLeft (length ys2) linesLeft :: Layout -> TermPos -> Int -> Int linesLeft Layout {width=w} TermPos {termCol = c} n | c + n < w = 1 | otherwise = 1 + div (c+n) w lsLinesLeft :: Layout -> TermPos -> LineChars -> Int lsLinesLeft layout pos s = linesLeft layout pos (lengthToEnd s) clearDeadText :: MonadLayout m => Int -> Draw m () clearDeadText n | n <= 0 = return () | otherwise = do layout <- ask pos <- get let numLinesToClear = linesLeft layout pos n output clearToLineEnd when (numLinesToClear > 1) $ output $ mconcat [ mreplicate (numLinesToClear - 1) $ nl <#> clearToLineEnd , up (numLinesToClear - 1) , right (termCol pos)] clearLayoutT :: MonadLayout m => Draw m () clearLayoutT = do h <- asks height output (flip clearAll h) put initTermPos moveToNextLineT :: MonadLayout m => LineChars -> Draw m () moveToNextLineT s = do pos <- get layout <- ask output $ mreplicate (lsLinesLeft layout pos s) nl put initTermPos repositionT :: (MonadLayout m, MonadException m) => Layout -> LineChars -> Draw m () repositionT oldLayout s = do oldPos <- get let l = lsLinesLeft oldLayout oldPos s - 1 output $ cr <#> mreplicate l nl <#> mreplicate (l + termRow oldPos) (clearToLineEnd <#> up 1) put initTermPos drawLineDiffT ("","") s instance (MonadException m, MonadLayout m) => Term (Draw m) where drawLineDiff = drawLineDiffT reposition = repositionT printLines [] = return () printLines ls = output $ mconcat $ intersperse nl (map text ls) ++ [nl] clearLayout = clearLayoutT moveToNextLine = moveToNextLineT ringBell True = output bellAudible ringBell False = output bellVisual