diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,2 +1,8 @@ 0.5: 12 Dec 2011 * First public release. basic pen operation, eraser operation, rectangular selection and file operations are implemented + +0.5.1: 16 Dec 2011 + * Use of configuration file '.hxournal'. Enable Use X Input menu. Dependency on xournal-parser and xournal-render is restricted to 0.2.0.* only + * checking gtk+-2.0 using pkg-config + + diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Config where + +import Data.List +import Data.Maybe + +import Control.Applicative +import Control.Monad + + +import Distribution.Simple +import Distribution.Simple.BuildPaths + +import Distribution.Simple.Setup +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo + +import Distribution.System + +import System.Exit +import System.Process + +import System.FilePath +import System.Directory + +import System.Info + +myConfigHook :: UserHooks +myConfigHook = simpleUserHooks { + confHook = hookfunction +} + +hookfunction :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags + -> IO LocalBuildInfo +hookfunction x cflags = do + binfo <- confHook simpleUserHooks x cflags + let pkg_descr = localPkgDescr binfo + r_pbi <- config binfo + let newbinfo = + case r_pbi of + Just pbi -> binfo { localPkgDescr = + updatePackageDescription pbi pkg_descr } + Nothing -> do + let r_lib = library pkg_descr + case r_lib of + Just lib -> + let binfo2 = libBuildInfo lib + newlib = lib { libBuildInfo = binfo2 { cSources = [] }} + in binfo {localPkgDescr = pkg_descr {library = Just newlib}} + Nothing -> error "some library setting is wrong." + return newbinfo + + +config :: LocalBuildInfo -> IO (Maybe HookedBuildInfo) +config bInfo = do + (excode,out,err) <- readProcessWithExitCode "pkg-config" ["--cflags", "gtk+-2.0"] "" + incdirs <- case excode of + ExitSuccess -> return . extractIncDir $ out + _ -> error $ ("failure when running pkg-config --cflags gtk+-2.0 :\n" ++ err) + + + let Just lib = library . localPkgDescr $ bInfo + buildinfo = libBuildInfo lib + let hbi = emptyBuildInfo { extraLibs = extraLibs buildinfo + , extraLibDirs = extraLibDirs buildinfo + , includeDirs = incdirs ++ includeDirs buildinfo + } + let (r :: Maybe HookedBuildInfo) = Just (Just hbi, []) + -- putStrLn $ show hbi + return r + +-- data CFlagsOptionSet = CFlagsOptionSet { +-- includedirs :: [String] +-- others :: [String] +-- } + +extractIncDir :: String -> [String] +extractIncDir = (mapMaybe parseCFlags) . words + +parseCFlags :: String -> Maybe String +parseCFlags [] = Nothing +parseCFlags str@(x:xs) = + case x of + '-' -> if null xs + then Nothing + else let (y:ys) = xs + in case y of + 'I' -> Just ys + _ -> Nothing + _ -> Nothing diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,10 +1,9 @@ #! /usr/bin/env runhaskell - +> > import Distribution.Simple > import Distribution.PackageDescription -> --import System.Process -> main = defaultMain -> --main = defaultMainWithHooks testUserHooks -> --testUserHooks = simpleUserHooks { -> -- preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo -> -- } +> import Config +> +> main :: IO () +> main = defaultMainWithHooks myConfigHook +> diff --git a/csrc/c_initdevice.c b/csrc/c_initdevice.c --- a/csrc/c_initdevice.c +++ b/csrc/c_initdevice.c @@ -2,7 +2,9 @@ #include #include -void initdevice( int* core, int* stylus, int* eraser ) +void initdevice( int* core, int* stylus, int* eraser, + char* corepointername, char* stylusname, char* erasername + ) { GList* dev_list; GdkDevice* device; @@ -19,15 +21,21 @@ // #endif gdk_device_set_mode(device, GDK_MODE_SCREEN); - printf(" yeah this is xinput device %s \n", device -> name); - if( !strcmp (device->name, "stylus") ) + printf("This is xinput device %s \n", device -> name); + if( !strcmp (device->name, stylusname) ) { + printf("got stylus\n"); (*stylus) = (int) device; - if( !strcmp (device->name, "eraser") ) + } + if( !strcmp (device->name, erasername) ) { + printf("got eraser\n"); (*eraser) = (int) device; + } } else { - if( !strcmp (device->name, "Core Pointer") ) + if( !strcmp (device->name, corepointername) ) { + printf("got Core Pointer\n"); (*core) = (int) device; + } } dev_list = dev_list->next; } diff --git a/csrc/c_initdevice.h b/csrc/c_initdevice.h --- a/csrc/c_initdevice.h +++ b/csrc/c_initdevice.h @@ -1,6 +1,6 @@ #include #include -void initdevice( int*, int*, int* ); +void initdevice( int* core, int* stylus, int* eraser, + char* corepointername, char* stylusname, char* erasername ); -//void extEventCanvas( void* ); diff --git a/hxournal.cabal b/hxournal.cabal --- a/hxournal.cabal +++ b/hxournal.cabal @@ -1,19 +1,25 @@ Name: hxournal -Version: 0.5.0.0 +Version: 0.5.1 Synopsis: A pen notetaking program written in haskell Description: notetaking program written in haskell and gtk2hs +Homepage: http://ianwookim.org/hxournal License: BSD3 License-file: LICENSE Author: Ian-Woo Kim Maintainer: Ian-Woo Kim Category: Application Tested-with: GHC == 7.0.3 -Build-Type: Simple +Build-Type: Custom Cabal-Version: >= 1.8 data-files: template/*.html.st resource/*.png CHANGES + Config.hs +Source-repository head + type: git + location: https://www.github.com/wavewave/hxournal + Executable hxournal Main-is: hxournal.hs hs-source-dirs: exe @@ -35,18 +41,21 @@ filepath == 1.*, strict == 0.3.*, gtk == 0.12.*, - cairo == 0.12.*, + cairo == 0.12.*, monad-coroutine == 0.7.*, transformers == 0.2.*, - xournal-parser == 0.2.*, - xournal-render == 0.2.*, + xournal-parser == 0.2.0.*, + xournal-render == 0.2.0.*, containers == 0.4.*, template-haskell == 2.*, blaze-builder == 0.3.*, bytestring == 0.9.*, double-conversion == 0.2.*, fclabels == 1.0.*, - cmdargs >= 0.7 && <= 0.10 + cmdargs >= 0.7 && <= 0.10, + configurator == 0.1.* + + -- >= 0.1 && < 0.3 Exposed-Modules: Application.HXournal.ProgType Application.HXournal.Job @@ -88,6 +97,7 @@ Application.HXournal.Device Application.HXournal.Builder Application.HXournal.Accessor + Application.HXournal.Config Other-Modules: Paths_hxournal c-sources: diff --git a/lib/Application/HXournal/Config.hs b/lib/Application/HXournal/Config.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Config.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} + +module Application.HXournal.Config where + +import Control.Monad +import Data.Configurator as C +import Data.Configurator.Types +import System.Environment +import System.Directory +import System.FilePath +import Control.Concurrent + +emptyConfigString :: String +emptyConfigString = "\n#config file for hxournal \n " + +loadConfigFile :: IO Config +loadConfigFile = do + homepath <- getEnv "HOME" + let dothxournal = homepath ".hxournal" + b <- doesFileExist dothxournal + when (not b) $ do + writeFile dothxournal emptyConfigString + threadDelay 1000000 + config <- load [Required "$(HOME)/.hxournal"] + return config + +getPenDevConfig :: Config -> IO (Maybe String, Maybe String,Maybe String) +getPenDevConfig c = do + mcore <- C.lookup c "core" + mstylus <- C.lookup c "stylus" + meraser <- C.lookup c "eraser" + return (mcore,mstylus,meraser) + +getXInputConfig :: Config -> IO Bool +getXInputConfig c = do + (mxinput :: Maybe String) <- C.lookup c "xinput" + case mxinput of + Nothing -> return False + Just str -> case str of + "true" -> return True + "false" -> return False + _ -> error "cannot understand xinput in configfile" + + diff --git a/lib/Application/HXournal/Coroutine/Default.hs b/lib/Application/HXournal/Coroutine/Default.hs --- a/lib/Application/HXournal/Coroutine/Default.hs +++ b/lib/Application/HXournal/Coroutine/Default.hs @@ -10,6 +10,7 @@ import Application.HXournal.Draw import Application.HXournal.Accessor +import Application.HXournal.GUI.Menu import Application.HXournal.Coroutine.Callback import Application.HXournal.Coroutine.Draw import Application.HXournal.Coroutine.Pen @@ -60,21 +61,29 @@ let st0 = (emptyHXournalState :: HXournalState) sref <- newIORef st0 tref <- newIORef (undefined :: SusAwait) - let st1 = set deviceList devlst + (r,st') <- St.runStateT (resume guiProcess) st0 + writeIORef sref st' + case r of + Left aw -> do + writeIORef tref aw + Right _ -> error "what?" + + let st0new = set deviceList devlst . set rootOfRootWindow window - . set callBack (bouncecallback tref sref) $ st0 + . set callBack (bouncecallback tref sref) + $ st' + writeIORef sref st0new + ui <- getMenuUI tref sref + putStrLn "hi" + let st1 = set gtkUIManager ui st0new + initcvs <- initCanvasInfo st1 1 let initcmap = M.insert (get canvasId initcvs) initcvs M.empty let startingXstate = set currentCanvas (get canvasId initcvs) . set canvasInfoMap initcmap . set frameState (Node 1) $ st1 - (r,st') <- St.runStateT (resume guiProcess) startingXstate - writeIORef sref st' - case r of - Left aw -> do - writeIORef tref aw - Right _ -> error "what?" + writeIORef sref startingXstate return (tref,sref) initialize :: Iteratee MyEvent XournalStateIO () @@ -199,4 +208,23 @@ menuEventProcess MenuHSplit = eitherSplit SplitHorizontal menuEventProcess MenuVSplit = eitherSplit SplitVertical menuEventProcess MenuDelCanvas = deleteCanvas +menuEventProcess MenuUseXInput = do + -- putStrLn "Use X Input clicked" + xstate <- getSt + let ui = get gtkUIManager xstate + agr <- liftIO ( uiManagerGetActionGroups ui >>= \x -> + case x of + [] -> error "No action group? " + y:_ -> return y ) + uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> + return (castToToggleAction x) ) + b <- liftIO $ toggleActionGetActive uxinputa + -- liftIO $ putStrLn $ "bool = " ++ show b + let cmap = get canvasInfoMap xstate + canvases = map (get drawArea) . M.elems $ cmap + + if b + then mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsAll]) canvases + else mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsNone] ) canvases + menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m diff --git a/lib/Application/HXournal/Device.hsc b/lib/Application/HXournal/Device.hsc --- a/lib/Application/HXournal/Device.hsc +++ b/lib/Application/HXournal/Device.hsc @@ -5,12 +5,17 @@ module Application.HXournal.Device where +import Application.HXournal.Config +import Data.Configurator.Types + + import Control.Applicative import Control.Monad.Reader import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.C +import Foreign.C.String import Foreign.Storable import Graphics.UI.Gtk @@ -34,14 +39,27 @@ foreign import ccall "c_initdevice.h initdevice" c_initdevice - :: Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () + :: Ptr CInt -> Ptr CInt -> Ptr CInt -> CString -> CString -> CString -> IO () -initDevice :: IO DeviceList -initDevice = +initDevice :: Config -> IO DeviceList +initDevice cfg = do + (mcore,mstylus,meraser) <- getPenDevConfig cfg + putStrLn $ show mstylus with 0 $ \pcore -> - with 0 $ \pstylus -> - with 0 $ \peraser -> do - c_initdevice pcore pstylus peraser + with 0 $ \pstylus -> + with 0 $ \peraser -> do + pcorename <- case mcore of + Nothing -> newCString "Core Pointer" + Just core -> newCString core + pstylusname <- case mstylus of + Nothing -> newCString "stylus" + Just spen -> newCString spen + perasername <- case meraser of + Nothing -> newCString "eraser" + Just seraser -> newCString seraser + + c_initdevice pcore pstylus peraser pcorename pstylusname perasername + core_val <- peek pcore stylus_val <- peek pstylus eraser_val <- peek peraser diff --git a/lib/Application/HXournal/GUI.hs b/lib/Application/HXournal/GUI.hs --- a/lib/Application/HXournal/GUI.hs +++ b/lib/Application/HXournal/GUI.hs @@ -4,11 +4,16 @@ import Application.HXournal.Type.XournalState import Application.HXournal.Type.Event +import Application.HXournal.Type.Canvas +import qualified Data.IntMap as M + import Application.HXournal.Coroutine.Callback + +import Application.HXournal.Config import Application.HXournal.Device import Application.HXournal.Coroutine -import Application.HXournal.GUI.Menu +-- import Application.HXournal.GUI.Menu import Application.HXournal.ModelAction.File import Application.HXournal.ModelAction.Window @@ -27,28 +32,42 @@ startGUI mfname = do initGUI window <- windowNew - - devlst <- initDevice + + cfg <- loadConfigFile + devlst <- initDevice cfg (tref,sref) <- initCoroutine devlst window - st0 <- readIORef sref - st1 <- getFileContent mfname st0 - writeIORef sref st1 + st1 <- readIORef sref + + -- let st1 = set gtkUIManager ui st0 + st2 <- getFileContent mfname st1 + let ui = get gtkUIManager st2 + writeIORef sref st2 (winCvsArea, wconf) <- constructFrame <$> get frameState - <*> get canvasInfoMap $ st1 + <*> get canvasInfoMap $ st2 - setTitleFromFileName st1 + setTitleFromFileName st2 vbox <- vBoxNew False 0 - let st2 = set frameState wconf + let st3 = set frameState wconf . set rootWindow winCvsArea - . set rootContainer (castToBox vbox) $ st1 - writeIORef sref st2 - ui <- getMenuUI tref sref + . set rootContainer (castToBox vbox) $ st2 + writeIORef sref st3 - let st3 = set gtkUIManager ui st2 - writeIORef sref st3 + xinputbool <- getXInputConfig cfg + agr <- uiManagerGetActionGroups ui >>= \x -> + case x of + [] -> error "No action group? " + y:_ -> return y + uxinputa <- actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> + return (castToToggleAction x) + toggleActionSetActive uxinputa xinputbool + let canvases = map (get drawArea) . M.elems . get canvasInfoMap $ st3 + if xinputbool + then mapM_ (flip widgetSetExtensionEvents [ExtensionEventsAll]) canvases + else mapM_ (flip widgetSetExtensionEvents [ExtensionEventsNone]) canvases + maybeMenubar <- uiManagerGetWidget ui "/ui/menubar" let menubar = case maybeMenubar of Just x -> x diff --git a/lib/Application/HXournal/GUI/Menu.hs b/lib/Application/HXournal/GUI/Menu.hs --- a/lib/Application/HXournal/GUI/Menu.hs +++ b/lib/Application/HXournal/GUI/Menu.hs @@ -425,7 +425,10 @@ setdefopta <- actionNewAndRegister "SETDEFOPTA" "Set As Default" (Just "Just a Stub") Nothing (justMenu MenuSetAsDefaultOption) -- options menu - uxinputa <- actionNewAndRegister "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing (justMenu MenuUseXInput) + uxinputa <- toggleActionNew "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing + uxinputa `on` actionToggled $ do + bouncecallback tref sref (Menu MenuUseXInput) +-- AndRegister "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing (justMenu MenuUseXInput) 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 <- actionNewAndRegister "PRESSRSENSA" "Pressure Sensitivity" (Just "Just a Stub") Nothing (justMenu MenuPressureSensitivity) @@ -462,12 +465,15 @@ , shpreca, rulera, clra, penopta {- selregna, selrecta, vertspa, handa, -} , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta , setdefopta - , uxinputa, dcrdcorea, ersrtipa, pressrsensa, pghilta, mltpgvwa + {- , uxinputa, -} + , dcrdcorea, ersrtipa, pressrsensa, pghilta, mltpgvwa , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa , abouta , defaulta ] + + actionGroupAddAction agr uxinputa actionGroupAddRadioActions agr viewmods 0 (\_ -> return ()) actionGroupAddRadioActions agr pointmods 0 (assignPoint sref) actionGroupAddRadioActions agr penmods 0 (assignPenMode tref sref) @@ -485,7 +491,8 @@ , shpreca, rulera , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta , setdefopta - , uxinputa, dcrdcorea, ersrtipa, pressrsensa, pghilta, mltpgvwa + {- , uxinputa -} + , dcrdcorea, ersrtipa, pressrsensa, pghilta, mltpgvwa , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa , abouta @@ -494,6 +501,7 @@ enabledActions = [ opena, savea, saveasa, quita, fstpagea, prvpagea, nxtpagea, lstpagea , clra, penopta, zooma, nrmsizea, pgwdtha -- , selrecta + -- , uxinputa ] mapM_ (\x->actionSetSensitive x True) enabledActions diff --git a/lib/Application/HXournal/ModelAction/Window.hs b/lib/Application/HXournal/ModelAction/Window.hs --- a/lib/Application/HXournal/ModelAction/Window.hs +++ b/lib/Application/HXournal/ModelAction/Window.hs @@ -62,7 +62,19 @@ return () -} widgetAddEvents canvas [PointerMotionMask,Button1MotionMask] - widgetSetExtensionEvents canvas [ExtensionEventsAll] + -- widgetSetExtensionEvents canvas [ExtensionEventsAll] + -- widgetSetExtensionEvents canvas + let ui = get gtkUIManager xstate + agr <- liftIO ( uiManagerGetActionGroups ui >>= \x -> + case x of + [] -> error "No action group? " + y:_ -> return y ) + uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> + return (castToToggleAction x) ) + b <- liftIO $ toggleActionGetActive uxinputa + if b + then widgetSetExtensionEvents canvas [ExtensionEventsAll] + else widgetSetExtensionEvents canvas [ExtensionEventsNone] afterValueChanged hadj $ do v <- adjustmentGetValue hadj