diff --git a/c2hs/base/general/Binary.hs b/c2hs/base/general/Binary.hs --- a/c2hs/base/general/Binary.hs +++ b/c2hs/base/general/Binary.hs @@ -60,9 +60,16 @@ import Map (Map) import qualified Map as Map -# if __GLASGOW_HASKELL__>=602 +#if __GLASGOW_HASKELL__>=602 +# if __GLASGOW_HASKELL__>=707 +import Data.HashTable.Class as HashTable + (HashTable) +import Data.HashTable.IO as HashTable + (BasicHashTable, toList, new, insert, lookup) +# else import Data.HashTable as HashTable # endif +#endif import Data.Array.IO import Data.Array import Data.Bits @@ -697,7 +704,11 @@ -- The next two fields are only used when writing ud_next :: IORef Int, -- The next index to use #if __GLASGOW_HASKELL__>=602 +# if __GLASGOW_HASKELL__>=707 + ud_map :: BasicHashTable String Int -- The index of each string +# else ud_map :: HashTable String Int -- The index of each string +# endif #else ud_map :: IORef (Map String Int) #endif @@ -714,7 +725,11 @@ newWriteState = do j_r <- newIORef 0 #if __GLASGOW_HASKELL__>=602 +# if __GLASGOW_HASKELL__>=707 + out_r <- HashTable.new +# else out_r <- HashTable.new (==) HashTable.hashString +# endif #else out_r <- newIORef Map.empty #endif diff --git a/c2hs/gen/GenBind.hs b/c2hs/gen/GenBind.hs --- a/c2hs/gen/GenBind.hs +++ b/c2hs/gen/GenBind.hs @@ -113,7 +113,7 @@ -- standard libraries import Data.Char (toUpper, toLower, isSpace) -import Data.List (deleteBy, intersperse, isPrefixOf, find) +import Data.List (deleteBy, intersperse, isPrefixOf, find, nubBy) import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Control.Monad (when, unless, liftM, mapAndUnzipM) @@ -419,12 +419,9 @@ -- convert the translation table and generate data type definition code -- gprefix <- getPrefix - let prefix = case oprefix of - Nothing -> gprefix - Just pref -> pref - - let trans = transTabToTransFun prefix chsTrans - hide = identToLexeme . fromMaybe cide $ oalias + let prefix = fromMaybe gprefix oprefix + trans = transTabToTransFun prefix chsTrans + hide = identToLexeme . fromMaybe cide $ oalias enumDef enum hide trans (map identToLexeme derive) expandHook hook@(CHSCall isPure isUns isNol ide oalias pos) = do @@ -629,39 +626,34 @@ -- enumInst :: String -> [(String, Maybe CExpr)] -> String enumInst ident list = - "instance Enum " ++ ident ++ " where\n" - ++ fromDef list 0 ++ "\n" ++ toDef list 0 ++ "\n" + "instance Enum " ++ ident ++ " where\n" + ++ fromDef flatList ++ "\n" ++ toDef flatList ++ "\n" ++ succDef names ++ "\n" ++ predDef names ++ "\n" ++ enumFromToDef names where names = map fst list - fromDef [] _ = "" - fromDef ((ide, exp):list) n = - " fromEnum " ++ ide ++ " = " ++ show' val ++ "\n" - ++ fromDef list (val + 1) + flatList = flatten list 0 + + flatten [] n = [] + flatten ((ide, exp):list) n = (ide, val) : flatten list (val + 1) where val = case exp of - Nothing -> n - Just (CConst (CIntConst m _) _) -> m - Just _ -> - interr "GenBind.enumInst: Integer constant expected!" - -- - show' x = if x < 0 then "(" ++ show x ++ ")" else show x - -- - toDef [] _ = - " toEnum unmatched = error (\"" ++ ident + Nothing -> n + Just (CConst (CIntConst m _) _) -> m + Just _ -> interr "GenBind.enumInst: Integer constant expected!" + + show' x = if x < 0 then "(" ++ show x ++ ")" else show x + fromDef list = concat + [ " fromEnum " ++ ide ++ " = " ++ show' val ++ "\n" + | (ide, val) <- list + ] + toDef list = concat + [ " toEnum " ++ show' val ++ " = " ++ ide ++ "\n" + | (ide, val) <- nubBy (\x y -> snd x == snd y) list + ] + ++ " toEnum unmatched = error (\"" ++ ident ++ ".toEnum: Cannot match \" ++ show unmatched)\n" - toDef ((ide, exp):list) n = - " toEnum " ++ show' val ++ " = " ++ ide ++ "\n" - ++ toDef list (val + 1) - where - val = case exp of - Nothing -> n - Just (CConst (CIntConst m _) _) -> m - Just _ -> - interr "GenBind.enumInst: Integer constant expected!" - -- - show' x = if x < 0 then "(" ++ show x ++ ")" else show x + succDef [] = " succ _ = undefined\n" succDef [x] = " succ _ = undefined\n" succDef (x:x':xs) = diff --git a/c2hs/toplevel/Version.hs b/c2hs/toplevel/Version.hs --- a/c2hs/toplevel/Version.hs +++ b/c2hs/toplevel/Version.hs @@ -6,7 +6,7 @@ -- idstr = "$Id: Version.hs,v 1.1 2012/05/27 16:49:07 dmwit Exp $" name = "C->Haskell Compiler" -versnum = "0.13.6 (gtk2hs branch)" +versnum = "0.13.8 (gtk2hs branch)" versnick = "\"Bin IO\"" date = "27 May 2012" version = name ++ ", version " ++ versnum ++ " " ++ versnick ++ ", " ++ date diff --git a/dist/build/gtk2hsC2hs/gtk2hsC2hs-tmp/CLexer.hs b/dist/build/gtk2hsC2hs/gtk2hsC2hs-tmp/CLexer.hs --- a/dist/build/gtk2hsC2hs/gtk2hsC2hs-tmp/CLexer.hs +++ b/dist/build/gtk2hsC2hs/gtk2hsC2hs-tmp/CLexer.hs @@ -323,6 +323,7 @@ alex_action_58 = token_ CTokEllipsis {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} {-# LINE 1 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- diff --git a/dist/build/gtk2hsC2hs/gtk2hsC2hs-tmp/CParser.hs b/dist/build/gtk2hsC2hs/gtk2hsC2hs-tmp/CParser.hs --- a/dist/build/gtk2hsC2hs/gtk2hsC2hs-tmp/CParser.hs +++ b/dist/build/gtk2hsC2hs/gtk2hsC2hs-tmp/CParser.hs @@ -27,7 +27,7 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.18.10 +-- parser produced by Happy Version 1.18.9 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -5450,6 +5450,7 @@ position message {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} {-# LINE 1 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp diff --git a/gtk2hs-buildtools.cabal b/gtk2hs-buildtools.cabal --- a/gtk2hs-buildtools.cabal +++ b/gtk2hs-buildtools.cabal @@ -1,5 +1,5 @@ Name: gtk2hs-buildtools -Version: 0.12.4 +Version: 0.12.5.0 License: GPL-2 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team @@ -27,8 +27,8 @@ Extra-Source-Files: c2hs/toplevel/c2hs_config.h Source-Repository head - type: darcs - location: http://code.haskell.org/gtk2hs/ + type: git + location: https://github.com/gtk2hs/gtk2hs subdir: tools Flag ClosureSignals @@ -115,3 +115,5 @@ cpp-options: -D_C2HS_CPP_LANG_SINGLE extensions: ForeignFunctionInterface BangPatterns + if impl(ghc >= 7.7) + build-depends: hashtables diff --git a/hierarchyGen/Hierarchy.chs.template b/hierarchyGen/Hierarchy.chs.template --- a/hierarchyGen/Hierarchy.chs.template +++ b/hierarchyGen/Hierarchy.chs.template @@ -1,5 +1,4 @@ {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE CPP #-} -- -*-haskell-*- -- -------------------- automatically generated file - do not edit ---------- -- Object hierarchy for the GIMP Toolkit (GTK) Binding for Haskell @@ -37,7 +36,12 @@ @MODULE_EXPORTS@ ) where -import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, unsafeForeignPtrToPtr) +import Foreign.ForeignPtr (ForeignPtr, castForeignPtr) +#if __GLASGOW_HASKELL__ >= 707 +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +#else +import Foreign.ForeignPtr (unsafeForeignPtrToPtr) +#endif import Foreign.C.Types (CULong(..), CUInt(..)) import System.Glib.GType (GType, typeInstanceIsA) @MODULE_IMPORTS@ diff --git a/hierarchyGen/TypeGen.hs b/hierarchyGen/TypeGen.hs --- a/hierarchyGen/TypeGen.hs +++ b/hierarchyGen/TypeGen.hs @@ -279,13 +279,7 @@ indent 0. indent 0.ss "{#pointer *". (case lookup name table of - (Just TypeInfo { tiQueryFunction = cname }) - | stripPrefix cname == name -> ss name - | otherwise -> ss cname.ss " as ".ss name - where stripPrefix s = if uCasePrefix `isPrefixOf` s - then drop (length prefix) s - else s - uCasePrefix = toUpper (head prefix) : tail prefix -- gtk -> Gtk + (Just TypeInfo { tiQueryFunction = cname }) -> ss cname.ss " as ".ss name ). ss " foreign newtype #}". (case lookup name table of