c2hs 0.17.2 → 0.18.1
raw patch · 21 files changed
+592/−362 lines, 21 filesdep +dlistdep +transformersdep ~basedep ~language-cnew-component:exe:regression-suite
Dependencies added: dlist, transformers
Dependency ranges changed: base, language-c
Files
- ChangeLog +29/−0
- c2hs.cabal +9/−8
- src/C2HS/C/Trav.hs +32/−9
- src/C2HS/CHS.hs +105/−19
- src/C2HS/CHS/Lexer.hs +28/−11
- src/C2HS/Gen/Bind.hs +175/−120
- src/C2HS/Gen/Header.hs +19/−19
- src/C2HS/Gen/Monad.hs +27/−9
- src/C2HS/Version.hs +2/−2
- src/Control/StateBase.hs +9/−0
- src/Control/StateTrans.hs +10/−0
- src/Data/DLists.hs +0/−66
- src/Main.hs +33/−56
- src/System/CIO.hs +8/−4
- src/Text/Lexers.hs +3/−3
- tests/bugs/issue-51/Issue51.chs +0/−15
- tests/bugs/issue-51/Issue51_GNU.chs +15/−0
- tests/bugs/issue-51/Issue51_nonGNU.chs +16/−0
- tests/regression-suite.hs +7/−1
- tests/test-bugs.hs +52/−18
- tests/test-system.hs +13/−2
ChangeLog view
@@ -1,3 +1,32 @@+0.18.1+ - Numerous improvements to Enum handling [#78] (Philipp Balzarek:+ @Philonous)+ - Handle Haddock comments within C2HS hook definitions [#62] (@tangboyun)+ - Better error messages for missing files (Zejun Wu: @watashi)+ - Write CHS dump files to output directory (Zejun Wu: @watashi)+ - Handle C calling conventions within function pointer declarations [#88]+ (Michael Steele: @mikesteele81)+ - Fix FreeBSD libssh2 problem [#87] (Cindy Wang: @CindyLinz)+ - Better error messages for hook syntax errors (Ryan Scott: @RyanGIScott)+ - Fixes for GHC 7.9 [#100] (@int-index)+ - Fix test suite to use C2HS from dist directory [#81]+ - Allow free intermixing of command line options and input files [#86]+ - Treat CLang "block" syntax and other "non-GNU" issues differently:+ always undefine __BLOCKS__ CPP symbol to avoid problems with blocks;+ add nonGNU directive to trigger undefine of GNU-specific pre-processor+ symbols [#77]+ - Handle indented CPP directives correctly [#80]+ - Handle #sizeof and #alignof on non-typedef's structures [#95]+ - Fix #get and #set hooks to access newtyped pointers [#96]+ - Fix round-trip problem for interface files caused by changes in+ language-c [#87]+ - Treat "with" specially so that it can appear both as a marshaller+ identifier in an input parameter definition and as a keyword in enum+ definitions [#93]+ - Temporarily disable CUDA regression suite examples (CUDA install+ problems on Travis)++ 0.17.2 - Fix more regressions from 0.16.6 (affected packages included gnome-keyring, hsndfile and cuda)
c2hs.cabal view
@@ -1,5 +1,5 @@ Name: c2hs-Version: 0.17.2+Version: 0.18.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty@@ -68,8 +68,9 @@ Executable c2hs Build-Depends: base >= 2 && < 5,- language-c >= 0.4.2 && < 0.5,- filepath+ language-c >= 0.4.5 && < 0.5,+ filepath,+ dlist if flag(base3) Build-Depends: base >= 3, process, directory, array, containers, pretty@@ -99,7 +100,6 @@ Control.State Control.StateTrans Data.Attributes- Data.DLists Data.Errors Data.NameSpaces System.CIO@@ -121,7 +121,8 @@ test-framework-hunit, HUnit, shelly >= 1.0,- text+ text,+ transformers Test-Suite test-system type: exitcode-stdio-1.0@@ -133,10 +134,10 @@ test-framework-hunit, HUnit, shelly >= 1.0,- text+ text,+ transformers -Test-Suite regression-suite- type: exitcode-stdio-1.0+Executable regression-suite build-depends: base, filepath, shelly >= 1.0,
src/C2HS/C/Trav.hs view
@@ -73,7 +73,8 @@ declaredDeclr, declaredName, structMembers, expandDecl, structName, enumName, tagName, isPtrDeclr, dropPtrDeclr, isPtrDecl, isFunDeclr, structFromDecl, funResultAndArgs,- chaseDecl, findAndChaseDecl, checkForAlias, checkForOneCUName,+ chaseDecl, findAndChaseDecl, findAndChaseDeclOrTag,+ checkForAlias, checkForOneCUName, checkForOneAliasName, lookupEnum, lookupStructUnion, lookupDeclOrTag) where@@ -160,7 +161,7 @@ ctExc :: String ctExc = "ctExc" --- | throw an exception +-- | throw an exception -- throwCTExc :: CT s a throwCTExc = throwExc ctExc "Error during traversal of a C structure tree"@@ -316,7 +317,7 @@ -- | set the definition of an identifier -- refersToDef :: Ident -> CDef -> CT s ()-refersToDef ide def = +refersToDef ide def = do traceCTrav $ "linking identifier: "++ dumpIdent ide ++ " --> " ++ show def transAttrCCT $ \akl -> (setDefOfIdentC akl ide def, ()) @@ -538,12 +539,12 @@ -- into an anonymous declarator and also change its attributes -- dropPtrDeclr :: CDeclr -> CDeclr-dropPtrDeclr (CDeclr ide (outermost:derived) asm ats node) = +dropPtrDeclr (CDeclr ide (outermost:derived) asm ats node) = case outermost of (CPtrDeclr _ _) -> CDeclr ide derived asm ats node (CArrDeclr _ _ _) -> CDeclr ide derived asm ats node _ -> interr "CTrav.dropPtrDeclr: No pointer!"- + -- | checks whether the given declaration defines a pointer object -- -- * there may only be a single declarator in the declaration@@ -590,7 +591,7 @@ where funArgs (CDeclr _ide derived _asm _ats node) = case derived of- (CFunDeclr (Right (args,variadic)) _ats' _dnode : derived') -> + (CFunDeclr (Right (args,variadic)) _ats' _dnode : derived') -> (args, CDeclr Nothing derived' Nothing [] node, variadic) (CFunDeclr (Left _) _ _ : _) -> interr "CTrav.funResultAndArgs: Old style function definition"@@ -639,12 +640,34 @@ findAndChaseDecl :: Ident -> Bool -> Bool -> CT s CDecl findAndChaseDecl ide ind useShadows = do- traceCTrav $ "findAndChaseDecl: " ++ show ide ++ "\n"+ traceCTrav $ "findAndChaseDecl: " ++ show ide ++ " (" +++ show useShadows ++ ")\n" (obj, ide') <- findTypeObj ide useShadows -- is there an object def? ide `refersToNewDef` ObjCD obj ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing chaseDecl ide' ind +findAndChaseDeclOrTag :: Ident -> Bool -> Bool -> CT s CDecl+findAndChaseDeclOrTag ide ind useShadows =+ do+ traceCTrav $ "findAndChaseDeclOrTag: " ++ show ide ++ " (" +++ show useShadows ++ ")\n"+ mobjide <- findTypeObjMaybe ide useShadows -- is there an object def?+ case mobjide of+ Just (obj, ide') -> do+ ide `refersToNewDef` ObjCD obj+ ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing+ chaseDecl ide' ind+ Nothing -> do+ otag <- if useShadows+ then findTagShadow ide+ else liftM (fmap (\tag -> (tag, ide))) $ findTag ide+ case otag of+ Just (StructUnionCT su, _) -> do+ let (CStruct _ _ _ _ nodeinfo) = su+ return $ CDecl [CTypeSpec (CSUType su nodeinfo)] [] nodeinfo+ _ -> unknownObjErr ide+ -- | given a declaration (which must have exactly one declarator), if the -- declarator is an alias, chase it to the actual declaration --@@ -664,7 +687,7 @@ checkForOneCUName :: CDecl -> Maybe Ident checkForOneCUName decl@(CDecl specs _ _) = case [ts | CTypeSpec ts <- specs] of- [CSUType (CStruct _ n _ _ _) _] -> + [CSUType (CStruct _ n _ _ _) _] -> case declaredDeclr decl of Nothing -> n Just (CDeclr _ [] _ _ _) -> n -- no type derivations@@ -826,7 +849,7 @@ _ -> return su where err ide bad_obj =- do interr $ "CTrav.extractStruct: Illegal reference! Expected " ++ dumpIdent ide ++ + 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)
src/C2HS/CHS.hs view
@@ -95,7 +95,7 @@ CHSChangeCase(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..), loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix,- showCHSParm, apathToIdent)+ showCHSParm, apathToIdent, apathRootIdent, hasNonGNU) where -- standard libraries@@ -165,6 +165,12 @@ [CHSFrag])] -- then/elif branches (Maybe [CHSFrag]) -- else branch +hasNonGNU :: CHSModule -> Bool+hasNonGNU (CHSModule frags) = any isNonGNU frags+ where isNonGNU (CHSHook (CHSNonGNU _) _) = True+ isNonGNU _ = False++ instance Pos CHSFrag where posOf (CHSVerb _ pos ) = pos posOf (CHSHook _ pos ) = pos@@ -185,6 +191,7 @@ (Maybe String) -- prefix (Maybe String) -- replacement prefix Position+ | CHSNonGNU Position | CHSType Ident -- C type Position | CHSSizeof Ident -- C type@@ -304,6 +311,7 @@ Bool -- C repr: two values? CHSMarsh -- "out" marshaller Position+ String -- Comment for this para -- | kinds of arguments in function hooks --@@ -609,13 +617,15 @@ Just ide -> showString " as " . showCHSIdent ide) showCHSParm :: CHSParm -> ShowS-showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh _) =+showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh _ comment) = showOMarsh oimMarsh . showChar ' ' . showHsVerb hsTyStr . (if twoCVals then showChar '&' else id) . showChar ' ' . showOMarsh oomMarsh+ . showChar ' '+ . showComment comment where showOMarsh Nothing = id showOMarsh (Just (body, argKind)) = showMarshBody body@@ -629,6 +639,9 @@ showMarshBody (Right str) = showChar '|' . showString str . showChar '|' -- showHsVerb str = showChar '`' . showString str . showChar '\''+ showComment str = if null str+ then showString ""+ else showString "-- " . showString str . showChar '\n' showCHSTrans :: CHSTrans -> ShowS showCHSTrans (CHSTrans _2Case chgCase assocs) =@@ -822,31 +835,48 @@ return $ CHSLine pos : frags parseFrags0 (CHSTokC pos s:toks) = parseC pos s toks parseFrags0 (CHSTokHook hkpos:- CHSTokImport pos :toks) = parseImport hkpos pos toks+ CHSTokImport pos :toks) = parseImport hkpos pos+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokContext pos :toks) = parseContext hkpos pos toks+ CHSTokContext pos :toks) = parseContext hkpos pos+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokType pos :toks) = parseType hkpos pos toks+ CHSTokNonGNU pos :toks) = parseNonGNU hkpos pos+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokSizeof pos :toks) = parseSizeof hkpos pos toks+ CHSTokType pos :toks) = parseType hkpos pos+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokAlignof pos :toks) = parseAlignof hkpos pos toks+ CHSTokSizeof pos :toks) = parseSizeof hkpos pos+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokEnum pos :toks) = parseEnum hkpos pos toks+ CHSTokAlignof pos :toks) = parseAlignof hkpos pos+ (removeCommentInHook toks)+ -- TODO: issue 70, add haddock support for enum hook parseFrags0 (CHSTokHook hkpos:- CHSTokCall pos :toks) = parseCall hkpos pos toks+ CHSTokEnum pos :toks) = parseEnum hkpos pos+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokFun pos :toks) = parseFun hkpos pos toks+ CHSTokCall pos :toks) = parseCall hkpos pos+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokGet pos :toks) = parseField hkpos pos CHSGet toks+ CHSTokFun pos :toks) = parseFun hkpos pos toks parseFrags0 (CHSTokHook hkpos:- CHSTokSet pos :toks) = parseField hkpos pos CHSSet toks+ CHSTokGet pos :toks) = parseField hkpos pos CHSGet+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokOffsetof pos :toks) = parseOffsetof hkpos pos toks+ CHSTokSet pos :toks) = parseField hkpos pos CHSSet+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokClass pos :toks) = parseClass hkpos pos toks+ CHSTokOffsetof pos :toks) = parseOffsetof hkpos pos+ (removeCommentInHook toks) parseFrags0 (CHSTokHook hkpos:- CHSTokPointer pos :toks) = parsePointer hkpos pos toks+ CHSTokClass pos :toks) = parseClass hkpos pos+ (removeCommentInHook toks)+ parseFrags0 (CHSTokHook hkpos:+ CHSTokPointer pos :toks) = parsePointer hkpos pos+ (removeCommentInHook toks)+ parseFrags0 (CHSTokHook _ :toks) = syntaxError toks parseFrags0 toks = syntaxError toks -- -- skip to next Haskell or control token@@ -855,6 +885,15 @@ contFrags toks@(CHSTokHaskell _ _:_ ) = parseFrags toks contFrags toks@(CHSTokCtrl _ _:_ ) = parseFrags toks contFrags (_ :toks) = contFrags toks+ --+ -- Only keep comment in fun hook+ --+ isComment (CHSTokComment _ _) = True+ isComment _ = False+ isEndHook (CHSTokEndHook _) = True+ isEndHook _ = False+ removeCommentInHook xs = let (lhs,rhs) = span (not . isEndHook) xs+ in filter (not . isComment) lhs ++ rhs parseC :: Position -> String -> [CHSToken] -> CST s [CHSFrag] parseC pos s toks =@@ -912,6 +951,13 @@ let frag = CHSContext olib opref oreppref pos return $ CHSHook frag hkpos : frags +parseNonGNU :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]+parseNonGNU hkpos pos toks = do+ toks2 <- parseEndHook toks+ frags <- parseFrags toks2+ let frag = CHSNonGNU pos+ return $ CHSHook frag hkpos : frags+ parseType :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] parseType hkpos pos (CHSTokIdent _ ide:toks) = do@@ -979,7 +1025,7 @@ CHSHook (CHSCall isPure isUnsafe apath oalias pos) hkpos : frags parseFun :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]-parseFun hkpos pos toks =+parseFun hkpos pos inputToks = do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'2) <- parseIsUnsafe toks'@@ -995,6 +1041,7 @@ (CHSFun isPure isUnsafe apath oalias octxt parms parm pos) hkpos : frags where+ toks = removeIllPositionedComment inputToks parseOptContext (CHSTokHSVerb _ ctxt:CHSTokDArrow _:toks') = return (Just ctxt, toks') parseOptContext toks' =@@ -1008,6 +1055,10 @@ syntaxError toks' -- parseParms' (CHSTokRBrace _:CHSTokArrow _:toks') = return ([], toks')+ parseParms' (CHSTokComma _:CHSTokComment _ _:toks') = do+ (parm , toks'2 ) <- parseParm toks'+ (parms, toks'3) <- parseParms' toks'2+ return (parm:parms, toks'3) parseParms' (CHSTokComma _ :toks') = do (parm , toks'2 ) <- parseParm toks' (parms, toks'3) <- parseParms' toks'2@@ -1015,7 +1066,25 @@ parseParms' (CHSTokRBrace _ :toks') = syntaxError toks' -- gives better error messages parseParms' toks' = syntaxError toks'+ --+ isComment (CHSTokComment _ _) = True+ isComment _ = False+ isLBrace (CHSTokLBrace _) = True+ isLBrace _ = False+ isRBrace (CHSTokRBrace _) = True+ isRBrace _ = False+ isHSVerb (CHSTokHSVerb _ _) = True+ isHSVerb _ = False+ -- remove comment(s) between+ -- 1. {# and {+ -- 2. } and `ResultType'+ removeIllPositionedComment xs = let (lhs,rhs) = span (not . isLBrace) xs+ (lhs',rhs') = span (not . isRBrace) rhs+ (lhs'2,rhs'2) = span (not . isHSVerb) rhs'+ in filter (not . isComment) lhs ++ lhs' +++ (filter (not . isComment) lhs'2) ++ rhs'2 + parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken]) parseIsPure (CHSTokPure _:toks) = return (True , toks) parseIsPure (CHSTokFun _:toks) = return (True , toks) -- backwards compat.@@ -1039,6 +1108,11 @@ sel = upperFirst $ identToString ide' in internalIdentAt (posOf ide) (identToString ide ++ sel) +apathRootIdent :: CHSAPath -> Ident+apathRootIdent (CHSRoot _ ide) = ide+apathRootIdent (CHSDeref apath _) = apathRootIdent apath+apathRootIdent (CHSRef apath _) = apathRootIdent apath+ parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken]) parseParm toks = do@@ -1051,7 +1125,9 @@ return (hsTyStr, False, pos, toks'2) _toks -> syntaxError toks' (oomMarsh, toks'3) <- parseOptMarsh toks'2- return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh pos, toks'3)+ (comments, toks'4) <- parseOptComments toks'3+ return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh pos+ (concat (intersperse " " comments)), toks'4) where parseOptMarsh :: [CHSToken] -> CST s (CHSMarsh, [CHSToken]) parseOptMarsh (CHSTokIdent _ ide:toks') =@@ -1062,6 +1138,10 @@ do (marshType, toks'2) <- parseOptMarshType toks' return (Just (Right str, marshType), toks'2)+ parseOptMarsh (CHSTokWith _ ide:toks') =+ do+ (marshType, toks'2) <- parseOptMarshType toks'+ return (Just (Left ide, marshType), toks'2) parseOptMarsh toks' = return (Nothing, toks') @@ -1074,6 +1154,12 @@ parseOptMarshType toks' = return (CHSValArg, toks') +parseOptComments :: [CHSToken] -> CST s ([String], [CHSToken])+parseOptComments = go []+ where+ go acc (CHSTokComment _ s:toks) = go (s:acc) toks+ go acc _toks = return (reverse acc,_toks)+ parseField :: Position -> Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag] parseField hkpos pos access toks = do@@ -1161,12 +1247,12 @@ CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks)-parseOptPrefix True (CHSTokWith _ :+parseOptPrefix True (CHSTokWith _ _ : CHSTokPrefix _ : CHSTokEqual _ : CHSTokString _ str: toks) = return (Just str, toks)-parseOptPrefix _ (CHSTokWith _:toks) = syntaxError toks+parseOptPrefix _ (CHSTokWith _ _:toks) = syntaxError toks parseOptPrefix _ (CHSTokPrefix _:toks) = syntaxError toks parseOptPrefix _ toks = return (Nothing, toks)
src/C2HS/CHS/Lexer.hs view
@@ -211,6 +211,7 @@ | CHSTokCall Position -- `call' | CHSTokClass Position -- `class' | CHSTokContext Position -- `context'+ | CHSTokNonGNU Position -- `nonGNU' | CHSTokDerive Position -- `deriving' | CHSTokDown Position -- `downcaseFirstLetter' | CHSTokEnum Position -- `enum'@@ -235,7 +236,7 @@ | CHSTok_2Case Position -- `underscoreToCase' | CHSTokUnsafe Position -- `unsafe' | CHSTokUpper Position -- `upcaseFirstLetter'- | CHSTokWith Position -- `with'+ | CHSTokWith Position Ident -- `with' | CHSTokString Position String -- string | CHSTokHSVerb Position String -- verbatim Haskell (`...') | CHSTokHSQuot Position String -- quoted Haskell ('...')@@ -245,6 +246,7 @@ | CHSTokLine Position -- line pragma | CHSTokC Position String -- verbatim C code | CHSTokCtrl Position Char -- control code+ | CHSTokComment Position String -- comment instance Pos CHSToken where posOf (CHSTokArrow pos ) = pos@@ -260,12 +262,14 @@ posOf (CHSTokRBrace pos ) = pos posOf (CHSTokLParen pos ) = pos posOf (CHSTokRParen pos ) = pos+ posOf (CHSTokHook pos ) = pos posOf (CHSTokEndHook pos ) = pos posOf (CHSTokAdd pos ) = pos posOf (CHSTokAs pos ) = pos posOf (CHSTokCall pos ) = pos posOf (CHSTokClass pos ) = pos posOf (CHSTokContext pos ) = pos+ posOf (CHSTokNonGNU pos ) = pos posOf (CHSTokDerive pos ) = pos posOf (CHSTokDown pos ) = pos posOf (CHSTokEnum pos ) = pos@@ -290,7 +294,7 @@ posOf (CHSTok_2Case pos ) = pos posOf (CHSTokUnsafe pos ) = pos posOf (CHSTokUpper pos ) = pos- posOf (CHSTokWith pos ) = pos+ posOf (CHSTokWith pos _) = pos posOf (CHSTokString pos _) = pos posOf (CHSTokHSVerb pos _) = pos posOf (CHSTokHSQuot pos _) = pos@@ -300,6 +304,7 @@ posOf (CHSTokLine pos ) = pos posOf (CHSTokC pos _) = pos posOf (CHSTokCtrl pos _) = pos+ posOf (CHSTokComment pos _) = pos instance Eq CHSToken where (CHSTokArrow _ ) == (CHSTokArrow _ ) = True@@ -315,12 +320,14 @@ (CHSTokRBrace _ ) == (CHSTokRBrace _ ) = True (CHSTokLParen _ ) == (CHSTokLParen _ ) = True (CHSTokRParen _ ) == (CHSTokRParen _ ) = True+ (CHSTokHook _ ) == (CHSTokHook _ ) = True (CHSTokEndHook _ ) == (CHSTokEndHook _ ) = True (CHSTokAdd _ ) == (CHSTokAdd _ ) = True (CHSTokAs _ ) == (CHSTokAs _ ) = True (CHSTokCall _ ) == (CHSTokCall _ ) = True (CHSTokClass _ ) == (CHSTokClass _ ) = True (CHSTokContext _ ) == (CHSTokContext _ ) = True+ (CHSTokNonGNU _ ) == (CHSTokNonGNU _ ) = True (CHSTokDerive _ ) == (CHSTokDerive _ ) = True (CHSTokDown _ ) == (CHSTokDown _ ) = True (CHSTokEnum _ ) == (CHSTokEnum _ ) = True@@ -345,7 +352,7 @@ (CHSTok_2Case _ ) == (CHSTok_2Case _ ) = True (CHSTokUnsafe _ ) == (CHSTokUnsafe _ ) = True (CHSTokUpper _ ) == (CHSTokUpper _ ) = True- (CHSTokWith _ ) == (CHSTokWith _ ) = True+ (CHSTokWith _ _) == (CHSTokWith _ _) = True (CHSTokString _ _) == (CHSTokString _ _) = True (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True (CHSTokHSQuot _ _) == (CHSTokHSQuot _ _) = True@@ -355,6 +362,7 @@ (CHSTokLine _ ) == (CHSTokLine _ ) = True (CHSTokC _ _) == (CHSTokC _ _) = True (CHSTokCtrl _ _) == (CHSTokCtrl _ _) = True+ (CHSTokComment _ _) == (CHSTokComment _ _) = True _ == _ = False instance Show CHSToken where@@ -371,12 +379,14 @@ showsPrec _ (CHSTokRBrace _ ) = showString "}" showsPrec _ (CHSTokLParen _ ) = showString "(" showsPrec _ (CHSTokRParen _ ) = showString ")"+ showsPrec _ (CHSTokHook _ ) = showString "{#" showsPrec _ (CHSTokEndHook _ ) = showString "#}" showsPrec _ (CHSTokAdd _ ) = showString "add" showsPrec _ (CHSTokAs _ ) = showString "as" showsPrec _ (CHSTokCall _ ) = showString "call" showsPrec _ (CHSTokClass _ ) = showString "class" showsPrec _ (CHSTokContext _ ) = showString "context"+ showsPrec _ (CHSTokNonGNU _ ) = showString "nonGNU" showsPrec _ (CHSTokDerive _ ) = showString "deriving" showsPrec _ (CHSTokDown _ ) = showString "downcaseFirstLetter" showsPrec _ (CHSTokEnum _ ) = showString "enum"@@ -401,7 +411,7 @@ showsPrec _ (CHSTok_2Case _ ) = showString "underscoreToCase" showsPrec _ (CHSTokUnsafe _ ) = showString "unsafe" showsPrec _ (CHSTokUpper _ ) = showString "upcaseFirstLetter"- showsPrec _ (CHSTokWith _ ) = showString "with"+ showsPrec _ (CHSTokWith _ _) = showString "with" showsPrec _ (CHSTokString _ s) = showString ("\"" ++ s ++ "\"") showsPrec _ (CHSTokHSVerb _ s) = showString ("`" ++ s ++ "'") showsPrec _ (CHSTokHSQuot _ s) = showString ("'" ++ s ++ "'")@@ -411,7 +421,9 @@ showsPrec _ (CHSTokLine _ ) = id --TODO show line num? showsPrec _ (CHSTokC _ s) = showString s showsPrec _ (CHSTokCtrl _ c) = showChar c-+ showsPrec _ (CHSTokComment _ s) = showString (if null s+ then ""+ else " -- " ++ s ++ "\n") -- lexer state -- -----------@@ -621,11 +633,13 @@ cpp = directive where directive =- (string "\n#" >|< string "\0#") +>+ --(string "\n#" >|< string "\0#") +>+ alt "\n\0" +> alt " \t" `star` string "#" +> alt ('\t':inlineSet)`star` epsilon `lexmeta`- \t@(ld:_:dir) pos s -> -- strip off the "\n#" or "\0#"- case dir of+ \t@(ld:spdir) pos s -> -- strip off the "\n" or "\0"+ let dir = drop 1 $ dropWhile (`elem` " \t") spdir+ in case dir of ['c'] -> -- #c (Nothing, incPos pos (length t), s, Just cLexer) -- a #c may be followed by whitespace@@ -666,7 +680,7 @@ >||< whitespace >||< endOfHook >||< string "--" +> anyButNL`star` char '\n' -- comment- `lexmeta` \_ pos s -> (Nothing, retPos pos, s, Nothing)+ `lexaction` \cs pos -> Just (CHSTokComment pos (init (drop 2 cs))) where anyButNL = alt (anySet \\ ['\n']) endOfHook = string "#}"@@ -714,6 +728,7 @@ idkwtok pos "call" _ = CHSTokCall pos idkwtok pos "class" _ = CHSTokClass 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@@ -738,10 +753,11 @@ idkwtok pos "underscoreToCase" _ = CHSTok_2Case pos idkwtok pos "unsafe" _ = CHSTokUnsafe pos idkwtok pos "upcaseFirstLetter"_ = CHSTokUpper pos- idkwtok pos "with" _ = CHSTokWith pos+ idkwtok pos "with" name = mkwith pos name idkwtok pos cs name = mkid pos cs name -- mkid pos cs name = CHSTokIdent pos (mkIdent pos cs name)+ mkwith pos name = CHSTokWith pos (mkIdent pos "with" name) keywordToIdent :: CHSToken -> CHSToken keywordToIdent tok =@@ -751,6 +767,7 @@ CHSTokCall pos -> mkid pos "call" CHSTokClass pos -> mkid pos "class" 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"@@ -775,7 +792,7 @@ CHSTok_2Case pos -> mkid pos "underscoreToCase" CHSTokUnsafe pos -> mkid pos "unsafe" CHSTokUpper pos -> mkid pos "upcaseFirstLetter"- CHSTokWith pos -> mkid pos "with"+ CHSTokWith pos ide -> CHSTokIdent pos ide _ -> tok where mkid pos str = CHSTokIdent pos (internalIdent str)
src/C2HS/Gen/Bind.hs view
@@ -109,11 +109,13 @@ -- standard libraries import Data.Char (toLower) import Data.Function (on)-import Data.List (deleteBy, groupBy, sortBy, intersperse, find)+import Data.List (deleteBy, groupBy, sortBy, intersperse, find, nubBy, intercalate) import Data.Map (lookup) import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.Bits ((.|.), (.&.))+import Control.Arrow (second) import Control.Monad (when, unless, liftM, mapAndUnzipM)+import Data.Ord (comparing) -- Language.C / compiler toolkit import Language.C.Data.Position@@ -121,7 +123,6 @@ import Language.C.Pretty import Text.PrettyPrint.HughesPJ (render) import Data.Errors-import Data.Attributes (newAttrsOnlyPos) -- C->Haskell import C2HS.Config (PlatformSpec(..))@@ -132,7 +133,7 @@ -- friends import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..),- CHSPtrType(..), showCHSParm, apathToIdent)+ CHSPtrType(..), showCHSParm, apathToIdent, apathRootIdent) import C2HS.C.Info (CPrimType(..), alignment, getPlatform) import qualified C2HS.C.Info as CInfo import C2HS.Gen.Monad (TransFun, transTabToTransFun, HsObject(..), GB,@@ -411,6 +412,7 @@ when (isJust oprefix) $ applyPrefixToNameSpaces (fromJust oprefix) (maybe "" id orepprefix) return ""+expandHook (CHSNonGNU _) _ = return "" expandHook (CHSType ide pos) _ = do traceInfoType@@ -427,7 +429,7 @@ expandHook (CHSAlignof ide _) _ = do traceInfoAlignof- decl <- findAndChaseDecl ide False True -- no indirection, but shadows+ decl <- findAndChaseDeclOrTag ide False True -- no indirection, but shadows (_, align) <- sizeAlignOf decl traceInfoDump (render $ pretty decl) align return $ show align@@ -440,7 +442,7 @@ expandHook (CHSSizeof ide _) _ = do traceInfoSizeof- decl <- findAndChaseDecl ide False True -- no indirection, but shadows+ decl <- findAndChaseDeclOrTag ide False True -- no indirection, but shadows (size, _) <- sizeAlignOf decl traceInfoDump (render $ pretty decl) size return $ show (padBits size)@@ -498,7 +500,7 @@ _ -> funPtrExpectedErr pos traceValueType ty- set_get <- setGet pos CHSGet offsets ptrTy+ set_get <- setGet pos CHSGet offsets 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@@ -510,7 +512,7 @@ -- cdecl' = ide `simplifyDecl` cdecl args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] - callImportDyn hook isPure isUns ideLexeme hsLexeme ty pos+ callImportDyn hook isPure isUns ideLexeme hsLexeme decl ty pos return $ "(\\o" ++ args ++ " -> " ++ set_get ++ " o >>= \\f -> " ++ hsLexeme ++ " f" ++ args ++ ")" where@@ -565,9 +567,9 @@ -- cdecl' = cide `simplifyDecl` cdecl -- args = concat [ " x" ++ show n | n <- [1..numArgs ty] ] callHook = CHSCall isPure isUns apath (Just fiIde) pos- callImportDyn callHook isPure isUns ideLexeme fiLexeme ty pos+ callImportDyn callHook isPure isUns ideLexeme fiLexeme decl ty pos - set_get <- setGet pos CHSGet offsets ptrTy+ set_get <- setGet pos CHSGet offsets ptrTy Nothing funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) ctxt parms parm (Just set_get) pos hkpos where@@ -585,11 +587,13 @@ do traceInfoField traceGenBind $ "path = " ++ show path ++ "\n"+ onewtype <- apathNewtypeName path+ traceGenBind $ "onewtype = " ++ show onewtype ++ "\n" (decl, offsets) <- accessPath path traceDepth offsets ty <- extractSimpleType False pos decl traceValueType ty- setGet pos access offsets ty+ setGet pos access offsets ty onewtype where accessString = case access of CHSGet -> "Get"@@ -712,6 +716,19 @@ -- traceInfoClass = traceGenBind $ "** Class hook:\n" +apathNewtypeName :: CHSAPath -> GB (Maybe Ident)+apathNewtypeName path = do+ let ide = apathRootIdent path+ pm <- readCT ptrmap+ case (True, ide) `lookup` pm of+ Nothing -> return Nothing+ Just (hsty, _) -> do+ om <- readCT objmap+ let hside = internalIdent hsty+ case hside `lookup` om of+ Just (Pointer _ True) -> return (Just hside)+ _ -> return Nothing+ -- | produce code for an enumeration -- -- * an extra instance declaration is required when any of the enumeration@@ -725,50 +742,36 @@ enumDef (CEnum _ (Just list) _ _) hident trans userDerive _ = do (list', enumAuto) <- evalTagVals list- let enumVals = [(trans ide, cexpr) | (ide, cexpr) <- list']- toEnumVals = [(trans ide, cexpr) |- (ide, cexpr) <- stripEnumAliases list']+ let enumVals = fixTags [(trans ide, cexpr) | (ide, cexpr) <- list'] defHead = enumHead hident defBody = enumBody (length defHead - 2) enumVals inst = makeDerives (if enumAuto then "Enum" : userDerive else userDerive) +++ "\n" ++ if enumAuto- then "\n"- else "\n" ++ enumInst hident enumVals toEnumVals+ then ""+ else enumInst hident enumVals isEnum hident return $ defHead ++ defBody ++ inst where- evalTagVals [] = return ([], True)- evalTagVals ((ide, Nothing ):list') =- do- (list'', derived) <- evalTagVals list'- return ((ide, Nothing):list'', derived)- evalTagVals ((ide, Just exp):list') =- do- (list'', _derived) <- evalTagVals list'+ evalTagVals = liftM (second and . unzip) . mapM (uncurry evalTag)+ evalTag ide Nothing = return ((ide, Nothing), True)+ evalTag ide (Just exp) = do val <- evalConstCExpr exp case val of- IntResult val' ->- return ((ide, Just $ CConst (CIntConst (cInteger val') at1)):list'',- False)- FloatResult _ ->- illegalConstExprErr (posOf exp) "a float result"- where- at1 = newAttrsOnlyPos nopos+ IntResult v -> return ((ide, Just v), False)+ FloatResult _ -> illegalConstExprErr (posOf exp) "a float result" makeDerives [] = ""- makeDerives dList = "deriving (" ++ concat (intersperse "," dList) ++")"- stripEnumAliases :: [(Ident, Maybe CExpr)] -> [(Ident, Maybe CExpr)]- stripEnumAliases vs =- let okids = map (fst . head) .- groupBy ((==) `on` snd) .- sortBy (compare `on` snd) .- extractEnumVals $ vs- in filter ((`elem` okids) . fst) vs- extractEnumVals :: [(Ident, Maybe CExpr)] -> [(Ident, CInteger)]- extractEnumVals = go 0- where go _ [] = []- go k ((i, Nothing):vs') = (i,k) : go (k+1) vs'- go _ ((i, Just (CConst (CIntConst j _))):vs') = (i,j) : go (j+1) vs'+ makeDerives dList = "\n deriving (" ++ intercalate "," dList ++ ")"+ -- Fix implicit tag values+ fixTags = go 0+ where+ go _ [] = []+ go n ((ide, exp):rest) =+ let val = case exp of+ Nothing -> n+ Just m -> m+ in (ide, val) : go (val+1) rest -- | Haskell code for the head of an enumeration definition --@@ -777,15 +780,14 @@ -- | Haskell code for the body of an enumeration definition ---enumBody :: Int -> [(String, Maybe CExpr)] -> String-enumBody _ [] = ""-enumBody indent ((ide, _):list) =- ide ++ "\n" ++ replicate indent ' '- ++ (if null list then "" else "| " ++ enumBody indent list)-+enumBody :: Int -> [(String, Integer)] -> String+enumBody indent ides = constrs+ where+ constrs = intercalate separator . map fst $ sortBy (comparing snd) ides+ separator = "\n" ++ replicate indent ' ' ++ "| " -- | Num instance for C Integers--- We should preserve type flags and repr if possible +-- We should preserve type flags and repr if possible instance Num CInteger where fromInteger = cInteger (+) a b = cInteger (getCInteger a + getCInteger b)@@ -801,40 +803,72 @@ -- following tags are assigned values continuing from the explicitly -- specified one ---enumInst :: String -> [(String, Maybe CExpr)] -> [(String, Maybe CExpr)]- -> String-enumInst ident list tolist =- "instance Enum " ++ ident ++ " where\n"- ++ fromDef list 0 ++ "\n" ++ toDef tolist 0+enumInst :: String -> [(String, Integer)] -> String+enumInst ident list' = intercalate "\n"+ [ "instance Enum " ++ ident ++ " where"+ , succDef+ , predDef+ , enumFromToDef+ , enumFromDef+ , fromDef+ , toDef+ ] where- fromDef [] _ = ""- fromDef ((ide, exp):list') n =- " fromEnum " ++ ide ++ " = " ++ show' (getCInteger val) ++ "\n"- ++ fromDef list' (val + 1)- where- val = case exp of- Nothing -> n- Just (CConst (CIntConst m _)) -> m- Just _ ->- interr "GenBind.enumInst: Integer constant expected!"- --- show' x = if x < 0 then "(" ++ show x ++ ")" else show x- --- toDef [] _ =- " toEnum unmatched = error (\"" ++ ident- ++ ".toEnum: Cannot match \" ++ show unmatched)\n"- toDef ((ide, exp):list') n =- " toEnum " ++ show' val ++ " = " ++ ide ++ "\n"- ++ toDef list' (val + 1)- where- val = case exp of- Nothing -> n- Just (CConst (CIntConst m _)) -> m- Just _ ->- interr "GenBind.enumInst: Integer constant expected!"- --- show' x = if x < 0 then "(" ++ show x ++ ")" else show x+ concatFor = flip concatMap+ -- List of _all values_ (including aliases) and their associated tags+ list = sortBy (comparing snd) list'+ -- List of values without aliases and their associated tags+ toList = stripAliases list+ -- Generate explicit tags for all values:+ succDef = let idents = map fst toList+ aliases = map (map fst) $ groupBy ((==) `on` snd) list+ defs = concat $ zipWith+ (\is s -> concatFor is $ \i -> " succ " ++ i+ ++ " = " ++ s ++ "\n")+ aliases+ (tail idents)+ lasts = concatFor (last aliases) $ \i ->+ " succ " ++ i ++ " = error \""+ ++ ident ++ ".succ: " ++ i +++ " has no successor\"\n"+ in defs ++ lasts+ predDef = let idents = map fst toList+ aliases = map (map fst) $ groupBy ((==) `on` snd) list+ defs = concat $ zipWith+ (\is s -> concatFor is $ \i -> " pred " ++ i+ ++ " = " ++ s ++ "\n")+ (tail aliases)+ idents+ firsts = concatFor (head aliases) $ \i ->+ " pred " ++ i ++ " = error \""+ ++ ident ++ ".pred: " ++ i +++ " has no predecessor\"\n"+ in defs ++ firsts+ enumFromToDef = intercalate "\n"+ [ " enumFromTo from to = go from"+ , " where"+ , " end = fromEnum to"+ , " go v = case compare (fromEnum v) end of"+ , " LT -> v : go (succ v)"+ , " EQ -> [v]"+ , " GT -> []"+ , ""+ ]+ enumFromDef = let lastIdent = fst $ last list+ in " enumFrom from = enumFromTo from " ++ lastIdent ++ "\n" + fromDef = concatFor list (\(ide, val) -> " fromEnum " ++ ide ++ " = "+ ++ show' val ++ "\n")++ toDef = (concatFor toList (\(ide, val) -> " toEnum " ++ show' val ++ " = "+ ++ ide ++ "\n"))+ -- Default case:+ ++ " toEnum unmatched = error (\"" ++ ident+ ++ ".toEnum: Cannot match \" ++ show unmatched)\n"+ show' x = if x < 0 then "(" ++ show x ++ ")" else show x+ stripAliases :: [(String, Integer)] -> [(String, Integer)]+ stripAliases = nubBy ((==) `on` snd)+ -- | generate a foreign import declaration that is put into the delayed code -- -- * the C declaration is a simplified declaration of the function that we@@ -857,15 +891,16 @@ traceFunType et = traceGenBind $ "Imported function type: " ++ showExtType et ++ "\n" -callImportDyn :: CHSHook -> Bool -> Bool -> String -> String -> ExtType+callImportDyn :: CHSHook -> Bool -> Bool -> String -> String -> CDecl -> ExtType -> Position -> GB ()-callImportDyn hook _isPure isUns ideLexeme hsLexeme ty pos =+callImportDyn hook _isPure isUns ideLexeme hsLexeme cdecl ty pos = do -- compute the external type from the declaration, and delay the foreign -- export declaration --- when (isVariadic ty) (variadicErr pos pos) -- FIXME? (posOf cdecl))- delayCode hook (foreignImportDyn ideLexeme hsLexeme isUns ty)+ when (isVariadic ty) (variadicErr pos (posOf cdecl))+ delayCode hook (foreignImportDyn (extractCallingConvention cdecl)+ ideLexeme hsLexeme isUns ty) traceFunType ty where traceFunType et = traceGenBind $@@ -885,9 +920,10 @@ -- | Haskell code for the foreign import dynamic declaration needed by a call hook ---foreignImportDyn :: String -> String -> Bool -> ExtType -> String-foreignImportDyn _ident hsIdent isUnsafe ty =- "foreign import ccall " ++ safety ++ " \"dynamic\"\n " +++foreignImportDyn :: CallingConvention -> String -> String -> Bool -> ExtType -> String+foreignImportDyn cconv _ident hsIdent isUnsafe ty =+ "foreign import " ++ showCallingConvention cconv ++ " " ++ safety+ ++ " \"dynamic\"\n " ++ hsIdent ++ " :: FunPtr( " ++ showExtType ty ++ " ) -> " ++ showExtType ty ++ "\n" where@@ -931,7 +967,7 @@ call = if isPure then " let {res = " ++ fiLexeme ++ joinCallArgs ++ "} in\n" else " " ++ fiLexeme ++ joinCallArgs ++ case parm of- CHSParm _ "()" _ Nothing _ -> " >>\n"+ CHSParm _ "()" _ Nothing _ _ -> " >>\n" _ -> " >>= \\res ->\n" joinCallArgs = case marsh2 of Nothing -> join callArgs@@ -942,22 +978,22 @@ join (take 1 callArgs) ++ " >>= \\b1' ->\n" marshRes = case parm' of- CHSParm _ _ _twoCVal (Just (_ , CHSVoidArg )) _ -> ""- CHSParm _ _ _twoCVal (Just (omBody, CHSIOVoidArg)) _ ->+ CHSParm _ _ _twoCVal (Just (_ , CHSVoidArg )) _ _ -> ""+ CHSParm _ _ _twoCVal (Just (omBody, CHSIOVoidArg)) _ _ -> " " ++ marshBody omBody ++ " res >> \n"- CHSParm _ _ _twoCVal (Just (omBody, CHSIOArg )) _ ->+ CHSParm _ _ _twoCVal (Just (omBody, CHSIOArg )) _ _ -> " " ++ marshBody omBody ++ " res >>= \\res' ->\n"- CHSParm _ _ _twoCVal (Just (omBody, CHSValArg )) _ ->+ CHSParm _ _ _twoCVal (Just (omBody, CHSValArg )) _ _ -> " let {res' = " ++ marshBody omBody ++ " res} in\n"- CHSParm _ _ _ Nothing _ ->+ CHSParm _ _ _ Nothing _ _ -> interr "GenBind.funDef: marshRes: no default?" marshBody (Left ide) = identToString ide marshBody (Right str) = "(" ++ str ++ ")" retArgs' = case parm' of- CHSParm _ _ _ (Just (_, CHSVoidArg)) _ -> retArgs- CHSParm _ _ _ (Just (_, CHSIOVoidArg)) _ -> retArgs+ CHSParm _ _ _ (Just (_, CHSVoidArg)) _ _ -> retArgs+ CHSParm _ _ _ (Just (_, CHSIOVoidArg)) _ _ -> retArgs _ -> "res'":retArgs ret = "(" ++ concat (intersperse ", " retArgs') ++ ")" funBody = joinLines marshIns ++@@ -984,18 +1020,26 @@ -- funTy parms' parm' = let+ showComment str = if null str+ then ""+ else " -- " ++ str ++ "\n" ctxt = case octxt of Nothing -> "" Just ctxtStr -> ctxtStr ++ " => "- argTys = ["(" ++ ty ++ ")" | CHSParm im ty _ _ _ <- parms' , notVoid im]- resTys = ["(" ++ ty ++ ")" | CHSParm _ ty _ om _ <- parm':parms', notVoid om]+ argTys = ["(" ++ ty ++ ")" ++ showComment c |+ CHSParm im ty _ _ _ c <- parms', notVoid im]+ resTys = ["(" ++ ty ++ ")" |+ CHSParm _ ty _ om _ _ <- parm':parms', notVoid om] resTup = let+ comment = case parm' of+ CHSParm _ _ _ _ _ c -> c (lp, rp) = if isPure && length resTys == 1 then ("", "") else ("(", ")") io = if isPure then "" else "IO " in- io ++ lp ++ concat (intersperse ", " resTys) ++ rp+ io ++ lp ++ concat (intersperse ", " resTys) ++ rp +++ showComment comment in ctxt ++ concat (intersperse " -> " (argTys ++ [resTup]))@@ -1008,7 +1052,7 @@ -- code fragments -- marshArg i (CHSParm (Just (imBody, imArgKind)) _ twoCVal- (Just (omBody, omArgKind)) _ ) =+ (Just (omBody, omArgKind)) _ _ ) = let a = "a" ++ show (i :: Int) imStr = marshBody imBody@@ -1067,14 +1111,14 @@ -- -- * a default marshaller maybe used for "out" marshalling --- checkResMarsh (CHSParm (Just _) _ _ _ pos') _ =+ checkResMarsh (CHSParm (Just _) _ _ _ pos' _) _ = resMarshIllegalInErr pos'- checkResMarsh (CHSParm _ _ True _ pos') _ =+ checkResMarsh (CHSParm _ _ True _ pos' _) _ = resMarshIllegalTwoCValErr pos'- checkResMarsh (CHSParm _ ty _ omMarsh pos') cTy = do+ checkResMarsh (CHSParm _ ty _ omMarsh pos' c) cTy = do (imMarsh', _ ) <- addDftVoid Nothing (omMarsh', isImpure) <- addDftOut pos' omMarsh ty [cTy]- return (CHSParm imMarsh' ty False omMarsh' pos', isImpure)+ return (CHSParm imMarsh' ty False omMarsh' pos' c, isImpure) -- splitFunTy (FunET UnitET ty ) = splitFunTy ty splitFunTy (FunET ty1 ty2) = let@@ -1085,22 +1129,22 @@ -- -- match Haskell with C arguments (and results) --- addDft ((CHSParm imMarsh hsTy False omMarsh p):parms'') (cTy :cTys) = do+ addDft ((CHSParm imMarsh hsTy False omMarsh p c):parms'') (cTy :cTys) = do (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy] (omMarsh', isImpureOut) <- addDftVoid omMarsh (parms' , isImpure ) <- addDft parms'' cTys- return (CHSParm imMarsh' hsTy False omMarsh' p : parms',+ return (CHSParm imMarsh' hsTy False omMarsh' p c : parms', isImpure || isImpureIn || isImpureOut)- addDft ((CHSParm imMarsh hsTy True omMarsh p):parms'') (cTy1:cTy2:cTys) =+ addDft ((CHSParm imMarsh hsTy True omMarsh p c):parms'') (cTy1:cTy2:cTys) = do (imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy1, cTy2] (omMarsh', isImpureOut) <- addDftVoid omMarsh (parms' , isImpure ) <- addDft parms'' cTys- return (CHSParm imMarsh' hsTy True omMarsh' p : parms',+ return (CHSParm imMarsh' hsTy True omMarsh' p c : parms', isImpure || isImpureIn || isImpureOut) addDft [] [] = return ([], False)- addDft ((CHSParm _ _ _ _ pos'):_) [] =+ addDft ((CHSParm _ _ _ _ pos' _):_) [] = marshArgMismatchErr pos' "This parameter is in excess of the C arguments." addDft [] (_:_) = marshArgMismatchErr pos "Parameter marshallers are missing."@@ -1242,12 +1286,17 @@ -- | Haskell code for writing to or reading from a struct ---setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String-setGet pos access offsets ty =+setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> Maybe Ident+ -> GB String+setGet pos access offsets ty onewtype = do- let pre = case access of- CHSSet -> "(\\ptr val -> do {"- CHSGet -> "(\\ptr -> do {"+ let pre = case (access, onewtype) of+ (CHSSet, Nothing) -> "(\\ptr val -> do {"+ (CHSGet, Nothing) -> "(\\ptr -> do {"+ (CHSSet, Just ide) ->+ "(\\(" ++ identToString ide ++ " ptr) val -> do {"+ (CHSGet, Just ide) ->+ "(\\(" ++ identToString ide ++ " ptr) -> do {" body <- setGetBody (reverse offsets) return $ pre ++ body ++ "})" where@@ -1611,7 +1660,7 @@ [(Just declr, _, size)] | isPtrDeclr declr -> ptrType declr | isFunDeclr declr -> funType | otherwise -> aliasOrSpecType size- [] -> aliasOrSpecType Nothing+ _ -> aliasOrSpecType Nothing where -- handle explicit pointer types --@@ -1822,13 +1871,19 @@ funAttrs (CDecl specs declrs _) = let (_,attrs',_,_,_) = partitionDeclSpecs specs- in attrs' ++ funEndAttrs declrs+ in attrs' ++ funEndAttrs declrs ++ funPtrAttrs declrs -- attrs after the function name, e.g. void foo() __attribute__((...)); funEndAttrs [(Just ((CDeclr _ (CFunDeclr _ _ _ : _) _ attrs _)), _, _)] = attrs funEndAttrs _ = [] + -- attrs appearing within the declarator of a function pointer. As an+ -- example:+ -- typedef int (__stdcall *fp)();+ funPtrAttrs [(Just ((CDeclr _ (CPtrDeclr _ _ : CFunDeclr _ attrs _ : _) _ _ _)), _, _)] = attrs+ funPtrAttrs _ = [] + -- | generate the necessary parameter for "foreign import" for the -- provided calling convention showCallingConvention :: CallingConvention -> String@@ -2087,7 +2142,7 @@ do (cobj, _) <- findValueObj ide''' False case cobj of- EnumCO ide'' (CEnum _ (Just enumrs) _ _) -> + EnumCO ide'' (CEnum _ (Just enumrs) _ _) -> liftM IntResult $ enumTagValue ide'' enumrs 0 _ -> todo $ "GenBind.evalConstCExpr: variable names not implemented yet " ++@@ -2130,8 +2185,8 @@ evalCCast' :: CompType -> Integer -> GB ConstResult evalCCast' (ExtType (PrimET primType)) i | isIntegralCPrimType primType = return $ IntResult i-evalCCast' _ _ = todo "GenBind.evalCCast': Only integral trivial casts are implemented" - +evalCCast' _ _ = todo "GenBind.evalCCast': Only integral trivial casts are implemented"+ evalCConst :: CConst -> GB ConstResult evalCConst (CIntConst i _ ) = return $ IntResult (getCInteger i) evalCConst (CCharConst c _ ) = return $ IntResult (getCCharAsInt c)
src/C2HS/Gen/Header.hs view
@@ -53,8 +53,8 @@ import Language.C.Pretty import Language.C.Syntax import Data.Errors (interr)-import Data.DLists (DList)-import qualified Data.DLists as DL+import Data.DList (DList)+import qualified Data.DList as DL -- C->Haskell import C2HS.State (CST, runCST, transCST, raiseError, catchExc,@@ -132,7 +132,7 @@ (header, frags', last', _rest) <- ghFrags frags when (not . isEOF $ last') $ notOpenCondErr (posOf last')- return (DL.close header, CHSModule frags')+ return (DL.toList header, CHSModule frags') -- | Collect header and fragments up to eof or a CPP directive that is part of a -- conditional@@ -142,7 +142,7 @@ -- concatenation of lines that go into the header. -- ghFrags :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])-ghFrags [] = return (DL.zero, [], EOF, [])+ghFrags [] = return (DL.empty, [], EOF, []) ghFrags frags = do (header, frag, rest) <- ghFrag frags@@ -150,7 +150,7 @@ Frag aFrag -> do (header2, frags', frag', rest') <- ghFrags rest -- FIXME: Not tail rec- return (header `DL.join` header2, aFrag:frags',+ return (header `DL.append` header2, aFrag:frags', frag', rest') _ -> return (header, [], frag, rest) @@ -162,16 +162,16 @@ FragElem, -- processed fragment [CHSFrag]) -- not yet processed fragments ghFrag [] =- return (DL.zero, EOF, [])+ return (DL.empty, EOF, []) ghFrag (frag@(CHSVerb _ _ ) : frags) =- return (DL.zero, Frag frag, 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) = do ide <- newEnumIdent (enrs,trans') <- createEnumerators trans- return (DL.open [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))@@ -187,13 +187,13 @@ enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident) trans' Nothing Nothing instances pos) hkpos ghFrag (frag@(CHSHook _ _) : frags) =- return (DL.zero, Frag frag, frags)+ return (DL.empty, Frag frag, frags) ghFrag (frag@(CHSLine _ ) : frags) =- return (DL.zero, Frag frag, frags)+ return (DL.empty, Frag frag, frags) ghFrag ( (CHSC s _ ) : frags) = do (header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment- return (DL.unit s `DL.join` header, frag, frags')+ return (DL.singleton s `DL.append` header, frag, frags') -- FIXME: this is not tail recursive... ghFrag ( (CHSCond _ _ ) : _ ) =@@ -208,10 +208,10 @@ "if" -> openIf s pos frags "ifdef" -> openIf s pos frags "ifndef" -> openIf s pos frags- "else" -> return (DL.zero , Else pos , frags)- "elif" -> return (DL.zero , Elif s pos , frags)- "endif" -> return (DL.zero , Endif pos , frags)- _ -> return (DL.open ['#':s, "\n"],+ "else" -> return (DL.empty , Else pos , frags)+ "elif" -> return (DL.empty , Elif s pos , frags)+ "endif" -> return (DL.empty , Endif pos , frags)+ _ -> return (DL.fromList ['#':s, "\n"], Frag (CHSVerb (if nl then "\n" else "") pos), frags) where -- enter a new conditional (may be an #if[[n]def] or #elif)@@ -231,7 +231,7 @@ Endif _ -> closeIf ((headerTh `DL.snoc` "#else\n")- `DL.join`+ `DL.append` (headerEl `DL.snoc` "#endif\n")) (s', fragsTh)@@ -243,7 +243,7 @@ (headerEl, condFrag, rest') <- openIf s'' pos' rest case condFrag of Frag (CHSCond alts dft) ->- closeIf (headerTh `DL.join` headerEl)+ closeIf (headerTh `DL.append` headerEl) (s, fragsTh) alts dft@@ -270,9 +270,9 @@ -- don't use an internal ident, as we need to test for -- equality with identifiers read from the .i file -- during binding hook expansion- header = DL.open ['#':s', "\n",+ header = DL.fromList ['#':s', "\n", "struct ", sentryName, ";\n"]- `DL.join` headerTail+ `DL.append` headerTail return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest)
src/C2HS/Gen/Monad.hs view
@@ -223,16 +223,35 @@ show (Class osuper pointer ) = "Class " ++ show ptrType ++ show isNewtype -}++-- Remove everything until the next element in the list (given by a+-- ","), the end of the list (marked by "]"), or the end of a record+-- "}". Everything inside parenthesis is ignored.+chopIdent :: String -> String+chopIdent str = goChop 0 str+ where goChop :: Int -> String -> String+ goChop 0 rest@('}':_) = rest+ goChop 0 rest@(',':_) = rest+ goChop 0 rest@(']':_) = rest+ goChop level ('(':rest) = goChop (level+1) rest+ goChop level (')':rest) = goChop (level-1) rest+ goChop level (_ :rest) = goChop level rest+ goChop level [] = []++extractIdent :: String -> (Ident, String)+extractIdent str =+ let isQuote c = c == '\'' || c == '"'+ (ideChars, rest) = span (not . isQuote)+ . tail+ . dropWhile (not . isQuote) $ str+ in+ if null ideChars+ then error $ "Could not interpret " ++ show str ++ "as an Ident."+ else (internalIdent ideChars, (chopIdent . tail) rest)+ -- super kludgy (depends on Show instance of Ident) instance Read Ident where- readsPrec _ ('`':lexeme) = let (ideChars, rest) = span (/= '\'') lexeme- in- if null ideChars- then []- else [(internalIdent ideChars, tail rest)]- readsPrec p (c:cs)- | isSpace c = readsPrec p cs- readsPrec _ _ = []+ readsPrec _ str = [extractIdent str] -- | the local state consists of --@@ -467,4 +486,3 @@ ["Unknown name!", "`" ++ identToString ide ++ "' is unknown; it has *not* been defined by", "a previous hook."]-
src/C2HS/Version.hs view
@@ -9,8 +9,8 @@ name = "C->Haskell Compiler" versnum = Paths_c2hs.version-versnick = "Crystal Seed"-date = "24 Jan 2009"+versnick = "The shapeless maps"+date = "31 Oct 2014" version = name ++ ", version " ++ showVersion versnum ++ " " ++ versnick ++ ", " ++ date copyright = "Copyright (c) 1999-2007 Manuel M T Chakravarty\n" ++ " 2005-2008 Duncan Coutts\n"
src/Control/StateBase.hs view
@@ -56,6 +56,8 @@ import Data.Errors (ErrorLevel(..), Error) import Language.C.Data.Name +import Control.Applicative (Applicative(..))+import Control.Monad (liftM, ap) -- state used in the whole compiler -- --------------------------------@@ -80,6 +82,13 @@ -- newtype PreCST e s a = CST (STB (BaseState e) s a)++instance Functor (PreCST e s) where+ fmap = liftM++instance Applicative (PreCST e s) where+ pure = return+ (<*>) = ap instance Monad (PreCST e s) where return = yield
src/Control/StateTrans.hs view
@@ -73,6 +73,9 @@ throwExc, fatal, catchExc, fatalsHandledBy) where ++import Control.Applicative (Applicative(..))+import Control.Monad (liftM, ap) import Control.Exception (catch) import Prelude hiding (catch) @@ -98,6 +101,13 @@ -- @Right a@ -- is a successfully delivered result -- newtype STB bs gs a = STB (bs -> gs -> IO (bs, gs, Either (String, String) a))++instance Functor (STB bs gs) where+ fmap = liftM++instance Applicative (STB bs gs) where+ pure = return+ (<*>) = ap instance Monad (STB bs gs) where return = yield
− src/Data/DLists.hs
@@ -1,66 +0,0 @@--- The Compiler Toolkit: difference lists------ Author : Manuel M. T. Chakravarty--- Created: 24 February 95------ Copyright (c) [1995..2000] Manuel M. T. Chakravarty------ This library is free software; you can redistribute it and/or--- modify it under the terms of the GNU Library General Public--- License as published by the Free Software Foundation; either--- version 2 of the License, or (at your option) any later version.------ This library is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- Library General Public License for more details.------- DESCRIPTION --------------------------------------------------------------------- This module provides the functional equivalent of the difference lists--- from logic programming. They provide an O(1) append.------- DOCU ---------------------------------------------------------------------------- language: Haskell 98------- TODO ---------------------------------------------------------------------------module Data.DLists (DList, open, zero, unit, snoc, join, close)-where---- | a difference list is a function that given a list returns the original--- contents of the difference list prepended at the given list----type DList a = [a] -> [a]---- | open a list for use as a difference list----open :: [a] -> DList a-open = (++)---- | create a difference list containing no elements----zero :: DList a-zero = id---- | create difference list with given single element----unit :: a -> DList a-unit = (:)---- | append a single element at a difference list----snoc :: DList a -> a -> DList a-snoc dl x = \l -> dl (x:l)---- | appending difference lists----join :: DList a -> DList a -> DList a-join = (.)---- | closing a difference list into a normal list----close :: DList a -> [a]-close = ($[])
src/Main.hs view
@@ -124,7 +124,7 @@ import System.Console.GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) import qualified System.FilePath as FilePath- (takeExtension, dropExtension, takeBaseName)+ (takeDirectory, takeExtension, dropExtension) import System.FilePath ((<.>), (</>), splitSearchPath) import System.IO (stderr, openFile, IOMode(..)) import System.IO.Error (ioeGetErrorString, ioeGetFileName)@@ -136,7 +136,7 @@ traceSet, setSwitch, getSwitch, putTraceStr) import qualified System.CIO as CIO import C2HS.C (hsuffix, isuffix, loadAttrC)-import C2HS.CHS (loadCHS, dumpCHS, hssuffix, chssuffix, dumpCHI)+import C2HS.CHS (loadCHS, dumpCHS, hssuffix, chssuffix, dumpCHI, hasNonGNU) import C2HS.Gen.Header (genHeader) import C2HS.Gen.Bind (expandHooks) import C2HS.Version (versnum, version, copyright, disclaimer)@@ -178,8 +178,6 @@ -- data Flag = CPPOpts String -- ^ additional options for C preprocessor | CPP String -- ^ program name of C preprocessor- | NoGNU -- ^ suppress GNU preprocessor symbols- | NoBlocks -- ^ suppress MacOS __BLOCKS__ preproc. symbol | Dump DumpType -- ^ dump internal information | Help -- ^ print brief usage information | Keep -- ^ keep the .i file@@ -211,14 +209,6 @@ ["cpp"] (ReqArg CPP "CPP") "use executable CPP to invoke C preprocessor",- Option ['n']- ["no-gnu"]- (NoArg NoGNU)- "suppress GNU preprocessor symbols",- Option ['b']- ["no-blocks"]- (NoArg NoBlocks)- "suppress MacOS __BLOCKS__ preprocessor symbol", Option ['d'] ["dump"] (ReqArg dumpArg "TYPE")@@ -279,7 +269,7 @@ do setup cmdLine <- CIO.getArgs- case getOpt RequireOrder options cmdLine of+ case getOpt Permute options cmdLine of (opts, [] , []) | noCompOpts opts -> doExecute opts Nothing (opts, args, []) -> case parseArgs args of@@ -330,7 +320,8 @@ fnMsg = case ioeGetFileName err of Nothing -> "" Just s -> " (file: `" ++ s ++ "')"- CIO.hPutStrLn stderr (msg ++ fnMsg)+ name <- CIO.getProgName+ CIO.hPutStrLn stderr $ concat [name, ": ", msg, fnMsg] CIO.exitWith $ CIO.ExitFailure 1 -- | set up base configuration@@ -370,19 +361,11 @@ let bndFileWithoutSuffix = FilePath.dropExtension bndFile computeOutputName bndFileWithoutSuffix process headerFiles bndFileWithoutSuffix- `fatalsHandledBy` die Nothing -> computeOutputName "." -- we need the output name for library copying copyLibrary- `fatalsHandledBy` die where atMostOne = (foldl (\_ x -> [x]) [])- --- die ioerr =- do- name <- CIO.getProgName- CIO.putStr $ name ++ ": " ++ ioeGetErrorString ioerr ++ "\n"- CIO.exitWith $ CIO.ExitFailure 1 -- | emit help message --@@ -403,8 +386,6 @@ processOpt :: Flag -> CST s () processOpt (CPPOpts cppopt ) = addCPPOpts [cppopt] processOpt (CPP cpp ) = setCPP cpp-processOpt (NoGNU ) = setNoGNU-processOpt (NoBlocks ) = setNoBlocks processOpt (Dump dt ) = setDump dt processOpt (Keep ) = setKeep processOpt (Library ) = setLibrary@@ -465,16 +446,6 @@ setCPP :: FilePath -> CST s () setCPP fname = setSwitch $ \sb -> sb {cppSB = fname} --- | set flag to suppress GNU preprocessor symbols----setNoGNU :: CST s ()-setNoGNU = setSwitch $ \sb -> sb {noGnuSB = True}---- | set flag to suppress MacOS __BLOCKS__ preprocessor symbols----setNoBlocks :: CST s ()-setNoBlocks = setSwitch $ \sb -> sb {noBlocksSB = True}- -- set the given dump option -- setDump :: DumpType -> CST s ()@@ -551,8 +522,22 @@ -- (chsMod , warnmsgs) <- loadCHS bndFile CIO.putStr warnmsgs- traceCHSDump chsMod --+ -- get output directory and create it if it's missing+ --+ outFName <- getSwitch outputSB+ outDir <- getSwitch outDirSB+ let outFPath = outDir </> outFName+ CIO.createDirectoryIfMissing True $ FilePath.takeDirectory outFPath+ --+ -- dump the binding file when demanded+ --+ flag <- traceSet dumpCHSSW+ when flag $ do+ let chsName = outFPath <.> "dump"+ CIO.putStrLn $ "...dumping CHS to `" ++ chsName ++ "'..."+ dumpCHS chsName chsMod False+ -- -- extract CPP and inline-C embedded in the .chs file (all CPP and -- inline-C fragments are removed from the .chs tree and conditionals are -- replaced by structured conditionals)@@ -563,11 +548,9 @@ -- create new header file, make it #include `headerFile', and emit -- CPP and inline-C of .chs file into the new header --- outFName <- getSwitch outputSB- outDir <- getSwitch outDirSB let newHeader = outFName <.> chssuffix <.> hsuffix newHeaderFile = outDir </> newHeader- preprocFile = FilePath.takeBaseName outFName <.> isuffix+ preprocFile = outFPath <.> isuffix CIO.writeFile newHeaderFile $ concat $ [ "#include \"" ++ headerFile ++ "\"\n" | headerFile <- headerFiles ]@@ -586,14 +569,17 @@ -- cpp <- getSwitch cppSB cppOpts <- getSwitch cppOptsSB- noGnu <- getSwitch noGnuSB- noBlocks <- getSwitch noBlocksSB- let noGnuOpts =- if noGnu- then ["-U__GNUC__", "-U__GNUC_MINOR__", "-U__GNUC_PATCHLEVEL__"]+ let nonGNUOpts =+ 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)" ] else []- noBlocksOpts = if noBlocks then ["-U__BLOCKS__"] else []- args = cppOpts ++ noGnuOpts ++ noBlocksOpts ++ [newHeaderFile]+ args = cppOpts ++ nonGNUOpts ++ ["-U__BLOCKS__"] ++ [newHeaderFile] tracePreproc (unwords (cpp:args)) exitCode <- CIO.liftIO $ do preprocHnd <- openFile preprocFile WriteMode@@ -627,17 +613,8 @@ -- -- output the result --- dumpCHS (outDir </> outFName) hsMod True- dumpCHI (outDir </> outFName) chi -- different suffix will be appended+ dumpCHS outFPath hsMod True+ dumpCHI outFPath chi -- different suffix will be appended where tracePreproc cmd = putTraceStr tracePhasesSW $ "Invoking cpp as `" ++ cmd ++ "'...\n"- traceCHSDump mod' = do- flag <- traceSet dumpCHSSW- when flag $- (do- CIO.putStr ("...dumping CHS to `" ++ chsName- ++ "'...\n")- dumpCHS chsName mod' False)-- chsName = FilePath.takeBaseName bndFile <.> "dump"
src/System/CIO.hs view
@@ -50,7 +50,7 @@ -- -- `Directory' --- doesFileExist, removeFile,+ createDirectoryIfMissing, doesFileExist, removeFile, -- -- `System' --@@ -64,10 +64,11 @@ import Prelude (Bool, Char, String, FilePath, (.), ($), Show, return) import qualified System.IO as IO-import qualified System.Directory as IO (doesFileExist, removeFile)+import qualified System.Directory as IO+ (createDirectoryIfMissing, doesFileExist, removeFile) import qualified System.Environment as IO (getArgs, getProgName)-import qualified System.Cmd as IO (system)-import qualified System.Exit as IO (ExitCode(..), exitWith)+import qualified System.Process as IO (system)+import qualified System.Exit as IO (ExitCode(..), exitWith) import Control.StateBase (PreCST, liftIO) @@ -149,6 +150,9 @@ -- `Directory' -- -----------++createDirectoryIfMissing :: Bool -> FilePath -> PreCST e s ()+createDirectoryIfMissing p = liftIO . IO.createDirectoryIfMissing p doesFileExist :: FilePath -> PreCST e s Bool doesFileExist = liftIO . IO.doesFileExist
src/Text/Lexers.hs view
@@ -136,7 +136,7 @@ import Data.Array (Array, (!), assocs, accumArray) import Language.C.Data.Position -import qualified Data.DLists as DL+import qualified Data.DList as DL import Data.Errors (interr, ErrorLevel(..), Error, makeError) @@ -450,7 +450,7 @@ -- -- lexOne :: Lexer s t -> LexerState s t -- -> (Either Error (Maybe t), Lexer s t, LexerState s t)- lexOne l0 state' = oneLexeme l0 state' DL.zero lexErr+ lexOne l0 state' = oneLexeme l0 state' DL.empty lexErr where -- the result triple of `lexOne' that signals a lexical error; -- the result state is advanced by one character for error correction@@ -504,7 +504,7 @@ -- execute the action if present and finalise the current lexeme -- action (Action f) csDL (cs, pos, s) _last =- case f (DL.close csDL) pos s of+ case f (DL.toList csDL) pos s of (Nothing, pos', s', l') | not . null $ cs -> lexOne (fromMaybe l0 l') (cs, pos', s') (res , pos', s', l') -> (res, (fromMaybe l0 l'), (cs, pos', s'))
− tests/bugs/issue-51/Issue51.chs
@@ -1,15 +0,0 @@-module Main where--import Foreign.C--#include "issue51.h"--foo :: CInt -> CInt-#ifdef __GNUC__-foo = {#call pure fooGnu#}-#else-foo = {#call pure fooNonGnu#}-#endif--main :: IO ()-main = print $ foo 0
+ tests/bugs/issue-51/Issue51_GNU.chs view
@@ -0,0 +1,15 @@+module Main where++import Foreign.C++#include "issue51.h"++foo :: CInt -> CInt+#ifdef __GNUC__+foo = {#call pure fooGnu#}+#else+foo = {#call pure fooNonGnu#}+#endif++main :: IO ()+main = print $ foo 0
+ tests/bugs/issue-51/Issue51_nonGNU.chs view
@@ -0,0 +1,16 @@+module Main where++import Foreign.C++{#nonGNU#}+#include "issue51.h"++foo :: CInt -> CInt+#ifdef __GNUC__+foo = {#call pure fooGnu#}+#else+foo = {#call pure fooNonGnu#}+#endif++main :: IO ()+main = print $ foo 0
tests/regression-suite.hs view
@@ -19,6 +19,7 @@ , flags :: [Text] , aptPPA :: [Text] , aptPackages :: [Text]+ , cabalBuildTools :: [Text] , specialSetup :: [Text] , extraPath :: [Text] } deriving (Eq, Show)@@ -29,6 +30,7 @@ <*> v .:? "flags" .!= [] <*> v .:? "apt-ppa" .!= [] <*> v .:? "apt-packages" .!= []+ <*> v .:? "cabal-build-tools" .!= [] <*> v .:? "special-setup" .!= [] <*> v .:? "extra-path" .!= [] parseJSON _ = mzero@@ -55,12 +57,16 @@ tests <- liftIO $ readTests "tests/regression-suite.yaml" let ppas = nub $ concatMap aptPPA tests pkgs = nub $ concatMap aptPackages tests+ buildTools = nub $ concatMap cabalBuildTools tests specials = concatMap specialSetup tests extraPaths = concatMap extraPath tests when (not travis) $ echo "ASSUMING THAT ALL NECESSARY LIBRARIES ALREADY INSTALLED!\n" + home <- fromText <$> get_env_text "HOME"+ appendToPath $ home </> ".cabal/bin"+ when travis $ do when (not (null ppas)) $ do echo "SETTING UP APT PPAS\n"@@ -94,7 +100,7 @@ Just efs -> infs ++ concatMap (\f -> ["-f", f]) (T.splitOn "," efs) echo $ "\nREGRESSION TEST: " <> n <> "\n" errExit False $ do- run_ "cabal" $ ["install"] ++ fs ++ [n]+ run_ "cabal" $ ["install", "--jobs=1"] ++ fs ++ [n] lastExitCode if all (== 0) codes
tests/test-bugs.hs view
@@ -5,22 +5,37 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, assert) import System.FilePath (searchPathSeparator)+import Prelude hiding (FilePath)+import Control.Monad.IO.Class import Shelly import Data.Text (Text) import Data.Monoid import qualified Data.Text as T+import Paths_c2hs default (T.Text) main :: IO () main = defaultMain tests +c2hsShelly :: MonadIO m => Sh a -> m a+c2hsShelly as = shelly $ do+ oldpath <- get_env_text "PATH"+ let newpath = "../../../dist/build/c2hs:" <> oldpath+ setenv "PATH" newpath+ as+ tests :: [Test] tests = [ testGroup "Bugs" [ testCase "call_capital (issue #??)" call_capital+ , 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@@ -43,7 +58,7 @@ ] call_capital :: Assertion-call_capital = shelly $ chdir "tests/bugs/call_capital" $ do+call_capital = c2hsShelly $ chdir "tests/bugs/call_capital" $ do mapM_ rm_f ["Capital.hs", "Capital.chs.h", "Capital.chi", "Capital_c.o", "Capital"] cmd "c2hs" "-d" "genbind" "Capital.chs"@@ -53,6 +68,18 @@ let expected = ["upper C();", "lower c();", "upper C();"] liftIO $ assertBool "" (T.lines res == expected) +issue96 :: Assertion+issue96 = build_issue 96++issue95 :: Assertion+issue95 = build_issue 95++issue93 :: Assertion+issue93 = build_issue 93++issue80 :: Assertion+issue80 = build_issue 80+ issue79 :: Assertion issue79 = expect_issue 79 ["A=1", "B=2", "C=2", "D=3"] @@ -62,6 +89,9 @@ issue69 :: Assertion issue69 = build_issue 69 +issue62 :: Assertion+issue62 = build_issue 62+ issue60 :: Assertion issue60 = build_issue 60 @@ -71,7 +101,9 @@ "3", "0.3", "3", "0.3"] issue51 :: Assertion-issue51 = expect_issue_with 51 ["--no-gnu"] ["0"]+issue51 = do+ expect_issue_with 51 "nonGNU" [] ["0"]+ expect_issue_with 51 "GNU" [] ["1"] issue47 :: Assertion issue47 = build_issue 47@@ -102,7 +134,7 @@ -- This is tricky to test since it's Windows-specific, but we can at -- least make sure that paths with spaces work OK. issue30 :: Assertion-issue30 = shelly $ chdir "tests/bugs/issue-30" $ do+issue30 = c2hsShelly $ chdir "tests/bugs/issue-30" $ do mkdir_p "test 1" mkdir_p "test 2" mapM_ rm_f ["Issue30.hs", "Issue30.chs.h", "Issue30.chi",@@ -113,7 +145,7 @@ mv "Issue30Aux1.chi" "test 1" cmd "c2hs" "Issue30Aux2.chs" mv "Issue30Aux2.chi" "test 2"- let sp = "test 1" ++ [searchPathSeparator] ++ "test 2"+ let sp = T.pack $ "test 1" ++ [searchPathSeparator] ++ "test 2" cmd "c2hs" "--include" sp "Issue30.chs" cmd "cc" "-c" "-o" "issue30_c.o" "issue30.c" cmd "cc" "-c" "-o" "issue30aux1_c.o" "issue30aux1.c"@@ -125,11 +157,11 @@ liftIO $ assertBool "" (T.lines res == expected) issue29 :: Assertion-issue29 = shelly $ do+issue29 = c2hsShelly $ do errExit False $ do cd "tests/bugs/issue-29" mapM_ rm_f ["Issue29.hs", "Issue29.chs.h", "Issue29.chi"]- run "c2hs" $ ["--no-blocks", toTextIgnore "Issue29.chs"]+ run "c2hs" [toTextIgnore "Issue29.chs"] code <- lastExitCode liftIO $ assertBool "" (code == 0) @@ -149,21 +181,22 @@ issue10 = expect_issue 10 ["SAME", "SAME", "SAME"] issue7 :: Assertion-issue7 = shelly $ do+issue7 = c2hsShelly $ do errExit False $ do cd "tests/bugs/issue-7" mapM_ rm_f ["Issue7.hs", "Issue7.chs.h", "Issue7.chi"] setenv "LANG" "zh_CN.utf8"- run "c2hs" $ [toTextIgnore "Issue7.chs"]+ run "c2hs" [toTextIgnore "Issue7.chs"] code <- lastExitCode liftIO $ assertBool "" (code == 0) -do_issue_build :: Int -> [Text] -> Sh ()-do_issue_build n c2hsargs =+do_issue_build :: Int -> String -> [Text] -> Sh ()+do_issue_build n ext c2hsargs = let wdir = "tests/bugs" </> ("issue-" <> show n) lc = "issue" <> show n lcc = lc <> "_c"- uc = fromText $ T.pack $ "Issue" <> show n+ uc = fromText $ T.pack $ "Issue" <> show n <>+ (if ext == "" then "" else "_" <> ext) in do cd wdir mapM_ rm_f [uc <.> "hs", uc <.> "chs.h", uc <.> "chi", lcc <.> "o", uc]@@ -172,17 +205,18 @@ cmd "ghc" "-Wall" "-Werror" "--make" (lcc <.> "o") (uc <.> "hs") expect_issue :: Int -> [Text] -> Assertion-expect_issue n expected = expect_issue_with n [] expected+expect_issue n expected = expect_issue_with n "" [] expected -expect_issue_with :: Int -> [Text] -> [Text] -> Assertion-expect_issue_with n c2hsargs expected = shelly $ do- do_issue_build n c2hsargs- res <- absPath ("." </> (fromText $ T.pack $ "Issue" <> show n)) >>= cmd+expect_issue_with :: Int -> String -> [Text] -> [Text] -> Assertion+expect_issue_with n ext c2hsargs expected = c2hsShelly $ do+ do_issue_build n ext c2hsargs+ res <- absPath ("." </> (fromText $ T.pack $ "Issue" <> show n <>+ (if ext == "" then "" else "_" <> ext))) >>= cmd liftIO $ assertBool "" (T.lines res == expected) build_issue_with :: Int -> [Text] -> Assertion-build_issue_with n c2hsargs = shelly $ do- errExit False $ do_issue_build n c2hsargs+build_issue_with n c2hsargs = c2hsShelly $ do+ errExit False $ do_issue_build n "" c2hsargs code <- lastExitCode liftIO $ assertBool "" (code == 0)
tests/test-system.hs view
@@ -4,16 +4,27 @@ import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, assert)+import Control.Monad.IO.Class import Shelly import qualified Shelly as Sh+import Prelude hiding (FilePath) import Control.Monad (forM_) import Data.Text (Text)+import Data.Monoid import qualified Data.Text as T+import Paths_c2hs default (T.Text) main :: IO () main = defaultMain tests +c2hsShelly :: MonadIO m => Sh a -> m a+c2hsShelly as = shelly $ do+ oldpath <- get_env_text "PATH"+ let newpath = "../../../dist/build/c2hs:" <> oldpath+ setenv "PATH" newpath+ as+ tests :: [Test] tests = [ testGroup "System"@@ -29,7 +40,7 @@ ] run_test_exit_code :: Sh.FilePath -> [(Sh.FilePath, [Text])] -> Assertion-run_test_exit_code dir cmds = shelly $ chdir dir $ do+run_test_exit_code dir cmds = c2hsShelly $ chdir dir $ do forM_ (init cmds) $ \(c, as) -> run c as errExit False $ run (fst $ last cmds) (snd $ last cmds) code <- lastExitCode@@ -37,7 +48,7 @@ run_test_expect :: Sh.FilePath -> [(Sh.FilePath, [Text])] -> Sh.FilePath -> [Text] -> Assertion-run_test_expect dir cmds expcmd expected = shelly $ chdir dir $ do+run_test_expect dir cmds expcmd expected = c2hsShelly $ chdir dir $ do forM_ cmds $ \(c, as) -> run c as res <- absPath expcmd >>= cmd liftIO $ assertBool "" (T.lines res == expected)