{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.Coroutine.Default -- Copyright : (c) 2011, 2012 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- 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 -- | initViewModeIOAction :: MainCoroutine HXournalState initViewModeIOAction = do oxstate <- getSt let ui = get gtkUIManager oxstate agr <- liftIO $ uiManagerGetActionGroups ui Just ra <- liftIO $ actionGroupGetAction (head agr) "CONTA" let wra = castToRadioAction ra connid <- liftIO $ wra `on` radioActionChanged $ \x -> do y <- viewModeToMyEvent x get callBack oxstate y return () let xstate = set pageModeSignal (Just connid) oxstate putSt xstate return xstate -- | guiProcess :: MainCoroutine () guiProcess = do initialize liftIO $ putStrLn "hi!" liftIO $ putStrLn "welcome to hxournal" changePage (const 0) xstate <- initViewModeIOAction let cinfoMap = getCanvasInfoMap 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 st2 = set frameState (Node 1) . updateFromCanvasInfoAsCurrentCanvas initcvsbox $ st1 { _cvsInfoMap = M.empty } (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 = getCanvasInfoMap 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