Add CI of error-message-lines

.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

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);"

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

inline-c-cpp/test/tests.hs

@@ -13,7 +13,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TypeApplications #-}
@@ -284,6 +284,60 @@
 
       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

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