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.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.Prelude
import Yi.Style (StyleName, defaultStyle)
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 (PL.PointedList Window))
,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 msh >> put kr
get = do
bss <- get
bs <- get
supply <- get
ts <- get
msh <- get
kr <- get
return $ emptyEditor {bufferStack = bss,
buffers = bs,
refSupply = supply,
tabs_ = ts,
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 (PL.singleton win)
,bufferStack = [bkey buf]
,refSupply = 2
,currentRegex = Nothing
,searchDirection = Forward
,dynamic = M.empty
,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 = 1, isMini = False}
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 editor = PL.focus $ tabs_ editor
windowsA :: Accessor Editor (PL.PointedList Window)
windowsA = PL.focusA . tabsA
tabsA :: Accessor Editor (PL.PointedList (PL.PointedList Window))
tabsA = tabs_A . fixCurrentBufferA_
dynA :: Initializable 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
forceFold2 :: (Foldable t1, Foldable t2) => t1 (t2 a) -> t1 (t2 a)
forceFold2 x = foldr (seq . forceFold1) 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_ = forceFold2 $ fmap (fmap 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 :: Initializable a => EditorM a
getDynamic = getA (dynamicValueA . dynamicA)
setDynamic :: Initializable 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 Initializable TempBufferNameHint where
initial = TempBufferNameHint "tmp" 0
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
newWindowE :: Bool -> BufferRef -> EditorM Window
newWindowE mini bk = Window mini bk [] 0 emptyRegion <$> 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
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 . PL.focusA . tabs_A) (\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 [])) 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 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)
enlargeWinE :: EditorM ()
enlargeWinE = error "enlargeWinE: not implemented"
shrinkWinE :: EditorM ()
shrinkWinE = error "shrinkWinE: not implemented"
newTabE :: EditorM ()
newTabE = do
bk <- gets currentBuffer
win <- newWindowE False bk
modA tabsA (PL.insertRight (PL.singleton 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