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/src/Language/C/Inline/Cpp/Exception.hs b/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs index 420a753..e8878bc 100644 --- a/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs +++ b/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs @@ -210,9 +210,10 @@ exceptionalValue typeStr = tryBlockQuoteExp :: QuasiQuoter -> String -> Q Exp tryBlockQuoteExp block blockStr = do - let (ty, body) = C.splitTypedC blockStr + let (ty, body, bodyLineShift) = C.splitTypedC blockStr _ <- C.include "HaskellException.hxx" basePtrVarName <- newName "basePtr" + there <- location let inlineCStr = unlines [ ty ++ " {" , " void** __inline_c_cpp_base_ptr__ = $(void** " ++ nameBase basePtrVarName ++ ");" @@ -223,7 +224,9 @@ tryBlockQuoteExp block blockStr = do , " HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)(__inline_c_cpp_base_ptr__ + 4);" , " *__inline_c_cpp_exception_type__ = 0;" , " 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-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 bf84fd2..ab8ce1d 100644 --- a/inline-c-cpp/test/tests.hs +++ b/inline-c-cpp/test/tests.hs @@ -284,6 +284,60 @@ 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 -- For CI, uncomment this line. + + Hspec.it "error reporting test case" $ do + 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; 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. */ + return 0xDEADBEEF; + } + |] + result `shouldBeRight` 0xDEADBEEF + + Hspec.it "error reporting test case" $ do + result <- try $ [C.throwBlock| + int + { + 3 = 3; /* Test this line. */ + return 0xDEADBEEF; + } + |] + result `shouldBeRight` 0xDEADBEEF + + Hspec.it "error reporting test case" $ do + result <- try $ [C.throwBlock| + + int + { + 4 = 4; /* Test this line. */ + return 0xDEADBEEF; + } + |] + result `shouldBeRight` 0xDEADBEEF + -- For CI, uncomment this line. -} + 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 7dc3665..2945dac 100644 --- a/inline-c/src/Language/C/Inline/Internal.hs +++ b/inline-c/src/Language/C/Inline/Internal.hs @@ -53,6 +53,11 @@ module Language.C.Inline.Internal , runParserInQ , splitTypedC + -- * Line directives + , lineDirective + , here + , shiftLines + -- * Utility functions for writing quasiquoters , genericQuote , funPtrQuote @@ -295,7 +300,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 @@ -681,14 +686,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 @@ -756,6 +784,52 @@ funPtrQuote callSafety = quoteCode $ \rawCode -> do ] return (s ++ s') +------------------------------------------------------------------------ +-- 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