glade 0.11.1 → 0.12.0
raw patch · 12 files changed
+195/−167 lines, 12 filesdep ~cairodep ~glibdep ~gtksetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: cairo, glib, gtk, pango
API changes (from Hackage documentation)
- Graphics.UI.Gtk.Glade: class (GObjectClass o) => GladeXMLClass o
+ Graphics.UI.Gtk.Glade: class GObjectClass o => GladeXMLClass o
- Graphics.UI.Gtk.Glade: xmlGetWidget :: (WidgetClass widget) => GladeXML -> (GObject -> widget) -> String -> IO widget
+ Graphics.UI.Gtk.Glade: xmlGetWidget :: WidgetClass widget => GladeXML -> (GObject -> widget) -> String -> IO widget
Files
- Graphics/UI/Gtk/Glade.chs +3/−3
- Gtk2HsSetup.hs +44/−19
- Setup.hs +5/−2
- demo/calc/Calc.hs +7/−7
- demo/calc/CalcModel.hs +3/−3
- demo/glade/GladeTest.hs +19/−19
- demo/noughty/Noughty.hs +8/−8
- demo/noughty/NoughtyGlade.hs +8/−8
- demo/profileviewer/ParseProfile.hs +1/−1
- demo/profileviewer/ProfileViewer.hs +14/−14
- demo/scaling/Scaling.hs +78/−78
- glade.cabal +5/−5
Graphics/UI/Gtk/Glade.chs view
@@ -61,7 +61,7 @@ import System.Glib.FFI import System.Glib.GType import Graphics.UI.Gtk.Abstract.Object (makeNewObject)-import System.Glib.GObject (constructNewGObject)+import System.Glib.GObject (wrapNewGObject) {#import Graphics.UI.Gtk.Glade.Types#} import System.Glib.GList @@ -79,7 +79,7 @@ withCString file $ \strPtr1 -> do xmlPtr <- {#call unsafe xml_new#} strPtr1 nullPtr nullPtr if xmlPtr==nullPtr then return Nothing- else liftM Just $ constructNewGObject mkGladeXML (return xmlPtr)+ else liftM Just $ wrapNewGObject mkGladeXML (return xmlPtr) -- | Create a new GladeXML object (and the corresponding widgets) from the -- given XML file.@@ -100,7 +100,7 @@ -- 'Nothing' for default) -> IO (Maybe GladeXML) xmlNewWithRootAndDomain file rootWidgetName domain =- maybeNull (constructNewGObject mkGladeXML) $+ maybeNull (wrapNewGObject mkGladeXML) $ withCString file $ \filePtr -> maybeWith withCString rootWidgetName $ \rootWidgetNamePtr -> maybeWith withCString domain $ \domainPtr ->
Gtk2HsSetup.hs view
@@ -23,16 +23,24 @@ CABAL_VERSION_MICRO) #else #warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command)+#if (__GLASGOW_HASKELL__ >= 700)+#define CABAL_VERSION CABAL_VERSION_ENCODE(1,10,0)+#else #if (__GLASGOW_HASKELL__ >= 612) #define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0) #else #define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0) #endif #endif+#endif -- | Build a Gtk2hs package. ---module Gtk2HsSetup ( gtk2hsUserHooks, getPkgConfigPackages ) where+module Gtk2HsSetup ( + gtk2hsUserHooks, + getPkgConfigPackages, + checkGtk2hsBuildtools+ ) where import Distribution.Simple import Distribution.Simple.PreProcess@@ -65,7 +73,7 @@ import Distribution.Simple.Compiler ( Compiler(..) ) import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..),- rawSystemProgramConf, rawSystemProgramStdoutConf,+ rawSystemProgramConf, rawSystemProgramStdoutConf, programName, c2hsProgram, pkgConfigProgram, requireProgram, ghcPkgProgram, simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg) import Distribution.ModuleName ( ModuleName, components, toFilePath )@@ -83,10 +91,11 @@ #endif import Distribution.Text ( simpleParse, display ) import System.FilePath-import System.Directory ( doesFileExist )+import System.Exit (exitFailure)+import System.Directory ( doesFileExist, getDirectoryContents, doesDirectoryExist ) import Distribution.Version (Version(..)) import Distribution.Verbosity-import Control.Monad (when, unless, filterM)+import Control.Monad (when, unless, filterM, liftM, forM, forM_) import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList ) import Data.List (isPrefixOf, isSuffixOf, nub) import Data.Char (isAlpha)@@ -94,7 +103,6 @@ import qualified Data.Set as S import Control.Applicative ((<$>))-import System.Directory (getDirectoryContents, doesDirectoryExist) -- the name of the c2hs pre-compiled header file precompFile = "precompchs.bin"@@ -103,13 +111,13 @@ hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal], hookedPreProcessors = [("chs", ourC2hs)], confHook = \pd cf ->- confHook simpleUserHooks pd cf >>= return . adjustLocalBuildInfo,+ (fmap adjustLocalBuildInfo (confHook simpleUserHooks pd cf)), postConf = \args cf pd lbi -> do genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi postConf simpleUserHooks args cf pd lbi, buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd ->- (buildHook simpleUserHooks) pd lbi uh bf,- copyHook = \pd lbi uh flags -> (copyHook simpleUserHooks) pd lbi uh flags >>+ buildHook simpleUserHooks pd lbi uh bf,+ copyHook = \pd lbi uh flags -> copyHook simpleUserHooks pd lbi uh flags >> installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)), instHook = \pd lbi uh flags -> #if defined(mingw32_HOST_OS) || defined(__MINGW32__)@@ -187,7 +195,11 @@ _ | modeGenerateRegFile -> die "Generate Reg File not supported" | modeGenerateRegScript -> die "Generate Reg Script not supported" | otherwise -> registerPackage verbosity+#if CABAL_VERSION_CHECK(1,10,0)+ installedPkgInfo pkg lbi inplace [packageDb]+#else installedPkgInfo pkg lbi inplace packageDb+#endif where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))@@ -298,7 +310,7 @@ getCppOptions bi lbi = nub $ ["-I" ++ dir | dir <- PD.includeDirs bi]- ++ [opt | opt@('-':c:_) <- (PD.cppOptions bi ++ PD.ccOptions bi), c `elem` "DIU"]+ ++ [opt | opt@('-':c:_) <- PD.cppOptions bi ++ PD.ccOptions bi, c `elem` "DIU"] installCHI :: PackageDescription -- ^information from the .cabal file -> LocalBuildInfo -- ^information from the configure step@@ -308,14 +320,13 @@ let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest -- cannot use the recommended 'findModuleFiles' since it fails if there exists -- a modules that does not have a .chi file- mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi])- (map toFilePath+ mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi] . toFilePath) #if CABAL_VERSION_CHECK(1,8,0) (PD.libModules lib) #else (PD.libModules pkg) #endif- )+ let files = [ f | Just f <- mFiles ] #if CABAL_VERSION_CHECK(1,8,0) installOrdinaryFiles verbosity libPref files@@ -331,13 +342,13 @@ ------------------------------------------------------------------------------ typeGenProgram :: Program-typeGenProgram = (simpleProgram "gtk2hsTypeGen")+typeGenProgram = simpleProgram "gtk2hsTypeGen" signalGenProgram :: Program-signalGenProgram = (simpleProgram "gtk2hsHookGenerator")+signalGenProgram = simpleProgram "gtk2hsHookGenerator" c2hsLocal :: Program-c2hsLocal = (simpleProgram "gtk2hsC2hs")+c2hsLocal = simpleProgram "gtk2hsC2hs" genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () genSynthezisedFiles verb pd lbi = do@@ -370,7 +381,7 @@ res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args rewriteFile outFile res - (flip mapM_) (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $+ forM_ (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $ \(fileTag, f) -> do let tag = reverse (drop 4 (reverse fileTag)) info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.")@@ -391,7 +402,7 @@ sequence [ do version <- pkgconfig ["--modversion", display pkgname] case simpleParse version of- Nothing -> die $ "parsing output of pkg-config --modversion failed"+ Nothing -> die "parsing output of pkg-config --modversion failed" Just v -> return (PackageIdentifier pkgname v) | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ] where@@ -456,9 +467,9 @@ extractDeps :: ModDep -> IO ModDep extractDeps md@ModDep { mdLocation = Nothing } = return md extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do- let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of+ let findImports acc (('{':'#':xs):xxs) = case (dropWhile (' ' ==) xs) of ('i':'m':'p':'o':'r':'t':' ':ys) ->- case simpleParse (takeWhile ((/=) '#') ys) of+ case simpleParse (takeWhile ('#' /=) ys) of Just m -> findImports (m:acc) xxs Nothing -> die ("cannot parse chs import in "++f++":\n"++ "offending line is {#"++xs)@@ -484,3 +495,17 @@ Just md -> (md:out', visited') where (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md)++-- Check user whether install gtk2hs-buildtools correctly.+checkGtk2hsBuildtools :: [String] -> IO ()+checkGtk2hsBuildtools programs = do+ programInfos <- mapM (\ name -> do+ location <- programFindLocation (simpleProgram name) normal+ return (name, location)+ ) programs+ let printError name = do+ putStrLn $ "Cannot find " ++ name ++ "\n" + ++ "Please install `gtk2hs-buildtools` first and check that the install directory is in your PATH (e.g. HOME/.cabal/bin)."+ exitFailure+ forM_ programInfos $ \ (name, location) ->+ when (isNothing location) (printError name)
Setup.hs view
@@ -1,7 +1,10 @@ -- Setup file for a Gtk2Hs module. Contains only adjustments specific to this module, -- all Gtk2Hs-specific boilerplate is stored in Gtk2HsSetup.hs which should be kept -- identical across all modules.-import Gtk2HsSetup ( gtk2hsUserHooks )+import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools ) import Distribution.Simple ( defaultMainWithHooks ) -main = defaultMainWithHooks gtk2hsUserHooks+main = do+ checkGtk2hsBuildtools ["gtk2hsC2hs", "gtk2hsTypeGen", "gtk2hsHookGenerator"]+ defaultMainWithHooks gtk2hsUserHooks+
demo/calc/Calc.hs view
@@ -9,18 +9,18 @@ main = do initGUI- + -- load up the glade file calcXmlM <- xmlNew "calc.glade" let calcXml = case calcXmlM of (Just calcXml) -> calcXml Nothing -> error "can't find the glade file \"calc.glade\" \ \in the current directory"- + -- get a handle on a some widgets from the glade file window <- xmlGetWidget calcXml castToWindow "calcwindow" display <- xmlGetWidget calcXml castToLabel "display"- + -- a list of the names of the buttons and the actions associated with them let buttonNamesAndOperations = numbericButtons ++ otherButtons numbericButtons = [ ("num-" ++ show n, Calc.enterDigit n)@@ -33,7 +33,7 @@ ,("op-divide", Calc.enterBinOp Calc.divide) ,("equals", Calc.evaluate) ,("clear", \_ -> Just ("0", Calc.clearCalc))]- + -- action to do when a button corresponding to a calculator operation gets -- pressed: we update the calculator state and display the new result. -- These calculator operations can return Nothing for when the operation@@ -52,13 +52,13 @@ connectButtonToOperation name operation = do button <- xmlGetWidget calcXml castToButton name button `onClicked` calcOperation operation- + -- connect up all the buttons with their actions. mapM_ (uncurry connectButtonToOperation) buttonNamesAndOperations- + -- make the program exit when the main window is closed window `onDestroy` mainQuit- + -- show everything and run the main loop widgetShowAll window mainGUI
demo/calc/CalcModel.hs view
@@ -86,7 +86,7 @@ }) evaluate :: Calc -> Maybe (String, Calc)-evaluate calc = +evaluate calc = let newTotal = (case operator calc of BinOp op -> op) (total calc) (digitsToNumber (number calc))@@ -126,7 +126,7 @@ testProg :: IO () testProg = do evalLoop clearCalc- + where evalLoop :: Calc -> IO () evalLoop calc = do putStr "calc> "@@ -134,7 +134,7 @@ when (line /= "q") $ do result <- case line of [digit] | isDigit digit- -> return $ enterDigit (read [digit]) calc + -> return $ enterDigit (read [digit]) calc "." -> return $ enterDecimalPoint calc "+" -> return $ enterBinOp plus calc "-" -> return $ enterBinOp minus calc
demo/glade/GladeTest.hs view
@@ -5,22 +5,22 @@ main = do initGUI- - -- load up the glade file- dialogXmlM <- xmlNew "simple.glade"- let dialogXml = case dialogXmlM of- (Just dialogXml) -> dialogXml- Nothing -> error "can't find the glade file \"simple.glade\" \- \in the current directory"- - -- get a handle on a couple widgets from the glade file- window <- xmlGetWidget dialogXml castToWindow "window1"- button <- xmlGetWidget dialogXml castToButton "button1"- - -- do something with the widgets, just to prove it works- button `onClicked` putStrLn "button pressed!"- window `onDestroy` mainQuit- - -- show everything- widgetShowAll window- mainGUI++ -- load up the glade file+ dialogXmlM <- xmlNew "simple.glade"+ let dialogXml = case dialogXmlM of+ (Just dialogXml) -> dialogXml+ Nothing -> error "can't find the glade file \"simple.glade\" \+ \in the current directory"++ -- get a handle on a couple widgets from the glade file+ window <- xmlGetWidget dialogXml castToWindow "window1"+ button <- xmlGetWidget dialogXml castToButton "button1"++ -- do something with the widgets, just to prove it works+ button `onClicked` putStrLn "button pressed!"+ window `onDestroy` mainQuit++ -- show everything+ widgetShowAll window+ mainGUI
demo/noughty/Noughty.hs view
@@ -31,26 +31,26 @@ move :: Int -> Player -> Board -> Maybe Board move n p b = case y of- Blank -> Just (chop size (xs ++ (p : ys)))- _ -> Nothing- where+ Blank -> Just (chop size (xs ++ (p : ys)))+ _ -> Nothing+ where (xs,y:ys) = splitAt n (concat b) chop :: Int -> [a] -> [[a]] chop n [] = [] chop n xs = take n xs : chop n (drop n xs) -diag :: [[a]] -> [a]+diag :: [[a]] -> [a] diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]] full :: Board -> Bool full b = all (all (/= Blank)) b -wins :: Player -> Board -> Bool+wins :: Player -> Board -> Bool wins p b = any (all (== p)) b- || any (all (== p)) (transpose b)- || all (== p) (diag b)- || all (== p) (diag (reverse b))+ || any (all (== p)) (transpose b)+ || all (== p) (diag b)+ || all (== p) (diag (reverse b)) won :: Board -> Bool won b = wins Nought b || wins Cross b
demo/noughty/NoughtyGlade.hs view
@@ -32,26 +32,26 @@ move :: Int -> Player -> Board -> Maybe Board move n p b = case y of- Blank -> Just (chop size (xs ++ (p : ys)))- _ -> Nothing- where+ Blank -> Just (chop size (xs ++ (p : ys)))+ _ -> Nothing+ where (xs,y:ys) = splitAt n (concat b) chop :: Int -> [a] -> [[a]] chop n [] = [] chop n xs = take n xs : chop n (drop n xs) -diag :: [[a]] -> [a]+diag :: [[a]] -> [a] diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]] full :: Board -> Bool full b = all (all (/= Blank)) b -wins :: Player -> Board -> Bool+wins :: Player -> Board -> Bool wins p b = any (all (== p)) b- || any (all (== p)) (transpose b)- || all (== p) (diag b)- || all (== p) (diag (reverse b))+ || any (all (== p)) (transpose b)+ || all (== p) (diag b)+ || all (== p) (diag (reverse b)) won :: Board -> Bool won b = wins Nought b || wins Cross b
demo/profileviewer/ParseProfile.hs view
@@ -88,7 +88,7 @@ eindividualTime = floor $ (read individualTime) * 10, eindividualAlloc = floor $ (read individualAlloc) * 10, einheritedTime = floor $ (read inheritedTime) * 10,- einheritedAlloc = floor $ (read inheritedAlloc) * 10 + einheritedAlloc = floor $ (read inheritedAlloc) * 10 } _ -> error $ "bad profile line:\n\t" ++ line
demo/profileviewer/ProfileViewer.hs view
@@ -4,7 +4,7 @@ -- This is a slightly larger demo that combines use of glade, the file chooser -- dialog, program state (IORefs) and use of the mogul tree view wrapper--- interface. +-- interface. -- The program is a simple viewer for the log files that ghc produces when you -- do time profiling. The parser is not very clever so loading large files can@@ -33,7 +33,7 @@ -- our global state thresholdVar <- newIORef 0 --current cuttoff/threshhold value profileVar <- newIORef Nothing --holds the current profile data structure- + -- initialisation stuff initGUI @@ -49,7 +49,7 @@ commandLabel <- xmlGetWidget dialogXml castToLabel "commandLabel" totalTimeLabel <- xmlGetWidget dialogXml castToLabel "totalTimeLabel" totalAllocLabel <- xmlGetWidget dialogXml castToLabel "totalAllocLabel"- + -- create the tree model store <- New.treeStoreNew [] New.treeViewSetModel mainView store@@ -74,7 +74,7 @@ -- this action clears the tree model and then populates it with the -- profile contained in the profileVar, taking into account the current- -- threshold value kept in the thresholdVar + -- threshold value kept in the thresholdVar let repopulateTreeStore = do profile <- readIORef profileVar maybe (return ()) repopulateTreeStore' profile@@ -86,8 +86,8 @@ commandLabel `labelSetText` (command profile) totalTimeLabel `labelSetText` (show (totalTime profile) ++ " sec") totalAllocLabel `labelSetText` (formatNumber (totalAlloc profile) ++ " bytes")- - threshold <- readIORef thresholdVar++ threshold <- readIORef thresholdVar let node = if threshold > 0 then pruneOnThreshold threshold (breakdown profile) else Just (breakdown profile)@@ -98,7 +98,7 @@ Just node -> New.treeStoreInsertTree store [] 0 (toTree node) -- associate actions with the menus- + -- the open menu item, opens a file dialog and then loads and displays -- the the profile (unless the user cancleled the dialog) openMenuItem <- xmlGetWidget dialogXml castToMenuItem "openMenuItem"@@ -106,21 +106,21 @@ filename <- openFileDialog mainWindow when (isJust filename) (do profile <- parseProfileFile (fromJust filename)- writeIORef profileVar (Just profile)+ writeIORef profileVar (Just profile) repopulateTreeStore) quitMenuItem <- xmlGetWidget dialogXml castToMenuItem "quitMenuItem" quitMenuItem `onActivateLeaf` mainQuit- + aboutMenuItem <- xmlGetWidget dialogXml castToMenuItem "aboutMenuItem" aboutMenuItem `onActivateLeaf` showAboutDialog mainWindow- + -- each menu item in the "View" menu sets the thresholdVar and re-displays -- the current profile let doThresholdMenuItem threshold itemName = do menuItem <- xmlGetWidget dialogXml castToMenuItem itemName menuItem `onActivateLeaf` do writeIORef thresholdVar threshold- repopulateTreeStore+ repopulateTreeStore mapM_ (uncurry doThresholdMenuItem) [(0, "allEntries"), (1, "0.1%Entries"), (5, "0.5%Entries"), (10, "1%Entries"), (50, "5%Entries"), (100, "10%Entries"), (500, "50%Entries")]@@ -143,9 +143,9 @@ dialog <- fileChooserDialogNew (Just "Open Profile... ") (Just parentWindow)- FileChooserActionOpen- [("gtk-cancel", ResponseCancel)- ,("gtk-open", ResponseAccept)]+ FileChooserActionOpen+ [("gtk-cancel", ResponseCancel)+ ,("gtk-open", ResponseAccept)] widgetShow dialog response <- dialogRun dialog widgetHide dialog
demo/scaling/Scaling.hs view
@@ -20,10 +20,10 @@ import Control.Monad ( when, unless, liftM ) import Control.Monad.Trans ( liftIO ) import Control.Monad.ST-import Data.Array.Base ( unsafeWrite, unsafeRead ) +import Data.Array.Base ( unsafeWrite, unsafeRead ) import Graphics.UI.Gtk import Graphics.UI.Gtk.Glade-import Graphics.UI.Gtk.ModelView as New +import Graphics.UI.Gtk.ModelView as New import Graphics.UI.Gtk.Gdk.GC (gcNew) import CPUTime import System.Environment ( getArgs )@@ -39,7 +39,7 @@ is :: ImageState } - + main = do args <- getArgs case args of@@ -48,8 +48,8 @@ if exists then runGUI fName else putStrLn ("File "++fName++" not found.") _ -> putStrLn "Usage: scaling <image.jpg>"- -runGUI fName = do ++runGUI fName = do initGUI window <- windowNew@@ -59,19 +59,19 @@ label <- labelNew (Just "Content Aware Image Scaling") vboxOuter <- vBoxNew False 0 vboxInner <- vBoxNew False 5- + (mb,miOpen,miSave,miScale, miGradient, miSeamCarve, miQuit) <- makeMenuBar canvas <- drawingAreaNew containerAdd vboxInner canvas- - ++ -- Assemble the bits set vboxOuter [ containerChild := mb , containerChild := vboxInner ] set vboxInner [ containerChild := label , containerBorderWidth := 10 ] set window [ containerChild := vboxOuter ]- + -- create the Pixbuf pb <- pixbufNew ColorspaceRgb False 8 256 256 -- Initialize the state@@ -79,8 +79,8 @@ let modifyState f = readIORef state >>= f >>= writeIORef state canvas `onSizeRequest` return (Requisition 256 256)- + -- Add action handlers onActivateLeaf miQuit mainQuit -- onActivateLeaf miOpen $ modifyState $ reset gui@@ -91,7 +91,7 @@ onActivateLeaf miSeamCarve $ modifyState $ seamCarveImageDlg canvas window modifyState (loadImage canvas window fName)- + canvas `on` exposeEvent $ updateCanvas state boxPackStartDefaults vboxInner canvas widgetShowAll window@@ -102,7 +102,7 @@ --uncomment for ghc < 6.8.3 --instance Show Rectangle where -- show (Rectangle x y w h) = "x="++show x++", y="++show y++--- ", w="++show w++", h="++show h++";"+-- ", w="++show w++", h="++show h++";" updateCanvas :: IORef State -> EventM EExpose Bool updateCanvas rstate = do@@ -148,9 +148,9 @@ | otherwise = do action n loop (n+step) in loop from- + --forM = flip mapM- + makeMenuBar = do mb <- menuBarNew fileMenu <- menuNew@@ -189,7 +189,7 @@ -- updateCanvas canvas pxb return (State pxb NonEmpty) - + saveImageDlg canvas window (State pb is) = do putStrLn ("saveImage") ret <- openFileDialog window@@ -201,7 +201,7 @@ scaleImageDlg canvas window (State pb is) = do putStrLn ("scaleImage")- + origWidth <- pixbufGetWidth pb origHeight <- pixbufGetHeight pb ret <- scaleDialog window origWidth origHeight@@ -220,7 +220,7 @@ case ret of Nothing -> return (State pb NonEmpty) Just (w,h) -> (update w h)- + gradientImageDlg canvas window (State pb is) = do putStrLn ("gradientImageDlg") --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf@@ -231,7 +231,7 @@ widgetQueueDraw canvas -- updateCanvas canvas pxb return (State pxb NonEmpty)- + seamCarveImageDlg canvas window (State pb is) = do origWidth <- pixbufGetWidth pb origHeight <- pixbufGetHeight pb@@ -256,17 +256,17 @@ Nothing -> return (State pb NonEmpty) Just (w,h,grdCnt) -> (update w h grdCnt) - + scaleDialog :: Window -> Int -> Int-> IO (Maybe (Int, Int)) scaleDialog parent width height = do - Just xml <- xmlNew "scaling.glade" + Just xml <- xmlNew "scaling.glade" dia <- xmlGetWidget xml castToDialog "dialogScale" dialogAddButton dia stockCancel ResponseCancel dialogAddButton dia stockOk ResponseOk- entryWidth <- xmlGetWidget xml castToEntry "entryScalingWidth" - entryHeight <- xmlGetWidget xml castToEntry "entryScalingHeight" + entryWidth <- xmlGetWidget xml castToEntry "entryScalingWidth"+ entryHeight <- xmlGetWidget xml castToEntry "entryScalingHeight" entrySetText entryWidth (show width) entrySetText entryHeight (show height) res <- dialogRun dia@@ -281,14 +281,14 @@ seamCarveDialog :: Window -> Int -> Int -> Int -> IO (Maybe (Int, Int, Int)) seamCarveDialog parent width height grdCnt= do - Just xml <- xmlNew "scaling.glade" + Just xml <- xmlNew "scaling.glade" dia <- xmlGetWidget xml castToDialog "dialogSeamCarve" dialogAddButton dia stockCancel ResponseCancel dialogAddButton dia stockOk ResponseOk- entryWidth <- xmlGetWidget xml castToEntry "entryWidth" - entryHeight <- xmlGetWidget xml castToEntry "entryHeight" - entryGrdCnt <- xmlGetWidget xml castToEntry "entryGrdCnt" + entryWidth <- xmlGetWidget xml castToEntry "entryWidth"+ entryHeight <- xmlGetWidget xml castToEntry "entryHeight"+ entryGrdCnt <- xmlGetWidget xml castToEntry "entryGrdCnt" entrySetText entryWidth (show width) entrySetText entryHeight (show height) entrySetText entryGrdCnt (show grdCnt)@@ -302,15 +302,15 @@ ResponseOk -> return (Just (read widthStr,read heightStr, read grdCntStr)) _ -> return Nothing - + openFileDialog :: Window -> IO (Maybe String) openFileDialog parentWindow = do dialog <- fileChooserDialogNew (Just "Open Profile... ") (Just parentWindow)- FileChooserActionOpen- [("gtk-cancel", ResponseCancel)- ,("gtk-open", ResponseAccept)]+ FileChooserActionOpen+ [("gtk-cancel", ResponseCancel)+ ,("gtk-open", ResponseAccept)] widgetShow dialog response <- dialogRun dialog widgetHide dialog@@ -331,10 +331,10 @@ pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8)) newRow <- pixbufGetRowstride pbn putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++- ", bits per sample: "++show bits)+ ", bits per sample: "++show bits) putStrLn ("width: "++show width++", height: "++show height++", newWidth: "++show newWidth++", newHeight: "++show newHeight++" bytes per row new: "++show newRow)- - ++ let stepX = (fromIntegral width) / (fromIntegral newWidth) :: Double let stepY = (fromIntegral height) / (fromIntegral newHeight) :: Double @@ -366,7 +366,7 @@ --putStrLn("arrmove2 "++show src++" "++show dst++" "++show size) return () - + {-# INLINE arrmovesd #-} arrmovesd :: (Ix b, MArray a c IO) => a b c -> a b c -> Int -> Int -> Int -> IO () arrmovesd arrsrc arrdst src dst size = do@@ -399,26 +399,26 @@ pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8)) newRow <- pixbufGetRowstride pbn putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++- ", bits per sample: "++show bits)+ ", bits per sample: "++show bits) putStrLn ("width: "++show width++", height: "++show height++", newWidth: "++show newWidth++", newHeight: "++show newHeight++" bytes per row new: "++show newRow) tmpPB <- pixbufCopy pb tmpData <- (pixbufGetPixels tmpPB) :: IO (PixbufData Int Word8) ----double gradient- + let computeSrcPic pb cnt | cnt <= 0 = do pixbufCopy pb | cnt > 0 = do pb <- computeSrcPic pb (cnt-1) gradientPixbuf pb --computing gradient but one more gradient- --will be compute later by gradientArray function + --will be compute later by gradientArray function tmpPB2 <- computeSrcPic tmpPB (grdCnt-1) tmpData2 <- (pixbufGetPixels tmpPB2) :: IO (PixbufData Int Word8) -- array to store x coord of removed pixels- coordArr <- newArray (0, (max width height)) 0 :: IO (ArrayType Int Int) - + coordArr <- newArray (0, (max width height)) 0 :: IO (ArrayType Int Int)+ let removeVPixel pixData x y w = do --unsafeWrite pixData (0+x*chan+y*row) 255 --unsafeWrite pixData (1+x*chan+y*row) 255@@ -426,8 +426,8 @@ --store x-coord of removed pixel unsafeWrite coordArr y x arrmove pixData ((x+1)*chan+y*row) (x*chan+y*row) ((w-x-1)*chan)- return () - + return ()+ let removeHPixel pixData x y h = do --putStrLn("removeHPixel "++show x++" "++show y++" "++show h) --store y-coord of removed pixel@@ -435,18 +435,18 @@ --putStrLn("removeHPixel1.5 "++show x++" "++show y++" "++show h) arrmoven pixData (y*chan+(x+1)*row) (y*chan+x*row) chan row (h-x-1) --putStrLn("removeHPixel2 "++show x++" "++show y++" "++show h)- return () - + return ()+ let removeVGrdPixel grdData x y w = do arrmove grdData (x+1+y*width) (x+y*width) (w-x-1) return ()- + let removeHGrdPixel grdData x y h = do --putStrLn("removeHGrdPixel "++show x++" "++show y++" "++show h) arrmoven grdData (y+(x+1)*width) (y+x*width) 1 width (h-x-1) --putStrLn("removeHGrdPixel2 "++show x++" "++show y++" "++show h) return ()- + let vPixIndex x y chan row = (x*chan)+(y*row) let hPixIndex x y chan row = (y*chan)+(x*row) @@ -460,7 +460,7 @@ v1 <- unsafeRead seamArr (pixIndex x y 1 width) v2 <- if x==(w-1) then return 0x7fffffff else unsafeRead seamArr (pixIndex (x+1) y 1 width) let nextX | v0 < v1 && v0 < v2 = (x-1)- | v2 < v1 = (x+1) + | v2 < v1 = (x+1) | True = x removeSeam pixIndex rmPixel rmGrdPixel seamArr grdArr nextX (y-1) w @@ -487,7 +487,7 @@ unsafeWrite grdArr (pixIndex x (y+1) 1 width) g updateGradientArray pixIndex grdArr (y-1) w h return ()- + let findMinVal pixIndex seamArr w h = do v <- unsafeRead seamArr (pixIndex 0 (h-1) 1 width) xRef <- newIORef (v :: Int, 0 :: Int)@@ -498,12 +498,12 @@ (mval, m) <- readIORef xRef writeIORef xRef (if v < mval then (v, x) else (mval, m)) (mval, m) <- readIORef xRef- - putStrLn("w: " ++show w++ " minSeam: " ++ show mval ++ " at: "++show m) ++ putStrLn("w: " ++show w++ " minSeam: " ++ show mval ++ " at: "++show m) return m grdArr <- gradientArray tmpPB2 width height- + let removeVSeam w = do seamArr <- (computeVSeamArray grdArr width height w) m <- findMinVal vPixIndex seamArr w (height-1)@@ -517,11 +517,11 @@ removeSeam hPixIndex removeHPixel removeHGrdPixel seamArr grdArr m (width-1) h updateGradientArray hPixIndex grdArr (width-1) h width return ()- + --let nextX | v0 < v1 && v0 < v2 = (x-1)- -- | v2 < v1 = (x+1) + -- | v2 < v1 = (x+1) -- | True = x- + let grdSeam w h | w > newWidth && h > newHeight = do --putStrLn("grdSeam: "++show w++" "++show h) vSeamArr <- (computeVSeamArray grdArr width height w)@@ -541,27 +541,27 @@ --putStrLn("grdSeam2: "++show w++" "++show h) removeVSeam w grdSeam (w-1) h- + | h > newHeight = do --putStrLn("grdSeam3: "++show w++" "++show h) removeHSeam h grdSeam w (h-1) | True = do return ()- + -- remove/add seams --doFromToDown width (newWidth+1) $ \w -> do -- removeVSeam w- + --doFromToDown height (newHeight+1) $ \h -> do -- removeHSeam h- + grdSeam width height- - ++ doFromTo 0 (newHeight-1) $ \y -> do arrmovesd tmpData pbnData (y*row) (y*newRow) newRow- + return pbn -- compute the gradient map@@ -577,12 +577,12 @@ pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8)) putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++", bits per sample: "++show bits) putStrLn ("width: "++show width++", height: "++show height)- + let getpix x y c = do case (x < 1 || x >= width || y < 1 || y >= height) of True -> return 0 False -> (unsafeRead pbData (c+x*chan+y*row))- + let gradient x y c = do let convM = liftM fromIntegral blah a b = convM (getpix a b c)@@ -594,7 +594,7 @@ v02 <- blah (x-1) (y+1) v12 <- blah x (y+1) v22 <- blah (x+1) (y+1)- + let gx = abs ((v20-v00)+2*(v21-v01)+(v22-v02)) let gy = abs ((v02-v00)+2*(v12-v10)+(v22-v20)) let g = (gx + gy)::Int@@ -608,8 +608,8 @@ bg <- gradient x y 2 let g = rg + gg + bg return ((fromIntegral g)::Word8)- + doFromTo 0 (height-1) $ \y -> do let offY = y*row doFromTo 0 (width-1) $ \x -> do@@ -626,7 +626,7 @@ {-# INLINE pixelGradient #-} pixelGradient :: (Int -> Int -> Int -> Int -> Int) -> (PixbufData Int Word8) -> Int -> Int -> Int -> Int -> Int -> Int -> (IO Word16) pixelGradient pixIndex pbData row chan w h x y = do- + let getpix x y c = do case (x < 0 || x >= w || y < 0 || y >= h) of True -> return 0@@ -644,15 +644,15 @@ v02 <- blah (x-1) (y+1) v12 <- blah x (y+1) v22 <- blah (x+1) (y+1)- + let gx = abs ((v20-v00)+2*(v21-v01)+(v22-v02)) let gy = abs ((v02-v00)+2*(v12-v10)+(v22-v20)) let g = (gx + gy)::Int --let g8 = (shiftR g 3) let g8 = if g > 255 then 255 else g return (fromIntegral(g8) :: Word8)- - ++ let gradient x y c = do let convM = liftM fromIntegral blah a b = convM (getpix a b c)@@ -675,7 +675,7 @@ let g = rg + gg + bg return ((fromIntegral g) :: Word16) - + -- compute the gradient map gradientArray :: Pixbuf -> Int -> Int -> IO (ArrayType Int Word16) gradientArray pb w h = do@@ -690,7 +690,7 @@ putStrLn ("width: "++show width++", height: "++show height) let vPixIndex x y chan row = x*chan+y*row- + doFromTo 0 (h-1) $ \y -> do let offY = y*width doFromTo 0 (w-1) $ \x -> do@@ -703,14 +703,14 @@ computeVSeamArray :: (ArrayType Int Word16) -> Int -> Int -> Int -> IO (ArrayType Int Int) computeVSeamArray grdArr width height currentWidth = do- + seamArr <- newArray (0, width * height) 0 --grdArr <- gradientArr- + doFromTo 0 (currentWidth-1) $ \x -> do v <- unsafeRead grdArr x unsafeWrite seamArr x (fromIntegral v :: Int)- + doFromTo 1 (height-1) $ \y -> do let offY = y*width let prevOffY = offY-width@@ -728,19 +728,19 @@ p2r <- unsafeRead seamArr (currentWidth-1+prevOffY) vr <- unsafeRead grdArr (currentWidth-1+offY) unsafeWrite seamArr (currentWidth-1+offY) ((fromIntegral vr :: Int) +(min p1r p2r))- + return seamArr computeHSeamArray :: (ArrayType Int Word16) -> Int -> Int -> Int -> IO (ArrayType Int Int) computeHSeamArray grdArr width height currentHeight = do- + seamArr <- newArray (0, width * height) 0 --grdArr <- gradientArr- + doFromTo 0 (currentHeight-1) $ \y -> do v <- unsafeRead grdArr (y*width) unsafeWrite seamArr (y*width) (fromIntegral v :: Int)- + doFromTo 1 (width-1) $ \x -> do doFromTo 1 (currentHeight-2) $ \y -> do let offY = y*width@@ -759,5 +759,5 @@ p2r <- unsafeRead seamArr (x-1+((currentHeight-1)*width)) vr <- unsafeRead grdArr (x+((currentHeight-1)*width)) unsafeWrite seamArr (x+((currentHeight-1)*width)) ((fromIntegral vr :: Int) +(min p1r p2r))- + return seamArr
glade.cabal view
@@ -1,5 +1,5 @@ Name: glade-Version: 0.11.1+Version: 0.12.0 License: LGPL-2.1 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team@@ -63,10 +63,10 @@ Library build-depends: base >= 4 && < 5, array, containers, haskell98, mtl,- glib >= 0.11 && < 0.12, - pango >= 0.11 && < 0.12, - cairo >= 0.11 && < 0.12,- gtk >= 0.11 && < 0.12+ glib >= 0.12 && < 0.13, + pango >= 0.12 && < 0.13, + cairo >= 0.12 && < 0.13,+ gtk >= 0.12 && < 0.13 build-tools: gtk2hsC2hs, gtk2hsHookGenerator, gtk2hsTypeGen