module System.Console.ZipEdit
(
Action(..)
, stdActions
, EditorConf(..)
, edit
) where
import System.IO
import qualified Control.Monad.State as St
import Control.Monad.Reader
data LZipper a = LZ { past :: [a]
, present :: a
, future :: [a]
}
type Context a = Maybe (LZipper a)
instance Functor LZipper where
fmap f (LZ ps pr fs) = LZ (map f ps) (f pr) (map f fs)
integrate :: Context a -> [a]
integrate Nothing = []
integrate (Just (LZ p pr f)) = reverse p ++ [pr] ++ f
differentiate :: [a] -> Context a
differentiate [] = Nothing
differentiate (x:xs) = Just $ LZ [] x xs
back :: Context a -> Context a
back Nothing = Nothing
back z@(Just (LZ [] _ _)) = z
back (Just (LZ (p:ps) pr fs)) = Just $ LZ ps p (pr:fs)
fwd :: Context a -> Context a
fwd Nothing = Nothing
fwd z@(Just (LZ _ _ [])) = z
fwd (Just (LZ ps pr (f:fs))) = Just $ LZ (pr:ps) f fs
modify :: (a -> a) -> Context a -> Context a
modify _ Nothing = Nothing
modify f (Just z) = Just $ z { present = f (present z) }
modifyBack :: (a -> a) -> Context a -> Context a
modifyBack _ Nothing = Nothing
modifyBack f (Just z) = Just $ z { past = map f (past z) }
modifyFwd :: (a -> a) -> Context a -> Context a
modifyFwd _ Nothing = Nothing
modifyFwd f (Just z) = Just $ z { future = map f (future z) }
delete :: Context a -> Context a
delete Nothing = Nothing
delete (Just (LZ [] _ [])) = Nothing
delete (Just (LZ (p:ps) _ [])) = Just $ LZ ps p []
delete (Just (LZ ps _ (f:fs))) = Just $ LZ ps f fs
insback :: a -> Context a -> Context a
insback x Nothing = Just $ LZ [] x []
insback x (Just (LZ ps pr fs)) = Just $ LZ ps x (pr:fs)
insfwd :: a -> Context a -> Context a
insfwd x Nothing = Just $ LZ [] x []
insfwd x (Just (LZ ps pr fs)) = Just $ LZ (pr:ps) x fs
data Action a = Fwd
| Back
| Delete
| Modify (a -> a)
| ModifyFwd (a -> a)
| ModifyBack (a -> a)
| ModifyWInp String (String -> a -> a)
| InsFwd String (String -> a)
| InsBack String (String -> a)
| Output (a -> String)
| Cancel
| Done
| Seq [Action a]
stdActions :: [(Char, Action a)]
stdActions = [ ('j', Fwd)
, ('k', Back)
, ('x', Delete)
, ('q', Cancel)
, ('d', Done)
]
data EditorConf a = EC { display :: a -> String
, prompt :: a -> String
, emptyPrompt :: String
, actions :: [(Char, Action a)]
}
edit :: EditorConf a
-> [a]
-> IO (Maybe [a])
edit ec l = runEditor process ec l
newtype Editor e a = E (ReaderT (EditorConf e) (St.StateT (Context e) IO) a)
deriving (Functor, Monad, St.MonadState (Context e), MonadReader (EditorConf e), MonadIO)
runEditor :: Editor e a -> EditorConf e -> [e] -> IO a
runEditor (E e) ec l = do
hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
St.evalStateT (runReaderT e ec) (differentiate l)
io :: IO a -> Editor e a
io = liftIO
process :: Editor a (Maybe [a])
process = do
c <- St.get
e <- ask
io $ putStr "\n"
case c of
Nothing -> io $ putStr (emptyPrompt e)
(Just z) -> io $ mapM_ (\f -> putStr (f e (present z))) [display, prompt]
ch <- io $ getChar
io $ putStr "\n"
cont <- case lookup ch (actions e) of
Nothing -> return (Just True)
Just act -> doAction act
case cont of
Nothing -> return Nothing
Just True -> process
Just False -> (Just . integrate) `fmap` St.get
doAction :: Action a -> Editor a (Maybe Bool)
doAction Fwd = St.modify fwd >> continue
doAction Back = St.modify back >> continue
doAction Delete = St.modify delete >> continue
doAction (Modify f) = St.modify (modify f) >> continue
doAction (ModifyFwd f) = St.modify (modifyFwd f) >> continue
doAction (ModifyBack f) = St.modify (modifyBack f) >> continue
doAction (ModifyWInp p f) = doModifyPrompt p f >> continue
doAction (InsFwd p f) = doInsPrompt p f >>= St.modify . insfwd >> continue
doAction (InsBack p f) = doInsPrompt p f >>= St.modify . insback >> continue
doAction (Output f) = doOutput f >> continue
doAction Cancel = return Nothing
doAction Done = return (Just False)
doAction (Seq as) = fmap (fmap and . sequence) $ mapM doAction as
continue :: Editor a (Maybe Bool)
continue = return $ Just True
doModifyPrompt :: String -> (String -> e -> e) -> Editor e ()
doModifyPrompt p f = do
io $ putStr p
inp <- io getLine
St.modify (modify $ f inp)
doInsPrompt :: String -> (String -> e) -> Editor e e
doInsPrompt p f = do
io $ putStr p
f `fmap` io getLine
doOutput :: (e -> String) -> Editor e ()
doOutput f = do
c <- St.get
case c of
Nothing -> return ()
Just z -> io $ putStr (f . present $ z)