module Yi.Keymap
( Action(..)
, emptyAction
, Interact
, KeymapM
, Keymap
, KeymapEndo
, KeymapProcess
, KeymapSet(..)
, topKeymapA
, startInsertKeymapA
, insertKeymapA
, startTopKeymapA
, extractTopKeymap
, modelessKeymapSet
, YiM(..)
, withUI
, unsafeWithEditor
, withGivenBuffer
, withBuffer
, readEditor
, catchDynE
, catchJustE
, handleJustE
, shutdown
, YiAction (..)
, Yi(..)
, YiVar(..)
, write
) where
import Prelude ()
import Yi.Prelude
import Control.Concurrent
import Control.Monad.Reader hiding (mapM_)
import Control.Monad.State hiding (mapM_)
import Control.Exception
import Data.Typeable ()
import Yi.Buffer
import Yi.Config
import Yi.Editor (EditorM, Editor, runEditor, MonadEditor(..))
import Yi.Event
import Yi.Monad ()
import Yi.Process (SubprocessInfo, SubprocessId)
import Yi.UI.Common
import qualified Data.Map as M
import qualified Yi.Editor as Editor
import qualified Yi.Interact as I
import Data.Accessor.Template
data Action = forall a. Show a => YiA (YiM a)
| forall a. Show a => EditorA (EditorM a)
| forall a. Show a => BufferA (BufferM a)
deriving Typeable
emptyAction :: Action
emptyAction = BufferA (return ())
instance I.PEq Action where
equiv _ _ = False
instance Show Action where
show (YiA _) = "@Y"
show (EditorA _) = "@E"
show (BufferA _) = "@B"
type Interact ev a = I.I ev Action a
type KeymapM a = Interact Event a
type Keymap = KeymapM ()
type KeymapEndo = Keymap -> Keymap
type KeymapProcess = I.P Event Action
data Yi = Yi {yiUi :: UI,
input :: Event -> IO (),
output :: [Action] -> IO (),
yiConfig :: Config,
yiVar :: MVar YiVar
}
deriving Typeable
data YiVar = YiVar {yiEditor :: !Editor,
threads :: ![ThreadId],
yiSubprocessIdSupply :: !SubprocessId,
yiSubprocesses :: !(M.Map SubprocessId SubprocessInfo)
}
newtype YiM a = YiM {runYiM :: ReaderT Yi IO a}
deriving (Monad, MonadReader Yi, MonadIO, Typeable, Functor)
instance MonadState Editor YiM where
get = yiEditor <$> (readRef =<< yiVar <$> ask)
put v = flip modifyRef (\x -> x {yiEditor = v}) =<< yiVar <$> ask
instance MonadEditor YiM where
askCfg = yiConfig <$> ask
withEditor f = do
r <- asks yiVar
cfg <- asks yiConfig
liftIO $ unsafeWithEditor cfg r f
write :: (I.MonadInteract m Action ev, YiAction a x, Show x) => a -> m ()
write x = I.write (makeAction x)
withUI :: (UI -> IO a) -> YiM a
withUI = with yiUi
unsafeWithEditor :: Config -> MVar YiVar -> EditorM a -> IO a
unsafeWithEditor cfg r f = modifyMVar r $ \var -> do
let e = yiEditor var
let (e',a) = runEditor cfg f e
e' `seq` a `seq` return (var {yiEditor = e'}, a)
withGivenBuffer :: MonadEditor m => BufferRef -> BufferM a -> m a
withGivenBuffer b f = withEditor (Editor.withGivenBuffer0 b f)
withBuffer :: MonadEditor m => BufferM a -> m a
withBuffer f = withEditor (Editor.withBuffer0 f)
readEditor :: MonadEditor m => (Editor -> a) -> m a
readEditor f = withEditor (gets f)
catchDynE :: Exception exception => YiM a -> (exception -> YiM a) -> YiM a
catchDynE (YiM inner) handler
= YiM $ ReaderT (\r -> catch (runReaderT inner r) (\e -> runReaderT (runYiM $ handler e) r))
catchJustE :: (Exception e) => (e -> Maybe b)
-> YiM a
-> (b -> YiM a)
-> YiM a
catchJustE p (YiM c) h = YiM $ ReaderT (\r -> catchJust p (runReaderT c r) (\b -> runReaderT (runYiM $ h b) r))
handleJustE :: (Exception e) => (e -> Maybe b) -> (b -> YiM a) -> YiM a -> YiM a
handleJustE p h c = catchJustE p c h
shutdown :: YiM ()
shutdown = do ts <- threads <$> readsRef yiVar
liftIO $ mapM_ killThread ts
class YiAction a x | a -> x where
makeAction :: Show x => a -> Action
instance YiAction (IO x) x where
makeAction = YiA . io
instance YiAction (YiM x) x where
makeAction = YiA
instance YiAction (EditorM x) x where
makeAction = EditorA
instance YiAction (BufferM x) x where
makeAction = BufferA
instance YiAction Action () where
makeAction = id
instance I.PEq Event where
equiv = (==)
data KeymapSet = KeymapSet
{ topKeymap :: Keymap
, startInsertKeymap :: Keymap
, insertKeymap :: Keymap
, startTopKeymap :: Keymap
}
$(nameDeriveAccessors ''KeymapSet $ Just.(++ "A"))
extractTopKeymap :: KeymapSet -> Keymap
extractTopKeymap kms = startTopKeymap kms >> forever (topKeymap kms)
modelessKeymapSet :: Keymap -> KeymapSet
modelessKeymapSet k = KeymapSet
{ insertKeymap = k
, startInsertKeymap = return ()
, topKeymap = k
, startTopKeymap = return ()
}