hoodle-core-0.10: src/Hoodle/Coroutine/Link.hs
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Link
-- Copyright : (c) 2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Hoodle.Coroutine.Link where
import Control.Applicative
import Control.Lens (view,(%~))
import Control.Monad.State
import Control.Monad.Trans.Maybe
import qualified Data.ByteString.Char8 as B
import Data.UUID.V4 (nextRandom)
import Graphics.UI.Gtk hiding (get,set)
import System.FilePath
-- from hoodle-platform
import Control.Monad.Trans.Crtn.Event
import Control.Monad.Trans.Crtn.Queue
import Data.Hoodle.BBox
import Graphics.Hoodle.Render.Item
import Graphics.Hoodle.Render.Type
import Graphics.Hoodle.Render.Type.HitTest
import Graphics.Hoodle.Render.Util.HitTest
-- from this package
import Hoodle.Accessor
import Hoodle.Coroutine.Draw
import Hoodle.Coroutine.File
import Hoodle.Coroutine.TextInput
import Hoodle.Device
import Hoodle.Type.Canvas
import Hoodle.Type.Coroutine
import Hoodle.Type.Event
import Hoodle.Type.HoodleState
import Hoodle.Type.PageArrangement
import Hoodle.Util
import Hoodle.View.Coordinate
import Hoodle.View.Draw
--
import Prelude hiding (mapM_, mapM)
notifyLink :: CanvasId -> PointerCoord -> MainCoroutine ()
notifyLink cid pcoord = do
xst <- get
(boxAction f . getCanvasInfo cid) xst
where
f :: forall b. (ViewMode b) => CanvasInfo b -> MainCoroutine ()
f cvsInfo = do
let cpn = PageNum . view currentPageNum $ cvsInfo
arr = view (viewInfo.pageArrangement) cvsInfo
canvas = view drawArea cvsInfo
geometry <- liftIO $ makeCanvasGeometry cpn arr canvas
case (desktop2Page geometry . device2Desktop geometry) pcoord of
Nothing -> return ()
Just (pnum,PageCoord (x,y)) -> do
itms <- rItmsInCurrLyr
let lnks = filter isLinkInRItem itms
hlnks = hltFilteredBy (\itm->isPointInBBox (getBBox itm) (x,y)) lnks
hitted = takeHitted hlnks
when ((not.null) hitted) $ do
let lnk = head hitted
bbx = getBBox lnk
bbx_desk = xformBBox (unDeskCoord . page2Desktop geometry
. (pnum,) . PageCoord) bbx
invalidateInBBox (Just bbx_desk) Efficient cid
-- | got a link address (or embedded image) from drag and drop
gotLink :: Maybe String -> (Int,Int) -> MainCoroutine ()
gotLink mstr (x,y) = do
xst <- get
let cid = getCurrentCanvasId xst
mr <- runMaybeT $ do
str <- (MaybeT . return) mstr
let (str1,rem1) = break (== ',') str
guard ((not.null) rem1)
return (B.pack str1,tail rem1)
case mr of
Nothing -> do
mr2 <- runMaybeT $ do
str <- (MaybeT . return) mstr
(MaybeT . return) (urlParse str)
case mr2 of
Nothing -> liftIO $ putStrLn "nothing"
Just (FileUrl file) -> do
liftIO $ print file
let ext = takeExtension file
if ext == ".png" || ext == ".PNG" || ext == ".jpg" || ext == ".JPG"
then do
let isembedded = view (settings.doesEmbedImage) xst
nitm <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded file)
geometry <- liftIO $ getCanvasGeometryCvsId cid xst
let ccoord = CvsCoord (fromIntegral x,fromIntegral y)
mpgcoord = (desktop2Page geometry . canvas2Desktop geometry)
ccoord
insertItemAt mpgcoord nitm
{- let ccoord = CvsCoord (fromIntegral x,fromIntegral y)
mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord
rdr' = case mpgcoord of
Nothing -> rdr
Just (_,PageCoord (x',y')) ->
let bbox' = moveBBoxULCornerTo (x',y') (snd rdr)
in (fst rdr,bbox')
liftIO $ print mpgcoord
liftIO $ print (snd rdr')
linkInsert "simple" (uuidbstr,fp) fn rdr' -}
else return ()
Just (uuidbstr,fp) -> do
let fn = takeFileName fp
rdr <- liftIO (makePangoTextSVG fn)
geometry <- liftIO $ getCanvasGeometryCvsId cid xst
let ccoord = CvsCoord (fromIntegral x,fromIntegral y)
mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord
rdr' = case mpgcoord of
Nothing -> rdr
Just (_,PageCoord (x',y')) ->
let bbox' = moveBBoxULCornerTo (x',y') (snd rdr)
in (fst rdr,bbox')
liftIO $ print mpgcoord
liftIO $ print (snd rdr')
linkInsert "simple" (uuidbstr,fp) fn rdr'
liftIO $ putStrLn "gotLink"
liftIO $ print mstr
liftIO $ print (x,y)
-- |
addLink :: MainCoroutine ()
addLink = do
mfilename <- fileChooser FileChooserActionOpen Nothing
modify (tempQueue %~ enqueue (action mfilename))
minput <- go
case minput of
Nothing -> return ()
Just (str,fname) -> do
uuid <- liftIO $ nextRandom
let uuidbstr = B.pack (show uuid)
rdr <- liftIO (makePangoTextSVG str)
linkInsert "simple" (uuidbstr,fname) str rdr
where
go = do r <- nextevent
case r of
AddLink minput -> return minput
UpdateCanvas cid -> -- this is temporary
(invalidateInBBox Nothing Efficient cid) >> go
_ -> go
action mfn = Left . ActionOrder $
\_evhandler -> do
dialog <- messageDialogNew Nothing [DialogModal]
MessageQuestion ButtonsOkCancel "add link"
vbox <- dialogGetUpper dialog
txtvw <- textViewNew
boxPackStart vbox txtvw PackGrow 0
widgetShowAll dialog
res <- dialogRun dialog
case res of
ResponseOk -> do
buf <- textViewGetBuffer txtvw
(istart,iend) <- (,) <$> textBufferGetStartIter buf
<*> textBufferGetEndIter buf
l <- textBufferGetText buf istart iend True
widgetDestroy dialog
return (AddLink ((l,) <$> mfn))
_ -> do
widgetDestroy dialog
return (AddLink Nothing)