diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/src/Yi/Config/Default/Emacs.hs b/src/Yi/Config/Default/Emacs.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Config/Default/Emacs.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +module Yi.Config.Default.Emacs (configureEmacs) where + +import Lens.Micro.Platform ((%=), (.=), (.~)) +import Yi.Buffer.Misc (identA, directoryContentA) +import Yi.Config.Misc (ScrollStyle (..)) +import Yi.Editor (buffersA, newBufferE) +import Yi.Event (Modifier (..), Key (..), Event (..)) +import Yi.Interact (mkAutomaton, anyEvent, write, (||>), event, P) +import Yi.Keymap (makeAction) +import Yi.Keymap.Emacs (keymap) +import Yi.Keymap.Keys (printableChar, spec) +import Yi.Config.Lens +import Yi.Config.Simple (ConfigM) +import qualified Yi.Rope as R +import Yi.Types + +import Control.Monad (forever, unless, void) +import qualified Data.Map as M +import Lens.Micro.Platform (use, (^.)) + +configureEmacs :: ConfigM () +configureEmacs = do + configUIA %= (configScrollStyleA .~ Just SnapToCenter) + defaultKmA .= keymap + startActionsA %= (makeAction openScratchBuffer :) + configInputPreprocessA .= escToMeta + configKillringAccumulateA .= True + +-- | Input preprocessor: Transform Esc;Char into Meta-Char +-- Useful for emacs lovers ;) +escToMeta :: P Event Event +escToMeta = mkAutomaton $ forever $ (anyEvent >>= write) ||> do + _ <- event (spec KEsc) + c <- printableChar + write (Event (KASCII c) [MMeta]) + +-- | Open an emacs-like scratch buffer if no file is open. +openScratchBuffer :: YiM () +openScratchBuffer = withEditor $ do + fileBufOpen <- any isFileOrDir . M.elems <$> use buffersA + unless fileBufOpen $ + void . newBufferE (MemBuffer "scratch") $ R.unlines + [ "This buffer is for notes you don't want to save." + , "If you want to create a file, open that file," + , "then enter the text in that file's own buffer." + , "" + ] + where + isFileOrDir :: FBuffer -> Bool + isFileOrDir attrs = case attrs ^. identA of + MemBuffer _ -> attrs ^. directoryContentA + FileBuffer _ -> True diff --git a/src/Yi/Keymap/Emacs.hs b/src/Yi/Keymap/Emacs.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Keymap/Emacs.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Yi.Keymap.Emacs +-- License : GPL-2 +-- Maintainer : yi-devel@googlegroups.com +-- Stability : experimental +-- Portability : portable +-- +-- This module aims at a mode that should be (mostly) intuitive to +-- emacs users, but mapping things into the Yi world when convenient. +-- Hence, do not go into the trouble of trying 100% emulation. For +-- example, @M-x@ gives access to Yi (Haskell) functions, with their +-- native names. + +module Yi.Keymap.Emacs ( keymap + , mkKeymap + , defKeymap + , ModeMap(..) + , eKeymap + , completionCaseSensitive + ) where + +import Control.Applicative (Alternative ((<|>), empty, some)) +import Lens.Micro.Platform ((.=), makeLenses, (%=)) +import Control.Monad (replicateM_, unless, void) +import Control.Monad.State (gets) +import Data.Char (digitToInt, isDigit) +import Data.Maybe (fromMaybe) +import Data.Prototype (Proto (Proto), extractValue) +import Data.Text () +import Yi.Buffer +import Yi.Command (shellCommandE) +import Yi.Core +import Yi.Dired (dired) +import Yi.Editor +import Yi.File (fwriteE, fwriteToE) +import Yi.Keymap (Keymap, KeymapSet, YiAction (..), YiM, modelessKeymapSet, write) +import Yi.Keymap.Emacs.KillRing +import Yi.Keymap.Emacs.Utils +import Yi.Keymap.Keys +import Yi.MiniBuffer +import Yi.Misc (adjBlock, adjIndent, placeMark, selectAll) +import Yi.Mode.Buffers (listBuffers) +import Yi.Rectangle +import Yi.Search (isearchFinishWithE, resetRegexE, getRegexE) +import Yi.TextCompletion (resetComplete, wordComplete') + +data ModeMap = ModeMap { _eKeymap :: Keymap + , _completionCaseSensitive :: Bool + } + +$(makeLenses ''ModeMap) + +keymap :: KeymapSet +keymap = mkKeymap defKeymap + +mkKeymap :: Proto ModeMap -> KeymapSet +mkKeymap = modelessKeymapSet . _eKeymap . extractValue + +defKeymap :: Proto ModeMap +defKeymap = Proto template + where + template self = ModeMap { _eKeymap = emacsKeymap + , _completionCaseSensitive = False } + where + emacsKeymap :: Keymap + emacsKeymap = selfInsertKeymap Nothing isDigit <|> completionKm (_completionCaseSensitive self) <|> + do univArg <- readUniversalArg + selfInsertKeymap univArg (not . isDigit) <|> emacsKeys univArg + +selfInsertKeymap :: Maybe Int -> (Char -> Bool) -> Keymap +selfInsertKeymap univArg condition = do + c <- printableChar + unless (condition c) empty + let n = argToInt univArg + write (adjBlock n >> replicateM_ n (insertB c)) + +completionKm :: Bool -> Keymap +completionKm caseSensitive = do void $ some (meta (char '/') ?>>! wordComplete' caseSensitive) + deprioritize + write resetComplete + -- 'adjustPriority' is there to lift the ambiguity between "continuing" completion + -- and resetting it (restarting at the 1st completion). + +deleteB' :: BufferM () +deleteB' = adjBlock (-1) >> deleteN 1 + +-- | Wrapper around 'moveE' which also cancels incremental search. See +-- issue #499 for details. +moveE :: TextUnit -> Direction -> EditorM () +moveE u d = do + getRegexE >>= \case + -- let's check whether searching is in progress (issues #738, #610) + Nothing -> return () + _ -> isearchFinishWithE resetRegexE + withCurrentBuffer (moveB u d) + +emacsKeys :: Maybe Int -> Keymap +emacsKeys univArg = + choice [ -- First all the special key bindings + spec KTab ?>>! adjIndent IncreaseCycle + , shift (spec KTab) ?>>! adjIndent DecreaseCycle + , spec KEnter ?>>! repeatingArg newlineB + , spec KDel ?>>! deleteRegionOr deleteForward + , spec KBS ?>>! deleteRegionOr deleteBack + , spec KHome ?>>! repeatingArg moveToSol + , spec KEnd ?>>! repeatingArg moveToEol + , spec KLeft ?>>! repeatingArg $ moveE Character Backward + , spec KRight ?>>! repeatingArg $ moveE Character Forward + , spec KUp ?>>! repeatingArg $ moveE VLine Backward + , spec KDown ?>>! repeatingArg $ moveE VLine Forward + , spec KPageDown ?>>! repeatingArg downScreenB + , spec KPageUp ?>>! repeatingArg upScreenB + + , shift (spec KUp) ?>>! repeatingArg (scrollB (-1)) + , shift (spec KDown) ?>>! repeatingArg (scrollB 1) + + -- All the keybindings of the form 'Ctrl + special key' + , ctrl (spec KLeft) ?>>! repeatingArg prevWordB + , ctrl (spec KRight) ?>>! repeatingArg nextWordB + , ctrl (spec KHome) ?>>! repeatingArg topB + , ctrl (spec KEnd) ?>>! repeatingArg botB + , ctrl (spec KUp) ?>>! repeatingArg (prevNParagraphs 1) + , ctrl (spec KDown) ?>>! repeatingArg (nextNParagraphs 1) + + -- All the keybindings of the form "C-c" where 'c' is some character + , ctrlCh '@' ?>>! placeMark + , ctrlCh ' ' ?>>! placeMark + , ctrlCh '/' ?>>! repeatingArg undoB + , ctrlCh '_' ?>>! repeatingArg undoB + , ctrlCh 'a' ?>>! repeatingArg (maybeMoveB Line Backward) + , ctrlCh 'b' ?>>! repeatingArg $ moveE Character Backward + , ctrlCh 'd' ?>>! deleteForward + , ctrlCh 'e' ?>>! repeatingArg (maybeMoveB Line Forward) + , ctrlCh 'f' ?>>! repeatingArg $ moveE Character Forward + , ctrlCh 'g' ?>>! setVisibleSelection False + , ctrlCh 'h' ?>> char 'b' ?>>! acceptedInputsOtherWindow + , ctrlCh 'i' ?>>! adjIndent IncreaseOnly + , ctrlCh 'j' ?>>! newlineAndIndentB + , ctrlCh 'k' ?>>! killLine univArg + , ctrlCh 'l' ?>>! (withCurrentBuffer scrollToCursorB >> userForceRefresh) + , ctrlCh 'm' ?>>! repeatingArg (insertB '\n') + , ctrlCh 'n' ?>>! repeatingArg (moveE VLine Forward) + , ctrlCh 'o' ?>>! repeatingArg (insertB '\n' >> leftB) + , ctrlCh 'p' ?>>! repeatingArg (moveE VLine Backward) + , ctrlCh 'q' ?>> insertNextC univArg + , ctrlCh 'r' ?>> isearchKeymap Backward + , ctrlCh 's' ?>> isearchKeymap Forward + , ctrlCh 't' ?>>! repeatingArg swapB + , ctrlCh 'v' ?>>! scrollDownE univArg + , ctrlCh 'w' ?>>! killRegion + , ctrlCh 'y' ?>>! yank + , ctrlCh 'z' ?>>! suspendEditor + , ctrlCh '+' ?>>! repeatingArg (increaseFontSize 1) + , ctrlCh '-' ?>>! repeatingArg (decreaseFontSize 1) + + -- All the keybindings of the form "C-M-c" where 'c' is some character + , ctrl (metaCh 'w') ?>>! appendNextKillE + , ctrl (metaCh ' ') ?>>! layoutManagersNextE + , ctrl (metaCh ',') ?>>! layoutManagerNextVariantE + , ctrl (metaCh '.') ?>>! layoutManagerPreviousVariantE + , ctrl (metaCh 'j') ?>>! nextWinE + , ctrl (metaCh 'k') ?>>! prevWinE + , ctrl (meta $ spec KEnter) ?>>! swapWinWithFirstE + + +-- All the keybindings of the form "S-C-M-c" where 'c' is some key + , shift (ctrl $ metaCh 'j') ?>>! moveWinNextE + , shift (ctrl $ metaCh 'k') ?>>! moveWinPrevE + , shift (ctrl $ meta $ spec KEnter) ?>>! pushWinToFirstE + , Event (KASCII ' ') [MShift,MCtrl,MMeta] ?>>! layoutManagersPreviousE + + -- All the key-bindings which are preceded by a 'C-x' + , ctrlCh 'x' ?>> ctrlX + + , ctrlCh 'c' ?>> ctrlC + + -- All The key-bindings of the form M-c where 'c' is some character. + , metaCh ' ' ?>>! justOneSep univArg + , metaCh 'v' ?>>! scrollUpE univArg + , metaCh '!' ?>>! shellCommandE + , metaCh '<' ?>>! repeatingArg topB + , metaCh '>' ?>>! repeatingArg botB + , metaCh '%' ?>>! queryReplaceE + , metaCh '^' ?>>! joinLinesE univArg + , metaCh ';' ?>>! commentRegion + , metaCh 'a' ?>>! repeatingArg (moveE unitSentence Backward) + , metaCh 'b' ?>>! repeatingArg prevWordB + , metaCh 'c' ?>>! repeatingArg capitaliseWordB + , metaCh 'd' ?>>! repeatingArg killWordB + , metaCh 'e' ?>>! repeatingArg (moveE unitSentence Forward) + , metaCh 'f' ?>>! repeatingArg nextWordB + , metaCh 'h' ?>>! (setSelectRegionB =<< regionOfB unitParagraph) + , metaCh 'k' ?>>! repeatingArg (deleteB unitSentence Forward) + , metaCh 'l' ?>>! repeatingArg lowercaseWordB + , metaCh 'm' ?>>! firstNonSpaceB + , metaCh 'q' ?>>! withSyntax modePrettify + , metaCh 'r' ?>>! repeatingArg moveToMTB + , metaCh 'u' ?>>! repeatingArg uppercaseWordB + , metaCh 't' ?>>! repeatingArg (transposeB unitWord Forward) + , metaCh 'w' ?>>! killRingSave + , metaCh 'x' ?>>! executeExtendedCommandE + , metaCh 'y' ?>>! yankPopE + , metaCh '.' ?>>! promptTag + , metaCh '{' ?>>! repeatingArg (prevNParagraphs 1) + , metaCh '}' ?>>! repeatingArg (nextNParagraphs 1) + , metaCh '=' ?>>! countWordsRegion + , metaCh '\\' ?>>! deleteHorizontalSpaceB univArg + , metaCh '@' ?>>! repeatingArg markWord + + -- Other meta key-bindings + , meta (spec KBS) ?>>! repeatingArg bkillWordB + , metaCh 'g' ?>> + optMod meta (char 'g') >>! (gotoLn . fromDoc :: Int ::: LineNumber -> BufferM Int) + ] + where + -- inserting the empty string prevents the deletion from appearing in the killring + -- which is a good thing when we are deleting individuals characters. See + -- http://code.google.com/p/yi-editor/issues/detail?id=212 + blockKillring = insertN "" + + withUnivArg :: YiAction (m ()) () => (Maybe Int -> m ()) -> YiM () + withUnivArg cmd = runAction $ makeAction (cmd univArg) + + repeatingArg :: (Monad m, YiAction (m ()) ()) => m () -> YiM () + repeatingArg f = withIntArg $ \n -> replicateM_ n f + + withIntArg :: YiAction (m ()) () => (Int -> m ()) -> YiM () + withIntArg cmd = withUnivArg $ \arg -> cmd (fromMaybe 1 arg) + + deleteBack :: YiM () + deleteBack = repeatingArg $ blockKillring >> adjBlock (-1) >> bdeleteB + + deleteForward :: YiM () + deleteForward = repeatingArg $ blockKillring >> deleteB' + + -- Deletes current region if any, otherwise executes the given + -- action. + deleteRegionOr :: (Show a, YiAction (m a) a) => m a -> YiM () + deleteRegionOr f = do + b <- gets currentBuffer + r <- withGivenBuffer b getSelectRegionB + if regionSize r == 0 + then runAction $ makeAction f + else withGivenBuffer b $ deleteRegionB r + + ctrlC = choice [ ctrlCh 'c' ?>>! commentRegion ] + + + rectangleFunctions = choice [ char 'a' ?>>! alignRegionOn + , char 'o' ?>>! openRectangle + , char 't' ?>>! stringRectangle + , char 'k' ?>>! killRectangle + , char 'y' ?>>! yankRectangle + ] + + tabFunctions :: Keymap + tabFunctions = choice [ optMod ctrl (char 'n') >>! nextTabE + , optMod ctrl (char 'p') >>! previousTabE + , optMod ctrl (char 't') >>! newTabE + , optMod ctrl (char 'e') >>! findFileNewTab + , optMod ctrl (char 'd') >>! deleteTabE + , charOf id '0' '9' >>=! moveTabE . Just . digitToInt + ] + -- These keybindings are all preceded by a 'C-x' so for example to + -- quit the editor we do a 'C-x C-c' + ctrlX = choice [ ctrlCh 'o' ?>>! deleteBlankLinesB + , char '0' ?>>! closeWindowEmacs + , char '1' ?>>! closeOtherE + , char '2' ?>>! splitE + , char 'h' ?>>! selectAll + , char 's' ?>>! askSaveEditor + , ctrlCh 'b' ?>>! listBuffers + , ctrlCh 'c' ?>>! askQuitEditor + , ctrlCh 'f' ?>>! findFile + , ctrlCh 'r' ?>>! findFileReadOnly + , ctrlCh 'q' ?>>! + ((withCurrentBuffer (readOnlyA %= not)) :: EditorM ()) + , ctrlCh 's' ?>>! fwriteE + , ctrlCh 'w' ?>>! promptFile "Write file:" (void . fwriteToE) + , ctrlCh 'x' ?>>! (exchangePointAndMarkB >> + highlightSelectionA .= True) + , char 'b' ?>>! switchBufferE + , char 'd' ?>>! dired + , char 'e' ?>> + char 'e' ?>>! evalRegionE + , char 'o' ?>>! nextWinE + , char 'k' ?>>! killBufferE + , char 'r' ?>> rectangleFunctions + , char 'u' ?>>! repeatingArg undoB + , optMod ctrl (char 't') >> tabFunctions + ] diff --git a/src/Yi/Keymap/Emacs/KillRing.hs b/src/Yi/Keymap/Emacs/KillRing.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Keymap/Emacs/KillRing.hs @@ -0,0 +1,114 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Yi.Keymap.Emacs.KillRing +-- License : GPL-2 +-- Maintainer : yi-devel@googlegroups.com +-- Stability : experimental +-- Portability : portable + +module Yi.Keymap.Emacs.KillRing where + +import Lens.Micro.Platform (use, (%=), (.=)) +import Control.Monad (replicateM_, when) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (fromMaybe) +import Yi.Buffer +import Yi.Editor (EditorM, killringA, withCurrentBuffer) +import Yi.Keymap (YiM) +import Yi.KillRing (Killring (_krContents), krKilled, krPut) +import qualified Yi.Rope as R (YiString, fromString, toString) +import Yi.Types (withEditor) +import Yi.Utils (io) +import System.Hclip (getClipboard, setClipboard) + +uses l f = f <$> use l + +-- * Killring actions + +-- | Adds system clipboard's contents on top of the killring if not already there +clipboardToKillring :: YiM () +clipboardToKillring = do + text <- fmap R.fromString $ io getClipboard + withEditor $ do + text' <- killringGet + when (text' /= text) $ killringPut Forward text + +-- | Adds the top of the killring to the system clipboard +killringToClipboard :: YiM () +killringToClipboard = do + text <- withEditor killringGet + io . setClipboard $ R.toString text + +-- This is like @kill-region-or-backward-word@. +killRegionB :: BufferM () +killRegionB = getSelectRegionB >>= \r -> + if regionStart r == regionEnd r then bkillWordB else deleteRegionB r + +-- | C-w +-- Like `killRegionB`, but with system clipboard synchronization +killRegion :: YiM () +killRegion = withCurrentBuffer killRegionB >> killringToClipboard + +-- | Kills current line +killLineB :: Maybe Int -> BufferM () +killLineB mbr = replicateM_ (fromMaybe 1 mbr) $ do + eol <- atEol + let tu = if eol then Character else Line + deleteRegionB =<< regionOfPartNonEmptyB tu Forward + +-- | C-k +-- | Like `killLineB`, but with system clipboard synchronization +killLine :: Maybe Int -> YiM () +killLine mbr = withCurrentBuffer (killLineB mbr) >> killringToClipboard + +killringGet :: EditorM R.YiString +killringGet = do + text :| _ <- uses killringA _krContents + return text + +killringPut :: Direction -> R.YiString -> EditorM () +killringPut dir s = killringA %= krPut dir s + +-- | Yanks top of killbuffer +yankE :: EditorM () +yankE = do + text :| _ <- uses killringA _krContents + withCurrentBuffer $ pointB >>= setSelectionMarkPointB >> insertN text + +-- | C-y +-- Like `yankE`, but with system clipboard synchronization +yank :: YiM () +yank = clipboardToKillring >> withEditor yankE + +-- | Saves current selection to killring and then clears it +killRingSaveE :: EditorM () +killRingSaveE = do + (r, text) <- withCurrentBuffer $ do + r <- getSelectRegionB + text <- readRegionB r + highlightSelectionA .= False + return (r, text) + killringPut (regionDirection r) text + +-- | M-w +-- Like `killRingSaveE`, but with system clipboard synchronization +killRingSave :: YiM () +killRingSave = withEditor killRingSaveE >> killringToClipboard + +-- | M-y +-- TODO: Handle argument, verify last command was a yank +yankPopE :: EditorM () +yankPopE = do + kr <- use killringA + withCurrentBuffer (deleteRegionB =<< getRawestSelectRegionB) + killringA .= let x :| xs = _krContents kr + in kr { _krContents = case xs of + [] -> x :| [] + y:ys -> y :| ys ++ [x] + } + yankE + +-- | C-M-w +appendNextKillE :: EditorM () +appendNextKillE = killringA . krKilled .= True diff --git a/src/Yi/Keymap/Emacs/Utils.hs b/src/Yi/Keymap/Emacs/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Keymap/Emacs/Utils.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Yi.Keymap.Emacs.Utils +-- License : GPL-2 +-- Maintainer : yi-devel@googlegroups.com +-- Stability : experimental +-- Portability : portable +-- +-- This module is aimed at being a helper for the Emacs keybindings. +-- In particular this should be useful for anyone that has a custom +-- keymap derived from or based on the Emacs one. + +module Yi.Keymap.Emacs.Utils + ( UnivArgument + , argToInt + , askQuitEditor + , askSaveEditor + , modifiedQuitEditor + , withMinibuffer + , queryReplaceE + , isearchKeymap + , cabalConfigureE + , cabalBuildE + , reloadProjectE + , executeExtendedCommandE + , evalRegionE + , readUniversalArg + , scrollDownE + , scrollUpE + , switchBufferE + , killBufferE + , insertNextC + , findFile + , findFileReadOnly + , findFileNewTab + , promptFile + , promptTag + , justOneSep + , joinLinesE + , countWordsRegion + ) +where + +import Control.Applicative (Alternative ((<|>), many, some), optional) +import Lens.Micro.Platform (use, (.=)) +import Control.Monad (filterM, replicateM_, void) +import Control.Monad.Base () +import Data.List ((\\)) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import qualified Data.Text as T (Text, concat, null, pack, singleton, snoc, unpack, unwords) +import System.FilePath (takeDirectory, takeFileName, ()) +import System.FriendlyPath () +import Yi.Buffer +import Yi.Command (cabalBuildE, cabalConfigureE, reloadProjectE) +import Yi.Core (quitEditor) +import Yi.Editor +import Yi.Eval (execEditorAction, getAllNamesInScope) +import Yi.File (deservesSave, editFile, fwriteBufferE, openingNewFile) +import Yi.Keymap (Keymap, KeymapM, YiM, write) +import Yi.Keymap.Keys +import Yi.MiniBuffer +import Yi.Misc (promptFile) +import Yi.Monad (gets) +import Yi.Rectangle (getRectangle) +import Yi.Regex (makeSearchOptsM) +import qualified Yi.Rope as R (countNewLines, fromText, length, replicateChar, toText, words) +import Yi.Search +import Yi.String (showT) +import Yi.Tag +import Yi.Utils (io) + +type UnivArgument = Maybe Int + +---------------------------- +-- | Quits the editor if there are no unmodified buffers +-- if there are unmodified buffers then we ask individually for +-- each modified buffer whether or not the user wishes to save +-- it or not. If we get to the end of this list and there are still +-- some modified buffers then we ask again if the user wishes to +-- quit, but this is then a simple yes or no. +askQuitEditor :: YiM () +askQuitEditor = askIndividualSave True =<< getModifiedBuffers + +askSaveEditor :: YiM () +askSaveEditor = askIndividualSave False =<< getModifiedBuffers + +getModifiedBuffers :: YiM [FBuffer] +getModifiedBuffers = filterM deservesSave =<< gets bufferSet + +-------------------------------------------------- +-- Takes in a list of buffers which have been identified +-- as modified since their last save. + +askIndividualSave :: Bool -> [FBuffer] -> YiM () +askIndividualSave True [] = modifiedQuitEditor +askIndividualSave False [] = return () +askIndividualSave hasQuit allBuffers@(firstBuffer : others) = + void (withEditor (spawnMinibufferE saveMessage (const askKeymap))) + where + saveMessage = T.concat [ "do you want to save the buffer: " + , bufferName + , "? (y/n/", if hasQuit then "q/" else "", "c/!)" + ] + bufferName = identString firstBuffer + + askKeymap = choice ([ char 'n' ?>>! noAction + , char 'y' ?>>! yesAction + , char '!' ?>>! allAction + , oneOf [char 'c', ctrl $ char 'g'] + >>! closeBufferAndWindowE + -- cancel + ] ++ [char 'q' ?>>! quitEditor | hasQuit]) + yesAction = do void $ fwriteBufferE (bkey firstBuffer) + withEditor closeBufferAndWindowE + continue + + noAction = do withEditor closeBufferAndWindowE + continue + + allAction = do mapM_ fwriteBufferE $ fmap bkey allBuffers + withEditor closeBufferAndWindowE + askIndividualSave hasQuit [] + + continue = askIndividualSave hasQuit others + +--------------------------- + +--------------------------- +-- | Quits the editor if there are no unmodified buffers +-- if there are then simply confirms with the user that they +-- with to quit. +modifiedQuitEditor :: YiM () +modifiedQuitEditor = + do modifiedBuffers <- getModifiedBuffers + if null modifiedBuffers + then quitEditor + else withEditor $ void (spawnMinibufferE modifiedMessage (const askKeymap)) + where + modifiedMessage = "Modified buffers exist really quit? (y/n)" + + askKeymap = choice [ char 'n' ?>>! noAction + , char 'y' ?>>! quitEditor + ] + + noAction = closeBufferAndWindowE + +----------------------------- +-- isearch +selfSearchKeymap :: Keymap +selfSearchKeymap = do + Event (KASCII c) [] <- anyEvent + write . isearchAddE $ T.singleton c + +searchKeymap :: Keymap +searchKeymap = selfSearchKeymap <|> choice + [ -- ("C-g", isearchDelE) -- Only if string is not empty. + ctrl (char 'r') ?>>! isearchPrevE + , ctrl (char 's') ?>>! isearchNextE + , ctrl (char 'w') ?>>! isearchWordE + , meta (char 'p') ?>>! isearchHistory 1 + , meta (char 'n') ?>>! isearchHistory (-1) + , spec KBS ?>>! isearchDelE + ] + +isearchKeymap :: Direction -> Keymap +isearchKeymap dir = + do write $ isearchInitE dir + void $ many searchKeymap + choice [ ctrl (char 'g') ?>>! isearchCancelE + , oneOf [ctrl (char 'm'), spec KEnter] + >>! isearchFinishWithE resetRegexE + ] + <|| write isearchFinishE + +---------------------------- +-- query-replace +queryReplaceE :: YiM () +queryReplaceE = withMinibufferFree "Replace:" $ \replaceWhat -> + withMinibufferFree "With:" $ \replaceWith -> do + b <- gets currentBuffer + win <- use currentWindowA + let repStr = R.fromText replaceWith + replaceKm = + choice [ char 'n' ?>>! qrNext win b re + , char '!' ?>>! qrReplaceAll win b re repStr + , oneOf [char 'y', char ' '] >>! qrReplaceOne win b re repStr + , oneOf [char 'q', ctrl (char 'g')] >>! qrFinish + ] + -- TODO: Yi.Regex to Text + Right re = makeSearchOptsM [] (T.unpack replaceWhat) + question = T.unwords [ "Replacing", replaceWhat + , "with", replaceWith, " (y,n,q,!):" + ] + withEditor $ do + setRegexE re + void $ spawnMinibufferE question (const replaceKm) + qrNext win b re + + +executeExtendedCommandE :: YiM () +executeExtendedCommandE = withMinibuffer "M-x" scope act + where + act = execEditorAction . T.unpack + scope = const $ map T.pack <$> getAllNamesInScope + +evalRegionE :: YiM () +evalRegionE = do + -- FIXME: do something sensible. + void $ withCurrentBuffer (getSelectRegionB >>= readRegionB) + return () + +-- * Code for various commands +-- This ideally should be put in their own module, +-- without a prefix, so M-x ... would be easily implemented +-- by looking up that module's contents + +-- | Insert next character, "raw" +insertNextC :: UnivArgument -> KeymapM () +insertNextC a = do c <- anyEvent + write $ replicateM_ (argToInt a) $ insertB (eventToChar c) + +-- | Convert the universal argument to a number of repetitions +argToInt :: UnivArgument -> Int +argToInt = fromMaybe 1 + + +digit :: (Event -> Event) -> KeymapM Char +digit f = charOf f '0' '9' + +-- TODO: replace tt by digit meta +tt :: KeymapM Char +tt = do + Event (KASCII c) _ <- foldr1 (<|>) $ fmap (event . metaCh ) ['0'..'9'] + return c + + +-- doing the argument precisely is kind of tedious. +-- read: http://www.gnu.org/software/emacs/manual/html_node/Arguments.html +-- and: http://www.gnu.org/software/emacs/elisp-manual/html_node/elisp_318.html +readUniversalArg :: KeymapM (Maybe Int) +readUniversalArg = optional ((ctrlCh 'u' ?>> (read <$> some (digit id) <|> pure 4)) <|> (read <$> some tt)) + + +-- | Finds file and runs specified action on the resulting buffer +findFileAndDo :: T.Text -- ^ Prompt + -> BufferM a -- ^ Action to run on the resulting buffer + -> YiM () +findFileAndDo prompt act = promptFile prompt $ \filename -> do + printMsg $ "loading " <> filename + openingNewFile (T.unpack filename) act + +-- | Open a file using the minibuffer. We have to set up some stuff to +-- allow hints and auto-completion. +findFile :: YiM () +findFile = findFileAndDo "find file:" $ return () + +-- | Like 'findFile' but sets the resulting buffer to read-only. +findFileReadOnly :: YiM () +findFileReadOnly = findFileAndDo "find file (read only):" $ readOnlyA .= True + +-- | Open a file in a new tab using the minibuffer. +findFileNewTab :: YiM () +findFileNewTab = promptFile "find file (new tab): " $ \filename -> do + withEditor newTabE + printMsg $ "loading " <> filename + void . editFile $ T.unpack filename + +scrollDownE :: UnivArgument -> BufferM () +scrollDownE a = case a of + Nothing -> downScreenB + Just n -> scrollB n + +scrollUpE :: UnivArgument -> BufferM () +scrollUpE a = case a of + Nothing -> upScreenB + Just n -> scrollB (negate n) + +-- | Prompts the user for a buffer name and switches to the chosen buffer. +switchBufferE :: YiM () +switchBufferE = promptingForBuffer "switch to buffer:" + (withEditor . switchToBufferE) (\o b -> (b \\ o) ++ o) + + +-- | Prompts the user for a buffer name and kills the chosen buffer. +-- Prompts about really closing if the buffer is marked as changed +-- since last save. +killBufferE :: YiM () +killBufferE = promptingForBuffer "kill buffer:" k (\o b -> o ++ (b \\ o)) + where + k :: BufferRef -> YiM () + k b = do + buf <- withEditor . gets $ findBufferWith b + ch <- deservesSave buf + let askKeymap = choice [ char 'n' ?>>! closeBufferAndWindowE + , char 'y' ?>>! delBuf >> closeBufferAndWindowE + , ctrlCh 'g' ?>>! closeBufferAndWindowE + ] + delBuf = deleteBuffer b + question = identString buf <> " changed, close anyway? (y/n)" + withEditor $ + if ch + then void $ spawnMinibufferE question (const askKeymap) + else delBuf + + +-- | If on separators (space, tab, unicode seps), reduce multiple +-- separators to just a single separator (or however many given +-- through 'UnivArgument'). +-- +-- If we aren't looking at a separator, insert a single space. This is +-- like emacs ‘just-one-space’ but doesn't deal with negative argument +-- case but works with other separators than just space. What counts +-- as a separator is decided by 'isAnySep' modulo @\n@ character. +-- +-- Further, it will only reduce a single type of separator at once: if +-- we have hard tabs followed by spaces, we are able to reduce one and +-- not the other. +justOneSep :: UnivArgument -> BufferM () +justOneSep u = readB >>= \c -> + pointB >>= \point -> case point of + Point 0 -> if isSep c then deleteSeparators else insertMult c + Point x -> + if isSep c + then deleteSeparators + else readAtB (Point $ x - 1) >>= \d -> + -- We weren't looking at separator but there might be one behind us + if isSep d + then moveB Character Backward >> deleteSeparators + else insertMult ' ' -- no separators, insert a space just + -- like emacs does + where + isSep c = c /= '\n' && isAnySep c + insertMult c = insertN $ R.replicateChar (maybe 1 (max 1) u) c + + deleteSeparators = do + genMaybeMoveB unitSepThisLine (Backward, InsideBound) Backward + moveB Character Forward + doIfCharB isSep $ deleteB unitSepThisLine Forward + + + +-- | Join this line to previous (or next N if universal) +joinLinesE :: UnivArgument -> BufferM () +joinLinesE Nothing = return () +joinLinesE (Just _) = do + moveB VLine Forward + moveToSol >> transformB (const " ") Character Backward >> justOneSep Nothing + +-- | Shortcut to use a default list when a blank list is given. +-- Used for default values to emacs queries +maybeList :: [a] -> [a] -> [a] +maybeList def [] = def +maybeList _ ls = ls + +maybeTag :: Tag -> T.Text -> Tag +maybeTag def t = if T.null t then def else Tag t + +-------------------------------------------------- +-- TAGS - See Yi.Tag for more info + +-- | Prompt the user to give a tag and then jump to that tag +promptTag :: YiM () +promptTag = do + -- default tag is where the buffer is on + defaultTag <- withCurrentBuffer $ Tag . R.toText <$> readUnitB unitWord + -- if we have tags use them to generate hints + tagTable <- withEditor getTags + -- Hints are expensive - only lazily generate 10 + let hinter = return . take 10 . maybe (fail . T.unpack) hintTags tagTable + -- Completions are super-cheap. Go wild + let completer = return . maybe id completeTag tagTable + p = "Find tag: (default " <> _unTag defaultTag `T.snoc` ')' + withMinibufferGen "" hinter p completer (const $ return ()) $ + -- if the string is "" use the defaultTag + gotoTag . maybeTag defaultTag + +-- | Opens the file that contains @tag@. Uses the global tag table and prompts +-- the user to open one if it does not exist +gotoTag :: Tag -> YiM () +gotoTag tag = + visitTagTable $ \tagTable -> + case lookupTag tag tagTable of + [] -> printMsg $ "No tags containing " <> _unTag tag + (filename, line):_ -> openingNewFile filename $ gotoLn line + +-- | Call continuation @act@ with the TagTable. Uses the global table +-- and prompts the user if it doesn't exist +visitTagTable :: (TagTable -> YiM ()) -> YiM () +visitTagTable act = do + posTagTable <- withEditor getTags + -- does the tagtable exist? + case posTagTable of + Just tagTable -> act tagTable + Nothing -> promptFile "Visit tags table: (default tags)" $ \path -> do + -- default emacs behavior, append tags + let p = T.unpack path + filename = maybeList "tags" $ takeFileName p + tagTable <- io $ importTagTable $ takeDirectory p filename + withEditor $ setTags tagTable + act tagTable + +-- TODO: use TextUnit to count things inside region for better experience +-- | Counts the number of lines, words and characters inside selected +-- region. Coresponds to emacs' @count-words-region@. +countWordsRegion :: YiM () +countWordsRegion = do + (l, w, c) <- withEditor $ do + t <- withCurrentBuffer $ getRectangle >>= \(reg, _, _) -> readRegionB reg + let nls = R.countNewLines t + return (if nls == 0 then 1 else nls, length $ R.words t, R.length t) + printMsg $ T.unwords [ "Region has", showT l, p l "line" <> "," + , showT w, p w "word" <> ", and" + , showT c, p w "character" <> "." + ] + where + p x w = if x == 1 then w else w <> "s" diff --git a/yi-keymap-emacs.cabal b/yi-keymap-emacs.cabal new file mode 100644 --- /dev/null +++ b/yi-keymap-emacs.cabal @@ -0,0 +1,46 @@ +-- This file has been generated from package.yaml by hpack version 0.14.0. +-- +-- see: https://github.com/sol/hpack + +name: yi-keymap-emacs +version: 0.13 +synopsis: Emacs keymap for Yi editor +category: Yi +homepage: https://github.com/yi-editor/yi#readme +bug-reports: https://github.com/yi-editor/yi/issues +maintainer: Yi developers +license: GPL-2 +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/yi-editor/yi + +library + hs-source-dirs: + src + ghc-options: -Wall -ferror-spans + build-depends: + base >= 4.8 && < 5 + , containers + , filepath + , Hclip + , microlens-platform + , mtl + , oo-prototypes + , semigroups + , text + , transformers-base + , yi-core + , yi-misc-modes + , yi-language + , yi-rope + exposed-modules: + Yi.Config.Default.Emacs + Yi.Keymap.Emacs + Yi.Keymap.Emacs.KillRing + Yi.Keymap.Emacs.Utils + other-modules: + Paths_yi_keymap_emacs + default-language: Haskell2010