module Yi.UI.Vty (start) where
import Prelude hiding (error,mapM,foldr1,concatMap,mapM_,reverse)
import Control.Applicative hiding ((<|>))
import Control.Arrow
import Control.Monad hiding (mapM,mapM_)
import Control.Concurrent
import Control.Exception
import Control.Monad.State (evalState, get, put)
import Control.Monad.Base
import Control.Lens hiding (wrapped,set)
import Data.Char (ord,chr)
import Data.IORef
import Data.List (partition, sort, nub)
import qualified Data.List.PointedList.Circular as PL
import Data.Foldable
import Data.Traversable
import Data.Maybe
import Data.Monoid
import System.Exit
import System.Posix.Signals (raiseSignal, sigTSTP)
import System.Posix.Terminal
import System.Posix.IO (stdInput)
import Yi.Buffer
import Yi.Editor
import Yi.Event
import Yi.Style
import qualified Yi.UI.Common as Common
import Yi.Config
import Yi.Window
import Graphics.Vty as Vty hiding (refresh, Default)
import qualified Graphics.Vty as Vty
import Yi.Keymap (makeAction, YiM)
import Yi.Debug
import Yi.Utils
import Yi.Monad
import Yi.UI.Utils
import Yi.UI.TabBar
data Rendered =
Rendered { picture :: !Image
, cursor :: !(Maybe (Int,Int))
}
data UI = UI { vty :: Vty
, scrsize :: IORef (Int,Int)
, uiThread :: ThreadId
, uiEndInputLoop :: MVar ()
, uiEndRenderLoop :: MVar ()
, uiEditor :: IORef Editor
, uiDirty :: MVar ()
, config :: Config
, oAttrs :: TerminalAttributes
}
mkUI :: UI -> Common.UI
mkUI ui = Common.dummyUI
{
Common.main = main ui,
Common.end = end ui,
Common.suspend = raiseSignal sigTSTP,
Common.refresh = requestRefresh ui,
Common.layout = layout ui,
Common.userForceRefresh = userForceRefresh ui
}
start :: UIBoot
start cfg ch outCh editor =
liftBase $ do
oattr <- getTerminalAttributes stdInput
v <- mkVtyEscDelay $ configVtyEscDelay $ configUI cfg
nattr <- getTerminalAttributes stdInput
setTerminalAttributes stdInput (withoutMode nattr ExtendedFunctions) Immediately
Vty.DisplayRegion x0 y0 <- Vty.display_bounds $ Vty.terminal v
sz <- newIORef (fromEnum y0, fromEnum x0)
tid <- myThreadId
endInput <- newEmptyMVar
endRender <- newEmptyMVar
editorRef <- newIORef editor
dirty <- newEmptyMVar
let ui = UI v sz tid endInput endRender editorRef dirty cfg oattr
inputLoop :: IO ()
inputLoop = tryTakeMVar endInput >>=
maybe (getKey >>= ch >> inputLoop)
(const $ return ())
getKey :: IO Yi.Event.Event
getKey = do
event <- Vty.next_event v
case event of
(EvResize x y) -> do
logPutStrLn $ "UI: EvResize: " ++ show (x,y)
writeIORef sz (y,x)
outCh [makeAction (layoutAction ui :: YiM ())]
getKey
_ -> return (fromVtyEvent event)
renderLoop :: IO ()
renderLoop = do
takeMVar dirty
tryTakeMVar endRender >>=
maybe (do logPutStrLn "time to render"
handle (\(except :: IOException) -> do
logPutStrLn "refresh crashed with IO Error"
logError $ show except)
(readIORef editorRef >>= refresh ui >> renderLoop))
(const $ return ())
void $ forkIO inputLoop
void $ forkIO renderLoop
return (mkUI ui)
main :: UI -> IO ()
main _ui = forever $ threadDelay 1000000
end :: UI -> Bool -> IO ()
end ui reallyQuit = do
Vty.shutdown (vty ui)
setTerminalAttributes stdInput (oAttrs ui) Immediately
void $ tryPutMVar (uiEndInputLoop ui) ()
void $ tryPutMVar (uiEndRenderLoop ui) ()
when reallyQuit $ throwTo (uiThread ui) ExitSuccess
return ()
fromVtyEvent :: Vty.Event -> Yi.Event.Event
fromVtyEvent (EvKey Vty.KBackTab mods) = Event Yi.Event.KTab (sort $ nub $ Yi.Event.MShift : map fromVtyMod mods)
fromVtyEvent (EvKey k mods) = Event (fromVtyKey k) (sort $ map fromVtyMod mods)
fromVtyEvent _ = error "fromVtyEvent: unsupported event encountered."
fromVtyKey :: Vty.Key -> Yi.Event.Key
fromVtyKey (Vty.KEsc ) = Yi.Event.KEsc
fromVtyKey (Vty.KFun x ) = Yi.Event.KFun x
fromVtyKey (Vty.KPrtScr ) = Yi.Event.KPrtScr
fromVtyKey (Vty.KPause ) = Yi.Event.KPause
fromVtyKey (Vty.KASCII '\t') = Yi.Event.KTab
fromVtyKey (Vty.KASCII c ) = Yi.Event.KASCII c
fromVtyKey (Vty.KBS ) = Yi.Event.KBS
fromVtyKey (Vty.KIns ) = Yi.Event.KIns
fromVtyKey (Vty.KHome ) = Yi.Event.KHome
fromVtyKey (Vty.KPageUp ) = Yi.Event.KPageUp
fromVtyKey (Vty.KDel ) = Yi.Event.KDel
fromVtyKey (Vty.KEnd ) = Yi.Event.KEnd
fromVtyKey (Vty.KPageDown) = Yi.Event.KPageDown
fromVtyKey (Vty.KNP5 ) = Yi.Event.KNP5
fromVtyKey (Vty.KUp ) = Yi.Event.KUp
fromVtyKey (Vty.KMenu ) = Yi.Event.KMenu
fromVtyKey (Vty.KLeft ) = Yi.Event.KLeft
fromVtyKey (Vty.KDown ) = Yi.Event.KDown
fromVtyKey (Vty.KRight ) = Yi.Event.KRight
fromVtyKey (Vty.KEnter ) = Yi.Event.KEnter
fromVtyKey (Vty.KBackTab ) = error "This should be handled in fromVtyEvent"
fromVtyKey (Vty.KBegin ) = error "Yi.UI.Vty.fromVtyKey: can't handle KBegin"
fromVtyMod :: Vty.Modifier -> Yi.Event.Modifier
fromVtyMod Vty.MShift = Yi.Event.MShift
fromVtyMod Vty.MCtrl = Yi.Event.MCtrl
fromVtyMod Vty.MMeta = Yi.Event.MMeta
fromVtyMod Vty.MAlt = Yi.Event.MMeta
layout :: UI -> Editor -> IO Editor
layout ui e = do
(rows,cols) <- readIORef (scrsize ui)
let ws = windows e
tabBarHeight = if hasTabBar e ui then 1 else 0
(cmd, _) = statusLineInfo e
niceCmd = arrangeItems cmd cols (maxStatusHeight e)
cmdHeight = length niceCmd
ws' = applyHeights (computeHeights (rows tabBarHeight cmdHeight + 1) ws) ws
discardOldRegion w = w { winRegion = emptyRegion }
let apply :: Window -> IO Window
apply win = do
let uiconfig = configUI $ config ui
newWinRegion <- return $! getRegionImpl win uiconfig e cols (height win)
newActualLines <- return $! windowLinesDisp win uiconfig e cols (height win)
return $! win { winRegion = newWinRegion, actualLines = newActualLines }
ws'' <- mapM (apply . discardOldRegion) ws'
return $ windowsA .~ ws'' $ e
layoutAction :: (MonadEditor m, MonadBase IO m) => UI -> m ()
layoutAction ui = do
withEditor . put =<< io . layout ui =<< withEditor get
withEditor $ mapM_ (`withWindowE` snapInsB) =<< use windowsA
requestRefresh :: UI -> Editor -> IO ()
requestRefresh ui e = do
writeIORef (uiEditor ui) e
void $ tryPutMVar (uiDirty ui) ()
refresh :: UI -> Editor -> IO ()
refresh ui e = do
(_,xss) <- readRef (scrsize ui)
let ws = windows e
tabBarHeight = if hasTabBar e ui then 1 else 0
windowStartY = tabBarHeight
(cmd, cmdSty) = statusLineInfo e
niceCmd = arrangeItems cmd xss (maxStatusHeight e)
formatCmdLine text = withAttributes statusBarStyle (take xss $ text ++ repeat ' ')
renders = fmap (renderWindow (configUI $ config ui) e xss) (PL.withFocus ws)
startXs = scanrT (+) windowStartY (fmap height ws)
wImages = fmap picture renders
statusBarStyle = ((appEndo <$> cmdSty) <*> baseAttributes) $ configStyle $ configUI $ config ui
tabBarImages = renderTabBar e ui xss
logPutStrLn "refreshing screen."
logPutStrLn $ "startXs: " ++ show startXs
Vty.update (vty ui)
( pic_for_image ( vert_cat tabBarImages
<->
vert_cat (toList wImages)
<->
vert_cat (fmap formatCmdLine niceCmd)
)
) { pic_cursor = case cursor (PL._focus renders) of
Just (y,x) -> Cursor (toEnum x) (toEnum $ y + PL._focus startXs)
Nothing -> NoCursor
}
return ()
renderTabBar :: Editor -> UI -> Int -> [Image]
renderTabBar e ui xss = [tabImages <|> extraImage | hasTabBar e ui]
where tabImages = foldr1 (<|>) $ fmap tabToVtyImage $ tabBarDescr e
extraImage = withAttributes (tabBarAttributes uiStyle) (replicate (xss fromEnum totalTabWidth) ' ')
totalTabWidth = Vty.image_width tabImages
uiStyle = configStyle $ configUI $ config ui
tabTitle text = " " ++ text ++ " "
tabAttr b = baseAttr b $ tabBarAttributes uiStyle
baseAttr True sty = attributesToAttr (appEndo (tabInFocusStyle uiStyle) sty) Vty.def_attr
baseAttr False sty = attributesToAttr (appEndo (tabNotFocusedStyle uiStyle) sty) Vty.def_attr `Vty.with_style` Vty.underline
tabToVtyImage _tab@(TabDescr text inFocus) = Vty.string (tabAttr inFocus) (tabTitle text)
hasTabBar :: Editor -> UI -> Bool
hasTabBar e ui = (not . configAutoHideTabBar . configUI . config $ ui) || PL.length (e ^. tabsA) > 1
scanrT :: (Int -> Int -> Int) -> Int -> PL.PointedList Int -> PL.PointedList Int
scanrT (+*+) k t = evalState (mapM f t) k
where f x = do s <- get
let s' = s +*+ x
put s'
return s
windowLinesDisp :: Window -> UIConfig -> Editor -> Int -> Int -> Int
windowLinesDisp win cfg e w h = dispCount
where (_,_,dispCount) = drawWindow cfg e (error "focus must not be used") win w h
getRegionImpl :: Window -> UIConfig -> Editor -> Int -> Int -> Region
getRegionImpl win cfg e w h = region
where (_,region,_) = drawWindow cfg e (error "focus must not be used") win w h
renderWindow :: UIConfig -> Editor -> Int -> (Window, Bool) -> Rendered
renderWindow cfg e width (win,hasFocus) =
let (rendered,_,_) = drawWindow cfg e hasFocus win width (height win)
in rendered
drawWindow :: UIConfig -> Editor -> Bool -> Window -> Int -> Int -> (Rendered, Region, Int)
drawWindow cfg e focused win w h = (Rendered { picture = pict,cursor = cur}, mkRegion fromMarkPoint toMarkPoint', dispLnCount)
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.def_attr
eofsty = appEndo (eofStyle sty) ground
(point, _) = runBuffer win b pointB
(eofPoint, _) = runBuffer win b sizeB
region = mkSizeRegion fromMarkPoint (Size (w*h'))
(Just (MarkSet fromM _ _), _) = runBuffer win b (getMarks win)
fromMarkPoint = if notMini
then fst $ runBuffer win b (getMarkPointB fromM)
else Point 0
(text, _) = runBuffer win b (indexedAnnotatedStreamB fromMarkPoint)
(attributes, _) = runBuffer win b $ attributesPictureAndSelB sty (currentRegex e) region
colors = map (second (($ Vty.def_attr) . attributesToAttr)) attributes
bufData =
paintChars Vty.def_attr colors text
tabWidth = tabSize . fst $ runBuffer win b indentSettingsB
prompt = if isMini win then miniIdentString b else ""
(rendered,toMarkPoint',cur,dispLnCount) = drawText h' w
fromMarkPoint
point
tabWidth
([(c,(wsty, 1)) | c <- prompt] ++ bufData ++ [(' ',(wsty, eofPoint))])
(modeLine0, _) = runBuffer win b $ getModeLine (commonNamePrefix e)
modeLine = if notMini then Just modeLine0 else Nothing
modeLines = map (withAttributes modeStyle . take w . (++ repeat ' ')) $ maybeToList modeLine
modeStyle = (if focused then appEndo (modelineFocusStyle sty) else id) (modelineAttributes sty)
filler = take w (configWindowFill cfg : repeat ' ')
pict = vert_cat (take h' (rendered ++ repeat (withAttributes eofsty filler)) ++ modeLines)
drawText :: Int
-> Int
-> Point
-> Point
-> Int
-> [(Char,(Vty.Attr,Point))]
-> ([Image], Point, Maybe (Int,Int), Int)
drawText h w topPoint point tabWidth bufData
| h == 0 || w == 0 = ([], topPoint, Nothing, 0)
| otherwise = (rendered_lines, bottomPoint, pntpos, h (length wrapped h))
where
wrapped = concatMap (wrapLine w) $ map (concatMap expandGraphic) $ take h $ lines' bufData
lns0 = take h wrapped
bottomPoint = case lns0 of
[] -> topPoint
_ -> snd $ snd $ last $ last lns0
pntpos = listToMaybe [(y,x) | (y,l) <- zip [0..] lns0, (x,(_char,(_attr,p))) <- zip [0..] l, p == point]
rendered_lines = map fillColorLine lns0
colorChar (c, (a, _aPoint)) = Vty.char a c
fillColorLine :: [(Char, (Vty.Attr, Point))] -> Image
fillColorLine [] = char_fill Vty.def_attr ' ' w 1
fillColorLine l = horiz_cat (map colorChar l)
<|>
char_fill a ' ' (w length l) 1
where (_,(a,_x)) = last l
lines' :: [(Char,a)] -> [[(Char,a)]]
lines' [] = []
lines' s = case s' of
[] -> [l]
((_,x):s'') -> (l++[(' ',x)]) : 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)
| ord c < 32 = [('^',p),(chr (ord c + 64),p)]
| otherwise = [(c,p)]
withAttributes :: Attributes -> String -> Image
withAttributes sty = Vty.string (attributesToAttr sty Vty.def_attr)
userForceRefresh :: UI -> IO ()
userForceRefresh = Vty.refresh . vty
computeHeights :: Int -> PL.PointedList Window -> [Int]
computeHeights totalHeight ws = y+r1 : repeat y
where (mwls, wls) = partition isMini (toList ws)
(y,r) = getY (totalHeight length mwls) (length wls)
getY :: Int -> Int -> (Int,Int)
getY screenHeight 0 = (screenHeight, 0)
getY screenHeight numberOfWindows = screenHeight `quotRem` numberOfWindows
colorToAttr :: (Vty.Color -> Vty.Attr -> Vty.Attr) -> Yi.Style.Color -> Vty.Attr -> Vty.Attr
colorToAttr set c =
case c of
RGB 0 0 0 -> set Vty.black
RGB 128 128 128 -> set Vty.bright_black
RGB 139 0 0 -> set Vty.red
RGB 255 0 0 -> set Vty.bright_red
RGB 0 100 0 -> set Vty.green
RGB 0 128 0 -> set Vty.bright_green
RGB 165 42 42 -> set Vty.yellow
RGB 255 255 0 -> set Vty.bright_yellow
RGB 0 0 139 -> set Vty.blue
RGB 0 0 255 -> set Vty.bright_blue
RGB 128 0 128 -> set Vty.magenta
RGB 255 0 255 -> set Vty.bright_magenta
RGB 0 139 139 -> set Vty.cyan
RGB 0 255 255 -> set Vty.bright_cyan
RGB 165 165 165 -> set Vty.white
RGB 255 255 255 -> set Vty.bright_white
Default -> id
RGB r g b -> set (Vty.rgb_color r g b)
attributesToAttr :: Attributes -> Vty.Attr -> Vty.Attr
attributesToAttr (Attributes fg bg reverse bd _itlc underline') =
(if reverse then (`Vty.with_style` Vty.reverse_video) else id) .
(if bd then (`Vty.with_style` Vty.bold) else id) .
(if underline' then (`Vty.with_style` Vty.underline) else id) .
colorToAttr (flip Vty.with_fore_color) fg .
colorToAttr (flip Vty.with_back_color) bg
paintChars :: a -> [(Point,a)] -> [(Point,Char)] -> [(Char, (a,Point))]
paintChars sty changes cs = [(c,(s,p)) | ((p,c),s) <- zip 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