{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Default -- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Hoodle.Coroutine.Default where import Control.Applicative ((<$>)) import Control.Category import Control.Concurrent import Control.Lens (_1,over,view,set,at,(.~),(%~)) import Control.Monad.Reader import Control.Monad.State import qualified Data.ByteString.Char8 as B import qualified Data.IntMap as M import Data.IORef import Data.Maybe import Data.Time.Clock import Graphics.UI.Gtk hiding (get,set) import System.Process -- from hoodle-platform import Control.Monad.Trans.Crtn.Driver import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Object import Control.Monad.Trans.Crtn.Logger.Simple import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.Select import Data.Hoodle.Simple (Dimension(..)) import Data.Hoodle.Generic import Graphics.Hoodle.Render.Type.Background -- from this package import Hoodle.Accessor import Hoodle.Coroutine.Callback import Hoodle.Coroutine.Commit import Hoodle.Coroutine.ContextMenu import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Eraser import Hoodle.Coroutine.File import Hoodle.Coroutine.Highlighter import Hoodle.Coroutine.Layer import Hoodle.Coroutine.Link import Hoodle.Coroutine.Page import Hoodle.Coroutine.Pen import Hoodle.Coroutine.Scroll import Hoodle.Coroutine.Select import Hoodle.Coroutine.Select.Clipboard import Hoodle.Coroutine.TextInput import Hoodle.Coroutine.Mode import Hoodle.Coroutine.VerticalSpace import Hoodle.Coroutine.Window import Hoodle.Device import Hoodle.GUI.Menu import Hoodle.GUI.Reflect import Hoodle.ModelAction.File import Hoodle.ModelAction.Page import Hoodle.ModelAction.Window import Hoodle.Script import Hoodle.Script.Hook import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Enum import Hoodle.Type.Event import Hoodle.Type.HoodleState import Hoodle.Type.PageArrangement import Hoodle.Type.Predefined import Hoodle.Type.Undo import Hoodle.Type.Window import Hoodle.Type.Widget import Hoodle.Widget.PanZoom import Hoodle.Widget.Layer import Hoodle.Widget.Dispatch -- import Prelude hiding ((.), id) -- | initCoroutine :: DeviceList -> Window -> Maybe FilePath -> Maybe Hook -> Int -- ^ maxundo -> (Bool,Bool,Bool) -- ^ (xinputbool,usepz,uselyr) -> Statusbar -- ^ status bar -> IO (EventVar,HoodleState,UIManager,VBox) initCoroutine devlst window mfname mhook maxundo (xinputbool,usepz,uselyr) stbar = do evar <- newEmptyMVar putMVar evar Nothing st0new <- set deviceList devlst . set rootOfRootWindow window . set callBack (eventHandler evar) <$> emptyHoodleState (ui,uicompsighdlr) <- getMenuUI evar let st1 = set gtkUIManager ui st0new initcvs = set (canvasWidgets.widgetConfig.doesUsePanZoomWidget) usepz . set (canvasWidgets.widgetConfig.doesUseLayerWidget) uselyr $ defaultCvsInfoSinglePage { _canvasId = 1 } initcvsbox = CanvasSinglePage initcvs st2 = set frameState (Node 1) . updateFromCanvasInfoAsCurrentCanvas initcvsbox $ st1 { _cvsInfoMap = M.empty } (st3,cvs,_wconf) <- constructFrame st2 (view frameState st2) (st4,wconf') <- eventConnect st3 (view frameState st3) let st5 = set (settings.doesUseXInput) xinputbool . set hookSet mhook . set undoTable (emptyUndo maxundo) . set frameState wconf' . set rootWindow cvs . set uiComponentSignalHandler uicompsighdlr . set statusBar (Just stbar) $ st4 st6 <- getFileContent mfname st5 -- very dirty, need to be cleaned let hdlst6 = view hoodleModeState st6 hdlst7 <- resetHoodleModeStateBuffers hdlst6 let st7 = set hoodleModeState hdlst7 st6 -- vbox <- vBoxNew False 0 -- let startingXstate = set rootContainer (castToBox vbox) st7 let startworld = world startingXstate . ReaderT $ (\(Arg DoEvent ev) -> guiProcess ev) putMVar evar . Just $ (driver simplelogger startworld) return (evar,startingXstate,ui,vbox) -- | initialization according to the setting initialize :: AllEvent -> MainCoroutine () initialize ev = do case ev of UsrEv Initialized -> do -- additional initialization goes here viewModeChange ToContSinglePage pageZoomChange FitWidth xst <- get let Just sbar = view statusBar xst cxtid <- liftIO $ statusbarGetContextId sbar "test" liftIO $ statusbarPush sbar cxtid "Hello there" let ui = view gtkUIManager xst liftIO $ toggleSave ui False put (set isSaved True xst) _ -> do ev' <- nextevent initialize (UsrEv ev') -- | guiProcess :: AllEvent -> MainCoroutine () guiProcess ev = do initialize ev changePage (const 0) xstate <- get reflectViewModeUI reflectPenModeUI reflectPenColorUI reflectPenWidthUI 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) -- | dispatchMode :: MainCoroutine () dispatchMode = get >>= return . hoodleModeStateEither . view hoodleModeState >>= either (const viewAppendMode) (const selectMode) -- | viewAppendMode :: MainCoroutine () viewAppendMode = do r1 <- nextevent case r1 of PenDown cid pbtn pcoord -> do widgetCheckPen cid pcoord $ do ptype <- getPenType case (ptype,pbtn) of (PenWork,PenButton1) -> penStart cid pcoord (PenWork,PenButton2) -> eraserStart cid pcoord (PenWork,PenButton3) -> do updateXState (return . set isOneTimeSelectMode YesBeforeSelect) modeChange ToSelectMode selectLassoStart PenButton3 cid pcoord (PenWork,EraserButton) -> eraserStart cid pcoord (PenWork,_) -> return () (EraserWork,_) -> eraserStart cid pcoord (HighlighterWork,_) -> highlighterStart cid pcoord (VerticalSpaceWork,PenButton1) -> verticalSpaceStart cid pcoord (VerticalSpaceWork,_) -> return () TouchDown cid pcoord -> touchStart cid pcoord PenMove cid pcoord -> disableTouch >> notifyLink cid pcoord _ -> defaultEventProcess r1 disableTouch :: MainCoroutine () disableTouch = do xst <- get let devlst = view deviceList xst let b = view (settings.doesUseTouch) xst when b $ do let nxst = set (settings.doesUseTouch) False xst doIOaction $ \_ -> do setToggleUIForFlag "HANDA" (settings.doesUseTouch) nxst let touchstr = dev_touch_str devlst -- ad hoc when (touchstr /= "touch") $ do readProcess "xinput" [ "disable", touchstr ] "" return () -- return (UsrEv ActionOrdered) waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False) put nxst -- | selectMode :: MainCoroutine () selectMode = do r1 <- nextevent case r1 of PenDown cid pbtn pcoord -> do ptype <- liftM (view (selectInfo.selectType)) get case ptype of SelectRectangleWork -> selectRectStart pbtn cid pcoord SelectRegionWork -> selectLassoStart pbtn cid pcoord _ -> return () PenMove cid pcoord -> disableTouch >> notifyLink cid pcoord TouchDown cid pcoord -> touchStart cid pcoord PenColorChanged c -> do modify (penInfo.currentTool.penColor .~ c) selectPenColorChanged c PenWidthChanged v -> do w <- flip int2Point v . view (penInfo.penType) <$> get modify (penInfo.currentTool.penWidth .~ w) selectPenWidthChanged w _ -> defaultEventProcess r1 -- | defaultEventProcess :: UserEvent -> 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 v defaultEventProcess PaneMoveStart = paneMoveStart defaultEventProcess (CanvasConfigure cid w' h') = doCanvasConfigure cid (CanvasDimension (Dim w' h')) defaultEventProcess ToViewAppendMode = modeChange ToViewAppendMode defaultEventProcess ToSelectMode = modeChange ToSelectMode defaultEventProcess ToSinglePage = viewModeChange ToSinglePage defaultEventProcess ToContSinglePage = viewModeChange ToContSinglePage defaultEventProcess (AssignPenMode t) = case t of Left pm -> do modify (penInfo.penType .~ pm) modeChange ToViewAppendMode Right sm -> do modify (selectInfo.selectType .~ sm) modeChange ToSelectMode defaultEventProcess (PenColorChanged c) = modify (penInfo.currentTool.penColor .~ c) defaultEventProcess (PenWidthChanged v) = do st <- get let ptype = view (penInfo.penType) st let w = int2Point ptype v let stNew = set (penInfo.currentTool.penWidth) w st put stNew defaultEventProcess (BackgroundStyleChanged bsty) = do modify (backgroundStyle .~ bsty) xstate <- get let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate hdl = getHoodle xstate pgs = view gpages hdl cpage = getPageFromGHoodleMap pgnum hdl cbkg = view gbackground cpage bstystr = convertBackgroundStyleToByteString bsty -- for the time being, I replace any background to solid background getnbkg :: RBackground -> RBackground getnbkg (RBkgSmpl c _ _) = RBkgSmpl c bstystr Nothing getnbkg (RBkgPDF _ _ _ _ _) = RBkgSmpl "white" bstystr Nothing getnbkg (RBkgEmbedPDF _ _ _) = RBkgSmpl "white" bstystr Nothing -- npage = set gbackground (getnbkg cbkg) cpage npgs = set (at pgnum) (Just npage) pgs nhdl = set gpages npgs hdl modeChange ToViewAppendMode modify (set hoodleModeState (ViewAppendState nhdl)) invalidateAll defaultEventProcess (GotContextMenuSignal ctxtmenu) = processContextMenu ctxtmenu defaultEventProcess (GetHoodleFileInfo ref) = do xst <- get let hdl = getHoodle xst uuid = B.unpack (view ghoodleID hdl) case view (hoodleFileControl.hoodleFileName) xst of Nothing -> liftIO $ writeIORef ref Nothing Just fp -> liftIO $ writeIORef ref (Just (uuid ++ "," ++ fp)) defaultEventProcess (GotLink mstr (x,y)) = gotLink mstr (x,y) defaultEventProcess (Sync ctime) = do xst <- get case view (hoodleFileControl.lastSavedTime) xst of Nothing -> return () Just otime -> do let dtime = diffUTCTime ctime otime if dtime < dtime_bound * 10 then return () else do let ioact = mkIOaction $ \evhandler -> do postGUISync (evhandler (UsrEv FileReloadOrdered)) return (UsrEv ActionOrdered) modify (tempQueue %~ enqueue ioact) defaultEventProcess FileReloadOrdered = fileReload defaultEventProcess (CustomKeyEvent str) = if str == "[]:\"Super_L\"" then do xst <- liftM (over (settings.doesUseTouch) not) get put xst let action = mkIOaction $ \_evhandler -> do setToggleUIForFlag "HANDA" (settings.doesUseTouch) xst return (UsrEv ActionOrdered) modify (tempQueue %~ enqueue action) waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False) toggleTouch else return () defaultEventProcess ev = -- for debugging do liftIO $ putStrLn "--- no default ---" liftIO $ print ev liftIO $ putStrLn "------------------" return () -- | menuEventProcess :: MenuEvent -> MainCoroutine () menuEventProcess MenuQuit = do xstate <- get liftIO $ putStrLn "MenuQuit called" if view 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. view gpages) (M.size . view gselAll) . hoodleModeStateEither . view hoodleModeState) <$> get changePage (const (totalnumofpages-1)) menuEventProcess MenuNewPageBefore = newPage PageBefore menuEventProcess MenuNewPageAfter = newPage PageAfter menuEventProcess MenuDeletePage = deleteCurrentPage menuEventProcess MenuExportPageSVG = exportCurrentPageAsSVG menuEventProcess MenuNew = askIfSave fileNew menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF menuEventProcess MenuLoadPNGorJPG = fileLoadPNGorJPG menuEventProcess MenuLoadSVG = fileLoadSVG menuEventProcess MenuLaTeX = fileLaTeX menuEventProcess MenuUndo = undo menuEventProcess MenuRedo = redo menuEventProcess MenuOpen = askIfSave fileOpen menuEventProcess MenuSave = fileSave menuEventProcess MenuSaveAs = fileSaveAs menuEventProcess MenuReload = fileReload menuEventProcess MenuExport = fileExport menuEventProcess MenuStartSync = fileStartSync menuEventProcess MenuVersionSave = fileVersionSave menuEventProcess MenuShowRevisions = fileShowRevisions menuEventProcess MenuShowUUID = fileShowUUID -- menuEventProcess MenuCut = cutSelection menuEventProcess MenuCopy = copySelection menuEventProcess MenuPaste = pasteToSelection menuEventProcess MenuDelete = deleteSelection menuEventProcess MenuZoomIn = pageZoomChangeRel ZoomIn menuEventProcess MenuZoomOut = pageZoomChangeRel ZoomOut 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 <- get b <- updateFlagFromToggleUI "UXINPUTA" (settings.doesUseXInput) 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 MenuUseTouch = toggleTouch menuEventProcess MenuSmoothScroll = updateFlagFromToggleUI "SMTHSCRA" (settings.doesSmoothScroll) >> return () menuEventProcess MenuUsePopUpMenu = updateFlagFromToggleUI "POPMENUA" (settings.doesUsePopUpMenu) >> return () menuEventProcess MenuEmbedImage = updateFlagFromToggleUI "EBDIMGA" (settings.doesEmbedImage) >> return () menuEventProcess MenuEmbedPDF = updateFlagFromToggleUI "EBDPDFA" (settings.doesEmbedPDF) >> return () menuEventProcess MenuFollowLinks = updateFlagFromToggleUI "FLWLNKA" (settings.doesFollowLinks) >> return () menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return () menuEventProcess MenuRelaunch = liftIO $ relaunchApplication menuEventProcess MenuColorPicker = colorPick menuEventProcess MenuFullScreen = fullScreen menuEventProcess MenuText = textInput menuEventProcess MenuAddLink = addLink menuEventProcess MenuEmbedPredefinedImage = embedPredefinedImage menuEventProcess MenuEmbedPredefinedImage2 = embedPredefinedImage2 menuEventProcess MenuEmbedPredefinedImage3 = embedPredefinedImage3 menuEventProcess MenuApplyToAllPages = do xstate <- get let bsty = view backgroundStyle xstate let hdl = getHoodle xstate pgs = view gpages hdl changeBkg cpage = let cbkg = view gbackground cpage nbkg | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty } | otherwise = cbkg in set gbackground nbkg cpage npgs = fmap changeBkg pgs nhdl = set gpages npgs hdl modeChange ToViewAppendMode modify (set hoodleModeState (ViewAppendState nhdl)) invalidateAll menuEventProcess MenuEmbedAllPDFBkg = embedAllPDFBackground menuEventProcess MenuTogglePanZoomWidget = (togglePanZoom . view (currentCanvas._1)) =<< get menuEventProcess MenuToggleLayerWidget = (toggleLayer . view (currentCanvas._1)) =<< get menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m -- | colorPick :: MainCoroutine () colorPick = do mc <- colorPickerBox "Pen Color" maybe (return ()) (\c->modify (penInfo.currentTool.penColor .~ c)) mc -- | colorConvert :: Color -> PenColor colorConvert (Color r g b) = ColorRGBA (realToFrac r/65536.0) (realToFrac g/65536.0) (realToFrac b/65536.0) 1.0 -- | colorPickerBox :: String -> MainCoroutine (Maybe PenColor) colorPickerBox msg = do xst <- get let pcolor = view ( penInfo.currentTool.penColor) xst modify (tempQueue %~ enqueue (action pcolor)) >> go where action pcolor = mkIOaction $ \_evhandler -> do dialog <- colorSelectionDialogNew msg csel <- colorSelectionDialogGetColor dialog let (r,g,b,_a) = convertPenColorToRGBA pcolor color = Color (floor (r*65535.0)) (floor (g*65535.0)) (floor (b*65535.0)) colorSelectionSetCurrentColor csel color res <- dialogRun dialog mc <- case res of ResponseOk -> do clrsel <- colorSelectionDialogGetColor dialog clr <- colorSelectionGetCurrentColor clrsel return (Just (colorConvert clr)) _ -> return Nothing widgetDestroy dialog return (UsrEv (ColorChosen mc)) go = do r <- nextevent case r of ColorChosen mc -> return mc UpdateCanvas cid -> -- this is temporary invalidateInBBox Nothing Efficient cid >> go _ -> go