diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +0.17.1 + + - Fix regressions from 0.16.6 (caused by fix for issue #45) + - Version number bump (should have been done in the last release) + + 0.16.6 - Trivial integer casts in enum defines supporting typedefs [Anton Dessiatov] diff --git a/c2hs.cabal b/c2hs.cabal --- a/c2hs.cabal +++ b/c2hs.cabal @@ -1,5 +1,5 @@ Name: c2hs -Version: 0.16.6 +Version: 0.17.1 License: GPL-2 License-File: COPYING Copyright: Copyright (c) 1999-2007 Manuel M T Chakravarty @@ -120,7 +120,7 @@ test-framework, test-framework-hunit, HUnit, - shelly >= 0.15.4.1 && < 1.0, + shelly >= 1.0, text Test-Suite test-system @@ -132,5 +132,5 @@ test-framework, test-framework-hunit, HUnit, - shelly >= 0.15.4.1 && < 1.0, + shelly >= 1.0, text diff --git a/src/C2HS/CHS.hs b/src/C2HS/CHS.hs --- a/src/C2HS/CHS.hs +++ b/src/C2HS/CHS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StandaloneDeriving #-} -- C->Haskell Compiler: CHS file abstraction -- -- Author : Manuel M T Chakravarty @@ -126,6 +127,15 @@ -- data CHSModule = CHSModule [CHSFrag] +deriving instance Show CHSModule +deriving instance Show CHSFrag +deriving instance Show CHSHook +deriving instance Show CHSAccess +deriving instance Show CHSParm +deriving instance Show CHSTrans +deriving instance Show CHSArg +deriving instance Show CHSChangeCase + -- | a CHS code fragament -- -- * 'CHSVerb' fragments are present throughout the compilation and finally @@ -144,6 +154,7 @@ data CHSFrag = CHSVerb String -- Haskell code Position | CHSHook CHSHook -- binding hook + Position | CHSCPP String -- pre-processor directive Position Bool @@ -156,7 +167,7 @@ instance Pos CHSFrag where posOf (CHSVerb _ pos ) = pos - posOf (CHSHook hook ) = posOf hook + posOf (CHSHook _ pos ) = pos posOf (CHSCPP _ pos _) = pos posOf (CHSLine pos ) = pos posOf (CHSC _ pos ) = pos @@ -458,7 +469,7 @@ else id) . showString s . showFrags pureHs nextState frags - showFrags False _ (CHSHook hook : frags) = + showFrags False _ (CHSHook hook _ : frags) = showString "{#" . showCHSHook hook . showString "#}" @@ -810,19 +821,32 @@ frags <- parseFrags toks return $ CHSLine pos : frags parseFrags0 (CHSTokC pos s:toks) = parseC pos s toks - parseFrags0 (CHSTokImport pos :toks) = parseImport pos toks - parseFrags0 (CHSTokContext pos :toks) = parseContext pos toks - parseFrags0 (CHSTokType pos :toks) = parseType pos toks - parseFrags0 (CHSTokSizeof pos :toks) = parseSizeof pos toks - parseFrags0 (CHSTokAlignof pos :toks) = parseAlignof pos toks - parseFrags0 (CHSTokEnum pos :toks) = parseEnum pos toks - parseFrags0 (CHSTokCall pos :toks) = parseCall pos toks - parseFrags0 (CHSTokFun pos :toks) = parseFun pos toks - parseFrags0 (CHSTokGet pos :toks) = parseField pos CHSGet toks - parseFrags0 (CHSTokSet pos :toks) = parseField pos CHSSet toks - parseFrags0 (CHSTokOffsetof pos :toks) = parseOffsetof pos toks - parseFrags0 (CHSTokClass pos :toks) = parseClass pos toks - parseFrags0 (CHSTokPointer pos :toks) = parsePointer pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokImport pos :toks) = parseImport hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokContext pos :toks) = parseContext hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokType pos :toks) = parseType hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokSizeof pos :toks) = parseSizeof hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokAlignof pos :toks) = parseAlignof hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokEnum pos :toks) = parseEnum hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokCall pos :toks) = parseCall hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokFun pos :toks) = parseFun hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokGet pos :toks) = parseField hkpos pos CHSGet toks + parseFrags0 (CHSTokHook hkpos: + CHSTokSet pos :toks) = parseField hkpos pos CHSSet toks + parseFrags0 (CHSTokHook hkpos: + CHSTokOffsetof pos :toks) = parseOffsetof hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokClass pos :toks) = parseClass hkpos pos toks + parseFrags0 (CHSTokHook hkpos: + CHSTokPointer pos :toks) = parsePointer hkpos pos toks parseFrags0 toks = syntaxError toks -- -- skip to next Haskell or control token @@ -846,8 +870,8 @@ return $ CHSC s' pos' : frags collectCtrlAndC toks' = parseFrags toks' -parseImport :: Position -> [CHSToken] -> CST s [CHSFrag] -parseImport pos toks = do +parseImport :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseImport hkpos pos toks = do (qual, modid, toks') <- case toks of CHSTokIdent _ ide :toks' -> @@ -860,7 +884,7 @@ chi <- loadCHI . moduleNameToFileName . identToString $ modid toks'2 <- parseEndHook toks' frags <- parseFrags toks'2 - return $ CHSHook (CHSImport qual modid chi pos) : frags + return $ CHSHook (CHSImport qual modid chi pos) hkpos : frags -- | Qualified module names do not get lexed as a single token so we need to -- reconstruct it from a sequence of identifer and dot tokens. @@ -878,54 +902,54 @@ where dotToSlash '.' = '/' dotToSlash c = c -parseContext :: Position -> [CHSToken] -> CST s [CHSFrag] -parseContext pos toks = do +parseContext :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseContext hkpos pos toks = do (olib , toks2) <- parseOptLib toks (opref , toks3) <- parseOptPrefix False toks2 (oreppref, toks4) <- parseOptReplPrefix toks3 toks5 <- parseEndHook toks4 frags <- parseFrags toks5 let frag = CHSContext olib opref oreppref pos - return $ CHSHook frag : frags + return $ CHSHook frag hkpos : frags -parseType :: Position -> [CHSToken] -> CST s [CHSFrag] -parseType pos (CHSTokIdent _ ide:toks) = +parseType :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseType hkpos pos (CHSTokIdent _ ide:toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' - return $ CHSHook (CHSType ide pos) : frags -parseType _ toks = syntaxError toks + return $ CHSHook (CHSType ide pos) hkpos : frags +parseType _ _ toks = syntaxError toks -parseSizeof :: Position -> [CHSToken] -> CST s [CHSFrag] -parseSizeof pos (CHSTokIdent _ ide:toks) = +parseSizeof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseSizeof hkpos pos (CHSTokIdent _ ide:toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' - return $ CHSHook (CHSSizeof ide pos) : frags -parseSizeof _ toks = syntaxError toks + return $ CHSHook (CHSSizeof ide pos) hkpos : frags +parseSizeof _ _ toks = syntaxError toks -parseAlignof :: Position -> [CHSToken] -> CST s [CHSFrag] -parseAlignof pos (CHSTokIdent _ ide:toks) = +parseAlignof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseAlignof hkpos pos (CHSTokIdent _ ide:toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' - return $ CHSHook (CHSAlignof ide pos) : frags -parseAlignof _ toks = syntaxError toks + return $ CHSHook (CHSAlignof ide pos) hkpos : frags +parseAlignof _ _ toks = syntaxError toks -parseEnum :: Position -> [CHSToken] -> CST s [CHSFrag] +parseEnum :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] -- {#enum define hsid {alias_1,...,alias_n} [deriving (clid_1,...,clid_n)] #} -parseEnum pos (CHSTokIdent _ def: CHSTokIdent _ hsid: toks) +parseEnum hkpos pos (CHSTokIdent _ def: CHSTokIdent _ hsid: toks) | identToString def == "define" = do (trans , toks') <- parseTrans toks (derive, toks'') <- parseDerive toks' toks''' <- parseEndHook toks'' frags <- parseFrags toks''' - return $ CHSHook (CHSEnumDefine hsid trans derive pos) : frags + return $ CHSHook (CHSEnumDefine hsid trans derive pos) hkpos : frags -- {#enum cid [as hsid] {alias_1,...,alias_n} [with prefix = pref] [deriving (clid_1,...,clid_n)] #} -parseEnum pos (CHSTokIdent _ ide:toks) = +parseEnum hkpos pos (CHSTokIdent _ ide:toks) = do (oalias, toks2) <- parseOptAs ide True toks (trans, toks3) <- parseTrans toks2 @@ -935,15 +959,15 @@ toks7 <- parseEndHook toks6 frags <- parseFrags toks7 return $ CHSHook (CHSEnum ide (norm oalias) trans - oprefix oreplprefix derive pos) : frags + oprefix oreplprefix derive pos) hkpos : frags where norm Nothing = Nothing norm (Just ide') | ide == ide' = Nothing | otherwise = Just ide' -parseEnum _ toks = syntaxError toks +parseEnum _ _ toks = syntaxError toks -parseCall :: Position -> [CHSToken] -> CST s [CHSFrag] -parseCall pos toks = +parseCall :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseCall hkpos pos toks = do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'' ) <- parseIsUnsafe toks' @@ -952,10 +976,10 @@ toks''''' <- parseEndHook toks'''' frags <- parseFrags toks''''' return $ - CHSHook (CHSCall isPure isUnsafe apath oalias pos) : frags + CHSHook (CHSCall isPure isUnsafe apath oalias pos) hkpos : frags -parseFun :: Position -> [CHSToken] -> CST s [CHSFrag] -parseFun pos toks = +parseFun :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseFun hkpos pos toks = do (isPure , toks' ) <- parseIsPure toks (isUnsafe, toks'2) <- parseIsUnsafe toks' @@ -968,7 +992,7 @@ frags <- parseFrags toks'8 return $ CHSHook - (CHSFun isPure isUnsafe apath oalias octxt parms parm pos) : + (CHSFun isPure isUnsafe apath oalias octxt parms parm pos) hkpos : frags where parseOptContext (CHSTokHSVerb _ ctxt:CHSTokDArrow _:toks') = @@ -1050,24 +1074,24 @@ parseOptMarshType toks' = return (CHSValArg, toks') -parseField :: Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag] -parseField pos access toks = +parseField :: Position -> Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag] +parseField hkpos pos access toks = do (path, toks') <- parsePath toks toks'' <- parseEndHook toks' frags <- parseFrags toks'' - return $ CHSHook (CHSField access path pos) : frags + return $ CHSHook (CHSField access path pos) hkpos : frags -parseOffsetof :: Position -> [CHSToken] -> CST s [CHSFrag] -parseOffsetof pos toks = +parseOffsetof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseOffsetof hkpos pos toks = do (path, toks') <- parsePath toks toks'' <- parseEndHook toks' frags <- parseFrags toks'' - return $ CHSHook (CHSOffsetof path pos) : frags + return $ CHSHook (CHSOffsetof path pos) hkpos : frags -parsePointer :: Position -> [CHSToken] -> CST s [CHSFrag] -parsePointer pos toks = +parsePointer :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parsePointer hkpos pos toks = do (isStar, ide, toks') <- case toks of @@ -1092,7 +1116,7 @@ return $ CHSHook (CHSPointer - isStar ide (norm ide oalias) ptrType isNewtype oRefType emit pos) + isStar ide (norm ide oalias) ptrType isNewtype oRefType emit pos) hkpos : frags where parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken]) @@ -1104,8 +1128,8 @@ norm ide (Just ide') | ide == ide' = Nothing | otherwise = Just ide' -parseClass :: Position -> [CHSToken] -> CST s [CHSFrag] -parseClass pos (CHSTokIdent _ sclassIde: +parseClass :: Position -> Position -> [CHSToken] -> CST s [CHSFrag] +parseClass hkpos pos (CHSTokIdent _ sclassIde: CHSTokDArrow _ : CHSTokIdent _ classIde : CHSTokIdent _ typeIde : @@ -1113,15 +1137,16 @@ do toks' <- parseEndHook toks frags <- parseFrags toks' - return $ CHSHook (CHSClass (Just sclassIde) classIde typeIde pos) : frags -parseClass pos (CHSTokIdent _ classIde : - CHSTokIdent _ typeIde : - toks) = + return $ CHSHook (CHSClass (Just sclassIde) + classIde typeIde pos) hkpos : frags +parseClass hkpos pos (CHSTokIdent _ classIde : + CHSTokIdent _ typeIde : + toks) = do toks' <- parseEndHook toks frags <- parseFrags toks' - return $ CHSHook (CHSClass Nothing classIde typeIde pos) : frags -parseClass _ toks = syntaxError toks + return $ CHSHook (CHSClass Nothing classIde typeIde pos) hkpos : frags +parseClass _ _ toks = syntaxError toks parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken]) parseOptLib (CHSTokLib _ : diff --git a/src/C2HS/CHS/Lexer.hs b/src/C2HS/CHS/Lexer.hs --- a/src/C2HS/CHS/Lexer.hs +++ b/src/C2HS/CHS/Lexer.hs @@ -204,6 +204,7 @@ | CHSTokRBrace Position -- `}' | CHSTokLParen Position -- `(' | CHSTokRParen Position -- `)' + | CHSTokHook Position -- `{#' | CHSTokEndHook Position -- `#}' | CHSTokAdd Position -- `add' | CHSTokAs Position -- `as' @@ -599,7 +600,8 @@ -- hook :: CHSLexer hook = string "{#" - `lexmeta` \_ pos s -> (Nothing, incPos pos 2, s, Just bhLexer) + `lexmeta` \_ pos s -> (Just $ Right (CHSTokHook pos), + incPos pos 2, s, Just bhLexer) -- | start marker: used to identify pre-processor directive at -- beginning of input -- this lexer just drops the start marker if it diff --git a/src/C2HS/Gen/Bind.hs b/src/C2HS/Gen/Bind.hs --- a/src/C2HS/Gen/Bind.hs +++ b/src/C2HS/Gen/Bind.hs @@ -362,9 +362,9 @@ expandFrag :: CHSFrag -> GB [CHSFrag] expandFrag verb@(CHSVerb _ _ ) = return [verb] expandFrag line@(CHSLine _ ) = return [line] -expandFrag (CHSHook h ) = +expandFrag (CHSHook h pos) = do - code <- expandHook h + code <- expandHook h pos return [CHSVerb code builtinPos] `ifCTExc` return [CHSVerb "** ERROR **" builtinPos] expandFrag (CHSCPP s _ _) = @@ -398,20 +398,20 @@ else traceGenBind "Choosing else branch.\n" -expandHook :: CHSHook -> GB String -expandHook (CHSImport qual ide chi _) = +expandHook :: CHSHook -> Position -> GB String +expandHook (CHSImport qual ide chi _) _ = do mergeMaps chi return $ "import " ++ (if qual then "qualified " else "") ++ identToString ide -expandHook (CHSContext olib oprefix orepprefix _) = +expandHook (CHSContext olib oprefix orepprefix _) _ = do setContext olib oprefix orepprefix -- enter context information -- use the prefix on name spaces when (isJust oprefix) $ applyPrefixToNameSpaces (fromJust oprefix) (maybe "" id orepprefix) return "" -expandHook (CHSType ide pos) = +expandHook (CHSType ide pos) _ = do traceInfoType decl <- findAndChaseDecl ide False True -- no indirection, but shadows @@ -424,7 +424,7 @@ traceInfoDump decl ty = traceGenBind $ "Declaration\n" ++ show decl ++ "\ntranslates to\n" ++ showExtType ty ++ "\n" -expandHook (CHSAlignof ide _) = +expandHook (CHSAlignof ide _) _ = do traceInfoAlignof decl <- findAndChaseDecl ide False True -- no indirection, but shadows @@ -437,7 +437,7 @@ "Alignment of declaration\n" ++ show decl ++ "\nis " ++ show align ++ "\n" -expandHook (CHSSizeof ide _) = +expandHook (CHSSizeof ide _) _ = do traceInfoSizeof decl <- findAndChaseDecl ide False True -- no indirection, but shadows @@ -449,9 +449,9 @@ traceInfoDump decl size = traceGenBind $ "Size of declaration\n" ++ show decl ++ "\nis " ++ show (padBits size) ++ "\n" -expandHook (CHSEnumDefine _ _ _ _) = +expandHook (CHSEnumDefine _ _ _ _) _ = interr "Binding generation error : enum define hooks should be eliminated via preprocessing " -expandHook (CHSEnum cide oalias chsTrans oprefix orepprefix derive pos) = +expandHook (CHSEnum cide oalias chsTrans oprefix orepprefix derive pos) _ = do -- get the corresponding C declaration -- @@ -471,7 +471,7 @@ let trans = transTabToTransFun pfx reppfx chsTrans hide = identToString . fromMaybe cide $ oalias enumDef enum hide trans (map identToString derive) pos -expandHook hook@(CHSCall isPure isUns (CHSRoot _ ide) oalias pos) = +expandHook hook@(CHSCall isPure isUns (CHSRoot _ ide) oalias pos) _ = do traceEnter -- get the corresponding C declaration; raises error if not found or not a @@ -487,7 +487,7 @@ where traceEnter = traceGenBind $ "** Call hook for `" ++ identToString ide ++ "':\n" -expandHook hook@(CHSCall isPure isUns apath oalias pos) = +expandHook hook@(CHSCall isPure isUns apath oalias pos) _ = do traceEnter @@ -518,9 +518,11 @@ "** Indirect call hook for `" ++ identToString (apathToIdent apath) ++ "':\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" -expandHook (CHSFun isPure isUns (CHSRoot _ ide) oalias ctxt parms parm pos) = +expandHook (CHSFun isPure isUns (CHSRoot _ ide) + oalias ctxt parms parm pos) hkpos = do traceEnter + traceGenBind $ "ide = '" ++ show ide ++ "'\n" -- get the corresponding C declaration; raises error if not found or not a -- function; we use shadow identifiers, so the returned identifier is used -- afterwards instead of the original one @@ -535,11 +537,11 @@ callImport callHook isPure isUns (identToString cide) fiLexeme cdecl' pos extTy <- extractFunType pos cdecl' True - funDef isPure hsLexeme fiLexeme extTy ctxt parms parm Nothing pos + funDef isPure hsLexeme fiLexeme extTy ctxt parms parm Nothing pos hkpos where traceEnter = traceGenBind $ "** Fun hook for `" ++ identToString ide ++ "':\n" -expandHook (CHSFun isPure isUns apath oalias ctxt parms parm pos) = +expandHook (CHSFun isPure isUns apath oalias ctxt parms parm pos) hkpos = do traceEnter @@ -567,7 +569,7 @@ set_get <- setGet pos CHSGet offsets ptrTy funDef isPure hsLexeme fiLexeme (FunET ptrTy $ purify ty) - ctxt parms parm (Just set_get) pos + ctxt parms parm (Just set_get) pos hkpos where -- remove IO from the result type of a function ExtType. necessary -- due to an unexpected interaction with the way funDef works @@ -579,7 +581,7 @@ "** Fun hook for `" ++ identToString (apathToIdent apath) ++ "':\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" -expandHook (CHSField access path pos) = +expandHook (CHSField access path pos) _ = do traceInfoField traceGenBind $ "path = " ++ show path ++ "\n" @@ -597,7 +599,7 @@ ++ show (length offsets) ++ "\n" traceValueType et = traceGenBind $ "Type of accessed value: " ++ showExtType et ++ "\n" -expandHook (CHSOffsetof path pos) = +expandHook (CHSOffsetof path pos) _ = do traceGenBind $ "** offsetof hook:\n" (decl, offsets) <- accessPath path @@ -620,7 +622,7 @@ SUType _ -> return offset checkType _ _ = offsetDerefErr pos expandHook (CHSPointer isStar cName oalias ptrKind isNewtype oRefType emit - pos) = + pos) _ = do traceInfoPointer let hsIde = fromMaybe cName oalias @@ -686,7 +688,7 @@ ++ "\n" traceInfoCName kind ide = traceGenBind $ "found C " ++ kind ++ " for `" ++ identToString ide ++ "'\n" -expandHook (CHSClass oclassIde classIde typeIde pos) = +expandHook (CHSClass oclassIde classIde typeIde pos) _ = do traceInfoClass classIde `objIs` Class oclassIde typeIde -- register Haskell object @@ -905,8 +907,9 @@ -> CHSParm -- result marshalling description -> Maybe String -- optional additional marshaller for first arg -> 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 = +funDef isPure hsLexeme fiLexeme extTy octxt parms parm marsh2 pos hkpos = do (parms', parm', isImpure) <- addDftMarshaller pos parms parm extTy @@ -961,8 +964,7 @@ " " ++ (if isImpure || not isPure then "return " else "") ++ ret - pad code = let col = posColumn pos - padding = replicate (col - 3) ' ' + pad code = let padding = replicate (posColumn hkpos - 1) ' ' (l:ls) = lines code in unlines $ l : map (padding ++) ls diff --git a/src/C2HS/Gen/Header.hs b/src/C2HS/Gen/Header.hs --- a/src/C2HS/Gen/Header.hs +++ b/src/C2HS/Gen/Header.hs @@ -168,7 +168,7 @@ -- 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)) : frags) = +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) @@ -184,9 +184,9 @@ createEnumerator (cid,hsid) = liftM (\enr -> ((enr,cid),(enr,hsid))) newEnrIdent enumDef ide enrs = CEnum (Just ide) (Just$ map mkEnr enrs) [] undefNode where mkEnr (name,value) = (name, Just $ CVar value undefNode) - enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident) trans' Nothing Nothing instances pos) + enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident) trans' Nothing Nothing instances pos) hkpos -ghFrag (frag@(CHSHook _ ) : frags) = +ghFrag (frag@(CHSHook _ _) : frags) = return (DL.zero, Frag frag, frags) ghFrag (frag@(CHSLine _ ) : frags) = return (DL.zero, Frag frag, frags) @@ -251,7 +251,7 @@ _ -> interr "GenHeader.ghFrag: Expected CHSCond!" Endif _ -> closeIf (headerTh `DL.snoc` "#endif\n") - (s, fragsTh) + (s', fragsTh) [] (Just []) rest diff --git a/tests/test-bugs.hs b/tests/test-bugs.hs --- a/tests/test-bugs.hs +++ b/tests/test-bugs.hs @@ -6,10 +6,10 @@ import Test.HUnit hiding (Test, assert) import System.FilePath (searchPathSeparator) import Shelly -import Data.Text.Lazy (Text) +import Data.Text (Text) import Data.Monoid -import qualified Data.Text.Lazy as LT -default (LT.Text) +import qualified Data.Text as T +default (T.Text) main :: IO () main = defaultMain tests @@ -18,6 +18,7 @@ tests = [ testGroup "Bugs" [ testCase "call_capital (issue #??)" call_capital + , testCase "Issue #69" issue69 , testCase "Issue #60" issue60 , testCase "Issue #51" issue51 , testCase "Issue #47" issue47 @@ -48,8 +49,11 @@ cmd "ghc" "--make" "-cpp" "Capital_c.o" "Capital.hs" res <- absPath "./Capital" >>= cmd let expected = ["upper C();", "lower c();", "upper C();"] - liftIO $ assertBool "" (LT.lines res == expected) + liftIO $ assertBool "" (T.lines res == expected) +issue69 :: Assertion +issue69 = build_issue 69 + issue60 :: Assertion issue60 = build_issue 60 @@ -110,7 +114,7 @@ "Issue30Aux1.hs" "Issue30Aux2.hs" "Issue30.hs" res <- absPath "./Issue30" >>= cmd let expected = ["3", "2", "4"] - liftIO $ assertBool "" (LT.lines res == expected) + liftIO $ assertBool "" (T.lines res == expected) issue29 :: Assertion issue29 = shelly $ do @@ -151,7 +155,7 @@ let wdir = "tests/bugs" ("issue-" <> show n) lc = "issue" <> show n lcc = lc <> "_c" - uc = fromText $ LT.pack $ "Issue" <> show n + uc = fromText $ T.pack $ "Issue" <> show n in do cd wdir mapM_ rm_f [uc <.> "hs", uc <.> "chs.h", uc <.> "chi", lcc <.> "o", uc] @@ -165,8 +169,8 @@ expect_issue_with :: Int -> [Text] -> [Text] -> Assertion expect_issue_with n c2hsargs expected = shelly $ do do_issue_build n c2hsargs - res <- absPath ("." (fromText $ LT.pack $ "Issue" <> show n)) >>= cmd - liftIO $ assertBool "" (LT.lines res == expected) + res <- absPath ("." (fromText $ T.pack $ "Issue" <> show n)) >>= cmd + liftIO $ assertBool "" (T.lines res == expected) build_issue_with :: Int -> [Text] -> Assertion build_issue_with n c2hsargs = shelly $ do diff --git a/tests/test-system.hs b/tests/test-system.hs --- a/tests/test-system.hs +++ b/tests/test-system.hs @@ -7,9 +7,9 @@ import Shelly import qualified Shelly as Sh import Control.Monad (forM_) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as LT -default (LT.Text) +import Data.Text (Text) +import qualified Data.Text as T +default (T.Text) main :: IO () main = defaultMain tests @@ -40,7 +40,7 @@ run_test_expect dir cmds expcmd expected = shelly $ chdir dir $ do forM_ cmds $ \(c, as) -> run c as res <- absPath expcmd >>= cmd - liftIO $ assertBool "" (LT.lines res == expected) + liftIO $ assertBool "" (T.lines res == expected) test_calls :: Assertion