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

-- standard trick for a purely functional queue:
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 (a
x:[a]
_) [a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
peek (Stack [] [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 (a
x:[a]
xs) [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 [] [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 a
x (Stack [a]
xs [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 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 [Grapheme] -> s -> s
use = \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
        Maybe [Grapheme]
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 [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 [Grapheme]
xs1 [Grapheme]
ys1) (IMode [Grapheme]
xs2 [Grapheme]
ys2)
    | Int
posChange Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
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 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
>|> \s
oldS -> do
    let ([Grapheme]
gs,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 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
>|> \ArgMode s
oldS -> do
    let ([Grapheme]
gs,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 KillHelper
helper = \ArgMode s
oldS -> do
    let ([Grapheme]
gs,InsertMode
_) = 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))
        -- a generic kill gives more flexibility, but isn't repeatable.
        -- for example: dd,cc, %

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 [Grapheme]
xs [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 InsertMode -> InsertMode
move) InsertMode
im = InsertMode -> InsertMode -> ([Grapheme], InsertMode)
deleteFromDiff' InsertMode
im (InsertMode -> InsertMode
move InsertMode
im)
applyHelper (GenericKill InsertMode -> ([Grapheme], InsertMode)
act) InsertMode
im = InsertMode -> ([Grapheme], InsertMode)
act InsertMode
im

applyArgHelper :: KillHelper -> ArgMode InsertMode -> ([Grapheme],InsertMode)
applyArgHelper :: KillHelper -> ArgMode InsertMode -> ([Grapheme], InsertMode)
applyArgHelper (SimpleMove InsertMode -> InsertMode
move) 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 InsertMode -> ([Grapheme], InsertMode)
act) ArgMode InsertMode
im = InsertMode -> ([Grapheme], InsertMode)
act (ArgMode InsertMode -> InsertMode
forall s. ArgMode s -> s
argState ArgMode InsertMode
im)