diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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) diff --git a/c2hs.cabal b/c2hs.cabal --- a/c2hs.cabal +++ b/c2hs.cabal @@ -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 diff --git a/src/C2HS/C/Trav.hs b/src/C2HS/C/Trav.hs --- a/src/C2HS/C/Trav.hs +++ b/src/C2HS/C/Trav.hs @@ -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 diff --git a/src/C2HS/Gen/Bind.hs b/src/C2HS/Gen/Bind.hs --- a/src/C2HS/Gen/Bind.hs +++ b/src/C2HS/Gen/Bind.hs @@ -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) diff --git a/tests/regression-suite.hs b/tests/regression-suite.hs new file mode 100644 --- /dev/null +++ b/tests/regression-suite.hs @@ -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" diff --git a/tests/test-bugs.hs b/tests/test-bugs.hs --- a/tests/test-bugs.hs +++ b/tests/test-bugs.hs @@ -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