diff --git a/Graphics/UI/Gtk/Poppler/Action.chs b/Graphics/UI/Gtk/Poppler/Action.chs --- a/Graphics/UI/Gtk/Poppler/Action.chs +++ b/Graphics/UI/Gtk/Poppler/Action.chs @@ -30,13 +30,13 @@ module Graphics.UI.Gtk.Poppler.Action ( -- * Types, Action, - ActionClass, Dest, - DestClass, -- * Methods actionCopy, destCopy, + makeNewAction, + makeNewDest, ) where import Control.Monad @@ -52,14 +52,34 @@ {# context lib="poppler" prefix="poppler" #} +{#pointer *Action foreign newtype #} + +makeNewAction :: Ptr Action -> IO Action +makeNewAction rPtr = do + action <- newForeignPtr rPtr action_free + return (Action action) + +foreign import ccall unsafe "&poppler_action_free" + action_free :: FinalizerPtr Action + +{#pointer *Dest foreign newtype #} + +makeNewDest :: Ptr Dest -> IO Dest +makeNewDest rPtr = do + dest <- newForeignPtr rPtr dest_free + return (Dest dest) + +foreign import ccall unsafe "&poppler_dest_free" + dest_free :: FinalizerPtr Dest + -- | Copies action, creating an identical 'Action'. -actionCopy :: ActionClass action => action -> IO Action +actionCopy :: Action -> IO Action actionCopy action = - makeNewGObject mkAction $ - {#call poppler_action_copy #} (toAction action) + {#call poppler_action_copy #} action + >>= makeNewAction -- | Copies dest, creating an identical 'Dest'. -destCopy :: DestClass dest => dest -> IO Dest +destCopy :: Dest -> IO Dest destCopy dest = - makeNewGObject mkDest $ - {#call poppler_dest_copy #} (toDest dest) + {#call poppler_dest_copy #} dest + >>= makeNewDest diff --git a/Graphics/UI/Gtk/Poppler/Document.chs b/Graphics/UI/Gtk/Poppler/Document.chs --- a/Graphics/UI/Gtk/Poppler/Document.chs +++ b/Graphics/UI/Gtk/Poppler/Document.chs @@ -41,13 +41,11 @@ Page, PageClass, IndexIter, - IndexIterClass, FontsIter, FontsIterClass, FontInfo, FontInfoClass, Dest, - DestClass, FormField, Action, PSFile, @@ -124,6 +122,7 @@ import System.Glib.GObject import System.Glib.UTFString import Graphics.UI.Gtk.Poppler.Enums +import Graphics.UI.Gtk.Poppler.Action (Action, Dest, makeNewAction, makeNewDest) {#import Graphics.UI.Gtk.Poppler.Types#} {# context lib="poppler" prefix="poppler" #} @@ -135,7 +134,7 @@ -> Maybe String -- ^ @password@ password to unlock the file with, or 'Nothing' -> IO (Maybe Document) -- ^ returns A newly created 'Document', or 'Nothing' documentNewFromFile uri password = - maybeNull (makeNewGObject mkDocument) $ + maybeNull (wrapNewGObject mkDocument) $ withUTFString uri $ \ uriPtr -> maybeWith withUTFString password $ \ passwordPtr -> propagateGError ({# call poppler_document_new_from_file #} @@ -149,7 +148,7 @@ -> Maybe String -- ^ @password@ password to unlock the file with, or 'Nothing' -> IO (Maybe Document) -- ^ returns A newly created 'Document', or 'Nothing' documentNewFromData dat password = - maybeNull (makeNewGObject mkDocument) $ + maybeNull (wrapNewGObject mkDocument) $ withUTFString dat $ \ datPtr -> maybeWith withUTFString password $ \ passwordPtr -> propagateGError ({#call poppler_document_new_from_data #} @@ -183,7 +182,7 @@ -> Int -- ^ @index@ a page index -> IO Page -- ^ returns The 'Page' at index documentGetPage doc index = - makeNewGObject mkPage $ + wrapNewGObject mkPage $ {#call poppler_document_get_page#} (toDocument doc) (fromIntegral index) -- | Returns the 'Page' reference by label. This object is owned by the caller. label is a @@ -195,7 +194,7 @@ -> String -- ^ @label@ a page label -> IO Page -- ^ returns The 'Page' referenced by label documentGetPageByLabel doc label = - makeNewGObject mkPage $ + wrapNewGObject mkPage $ withUTFString label $ \ labelPtr -> {#call poppler_document_get_page_by_label #} (toDocument doc) labelPtr @@ -210,10 +209,7 @@ linkNamePtr if destPtr == nullPtr then return Nothing - else do - dest <- makeNewGObject mkDest $ return destPtr - {#call unsafe poppler_dest_free #} dest - return $ Just dest + else liftM Just $ makeNewDest (castPtr destPtr) -- | Returns 'True' of document has any attachments. documentHasAttachments :: DocumentClass doc => doc @@ -227,7 +223,7 @@ -> Int -- ^ @id@ an id of a 'FormField' -> IO (Maybe FormField) documentGetFormField doc id = - maybeNull (makeNewGObject mkFormField) $ + maybeNull (wrapNewGObject mkFormField) $ {#call poppler_document_get_form_field #} (toDocument doc) (fromIntegral id) @@ -239,7 +235,7 @@ -> Int -- ^ @nPages@ the number of pages to print -> IO PSFile psFileNew doc filename firstPage nPages = - makeNewGObject mkPSFile $ + wrapNewGObject mkPSFile $ withUTFString filename $ \ filenamePtr -> {#call poppler_ps_file_new #} (toDocument doc) @@ -276,61 +272,73 @@ documentGetAttachments doc = do glistPtr <- {#call poppler_document_get_attachments #} (toDocument doc) list <- fromGList glistPtr - attachs <- mapM (makeNewGObject mkAttachment . return) list + attachs <- mapM (wrapNewGObject mkAttachment . return) list {#call unsafe g_list_free #} glistPtr return attachs -- | Returns the root 'IndexIter' for document, or 'Nothing'. indexIterNew :: DocumentClass doc => doc -> IO (Maybe IndexIter) -indexIterNew doc = - maybeNull (makeNewGObject mkIndexIter) $ - {#call poppler_index_iter_new #} (toDocument doc) +indexIterNew doc = do + iterPtr <- {#call poppler_index_iter_new #} (toDocument doc) + if iterPtr == nullPtr + then return Nothing + else liftM Just (makeNewIndexIter (castPtr iterPtr)) +{#pointer *IndexIter foreign newtype #} + +makeNewIndexIter :: Ptr IndexIter -> IO IndexIter +makeNewIndexIter rPtr = do + iter <- newForeignPtr rPtr indexIter_free + return (IndexIter iter) + +foreign import ccall unsafe "&poppler_index_iter_free" + indexIter_free :: FinalizerPtr IndexIter + -- | Creates a new 'IndexIter' as a copy of iter. -indexIterCopy :: IndexIterClass iter => iter -> IO IndexIter +indexIterCopy :: IndexIter -> IO IndexIter indexIterCopy iter = - makeNewGObject mkIndexIter $ - {#call poppler_index_iter_copy #} (toIndexIter iter) + {#call poppler_index_iter_copy #} iter + >>= makeNewIndexIter -- | Returns a newly created child of parent, or 'Nothing' if the iter has no child. See -- 'indexIterNew' for more information on this function. -indexIterGetChild :: IndexIterClass iter => iter -> IO (Maybe IndexIter) -indexIterGetChild iter = - maybeNull (makeNewGObject mkIndexIter) $ - {#call poppler_index_iter_get_child #} (toIndexIter iter) +indexIterGetChild :: IndexIter -> IO (Maybe IndexIter) +indexIterGetChild iter = do + iterPtr <- {#call poppler_index_iter_get_child #} iter + if iterPtr == nullPtr + then return Nothing + else liftM Just (makeNewIndexIter iterPtr) -- | Returns whether this node should be expanded by default to the user. The document can provide a hint -- as to how the document's index should be expanded initially. -indexIterIsOpen :: IndexIterClass iter => iter - -> IO Bool -- ^ returns 'True', if the document wants iter to be expanded +indexIterIsOpen :: IndexIter -> IO Bool -- ^ returns 'True', if the document wants iter to be expanded indexIterIsOpen iter = liftM toBool $ - {#call poppler_index_iter_is_open #} (toIndexIter iter) + {#call poppler_index_iter_is_open #} iter -- | Sets iter to point to the next action at the current level, if valid. See 'indexIterNew' -- for more information. -indexIterNext :: IndexIterClass iter => iter - -> IO Bool -- ^ returns 'True', if iter was set to the next action +indexIterNext :: IndexIter -> IO Bool -- ^ returns 'True', if iter was set to the next action indexIterNext iter = liftM toBool $ - {#call poppler_index_iter_next #} (toIndexIter iter) + {#call poppler_index_iter_next #} iter -- | Returns the 'Action' associated with iter. -indexIterGetAction :: IndexIterClass iter => iter -> IO Action +indexIterGetAction :: IndexIter -> IO Action indexIterGetAction iter = - makeNewGObject mkAction $ - {#call poppler_index_iter_get_action #} (toIndexIter iter) + {#call poppler_index_iter_get_action #} iter + >>= makeNewAction . castPtr -- | fontInfoNew :: DocumentClass doc => doc -> IO FontInfo fontInfoNew doc = - makeNewGObject mkFontInfo $ + wrapNewGObject mkFontInfo $ {#call poppler_font_info_new#} (toDocument doc) -- | fontsIterCopy :: FontsIterClass iter => iter -> IO FontsIter fontsIterCopy iter = - makeNewGObject mkFontsIter $ + wrapNewGObject mkFontsIter $ {#call poppler_fonts_iter_copy #} (toFontsIter iter) -- | diff --git a/Graphics/UI/Gtk/Poppler/Page.chs b/Graphics/UI/Gtk/Poppler/Page.chs --- a/Graphics/UI/Gtk/Poppler/Page.chs +++ b/Graphics/UI/Gtk/Poppler/Page.chs @@ -33,13 +33,9 @@ PopplerRectangle (..), PopplerColor (..), ImageMapping, - ImageMappingClass, PageTransition, - PageTransitionClass, LinkMapping, - LinkMappingClass, FormFieldMapping, - FormFieldMappingClass, -- * Enums SelectionStyle (..), @@ -79,7 +75,6 @@ {#import Graphics.UI.Gtk.Poppler.Types#} import Graphics.UI.Gtk.Poppler.Structs import Control.Monad.Reader (ReaderT(runReaderT), ask, MonadIO, liftIO) - import Graphics.Rendering.Cairo.Internal (Render(..), bracketR) {# context lib="poppler" prefix="poppler" #} @@ -89,9 +84,8 @@ -- instead pageRender :: PageClass page => page -> Render () -pageRender page = do - cairo <- ask - liftIO $ {#call poppler_page_render #} (toPage page) cairo +pageRender page = + ask >>= \ x -> liftIO ({#call poppler_page_render #} (toPage page) x) -- | First scale the document to match the specified pixels per point, then render the rectangle given by -- the upper left corner at (@srcX@, @srcY@) and @srcWidth@ and @srcHeight@. This function is for rendering @@ -198,39 +192,81 @@ -- | Returns the transition effect of page pageGetTransition :: PageClass page => page -> IO (Maybe PageTransition) -- ^ returns a 'PageTransition' or 'Nothing'. -pageGetTransition page = - maybeNull (makeNewGObject mkPageTransition) $ - {#call poppler_page_get_transition #} (toPage page) +pageGetTransition page = do + ptr <- {#call poppler_page_get_transition #} (toPage page) + if ptr == nullPtr + then return Nothing + else liftM Just $ makeNewPageTransition (castPtr ptr) +{#pointer *PageTransition foreign newtype #} + +makeNewPageTransition :: Ptr PageTransition -> IO PageTransition +makeNewPageTransition rPtr = do + transition <- newForeignPtr rPtr page_transition_free + return (PageTransition transition) + +foreign import ccall unsafe "&poppler_page_transition_free" + page_transition_free :: FinalizerPtr PageTransition + -- | Returns a list of 'LinkMapping' items that map from a location on page to a 'Action'. pageGetLinkMapping :: PageClass page => page -> IO [LinkMapping] pageGetLinkMapping page = do glistPtr <- {#call poppler_page_get_link_mapping #} (toPage page) list <- fromGList glistPtr - mappings <- mapM (makeNewGObject mkLinkMapping . return) list + mappings <- mapM makeNewLinkMapping list {#call unsafe poppler_page_free_link_mapping #} (castPtr glistPtr) return mappings +{#pointer *LinkMapping foreign newtype #} + +makeNewLinkMapping :: Ptr LinkMapping -> IO LinkMapping +makeNewLinkMapping rPtr = do + linkMapping <- newForeignPtr rPtr poppler_link_mapping_free + return (LinkMapping linkMapping) + +foreign import ccall unsafe "&poppler_link_mapping_free" + poppler_link_mapping_free :: FinalizerPtr LinkMapping + -- | Returns a list of 'ImageMapping' items that map from a location on page to a 'Action'. pageGetImageMapping :: PageClass page => page -> IO [ImageMapping] pageGetImageMapping page = do glistPtr <- {#call poppler_page_get_image_mapping #} (toPage page) list <- fromGList glistPtr - mappings <- mapM (makeNewGObject mkImageMapping . return) list + mappings <- mapM makeNewImageMapping list {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr) return mappings +{#pointer *ImageMapping foreign newtype #} + +makeNewImageMapping :: Ptr ImageMapping -> IO ImageMapping +makeNewImageMapping rPtr = do + imageMapping <- newForeignPtr rPtr poppler_image_mapping_free + return (ImageMapping imageMapping) + +foreign import ccall unsafe "&poppler_image_mapping_free" + poppler_image_mapping_free :: FinalizerPtr ImageMapping + -- | Returns a list of 'FormFieldMapping' items that map from a location on page to a 'Action'. pageGetFormFieldMapping :: PageClass page => page -> IO [FormFieldMapping] pageGetFormFieldMapping page = do glistPtr <- {#call poppler_page_get_form_field_mapping #} (toPage page) list <- fromGList glistPtr - mappings <- mapM (makeNewGObject mkFormFieldMapping . return) list + mappings <- mapM makeNewFormFieldMapping list {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr) return mappings + +{#pointer *FormFieldMapping foreign newtype #} + +makeNewFormFieldMapping :: Ptr FormFieldMapping -> IO FormFieldMapping +makeNewFormFieldMapping rPtr = do + formFieldMapping <- newForeignPtr rPtr poppler_form_field_mapping_free + return (FormFieldMapping formFieldMapping) + +foreign import ccall unsafe "&poppler_form_field_mapping_free" + poppler_form_field_mapping_free :: FinalizerPtr FormFieldMapping -- | Returns a region containing the area that would be rendered by 'pageRenderSelection' or -- 'pageRenderSelectionToPixbuf' as a GList of PopplerRectangle. diff --git a/Graphics/UI/Gtk/Poppler/Types.chs b/Graphics/UI/Gtk/Poppler/Types.chs --- a/Graphics/UI/Gtk/Poppler/Types.chs +++ b/Graphics/UI/Gtk/Poppler/Types.chs @@ -66,10 +66,6 @@ toDocument, mkDocument, unDocument, castToDocument, gTypeDocument, - IndexIter(IndexIter), IndexIterClass, - toIndexIter, - mkIndexIter, unIndexIter, - castToIndexIter, gTypeIndexIter, FontsIter(FontsIter), FontsIterClass, toFontsIter, mkFontsIter, unFontsIter, @@ -78,10 +74,6 @@ toPage, mkPage, unPage, castToPage, gTypePage, - Dest(Dest), DestClass, - toDest, - mkDest, unDest, - castToDest, gTypeDest, FormField(FormField), FormFieldClass, toFormField, mkFormField, unFormField, @@ -90,22 +82,6 @@ toPSFile, mkPSFile, unPSFile, castToPSFile, gTypePSFile, - PageTransition(PageTransition), PageTransitionClass, - toPageTransition, - mkPageTransition, unPageTransition, - castToPageTransition, gTypePageTransition, - LinkMapping(LinkMapping), LinkMappingClass, - toLinkMapping, - mkLinkMapping, unLinkMapping, - castToLinkMapping, gTypeLinkMapping, - ImageMapping(ImageMapping), ImageMappingClass, - toImageMapping, - mkImageMapping, unImageMapping, - castToImageMapping, gTypeImageMapping, - FormFieldMapping(FormFieldMapping), FormFieldMappingClass, - toFormFieldMapping, - mkFormFieldMapping, unFormFieldMapping, - castToFormFieldMapping, gTypeFormFieldMapping, FontInfo(FontInfo), FontInfoClass, toFontInfo, mkFontInfo, unFontInfo, @@ -114,10 +90,6 @@ toAttachment, mkAttachment, unAttachment, castToAttachment, gTypeAttachment, - Action(Action), ActionClass, - toAction, - mkAction, unAction, - castToAction, gTypeAction, Layer(Layer), LayerClass, toLayer, mkLayer, unLayer, @@ -328,29 +300,6 @@ gTypeDocument = {# call fun unsafe poppler_document_get_type #} --- ****************************************************************** IndexIter - -{#pointer *IndexIter foreign newtype #} deriving (Eq,Ord) - -mkIndexIter = (IndexIter, objectUnref) -unIndexIter (IndexIter o) = o - -class GObjectClass o => IndexIterClass o -toIndexIter :: IndexIterClass o => o -> IndexIter -toIndexIter = unsafeCastGObject . toGObject - -instance IndexIterClass IndexIter -instance GObjectClass IndexIter where - toGObject = GObject . castForeignPtr . unIndexIter - unsafeCastGObject = IndexIter . castForeignPtr . unGObject - -castToIndexIter :: GObjectClass obj => obj -> IndexIter -castToIndexIter = castTo gTypeIndexIter "IndexIter" - -gTypeIndexIter :: GType -gTypeIndexIter = - {# call fun unsafe poppler_index_iter_get_type #} - -- ****************************************************************** FontsIter {#pointer *FontsIter foreign newtype #} deriving (Eq,Ord) @@ -397,29 +346,6 @@ gTypePage = {# call fun unsafe poppler_page_get_type #} --- *********************************************************************** Dest - -{#pointer *Dest foreign newtype #} deriving (Eq,Ord) - -mkDest = (Dest, objectUnref) -unDest (Dest o) = o - -class GObjectClass o => DestClass o -toDest :: DestClass o => o -> Dest -toDest = unsafeCastGObject . toGObject - -instance DestClass Dest -instance GObjectClass Dest where - toGObject = GObject . castForeignPtr . unDest - unsafeCastGObject = Dest . castForeignPtr . unGObject - -castToDest :: GObjectClass obj => obj -> Dest -castToDest = castTo gTypeDest "Dest" - -gTypeDest :: GType -gTypeDest = - {# call fun unsafe poppler_dest_get_type #} - -- ****************************************************************** FormField {#pointer *FormField foreign newtype #} deriving (Eq,Ord) @@ -466,98 +392,6 @@ gTypePSFile = {# call fun unsafe poppler_ps_file_get_type #} --- ************************************************************* PageTransition - -{#pointer *PageTransition foreign newtype #} deriving (Eq,Ord) - -mkPageTransition = (PageTransition, objectUnref) -unPageTransition (PageTransition o) = o - -class GObjectClass o => PageTransitionClass o -toPageTransition :: PageTransitionClass o => o -> PageTransition -toPageTransition = unsafeCastGObject . toGObject - -instance PageTransitionClass PageTransition -instance GObjectClass PageTransition where - toGObject = GObject . castForeignPtr . unPageTransition - unsafeCastGObject = PageTransition . castForeignPtr . unGObject - -castToPageTransition :: GObjectClass obj => obj -> PageTransition -castToPageTransition = castTo gTypePageTransition "PageTransition" - -gTypePageTransition :: GType -gTypePageTransition = - {# call fun unsafe poppler_page_transition_get_type #} - --- **************************************************************** LinkMapping - -{#pointer *LinkMapping foreign newtype #} deriving (Eq,Ord) - -mkLinkMapping = (LinkMapping, objectUnref) -unLinkMapping (LinkMapping o) = o - -class GObjectClass o => LinkMappingClass o -toLinkMapping :: LinkMappingClass o => o -> LinkMapping -toLinkMapping = unsafeCastGObject . toGObject - -instance LinkMappingClass LinkMapping -instance GObjectClass LinkMapping where - toGObject = GObject . castForeignPtr . unLinkMapping - unsafeCastGObject = LinkMapping . castForeignPtr . unGObject - -castToLinkMapping :: GObjectClass obj => obj -> LinkMapping -castToLinkMapping = castTo gTypeLinkMapping "LinkMapping" - -gTypeLinkMapping :: GType -gTypeLinkMapping = - {# call fun unsafe poppler_link_mapping_get_type #} - --- *************************************************************** ImageMapping - -{#pointer *ImageMapping foreign newtype #} deriving (Eq,Ord) - -mkImageMapping = (ImageMapping, objectUnref) -unImageMapping (ImageMapping o) = o - -class GObjectClass o => ImageMappingClass o -toImageMapping :: ImageMappingClass o => o -> ImageMapping -toImageMapping = unsafeCastGObject . toGObject - -instance ImageMappingClass ImageMapping -instance GObjectClass ImageMapping where - toGObject = GObject . castForeignPtr . unImageMapping - unsafeCastGObject = ImageMapping . castForeignPtr . unGObject - -castToImageMapping :: GObjectClass obj => obj -> ImageMapping -castToImageMapping = castTo gTypeImageMapping "ImageMapping" - -gTypeImageMapping :: GType -gTypeImageMapping = - {# call fun unsafe poppler_image_mapping_get_type #} - --- *********************************************************** FormFieldMapping - -{#pointer *FormFieldMapping foreign newtype #} deriving (Eq,Ord) - -mkFormFieldMapping = (FormFieldMapping, objectUnref) -unFormFieldMapping (FormFieldMapping o) = o - -class GObjectClass o => FormFieldMappingClass o -toFormFieldMapping :: FormFieldMappingClass o => o -> FormFieldMapping -toFormFieldMapping = unsafeCastGObject . toGObject - -instance FormFieldMappingClass FormFieldMapping -instance GObjectClass FormFieldMapping where - toGObject = GObject . castForeignPtr . unFormFieldMapping - unsafeCastGObject = FormFieldMapping . castForeignPtr . unGObject - -castToFormFieldMapping :: GObjectClass obj => obj -> FormFieldMapping -castToFormFieldMapping = castTo gTypeFormFieldMapping "FormFieldMapping" - -gTypeFormFieldMapping :: GType -gTypeFormFieldMapping = - {# call fun unsafe poppler_form_field_mapping_get_type #} - -- ******************************************************************* FontInfo {#pointer *FontInfo foreign newtype #} deriving (Eq,Ord) @@ -603,29 +437,6 @@ gTypeAttachment :: GType gTypeAttachment = {# call fun unsafe poppler_attachment_get_type #} - --- ********************************************************************* Action - -{#pointer *Action foreign newtype #} deriving (Eq,Ord) - -mkAction = (Action, objectUnref) -unAction (Action o) = o - -class GObjectClass o => ActionClass o -toAction :: ActionClass o => o -> Action -toAction = unsafeCastGObject . toGObject - -instance ActionClass Action -instance GObjectClass Action where - toGObject = GObject . castForeignPtr . unAction - unsafeCastGObject = Action . castForeignPtr . unGObject - -castToAction :: GObjectClass obj => obj -> Action -castToAction = castTo gTypeAction "Action" - -gTypeAction :: GType -gTypeAction = - {# call fun unsafe poppler_action_get_type #} -- ********************************************************************** Layer diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs --- a/Gtk2HsSetup.hs +++ b/Gtk2HsSetup.hs @@ -23,20 +23,32 @@ 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 -import Distribution.InstalledPackageInfo ( importDirs ) +import Distribution.InstalledPackageInfo ( importDirs, + showInstalledPackageInfo, + libraryDirs, + extraLibraries, + extraGHCiLibraries ) import Distribution.Simple.PackageIndex ( #if CABAL_VERSION_CHECK(1,8,0) lookupInstalledPackageId @@ -49,7 +61,7 @@ BuildInfo(..), emptyBuildInfo, allBuildInfo, Library(..), - libModules) + libModules, hasLibs) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), InstallDirs(..), #if CABAL_VERSION_CHECK(1,8,0) @@ -61,27 +73,36 @@ import Distribution.Simple.Compiler ( Compiler(..) ) import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), - rawSystemProgramConf, rawSystemProgramStdoutConf, - c2hsProgram, pkgConfigProgram, + rawSystemProgramConf, rawSystemProgramStdoutConf, programName, + c2hsProgram, pkgConfigProgram, requireProgram, ghcPkgProgram, simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg) import Distribution.ModuleName ( ModuleName, components, toFilePath ) import Distribution.Simple.Utils import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..), defaultCopyFlags, ConfigFlags(configVerbosity), - fromFlag, toFlag) + fromFlag, toFlag, RegisterFlags(..), flagToMaybe, + fromFlagOrDefault, defaultRegisterFlags) import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Install ( install ) +#if CABAL_VERSION_CHECK(1,8,0) +import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) +#else +import qualified Distribution.Simple.Register as Register ( register ) +#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 (unless) -import Data.Maybe (fromMaybe) +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) import qualified Data.Map as M import qualified Data.Set as S +import Control.Applicative ((<$>)) -- the name of the c2hs pre-compiled header file precompFile = "precompchs.bin" @@ -90,19 +111,153 @@ 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 -> (instHook simpleUserHooks) pd lbi uh flags >> + instHook = \pd lbi uh flags -> +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + installHook pd lbi uh flags >> + installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest, + regHook = registerHook +#else + instHook simpleUserHooks pd lbi uh flags >> installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest +#endif } +------------------------------------------------------------------------------ +-- Lots of stuff for windows ghci support +------------------------------------------------------------------------------ + +getDlls :: [FilePath] -> IO [FilePath] +getDlls dirs = filter ((== ".dll") . takeExtension) . concat <$> + mapM getDirectoryContents dirs + +fixLibs :: [FilePath] -> [String] -> [String] +fixLibs dlls = concatMap $ \ lib -> + case filter (("lib" ++ lib) `isPrefixOf`) dlls of + dll:_ -> [dropExtension dll] + _ -> if lib == "z" then [] else [lib] + +-- The following code is a big copy-and-paste job from the sources of +-- Cabal 1.8 just to be able to fix a field in the package file. Yuck. + +#if CABAL_VERSION_CHECK(1,8,0) + +installHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +installHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +registerHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +registerHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg@PackageDescription { library = Just lib } + lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags + = do + + installedPkgInfoRaw <- generateRegistrationInfo + verbosity pkg lib lbi clbi inplace distPref + + dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls + let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw) + installedPkgInfo = installedPkgInfoRaw { + extraGHCiLibraries = libs } + + -- Three different modes: + case () of + _ | 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)) + modeGenerateRegScript = fromFlag (regGenScript regFlags) + inplace = fromFlag (regInPlace regFlags) + packageDb = case flagToMaybe (regPackageDB regFlags) of + Just db -> db + Nothing -> registrationPackageDB (withPackageDB lbi) + distPref = fromFlag (regDistPref regFlags) + verbosity = fromFlag (regVerbosity regFlags) + +register _ _ regFlags = notice verbosity "No package to register" + where + verbosity = fromFlag (regVerbosity regFlags) + +#else +installHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +installHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyInPlace = installInPlace flags, + copyUseWrapper = installUseWrapper flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +registerHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +registerHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg_descr lbi regFlags = do + let verbosity = fromFlag (regVerbosity regFlags) + warn verbosity "Cannot register ghci libraries with Cabal 1.6 (need 1.8)." + Register.register pkg_descr lbi regFlags + +#endif + +------------------------------------------------------------------------------ -- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later +------------------------------------------------------------------------------ + adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo adjustLocalBuildInfo lbi = let extra = (Just libBi, []) @@ -110,6 +265,10 @@ , buildDir lbi ] } in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) } +------------------------------------------------------------------------------ +-- Processing .chs files with our local c2hs. +------------------------------------------------------------------------------ + ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor ourC2hs bi lbi = PreProcessor { platformIndependent = False, @@ -151,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 @@ -161,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 @@ -184,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 @@ -223,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.") @@ -244,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 @@ -309,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) @@ -337,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) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 + diff --git a/demo/PdfViewer.hs b/demo/PdfViewer.hs --- a/demo/PdfViewer.hs +++ b/demo/PdfViewer.hs @@ -19,7 +19,7 @@ import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Poppler.Document import Graphics.UI.Gtk.Poppler.Page -import System.Environment +import System.Environment import System.Process data Viewer = @@ -35,8 +35,8 @@ args <- getArgs case args of -- Display help - ["--help"] -> - putStrLn $ "PDF viewer demo. \n\n" ++ + ["--help"] -> + putStrLn $ "PDF viewer demo. \n\n" ++ "Usage: pdfviewer file\n\n" -- Start program. [arg] -> viewerMain arg @@ -47,7 +47,7 @@ viewerMain file = do -- Init. initGUI - + -- Create window. window <- windowNew windowSetDefaultSize window 600 780 @@ -64,7 +64,7 @@ sWin = viewerScrolledWindow viewer -- Set title. - title <- get doc documentTitle + title <- get doc documentTitle windowSetTitle window ("PdfViewer " ++ title) -- Create spin button to select page. @@ -97,7 +97,7 @@ scrolledWindowAddWithViewport sWin area scrolledWindowSetPolicy sWin PolicyAutomatic PolicyAutomatic - area `on` exposeEvent $ tryEvent $ viewerDraw viewer + area `on` exposeEvent $ tryEvent $ viewerDraw viewer return viewer @@ -105,23 +105,23 @@ viewerDraw viewer = do let doc = viewerDocument viewer area = viewerArea viewer - (winWidth, winHeight) <- eventWindowSize + (winWidth, winHeight) <- eventWindowSize liftIO $ do pageNumber <- readTVarIO $ viewerPage viewer page <- documentGetPage doc pageNumber frameWin <- widgetGetDrawWindow area (docWidth, docHeight) <- pageGetSize page - widgetSetSizeRequest area (truncate docWidth) (truncate docHeight) + let scaleX = winWidth / docWidth + width = winWidth + height = scaleX * docHeight + widgetSetSizeRequest area (truncate width) (truncate height) - renderWithDrawable frameWin $ do + renderWithDrawable frameWin $ do setSourceRGB 1.0 1.0 1.0 - rectangle 0.0 0.0 winWidth winHeight - fill - let scaleX = winWidth / docWidth scale scaleX scaleX pageRender page -eventWindowSize :: EventM EExpose (Double, Double) +eventWindowSize :: EventM EExpose (Double, Double) eventWindowSize = do dr <- eventWindow (w,h) <- liftIO $ drawableGetSize dr diff --git a/hierarchy.list b/hierarchy.list --- a/hierarchy.list +++ b/hierarchy.list @@ -341,17 +341,10 @@ # For poppler PopplerDocument as Document, poppler_document_get_type if poppler - PopplerIndexIter as IndexIter, poppler_index_iter_get_type if poppler PopplerFontsIter as FontsIter, poppler_fonts_iter_get_type if poppler PopplerPage as Page, poppler_page_get_type if poppler - PopplerDest as Dest, poppler_dest_get_type if poppler PopplerFormField as FormField, poppler_form_field_get_type if poppler PopplerPSFile as PSFile, poppler_ps_file_get_type if poppler - PopplerPageTransition as PageTransition, poppler_page_transition_get_type if poppler - PopplerLinkMapping as LinkMapping, poppler_link_mapping_get_type if poppler - PopplerImageMapping as ImageMapping, poppler_image_mapping_get_type if poppler - PopplerFormFieldMapping as FormFieldMapping, poppler_form_field_mapping_get_type if poppler PopplerFontInfo as FontInfo, poppler_font_info_get_type if poppler PopplerAttachment as Attachment, poppler_attachment_get_type if poppler - PopplerAction as Action, poppler_action_get_type if poppler PopplerLayer as Layer, poppler_layer_get_type if poppler diff --git a/poppler.cabal b/poppler.cabal --- a/poppler.cabal +++ b/poppler.cabal @@ -1,5 +1,5 @@ Name: poppler -Version: 0.11.1 +Version: 0.12.0 License: GPL-2 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team @@ -38,9 +38,9 @@ Library build-depends: base >= 4 && < 5, array, containers, haskell98, mtl, bytestring, - glib >= 0.11 && < 0.12, - cairo >= 0.11 && < 0.12, - gtk >= 0.11 && < 0.12 + glib >= 0.12 && < 0.13, + cairo >= 0.12 && < 0.13, + tk >= 0.12 && < 0.13 build-tools: gtk2hsC2hs, gtk2hsHookGenerator, gtk2hsTypeGen