{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.TextInput -- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Hoodle.Coroutine.TextInput where import Control.Applicative -- import Control.Concurrent.STM (atomically, newTVar) import Control.Lens (_1,_2,_3,view,set,(%~),(^.),(.~)) import Control.Monad.State hiding (mapM_, forM_) import Control.Monad.Trans.Either import Control.Monad.Trans.Maybe -- import Data.Attoparsec import Data.Attoparsec.Char8 import qualified Data.ByteString.Char8 as B import Data.Foldable (mapM_, forM_) import Data.List (sortBy) import qualified Data.Map as M import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.IO as TIO import Data.UUID.V4 (nextRandom) import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.Rendering.Cairo.SVG as RSVG -- import qualified Graphics.Rendering.Pango.Cairo as Pango import qualified Graphics.UI.Gtk as Gtk import System.Directory import System.Exit (ExitCode(..)) import System.FilePath import System.Process (readProcessWithExitCode) -- import Control.Monad.Trans.Crtn import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Select import Data.Hoodle.Simple import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Type.HitTest import Graphics.Hoodle.Render.Type.Hoodle (rHoodle2Hoodle, rPage2Page) import Graphics.Hoodle.Render.Type.Item import qualified Text.Hoodle.Parse.Attoparsec as PA -- import Hoodle.Accessor import Hoodle.Coroutine.Commit import Hoodle.Coroutine.Dialog import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Mode import Hoodle.Coroutine.Network import Hoodle.Coroutine.Select.Clipboard import Hoodle.ModelAction.Layer import Hoodle.ModelAction.Page import Hoodle.ModelAction.Select import Hoodle.ModelAction.Select.Transform import Hoodle.ModelAction.Text 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.Util -- import Prelude hiding (readFile,mapM_) -- | single line text input : almost abandoned now textInputDialog :: MainCoroutine (Maybe String) textInputDialog = do doIOaction $ \_evhandler -> do dialog <- Gtk.messageDialogNew Nothing [Gtk.DialogModal] Gtk.MessageQuestion Gtk.ButtonsOkCancel "text input" vbox <- Gtk.dialogGetUpper dialog txtvw <- Gtk.textViewNew Gtk.boxPackStart vbox txtvw Gtk.PackGrow 0 Gtk.widgetShowAll dialog res <- Gtk.dialogRun dialog case res of Gtk.ResponseOk -> do buf <- Gtk.textViewGetBuffer txtvw (istart,iend) <- (,) <$> Gtk.textBufferGetStartIter buf <*> Gtk.textBufferGetEndIter buf l <- Gtk.textBufferGetText buf istart iend True Gtk.widgetDestroy dialog return (UsrEv (TextInput (Just l))) _ -> do Gtk.widgetDestroy dialog return (UsrEv (TextInput Nothing)) let go = do r <- nextevent case r of TextInput input -> return input UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> go _ -> go go -- | common dialog with multiline edit input box multiLineDialog :: T.Text -> Either (ActionOrder AllEvent) AllEvent multiLineDialog str = mkIOaction $ \evhandler -> do dialog <- Gtk.dialogNew vbox <- Gtk.dialogGetUpper dialog textbuf <- Gtk.textBufferNew Nothing Gtk.textBufferSetByteString textbuf (TE.encodeUtf8 str) textbuf `Gtk.on` Gtk.bufferChanged $ do (s,e) <- (,) <$> Gtk.textBufferGetStartIter textbuf <*> Gtk.textBufferGetEndIter textbuf contents <- Gtk.textBufferGetByteString textbuf s e False (evhandler . UsrEv . MultiLine . MultiLineChanged) (TE.decodeUtf8 contents) textarea <- Gtk.textViewNewWithBuffer textbuf vscrbar <- Gtk.vScrollbarNew =<< Gtk.textViewGetVadjustment textarea hscrbar <- Gtk.hScrollbarNew =<< Gtk.textViewGetHadjustment textarea textarea `Gtk.on` Gtk.sizeRequest $ return (Gtk.Requisition 500 600) fdesc <- Gtk.fontDescriptionNew Gtk.fontDescriptionSetFamily fdesc "Mono" Gtk.widgetModifyFont textarea (Just fdesc) -- table <- Gtk.tableNew 2 2 False Gtk.tableAttachDefaults table textarea 0 1 0 1 Gtk.tableAttachDefaults table vscrbar 1 2 0 1 Gtk.tableAttachDefaults table hscrbar 0 1 1 2 Gtk.boxPackStart vbox table Gtk.PackNatural 0 -- _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel _btnNetwork <- Gtk.dialogAddButton dialog "Network" (Gtk.ResponseUser 1) Gtk.widgetShowAll dialog res <- Gtk.dialogRun dialog Gtk.widgetDestroy dialog case res of Gtk.ResponseOk -> return (UsrEv (OkCancel True)) Gtk.ResponseCancel -> return (UsrEv (OkCancel False)) Gtk.ResponseUser 1 -> return (UsrEv (NetworkProcess NetworkDialog)) _ -> return (UsrEv (OkCancel False)) -- | main event loop for multiline edit box multiLineLoop :: T.Text -> MainCoroutine (Maybe T.Text) multiLineLoop txt = do r <- nextevent case r of UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> multiLineLoop txt OkCancel True -> (return . Just) txt OkCancel False -> return Nothing NetworkProcess NetworkDialog -> networkTextInput txt MultiLine (MultiLineChanged txt') -> multiLineLoop txt' _ -> multiLineLoop txt -- | insert text textInput :: Maybe (Double,Double) -> T.Text -> MainCoroutine () textInput mpos str = do case mpos of Just (x0,y0) -> do modify (tempQueue %~ enqueue (multiLineDialog str)) multiLineLoop str >>= mapM_ (\result -> deleteSelection >> liftIO (makePangoTextSVG (x0,y0) result) >>= svgInsert (result,"pango")) Nothing -> liftIO $ putStrLn "textInput: not implemented" -- | insert latex laTeXInput :: Maybe (Double,Double) -> T.Text -> MainCoroutine () laTeXInput mpos str = do case mpos of Just (x0,y0) -> do modify (tempQueue %~ enqueue (multiLineDialog str)) multiLineLoop str >>= mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) result) >>= \case Right r -> deleteSelection >> svgInsert (result,"latex") r Left err -> okMessageBox err >> laTeXInput mpos result ) Nothing -> do modeChange ToViewAppendMode autoPosText >>= maybe (laTeXInput (Just (100,100)) str) (\y'->laTeXInput (Just (100,y')) str) autoPosText :: MainCoroutine (Maybe Double) autoPosText = do cpg <- rPage2Page <$> getCurrentPageCurr let Dim _pgw pgh = view dimension cpg mcomponents = do l <- view layers cpg i <- view items l case i of ItemSVG svg -> case svg_command svg of Just "latex" -> do let (_,y) = svg_pos svg Dim _ h = svg_dim svg return (y,y+h) _ -> [] ItemImage img -> do let (_,y) = img_pos img Dim _ h = img_dim img return (y,y+h) _ -> [] if null mcomponents then return Nothing else do let y0 = (head . sortBy (flip compare) . map snd) mcomponents if y0 + 10 > pgh then return Nothing else return (Just (y0 + 10)) -- | laTeXInputNetwork :: Maybe (Double,Double) -> T.Text -> MainCoroutine () laTeXInputNetwork mpos str = case mpos of Just (x0,y0) -> do networkTextInput str >>= mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) result) >>= \case Right r -> deleteSelection >> svgInsert (result,"latex") r Left err -> okMessageBox err >> laTeXInput mpos result ) Nothing -> do modeChange ToViewAppendMode autoPosText >>= maybe (laTeXInputNetwork (Just (100,100)) str) (\y'->laTeXInputNetwork (Just (100,y')) str) dbusNetworkInput :: T.Text -> MainCoroutine () dbusNetworkInput txt = do modeChange ToViewAppendMode mpos <- autoPosText let pos = maybe (100,100) (100,) mpos rsvg <- liftIO (makeLaTeXSVG pos txt) case rsvg of Right r -> deleteSelection >> svgInsert (txt,"latex") r Left err -> okMessageBox err >> laTeXInput (Just pos) txt laTeXHeader :: T.Text laTeXHeader = "\\documentclass{article}\n\ \\\pagestyle{empty}\n\ \\\begin{document}\n" laTeXFooter :: T.Text laTeXFooter = "\\end{document}\n" makeLaTeXSVG :: (Double,Double) -> T.Text -> IO (Either String (B.ByteString,BBox)) makeLaTeXSVG (x0,y0) txt = do cdir <- getCurrentDirectory tdir <- getTemporaryDirectory tfilename <- show <$> nextRandom setCurrentDirectory tdir let check msg act = liftIO act >>= \(ecode,str) -> case ecode of ExitSuccess -> right () ; _ -> left (msg ++ ":" ++ str) B.writeFile (tfilename <.> "tex") (TE.encodeUtf8 txt) r <- runEitherT $ do check "error during xelatex" $ do (ecode,ostr,estr) <- readProcessWithExitCode "xelatex" [tfilename <.> "tex"] "" return (ecode,ostr++estr) check "error during pdfcrop" $ do (ecode,ostr,estr) <- readProcessWithExitCode "pdfcrop" [tfilename <.> "pdf",tfilename ++ "_crop" <.> "pdf"] "" return (ecode,ostr++estr) check "error during pdf2svg" $ do (ecode,ostr,estr) <- readProcessWithExitCode "pdf2svg" [tfilename ++ "_crop" <.> "pdf",tfilename <.> "svg"] "" return (ecode,ostr++estr) bstr <- liftIO $ B.readFile (tfilename <.> "svg") rsvg <- liftIO $ RSVG.svgNewFromString (B.unpack bstr) let (w,h) = RSVG.svgGetSize rsvg return (bstr,BBox (x0,y0) (x0+fromIntegral w,y0+fromIntegral h)) setCurrentDirectory cdir return r -- | svgInsert :: (T.Text,String) -> (B.ByteString,BBox) -> MainCoroutine () svgInsert (txt,cmd) (svgbstr,BBox (x0,y0) (x1,y1)) = do xstate <- get let pgnum = view (unboxLens currentPageNum) . view currentCanvasInfo $ xstate hdl = getHoodle xstate currpage = getPageFromGHoodleMap pgnum hdl currlayer = getCurrentLayer currpage -- callRenderer ( (return . GotRItem) =<< (cnstrctRItem (ItemSVG (SVG (Just (TE.encodeUtf8 txt)) (Just (B.pack cmd)) svgbstr (x0,y0) (Dim (x1-x0) (y1-y0)))))) RenderEv (GotRItem newitem) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False ) -- let otheritems = view gitems currlayer let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) cache = view renderCache xstate modeChange ToSelectMode nxstate <- get thdl <- case view hoodleModeState nxstate of SelectState thdl' -> return thdl' _ -> (lift . EitherT . return . Left . Other) "svgInsert" nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg pgnum put (set hoodleModeState (SelectState nthdl) nxstate) commit_ invalidateAll -- | convertLinkFromSimpleToDocID :: Link -> IO (Maybe Link) convertLinkFromSimpleToDocID (Link i _typ lstr txt cmd rdr pos dim) = do case urlParse (B.unpack lstr) of Nothing -> return Nothing Just (HttpUrl _url) -> return Nothing Just (FileUrl file) -> do b <- doesFileExist file if b then do bstr <- B.readFile file case parseOnly PA.hoodle bstr of Left _str -> return Nothing Right hdl -> do let uuid = view hoodleID hdl link = LinkDocID i uuid (B.pack file) txt cmd rdr pos dim return (Just link) else return Nothing convertLinkFromSimpleToDocID _ = return Nothing -- | linkInsert :: B.ByteString -> (B.ByteString,FilePath) -> String -> (B.ByteString,BBox) -> MainCoroutine () linkInsert _typ (uuidbstr,fname) str (svgbstr,BBox (x0,y0) (x1,y1)) = do xstate <- get let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate lnk = Link uuidbstr "simple" (B.pack fname) (Just (B.pack str)) Nothing svgbstr (x0,y0) (Dim (x1-x0) (y1-y0)) nlnk <- liftIO $ convertLinkFromSimpleToDocID lnk >>= maybe (return lnk) return -- callRenderer $ return . GotRItem =<< cnstrctRItem (ItemLink nlnk) RenderEv (GotRItem newitem) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False) -- insertItemAt (Just (PageNum pgnum, PageCoord (x0,y0))) newitem -- | anchor addAnchor :: MainCoroutine () addAnchor = do uuid <- liftIO $ nextRandom let uuidbstr = B.pack (show uuid) let anc = Anchor uuidbstr "" (100,100) (Dim 50 50) -- callRenderer $ return . GotRItem =<< cnstrctRItem (ItemAnchor anc) RenderEv (GotRItem nitm) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False) -- insertItemAt Nothing nitm -- | makePangoTextSVG :: (Double,Double) -> T.Text -> IO (B.ByteString,BBox) makePangoTextSVG (xo,yo) str = do let pangordr = do ctxt <- Gtk.cairoCreateContext Nothing layout <- Gtk.layoutEmpty ctxt Gtk.layoutSetWidth layout (Just 400) Gtk.layoutSetWrap layout Gtk.WrapAnywhere Gtk.layoutSetText layout (T.unpack str) -- this is gtk2hs pango limitation (_,reclog) <- Gtk.layoutGetExtents layout let Gtk.PangoRectangle x y w h = reclog -- 10 is just dirty-fix return (layout,BBox (x,y) (x+w+10,y+h)) rdr layout = do Cairo.setSourceRGBA 0 0 0 1 Gtk.updateLayout layout Gtk.showLayout layout (layout,(BBox (x0,y0) (x1,y1))) <- pangordr tdir <- getTemporaryDirectory let tfile = tdir "embedded.svg" Cairo.withSVGSurface tfile (x1-x0) (y1-y0) $ \s -> Cairo.renderWith s (rdr layout) bstr <- B.readFile tfile return (bstr,BBox (xo,yo) (xo+x1-x0,yo+y1-y0)) -- | combine all LaTeX texts into a text file combineLaTeXText :: MainCoroutine () combineLaTeXText = do hdl <- rHoodle2Hoodle . getHoodle <$> get let mlatex_components = do (pgnum,pg) <- (zip ([1..] :: [Int]) . view pages) hdl l <- view layers pg i <- view items l case i of ItemSVG svg -> case svg_command svg of Just "latex" -> do let (_,y) = svg_pos svg return ((pgnum,y,) <$> svg_text svg) _ -> [] _ -> [] let cfunc :: (Ord a,Ord b,Ord c) => (a,b,c) -> (a,b,c) -> Ordering cfunc x y | view _1 x > view _1 y = GT | view _1 x < view _1 y = LT | otherwise = if | view _2 x > view _2 y -> GT | view _2 x < view _2 y -> LT | otherwise -> EQ let latex_components = catMaybes mlatex_components sorted = sortBy cfunc latex_components resulttxt = (B.intercalate "%%%%%%%%%%%%\n\n%%%%%%%%%%\n" . map (view _3)) sorted mfilename <- fileChooser Gtk.FileChooserActionSave Nothing forM_ mfilename (\filename -> liftIO (B.writeFile filename resulttxt) >> return ()) insertItemAt :: Maybe (PageNum,PageCoordinate) -> RItem -> MainCoroutine () insertItemAt mpcoord ritm = do xst <- get geometry <- liftIO (getGeometry4CurrCvs xst) let hdl = getHoodle xst (pgnum,mpos) = case mpcoord of Just (PageNum n,pos) -> (n,Just pos) Nothing -> (view (currentCanvasInfo . unboxLens currentPageNum) xst,Nothing) (ulx,uly) = (bbox_upperleft.getBBox) ritm nitms = case mpos of Nothing -> adjustItemPosition4Paste geometry (PageNum pgnum) [ritm] Just (PageCoord (nx,ny)) -> map (changeItemBy (\(x,y)->(x+nx-ulx,y+ny-uly))) [ritm] let pg = getPageFromGHoodleMap pgnum hdl lyr = getCurrentLayer pg oitms = view gitems lyr ntpg = makePageSelectMode pg (oitms :- (Hitted nitms) :- Empty) modeChange ToSelectMode nxst <- get let cache = view renderCache nxst thdl <- case view hoodleModeState nxst of SelectState thdl' -> return thdl' _ -> (lift . EitherT . return . Left . Other) "insertItemAt" nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg pgnum put ( ( set hoodleModeState (SelectState nthdl) . set isOneTimeSelectMode YesAfterSelect) nxst) invalidateAll embedTextSource :: MainCoroutine () embedTextSource = do mfilename <- fileChooser Gtk.FileChooserActionOpen Nothing forM_ mfilename $ \filename -> do txt <- liftIO $ TIO.readFile filename xst <- get let nhdlmodst = case xst ^. hoodleModeState of ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just txt) $ hdl) SelectState thdl -> (SelectState . (gselEmbeddedText .~ Just txt) $ thdl) nxst = (hoodleModeState .~ nhdlmodst) xst put nxst commit_ -- | editEmbeddedTextSource :: MainCoroutine () editEmbeddedTextSource = do hdl <- getHoodle <$> get let mtxt = hdl ^. gembeddedtext forM_ mtxt $ \txt -> do modify (tempQueue %~ enqueue (multiLineDialog txt)) multiLineLoop txt >>= \case Nothing -> return () Just ntxt -> do modify $ \xst -> let nhdlmodst = case xst ^. hoodleModeState of ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just ntxt) $ hdl) SelectState thdl -> (SelectState . (gselEmbeddedText .~ Just ntxt) $ thdl) in (hoodleModeState .~ nhdlmodst) xst commit_ -- | editNetEmbeddedTextSource :: MainCoroutine () editNetEmbeddedTextSource = do hdl <- getHoodle <$> get let mtxt = hdl ^. gembeddedtext forM_ mtxt $ \txt -> do -- modify (tempQueue %~ enqueue (multiLineDialog txt)) networkTextInput txt >>= \case Nothing -> return () Just ntxt -> do modify $ \xst -> let nhdlmodst = case xst ^. hoodleModeState of ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just ntxt) $ hdl) SelectState thdl -> (SelectState . (gselEmbeddedText .~ Just ntxt) $ thdl) in (hoodleModeState .~ nhdlmodst) xst commit_ -- | insert text textInputFromSource :: (Double,Double) -> MainCoroutine () textInputFromSource (x0,y0) = do runMaybeT $ do txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle <$> get lift $ modify (tempQueue %~ enqueue linePosDialog) (l1,l2) <- MaybeT linePosLoop let txt = getLinesFromText (l1,l2) txtsrc lift $ deleteSelection liftIO (makePangoTextSVG (x0,y0) txt) >>= lift . svgInsert ("embedtxt:simple:L" <> T.pack (show l1) <> "," <> T.pack (show l2),"pango") return () -- | common dialog with line position linePosDialog :: Either (ActionOrder AllEvent) AllEvent linePosDialog = mkIOaction $ \evhandler -> do dialog <- Gtk.dialogNew vbox <- Gtk.dialogGetUpper dialog hbox <- Gtk.hBoxNew False 0 Gtk.boxPackStart vbox hbox Gtk.PackNatural 0 line1buf <- Gtk.entryBufferNew Nothing line1 <- Gtk.entryNewWithBuffer line1buf Gtk.boxPackStart hbox line1 Gtk.PackNatural 2 line2buf <- Gtk.entryBufferNew Nothing line2 <- Gtk.entryNewWithBuffer line2buf Gtk.boxPackStart hbox line2 Gtk.PackNatural 2 -- _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel Gtk.widgetShowAll dialog res <- Gtk.dialogRun dialog Gtk.widgetDestroy dialog case res of Gtk.ResponseOk -> do line1str <- B.pack <$> Gtk.get line1buf Gtk.entryBufferText line2str <- B.pack <$> Gtk.get line2buf Gtk.entryBufferText let el1l2 = (,) <$> parseOnly decimal line1str <*> parseOnly decimal line2str return . UsrEv . LinePosition . either (const Nothing) (\(l1,l2)->if l1 <= l2 then Just (l1,l2) else Nothing) $ el1l2 Gtk.ResponseCancel -> return (UsrEv (LinePosition Nothing)) _ -> return (UsrEv (LinePosition Nothing)) -- | main event loop for line position dialog linePosLoop :: MainCoroutine (Maybe (Int,Int)) linePosLoop = do r <- nextevent case r of UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> linePosLoop LinePosition x -> return x _ -> linePosLoop -- | insert text laTeXInputKeyword :: (Double,Double) -> T.Text -> MaybeT MainCoroutine () laTeXInputKeyword (x0,y0) keyword = do txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle <$> get subpart <- (MaybeT . return . M.lookup keyword . getKeywordMap) txtsrc let subpart' = laTeXHeader <> "\n" <> subpart <> laTeXFooter liftIO (makeLaTeXSVG (x0,y0) subpart') >>= \case Right r -> lift $ do deleteSelection svgInsert ("embedlatex:keyword:"<>keyword,"latex") r Left err -> lift $ do okMessageBox err return () -- | insert text laTeXInputFromSource :: (Double,Double) -> MainCoroutine () laTeXInputFromSource (x0,y0) = do runMaybeT $ do txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle <$> get lift $ modify (tempQueue %~ enqueue keywordDialog) keyword <- MaybeT keywordLoop laTeXInputKeyword (x0,y0) keyword return () -- | common dialog with line position keywordDialog :: Either (ActionOrder AllEvent) AllEvent keywordDialog = mkIOaction $ \evhandler -> do dialog <- Gtk.dialogNew vbox <- Gtk.dialogGetUpper dialog hbox <- Gtk.hBoxNew False 0 Gtk.boxPackStart vbox hbox Gtk.PackNatural 0 keybuf <- Gtk.entryBufferNew Nothing key <- Gtk.entryNewWithBuffer keybuf Gtk.boxPackStart hbox key Gtk.PackNatural 2 -- _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel Gtk.widgetShowAll dialog res <- Gtk.dialogRun dialog Gtk.widgetDestroy dialog case res of Gtk.ResponseOk -> do keystr <- T.pack <$> Gtk.get keybuf Gtk.entryBufferText (return . UsrEv . Keyword . Just) keystr Gtk.ResponseCancel -> return (UsrEv (Keyword Nothing)) _ -> return (UsrEv (Keyword Nothing)) -- | main event loop for line position dialog keywordLoop :: MainCoroutine (Maybe T.Text) keywordLoop = do r <- nextevent case r of UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> keywordLoop Keyword x -> return x _ -> keywordLoop