c2hs 0.18.2 → 0.19.1
raw patch · 28 files changed
+605/−116 lines, 28 filesdep ~language-c
Dependency ranges changed: language-c
Files
- ChangeLog +11/−0
- c2hs.cabal +7/−2
- src/C2HS/C/Trav.hs +10/−1
- src/C2HS/CHS.hs +71/−24
- src/C2HS/CHS/Lexer.hs +18/−6
- src/C2HS/Gen/Bind.hs +87/−26
- src/C2HS/Gen/Header.hs +44/−14
- src/C2HS/Gen/Monad.hs +20/−6
- src/Main.hs +1/−5
- tests/bugs/issue-103/Issue103.chs +14/−0
- tests/bugs/issue-103/Issue103A.chs +7/−0
- tests/bugs/issue-103/issue103.c +11/−0
- tests/bugs/issue-103/issue103.h +7/−0
- tests/bugs/issue-107/Issue107.chs +1/−1
- tests/bugs/issue-65/Issue65.chs +15/−0
- tests/bugs/issue-65/issue65.c +0/−0
- tests/bugs/issue-65/issue65.h +3/−0
- tests/bugs/issue-70/Issue70.chs +23/−0
- tests/bugs/issue-70/issue70.c +0/−0
- tests/bugs/issue-70/issue70.h +6/−0
- tests/bugs/issue-73/Issue73.chs +71/−0
- tests/bugs/issue-73/issue73.c +34/−0
- tests/bugs/issue-73/issue73.h +9/−0
- tests/bugs/issue-97/Issue97.chs +16/−0
- tests/bugs/issue-97/Issue97A.chs +13/−0
- tests/bugs/issue-97/issue97.c +6/−0
- tests/bugs/issue-97/issue97.h +12/−0
- tests/test-bugs.hs +88/−31
ChangeLog view
@@ -1,8 +1,19 @@+0.19.1+ - Add {#const ...#} hook for accessing #defined constants [#65]+ - Persist enumeration definitions across modules [#103]+ - Add nocode keyword for enumeration definitions [#70]+ - Bump version for language-c to fix OS X problems [#82, #85] (thanks to+ Anthony Cowley and Benedikt Huber for help with this)+ - Add finalizer support to foreign pointer definitions [#73]+ - Comment parsing cleanups (Sivert Berg: @sivertb)++ 0.18.2 - Add C2HS_MIN_VERSION(major,minor,revision) preprocessor macro - Suppress regression suite build (and associated dependency installation) for non-Travis cases - Fix Cabal file to include previously missing tests+ 0.18.1 - Numerous improvements to Enum handling [#78] (Philipp Balzarek:
c2hs.cabal view
@@ -1,5 +1,5 @@ Name: c2hs-Version: 0.18.2+Version: 0.19.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -60,13 +60,18 @@ tests/bugs/issue-54/*.chs tests/bugs/issue-54/*.h tests/bugs/issue-54/*.c tests/bugs/issue-60/*.chs tests/bugs/issue-60/*.h tests/bugs/issue-60/*.c tests/bugs/issue-62/*.chs tests/bugs/issue-62/*.h tests/bugs/issue-62/*.c+ tests/bugs/issue-65/*.chs tests/bugs/issue-65/*.h tests/bugs/issue-65/*.c tests/bugs/issue-69/*.chs tests/bugs/issue-69/*.h tests/bugs/issue-69/*.c+ tests/bugs/issue-70/*.chs tests/bugs/issue-70/*.h tests/bugs/issue-70/*.c+ tests/bugs/issue-73/*.chs tests/bugs/issue-73/*.h tests/bugs/issue-73/*.c tests/bugs/issue-75/*.chs tests/bugs/issue-75/*.h tests/bugs/issue-75/*.c tests/bugs/issue-79/*.chs tests/bugs/issue-79/*.h tests/bugs/issue-79/*.c tests/bugs/issue-80/*.chs tests/bugs/issue-80/*.h tests/bugs/issue-80/*.c tests/bugs/issue-93/*.chs tests/bugs/issue-93/*.h tests/bugs/issue-93/*.c tests/bugs/issue-95/*.chs tests/bugs/issue-95/*.h tests/bugs/issue-95/*.c tests/bugs/issue-96/*.chs tests/bugs/issue-96/*.h tests/bugs/issue-96/*.c+ tests/bugs/issue-97/*.chs tests/bugs/issue-97/*.h tests/bugs/issue-97/*.c+ tests/bugs/issue-103/*.chs tests/bugs/issue-103/*.h tests/bugs/issue-103/*.c tests/bugs/issue-107/*.chs source-repository head@@ -77,7 +82,7 @@ Executable c2hs Build-Depends: base >= 2 && < 5,- language-c >= 0.4.5 && < 0.5,+ language-c >= 0.4.7 && < 0.5, filepath, dlist
src/C2HS/C/Trav.hs view
@@ -70,7 +70,7 @@ -- C structure tree query functions -- isTypedef, simplifyDecl, declrFromDecl, declrNamed,- declaredDeclr, declaredName, structMembers, expandDecl,+ declaredDeclr, initDeclr, declaredName, structMembers, expandDecl, structName, enumName, tagName, isPtrDeclr, dropPtrDeclr, isPtrDecl, isFunDeclr, structFromDecl, funResultAndArgs, chaseDecl, findAndChaseDecl, findAndChaseDeclOrTag,@@ -475,6 +475,15 @@ declaredDeclr (CDecl _ [(odeclr, _, _)] _) = odeclr declaredDeclr decl = interr $ "CTrav.declaredDeclr: Too many declarators!\n\+ \ Declaration at " ++ show (posOf decl)++-- | get the initialiser of a declaration that has at most one initialiser+--+initDeclr :: CDecl -> Maybe (CInitializer NodeInfo)+initDeclr (CDecl _ [] _) = Nothing+initDeclr (CDecl _ [(_, ini, _)] _) = ini+initDeclr decl =+ interr $ "CTrav.initDeclr: Too many declarators!\n\ \ Declaration at " ++ show (posOf decl) -- | get the name declared by a declaration that has exactly one declarator
src/C2HS/CHS.hs view
@@ -53,7 +53,7 @@ -- | `type' ident -- | `sizeof' ident -- | `alignof' ident--- | `enum' idalias trans [`with' prefix] [`add' prefix] [deriving]+-- | `enum' idalias trans [`nocode'] [`with' prefix] [`add' prefix] [deriving] -- | `enum` `define` idalias [deriving] -- | `call' [`pure'] [`unsafe'] idalias -- | `fun' [`pure'] [`unsafe'] idalias parms@@ -62,8 +62,9 @@ -- | `offsetof` apath -- | `pointer' ['*'] idalias ptrkind ['nocode'] -- | `class' [ident `=>'] ident ident+-- | `const' ident -- ctxt -> [`lib' `=' string] [prefix]--- idalias -> ident [`as' (ident | `^')]+-- idalias -> ident [`as' (ident | `^' | `'' ident1 ident2 ... `'')] -- prefix -> `prefix' `=' string [`add' `prefix' `=' string] -- deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)' -- parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm@@ -77,7 +78,7 @@ -- alias -> `underscoreToCase' | `upcaseFirstLetter' -- | `downcaseFirstLetter' -- | ident `as' ident--- ptrkind -> [`foreign' | `stable'] ['newtype' | '->' ident]+-- ptrkind -> [`foreign' [`finalizer' idalias] | `stable'] ['newtype' | '->' ident] -- -- If `underscoreToCase', `upcaseFirstLetter', or `downcaseFirstLetter' -- occurs in a translation table, it must be the first entry, or if two of@@ -201,6 +202,7 @@ | CHSEnum Ident -- C enumeration type (Maybe Ident) -- Haskell name CHSTrans -- translation table+ Bool -- emit code or not? (Maybe String) -- local prefix (Maybe String) -- local replacement prefix [Ident] -- instance requests from user@@ -239,14 +241,17 @@ Ident -- class name Ident -- name of pointer type Position+ | CHSConst Ident -- C identifier+ Position + instance Pos CHSHook where posOf (CHSImport _ _ _ pos) = pos posOf (CHSContext _ _ _ pos) = pos posOf (CHSType _ pos) = pos posOf (CHSSizeof _ pos) = pos posOf (CHSAlignof _ pos) = pos- posOf (CHSEnum _ _ _ _ _ _ pos) = pos+ posOf (CHSEnum _ _ _ _ _ _ _ pos) = pos posOf (CHSEnumDefine _ _ _ pos) = pos posOf (CHSCall _ _ _ _ pos) = pos posOf (CHSFun _ _ _ _ _ _ _ pos) = pos@@ -254,6 +259,7 @@ posOf (CHSOffsetof _ pos) = pos posOf (CHSPointer _ _ _ _ _ _ _ pos) = pos posOf (CHSClass _ _ _ pos) = pos+ posOf (CHSConst _ pos) = pos -- | two hooks are equal if they have the same Haskell name and reference the -- same C object@@ -269,7 +275,7 @@ ide1 == ide2 (CHSAlignof ide1 _) == (CHSAlignof ide2 _) = ide1 == ide2- (CHSEnum ide1 oalias1 _ _ _ _ _) == (CHSEnum ide2 oalias2 _ _ _ _ _) =+ (CHSEnum ide1 oalias1 _ _ _ _ _ _) == (CHSEnum ide2 oalias2 _ _ _ _ _ _) = oalias1 == oalias2 && ide1 == ide2 (CHSEnumDefine ide1 _ _ _) == (CHSEnumDefine ide2 _ _ _) = ide1 == ide2@@ -286,6 +292,8 @@ ide1 == ide2 && oalias1 == oalias2 (CHSClass _ ide1 _ _) == (CHSClass _ ide2 _ _) = ide1 == ide2+ (CHSConst ide1 _) == (CHSConst ide2 _) =+ ide1 == ide2 _ == _ = False -- | translation table@@ -344,21 +352,24 @@ -- | pointer options -- -data CHSPtrType = CHSPtr -- standard Ptr from Haskell- | CHSForeignPtr -- a pointer with a finalizer- | CHSStablePtr -- a pointer into Haskell land+data CHSPtrType = CHSPtr+ -- standard Ptr from Haskell+ | CHSForeignPtr (Maybe (Ident, Maybe Ident))+ -- a foreign pointer possibly with a finalizer+ | CHSStablePtr+ -- a pointer into Haskell land deriving (Eq) instance Show CHSPtrType where show CHSPtr = "Ptr"- show CHSForeignPtr = "ForeignPtr"+ show (CHSForeignPtr _) = "ForeignPtr" show CHSStablePtr = "StablePtr" instance Read CHSPtrType where readsPrec _ ( 'P':'t':'r':rest) = [(CHSPtr, rest)] readsPrec _ ('F':'o':'r':'e':'i':'g':'n':'P':'t':'r':rest) =- [(CHSForeignPtr, rest)]+ [(CHSForeignPtr Nothing, rest)] readsPrec _ ('S':'t':'a':'b':'l':'e' :'P':'t':'r':rest) = [(CHSStablePtr, rest)] readsPrec p (c:cs)@@ -520,10 +531,13 @@ showCHSHook (CHSAlignof ide _) = showString "alignof " . showCHSIdent ide-showCHSHook (CHSEnum ide oalias trans oprefix oreplprefix derive _) =+showCHSHook (CHSEnum ide oalias trans emit oprefix oreplprefix derive _) = showString "enum " . showIdAlias ide oalias . showCHSTrans trans+ . (case emit of+ True -> showString ""+ False -> showString " nocode") . showPrefix oprefix True . showReplacementPrefix oreplprefix . if null derive then id else showString $@@ -568,9 +582,11 @@ . (if star then showString "*" else showString "") . showIdAlias ide oalias . (case ptrType of- CHSForeignPtr -> showString " foreign"- CHSStablePtr -> showString " stable"- _ -> showString "")+ CHSForeignPtr Nothing -> showString " foreign"+ CHSForeignPtr (Just (fide, foalias)) ->+ showString " foreign finalizer " . showIdAlias fide foalias+ CHSStablePtr -> showString " stable"+ _ -> showString "") . (case (isNewtype, oRefType) of (True , _ ) -> showString " newtype" (False, Just ide') -> showString " -> " . showCHSIdent ide'@@ -586,6 +602,9 @@ . showCHSIdent classIde . showString " " . showCHSIdent typeIde+showCHSHook (CHSConst constIde _) =+ showString "const "+ . showCHSIdent constIde showPrefix :: Maybe String -> Bool -> ShowS showPrefix Nothing _ = showString ""@@ -641,7 +660,7 @@ showHsVerb str = showChar '`' . showString str . showChar '\'' showComment str = if null str then showString ""- else showString "-- " . showString str . showChar '\n'+ else showString "--" . showString str . showChar '\n' showCHSTrans :: CHSTrans -> ShowS showCHSTrans (CHSTrans _2Case chgCase assocs) =@@ -682,7 +701,10 @@ . showCHSIdent ide showCHSIdent :: Ident -> ShowS-showCHSIdent = showString . identToString+showCHSIdent ide = showString $ let s = identToString ide+ in case ' ' `elem` s of+ False -> s+ True -> "'" ++ s ++ "'" -- load and dump a CHI file@@ -874,6 +896,9 @@ CHSTokClass pos :toks) = parseClass hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:+ CHSTokConst pos :toks) = parseConst hkpos pos+ (removeCommentInHook toks)+ parseFrags0 (CHSTokHook hkpos: CHSTokPointer pos :toks) = parsePointer hkpos pos (removeCommentInHook toks) parseFrags0 (CHSTokHook _ :toks) = syntaxError toks@@ -998,13 +1023,14 @@ parseEnum hkpos pos (CHSTokIdent _ ide:toks) = do (oalias, toks2) <- parseOptAs ide True toks- (trans, toks3) <- parseTrans toks2- (oprefix, toks4) <- parseOptPrefix True toks3- (oreplprefix, toks5) <- parseOptReplPrefix toks4- (derive, toks6) <- parseDerive toks5- toks7 <- parseEndHook toks6- frags <- parseFrags toks7- return $ CHSHook (CHSEnum ide (norm oalias) trans+ (emit, toks3) <- parseOptNoCode toks2+ (trans, toks4) <- parseTrans toks3+ (oprefix, toks5) <- parseOptPrefix True toks4+ (oreplprefix, toks6) <- parseOptReplPrefix toks5+ (derive, toks7) <- parseDerive toks6+ toks8 <- parseEndHook toks7+ frags <- parseFrags toks8+ return $ CHSHook (CHSEnum ide (norm oalias) trans emit oprefix oreplprefix derive pos) hkpos : frags where norm Nothing = Nothing@@ -1012,6 +1038,10 @@ | otherwise = Just ide' parseEnum _ _ toks = syntaxError toks +parseOptNoCode :: [CHSToken] -> CST s (Bool, [CHSToken])+parseOptNoCode (CHSTokNocode _ :toks) = return (False, toks)+parseOptNoCode toks = return (True, toks)+ parseCall :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseCall hkpos pos toks = do@@ -1206,10 +1236,17 @@ : frags where parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken])- parsePtrType (CHSTokForeign _:toks') = return (CHSForeignPtr, toks')+ parsePtrType (CHSTokForeign _:toks') = do+ (final, toks'') <- parseFinalizer toks'+ return (CHSForeignPtr final, toks'') parsePtrType (CHSTokStable _ :toks') = return (CHSStablePtr, toks') parsePtrType toks' = return (CHSPtr, toks') + parseFinalizer (CHSTokFinal _ : CHSTokIdent _ ide : toks') = do+ (oalias, toks'') <- parseOptAs ide False toks'+ return (Just (ide, oalias), toks'')+ parseFinalizer toks' = return (Nothing, toks')+ norm _ Nothing = Nothing norm ide (Just ide') | ide == ide' = Nothing | otherwise = Just ide'@@ -1234,6 +1271,14 @@ return $ CHSHook (CHSClass Nothing classIde typeIde pos) hkpos : frags parseClass _ _ toks = syntaxError toks +parseConst :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]+parseConst hkpos pos (CHSTokIdent _ constIde : toks) =+ do+ toks' <- parseEndHook toks+ frags <- parseFrags toks'+ return $ CHSHook (CHSConst constIde pos) hkpos : frags+parseConst _ _ toks = syntaxError toks+ parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptLib (CHSTokLib _ : CHSTokEqual _ :@@ -1272,6 +1317,8 @@ parseOptAs :: Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken]) parseOptAs _ _ (CHSTokAs _:CHSTokIdent _ ide:toks) = return (Just ide, toks)+parseOptAs _ _ (CHSTokAs _:CHSTokHSQuot pos ide:toks) =+ return (Just $ internalIdentAt pos ide, toks) parseOptAs ide upper (CHSTokAs _:CHSTokHat pos :toks) = return (Just $ underscoreToCase ide upper pos, toks) parseOptAs _ _ (CHSTokAs _ :toks) = syntaxError toks
src/C2HS/CHS/Lexer.hs view
@@ -89,11 +89,11 @@ -- ident -> letter (letter | digit | `\'')* -- reservedid -> `add' | `as' | `call' | `class' | `context' | `deriving' -- | `enum' | `foreign' | `fun' | `get' | `lib'--- | `downcaseFirstLetter'+-- | `downcaseFirstLetter' | `finalizer' -- | `newtype' | `nocode' | `pointer' | `prefix' | `pure' -- | `set' | `sizeof' | `stable' | `struct' | `type' -- | `underscoreToCase' | `upcaseFirstLetter' | `unsafe' |--- | `with'+-- | `with' | `const' -- reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `=' -- | `=>' | '-' | `*' | `&' | `^' -- string -> `"' instr* `"'@@ -210,11 +210,13 @@ | CHSTokAs Position -- `as' | CHSTokCall Position -- `call' | CHSTokClass Position -- `class'+ | CHSTokConst Position -- `const' | CHSTokContext Position -- `context' | CHSTokNonGNU Position -- `nonGNU' | CHSTokDerive Position -- `deriving' | CHSTokDown Position -- `downcaseFirstLetter' | CHSTokEnum Position -- `enum'+ | CHSTokFinal Position -- `finalizer' | CHSTokForeign Position -- `foreign' | CHSTokFun Position -- `fun' | CHSTokGet Position -- `get'@@ -268,11 +270,13 @@ posOf (CHSTokAs pos ) = pos posOf (CHSTokCall pos ) = pos posOf (CHSTokClass pos ) = pos+ posOf (CHSTokConst pos ) = pos posOf (CHSTokContext pos ) = pos posOf (CHSTokNonGNU pos ) = pos posOf (CHSTokDerive pos ) = pos posOf (CHSTokDown pos ) = pos posOf (CHSTokEnum pos ) = pos+ posOf (CHSTokFinal pos ) = pos posOf (CHSTokForeign pos ) = pos posOf (CHSTokFun pos ) = pos posOf (CHSTokGet pos ) = pos@@ -326,11 +330,13 @@ (CHSTokAs _ ) == (CHSTokAs _ ) = True (CHSTokCall _ ) == (CHSTokCall _ ) = True (CHSTokClass _ ) == (CHSTokClass _ ) = True+ (CHSTokConst _ ) == (CHSTokConst _ ) = True (CHSTokContext _ ) == (CHSTokContext _ ) = True (CHSTokNonGNU _ ) == (CHSTokNonGNU _ ) = True (CHSTokDerive _ ) == (CHSTokDerive _ ) = True (CHSTokDown _ ) == (CHSTokDown _ ) = True (CHSTokEnum _ ) == (CHSTokEnum _ ) = True+ (CHSTokFinal _ ) == (CHSTokFinal _ ) = True (CHSTokForeign _ ) == (CHSTokForeign _ ) = True (CHSTokFun _ ) == (CHSTokFun _ ) = True (CHSTokGet _ ) == (CHSTokGet _ ) = True@@ -385,11 +391,13 @@ showsPrec _ (CHSTokAs _ ) = showString "as" showsPrec _ (CHSTokCall _ ) = showString "call" showsPrec _ (CHSTokClass _ ) = showString "class"+ showsPrec _ (CHSTokConst _ ) = showString "const" showsPrec _ (CHSTokContext _ ) = showString "context" showsPrec _ (CHSTokNonGNU _ ) = showString "nonGNU" showsPrec _ (CHSTokDerive _ ) = showString "deriving" showsPrec _ (CHSTokDown _ ) = showString "downcaseFirstLetter" showsPrec _ (CHSTokEnum _ ) = showString "enum"+ showsPrec _ (CHSTokFinal _ ) = showString "finalizer" showsPrec _ (CHSTokForeign _ ) = showString "foreign" showsPrec _ (CHSTokFun _ ) = showString "fun" showsPrec _ (CHSTokGet _ ) = showString "get"@@ -423,7 +431,7 @@ showsPrec _ (CHSTokCtrl _ c) = showChar c showsPrec _ (CHSTokComment _ s) = showString (if null s then ""- else " -- " ++ s ++ "\n")+ else " --" ++ s ++ "\n") -- lexer state -- -----------@@ -621,7 +629,7 @@ -- startmarker :: CHSLexer startmarker = char '\000' `lexmeta`- \lexeme pos s -> (Nothing, incPos pos 1, s, Just chslexer)+ \_ pos s -> (Nothing, incPos pos 1, s, Just chslexer) -- | pre-processor directives and `#c' --@@ -679,8 +687,8 @@ >||< hsquot >||< whitespace >||< endOfHook- >||< string "--" +> anyButNL`star` char '\n' -- comment- `lexaction` \cs pos -> Just (CHSTokComment pos (init (drop 2 cs)))+ >||< string "--" +> anyButNL`star` epsilon -- comment+ `lexaction` \cs pos -> Just (CHSTokComment pos (drop 2 cs)) where anyButNL = alt (anySet \\ ['\n']) endOfHook = string "#}"@@ -727,11 +735,13 @@ idkwtok pos "as" _ = CHSTokAs pos idkwtok pos "call" _ = CHSTokCall pos idkwtok pos "class" _ = CHSTokClass pos+ idkwtok pos "const" _ = CHSTokConst pos idkwtok pos "context" _ = CHSTokContext pos idkwtok pos "nonGNU" _ = CHSTokNonGNU pos idkwtok pos "deriving" _ = CHSTokDerive pos idkwtok pos "downcaseFirstLetter" _ = CHSTokDown pos idkwtok pos "enum" _ = CHSTokEnum pos+ idkwtok pos "finalizer" _ = CHSTokFinal pos idkwtok pos "foreign" _ = CHSTokForeign pos idkwtok pos "fun" _ = CHSTokFun pos idkwtok pos "get" _ = CHSTokGet pos@@ -766,11 +776,13 @@ CHSTokAs pos -> mkid pos "as" CHSTokCall pos -> mkid pos "call" CHSTokClass pos -> mkid pos "class"+ CHSTokConst pos -> mkid pos "const" CHSTokContext pos -> mkid pos "context" CHSTokNonGNU pos -> mkid pos "nonGNU" CHSTokDerive pos -> mkid pos "deriving" CHSTokDown pos -> mkid pos "downcaseFirstLetter" CHSTokEnum pos -> mkid pos "enum"+ CHSTokFinal pos -> mkid pos "finalizer" CHSTokForeign pos -> mkid pos "foreign" CHSTokFun pos -> mkid pos "fun" CHSTokGet pos -> mkid pos "get"
src/C2HS/Gen/Bind.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} -- C->Haskell Compiler: binding generator -- -- Copyright (c) [1999..2003] Manuel M T Chakravarty@@ -194,10 +195,10 @@ -- 2. naked and newtype pointer hooks (False, Just (Pointer CHSPtr _)) -> Just (Left idIde, CHSValArg) -- 3. foreign pointer hooks- (False, Just (Pointer CHSForeignPtr False)) ->+ (False, Just (Pointer (CHSForeignPtr _) False)) -> Just (Left withForeignPtrIde, CHSIOArg) -- 4. foreign newtype pointer hooks- (False, Just (Pointer CHSForeignPtr True)) ->+ (False, Just (Pointer (CHSForeignPtr _) True)) -> Just (Right $ "with" ++ hsty, CHSIOArg) _ -> Nothing -- FIXME: handle array-list conversion@@ -228,22 +229,37 @@ lookupDftMarshOut hsty _ = do om <- readCT objmap isenum <- queryEnum hsty- return $ case (isenum, (internalIdent hsty) `lookup` om) of+ res <- case (isenum, (internalIdent hsty) `lookup` om) of -- 1. enumeration hooks- (True, Nothing) -> Just (Right "toEnum . fromIntegral", CHSValArg)+ (True, Nothing) -> return $ Just (Right "toEnum . fromIntegral", CHSValArg) -- 2. naked and newtype pointer hooks- (False, Just (Pointer CHSPtr _)) -> Just (Left idIde, CHSValArg)+ (False, Just (Pointer CHSPtr _)) -> return $ Just (Left idIde, CHSValArg) -- 3. foreign pointer hooks- (False, Just (Pointer CHSForeignPtr False)) ->- Just (Left newForeignPtrIde, CHSIOArg)+ (False, Just (Pointer (CHSForeignPtr Nothing) False)) ->+ return $ Just (Left newForeignPtr_Ide, CHSIOArg)+ (False, Just (Pointer (CHSForeignPtr (Just fin)) False)) -> do+ code <- newForeignPtrCode fin+ return $ Just (Right $ code, CHSIOArg) -- 4. foreign newtype pointer hooks- (False, Just (Pointer CHSForeignPtr True)) ->- Just (Right $ "newForeignPtr_ >=> (return . " ++ hsty ++ ")", CHSIOArg)- _ -> Nothing+ (False, Just (Pointer (CHSForeignPtr Nothing) True)) ->+ return $ Just (Right $ "newForeignPtr_ >=> (return . " +++ hsty ++ ")", CHSIOArg)+ (False, Just (Pointer (CHSForeignPtr (Just fin)) True)) -> do+ code <- newForeignPtrCode fin+ return $ Just (Right $ code ++ " >=> (return . " +++ hsty ++ ")", CHSIOArg)+ _ -> return Nothing+ return res -- FIXME: add combination, such as "peek" plus "cIntConv" etc -- FIXME: handle array-list conversion +newForeignPtrCode :: (Ident, Maybe Ident) -> GB String+newForeignPtrCode (cide, ohside) = do+ (_, cide') <- findFunObj cide True+ let fin = (identToString cide') `maybe` identToString $ ohside+ return $ "newForeignPtr " ++ fin + -- | check for integral Haskell types -- isIntegralHsType :: String -> Bool@@ -292,7 +308,7 @@ -- voidIde, cFromBoolIde, cToBoolIde, cIntConvIde, cFloatConvIde, withCStringIde, peekIde, peekCStringIde, idIde,- newForeignPtrIde, withForeignPtrIde :: Ident+ newForeignPtr_Ide, withForeignPtrIde :: Ident voidIde = internalIdent "void" -- never appears in the output cFromBoolIde = internalIdent "fromBool" cToBoolIde = internalIdent "toBool"@@ -302,7 +318,7 @@ peekIde = internalIdent "peek" peekCStringIde = internalIdent "peekCString" idIde = internalIdent "id"-newForeignPtrIde = internalIdent "newForeignPtr_"+newForeignPtr_Ide = internalIdent "newForeignPtr_" withForeignPtrIde = internalIdent "withForeignPtr" @@ -453,7 +469,7 @@ ++ show (padBits size) ++ "\n" expandHook (CHSEnumDefine _ _ _ _) _ = interr "Binding generation error : enum define hooks should be eliminated via preprocessing "-expandHook (CHSEnum cide oalias chsTrans oprefix orepprefix derive pos) _ =+expandHook (CHSEnum cide oalias chsTrans emit oprefix orepprefix derive pos) _ = do -- get the corresponding C declaration --@@ -472,7 +488,7 @@ let trans = transTabToTransFun pfx reppfx chsTrans hide = identToString . fromMaybe cide $ oalias- enumDef enum hide trans (map identToString derive) pos+ enumDef enum hide trans emit (map identToString derive) pos expandHook hook@(CHSCall isPure isUns (CHSRoot _ ide) oalias pos) _ = do traceEnter@@ -625,12 +641,13 @@ _ -> return offset SUType _ -> return offset checkType _ _ = offsetDerefErr pos-expandHook (CHSPointer isStar cName oalias ptrKind isNewtype oRefType emit- pos) _ =+expandHook hook@(CHSPointer isStar cName oalias ptrKind isNewtype oRefType emit+ pos) _ = do traceInfoPointer let hsIde = fromMaybe cName oalias hsName = identToString hsIde+ hsIde `objIs` Pointer ptrKind isNewtype -- register Haskell object -- -- we check for a typedef declaration or tag (struct, union, or enum)@@ -663,6 +680,7 @@ -- allow `... -> fun HSTYPE' to explicitly mark function -- types if this ever becomes important traceInfoHsType hsName hsType+ doFinalizer hook ptrKind (if isNewtype then hsName else "()") pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun emit Right tag -> do -- found a tag definition let cNameFull = tagName tag@@ -673,6 +691,7 @@ Nothing -> "()" Just hsType' -> identToString hsType' traceInfoHsType hsName hsType+ doFinalizer hook ptrKind (if isNewtype then hsName else "()") pointerDef isStar cNameFull hsName ptrKind isNewtype hsType False emit where -- remove a pointer level if the first argument is `False'@@ -715,6 +734,12 @@ return $ (identToString ide, identToString typeIde', ptr) : classes -- traceInfoClass = traceGenBind $ "** Class hook:\n"+expandHook (CHSConst cIde _) _ =+ do+ traceGenBind "** Constant hook:\n"+ Just (ObjCO cdecl) <- findObj cIde+ let (Just ini) = initDeclr cdecl+ return . show . pretty $ ini apathNewtypeName :: CHSAPath -> GB (Maybe Ident) apathNewtypeName path = do@@ -737,14 +762,16 @@ -- * the translation function strips prefixes where possible (different -- enumerators maye have different prefixes) ---enumDef :: CEnum -> String -> TransFun -> [String] -> Position -> GB String-enumDef (CEnum _ Nothing _ _) _ _ _ pos = undefEnumErr pos-enumDef (CEnum _ (Just list) _ _) hident trans userDerive _ =+enumDef :: CEnum -> String -> TransFun -> Bool -> [String] -> Position+ -> GB String+enumDef (CEnum _ Nothing _ _) _ _ _ _ pos = undefEnumErr pos+enumDef (CEnum _ (Just list) _ _) hident trans emit userDerive _ = do (list', enumAuto) <- evalTagVals list let enumVals = fixTags [(trans ide, cexpr) | (ide, cexpr) <- list'] defHead = enumHead hident defBody = enumBody (length defHead - 2) enumVals+ dataDef = if emit then defHead ++ defBody else "" inst = makeDerives (if enumAuto then "Enum" : userDerive else userDerive) ++ "\n" ++@@ -752,7 +779,7 @@ then "" else enumInst hident enumVals isEnum hident- return $ defHead ++ defBody ++ inst+ return $ dataDef ++ inst where evalTagVals = liftM (second and . unzip) . mapM (uncurry evalTag) evalTag ide Nothing = return ((ide, Nothing), True)@@ -792,6 +819,7 @@ fromInteger = cInteger (+) a b = cInteger (getCInteger a + getCInteger b) (*) a b = cInteger (getCInteger a * getCInteger b)+ (-) a b = cInteger (getCInteger a - getCInteger b) abs a = cInteger (abs $ getCInteger a) signum a = cInteger (signum $ getCInteger a) -- | Haskell code for an instance declaration for 'Enum'@@ -805,7 +833,7 @@ -- enumInst :: String -> [(String, Integer)] -> String enumInst ident list' = intercalate "\n"- [ "instance Enum " ++ ident ++ " where"+ [ "instance Enum " ++ wrap ident ++ " where" , succDef , predDef , enumFromToDef@@ -814,6 +842,7 @@ , toDef ] where+ wrap s = if ' ' `elem` s then "(" ++ s ++ ")" else s concatFor = flip concatMap -- List of _all values_ (including aliases) and their associated tags list = sortBy (comparing snd) list'@@ -1022,7 +1051,7 @@ let showComment str = if null str then ""- else " -- " ++ str ++ "\n"+ else " --" ++ str ++ "\n" ctxt = case octxt of Nothing -> "" Just ctxtStr -> ctxtStr ++ " => "@@ -1380,9 +1409,9 @@ ptrType = ptrCon ++ " (" ++ ptrArg ++ ")" thePtr = (isStar, cNameFull) case ptrKind of- CHSForeignPtr -> thePtr `ptrMapsTo` ("Ptr (" ++ ptrArg ++ ")",- "Ptr (" ++ ptrArg ++ ")")- _ -> thePtr `ptrMapsTo` (hsName, hsName)+ CHSForeignPtr _ -> thePtr `ptrMapsTo` ("Ptr (" ++ ptrArg ++ ")",+ "Ptr (" ++ ptrArg ++ ")")+ _ -> thePtr `ptrMapsTo` (hsName, hsName) return $ case (emit, isNewtype) of (False, _) -> "" -- suppress code generation@@ -1396,11 +1425,43 @@ -- safe unwrapping function automatically -- withForeignFun- | ptrKind == CHSForeignPtr =+ | isForeign ptrKind = "\nwith" ++ hsName ++ " :: " ++ hsName ++ " -> (Ptr " ++ hsName ++ " -> IO b) -> IO b" ++ "\nwith" ++ hsName ++ " (" ++ hsName ++ " fptr) = withForeignPtr fptr" | otherwise = ""+ isForeign (CHSForeignPtr _) = True+ isForeign _ = False++-- | generate a foreign pointer finalizer import declaration that is+-- put into the delayed code+--+doFinalizer :: CHSHook -> CHSPtrType -> String -> GB ()+doFinalizer hook (CHSForeignPtr (Just (cide, ohside))) ptrHsIde = do+ (ObjCO cdecl, cide') <- findFunObj cide True+ let finCIde = identToString cide'+ finHsIde = finCIde `maybe` identToString $ ohside+ cdecl' = cide' `simplifyDecl` cdecl+ header <- getSwitch headerSB+ delayCode hook (finalizerImport (extractCallingConvention cdecl')+ header finCIde finHsIde ptrHsIde)+ traceFunType ptrHsIde+ where+ traceFunType et = traceGenBind $+ "Imported finalizer function type: " ++ et ++ "\n"+doFinalizer _ _ _ = return ()++-- | Haskell code for the foreign import declaration needed by foreign+-- pointer finalizers.+--+finalizerImport :: CallingConvention -> String -> String -> String ->+ String -> String+finalizerImport cconv header ident hsIdent hsPtrName =+ "foreign import " ++ showCallingConvention cconv ++ " " ++ show entity +++ "\n " ++ hsIdent ++ " :: FinalizerPtr " ++ hsPtrName ++ "\n"+ where+ entity | null header = "&" ++ ident+ | otherwise = header ++ " &" ++ ident -- | generate the class and instance definitions for a class hook --
src/C2HS/Gen/Header.hs view
@@ -166,30 +166,60 @@ ghFrag (frag@(CHSVerb _ _ ) : frags) = return (DL.empty, Frag frag, frags) --- generate an enum __c2hs__enum__'id { __c2hs_enr__'id = DEF1, ... } and then process an--- ordinary enum directive-ghFrag (_frag@(CHSHook (CHSEnumDefine hsident trans instances pos) hkpos) : frags) =+-- generate an+-- enum __c2hs__enum__'id { __c2hs_enr__'id = DEF1, ... }+-- and then process an ordinary enum directive+ghFrag (_frag@(CHSHook (CHSEnumDefine hsident trans+ instances pos) hkpos) : frags) = do ide <- newEnumIdent (enrs,trans') <- createEnumerators trans- return (DL.fromList [show.pretty $ enumDef ide enrs,";\n"], Frag (enumFrag (identToString ide) trans'), frags)+ return (DL.fromList [show.pretty $ enumDef ide enrs,";\n"],+ Frag (enumFrag (identToString ide) trans'), frags) where- newEnumIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs_enum__" ++ show (nameId $ head supply))- newEnrIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs_enr__" ++ show (nameId $ head supply))+ newEnumIdent = liftM internalIdent $ transCST $+ \supply -> (tail supply, "__c2hs_enum__" +++ show (nameId $ head supply))+ newEnrIdent = liftM internalIdent $ transCST $+ \supply -> (tail supply, "__c2hs_enr__" +++ show (nameId $ head supply)) createEnumerators (CHSTrans isUnderscore changeCase aliases)- | isUnderscore = raiseErrorGHExc pos ["underScoreToCase is meaningless for `enum define' hooks"]- | changeCase /= CHSSameCase = raiseErrorGHExc pos ["changing case is meaningless for `enum define' hooks"]+ | isUnderscore =+ raiseErrorGHExc pos ["underScoreToCase is meaningless " +++ "for `enum define' hooks"]+ | changeCase /= CHSSameCase =+ raiseErrorGHExc pos ["changing case is meaningless " +++ "for `enum define' hooks"] | otherwise = do (enrs,transtbl') <- liftM unzip (mapM createEnumerator aliases) return (enrs,CHSTrans False CHSSameCase transtbl')- createEnumerator (cid,hsid) = liftM (\enr -> ((enr,cid),(enr,hsid))) newEnrIdent+ createEnumerator (cid,hsid) =+ liftM (\enr -> ((enr,cid),(enr,hsid))) newEnrIdent enumDef ide enrs = CEnum (Just ide) (Just$ map mkEnr enrs) [] undefNode where mkEnr (name,value) = (name, Just $ CVar value undefNode)- enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident) trans' Nothing Nothing instances pos) hkpos+ enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident)+ trans' True Nothing Nothing+ instances pos) hkpos -ghFrag (frag@(CHSHook _ _) : frags) =- return (DL.empty, Frag frag, frags)-ghFrag (frag@(CHSLine _ ) : frags) =- return (DL.empty, Frag frag, frags)+ghFrag (_frag@(CHSHook (CHSConst cident pos) hkpos) : frags) =+ do ide <- newConstIdent+ return (DL.fromList [show.pretty $ constDef ide,";\n"],+ Frag (CHSHook (CHSConst ide pos) hkpos), frags)+ where+ newConstIdent =+ liftM internalIdent $ transCST $+ \supply -> (tail supply, "c2hs__const__" ++ show (nameId $ head supply))+ constDef ide =+ -- This is a little nasty. We write a definition of an *integer*+ -- C value into the header, regardless of what type it really+ -- is...+ CDecl [CTypeSpec (CIntType undefNode)]+ [(Just (CDeclr (Just ide) [] Nothing [] undefNode),+ Just (CInitExpr (CVar cident undefNode) undefNode),+ Nothing)]+ undefNode++ghFrag (frag@(CHSHook _ _) : frags) = return (DL.empty, Frag frag, frags)+ghFrag (frag@(CHSLine _ ) : frags) = return (DL.empty, Frag frag, frags) ghFrag ( (CHSC s _ ) : frags) = do (header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment
src/C2HS/Gen/Monad.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} -- C->Haskell Compiler: monad for the binding generator -- -- Author : Manuel M T Chakravarty@@ -77,13 +78,13 @@ ) where -- standard libraries-import Data.Char (toUpper, toLower, isSpace)+import Data.Char (toUpper, toLower) import Data.List (find) import Data.Maybe (fromMaybe) import qualified Data.Map as Map (empty, insert, lookup, union, toList, fromList) import Data.Map (Map) import Data.Set (Set)-import qualified Data.Set as Set (empty, insert, member)+import qualified Data.Set as Set (empty, insert, member, union, toList, fromList) -- Language.C import Language.C.Data.Position@@ -236,7 +237,7 @@ goChop level ('(':rest) = goChop (level+1) rest goChop level (')':rest) = goChop (level-1) rest goChop level (_ :rest) = goChop level rest- goChop level [] = []+ goChop _ [] = [] extractIdent :: String -> (Ident, String) extractIdent str =@@ -338,6 +339,10 @@ && ide == ide' -> return frags' | otherwise -> err (posOf ide) (posOf ide') Nothing -> return $ frags' ++ [newEntry]+ delay hook'@(CHSPointer _ _ _ _ _ _ _ _) frags' =+ case find (\(hook'', _) -> hook'' == hook') frags' of+ Just (CHSPointer _ _ _ _ _ _ _ _, _) -> return frags'+ Nothing -> return $ frags' ++ [newEntry] delay _ _ = interr "GBMonad.delayCode: Illegal delay!" --@@ -420,14 +425,21 @@ mergeMaps str = transCT (\state -> (state { ptrmap = Map.union readPtrMap (ptrmap state),- objmap = Map.union readObjMap (objmap state)+ objmap = Map.union readObjMap (objmap state),+ enums = Set.union readEnumSet (enums state) }, ())) where- (ptrAssoc, objAssoc) = read str+ -- Deal with variant interface file formats (old .chi files don't+ -- contain the list of enumerations).+ (ptrAssoc, objAssoc, enumList) =+ case reads str of+ [] -> let (ptr, obj) = read str in (ptr, obj, [])+ [(r, "")] -> r readPtrMap = Map.fromList [((isStar, internalIdent ide), repr) | ((isStar, ide), repr) <- ptrAssoc] readObjMap = Map.fromList [(internalIdent ide, obj) | (ide, obj) <- objAssoc]+ readEnumSet = Set.fromList enumList -- | convert the whole pointer and Haskell object maps into printable form --@@ -435,10 +447,12 @@ dumpMaps = do ptrFM <- readCT ptrmap objFM <- readCT objmap+ enumS <- readCT enums let dumpable = ([((isStar, identToString ide), repr) | ((isStar, ide), repr) <- Map.toList ptrFM], [(identToString ide, obj)- | (ide, obj) <- Map.toList objFM])+ | (ide, obj) <- Map.toList objFM],+ Set.toList enumS) return $ show dumpable -- | query the enum map
src/Main.hs view
@@ -574,11 +574,7 @@ if hasNonGNU chsMod then [ "-U__GNUC__" , "-U__GNUC_MINOR__"- , "-U__GNUC_PATCHLEVEL__"- , "-D__AVAILIBILITY__"- , "-D__OSX_AVAILABLE_STARTING(a,b)"- , "-D__OSX_AVAILABLE_BUT_DEPRECATED(a,b,c,d)"- , "-D__OSX_AVAILABLE_BUT_DEPRECATED_MSG(a,b,c,d,e)" ]+ , "-U__GNUC_PATCHLEVEL__" ] else [] [versMajor, versMinor, versRev] = map show $ DV.versionBranch versnum versionOpt = [ "-DC2HS_MIN_VERSION(mj,mn,rv)=" ++
+ tests/bugs/issue-103/Issue103.chs view
@@ -0,0 +1,14 @@+module Main where++import Foreign.C.Types++#include "issue103.h"+{#import Issue103A#}++{#fun unsafe test_func as ^ { `TestEnum' } -> `()' #}++main :: IO ()+main = do+ testFunc E1+ testFunc E2+ testFunc E3
+ tests/bugs/issue-103/Issue103A.chs view
@@ -0,0 +1,7 @@+module Issue103A where++import Foreign.C.Types++#include "issue103.h"++{#enum test_enum as TestEnum {underscoreToCase} #}
+ tests/bugs/issue-103/issue103.c view
@@ -0,0 +1,11 @@+#include "issue103.h"+#include <stdio.h>++void test_func(test_enum val)+{+ switch (val) {+ case E_1: printf("1\n"); return;+ case E_2: printf("2\n"); return;+ case E_3: printf("3\n"); return;+ }+}
+ tests/bugs/issue-103/issue103.h view
@@ -0,0 +1,7 @@+typedef enum {+ E_1,+ E_2,+ E_3+} test_enum;++void test_func(test_enum val);
tests/bugs/issue-107/Issue107.chs view
@@ -1,7 +1,7 @@ module Main where check :: Bool-#if (C2HS_MIN_VERSION(0,18,2))+#if (C2HS_MIN_VERSION(0,19,1)) check = True #else check = False
+ tests/bugs/issue-65/Issue65.chs view
@@ -0,0 +1,15 @@+module Main where++#include "issue65.h"++const1 :: Int+const1 = {#const CONST1#}++const2 :: Double+const2 = {#const CONST2#}++const3 :: String+const3 = {#const CONST3#}++main :: IO ()+main = print const1 >> print const2 >> print const3
+ tests/bugs/issue-65/issue65.c view
+ tests/bugs/issue-65/issue65.h view
@@ -0,0 +1,3 @@+#define CONST1 123+#define CONST2 3.14+#define CONST3 "hello"
+ tests/bugs/issue-70/Issue70.chs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+module Foo where++#include "issue70.h"++class Flux a where+ data FluxCode a+ gigawattsNeeded :: a -> Double+ gigawattsNeeded _ = 1.21++data Capacitor = Capacitor Int++instance Flux Capacitor where+ -- associated data type decl+ data FluxCode Capacitor = Bar | Baz | Qux | Xyzzy++-- Note: must be able to define longer names here, I've used single quotes.+-- underscoreToCase still works, it aliases the C identifiers for the instance.+-- XYZZY_THUD is manually aliased.+-- nocode suppresses emitting a data declaration.+{# enum Foo as 'FluxCode Capacitor' nocode { underscoreToCase,+ XYZZY_THUD as Xyzzy } #}
+ tests/bugs/issue-70/issue70.c view
+ tests/bugs/issue-70/issue70.h view
@@ -0,0 +1,6 @@+enum Foo {+ BAR,+ BAZ,+ QUX = 5,+ XYZZY_THUD+};
+ tests/bugs/issue-73/Issue73.chs view
@@ -0,0 +1,71 @@+module Main where++import Control.Monad+import Foreign+import Foreign.C++#include "issue73.h"++-- * withForeignPtr and newForeignPtr_ for foreign pointer hooks++{#pointer *test_struct3 as TestForeign1Ptr foreign#}+{#fun make_struct3 as foreign1MakeStruct {} -> `TestForeign1Ptr'#}+{#fun access_struct3 as foreign1Access {`TestForeign1Ptr'} -> `Int'#}++foreign1 :: IO ()+foreign1 = do+ foreignPtr <- foreign1MakeStruct+ foreignVal <- foreign1Access foreignPtr+ putStrLn $ "Foreign pointer: " ++ show foreignVal+++{#pointer *test_struct3 as TestForeign2Ptr foreign finalizer free_struct3#}+{#fun make_struct3 as foreign2MakeStruct {} -> `TestForeign2Ptr'#}+{#fun access_struct3 as foreign2Access {`TestForeign2Ptr'} -> `Int'#}++foreign2 :: IO ()+foreign2 = do+ foreignPtr <- foreign2MakeStruct+ foreignVal <- foreign2Access foreignPtr+ putStrLn $ "Foreign pointer: " ++ show foreignVal+++-- * withPointerType (the generated function) and+-- PointerType . newForeignPtr_ for foreign newtype pointer+-- hooks. The out marshaller is not great here, a !ForeignPtr with+-- no finalizers is not terribly useful concealed inside the+-- newtype. Perhaps foreign newtype should be left naked, or+-- furnished with an 'in' default marshaller only.++{#pointer *test_struct4 as TestForeignNt1Ptr foreign newtype#}+{#fun make_struct4 as foreignNt1MakeStruct {} -> `TestForeignNt1Ptr'#}+{#fun access_struct4 as foreignNt1Access {`TestForeignNt1Ptr'} -> `Int'#}++foreignNt1 :: IO ()+foreignNt1 = do+ foreignNtPtr <- foreignNt1MakeStruct+ foreignNtVal <- foreignNt1Access foreignNtPtr+ putStrLn $ "Foreign newtype pointer: " ++ show foreignNtVal+ return ()+++{#pointer *test_struct4 as TestForeignNt2Ptr+ foreign finalizer free_struct4 newtype#}+{#fun make_struct4 as foreignNt2MakeStruct {} -> `TestForeignNt2Ptr'#}+{#fun access_struct4 as foreignNt2Access {`TestForeignNt2Ptr'} -> `Int'#}++foreignNt2 :: IO ()+foreignNt2 = do+ foreignNtPtr <- foreignNt2MakeStruct+ foreignNtVal <- foreignNt2Access foreignNtPtr+ putStrLn $ "Foreign newtype pointer: " ++ show foreignNtVal+ return ()+++main :: IO ()+main = do+ foreign1+ foreign2+ foreignNt1+ foreignNt2+ return ()
+ tests/bugs/issue-73/issue73.c view
@@ -0,0 +1,34 @@+#include <stdio.h>+#include <stdlib.h>+#include "issue73.h"++test_struct3 *make_struct3(void)+{+ test_struct3 *tmp = (test_struct3 *)(malloc(sizeof(test_struct3)));+ tmp->c = 3;+ printf("Allocated struct3\n");+ return tmp;+}++int access_struct3(test_struct3 *s) { return s->c; }++void free_struct3(test_struct3 *s) {+ printf("Freeing struct3\n");+ free(s);+}+++test_struct4 *make_struct4(void)+{+ test_struct4 *tmp = (test_struct4 *)(malloc(sizeof(test_struct4)));+ tmp->d = 4;+ printf("Allocated struct4\n");+ return tmp;+}++int access_struct4(test_struct4 *s) { return s->d; }++void free_struct4(test_struct4 *s) {+ printf("Freeing struct4\n");+ free(s);+}
+ tests/bugs/issue-73/issue73.h view
@@ -0,0 +1,9 @@+typedef struct { int c; } test_struct3;+test_struct3 *make_struct3(void);+void free_struct3(test_struct3 *v);+int access_struct3(test_struct3 *);++typedef struct { int d; } test_struct4;+test_struct4 *make_struct4(void);+void free_struct4(test_struct4 *v);+int access_struct4(test_struct4 *);
+ tests/bugs/issue-97/Issue97.chs view
@@ -0,0 +1,16 @@+-- Main.chs+{-# LANGUAGE ForeignFunctionInterface #-}+module Main where++{#import Issue97A#}+import Foreign+import Foreign.C.Types++#include "issue97.h"++{#fun pure foo_x as fooX { `FooPtr' } -> `Int' #}++main :: IO ()+main = allocaBytes {#sizeof foo_t #} $ \fooPtr -> do+ {#set foo_t.x #} fooPtr 42+ print $ fooX fooPtr
+ tests/bugs/issue-97/Issue97A.chs view
@@ -0,0 +1,13 @@+-- Foo.chs+{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-}+module Issue97A (+ Foo+ , FooPtr+ ) where++import Foreign++#include "issue97.h"++data Foo+{#pointer *foo_t as FooPtr -> Foo #}
+ tests/bugs/issue-97/issue97.c view
@@ -0,0 +1,6 @@+/* foo.c */+#include "issue97.h"++int foo_x(foo_t *f) {+ return f->x;+}
+ tests/bugs/issue-97/issue97.h view
@@ -0,0 +1,12 @@+/* foo.h */+#ifndef FOO_H+#define FOO_H++typedef struct {+ int x;+ int y;+} foo_t;++int foo_x(foo_t *f);++#endif
tests/test-bugs.hs view
@@ -8,6 +8,7 @@ import Prelude hiding (FilePath) import Control.Monad.IO.Class import Shelly+import Data.List (sort) import Data.Text (Text) import Data.Monoid import qualified Data.Text as T@@ -28,33 +29,38 @@ tests = [ testGroup "Bugs" [ testCase "call_capital (issue #??)" call_capital- , testCase "Issue #107" issue107- , testCase "Issue #96" issue96- , testCase "Issue #95" issue95- , testCase "Issue #93" issue93- , testCase "Issue #80" issue80- , testCase "Issue #79" issue79- , testCase "Issue #75" issue75- , testCase "Issue #69" issue69- , testCase "Issue #62" issue62- , testCase "Issue #60" issue60- , testCase "Issue #51" issue51- , testCase "Issue #47" issue47- , testCase "Issue #31" issue31- , testCase "Issue #30" issue30- , testCase "Issue #23" issue23+ , testCase "Issue #7" issue7+-- , testCase "Issue #10" issue10+ , testCase "Issue #16" issue16+ , testCase "Issue #19" issue19 , testCase "Issue #22" issue22- , testCase "Issue #54" issue54- , testCase "Issue #45" issue45- , testCase "Issue #44" issue44- , testCase "Issue #43" issue43+ , testCase "Issue #23" issue23+ , testCase "Issue #29" issue29+ , testCase "Issue #30" issue30+ , testCase "Issue #31" issue31 , testCase "Issue #32" issue32 , testCase "Issue #38" issue38- , testCase "Issue #29" issue29- , testCase "Issue #19" issue19- , testCase "Issue #16" issue16--- , testCase "Issue #10" issue10- , testCase "Issue #7" issue7+ , testCase "Issue #43" issue43+ , testCase "Issue #44" issue44+ , testCase "Issue #45" issue45+ , testCase "Issue #47" issue47+ , testCase "Issue #51" issue51+ , testCase "Issue #54" issue54+ , testCase "Issue #60" issue60+ , testCase "Issue #62" issue62+ , testCase "Issue #65" issue65+ , testCase "Issue #69" issue69+ , testCase "Issue #70" issue70+ , testCase "Issue #73" issue73+ , testCase "Issue #75" issue75+ , testCase "Issue #79" issue79+ , testCase "Issue #80" issue80+ , testCase "Issue #93" issue93+ , testCase "Issue #95" issue95+ , testCase "Issue #96" issue96+ , testCase "Issue #97" issue97+ , testCase "Issue #103" issue103+ , testCase "Issue #107" issue107 ] ] @@ -72,6 +78,32 @@ issue107 :: Assertion issue107 = hs_only_expect_issue 107 ["True"] +issue103 :: Assertion+issue103 = c2hsShelly $ chdir "tests/bugs/issue-103" $ do+ mapM_ rm_f ["Issue103.hs", "Issue103.chs.h", "Issue103.chi",+ "Issue103A.hs", "Issue103A.chs.h", "Issue103A.chi",+ "issue103_c.o", "Issue103"]+ cmd "c2hs" "Issue103A.chs"+ cmd "c2hs" "Issue103.chs"+ cmd "cc" "-c" "-o" "issue103_c.o" "issue103.c"+ cmd "ghc" "--make" "issue103_c.o" "Issue103A.hs" "Issue103.hs"+ res <- absPath "./Issue103" >>= cmd+ let expected = ["1", "2", "3"]+ liftIO $ assertBool "" (T.lines res == expected)++issue97 :: Assertion+issue97 = c2hsShelly $ chdir "tests/bugs/issue-97" $ do+ mapM_ rm_f ["Issue97.hs", "Issue97.chs.h", "Issue97.chi",+ "Issue97A.hs", "Issue97A.chs.h", "Issue97A.chi",+ "issue97_c.o", "Issue97"]+ cmd "c2hs" "Issue97A.chs"+ cmd "c2hs" "Issue97.chs"+ cmd "cc" "-c" "-o" "issue97_c.o" "issue97.c"+ cmd "ghc" "--make" "issue97_c.o" "Issue97A.hs" "Issue97.hs"+ res <- absPath "./Issue97" >>= cmd+ let expected = ["42"]+ liftIO $ assertBool "" (T.lines res == expected)+ issue96 :: Assertion issue96 = build_issue 96 @@ -90,9 +122,27 @@ issue75 :: Assertion issue75 = build_issue 75 +issue73 :: Assertion+issue73 = unordered_expect_issue 73 [ "Allocated struct3"+ , "Foreign pointer: 3"+ , "Allocated struct3"+ , "Foreign pointer: 3"+ , "Allocated struct4"+ , "Foreign newtype pointer: 4"+ , "Allocated struct4"+ , "Foreign newtype pointer: 4"+ , "Freeing struct3"+ , "Freeing struct4" ]++issue70 :: Assertion+issue70 = build_issue 70+ issue69 :: Assertion issue69 = build_issue 69 +issue65 :: Assertion+issue65 = expect_issue 65 ["123", "3.14", "\"hello\""]+ issue62 :: Assertion issue62 = build_issue 62 @@ -106,8 +156,8 @@ issue51 :: Assertion issue51 = do- expect_issue_with True 51 "nonGNU" [] ["0"]- expect_issue_with True 51 "GNU" [] ["1"]+ expect_issue_with True True 51 "nonGNU" [] ["0"]+ expect_issue_with True True 51 "GNU" [] ["1"] issue47 :: Assertion issue47 = build_issue 47@@ -211,17 +261,24 @@ else cmd "ghc" "-Wall" "-Werror" "--make" (uc <.> "hs") expect_issue :: Int -> [Text] -> Assertion-expect_issue n expected = expect_issue_with True n "" [] expected+expect_issue n expected = expect_issue_with True True n "" [] expected +unordered_expect_issue :: Int -> [Text] -> Assertion+unordered_expect_issue n expected =+ expect_issue_with False True n "" [] expected+ hs_only_expect_issue :: Int -> [Text] -> Assertion-hs_only_expect_issue n expected = expect_issue_with False n "" [] expected+hs_only_expect_issue n expected = expect_issue_with True False n "" [] expected -expect_issue_with :: Bool -> Int -> String -> [Text] -> [Text] -> Assertion-expect_issue_with cbuild n ext c2hsargs expected = c2hsShelly $ do+expect_issue_with :: Bool -> Bool -> Int -> String -> [Text] -> [Text]+ -> Assertion+expect_issue_with ordered cbuild n ext c2hsargs expected = c2hsShelly $ do do_issue_build cbuild n ext c2hsargs res <- absPath ("." </> (fromText $ T.pack $ "Issue" <> show n <> (if ext == "" then "" else "_" <> ext))) >>= cmd- liftIO $ assertBool "" (T.lines res == expected)+ liftIO $ assertBool "" $ case ordered of+ True -> T.lines res == expected+ False -> sort (T.lines res) == sort expected build_issue_with :: Int -> [Text] -> Assertion build_issue_with n c2hsargs = c2hsShelly $ do