Default.hs

{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      : Application.HXournal.Coroutine.Default 
-- Copyright   : (c) 2011, 2012 Ian-Woo Kim
--
-- License     : BSD3
-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability   : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------

module Application.HXournal.Coroutine.Default where

import Graphics.UI.Gtk hiding (get,set)

import Application.HXournal.Type.Event
import Application.HXournal.Type.Coroutine
import Application.HXournal.Type.Canvas
import Application.HXournal.Type.XournalState
import Application.HXournal.Type.Clipboard
import Application.HXournal.Accessor
import Application.HXournal.GUI.Menu
import Application.HXournal.Coroutine.Callback
import Application.HXournal.Coroutine.Commit
import Application.HXournal.Coroutine.Draw
import Application.HXournal.Coroutine.Pen
import Application.HXournal.Coroutine.Eraser
import Application.HXournal.Coroutine.Highlighter
import Application.HXournal.Coroutine.Scroll
import Application.HXournal.Coroutine.Page
import Application.HXournal.Coroutine.Select
import Application.HXournal.Coroutine.File
import Application.HXournal.Coroutine.Mode
import Application.HXournal.Coroutine.Window
-- import Application.HXournal.Coroutine.Network
import Application.HXournal.Coroutine.Layer 
import Application.HXournal.ModelAction.Window 
import Application.HXournal.ModelAction.Page
import Application.HXournal.Type.Window 
import Application.HXournal.Device
import Control.Applicative ((<$>))
import Control.Monad.Coroutine
import Control.Monad.Coroutine.SuspensionFunctors
import qualified Control.Monad.State as St 
import Control.Monad.Trans
import qualified Data.IntMap as M
import Data.Maybe
import Control.Category
import Data.Label
import Prelude hiding ((.), id)
import Data.IORef
import Application.HXournal.Type.PageArrangement
import Data.Xournal.Simple (Dimension(..))
import Data.Xournal.BBox
import Data.Xournal.Generic

-- |

guiProcess :: MainCoroutine ()
guiProcess = do 
  initialize
  liftIO $ putStrLn "hi!"
  
  liftIO $ putStrLn "welcome to hxournal"
  changePage (const 0)
  xstate <- getSt
  let cinfoMap  = get canvasInfoMap xstate
      assocs = M.toList cinfoMap 
      f (cid,cinfobox) = do let canvas = getDrawAreaFromBox cinfobox
                            (w',h') <- liftIO $ widgetGetSize canvas
                            defaultEventProcess (CanvasConfigure cid
                                                (fromIntegral w') 
                                                (fromIntegral h')) 
  mapM_ f assocs
  sequence_ (repeat dispatchMode)


-- |

initCoroutine :: DeviceList -> Window -> IO (TRef,SRef)
initCoroutine devlst window = do 
  let st0 = (emptyHXournalState :: HXournalState)
  sref <- newIORef st0
  tref <- newIORef (undefined :: SusAwait)
  (r,st') <- St.runStateT (resume guiProcess) st0 
  writeIORef sref st' 
  either (writeIORef tref) (error "what?") r 
  let st0new = set deviceList devlst  
            . set rootOfRootWindow window 
            . set callBack (bouncecallback tref sref) 
            $ st' 
  writeIORef sref st0new            
  ui <- getMenuUI tref sref    
  putStrLn "hi"  
  let st1 = set gtkUIManager ui st0new

  -- (initcvstemp :: CanvasInfo SinglePage) <- initCanvasInfo st1 1 
  let initcvs = defaultCvsInfoSinglePage { _canvasId = 1 } 
  let initcvsbox = CanvasInfoBox initcvs
      --  initcmap = M.insert (get canvasId initcvs) initcvsbox M.empty
  let -- startingXstate = set canvasInfoMap initcmap 
      --                  . set frameState (Node 1)
      --                 $ st1
      st2 = set frameState (Node 1) 
            . updateFromCanvasInfoAsCurrentCanvas initcvsbox 
            . set canvasInfoMap (M.empty)
            $ st1 
  (st3,cvs,wconf) <- constructFrame st2 (get frameState st2)
  (st4,wconf') <- eventConnect st3 (get frameState st3)
  let startingXstate = set frameState wconf' . set rootWindow cvs $ st4
                       
  writeIORef sref startingXstate   
  return (tref,sref)


initialize :: MainCoroutine ()
initialize = do ev <- await 
                liftIO $ putStrLn $ show ev 
                case ev of 
                  Initialized -> return () 
                  _ -> initialize

-- | 

dispatchMode :: MainCoroutine () 
dispatchMode = getSt >>= return . xojstateEither . get xournalstate
                     >>= either (const viewAppendMode) (const selectMode)
                     
{-  xojstate <- return . get xournalstate =<< getSt 
    case xojstate of 
    ViewAppendState _ -> viewAppendMode
    SelectState _ -> selectMode -}

-- | 

viewAppendMode :: MainCoroutine () 
viewAppendMode = do 
  r1 <- await 
  case r1 of 
    PenDown cid pcoord -> do 
      ptype <- getPenType 
      case ptype of 
        PenWork         -> penStart cid pcoord 
        EraserWork      -> eraserStart cid pcoord 
        HighlighterWork -> highlighterStart cid pcoord
        _ -> return () 
    _ -> defaultEventProcess r1

selectMode :: MainCoroutine () 
selectMode = do 
  r1 <- await 
  case r1 of 
    PenDown cid pcoord -> do 
      ptype <- return . get (selectType.selectInfo) =<< lift St.get 
      case ptype of 
        SelectRectangleWork -> selectRectStart cid pcoord 
        SelectRegionWork -> selectLassoStart cid pcoord
        _ -> return ()
    PenColorChanged c -> selectPenColorChanged c
    PenWidthChanged w -> selectPenWidthChanged w
    _ -> defaultEventProcess r1



defaultEventProcess :: MyEvent -> MainCoroutine ()
defaultEventProcess (UpdateCanvas cid) = invalidate cid   
defaultEventProcess (Menu m) = menuEventProcess m
defaultEventProcess (HScrollBarMoved cid v) = hscrollBarMoved cid v
defaultEventProcess (VScrollBarMoved cid v) = vscrollBarMoved cid v
defaultEventProcess (VScrollBarStart cid _v) = vscrollStart cid 
defaultEventProcess (CanvasConfigure cid w' h') = 
  canvasConfigure cid (CanvasDimension (Dim w' h'))
  
defaultEventProcess ToViewAppendMode = modeChange ToViewAppendMode
defaultEventProcess ToSelectMode = modeChange ToSelectMode 
defaultEventProcess ToSinglePage = viewModeChange ToSinglePage
defaultEventProcess ToContSinglePage = viewModeChange ToContSinglePage
defaultEventProcess _ = return ()

askQuitProgram :: MainCoroutine () 
askQuitProgram = do 
  dialog <- liftIO $ messageDialogNew Nothing [DialogModal] 
                       MessageQuestion ButtonsOkCancel 
                       "Current canvas is not saved yet. Will you close hxournal?" 
  res <- liftIO $ dialogRun dialog
  case res of
    ResponseOk -> do 
      liftIO $ widgetDestroy dialog
      liftIO $ mainQuit
    _ -> do 
      liftIO $ widgetDestroy dialog
      return ()

menuEventProcess :: MenuEvent -> MainCoroutine () 
menuEventProcess MenuQuit = do 
  xstate <- getSt
  liftIO $ putStrLn "MenuQuit called"
  if get isSaved xstate 
    then liftIO $ mainQuit
    else askQuitProgram
menuEventProcess MenuPreviousPage = changePage (\x->x-1)
menuEventProcess MenuNextPage =  changePage (+1)
menuEventProcess MenuFirstPage = changePage (const 0)
menuEventProcess MenuLastPage = do 
  totalnumofpages <- (either (M.size. get g_pages) (M.size . get g_selectAll) 
                      . xojstateEither . get xournalstate) <$> getSt 
  changePage (const (totalnumofpages-1))
menuEventProcess MenuNewPageBefore = return () -- newPageBefore 
menuEventProcess MenuNew  = askIfSave fileNew 
menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF
menuEventProcess MenuUndo = undo 
menuEventProcess MenuRedo = redo
menuEventProcess MenuOpen = askIfSave fileOpen
menuEventProcess MenuSave = fileSave 
menuEventProcess MenuSaveAs = fileSaveAs
menuEventProcess MenuCut = cutSelection
menuEventProcess MenuCopy = copySelection
menuEventProcess MenuPaste = pasteToSelection
menuEventProcess MenuDelete = deleteSelection
-- menuEventProcess MenuNetCopy = clipCopyToNetworkClipboard
-- menuEventProcess MenuNetPaste = clipPasteFromNetworkClipboard
menuEventProcess MenuNormalSize = pageZoomChange Original  
menuEventProcess MenuPageWidth = pageZoomChange FitWidth 
menuEventProcess MenuPageHeight = pageZoomChange FitHeight
menuEventProcess MenuHSplit = eitherSplit SplitHorizontal
menuEventProcess MenuVSplit = eitherSplit SplitVertical
menuEventProcess MenuDelCanvas = deleteCanvas
menuEventProcess MenuNewLayer = makeNewLayer 
menuEventProcess MenuNextLayer = gotoNextLayer 
menuEventProcess MenuPrevLayer = gotoPrevLayer
menuEventProcess MenuGotoLayer = startGotoLayerAt 
menuEventProcess MenuDeleteLayer = deleteCurrentLayer

menuEventProcess MenuUseXInput = do 
  xstate <- getSt 
  let ui = get gtkUIManager xstate 
  agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->
                    case x of 
                      [] -> error "No action group? "
                      y:_ -> return y )
  uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA") 
              >>= maybe (error "MenuUseXInput") (return . castToToggleAction)
  b <- liftIO $ toggleActionGetActive uxinputa
  let cmap = get canvasInfoMap xstate
      canvases = map (getDrawAreaFromBox) . M.elems $ cmap 
  
  if b
    then mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsAll]) canvases
    else mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsNone] ) canvases
         
menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m