module System.Console.Haskeline.Command.KillRing where
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Command
import System.Console.Haskeline.Monads
import System.Console.Haskeline.Command.Undo
import Control.Monad
import Data.IORef
data Stack a = Stack [a] [a]
deriving Int -> Stack a -> ShowS
[Stack a] -> ShowS
Stack a -> String
(Int -> Stack a -> ShowS)
-> (Stack a -> String) -> ([Stack a] -> ShowS) -> Show (Stack a)
forall a. Show a => Int -> Stack a -> ShowS
forall a. Show a => [Stack a] -> ShowS
forall a. Show a => Stack a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stack a] -> ShowS
$cshowList :: forall a. Show a => [Stack a] -> ShowS
show :: Stack a -> String
$cshow :: forall a. Show a => Stack a -> String
showsPrec :: Int -> Stack a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Stack a -> ShowS
Show
emptyStack :: Stack a
emptyStack :: Stack a
emptyStack = [a] -> [a] -> Stack a
forall a. [a] -> [a] -> Stack a
Stack [] []
peek :: Stack a -> Maybe a
peek :: Stack a -> Maybe a
peek (Stack [] []) = Maybe a
forall a. Maybe a
Nothing
peek (Stack (x :: a
x:_) _) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
peek (Stack [] ys :: [a]
ys) = Stack a -> Maybe a
forall a. Stack a -> Maybe a
peek ([a] -> [a] -> Stack a
forall a. [a] -> [a] -> Stack a
Stack ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys) [])
rotate :: Stack a -> Stack a
rotate :: Stack a -> Stack a
rotate s :: Stack a
s@(Stack [] []) = Stack a
s
rotate (Stack (x :: a
x:xs :: [a]
xs) ys :: [a]
ys) = [a] -> [a] -> Stack a
forall a. [a] -> [a] -> Stack a
Stack [a]
xs (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
rotate (Stack [] ys :: [a]
ys) = Stack a -> Stack a
forall a. Stack a -> Stack a
rotate ([a] -> [a] -> Stack a
forall a. [a] -> [a] -> Stack a
Stack ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys) [])
push :: a -> Stack a -> Stack a
push :: a -> Stack a -> Stack a
push x :: a
x (Stack xs :: [a]
xs ys :: [a]
ys) = [a] -> [a] -> Stack a
forall a. [a] -> [a] -> Stack a
Stack (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a]
ys
type KillRing = Stack [Grapheme]
runKillRing :: MonadIO m => ReaderT (IORef KillRing) m a -> m a
runKillRing :: ReaderT (IORef KillRing) m a -> m a
runKillRing act :: ReaderT (IORef KillRing) m a
act = do
IORef KillRing
ringRef <- IO (IORef KillRing) -> m (IORef KillRing)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef KillRing) -> m (IORef KillRing))
-> IO (IORef KillRing) -> m (IORef KillRing)
forall a b. (a -> b) -> a -> b
$ KillRing -> IO (IORef KillRing)
forall a. a -> IO (IORef a)
newIORef KillRing
forall a. Stack a
emptyStack
ReaderT (IORef KillRing) m a -> IORef KillRing -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (IORef KillRing) m a
act IORef KillRing
ringRef
pasteCommand :: (Save s, MonadState KillRing m, MonadState Undo m)
=> ([Grapheme] -> s -> s) -> Command m (ArgMode s) s
pasteCommand :: ([Grapheme] -> s -> s) -> Command m (ArgMode s) s
pasteCommand use :: [Grapheme] -> s -> s
use = \s :: ArgMode s
s -> do
Maybe [Grapheme]
ms <- (KillRing -> Maybe [Grapheme])
-> CmdM m KillRing -> CmdM m (Maybe [Grapheme])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM KillRing -> Maybe [Grapheme]
forall a. Stack a -> Maybe a
peek CmdM m KillRing
forall s (m :: * -> *). MonadState s m => m s
get
case Maybe [Grapheme]
ms of
Nothing -> s -> CmdM m s
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> CmdM m s) -> s -> CmdM m s
forall a b. (a -> b) -> a -> b
$ ArgMode s -> s
forall s. ArgMode s -> s
argState ArgMode s
s
Just p :: [Grapheme]
p -> do
(Undo -> Undo) -> CmdM m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Undo -> Undo) -> CmdM m ()) -> (Undo -> Undo) -> CmdM m ()
forall a b. (a -> b) -> a -> b
$ s -> Undo -> Undo
forall s. Save s => s -> Undo -> Undo
saveToUndo (s -> Undo -> Undo) -> s -> Undo -> Undo
forall a b. (a -> b) -> a -> b
$ ArgMode s -> s
forall s. ArgMode s -> s
argState ArgMode s
s
s -> CmdM m s
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState (s -> CmdM m s) -> s -> CmdM m s
forall a b. (a -> b) -> a -> b
$ (s -> s) -> ArgMode s -> s
forall s. (s -> s) -> ArgMode s -> s
applyArg ([Grapheme] -> s -> s
use [Grapheme]
p) ArgMode s
s
deleteFromDiff' :: InsertMode -> InsertMode -> ([Grapheme],InsertMode)
deleteFromDiff' :: InsertMode -> InsertMode -> ([Grapheme], InsertMode)
deleteFromDiff' (IMode xs1 :: [Grapheme]
xs1 ys1 :: [Grapheme]
ys1) (IMode xs2 :: [Grapheme]
xs2 ys2 :: [Grapheme]
ys2)
| Int
posChange Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 = (Int -> [Grapheme] -> [Grapheme]
forall a. Int -> [a] -> [a]
take Int
posChange [Grapheme]
ys1, [Grapheme] -> [Grapheme] -> InsertMode
IMode [Grapheme]
xs1 [Grapheme]
ys2)
| Bool
otherwise = (Int -> [Grapheme] -> [Grapheme]
forall a. Int -> [a] -> [a]
take (Int -> Int
forall a. Num a => a -> a
negate Int
posChange) [Grapheme]
ys2 ,[Grapheme] -> [Grapheme] -> InsertMode
IMode [Grapheme]
xs2 [Grapheme]
ys1)
where
posChange :: Int
posChange = [Grapheme] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Grapheme]
xs2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Grapheme] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Grapheme]
xs1
killFromHelper :: (MonadState KillRing m, MonadState Undo m,
Save s, Save t)
=> KillHelper -> Command m s t
killFromHelper :: KillHelper -> Command m s t
killFromHelper helper :: KillHelper
helper = Command m s s
forall s (m :: * -> *).
(Save s, MonadState Undo m) =>
Command m s s
saveForUndo Command m s s -> Command m s t -> Command m s t
forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> Command m t u -> Command m s u
>|> \oldS :: s
oldS -> do
let (gs :: [Grapheme]
gs,newIM :: InsertMode
newIM) = KillHelper -> InsertMode -> ([Grapheme], InsertMode)
applyHelper KillHelper
helper (s -> InsertMode
forall s. Save s => s -> InsertMode
save s
oldS)
(KillRing -> KillRing) -> CmdM m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ([Grapheme] -> KillRing -> KillRing
forall a. a -> Stack a -> Stack a
push [Grapheme]
gs)
Command m t t
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState (InsertMode -> t
forall s. Save s => InsertMode -> s
restore InsertMode
newIM)
killFromArgHelper :: (MonadState KillRing m, MonadState Undo m, Save s, Save t)
=> KillHelper -> Command m (ArgMode s) t
killFromArgHelper :: KillHelper -> Command m (ArgMode s) t
killFromArgHelper helper :: KillHelper
helper = Command m (ArgMode s) (ArgMode s)
forall s (m :: * -> *).
(Save s, MonadState Undo m) =>
Command m s s
saveForUndo Command m (ArgMode s) (ArgMode s)
-> Command m (ArgMode s) t -> Command m (ArgMode s) t
forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> Command m t u -> Command m s u
>|> \oldS :: ArgMode s
oldS -> do
let (gs :: [Grapheme]
gs,newIM :: InsertMode
newIM) = KillHelper -> ArgMode InsertMode -> ([Grapheme], InsertMode)
applyArgHelper KillHelper
helper ((s -> InsertMode) -> ArgMode s -> ArgMode InsertMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> InsertMode
forall s. Save s => s -> InsertMode
save ArgMode s
oldS)
(KillRing -> KillRing) -> CmdM m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ([Grapheme] -> KillRing -> KillRing
forall a. a -> Stack a -> Stack a
push [Grapheme]
gs)
Command m t t
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState (InsertMode -> t
forall s. Save s => InsertMode -> s
restore InsertMode
newIM)
copyFromArgHelper :: (MonadState KillRing m, Save s)
=> KillHelper -> Command m (ArgMode s) s
copyFromArgHelper :: KillHelper -> Command m (ArgMode s) s
copyFromArgHelper helper :: KillHelper
helper = \oldS :: ArgMode s
oldS -> do
let (gs :: [Grapheme]
gs,_) = KillHelper -> ArgMode InsertMode -> ([Grapheme], InsertMode)
applyArgHelper KillHelper
helper ((s -> InsertMode) -> ArgMode s -> ArgMode InsertMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> InsertMode
forall s. Save s => s -> InsertMode
save ArgMode s
oldS)
(KillRing -> KillRing) -> CmdM m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ([Grapheme] -> KillRing -> KillRing
forall a. a -> Stack a -> Stack a
push [Grapheme]
gs)
Command m s s
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState (ArgMode s -> s
forall s. ArgMode s -> s
argState ArgMode s
oldS)
data KillHelper = SimpleMove (InsertMode -> InsertMode)
| GenericKill (InsertMode -> ([Grapheme],InsertMode))
killAll :: KillHelper
killAll :: KillHelper
killAll = (InsertMode -> ([Grapheme], InsertMode)) -> KillHelper
GenericKill ((InsertMode -> ([Grapheme], InsertMode)) -> KillHelper)
-> (InsertMode -> ([Grapheme], InsertMode)) -> KillHelper
forall a b. (a -> b) -> a -> b
$ \(IMode xs :: [Grapheme]
xs ys :: [Grapheme]
ys) -> ([Grapheme] -> [Grapheme]
forall a. [a] -> [a]
reverse [Grapheme]
xs [Grapheme] -> [Grapheme] -> [Grapheme]
forall a. [a] -> [a] -> [a]
++ [Grapheme]
ys, InsertMode
emptyIM)
applyHelper :: KillHelper -> InsertMode -> ([Grapheme],InsertMode)
applyHelper :: KillHelper -> InsertMode -> ([Grapheme], InsertMode)
applyHelper (SimpleMove move :: InsertMode -> InsertMode
move) im :: InsertMode
im = InsertMode -> InsertMode -> ([Grapheme], InsertMode)
deleteFromDiff' InsertMode
im (InsertMode -> InsertMode
move InsertMode
im)
applyHelper (GenericKill act :: InsertMode -> ([Grapheme], InsertMode)
act) im :: InsertMode
im = InsertMode -> ([Grapheme], InsertMode)
act InsertMode
im
applyArgHelper :: KillHelper -> ArgMode InsertMode -> ([Grapheme],InsertMode)
applyArgHelper :: KillHelper -> ArgMode InsertMode -> ([Grapheme], InsertMode)
applyArgHelper (SimpleMove move :: InsertMode -> InsertMode
move) im :: ArgMode InsertMode
im = InsertMode -> InsertMode -> ([Grapheme], InsertMode)
deleteFromDiff' (ArgMode InsertMode -> InsertMode
forall s. ArgMode s -> s
argState ArgMode InsertMode
im) ((InsertMode -> InsertMode) -> ArgMode InsertMode -> InsertMode
forall s. (s -> s) -> ArgMode s -> s
applyArg InsertMode -> InsertMode
move ArgMode InsertMode
im)
applyArgHelper (GenericKill act :: InsertMode -> ([Grapheme], InsertMode)
act) im :: ArgMode InsertMode
im = InsertMode -> ([Grapheme], InsertMode)
act (ArgMode InsertMode -> InsertMode
forall s. ArgMode s -> s
argState ArgMode InsertMode
im)