module System.Console.Haskeline.Backend.DumbTerm where
import System.Console.Haskeline.Backend.Posix
import System.Console.Haskeline.Term
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Monads as Monads
import System.IO
import qualified Data.ByteString as B
import Control.Concurrent.Chan
data Window = Window {pos :: Int
}
initWindow :: Window
initWindow = Window {pos=0}
newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a}
deriving (Monad, MonadIO, MonadException,
MonadState Window,
MonadReader Handle, MonadReader Encoders)
instance MonadReader Layout m => MonadReader Layout (DumbTerm m) where
ask = lift ask
local r = DumbTerm . local r . unDumbTerm
instance MonadTrans DumbTerm where
lift = DumbTerm . lift . lift . lift
runDumbTerm :: IO RunTerm
runDumbTerm = do
ch <- newChan
posixRunTerm $ \enc h ->
TermOps {
getLayout = tryGetLayouts (posixLayouts h),
runTerm = \f ->
runPosixT enc h $ evalStateT' initWindow
$ unDumbTerm
$ withPosixGetEvent ch enc [] f
}
instance (MonadException m, MonadLayout m) => Term (DumbTerm m) where
reposition _ s = refitLine s
drawLineDiff = drawLineDiff'
printLines = mapM_ (\s -> printText (s ++ crlf))
moveToNextLine = \_ -> printText crlf
clearLayout = clearLayoutD
ringBell True = printText "\a"
ringBell False = return ()
printText :: MonadIO m => String -> DumbTerm m ()
printText str = do
h <- ask
posixEncode str >>= liftIO . B.hPutStr h
liftIO $ hFlush h
cr,crlf :: String
crlf = "\r\n"
cr = "\r"
backs,spaces :: Int -> String
backs n = replicate n '\b'
spaces n = replicate n ' '
clearLayoutD :: MonadLayout m => DumbTerm m ()
clearLayoutD = do
w <- maxWidth
printText (cr ++ spaces w ++ cr)
maxWidth :: MonadLayout m => DumbTerm m Int
maxWidth = asks (\lay -> width lay 1)
drawLineDiff' :: MonadLayout m => LineChars -> LineChars -> DumbTerm m ()
drawLineDiff' (xs1,ys1) (xs2,ys2) = do
Window {pos=p} <- get
w <- maxWidth
let (xs1',xs2') = matchInit xs1 xs2
let newP = p + length xs2' length xs1'
let ys2' = take (wnewP) ys2
if length xs1' > p || newP >= w
then refitLine (xs2,ys2)
else do
put Window {pos=newP}
case (xs1',xs2') of
([],[]) | ys1 == ys2 -> return ()
(_,[]) | xs1' ++ ys1 == ys2 ->
printText $ backs (length xs1')
([],_) | ys1 == xs2' ++ ys2 ->
printText xs2'
_ -> let
extraLength = length xs1' + length ys1
length xs2' length ys2
in printText $ backs (length xs1')
++ xs2' ++ ys2' ++ clearDeadText extraLength
++ backs (length ys2')
refitLine :: MonadLayout m => (String,String) -> DumbTerm m ()
refitLine (xs,ys) = do
w <- maxWidth
let xs' = dropFrames w xs
let p = length xs'
put Window {pos=p}
let ys' = take (w p) ys
let k = length ys'
printText $ cr ++ xs' ++ ys'
++ spaces (wkp)
++ backs (wp)
where
dropFrames w zs = case splitAt w zs of
(_,"") -> zs
(_,zs') -> dropFrames w zs'
clearDeadText :: Int -> String
clearDeadText n | n > 0 = spaces n ++ backs n
| otherwise = ""