{-# 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 System.Console.ZipEdit
  (
    -- * Example usage
    -- $sample

    -- * Interface

    Action(..)
  , stdActions
  , EditorConf(..)
  , edit

  ) where

import System.IO

import qualified Control.Monad.State as St
import Control.Monad.Reader

{- TODO.

   Ability to use context in prompts etc.?
-}

{- $sample

Here is a simple example of using the ZipEdit library:

> module Main where
>
> import System.Console.ZipEdit
>
> myEd = EC { display = const ""
>           , prompt  = \n -> show n ++ "? "
>           , emptyPrompt = "? "
>           , actions = [ ('+', Modify (+1))
>                       , ('i', InsFwd "Value to insert: " read)
>                       ]
>                       ++ 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 a slightly more sophisticated example, see @planethaskell.hs@ in
<http://code.haskell.org/~byorgey/code/hwn/utils>.

-}

-- | List zipper.
data LZipper a = LZ { past    :: [a]
                    , present :: a
                    , future  :: [a]
                    }

-- | A context includes the possibility of an empty list.
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

-- | Actions that can be taken by an editor in response to
--   user input.
data Action a = 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.
              | ModifyFwd (a -> a)  -- ^ modify all items following
                                    --   the current item by applying
                                    --   the given function.
              | ModifyBack (a -> a) -- ^ modify all 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.
              | 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                -- ^ complete the editing session.
              | Seq [Action a]      -- ^ perform a sequence of actions.

-- | 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 :: [(Char, Action a)]
stdActions = [ ('j', Fwd)
             , ('k', Back)
             , ('x', Delete)
             , ('q', Cancel)
             , ('d', Done)
             ]

-- | A configuration record determining the behavior of the editor.
data EditorConf a = EC { display     :: a -> String
                           -- ^ How to display the current item.
                       , prompt      :: a -> String
                           -- ^ How to display a prompt to the user.
                       , emptyPrompt :: String
                           -- ^ What to display as a prompt if there
                           -- is no current item.
                       , actions     :: [(Char, Action a)]
                           -- ^ A list specifying the actions to take
                           -- in response to user inputs.
                       }

-- | 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 :: EditorConf a       -- ^ editor configuration
     -> [a]                -- ^ the list to edit
     -> 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: Nothing = cancel, Just True = continue, Just False = done
  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)