-- A Boolean Editor in Haskell
--
-- Manuel M T Chakravarty, 2001
--
-- This program demonstrates the use of the GTK+ API in Haskell.  The basic
-- API does not provide any special support for handling global GUI state in a
-- functional way.  Thus, this state is maintained using `IORef's.  For an
-- alternative - yet experimental - API see the iHaskell component of Gtk+HS.
--
-- To compile and link this file with an installed version of Gtk+HS invoke
--
--   ghc -o booled `gtkhs-config --cflags --libs` BoolEd.hs


module Main (main)
where

import List      (isPrefixOf, (\\))
import Maybe     (isNothing, isJust, fromJust)
import Monad     (when, liftM)
import IO        (ioeGetFileName, ioeGetErrorString)
import Directory (getCurrentDirectory)
import System    (ExitCode(..), getArgs, getProgName)

import IOExts    (IORef, newIORef, readIORef, writeIORef, modifyIORef)

import Gtk hiding (init, main)
import qualified
       Gtk       (init, main)


-- constants
-- ---------

-- suffix of Boolean files that can be edited by the Boolean Editor
--
suffix :: String
suffix  = ".bed"


-- the GUI state
-- -------------

-- GUI state of the whole program
--
-- * NB: the use of a list here makes for slightly awkward update functions,
--	 but keeps this example application simple
--
type GUIState = [WindowState]

-- an updatable GUI state
--
type GUIStateHandle = IORef GUIState

-- the GUI elements of a single window
--
-- * contains all the handles that need to be referenced during operation
--
data WindowElems = WindowElems {
		     windowWE   :: Window,	 -- window widget
		     labelWE    :: Label,	 -- label widget
		     buttonWE   :: ToggleButton, -- button widget
		     toggledWE  :: Connection,	 -- toggled handler connection
		     menuSaveWE :: MenuItem	 -- "File.Save" menu item
		   }

instance Eq WindowElems where
  we1 == we2 = windowWE we1 == windowWE we2  -- window determines the identity

-- state for a single window
--
-- * a file name and Boolean value may or may not be associated with a window
--
-- * if a file name is associated, it is the default file name used to store
--   the value of the window
--
-- * if a value is associated, it is displayed in the window
--
-- * a file name can only be associated if also a value is associated with the
--   same window
--
-- * multiple windows may display the contents of the same file and are
--   modified in sync; thus, the list of window handles
--
-- * NB: a good design should better separate the GUI-related state from the
--	 application-specific state; but we don't bother for this example
--	 application
--
data WindowState = WindowState {
		     windowsWS :: [WindowElems],   -- window widgets, >= 1
		     fnameWS   :: Maybe FilePath,  -- where to save the value
		     valueWS   :: Maybe Bool,	   -- edited value
		     dirtyWS   :: Bool		   -- needs to be saved
		   }

-- obtain all window widgets associated with a window state
--
windowWidgets :: WindowState -> [Window]
windowWidgets  = map windowWE . windowsWS

-- obtain the window elements for a particular window
--
windowElems        :: WindowState -> Window -> WindowElems
windowElems ws win  = head . filter ((win ==) . windowWE) $ windowsWS ws

-- obtain the window handles of all open windows
--
allWindows      :: GUIStateHandle -> IO [Window]
allWindows guis  = liftM (concat . map windowWidgets) $ readIORef guis

-- add a window to the GUI state
--
-- * if an existing window is already associate with the same file, the
--   window states are merged; the values of the old window dominate (this is
--   important to avoid loosing edits)
--
addWindow         :: GUIStateHandle -> WindowState -> IO ()
addWindow guis ws  = modifyIORef guis updateWSs
  where
    fname = fnameWS ws
    --
    updateWSs []                             = [ws]
    updateWSs (ws':wss) 
      | isJust fname && fnameWS ws' == fname = merge ws' :           wss
      | otherwise			     =       ws' : updateWSs wss
    --
    merge ws' = ws' {windowsWS = windowsWS ws ++ windowsWS ws'}

-- remove a window from the GUI state
--
-- * removes the window unconditionally; high-level code needs to handle
--   situations that need a user confirmation etc
--
-- * the whole state is thrown away as soon as all its window handles are gone
--
removeWindow          :: GUIStateHandle -> Window -> IO ()
removeWindow guis win  = do
  modifyIORef guis $ \wss ->
    [ws {windowsWS = wins} | ws <- wss,
			     let wins = windowsWS ws \\ [winElems],
			     (not . null) wins]
  where
    winElems = WindowElems {windowWE = win}

-- update the window elements for the given window
--
-- * exploits that the equality on `WindowElems' merely takes the window
--   handle in account
--
updateWindowElems         :: GUIStateHandle -> WindowElems -> IO ()
updateWindowElems guis we  = do
  modifyIORef guis $ \wss ->
    [ws {windowsWS = [if we == we' then we else we'| we' <- windowsWS ws]} 
    | ws <- wss]

-- update GUI state for the given window
--
updateWindow :: GUIStateHandle -> Window -> Maybe FilePath -> Bool -> Bool 
	     -> IO ()
updateWindow guis win ofname value dirty = do
  modifyIORef guis $ map $ \ws ->
    if win `notElem` windowWidgets ws 
    then ws 
    else ws {fnameWS = ofname,
	     valueWS = Just value,
	     dirtyWS = dirty}

-- obtain the current state of the given window
--
-- Pre: window is in the list of one window state
--
currentState          :: GUIStateHandle -> Window -> IO WindowState
currentState guis win  = do
  wss <- readIORef guis
  return $ (head . filter ((win `elem`) . windowWidgets)) wss


-- widget handling
-- ---------------

-- display an about dialog
--
about :: IO ()
about  = do
  win <- windowNew WindowDialog
  windowSetTitle win "About BoolEd"
  containerSetBorderWidth win 10
  --
  frame <- frameNew "The Boolean Editor"
  frameSetShadowType frame ShadowEtchedOut
  --
  label <- labelNew "The Gtk+HS Boolean Editor is an example application that \
		    \demonstrates the use of Gtk+HS for implementing GUI \
		    \applications with Haskell.\n\n\
		    \Manuel M T Chakravarty, 2001"
  labelSetLineWrap label True
  labelSetJustify label JustifyFill
  containerAdd frame label
  --
  but <- buttonNewWithLabel "Ok"
  buttonSignalConnectObject but (ButtonClickedHandler widgetDestroy) win
  --
  box <- vBoxNew False 0
  containerAdd win box
  boxPackStart box frame True True  10
  boxPackStart box but   True False 10
  --
  widgetShowAll win

-- display an alert message
--
alert            :: Maybe Window -> String -> IO ()
alert parent msg  = do
  --
  -- create a transient window
  --
  win <- windowNew WindowDialog
  windowSetTitle win "Error!"
  maybeDo (windowSetTransientFor win) parent
  containerSetBorderWidth win 10
  --
  -- with a label displaying the alert message
  --
  lbl <- labelNew msg
  --
  -- and an "Ok" button
  --
  but <- buttonNewWithLabel "Ok"
  buttonSignalConnectObject but (ButtonClickedHandler widgetDestroy) win
  --
  -- all in a vertical box
  --
  box <- vBoxNew False 0
  containerAdd win box
  boxPackStart box lbl True True  10
  boxPackStart box but True False 10
  --
  -- display the whole lot
  --
  mapM_ widgetShow [widget lbl, widget but, widget box, widget win]

-- display an IO error in an alert box
--
alertIOError            :: Maybe Window -> IOError -> IO ()
alertIOError parent ioe  =
  let
    optFName = maybe "" (++ ": ") (ioeGetFileName ioe)
  in
  alert parent $ optFName ++ ioeGetErrorString ioe

-- menu bar specification
--
type MenuBarSpec = [(String,		  -- menu bar item
		     [(String, IO ())])   -- pull-down menu items
		   ]

-- menu bar item structure matching a menu bar specification
--
type MenuBarItems = [[MenuItem]]	  -- a sublist per item in the menu bar

-- create a completely populated menu bar from a specification
--
createMenuBar       :: MenuBarSpec -> IO (MenuBar, MenuBarItems)
createMenuBar items  = do
  mbar <- menuBarNew
  itemWidgets <- mapM (createMenuBarItem mbar) items
  return (mbar, itemWidgets)
  where
    --
    -- add an entry to the given menu bar and attach a menu to it
    --
    createMenuBarItem mbar (label, menuItems) = do
      mbarItem <- menuItemNewWithLabel label
      menuBarAppend mbar mbarItem
      menu <- menuNew
      menuItemSetSubmenu mbarItem menu
      items <- mapM (createMenuItem menu) menuItems
      widgetShow mbarItem
      return items
    --
    -- add an item to a menu
    --
    createMenuItem menu (label, action) = do
      item <- menuItemNewWithLabel label
      menuAppend menu item
      menuItemSignalConnect item (MenuItemActivateHandler (const action))
      widgetShow item
      return item

-- add all widgets to a virgin window
--
-- Pre: the window has a value associated in the GUI state
--
addWindowWidgets          :: GUIStateHandle -> Window -> IO ()
addWindowWidgets guis win  = do
  ws <- currentState guis win
  windowSetTitle win (windowTitle (fnameWS ws))
  --
  -- execute the close action when the window manager wants to close the
  -- window (eg, because the user selected the close button on the window
  -- frame)
  --
  objectSignalConnect win (ObjectDestroyHandler closeFile)
  --
  -- add the button and label representing the Boolean value
  --
  -- * button needs to be set before connecting the signal handler, as the GUI
  --   state is not yet properly initialised for the current window and so
  --   cannot handle the signal handler `buttonToggled' to be raised
  --
  let initValue = fromJust (valueWS ws)
  but  <- toggleButtonNewWithLabel " False/True "
  lbl  <- labelNew (show initValue)
  toggleButtonSetActive but initValue
  conn <- toggleButtonSignalConnect but 
	    (ToggleButtonToggledHandler buttonToggled)
  --
  -- create the whole pull-down menu
  --
  (mbar, items) <- createMenuBar [("File", [
		                   ("Open..."   , openFile guis),
				   ("Save"      , saveFile guis win),
				   ("Save as...", saveAsFile guis win),
				   ("Close"     , closeFile win),
				   ("Exit"      , exitFile)
				  ]),
				  ("Help", [
				   ("About..."  , about)
				  ])
				 ]
  --
  -- the "File.Save" menu item is activated only when a file name is set
  --
  let saveItem = items!!0!!1
  when (isNothing (fnameWS ws)) $ 
    widgetSetSensitive saveItem False
--FIXME: add separators
  --
  -- put everything into a vbox in the window
  --
  box <- vBoxNew False 0
  containerAdd win box
  boxPackStart box mbar False False 0 
  boxPackStart box lbl  True  True  10
  boxPackStart box but  True  True  10
  --
  -- and display and memorise the new widgets
  --
  mapM_ widgetShow [widget mbar, widget box, widget but, widget lbl]
  updateWindowElems guis (WindowElems win lbl but conn saveItem)
  where
    --
    -- close the window, asking for confirmation if dirty
    --
    closeFile win = do
--FIXME: need to confirm close when window dirty; needs a modal window and
--	 need to be able to abort the closing if user wishes so (ie, need to
--	 return something from this signal handler)
      widgetDestroy win
      removeWindow guis win
      wins <- allWindows guis		-- when all edit windows are gone,
      when (null wins) $		-- leave the application
        mainQuit
    -- 
    -- close all windows
    --
    exitFile = do
      wins <- allWindows guis
      mapM_ closeFile wins
    --
    -- the given button has been toggeled; adjust the state
    --
    buttonToggled but = do
      onOff <- toggleButtonQueryState but
      setBooleanValue guis win onOff

-- set the value of a window
--
-- * update the GUI state and update the display of all associated windows
--
setBooleanValue                :: GUIStateHandle -> Window -> Bool -> IO ()
setBooleanValue guis win value  = do
  ws <- currentState guis win
  updateWindow guis win (fnameWS ws) value True
  mapM_ displayValue (windowsWS ws)
  where
   displayValue we = do
		       signalHandlerBlock    (buttonWE we) (toggledWE we)
		       toggleButtonSetActive (buttonWE we) value
		       signalHandlerUnblock  (buttonWE we) (toggledWE we)
		       labelSetText	     (labelWE  we) (show value)

-- open a new file using a file selector to select the file
--
openFile      :: GUIStateHandle -> IO ()
openFile guis  = do
  fsel <- fileSelectionNew "Open file..." 
  (ok, cancel) <- fileSelectionQueryButtons fsel
  buttonSignalConnect ok     (ButtonClickedHandler (const (selection fsel)))
  buttonSignalConnect cancel (ButtonClickedHandler 
			       (const (widgetDestroy fsel)))
  widgetShow fsel
  where
    --
    -- when the "Ok" button of the file selector is clicked, open a new window
    --
    selection fsel = do
      fname <- fileSelectionGetFilename fsel
      widgetDestroy fsel
      newWindow guis (Just fname)

-- save window value under an already set file name
--
-- * clears the dirty flag
--
-- Pre: file name is set (ensured by having the menu item deselected while
--	    none is set)
--
saveFile          :: GUIStateHandle -> Window -> IO ()
saveFile guis win  = do
  ws <- currentState guis win
  writeBedFile win (fromJust (fnameWS ws)) (fromJust (valueWS ws))
  updateWindow guis win (fnameWS ws) (fromJust (valueWS ws)) False

-- get a file name before saving
--
saveAsFile          :: GUIStateHandle -> Window -> IO ()
saveAsFile guis win  = do
  fsel <- fileSelectionNew "Save file..." 
  (ok, cancel) <- fileSelectionQueryButtons fsel
  buttonSignalConnect ok     (ButtonClickedHandler (const (selection fsel)))
  buttonSignalConnect cancel (ButtonClickedHandler 
			       (const (widgetDestroy fsel)))
  widgetShow fsel
  where
    --
    -- when the "Ok" button of the file selector is clicked, set the file name
    -- and save the file
    --
    selection fsel = do
      ws     <- currentState guis win
      fname  <- fileSelectionGetFilename fsel
      fname' <- normaliseFName fname
      widgetDestroy fsel
      updateWindow guis win (Just fname') (fromJust (valueWS ws)) True
      widgetSetSensitive (menuSaveWE (windowElems ws win)) True
      windowSetTitle win (windowTitle (Just fname'))
      saveFile guis win


-- file handling
-- -------------

-- read a Boolean file
--
-- * `Nothing' is returned if there is an error
--
readBedFile       :: FilePath -> IO (Maybe Bool)
readBedFile fname  =
  do
    contents <- readFile fname
    case contents of
      "True"  -> return $ Just True
      "False" -> return $ Just False
      _	      -> fail   $ fname ++ ": Not a Boolean file"
  `catch` \err -> do
		    alertIOError Nothing err
		    return Nothing

-- write a Boolean file
--
writeBedFile             :: Window -> FilePath -> Bool -> IO ()
writeBedFile win fname b  =
  writeFile (bedFName fname) (show b)  -- calls `bedFName' for safety reasons
  `catch` alertIOError (Just win)


-- window handling
-- ---------------

-- determines the window title string
--
windowTitle              :: Maybe FilePath -> String
windowTitle Nothing       = "booled: <unnamed>"
windowTitle (Just fname)  = "booled: " ++ fname

-- compute the window state for a new window that enables editing the content
-- of the given file 
--
-- * if the given file does not exist, a warning is displayed and the window
--   is empty 
--
-- * if any other window already displays the same file, the value of that
--   window is displayed
--
newWindowState            :: GUIState -> Maybe FilePath -> IO WindowState
newWindowState wss ofname  = do
  ofname' <- case ofname of
	       Nothing    -> return Nothing
	       Just fname -> liftM Just $ normaliseFName fname
  win     <- windowNew WindowToplevel
  ovalue  <- case ofname' of
	       Nothing              -> return Nothing    -- no associated file
	       Just fname
		 | null buddyValues -> readBedFile fname -- no buddy window
		 | otherwise        -> return $ head buddyValues
	         where
	          buddyValues = [valueWS ws | ws <- wss, fnameWS ws == ofname']
  return $ WindowState [WindowElems {windowWE = win}] ofname' ovalue False

-- create a new window that enables editing the content of the given file
--
-- * if there is no value (ie, nothing could be read from a file), the Boolean
--   value defaults to `False'
--
-- * if the given file does not exist, a warning is displayed and the window
--   is empty 
--
-- * if any other window already displays the same file, the value of that
--   window is displayed
--
newWindow             :: GUIStateHandle -> Maybe FilePath -> IO ()
newWindow guis ofname  = do
  wss <- readIORef guis
  ws  <- newWindowState wss ofname
  let ws' = if isNothing (valueWS ws) then ws {valueWS = Just False} else ws
      win = head (windowWidgets ws)
  addWindow guis ws'
  addWindowWidgets guis win
  widgetShow win


-- startup & shutdown
-- ------------------

-- emit usage information and quit
--
usageAndExit :: IO ()
usageAndExit  = do
  prgm <- getProgName
  putStrLn $ "Usage: " ++ prgm ++ " [FILE]"
  putStrLn $ "  FILE   Boolean file to load"
  putStrLn $ "Boolean files have the suffix `.bed'"
  exit     $ ExitFailure 1

-- overall structure
--
main :: IO ()
main  = do
  --
  -- initialise and analyse the command arguments
  --
  (_, args) <- Gtk.init Nothing
  when (length args > 1) $
    usageAndExit
  let ofname = if null args then Nothing else Just (head args)
  --
  -- pop up one window and enter the main event loop
  --
  guis <- newIORef []		-- initial GUI state
  newWindow guis ofname
  Gtk.main
  --
  -- terminate
  --
  exit ExitSuccess


-- auxiliary functions
-- -------------------

-- apply action if `Just a'
--
maybeDo            :: (a -> IO b) -> Maybe a -> IO (Maybe b)
maybeDo m Nothing   = return Nothing
maybeDo m (Just v)  = liftM Just $ m v

-- guarantee a `.bed' suffix
--
bedFName                   :: FilePath -> FilePath
bedFName fname | hasSuffix  = fname
	       | otherwise  = fname ++ suffix
	       where
	         fnameLen  = length fname
		 suffixLen = length suffix
	         hasSuffix = fnameLen >= suffixLen
			     && drop (fnameLen - suffixLen) fname == suffix

-- remove any file path prefix matching the current directory
--
normaliseFName       :: FilePath -> IO FilePath
normaliseFName fname  = do
  wd <- getCurrentDirectory
  let fname'    = bedFName fname
      prefixLen = length wd + if last wd == '/' then 0 else 1
  return $ if wd `isPrefixOf` fname'
	   then drop prefixLen fname'
	   else fname'