module Yi.Editor where
import Prelude hiding (foldl,concatMap,foldr,all)
import Control.Monad.State hiding (get, put, mapM, forM_)
import Control.Monad.Reader hiding (mapM, forM_ )
import Control.Applicative
import Control.Monad
import Control.Lens
import Data.Binary
import Data.DeriveTH
import Data.Either (rights)
import Data.List (nub, delete, (\\))
import Data.Maybe
import Data.Typeable
import Data.Default
import Data.Foldable hiding (forM_)
import System.FilePath (splitPath)
import Yi.Buffer
import Yi.Config
import Yi.Dynamic
import Yi.Event (Event)
import Yi.Interact as I
import Yi.JumpList
import Yi.KillRing
import Yi.Layout
import Yi.Style (StyleName, defaultStyle)
import Yi.Tab
import Yi.Window
import Yi.Monad hiding (newRef)
import Yi.Utils
import Data.Rope (Rope)
import qualified Data.Rope as R
import qualified Data.DelayList as DelayList
import qualified Data.List.PointedList as PL (atEnd, moveTo)
import qualified Data.List.PointedList.Circular as PL
import qualified Data.Map as M
import Yi.Keymap (extractTopKeymap)
type Status = ([String],StyleName)
type Statuses = DelayList.DelayList Status
data Editor = Editor {
bufferStack :: ![BufferRef]
,buffers :: !(M.Map BufferRef FBuffer)
,refSupply :: !Int
,tabs_ :: !(PL.PointedList Tab)
,dynamic :: !DynamicValues
,statusLines :: !Statuses
,maxStatusHeight :: !Int
,killring :: !Killring
,currentRegex :: !(Maybe SearchExp)
,searchDirection :: !Direction
,pendingEvents :: ![Event]
,onCloseActions :: !(M.Map BufferRef (EditorM ()))
}
deriving Typeable
instance Binary Editor where
put (Editor bss bs supply ts dv _sl msh kr _re _dir _ev _cwa ) = put bss >> put bs >> put supply >> put ts >> put dv >> put msh >> put kr
get = do
bss <- get
bs <- get
supply <- get
ts <- get
dv <- get
msh <- get
kr <- get
return $ emptyEditor {bufferStack = bss,
buffers = bs,
refSupply = supply,
tabs_ = ts,
dynamic = dv,
maxStatusHeight = msh,
killring = kr
}
newtype EditorM a = EditorM {fromEditorM :: ReaderT Config (State Editor) a}
deriving (Monad, MonadState Editor, MonadReader Config, Functor)
deriving instance Typeable1 EditorM
instance Applicative EditorM where
pure = return
(<*>) = ap
class (Monad m, MonadState Editor m) => MonadEditor m
where askCfg :: m Config
withEditor :: EditorM a -> m a
withEditor f = do
cfg <- askCfg
getsAndModify (runEditor cfg f)
liftEditor :: MonadEditor m => EditorM a -> m a
liftEditor = withEditor
instance MonadEditor EditorM where
askCfg = ask
withEditor = id
emptyEditor :: Editor
emptyEditor = Editor {
buffers = M.singleton (bkey buf) buf
,tabs_ = PL.singleton tab
,bufferStack = [bkey buf]
,refSupply = 3
,currentRegex = Nothing
,searchDirection = Forward
,dynamic = def
,statusLines = DelayList.insert (maxBound, ([""], defaultStyle)) []
,killring = krEmpty
,pendingEvents = []
,maxStatusHeight = 1
,onCloseActions = M.empty
}
where buf = newB 0 (Left "console") (R.fromString "")
win = (dummyWindow (bkey buf)) {wkey = WindowRef 1, isMini = False}
tab = makeTab1 2 win
runEditor :: Config -> EditorM a -> Editor -> (Editor, a)
runEditor cfg f e = let (a, e') = runState (runReaderT (fromEditorM f) cfg) e in (e',a)
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 ^. configVarsA ^. configVariableA
dynA :: YiVariable a => Lens' Editor a
dynA = dynamicA . dynamicValueA
newRef :: EditorM Int
newRef = do
(%=) refSupplyA (+ 1)
use refSupplyA
newBufRef :: EditorM BufferRef
newBufRef = BufferRef <$> newRef
stringToNewBuffer :: BufferId
-> Rope
-> EditorM BufferRef
stringToNewBuffer nm cs = do
u <- newBufRef
defRegStyle <- configRegionStyle <$> askCfg
insertBuffer $ set regionStyleA defRegStyle $ newB u nm cs
m <- asks configFundamentalMode
withGivenBuffer0 u $ setAnyMode m
return u
insertBuffer :: FBuffer -> EditorM ()
insertBuffer b = 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 :: BufferRef -> EditorM ()
deleteBuffer k = do
pure length <*> gets bufferStack
>>= \l -> case l of
1 -> return ()
_ -> pure (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 = fmap bufkey $ toList ws
other = head $ (bs \\ visibleBuffers) ++ delete k bs
when (b0 == k) $
switchToBufferE nextB
modify $ \e -> e {bufferStack = forceFold1 $ filter (k /=) $ bufferStack e,
buffers = M.delete k (buffers e),
tabs_ = forceFoldTabs $ fmap (mapWindows pickOther) (tabs_ e)
}
(%=) windowsA (fmap (\w -> w { bufAccessList = forceFold1 . filter (k/=) $ bufAccessList w }))
_ -> return ()
bufferSet :: Editor -> [FBuffer]
bufferSet = M.elems . buffers
commonNamePrefix :: Editor -> [String]
commonNamePrefix = commonPrefix . fmap (dropLast . splitPath) . rights . fmap (^. identA) . bufferSet
where dropLast [] = []
dropLast x = init x
getBufferStack :: EditorM [FBuffer]
getBufferStack = do
bufMap <- gets buffers
gets (fmap (bufMap M.!) . bufferStack)
findBuffer :: BufferRef -> EditorM (Maybe FBuffer)
findBuffer k = gets (M.lookup k . buffers)
findBufferWith :: BufferRef -> Editor -> FBuffer
findBufferWith k e = fromMaybe (error "Editor.findBufferWith: no buffer has this key") (M.lookup k (buffers e))
findBufferWithName :: String -> Editor -> [BufferRef]
findBufferWithName n e = map bkey $ filter (\b -> shortIdentString (commonNamePrefix e) b == n) (M.elems $ buffers e)
getBufferWithName :: String -> EditorM BufferRef
getBufferWithName bufName = do
bs <- gets $ findBufferWithName bufName
case bs of
[] -> fail ("Buffer not found: " ++ bufName)
(b:_) -> return b
openAllBuffersE :: EditorM ()
openAllBuffersE = do bs <- gets bufferSet
forM_ bs $ ((%=) windowsA . PL.insertRight =<<) . newWindowE False . bkey
shiftBuffer :: Int -> EditorM ()
shiftBuffer shift = do
(%=) bufferStackA rotate
fixCurrentWindow
where rotate l = take len $ drop (shift `mod` len) $ cycle l
where len = length l
withGivenBuffer0 :: BufferRef -> BufferM a -> EditorM a
withGivenBuffer0 k f = do
b <- gets (findBufferWith k)
withGivenBufferAndWindow0 (b ^. lastActiveWindowA) k f
withGivenBufferAndWindow0 :: Window -> BufferRef -> BufferM a -> EditorM a
withGivenBufferAndWindow0 w k f = do
accum <- asks configKillringAccumulate
(us, v) <- getsAndModify (\e ->
let b = findBufferWith k e
(v, us, b') = runBufferFull w b f
in (e {buffers = mapAdjust' (const b') k (buffers e),
killring = (if accum && all updateIsDelete us
then foldl (.) id
(reverse [krPut dir (R.toString s) | Delete _ dir s <- us])
else id)
(killring e)
}, (us, v)))
updHandler <- return . bufferUpdateHandler =<< ask
unless (null us || null updHandler) $
forM_ updHandler (\h -> withGivenBufferAndWindow0 w k (h us))
return v
withBuffer0 :: BufferM a -> EditorM a
withBuffer0 f = do
w <- use currentWindowA
withGivenBufferAndWindow0 w (bufkey w) f
withEveryBufferE :: BufferM a -> EditorM [a]
withEveryBufferE action =
gets bufferStack >>= mapM (`withGivenBuffer0` action)
currentWindowA :: Lens' Editor Window
currentWindowA = windowsA . PL.focus
currentBuffer :: Editor -> BufferRef
currentBuffer = head . bufferStack
printMsg :: String -> EditorM ()
printMsg s = printStatus ([s], defaultStyle)
printMsgs :: [String] -> EditorM ()
printMsgs s = printStatus (s, defaultStyle)
printStatus :: Status -> EditorM ()
printStatus = setTmpStatus 1
setStatus :: Status -> EditorM ()
setStatus = setTmpStatus maxBound
clrStatus :: EditorM ()
clrStatus = setStatus ([""], defaultStyle)
statusLine :: Editor -> [String]
statusLine = fst . statusLineInfo
statusLineInfo :: Editor -> Status
statusLineInfo = snd . head . statusLines
setTmpStatus :: Int -> Status -> EditorM ()
setTmpStatus delay s = do
(%=) statusLinesA $ DelayList.insert (delay, s)
bs <- gets (filter (\b -> b ^. identA == Left "messages") . M.elems . buffers)
b <- case bs of
(b':_) -> return $ bkey b'
[] -> stringToNewBuffer (Left "messages") (R.fromString "")
withGivenBuffer0 b $ do botB; insertN (show s ++ "\n")
setRegE :: String -> EditorM ()
setRegE s = (%=) killringA $ krSet s
getRegE :: EditorM String
getRegE = uses killringA krGet
getDynamic :: YiVariable a => EditorM a
getDynamic = use (dynamicA . dynamicValueA)
setDynamic :: YiVariable a => a -> EditorM ()
setDynamic = assign (dynamicA . dynamicValueA)
nextBufW :: EditorM ()
nextBufW = shiftBuffer 1
prevBufW :: EditorM ()
prevBufW = shiftBuffer (negate 1)
newBufferE :: BufferId
-> Rope
-> EditorM BufferRef
newBufferE f s = do
b <- stringToNewBuffer f s
switchToBufferE b
return b
newTempBufferE :: EditorM BufferRef
newTempBufferE = do
hint :: TempBufferNameHint <- getDynamic
e <- gets id
let find_next in_name =
case findBufferWithName (show in_name) e of
(_b : _) -> find_next $ inc in_name
[] -> in_name
inc in_name = TempBufferNameHint (tmp_name_base in_name) (tmp_name_index in_name + 1)
next_tmp_name = find_next hint
b <- newBufferE (Left $ show next_tmp_name)
(R.fromString "")
setDynamic $ inc next_tmp_name
return b
data TempBufferNameHint = TempBufferNameHint
{ tmp_name_base :: String
, tmp_name_index :: Int
} deriving Typeable
instance Show TempBufferNameHint where
show (TempBufferNameHint s i) = s ++ "-" ++ show i
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 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 { bufkey = bk,
bufAccessList = forceFold1 $ (bufkey w:) . filter (bk/=) $ bufAccessList w })
switchToBufferOtherWindowE :: BufferRef -> EditorM ()
switchToBufferOtherWindowE b = shiftOtherWindow >> switchToBufferE b
switchToBufferWithNameE :: String -> EditorM ()
switchToBufferWithNameE "" = alternateBufferE 0
switchToBufferWithNameE bufName = switchToBufferE =<< getBufferWithName bufName
closeBufferE :: String -> EditorM ()
closeBufferE nm = deleteBuffer =<< getBufferWithNameOrCurrent nm
getBufferWithNameOrCurrent :: String -> EditorM BufferRef
getBufferWithNameOrCurrent nm = if null nm then gets currentBuffer else getBufferWithName nm
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 : bufferStack new)
in length newBufferStack `seq` new { bufferStack = newBufferStack } )
fixCurrentWindow :: EditorM ()
fixCurrentWindow = do
b <- gets currentBuffer
(%=) (windowsA . PL.focus) (\w -> w {bufkey = b})
withWindowE :: Window -> BufferM a -> EditorM a
withWindowE w = withGivenBufferAndWindow0 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
return $ concatMap (concatMap (\win -> [win | bufkey win == k]) . (^. tabWindowsA)) 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 wkey ++ "found. (focusWindowE)"
(True, tabIndex, winIndex) -> do
assign tabsA (fromJust $ PL.moveTo tabIndex ts)
(%=) windowsA (fromJust . PL.moveTo winIndex)
splitE :: EditorM ()
splitE = do
b <- gets currentBuffer
w <- newWindowE False b
(%=) windowsA (PL.insertRight w)
layoutManagersNextE :: EditorM ()
layoutManagersNextE = withLMStack PL.next
layoutManagersPreviousE :: EditorM ()
layoutManagersPreviousE = withLMStack PL.previous
withLMStack :: (PL.PointedList AnyLayoutManager -> PL.PointedList AnyLayoutManager) -> EditorM ()
withLMStack 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 = (%=) (currentTabA . tabLayoutManagerA) nextVariant
layoutManagerPreviousVariantE :: EditorM ()
layoutManagerPreviousVariantE = (%=) (currentTabA . tabLayoutManagerA) previousVariant
enlargeWinE :: EditorM ()
enlargeWinE = error "enlargeWinE: not implemented"
shrinkWinE :: EditorM ()
shrinkWinE = error "shrinkWinE: not implemented"
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
moveTab :: Maybe Int -> EditorM ()
moveTab Nothing = do count <- uses tabsA PL.length
(%=) tabsA $ fromJust . PL.moveTo (pred count)
moveTab (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 = liftEditor $ 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
liftEditor prevWinE
return x
acceptedInputs :: EditorM [String]
acceptedInputs = do
cfg <- askCfg
keymap <- withBuffer0 $ gets (withMode0 modeKeymap)
let l = I.accepted 3 $ I.mkAutomaton $ extractTopKeymap $ keymap $ defaultKm cfg
return $ fmap unwords l
onCloseBufferE :: BufferRef -> EditorM () -> EditorM ()
onCloseBufferE b a = (%=) onCloseActionsA $ M.insertWith' (\_ old_a -> old_a >> a) b a
$(derive makeBinary ''TempBufferNameHint)
instance Default TempBufferNameHint where
def = TempBufferNameHint "tmp" 0
instance YiVariable TempBufferNameHint
addJumpHereE :: EditorM ()
addJumpHereE = addJumpAtE =<< withBuffer0 pointB
addJumpAtE :: Point -> EditorM ()
addJumpAtE point = do
w <- use currentWindowA
let jl = jumpList w
shouldAddJump <- case jl of
Just (PL.PointedList _ (Jump mark bf) _) -> do
bfStillAlive <- gets (M.lookup bf . buffers)
case bfStillAlive of
Nothing -> return False
_ -> do
p <- withGivenBuffer0 bf $ getMarkPointB mark
return $! (p, bf) /= (point, bufkey w)
_ -> return True
when shouldAddJump $ do
m <- withBuffer0 setMarkHereB
let bf = bufkey w
j = Jump m bf
assign currentWindowA $ w { jumpList = addJump j (jumpList w) }
return ()
jumpBackE :: EditorM ()
jumpBackE = addJumpHereE >> modifyJumpListE jumpBack
jumpForwardE :: EditorM ()
jumpForwardE = modifyJumpListE jumpForward
modifyJumpListE :: (JumpList -> JumpList) -> EditorM ()
modifyJumpListE f = do
w <- use currentWindowA
let w' = w { jumpList = f (jumpList w) }
jl = jumpList w'
case jl of
Nothing -> return ()
Just (PL.PointedList _ (Jump mark bf) _) -> do
switchToBufferE bf
withBuffer0 $ getMarkPointB mark >>= moveTo
(%=) currentWindowA (\win -> win { jumpList = f (jumpList win) })