From 2191db41bbd2f3e323655427db50bb9568534c22 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 25 Apr 2022 11:21:27 +0200 Subject: [PATCH 1/4] Refactor: extract lineDirective --- inline-c/src/Language/C/Inline/Internal.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/inline-c/src/Language/C/Inline/Internal.hs b/inline-c/src/Language/C/Inline/Internal.hs index 633497f..a79087c 100644 --- a/inline-c/src/Language/C/Inline/Internal.hs +++ b/inline-c/src/Language/C/Inline/Internal.hs @@ -53,6 +53,9 @@ module Language.C.Inline.Internal , runParserInQ , splitTypedC + -- * Line directives + , lineDirective + -- * Utility functions for writing quasiquoters , genericQuote , funPtrQuote @@ -294,7 +297,7 @@ inlineCode Code{..} = do -- Write out definitions ctx <- getContext let out = fromMaybe id $ ctxOutput ctx - let directive = maybe "" (\l -> "#line " ++ show (fst $ TH.loc_start l) ++ " " ++ show (TH.loc_filename l ) ++ "\n") codeLoc + let directive = maybe "" lineDirective codeLoc void $ emitVerbatim $ out $ directive ++ codeDefs -- Create and add the FFI declaration. ffiImportName <- uniqueFfiImportName @@ -755,6 +758,13 @@ funPtrQuote callSafety = quoteCode $ \rawCode -> do ] return (s ++ s') +------------------------------------------------------------------------ +-- Line directives + +lineDirective :: TH.Loc -> String +lineDirective l = "#line " ++ show (fst $ TH.loc_start l) ++ " " ++ show (TH.loc_filename l ) ++ "\n" + + ------------------------------------------------------------------------ -- Utils From 305ea24f47b3288d89ddb772e13d934f13f93fc1 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 25 Apr 2022 13:36:15 +0200 Subject: [PATCH 2/4] Fix user error message line numbers in Cpp.Exception module This builds on the splitTypedC function, which is a bit of a hack, but gets the job done. --- .../src/Language/C/Inline/Cpp/Exception.hs | 6 +- inline-c-cpp/test/tests.hs | 51 +++++++++++++ inline-c/src/Language/C/Inline/Internal.hs | 74 +++++++++++++++++-- 3 files changed, 125 insertions(+), 6 deletions(-) diff --git a/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs b/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs index ff09371..3ca4949 100644 --- a/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs +++ b/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs @@ -208,22 +208,26 @@ exceptionalValue typeStr = tryBlockQuoteExp :: String -> Q Exp tryBlockQuoteExp blockStr = do - let (ty, body) = C.splitTypedC blockStr + let (ty, body, bodyLineShift) = C.splitTypedC blockStr _ <- C.include "HaskellException.hxx" typePtrVarName <- newName "exTypePtr" msgPtrVarName <- newName "msgPtr" haskellExPtrVarName <- newName "haskellExPtr" exPtrVarName <- newName "exPtr" typeStrPtrVarName <- newName "typeStrPtr" + there <- location let inlineCStr = unlines [ ty ++ " {" + , C.lineDirective $(C.here) , " int* __inline_c_cpp_exception_type__ = $(int* " ++ nameBase typePtrVarName ++ ");" , " const char** __inline_c_cpp_error_message__ = $(const char** " ++ nameBase msgPtrVarName ++ ");" , " const char** __inline_c_cpp_error_typ__ = $(const char** " ++ nameBase typeStrPtrVarName ++ ");" , " HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)($(void ** " ++ nameBase haskellExPtrVarName ++ "));" , " std::exception_ptr** __inline_c_cpp_exception_ptr__ = (std::exception_ptr**)$(std::exception_ptr** " ++ nameBase exPtrVarName ++ ");" , " try {" + , C.lineDirective (C.shiftLines (bodyLineShift - 1) there) , body + , C.lineDirective $(C.here) , " } catch (const HaskellException &e) {" , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";" , " *__inline_c_cpp_haskellexception__ = new HaskellException(e);" diff --git a/inline-c-cpp/test/tests.hs b/inline-c-cpp/test/tests.hs index 9f8348e..f13ccd1 100644 --- a/inline-c-cpp/test/tests.hs +++ b/inline-c-cpp/test/tests.hs @@ -274,6 +274,57 @@ main = Hspec.hspec $ do result `shouldBeRight` 0xDEADBEEF + Hspec.it "code can contain preprocessor directives" $ do + result <- try $ [C.throwBlock| int { + #ifndef THE_MACRO_THAT_HAS_NOT_BEEN_DEFINED + return 0xDEADBEEF; + #else + return 0xBEEFCAFE; + #endif + } |] + + result `shouldBeRight` 0xDEADBEEF + + {- Manual test cases for testing lineDirective and splitTypedC + + Hspec.it "error reporting test case" $ do + result <- try $ [C.throwBlock| int { 0 = 0; }|] + result `shouldBeRight` 0xDEADBEEF + + Hspec.it "error reporting test case" $ do + result <- try $ [C.throwBlock| int + { 1 = 1; } + |] + result `shouldBeRight` 0xDEADBEEF + + Hspec.it "error reporting test case" $ do + result <- try $ [C.throwBlock| int + { + 2 = 2; + } + |] + result `shouldBeRight` 0xDEADBEEF + + Hspec.it "error reporting test case" $ do + result <- try $ [C.throwBlock| + int + { + 3 = 3; + } + |] + result `shouldBeRight` 0xDEADBEEF + + Hspec.it "error reporting test case" $ do + result <- try $ [C.throwBlock| + + int + { + 4 = 4; + } + |] + result `shouldBeRight` 0xDEADBEEF + -- -} + Hspec.describe "Macros" $ do Hspec.it "generated std::vector instances work correctly" $ do intVec <- StdVector.new @C.CInt diff --git a/inline-c/src/Language/C/Inline/Internal.hs b/inline-c/src/Language/C/Inline/Internal.hs index a79087c..949367a 100644 --- a/inline-c/src/Language/C/Inline/Internal.hs +++ b/inline-c/src/Language/C/Inline/Internal.hs @@ -55,6 +55,8 @@ module Language.C.Inline.Internal -- * Line directives , lineDirective + , here + , shiftLines -- * Utility functions for writing quasiquoters , genericQuote @@ -683,14 +685,37 @@ genericQuote purity build = quoteCode $ \rawStr -> do go (paramType : params) = do [t| $(return paramType) -> $(go params) |] -splitTypedC :: String -> (String, String) - -- ^ Returns the type and the body separately -splitTypedC s = (trim ty, case body of - [] -> [] - r -> r) + +-- NOTE: splitTypedC wouldn't be necessary if inline-c-cpp could reuse C.block +-- internals with a clean interface. +-- This would be a significant refactoring but presumably it would lead to an +-- api that could let users write their own quasiquoters a bit more conveniently. + +-- | Returns the type and the body separately. +splitTypedC :: String -> (String, String, Int) +splitTypedC s = (trim ty, bodyIndent <> body, bodyLineShift) where (ty, body) = span (/= '{') s trim x = L.dropWhileEnd C.isSpace (dropWhile C.isSpace x) + -- We may need to correct the line number of the body + bodyLineShift = length (filter (== '\n') ty) + + -- Indentation is relevant for error messages when the syntax is: + -- [C.foo| type + -- { foo(); } + -- |] + bodyIndent = + let precedingSpaceReversed = + takeWhile (\c -> C.isSpace c) $ + reverse $ + ty + (precedingSpacesTabsReversed, precedingLine) = + span (`notElem` ("\n\r" :: [Char])) precedingSpaceReversed + in case precedingLine of + ('\n':_) -> reverse precedingSpacesTabsReversed + ('\r':_) -> reverse precedingSpacesTabsReversed + _ -> "" -- it wasn't indentation after all; just spaces after the type + -- | Data to parse for the 'funPtr' quasi-quoter. data FunPtrDecl = FunPtrDecl { funPtrReturnType :: C.Type C.CIdentifier @@ -761,9 +786,48 @@ funPtrQuote callSafety = quoteCode $ \rawCode -> do ------------------------------------------------------------------------ -- Line directives +-- | Tell the C compiler where the next line came from. +-- +-- Example: +-- +-- @@@ +-- there <- location +-- f (unlines +-- [ lineDirective $(here) +-- , "generated_code_user_did_not_write()" +-- , lineDirective there +-- ] ++ userCode +-- ]) +-- @@@ +-- +-- Use @lineDirective $(C.here)@ when generating code, so that any errors or +-- warnings report the location of the generating haskell module, rather than +-- tangentially related user code that doesn't contain the actual problem. lineDirective :: TH.Loc -> String lineDirective l = "#line " ++ show (fst $ TH.loc_start l) ++ " " ++ show (TH.loc_filename l ) ++ "\n" +-- | Get the location of the code you're looking at, for use with +-- 'lineDirective'; place before generated code that user did not write. +here :: TH.ExpQ +here = [| $(TH.location >>= \(TH.Loc a b c (d1, d2) (e1, e2)) -> + [|Loc + $(TH.lift a) + $(TH.lift b) + $(TH.lift c) + ($(TH.lift d1), $(TH.lift d2)) + ($(TH.lift e1), $(TH.lift e2)) + |]) + |] + +shiftLines :: Int -> TH.Loc -> TH.Loc +shiftLines n l = l + { TH.loc_start = + let (startLn, startCol) = TH.loc_start l + in (startLn + n, startCol) + , TH.loc_end = + let (endLn, endCol) = TH.loc_end l + in (endLn + n, endCol) + } ------------------------------------------------------------------------ -- Utils From 12c2e08ae2695618b6ed92c5223b35cb6556bdb4 Mon Sep 17 00:00:00 2001 From: Junji Hashimoto Date: Fri, 29 Sep 2023 05:18:32 +0900 Subject: [PATCH 3/4] Add CI for error-message-lines --- .github/workflows/ci.yaml | 2 ++ inline-c-cpp/test-error-message-line-numbers.sh | 11 +++++++++++ inline-c-cpp/test/tests.hs | 14 +++++++------- 3 files changed, 20 insertions(+), 7 deletions(-) create mode 100755 inline-c-cpp/test-error-message-line-numbers.sh diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index c321cf2..3f03e30 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -45,6 +45,8 @@ jobs: run: | if [ ${{ matrix.os }} == "ubuntu-latest" ] ; then stack test --stack-yaml stack-${{ matrix.stackage }}.yaml --flag inline-c:gsl-example --flag inline-c-cpp:std-vector-example + ./inline-c-cpp/test-error-message-line-numbers.sh --stack-yaml stack-${{ matrix.stackage }}.yaml else stack test --stack-yaml stack-${{ matrix.stackage }}.yaml --flag inline-c-cpp:std-vector-example + ./inline-c-cpp/test-error-message-line-numbers.sh --stack-yaml stack-${{ matrix.stackage }}.yaml fi diff --git a/inline-c-cpp/test-error-message-line-numbers.sh b/inline-c-cpp/test-error-message-line-numbers.sh new file mode 100755 index 0000000..6752f9b --- /dev/null +++ b/inline-c-cpp/test-error-message-line-numbers.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash +set -x +sed -i -e 's/.*uncomment this line.*//g' inline-c-cpp/test/tests.hs +stack test $@ inline-c-cpp >& error-log +cat error-log +grep -n 'Test this line' inline-c-cpp/test/tests.hs | awk -F ':' '{print $1}' > exp +cat exp +grep 'tests.hs:[0-9]*:.*error' error-log | awk -F ':' '{print $2}' > out +cat out +set -xe +diff exp out diff --git a/inline-c-cpp/test/tests.hs b/inline-c-cpp/test/tests.hs index 5d56351..1474f7f 100644 --- a/inline-c-cpp/test/tests.hs +++ b/inline-c-cpp/test/tests.hs @@ -295,22 +295,22 @@ main = Hspec.hspec $ do result `shouldBeRight` 0xDEADBEEF - {- Manual test cases for testing lineDirective and splitTypedC + {- Manual test cases for testing lineDirective and splitTypedC -- For CI, uncomment this line. Hspec.it "error reporting test case" $ do - result <- try $ [C.throwBlock| int { 0 = 0; }|] + result <- try $ [C.throwBlock| int { 0 = 0; /* Test this line. */}|] result `shouldBeRight` 0xDEADBEEF Hspec.it "error reporting test case" $ do result <- try $ [C.throwBlock| int - { 1 = 1; } + { 1 = 1; /* Test this line. */} |] result `shouldBeRight` 0xDEADBEEF Hspec.it "error reporting test case" $ do result <- try $ [C.throwBlock| int { - 2 = 2; + 2 = 2; /* Test this line. */ } |] result `shouldBeRight` 0xDEADBEEF @@ -319,7 +319,7 @@ main = Hspec.hspec $ do result <- try $ [C.throwBlock| int { - 3 = 3; + 3 = 3; /* Test this line. */ } |] result `shouldBeRight` 0xDEADBEEF @@ -329,11 +329,11 @@ main = Hspec.hspec $ do int { - 4 = 4; + 4 = 4; /* Test this line. */ } |] result `shouldBeRight` 0xDEADBEEF - -- -} + -- For CI, uncomment this line. -} Hspec.describe "Macros" $ do Hspec.it "generated std::vector instances work correctly" $ do From dd235d5ded878ace99ac89d32d55651aeaf6cee5 Mon Sep 17 00:00:00 2001 From: Junji Hashimoto Date: Fri, 29 Sep 2023 05:35:10 +0900 Subject: [PATCH 4/4] Remove 'error: control reaches end of non-void function' of C++ --- inline-c-cpp/test/tests.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/inline-c-cpp/test/tests.hs b/inline-c-cpp/test/tests.hs index 1474f7f..ab8ce1d 100644 --- a/inline-c-cpp/test/tests.hs +++ b/inline-c-cpp/test/tests.hs @@ -298,19 +298,20 @@ main = Hspec.hspec $ do {- Manual test cases for testing lineDirective and splitTypedC -- For CI, uncomment this line. Hspec.it "error reporting test case" $ do - result <- try $ [C.throwBlock| int { 0 = 0; /* Test this line. */}|] + result <- try $ [C.throwBlock| int { 0 = 0; return 0xDEADBEEF; /* Test this line. */}|] result `shouldBeRight` 0xDEADBEEF Hspec.it "error reporting test case" $ do result <- try $ [C.throwBlock| int - { 1 = 1; /* Test this line. */} + { 1 = 1; return 0xDEADBEEF; /* Test this line. */} |] result `shouldBeRight` 0xDEADBEEF Hspec.it "error reporting test case" $ do result <- try $ [C.throwBlock| int { - 2 = 2; /* Test this line. */ + 2 = 2; /* Test this line. */ + return 0xDEADBEEF; } |] result `shouldBeRight` 0xDEADBEEF @@ -320,6 +321,7 @@ main = Hspec.hspec $ do int { 3 = 3; /* Test this line. */ + return 0xDEADBEEF; } |] result `shouldBeRight` 0xDEADBEEF @@ -330,6 +332,7 @@ main = Hspec.hspec $ do int { 4 = 4; /* Test this line. */ + return 0xDEADBEEF; } |] result `shouldBeRight` 0xDEADBEEF