{- This module defines SimpleForm.hs, which is intended as a simple interface
   to filling in forms using HTk.  (Indeed, it is simple enough that it might
   be ported to some other GUI sometime.) -}
module SimpleForm(
   Form, -- This represents a series of input fields. Fi
      -- A (Form x) represents a form yielding a value of type x

   newFormEntry, -- :: (FormLabel label,FormValue value) 
      -- => label -> value -> Form x
      -- This creates a new form entry for a single item. 

   (//), -- :: Form value1 -> Form value2 -> Form (value1,value2)
      -- This combines two forms.  They will be displayed with one on top of
      -- the other.

   doForm, -- :: String -> Form x -> (x -> IO (Maybe String)) -> IO (Maybe x)
      -- This displays a form.  The first string is the title;
      -- the second the form; the third a filtering function which is called
      -- after the user clicks "OK" on the form.  If the function returns
      -- Just String this is an error message which is displayed in a window
      -- and we repeat, otherwise we return Just (x).  The form also has a
      -- Cancel button which causes us to return Nothing.

   FormValue(..), -- This is a class of values which can be read in from a 
      -- simple form.  Instances include Int, String and Bool.
      -- A user friendly way of constructing new instances is to instance
      -- one of the following two classes.
--   FormRadioButton(..), -- This class is used for types which are suitable
      -- for being read with radio buttons, for example a small enumeration.
   FormTextField(..), -- This class is used for types which can be
      -- read in using a text field.

   FormLabel(..), -- This class represents things which can be used for
      -- labels in the form.  Instances include String and Image.
   ) where

import Char

import qualified IOExts

import HTk
import DialogWin

-- -------------------------------------------------------------------------
-- The EnteredForm type
-- -------------------------------------------------------------------------

---
-- EnteredForm represents a form entry constructed in a given widget
-- The actions should be performed in the following sequence:
-- packAction
-- 0 or more uses of getFormValue
-- destroyAction
data EnteredForm value = EnteredForm {
   packAction :: IO (), -- packs the form entry into the widget.
   getFormValue :: IO value, -- extracts value
   destroyAction :: IO () -- does any necessary clean-up. 
   }

-- -------------------------------------------------------------------------
-- The Form type and (//)
-- -------------------------------------------------------------------------

newtype Form value = Form (Toplevel -> IO (EnteredForm value))

infixl //

(//) :: Form value1 -> Form value2 -> Form (value1,value2)
(//) (Form enterForm1) (Form enterForm2) =
   let
      enterForm topLevel =
         do
            enteredForm1 <- enterForm1 topLevel
            enteredForm2 <- enterForm2 topLevel
            let
               enteredForm = EnteredForm {
                  packAction = (
                     do
                        packAction enteredForm1
                        packAction enteredForm2
                     ),
                  getFormValue = (
                     do
                        value1 <- getFormValue enteredForm1
                        value2 <- getFormValue enteredForm2
                        return (value1,value2)
                     ),
                  destroyAction = (
                     do
                        destroyAction enteredForm1
                        destroyAction enteredForm2
                     )
                  }
            return enteredForm
   in
      Form enterForm

-- -------------------------------------------------------------------------
-- The doForm action 
-- -------------------------------------------------------------------------

doForm :: String -> Form value -> (value -> IO (Maybe String)) -> IO (Maybe value)
doForm title (Form enterForm) filterAct =
   do
      toplevel <- createToplevel [text title]
      enteredForm <- enterForm toplevel
      -- create frame for "OK" and "Cancel" buttons.
      frame <- newFrame toplevel []
      (okButton :: Button String) <- newButton frame [text "OK"]
      (cancelButton :: Button String) <- newButton frame [text "Cancel"]

      -- Pack everything
      packAction enteredForm
      pack okButton [Side AtLeft]
      pack cancelButton [Side AtRight]
      pack frame [Side AtBottom]

      -- Monitor ok and cancel buttons
      okEvent <- clicked okButton
      cancelEvent <- clicked cancelButton
      let
         handler =
               (do
                  okEvent
                  always (
                     do
                        value <- getFormValue enteredForm
                        isOk <- filterAct value
                        case isOk of
                           Nothing -> return (Just value)
                           Just message ->
                              do
                                 newErrorWin message []
                                 sync handler
                     )
               )
            +> (do
                  cancelEvent
                  return Nothing
               )

      valueOpt <- sync handler

      -- finish off
      destroyAction enteredForm
      destroy toplevel

      return valueOpt
 
-- -------------------------------------------------------------------------
-- newFormEntry
-- -------------------------------------------------------------------------

newFormEntry :: (FormLabel label,FormValue value) => label -> value -> Form value
newFormEntry label value =
   let
      enterForm topLevel =
         do
            frame <- newFrame topLevel []
            packLabel <- formLabel frame label
            enteredForm1 <- makeFormEntry frame value
            let
               enteredForm = EnteredForm {
                  packAction = (
                     do
                        packLabel
                        packAction enteredForm1
                        pack frame [Side AtBottom]
                     ),
                  getFormValue = getFormValue enteredForm1,
                  destroyAction = destroyAction enteredForm1
                  }
            return enteredForm
   in
      Form enterForm         

-- -------------------------------------------------------------------------
-- The FormLabel class
-- -------------------------------------------------------------------------

class FormLabel label where
   formLabel :: Frame -> label -> IO (IO ())
   -- formLabel frame label creates a new label 
   -- (normally at the left of) the frame "frame" with detail label.  The action
   -- returned is the packing action.

instance FormLabel String where
    formLabel frame str =
       do
          label <- newLabel frame [text str]
          return (pack label [Side AtLeft])

-- -------------------------------------------------------------------------
-- The FormValue class 
-- -------------------------------------------------------------------------

class FormValue value where
   makeFormEntry :: Frame -> value -> IO (EnteredForm value)
   -- Create a new form entry, given a default value.

-- -------------------------------------------------------------------------
-- Instance #1 - FormTextField's, corresponding to a single line of text.
-- -------------------------------------------------------------------------

class FormTextField value where
   makeFormString :: value -> String
      -- used for computing the initial string from the given default value
   readFormString :: String -> Either String value
      -- readFormString computes the value, or an error message.

-- Two examples

-- strings
instance FormTextField String where
   makeFormString str = str
   readFormString str = Right str

allSpaces :: String -> Bool
allSpaces = all isSpace

-- numbers
instance (Num a,Show a,Read a) => FormTextField a where
   makeFormString value = show value
   readFormString str = case reads str of
      [(value,rest)] | allSpaces rest -> Right value
      _ -> Left "Not a number"

instance FormTextField value => FormValue value where
   makeFormEntry frame defaultVal =
      do
         let defaultString = makeFormString defaultVal
         contentsVariable <- createTkVariable defaultString
         contentsRef <- IOExts.newIORef defaultVal
            -- This contains the last valid value.
         (entry :: Entry String) <- newEntry frame [variable contentsVariable]
         -- Set up the binding on Return
         (returned,endBinding) <- bindSimple entry 
            (KeyPress (Just (KeySym "Return")))
         -- Set up die-channel. 
         dieChannel <- newChannel
         let
            handler =
                  (do
                     returned -- return pressed
                     always(
                        do
                           txt <- readTkVariable contentsVariable
                           case readFormString txt of
                              Left error ->
                                 do
                                    oldVal <- IOExts.readIORef contentsRef
                                    newErrorWin 
                                       (error++"\n Using old entry "++
                                          makeFormString oldVal) []
                              Right newVal ->
                                 IOExts.writeIORef contentsRef newVal
                        )
                     handler 
                  ) 
               +> receive dieChannel
         spawnEvent handler
         let
            enteredForm = EnteredForm {
               packAction = pack entry [Side AtRight],
               getFormValue = IOExts.readIORef contentsRef,
               destroyAction = 
                  do
                     endBinding
                     sendIO dieChannel ()
               }
         return enteredForm