module System.Console.Haskeline.Backend.DumbTerm where
import System.Console.Haskeline.Backend.Posix
import System.Console.Haskeline.Backend.WCWidth
import System.Console.Haskeline.Term
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Monads as Monads
import System.IO
import Control.Applicative(Applicative)
import Control.Monad(liftM)
data Window = Window {pos :: Int
}
initWindow :: Window
initWindow = Window {pos=0}
newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a}
deriving (Functor, Applicative, Monad, MonadIO, MonadException,
MonadState Window, MonadReader Handles)
type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a
instance MonadTrans DumbTerm where
lift = DumbTerm . lift . lift
evalDumb :: (MonadReader Layout m, CommandMonad m) => EvalTerm (PosixT m)
evalDumb = EvalTerm (evalStateT' initWindow . unDumbTerm) (DumbTerm . lift)
runDumbTerm :: Handles -> MaybeT IO RunTerm
runDumbTerm h = liftIO $ posixRunTerm h (posixLayouts h) [] id evalDumb
instance (MonadException m, MonadReader Layout m) => Term (DumbTerm m) where
reposition _ s = refitLine s
drawLineDiff = drawLineDiff'
printLines = mapM_ (printText . (++ crlf))
moveToNextLine _ = printText crlf
clearLayout = clearLayoutD
ringBell True = printText "\a"
ringBell False = return ()
printText :: MonadIO m => String -> DumbTerm m ()
printText str = do
h <- liftM ehOut ask
liftIO $ hPutStr h str
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 :: DumbTermM ()
clearLayoutD = do
w <- maxWidth
printText (cr ++ spaces w ++ cr)
maxWidth :: DumbTermM Int
maxWidth = asks (\lay -> width lay - 1)
drawLineDiff' :: LineChars -> LineChars -> DumbTermM ()
drawLineDiff' (xs1,ys1) (xs2,ys2) = do
Window {pos=p} <- get
w <- maxWidth
let (xs1',xs2') = matchInit xs1 xs2
let (xw1, xw2) = (gsWidth xs1', gsWidth xs2')
let newP = p + xw2 - xw1
let (ys2', yw2) = takeWidth (w-newP) ys2
if xw1 > 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 xw1
([],_) | ys1 == xs2' ++ ys2 ->
printText (graphemesToString xs2')
_ -> let extraLength = xw1 + snd (takeWidth (w-p) ys1)
- xw2 - yw2
in printText $ backs xw1
++ graphemesToString (xs2' ++ ys2') ++ clearDeadText extraLength
++ backs yw2
refitLine :: ([Grapheme],[Grapheme]) -> DumbTermM ()
refitLine (xs,ys) = do
w <- maxWidth
let (xs',p) = dropFrames w xs
put Window {pos=p}
let (ys',k) = takeWidth (w - p) ys
printText $ cr ++ graphemesToString (xs' ++ ys')
++ spaces (w-k-p)
++ backs (w-p)
where
dropFrames w zs = case splitAtWidth w zs of
(_,[],l) -> (zs,l)
(_,zs',_) -> dropFrames w zs'
clearDeadText :: Int -> String
clearDeadText n | n > 0 = spaces n ++ backs n
| otherwise = ""