{-# 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 Monoid (Action m a u) where
  mappend = Comp
  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)