module Yi.Editor where
import Control.Monad.RWS hiding (get, put, mapM, forM_)
import Data.Accessor.Basic (fromSetGet)
import Data.Accessor.Template
import Data.Binary
import Data.DeriveTH
import Data.Either (rights)
import Data.List (nub, delete, (\\), (!!), intercalate, take, drop, cycle)
import Data.Maybe
import Data.Typeable
import Prelude (map, filter, length, reverse)
import System.FilePath (splitPath)
import Yi.Buffer
import Yi.Config
import Yi.Dynamic
import Yi.Event (Event)
import Yi.Interact as I
import Yi.KillRing
import Yi.Layout
import Yi.Prelude
import Yi.Style (StyleName, defaultStyle)
import Yi.Tab
import Yi.Window
import qualified Data.Rope as R
import qualified Data.DelayList as DelayList
import qualified Data.List.PointedList as PL (atEnd)
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 :: RWS Config () 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 = initial
,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',()) = runRWS (fromEditorM f) cfg e in (e',a)
$(nameDeriveAccessors ''Editor (\n -> Just (n ++ "A")))
windows :: Editor -> PL.PointedList Window
windows e = e ^. windowsA
windowsA :: Accessor Editor (PL.PointedList Window)
windowsA = tabWindowsA . currentTabA
tabsA :: Accessor Editor (PL.PointedList Tab)
tabsA = tabs_A . fixCurrentBufferA_
currentTabA :: Accessor Editor Tab
currentTabA = PL.focusA . tabsA
dynA :: YiVariable a => Accessor Editor a
dynA = dynamicValueA . dynamicA
newRef :: EditorM Int
newRef = do
modA refSupplyA (+ 1)
getA refSupplyA
newBufRef :: EditorM BufferRef
newBufRef = BufferRef <$> newRef
stringToNewBuffer :: BufferId
-> Rope
-> EditorM BufferRef
stringToNewBuffer nm cs = do
u <- newBufRef
defRegStyle <- configRegionStyle <$> askCfg
insertBuffer $ setVal 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 -> case m_action of
Nothing -> return ()
Just action -> action
bs <- gets bufferStack
ws <- getA 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) $ do
switchToBufferE nextB
modify $ \e -> e {bufferStack = forceFold1 $ filter (k /=) $ bufferStack e,
buffers = M.delete k (buffers e),
tabs_ = forceFoldTabs $ fmap (mapWindows pickOther) (tabs_ e)
}
modA 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 =
case M.lookup k (buffers e) of
Just b -> b
Nothing -> error "Editor.findBufferWith: no buffer has this key"
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 $ (modA windowsA . PL.insertRight =<<) . newWindowE False . bkey
shiftBuffer :: Int -> EditorM ()
shiftBuffer shift = do
modA 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) $ do
forM_ updHandler (\h -> withGivenBufferAndWindow0 w k (h us))
return v
withBuffer0 :: BufferM a -> EditorM a
withBuffer0 f = do
w <- getA currentWindowA
withGivenBufferAndWindow0 w (bufkey w) f
currentWindowA :: Accessor Editor Window
currentWindowA = PL.focusA . windowsA
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
modA 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 = modA killringA $ krSet s
getRegE :: EditorM String
getRegE = getsA killringA krGet
getDynamic :: YiVariable a => EditorM a
getDynamic = getA (dynamicValueA . dynamicA)
setDynamic :: YiVariable a => a -> EditorM ()
setDynamic x = putA (dynamicValueA . dynamicA) x
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 } <- getA 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
newWindowE :: Bool -> BufferRef -> EditorM Window
newWindowE mini bk = newZeroSizeWindow mini bk . WindowRef <$> newRef
switchToBufferE :: BufferRef -> EditorM ()
switchToBufferE bk = do
modA (PL.focusA . windowsA) (\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 = modA windowsA PL.next
prevWinE :: EditorM ()
prevWinE = modA windowsA PL.previous
swapWinWithFirstE :: EditorM ()
swapWinWithFirstE = modA windowsA (swapFocus (fromJust . PL.move 0))
pushWinToFirstE :: EditorM ()
pushWinToFirstE = modA windowsA pushToFirst
where
pushToFirst ws = case PL.delete ws of
Nothing -> ws
Just ws' -> PL.insertLeft (ws ^. PL.focusA) (fromJust $ PL.move 0 ws')
moveWinNextE :: EditorM ()
moveWinNextE = modA windowsA (swapFocus PL.next)
moveWinPrevE :: EditorM ()
moveWinPrevE = modA windowsA (swapFocus PL.previous)
fixCurrentBufferA_ :: Accessor Editor Editor
fixCurrentBufferA_ = fromSetGet (\new _old -> let
ws = windows new
b = findBufferWith (bufkey $ PL.focus ws) new
newBufferStack = nub (bkey b : bufferStack new)
in length newBufferStack `seq` new { bufferStack = newBufferStack } ) id
fixCurrentWindow :: EditorM ()
fixCurrentWindow = do
b <- gets currentBuffer
modA (PL.focusA . windowsA) (\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 -> if (wkey win == k) then [win] else []) $ windows e
windowsOnBufferE :: BufferRef -> EditorM [Window]
windowsOnBufferE k = do
ts <- getA tabsA
return $ concatMap (concatMap (\win -> if (bufkey win == k) then [win] else []) . (^. tabWindowsA)) ts
focusWindowE :: WindowRef -> EditorM ()
focusWindowE k = do
ts <- getA 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
putA tabsA (fromJust $ PL.move tabIndex ts)
modA windowsA (\ws -> fromJust $ PL.move winIndex ws)
splitE :: EditorM ()
splitE = do
b <- gets currentBuffer
w <- newWindowE False b
modA 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 -> modA (tabLayoutManagerA . currentTabA) (go (layoutManagers cfg))
where
go [] lm = lm
go lms lm =
case findPL (layoutManagerSameType lm) lms of
Nothing -> head lms
Just lmsPL -> f lmsPL ^. PL.focusA
layoutManagerNextVariantE :: EditorM ()
layoutManagerNextVariantE = modA (tabLayoutManagerA . currentTabA) nextVariant
layoutManagerPreviousVariantE :: EditorM ()
layoutManagerPreviousVariantE = modA (tabLayoutManagerA . currentTabA) previousVariant
enlargeWinE :: EditorM ()
enlargeWinE = error "enlargeWinE: not implemented"
shrinkWinE :: EditorM ()
shrinkWinE = error "shrinkWinE: not implemented"
setDividerPosE :: DividerRef -> DividerPosition -> EditorM ()
setDividerPosE ref pos = putA (tabDividerPositionA ref . currentTabA) pos
newTabE :: EditorM ()
newTabE = do
bk <- gets currentBuffer
win <- newWindowE False bk
ref <- newRef
modA tabsA (PL.insertRight (makeTab1 ref win))
nextTabE :: EditorM ()
nextTabE = modA tabsA PL.next
previousTabE :: EditorM ()
previousTabE = modA tabsA PL.previous
moveTab :: Maybe Int -> EditorM ()
moveTab Nothing = do count <- getsA tabsA PL.length
modA tabsA $ fromJust . PL.move (pred count)
moveTab (Just n) = do newTabs <- getsA tabsA (PL.move n)
when (isNothing newTabs) failure
putA tabsA $ fromJust newTabs
where failure = fail $ "moveTab " ++ show n ++ ": no such tab"
deleteTabE :: EditorM ()
deleteTabE = modA tabsA $ maybe failure id . deleteTab
where failure = error "deleteTab: cannot delete sole tab"
deleteTab tabs = case PL.atEnd tabs of
True -> PL.deleteLeft tabs
False -> PL.deleteRight tabs
tryCloseE :: EditorM ()
tryCloseE = do
n <- getsA windowsA PL.length
if n == 1
then modA tabsA (fromJust . PL.deleteLeft)
else modA windowsA (fromJust . PL.deleteLeft)
closeOtherE :: EditorM ()
closeOtherE = modA windowsA PL.deleteOthers
shiftOtherWindow :: MonadEditor m => m ()
shiftOtherWindow = liftEditor $ do
len <- getsA 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 (intercalate " ") l
onCloseBufferE :: BufferRef -> EditorM () -> EditorM ()
onCloseBufferE b a = do
modA onCloseActionsA $ M.insertWith' (\_ old_a -> old_a >> a) b a
$(derive makeBinary ''TempBufferNameHint)
instance Initializable TempBufferNameHint where
initial = TempBufferNameHint "tmp" 0
instance YiVariable TempBufferNameHint