module Yi.UI.Vty
( start
) where
import Prelude hiding (error, concatMap, reverse)
import Control.Applicative hiding ((<|>))
import Control.Concurrent
import Control.Exception
import Control.Lens
import Control.Monad
import Data.Char
import qualified Data.DList as D
import Data.Foldable (toList, concatMap)
import Data.IORef
import qualified Data.List.PointedList.Circular as PL
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import GHC.Conc (labelThread)
import Yi.Buffer
import Yi.Config
import Yi.Debug
import Yi.Editor
import Yi.Event
import Yi.Style
import qualified Yi.UI.Common as Common
import qualified Yi.UI.SimpleLayout as SL
import Yi.UI.Vty.Conversions
import Yi.UI.TabBar
import Yi.UI.Utils
import Yi.Window
data Rendered = Rendered
{ picture :: !Vty.Image
, cursor :: !(Maybe (Int,Int))
}
data FrontendState = FrontendState
{ fsVty :: Vty.Vty
, fsConfig :: Config
, fsEndMain :: MVar ()
, fsEndInputLoop :: MVar ()
, fsEndRenderLoop :: MVar ()
, fsDirty :: MVar ()
, fsEditorRef :: IORef Editor
}
start :: UIBoot
start config submitEvents submitActions editor = do
vty <- (Vty.mkVty . configVty . configUI) config
let inputChan = Vty._eventChannel (Vty.inputIface vty)
endInput <- newEmptyMVar
endMain <- newEmptyMVar
endRender <- newEmptyMVar
dirty <- newEmptyMVar
editorRef <- newIORef editor
let
inputLoop :: IO ()
inputLoop = tryTakeMVar endInput >>=
maybe (do
let go evs = do
e <- getEvent
done <- isEmptyChan inputChan
if done
then submitEvents (D.toList (evs `D.snoc` e))
else go (evs `D.snoc` e)
go D.empty
inputLoop)
(const $ return ())
getEvent :: IO Yi.Event.Event
getEvent = do
event <- readChan inputChan
case event of
(Vty.EvResize _ _) -> do
submitActions []
getEvent
_ -> return (fromVtyEvent event)
renderLoop :: IO ()
renderLoop = do
takeMVar dirty
tryTakeMVar endRender >>=
maybe (handle (\(except :: IOException) -> do
logPutStrLn "refresh crashed with IO Error"
logError (T.pack (show except)))
(readIORef editorRef >>= refresh fs >> renderLoop))
(const $ return ())
fs = FrontendState vty config endMain endInput endRender dirty editorRef
inputThreadId <- forkIO inputLoop
labelThread inputThreadId "VtyInput"
renderThreadId <- forkIO renderLoop
labelThread renderThreadId "VtyRender"
return $! Common.dummyUI
{ Common.main = main fs
, Common.end = end fs
, Common.refresh = requestRefresh fs
, Common.userForceRefresh = Vty.refresh vty
, Common.layout = layout fs
}
main :: FrontendState -> IO ()
main fs = do
tid <- myThreadId
labelThread tid "VtyMain"
takeMVar (fsEndMain fs)
layout :: FrontendState -> Editor -> IO Editor
layout fs e = do
(colCount, rowCount) <- Vty.displayBounds (Vty.outputIface (fsVty fs))
let (e', _layout) = SL.layout colCount rowCount e
return e'
end :: FrontendState -> Bool -> IO ()
end fs mustQuit = do
void $ tryPutMVar (fsEndInputLoop fs) ()
void $ tryPutMVar (fsEndRenderLoop fs) ()
Vty.shutdown (fsVty fs)
when mustQuit $
void (tryPutMVar (fsEndMain fs) ())
requestRefresh :: FrontendState -> Editor -> IO ()
requestRefresh fs e = do
writeIORef (fsEditorRef fs) e
void $ tryPutMVar (fsDirty fs) ()
refresh :: FrontendState -> Editor -> IO ()
refresh fs e = do
(colCount, rowCount) <- Vty.displayBounds (Vty.outputIface (fsVty fs))
let (_e, SL.Layout _tabbarRect winRects promptRect) = SL.layout colCount rowCount e
ws = windows e
(cmd, cmdSty) = statusLineInfo e
niceCmd = arrangeItems cmd (SL.sizeX promptRect) (maxStatusHeight e)
mkLine = T.justifyLeft colCount ' ' . T.take colCount
formatCmdLine text = withAttributes statusBarStyle (mkLine text)
winImage (win, hasFocus) =
let rect = winRects M.! wkey win
in renderWindow (configUI $ fsConfig fs) e rect (win, hasFocus)
windowsAndImages =
fmap (\(w, f) -> (w, winImage (w, f))) (PL.withFocus ws)
bigImages =
map (picture . snd)
(filter (not . isMini . fst) (toList windowsAndImages))
miniImages =
map (picture . snd)
(filter (isMini . fst) (toList windowsAndImages))
statusBarStyle =
((appEndo <$> cmdSty) <*> baseAttributes)
(configStyle (configUI (fsConfig fs)))
tabBarImage =
renderTabBar (configStyle (configUI (fsConfig fs)))
(map (\(TabDescr t f) -> (t, f)) (toList (tabBarDescr e)))
cmdImage = if null cmd
then Vty.emptyImage
else Vty.translate
(SL.offsetX promptRect)
(SL.offsetY promptRect)
(Vty.vertCat (fmap formatCmdLine niceCmd))
cursorPos =
let (w, image) = PL._focus windowsAndImages
in case (isMini w, cursor image) of
(False, Just (y, x)) ->
Vty.Cursor (toEnum x) (toEnum y)
(True, Just (_, x)) -> Vty.Cursor (toEnum x) (toEnum (rowCount 1))
(_, Nothing) -> Vty.NoCursor
logPutStrLn "refreshing screen."
Vty.update (fsVty fs)
(Vty.picForLayers ([tabBarImage, cmdImage] ++ bigImages ++ miniImages))
{ Vty.picCursor = cursorPos }
renderWindow :: UIConfig -> Editor -> SL.Rect -> (Window, Bool) -> Rendered
renderWindow cfg e (SL.Rect x y w h) (win, focused) =
Rendered (Vty.translate x y pict)
(fmap (\(i, j) -> (i + y, j + x)) cur)
where
b = findBufferWith (bufkey win) e
sty = configStyle cfg
notMini = not (isMini win)
off = if notMini then 1 else 0
h' = h off
ground = baseAttributes sty
wsty = attributesToAttr ground Vty.defAttr
eofsty = appEndo (eofStyle sty) ground
(point, _) = runBuffer win b pointB
region = mkSizeRegion fromMarkPoint (Size (w*h'))
(Just (MarkSet fromM _ _), _) = runBuffer win b (getMarks win)
fromMarkPoint = if notMini
then fst $ runBuffer win b $ use $ markPointA fromM
else Point 0
(text, _) = runBuffer win b (indexedStreamB Forward fromMarkPoint)
(attributes, _) = runBuffer win b $ attributesPictureAndSelB sty (currentRegex e) region
colors = map (fmap (($ Vty.defAttr) . attributesToAttr)) attributes
bufData = paintChars Vty.defAttr colors text
tabWidth = tabSize . fst $ runBuffer win b indentSettingsB
prompt = if isMini win then miniIdentString b else ""
cur = (fmap (\(SL.Point2D curx cury) -> (cury, T.length prompt + curx)) . fst)
(runBuffer win b
(SL.coordsOfCharacterB
(SL.Size2D w h)
fromMarkPoint
point))
rendered =
drawText wsty h' w
tabWidth
([(c, wsty) | c <- T.unpack prompt] ++ bufData ++ [(' ', wsty)])
commonPref = T.pack <$> commonNamePrefix e
(modeLine0, _) = runBuffer win b $ getModeLine commonPref
modeLine = if notMini then Just modeLine0 else Nothing
prepare = withAttributes modeStyle . T.justifyLeft w ' ' . T.take w
modeLines = map prepare $ maybeToList modeLine
modeStyle = (if focused then appEndo (modelineFocusStyle sty) else id) (modelineAttributes sty)
filler :: T.Text
filler = if w == 0
then T.empty
else T.justifyLeft w ' ' $ T.singleton (configWindowFill cfg)
pict = Vty.vertCat (take h' (rendered <> repeat (withAttributes eofsty filler)) <> modeLines)
withAttributes :: Attributes -> T.Text -> Vty.Image
withAttributes sty = Vty.text' (attributesToAttr sty Vty.defAttr)
attributesToAttr :: Attributes -> Vty.Attr -> Vty.Attr
attributesToAttr (Attributes fg bg reverse bd _itlc underline') =
(if reverse then (`Vty.withStyle` Vty.reverseVideo) else id) .
(if bd then (`Vty.withStyle` Vty.bold) else id) .
(if underline' then (`Vty.withStyle` Vty.underline) else id) .
colorToAttr (flip Vty.withForeColor) fg .
colorToAttr (flip Vty.withBackColor) bg
paintChars :: a -> [(Point, a)] -> [(Point, Char)] -> [(Char, a)]
paintChars sty changes cs = zip (fmap snd cs) attrs
where attrs = stys sty changes cs
stys :: a -> [(Point, a)] -> [(Point, Char)] -> [a]
stys sty [] cs = [ sty | _ <- cs ]
stys sty ((endPos, sty') : xs) cs = [ sty | _ <- previous ] <> stys sty' xs later
where (previous, later) = break ((endPos <=) . fst) cs
drawText :: Vty.Attr
-> Int
-> Int
-> Int
-> [(Char, Vty.Attr)]
-> [Vty.Image]
drawText wsty h w tabWidth bufData
| h == 0 || w == 0 = []
| otherwise = renderedLines
where
wrapped = concatMap (wrapLine w . addSpace . concatMap expandGraphic) $ take h $ lines' bufData
lns0 = take h wrapped
renderedLines = map fillColorLine lns0
colorChar (c, a) = Vty.char a c
fillColorLine :: [(Char, Vty.Attr)] -> Vty.Image
fillColorLine [] = Vty.charFill Vty.defAttr ' ' w 1
fillColorLine l = Vty.horizCat (map colorChar l)
Vty.<|>
Vty.charFill a ' ' (w length l) 1
where (_, a) = last l
addSpace :: [(Char, Vty.Attr)] -> [(Char, Vty.Attr)]
addSpace [] = [(' ', wsty)]
addSpace l = case mod lineLength w of
0 -> l
_ -> l ++ [(' ', wsty)]
where
lineLength = length l
lines' :: [(Char, a)] -> [[(Char, a)]]
lines' [] = []
lines' s = case s' of
[] -> [l]
((_,x):s'') -> l : lines' s''
where
(l, s') = break ((== '\n') . fst) s
wrapLine :: Int -> [x] -> [[x]]
wrapLine _ [] = []
wrapLine n l = let (x,rest) = splitAt n l in x : wrapLine n rest
expandGraphic ('\t', p) = replicate tabWidth (' ', p)
expandGraphic (c, p)
| numeric < 32 = [('^', p), (chr (numeric + 64), p)]
| otherwise = [(c, p)]
where numeric = ord c
renderTabBar :: UIStyle -> [(T.Text, Bool)] -> Vty.Image
renderTabBar uiStyle = Vty.horizCat . fmap render
where
render (text, inFocus) = Vty.text' (tabAttr inFocus) (tabTitle text)
tabTitle text = ' ' `T.cons` text `T.snoc` ' '
tabAttr b = baseAttr b $ tabBarAttributes uiStyle
baseAttr True sty =
attributesToAttr (appEndo (tabInFocusStyle uiStyle) sty) Vty.defAttr
baseAttr False sty =
attributesToAttr (appEndo (tabNotFocusedStyle uiStyle) sty) Vty.defAttr
`Vty.withStyle` Vty.underline