c2hs 0.17.1 → 0.17.2
raw patch · 6 files changed
+179/−19 lines, 6 filesdep +yamldep ~base
Dependencies added: yaml
Dependency ranges changed: base
Files
- ChangeLog +6/−0
- c2hs.cabal +11/−1
- src/C2HS/C/Trav.hs +40/−10
- src/C2HS/Gen/Bind.hs +12/−8
- tests/regression-suite.hs +102/−0
- tests/test-bugs.hs +8/−0
ChangeLog view
@@ -1,3 +1,9 @@+0.17.2+ - Fix more regressions from 0.16.6 (affected packages included+ gnome-keyring, hsndfile and cuda)+ - Add regression suite tests to reduce chances of future regressions++ 0.17.1 - Fix regressions from 0.16.6 (caused by fix for issue #45)
c2hs.cabal view
@@ -1,5 +1,5 @@ Name: c2hs-Version: 0.17.1+Version: 0.17.2 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -134,3 +134,13 @@ HUnit, shelly >= 1.0, text++Test-Suite regression-suite+ type: exitcode-stdio-1.0+ build-depends: base,+ filepath,+ shelly >= 1.0,+ text,+ yaml >= 0.8+ hs-source-dirs: tests+ main-is: regression-suite.hs
src/C2HS/C/Trav.hs view
@@ -338,9 +338,9 @@ DontCareCD -> interr "CTrav.getDeclOf: Don't care!" TagCD _ -> interr "CTrav.getDeclOf: Illegal tag!" ObjCD obj -> case obj of- TypeCO decl -> traceTypeCO >>+ TypeCO decl -> traceTypeCO decl >> return decl- ObjCO decl -> traceObjCO >>+ ObjCO decl -> traceObjCO decl >> return decl EnumCO _ _ -> illegalEnum BuiltinCO -> illegalBuiltin@@ -354,10 +354,10 @@ traceEnter = traceCTrav $ "Entering `getDeclOf' for `" ++ identToString ide ++ "'...\n"- traceTypeCO = traceCTrav $- "...found a type object.\n"- traceObjCO = traceCTrav $- "...found a vanilla object.\n"+ traceTypeCO decl = traceCTrav $+ "...found a type object.\n" ++ show decl ++ "\n"+ traceObjCO decl = traceCTrav $+ "...found a vanilla object.\n" ++ show decl ++ "\n" -- convenience functions@@ -568,6 +568,12 @@ CSUType su _ -> extractStruct pos (StructUnionCT su) _ -> structExpectedErr pos +structFromDecl' :: Position -> CDecl -> CT s (Maybe CStructUnion)+structFromDecl' pos (CDecl specs _ _) =+ case head [ts | CTypeSpec ts <- specs] of+ CSUType su _ -> extractStruct' pos (StructUnionCT su)+ _ -> structExpectedErr pos+ -- | extracts the arguments from a function declaration (must be a unique -- declarator) and constructs a declaration for the result of the function --@@ -709,6 +715,8 @@ -- lookupStructUnion :: Ident -> Bool -> Bool -> CT s CStructUnion lookupStructUnion ide preferTag useShadows = do+ traceCTrav $ "lookupStructUnion: ide=" ++ show ide ++ " preferTag=" +++ show preferTag ++ " useShadows=" ++ show useShadows ++ "\n" otag <- if useShadows then liftM (fmap fst) $ findTagShadow ide else findTag ide@@ -728,7 +736,12 @@ False -> case oobj of Just _ -> do decl <- findAndChaseDecl ide True useShadows- structFromDecl (posOf ide) decl+ mres <- structFromDecl' (posOf ide) decl+ case mres of+ Just su -> return su+ Nothing -> case otag of+ Just tag -> extractStruct (posOf ide) tag+ Nothing -> unknownObjErr ide Nothing -> case otag of Just tag -> extractStruct (posOf ide) tag Nothing -> unknownObjErr ide@@ -801,19 +814,36 @@ -- extractStruct :: Position -> CTag -> CT s CStructUnion extractStruct pos (EnumCT _ ) = structExpectedErr pos-extractStruct pos (StructUnionCT su) =+extractStruct pos (StructUnionCT su) = do+ traceCTrav $ "extractStruct: " ++ show su ++ "\n" case su of CStruct _ (Just ide') Nothing _ _ -> do -- found forward definition def <- getDefOf ide'+ traceCTrav $ "def=" ++ show def ++ "\n" case def of TagCD tag -> extractStruct pos tag bad_obj -> err ide' bad_obj _ -> return su where- err ide bad_obj = + err ide bad_obj = do interr $ "CTrav.extractStruct: Illegal reference! Expected " ++ dumpIdent ide ++ " to link to TagCD but refers to "++ (show bad_obj) ++ "\n"- ++extractStruct' :: Position -> CTag -> CT s (Maybe CStructUnion)+extractStruct' pos (EnumCT _ ) = structExpectedErr pos+extractStruct' pos (StructUnionCT su) = do+ traceCTrav $ "extractStruct': " ++ show su ++ "\n"+ case su of+ CStruct _ (Just ide') Nothing _ _ -> do+ def <- getDefOf ide'+ traceCTrav $ "def=" ++ show def ++ "\n"+ case def of+ TagCD tag -> do+ res <- extractStruct pos tag+ return . Just $ res+ _ -> return Nothing+ _ -> return . Just $ su+ -- | yield the name declared by a declarator if any -- declrName :: CDeclr -> Maybe Ident
src/C2HS/Gen/Bind.hs view
@@ -725,13 +725,16 @@ enumDef (CEnum _ (Just list) _ _) hident trans userDerive _ = do (list', enumAuto) <- evalTagVals list- let enumVals = [(trans ide, cexpr) |- (ide, cexpr) <- stripEnumAliases list'] -- translate+ let enumVals = [(trans ide, cexpr) | (ide, cexpr) <- list']+ toEnumVals = [(trans ide, cexpr) |+ (ide, cexpr) <- stripEnumAliases list'] defHead = enumHead hident defBody = enumBody (length defHead - 2) enumVals inst = makeDerives (if enumAuto then "Enum" : userDerive else userDerive) ++- if enumAuto then "\n" else "\n" ++ enumInst hident enumVals+ if enumAuto+ then "\n"+ else "\n" ++ enumInst hident enumVals toEnumVals isEnum hident return $ defHead ++ defBody ++ inst where@@ -798,10 +801,11 @@ -- following tags are assigned values continuing from the explicitly -- specified one ---enumInst :: String -> [(String, Maybe CExpr)] -> String-enumInst ident list =+enumInst :: String -> [(String, Maybe CExpr)] -> [(String, Maybe CExpr)]+ -> String+enumInst ident list tolist = "instance Enum " ++ ident ++ " where\n"- ++ fromDef list 0 ++ "\n" ++ toDef list 0+ ++ fromDef list 0 ++ "\n" ++ toDef tolist 0 where fromDef [] _ = "" fromDef ((ide, exp):list') n =@@ -927,8 +931,8 @@ call = if isPure then " let {res = " ++ fiLexeme ++ joinCallArgs ++ "} in\n" else " " ++ fiLexeme ++ joinCallArgs ++ case parm of- CHSParm _ "()" _ _ _ -> " >>\n"- _ -> " >>= \\res ->\n"+ CHSParm _ "()" _ Nothing _ -> " >>\n"+ _ -> " >>= \\res ->\n" joinCallArgs = case marsh2 of Nothing -> join callArgs Just _ -> join ("b1'" : drop 1 callArgs)
+ tests/regression-suite.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module Main where++import Control.Applicative ((<$>), (<*>))+import Control.Monad+import Shelly hiding (FilePath)+import Data.List (nub)+import Data.Text (Text)+import Data.Monoid+import qualified Data.Text as T+import Data.Yaml+default (T.Text)++data RegressionTest = RegressionTest+ { name :: Text+ , cabal :: Bool+ , flags :: [Text]+ , aptPPA :: [Text]+ , aptPackages :: [Text]+ , specialSetup :: [Text]+ , extraPath :: [Text]+ } deriving (Eq, Show)++instance FromJSON RegressionTest where+ parseJSON (Object v) = RegressionTest <$> v .: "name"+ <*> v .:? "cabal" .!= True+ <*> v .:? "flags" .!= []+ <*> v .:? "apt-ppa" .!= []+ <*> v .:? "apt-packages" .!= []+ <*> v .:? "special-setup" .!= []+ <*> v .:? "extra-path" .!= []+ parseJSON _ = mzero++readTests :: FilePath -> IO [RegressionTest]+readTests fp = maybe [] id <$> decodeFile fp++checkApt :: Sh ()+checkApt = do+ apt <- which "apt-get"+ case apt of+ Nothing -> errorExit "Can't find apt-get. Are you sure this is Ubuntu?"+ _ -> return ()++main :: IO ()+main = shelly $ do+ travis <- maybe False (const True) <$> get_env "TRAVIS"+ enabled <- maybe False (const True) <$> get_env "C2HS_REGRESSION_SUITE"+ when (not (travis || enabled)) $ do+ echo "REGRESSION SUITE IS DISABLED"+ exit 0++ when travis checkApt+ tests <- liftIO $ readTests "tests/regression-suite.yaml"+ let ppas = nub $ concatMap aptPPA tests+ pkgs = nub $ concatMap aptPackages tests+ specials = concatMap specialSetup tests+ extraPaths = concatMap extraPath tests++ when (not travis) $+ echo "ASSUMING THAT ALL NECESSARY LIBRARIES ALREADY INSTALLED!\n"++ when travis $ do+ when (not (null ppas)) $ do+ echo "SETTING UP APT PPAS\n"+ forM_ ppas $ \ppa -> run_ "sudo" $ ["apt-add-repository", "ppa:" <> ppa]+ run_ "sudo" $ ["apt-get", "update"]+ echo "\n"++ when (not (null pkgs)) $ do+ echo "INSTALLING APT PACKAGES\n"+ run_ "sudo" $ ["apt-get", "install", "-y"] ++ pkgs+ echo "\n"++ when (not (null specials)) $ do+ echo "SPECIAL INSTALL STEPS\n"+ forM_ specials $ \s -> let (c:as) = T.words s in run_ (fromText c) as+ echo "\n"++ when (not (null extraPaths)) $ do+ echo "ADDING PATHS\n"+ forM_ extraPaths $ \p -> do+ echo p+ appendToPath $ fromText p+ echo "\n"++ codes <- forM (filter cabal tests) $ \t -> do+ let n = name t+ infs = concatMap (\f -> ["-f", f]) $ flags t+ mefs <- get_env $ "C2HS_REGRESSION_FLAGS_" <> n+ let fs = case mefs of+ Nothing -> infs+ Just efs -> infs ++ concatMap (\f -> ["-f", f]) (T.splitOn "," efs)+ echo $ "\nREGRESSION TEST: " <> n <> "\n"+ errExit False $ do+ run_ "cabal" $ ["install"] ++ fs ++ [n]+ lastExitCode++ if all (== 0) codes+ then exit 0+ else errorExit "SOME TESTS FAILED"
tests/test-bugs.hs view
@@ -18,6 +18,8 @@ tests = [ testGroup "Bugs" [ testCase "call_capital (issue #??)" call_capital+ , testCase "Issue #79" issue79+ , testCase "Issue #75" issue75 , testCase "Issue #69" issue69 , testCase "Issue #60" issue60 , testCase "Issue #51" issue51@@ -50,6 +52,12 @@ res <- absPath "./Capital" >>= cmd let expected = ["upper C();", "lower c();", "upper C();"] liftIO $ assertBool "" (T.lines res == expected)++issue79 :: Assertion+issue79 = expect_issue 79 ["A=1", "B=2", "C=2", "D=3"]++issue75 :: Assertion+issue75 = build_issue 75 issue69 :: Assertion issue69 = build_issue 69