From 2191db41bbd2f3e323655427db50bb9568534c22 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 25 Apr 2022 11:21:27 +0200 Subject: [PATCH 1/2] 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/2] 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