{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import Control.Exception.Safe
import Control.Monad
import qualified Language.C.Inline.Cpp as C
import qualified Language.C.Inline.Context as CC
import qualified Language.C.Types as CT
import qualified Language.C.Inline.Cpp.Exceptions as C
import Foreign.C.String (withCString)
import Foreign.StablePtr (StablePtr, newStablePtr, castStablePtrToPtr)
import qualified Test.Hspec as Hspec
import Foreign.Ptr (Ptr)
import Data.List (isInfixOf)
data Test
data Vector a
data Array a
C.context $ C.cppCtx `mappend` C.cppTypePairs [
("Test::Test", [t|Test|]),
("std::vector", [t|Vector|]),
("std::array", [t|Array|])
]
C.include "<iostream>"
C.include "<vector>"
C.include "<array>"
C.include "<tuple>"
C.include "<stdexcept>"
C.include "test.h"
data MyCustomException = MyCustomException Int
deriving (Eq, Show, Typeable)
instance Exception MyCustomException
main :: IO ()
main = Hspec.hspec $ do
Hspec.describe "Basic C++" $ do
Hspec.it "Hello World" $ do
let x = 3
[C.block| void {
std::cout << "Hello, world!" << $(int x) << std::endl;
} |]
Hspec.describe "C++ Types" $ do
Hspec.it "Hello Namespace" $ do
pt <- [C.block| Test::Test* {
return new Test::Test();
} |] :: IO (Ptr Test)
[C.block| void {
std::cout << $(Test::Test* pt)->get() << std::endl;
} |]
Hspec.it "Hello Template" $ do
pt <- [C.block| std::vector<int>* {
return new std::vector<int>();
} |] :: IO (Ptr (Vector C.CInt))
[C.block| void {
$(std::vector<int>* pt)->push_back(100);
std::cout << (*$(std::vector<int>* pt))[0] << std::endl;
} |]
Hspec.it "Template + Namespace" $ do
pt <- [C.block| std::vector<Test::Test>* {
return new std::vector<Test::Test>();
} |] :: IO (Ptr (Vector Test))
[C.block| void {
$(std::vector<Test::Test>* pt)->push_back(Test::Test());
} |]
Hspec.it "Template with 2 arguments" $ do
pt <- [C.block| std::array<int,10>* {
return new std::array<int,10>();
} |] :: IO (Ptr (Array '(C.CInt,10)))
[C.block| void {
(*$(std::array<int,10>* pt))[0]=true;
std::cout << (*$(std::array<int,10>* pt))[0] << std::endl;
} |]
Hspec.describe "Exception handling" $ do
Hspec.it "std::exceptions are caught" $ do
result <- try [C.catchBlock|
throw std::runtime_error("C++ error message");
|]
result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"
Hspec.it "non-exceptions are caught (unsigned int)" $ do
result <- try [C.catchBlock|
throw 0xDEADBEEF;
|]
result `shouldBeCppOtherException` (Just "unsigned int")
Hspec.it "non-exceptions are caught (std::string)" $ do
result <- try [C.catchBlock|
throw std::string("FOOBAR");
|]
case result of
Left (C.CppOtherException (Just ty)) | "string" `isInfixOf` ty -> return ()
_ -> error ("Expected Left CppOtherException with string type, but got " ++ show result)
Hspec.it "catch without return (pure)" $ do
result <- [C.tryBlock| void {
throw std::runtime_error("C++ error message");
}
|]
result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"
Hspec.it "try and return without throwing (pure)" $ do
result <- [C.tryBlock| int {
return 123;
}
|]
result `shouldBeRight` 123
Hspec.it "return maybe throwing (pure)" $ do
result <- [C.tryBlock| int {
if(1) return 123;
else throw std::runtime_error("C++ error message");
}
|]
result `shouldBeRight` 123
Hspec.it "return definitely throwing (pure)" $ do
result <- [C.tryBlock| int {
if(0) return 123;
else throw std::runtime_error("C++ error message");
}
|]
result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"
Hspec.it "catch without return (pure)" $ do
result <- [C.tryBlock| void {
throw std::runtime_error("C++ error message");
}
|]
result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"
Hspec.it "try and return without throwing (throw)" $ do
result :: Either C.CppException C.CInt <- try [C.throwBlock| int {
return 123;
}
|]
result `shouldBeRight` 123
Hspec.it "return maybe throwing (throw)" $ do
result :: Either C.CppException C.CInt <- try [C.throwBlock| int {
if(1) return 123;
else throw std::runtime_error("C++ error message");
}
|]
result `shouldBeRight` 123
Hspec.it "return definitely throwing (throw)" $ do
result <- try [C.throwBlock| int {
if(0) return 123;
else throw std::runtime_error("C++ error message");
}
|]
result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"
Hspec.it "return throwing Haskell" $ do
let exc = toException $ userError "This is from Haskell"
let doIt = withCString (displayException exc) $ \renderedException -> do
stablePtr <- newStablePtr exc
let stablePtr' = castStablePtrToPtr stablePtr
[C.throwBlock| int {
if(0) return 123;
else throw HaskellException(HaskellException(std::string($(const char *renderedException)), $(void *stablePtr')));
}
|]
let isTheError e | e == userError "This is from Haskell" = True
isTheError _ = False
doIt `Hspec.shouldThrow` isTheError
Hspec.it "return throwing custom Haskell exception" $ do
let exc = toException $ MyCustomException 42
let doIt = withCString (displayException exc) $ \renderedException -> do
stablePtr <- newStablePtr exc
let stablePtr' = castStablePtrToPtr stablePtr
[C.throwBlock| int {
if(0) return 123;
else throw HaskellException(HaskellException(std::string($(const char *renderedException)), $(void *stablePtr')));
}
|]
let isTheError (MyCustomException 42) = True
isTheError _ = False
doIt `Hspec.shouldThrow` isTheError
Hspec.it "catch without return (throw)" $ do
result <- try [C.throwBlock| void {
throw std::runtime_error("C++ error message");
}
|]
result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"
Hspec.it "code without exceptions works normally" $ do
result :: Either C.CppException C.CInt <- try $ C.withPtr_ $ \resPtr -> [C.catchBlock|
*$(int* resPtr) = 0xDEADBEEF;
|]
result `shouldBeRight` 0xDEADBEEF
tag :: C.CppException -> String
tag (C.CppStdException {}) = "CppStdException"
tag (C.CppHaskellException {}) = "CppHaskellException"
tag (C.CppOtherException {}) = "CppStdException"
shouldBeCppStdException :: Either C.CppException a -> String -> IO ()
shouldBeCppStdException (Left (C.CppStdException actualMsg)) expectedMsg = do
actualMsg `Hspec.shouldBe` expectedMsg
shouldBeCppStdException (Left x) expectedMsg = tag x `Hspec.shouldBe` ("CppStdException " <> show expectedMsg)
shouldBeCppStdException (Right _) expectedMsg = "Right _" `Hspec.shouldBe` ("Left (CppStdException " <> show expectedMsg <> ")")
shouldBeCppOtherException :: Either C.CppException a -> Maybe String -> IO ()
shouldBeCppOtherException (Left (C.CppOtherException actualType)) expectedType = do
actualType `Hspec.shouldBe` expectedType
shouldBeCppOtherException (Left x) expectedType = tag x `Hspec.shouldBe` ("CppOtherException " <> show expectedType)
shouldBeCppOtherException (Right _) expectedType = "Right _" `Hspec.shouldBe` ("Left (CppOtherException " <> show expectedType <> ")")
shouldBeRight :: (Eq a, Show a) => Either C.CppException a -> a -> IO ()
shouldBeRight (Right actual) expected = actual `Hspec.shouldBe` expected
shouldBeRight (Left e) expected = ("Left (" <> tag e <> " {})") `Hspec.shouldBe` ("Right " <> (show expected))