{-# 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 :: ConfigM ()
configureEmacs = do
  (UIConfig -> Identity UIConfig) -> Config -> Identity Config
Lens' Config UIConfig
configUIA ((UIConfig -> Identity UIConfig) -> Config -> Identity Config)
-> (UIConfig -> UIConfig) -> ConfigM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((Maybe ScrollStyle -> Identity (Maybe ScrollStyle))
-> UIConfig -> Identity UIConfig
Lens' UIConfig (Maybe ScrollStyle)
configScrollStyleA ((Maybe ScrollStyle -> Identity (Maybe ScrollStyle))
 -> UIConfig -> Identity UIConfig)
-> Maybe ScrollStyle -> UIConfig -> UIConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScrollStyle -> Maybe ScrollStyle
forall a. a -> Maybe a
Just ScrollStyle
SnapToCenter)
  (KeymapSet -> Identity KeymapSet) -> Config -> Identity Config
Lens' Config KeymapSet
defaultKmA ((KeymapSet -> Identity KeymapSet) -> Config -> Identity Config)
-> KeymapSet -> ConfigM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= KeymapSet
keymap
  ([Action] -> Identity [Action]) -> Config -> Identity Config
Lens' Config [Action]
startActionsA (([Action] -> Identity [Action]) -> Config -> Identity Config)
-> ([Action] -> [Action]) -> ConfigM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (YiM () -> Action
forall a x. (YiAction a x, Show x) => a -> Action
makeAction YiM ()
openScratchBuffer Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:)
  (P Event Event -> Identity (P Event Event))
-> Config -> Identity Config
Lens' Config (P Event Event)
configInputPreprocessA ((P Event Event -> Identity (P Event Event))
 -> Config -> Identity Config)
-> P Event Event -> ConfigM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= P Event Event
escToMeta
  (Bool -> Identity Bool) -> Config -> Identity Config
Lens' Config Bool
configKillringAccumulateA ((Bool -> Identity Bool) -> Config -> Identity Config)
-> Bool -> ConfigM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True

-- | Input preprocessor: Transform Esc;Char into Meta-Char
-- Useful for emacs lovers ;)
escToMeta :: P Event Event
escToMeta :: P Event Event
escToMeta = I Event Event Any -> P Event Event
forall w ev a. Eq w => I ev w a -> P ev w
mkAutomaton (I Event Event Any -> P Event Event)
-> I Event Event Any -> P Event Event
forall a b. (a -> b) -> a -> b
$ I Event Event () -> I Event Event Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (I Event Event () -> I Event Event Any)
-> I Event Event () -> I Event Event Any
forall a b. (a -> b) -> a -> b
$ (I Event Event Event
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
m event
anyEvent I Event Event Event
-> (Event -> I Event Event ()) -> I Event Event ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Event -> I Event Event ()
forall (m :: * -> *) w e. MonadInteract m w e => w -> m ()
write) I Event Event () -> I Event Event () -> I Event Event ()
forall (f :: * -> *) w e a.
MonadInteract f w e =>
f a -> f a -> f a
||> do
    Event
_ <- Event -> I Event Event Event
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
event -> m event
event (Key -> Event
spec Key
KEsc)
    Char
c <- I Event Event Char
forall (m :: * -> *) w.
(MonadFail m, MonadInteract m w Event) =>
m Char
printableChar
    Event -> I Event Event ()
forall (m :: * -> *) w e. MonadInteract m w e => w -> m ()
write (Key -> [Modifier] -> Event
Event (Char -> Key
KASCII Char
c) [Modifier
MMeta])

-- | Open an emacs-like scratch buffer if no file is open.
openScratchBuffer :: YiM ()
openScratchBuffer :: YiM ()
openScratchBuffer = EditorM () -> YiM ()
forall (m :: * -> *) a. MonadEditor m => EditorM a -> m a
withEditor (EditorM () -> YiM ()) -> EditorM () -> YiM ()
forall a b. (a -> b) -> a -> b
$ do
  Bool
fileBufOpen <- (FBuffer -> Bool) -> [FBuffer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any FBuffer -> Bool
isFileOrDir ([FBuffer] -> Bool)
-> (Map BufferRef FBuffer -> [FBuffer])
-> Map BufferRef FBuffer
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map BufferRef FBuffer -> [FBuffer]
forall k a. Map k a -> [a]
M.elems (Map BufferRef FBuffer -> Bool)
-> EditorM (Map BufferRef FBuffer) -> EditorM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Map BufferRef FBuffer) Editor (Map BufferRef FBuffer)
-> EditorM (Map BufferRef FBuffer)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Map BufferRef FBuffer) Editor (Map BufferRef FBuffer)
Lens' Editor (Map BufferRef FBuffer)
buffersA
  Bool -> EditorM () -> EditorM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
fileBufOpen (EditorM () -> EditorM ()) -> EditorM () -> EditorM ()
forall a b. (a -> b) -> a -> b
$
    EditorM BufferRef -> EditorM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (EditorM BufferRef -> EditorM ())
-> (YiString -> EditorM BufferRef) -> YiString -> EditorM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BufferId -> YiString -> EditorM BufferRef
newBufferE (Text -> BufferId
MemBuffer Text
"scratch") (YiString -> EditorM ()) -> YiString -> EditorM ()
forall a b. (a -> b) -> a -> b
$ [YiString] -> YiString
R.unlines
            [ YiString
"This buffer is for notes you don't want to save."
            , YiString
"If you want to create a file, open that file,"
            , YiString
"then enter the text in that file's own buffer."
            , YiString
""
            ]
  where
    isFileOrDir :: FBuffer -> Bool
    isFileOrDir :: FBuffer -> Bool
isFileOrDir FBuffer
attrs = case FBuffer
attrs FBuffer -> Getting BufferId FBuffer BufferId -> BufferId
forall s a. s -> Getting a s a -> a
^. Getting BufferId FBuffer BufferId
forall c. HasAttributes c => Lens' c BufferId
identA of
      MemBuffer  Text
_ -> FBuffer
attrs FBuffer -> Getting Bool FBuffer Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool FBuffer Bool
forall c. HasAttributes c => Lens' c Bool
directoryContentA
      FileBuffer FilePath
_ -> Bool
True