c2hs 0.20.1 → 0.21.1
raw patch · 23 files changed
+438/−94 lines, 23 files
Files
- ChangeLog +9/−0
- c2hs.cabal +9/−4
- src/C2HS/C/Trav.hs +17/−4
- src/C2HS/CHS.hs +53/−18
- src/C2HS/CHS/Lexer.hs +11/−2
- src/C2HS/Gen/Bind.hs +102/−44
- src/C2HS/Gen/Header.hs +2/−2
- src/C2HS/Gen/Monad.hs +34/−13
- src/C2HS/Version.hs +1/−1
- tests/bugs/issue-115/Issue115.chs +19/−0
- tests/bugs/issue-115/issue115.c +19/−0
- tests/bugs/issue-115/issue115.h +8/−0
- tests/bugs/issue-116/Issue116.chs +14/−0
- tests/bugs/issue-116/issue116.c +0/−0
- tests/bugs/issue-116/issue116.h +6/−0
- tests/bugs/issue-36/Issue36.chs +16/−0
- tests/bugs/issue-36/issue36.h +2/−0
- tests/bugs/issue-46/Issue46.chs +19/−0
- tests/bugs/issue-46/issue46.c +17/−0
- tests/bugs/issue-46/issue46.h +9/−0
- tests/bugs/issue-83/Issue83.chs +33/−0
- tests/regression-suite.hs +11/−2
- tests/test-bugs.hs +27/−4
ChangeLog view
@@ -1,3 +1,12 @@+0.21.1+ - Parametrized pointer types in pointer hooks [#36]+ - Special "+" parameters for efficient foreign pointer marshalling [#46]+ - Add default marshallers for C types [#83]+ - Fix treatment of arrays within structs [#115]+ - Add ability to omit given enum values [#116]+ - Regression suite tidy-ups++ 0.20.1 - Get CUDA Travis tests working again (hopefully...) - Modify approach for defining C2HS_MIN_VERSION macro to work with
c2hs.cabal view
@@ -1,5 +1,5 @@ Name: c2hs-Version: 0.20.1+Version: 0.21.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -50,11 +50,13 @@ tests/bugs/issue-30/*.chs tests/bugs/issue-30/*.h tests/bugs/issue-30/*.c tests/bugs/issue-31/*.chs tests/bugs/issue-31/*.h tests/bugs/issue-31/*.c tests/bugs/issue-32/*.chs tests/bugs/issue-32/*.h tests/bugs/issue-32/*.c+ tests/bugs/issue-36/*.chs tests/bugs/issue-36/*.h tests/bugs/issue-37/*.chs tests/bugs/issue-37/*.h tests/bugs/issue-37/*.c tests/bugs/issue-38/*.chs tests/bugs/issue-38/*.h tests/bugs/issue-38/*.c tests/bugs/issue-43/*.chs tests/bugs/issue-43/*.h tests/bugs/issue-43/*.c tests/bugs/issue-44/*.chs tests/bugs/issue-44/*.h tests/bugs/issue-44/*.c tests/bugs/issue-45/*.chs tests/bugs/issue-45/*.h tests/bugs/issue-45/*.c+ tests/bugs/issue-46/*.chs tests/bugs/issue-46/*.h tests/bugs/issue-46/*.c tests/bugs/issue-47/*.chs tests/bugs/issue-47/*.h tests/bugs/issue-47/*.c tests/bugs/issue-51/*.chs tests/bugs/issue-51/*.h tests/bugs/issue-51/*.c tests/bugs/issue-54/*.chs tests/bugs/issue-54/*.h tests/bugs/issue-54/*.c@@ -67,6 +69,7 @@ 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-83/*.chs 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@@ -74,6 +77,8 @@ tests/bugs/issue-103/*.chs tests/bugs/issue-103/*.h tests/bugs/issue-103/*.c tests/bugs/issue-107/*.chs tests/bugs/issue-113/*.chs tests/bugs/issue-113/*.h tests/bugs/issue-113/*.c+ tests/bugs/issue-115/*.chs tests/bugs/issue-115/*.h tests/bugs/issue-115/*.c+ tests/bugs/issue-116/*.chs tests/bugs/issue-116/*.h tests/bugs/issue-116/*.c source-repository head type: git@@ -152,14 +157,14 @@ text, transformers -Flag travis- description: Enable regression suite build for Travis-CI.+Flag regression+ description: Enable regression suite build. default: False Executable regression-suite main-is: regression-suite.hs hs-source-dirs: tests- if flag(travis)+ if flag(regression) build-depends: base, filepath, shelly >= 1.0,
src/C2HS/C/Trav.hs view
@@ -71,10 +71,10 @@ -- isTypedef, simplifyDecl, declrFromDecl, declrNamed, declaredDeclr, initDeclr, declaredName, structMembers, expandDecl,- structName, enumName, tagName, isPtrDeclr, dropPtrDeclr,- isPtrDecl, isFunDeclr, structFromDecl, funResultAndArgs,- chaseDecl, findAndChaseDecl, findAndChaseDeclOrTag,- checkForAlias, checkForOneCUName,+ structName, enumName, tagName, isPtrDeclr, isArrDeclr,+ dropPtrDeclr, isPtrDecl, isArrDecl, isFunDeclr, structFromDecl,+ funResultAndArgs, chaseDecl, findAndChaseDecl,+ findAndChaseDeclOrTag, checkForAlias, checkForOneCUName, checkForOneAliasName, lookupEnum, lookupStructUnion, lookupDeclOrTag) where@@ -537,6 +537,13 @@ isPtrDeclr (CDeclr _ (CArrDeclr _ _ _:_) _ _ _) = True isPtrDeclr _ = False +-- | Need to distinguish between pointer and array declarations within+-- structures.+--+isArrDeclr :: CDeclr -> Bool+isArrDeclr (CDeclr _ (CArrDeclr _ _ _:_) _ _ _) = True+isArrDeclr _ = False+ -- | drops the first pointer level from the given declarator -- -- * the declarator must declare a pointer object@@ -563,6 +570,12 @@ isPtrDecl (CDecl _ [(Just declr, _, _)] _) = isPtrDeclr declr isPtrDecl _ = interr "CTrav.isPtrDecl: There was more than one declarator!"++isArrDecl :: CDecl -> Bool+isArrDecl (CDecl _ [] _) = False+isArrDecl (CDecl _ [(Just declr, _, _)] _) = isArrDeclr declr+isArrDecl _ =+ interr "CTrav.isArrDecl: There was more than one declarator!" -- | checks whether the given declarator defines a function object --
src/C2HS/CHS.hs view
@@ -69,13 +69,15 @@ -- prefix -> `prefix' `=' string [`add' `prefix' `=' string] -- deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)' -- parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm--- parm -> [ident_or_quot_1 [`*' | `-']] verbhs [`&'] [ident_or_quot_2 [`*'] [`-']]+-- parm -> `+'+-- | [ident_or_quot_1 [`*' | `-']] verbhs [`&'] [ident_or_quot_2 [`*'] [`-']] -- ident_or_quot -> ident | quoths -- apath -> ident -- | `*' apath -- | apath `.' ident -- | apath `->' ident--- trans -> `{' alias_1 `,' ... `,' alias_n `}'+-- trans -> `{' alias_1 `,' ... `,' alias_n `}' [omit]+-- omit -> `omit' `(' ident_1 `,' ... `,' ident_n `)' -- alias -> `underscoreToCase' | `upcaseFirstLetter' -- | `downcaseFirstLetter' -- | ident `as' ident@@ -122,6 +124,7 @@ -- friends import C2HS.CHS.Lexer (CHSToken(..), lexCHS, keywordToIdent) + -- CHS abstract syntax -- ------------------- @@ -235,7 +238,7 @@ (Maybe Ident) -- Haskell name CHSPtrType -- Ptr, ForeignPtr or StablePtr Bool -- create new type?- (Maybe Ident) -- Haskell type pointed to+ [Ident] -- Haskell type pointed to Bool -- emit type decl? Position | CHSClass (Maybe Ident) -- superclass@@ -302,6 +305,7 @@ data CHSTrans = CHSTrans Bool -- underscore to case? CHSChangeCase -- upcase or downcase? [(Ident, Ident)] -- alias list+ [Ident] -- omit list data CHSChangeCase = CHSSameCase | CHSUpCase@@ -315,7 +319,8 @@ -- | marshalling descriptor for function hooks ---data CHSParm = CHSParm CHSMarsh -- "in" marshaller+data CHSParm = CHSPlusParm -- special "+" parameter+ | CHSParm CHSMarsh -- "in" marshaller String -- Haskell type Bool -- C repr: two values? CHSMarsh -- "out" marshaller@@ -542,7 +547,7 @@ . showPrefix oprefix True . showReplacementPrefix oreplprefix . if null derive then id else showString $- "deriving ("+ " deriving (" ++ concat (intersperse ", " (map identToString derive)) ++ ") " showCHSHook (CHSEnumDefine ide trans derive _) =@@ -550,7 +555,7 @@ . showCHSIdent ide . showCHSTrans trans . if null derive then id else showString $- "deriving ("+ " deriving (" ++ concat (intersperse ", " (map identToString derive)) ++ ") " showCHSHook (CHSCall isPure isUns ide oalias _) =@@ -590,8 +595,10 @@ _ -> showString "") . (case (isNewtype, oRefType) of (True , _ ) -> showString " newtype"- (False, Just ide') -> showString " -> " . showCHSIdent ide'- (False, Nothing ) -> showString "")+ (False, [] ) -> showString ""+ (False, ides) -> showString " -> " .+ foldr (.) id (intersperse (showString " ")+ (map showCHSIdent ides))) . (case emit of True -> showString "" False -> showString " nocode")@@ -637,6 +644,7 @@ Just ide -> showString " as " . showCHSIdent ide) showCHSParm :: CHSParm -> ShowS+showCHSParm CHSPlusParm = showChar '+' showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh _ comment) = showOMarsh oimMarsh . showChar ' '@@ -664,12 +672,17 @@ else showString "--" . showString str . showChar '\n' showCHSTrans :: CHSTrans -> ShowS-showCHSTrans (CHSTrans _2Case chgCase assocs) =- showString "{"+showCHSTrans (CHSTrans _2Case chgCase assocs omit) =+ showString " {" . (if _2Case then showString ("underscoreToCase" ++ maybeComma) else id) . showCHSChangeCase chgCase . foldr (.) id (intersperse (showString ", ") (map showAssoc assocs)) . showString "}"+ . (if not (null omit)+ then showString " omit (" .+ foldr (.) id (intersperse (showString ", ") (map showCHSIdent omit)) .+ showString ")"+ else id) where maybeComma = if null assocs then "" else ", " --@@ -1145,6 +1158,7 @@ apathRootIdent (CHSRef apath _) = apathRootIdent apath parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken])+parseParm (CHSTokPlus _:toks') = return (CHSPlusParm, toks') parseParm toks = do (oimMarsh, toks' ) <- parseOptMarsh toks@@ -1208,8 +1222,7 @@ return $ CHSHook (CHSOffsetof path pos) hkpos : frags parsePointer :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]-parsePointer hkpos pos toks =- do+parsePointer hkpos pos toks = do (isStar, ide, toks') <- case toks of CHSTokStar _:CHSTokIdent _ ide:toks' -> return (True , ide, toks')@@ -1220,9 +1233,16 @@ let (isNewtype, oRefType, toks'4) = case toks'3 of- CHSTokNewtype _ :toks'' -> (True , Nothing , toks'' )- CHSTokArrow _:CHSTokIdent _ ide':toks'' -> (False, Just ide', toks'' )- _ -> (False, Nothing , toks'3)+ CHSTokNewtype _ :toks'' -> (True , [] , toks'' )+ CHSTokArrow _:CHSTokIdent _ ide':toks'' ->+ let (ides, toks''') = span isIde toks''+ isIde (CHSTokIdent _ _) = True+ isIde _ = False+ takeId (CHSTokIdent _ i) = i+ in (False, ide':map takeId ides, toks''')+ CHSTokArrow _:CHSTokHSVerb _ hs:toks'' ->+ (False, map internalIdent $ words hs, toks'')+ _ -> (False, [] , toks'3) let (emit, toks'5) = case toks'4 of@@ -1233,7 +1253,8 @@ return $ CHSHook (CHSPointer- isStar ide (norm ide oalias) ptrType isNewtype oRefType emit pos) hkpos+ isStar ide (norm ide oalias) ptrType isNewtype+ oRefType emit pos) hkpos : frags where parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken])@@ -1399,7 +1420,9 @@ do (_2Case, chgCase, toks' ) <- parse_2CaseAndChange toks case toks' of- (CHSTokRBrace _:toks'2) -> return (CHSTrans _2Case chgCase [], toks'2)+ (CHSTokRBrace _:toks'2) -> do+ (omits, toks'3) <- parseOmits toks'2+ return (CHSTrans _2Case chgCase [] omits, toks'3) _ -> do -- if there was no `underscoreToCase', we add a comma token to meet@@ -1408,7 +1431,8 @@ (transs, toks'2) <- if (_2Case || chgCase /= CHSSameCase) then parseTranss toks' else parseTranss (CHSTokComma nopos:toks')- return (CHSTrans _2Case chgCase transs, toks'2)+ (omits, toks'3) <- parseOmits toks'2+ return (CHSTrans _2Case chgCase transs omits, toks'3) where parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokUpper _:toks') = return (True, CHSUpCase, toks')@@ -1433,6 +1457,17 @@ (trans, toks'3) <- parseTranss toks'2 return (assoc:trans, toks'3) parseTranss toks' = syntaxError toks'+ --+ parseOmits (CHSTokOmit _:CHSTokLParen _:CHSTokIdent _ omit:toks') = do+ (omits, toks'2) <- parseOmits1 toks'+ return (omit:omits, toks'2)+ parseOmits toks' = return ([], toks')+ --+ parseOmits1 (CHSTokRParen _:toks') = return ([], toks')+ parseOmits1 (CHSTokComma _:CHSTokIdent _ omit:toks') = do+ (omits, toks'2) <- parseOmits1 toks'+ return (omit:omits, toks'2)+ parseOmits1 toks' = syntaxError toks' -- parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks') = return ((ide1, ide2), toks')
src/C2HS/CHS/Lexer.hs view
@@ -94,9 +94,9 @@ -- | `newtype' | `nocode' | `pointer' | `prefix' | `pure' -- | `set' | `sizeof' | `stable' | `struct' | `type' -- | `underscoreToCase' | `upcaseFirstLetter' | `unsafe' |--- | `with' | `const'+-- | `with' | `const' | `omit' -- reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `='--- | `=>' | '-' | `*' | `&' | `^'+-- | `=>' | '-' | `*' | `&' | `^' | `+' -- string -> `"' instr* `"' -- verbhs -> `\`' inhsverb* `\'' -- quoths -> `\'' inhsverb* `\''@@ -201,6 +201,7 @@ | CHSTokStar Position -- `*' | CHSTokAmp Position -- `&' | CHSTokHat Position -- `^'+ | CHSTokPlus Position -- `+' | CHSTokLBrace Position -- `{' | CHSTokRBrace Position -- `}' | CHSTokLParen Position -- `('@@ -226,6 +227,7 @@ | CHSTokNewtype Position -- `newtype' | CHSTokNocode Position -- `nocode' | CHSTokOffsetof Position -- `offsetof'+ | CHSTokOmit Position -- `omit' | CHSTokPointer Position -- `pointer' | CHSTokPrefix Position -- `prefix' | CHSTokPure Position -- `pure'@@ -287,6 +289,7 @@ posOf (CHSTokNewtype pos ) = pos posOf (CHSTokNocode pos ) = pos posOf (CHSTokOffsetof pos ) = pos+ posOf (CHSTokOmit pos ) = pos posOf (CHSTokPointer pos ) = pos posOf (CHSTokPrefix pos ) = pos posOf (CHSTokPure pos ) = pos@@ -348,6 +351,7 @@ (CHSTokNewtype _ ) == (CHSTokNewtype _ ) = True (CHSTokNocode _ ) == (CHSTokNocode _ ) = True (CHSTokOffsetof _ ) == (CHSTokOffsetof _ ) = True+ (CHSTokOmit _ ) == (CHSTokOmit _ ) = True (CHSTokPointer _ ) == (CHSTokPointer _ ) = True (CHSTokPrefix _ ) == (CHSTokPrefix _ ) = True (CHSTokPure _ ) == (CHSTokPure _ ) = True@@ -385,6 +389,7 @@ showsPrec _ (CHSTokStar _ ) = showString "*" showsPrec _ (CHSTokAmp _ ) = showString "&" showsPrec _ (CHSTokHat _ ) = showString "^"+ showsPrec _ (CHSTokPlus _ ) = showString "+" showsPrec _ (CHSTokLBrace _ ) = showString "{" showsPrec _ (CHSTokRBrace _ ) = showString "}" showsPrec _ (CHSTokLParen _ ) = showString "("@@ -410,6 +415,7 @@ showsPrec _ (CHSTokNewtype _ ) = showString "newtype" showsPrec _ (CHSTokNocode _ ) = showString "nocode" showsPrec _ (CHSTokOffsetof _ ) = showString "offsetof"+ showsPrec _ (CHSTokOmit _ ) = showString "omit" showsPrec _ (CHSTokPointer _ ) = showString "pointer" showsPrec _ (CHSTokPrefix _ ) = showString "prefix" showsPrec _ (CHSTokPure _ ) = showString "pure"@@ -759,6 +765,7 @@ idkwtok pos "newtype" _ = CHSTokNewtype pos idkwtok pos "nocode" _ = CHSTokNocode pos idkwtok pos "offsetof" _ = CHSTokOffsetof pos+ idkwtok pos "omit" _ = CHSTokOmit pos idkwtok pos "pointer" _ = CHSTokPointer pos idkwtok pos "prefix" _ = CHSTokPrefix pos idkwtok pos "pure" _ = CHSTokPure pos@@ -800,6 +807,7 @@ CHSTokNewtype pos -> mkid pos "newtype" CHSTokNocode pos -> mkid pos "nocode" CHSTokOffsetof pos -> mkid pos "offsetof"+ CHSTokOmit pos -> mkid pos "omit" CHSTokPointer pos -> mkid pos "pointer" CHSTokPrefix pos -> mkid pos "prefix" CHSTokPure pos -> mkid pos "pure"@@ -829,6 +837,7 @@ >||< sym "*" CHSTokStar >||< sym "&" CHSTokAmp >||< sym "^" CHSTokHat+ >||< sym "+" CHSTokPlus >||< sym "{" CHSTokLBrace >||< sym "}" CHSTokRBrace >||< sym "(" CHSTokLParen
src/C2HS/Gen/Bind.hs view
@@ -115,7 +115,7 @@ import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.Bits ((.|.), (.&.)) import Control.Arrow (second)-import Control.Monad (when, unless, liftM, mapAndUnzipM)+import Control.Monad (when, unless, liftM, mapAndUnzipM, zipWithM) import Data.Ord (comparing) -- Language.C / compiler toolkit@@ -141,8 +141,8 @@ GBState(..), initialGBState, setContext, getPrefix, getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,- queryClass, queryPointer, mergeMaps, dumpMaps,- queryEnum, isEnum)+ sizeIs, querySize, queryClass, queryPointer,+ mergeMaps, dumpMaps, queryEnum, isEnum) -- default marshallers@@ -171,6 +171,8 @@ return $ Just (Left cFloatConvIde, CHSValArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] = return $ Just (Left withCStringIde, CHSIOArg)+lookupDftMarshIn "CString" [PtrET (PrimET CCharPT)] =+ return $ Just (Right "flip ($)", CHSIOArg) lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt = return $ Just (Right stringIn , CHSIOArg)@@ -219,6 +221,8 @@ return $ Just (Left cFloatConvIde, CHSValArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] = return $ Just (Left peekCStringIde, CHSIOArg)+lookupDftMarshOut "CString" [PtrET (PrimET CCharPT)] =+ return $ Just (Left returnIde, CHSIOArg) lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt] | isIntegralCPrimType pt = return $ Just (Right "\\(s, n) -> peekCStringLen (s, fromIntegral n)",@@ -263,23 +267,31 @@ -- | check for integral Haskell types -- isIntegralHsType :: String -> Bool-isIntegralHsType "Int" = True-isIntegralHsType "Int8" = True-isIntegralHsType "Int16" = True-isIntegralHsType "Int32" = True-isIntegralHsType "Int64" = True-isIntegralHsType "Word8" = True-isIntegralHsType "Word16" = True-isIntegralHsType "Word32" = True-isIntegralHsType "Word64" = True-isIntegralHsType _ = False+isIntegralHsType "Int" = True+isIntegralHsType "Int8" = True+isIntegralHsType "Int16" = True+isIntegralHsType "Int32" = True+isIntegralHsType "Int64" = True+isIntegralHsType "Word8" = True+isIntegralHsType "Word16" = True+isIntegralHsType "Word32" = True+isIntegralHsType "Word64" = True+isIntegralHsType "CShort" = True+isIntegralHsType "CUShort" = True+isIntegralHsType "CInt" = True+isIntegralHsType "CUInt" = True+isIntegralHsType "CLong" = True+isIntegralHsType "CULong" = True+isIntegralHsType _ = False -- | check for floating Haskell types -- isFloatHsType :: String -> Bool-isFloatHsType "Float" = True-isFloatHsType "Double" = True-isFloatHsType _ = False+isFloatHsType "Float" = True+isFloatHsType "Double" = True+isFloatHsType "CFloat" = True+isFloatHsType "CDouble" = True+isFloatHsType _ = False isVariadic :: ExtType -> Bool isVariadic (FunET s t) = any isVariadic [s,t]@@ -308,7 +320,7 @@ -- voidIde, cFromBoolIde, cToBoolIde, cIntConvIde, cFloatConvIde, withCStringIde, peekIde, peekCStringIde, idIde,- newForeignPtr_Ide, withForeignPtrIde :: Ident+ newForeignPtr_Ide, withForeignPtrIde, returnIde :: Ident voidIde = internalIdent "void" -- never appears in the output cFromBoolIde = internalIdent "fromBool" cToBoolIde = internalIdent "toBool"@@ -320,6 +332,7 @@ idIde = internalIdent "id" newForeignPtr_Ide = internalIdent "newForeignPtr_" withForeignPtrIde = internalIdent "withForeignPtr"+returnIde = internalIdent "return" -- expansion of binding hooks@@ -516,7 +529,7 @@ _ -> funPtrExpectedErr pos traceValueType ty- set_get <- setGet pos CHSGet offsets ptrTy Nothing+ set_get <- setGet pos CHSGet offsets False ptrTy Nothing -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used@@ -585,7 +598,7 @@ callHook = CHSCall isPure isUns apath (Just fiIde) pos callImportDyn callHook isPure isUns ideLexeme fiLexeme decl ty pos - set_get <- setGet pos CHSGet offsets ptrTy Nothing+ set_get <- setGet pos CHSGet offsets False ptrTy Nothing funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) ctxt parms parm (Just set_get) pos hkpos where@@ -609,7 +622,7 @@ traceDepth offsets ty <- extractSimpleType False pos decl traceValueType ty- setGet pos access offsets ty onewtype+ setGet pos access offsets (isArrDecl decl) ty onewtype where accessString = case access of CHSGet -> "Get"@@ -649,6 +662,9 @@ hsName = identToString hsIde hsIde `objIs` Pointer ptrKind isNewtype -- register Haskell object+ decl <- findAndChaseDeclOrTag cName False True+ (size, _) <- sizeAlignOf decl+ hsIde `sizeIs` (padBits size) -- -- we check for a typedef declaration or tag (struct, union, or enum) --@@ -666,7 +682,7 @@ ptrExpectedErr (posOf cName) (hsType, isFun) <- case oRefType of- Nothing -> do+ [] -> do cDecl <- chaseDecl cNameFull (not isStar) et <- extractPtrType cDecl traceInfoPtrType et@@ -674,7 +690,7 @@ when (isVariadic et') (variadicErr pos (posOf cDecl)) return (showExtType et', isFunExtType et')- Just hsType -> return (identToString hsType, False)+ hsType -> return (identsToString hsType, False) -- FIXME: it is not possible to determine whether `hsType' -- is a function; we would need to extend the syntax to -- allow `... -> fun HSTYPE' to explicitly mark function@@ -688,8 +704,8 @@ unless isStar $ -- tags need an explicit `*' ptrExpectedErr (posOf cName) let hsType = case oRefType of- Nothing -> "()"- Just hsType' -> identToString hsType'+ [] -> "()"+ hsType' -> identsToString hsType' traceInfoHsType hsName hsType doFinalizer hook ptrKind (if isNewtype then hsName else "()") pointerDef isStar cNameFull hsName ptrKind isNewtype hsType False emit@@ -711,6 +727,9 @@ ++ "\n" traceInfoCName kind ide = traceGenBind $ "found C " ++ kind ++ " for `" ++ identToString ide ++ "'\n"+ identsToString :: [Ident] -> String+ identsToString = intercalate " " . map identToString+ expandHook (CHSClass oclassIde classIde typeIde pos) _ = do traceInfoClass@@ -768,7 +787,8 @@ enumDef (CEnum _ (Just list) _ _) hident trans emit userDerive _ = do (list', enumAuto) <- evalTagVals list- let enumVals = fixTags [(trans ide, cexpr) | (ide, cexpr) <- list']+ let enumVals = map (\(Just i, e) -> (i, e)) $ filter (isJust . fst) $+ fixTags [(trans ide, cexpr) | (ide, cexpr) <- list'] defHead = enumHead hident defBody = enumBody (length defHead - 2) enumVals dataDef = if emit then defHead ++ defBody else ""@@ -978,14 +998,16 @@ -> Position -- source location of the hook -> Position -- source location of the start of the hook -> GB String -- Haskell code in text form-funDef isPure hsLexeme fiLexeme extTy octxt parms parm marsh2 pos hkpos =+funDef isPure hsLexeme fiLexeme extTy octxt parms+ parm@(CHSParm _ hsParmTy _ _ _ _) marsh2 pos hkpos = do+ when (countPlus parms > 1 || isPlus parm) $ illegalPlusErr pos (parms', parm', isImpure) <- addDftMarshaller pos parms parm extTy traceMarsh parms' parm' isImpure+ marshs <- zipWithM marshArg [1..] parms' let sig = hsLexeme ++ " :: " ++ funTy parms' parm' ++ "\n"- marshs = [marshArg i parm'' | (i, parm'') <- zip [1..] parms'] funArgs = [funArg | (funArg, _, _, _, _) <- marshs, funArg /= ""] marshIns = [marshIn | (_, marshIn, _, _, _) <- marshs] callArgs = [callArg | (_, _, cs, _, _) <- marshs, callArg <- cs]@@ -997,7 +1019,9 @@ then " let {res = " ++ fiLexeme ++ joinCallArgs ++ "} in\n" else " " ++ fiLexeme ++ joinCallArgs ++ case parm of CHSParm _ "()" _ Nothing _ _ -> " >>\n"- _ -> " >>= \\res ->\n"+ _ ->+ if countPlus parms == 1+ then " >>\n" else " >>= \\res ->\n" joinCallArgs = case marsh2 of Nothing -> join callArgs Just _ -> join ("b1'" : drop 1 callArgs)@@ -1006,7 +1030,9 @@ Just m -> " " ++ m ++ " " ++ join (take 1 callArgs) ++ " >>= \\b1' ->\n"- marshRes = case parm' of+ marshRes = if countPlus parms == 1+ then ""+ else case parm' of CHSParm _ _ _twoCVal (Just (_ , CHSVoidArg )) _ _ -> "" CHSParm _ _ _twoCVal (Just (omBody, CHSIOVoidArg)) _ _ -> " " ++ marshBody omBody ++ " res >> \n"@@ -1023,7 +1049,8 @@ retArgs' = case parm' of CHSParm _ _ _ (Just (_, CHSVoidArg)) _ _ -> retArgs CHSParm _ _ _ (Just (_, CHSIOVoidArg)) _ _ -> retArgs- _ -> "res'":retArgs+ _ ->+ if countPlus parms == 0 then "res'":retArgs else retArgs ret = "(" ++ concat (intersperse ", " retArgs') ++ ")" funBody = joinLines marshIns ++ mkMarsh2 ++@@ -1039,6 +1066,10 @@ return $ pad $ sig ++ funHead ++ funBody where+ countPlus :: [CHSParm] -> Int+ countPlus = sum . map (\p -> if isPlus p then 1 else 0)+ isPlus CHSPlusParm = True+ isPlus _ = False join = concatMap (' ':) joinLines = concatMap (\s -> " " ++ s ++ "\n") --@@ -1081,7 +1112,7 @@ -- code fragments -- marshArg i (CHSParm (Just (imBody, imArgKind)) _ twoCVal- (Just (omBody, omArgKind)) _ _ ) =+ (Just (omBody, omArgKind)) _ _ ) = do let a = "a" ++ show (i :: Int) imStr = marshBody imBody@@ -1106,12 +1137,25 @@ CHSIOArg -> omApp ++ ">>= \\" ++ outBndr ++ " -> " CHSValArg -> "let {" ++ outBndr ++ " = " ++ omApp ++ "} in "- retArg = if omArgKind == CHSVoidArg || omArgKind == CHSIOVoidArg then "" else outBndr+ retArg = if omArgKind == CHSVoidArg || omArgKind == CHSIOVoidArg+ then "" else outBndr marshBody (Left ide) = identToString ide marshBody (Right str) = "(" ++ str ++ ")"- in- (funArg, marshIn, callArgs, marshOut, retArg)+ return (funArg, marshIn, callArgs, marshOut, retArg)+ marshArg i CHSPlusParm = do+ msize <- querySize $ internalIdent hsParmTy+ case msize of+ Nothing -> interr "Missing size for \"+\" parameter allocation!"+ Just size -> do+ let a = "a" ++ show (i :: Int)+ bdr1 = a ++ "'"+ bdr2 = a ++ "''"+ marshIn = "mallocForeignPtrBytes " ++ show size +++ " >>= \\" ++ bdr2 +++ " -> withForeignPtr " ++ bdr2 ++ " $ \\" +++ bdr1 ++ " -> "+ return ("", marshIn, [bdr1], "", hsParmTy ++ " " ++ bdr2) marshArg _ _ = interr "GenBind.funDef: Missing default?" -- traceMarsh parms' parm' isImpure = traceGenBind $@@ -1158,6 +1202,9 @@ -- -- match Haskell with C arguments (and results) --+ addDft ((CHSPlusParm):parms'') (_:cTys) = do+ (parms', _) <- addDft parms'' cTys+ return (CHSPlusParm : parms', True) addDft ((CHSParm imMarsh hsTy False omMarsh p c):parms'') (cTy :cTys) = do (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy] (omMarsh', isImpureOut) <- addDftVoid omMarsh@@ -1315,9 +1362,9 @@ -- | Haskell code for writing to or reading from a struct ---setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> Maybe Ident+setGet :: Position -> CHSAccess -> [BitSize] -> Bool -> ExtType -> Maybe Ident -> GB String-setGet pos access offsets ty onewtype =+setGet pos access offsets isArr ty onewtype = do let pre = case (access, onewtype) of (CHSSet, Nothing) -> "(\\ptr val -> do {"@@ -1335,15 +1382,15 @@ bf <- checkType ty case bf of Nothing -> return $ case access of -- not a bitfield- CHSGet -> peekOp offset tyTag- CHSSet -> pokeOp offset tyTag "val"+ CHSGet -> peekOp offset tyTag isArr+ CHSSet -> pokeOp offset tyTag "val" isArr --FIXME: must take `bitfieldDirection' into account Just (_, bs) -> return $ case access of -- a bitfield- CHSGet -> "val <- " ++ peekOp offset tyTag+ CHSGet -> "val <- " ++ peekOp offset tyTag isArr ++ extractBitfield- CHSSet -> "org <- " ++ peekOp offset tyTag+ CHSSet -> "org <- " ++ peekOp offset tyTag isArr ++ insertBitfield- ++ pokeOp offset tyTag "val'"+ ++ pokeOp offset tyTag "val'" isArr where -- we have to be careful here to ensure proper sign extension; -- in particular, shifting right followed by anding a mask is@@ -1382,9 +1429,13 @@ checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs) checkType _ = return Nothing --- peekOp off tyTag = "peekByteOff ptr " ++ show off ++ " ::IO " ++ tyTag- pokeOp off tyTag var = "pokeByteOff ptr " ++ show off ++ " (" ++ var- ++ "::" ++ tyTag ++ ")"+ peekOp off tyTag False =+ "peekByteOff ptr " ++ show off ++ " ::IO " ++ tyTag+ peekOp off tyTag True =+ "return $ ptr `plusPtr` " ++ show off ++ " ::IO " ++ tyTag+ pokeOp off tyTag var False =+ "pokeByteOff ptr " ++ show off ++ " (" ++ var ++ "::" ++ tyTag ++ ")"+ pokeOp _ tyTag var True = "poke ptr (" ++ var ++ "::" ++ tyTag ++ ")" -- | generate the type definition for a pointer hook and enter the required type -- mapping into the 'ptrmap'@@ -2394,6 +2445,13 @@ ["Variadic function!", "Calling variadic functions is not supported by the FFI; the function", "is defined at " ++ show cpos ++ "."]++illegalPlusErr :: Position -> GB a+illegalPlusErr pos =+ raiseErrorCTExc pos+ ["Illegal plus parameter!",+ "The special parameter `+' may only be used in a single input " +++ "parameter position in a function hook"] illegalConstExprErr :: Position -> String -> GB a illegalConstExprErr cpos hint =
src/C2HS/Gen/Header.hs view
@@ -182,7 +182,7 @@ newEnrIdent = liftM internalIdent $ transCST $ \supply -> (tail supply, "__c2hs_enr__" ++ show (nameId $ head supply))- createEnumerators (CHSTrans isUnderscore changeCase aliases)+ createEnumerators (CHSTrans isUnderscore changeCase aliases omits) | isUnderscore = raiseErrorGHExc pos ["underScoreToCase is meaningless " ++ "for `enum define' hooks"]@@ -191,7 +191,7 @@ "for `enum define' hooks"] | otherwise = do (enrs,transtbl') <- liftM unzip (mapM createEnumerator aliases)- return (enrs,CHSTrans False CHSSameCase transtbl')+ return (enrs,CHSTrans False CHSSameCase transtbl' omits) createEnumerator (cid,hsid) = liftM (\enr -> ((enr,cid),(enr,hsid))) newEnrIdent enumDef ide enrs = CEnum (Just ide) (Just$ map mkEnr enrs) [] undefNode
src/C2HS/Gen/Monad.hs view
@@ -73,8 +73,8 @@ HsObject(..), GB, GBState(..), initialGBState, setContext, getLibrary, getPrefix, getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr,- objIs, queryObj, queryClass, queryPointer, mergeMaps, dumpMaps,- queryEnum, isEnum+ objIs, queryObj, sizeIs, querySize, queryClass, queryPointer,+ mergeMaps, dumpMaps, queryEnum, isEnum ) where -- standard libraries@@ -105,7 +105,7 @@ -- | takes an identifier to a lexeme including a potential mapping by a -- translation table ---type TransFun = Ident -> String+type TransFun = Ident -> Maybe String -- | translation function for the 'underscoreToCase' flag --@@ -145,16 +145,18 @@ -- beginning of this file -- transTabToTransFun :: String -> String -> CHSTrans -> TransFun-transTabToTransFun prefx rprefx (CHSTrans _2Case chgCase table) =- \ide -> let- caseTrafo = (if _2Case then underscoreToCase else id) .- (case chgCase of- CHSSameCase -> id- CHSUpCase -> upcaseFirstLetter- CHSDownCase -> downcaseFirstLetter)- lexeme = identToString ide- dft = caseTrafo lexeme -- default uses case trafo- in+transTabToTransFun prefx rprefx (CHSTrans _2Case chgCase table omits) =+ \ide ->+ let caseTrafo = (if _2Case then underscoreToCase else id) .+ (case chgCase of+ CHSSameCase -> id+ CHSUpCase -> upcaseFirstLetter+ CHSDownCase -> downcaseFirstLetter)+ lexeme = identToString ide+ dft = caseTrafo lexeme -- default uses case trafo+ in if ide `elem` omits+ then Nothing+ else Just $ case lookup ide table of -- lookup original ident Just ide' -> identToString ide' -- original ident matches Nothing ->@@ -214,6 +216,8 @@ deriving (Show, Read) type HsObjectMap = Map Ident HsObject +type SizeMap = Map Ident Int+ -- | set of Haskell type names corresponding to C enums. type EnumSet = Set String @@ -274,6 +278,7 @@ frags :: [(CHSHook, CHSFrag)], -- delayed code (with hooks) ptrmap :: PointerMap, -- pointer representation objmap :: HsObjectMap, -- generated Haskell objects+ szmap :: SizeMap, -- object sizes enums :: EnumSet -- enumeration hooks } @@ -287,6 +292,7 @@ frags = [], ptrmap = Map.empty, objmap = Map.empty,+ szmap = Map.empty, enums = Set.empty } @@ -382,6 +388,21 @@ queryObj hsName = do fm <- readCT objmap return $ Map.lookup hsName fm++-- | add an entry to the size map+--+sizeIs :: Ident -> Int -> GB ()+hsName `sizeIs` sz =+ transCT (\state -> (state {+ szmap = Map.insert hsName sz (szmap state)+ }, ()))++-- | query the size map+--+querySize :: Ident -> GB (Maybe Int)+querySize hsName = do+ sm <- readCT szmap+ return $ Map.lookup hsName sm -- | query the Haskell object map for a class --
src/C2HS/Version.hs view
@@ -9,7 +9,7 @@ name = "C->Haskell Compiler" versnum = Paths_c2hs.version-versnick = "The shapeless maps"+versnick = "Snowbound" date = "31 Oct 2014" version = name ++ ", version " ++ showVersion versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) 1999-2007 Manuel M T Chakravarty\n"
+ tests/bugs/issue-115/Issue115.chs view
@@ -0,0 +1,19 @@+module Main where++import Foreign+import Foreign.C++#include "issue115.h"++{#pointer *array_t as MyStruct#}++{#fun get_struct {`Int', `Int', `Int'} -> `MyStruct' return* #}++main :: IO ()+main = do+ myStruct <- get_struct 7 42 93+ p <- {#get array_t->p#} myStruct >>= peekArray 3+ print p+ -- The following line produces a segmentation fault+ a <- {#get array_t->a#} myStruct >>= peekArray 3+ print a
+ tests/bugs/issue-115/issue115.c view
@@ -0,0 +1,19 @@+#include "issue115.h"++array_t myStruct;+int other_a[3];++array_t *get_struct(int n, int m, int o)+{+ myStruct.a[0] = n;+ myStruct.a[1] = m;+ myStruct.a[2] = o;++ other_a[0] = n + 1;+ other_a[1] = m + 1;+ other_a[2] = o + 1;++ myStruct.p = other_a;++ return &myStruct;+}
+ tests/bugs/issue-115/issue115.h view
@@ -0,0 +1,8 @@+#pragma once++typedef struct {+ int a[3]; /* An array of length 3. */+ int *p; /* A pointer to an array. */+} array_t;++array_t *get_struct(int n, int m, int o);
+ tests/bugs/issue-116/Issue116.chs view
@@ -0,0 +1,14 @@+module Main where++#include "issue116.h"++{#enum test_enum as TestEnum {underscoreToCase} omit (TOTAL_ENUM_COUNT)+ deriving (Eq, Show)#}++-- Force name overlap: causes compilation failure if "omit" in enum+-- hook doesn't work.+data Check = TotalEnumCount+ | Dummy++main :: IO ()+main = print (fromEnum E1, fromEnum E2, fromEnum E3)
+ tests/bugs/issue-116/issue116.c view
+ tests/bugs/issue-116/issue116.h view
@@ -0,0 +1,6 @@+typedef enum {+ E_1,+ E_2,+ E_3,+ TOTAL_ENUM_COUNT+} test_enum;
+ tests/bugs/issue-36/Issue36.chs view
@@ -0,0 +1,16 @@+module Main where++import Foreign++#include "issue36.h"++data Hit1 a = Hit1 a+data Hit2 a b = Hit2 a b++{#pointer *hit_int as HitEg1 -> Hit1 Int#}+{#pointer *hit_double as HitEg2 -> Hit1 Double#}+{#pointer *hit_int as HitEg3 -> `Hit2 Int ()'#}+{#pointer *hit_double as HitEg4 -> `Hit2 Double [Int]'#}++main :: IO ()+main = return ()
+ tests/bugs/issue-36/issue36.h view
@@ -0,0 +1,2 @@+typedef struct { int a; } hit_int;+typedef struct { double a; } hit_double;
+ tests/bugs/issue-46/Issue46.chs view
@@ -0,0 +1,19 @@+module Main where++import Foreign+import Foreign.C.Types++#include "issue46.h"++{#pointer *oid as Oid foreign newtype#}++{#fun func as ^ {+, `Int', `Float'} -> `Oid'#}+{#fun oid_a as ^ {`Oid'} -> `Int'#}+{#fun oid_b as ^ {`Oid'} -> `Float'#}++main :: IO ()+main = do+ obj <- func 1 2.5+ a <- oidA obj+ b <- oidB obj+ print (a, b)
+ tests/bugs/issue-46/issue46.c view
@@ -0,0 +1,17 @@+#include "issue46.h"++void func(oid *obj, int aval, float bval)+{+ obj->a = aval;+ obj->b = bval;+}++int oid_a(oid *obj)+{+ return obj->a;+}++float oid_b(oid *obj)+{+ return obj->b;+}
+ tests/bugs/issue-46/issue46.h view
@@ -0,0 +1,9 @@+typedef struct {+ int a;+ float b;+ char dummy;+} oid;++void func(oid *obj, int aval, float bval);+int oid_a(oid *obj);+float oid_b(oid *obj);
+ tests/bugs/issue-83/Issue83.chs view
@@ -0,0 +1,33 @@+module Main where++import Control.Monad+import Foreign.Ptr+import Foreign.C.String+import Foreign.C.Types++#include <string.h>+#include <stdlib.h>+#include <math.h>++-- This is for testing marshalling of C... types, e.g. CInt, etc.+{#fun strcmp as ^ {`CString', `CString'} -> `CInt'#}+{#fun setenv as ^ {`String', `String', `Int'} -> `Int'#}+{#fun getenv as ^ {`String'} -> `CString'#}+{#fun sin as hsin {`Double'} -> `Double'#}+{#fun sin as csin {`CDouble'} -> `CDouble'#}++main :: IO ()+main = do+ let s1 = "abc" ; s2 = "def" ; s3 = "def"+ res1 <- withCString s1 $ \cs1 ->+ withCString s2 $ \cs2 -> strcmp cs1 cs2+ res2 <- withCString s2 $ \cs2 ->+ withCString s3 $ \cs3 -> strcmp cs2 cs3+ print (res1, res2)+ void $ setenv "TEST_VAR" "TEST_VAL" 1+ h <- getenv "TEST_VAR"+ peekCString h >>= putStrLn+ cx <- csin 1.0+ print (round (10000 * cx) :: Integer)+ hx <- hsin 1.0+ print (round (10000 * hx) :: Integer)
tests/regression-suite.hs view
@@ -23,6 +23,7 @@ , cabalBuildTools :: [Text] , specialSetup :: [Text] , extraPath :: [Text]+ , onTravis :: Bool } deriving (Eq, Show) instance FromJSON RegressionTest where@@ -34,6 +35,7 @@ <*> v .:? "cabal-build-tools" .!= [] <*> v .:? "special-setup" .!= [] <*> v .:? "extra-path" .!= []+ <*> v .:? "on-travis" .!= True parseJSON _ = mzero readTests :: FilePath -> IO [RegressionTest]@@ -55,7 +57,11 @@ exit 0 when travis checkApt- tests <- liftIO $ readTests "tests/regression-suite.yaml"+ let travisCheck t = case travis of+ False -> True+ True -> onTravis t+ tests <- liftIO $ filter travisCheck <$>+ readTests "tests/regression-suite.yaml" let ppas = nub $ concatMap aptPPA tests pkgs = nub $ concatMap aptPackages tests buildTools = nub $ concatMap cabalBuildTools tests@@ -107,7 +113,10 @@ if all (== 0) codes then exit 0- else errorExit "SOME TESTS FAILED"+ else do+ let failed = filter (\(c, _) -> c /= 0) $ zip codes (filter cabal tests)+ forM_ failed $ \(c, t) -> echo $ "FAILED: " <> name t+ echo "SOME TESTS FAILED" escapedWords :: Text -> [Text] escapedWords = map (T.pack . reverse) . escWords False "" . T.unpack
tests/test-bugs.hs view
@@ -39,10 +39,12 @@ , testCase "Issue #30" issue30 , testCase "Issue #31" issue31 , testCase "Issue #32" issue32+ , testCase "Issue #36" issue36 , testCase "Issue #38" issue38 , testCase "Issue #43" issue43 , testCase "Issue #44" issue44 , testCase "Issue #45" issue45+ , testCase "Issue #46" issue46 , testCase "Issue #47" issue47 , testCase "Issue #51" issue51 , testCase "Issue #54" issue54@@ -55,6 +57,7 @@ , testCase "Issue #75" issue75 , testCase "Issue #79" issue79 , testCase "Issue #80" issue80+ , testCase "Issue #83" issue83 , testCase "Issue #93" issue93 , testCase "Issue #95" issue95 , testCase "Issue #96" issue96@@ -62,6 +65,8 @@ , testCase "Issue #103" issue103 , testCase "Issue #107" issue107 , testCase "Issue #113" issue113+ , testCase "Issue #115" issue115+ , testCase "Issue #116" issue116 ] ] @@ -76,6 +81,12 @@ let expected = ["upper C();", "lower c();", "upper C();"] liftIO $ assertBool "" (T.lines res == expected) +issue116 :: Assertion+issue116 = build_issue 116++issue115 :: Assertion+issue115 = expect_issue 115 ["[8,43,94]", "[7,42,93]"]+ issue113 :: Assertion issue113 = build_issue 113 @@ -117,6 +128,9 @@ issue93 :: Assertion issue93 = build_issue 93 +issue83 :: Assertion+issue83 = hs_only_expect_issue 83 ["(-3,0)", "TEST_VAL", "8415", "8415"]+ issue80 :: Assertion issue80 = build_issue 80 @@ -166,6 +180,9 @@ issue47 :: Assertion issue47 = build_issue 47 +issue46 :: Assertion+issue46 = expect_issue 46 ["(1,2.5)"]+ issue45 :: Assertion issue45 = build_issue 45 @@ -179,6 +196,9 @@ issue38 :: Assertion issue38 = expect_issue 38 ["Enum OK"] +issue36 :: Assertion+issue36 = hs_only_build_issue 36+ issue32 :: Assertion issue32 = expect_issue 32 ["1234", "1", "523"] @@ -284,11 +304,14 @@ 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- errExit False $ do_issue_build True n "" c2hsargs+build_issue_with :: Bool -> Int -> [Text] -> Assertion+build_issue_with cbuild n c2hsargs = c2hsShelly $ do+ errExit False $ do_issue_build cbuild n "" c2hsargs code <- lastExitCode liftIO $ assertBool "" (code == 0) build_issue :: Int -> Assertion-build_issue n = build_issue_with n []+build_issue n = build_issue_with True n []++hs_only_build_issue :: Int -> Assertion+hs_only_build_issue n = build_issue_with False n []