{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :  Yi.Frontend.Vty
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- This module defines a user interface implemented using vty.
--
-- Originally derived from: riot/UI.hs Copyright (c) Tuomo Valkonen 2004.

module Yi.Frontend.Vty
    ( start

    , baseVtyConfig
    ) where

import           Prelude                        hiding (concatMap, error,
                                                 reverse)

import           Control.Concurrent             (MVar, forkIO, myThreadId, newEmptyMVar,
                                                 takeMVar, tryPutMVar, tryTakeMVar)
import           Control.Concurrent.STM         (atomically, isEmptyTChan, readTChan)
import           Control.Exception              (IOException, handle)
import           Lens.Micro.Platform            (makeLenses, view, use, Lens')
import           Control.Monad                  (void, when)
import           Data.Char                      (chr, ord)
import           Data.Default                   (Default)
import qualified Data.DList                     as D (empty, snoc, toList)
import           Data.Foldable                  (concatMap, toList)
import           Data.IORef                     (IORef, newIORef, readIORef, writeIORef)
import qualified Data.List.PointedList.Circular as PL (PointedList (_focus), withFocus)
import qualified Data.Map.Strict                as M ((!))
import           Data.Maybe                     (fromMaybe, maybeToList)
import           Data.Monoid                    (Endo (appEndo), (<>))
import qualified Data.Text                      as T (Text, cons, empty,
                                                      justifyLeft, length, pack,
                                                      singleton, snoc, take,
                                                      unpack)
import           Data.Typeable                  (Typeable)
import           GHC.Conc                       (labelThread)
import qualified Graphics.Vty                   as Vty (Attr, Cursor (Cursor, NoCursor),
                                                        Config,
                                                        Event (EvResize), Image,
                                                        Input (_eventChannel),
                                                        Output (displayBounds),
                                                        Picture (picCursor), Vty (inputIface, outputIface, refresh, shutdown, update),
                                                        bold, char, charFill,
                                                        defAttr, emptyImage,
                                                        horizCat, mkVty,
                                                        picForLayers,
                                                        standardIOConfig,
                                                        string,
                                                        reverseVideo, text',
                                                        translate, underline,
                                                        vertCat, withBackColor,
                                                        withForeColor,
                                                        withStyle, (<|>))
import           System.Exit                    (ExitCode, exitWith)
import           Yi.Buffer
import           Yi.Config
import           Yi.Debug                       (logError, logPutStrLn)
import           Yi.Editor
import           Yi.Event                       (Event)
import qualified Yi.Rope as R
import           Yi.Style
import           Yi.Types                       (YiConfigVariable)
import qualified Yi.UI.Common                   as Common
import qualified Yi.UI.SimpleLayout             as SL
import           Yi.Layout                      (HasNeighborWest)
import           Yi.UI.LineNumbers              (getDisplayLineNumbersLocal)
import           Yi.UI.TabBar                   (TabDescr (TabDescr), tabBarDescr)
import           Yi.UI.Utils                    (arrangeItems, attributesPictureAndSelB)
import           Yi.Frontend.Vty.Conversions          (colorToAttr, fromVtyEvent)
import           Yi.Window                      (Window (bufkey, isMini, wkey, width, height))


data Rendered = Rendered
    { Rendered -> Image
picture :: !Vty.Image
    , Rendered -> Maybe (Int, Int)
cursor  :: !(Maybe (Int,Int))
    }

data FrontendState = FrontendState
    { FrontendState -> Vty
fsVty :: Vty.Vty
    , FrontendState -> Config
fsConfig :: Config
    , FrontendState -> MVar ExitCode
fsEndMain :: MVar ExitCode
    , FrontendState -> MVar ()
fsEndInputLoop :: MVar ()
    , FrontendState -> MVar ()
fsEndRenderLoop :: MVar ()
    , FrontendState -> MVar ()
fsDirty :: MVar ()
    , FrontendState -> IORef Editor
fsEditorRef :: IORef Editor
    }

-- | Base vty configuration, named so to distinguish it from any vty
-- frontend configuration.
--
-- If this is set to its default (None) it will be replaced by the default
-- vty configuration from standardIOConfig. However, standardIOConfig
-- runs in the IO monad so we cannot set the real default here.
newtype BaseVtyConfig = BaseVtyConfig { BaseVtyConfig -> Maybe Config
_baseVtyConfig' :: Maybe Vty.Config }
    deriving (Typeable, BaseVtyConfig
BaseVtyConfig -> Default BaseVtyConfig
forall a. a -> Default a
def :: BaseVtyConfig
$cdef :: BaseVtyConfig
Default)

instance YiConfigVariable BaseVtyConfig

makeLenses ''BaseVtyConfig

baseVtyConfig :: Lens' Config (Maybe Vty.Config)
baseVtyConfig :: (Maybe Config -> f (Maybe Config)) -> Config -> f Config
baseVtyConfig = (BaseVtyConfig -> f BaseVtyConfig) -> Config -> f Config
forall a. YiConfigVariable a => Lens Config Config a a
configVariable ((BaseVtyConfig -> f BaseVtyConfig) -> Config -> f Config)
-> ((Maybe Config -> f (Maybe Config))
    -> BaseVtyConfig -> f BaseVtyConfig)
-> (Maybe Config -> f (Maybe Config))
-> Config
-> f Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Config -> f (Maybe Config))
-> BaseVtyConfig -> f BaseVtyConfig
Lens' BaseVtyConfig (Maybe Config)
baseVtyConfig'

start :: UIBoot
start :: UIBoot
start Config
config [Event] -> IO ()
submitEvents [Action] -> IO ()
submitActions Editor
editor = do
    let baseConfig :: Maybe Config
baseConfig = Getting (Maybe Config) Config (Maybe Config)
-> Config -> Maybe Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Config) Config (Maybe Config)
Lens' Config (Maybe Config)
baseVtyConfig Config
config
    Vty
vty <- Config -> IO Vty
Vty.mkVty (Config -> IO Vty) -> IO Config -> IO Vty
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Maybe Config
baseConfig of
        Maybe Config
Nothing -> IO Config
Vty.standardIOConfig
        Just Config
conf -> Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config
conf
    let inputChan :: TChan Event
inputChan = Input -> TChan Event
Vty._eventChannel (Vty -> Input
Vty.inputIface Vty
vty)
    MVar ()
endInput <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    MVar ExitCode
endMain <- IO (MVar ExitCode)
forall a. IO (MVar a)
newEmptyMVar
    MVar ()
endRender <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    MVar ()
dirty <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    IORef Editor
editorRef <- Editor -> IO (IORef Editor)
forall a. a -> IO (IORef a)
newIORef Editor
editor
    let -- | Action to read characters into a channel
        inputLoop :: IO ()
        inputLoop :: IO ()
inputLoop = MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
endInput IO (Maybe ()) -> (Maybe () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    IO () -> (() -> IO ()) -> Maybe () -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (do
                            let go :: DList Event -> IO ()
go DList Event
evs = do
                                    Event
e <- IO Event
getEvent
                                    Bool
done <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (TChan Event -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan Event
inputChan)
                                    if Bool
done
                                    then [Event] -> IO ()
submitEvents (DList Event -> [Event]
forall a. DList a -> [a]
D.toList (DList Event
evs DList Event -> Event -> DList Event
forall a. DList a -> a -> DList a
`D.snoc` Event
e))
                                    else DList Event -> IO ()
go (DList Event
evs DList Event -> Event -> DList Event
forall a. DList a -> a -> DList a
`D.snoc` Event
e)
                            DList Event -> IO ()
go DList Event
forall a. DList a
D.empty
                            IO ()
inputLoop)
                          (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

        -- | Read a key. UIs need to define a method for getting events.
        getEvent :: IO Yi.Event.Event
        getEvent :: IO Event
getEvent = do
          Event
event <- STM Event -> IO Event
forall a. STM a -> IO a
atomically (TChan Event -> STM Event
forall a. TChan a -> STM a
readTChan TChan Event
inputChan)
          case Event
event of
            (Vty.EvResize Int
_ Int
_) -> do
                [Action] -> IO ()
submitActions []
                IO Event
getEvent
            Event
_ -> Event -> IO Event
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> Event
fromVtyEvent Event
event)

        renderLoop :: IO ()
        renderLoop :: IO ()
renderLoop = do
          MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
dirty
          MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
endRender IO (Maybe ()) -> (Maybe () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            IO () -> (() -> IO ()) -> Maybe () -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(IOException
except :: IOException) -> do
                              Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn Text
"refresh crashed with IO Error"
                              Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logError (String -> Text
T.pack (IOException -> String
forall a. Show a => a -> String
show IOException
except)))
                          (IORef Editor -> IO Editor
forall a. IORef a -> IO a
readIORef IORef Editor
editorRef IO Editor -> (Editor -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FrontendState -> Editor -> IO ()
refresh FrontendState
fs IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
renderLoop))
                  (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

        fs :: FrontendState
fs = Vty
-> Config
-> MVar ExitCode
-> MVar ()
-> MVar ()
-> MVar ()
-> IORef Editor
-> FrontendState
FrontendState Vty
vty Config
config MVar ExitCode
endMain MVar ()
endInput MVar ()
endRender MVar ()
dirty IORef Editor
editorRef

    ThreadId
inputThreadId <- IO () -> IO ThreadId
forkIO IO ()
inputLoop
    ThreadId -> String -> IO ()
labelThread ThreadId
inputThreadId String
"VtyInput"
    ThreadId
renderThreadId <- IO () -> IO ThreadId
forkIO IO ()
renderLoop
    ThreadId -> String -> IO ()
labelThread ThreadId
renderThreadId String
"VtyRender"

    UI Editor -> IO (UI Editor)
forall (m :: * -> *) a. Monad m => a -> m a
return (UI Editor -> IO (UI Editor)) -> UI Editor -> IO (UI Editor)
forall a b. (a -> b) -> a -> b
$! UI Any
forall e. UI e
Common.dummyUI
        { main :: IO ()
Common.main = FrontendState -> IO ()
main FrontendState
fs
        , end :: Maybe ExitCode -> IO ()
Common.end = FrontendState -> Maybe ExitCode -> IO ()
end FrontendState
fs
        , refresh :: Editor -> IO ()
Common.refresh = FrontendState -> Editor -> IO ()
requestRefresh FrontendState
fs
        , userForceRefresh :: IO ()
Common.userForceRefresh = Vty -> IO ()
Vty.refresh Vty
vty
        , layout :: Editor -> IO Editor
Common.layout = FrontendState -> Editor -> IO Editor
layout FrontendState
fs
        }

main :: FrontendState -> IO ()
main :: FrontendState -> IO ()
main FrontendState
fs = do
    ThreadId
tid <- IO ThreadId
myThreadId
    ThreadId -> String -> IO ()
labelThread ThreadId
tid String
"VtyMain"
    ExitCode
exitCode <- MVar ExitCode -> IO ExitCode
forall a. MVar a -> IO a
takeMVar (FrontendState -> MVar ExitCode
fsEndMain FrontendState
fs)
    ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
exitCode

layout :: FrontendState -> Editor -> IO Editor
layout :: FrontendState -> Editor -> IO Editor
layout FrontendState
fs Editor
e = do
    (Int
colCount, Int
rowCount) <- Output -> IO (Int, Int)
Vty.displayBounds (Vty -> Output
Vty.outputIface (FrontendState -> Vty
fsVty FrontendState
fs))
    let (Editor
e', Layout
_layout) = Int -> Int -> Editor -> (Editor, Layout)
SL.layout Int
colCount Int
rowCount Editor
e
    Editor -> IO Editor
forall (m :: * -> *) a. Monad m => a -> m a
return Editor
e'

end :: FrontendState -> Maybe ExitCode -> IO ()
end :: FrontendState -> Maybe ExitCode -> IO ()
end FrontendState
fs Maybe ExitCode
mExit = do
    -- setTerminalAttributes stdInput (oAttrs ui) Immediately
    IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar (FrontendState -> MVar ()
fsEndInputLoop FrontendState
fs) ()
    IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar (FrontendState -> MVar ()
fsEndRenderLoop FrontendState
fs) ()
    Vty -> IO ()
Vty.shutdown (FrontendState -> Vty
fsVty FrontendState
fs)
    case Maybe ExitCode
mExit of
      Maybe ExitCode
Nothing   -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ExitCode
code -> IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar ExitCode -> ExitCode -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar (FrontendState -> MVar ExitCode
fsEndMain FrontendState
fs) ExitCode
code)

requestRefresh :: FrontendState -> Editor -> IO ()
requestRefresh :: FrontendState -> Editor -> IO ()
requestRefresh FrontendState
fs Editor
e = do
    IORef Editor -> Editor -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (FrontendState -> IORef Editor
fsEditorRef FrontendState
fs) Editor
e
    IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar (FrontendState -> MVar ()
fsDirty FrontendState
fs) ()

refresh :: FrontendState -> Editor -> IO ()
refresh :: FrontendState -> Editor -> IO ()
refresh FrontendState
fs Editor
e = do
    (Int
colCount, Int
rowCount) <- Output -> IO (Int, Int)
Vty.displayBounds (Vty -> Output
Vty.outputIface (FrontendState -> Vty
fsVty FrontendState
fs))
    let (Editor
_e, SL.Layout Rect
tabbarRect Map WindowRef (Rect, Bool)
winRects Rect
promptRect) = Int -> Int -> Editor -> (Editor, Layout)
SL.layout Int
colCount Int
rowCount Editor
e
        ws :: PointedList Window
ws = Editor -> PointedList Window
windows Editor
e
        ([Text]
cmd, StyleName
cmdSty) = Editor -> ([Text], StyleName)
statusLineInfo Editor
e
        niceCmd :: [Text]
niceCmd = [Text] -> Int -> Int -> [Text]
arrangeItems [Text]
cmd (Rect -> Int
SL.sizeX Rect
promptRect) (Editor -> Int
maxStatusHeight Editor
e)
        mkLine :: Text -> Text
mkLine = Int -> Char -> Text -> Text
T.justifyLeft Int
colCount Char
' ' (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.take Int
colCount
        formatCmdLine :: Text -> Image
formatCmdLine Text
text = Attributes -> Text -> Image
withAttributes Attributes
statusBarStyle (Text -> Text
mkLine Text
text)
        winImage :: (Window, Bool) -> Rendered
winImage (Window
win, Bool
hasFocus) =
            let (Rect
rect, Bool
nb) = Map WindowRef (Rect, Bool)
winRects Map WindowRef (Rect, Bool) -> WindowRef -> (Rect, Bool)
forall k a. Ord k => Map k a -> k -> a
M.! Window -> WindowRef
wkey Window
win
            in Config -> Editor -> Rect -> Bool -> (Window, Bool) -> Rendered
renderWindow (FrontendState -> Config
fsConfig FrontendState
fs) Editor
e Rect
rect Bool
nb (Window
win, Bool
hasFocus)
        windowsAndImages :: PointedList (Window, Rendered)
windowsAndImages =
            ((Window, Bool) -> (Window, Rendered))
-> PointedList (Window, Bool) -> PointedList (Window, Rendered)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Window
w, Bool
f) -> (Window
w, (Window, Bool) -> Rendered
winImage (Window
w, Bool
f))) (PointedList Window -> PointedList (Window, Bool)
forall a. PointedList a -> PointedList (a, Bool)
PL.withFocus PointedList Window
ws)
        bigImages :: [Image]
bigImages =
            ((Window, Rendered) -> Image) -> [(Window, Rendered)] -> [Image]
forall a b. (a -> b) -> [a] -> [b]
map (Rendered -> Image
picture (Rendered -> Image)
-> ((Window, Rendered) -> Rendered) -> (Window, Rendered) -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window, Rendered) -> Rendered
forall a b. (a, b) -> b
snd)
                (((Window, Rendered) -> Bool)
-> [(Window, Rendered)] -> [(Window, Rendered)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Window, Rendered) -> Bool) -> (Window, Rendered) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> Bool
isMini (Window -> Bool)
-> ((Window, Rendered) -> Window) -> (Window, Rendered) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window, Rendered) -> Window
forall a b. (a, b) -> a
fst) (PointedList (Window, Rendered) -> [(Window, Rendered)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList PointedList (Window, Rendered)
windowsAndImages))
        miniImages :: [Image]
miniImages =
            ((Window, Rendered) -> Image) -> [(Window, Rendered)] -> [Image]
forall a b. (a -> b) -> [a] -> [b]
map (Rendered -> Image
picture (Rendered -> Image)
-> ((Window, Rendered) -> Rendered) -> (Window, Rendered) -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window, Rendered) -> Rendered
forall a b. (a, b) -> b
snd)
                (((Window, Rendered) -> Bool)
-> [(Window, Rendered)] -> [(Window, Rendered)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Window -> Bool
isMini (Window -> Bool)
-> ((Window, Rendered) -> Window) -> (Window, Rendered) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window, Rendered) -> Window
forall a b. (a, b) -> a
fst) (PointedList (Window, Rendered) -> [(Window, Rendered)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList PointedList (Window, Rendered)
windowsAndImages))
        statusBarStyle :: Attributes
statusBarStyle =
            ((Endo Attributes -> Attributes -> Attributes
forall a. Endo a -> a -> a
appEndo (Endo Attributes -> Attributes -> Attributes)
-> StyleName -> UIStyle -> Attributes -> Attributes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StyleName
cmdSty) (UIStyle -> Attributes -> Attributes)
-> (UIStyle -> Attributes) -> UIStyle -> Attributes
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UIStyle -> Attributes
baseAttributes)
                (UIConfig -> UIStyle
configStyle (Config -> UIConfig
configUI (FrontendState -> Config
fsConfig FrontendState
fs)))
        tabBarImage :: Image
tabBarImage =
            Rect -> UIStyle -> [(Text, Bool)] -> Image
renderTabBar Rect
tabbarRect (UIConfig -> UIStyle
configStyle (Config -> UIConfig
configUI (FrontendState -> Config
fsConfig FrontendState
fs)))
                ((TabDescr -> (Text, Bool)) -> [TabDescr] -> [(Text, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\(TabDescr Text
t Bool
f) -> (Text
t, Bool
f)) (PointedList TabDescr -> [TabDescr]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Editor -> PointedList TabDescr
tabBarDescr Editor
e)))
        cmdImage :: Image
cmdImage = if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
cmd
                   then Image
Vty.emptyImage
                   else Int -> Int -> Image -> Image
Vty.translate
                           (Rect -> Int
SL.offsetX Rect
promptRect)
                           (Rect -> Int
SL.offsetY Rect
promptRect)
                           ([Image] -> Image
Vty.vertCat ((Text -> Image) -> [Text] -> [Image]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Image
formatCmdLine [Text]
niceCmd))
        cursorPos :: Cursor
cursorPos =
            let (Window
w, Rendered
image) = PointedList (Window, Rendered) -> (Window, Rendered)
forall a. PointedList a -> a
PL._focus PointedList (Window, Rendered)
windowsAndImages
            in case (Window -> Bool
isMini Window
w, Rendered -> Maybe (Int, Int)
cursor Rendered
image) of
                  (Bool
False, Just (Int
y, Int
x)) ->
                      Int -> Int -> Cursor
Vty.Cursor (Int -> Int
forall a. Enum a => Int -> a
toEnum Int
x) (Int -> Int
forall a. Enum a => Int -> a
toEnum Int
y)
                  (Bool
True, Just (Int
_, Int
x)) -> Int -> Int -> Cursor
Vty.Cursor (Int -> Int
forall a. Enum a => Int -> a
toEnum Int
x) (Int -> Int
forall a. Enum a => Int -> a
toEnum (Int
rowCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                  (Bool
_, Maybe (Int, Int)
Nothing) -> Cursor
Vty.NoCursor
    Text -> IO ()
forall (m :: * -> *). MonadBase IO m => Text -> m ()
logPutStrLn Text
"refreshing screen."
    Vty -> Picture -> IO ()
Vty.update (FrontendState -> Vty
fsVty FrontendState
fs)
        ([Image] -> Picture
Vty.picForLayers ([Image
tabBarImage, Image
cmdImage] [Image] -> [Image] -> [Image]
forall a. [a] -> [a] -> [a]
++ [Image]
bigImages [Image] -> [Image] -> [Image]
forall a. [a] -> [a] -> [a]
++ [Image]
miniImages))
        { picCursor :: Cursor
Vty.picCursor = Cursor
cursorPos }

renderWindow :: Config -> Editor -> SL.Rect -> HasNeighborWest -> (Window, Bool) -> Rendered
renderWindow :: Config -> Editor -> Rect -> Bool -> (Window, Bool) -> Rendered
renderWindow Config
cfg' Editor
e (SL.Rect Int
x Int
y Int
_ Int
_) Bool
nb (Window
win, Bool
focused) =
    Image -> Maybe (Int, Int) -> Rendered
Rendered (Int -> Int -> Image -> Image
Vty.translate Int
x Int
y (Image -> Image) -> Image -> Image
forall a b. (a -> b) -> a -> b
$ if Bool
nb then Image
vertSep Image -> Image -> Image
Vty.<|> Image
pict else Image
pict)
             (((Int, Int) -> (Int, Int)) -> Maybe (Int, Int) -> Maybe (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
i, Int
j) -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y, Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x')) Maybe (Int, Int)
cur)
    where
        cfg :: UIConfig
cfg = Config -> UIConfig
configUI Config
cfg'
        w :: Int
w = Window -> Int
Yi.Window.width Window
win
        h :: Int
h = Window -> Int
Yi.Window.height Window
win
        x' :: Int
x' = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Bool
nb then Int
1 else Int
0
        w' :: Int
w' = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- if Bool
nb then Int
1 else Int
0
        b :: FBuffer
b = BufferRef -> Editor -> FBuffer
findBufferWith (Window -> BufferRef
bufkey Window
win) Editor
e
        sty :: UIStyle
sty = UIConfig -> UIStyle
configStyle UIConfig
cfg

        notMini :: Bool
notMini = Bool -> Bool
not (Window -> Bool
isMini Window
win)
        displayLineNumbers :: Bool
displayLineNumbers =
          let local :: Maybe Bool
local = (Editor, Maybe Bool) -> Maybe Bool
forall a b. (a, b) -> b
snd ((Editor, Maybe Bool) -> Maybe Bool)
-> (Editor, Maybe Bool) -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Config -> EditorM (Maybe Bool) -> Editor -> (Editor, Maybe Bool)
forall a. Config -> EditorM a -> Editor -> (Editor, a)
runEditor Config
cfg' (BufferRef -> BufferM (Maybe Bool) -> EditorM (Maybe Bool)
forall (m :: * -> *) a.
MonadEditor m =>
BufferRef -> BufferM a -> m a
withGivenBuffer (Window -> BufferRef
bufkey Window
win) BufferM (Maybe Bool)
getDisplayLineNumbersLocal) Editor
e
              global :: Bool
global = UIConfig -> Bool
configLineNumbers UIConfig
cfg
          in Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
global Maybe Bool
local

        -- Collect some information for displaying line numbers
        (Int
lineCount, FBuffer
_) = Window -> FBuffer -> BufferM Int -> (Int, FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b BufferM Int
lineCountB
        (Int
topLine, FBuffer
_) = Window -> FBuffer -> BufferM Int -> (Int, FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b BufferM Int
screenTopLn
        linesInfo :: Maybe (Int, Int)
linesInfo = if Bool
notMini Bool -> Bool -> Bool
&& Bool
displayLineNumbers
                       then (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
topLine, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> String
forall a. Show a => a -> String
show Int
lineCount) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                       else Maybe (Int, Int)
forall a. Maybe a
Nothing
        wNumbers :: Int
wNumbers = Int -> ((Int, Int) -> Int) -> Maybe (Int, Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int, Int) -> Int
forall a b. (a, b) -> b
snd Maybe (Int, Int)
linesInfo

        -- off reserves space for the mode line. The mini window does not have a mode line.
        off :: Int
off = if Bool
notMini then Int
1 else Int
0
        h' :: Int
h' = Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
off
        ground :: Attributes
ground = UIStyle -> Attributes
baseAttributes UIStyle
sty
        wsty :: Attr
wsty = Attributes -> Attr -> Attr
attributesToAttr Attributes
ground Attr
Vty.defAttr
        eofsty :: Attributes
eofsty = Endo Attributes -> Attributes -> Attributes
forall a. Endo a -> a -> a
appEndo (StyleName
eofStyle UIStyle
sty) Attributes
ground
        (Point
point, FBuffer
_) = Window -> FBuffer -> BufferM Point -> (Point, FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b BufferM Point
pointB
        (YiString
text, FBuffer
_) = Window -> FBuffer -> BufferM YiString -> (YiString, FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b (BufferM YiString -> (YiString, FBuffer))
-> BufferM YiString -> (YiString, FBuffer)
forall a b. (a -> b) -> a -> b
$
          -- Take the window worth of lines; we now know exactly how
          -- much text to render, parse and stroke.
          (YiString, YiString) -> YiString
forall a b. (a, b) -> a
fst ((YiString, YiString) -> YiString)
-> (YiString -> (YiString, YiString)) -> YiString -> YiString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> YiString -> (YiString, YiString)
R.splitAtLine Int
h' (YiString -> YiString) -> BufferM YiString -> BufferM YiString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Direction -> Point -> BufferM YiString
streamB Direction
Forward Point
fromMarkPoint

        region :: Region
region = Point -> Size -> Region
mkSizeRegion Point
fromMarkPoint (Size -> Region) -> (Int -> Size) -> Int -> Region
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Size
Size (Int -> Region) -> Int -> Region
forall a b. (a -> b) -> a -> b
$! YiString -> Int
R.length YiString
text
        -- Work around a problem with the mini window never displaying it's contents due to a
        -- fromMark that is always equal to the end of the buffer contents.
        (Just (MarkSet Mark
fromM Mark
_ Mark
_), FBuffer
_) = Window
-> FBuffer
-> BufferM (Maybe (MarkSet Mark))
-> (Maybe (MarkSet Mark), FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b (Window -> BufferM (Maybe (MarkSet Mark))
getMarks Window
win)
        fromMarkPoint :: Point
fromMarkPoint = if Bool
notMini
                        then (Point, FBuffer) -> Point
forall a b. (a, b) -> a
fst ((Point, FBuffer) -> Point) -> (Point, FBuffer) -> Point
forall a b. (a -> b) -> a -> b
$ Window -> FBuffer -> BufferM Point -> (Point, FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b (BufferM Point -> (Point, FBuffer))
-> BufferM Point -> (Point, FBuffer)
forall a b. (a -> b) -> a -> b
$ Getting Point FBuffer Point -> BufferM Point
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting Point FBuffer Point -> BufferM Point)
-> Getting Point FBuffer Point -> BufferM Point
forall a b. (a -> b) -> a -> b
$ Mark -> Lens' FBuffer Point
markPointA Mark
fromM
                        else Int -> Point
Point Int
0

        ([(Point, Attributes)]
attributes, FBuffer
_) = Window
-> FBuffer
-> BufferM [(Point, Attributes)]
-> ([(Point, Attributes)], FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b (BufferM [(Point, Attributes)] -> ([(Point, Attributes)], FBuffer))
-> BufferM [(Point, Attributes)]
-> ([(Point, Attributes)], FBuffer)
forall a b. (a -> b) -> a -> b
$ UIStyle
-> Maybe SearchExp -> Region -> BufferM [(Point, Attributes)]
attributesPictureAndSelB UIStyle
sty (Editor -> Maybe SearchExp
currentRegex Editor
e) Region
region
        -- TODO: I suspect that this costs quite a lot of CPU in the "dry run" which determines the window size;
        -- In that case, since attributes are also useless there, it might help to replace the call by a dummy value.
        -- This is also approximately valid of the call to "indexedAnnotatedStreamB".
        colors :: [(Point, Attr)]
colors = ((Point, Attributes) -> (Point, Attr))
-> [(Point, Attributes)] -> [(Point, Attr)]
forall a b. (a -> b) -> [a] -> [b]
map ((Attributes -> Attr) -> (Point, Attributes) -> (Point, Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Attr -> Attr) -> Attr -> Attr
forall a b. (a -> b) -> a -> b
$ Attr
Vty.defAttr) ((Attr -> Attr) -> Attr)
-> (Attributes -> Attr -> Attr) -> Attributes -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Attr -> Attr
attributesToAttr)) [(Point, Attributes)]
attributes
        bufData :: [(Char, Attr)]
bufData =  Attr -> [(Point, Attr)] -> [(Point, Char)] -> [(Char, Attr)]
forall a. a -> [(Point, a)] -> [(Point, Char)] -> [(Char, a)]
paintChars Attr
Vty.defAttr [(Point, Attr)]
colors ([(Point, Char)] -> [(Char, Attr)])
-> [(Point, Char)] -> [(Char, Attr)]
forall a b. (a -> b) -> a -> b
$! [Point] -> String -> [(Point, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Point
fromMarkPoint..] (YiString -> String
R.toString YiString
text)
        tabWidth :: Int
tabWidth = IndentSettings -> Int
tabSize (IndentSettings -> Int)
-> ((IndentSettings, FBuffer) -> IndentSettings)
-> (IndentSettings, FBuffer)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndentSettings, FBuffer) -> IndentSettings
forall a b. (a, b) -> a
fst ((IndentSettings, FBuffer) -> Int)
-> (IndentSettings, FBuffer) -> Int
forall a b. (a -> b) -> a -> b
$ Window
-> FBuffer -> BufferM IndentSettings -> (IndentSettings, FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b BufferM IndentSettings
indentSettingsB
        prompt :: Text
prompt = if Window -> Bool
isMini Window
win then FBuffer -> Text
miniIdentString FBuffer
b else Text
""

        cur :: Maybe (Int, Int)
cur = ((Point2D -> (Int, Int)) -> Maybe Point2D -> Maybe (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(SL.Point2D Int
curx Int
cury) -> (Int
cury, Text -> Int
T.length Text
prompt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wNumbers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
curx)) (Maybe Point2D -> Maybe (Int, Int))
-> ((Maybe Point2D, FBuffer) -> Maybe Point2D)
-> (Maybe Point2D, FBuffer)
-> Maybe (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Point2D, FBuffer) -> Maybe Point2D
forall a b. (a, b) -> a
fst)
              (Window
-> FBuffer -> BufferM (Maybe Point2D) -> (Maybe Point2D, FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b
                         (Size2D -> Point -> Point -> BufferM (Maybe Point2D)
SL.coordsOfCharacterB
                             (Int -> Int -> Size2D
SL.Size2D (Int
w' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wNumbers) Int
h)
                             Point
fromMarkPoint
                             Point
point))

        rendered :: [Image]
rendered =
            Attr
-> Int
-> Int
-> Int
-> Maybe (Int, Int)
-> [(Char, Attr)]
-> [Image]
drawText Attr
wsty Int
h' Int
w'
                     Int
tabWidth
                     Maybe (Int, Int)
linesInfo
                     ([(Char
c, Attr
wsty) | Char
c <- Text -> String
T.unpack Text
prompt] [(Char, Attr)] -> [(Char, Attr)] -> [(Char, Attr)]
forall a. [a] -> [a] -> [a]
++ [(Char, Attr)]
bufData [(Char, Attr)] -> [(Char, Attr)] -> [(Char, Attr)]
forall a. [a] -> [a] -> [a]
++ [(Char
' ', Attr
wsty)])
                     -- we always add one character which can be used to position the cursor at the end of file
        commonPref :: [Text]
commonPref = String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Editor -> [String]
commonNamePrefix Editor
e
        (Text
modeLine0, FBuffer
_) = Window -> FBuffer -> BufferM Text -> (Text, FBuffer)
forall a. Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer Window
win FBuffer
b (BufferM Text -> (Text, FBuffer))
-> BufferM Text -> (Text, FBuffer)
forall a b. (a -> b) -> a -> b
$ [Text] -> BufferM Text
getModeLine [Text]
commonPref
        modeLine :: Maybe Text
modeLine = if Bool
notMini then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
modeLine0 else Maybe Text
forall a. Maybe a
Nothing
        prepare :: Text -> Image
prepare = Attributes -> Text -> Image
withAttributes Attributes
modeStyle (Text -> Image) -> (Text -> Text) -> Text -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> Text -> Text
T.justifyLeft Int
w' Char
' ' (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.take Int
w'
        modeLines :: [Image]
modeLines = (Text -> Image) -> [Text] -> [Image]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Image
prepare ([Text] -> [Image]) -> [Text] -> [Image]
forall a b. (a -> b) -> a -> b
$ Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList Maybe Text
modeLine
        modeStyle :: Attributes
modeStyle = (if Bool
focused then Endo Attributes -> Attributes -> Attributes
forall a. Endo a -> a -> a
appEndo (StyleName
modelineFocusStyle UIStyle
sty) else Attributes -> Attributes
forall a. a -> a
id) (UIStyle -> Attributes
modelineAttributes UIStyle
sty)

        filler :: T.Text
        filler :: Text
filler = if Int
w' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -- justify would return a single char at w = 0
                 then Text
T.empty
                 else Int -> Char -> Text -> Text
T.justifyLeft Int
w' Char
' ' (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton (UIConfig -> Char
configWindowFill UIConfig
cfg)

        pict :: Image
pict = [Image] -> Image
Vty.vertCat ([Image] -> Image) -> [Image] -> Image
forall a b. (a -> b) -> a -> b
$ Int -> [Image] -> [Image]
forall a. Int -> [a] -> [a]
take Int
h' ([Image]
rendered [Image] -> [Image] -> [Image]
forall a. Semigroup a => a -> a -> a
<> Image -> [Image]
forall a. a -> [a]
repeat (Attributes -> Text -> Image
withAttributes Attributes
eofsty Text
filler)) [Image] -> [Image] -> [Image]
forall a. Semigroup a => a -> a -> a
<> [Image]
modeLines

        sepStyle :: Attr
sepStyle = Attributes -> Attr -> Attr
attributesToAttr (UIStyle -> Attributes
modelineAttributes UIStyle
sty) Attr
Vty.defAttr
        vertSep :: Image
vertSep = Attr -> Char -> Int -> Int -> Image
forall d. Integral d => Attr -> Char -> d -> d -> Image
Vty.charFill Attr
sepStyle Char
' ' Int
1 Int
h

withAttributes :: Attributes -> T.Text -> Vty.Image
withAttributes :: Attributes -> Text -> Image
withAttributes Attributes
sty = Attr -> Text -> Image
Vty.text' (Attributes -> Attr -> Attr
attributesToAttr Attributes
sty Attr
Vty.defAttr)

attributesToAttr :: Attributes -> Vty.Attr -> Vty.Attr
attributesToAttr :: Attributes -> Attr -> Attr
attributesToAttr (Attributes Color
fg Color
bg Bool
reverse Bool
bd Bool
_itlc Bool
underline') =
    (if Bool
reverse then (Attr -> Style -> Attr
`Vty.withStyle` Style
Vty.reverseVideo) else Attr -> Attr
forall a. a -> a
id) (Attr -> Attr) -> (Attr -> Attr) -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (if Bool
bd then (Attr -> Style -> Attr
`Vty.withStyle` Style
Vty.bold) else Attr -> Attr
forall a. a -> a
id) (Attr -> Attr) -> (Attr -> Attr) -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (if Bool
underline' then (Attr -> Style -> Attr
`Vty.withStyle` Style
Vty.underline) else Attr -> Attr
forall a. a -> a
id) (Attr -> Attr) -> (Attr -> Attr) -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Color -> Attr -> Attr) -> Color -> Attr -> Attr
colorToAttr ((Attr -> Color -> Attr) -> Color -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Color -> Attr
Vty.withForeColor) Color
fg (Attr -> Attr) -> (Attr -> Attr) -> Attr -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Color -> Attr -> Attr) -> Color -> Attr -> Attr
colorToAttr ((Attr -> Color -> Attr) -> Color -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Color -> Attr
Vty.withBackColor) Color
bg

-- | Apply the attributes in @sty@ and @changes@ to @cs@.  If the
-- attributes are not used, @sty@ and @changes@ are not evaluated.
paintChars :: a -> [(Point, a)] -> [(Point, Char)] -> [(Char, a)]
paintChars :: a -> [(Point, a)] -> [(Point, Char)] -> [(Char, a)]
paintChars a
sty [(Point, a)]
changes [(Point, Char)]
cs = String -> [a] -> [(Char, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Point, Char) -> Char) -> [(Point, Char)] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Point, Char) -> Char
forall a b. (a, b) -> b
snd [(Point, Char)]
cs) [a]
attrs
    where attrs :: [a]
attrs = a -> [(Point, a)] -> [(Point, Char)] -> [a]
forall a. a -> [(Point, a)] -> [(Point, Char)] -> [a]
stys a
sty [(Point, a)]
changes [(Point, Char)]
cs

stys :: a -> [(Point, a)] -> [(Point, Char)] -> [a]
stys :: a -> [(Point, a)] -> [(Point, Char)] -> [a]
stys a
sty [] [(Point, Char)]
cs = [ a
sty | (Point, Char)
_ <- [(Point, Char)]
cs ]
stys a
sty ((Point
endPos, a
sty') : [(Point, a)]
xs) [(Point, Char)]
cs = [ a
sty | (Point, Char)
_ <- [(Point, Char)]
previous ] [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> a -> [(Point, a)] -> [(Point, Char)] -> [a]
forall a. a -> [(Point, a)] -> [(Point, Char)] -> [a]
stys a
sty' [(Point, a)]
xs [(Point, Char)]
later
    where ([(Point, Char)]
previous, [(Point, Char)]
later) = ((Point, Char) -> Bool)
-> [(Point, Char)] -> ([(Point, Char)], [(Point, Char)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Point
endPos Point -> Point -> Bool
forall a. Ord a => a -> a -> Bool
<=) (Point -> Bool)
-> ((Point, Char) -> Point) -> (Point, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point, Char) -> Point
forall a b. (a, b) -> a
fst) [(Point, Char)]
cs

drawText :: Vty.Attr -- ^ "Ground" attribute.
         -> Int    -- ^ The height of the part of the window we are in
         -> Int    -- ^ The width of the part of the window we are in
         -> Int    -- ^ The number of spaces to represent a tab character with.
         -> Maybe (Int, Int) -- ^ The number of the first line and the reserved width
                             --   for line numbers or Nothing to show no line numbers
         -> [(Char, Vty.Attr)]  -- ^ The data to draw.
         -> [Vty.Image]
drawText :: Attr
-> Int
-> Int
-> Int
-> Maybe (Int, Int)
-> [(Char, Attr)]
-> [Image]
drawText Attr
wsty Int
h Int
w Int
tabWidth Maybe (Int, Int)
linesInfo [(Char, Attr)]
bufData
    | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = []
    | Bool
otherwise        = case Maybe (Int, Int)
linesInfo of
       Maybe (Int, Int)
Nothing -> [Image]
renderedLines
       Just (Int
firstLine, Int
lineNumberWidth) -> Int -> Int -> [Image]
renderedLinesWithNumbers Int
firstLine Int
lineNumberWidth
    where

    wrapped :: Int -> [[[(Char, Attr)]]]
wrapped Int
w' = ([(Char, Attr)] -> [[(Char, Attr)]])
-> [[(Char, Attr)]] -> [[[(Char, Attr)]]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [(Char, Attr)] -> [[(Char, Attr)]]
forall x. Int -> [x] -> [[x]]
wrapLine Int
w' ([(Char, Attr)] -> [[(Char, Attr)]])
-> ([(Char, Attr)] -> [(Char, Attr)])
-> [(Char, Attr)]
-> [[(Char, Attr)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Char, Attr)] -> [(Char, Attr)]
addSpace ([(Char, Attr)] -> [(Char, Attr)])
-> ([(Char, Attr)] -> [(Char, Attr)])
-> [(Char, Attr)]
-> [(Char, Attr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, Attr) -> [(Char, Attr)])
-> [(Char, Attr)] -> [(Char, Attr)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Char, Attr) -> [(Char, Attr)]
forall b. (Char, b) -> [(Char, b)]
expandGraphic) ([[(Char, Attr)]] -> [[[(Char, Attr)]]])
-> [[(Char, Attr)]] -> [[[(Char, Attr)]]]
forall a b. (a -> b) -> a -> b
$ Int -> [[(Char, Attr)]] -> [[(Char, Attr)]]
forall a. Int -> [a] -> [a]
take Int
h ([[(Char, Attr)]] -> [[(Char, Attr)]])
-> [[(Char, Attr)]] -> [[(Char, Attr)]]
forall a b. (a -> b) -> a -> b
$ [(Char, Attr)] -> [[(Char, Attr)]]
forall a. [(Char, a)] -> [[(Char, a)]]
lines' [(Char, Attr)]
bufData

    renderedLinesWithNumbers :: Int -> Int -> [Image]
renderedLinesWithNumbers Int
firstLine Int
lineNumberWidth =
      let lns0 :: [(Maybe Int, [(Char, Attr)])]
lns0 = Int
-> [(Maybe Int, [(Char, Attr)])] -> [(Maybe Int, [(Char, Attr)])]
forall a. Int -> [a] -> [a]
take Int
h ([(Maybe Int, [(Char, Attr)])] -> [(Maybe Int, [(Char, Attr)])])
-> [(Maybe Int, [(Char, Attr)])] -> [(Maybe Int, [(Char, Attr)])]
forall a b. (a -> b) -> a -> b
$ Int -> [[[(Char, Attr)]]] -> [(Maybe Int, [(Char, Attr)])]
concatWithNumbers Int
firstLine ([[[(Char, Attr)]]] -> [(Maybe Int, [(Char, Attr)])])
-> [[[(Char, Attr)]]] -> [(Maybe Int, [(Char, Attr)])]
forall a b. (a -> b) -> a -> b
$ Int -> [[[(Char, Attr)]]]
wrapped (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineNumberWidth)
          renderLineWithNumber :: (Maybe Int, [(Char, Attr)]) -> Image
renderLineWithNumber (Maybe Int
num, [(Char, Attr)]
ln) = Int -> Maybe Int -> Image
renderLineNumber Int
lineNumberWidth Maybe Int
num Image -> Image -> Image
Vty.<|> Int -> [(Char, Attr)] -> Image
fillColorLine (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineNumberWidth) [(Char, Attr)]
ln
      in ((Maybe Int, [(Char, Attr)]) -> Image)
-> [(Maybe Int, [(Char, Attr)])] -> [Image]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Int, [(Char, Attr)]) -> Image
renderLineWithNumber [(Maybe Int, [(Char, Attr)])]
lns0

    renderedLines :: [Image]
renderedLines = ([(Char, Attr)] -> Image) -> [[(Char, Attr)]] -> [Image]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [(Char, Attr)] -> Image
fillColorLine Int
w) ([[(Char, Attr)]] -> [Image]) -> [[(Char, Attr)]] -> [Image]
forall a b. (a -> b) -> a -> b
$ Int -> [[(Char, Attr)]] -> [[(Char, Attr)]]
forall a. Int -> [a] -> [a]
take Int
h ([[(Char, Attr)]] -> [[(Char, Attr)]])
-> [[(Char, Attr)]] -> [[(Char, Attr)]]
forall a b. (a -> b) -> a -> b
$ [[[(Char, Attr)]]] -> [[(Char, Attr)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[(Char, Attr)]]] -> [[(Char, Attr)]])
-> [[[(Char, Attr)]]] -> [[(Char, Attr)]]
forall a b. (a -> b) -> a -> b
$ Int -> [[[(Char, Attr)]]]
wrapped Int
w

    colorChar :: (Char, Attr) -> Image
colorChar (Char
c, Attr
a) = Attr -> Char -> Image
Vty.char Attr
a Char
c

    -- | Like concat, but adds a line number (starting with n) to every first part of a wrapped line
    concatWithNumbers :: Int -> [[[(Char, Vty.Attr)]]] -> [(Maybe Int, [(Char, Vty.Attr)])]
    concatWithNumbers :: Int -> [[[(Char, Attr)]]] -> [(Maybe Int, [(Char, Attr)])]
concatWithNumbers Int
_ [] = []
    concatWithNumbers Int
n ([]:[[[(Char, Attr)]]]
ls) = Int -> [[[(Char, Attr)]]] -> [(Maybe Int, [(Char, Attr)])]
concatWithNumbers Int
n [[[(Char, Attr)]]]
ls
    concatWithNumbers Int
n (([(Char, Attr)]
l0:[[(Char, Attr)]]
ls0):[[[(Char, Attr)]]]
ls) = (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n, [(Char, Attr)]
l0) (Maybe Int, [(Char, Attr)])
-> [(Maybe Int, [(Char, Attr)])] -> [(Maybe Int, [(Char, Attr)])]
forall a. a -> [a] -> [a]
: ([(Char, Attr)] -> (Maybe Int, [(Char, Attr)]))
-> [[(Char, Attr)]] -> [(Maybe Int, [(Char, Attr)])]
forall a b. (a -> b) -> [a] -> [b]
map (\[(Char, Attr)]
l -> (Maybe Int
forall a. Maybe a
Nothing, [(Char, Attr)]
l)) [[(Char, Attr)]]
ls0 [(Maybe Int, [(Char, Attr)])]
-> [(Maybe Int, [(Char, Attr)])] -> [(Maybe Int, [(Char, Attr)])]
forall a. [a] -> [a] -> [a]
++ Int -> [[[(Char, Attr)]]] -> [(Maybe Int, [(Char, Attr)])]
concatWithNumbers (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [[[(Char, Attr)]]]
ls

    -- | Render (maybe) a line number padded to a given width
    renderLineNumber :: Int -> Maybe Int -> Vty.Image
    renderLineNumber :: Int -> Maybe Int -> Image
renderLineNumber Int
w' (Just Int
n) = Attr -> Char -> Int -> Int -> Image
forall d. Integral d => Attr -> Char -> d -> d -> Image
Vty.charFill Attr
wsty Char
' ' (Int
w' Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> String
forall a. Show a => a -> String
show Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
1
                                   Image -> Image -> Image
Vty.<|>
                                   Attr -> String -> Image
Vty.string Attr
wsty (Int -> String
forall a. Show a => a -> String
show Int
n)
                                   Image -> Image -> Image
Vty.<|>
                                   Attr -> Char -> Image
Vty.char Attr
wsty Char
' '
    renderLineNumber Int
w' Maybe Int
Nothing  = Attr -> Char -> Int -> Int -> Image
forall d. Integral d => Attr -> Char -> d -> d -> Image
Vty.charFill Attr
wsty Char
' ' Int
w' Int
1

    fillColorLine :: Int -> [(Char, Vty.Attr)] -> Vty.Image
    fillColorLine :: Int -> [(Char, Attr)] -> Image
fillColorLine Int
w' [] = Attr -> Char -> Int -> Int -> Image
forall d. Integral d => Attr -> Char -> d -> d -> Image
Vty.charFill Attr
Vty.defAttr Char
' ' Int
w' Int
1
    fillColorLine Int
w' [(Char, Attr)]
l = [Image] -> Image
Vty.horizCat (((Char, Attr) -> Image) -> [(Char, Attr)] -> [Image]
forall a b. (a -> b) -> [a] -> [b]
map (Char, Attr) -> Image
colorChar [(Char, Attr)]
l)
                         Image -> Image -> Image
Vty.<|>
                         Attr -> Char -> Int -> Int -> Image
forall d. Integral d => Attr -> Char -> d -> d -> Image
Vty.charFill Attr
a Char
' ' (Int
w' Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(Char, Attr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Char, Attr)]
l) Int
1
                         where (Char
_, Attr
a) = [(Char, Attr)] -> (Char, Attr)
forall a. [a] -> a
last [(Char, Attr)]
l

    addSpace :: [(Char, Vty.Attr)] -> [(Char, Vty.Attr)]
    addSpace :: [(Char, Attr)] -> [(Char, Attr)]
addSpace [] = [(Char
' ', Attr
wsty)]
    addSpace [(Char, Attr)]
l = case Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
lineLength Int
w of
                    Int
0 -> [(Char, Attr)]
l
                    Int
_ -> [(Char, Attr)]
l [(Char, Attr)] -> [(Char, Attr)] -> [(Char, Attr)]
forall a. [a] -> [a] -> [a]
++ [(Char
' ', Attr
wsty)]
                 where
                    lineLength :: Int
lineLength = [(Char, Attr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Char, Attr)]
l

    -- | Cut a string in lines separated by a '\n' char. Note
    -- that we remove the newline entirely since it is no longer
    -- significant for drawing text.

    lines' :: [(Char, a)] -> [[(Char, a)]]
    lines' :: [(Char, a)] -> [[(Char, a)]]
lines' [] =  []
    lines' [(Char, a)]
s  = case [(Char, a)]
s' of
                  []          -> [[(Char, a)]
l]
                  ((Char
_,a
_):[(Char, a)]
s'') -> [(Char, a)]
l [(Char, a)] -> [[(Char, a)]] -> [[(Char, a)]]
forall a. a -> [a] -> [a]
: [(Char, a)] -> [[(Char, a)]]
forall a. [(Char, a)] -> [[(Char, a)]]
lines' [(Char, a)]
s''
                where
                ([(Char, a)]
l, [(Char, a)]
s') = ((Char, a) -> Bool) -> [(Char, a)] -> ([(Char, a)], [(Char, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') (Char -> Bool) -> ((Char, a) -> Char) -> (Char, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, a) -> Char
forall a b. (a, b) -> a
fst) [(Char, a)]
s

    wrapLine :: Int -> [x] -> [[x]]
    wrapLine :: Int -> [x] -> [[x]]
wrapLine Int
_ [] = []
    wrapLine Int
n [x]
l = let ([x]
x,[x]
rest) = Int -> [x] -> ([x], [x])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [x]
l in [x]
x [x] -> [[x]] -> [[x]]
forall a. a -> [a] -> [a]
: Int -> [x] -> [[x]]
forall x. Int -> [x] -> [[x]]
wrapLine Int
n [x]
rest

    expandGraphic :: (Char, b) -> [(Char, b)]
expandGraphic (Char
'\t', b
p) = Int -> (Char, b) -> [(Char, b)]
forall a. Int -> a -> [a]
replicate Int
tabWidth (Char
' ', b
p)
    expandGraphic (Char
c, b
p)
        | Int
numeric Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
32 = [(Char
'^', b
p), (Int -> Char
chr (Int
numeric Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
64), b
p)]
        | Bool
otherwise = [(Char
c, b
p)]
        where numeric :: Int
numeric = Char -> Int
ord Char
c

renderTabBar :: SL.Rect -> UIStyle -> [(T.Text, Bool)] -> Vty.Image
renderTabBar :: Rect -> UIStyle -> [(Text, Bool)] -> Image
renderTabBar Rect
r UIStyle
uiStyle [(Text, Bool)]
ts = (Image -> Image -> Image
Vty.<|> Image
padding) (Image -> Image) -> ([Image] -> Image) -> [Image] -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Image] -> Image
Vty.horizCat ([Image] -> Image) -> [Image] -> Image
forall a b. (a -> b) -> a -> b
$ ((Text, Bool) -> Image) -> [(Text, Bool)] -> [Image]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Bool) -> Image
render [(Text, Bool)]
ts
  where
    render :: (Text, Bool) -> Image
render (Text
text, Bool
inFocus) = Attr -> Text -> Image
Vty.text' (Bool -> Attr
tabAttr Bool
inFocus) (Text -> Text
tabTitle Text
text)
    tabTitle :: Text -> Text
tabTitle Text
text   = Char
' ' Char -> Text -> Text
`T.cons` Text
text Text -> Char -> Text
`T.snoc` Char
' '
    tabAttr :: Bool -> Attr
tabAttr Bool
b       = Bool -> Attributes -> Attr
baseAttr Bool
b (Attributes -> Attr) -> Attributes -> Attr
forall a b. (a -> b) -> a -> b
$ UIStyle -> Attributes
tabBarAttributes UIStyle
uiStyle
    baseAttr :: Bool -> Attributes -> Attr
baseAttr Bool
True Attributes
sty =
        Attributes -> Attr -> Attr
attributesToAttr (Endo Attributes -> Attributes -> Attributes
forall a. Endo a -> a -> a
appEndo (StyleName
tabInFocusStyle UIStyle
uiStyle) Attributes
sty) Attr
Vty.defAttr
    baseAttr Bool
False Attributes
sty =
        Attributes -> Attr -> Attr
attributesToAttr (Endo Attributes -> Attributes -> Attributes
forall a. Endo a -> a -> a
appEndo (StyleName
tabNotFocusedStyle UIStyle
uiStyle) Attributes
sty) Attr
Vty.defAttr
            Attr -> Style -> Attr
`Vty.withStyle` Style
Vty.underline
    padding :: Image
padding = Attr -> Char -> Int -> Int -> Image
forall d. Integral d => Attr -> Char -> d -> d -> Image
Vty.charFill (Bool -> Attr
tabAttr Bool
False) Char
' ' (Rect -> Int
SL.sizeX Rect
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width') Int
1
    width' :: Int
width' = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> ([(Text, Bool)] -> [Int]) -> [(Text, Bool)] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Bool) -> Int) -> [(Text, Bool)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) (Int -> Int) -> ((Text, Bool) -> Int) -> (Text, Bool) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length (Text -> Int) -> ((Text, Bool) -> Text) -> (Text, Bool) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Bool) -> Text
forall a b. (a, b) -> a
fst) ([(Text, Bool)] -> Int) -> [(Text, Bool)] -> Int
forall a b. (a -> b) -> a -> b
$ [(Text, Bool)]
ts