{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Default -- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Hoodle.Coroutine.Default where import Control.Applicative hiding (empty) import Control.Concurrent import Control.Concurrent.STM import Control.Lens (_1,over,view,set,at,(.~),(%~),(^.)) -- import Control.Monad.Reader hiding (mapM_) import Control.Monad.State hiding (mapM_) import Control.Monad.Trans.Reader (ReaderT(..)) import qualified Data.ByteString.Char8 as B import Data.Foldable (mapM_) import qualified Data.IntMap as M import Data.IORef import Data.Maybe import Data.Monoid ((<>)) import Data.Sequence (Seq, (<|),(|>), empty, singleton, viewl, ViewL(..)) import qualified Data.Sequence as Seq (null) import qualified Data.Text as T (unpack) import Data.Time.Clock import Data.UUID import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.UI.Gtk as Gtk hiding (get,set) import qualified Graphics.UI.Gtk.Poppler.Document as Poppler import qualified Graphics.UI.Gtk.Poppler.Page as Poppler import System.Process -- from hoodle-platform import Control.Monad.Trans.Crtn.Driver 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(..), Background(..), defaultHoodle) import Data.Hoodle.Generic import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Background import Graphics.Hoodle.Render.Type -- 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.HandwritingRecognition 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.Clock import Hoodle.Widget.Dispatch import Hoodle.Widget.Layer import Hoodle.Widget.PanZoom -- import Prelude hiding (mapM_) -- | initCoroutine :: DeviceList -> Gtk.Window -> Maybe Hook -> Int -- ^ maxundo -> (Bool,Bool,Bool) -- ^ (xinputbool,usepz,uselyr) -> Gtk.Statusbar -- ^ status bar -> IO (EventVar,HoodleState,Gtk.UIManager,Gtk.VBox) initCoroutine devlst window mhook maxundo (xinputbool,usepz,uselyr) stbar = do evar <- newEmptyMVar putMVar evar Nothing st0new <- set deviceList devlst . set rootOfRootWindow window . set callBack (eventHandler evar) <$> emptyHoodleState -- pdf rendering testing code let tvar = st0new ^. pdfRenderQueue -- (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) -- testing -- let handler = const (putStrLn "In getFileContent, got call back") -- newhdl <- flip runReaderT (undefined,undefined) . cnstrctRHoodle =<< defaultHoodle -- let nhmodstate = ViewAppendState newhdl 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) . set (hoodleFileControl.hoodleFileName) Nothing -- . set hoodleModeState nhmodstate $ st4 vbox <- Gtk.vBoxNew False 0 -- let startingXstate = set rootContainer (Gtk.castToBox vbox) st5 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 mfname) -> do -- additional initialization goes here xst1 <- get let tvar = xst1 ^. pdfRenderQueue doIOaction $ \evhandler -> do let handler = Gtk.postGUIAsync . evhandler . SysEv . RenderCacheUpdate forkOn 2 $ pdfRendererMain handler tvar return (UsrEv ActionOrdered) waitSomeEvent (\case ActionOrdered -> True ; _ -> False ) getFileContent mfname xst2 <- get let hdlst = xst2 ^. hoodleModeState cache = xst2 ^. renderCache hdlst' <- liftIO $ resetHoodleModeStateBuffers cache hdlst put (set hoodleModeState hdlst' xst2) xst <- get let Just sbar = view statusBar xst cxtid <- liftIO $ Gtk.statusbarGetContextId sbar "test" liftIO $ Gtk.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 $ Gtk.widgetGetSize canvas liftIO $ print (w',h') -- defaultEventProcess (CanvasConfigure cid -- (fromIntegral w') -- (fromIntegral h')) mapM_ f assocs viewModeChange ToContSinglePage pageZoomChange FitWidth -- waitSomeEvent (\x -> case x of CanvasConfigure cid w h -> True ; _ -> False) startLinkReceiver -- main loop 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 SelectLassoWork -> 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 (UpdateCanvasEfficient cid) = invalidateInBBox Nothing Efficient 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) = do modify (penInfo.currentTool.penColor .~ c) reflectPenColorUI 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 reflectPenWidthUI defaultEventProcess (BackgroundStyleChanged bsty) = do modify (backgroundStyle .~ bsty) xstate <- get let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) 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 dim = view gdimension cpage getnbkg' :: RBackground -> Background getnbkg' (RBkgSmpl c _ _) = Background "solid" c bstystr getnbkg' (RBkgPDF _ _ _ _ _) = Background "solid" "white" bstystr getnbkg' (RBkgEmbedPDF _ _ _) = Background "solid" "white" bstystr -- liftIO $ putStrLn " defaultEventProcess: BackgroundStyleChanged HERE/ " callRenderer $ GotRBackground <$> evalStateT (cnstrctRBkg_StateT dim (getnbkg' cbkg)) Nothing RenderEv (GotRBackground nbkg) <- waitSomeEvent (\case RenderEv (GotRBackground _) -> True ; _ -> False ) let npage = set gbackground nbkg 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 Gtk.postGUISync (evhandler (UsrEv FileReloadOrdered)) return (UsrEv ActionOrdered) modify (tempQueue %~ enqueue ioact) defaultEventProcess FileReloadOrdered = fileReload defaultEventProcess (CustomKeyEvent str) = do liftIO $ print str if | str == "[]:\"Super_L\"" -> 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 | str == "[]:\"1\"" -> colorfunc ColorBlack | str == "[]:\"2\"" -> colorfunc ColorBlue | str == "[]:\"3\"" -> colorfunc ColorRed | str == "[]:\"4\"" -> colorfunc ColorGreen | str == "[]:\"5\"" -> colorfunc ColorGray | str == "[]:\"6\"" -> colorfunc ColorLightBlue | str == "[]:\"7\"" -> colorfunc ColorLightGreen | str == "[]:\"8\"" -> colorfunc ColorMagenta | str == "[]:\"9\"" -> colorfunc ColorOrange | str == "[]:\"0\"" -> colorfunc ColorYellow | str == "[]:\"minus\"" -> colorfunc ColorWhite | str == "[]:\"a\"" -> toolfunc PenWork | str == "[]:\"b\"" -> toolfunc HighlighterWork | str == "[]:\"c\"" -> toolfunc EraserWork | str == "[]:\"d\"" -> toolfunc VerticalSpaceWork | otherwise -> return () where colorfunc c = doIOaction $ \_evhandler -> return (UsrEv (PenColorChanged c)) toolfunc t = doIOaction $ \_evhandler -> return (UsrEv (AssignPenMode (Left t))) defaultEventProcess (DBusEv (ImageFileDropped fname)) = embedImage fname defaultEventProcess (DBusEv (DBusNetworkInput txt)) = dbusNetworkInput txt defaultEventProcess (DBusEv (GoToLink (docid,anchorid))) = goToAnchorPos docid anchorid 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 $ Gtk.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 MenuText = textInput (Just (100,100)) "" menuEventProcess MenuEmbedTextSource = embedTextSource menuEventProcess MenuEditEmbedTextSource = editEmbeddedTextSource menuEventProcess MenuEditNetEmbedTextSource = editNetEmbeddedTextSource menuEventProcess MenuTextFromSource = textInputFromSource (100,100) menuEventProcess MenuLaTeX = laTeXInput Nothing (laTeXHeader <> "\n\n" <> laTeXFooter) menuEventProcess MenuLaTeXNetwork = laTeXInputNetwork Nothing (laTeXHeader <> "\n\n" <> laTeXFooter) menuEventProcess MenuCombineLaTeX = combineLaTeXText menuEventProcess MenuLaTeXFromSource = laTeXInputFromSource (100,100) 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 $ Gtk.widgetSetExtensionEvents x [Gtk.ExtensionEventsAll]) canvases else mapM_ (\x->liftIO $ Gtk.widgetSetExtensionEvents x [Gtk.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 MenuKeepAspectRatio = updateFlagFromToggleUI "KEEPRATIOA" (settings.doesKeepAspectRatio) >> return () menuEventProcess MenuUseVariableCursor = updateFlagFromToggleUI "VCURSORA" (settings.doesUseVariableCursor) >> reflectCursor >> return () menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return () menuEventProcess MenuRelaunch = liftIO $ relaunchApplication menuEventProcess MenuColorPicker = colorPick menuEventProcess MenuFullScreen = fullScreen menuEventProcess MenuAddLink = addLink menuEventProcess MenuAddAnchor = addAnchor menuEventProcess MenuListAnchors = listAnchors 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 MenuToggleClockWidget = (toggleClock . view (currentCanvas._1)) =<< get menuEventProcess MenuHandwritingRecognitionDialog = handwritingRecognitionDialog >>= mapM_ (\(b,txt) -> when b $ embedHoodlet (T.unpack txt)) 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 :: Gtk.Color -> PenColor colorConvert (Gtk.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 <- Gtk.colorSelectionDialogNew msg csel <- Gtk.colorSelectionDialogGetColor dialog let (r,g,b,_a) = convertPenColorToRGBA pcolor color = Gtk.Color (floor (r*65535.0)) (floor (g*65535.0)) (floor (b*65535.0)) Gtk.colorSelectionSetCurrentColor csel color res <- Gtk.dialogRun dialog mc <- case res of Gtk.ResponseOk -> do clrsel <- Gtk.colorSelectionDialogGetColor dialog clr <- Gtk.colorSelectionGetCurrentColor clrsel return (Just (colorConvert clr)) _ -> return Nothing Gtk.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 pdfRendererMain :: ((UUID,(Double,Cairo.Surface))->IO ()) -> TVar (Seq (UUID,PDFCommand)) -> IO () pdfRendererMain handler tvar = forever $ do -- putStrLn "pdfRenderMain called" p <- atomically $ do lst' <- readTVar tvar case viewl lst' of EmptyL -> retry p :< ps -> do writeTVar tvar ps return p pdfWorker handler p pdfWorker :: ((UUID,(Double,Cairo.Surface))->IO ()) -> (UUID,PDFCommand) -> IO () pdfWorker _handler (_,GetDocFromFile fp tmvar) = do -- putStrLn "pdfWorker : GetDocFromFile" mdoc <- popplerGetDocFromFile fp atomically $ putTMVar tmvar mdoc pdfWorker _handler (_,GetDocFromDataURI str tmvar) = do -- putStrLn "pdfWorker : GetDocFromDataURI" mdoc <- popplerGetDocFromDataURI str atomically $ putTMVar tmvar mdoc pdfWorker _handler (_,GetPageFromDoc doc pn tmvar) = do -- putStrLn "pdfWorker : GetPageFromDoc" mpg <- popplerGetPageFromDoc doc pn atomically $ putTMVar tmvar mpg pdfWorker handler (uuid,RenderPageScaled page (Dim ow oh) (Dim w h)) = do -- putStrLn "pdfWorker : RenderPageScaled" let s = w / ow sfc <- Cairo.createImageSurface Cairo.FormatARGB32 (floor w) (floor h) Cairo.renderWith sfc $ do Cairo.setSourceRGBA 1 1 1 1 Cairo.rectangle 0 0 w h Cairo.fill Cairo.scale s s Poppler.pageRender page handler (uuid,(s,sfc))