hoodle-core 0.10 → 0.11

raw patch · 40 files changed

+477/−323 lines, 40 filesdep ~hoodle-renderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hoodle-render

API changes (from Hackage documentation)

Files

• hoodle-core.cabal +5/−22
• resource/menu.xml +1/−0
• src/Hoodle/Config.hs +1/−1
• src/Hoodle/Coroutine/Callback.hs +3/−10
• src/Hoodle/Coroutine/ContextMenu.hs +65/−46
• src/Hoodle/Coroutine/Default.hs +13/−4
• src/Hoodle/Coroutine/File.hs +4/−3
• src/Hoodle/Coroutine/Highlighter.hs +1/−1
• src/Hoodle/Coroutine/Layer.hs +1/−1
• src/Hoodle/Coroutine/Link.hs +69/−39
• src/Hoodle/Coroutine/Page.hs +1/−1
• src/Hoodle/Coroutine/Pen.hs +1/−1
• src/Hoodle/Coroutine/Scroll.hs +1/−1
• src/Hoodle/Coroutine/Select.hs +2/−2
• src/Hoodle/Coroutine/Select/Clipboard.hs +1/−1
• src/Hoodle/Coroutine/TextInput.hs +3/−3
• src/Hoodle/Coroutine/Window.hs +1/−1
• src/Hoodle/Device.hsc +1/−1
• src/Hoodle/GUI.hs +7/−5
• src/Hoodle/GUI/Menu.hs +8/−7
• src/Hoodle/GUI/Reflect.hs +1/−3
• src/Hoodle/ModelAction/ContextMenu.hs +80/−0
• src/Hoodle/ModelAction/File.hs +2/−2
• src/Hoodle/Script.hs +1/−1
• src/Hoodle/Script/Coroutine.hs +1/−1
• src/Hoodle/Type.hs +1/−1
• src/Hoodle/Type/Alias.hs +1/−1
• src/Hoodle/Type/Canvas.hs +9/−35
• src/Hoodle/Type/Coroutine.hs +1/−1
• src/Hoodle/Type/Event.hs +3/−1
• src/Hoodle/Type/HoodleState.hs +7/−10
• src/Hoodle/Type/PageArrangement.hs +1/−1
• src/Hoodle/Type/Predefined.hs +1/−1
• src/Hoodle/Type/Undo.hs +3/−2
• src/Hoodle/Type/Widget.hs +53/−0
• src/Hoodle/Type/Window.hs +1/−1
• src/Hoodle/Util.hs +18/−5
• src/Hoodle/View/Coordinate.hs +1/−1
• src/Hoodle/View/Draw.hs +49/−21
• src/Hoodle/Widget/PanZoom.hs +54/−85

@@ -1,5 +1,5 @@ Name:		hoodle-core-Version:	0.10+Version:	0.11 Synopsis:	Core library for hoodle Description: 	Hoodle is a pen notetaking program written in haskell.                  hoodle-core is the core library written in haskell and @@ -22,11 +22,6 @@   type: git   location: http://www.github.com/wavewave/hoodle-core --- Flag Poppler---  Description: Enable poppler support---  Default:     False-- Library   hs-source-dirs: src   ghc-options: 	-Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans@@ -46,10 +41,9 @@                    transformers == 0.3.*,                    transformers-free == 1.0.*,                    hoodle-types >= 0.2,-                   -- hoodle-common >= 0.1,                     hoodle-parser >= 0.2,                    xournal-parser >= 0.5.0.1,-                   hoodle-render >= 0.3,+                   hoodle-render >= 0.3.1,                    hoodle-builder >= 0.2,                    containers >= 0.4,                    template-haskell == 2.*,@@ -70,13 +64,6 @@                    monad-loops >= 0.3,                     network,                     poppler >= 0.12.2.2-                   ---   if flag(poppler) ---     Build-Depends:    ---   else ---     Build-Depends:--   Exposed-Modules:                     Hoodle.Accessor                    Hoodle.Config@@ -87,7 +74,6 @@                    Hoodle.Coroutine.Default                    Hoodle.Coroutine.Draw                    Hoodle.Coroutine.Eraser-                   -- Hoodle.Coroutine.EventConnect                    Hoodle.Coroutine.File                    Hoodle.Coroutine.Highlighter                    Hoodle.Coroutine.Layer@@ -98,7 +84,6 @@                    Hoodle.Coroutine.Scroll                    Hoodle.Coroutine.Select                    Hoodle.Coroutine.Select.Clipboard-                   -- Hoodle.Coroutine.Select.Transform                    Hoodle.Coroutine.TextInput                    Hoodle.Coroutine.VerticalSpace                     Hoodle.Coroutine.Window@@ -108,9 +93,9 @@                    Hoodle.GUI.Reflect                     Hoodle.ModelAction.Adjustment                    Hoodle.ModelAction.Clipboard+                   Hoodle.ModelAction.ContextMenu                    Hoodle.ModelAction.Eraser                    Hoodle.ModelAction.File-                   -- Hoodle.ModelAction.Item                    Hoodle.ModelAction.Layer                    Hoodle.ModelAction.Page                    Hoodle.ModelAction.Pen @@ -127,13 +112,13 @@                    Hoodle.Type.Coroutine                    Hoodle.Type.Enum                    Hoodle.Type.Event +                   Hoodle.Type.HoodleState                    Hoodle.Type.PageArrangement                     Hoodle.Type.Predefined                    Hoodle.Type.Undo                     Hoodle.Type.Window-                   Hoodle.Type.HoodleState+                   Hoodle.Type.Widget                     Hoodle.Util-                   -- Hoodle.Util.Process                    Hoodle.View.Coordinate                    Hoodle.View.Draw                    Hoodle.Widget.PanZoom@@ -147,5 +132,3 @@                    csrc/template-hsc-gtk2hs.h   cc-options:      -Wno-pointer-to-int-cast ---   if flag(poppler)---    cpp-options: -DPOPPLER

@@ -145,6 +145,7 @@        <menuitem action="POPMENUA" />         <menuitem action="EBDIMGA" />        <menuitem action="EBDPDFA" />+       <menuitem action="WIDGETTOGGLEA" />        <menuitem action="DCRDCOREA" />                                <menuitem action="ERSRTIPA" />                                <menuitem action="PRESSRSENSA" />                        

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Config --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Callback--- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -13,12 +13,7 @@ module Hoodle.Coroutine.Callback where  import Control.Concurrent-import Control.Exception--- import Data.Time--- import System.Directory--- import System.Environment--- import System.FilePath--- import System.Locale+import Control.Exception (SomeException(..),ErrorCall,PatternMatchFail,catch) import System.IO import System.Exit --@@ -27,12 +22,10 @@ --  import Hoodle.Util -- -import Prelude hiding (catch)+import Prelude (show,Maybe(..),) -- hiding (catch)  eventHandler :: MVar (Maybe (Driver e IO ())) -> e -> IO () eventHandler evar ev = E.eventHandler evar ev `catch` allexceptionproc -    -    -- `catches` [Handler errorcall, Handler patternerr]     allexceptionproc :: SomeException -> IO () allexceptionproc e = do errorlog (show e)

@@ -23,6 +23,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.IntMap as IM import           Data.Monoid+import           Data.UUID.V4  import           Graphics.Rendering.Cairo import           Graphics.UI.Gtk hiding (get,set) import           System.Directory @@ -34,7 +35,7 @@ import           Data.Hoodle.BBox import           Data.Hoodle.Generic import           Data.Hoodle.Select-import           Data.Hoodle.Simple (Item(..),Link(..),hoodleID)+import           Data.Hoodle.Simple (SVG(..),Item(..),Link(..),hoodleID) import           Graphics.Hoodle.Render import           Graphics.Hoodle.Render.Item import           Graphics.Hoodle.Render.Type@@ -47,6 +48,8 @@ import           Hoodle.Coroutine.File import           Hoodle.Coroutine.Scroll import           Hoodle.Coroutine.Select.Clipboard +import           Hoodle.Coroutine.TextInput +import           Hoodle.ModelAction.ContextMenu import           Hoodle.ModelAction.Page  import           Hoodle.ModelAction.Select import           Hoodle.ModelAction.Select.Transform@@ -55,28 +58,23 @@ import           Hoodle.Type.Event import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement +import           Hoodle.Util -- import Prelude hiding ((.),id)  processContextMenu :: ContextMenuEvent -> MainCoroutine ()  processContextMenu (CMenuSaveSelectionAs ityp) = do -  xstate <- get-  case view hoodleModeState xstate of -    SelectState thdl -> do -      liftIO $ putStrLn "SelectState"-      case view gselSelected thdl of -        Nothing -> return () -        Just (_,tpg) -> do -          let hititms = getSelectedItms tpg  -              ulbbox = unUnion . mconcat . fmap (Union . Middle . getBBox) -                         $ hititms -          case ulbbox of -            Middle bbox -> -              case ityp of -                SVG -> exportCurrentSelectionAsSVG hititms bbox-                PDF -> exportCurrentSelectionAsPDF hititms bbox-            _ -> return () -    _ -> return () +  xst <- get+  case getSelectedItmsFromHoodleState xst of+    Nothing -> return ()+    Just hititms ->+      let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms +      in case ulbbox of +           Middle bbox -> +             case ityp of +               TypSVG -> exportCurrentSelectionAsSVG hititms bbox+               TypPDF -> exportCurrentSelectionAsPDF hititms bbox+           _ -> return ()  processContextMenu CMenuCut = cutSelection processContextMenu CMenuCopy = copySelection processContextMenu CMenuDelete = deleteSelection@@ -123,7 +121,25 @@               commit . set hoodleModeState (SelectState nthdl)                 =<< (liftIO (updatePageAll (SelectState nthdl) xst))               invalidateAll -+processContextMenu CMenuCreateALink = do +  liftIO $ putStrLn "create a link called"+  mfilename <- fileChooser FileChooserActionOpen Nothing+  case mfilename of +    Nothing -> return () +    Just fname -> do +      xst <- get +      case getSelectedItmsFromHoodleState xst of +        Nothing -> return () +        Just hititms -> +          let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms +          in case ulbbox of +               Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do +                 svg <- liftIO $ makeSVGFromSelection hititms bbox+                 uuid <- liftIO $ nextRandom+                 let uuidbstr = B.pack (show uuid) +                 deleteSelection +                 linkInsert "simple" (uuidbstr,fname) fname (svg_render svg,bbox)  +               _ -> return ()  processContextMenu CMenuCustom =       either (const (return ())) action . hoodleModeStateEither . view hoodleModeState =<< get    where action thdl = do    @@ -192,9 +208,9 @@                     menuitem4 <- menuItemNewWithLabel "Copy"                     menuitem5 <- menuItemNewWithLabel "Delete"                     menuitem1 `on` menuItemActivate $   -                      evhandler (GotContextMenuSignal (CMenuSaveSelectionAs SVG))+                      evhandler (GotContextMenuSignal (CMenuSaveSelectionAs TypSVG))                     menuitem2 `on` menuItemActivate $ -                      evhandler (GotContextMenuSignal (CMenuSaveSelectionAs PDF))+                      evhandler (GotContextMenuSignal (CMenuSaveSelectionAs TypPDF))                     menuitem3 `on` menuItemActivate $                        evhandler (GotContextMenuSignal (CMenuCut))                          menuitem4 `on` menuItemActivate $    @@ -206,33 +222,39 @@                     menuAttach menu menuitem3 1 2 0 1                                          menuAttach menu menuitem4 1 2 1 2                                          menuAttach menu menuitem5 1 2 2 3    +                    +                    maybe (return ()) (\mi -> menuAttach menu mi 1 2 4 5) =<< menuCreateALink evhandler sitms +                                         case sitms of                        sitm : [] -> do                          case sitm of                            RItemLink lnkbbx _msfc -> do                              let lnk = bbxed_content lnkbbx-                            let fp = (B.unpack . link_location) lnk-                                cmdargs = [fp]-                            menuitemlnk <- menuItemNewWithLabel ("Open "++fp) -                            menuitemlnk `on` menuItemActivate $ do-                              createProcess (proc "hoodle" cmdargs)  -                              return () -                            menuAttach menu menuitemlnk 0 1 3 4 +                            maybe (return ()) +                                  (\urlpath -> do +                                    milnk <- menuOpenALink evhandler urlpath+                                    menuAttach menu milnk 0 1 3 4    +                                  )+                                  (urlParse ((B.unpack . link_location) lnk))                             case lnk of -                              Link i _typ file txt cmd rdr pos dim -> do -                                b <- doesFileExist (B.unpack file)-                                when b $ do -                                  bstr <- B.readFile (B.unpack file)-                                  case parseOnly PA.hoodle bstr of -                                    Left str -> print str -                                    Right hdl -> do -                                      let uuid = view hoodleID hdl-                                          link = LinkDocID i uuid file txt cmd rdr pos dim-                                          -                                      menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid) -                                      menuitemcvt `on` menuItemActivate $ do-                                        evhandler (GotContextMenuSignal (CMenuLinkConvert link))-                                      menuAttach menu menuitemcvt 0 1 4 5 +                              Link i _typ lstr txt cmd rdr pos dim -> do +                                case urlParse (B.unpack lstr) of +                                  Nothing -> return ()+                                  Just (HttpUrl url) -> return ()+                                  Just (FileUrl file) -> do +                                    b <- doesFileExist file+                                    when b $ do +                                      bstr <- B.readFile file+                                      case parseOnly PA.hoodle bstr of +                                        Left str -> print str +                                        Right hdl -> do +                                          let uuid = view hoodleID hdl+                                              link = LinkDocID i uuid (B.pack file) txt cmd rdr pos dim++                                          menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid) +                                          menuitemcvt `on` menuItemActivate $ do+                                            evhandler (GotContextMenuSignal (CMenuLinkConvert link))+                                          menuAttach menu menuitemcvt 0 1 4 5                                LinkDocID i lid file txt cmd rdr pos dim -> do                                  case (lookupPathFromId =<< view hookSet xstate) of                                   Nothing -> return () @@ -249,11 +271,8 @@                                             menuitemcvt `on` menuItemActivate $ do                                               evhandler (GotContextMenuSignal (CMenuLinkConvert link))                                             menuAttach menu menuitemcvt 0 1 4 5 -                                   ---                           _ -> return () +                                             _ -> return ()                  case (customContextMenuTitle =<< view hookSet xstate) of                    Nothing -> return () 

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Default --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -84,8 +84,9 @@               -> Maybe Hook                -> Int -- ^ maxundo                -> Bool -- ^ xinputbool +              -> Statusbar -- ^ status bar                -> IO (EventVar,HoodleState,UIManager,VBox)-initCoroutine devlst window mfname mhook maxundo xinputbool = do +initCoroutine devlst window mfname mhook maxundo xinputbool stbar = do    evar <- newEmptyMVar     putMVar evar Nothing    st0new <- set deviceList devlst  @@ -107,6 +108,7 @@           . set frameState wconf'            . set rootWindow cvs            . set uiComponentSignalHandler uicompsighdlr +          . set statusBar (Just stbar)           $ st4              st6 <- getFileContent mfname st5@@ -128,11 +130,17 @@ initialize :: MyEvent -> MainCoroutine () initialize ev = do       case ev of -      Initialized -> do return () -                        -- additional initialization goes here+      Initialized -> do -- additional initialization goes here                         viewModeChange ToContSinglePage                         -- pageZoomChange (Zoom 0.3)                           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 ev' @@ -353,6 +361,7 @@     modify (set hoodleModeState (ViewAppendState nhdl))     invalidateAll  menuEventProcess MenuEmbedAllPDFBkg = embedAllPDFBackground+menuEventProcess MenuWidgetToggle = togglePanZoom menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m   

@@ -64,7 +64,7 @@ -- import           Hoodle.Type.Alias import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine-import           Hoodle.Type.Event hiding (SVG)+import           Hoodle.Type.Event hiding (TypSVG) import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement import           Hoodle.View.Draw@@ -254,8 +254,9 @@     xstate' <- liftIO $ getFileContent (Just filename) xstate     ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate')     xstateNew <- return $ over currentCanvasInfo (const ncvsinfo) xstate'-    put . set isSaved True -      $ xstateNew +    put . set isSaved True $ xstateNew +    let ui = view gtkUIManager xstate+    liftIO $ toggleSave ui False     liftIO $ setTitleFromFileName xstateNew       clearUndoHistory      modeChange ToViewAppendMode 

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Highlighter --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Layer --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -20,10 +20,9 @@ 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.Monoid (mconcat) import           Data.UUID.V4 (nextRandom) import           Graphics.UI.Gtk hiding (get,set)  import           System.FilePath @@ -31,6 +30,7 @@ import           Control.Monad.Trans.Crtn.Event  import           Control.Monad.Trans.Crtn.Queue  import           Data.Hoodle.BBox+import           Data.Hoodle.Simple (SVG(..)) import           Graphics.Hoodle.Render.Item  import           Graphics.Hoodle.Render.Type  import           Graphics.Hoodle.Render.Type.HitTest @@ -39,8 +39,11 @@ import           Hoodle.Accessor import           Hoodle.Coroutine.Draw import           Hoodle.Coroutine.File +import           Hoodle.Coroutine.Select.Clipboard import           Hoodle.Coroutine.TextInput  import           Hoodle.Device +import           Hoodle.ModelAction.ContextMenu+import           Hoodle.ModelAction.Select import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine import           Hoodle.Type.Event@@ -52,6 +55,22 @@ -- import Prelude hiding (mapM_, mapM) +makeTextSVGFromStringAt :: String +                           -> CanvasId +                           -> HoodleState+                           -> CanvasCoordinate+                           -> IO (B.ByteString, BBox)+makeTextSVGFromStringAt str cid xst ccoord = do +    rdr <- makePangoTextSVG str +    geometry <- getCanvasGeometryCvsId cid xst +    let mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord +    return $ case mpgcoord of +               Nothing -> rdr +               Just (_,PageCoord (x',y')) -> +                 let bbox' = moveBBoxULCornerTo (x',y') (snd rdr) +                 in (fst rdr,bbox')++-- |  notifyLink :: CanvasId -> PointerCoord -> MainCoroutine ()  notifyLink cid pcoord = do      xst <- get @@ -81,6 +100,7 @@ gotLink :: Maybe String -> (Int,Int) -> MainCoroutine ()  gotLink mstr (x,y) = do    xst <- get +  liftIO $ print mstr    let cid = getCurrentCanvasId xst   mr <- runMaybeT $ do      str <- (MaybeT . return) mstr @@ -92,10 +112,10 @@       mr2 <- runMaybeT $ do          str <- (MaybeT . return) mstr          (MaybeT . return) (urlParse str)+      liftIO $ putStrLn ("mr2= " ++ show mr2)       case mr2 of  -        Nothing -> liftIO $ putStrLn "nothing" +        Nothing -> return ()         Just (FileUrl file) -> do -          liftIO $ print file            let ext = takeExtension file            if ext == ".png" || ext == ".PNG" || ext == ".jpg" || ext == ".JPG"              then do @@ -103,44 +123,54 @@               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 () --         -      -      +              insertItemAt mpgcoord nitm +            else return ()  +        Just (HttpUrl url) -> do +          case getSelectedItmsFromHoodleState xst of     +            Nothing -> do +              liftIO $ print "here"+              uuidbstr <- liftIO $ B.pack . show <$> nextRandom              +              rdrbbx <- liftIO $ makeTextSVGFromStringAt url cid xst +                                   (CvsCoord (fromIntegral x,fromIntegral y))+              linkInsert "simple" (uuidbstr,url) url rdrbbx+            Just hititms -> do +              b <- okCancelMessageBox ("replace selected item with link to " ++ url  ++ "?")+              when b $ do +                let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms +                case ulbbox of +                  Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do +                    svg <- liftIO $ makeSVGFromSelection hititms bbox+                    uuidbstr <- liftIO $ B.pack . show <$> nextRandom+                    deleteSelection +                    linkInsert "simple" (uuidbstr,url) url (svg_render svg,bbox)  +                  _ -> 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' +      case getSelectedItmsFromHoodleState xst of     +        Nothing -> do +          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')+          linkInsert "simple" (uuidbstr,fp) fn rdr' +        Just hititms -> do +          b <- okCancelMessageBox ("replace selected item with link to " ++ fn ++ "?")+          when b $ do +            let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms +            case ulbbox of +              Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do +                svg <- liftIO $ makeSVGFromSelection hititms bbox+                uuid <- liftIO $ nextRandom+                let uuidbstr = B.pack (show uuid) +                deleteSelection +                linkInsert "simple" (uuidbstr,fp) fn (svg_render svg,bbox)  +              _ -> return ()             liftIO $ putStrLn "gotLink"   liftIO $ print mstr    liftIO $ print (x,y)

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Page --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Pen --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Scroll --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Select --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -495,7 +495,7 @@           hittestlasso1 = hltFilteredBy (hitLassoItem (nlasso |> orig)) itms           selectitms1 = fmapAL unNotHitted id hittestlasso1           selecteditms1 = (concatMap unHitted . getB) selectitms1 -          hittestlasso2 = flip hltFilteredBy itms $ +          hittestlasso2 = takeLastFromHitted . flip hltFilteredBy itms $                              \itm-> (not.isStrkInRItem) itm                                     && isPointInBBox (getBBox itm) (x,y)           selectitms2 = fmapAL unNotHitted id hittestlasso2

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Select.Clipboard --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -42,7 +42,7 @@ import           Hoodle.Coroutine.Mode import           Hoodle.Type.Canvas  import           Hoodle.Type.Coroutine-import           Hoodle.Type.Event hiding (SVG)+import           Hoodle.Type.Event  import           Hoodle.Type.HoodleState  --  import Prelude hiding (readFile)@@ -118,7 +118,6 @@         hdl = getHoodle xstate          currpage = getPageFromGHoodleMap pgnum hdl         currlayer = getCurrentLayer currpage-       newitem <- (liftIO . cnstrctRItem . ItemLink)                   (Link uuidbstr typ (B.pack fname)                        (Just (B.pack str)) Nothing svgbstr @@ -147,7 +146,8 @@           layoutSetText layout str            (_,reclog) <- layoutGetExtents layout            let PangoRectangle x y w h = reclog -          return (layout,BBox (x,y) (x+w,y+h)) +          -- 10 is just dirty-fix+          return (layout,BBox (x,y) (x+w+10,y+h))          rdr layout = do setSourceRGBA 0 0 0 1                         updateLayout layout                          showLayout layout 

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Window --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Device --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -14,7 +14,7 @@  module Hoodle.GUI where -import           Control.Exception+import           Control.Exception (SomeException(..),catch) import           Control.Lens (view) import           Control.Monad import           Control.Monad.Trans @@ -38,7 +38,7 @@ import           Hoodle.Type.Event import           Hoodle.Type.HoodleState  ---import           Prelude hiding (catch)+import           Prelude ((.),($),String,Bool(..),const,error,flip,id,map) -- hiding (catch)  -- | startGUI :: Maybe FilePath -> Maybe Hook -> IO () @@ -51,7 +51,8 @@   maxundo <- getMaxUndo cfg >>=                 \mmax -> maybe (return 50) (return . id) mmax   xinputbool <- getXInputConfig cfg -  (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo  xinputbool+  statusbar <- statusbarNew +  (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo  xinputbool statusbar    setTitleFromFileName st0   -- need for refactoring   setToggleUIForFlag "UXINPUTA" (settings.doesUseXInput) st0 @@ -74,7 +75,6 @@   ebox <- eventBoxNew   label <- labelNew (Just "drag me")   containerAdd ebox label -     dragSourceSet ebox [Button1] [ActionCopy]   dragSourceSetIconStock ebox stockIndex   dragSourceAddTextTargets ebox@@ -88,6 +88,7 @@         readIORef ref       maybe (return ()) (selectionDataSetText >=> const (return ())) minfo   --+  --    hbox <- hBoxNew False 0    boxPackStart hbox toolbar1 PackGrow 0   boxPackStart hbox ebox PackNatural 0@@ -95,7 +96,8 @@   boxPackStart vbox menubar PackNatural 0    boxPackStart vbox hbox PackNatural 0   boxPackStart vbox toolbar2 PackNatural 0  -  boxPackEnd vbox (view rootWindow st0) PackGrow 0 +  boxPackEnd vbox statusbar PackNatural 0 +  boxPackStart vbox (view rootWindow st0) PackGrow 0    window `on` deleteEvent $ do     liftIO $ eventHandler tref (Menu MenuQuit)     return True

@@ -281,6 +281,9 @@   ebdpdfa <- toggleActionNew "EBDPDFA" "Embed PDF" (Just "Just a stub") Nothing   ebdpdfa `on` actionToggled $ do      eventHandler evar (Menu MenuEmbedPDF)+  -- temporary implementation (later will be as submenus with toggle action. appropriate reflection)+  widgettogglea <- actionNewAndRegister "WIDGETTOGGLEA" "Toggle Pan/Zoom Widget"  (Just "Just a stub") Nothing (justMenu MenuWidgetToggle)+       dcrdcorea <- actionNewAndRegister "DCRDCOREA" "Discard Core Events" (Just "Just a Stub") Nothing (justMenu MenuDiscardCoreEvents)   ersrtipa <- actionNewAndRegister "ERSRTIPA" "Eraser Tip" (Just "Just a Stub") Nothing (justMenu MenuEraserTip)   pressrsensa <- toggleActionNew "PRESSRSENSA" "Pressure Sensitivity" (Just "Just a Stub") Nothing @@ -322,10 +325,11 @@         , hsplita, vsplita, delcvsa         , newpgba, newpgaa, newpgea, delpga, expsvga, newlyra, nextlayera, prevlayera, gotolayera, dellyra, ppsizea, ppclra         , ppstya -        , apallpga, embedbkgpdfa, {- ldbkga, bkgscrshta, -} defppa, setdefppa+        , apallpga, embedbkgpdfa, defppa, setdefppa         , texta, linka, shpreca, rulera, clra, clrpcka, penopta          , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta         , setdefopta, relauncha+        , widgettogglea         , dcrdcorea, ersrtipa, pghilta, mltpgvwa         , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea          , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa @@ -352,14 +356,11 @@         let disabledActions = -        [ recenta, printa {- , exporta-}-        , cuta, copya, {- pastea, -} deletea-        {- , fscra -}+        [ recenta, printa+        , cuta, copya, deletea         ,  setzma         , shwlayera, hidlayera-        , newpgea, {- delpga, -} ppsizea, ppclra-        {- , ppstya, apallpga -} -        {- , ldbkga, bkgscrshta, -}+        , newpgea, ppsizea, ppclra         , defppa, setdefppa         , shpreca, rulera          , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta

@@ -118,9 +118,7 @@     Just pma <- liftIO $ actionGroupGetAction (head agr) name      let wpma = castToRadioAction pma      update xst wpma mconnid   -  where -- (#) :: a -> (a -> b) -> b -        -- (#) = flip ($)-        update xst wpma mconnid  = do +  where update xst wpma mconnid  = do            (f xst) #              (maybe (return ()) $ \v -> do               let action = Left . ActionOrder $ 

@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.ModelAction.ContextMenu+-- Copyright   : (c) 2011-2013 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.ModelAction.ContextMenu where++import qualified Data.ByteString.Char8 as B+import Data.UUID.V4+import Graphics.Rendering.Cairo+import Graphics.UI.Gtk+import System.Directory +import System.FilePath +import System.Process+-- +-- import Control.Monad.Trans.Crtn.Driver +import Data.Hoodle.BBox+import Data.Hoodle.Simple+import Graphics.Hoodle.Render +import Graphics.Hoodle.Render.Type.Item+--+import Hoodle.Type.Event +import Hoodle.Util++-- |+menuOpenALink :: (MyEvent -> IO ()) -> UrlPath -> IO MenuItem+menuOpenALink evhandler urlpath = do +    let urlname = case urlpath of +                    FileUrl fp -> fp +                    HttpUrl url -> url +    menuitemlnk <- menuItemNewWithLabel ("Open "++urlname) +    menuitemlnk `on` menuItemActivate $ do+      case urlpath of +        FileUrl fp -> do +          let cmdargs = [fp]+          createProcess (proc "hoodle" cmdargs)  +          return () +        HttpUrl url -> do +          let cmdargs = [url]+          createProcess (proc "xdg-open" cmdargs)  +          return () +    return menuitemlnk+++  +  +-- | +menuCreateALink :: (MyEvent -> IO ()) -> [RItem] -> IO (Maybe MenuItem)+menuCreateALink evhandler sitems = +  if (length . filter isLinkInRItem) sitems > 0+  then return Nothing +  else do mi <- menuItemNewWithLabel "Create a link to..." +          mi `on` menuItemActivate $ +            evhandler (GotContextMenuSignal CMenuCreateALink)+          return (Just mi)+         ++-- |+makeSVGFromSelection :: [RItem] -> BBox -> IO SVG +makeSVGFromSelection hititms (BBox (ulx,uly) (lrx,lry)) = do +  uuid <- nextRandom+  tdir <- getTemporaryDirectory+  let filename = tdir </> show uuid <.> "svg"+      (x,y) = (ulx,uly)+      (w,h) = (lrx-ulx,lry-uly)+  withSVGSurface filename w h $ \s -> renderWith s $ do +    translate (-ulx) (-uly) +    mapM_ renderRItem hititms +  bstr <- B.readFile filename+  let svg = SVG Nothing Nothing bstr (x,y) (Dim w h)+  svg `seq` removeFile filename +  return svg                       +

@@ -181,7 +181,6 @@       return (Just nhdl)        -- | -       createPage :: Bool         -- ^ does embed pdf?            -> Dimension             -> C.ByteString @@ -197,8 +196,9 @@             = BackgroundEmbedPdf "embedpdf" n      in Page dim bkg [emptyLayer]                    --- |                     ++-- | this function must be moved to GUI.Reflect toggleSave :: UIManager -> Bool -> IO () toggleSave ui b = do      agr <- uiManagerGetActionGroups ui >>= \x -> 

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Script--- Copyright   : (c) 2012 Ian-Woo Kim+-- Copyright   : (c) 2012, 2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Script.Coroutine--- Copyright   : (c) 2012 Ian-Woo Kim+-- Copyright   : (c) 2012, 2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.Alias--- Copyright   : (c) 2012 Ian-Woo Kim+-- Copyright   : (c) 2012, 2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -69,6 +69,8 @@ , xfrmViewInfo , getDrawAreaFromBox , unboxGet+, unboxSet+, unboxLens , fmap4CvsInfoBox , insideAction4CvsInfoBox , insideAction4CvsInfoBoxF@@ -93,6 +95,7 @@ -- import           Hoodle.Type.Enum  import           Hoodle.Type.PageArrangement+import           Hoodle.Type.Widget --  @@ -143,10 +146,6 @@ pageArrangement :: Simple Lens (ViewInfo a) (PageArrangement a) pageArrangement = lens _pageArrangement (\f a -> f { _pageArrangement = a }) --- | -data CanvasWidgets = -  CanvasWidgets { _testWidgetPosition :: CanvasCoordinate-                }      -- |@@ -164,14 +163,6 @@                                , _canvasWidgets :: CanvasWidgets                                } --- | default hoodle widgets-defaultCanvasWidgets :: CanvasWidgets-defaultCanvasWidgets = -  CanvasWidgets-  { _testWidgetPosition = CvsCoord (100,100)-  }   -- -- |      xfrmCvsInfo :: (ViewMode a, ViewMode b) =>                 (ViewInfo a -> ViewInfo b) @@ -257,9 +248,6 @@ canvasWidgets :: Simple Lens (CanvasInfo a) CanvasWidgets  canvasWidgets = lens _canvasWidgets (\f a -> f { _canvasWidgets = a } ) --- | -testWidgetPosition :: Simple Lens CanvasWidgets CanvasCoordinate-testWidgetPosition = lens _testWidgetPosition (\f a -> f { _testWidgetPosition = a} )   -- |@@ -298,7 +286,13 @@ unboxGet f x = fmap4CvsInfoBox (view f) x  +-- | +unboxSet :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> CanvasInfoBox -> b -> CanvasInfoBox+unboxSet l (CanvasSinglePage a) b = CanvasSinglePage (set l b a)+unboxSet l (CanvasContPage a) b = CanvasContPage (set l b a)  +unboxLens :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> Simple Lens CanvasInfoBox b+unboxLens l = lens (unboxGet l) (unboxSet l)   -- |  boxAction :: Monad m => (forall a. ViewMode a => CanvasInfo a -> m b) @@ -370,9 +364,6 @@ currVerticalSpace = lens _currVerticalSpace                        (\f a -> f { _currVerticalSpace = a } ) ---                       -- |  data PenInfo = PenInfo { _penType :: PenType@@ -393,10 +384,6 @@ variableWidthPen :: Simple Lens PenInfo Bool variableWidthPen = lens _variableWidthPen (\f a -> f { _variableWidthPen = a } ) ---- -- |  currentTool :: Simple Lens PenInfo WidthColorStyle  currentTool = lens chooser setter@@ -405,8 +392,6 @@                           HighlighterWork -> _currHighlighter . _penSet $ pinfo                           EraserWork -> _currEraser . _penSet $ pinfo                           VerticalSpaceWork -> NoWidthColorStyle-                          -                          -- TextWork -> _currText . _penSet $ pinfo          setter pinfo wcs =            let pset = _penSet pinfo               psetnew = case _penType pinfo of @@ -414,7 +399,6 @@                           HighlighterWork -> pset { _currHighlighter = wcs }                           EraserWork -> pset { _currEraser = wcs }                           VerticalSpaceWork -> pset -                          -- TextWork -> pset { _currText = wcs }           in  pinfo { _penSet = psetnew }   -- |         @@ -446,16 +430,6 @@           , _variableWidthPen = False           }                                             -------- makeLenses ''PenDraw--- makeLenses ''PenInfo--- makeLenses ''PenHighlighterEraserSet--- makeLenses ''WidthColorStyle - -- |  updateCanvasDimForSingle :: CanvasDimension                              -> CanvasInfo SinglePage  

@@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.Coroutine --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -147,6 +147,7 @@                | MenuUsePopUpMenu                | MenuEmbedImage                | MenuEmbedPDF+               | MenuWidgetToggle                | MenuDiscardCoreEvents                 | MenuEraserTip                 | MenuPressureSensitivity@@ -167,7 +168,7 @@                deriving (Show, Ord, Eq)  -- |-data ImgType = SVG | PDF +data ImgType = TypSVG | TypPDF                 deriving (Show, Ord, Eq)                           -- |                         @@ -180,6 +181,7 @@                       | CMenuRotateCCW                        | CMenuAutosavePage                       | CMenuLinkConvert Link+                      | CMenuCreateALink                        | CMenuCustom                       deriving (Show, Ord, Eq)  

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.HoodleState --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -44,6 +44,7 @@ , hookSet  , tempLog  , tempQueue +, statusBar --  , hoodleFileName  --@@ -74,8 +75,6 @@ , updateFromCanvasInfoAsCurrentCanvas , setCanvasId , modifyCanvasInfo--- , modifyCurrentCanvasInfo--- , modifyCurrCvsInfoM , hoodleModeStateEither , getCurrentPageFromHoodleModeState , getCurrentPageDimFromHoodleModeState@@ -95,7 +94,6 @@ import           Control.Monad.Trans.Crtn.Queue  import           Data.Hoodle.Generic import           Data.Hoodle.Select--- import           Data.Hoodle.Map import           Graphics.Hoodle.Render import           Graphics.Hoodle.Render.Type -- from this package @@ -112,9 +110,6 @@ --  import Prelude hiding ((.), id) ---- type HoodleModeStateIO = StateT HoodleState IO - -- |   data HoodleModeState = ViewAppendState { unView :: RHoodle }@@ -149,12 +144,11 @@                 , _settings :: Settings                  , _uiComponentSignalHandler :: UIComponentSignalHandler                  , _isOneTimeSelectMode :: IsOneTimeSelectMode-                -- , _pageModeSignal :: Maybe (ConnectId RadioAction)-                -- , _penModeSignal :: Maybe (ConnectId RadioAction)                 , _lastTimeCanvasConfigure :: Maybe UTCTime                  , _hookSet :: Maybe Hook                 , _tempQueue :: Queue (Either (ActionOrder MyEvent) MyEvent)                 , _tempLog :: String -> String +                , _statusBar :: Maybe Statusbar                 }   @@ -264,6 +258,9 @@ tempLog :: Simple Lens HoodleState (String -> String) tempLog = lens _tempLog (\f a -> f { _tempLog = a } ) +-- | +statusBar :: Simple Lens HoodleState (Maybe Statusbar)+statusBar = lens _statusBar (\f a -> f { _statusBar = a })  -- |  data HoodleFileControl = @@ -328,7 +325,6 @@ doesEmbedPDF :: Simple Lens Settings Bool doesEmbedPDF = lens _doesEmbedPDF (\f a -> f { _doesEmbedPDF = a } ) - -- | default hoodle state  emptyHoodleState :: IO HoodleState  emptyHoodleState = do@@ -365,6 +361,7 @@     , _hookSet = Nothing     , _tempQueue = emptyQueue     , _tempLog = id +    , _statusBar = Nothing      }  emptyHoodleFileControl :: HoodleFileControl 

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.PageArrangement--- Copyright   : (c) 2012 Ian-Woo Kim+-- Copyright   : (c) 2012, 2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.Predefined--- Copyright   : (c) 2012 Ian-Woo Kim+-- Copyright   : (c) 2012, 2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -1,14 +1,15 @@- ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.Undo --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Hoodle.Type.Undo where  import Data.Hoodle.Zipper 

@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Type.Widget+-- Copyright   : (c) 2013 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- Types for Widgets +-- +-----------------------------------------------------------------------------++module Hoodle.Type.Widget where++import Control.Lens (Simple,Lens,lens) +-- +import Hoodle.Type.PageArrangement ++-- | +data CanvasWidgets = +  CanvasWidgets { _testWidgetPosition :: CanvasCoordinate+                , _widgetConfig :: WidgetConfig +                }   ++-- | +testWidgetPosition :: Simple Lens CanvasWidgets CanvasCoordinate+testWidgetPosition = lens _testWidgetPosition (\f a -> f { _testWidgetPosition = a} )++-- | default hoodle widgets+defaultCanvasWidgets :: CanvasWidgets+defaultCanvasWidgets = +  CanvasWidgets+  { _testWidgetPosition = CvsCoord (100,100)+  , _widgetConfig = defaultWidgetConfig +  }   +++data WidgetConfig = WidgetConfig { _doesUsePanZoom :: Bool } ++-- | flag for pan zoom widget +doesUsePanZoom :: Simple Lens WidgetConfig Bool +doesUsePanZoom = lens _doesUsePanZoom (\f a -> f {_doesUsePanZoom = a})++-- | default widget configuration +defaultWidgetConfig :: WidgetConfig +defaultWidgetConfig = WidgetConfig { _doesUsePanZoom = True } +++-- | widget config lens +widgetConfig :: Simple Lens CanvasWidgets WidgetConfig+widgetConfig = lens _widgetConfig (\f a -> f { _widgetConfig =a } )

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.Window --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -29,7 +29,8 @@ import System.Locale --  import Data.Hoodle.Simple-+-- +import Debug.Trace   -- for test@@ -103,19 +104,31 @@   -data UrlPath = FileUrl FilePath +data UrlPath = FileUrl FilePath | HttpUrl String +             deriving (Show,Eq) +data T = N | F | H | HS deriving (Show,Eq)+ -- |  urlParse :: String -> Maybe UrlPath  urlParse str =    if length str < 7      then Just (FileUrl str)      else -      let p = string "file://" *> manyTill anyChar (satisfy (inClass "\r\n"))+      let p = do b <- (try (string "file://" *> return F)  +                       <|> try (string "http://" *> return H) +                       <|> try (string "https://" *> return HS)+                       <|> (return N) )+                 rem <- manyTill anyChar ((satisfy (inClass "\r\n") *> return ()) <|> endOfInput)+                 return (b,rem)            r = parseOnly p (B.pack str)       in case r of -           Left _ -> Just (FileUrl str) -           Right f -> Just (FileUrl (unEscapeString f))+           Left _ -> Nothing -- Just (FileUrl str) +           Right (b,f) -> case b of +                            N -> Just (FileUrl f)+                            F -> Just (FileUrl (unEscapeString f))+                            H -> Just (HttpUrl ("http://" ++ f))+                            HS -> Just (HttpUrl ("https://" ++ f))       {-

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.View.Coordinate--- Copyright   : (c) 2012,2013 Ian-Woo Kim+-- Copyright   : (c) 2012, 2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>

@@ -39,12 +39,13 @@ import Graphics.Hoodle.Render.Type.HitTest  import Graphics.Hoodle.Render.Util  -- from this package-import Hoodle.Type.Canvas import Hoodle.Type.Alias -import Hoodle.Util+import Hoodle.Type.Canvas import Hoodle.Type.PageArrangement-import Hoodle.Type.Predefined import Hoodle.Type.Enum+import Hoodle.Type.Predefined+import Hoodle.Type.Widget+import Hoodle.Util import Hoodle.View.Coordinate --  import Prelude hiding ((.),id,mapM_,concatMap,foldr)@@ -108,6 +109,33 @@   let ViewPortBBox vportbbox = getCanvasViewPort geometry     in (fromMaybe mbbox :: IntersectBBox) `mappend` (Intersect (Middle vportbbox))                +-- | double buffering within two image surfaces +virtualDoubleBufferDraw :: (MonadIO m) => +                           Surface  -- source surface +                        -> Surface  -- target surface +                        -> Render () -- pre-render before source paint +                        -> Render () -- post-render after source paint +                        -> m ()+virtualDoubleBufferDraw sfc sfc2 pre post = +    renderWith sfc2 $ do +      pre+      setSourceSurface sfc 0 0 +      setOperator OperatorSource +      paint+      setOperator OperatorOver+      post  +          +doubleBufferFlush :: ViewMode a => Surface -> CanvasInfo a -> IO () +doubleBufferFlush sfc cinfo = do +      let canvas = view drawArea cinfo +      win <- widgetGetDrawWindow canvas+      renderWithDrawable win $ do +        setSourceSurface sfc 0 0 +        setOperator OperatorSource +        paint+  ++ -- | common routine for double buffering  doubleBufferDraw :: (DrawWindow, Maybe Surface)                       -> CanvasGeometry -> Render () -> Render a@@ -128,7 +156,6 @@               rectangle 0 0 cw ch                fill  	      rndr -              -- return ()  	  Just sfc -> do  	    r <- renderWith sfc $ do  	      clipBBox (fmap (flip inflate (-1.0)) mbbox')@@ -142,11 +169,10 @@ 	      setOperator OperatorSource  	      paint              return r -        -- return ()         case ibbox of-    Top -> Just <$> action -- >> return Nothing -    Middle _ -> Just <$> action -- >> return Nothing -    Bottom -> return Nothing +    Top      -> Just <$> action +    Middle _ -> Just <$> action +    Bottom   -> return Nothing   -- |  cairoXform4PageCoordinate :: CanvasGeometry -> PageNum -> Render () @@ -207,7 +233,6 @@               xformfunc = cairoXform4PageCoordinate geometry pnum               renderfunc = do                 xformfunc -                -- clipBBox (fmap (flip inflate 1) mbboxnew) -- ad hoc ?                  pg <- render (pnum,page) mbboxnew flag                 -- Start Widget                 when isCurrentCvs (emphasisCanvasRender ColorBlue geometry)  @@ -276,22 +301,18 @@                 identityMatrix                  cairoXform4PageCoordinate geometry pn                 let pgmbbox = fmap (getBBoxInPageCoord geometry pn) mbboxnew-                -- clipBBox (fmap (flip inflate 1) pgmbbox) -- ad hoc                      render (pn,pg) pgmbbox flag               renderfunc = do                 xformfunc -                -- mapM_ onepagerender drawpgs                  ndrawpgs <- mapM onepagerender drawpgs                  let npgs = foldr rfunc pgs ndrawpgs                           where rfunc (k,pg) m = M.adjust (const pg) k m                  let nhdl = set gpages npgs hdl                   maybe (return ()) (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg -                -- Start Widget                  when isCurrentCvs (emphasisCanvasRender ColorRed geometry)-                -- widget test                 let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew                 -                renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo) -- (CvsCoord (100,100))-                -- End Widget+                when (view (canvasWidgets.widgetConfig.doesUsePanZoom) cinfo) $+                  renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo)                  resetClip                  return nhdl            doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew@@ -343,12 +364,10 @@                                     lift (selpagerender (PageNum n,tpage))                  let nthdl2 = set gselSelected r nthdl                 maybe (return ()) (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg -                -- Start Widget                 when isCurrentCvs (emphasisCanvasRender ColorGreen geometry)  -                -- widget test                 let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew                 -                renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo)-                -- End Widget +                when (view (canvasWidgets.widgetConfig.doesUsePanZoom) cinfo) $+                  renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo)                 resetClip                  return nthdl2             doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew@@ -525,6 +544,17 @@   setSourceRGBA 0.7 0.2 0.2 0.5   rectangle (x+30) (y+30) 40 40    fill  +  setSourceRGBA 0.5 0.5 0.5 0.5+  rectangle (x+90) y 10 10+  fill+  setSourceRGBA 0 0 0 0.7 +  setLineWidth 1+  moveTo (x+90) y +  lineTo (x+100) (y+10)+  stroke +  moveTo (x+90) (y+10)+  lineTo (x+100) y+  stroke   resetClip   @@ -544,12 +574,10 @@       nbbx_cvs =          xformBBox ( unCvsCoord . desktop2Canvas geometry . DeskCoord ) nbbx_desk       nvport = ViewPortBBox nbbx_desk-      -- Dim _w_desk _h_desk = bboxToDim nbbx_desk       Dim w_cvs  h_cvs  = bboxToDim nbbx_cvs   let pgs = view gpages hdl        drawpgs = (catMaybes . map f . getPagesInRange geometry nvport) hdl          where f k = maybe Nothing (\a -> Just (k,a)) . M.lookup (unPageNum k) $ pgs-             onepagerender (pn,pg) = do          identityMatrix          case mmulti of 

@@ -8,52 +8,42 @@ -- Stability   : experimental -- Portability : GHC --+-- Pan-Zoom widget drawing and action+--  -----------------------------------------------------------------------------  module Hoodle.Widget.PanZoom where  -- from other packages-import           Control.Category-import           Control.Lens (view,set)+import           Control.Lens (view,set,over) import           Control.Monad.Identity  import           Control.Monad.State  import           Data.Time.Clock  import           Graphics.Rendering.Cairo -import           Graphics.UI.Gtk hiding (get,set) --- import           Graphics.UI.Gtk hiding (get,set)--- import qualified Graphics.UI.Gtk as Gtk (get)+-- import           Graphics.UI.Gtk hiding (get,set)  -- from hoodle-platform  import           Data.Hoodle.BBox- import           Data.Hoodle.Simple--- import           Graphics.Hoodle.Render.Util.HitTest--- +-- from this package  import           Hoodle.Accessor import           Hoodle.Coroutine.Draw import           Hoodle.Coroutine.Page import           Hoodle.Coroutine.Pen  import           Hoodle.Coroutine.Scroll- import           Hoodle.Device import           Hoodle.ModelAction.Page -- import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine import           Hoodle.Type.Event import           Hoodle.Type.HoodleState  import           Hoodle.Type.PageArrangement -+import           Hoodle.Type.Widget import           Hoodle.View.Coordinate import           Hoodle.View.Draw -- -import Prelude hiding ((.),id) --data WidgetMode = Moving | Zooming | Panning Bool +data PanZoomMode = Moving | Zooming | Panning Bool  widgetCheckPen :: CanvasId -> PointerCoord                 -> MainCoroutine () @@ -61,7 +51,8 @@ widgetCheckPen cid pcoord act = do      xst <- get     let cinfobox = getCanvasInfo cid xst -    boxAction (f xst) cinfobox +        b = view (unboxLens (canvasWidgets.widgetConfig.doesUsePanZoom)) cinfobox+    if b then boxAction (f xst) cinfobox else act    where      f xst cinfo = do        let cvs = view drawArea cinfo@@ -73,36 +64,37 @@           obbox = BBox (x0,y0) (x0+100,y0+100)            pbbox1 = BBox (x0+10,y0+10) (x0+50,y0+90)           pbbox2 = BBox (x0+50,y0+10) (x0+90,y0+90)+          pbbox3 = BBox (x0+90,y0) (x0+100,y0+10)           zbbox = BBox (x0+30,y0+30) (x0+70,y0+70)-              -                 if (isPointInBBox obbox (x,y))            then do -           let mode | isPointInBBox zbbox (x,y) = Zooming -                    | isPointInBBox pbbox1 (x,y) = Panning False-                    | isPointInBBox pbbox2 (x,y) = Panning True -                    | otherwise = Moving +           let mmode | isPointInBBox zbbox (x,y) = Just Zooming +                     | isPointInBBox pbbox1 (x,y) = Just (Panning False)+                     | isPointInBBox pbbox2 (x,y) = Just (Panning True)+                     | isPointInBBox pbbox3 (x,y) = Nothing+                     | otherwise = Just Moving             let hdl = getHoodle xst-           (sfc,Dim wsfc hsfc) <- -             case mode of -               Moving -> liftIO (canvasImageSurface Nothing geometry hdl)-               Zooming -> liftIO (canvasImageSurface (Just 1) geometry hdl)-               Panning _ -> liftIO (canvasImageSurface (Just 1) geometry hdl) -           sfc2 <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc)-           ctime <- liftIO getCurrentTime -           startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy ctime -           liftIO $ surfaceFinish sfc -           liftIO $ surfaceFinish sfc2-         else do -           act -+           case mmode of +             Nothing -> togglePanZoom+             Just mode -> do +               (sfc,Dim wsfc hsfc) <- case mode of +                                        Moving -> liftIO (canvasImageSurface Nothing geometry hdl)+                                        Zooming -> liftIO (canvasImageSurface (Just 1) geometry hdl)+                                        Panning _ -> liftIO (canvasImageSurface (Just 1) geometry hdl) +               sfc2 <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc)+               ctime <- liftIO getCurrentTime +               startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy ctime +               liftIO $ surfaceFinish sfc +               liftIO $ surfaceFinish sfc2+         else act  +-- |  findZoomXform :: Dimension                 -> ((Double,Double),(Double,Double),(Double,Double))                 -> (Double,(Double,Double)) findZoomXform (Dim w h) ((xo,yo),(x0,y0),(x,y)) = -    let tx = x - x0 --  if x0 > xo then x - x0 else x0 - x -        ty = y - y0 -- if y0 > yo then y - y0 else y0 - y+    let tx = x - x0 +        ty = y - y0          ztx = 1 + tx / 200         zty = 1 + ty / 200         zx | ztx > 2 = 2  @@ -133,9 +125,8 @@            | otherwise = ty      in ((dx-w),(dy-h)) - -- | -startWidgetAction :: WidgetMode +startWidgetAction :: PanZoomMode                       -> CanvasId                       -> CanvasGeometry                       -> (Surface,Surface)@@ -161,7 +152,6 @@               ccoord@(CvsCoord (xo,yo)) = CvsCoord (xw+50,yw+50)               (z,(_,_)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))               nratio = zoomRatioFrmRelToCurr geometry z-                             mpnpgxy = (desktop2Page geometry . canvas2Desktop geometry) ccoord            canvasZoomUpdateGenRenderCvsId (return ()) cid (Just (Zoom nratio)) Nothing            case mpnpgxy of @@ -184,8 +174,8 @@       invalidate cid      _ -> startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy otime --movingRender :: WidgetMode -> CanvasId -> CanvasGeometry -> (Surface,Surface) +-- | +movingRender :: PanZoomMode -> CanvasId -> CanvasGeometry -> (Surface,Surface)                  -> CanvasCoordinate -> CanvasCoordinate -> PointerCoord                  -> MainCoroutine ()  movingRender mode cid geometry (sfc,sfc2) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do @@ -201,34 +191,22 @@                   nposy | yw+y-y0 < -50 = -50                          | yw+y-y0 > ch-50 = ch-50                          | otherwise = yw+y-y0                             -                  nwpos = CvsCoord (nposx,nposy) -- (xw+x-x0,yw+y-y0)+                  nwpos = CvsCoord (nposx,nposy)                    changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a                    changeact cinfo =                       set (canvasWidgets.testWidgetPosition) nwpos $ cinfo                   ncinfobox = selectBox changeact changeact  cinfobox               put (setCanvasInfo (cid,ncinfobox) xst)-              renderWith sfc2 $ do -                setSourceSurface sfc 0 0 -                setOperator OperatorSource -                paint-                setOperator OperatorOver-                renderPanZoomWidget Nothing nwpos +              virtualDoubleBufferDraw sfc sfc2 (return ()) (renderPanZoomWidget Nothing nwpos)             Zooming -> do                let cinfobox = getCanvasInfo cid xst                              let pos = runIdentity (boxAction (return . view (canvasWidgets.testWidgetPosition)) cinfobox )               let (xo,yo) = (xw+50,yw+50)                   CanvasDimension cdim = canvasDim geometry                    (z,(xtrans,ytrans)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))-              renderWith sfc2 $ do -                  save-                  scale z z-                  translate xtrans ytrans -                  setSourceSurface sfc 0 0 -                  setOperator OperatorSource -                  paint-                  setOperator OperatorOver-                  restore-                  renderPanZoomWidget Nothing pos +              virtualDoubleBufferDraw sfc sfc2 +                (save >> scale z z >> translate xtrans ytrans)+                (restore >> renderPanZoomWidget Nothing pos)             Panning b -> do                let cinfobox = getCanvasInfo cid xst                                  CanvasDimension cdim = canvasDim geometry @@ -244,32 +222,23 @@                           then CvsCoord (nposx,nposy)                            else                              runIdentity (boxAction (return . view (canvasWidgets.testWidgetPosition)) cinfobox)-                  changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a -                  changeact cinfo =  -                    set (canvasWidgets.testWidgetPosition) nwpos $ cinfo-                  ncinfobox = selectBox changeact changeact  cinfobox+                  -- changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a +                  -- changeact cinfo =  +                  --   set (canvasWidgets.testWidgetPosition) nwpos $ cinfo+                  --             selectBox changeact changeact  cinfobox+                  ncinfobox = set (unboxLens (canvasWidgets.testWidgetPosition)) nwpos cinfobox               put (setCanvasInfo (cid,ncinfobox) xst)-                  -              renderWith sfc2 $ do -                  save-                  translate xtrans ytrans -                  setSourceSurface sfc 0 0 -                  setOperator OperatorSource -                  paint-                  setOperator OperatorOver-                  restore-                  renderPanZoomWidget Nothing nwpos +              virtualDoubleBufferDraw sfc sfc2 +                (save >> translate xtrans ytrans) +                (restore >> renderPanZoomWidget Nothing nwpos)           --              xst2 <- get            let cinfobox = getCanvasInfo cid xst2 -              drawact :: (ViewMode a) => CanvasInfo a -> IO ()-              drawact cinfo = do -                let canvas = view drawArea cinfo -                win <- widgetGetDrawWindow canvas-                renderWithDrawable win $ do -                  setSourceSurface sfc2 0 0 -                  setOperator OperatorSource -                  paint-          liftIO $ boxAction drawact cinfobox+          liftIO $ boxAction (doubleBufferFlush sfc2) cinfobox -      +  +-- | +togglePanZoom :: MainCoroutine () +togglePanZoom = do +  modify (over (currentCanvasInfo . unboxLens (canvasWidgets.widgetConfig.doesUsePanZoom)) not)+  invalidateAll