content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  System.Console.ZipEdit
  -- Copyright   :  (c) 2008  Brent Yorgey
  -- License     :  BSD-style (see LICENSE)
  --
  -- Maintainer  :  <byorgey@gmail.com>
  -- Stability   :  unstable
  -- Portability :  unportable
  --
  -- A library for creating simple interactive list editors, using a
  -- zipper to allow the user to navigate forward and back within the
  -- list and edit the list elements.
  -----------------------------------------------------------------------------
  
  
  module Buchhaltung.ZipEdit2
    (
      -- * Example usage
      -- $sample
  
      -- * Interface
  
      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
  
  {- $sample
  
  Here is a simple example of using the ZipEdit library:
  
  > module Main where
  >
  > import System.Console.ZipEdit
  >
  > myEd = EC { display = const ""
  >           , ecPrompt  = \n -> maybe "" show n ++ "? "
  >           , actions = [ ('+', Modify (+1) ?? "Increment the current number.")
  >                       , ('i', InsFwd "Value to insert: " read ?? "Insert a number.")
  >                       ]
  >                       ++ stdActions
  >           }
  >
  > main = do
  >   mxs <- edit myEd [1..10]
  >   case mxs of
  >     Nothing -> putStrLn "Canceled."
  >     Just xs -> putStrLn ("Final edited version: " ++ show xs)
  
  A session with this program might look something like this:
  
  > $ test
  >
  > 1? k
  >
  > 1? j
  >
  > 2? j
  >
  > 3? +
  >
  > 4? +
  >
  > 5? j
  >
  > 4? i
  > Value to insert: 98
  >
  > 98? d
  > Final edited version: [1,2,5,4,98,5,6,7,8,9,10]
  
  For more sophisticated examples, see @planethaskell.hs@ and @gmane.hs@ in
  <http://code.haskell.org/~byorgey/code/hwn/utils>.
  
  -}
  
  -- | A continuation which can compute more of the list, along with
  --   (maybe) another continuation.
  data LCont a = LC (IO ([a], Maybe (LCont a)))
  
  -- | The state of the editor consists of a current context, as well as
  --   an optional continuation which can compute more list elements.
  data LState a b = LS { ctx  :: Zipper a
                       , cont :: Maybe (LCont a)
                       , userSt :: b
                     }
  
  -- | Perform a ModifyAllM action by running the given IO action and
  -- | using it to replace all elements.
  doModifyAllM :: Monad m => (Zipper e -> m (Zipper e)) -> Editor e u m ()
  doModifyAllM m = do
    s <- get
    lift (m $ ctx s) >>= modifyCtx . const
    
  -- | Perform a ModifyAllM action by running the given IO action and
  -- | using it to replace all elements.
  doModifyStateM :: Monad m => (LState e u -> m (LState e u)) -> Editor e u m ()
  doModifyStateM m = do
    get >>= (lift . m) >>= put
                         
  
  -- | Actions that can be taken by an editor in response to
  --   user input.
  data Action m a u = Comp (Action m a u) (Action m a u) | 
    Fwd                 -- ^ move forward one item.
                | Back                -- ^ move back one item.
                | Delete              -- ^ delete the current item.
                | Modify (a -> a)     -- ^ modify the current item by applying
                                      --   the given function.
                | ModifyState (LState a u -> LState a u)
                                      -- ^ modify complete state
                | ModifyStateM (LState a u -> m (LState a u))
                                      -- ^ modify complete state with IO.
                | ModifyAllM (Zipper a -> m (Zipper a))
                                      -- ^ modify everything with IO.
                | ModifyAll (Zipper a -> Zipper a)
                                      -- ^ modify everything.
                | ModifyM (a -> m a)
                                      -- ^ modify the current item by
                                      --   applying the given function,
                                      --   which gives its result in the
                                      --   IO monad.
                | ModifyFwd ([a] -> [a])
                                      -- ^ modify items following
                                      --   the current item by applying
                                      --   the given function.
                | ModifyBack ([a] -> [a])
                                      -- ^ modify items before the
                                      --   current item by applying the
                                      --   given function.
                | ModifyWInp String (String -> a -> a)
                                      -- ^ Using the given string as a
                                      --   prompt, obtain a line of user
                                      --   input, and apply the given
                                      --   function to the user input to
                                      --   obtain a function for
                                      --   modifying the current item.
                | ModifyWEditor (a -> String) (String -> a -> a)
                                      -- ^ Run the first function on the
                                      --   current item to produce a
                                      --   string, and open an editor
                                      --   (using the $EDITOR
                                      --   environment variable) on that
                                      --   string.  After the user is
                                      --   done editing, pass the
                                      --   resulting string to the
                                      --   second function to obtain a
                                      --   function for modifying the
                                      --   current element.
                | InsFwd String (String -> a)
                                      -- ^ Using the given string as a
                                      --   prompt, obtain a line of user
                                      --   input, and apply the given
                                      --   function to the user input to
                                      --   obtain a new item, which
                                      --   should be inserted forward of
                                      --   the current item.  The
                                      --   inserted item becomes the new
                                      --   current item.
                | InsBack String (String -> a)
                                      -- ^ Similar to InsFwd, except
                                      --   that the new item is inserted
                                      --   before the old current item.
                | Output (a -> String)
                                      -- ^ output a string which is a
                                      --   function of the current item.
                | Cancel              -- ^ cancel the editing session.
                | Done (LState a u -> m (Maybe (LState a u)))
                                        -- ^ complete the editing
                                        -- session, but if te function evaluates
                                        -- to "Just" and the suer
                                        -- answers y. In this case
                                        -- return the functions result.
                | Seq [Action m a u]      -- ^ perform a sequence of actions.
                | Help String (Action m a u)
                                      -- ^ an action annotated with a
                                      --   help string.
  
  instance Semigroup (Action m a u) where
    (<>) = Comp
  
  instance Monoid (Action m a u) where
    mempty = Seq []
                
  -- | Annotate a command with a help string.
  (??) :: Action m a u -> String -> Action m a u
  (??) = flip Help
  
  -- | Some standard actions which can be used in constructing editor
  --   configurations. The actions are: j - Fwd, k - Back, x -
  --   Delete, q - Cancel, d - Done.
  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.")
               ]
  
  -- | A configuration record determining the behavior of the editor.
  data EditorConf m a u = EC { display     :: LState a u -> m T.Text
                             -- ^ How to display info about the current state.
                             , ecPrompt      :: Zipper a -> String
                               -- ^ How to display info about the all elements.
                             , actions     :: [(Char, Action m a u)]
                               -- ^ A list specifying the actions to take
                               -- in response to user inputs.
                             , getchar :: Maybe (IO Char)
                             -- ^ optional different getChar implementation
                             }
  
  -- | Editor monad: a reader monad with the editor configuration, plus
  -- | a state monad for storing the context, plus IO for interacting
  -- | with the user.
  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
  
  -- | Convenient shorthand for liftIO.
  io :: MonadIO m => IO a -> m a
  io = liftIO
  
  -- | Run an action in the Editor monad, given an editor configuration,
  -- | a starting list, and an optional continuation.
  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)
  
  -- | Lift a pure function on a context into a state modification
  -- | action in the Editor monad.
  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)
  
  -- | Run the given editor on the given list, returning @Nothing@ if
  --   the user canceled the editing process, or @Just l@ if the editing
  --   process completed successfully, where @l@ is the final state of
  --   the list being edited.
  edit :: MonadIO m => EditorConf m a u       -- ^ editor configuration
       -> u            -- ^ initial userState
       -> E.NonEmpty a                -- ^ the list to edit
       -> (Zipper a -> Zipper a) -- ^ startupModifier
       -> m (Maybe (u,[a]))
  edit ec u l mod = runEditor process ec l Nothing u mod
  
  -- | Like 'edit', but with an additional parameter for a continuation
  -- | which can be run to compute additional list elements and
  -- | (optionally) another continuation.
  editWCont :: MonadIO m => EditorConf m a u
            -> E.NonEmpty a                -- ^ the list to edit
            -> u            -- ^ initial userState
            -> IO ([a], Maybe (LCont a))
            -> (Zipper a -> Zipper a) -- ^ startupModifier
            -> m (Maybe (u,[a]))
  editWCont ec l u c mod = runEditor process ec l (Just (LC c)) u mod
  
  -- | The main Editor action implementing a zipedit-created interface.
  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: Nothing = cancel, Just True = continue, Just False = done
    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
  
  -- | Display any help annotations provided by the user.
  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 : " -"
  
  -- | Perform an action, returning an indication of the status: Nothing
  -- | indicates cancellation of the editing process; Just True
  -- | indicates that processing should continue; Just False indicates
  -- | that processing is complete.
  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)  -- quit with result
                 (Just True)   -- continue editing
  
  -- | Prompt the user to confirm a cancel.
  doCancel :: MonadIO m => Editor a u m (Maybe Bool)
  doCancel = io $ 
    yesNo "Discard all edits, are you SURE? [y/N] "
    Nothing      -- quit with nothing
    (Just True)  -- continue editing
  
  -- Ask yesNo question
  yesNo :: String -- ^ question
           -> a -> a -> IO a
  yesNo q a b = do putStr q
                   x <- getChar
                   return $ if x `elem` ("yY"::String) then a else b
  
  -- | Move the focus one element forward, unless we are at the end of
  -- | the list.  If we are at the end of a list and there is a
  -- | continuation, run it and append the generated elements, moving to
  -- | the first of the new elements; otherwise do nothing.
  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
  
  -- | Perform a ModifyM action by running the given IO action and
  -- | using it to replace the currently focused element.
  doModifyM :: Monad m => (e -> m e) -> Editor e u m ()
  doModifyM m = do
    pr <- gets $ present . ctx 
    lift (m pr) >>= modifyCtx . modifyPresent . const
  
  -- | Perform a ModifyWInp action by prompting the user and using their
  -- | input to modify the currently focused element.
  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
  
  -- | Prompt the user, convert their input to an element, and return
  -- | the element.
  doInsPrompt :: MonadIO m => String -> (String -> e) -> Editor e u m e
  doInsPrompt p f = do
    io $ putStr p
    f `fmap` io getLine
  
  -- | Output a function of the currently focused element.
  doOutput :: MonadIO m => (e -> String) -> Editor e u m ()
  doOutput f = do
    io . putStr . f =<< gets (present . ctx)
  