hxournal 0.6.4.1 → 0.6.4.2
raw patch · 19 files changed
+338/−121 lines, 19 files
Files
- hxournal.cabal +1/−1
- lib/Application/HXournal/Accessor.hs +91/−24
- lib/Application/HXournal/Coroutine/Callback.hs +11/−8
- lib/Application/HXournal/Coroutine/Default.hs +23/−9
- lib/Application/HXournal/Coroutine/Draw.hs +7/−7
- lib/Application/HXournal/Coroutine/File.hs +2/−2
- lib/Application/HXournal/Coroutine/Mode.hs +27/−4
- lib/Application/HXournal/Coroutine/Page.hs +2/−2
- lib/Application/HXournal/Coroutine/Pen.hs +1/−1
- lib/Application/HXournal/Coroutine/Select.hs +2/−3
- lib/Application/HXournal/Coroutine/Window.hs +6/−10
- lib/Application/HXournal/GUI.hs +1/−1
- lib/Application/HXournal/GUI/Menu.hs +17/−6
- lib/Application/HXournal/ModelAction/Page.hs +10/−7
- lib/Application/HXournal/ModelAction/Window.hs +3/−3
- lib/Application/HXournal/Type/Coroutine.hs +2/−1
- lib/Application/HXournal/Type/Event.hs +11/−1
- lib/Application/HXournal/Type/PageArrangement.hs +0/−2
- lib/Application/HXournal/Type/XournalState.hs +121/−29
hxournal.cabal view
@@ -1,5 +1,5 @@ Name: hxournal-Version: 0.6.4.1+Version: 0.6.4.2 Synopsis: A pen notetaking program written in haskell Description: notetaking program written in haskell and gtk2hs Homepage: http://ianwookim.org/hxournal
lib/Application/HXournal/Accessor.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- |@@ -32,9 +32,12 @@ import Application.HXournal.Util import Application.HXournal.ModelAction.Layer import Application.HXournal.Type.Alias+import Application.HXournal.Type.Event import Application.HXournal.Type.PageArrangement+import Application.HXournal.Type.Coroutine import Application.HXournal.View.Coordinate-+import Control.Monad.Coroutine +import Control.Monad.Coroutine.SuspensionFunctors -- | get HXournalState @@ -62,8 +65,8 @@ getAllStrokeBBoxInCurrentPage :: MainCoroutine [StrokeBBox] getAllStrokeBBoxInCurrentPage = do xstate <- getSt - case get currentCanvas xstate of- (_,CanvasInfoBox currCvsInfo) -> + case get currentCanvasInfo xstate of+ CanvasInfoBox currCvsInfo -> let pagebbox = getPage currCvsInfo in return [s| l <- gToList (get g_layers pagebbox), s <- get g_bstrokes l ] @@ -71,15 +74,15 @@ getAllStrokeBBoxInCurrentLayer :: MainCoroutine [StrokeBBox] getAllStrokeBBoxInCurrentLayer = do xstate <- getSt - case get currentCanvas xstate of - (_,CanvasInfoBox currCvsInfo) -> do + case get currentCanvasInfo xstate of + CanvasInfoBox currCvsInfo -> do let pagebbox = getPage currCvsInfo (mcurrlayer, _currpage) = getCurrentLayerOrSet pagebbox currlayer = maybe (error "getAllStrokeBBoxInCurrentLayer") id mcurrlayer return (get g_bstrokes currlayer) otherCanvas :: HXournalState -> [Int] -otherCanvas = M.keys . get canvasInfoMap +otherCanvas = M.keys . getCanvasInfoMap -- | @@ -87,27 +90,37 @@ changeCurrentCanvasId :: CanvasId -> MainCoroutine HXournalState changeCurrentCanvasId cid = do xstate1 <- getSt- (>>=) (return . M.lookup cid . get canvasInfoMap $ xstate1) $- maybe (return xstate1) - (\cinfo -> do - let nst = set currentCanvas (cid,cinfo) xstate1 - ui = get gtkUIManager nst - liftIO $ reflectUI ui cinfo- putSt nst >> return nst- )+ maybe (return xstate1) + (\xst -> do putSt xst + return xst)+ (setCurrentCanvasId cid xstate1)+ xst <- getSt+ let cinfo = get currentCanvasInfo xst + ui = get gtkUIManager xst + reflectUI ui cinfo+ return xst + -- | reflect UI for current canvas info -reflectUI :: UIManager -> CanvasInfoBox -> IO ()+reflectUI :: UIManager -> CanvasInfoBox -> MainCoroutine () reflectUI ui cinfobox = do - agr <- uiManagerGetActionGroups ui- Just ra1 <- actionGroupGetAction (head agr) "ONEPAGEA"+ xstate <- getSt+ let mconnid = get pageModeSignal xstate+ liftIO $ maybe (return ()) signalBlock mconnid + agr <- liftIO $ uiManagerGetActionGroups ui+ Just ra1 <- liftIO $ actionGroupGetAction (head agr) "ONEPAGEA"+ let wra1 = castToRadioAction ra1 selectBoxAction (fsingle ra1) (fcont ra1) cinfobox - where fsingle ra1 cinfo = - Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 1 ] - fcont ra1 cinfo = - Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 0 ] - + liftIO $ maybe (return ()) signalUnblock mconnid + return ()+ where fsingle ra1 cinfo = do+ let wra1 = castToRadioAction ra1 + liftIO $ Gtk.set wra1 [radioActionCurrentValue := 1 ] + fcont ra1 cinfo = do+ let wra1 = castToRadioAction ra1 + -- liftIO $ wra1 `on` radioActionChanged $ const (putStrLn "hellowworld2" >> return ())+ liftIO $ Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 0 ] -- | @@ -117,13 +130,65 @@ liftIO $ putStrLn $ show (unboxGet (viewPortBBox.pageArrangement.viewInfo) cvsInfo) -- | +printViewPortBBoxAll :: MainCoroutine () +printViewPortBBoxAll = do + xstate <- getSt + let cmap = getCanvasInfoMap xstate+ cids = M.keys cmap+ mapM_ printViewPortBBox cids ++-- | printViewPortBBoxCurr :: MainCoroutine () printViewPortBBoxCurr = do cvsInfo <- return . get currentCanvasInfo =<< getSt liftIO $ putStrLn $ show (unboxGet (viewPortBBox.pageArrangement.viewInfo) cvsInfo) +-- | + +printModes :: CanvasId -> MainCoroutine ()+printModes cid = do + cvsInfo <- return . getCanvasInfo cid =<< getSt + liftIO $ printCanvasMode cid cvsInfo+{- let zmode = unboxGet (zoomMode.viewInfo) cvsInfo+ f :: PageArrangement a -> String + f (SingleArrangement _ _ _) = "SingleArrangement"+ f (ContinuousSingleArrangement _ _ _ _) = "ContinuousSingleArrangement" + g :: CanvasInfo a -> String + g cinfo = f . get (pageArrangement.viewInfo) $ cinfo+ + arrmode :: String + arrmode = boxAction g cvsInfo + + incid = unboxGet canvasId cvsInfo + liftIO $ putStrLn $ show (cid,incid,zmode,arrmode) -}++printCanvasMode :: CanvasId -> CanvasInfoBox -> IO ()+printCanvasMode cid cvsInfo = do + let zmode = unboxGet (zoomMode.viewInfo) cvsInfo+ f :: PageArrangement a -> String + f (SingleArrangement _ _ _) = "SingleArrangement"+ f (ContinuousSingleArrangement _ _ _ _) = "ContinuousSingleArrangement"++ g :: CanvasInfo a -> String + g cinfo = f . get (pageArrangement.viewInfo) $ cinfo+ + arrmode :: String + arrmode = boxAction g cvsInfo + + incid = unboxGet canvasId cvsInfo + putStrLn $ show (cid,incid,zmode,arrmode)+++printModesAll :: MainCoroutine () +printModesAll = do + xstate <- getSt + let cmap = getCanvasInfoMap xstate+ cids = M.keys cmap+ mapM_ printModes cids ++ -- | unboxGetPage :: CanvasInfoBox -> (Page EditMode) @@ -138,6 +203,7 @@ cpn = PageNum . unboxGet currentPageNum $ cinfobox canvas = unboxGet drawArea cinfobox xojstate = get xournalstate xstate + fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry fsingle = flip (makeCanvasGeometry EditMode (cpn,page)) canvas . get (pageArrangement.viewInfo) boxAction fsingle cinfobox@@ -151,10 +217,11 @@ cpn = PageNum . unboxGet currentPageNum $ cinfobox canvas = unboxGet drawArea cinfobox xojstate = get xournalstate xstate + fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry fsingle = flip (makeCanvasGeometry EditMode (cpn,page)) canvas . get (pageArrangement.viewInfo) - selectBoxAction fsingle fsingle cinfobox+ boxAction fsingle cinfobox {-
lib/Application/HXournal/Coroutine/Callback.hs view
@@ -10,6 +10,7 @@ -- Stability : experimental -- Portability : GHC --+----------------------------------------------------------------------------- module Application.HXournal.Coroutine.Callback where @@ -18,6 +19,7 @@ import Control.Monad.Coroutine.SuspensionFunctors import Data.IORef import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.XournalState import Application.HXournal.Type.Event dummycallback :: MyEvent -> IO ()@@ -27,12 +29,13 @@ bouncecallback tref sref input = do Await cont <- readIORef tref st <- readIORef sref- (nr,st') <- runStateT (resume (cont input)) st - case nr of - Left naw -> do writeIORef tref naw - writeIORef sref st'- Right val -> do putStrLn $ show val - writeIORef tref (Await (\_ -> return ()))- writeIORef sref st'- return () + when (not (_isEventBlocked st)) $ do + (nr,st') <- runStateT (resume (cont input)) st + case nr of + Left naw -> do writeIORef tref naw + writeIORef sref st'+ Right val -> do putStrLn $ show val + writeIORef tref (Await (\_ -> return ()))+ writeIORef sref st'+ return ()
lib/Application/HXournal/Coroutine/Default.hs view
@@ -57,6 +57,25 @@ import Data.Xournal.BBox import Data.Xournal.Generic +-- | ++initViewModeIOAction :: MainCoroutine HXournalState+initViewModeIOAction = do + oxstate <- getSt+ let ui = get gtkUIManager oxstate+ agr <- liftIO $ uiManagerGetActionGroups ui + Just ra <- liftIO $ actionGroupGetAction (head agr) "CONTA"+ let wra = castToRadioAction ra + connid <- liftIO $ wra `on` radioActionChanged $ \x -> do + y <- viewModeToMyEvent x + get callBack oxstate y + return () + let xstate = set pageModeSignal (Just connid) oxstate+ putSt xstate + return xstate +++ -- | guiProcess :: MainCoroutine ()@@ -66,8 +85,8 @@ liftIO $ putStrLn "welcome to hxournal" changePage (const 0)- xstate <- getSt- let cinfoMap = get canvasInfoMap xstate+ xstate <- initViewModeIOAction + let cinfoMap = getCanvasInfoMap xstate assocs = M.toList cinfoMap f (cid,cinfobox) = do let canvas = getDrawAreaFromBox cinfobox (w',h') <- liftIO $ widgetGetSize canvas@@ -100,14 +119,9 @@ -- (initcvstemp :: CanvasInfo SinglePage) <- initCanvasInfo st1 1 let initcvs = defaultCvsInfoSinglePage { _canvasId = 1 } let initcvsbox = CanvasInfoBox initcvs- -- initcmap = M.insert (get canvasId initcvs) initcvsbox M.empty- let -- startingXstate = set canvasInfoMap initcmap - -- . set frameState (Node 1)- -- $ st1 st2 = set frameState (Node 1) . updateFromCanvasInfoAsCurrentCanvas initcvsbox - . set canvasInfoMap (M.empty)- $ st1 + $ st1 { _cvsInfoMap = M.empty } (st3,cvs,wconf) <- constructFrame st2 (get frameState st2) (st4,wconf') <- eventConnect st3 (get frameState st3) let startingXstate = set frameState wconf' . set rootWindow cvs $ st4@@ -244,7 +258,7 @@ uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA") >>= maybe (error "MenuUseXInput") (return . castToToggleAction) b <- liftIO $ toggleActionGetActive uxinputa- let cmap = get canvasInfoMap xstate+ let cmap = getCanvasInfoMap xstate canvases = map (getDrawAreaFromBox) . M.elems $ cmap if b
lib/Application/HXournal/Coroutine/Draw.hs view
@@ -57,7 +57,7 @@ where fsingle :: HXournalState -> CanvasInfo SinglePage -> MainCoroutine () fsingle xstate cvsInfo = do let cpn = PageNum . get currentPageNum $ cvsInfo - isCurrentCvs = cid == get currentCanvasId xstate+ isCurrentCvs = cid == getCurrentCanvasId xstate case get currentPage cvsInfo of Left page -> do liftIO (unSinglePageDraw drawf isCurrentCvs @@ -70,7 +70,7 @@ fcont :: HXournalState -> CanvasInfo ContinuousSinglePage -> MainCoroutine () fcont xstate cvsInfo = do let xojstate = get xournalstate xstate - isCurrentCvs = cid == get currentCanvasId xstate+ isCurrentCvs = cid == getCurrentCanvasId xstate case xojstate of ViewAppendState xoj -> do liftIO (unContPageDraw drawcont isCurrentCvs cvsInfo mbbox xoj)@@ -82,8 +82,8 @@ invalidateOther :: MainCoroutine () invalidateOther = do xstate <- getSt- let currCvsId = get currentCanvasId xstate- cinfoMap = get canvasInfoMap xstate+ let currCvsId = getCurrentCanvasId xstate+ cinfoMap = getCanvasInfoMap xstate keys = M.keys cinfoMap mapM_ invalidate (filter (/=currCvsId) keys) @@ -110,7 +110,7 @@ -> MainCoroutine () invalidateAllInBBox mbbox = do xstate <- getSt- let cinfoMap = get canvasInfoMap xstate+ let cinfoMap = getCanvasInfoMap xstate keys = M.keys cinfoMap forM_ keys (invalidateInBBox mbbox) @@ -124,7 +124,7 @@ -- | Invalidate Current canvas invalidateCurrent :: MainCoroutine () -invalidateCurrent = invalidate . get currentCanvasId =<< getSt+invalidateCurrent = invalidate . getCurrentCanvasId =<< getSt -- | Drawing temporary gadgets @@ -186,7 +186,7 @@ chkCvsIdNInvalidate :: CanvasId -> MainCoroutine () chkCvsIdNInvalidate cid = do - currcid <- liftM (get currentCanvasId) getSt + currcid <- liftM (getCurrentCanvasId) getSt when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll)
lib/Application/HXournal/Coroutine/File.hs view
@@ -57,7 +57,7 @@ fileNew = do xstate <- getSt xstate' <- liftIO $ getFileContent Nothing xstate - ncvsinfo <- liftIO $ setPage xstate' 0 (get currentCanvasId xstate')+ ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate') xstate'' <- return $ modifyCurrentCanvasInfo (const ncvsinfo) xstate' liftIO $ setTitleFromFileName xstate'' commit xstate'' @@ -101,7 +101,7 @@ liftIO $ putStrLn $ show filename xstate <- getSt xstate' <- liftIO $ getFileContent (Just filename) xstate- ncvsinfo <- liftIO $ setPage xstate' 0 (get currentCanvasId xstate')+ ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate') xstateNew <- return $ modifyCurrentCanvasInfo (const ncvsinfo) xstate' putSt . set isSaved True $ xstateNew
lib/Application/HXournal/Coroutine/Mode.hs view
@@ -32,6 +32,7 @@ import Control.Category import Data.Label import Data.Xournal.Simple (Dimension(..))+import Data.Xournal.BBox import Data.Xournal.Generic import Graphics.Xournal.Render.BBoxMapPDF import Graphics.UI.Gtk (adjustmentSetUpper,adjustmentGetValue,adjustmentSetValue)@@ -73,12 +74,34 @@ noaction :: HXournalState -> a -> MainCoroutine HXournalState noaction xstate = const (return xstate) - whencont xstate _ = do - liftIO $ putStrLn "cont2single"- return xstate+ whencont xstate cinfo = do + geometry <- liftIO $ getCanvasGeometry xstate + cdim <- liftIO $ return . canvasDim =<< getCanvasGeometry xstate + let zmode = get (zoomMode.viewInfo) cinfo+ canvas = get drawArea cinfo + cpn = PageNum . get currentPageNum $ cinfo + page = getPage cinfo+ pdim = PageDimension (get g_dimension page )+ ViewPortBBox bbox = get (viewPortBBox.pageArrangement.viewInfo) cinfo + (x0,y0) = bbox_upperleft bbox + (xpos,ypos) = maybe (0,0) (unPageCoord.snd) $ desktop2Page geometry (DeskCoord (x0,y0)) + let arr = makeSingleArrangement zmode pdim cdim (xpos,ypos) + let nvinfo = ViewInfo (get zoomMode (get viewInfo cinfo)) arr + ncinfo = CanvasInfo (get canvasId cinfo)+ canvas+ (get scrolledWindow cinfo)+ nvinfo + (unPageNum cpn)+ (Left page)+ (get horizAdjustment cinfo)+ (get vertAdjustment cinfo)+ (get horizAdjConnId cinfo)+ (get vertAdjConnId cinfo)+ liftIO $ putStrLn " after " + liftIO $ printCanvasMode (getCurrentCanvasId xstate) (CanvasInfoBox ncinfo)+ return $ set currentCanvasInfo (CanvasInfoBox ncinfo) xstate whensing xstate cinfo = do - liftIO $ putStrLn "single2cont" cdim <- liftIO $ return . canvasDim =<< getCanvasGeometry xstate let zmode = get (zoomMode.viewInfo) cinfo canvas = get drawArea cinfo
lib/Application/HXournal/Coroutine/Page.hs view
@@ -130,7 +130,7 @@ canvasZoomUpdateAll :: MainCoroutine () canvasZoomUpdateAll = do - klst <- liftM (M.keys . get canvasInfoMap) getSt+ klst <- liftM (M.keys . getCanvasInfoMap) getSt mapM_ (flip canvasZoomUpdateCvsId Nothing) klst @@ -138,7 +138,7 @@ canvasZoomUpdate :: Maybe ZoomMode -> MainCoroutine () canvasZoomUpdate mzmode = do - cid <- (liftM (get currentCanvasId) getSt)+ cid <- (liftM (getCurrentCanvasId) getSt) canvasZoomUpdateCvsId cid mzmode {-
lib/Application/HXournal/Coroutine/Pen.hs view
@@ -75,7 +75,7 @@ -> MainCoroutine () commonPenStart action cid pcoord = do oxstate <- getSt - let currcid = get currentCanvasId oxstate+ let currcid = getCurrentCanvasId oxstate when (cid /= currcid) (changeCurrentCanvasId cid >> invalidateAll) nxstate <- getSt boxAction f . getCanvasInfo cid $ nxstate
lib/Application/HXournal/Coroutine/Select.hs view
@@ -267,10 +267,9 @@ ntxoj2 <- liftIO $ updateTempXournalSelectIO ntxoj1 ntpage (unPageNum newpgn) let ncinfo = set currentPage (Right ntpage) . set currentPageNum (unPageNum newpgn) $ cinfo - cmap = get canvasInfoMap xstate1 + cmap = getCanvasInfoMap xstate1 cmap' = M.adjust (const (CanvasInfoBox ncinfo)) cid cmap- xst = set canvasInfoMap cmap' xstate1- + xst = maybe xstate1 id $ setCanvasInfoMap cmap' xstate1 return . set xournalstate (SelectState ntxoj2) =<< (liftIO (updatePageAll (SelectState ntxoj2) xst)) return coroutineaction
lib/Application/HXournal/Coroutine/Window.hs view
@@ -59,8 +59,8 @@ eitherSplit :: SplitType -> MainCoroutine () eitherSplit stype = do xstate <- getSt- let cmap = get canvasInfoMap xstate- (currcid,_) = get currentCanvas xstate+ let cmap = getCanvasInfoMap xstate+ currcid = getCurrentCanvasId xstate newcid = newCanvasId cmap fstate = get frameState xstate enewfstate = splitWindow currcid (newcid,stype) fstate @@ -82,23 +82,19 @@ liftIO $ boxPackEnd rtcntr win PackGrow 0 liftIO $ widgetShowAll rtcntr (xstate4,wconf) <- liftIO $ eventConnect xstate3 (get frameState xstate3)- -- liftIO $ putStrLn " called here 2 " - -- canvasZoomUpdateAll- -- liftIO $ putStrLn " called here 3 " xstate5 <- liftIO $ updatePageAll (get xournalstate xstate4) xstate4 putSt xstate5 + canvasZoomUpdateAll invalidateAll - - -- | deleteCanvas :: MainCoroutine () deleteCanvas = do xstate <- getSt- let cmap = get canvasInfoMap xstate- (currcid,_) = get currentCanvas xstate+ let cmap = getCanvasInfoMap xstate+ currcid = getCurrentCanvasId xstate fstate = get frameState xstate enewfstate = removeWindow currcid fstate case enewfstate of @@ -110,7 +106,7 @@ let cmap' = M.delete currcid cmap newcurrcid = maximum (M.keys cmap') xstate0 <- changeCurrentCanvasId newcurrcid - let xstate1 = set canvasInfoMap cmap' xstate0+ let xstate1 = maybe xstate0 id $ setCanvasInfoMap cmap' xstate0 putSt xstate1 let rtwin = get rootWindow xstate1 rtcntr = get rootContainer xstate1
lib/Application/HXournal/GUI.hs view
@@ -78,7 +78,7 @@ uxinputa <- actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> return (castToToggleAction x) toggleActionSetActive uxinputa xinputbool- let canvases = map (getDrawAreaFromBox) . M.elems . get canvasInfoMap $ st4+ let canvases = map (getDrawAreaFromBox) . M.elems . getCanvasInfoMap $ st4 if xinputbool then mapM_ (flip widgetSetExtensionEvents [ExtensionEventsAll]) canvases else mapM_ (flip widgetSetExtensionEvents [ExtensionEventsNone]) canvases
lib/Application/HXournal/GUI/Menu.hs view
@@ -17,6 +17,7 @@ import Application.HXournal.Coroutine.Callback import Application.HXournal.Type import Application.HXournal.Type.Clipboard+import Application.HXournal.Accessor import Control.Monad.Coroutine.SuspensionFunctors import Data.IORef import Data.Maybe@@ -496,7 +497,10 @@ ] actionGroupAddAction agr uxinputa - actionGroupAddRadioActions agr viewmods 0 (assignViewMode tref sref)+ -- actionGroupAddRadioActions agr viewmods 0 (assignViewMode tref sref)+ actionGroupAddRadioActions agr viewmods 0 (const (return ()))+ + actionGroupAddRadioActions agr pointmods 0 (assignPoint sref) actionGroupAddRadioActions agr penmods 0 (assignPenMode tref sref) actionGroupAddRadioActions agr colormods 0 (assignColor sref) @@ -529,8 +533,8 @@ uiManagerAddUiFromString ui uiDecl uiManagerInsertActionGroup ui agr 0 - Just ra1 <- actionGroupGetAction agr "ONEPAGEA"- Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 1] + -- Just ra1 <- actionGroupGetAction agr "ONEPAGEA"+ -- Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 1] Just ra2 <- actionGroupGetAction agr "PENFINEA" Gtk.set (castToRadioAction ra2) [radioActionCurrentValue := 2]@@ -555,15 +559,22 @@ return ui ++ assignViewMode :: IORef (Await MyEvent (Iteratee MyEvent XournalStateIO ())) -> IORef HXournalState -> RadioAction -> IO () assignViewMode tref sref a = do - v <- radioActionGetCurrentValue a+ -- v <- radioActionGetCurrentValue a st <- readIORef sref - case v of + putStrLn "in assignmViewMode"+ printCanvasMode (getCurrentCanvasId st) (get currentCanvasInfo st)+ putStrLn "still in assignViewMode"+ viewModeToMyEvent a >>= bouncecallback tref sref+ +{- case v of 1 -> bouncecallback tref sref ToSinglePage 0 -> bouncecallback tref sref ToContSinglePage- _ -> return ()+ _ -> return () -}
lib/Application/HXournal/ModelAction/Page.hs view
@@ -64,14 +64,17 @@ updatePageAll :: XournalState -> HXournalState -> IO HXournalState updatePageAll xojst xstate = do - let cmap = get canvasInfoMap xstate+ let cmap = getCanvasInfoMap xstate cmap' <- mapM (updatePage xojst . adjustPage xojst) cmap- let cid = get currentCanvasId xstate - cinfobox = maybeError "updatePageAll" (M.lookup cid cmap')- let newxstate = set currentCanvas (cid,cinfobox)- . set canvasInfoMap cmap' - . set xournalstate xojst $ xstate- return newxstate+ return $ maybe xstate id + . setCanvasInfoMap cmap' + . set xournalstate xojst $ xstate+ +-- return newxstate+-- let cid = getCurrentCanvasId xstate +-- cinfobox = maybeError "updatePageAll" (M.lookup cid cmap')+ -- set currentCanvasInfo cinfobox+ -- set currentCanvas (cid,cinfobox) adjustPage :: XournalState -> CanvasInfoBox -> CanvasInfoBox adjustPage xojstate = selectBox fsingle fsingle
lib/Application/HXournal/ModelAction/Window.hs view
@@ -164,7 +164,7 @@ eventConnect :: HXournalState -> WindowConfig -> IO (HXournalState,WindowConfig) eventConnect xstate (Node cid) = do - let cmap = get canvasInfoMap xstate + let cmap = getCanvasInfoMap xstate cinfobox = maybeError "eventConnect" $ M.lookup cid cmap case cinfobox of CanvasInfoBox cinfo -> do @@ -196,13 +196,13 @@ HXournalState -> WindowConfig -> IO (HXournalState,Widget,WindowConfig) constructFrame' template oxstate (Node cid) = do - let ocmap = get canvasInfoMap oxstate + let ocmap = getCanvasInfoMap oxstate (cinfobox,cmap,xstate) <- case M.lookup cid ocmap of Just cinfobox' -> return (cinfobox',ocmap,oxstate) Nothing -> do let cinfobox' = setCanvasId cid template cmap' = M.insert cid cinfobox' ocmap- xstate' = set canvasInfoMap cmap' oxstate+ xstate' = maybe oxstate id (setCanvasInfoMap cmap' oxstate) return (cinfobox',cmap',xstate') case cinfobox of CanvasInfoBox cinfo -> do
lib/Application/HXournal/Type/Coroutine.hs view
@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.Type.Coroutine @@ -9,6 +8,8 @@ -- Stability : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Type.Coroutine where import Data.IORef
lib/Application/HXournal/Type/Event.hs view
@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.Type.Event @@ -9,10 +8,13 @@ -- Stability : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Type.Event where import Application.HXournal.Type.Enum import Application.HXournal.Device +import Graphics.UI.Gtk data MyEvent = Initialized | CanvasConfigure Int Double Double @@ -120,3 +122,11 @@ | MenuDefault deriving (Show, Ord, Eq) +viewModeToMyEvent :: RadioAction -> IO MyEvent+viewModeToMyEvent a = do + v <- radioActionGetCurrentValue a+ case v of + 1 -> return ToSinglePage+ 0 -> return ToContSinglePage+ _ -> return ToSinglePage+
lib/Application/HXournal/Type/PageArrangement.hs view
@@ -116,8 +116,6 @@ in SingleArrangement cdim pdim (ViewPortBBox bbox) - - -- | makeContinuousSingleArrangement :: ZoomMode -> CanvasDimension
lib/Application/HXournal/Type/XournalState.hs view
@@ -12,7 +12,51 @@ -- ----------------------------------------------------------------------------- -module Application.HXournal.Type.XournalState where+module Application.HXournal.Type.XournalState +( XournalStateIO +, XournalState(..) +, HXournalState(..)+-- | labels+, xournalstate+, currFileName+-- , canvasInfoMap +-- , currentCanvas+, frameState+, rootWindow+, rootContainer+, rootOfRootWindow+, currentPenDraw+, clipboard+, callBack+, deviceList+, penInfo+, selectInfo+, gtkUIManager+, isSaved+, undoTable+, isEventBlocked +, pageModeSignal+-- | others +, emptyHXournalState+, getXournal+-- | additional lenses +, getCanvasInfoMap +, setCanvasInfoMap +, getCurrentCanvasId+, setCurrentCanvasId+, currentCanvasInfo+, resetXournalStateBuffers+, getCanvasInfo+, setCanvasInfo+, updateFromCanvasInfoAsCurrentCanvas+, setCanvasId+, modifyCanvasInfo+, modifyCurrentCanvasInfo+, modifyCurrCvsInfoM+, xojstateEither+-- | for debug+, showCanvasInfoMapViewPortBBox+) where import Application.HXournal.Device import Application.HXournal.Type.Event @@ -31,6 +75,7 @@ import Graphics.UI.Gtk hiding (Clipboard, get,set) import Data.Maybe import Data.Label +import qualified Data.Label.Maybe as ML import Data.Xournal.Generic import qualified Data.IntMap as M @@ -46,7 +91,7 @@ data HXournalState = HXournalState { _xournalstate :: XournalState , _currFileName :: Maybe FilePath- , _canvasInfoMap :: CanvasInfoMap + , _cvsInfoMap :: CanvasInfoMap , _currentCanvas :: (CanvasId,CanvasInfoBox) , _frameState :: WindowConfig , _rootWindow :: Widget@@ -61,6 +106,8 @@ , _gtkUIManager :: UIManager , _isSaved :: Bool , _undoTable :: UndoTable XournalState+ , _isEventBlocked :: Bool+ , _pageModeSignal :: Maybe (ConnectId RadioAction) -- , _networkClipboardInfo :: Maybe HXournalClipClientConfiguration } @@ -72,7 +119,7 @@ HXournalState { _xournalstate = ViewAppendState emptyGXournalMap , _currFileName = Nothing - , _canvasInfoMap = error "emptyHXournalState.canvasInfoMap"+ , _cvsInfoMap = error "emptyHXournalState.cvsInfoMap" , _currentCanvas = error "emtpyHxournalState.currentCanvas" , _frameState = error "emptyHXournalState.frameState" , _rootWindow = error "emtpyHXournalState.rootWindow"@@ -87,6 +134,8 @@ , _gtkUIManager = error "emptyHXournalState.gtkUIManager" , _isSaved = False , _undoTable = emptyUndo 1 + , _isEventBlocked = False + , _pageModeSignal = Nothing -- , _networkClipboardInfo = Nothing } @@ -99,17 +148,47 @@ -- | -currentCanvasId :: HXournalState :-> CanvasId-currentCanvasId = lens getter setter - where getter = fst . _currentCanvas - setter a = modify currentCanvas (\(_,x)->(a,x))+getCurrentCanvasId :: HXournalState -> CanvasId+getCurrentCanvasId = fst . _currentCanvas + +-- | +setCurrentCanvasId :: CanvasId -> HXournalState -> Maybe HXournalState+setCurrentCanvasId a f = do + cinfobox <- M.lookup a (_cvsInfoMap f)+ return (f { _currentCanvas = (a,cinfobox) })+ -- modify currentCanvas (\(_,x)->(a,x))+ +-- | + +getCanvasInfoMap :: HXournalState -> CanvasInfoMap +getCanvasInfoMap = _cvsInfoMap ++-- | ++setCanvasInfoMap :: CanvasInfoMap -> HXournalState -> Maybe HXournalState +setCanvasInfoMap cmap xstate + | M.null cmap = Nothing+ | otherwise = + let (cid,_) = _currentCanvas xstate+ (cidmax,cinfomax) = M.findMax cmap+ mcinfobox = M.lookup cid cmap + in Just . maybe (xstate {_currentCanvas=(cidmax,cinfomax), _cvsInfoMap = cmap}) + (\cinfobox -> xstate {_currentCanvas = (cid,cinfobox)+ ,_cvsInfoMap = cmap }) + $ mcinfobox+ currentCanvasInfo :: HXournalState :-> CanvasInfoBox currentCanvasInfo = lens getter setter - where getter = snd . _currentCanvas- setter a = modify currentCanvas (\(x,_)->(x,a)) -+ where + getter = snd . _currentCanvas + setter a f = + let cid = fst . _currentCanvas $ f + cmap' = M.adjust (const a) cid (_cvsInfoMap f)+ in f { _currentCanvas = (cid,a), _cvsInfoMap = cmap' } +-- modify currentCanvas (\(x,_)->(x,a)) + resetXournalStateBuffers :: XournalState -> IO XournalState resetXournalStateBuffers xojstate1 = case xojstate1 of @@ -120,7 +199,7 @@ getCanvasInfo :: CanvasId -> HXournalState -> CanvasInfoBox getCanvasInfo cid xstate = - let cinfoMap = get canvasInfoMap xstate+ let cinfoMap = getCanvasInfoMap xstate maybeCvs = M.lookup cid cinfoMap in maybeError ("no canvas with id = " ++ show cid) maybeCvs @@ -128,23 +207,23 @@ setCanvasInfo :: (CanvasId,CanvasInfoBox) -> HXournalState -> HXournalState setCanvasInfo (cid,cinfobox) xstate = - let cmap = get canvasInfoMap xstate+ let cmap = getCanvasInfoMap xstate cmap' = M.insert cid cinfobox cmap - xstate' = set canvasInfoMap cmap' xstate- in xstate' + in maybe xstate id $ setCanvasInfoMap cmap' xstate + -- | change current canvas. this is the master function updateFromCanvasInfoAsCurrentCanvas :: CanvasInfoBox -> HXournalState -> HXournalState updateFromCanvasInfoAsCurrentCanvas cinfobox xstate = let cid = unboxGet canvasId cinfobox - cmap = get canvasInfoMap xstate+ cmap = getCanvasInfoMap xstate cmap' = M.insert cid cinfobox cmap -- implement the following later -- page = gcast (unboxGet currentPage cinfobox) :: Page EditMode in xstate { _currentCanvas = (cid,cinfobox)- , _canvasInfoMap = cmap' }+ , _cvsInfoMap = cmap' } -- | @@ -156,8 +235,13 @@ modifyCanvasInfo :: CanvasId -> (CanvasInfoBox -> CanvasInfoBox) -> HXournalState -> HXournalState-modifyCanvasInfo cid f = modify currentCanvasInfo f - . modify canvasInfoMap (M.adjust f cid) +modifyCanvasInfo cid f xstate = + maybe xstate id . flip setCanvasInfoMap xstate + . M.adjust f cid . getCanvasInfoMap + $ xstate + +-- modify currentCanvasInfo f +-- . modify canvasInfoMap (M.adjust f cid) @@ -166,8 +250,10 @@ modifyCurrentCanvasInfo :: (CanvasInfoBox -> CanvasInfoBox) -> HXournalState -> HXournalState-modifyCurrentCanvasInfo f st = modify currentCanvasInfo f . modify canvasInfoMap (M.adjust f cid) $ st - where cid = get currentCanvasId st +modifyCurrentCanvasInfo f = modify currentCanvasInfo f + + -- modify currentCanvasInfo f . modify canvasInfoMap (M.adjust f cid) $ st + -- where cid = getCurrentCanvasId st -- | should be deprecated @@ -176,28 +262,34 @@ -> m HXournalState modifyCurrCvsInfoM f st = do let cinfobox = get currentCanvasInfo st - cid = get currentCanvasId st + cid = getCurrentCanvasId st ncinfobox <- f cinfobox- let cinfomap = get canvasInfoMap st+ let cinfomap = getCanvasInfoMap st ncinfomap = M.adjust (const ncinfobox) cid cinfomap - nst = set currentCanvasInfo ncinfobox - . set canvasInfoMap ncinfomap - $ st - return nst+ maybe (return st) return (setCanvasInfoMap ncinfomap st) +-- return nst+-- set currentCanvasInfo ncinfobox+ -- | xojstateEither :: XournalState -> Either (Xournal EditMode) (Xournal SelectMode) xojstateEither xojstate = case xojstate of ViewAppendState xoj -> Left xoj SelectState txoj -> Right txoj - - -- | showCanvasInfoMapViewPortBBox :: HXournalState -> IO () showCanvasInfoMapViewPortBBox xstate = do - let cmap = get canvasInfoMap xstate+ let cmap = getCanvasInfoMap xstate putStrLn . show . map (unboxGet (viewPortBBox.pageArrangement.viewInfo)) . M.elems $ cmap ++++++++