module Yi.Editor ( Editor(..), EditorM, MonadEditor(..)
, runEditor
, acceptedInputsOtherWindow
, addJumpAtE
, addJumpHereE
, alternateBufferE
, askConfigVariableA
, bufferSet
, buffersA
, closeBufferAndWindowE
, closeBufferE
, closeOtherE
, clrStatus
, commonNamePrefix
, currentBuffer
, currentRegexA
, currentWindowA
, deleteBuffer
, deleteTabE
, emptyEditor
, findBuffer
, findBufferWith
, findBufferWithName
, findWindowWith
, focusWindowE
, getBufferStack
, getBufferWithName
, getBufferWithNameOrCurrent
, getEditorDyn
, getRegE
, jumpBackE
, jumpForwardE
, killringA
, layoutManagerNextVariantE
, layoutManagerPreviousVariantE
, layoutManagersNextE
, layoutManagersPreviousE
, layoutManagersPrintMsgE
, maxStatusHeightA
, moveTabE
, moveWinNextE
, moveWinPrevE
, newBufferE
, newEmptyBufferE
, newTabE
, newTempBufferE
, newWindowE
, nextTabE
, nextWinE
, onCloseActionsA
, pendingEventsA
, prevWinE
, previousTabE
, printMsg
, printMsgs
, printStatus
, pushWinToFirstE
, putEditorDyn
, searchDirectionA
, setDividerPosE
, setRegE
, setStatus
, shiftOtherWindow
, splitE
, statusLine
, statusLineInfo
, statusLinesA
, stringToNewBuffer
, swapWinWithFirstE
, switchToBufferE
, switchToBufferWithNameE
, tabsA
, tryCloseE
, windows
, windowsA
, windowsOnBufferE
, withCurrentBuffer
, withEveryBuffer
, withGivenBuffer
, withGivenBufferAndWindow
, withOtherWindow
, withWindowE
) where
import Prelude hiding (all, concatMap, foldl, foldr)
import Control.Applicative ((<$>), (<*>))
import Control.Lens (Lens', assign, lens, mapped,
use, uses, view, (%=), (%~),
(&), (.~), (^.))
import Control.Monad (forM_, liftM)
import Control.Monad.Reader (MonadReader (ask), asks,
unless, when)
import Control.Monad.State (gets, modify)
import Data.Binary (Binary, get, put)
import Data.Default (Default, def)
import qualified Data.DelayList as DelayList (insert)
import Data.DynamicState.Serializable (getDyn, putDyn)
import Data.Foldable (Foldable (foldl, foldr), all, concatMap, toList)
import Data.List (delete, (\\))
import Data.List.NonEmpty (NonEmpty (..), fromList, nub)
import qualified Data.List.NonEmpty as NE (filter, head, length, toList, (<|))
import qualified Data.List.PointedList as PL (atEnd, moveTo)
import qualified Data.List.PointedList.Circular as PL (PointedList (..), delete,
deleteLeft, deleteOthers,
deleteRight, focus,
insertLeft, insertRight,
length, next, previous,
singleton, _focus)
import qualified Data.Map as M (delete, elems, empty,
insert, lookup, singleton, (!))
import Data.Maybe (fromJust, fromMaybe, isNothing)
import qualified Data.Monoid as Mon ((<>))
import Data.Semigroup (mempty, (<>))
import qualified Data.Text as T (Text, null, pack, unlines, unpack, unwords)
import System.FilePath (splitPath)
import Yi.Buffer
import Yi.Config
import Yi.Interact as I (accepted, mkAutomaton)
import Yi.JumpList (Jump (..), JumpList, addJump, jumpBack, jumpForward)
import Yi.KillRing (krEmpty, krGet, krPut, krSet)
import Yi.Layout
import Yi.Monad (getsAndModify)
import Yi.Rope (YiString, empty, fromText)
import qualified Yi.Rope as R (YiString, fromText, snoc)
import Yi.String (listify)
import Yi.Style (defaultStyle)
import Yi.Tab
import Yi.Types
import Yi.Utils
import Yi.Window
instance Binary Editor where
put (Editor bss bs supply ts dv _sl msh kr regex _dir _ev _cwa ) =
let putNE (x :| xs) = put x >> put xs
in putNE bss >> put bs >> put supply >> put ts
>> put dv >> put msh >> put kr >> put regex
get = do
bss <- (:|) <$> get <*> get
bs <- get
supply <- get
ts <- get
dv <- get
msh <- get
kr <- get
regex <- get
return $ emptyEditor { bufferStack = bss
, buffers = bs
, refSupply = supply
, tabs_ = ts
, dynamic = dv
, maxStatusHeight = msh
, killring = kr
, currentRegex = regex
}
emptyEditor :: Editor
emptyEditor = Editor
{ buffers = M.singleton (bkey buf) buf
, tabs_ = PL.singleton tab
, bufferStack = bkey buf :| []
, refSupply = 3
, currentRegex = Nothing
, searchDirection = Forward
, dynamic = mempty
, statusLines = DelayList.insert (maxBound, ([""], defaultStyle)) []
, killring = krEmpty
, pendingEvents = []
, maxStatusHeight = 1
, onCloseActions = M.empty
}
where buf = newB 0 (MemBuffer "console") mempty
win = (dummyWindow (bkey buf)) { wkey = WindowRef 1 , isMini = False }
tab = makeTab1 2 win
makeLensesWithSuffix "A" ''Editor
windows :: Editor -> PL.PointedList Window
windows e = e ^. windowsA
windowsA :: Lens' Editor (PL.PointedList Window)
windowsA = currentTabA . tabWindowsA
tabsA :: Lens' Editor (PL.PointedList Tab)
tabsA = fixCurrentBufferA_ . tabs_A
currentTabA :: Lens' Editor Tab
currentTabA = tabsA . PL.focus
askConfigVariableA :: (YiConfigVariable b, MonadEditor m) => m b
askConfigVariableA = do cfg <- askCfg
return $ cfg ^. configVariable
newRef :: MonadEditor m => m Int
newRef = withEditor (refSupplyA %= (+ 1) >> use refSupplyA)
newBufRef :: MonadEditor m => m BufferRef
newBufRef = liftM BufferRef newRef
stringToNewBuffer :: MonadEditor m
=> BufferId
-> YiString
-> m BufferRef
stringToNewBuffer nm cs = withEditor $ do
u <- newBufRef
defRegStyle <- configRegionStyle <$> askCfg
insertBuffer $ newB u nm cs
m <- asks configFundamentalMode
withGivenBuffer u $ do
putRegionStyle defRegStyle
setAnyMode m
return u
insertBuffer :: MonadEditor m => FBuffer -> m ()
insertBuffer b = withEditor . modify $ \e ->
e { bufferStack = nub (bufferStack e <> (bkey b :| []))
, buffers = M.insert (bkey b) b (buffers e)}
forceFold1 :: Foldable t => t a -> t a
forceFold1 x = foldr seq x x
forceFoldTabs :: Foldable t => t Tab -> t Tab
forceFoldTabs x = foldr (seq . forceTab) x x
deleteBuffer :: MonadEditor m => BufferRef -> m ()
deleteBuffer k = withEditor $ do
gets bufferStack >>= \case
_ :| [] -> return ()
_ -> M.lookup k <$> gets onCloseActions
>>= \m_action -> fromMaybe (return ()) m_action
bs <- gets bufferStack
ws <- use windowsA
case bs of
b0 :| nextB : _ -> do
let pickOther w = if bufkey w == k then w {bufkey = other} else w
visibleBuffers = bufkey <$> toList ws
bs' = NE.toList bs
other = head $ (bs' \\ visibleBuffers) ++ delete k bs'
when (b0 == k) $
switchToBufferE nextB
modify $ \e ->
e & bufferStackA %~ fromList . forceFold1 . NE.filter (k /=)
& buffersA %~ M.delete k
& tabs_A %~ forceFoldTabs . fmap (mapWindows pickOther)
windowsA . mapped . bufAccessListA %= forceFold1 . filter (k /=)
_ -> return ()
bufferSet :: Editor -> [FBuffer]
bufferSet = M.elems . buffers
commonNamePrefix :: Editor -> [FilePath]
commonNamePrefix = commonPrefix . fmap (dropLast . splitPath)
. fbufs . fmap (^. identA) . bufferSet
where dropLast [] = []
dropLast x = init x
fbufs xs = [ x | FileBuffer x <- xs ]
getBufferStack :: MonadEditor m => m (NonEmpty FBuffer)
getBufferStack = withEditor $ do
bufMap <- gets buffers
gets $ fmap (bufMap M.!) . bufferStack
findBuffer :: MonadEditor m => BufferRef -> m (Maybe FBuffer)
findBuffer k = withEditor (gets (M.lookup k . buffers))
findBufferWith :: BufferRef -> Editor -> FBuffer
findBufferWith k e = case M.lookup k (buffers e) of
Just x -> x
Nothing -> error "Editor.findBufferWith: no buffer has this key"
findBufferWithName :: T.Text -> Editor -> [BufferRef]
findBufferWithName n e =
let bufs = M.elems $ buffers e
sameIdent b = shortIdentString (length $ commonNamePrefix e) b == n
in map bkey $ filter sameIdent bufs
getBufferWithName :: MonadEditor m => T.Text -> m BufferRef
getBufferWithName bufName = withEditor $ do
bs <- gets $ findBufferWithName bufName
case bs of
[] -> fail ("Buffer not found: " ++ T.unpack bufName)
b:_ -> return b
withGivenBuffer :: MonadEditor m => BufferRef -> BufferM a -> m a
withGivenBuffer k f = do
b <- gets (findBufferWith k)
withGivenBufferAndWindow (b ^. lastActiveWindowA) k f
withGivenBufferAndWindow :: MonadEditor m
=> Window -> BufferRef -> BufferM a -> m a
withGivenBufferAndWindow w k f = withEditor $ do
accum <- asks configKillringAccumulate
let edit e = let b = findBufferWith k e
(v, us, b') = runBufferFull w b f
in (e & buffersA .~ mapAdjust' (const b') k (buffers e)
& killringA %~
if accum && all updateIsDelete us
then foldl (.) id $ reverse [ krPut dir s
| Delete _ dir s <- us ]
else id
, (us, v))
(us, v) <- getsAndModify edit
updHandler <- return . bufferUpdateHandler =<< ask
unless (null us || null updHandler) $
forM_ updHandler (\h -> withGivenBufferAndWindow w k (h us))
return v
withCurrentBuffer :: MonadEditor m => BufferM a -> m a
withCurrentBuffer f = withEditor $ do
w <- use currentWindowA
withGivenBufferAndWindow w (bufkey w) f
withEveryBuffer :: MonadEditor m => BufferM a -> m [a]
withEveryBuffer action =
withEditor (gets bufferStack) >>= mapM (`withGivenBuffer` action) . NE.toList
currentWindowA :: Lens' Editor Window
currentWindowA = windowsA . PL.focus
currentBuffer :: Editor -> BufferRef
currentBuffer = NE.head . bufferStack
printMsg :: MonadEditor m => T.Text -> m ()
printMsg s = printStatus ([s], defaultStyle)
printMsgs :: MonadEditor m => [T.Text] -> m ()
printMsgs s = printStatus (s, defaultStyle)
printStatus :: MonadEditor m => Status -> m ()
printStatus = setTmpStatus 1
setStatus :: MonadEditor m => Status -> m ()
setStatus = setTmpStatus maxBound
clrStatus :: EditorM ()
clrStatus = setStatus ([""], defaultStyle)
statusLine :: Editor -> [T.Text]
statusLine = fst . statusLineInfo
statusLineInfo :: Editor -> Status
statusLineInfo = snd . head . statusLines
setTmpStatus :: MonadEditor m => Int -> Status -> m ()
setTmpStatus delay s = withEditor $ do
statusLinesA %= DelayList.insert (delay, s)
bs <- gets (filter ((== MemBuffer "messages") . view identA) . M.elems . buffers)
b <- case bs of
(b':_) -> return $ bkey b'
[] -> stringToNewBuffer (MemBuffer "messages") mempty
let m = listify $ R.fromText <$> fst s
withGivenBuffer b $ botB >> insertN (m `R.snoc` '\n')
setRegE :: R.YiString -> EditorM ()
setRegE s = killringA %= krSet s
getRegE :: EditorM R.YiString
getRegE = uses killringA krGet
getEditorDyn :: (MonadEditor m, YiVariable a, Default a, Functor m) => m a
getEditorDyn = fromMaybe def <$> getDyn (use dynamicA) (assign dynamicA)
putEditorDyn :: (MonadEditor m, YiVariable a, Functor m) => a -> m ()
putEditorDyn = putDyn (use dynamicA) (assign dynamicA)
newBufferE :: BufferId
-> YiString
-> EditorM BufferRef
newBufferE f s = do
b <- stringToNewBuffer f s
switchToBufferE b
return b
newEmptyBufferE :: BufferId -> EditorM BufferRef
newEmptyBufferE f = newBufferE f Yi.Rope.empty
alternateBufferE :: Int -> EditorM ()
alternateBufferE n = do
Window { bufAccessList = lst } <- use currentWindowA
if null lst || (length lst 1) < n
then fail "no alternate buffer"
else switchToBufferE $ lst!!n
newZeroSizeWindow :: Bool -> BufferRef -> WindowRef -> Window
newZeroSizeWindow mini bk ref = Window mini bk [] 0 0 emptyRegion ref 0 Nothing
newWindowE :: Bool -> BufferRef -> EditorM Window
newWindowE mini bk = newZeroSizeWindow mini bk . WindowRef <$> newRef
switchToBufferE :: BufferRef -> EditorM ()
switchToBufferE bk = windowsA . PL.focus %= \w ->
w & bufkeyA .~ bk
& bufAccessListA %~ forceFold1 . (bufkey w:) . filter (bk /=)
switchToBufferWithNameE :: T.Text -> EditorM ()
switchToBufferWithNameE "" = alternateBufferE 0
switchToBufferWithNameE bufName = switchToBufferE =<< getBufferWithName bufName
closeBufferE :: T.Text -> EditorM ()
closeBufferE nm = deleteBuffer =<< getBufferWithNameOrCurrent nm
getBufferWithNameOrCurrent :: MonadEditor m => T.Text -> m BufferRef
getBufferWithNameOrCurrent t = withEditor $
case T.null t of
True -> gets currentBuffer
False -> getBufferWithName t
closeBufferAndWindowE :: EditorM ()
closeBufferAndWindowE = do
b <- gets currentBuffer
tryCloseE
deleteBuffer b
nextWinE :: EditorM ()
nextWinE = windowsA %= PL.next
prevWinE :: EditorM ()
prevWinE = windowsA %= PL.previous
swapWinWithFirstE :: EditorM ()
swapWinWithFirstE = windowsA %= swapFocus (fromJust . PL.moveTo 0)
pushWinToFirstE :: EditorM ()
pushWinToFirstE = windowsA %= pushToFirst
where
pushToFirst ws = case PL.delete ws of
Nothing -> ws
Just ws' -> PL.insertLeft (ws ^. PL.focus) (fromJust $ PL.moveTo 0 ws')
moveWinNextE :: EditorM ()
moveWinNextE = windowsA %= swapFocus PL.next
moveWinPrevE :: EditorM ()
moveWinPrevE = windowsA %= swapFocus PL.previous
fixCurrentBufferA_ :: Lens' Editor Editor
fixCurrentBufferA_ = lens id (\_old new -> let
ws = windows new
b = findBufferWith (bufkey $ PL._focus ws) new
newBufferStack = nub (bkey b NE.<| bufferStack new)
in NE.length newBufferStack `seq` new & bufferStackA .~ newBufferStack)
withWindowE :: Window -> BufferM a -> EditorM a
withWindowE w = withGivenBufferAndWindow w (bufkey w)
findWindowWith :: WindowRef -> Editor -> Window
findWindowWith k e =
head $ concatMap (\win -> [win | wkey win == k]) $ windows e
windowsOnBufferE :: BufferRef -> EditorM [Window]
windowsOnBufferE k = do
ts <- use tabsA
let tabBufEq = concatMap (\win -> [win | bufkey win == k]) . (^. tabWindowsA)
return $ concatMap tabBufEq ts
focusWindowE :: WindowRef -> EditorM ()
focusWindowE k = do
ts <- use tabsA
let check (False, i) win = if wkey win == k
then (True, i)
else (False, i + 1)
check r@(True, _) _win = r
searchWindowSet (False, tabIndex, _) ws =
case foldl check (False, 0) (ws ^. tabWindowsA) of
(True, winIndex) -> (True, tabIndex, winIndex)
(False, _) -> (False, tabIndex + 1, 0)
searchWindowSet r@(True, _, _) _ws = r
case foldl searchWindowSet (False, 0, 0) ts of
(False, _, _) -> fail $ "No window with key " ++ show k ++ "found. (focusWindowE)"
(True, tabIndex, winIndex) -> do
assign tabsA (fromJust $ PL.moveTo tabIndex ts)
windowsA %= fromJust . PL.moveTo winIndex
splitE :: EditorM ()
splitE = do
w <- gets currentBuffer >>= newWindowE False
windowsA %= PL.insertRight w
layoutManagersPrintMsgE :: EditorM ()
layoutManagersPrintMsgE = do
lm <- use $ currentTabA . tabLayoutManagerA
printMsg . T.pack $ describeLayout lm
layoutManagersNextE :: EditorM ()
layoutManagersNextE = withLMStackE PL.next >> layoutManagersPrintMsgE
layoutManagersPreviousE :: EditorM ()
layoutManagersPreviousE = withLMStackE PL.previous >> layoutManagersPrintMsgE
withLMStackE :: (PL.PointedList AnyLayoutManager
-> PL.PointedList AnyLayoutManager)
-> EditorM ()
withLMStackE f = askCfg >>= \cfg ->
currentTabA . tabLayoutManagerA %= go (layoutManagers cfg)
where
go [] lm = lm
go lms lm =
case findPL (layoutManagerSameType lm) lms of
Nothing -> head lms
Just lmsPL -> f lmsPL ^. PL.focus
layoutManagerNextVariantE :: EditorM ()
layoutManagerNextVariantE = do
currentTabA . tabLayoutManagerA %= nextVariant
layoutManagersPrintMsgE
layoutManagerPreviousVariantE :: EditorM ()
layoutManagerPreviousVariantE = do
currentTabA . tabLayoutManagerA %= previousVariant
layoutManagersPrintMsgE
setDividerPosE :: DividerRef -> DividerPosition -> EditorM ()
setDividerPosE ref = assign (currentTabA . tabDividerPositionA ref)
newTabE :: EditorM ()
newTabE = do
bk <- gets currentBuffer
win <- newWindowE False bk
ref <- newRef
tabsA %= PL.insertRight (makeTab1 ref win)
nextTabE :: EditorM ()
nextTabE = tabsA %= PL.next
previousTabE :: EditorM ()
previousTabE = tabsA %= PL.previous
moveTabE :: Maybe Int -> EditorM ()
moveTabE Nothing = do
count <- uses tabsA PL.length
tabsA %= fromJust . PL.moveTo (pred count)
moveTabE (Just n) = do
newTabs <- uses tabsA (PL.moveTo n)
when (isNothing newTabs) failure
assign tabsA $ fromJust newTabs
where failure = fail $ "moveTab " ++ show n ++ ": no such tab"
deleteTabE :: EditorM ()
deleteTabE = tabsA %= fromMaybe failure . deleteTab
where failure = error "deleteTab: cannot delete sole tab"
deleteTab tabs = if PL.atEnd tabs
then PL.deleteLeft tabs
else PL.deleteRight tabs
tryCloseE :: EditorM ()
tryCloseE = do
ntabs <- uses tabsA PL.length
nwins <- uses windowsA PL.length
unless (ntabs == 1 && nwins == 1) $ if nwins == 1
then tabsA %= fromJust . PL.deleteLeft
else windowsA %= fromJust . PL.deleteLeft
closeOtherE :: EditorM ()
closeOtherE = windowsA %= PL.deleteOthers
shiftOtherWindow :: MonadEditor m => m ()
shiftOtherWindow = withEditor $ do
len <- uses windowsA PL.length
if len == 1
then splitE
else nextWinE
withOtherWindow :: MonadEditor m => m a -> m a
withOtherWindow f = do
shiftOtherWindow
x <- f
withEditor prevWinE
return x
acceptedInputs :: EditorM [T.Text]
acceptedInputs = do
km <- defaultKm <$> askCfg
keymap <- withCurrentBuffer $ gets (withMode0 modeKeymap)
let l = I.accepted 3 . I.mkAutomaton . extractTopKeymap . keymap $ km
return $ fmap T.unwords l
acceptedInputsOtherWindow :: EditorM ()
acceptedInputsOtherWindow = do
ai <- acceptedInputs
b <- stringToNewBuffer (MemBuffer "keybindings") (fromText $ T.unlines ai)
w <- newWindowE False b
windowsA %= PL.insertRight w
addJumpHereE :: EditorM ()
addJumpHereE = addJumpAtE =<< withCurrentBuffer pointB
addJumpAtE :: Point -> EditorM ()
addJumpAtE point = do
w <- use currentWindowA
shouldAddJump <- case jumpList w of
Just (PL.PointedList _ (Jump mark bf) _) -> do
bfStillAlive <- gets (M.lookup bf . buffers)
case bfStillAlive of
Nothing -> return False
_ -> do
p <- withGivenBuffer bf . use $ markPointA mark
return $! (p, bf) /= (point, bufkey w)
_ -> return True
when shouldAddJump $ do
m <- withCurrentBuffer setMarkHereB
let bf = bufkey w
j = Jump m bf
assign currentWindowA $ w & jumpListA %~ addJump j
return ()
jumpBackE :: EditorM ()
jumpBackE = addJumpHereE >> modifyJumpListE jumpBack
jumpForwardE :: EditorM ()
jumpForwardE = modifyJumpListE jumpForward
modifyJumpListE :: (JumpList -> JumpList) -> EditorM ()
modifyJumpListE f = do
w <- use currentWindowA
case f $ w ^. jumpListA of
Nothing -> return ()
Just (PL.PointedList _ (Jump mark bf) _) -> do
switchToBufferE bf
withCurrentBuffer $ use (markPointA mark) >>= moveTo
currentWindowA . jumpListA %= f
newTempBufferE :: EditorM BufferRef
newTempBufferE = do
e <- gets id
let find_next currentName (nextName:otherNames) =
case findBufferWithName currentName e of
(_b : _) -> find_next nextName otherNames
[] -> currentName
find_next _ [] = error "Looks like nearly infinite list has just ended."
next_tmp_name = find_next name names
(name : names) = (fmap (("tmp-" Mon.<>) . T.pack . show) [0 :: Int ..])
newEmptyBufferE (MemBuffer next_tmp_name)