module Buchhaltung.ZipEdit2
(
Action(..)
, stdActions
, (??)
, EditorConf(..)
, edit
, LCont(..)
, editWCont
, Zipper(..)
, integrate
, differentiate
, fwd, back
, LState(..)
) where
import Buchhaltung.Zipper
import Control.Arrow
import Control.Monad.RWS.Strict
import qualified Data.List.NonEmpty as E
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.Directory (removeFile)
import System.IO
import System.Process
data LCont a = LC (IO ([a], Maybe (LCont a)))
data LState a b = LS { ctx :: Zipper a
, cont :: Maybe (LCont a)
, userSt :: b
}
doModifyAllM :: Monad m => (Zipper e -> m (Zipper e)) -> Editor e u m ()
doModifyAllM m = do
s <- get
lift (m $ ctx s) >>= modifyCtx . const
doModifyStateM :: Monad m => (LState e u -> m (LState e u)) -> Editor e u m ()
doModifyStateM m = do
get >>= (lift . m) >>= put
data Action m a u = Comp (Action m a u) (Action m a u) |
Fwd
| Back
| Delete
| Modify (a -> a)
| ModifyState (LState a u -> LState a u)
| ModifyStateM (LState a u -> m (LState a u))
| ModifyAllM (Zipper a -> m (Zipper a))
| ModifyAll (Zipper a -> Zipper a)
| ModifyM (a -> m a)
| ModifyFwd ([a] -> [a])
| ModifyBack ([a] -> [a])
| ModifyWInp String (String -> a -> a)
| ModifyWEditor (a -> String) (String -> a -> a)
| InsFwd String (String -> a)
| InsBack String (String -> a)
| Output (a -> String)
| Cancel
| Done (LState a u -> m (Maybe (LState a u)))
| Seq [Action m a u]
| Help String (Action m a u)
instance Monoid (Action m a u) where
mappend = Comp
mempty = Seq []
(??) :: Action m a u -> String -> Action m a u
(??) = flip Help
stdActions :: Monad m => [(Char, Action m a u)]
stdActions = [ ('j', Fwd ?? "Move forward one item.")
, ('k', Back ?? "Move backward one item.")
, ('x', Delete ?? "Delete the current item.")
, ('q', Cancel ?? "Cancel the current editing session.")
, ('d', Done (return . Just) ?? "Complete the current editing session.")
]
data EditorConf m a u = EC { display :: LState a u -> m T.Text
, ecPrompt :: Zipper a -> String
, actions :: [(Char, Action m a u)]
, getchar :: Maybe (IO Char)
}
newtype Editor e userState m a = E (RWST
(EditorConf m e userState) ()
(LState e userState) m a)
deriving (Functor, Monad, Applicative
, MonadWriter ()
, MonadState (LState e userState)
, MonadReader (EditorConf m e userState)
, MonadRWS (EditorConf m e userState) () (LState e userState)
, MonadIO)
instance MonadTrans (Editor e userState) where
lift = E . lift
io :: MonadIO m => IO a -> m a
io = liftIO
runEditor :: MonadIO m => Editor e u m a -> EditorConf m e u -> E.NonEmpty e ->
Maybe (LCont e) -> u -> (Zipper e -> Zipper e) -> m a
runEditor (E e) ec l c userState mod = do
io $ do hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
fst <$> evalRWST e ec (LS (mod $ differentiate l) c userState)
modifyCtx :: Monad m => (Zipper e -> Zipper e) -> Editor e u m ()
modifyCtx f = do
LS a b u <- get
put (LS (f a) b u)
edit :: MonadIO m => EditorConf m a u
-> u
-> E.NonEmpty a
-> (Zipper a -> Zipper a)
-> m (Maybe (u,[a]))
edit ec u l mod = runEditor process ec l Nothing u mod
editWCont :: MonadIO m => EditorConf m a u
-> E.NonEmpty a
-> u
-> IO ([a], Maybe (LCont a))
-> (Zipper a -> Zipper a)
-> m (Maybe (u,[a]))
editWCont ec l u c mod = runEditor process ec l (Just (LC c)) u mod
process :: MonadIO m => Editor a u m (Maybe (u,[a]))
process = do
s <- get
e <- ask
let cur = ctx s
display' <- lift $ display e s
ch <- io $ do putStr "\n"
T.putStr display'
putStr (ecPrompt e cur)
maybe getChar id $ getchar e
io $ putStr "\n"
res <- if ch == '?'
then showHelp (actions e) >> continue
else case lookup ch (actions e) of
Nothing -> return (Just True)
Just act -> doAction act
case res of
Nothing -> return Nothing
Just True -> process
Just False -> Just . (userSt &&& (integrate . ctx)) <$> get
showHelp :: MonadIO m => [(Char, Action m a u)] -> Editor a u m ()
showHelp cs = io $ mapM_ (putStrLn . showCmdHelp) (helpCmd:cs)
where helpCmd = ('?', Fwd ?? "Show this help.")
showCmdHelp (c, Help s _) = c : (" - " ++ s)
showCmdHelp (c, _) = c : " -"
doAction :: MonadIO m => Action m a u -> Editor a u m (Maybe Bool)
doAction Fwd = doFwd >> continue
doAction Back = modifyCtx back >> continue
doAction Delete = modifyCtx delete >> continue
doAction (Modify f) = modifyCtx (modifyPresent f) >> continue
doAction (ModifyM m) = doModifyM m >> continue
doAction (ModifyFwd f) = modifyCtx (modifyFwd f) >> continue
doAction (ModifyAll f) = modifyCtx f >> continue
doAction (ModifyAllM f) = doModifyAllM f >> continue
doAction (ModifyState f) = modify f >> continue
doAction (ModifyStateM f) = doModifyStateM f >> continue
doAction (ModifyBack f) = modifyCtx (modifyBack f) >> continue
doAction (ModifyWInp p f) = doModifyPrompt p f >> continue
doAction (ModifyWEditor f g) = doModifyWithEditor f g >> continue
doAction (InsFwd p f) = doInsPrompt p f >>= modifyCtx . insfwd >> continue
doAction (InsBack p f) = doInsPrompt p f >>= modifyCtx . insback >> continue
doAction (Output f) = doOutput f >> continue
doAction Cancel = doCancel
doAction (Comp a b) = doAction a >> doAction b
doAction (Done f) = doQuit f
doAction (Seq as) = fmap (fmap and . sequence) $ mapM doAction as
doAction (Help _ a) = doAction a
continue :: Monad m => Editor a u m (Maybe Bool)
continue = return $ Just True
doQuit :: MonadIO m
=> (LState a u -> m (Maybe (LState a u)))
-> Editor a u m (Maybe Bool)
doQuit f = do s <-get
(lift $ f s) >>= maybe (return (Just True)) ((>> quit) . put)
where quit = io $ yesNo "Save? [y/N] "
(Just False)
(Just True)
doCancel :: MonadIO m => Editor a u m (Maybe Bool)
doCancel = io $
yesNo "Discard all edits, are you SURE? [y/N] "
Nothing
(Just True)
yesNo :: String
-> a -> a -> IO a
yesNo q a b = do putStr q
x <- getChar
return $ if x `elem` ("yY"::String) then a else b
doFwd :: MonadIO m => Editor e u m ()
doFwd = do
LS{ctx=z,cont=s} <- get
case (future z, s) of
([], Just (LC c)) -> do (newElts, cont') <- io c
modifyCtx (fwd . modifyFwd (++newElts))
(LS l _ u) <- get
put (LS l cont' u)
([], Nothing) -> return ()
_ -> modifyCtx fwd
doModifyM :: Monad m => (e -> m e) -> Editor e u m ()
doModifyM m = do
pr <- gets $ present . ctx
lift (m pr) >>= modifyCtx . modifyPresent . const
doModifyPrompt :: MonadIO m => String -> (String -> e -> e) -> Editor e u m ()
doModifyPrompt p f = do
io $ putStr p
inp <- io getLine
modifyCtx (modifyPresent $ f inp)
doModifyWithEditor :: MonadIO m =>
(e -> String) -> (String -> e -> e) -> Editor e u m ()
doModifyWithEditor toStr fromStr = do
pr <- gets $ present . ctx
editTmpFile pr >>= modifyCtx . modifyPresent . fromStr
where editTmpFile z = io $ do
(tmp,h) <- openTempFile "/tmp" "zipedit.txt"
hPutStr h $ toStr z
hClose h
_ <- system $ "$EDITOR " ++ tmp
txt <- readFile tmp
removeFile tmp
return txt
doInsPrompt :: MonadIO m => String -> (String -> e) -> Editor e u m e
doInsPrompt p f = do
io $ putStr p
f `fmap` io getLine
doOutput :: MonadIO m => (e -> String) -> Editor e u m ()
doOutput f = do
io . putStr . f =<< gets (present . ctx)