├── .github └── workflows │ └── ci.yaml ├── .gitignore ├── README.md ├── inline-c-cpp ├── LICENSE ├── README.md ├── Setup.hs ├── cxx-src │ ├── HaskellException.cxx │ └── HaskellStablePtr.cxx ├── include │ ├── HaskellException.hxx │ └── HaskellStablePtr.hxx ├── inline-c-cpp.cabal ├── src │ └── Language │ │ └── C │ │ └── Inline │ │ ├── Cpp.hs │ │ └── Cpp │ │ ├── Exception.hs │ │ ├── Exceptions.hs │ │ └── Unsafe.hs ├── test-error-message-line-numbers.sh └── test │ ├── StdVector.hs │ ├── TemplateSpec.hs │ ├── test.h │ └── tests.hs ├── inline-c-cuda ├── LICENSE ├── README.md ├── Setup.hs ├── inline-c-cuda.cabal ├── src │ └── Language │ │ └── C │ │ └── Inline │ │ └── Cuda.hs └── test │ └── tests.hs ├── inline-c-objc ├── LICENSE ├── README.md ├── inline-c-objc.cabal ├── src │ └── Language │ │ └── C │ │ └── Inline │ │ └── ObjC.hs └── test │ └── tests.hs ├── inline-c ├── LICENSE ├── README.md ├── Setup.hs ├── changelog.md ├── examples │ └── gsl-ode.hs ├── inline-c.cabal ├── src │ └── Language │ │ └── C │ │ ├── Inline.hs │ │ ├── Inline │ │ ├── Context.hs │ │ ├── FunPtr.hs │ │ ├── HaskellIdentifier.hs │ │ ├── Internal.hs │ │ ├── Interruptible.hs │ │ └── Unsafe.hs │ │ ├── Types.hs │ │ └── Types │ │ └── Parse.hs └── test │ ├── Dummy.hs │ ├── Language │ └── C │ │ ├── Inline │ │ ├── ContextSpec.hs │ │ └── ParseSpec.hs │ │ └── Types │ │ └── ParseSpec.hs │ └── tests.hs ├── sample-cabal-project ├── LICENSE ├── sample-cabal-project.cabal └── src │ └── Main.hs ├── stack-lts-20.yaml ├── stack-lts-21.yaml ├── stack-nightly.yaml └── stack.yaml /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | types: 8 | - opened 9 | - synchronize 10 | jobs: 11 | build: 12 | name: ${{ matrix.os }}-stack-${{ matrix.stackage }} 13 | runs-on: ${{ matrix.os }} 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | os: ['ubuntu-latest', 'macos-latest'] 18 | stackage: ['nightly', 'lts-21', 'lts-20'] 19 | steps: 20 | - uses: actions/checkout@v4 21 | - uses: haskell/actions/setup@v2 22 | with: 23 | enable-stack: true 24 | stack-no-global: true 25 | - name: Install packages 26 | run: | 27 | if [ ${{ matrix.os }} == "ubuntu-latest" ] ; then 28 | sudo apt-get update -qq && sudo apt-get install -y gobjc++ libgnustep-base-dev libgsl-dev 29 | else 30 | /bin/bash -c "$(curl -fsSL https://raw.githubusercontent.com/Homebrew/install/HEAD/install.sh)" 31 | brew install gsl || true 32 | fi 33 | - uses: actions/cache@v3 34 | with: 35 | path: ~/.stack 36 | key: stack-${{ matrix.os }}-${{ matrix.stackage }}-${{ hashFiles('stack.yaml') }} 37 | - name: Build 38 | run: | 39 | if [ ${{ matrix.os }} == "ubuntu-latest" ] ; then 40 | stack build --stack-yaml stack-${{ matrix.stackage }}.yaml --flag inline-c:gsl-example --flag inline-c-cpp:std-vector-example --flag inline-c-cuda:test-without-cuda 41 | else 42 | stack build --stack-yaml stack-${{ matrix.stackage }}.yaml --flag inline-c-cpp:std-vector-example --flag inline-c-cuda:test-without-cuda 43 | fi 44 | - name: Test 45 | run: | 46 | if [ ${{ matrix.os }} == "ubuntu-latest" ] ; then 47 | stack test --stack-yaml stack-${{ matrix.stackage }}.yaml --flag inline-c:gsl-example --flag inline-c-cpp:std-vector-example --flag inline-c-cuda:test-without-cuda 48 | ./inline-c-cpp/test-error-message-line-numbers.sh --stack-yaml stack-${{ matrix.stackage }}.yaml 49 | else 50 | stack test --stack-yaml stack-${{ matrix.stackage }}.yaml --flag inline-c-cpp:std-vector-example --flag inline-c-cuda:test-without-cuda 51 | ./inline-c-cpp/test-error-message-line-numbers.sh --stack-yaml stack-${{ matrix.stackage }}.yaml 52 | fi 53 | env: 54 | INLINE_C_CUDA_SUFFIX: cc 55 | INLINE_C_CUDA_COMPILER: g++ 56 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .stack-work/ 3 | *.c 4 | *.cpp 5 | *.d 6 | *.tix 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://github.com/fpco/inline-c/actions/workflows/ci.yaml/badge.svg?branch=master)](https://github.com/fpco/inline-c/actions) 2 | 3 | See READMEs for `inline-c` and `inline-c-cpp`. 4 | 5 | ## Authors 6 | 7 | `inline-c` was written by [Francesco Mazzoli](https://github.com/bitonic), with contributions from Mathieu Boespflug, [Junji Hashimoto](https://github.com/junjihashimoto), and [Robert Hensing](https://github.com/roberth). 8 | 9 | It is now maintained by [Junji Hashimoto](https://github.com/junjihashimoto). 10 | -------------------------------------------------------------------------------- /inline-c-cpp/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 FP Complete Corporation. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /inline-c-cpp/README.md: -------------------------------------------------------------------------------- 1 | Small set of utilities to inline C++ code. See tests for example. 2 | -------------------------------------------------------------------------------- /inline-c-cpp/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /inline-c-cpp/cxx-src/HaskellException.cxx: -------------------------------------------------------------------------------- 1 | #include "HaskellException.hxx" 2 | 3 | // see 4 | // 5 | // regarding how to detect g++ or clang. 6 | // 7 | // the defined(__clang__) should actually be redundant, since apparently it also 8 | // defines GNUC, but but let's be safe. 9 | 10 | #include 11 | #include 12 | 13 | #if defined(__GNUC__) || defined(__clang__) 14 | #include 15 | #include 16 | #endif 17 | 18 | 19 | HaskellException::HaskellException(std::string renderedExceptionIn, void *haskellExceptionStablePtrIn) 20 | : haskellExceptionStablePtr(new HaskellStablePtr(haskellExceptionStablePtrIn)) 21 | , displayExceptionValue(renderedExceptionIn) 22 | { 23 | } 24 | 25 | HaskellException::HaskellException(const HaskellException &other) 26 | : haskellExceptionStablePtr(other.haskellExceptionStablePtr) 27 | , displayExceptionValue(other.displayExceptionValue) 28 | { 29 | } 30 | 31 | #ifdef __APPLE__ 32 | HaskellException::~HaskellException() _NOEXCEPT 33 | { 34 | haskellExceptionStablePtr.reset(); 35 | } 36 | 37 | const char* HaskellException::what() const _NOEXCEPT { 38 | #else 39 | const char* HaskellException::what() const noexcept { 40 | #endif 41 | return displayExceptionValue.c_str(); 42 | } 43 | 44 | 45 | // see 46 | // 47 | // regarding how to show the type of an exception. 48 | 49 | /* mallocs a string representing the exception type name or error condition. 50 | 51 | Ideally, this returns a demangled string, but it may degrade to 52 | - a mangled string if demangling fails, 53 | - "" if exception type info is not available, 54 | - "" if no current exception is found. 55 | 56 | The responsibility for freeing the returned string falls on the caller, 57 | such as handleForeignCatch, which passes the responsibility on to ByteString 58 | 59 | */ 60 | #if defined(__GNUC__) || defined(__clang__) 61 | const char* currentExceptionTypeName() 62 | { 63 | std::type_info *type_info = abi::__cxa_current_exception_type(); 64 | if (!type_info) 65 | return strdup(""); 66 | 67 | const char *raw_name = type_info->name(); 68 | if (!raw_name) 69 | return strdup(""); 70 | 71 | int demangle_status; 72 | const char *demangled_name = abi::__cxa_demangle(raw_name, 0, 0, &demangle_status); 73 | if (!demangled_name) 74 | return strdup(raw_name); 75 | 76 | return demangled_name; 77 | } 78 | #endif 79 | 80 | /* Set the message and type strings. 81 | 82 | The responsibility for freeing the returned string falls on the caller, 83 | such as handleForeignCatch, which passes the responsibility on to a 84 | ByteString. 85 | */ 86 | void setMessageOfStdException(const std::exception &e, const char** msgStrPtr, const char **typStrPtr){ 87 | *msgStrPtr = strdup(e.what()); 88 | setCppExceptionType(typStrPtr); 89 | } 90 | 91 | void setCppExceptionType(const char** typStrPtr){ 92 | #if defined(__GNUC__) || defined(__clang__) 93 | *typStrPtr = currentExceptionTypeName(); 94 | #else 95 | *typStrPtr = NULL; 96 | #endif 97 | } 98 | -------------------------------------------------------------------------------- /inline-c-cpp/cxx-src/HaskellStablePtr.cxx: -------------------------------------------------------------------------------- 1 | 2 | #include "HaskellStablePtr.hxx" 3 | 4 | HaskellStablePtr::~HaskellStablePtr() { 5 | if (stablePtr != STABLE_PTR_NULL) { 6 | hs_free_stable_ptr(stablePtr); 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /inline-c-cpp/include/HaskellException.hxx: -------------------------------------------------------------------------------- 1 | 2 | #pragma once 3 | 4 | #include "HaskellStablePtr.hxx" 5 | #include 6 | #include 7 | #include 8 | 9 | /* A representation of a Haskell exception (SomeException), with a precomputed 10 | exception message from Control.Exception.displayException. 11 | 12 | The std::exception requires that retrieving the message does not mutate the 13 | exception object and does not throw exceptions. 14 | 15 | This class uses std::shared_ptr for the exception, because its callers can 16 | not know in advance where and how often the exception will be copied, or when 17 | it is released. 18 | */ 19 | #ifdef __APPLE__ 20 | class HaskellException : public std::exception { 21 | #else 22 | class HaskellException : public std::exception { 23 | #endif 24 | public: 25 | std::shared_ptr haskellExceptionStablePtr; 26 | std::string displayExceptionValue; 27 | 28 | HaskellException(std::string displayExceptionValue, void *haskellExceptionStablePtr); 29 | HaskellException(const HaskellException &); 30 | #ifdef __APPLE__ 31 | virtual const char* what() const _NOEXCEPT override; 32 | virtual ~HaskellException() _NOEXCEPT; 33 | #else 34 | virtual const char* what() const noexcept override; 35 | #endif 36 | 37 | }; 38 | 39 | void setMessageOfStdException(const std::exception &e, const char** msgStrPtr, const char **typeStrPtr); 40 | void setCppExceptionType(const char** typeStrPtr); 41 | -------------------------------------------------------------------------------- /inline-c-cpp/include/HaskellStablePtr.hxx: -------------------------------------------------------------------------------- 1 | 2 | #pragma once 3 | 4 | #include "HsFFI.h" 5 | 6 | #ifndef STABLE_PTR_NULL 7 | #define STABLE_PTR_NULL (static_cast((void *)0)) 8 | #endif 9 | 10 | /* This is like a newtype that adds a C++ destructor, allowing C++ to call 11 | hs_free_stable_ptr when the lifetime ends. 12 | 13 | If you need to pass HaskellStablePtr around, you need to use something like 14 | std::shared_ptr to avoid copying the HaskellStablePtr. 15 | 16 | WARNING: If you copy HaskellStablePtr, you must call the original.setNull() 17 | method in order to prevent a premature/double free when original 18 | goes out of scope. This does make the original object invalid. 19 | */ 20 | struct HaskellStablePtr { 21 | HsStablePtr stablePtr; 22 | 23 | /* Takes ownership of a stable pointer. */ 24 | inline HaskellStablePtr(HsStablePtr s) { 25 | stablePtr = s; 26 | } 27 | 28 | /* Calls hs_free_stable_ptr if this.stablePtr is not NULL. */ 29 | ~HaskellStablePtr(); 30 | 31 | inline void setNull() { 32 | stablePtr = STABLE_PTR_NULL; 33 | } 34 | 35 | operator bool() const { 36 | return stablePtr != STABLE_PTR_NULL; 37 | } 38 | }; 39 | -------------------------------------------------------------------------------- /inline-c-cpp/inline-c-cpp.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: inline-c-cpp 3 | version: 0.5.0.2 4 | synopsis: Lets you embed C++ code into Haskell. 5 | description: Utilities to inline C++ code into Haskell using inline-c. See 6 | tests for example on how to build. 7 | license: MIT 8 | license-file: LICENSE 9 | author: Francesco Mazzoli 10 | maintainer: f@mazzo.li 11 | copyright: (c) 2015-2016 FP Complete Corporation, (c) 2017-2019 Francesco Mazzoli 12 | category: FFI 13 | tested-with: GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.2 14 | build-type: Simple 15 | extra-source-files: test/*.h 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/fpco/inline-c 20 | 21 | flag std-vector-example 22 | description: Build std::vector example 23 | default: False 24 | 25 | common cxx-opts 26 | -- These options are for compilation of C++ _files_. We need to duplicate 27 | -- these in ghc-options to apply them on inline-c-cpp snippets. 28 | -- This is partly(?) due to Cabal < 3.2.1.0 not passing cxx-options to 29 | -- GHC 8.10 correctly. See https://github.com/haskell/cabal/issues/6421 30 | cxx-options: 31 | -- Compilers strive to be ABI compatible regardless of the C++ language 32 | -- version (except perhaps experimental features). 33 | -- Discussion: https://stackoverflow.com/questions/46746878/is-it-safe-to-link-c17-c14-and-c11-objects/49118876 34 | -- We only have to raise this if a new inline-c-cpp feature requires us to 35 | -- bundle C++ code that requires a newer version of the standard. 36 | -- Generated code in user libraries will be compiled with the language 37 | -- version configured there. 38 | -std=c++11 39 | -Wall 40 | 41 | -- Linking to the C++ standard library 42 | if impl(ghc >= 9.4) 43 | build-depends: system-cxx-std-lib == 1.0 44 | elif os(linux) 45 | extra-libraries: stdc++ 46 | elif os(darwin) 47 | extra-libraries: c++ 48 | -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829 49 | ld-options: -Wl,-keep_dwarf_unwind 50 | -- Same issue, new fix https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7247 51 | -- Probably will be redundant in >=9.4 https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7423 52 | if impl(ghc >= 9.2.2 && < 9.4) 53 | ghc-options: 54 | -fcompact-unwind 55 | 56 | if impl(ghc >= 8.10) 57 | ghc-options: 58 | -optcxx-std=c++11 59 | -optcxx-Wall 60 | else 61 | -- On GHC < 8.10, we have to emulate -optcxx by making the C compiler compile 62 | -- C++. GCC accepts this via -std, whereas Clang requires us to change the 63 | -- command. 64 | ghc-options: 65 | -optc-std=c++11 66 | -optc-Wall 67 | if os(darwin) 68 | ghc-options: -pgmc=clang++ 69 | 70 | library 71 | import: cxx-opts 72 | exposed-modules: Language.C.Inline.Cpp 73 | Language.C.Inline.Cpp.Exception 74 | Language.C.Inline.Cpp.Exceptions 75 | Language.C.Inline.Cpp.Unsafe 76 | build-depends: base >=4.7 && <5 77 | , bytestring 78 | , inline-c >= 0.9.0.0 79 | , template-haskell 80 | , text 81 | , safe-exceptions 82 | , containers 83 | hs-source-dirs: src 84 | default-language: Haskell2010 85 | ghc-options: -Wall 86 | include-dirs: include 87 | install-includes: HaskellException.hxx HaskellStablePtr.hxx 88 | cxx-sources: cxx-src/HaskellException.cxx 89 | cxx-src/HaskellStablePtr.cxx 90 | 91 | test-suite tests 92 | import: cxx-opts 93 | type: exitcode-stdio-1.0 94 | hs-source-dirs: test 95 | main-is: tests.hs 96 | other-modules: StdVector 97 | , TemplateSpec 98 | build-depends: base >=4 && <5 99 | , bytestring 100 | , inline-c 101 | , inline-c-cpp 102 | , safe-exceptions 103 | , hspec 104 | , containers 105 | , template-haskell 106 | , vector 107 | default-language: Haskell2010 108 | cxx-options: -Werror -std=c++11 109 | 110 | if impl(ghc >= 8.10) 111 | ghc-options: 112 | -optcxx-Werror 113 | -- else 114 | -- ghc-options: 115 | -- -- GHC < 8.10 can pass options to the C++ compiler, but it warns 116 | -- -- so -Werror will not work. 117 | -- -optc-Werror 118 | -------------------------------------------------------------------------------- /inline-c-cpp/src/Language/C/Inline/Cpp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | -- | Module exposing a 'Context' to inline C++ code. We only have used 6 | -- this for experiments, so use with caution. See the C++ tests to see 7 | -- how to build inline C++ code. 8 | module Language.C.Inline.Cpp 9 | ( module Language.C.Inline 10 | , cppCtx 11 | , cppTypePairs 12 | , using 13 | , AbstractCppExceptionPtr 14 | ) where 15 | 16 | import Data.Monoid ((<>), mempty) 17 | import qualified Language.Haskell.TH as TH 18 | import qualified Language.Haskell.TH.Syntax as TH 19 | 20 | import Language.C.Inline 21 | import Language.C.Inline.Context 22 | import qualified Language.C.Types as CT 23 | 24 | import qualified Data.Map as Map 25 | 26 | -- | The equivalent of 'C.baseCtx' for C++. It specifies the @.cpp@ 27 | -- file extension for the C file, so that g++ will decide to build C++ 28 | -- instead of C. See the @.cabal@ test target for an example on how to 29 | -- build. 30 | cppCtx :: Context 31 | cppCtx = baseCtx <> mempty 32 | { ctxForeignSrcLang = Just TH.LangCxx 33 | , ctxOutput = Just $ \s -> "extern \"C\" {\n" ++ s ++ "\n}" 34 | , ctxEnableCpp = True 35 | , ctxTypesTable = Map.singleton (CT.TypeName "std::exception_ptr") [t|AbstractCppExceptionPtr|] 36 | } 37 | 38 | -- | Marks an @std::exception_ptr@. Only used via 'Ptr'. 39 | data AbstractCppExceptionPtr 40 | 41 | -- | Emits an @using@ directive, e.g. 42 | -- 43 | -- @ 44 | -- C.using "namespace std" ==> using namespace std 45 | -- @ 46 | using :: String -> TH.DecsQ 47 | using s = verbatim $ "using " ++ s ++ ";" 48 | 49 | 50 | cppTypePairs :: [(CT.CIdentifier, TH.TypeQ)] -> Context 51 | cppTypePairs typePairs = mempty { 52 | ctxTypesTable = Map.fromList $ map (\(cpp_sym, haskell_sym) -> (CT.TypeName cpp_sym, haskell_sym)) typePairs 53 | } 54 | -------------------------------------------------------------------------------- /inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs: -------------------------------------------------------------------------------- 1 | -- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters. 2 | 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | 8 | module Language.C.Inline.Cpp.Exception 9 | ( CppException(..) 10 | , CppExceptionPtr 11 | , toSomeException 12 | , throwBlock 13 | , tryBlock 14 | , catchBlock 15 | , tryBlockQuoteExp 16 | ) where 17 | 18 | import Control.Exception.Safe 19 | import qualified Data.ByteString.Unsafe as BS (unsafePackMallocCString) 20 | import Data.ByteString (ByteString) 21 | import qualified Data.Text as T 22 | import qualified Data.Text.Encoding as T 23 | import qualified Data.Text.Encoding.Error as T 24 | import qualified Language.C.Inline as C 25 | import qualified Language.C.Inline.Internal as C 26 | import qualified Language.C.Inline.Cpp as Cpp 27 | import Language.C.Inline.Cpp (AbstractCppExceptionPtr) 28 | import Language.Haskell.TH 29 | import Language.Haskell.TH.Quote 30 | import Foreign 31 | import Foreign.C 32 | import System.IO.Unsafe(unsafePerformIO) 33 | 34 | C.context Cpp.cppCtx 35 | C.include "HaskellException.hxx" 36 | 37 | -- | An exception thrown in C++ code. 38 | data CppException 39 | = CppStdException CppExceptionPtr ByteString (Maybe ByteString) 40 | | CppHaskellException SomeException 41 | | CppNonStdException CppExceptionPtr (Maybe ByteString) 42 | 43 | instance Show CppException where 44 | showsPrec p (CppStdException _ msg typ) = showParen (p >= 11) (showString "CppStdException e " . showsPrec 11 msg . showChar ' ' . showsPrec 11 typ) 45 | showsPrec p (CppHaskellException e) = showParen (p >= 11) (showString "CppHaskellException " . showsPrec 11 e) 46 | showsPrec p (CppNonStdException _ typ) = showParen (p >= 11) (showString "CppOtherException e " . showsPrec 11 typ) 47 | 48 | instance Exception CppException where 49 | displayException (CppStdException _ msg _typ) = bsToChars msg 50 | displayException (CppHaskellException e) = displayException e 51 | displayException (CppNonStdException _ (Just typ)) = "exception: Exception of type " <> bsToChars typ 52 | displayException (CppNonStdException _ Nothing) = "exception: Non-std exception of unknown type" 53 | 54 | type CppExceptionPtr = ForeignPtr AbstractCppExceptionPtr 55 | 56 | -- | This converts a plain pointer to a managed object. 57 | -- 58 | -- The pointer must have been created with @new@. The returned 'CppExceptionPtr' 59 | -- will @delete@ it when it is garbage collected, so you must not @delete@ it 60 | -- on your own. This function is called "unsafe" because it is not memory safe 61 | -- by itself, but safe when used correctly; similar to for example 62 | -- 'BS.unsafePackMallocCString'. 63 | unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr 64 | unsafeFromNewCppExceptionPtr = newForeignPtr finalizeAbstractCppExceptionPtr 65 | 66 | finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr 67 | {-# NOINLINE finalizeAbstractCppExceptionPtr #-} 68 | finalizeAbstractCppExceptionPtr = 69 | unsafePerformIO 70 | [C.exp| 71 | void (*)(std::exception_ptr *) { 72 | [](std::exception_ptr *v){ delete v; } 73 | }|] 74 | 75 | -- | Like 'toException' but unwrap 'CppHaskellException' 76 | toSomeException :: CppException -> SomeException 77 | toSomeException (CppHaskellException e) = e 78 | toSomeException x = toException x 79 | 80 | -- NOTE: Other C++ exception types (std::runtime_error etc) could be distinguished like this in the future. 81 | pattern ExTypeNoException :: CInt 82 | pattern ExTypeNoException = 0 83 | 84 | pattern ExTypeStdException :: CInt 85 | pattern ExTypeStdException = 1 86 | 87 | pattern ExTypeHaskellException :: CInt 88 | pattern ExTypeHaskellException = 2 89 | 90 | pattern ExTypeOtherException :: CInt 91 | pattern ExTypeOtherException = 3 92 | 93 | 94 | handleForeignCatch :: (Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) 95 | handleForeignCatch cont = 96 | allocaBytesAligned (sizeOf (undefined :: Ptr ()) * 5) (alignment (undefined :: Ptr ())) $ \basePtr -> do 97 | let ptrSize = sizeOf (undefined :: Ptr ()) 98 | exTypePtr = castPtr basePtr :: Ptr CInt 99 | msgCStringPtr = castPtr (basePtr `plusPtr` ptrSize) :: Ptr CString 100 | typCStringPtr = castPtr (basePtr `plusPtr` (ptrSize*2)) :: Ptr CString 101 | exPtr = castPtr (basePtr `plusPtr` (ptrSize*3)) :: Ptr (Ptr AbstractCppExceptionPtr) 102 | haskellExPtrPtr = castPtr (basePtr `plusPtr` (ptrSize*4)) :: Ptr (Ptr ()) 103 | -- we need to mask this entire block because the C++ allocates the 104 | -- string for the exception message and we need to make sure that 105 | -- we free it (see the @free@ below). The foreign code would not be 106 | -- preemptable anyway, so I do not think this loses us anything. 107 | mask_ $ do 108 | res <- cont basePtr 109 | exType <- peek exTypePtr 110 | case exType of 111 | ExTypeNoException -> return (Right res) 112 | ExTypeStdException -> do 113 | ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr 114 | 115 | -- BS.unsafePackMallocCString: safe because setMessageOfStdException 116 | -- (invoked via tryBlockQuoteExp) sets msgCStringPtr to a newly 117 | -- malloced string. 118 | errMsg <- BS.unsafePackMallocCString =<< peek msgCStringPtr 119 | 120 | -- BS.unsafePackMallocCString: safe because currentExceptionTypeName 121 | -- returns a newly malloced string 122 | mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr 123 | 124 | return (Left (CppStdException ex errMsg mbExcType)) 125 | ExTypeHaskellException -> do 126 | haskellExPtr <- peek haskellExPtrPtr 127 | stablePtr <- [C.block| void * { 128 | return (static_cast($(void *haskellExPtr)))->haskellExceptionStablePtr->stablePtr; 129 | } |] 130 | someExc <- deRefStablePtr (castPtrToStablePtr stablePtr) 131 | [C.block| void{ 132 | delete static_cast($(void *haskellExPtr)); 133 | } |] 134 | return (Left (CppHaskellException someExc)) 135 | ExTypeOtherException -> do 136 | ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr 137 | 138 | -- BS.unsafePackMallocCString: safe because currentExceptionTypeName 139 | -- returns a newly malloced string 140 | mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr 141 | 142 | return (Left (CppNonStdException ex mbExcType)) :: IO (Either CppException a) 143 | _ -> error "Unexpected C++ exception type." 144 | 145 | -- | Like 'tryBlock', but will throw unwrapped 'CppHaskellException's or other 'CppException's rather than returning 146 | -- them in an 'Either' 147 | throwBlock :: QuasiQuoter 148 | throwBlock = QuasiQuoter 149 | { quoteExp = \blockStr -> do 150 | [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp C.block blockStr) |] 151 | , quotePat = unsupported 152 | , quoteType = unsupported 153 | , quoteDec = unsupported 154 | } where 155 | unsupported _ = fail "Unsupported quasiquotation." 156 | 157 | -- | Variant of 'throwBlock' for blocks which return 'void'. 158 | catchBlock :: QuasiQuoter 159 | catchBlock = QuasiQuoter 160 | { quoteExp = \blockStr -> quoteExp throwBlock ("void {" ++ blockStr ++ "}") 161 | , quotePat = unsupported 162 | , quoteType = unsupported 163 | , quoteDec = unsupported 164 | } where 165 | unsupported _ = fail "Unsupported quasiquotation." 166 | 167 | exceptionalValue :: String -> String 168 | exceptionalValue typeStr = 169 | case typeStr of 170 | "void" -> "" 171 | "char" -> "0" 172 | "short" -> "0" 173 | "long" -> "0" 174 | "int" -> "0" 175 | "int8_t" -> "0" 176 | "int16_t" -> "0" 177 | "int32_t" -> "0" 178 | "int64_t" -> "0" 179 | "uint8_t" -> "0" 180 | "uint16_t" -> "0" 181 | "uint32_t" -> "0" 182 | "uint64_t" -> "0" 183 | "float" -> "0" 184 | "double" -> "0" 185 | "bool" -> "0" 186 | "signed char" -> "0" 187 | "signed short" -> "0" 188 | "signed int" -> "0" 189 | "signed long" -> "0" 190 | "unsigned char" -> "0" 191 | "unsigned short" -> "0" 192 | "unsigned int" -> "0" 193 | "unsigned long" -> "0" 194 | "size_t" -> "0" 195 | "wchar_t" -> "0" 196 | "ptrdiff_t" -> "0" 197 | "sig_atomic_t" -> "0" 198 | "intptr_t" -> "0" 199 | "uintptr_t" -> "0" 200 | "intmax_t" -> "0" 201 | "uintmax_t" -> "0" 202 | "clock_t" -> "0" 203 | "time_t" -> "0" 204 | "useconds_t" -> "0" 205 | "suseconds_t" -> "0" 206 | "FILE" -> "0" 207 | "fpos_t" -> "0" 208 | "jmp_buf" -> "0" 209 | _ -> "{}" 210 | 211 | tryBlockQuoteExp :: QuasiQuoter -> String -> Q Exp 212 | tryBlockQuoteExp block blockStr = do 213 | let (ty, body, bodyLineShift) = C.splitTypedC blockStr 214 | _ <- C.include "HaskellException.hxx" 215 | basePtrVarName <- newName "basePtr" 216 | there <- location 217 | let inlineCStr = unlines 218 | [ ty ++ " {" 219 | , " void** __inline_c_cpp_base_ptr__ = $(void** " ++ nameBase basePtrVarName ++ ");" 220 | , " int* __inline_c_cpp_exception_type__ = (int*)__inline_c_cpp_base_ptr__;" 221 | , " const char** __inline_c_cpp_error_message__ = (const char**)(__inline_c_cpp_base_ptr__ + 1);" 222 | , " const char** __inline_c_cpp_error_typ__ = (const char**)(__inline_c_cpp_base_ptr__ + 2);" 223 | , " std::exception_ptr** __inline_c_cpp_exception_ptr__ = (std::exception_ptr**)(__inline_c_cpp_base_ptr__ + 3);" 224 | , " HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)(__inline_c_cpp_base_ptr__ + 4);" 225 | , " *__inline_c_cpp_exception_type__ = 0;" 226 | , " try {" 227 | , C.lineDirective (C.shiftLines (bodyLineShift - 1) there) 228 | , body 229 | , C.lineDirective $(C.here) 230 | , " } catch (const HaskellException &e) {" 231 | , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";" 232 | , " *__inline_c_cpp_haskellexception__ = new HaskellException(e);" 233 | , " return " ++ exceptionalValue ty ++ ";" 234 | , " } catch (const std::exception &e) {" 235 | , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" 236 | , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";" 237 | , " setMessageOfStdException(e, __inline_c_cpp_error_message__, __inline_c_cpp_error_typ__);" 238 | , " return " ++ exceptionalValue ty ++ ";" 239 | , " } catch (...) {" 240 | , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" 241 | , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";" 242 | , " setCppExceptionType(__inline_c_cpp_error_typ__);" 243 | , " return " ++ exceptionalValue ty ++ ";" 244 | , " }" 245 | , "}" 246 | ] 247 | [e| handleForeignCatch $ \ $(varP basePtrVarName) -> $(quoteExp block inlineCStr) |] 248 | 249 | -- | Similar to `C.block`, but C++ exceptions will be caught and the result is (Either CppException value). The return type must be void or constructible with @{}@. 250 | -- Using this will automatically include @exception@, @cstring@ and @cstdlib@. 251 | tryBlock :: QuasiQuoter 252 | tryBlock = QuasiQuoter 253 | { quoteExp = tryBlockQuoteExp C.block 254 | , quotePat = unsupported 255 | , quoteType = unsupported 256 | , quoteDec = unsupported 257 | } where 258 | unsupported _ = fail "Unsupported quasiquotation." 259 | 260 | bsToChars :: ByteString -> String 261 | bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode 262 | -------------------------------------------------------------------------------- /inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | module Language.C.Inline.Cpp.Exceptions {-# DEPRECATED "Language.C.Inline.Cpp.Exceptions is deprecated in favor of Language.C.Inline.Cpp.Exception which changes the CppException data type to preserve the exception for custom error handling." #-} ( 4 | CppException(CppHaskellException) 5 | , pattern Language.C.Inline.Cpp.Exceptions.CppStdException 6 | , pattern Language.C.Inline.Cpp.Exceptions.CppOtherException 7 | , toSomeException 8 | , throwBlock 9 | , tryBlock 10 | , catchBlock 11 | ) where 12 | 13 | 14 | import Data.ByteString (ByteString) 15 | import qualified Data.Text.Encoding as T 16 | import qualified Data.Text.Encoding.Error as T 17 | import qualified Data.Text as T 18 | import Language.C.Inline.Cpp.Exception 19 | 20 | bsToChars :: ByteString -> String 21 | bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode 22 | 23 | cppStdExceptionMessage :: CppException -> Maybe String 24 | cppStdExceptionMessage (Language.C.Inline.Cpp.Exception.CppStdException _ s (Just t)) = Just $ "Exception: " <> bsToChars s <> "; type: " <> bsToChars t 25 | cppStdExceptionMessage (Language.C.Inline.Cpp.Exception.CppStdException _ s Nothing) = Just $ "Exception: " <> bsToChars s <> "; type: not available (please use g++ or clang)" 26 | cppStdExceptionMessage _ = Nothing 27 | 28 | cppNonStdExceptionType :: CppException -> Maybe (Maybe String) 29 | cppNonStdExceptionType (CppNonStdException _ mt) = Just (fmap bsToChars mt) 30 | cppNonStdExceptionType _ = Nothing 31 | 32 | pattern CppStdException :: String -> CppException 33 | pattern CppStdException s <- (cppStdExceptionMessage -> Just s) 34 | 35 | pattern CppOtherException :: Maybe String -> CppException 36 | pattern CppOtherException mt <- (cppNonStdExceptionType -> Just mt) 37 | -------------------------------------------------------------------------------- /inline-c-cpp/src/Language/C/Inline/Cpp/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | -- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters. 3 | 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | 9 | module Language.C.Inline.Cpp.Unsafe 10 | ( throwBlock 11 | , tryBlock 12 | , catchBlock 13 | , toSomeException 14 | ) where 15 | 16 | import Control.Exception.Safe 17 | import qualified Language.C.Inline.Unsafe as Unsafe 18 | import Language.Haskell.TH.Quote 19 | import Language.C.Inline.Cpp.Exception (tryBlockQuoteExp) 20 | import Language.C.Inline.Cpp.Exception (tryBlockQuoteExp,toSomeException) 21 | 22 | -- | Like 'tryBlock', but will throw unwrapped 'CppHaskellException's or other 'CppException's rather than returning 23 | -- them in an 'Either' 24 | throwBlock :: QuasiQuoter 25 | throwBlock = QuasiQuoter 26 | { quoteExp = \blockStr -> do 27 | [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp Unsafe.block blockStr) |] 28 | , quotePat = unsupported 29 | , quoteType = unsupported 30 | , quoteDec = unsupported 31 | } where 32 | unsupported _ = fail "Unsupported quasiquotation." 33 | 34 | -- | Variant of 'throwBlock' for blocks which return 'void'. 35 | catchBlock :: QuasiQuoter 36 | catchBlock = QuasiQuoter 37 | { quoteExp = \blockStr -> quoteExp throwBlock ("void {" ++ blockStr ++ "}") 38 | , quotePat = unsupported 39 | , quoteType = unsupported 40 | , quoteDec = unsupported 41 | } where 42 | unsupported _ = fail "Unsupported quasiquotation." 43 | 44 | -- | Similar to `C.block`, but C++ exceptions will be caught and the result is (Either CppException value). The return type must be void or constructible with @{}@. 45 | -- Using this will automatically include @exception@, @cstring@ and @cstdlib@. 46 | tryBlock :: QuasiQuoter 47 | tryBlock = QuasiQuoter 48 | { quoteExp = tryBlockQuoteExp Unsafe.block 49 | , quotePat = unsupported 50 | , quoteType = unsupported 51 | , quoteDec = unsupported 52 | } where 53 | unsupported _ = fail "Unsupported quasiquotation." 54 | -------------------------------------------------------------------------------- /inline-c-cpp/test-error-message-line-numbers.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -x 3 | sed -i -e 's/.*uncomment this line.*//g' inline-c-cpp/test/tests.hs 4 | stack test $@ inline-c-cpp >& error-log 5 | cat error-log 6 | grep -n 'Test this line' inline-c-cpp/test/tests.hs | awk -F ':' '{print $1}' > exp 7 | cat exp 8 | grep 'tests.hs:[0-9]*:.*error' error-log | awk -F ':' '{print $2}' > out 9 | cat out 10 | set -xe 11 | diff exp out 12 | -------------------------------------------------------------------------------- /inline-c-cpp/test/StdVector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# OPTIONS_GHC -fno-warn-unused-matches #-} 7 | 8 | module StdVector 9 | ( stdVectorCtx 10 | , instanceStdVector 11 | , CStdVector 12 | , StdVector() 13 | , StdVector.new 14 | , size 15 | , toVector 16 | , pushBack 17 | ) 18 | 19 | where 20 | 21 | import qualified Language.C.Inline as C 22 | import qualified Language.C.Inline.Unsafe as CU 23 | import qualified Language.C.Inline.Context as C 24 | import qualified Language.C.Inline.Cpp as C 25 | import qualified Language.C.Types as C 26 | import qualified Data.Vector.Storable as VS 27 | import qualified Data.Vector.Storable.Mutable as VSM 28 | import qualified Data.Map.Strict as M 29 | import Control.Monad 30 | import Data.Maybe 31 | import Language.Haskell.TH.Syntax 32 | import Foreign 33 | import Foreign.C 34 | import Language.Haskell.TH 35 | import Data.Proxy 36 | import Control.Exception (mask_) 37 | 38 | data CStdVector a 39 | 40 | stdVectorCtx :: C.Context 41 | stdVectorCtx = C.cppCtx `mappend` C.cppTypePairs [ ("std::vector", [t| CStdVector |]) ] 42 | 43 | newtype StdVector a = StdVector (ForeignPtr (CStdVector a)) 44 | 45 | class HasStdVector a where 46 | cNew :: IO (Ptr (CStdVector a)) 47 | cDelete :: FunPtr (Ptr (CStdVector a) -> IO ()) 48 | cSize :: Ptr (CStdVector a) -> IO CSize 49 | cCopyTo :: Ptr (CStdVector a) -> Ptr a -> IO () 50 | cPushBack :: a -> Ptr (CStdVector a) -> IO () 51 | 52 | instanceStdVector :: String -> DecsQ 53 | instanceStdVector cType = fmap concat $ sequence 54 | [ C.include "" 55 | , C.include "" 56 | , C.substitute 57 | [ ( "T", \_ -> cType ) 58 | , ( "VEC", \var -> "$(std::vector<" ++ cType ++ ">* " ++ var ++ ")" ) 59 | ] [d| 60 | instance HasStdVector $(C.getHaskellType False cType) where 61 | cNew = [CU.exp| std::vector<@T()>* { new std::vector<@T()>() } |] 62 | cDelete = [C.funPtr| void deleteStdVector(std::vector<@T()>* vec) { delete vec; } |] 63 | cSize vec = [CU.exp| size_t { @VEC(vec)->size() } |] 64 | cCopyTo vec dstPtr = [CU.block| void { 65 | const std::vector<@T()>* vec = @VEC(vec); 66 | std::copy(vec->begin(), vec->end(), $(@T()* dstPtr)); 67 | } |] 68 | cPushBack value vec = [CU.exp| void { @VEC(vec)->push_back($(@T() value)) } |] 69 | |] 70 | ] 71 | 72 | new :: forall a. HasStdVector a => IO (StdVector a) 73 | new = mask_ $ do 74 | ptr <- cNew @a 75 | StdVector <$> newForeignPtr cDelete ptr 76 | 77 | size :: HasStdVector a => StdVector a -> IO Int 78 | size (StdVector fptr) = fromIntegral <$> withForeignPtr fptr cSize 79 | 80 | toVector :: (HasStdVector a, Storable a) => StdVector a -> IO (VS.Vector a) 81 | toVector stdVec@(StdVector stdVecFPtr) = do 82 | vecSize <- size stdVec 83 | hsVec <- VSM.new vecSize 84 | withForeignPtr stdVecFPtr $ \stdVecPtr -> 85 | VSM.unsafeWith hsVec $ \hsVecPtr -> 86 | cCopyTo stdVecPtr hsVecPtr 87 | VS.unsafeFreeze hsVec 88 | 89 | pushBack :: HasStdVector a => StdVector a -> a -> IO () 90 | pushBack (StdVector fptr) value = withForeignPtr fptr (cPushBack value) -------------------------------------------------------------------------------- /inline-c-cpp/test/TemplateSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module TemplateSpec where 6 | 7 | import qualified Language.C.Inline.Cpp as C 8 | import qualified Language.C.Inline.Context as CC 9 | import qualified Language.C.Types as CT 10 | import Foreign 11 | import Foreign.C 12 | import Data.Monoid 13 | 14 | data CppVector a 15 | 16 | C.context $ 17 | C.cppCtx 18 | <> 19 | C.cppTypePairs [ 20 | ("std::vector" :: CT.CIdentifier, [t|CppVector|]) 21 | ] 22 | 23 | C.include "" 24 | C.include "" 25 | 26 | -- compiles: we can return std::vector* 27 | returns_vec_of_int = do 28 | [C.block| std::vector* { 29 | return ( (std::vector*) NULL); 30 | } 31 | |] :: IO (Ptr (CppVector CInt)) 32 | 33 | -- compiles: we can return std::vector* 34 | returns_vec_of_signed = do 35 | [C.block| std::vector* { 36 | return ( (std::vector*) NULL); 37 | } 38 | |] :: IO (Ptr (CppVector CInt)) 39 | 40 | -- compiles: we can return std::vector* 41 | returns_vec_of_unsigned = do 42 | [C.block| std::vector* { 43 | return ( (std::vector*) NULL); 44 | } 45 | |] :: IO (Ptr (CppVector CUInt)) 46 | 47 | -- compiles: we can return std::vector* 48 | returns_vec_of_long_int = do 49 | [C.block| std::vector* { 50 | return ( (std::vector*) NULL); 51 | } 52 | |] :: IO (Ptr (CppVector CLong)) 53 | 54 | -- compiles: we can return std::vector* 55 | returns_vec_of_short = do 56 | [C.block| std::vector* { 57 | return ( (std::vector*) NULL); 58 | } 59 | |] :: IO (Ptr (CppVector CShort)) 60 | 61 | -- compiles: we can return std::vector* 62 | returns_vec_of_short_int = do 63 | [C.block| std::vector* { 64 | return ( (std::vector*) NULL); 65 | } 66 | |] :: IO (Ptr (CppVector CShort)) 67 | 68 | -- compiles: we can return std::vector* 69 | returns_vec_of_unsigned_int = do 70 | [C.block| std::vector* { 71 | return ( (std::vector*) NULL); 72 | } 73 | |] :: IO (Ptr (CppVector CUInt)) 74 | 75 | -- compiles: we can return long* 76 | returns_ptr_to_long = do 77 | [C.block| long* { 78 | return ( (long*) NULL); 79 | } 80 | |] :: IO (Ptr CLong) 81 | 82 | -- compiles: we can return unsigned long* 83 | returns_ptr_to_unsigned_long = do 84 | [C.block| unsigned long* { 85 | return ( (unsigned long*) NULL); 86 | } 87 | |] :: IO (Ptr CULong) 88 | 89 | -- compiles: we can return std::vector* 90 | returns_vec_of_long = do 91 | [C.block| std::vector* { 92 | return ( (std::vector*) NULL); 93 | } 94 | |] :: IO (Ptr (CppVector CLong)) 95 | 96 | -- compiles: we can return std::vector* 97 | returns_vec_of_long_long = do 98 | [C.block| std::vector* { 99 | return ( (std::vector*) NULL); 100 | } 101 | |] :: IO (Ptr (CppVector CLLong)) 102 | 103 | -------------------------------------------------------------------------------- /inline-c-cpp/test/test.h: -------------------------------------------------------------------------------- 1 | namespace Test { 2 | class Test { 3 | public: 4 | Test() {} 5 | int get () {return 3;} 6 | }; 7 | }; 8 | ; 9 | -------------------------------------------------------------------------------- /inline-c-cpp/test/tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE QuasiQuotes #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeInType #-} 17 | {-# LANGUAGE TypeOperators #-} 18 | {-# LANGUAGE UndecidableInstances #-} 19 | {-# LANGUAGE TypeApplications #-} 20 | {-# OPTIONS_GHC -Wno-deprecations #-} 21 | 22 | import Control.Exception.Safe 23 | import Control.Monad 24 | import qualified Data.ByteString as BS 25 | import Data.ByteString (ByteString) 26 | import qualified Language.C.Inline.Cpp as C 27 | import qualified Language.C.Inline.Context as CC 28 | import qualified Language.C.Types as CT 29 | import qualified Language.C.Inline.Cpp.Exception as C 30 | import qualified Language.C.Inline.Cpp.Exceptions as Legacy 31 | import Foreign.C.String (withCString) 32 | import Foreign.StablePtr (StablePtr, newStablePtr, castStablePtrToPtr) 33 | import qualified Test.Hspec as Hspec 34 | import Test.Hspec (shouldBe) 35 | import Foreign.Ptr (Ptr) 36 | import Data.List (isInfixOf) 37 | import Data.Monoid 38 | import qualified StdVector 39 | import qualified Data.Vector.Storable as VS 40 | 41 | 42 | data Test 43 | data Array a 44 | data Tuple a 45 | 46 | C.context $ C.cppCtx <> C.fptrCtx <> C.cppTypePairs [ 47 | ("Test::Test", [t|Test|]), 48 | ("std::array", [t|Array|]), 49 | ("std::tuple", [t|Tuple|]) 50 | ] `mappend` StdVector.stdVectorCtx 51 | 52 | C.include "" 53 | C.include "" 54 | C.include "" 55 | C.include "" 56 | C.include "" 57 | C.include "test.h" 58 | 59 | data MyCustomException = MyCustomException Int 60 | deriving (Eq, Show, Typeable) 61 | instance Exception MyCustomException 62 | 63 | StdVector.instanceStdVector "int" 64 | StdVector.instanceStdVector "double" 65 | 66 | main :: IO () 67 | main = Hspec.hspec $ do 68 | Hspec.describe "Basic C++" $ do 69 | Hspec.it "Hello World" $ do 70 | let x = 3 71 | [C.block| void { 72 | std::cout << "Hello, world!" << $(int x) << std::endl; 73 | } |] 74 | 75 | Hspec.describe "C++ Types" $ do 76 | Hspec.it "Hello Namespace" $ do 77 | pt <- [C.block| Test::Test* { 78 | return new Test::Test(); 79 | } |] :: IO (Ptr Test) 80 | [C.block| void { 81 | std::cout << $(Test::Test* pt)->get() << std::endl; 82 | } |] 83 | 84 | Hspec.it "Hello Template" $ do 85 | pt <- [C.block| std::vector* { 86 | return new std::vector(); 87 | } |] :: IO (Ptr (StdVector.CStdVector C.CInt)) 88 | [C.block| void { 89 | $(std::vector* pt)->push_back(100); 90 | std::cout << (*$(std::vector* pt))[0] << std::endl; 91 | } |] 92 | 93 | Hspec.it "Template + Namespace" $ do 94 | pt <- [C.block| std::vector* { 95 | return new std::vector(); 96 | } |] :: IO (Ptr (StdVector.CStdVector Test)) 97 | [C.block| void { 98 | $(std::vector* pt)->push_back(Test::Test()); 99 | } |] 100 | 101 | Hspec.it "Template with 2 arguments" $ do 102 | pt <- [C.block| std::array* { 103 | return new std::array(); 104 | } |] :: IO (Ptr (Array '(C.CInt,10))) 105 | [C.block| void { 106 | (*$(std::array* pt))[0]=true; 107 | std::cout << (*$(std::array* pt))[0] << std::endl; 108 | } |] 109 | 110 | Hspec.it "Template with 6 arguments" $ do 111 | pt <- [C.block| std::tuple* { 112 | return NULL; 113 | } |] :: IO (Ptr (Tuple '(C.CInt,C.CInt,C.CInt,C.CInt,C.CInt,C.CInt))) 114 | [C.block| void { 115 | $(std::tuple* pt) = NULL; 116 | } |] 117 | 118 | Hspec.describe "Exception handling" $ do 119 | Hspec.it "std::exceptions are caught" $ do 120 | result <- try [C.catchBlock| 121 | throw std::runtime_error("C++ error message"); 122 | |] 123 | 124 | result `shouldBeCppStdException` ("C++ error message", Just "std::runtime_error") 125 | result `shouldBeLegacyCppStdException` "Exception: C++ error message; type: std::runtime_error" 126 | -- Test that we don't accidentally mess up formatting: 127 | result `shouldBeShownException` "CppStdException e \"C++ error message\" (Just \"std::runtime_error\")" 128 | 129 | Hspec.it "non-exceptions are caught (unsigned int)" $ do 130 | result <- try [C.catchBlock| 131 | throw 0xDEADBEEF; 132 | |] 133 | 134 | result `shouldBeCppNonStdException` (Just "unsigned int") 135 | result `shouldBeLegacyCppOtherException` (Just "unsigned int") 136 | 137 | Hspec.it "non-exceptions are caught (void *)" $ do 138 | result <- try [C.catchBlock| 139 | throw (void *)0xDEADBEEF; 140 | |] 141 | 142 | result `shouldBeCppNonStdException` (Just "void*") 143 | result `shouldBeLegacyCppOtherException` (Just "void*") 144 | 145 | Hspec.it "non-exceptions are caught (std::string)" $ do 146 | result <- try [C.catchBlock| 147 | throw std::string("FOOBAR"); 148 | |] 149 | 150 | case result of 151 | Left (C.CppNonStdException ex (Just ty)) -> do 152 | ("string" `BS.isInfixOf` ty) `shouldBe` True 153 | [C.throwBlock| int { 154 | std::exception_ptr *e = $fptr-ptr:(std::exception_ptr *ex); 155 | if (!e) throw std::runtime_error("Exception was null"); 156 | try { 157 | std::cerr << "throwing..." << std::endl; 158 | std::rethrow_exception(*e); 159 | } catch (std::string &foobar) { 160 | if (foobar == "FOOBAR") 161 | return 42; 162 | else 163 | return 1; 164 | } catch (...) { 165 | return 2; 166 | } 167 | return 3; 168 | }|] >>= \r -> r `shouldBe` 42 169 | _ -> error ("Expected Left CppOtherException with string type, but got " ++ show result) 170 | 171 | Hspec.it "catch without return (pure)" $ do 172 | result <- [C.tryBlock| void { 173 | throw std::runtime_error("C++ error message"); 174 | } 175 | |] 176 | 177 | result `shouldBeCppStdException` ("C++ error message", Just "std::runtime_error") 178 | result `shouldBeLegacyCppStdException` "Exception: C++ error message; type: std::runtime_error" 179 | 180 | Hspec.it "try and return without throwing (pure)" $ do 181 | result <- [C.tryBlock| int { 182 | return 123; 183 | } 184 | |] 185 | 186 | result `shouldBeRight` 123 187 | 188 | Hspec.it "return maybe throwing (pure)" $ do 189 | result <- [C.tryBlock| int { 190 | if(1) return 123; 191 | else throw std::runtime_error("C++ error message"); 192 | } 193 | |] 194 | 195 | result `shouldBeRight` 123 196 | 197 | Hspec.it "return definitely throwing (pure)" $ do 198 | result <- [C.tryBlock| int { 199 | if(0) return 123; 200 | else throw std::runtime_error("C++ error message"); 201 | } 202 | |] 203 | 204 | result `shouldBeCppStdException` ("C++ error message", Just "std::runtime_error") 205 | result `shouldBeLegacyCppStdException` "Exception: C++ error message; type: std::runtime_error" 206 | 207 | Hspec.it "catch without return (pure)" $ do 208 | result <- [C.tryBlock| void { 209 | throw std::runtime_error("C++ error message"); 210 | } 211 | |] 212 | 213 | result `shouldBeCppStdException` ("C++ error message", Just "std::runtime_error") 214 | result `shouldBeLegacyCppStdException` "Exception: C++ error message; type: std::runtime_error" 215 | 216 | Hspec.it "try and return without throwing (throw)" $ do 217 | result :: Either C.CppException C.CInt <- try [C.throwBlock| int { 218 | return 123; 219 | } 220 | |] 221 | 222 | result `shouldBeRight` 123 223 | 224 | Hspec.it "return maybe throwing (throw)" $ do 225 | result :: Either C.CppException C.CInt <- try [C.throwBlock| int { 226 | if(1) return 123; 227 | else throw std::runtime_error("C++ error message"); 228 | } 229 | |] 230 | 231 | result `shouldBeRight` 123 232 | 233 | Hspec.it "return definitely throwing (throw)" $ do 234 | result <- try [C.throwBlock| int { 235 | if(0) return 123; 236 | else throw std::runtime_error("C++ error message"); 237 | } 238 | |] 239 | 240 | result `shouldBeCppStdException` ("C++ error message", Just "std::runtime_error") 241 | result `shouldBeLegacyCppStdException` "Exception: C++ error message; type: std::runtime_error" 242 | 243 | Hspec.it "return throwing Haskell" $ do 244 | let exc = toException $ userError "This is from Haskell" 245 | 246 | let doIt = withCString (displayException exc) $ \renderedException -> do 247 | 248 | stablePtr <- newStablePtr exc 249 | let stablePtr' = castStablePtrToPtr stablePtr 250 | 251 | [C.throwBlock| int { 252 | if(0) return 123; 253 | else throw HaskellException(HaskellException(std::string($(const char *renderedException)), $(void *stablePtr'))); 254 | } 255 | |] 256 | 257 | let isTheError e | e == userError "This is from Haskell" = True 258 | isTheError _ = False 259 | 260 | doIt `Hspec.shouldThrow` isTheError 261 | 262 | Hspec.it "return throwing custom Haskell exception" $ do 263 | let exc = toException $ MyCustomException 42 264 | 265 | let doIt = withCString (displayException exc) $ \renderedException -> do 266 | 267 | stablePtr <- newStablePtr exc 268 | let stablePtr' = castStablePtrToPtr stablePtr 269 | 270 | [C.throwBlock| int { 271 | if(0) return 123; 272 | else throw HaskellException(HaskellException(std::string($(const char *renderedException)), $(void *stablePtr'))); 273 | } 274 | |] 275 | 276 | let isTheError (MyCustomException 42) = True 277 | isTheError _ = False 278 | 279 | doIt `Hspec.shouldThrow` isTheError 280 | 281 | Hspec.it "catch without return (throw)" $ do 282 | result <- try [C.throwBlock| void { 283 | throw std::runtime_error("C++ error message"); 284 | } 285 | |] 286 | 287 | result `shouldBeCppStdException` ("C++ error message", Just "std::runtime_error") 288 | result `shouldBeLegacyCppStdException` "Exception: C++ error message; type: std::runtime_error" 289 | 290 | Hspec.it "code without exceptions works normally" $ do 291 | result :: Either C.CppException C.CInt <- try $ C.withPtr_ $ \resPtr -> [C.catchBlock| 292 | *$(int* resPtr) = 0xDEADBEEF; 293 | |] 294 | 295 | result `shouldBeRight` 0xDEADBEEF 296 | 297 | Hspec.it "code can contain preprocessor directives" $ do 298 | result <- try $ [C.throwBlock| int { 299 | #ifndef THE_MACRO_THAT_HAS_NOT_BEEN_DEFINED 300 | return 0xDEADBEEF; 301 | #else 302 | return 0xBEEFCAFE; 303 | #endif 304 | } |] 305 | 306 | result `shouldBeRight` 0xDEADBEEF 307 | 308 | {- Manual test cases for testing lineDirective and splitTypedC -- For CI, uncomment this line. 309 | 310 | Hspec.it "error reporting test case" $ do 311 | result <- try $ [C.throwBlock| int { 0 = 0; return 0xDEADBEEF; /* Test this line. */}|] 312 | result `shouldBeRight` 0xDEADBEEF 313 | 314 | Hspec.it "error reporting test case" $ do 315 | result <- try $ [C.throwBlock| int 316 | { 1 = 1; return 0xDEADBEEF; /* Test this line. */} 317 | |] 318 | result `shouldBeRight` 0xDEADBEEF 319 | 320 | Hspec.it "error reporting test case" $ do 321 | result <- try $ [C.throwBlock| int 322 | { 323 | 2 = 2; /* Test this line. */ 324 | return 0xDEADBEEF; 325 | } 326 | |] 327 | result `shouldBeRight` 0xDEADBEEF 328 | 329 | Hspec.it "error reporting test case" $ do 330 | result <- try $ [C.throwBlock| 331 | int 332 | { 333 | 3 = 3; /* Test this line. */ 334 | return 0xDEADBEEF; 335 | } 336 | |] 337 | result `shouldBeRight` 0xDEADBEEF 338 | 339 | Hspec.it "error reporting test case" $ do 340 | result <- try $ [C.throwBlock| 341 | 342 | int 343 | { 344 | 4 = 4; /* Test this line. */ 345 | return 0xDEADBEEF; 346 | } 347 | |] 348 | result `shouldBeRight` 0xDEADBEEF 349 | -- For CI, uncomment this line. -} 350 | 351 | Hspec.describe "Macros" $ do 352 | Hspec.it "generated std::vector instances work correctly" $ do 353 | intVec <- StdVector.new @C.CInt 354 | StdVector.pushBack intVec 4 355 | StdVector.pushBack intVec 5 356 | hsIntVec <- StdVector.toVector intVec 357 | VS.toList hsIntVec `shouldBe` [ 4, 5 ] 358 | 359 | doubleVec <- StdVector.new @C.CDouble 360 | StdVector.pushBack doubleVec 4.3 361 | StdVector.pushBack doubleVec 6.7 362 | hsDoubleVec <- StdVector.toVector doubleVec 363 | VS.toList hsDoubleVec `shouldBe` [ 4.3, 6.7 ] 364 | 365 | Hspec.it "Template with pointers" $ do 366 | pt <- [C.block| std::vector* { 367 | return new std::vector(); 368 | } |] :: IO (Ptr (StdVector.CStdVector (Ptr C.CInt))) 369 | [C.block| void { 370 | int *a = new int; 371 | *a = 100; 372 | $(std::vector* pt)->push_back(a); 373 | std::cout << *((*$(std::vector* pt))[0]) << std::endl; 374 | delete a; 375 | delete $(std::vector* pt); 376 | } |] 377 | 378 | tag :: C.CppException -> String 379 | tag (C.CppStdException {}) = "CppStdException" 380 | tag (C.CppHaskellException {}) = "CppHaskellException" 381 | tag (C.CppNonStdException {}) = "CppNonStdException" 382 | 383 | shouldBeShownException :: Either C.CppException a -> String -> IO () 384 | shouldBeShownException (Left e) expectedStr = show e `shouldBe` expectedStr 385 | shouldBeShownException (Right _) _expectedStr = "Right _" `Hspec.shouldBe` "Left _" 386 | 387 | shouldBeCppStdException :: Either C.CppException a -> (ByteString, Maybe ByteString) -> IO () 388 | shouldBeCppStdException (Left (C.CppStdException _ actualMsg actualType)) (expectedMsg, expectedType) = do 389 | (actualMsg, actualType) `shouldBe` (expectedMsg, expectedType) 390 | shouldBeCppStdException (Left x) expectedMsg = tag x `Hspec.shouldBe` ("CppStdException " <> show expectedMsg) 391 | shouldBeCppStdException (Right _) expectedMsg = "Right _" `Hspec.shouldBe` ("Left (CppStdException " <> show expectedMsg <> ")") 392 | 393 | -- | Tests that the old, deprecated exception's module and error messages still work. 394 | shouldBeLegacyCppStdException :: Either Legacy.CppException a -> String -> IO () 395 | shouldBeLegacyCppStdException (Left (Legacy.CppStdException actualMsg)) expectedMsg = do 396 | actualMsg `Hspec.shouldBe` expectedMsg 397 | shouldBeLegacyCppStdException (Left x) expectedMsg = tag x `Hspec.shouldBe` ("CppStdException " <> show expectedMsg) 398 | shouldBeLegacyCppStdException (Right _) expectedMsg = "Right _" `Hspec.shouldBe` ("Left (CppStdException " <> show expectedMsg <> ")") 399 | 400 | shouldBeCppNonStdException :: Either C.CppException a -> Maybe ByteString -> IO () 401 | shouldBeCppNonStdException (Left (C.CppNonStdException _ actualType)) expectedType = do 402 | actualType `Hspec.shouldBe` expectedType 403 | shouldBeCppNonStdException (Left x) expectedType = tag x `Hspec.shouldBe` ("CppOtherException " <> show expectedType) 404 | shouldBeCppNonStdException (Right _) expectedType = "Right _" `Hspec.shouldBe` ("Left (CppOtherException " <> show expectedType <> ")") 405 | 406 | -- | Tests that the old, deprecated exception's module and error messages still work. 407 | shouldBeLegacyCppOtherException :: Either Legacy.CppException a -> Maybe String -> IO () 408 | shouldBeLegacyCppOtherException (Left (Legacy.CppOtherException actualType)) expectedType = do 409 | actualType `Hspec.shouldBe` expectedType 410 | shouldBeLegacyCppOtherException (Left x) expectedType = tag x `Hspec.shouldBe` ("CppOtherException " <> show expectedType) 411 | shouldBeLegacyCppOtherException (Right _) expectedType = "Right _" `Hspec.shouldBe` ("Left (CppOtherException " <> show expectedType <> ")") 412 | 413 | shouldBeRight :: (Eq a, Show a) => Either C.CppException a -> a -> IO () 414 | shouldBeRight (Right actual) expected = actual `Hspec.shouldBe` expected 415 | shouldBeRight (Left e) expected = ("Left (" <> tag e <> " {})") `Hspec.shouldBe` ("Right " <> (show expected)) 416 | -------------------------------------------------------------------------------- /inline-c-cuda/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 FP Complete Corporation. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /inline-c-cuda/README.md: -------------------------------------------------------------------------------- 1 | Small set of utilities to inline CUDA code. See tests for example. 2 | -------------------------------------------------------------------------------- /inline-c-cuda/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /inline-c-cuda/inline-c-cuda.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: inline-c-cuda 3 | version: 0.1.0.0 4 | synopsis: Lets you embed CUDA code into Haskell. 5 | description: Utilities to inline CUDA code into Haskell using inline-c. See 6 | tests for example on how to build. 7 | license: MIT 8 | license-file: LICENSE 9 | author: Junji Hashimoto 10 | maintainer: junji.hashimoto@gmail.com 11 | copyright: (c) 2015-2016 FP Complete Corporation, (c) 2023 Junji Hashimoto 12 | category: FFI 13 | tested-with: GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.2 14 | build-type: Simple 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/fpco/inline-c 19 | 20 | flag test-without-cuda 21 | description: Test without cuda 22 | default: False 23 | 24 | library 25 | exposed-modules: Language.C.Inline.Cuda 26 | build-depends: base >=4.7 && <5 27 | , bytestring 28 | , inline-c >= 0.9.0.0 29 | , inline-c-cpp 30 | , template-haskell 31 | , text 32 | , safe-exceptions 33 | , containers 34 | , process 35 | hs-source-dirs: src 36 | default-language: Haskell2010 37 | ghc-options: -Wall 38 | if flag(test-without-cuda) 39 | cpp-options: -DTEST_WITHOUT_CUDA 40 | else 41 | extra-libraries: cudart 42 | 43 | 44 | test-suite tests 45 | type: exitcode-stdio-1.0 46 | hs-source-dirs: test 47 | main-is: tests.hs 48 | build-depends: base >=4 && <5 49 | , bytestring 50 | , inline-c 51 | , inline-c-cpp 52 | , inline-c-cuda 53 | , safe-exceptions 54 | , hspec 55 | , containers 56 | , template-haskell 57 | , vector 58 | default-language: Haskell2010 59 | if flag(test-without-cuda) 60 | cpp-options: -DTEST_WITHOUT_CUDA 61 | -------------------------------------------------------------------------------- /inline-c-cuda/src/Language/C/Inline/Cuda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | -- | Module exposing a 'Context' to inline CUDA code. We only have used 7 | -- this for experiments, so use with caution. See the CUDA tests to see 8 | -- how to build inline CUDA code. 9 | module Language.C.Inline.Cuda 10 | ( module Language.C.Inline 11 | , cudaCtx 12 | , Cpp.cppTypePairs 13 | , Cpp.using 14 | , Cpp.AbstractCppExceptionPtr 15 | ) where 16 | 17 | import qualified Language.Haskell.TH as TH 18 | import qualified Language.Haskell.TH.Syntax as TH 19 | 20 | import Language.C.Inline 21 | import Language.C.Inline.Context 22 | import qualified Language.C.Types as CT 23 | import qualified Language.C.Inline.Cpp as Cpp 24 | 25 | import qualified Data.Map as Map 26 | import Control.Monad.IO.Class (liftIO) 27 | import System.Exit (ExitCode(..)) 28 | import System.Process (readProcessWithExitCode) 29 | import System.Environment (lookupEnv) 30 | import Data.Maybe (fromMaybe) 31 | 32 | compileCuda :: String -> TH.Q FilePath 33 | compileCuda src = do 34 | #ifdef TEST_WITHOUT_CUDA 35 | nvcc <- fromMaybe "g++" <$> TH.runIO (lookupEnv "INLINE_C_CUDA_COMPILER") 36 | cu <- fromMaybe "cc" <$> TH.runIO (lookupEnv "INLINE_C_CUDA_SUFFIX") 37 | #else 38 | nvcc <- fromMaybe "nvcc" <$> TH.runIO (lookupEnv "INLINE_C_CUDA_COMPILER") 39 | cu <- fromMaybe "cu" <$> TH.runIO (lookupEnv "INLINE_C_CUDA_SUFFIX") 40 | #endif 41 | oFile <- TH.addTempFile "o" 42 | cuFile <- TH.addTempFile cu 43 | let (cmd,args) = (nvcc, ["-c", "-o", oFile, cuFile]) 44 | (code, stdout, stderr) <- liftIO $ do 45 | writeFile cuFile src 46 | readProcessWithExitCode cmd args "" 47 | case code of 48 | ExitFailure _ -> fail $ "Compile Command: " ++ (foldl (\a b -> a ++ " " ++ b) " " (cmd : args)) ++ "\n" ++ " Output: " ++ stdout ++ "\n" ++ " Error: " ++ stderr 49 | ExitSuccess -> return oFile 50 | 51 | -- | The equivalent of 'C.baseCtx' for CUDA. It specifies the @.cu@ 52 | -- file extension for the CUDA file, so that nvcc will decide to build CUDA 53 | -- instead of C. See the @.cabal@ test target for an example on how to 54 | -- build. 55 | cudaCtx :: Context 56 | cudaCtx = Cpp.cppCtx <> mempty 57 | { ctxForeignSrcLang = Just TH.RawObject 58 | , ctxOutput = Just $ \s -> "extern \"C\" {\n" ++ s ++ "\n}" 59 | , ctxEnableCpp = True 60 | , ctxRawObjectCompile = Just compileCuda 61 | , ctxTypesTable = Map.singleton (CT.TypeName "std::exception_ptr") [t|Cpp.AbstractCppExceptionPtr|] 62 | } 63 | 64 | -------------------------------------------------------------------------------- /inline-c-cuda/test/tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE QuasiQuotes #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeInType #-} 17 | {-# LANGUAGE TypeOperators #-} 18 | {-# LANGUAGE UndecidableInstances #-} 19 | {-# LANGUAGE TypeApplications #-} 20 | {-# OPTIONS_GHC -Wno-deprecations #-} 21 | 22 | import Control.Exception.Safe 23 | import Control.Monad 24 | import qualified Language.C.Inline.Context as CC 25 | import qualified Language.C.Types as CT 26 | import qualified Language.C.Inline.Cuda as C 27 | import qualified Test.Hspec as Hspec 28 | import Test.Hspec (shouldBe) 29 | import Foreign.Ptr (Ptr) 30 | import Data.Monoid 31 | import Foreign.Marshal.Array 32 | import Foreign.Marshal.Alloc 33 | import Foreign.Storable 34 | 35 | 36 | C.context $ C.cudaCtx 37 | 38 | C.include "" 39 | C.include "" 40 | C.include "" 41 | 42 | #ifdef TEST_WITHOUT_CUDA 43 | 44 | [C.emitBlock| 45 | 46 | void 47 | vectorAdd(int blocksPerGrid, int threadsPerBlock, const float *A, const float *B, float *C, int numElements) 48 | { 49 | for(int blockIdx = 0; blockIdx < blocksPerGrid ; blockIdx++){ 50 | int blockDim = threadsPerBlock; 51 | for(int threadIdx = 0; threadIdx < threadsPerBlock ; threadIdx++){ 52 | int i = blockDim * blockIdx + threadIdx; 53 | 54 | if (i < numElements) 55 | { 56 | C[i] = A[i] + B[i]; 57 | } 58 | } 59 | } 60 | } 61 | 62 | 63 | typedef int cudaError_t; 64 | const int cudaSuccess = 1; 65 | 66 | cudaError_t cudaMalloc(void** dst, size_t size){ 67 | *dst = malloc(size); 68 | return cudaSuccess; 69 | } 70 | 71 | cudaError_t cudaFree(void* dst){ 72 | free(dst); 73 | return cudaSuccess; 74 | } 75 | 76 | const int cudaMemcpyHostToDevice = 0; 77 | const int cudaMemcpyDeviceToHost = 1; 78 | 79 | cudaError_t cudaMemcpy(void *dst, void *src, size_t nbytes, int direction){ 80 | memcpy(dst, src, nbytes); 81 | return cudaSuccess; 82 | } 83 | 84 | char* cudaGetErrorString(cudaError_t err){ 85 | return ""; 86 | } 87 | 88 | |] 89 | 90 | #else 91 | 92 | [C.emitBlock| 93 | __global__ void 94 | vectorAdd(const float *A, const float *B, float *C, int numElements) 95 | { 96 | int i = blockDim.x * blockIdx.x + threadIdx.x; 97 | 98 | if (i < numElements) 99 | { 100 | C[i] = A[i] + B[i]; 101 | } 102 | } 103 | |] 104 | 105 | #endif 106 | 107 | cudaAllocaArray :: forall b. Int -> (Ptr C.CFloat -> IO b) -> IO b 108 | cudaAllocaArray size func = do 109 | let csize = fromIntegral size 110 | alloca $ \(ptr_d_A :: Ptr (Ptr C.CFloat)) -> do 111 | [C.block| void { 112 | cudaError_t err = cudaMalloc((void **)$(float** ptr_d_A), $(int csize) * sizeof(float)); 113 | if (err != cudaSuccess) 114 | { 115 | fprintf(stderr, "Failed to allocate device vector C (error code %s)!\n", cudaGetErrorString(err)); 116 | exit(EXIT_FAILURE); 117 | } 118 | } |] 119 | d_A <- peekElemOff ptr_d_A 0 120 | ret <- func d_A 121 | [C.block| void { 122 | cudaError_t err = cudaFree($(float* d_A)); 123 | if (err != cudaSuccess) 124 | { 125 | fprintf(stderr, "Failed to free device vector A (error code %s)!\n", cudaGetErrorString(err)); 126 | exit(EXIT_FAILURE); 127 | } 128 | } |] 129 | return ret 130 | 131 | cudaMemcpyHostToDevice :: Int -> Ptr C.CFloat -> Ptr C.CFloat -> IO () 132 | cudaMemcpyHostToDevice num host device = do 133 | let cnum = fromIntegral num 134 | [C.block| void { 135 | cudaError_t err = cudaMemcpy($(float* device), $(float* host), $(int cnum) * sizeof(float), cudaMemcpyHostToDevice); 136 | if (err != cudaSuccess) 137 | { 138 | fprintf(stderr, "Failed to copy vector from host to device (error code %s)!\n", cudaGetErrorString(err)); 139 | exit(EXIT_FAILURE); 140 | } 141 | } |] 142 | 143 | cudaMemcpyDeviceToHost :: Int -> Ptr C.CFloat -> Ptr C.CFloat -> IO () 144 | cudaMemcpyDeviceToHost num device host = do 145 | let cnum = fromIntegral num 146 | [C.block| void { 147 | cudaError_t err = cudaMemcpy($(float* host), $(float* device), $(int cnum) * sizeof(float), cudaMemcpyDeviceToHost); 148 | if (err != cudaSuccess) 149 | { 150 | fprintf(stderr, "Failed to copy vector C from device to host (error code %s)!\n", cudaGetErrorString(err)); 151 | exit(EXIT_FAILURE); 152 | } 153 | } |] 154 | 155 | 156 | main :: IO () 157 | main = Hspec.hspec $ do 158 | Hspec.describe "Basic CUDA" $ do 159 | Hspec.it "Add vectors on device" $ do 160 | let numElements = 50000 161 | cNumElements = fromIntegral numElements 162 | allocaArray numElements $ \(h_A :: Ptr C.CFloat) -> do 163 | allocaArray numElements $ \(h_B :: Ptr C.CFloat) -> do 164 | allocaArray numElements $ \(h_C :: Ptr C.CFloat) -> do 165 | cudaAllocaArray numElements $ \(d_A :: Ptr C.CFloat) -> do 166 | cudaAllocaArray numElements $ \(d_B :: Ptr C.CFloat) -> do 167 | cudaAllocaArray numElements $ \(d_C :: Ptr C.CFloat) -> do 168 | [C.block| void { 169 | for (int i = 0; i < $(int cNumElements); ++i) 170 | { 171 | $(float* h_A)[i] = rand()/(float)RAND_MAX; 172 | $(float* h_B)[i] = rand()/(float)RAND_MAX; 173 | } 174 | } |] 175 | cudaMemcpyHostToDevice numElements h_A d_A 176 | cudaMemcpyHostToDevice numElements h_B d_B 177 | #ifdef TEST_WITHOUT_CUDA 178 | [C.block| void { 179 | const int threadsPerBlock = 256; 180 | const int blocksPerGrid =($(int cNumElements) + threadsPerBlock - 1) / threadsPerBlock; 181 | vectorAdd(blocksPerGrid, threadsPerBlock, $(float* d_A), $(float* d_B), $(float* d_C), $(int cNumElements)); 182 | } |] 183 | #else 184 | [C.block| void { 185 | const int threadsPerBlock = 256; 186 | const int blocksPerGrid =($(int cNumElements) + threadsPerBlock - 1) / threadsPerBlock; 187 | vectorAdd<<>>($(float* d_A), $(float* d_B), $(float* d_C), $(int cNumElements)); 188 | } |] 189 | #endif 190 | cudaMemcpyDeviceToHost numElements d_C h_C 191 | lA <- peekArray numElements h_A 192 | lB <- peekArray numElements h_B 193 | lC <- peekArray numElements h_C 194 | all (< 1e-5) (map (\((a,b),c) -> abs(a + b - c)) (zip (zip lA lB) lC)) `shouldBe` True 195 | -------------------------------------------------------------------------------- /inline-c-objc/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 FP Complete Corporation. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /inline-c-objc/README.md: -------------------------------------------------------------------------------- 1 | Small set of utilities to inline Objective-C code. See tests for example. 2 | -------------------------------------------------------------------------------- /inline-c-objc/inline-c-objc.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: inline-c-objc 3 | version: 0.1.0.0 4 | synopsis: Lets you embed Objective-C code into Haskell. 5 | description: Utilities to inline Objective-C code into Haskell using inline-c. See 6 | tests for example on how to build. 7 | license: MIT 8 | license-file: LICENSE 9 | author: Francesco Mazzoli 10 | maintainer: f@mazzo.li 11 | copyright: (c) 2015-2016 FP Complete Corporation, (c) 2017-2023 Francesco Mazzoli 12 | category: FFI 13 | tested-with: GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.2 14 | build-type: Simple 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/fpco/inline-c 19 | 20 | library 21 | exposed-modules: Language.C.Inline.ObjC 22 | build-depends: base >=4.7 && <5 23 | , inline-c >= 0.9.1.5 24 | , template-haskell 25 | , containers 26 | hs-source-dirs: src 27 | default-language: Haskell2010 28 | ghc-options: -Wall 29 | 30 | test-suite tests 31 | type: exitcode-stdio-1.0 32 | hs-source-dirs: test 33 | main-is: tests.hs 34 | build-depends: base >=4 && <5 35 | , inline-c 36 | , inline-c-objc 37 | , hspec 38 | default-language: Haskell2010 39 | if os(darwin) 40 | frameworks: Foundation 41 | buildable: True 42 | else 43 | buildable: False 44 | -------------------------------------------------------------------------------- /inline-c-objc/src/Language/C/Inline/ObjC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Language.C.Inline.ObjC 5 | ( module Language.C.Inline 6 | , objcCtx 7 | , CId, Id(..) 8 | ) where 9 | 10 | import qualified Language.Haskell.TH.Syntax as TH 11 | import qualified Language.C.Types as CT 12 | import Foreign 13 | 14 | import Language.C.Inline 15 | import Language.C.Inline.Context 16 | 17 | import qualified Data.Map as Map 18 | 19 | objcCtx :: Context 20 | objcCtx = baseCtx <> mempty 21 | { ctxForeignSrcLang = Just TH.LangObjc 22 | , ctxTypesTable = Map.singleton (CT.TypeName "id") [t|Id|] 23 | } 24 | 25 | data CId 26 | newtype Id = Id (Ptr CId) 27 | -------------------------------------------------------------------------------- /inline-c-objc/test/tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import qualified Language.C.Inline.ObjC as C 5 | import qualified Test.Hspec as Hspec 6 | 7 | C.context C.objcCtx 8 | 9 | C.include "" 10 | 11 | main :: IO () 12 | main = Hspec.hspec $ do 13 | Hspec.describe "Basic Objective-C" $ do 14 | Hspec.it "Hello World" $ do 15 | let x = 3 16 | [C.block| void { 17 | NSLog(@"%@ %d", @"Hello, world!", $(int x)); 18 | } |] 19 | Hspec.it "Expressions" $ do 20 | z <- [C.exp| int { [[@"A few words" componentsSeparatedByString: @" "] count] } |] 21 | z `Hspec.shouldBe` 3 22 | Hspec.it "Objects" $ do 23 | a <- [C.exp| id { [@"A few more words" componentsSeparatedByString: @" "] } |] 24 | s <- [C.exp| int { [$(id a) count] } |] 25 | s `Hspec.shouldBe` 4 26 | -------------------------------------------------------------------------------- /inline-c/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 FP Complete Corporation. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /inline-c/README.md: -------------------------------------------------------------------------------- 1 | # inline-c 2 | 3 | `inline-c` lets you seamlessly call C libraries and embed 4 | high-performance inline C code in Haskell modules. Haskell and C can 5 | be freely intermixed in the same source file, and data passed to and 6 | from code in either language with minimal overhead. No FFI required. 7 | 8 | `inline-c` is Haskell's escape hatch (or one of) to the wild world of 9 | legacy code and high-performance numerical and system libraries. It 10 | has other uses too: you can also think of `inline-c` as to Haskell 11 | what inline Assembly is to C — a convenient means to eke out a little 12 | bit of extra performance in those rare cases where C still beats 13 | Haskell. 14 | 15 | GHCi support is currently limited to using `-fobject-code`, see 16 | the [last section](#ghci) for more info. 17 | 18 | ## Getting started 19 | 20 | Let's say we want to compute the cosine of a number using C from 21 | Haskell. `inline-c` lets you write this function call inline, without 22 | any need for a binding to the foreign function: 23 | 24 | ``` 25 | {-# LANGUAGE QuasiQuotes #-} 26 | {-# LANGUAGE TemplateHaskell #-} 27 | 28 | import qualified Language.C.Inline as C 29 | 30 | C.include "" 31 | 32 | main :: IO () 33 | main = do 34 | x <- [C.exp| double{ cos(1) } |] 35 | print x 36 | ``` 37 | 38 | `inline-c` leverages the [quasiquotation][ghc-manual-quasiquotation] 39 | language extension implemented in GHC. 40 | [Template Haskell][ghc-manual-template-haskell] is also required. 41 | Importing the `Language.C.Inline` module brings in scope most required 42 | Haskell definitions. `C.include ""` brings into scope the 43 | foreign function `cos()` that we wish to call. Finally, in the `main` 44 | function, `[C.exp| double { cos(1) } |]` denotes an inline C expression 45 | of type `double`. `cexp` stands for "C expression". It is a custom 46 | quasiquoter provided by `inline-c`. 47 | 48 | A `C.exp` quasiquotation always includes a type annotation for the 49 | inline C expression. This annotation determines the type of the 50 | quasiquotation in Haskell. Out of the box, `inline-c` knows how to map 51 | many common C types to Haskell types. In this case, 52 | 53 | ``` 54 | [C.exp| double { cos(1) } |] :: IO CDouble 55 | ``` 56 | 57 | For pure C expression like these we also provide `C.pure`, which works 58 | exactly the same but without the `IO`: 59 | 60 | ``` 61 | [C.pure| double { cos(1) } |] :: CDouble 62 | ``` 63 | 64 | Obviously extra care must be taken when using `C.pure`: the embedded C 65 | code must be referentially transparent. 66 | 67 | ## Multiple statements 68 | 69 | `inline-c` allows embedding arbitrary C code, not just expressions, in 70 | the form of a sequence of statements, using the `c` quasiquoter: 71 | 72 | ``` 73 | {-# LANGUAGE QuasiQuotes #-} 74 | {-# LANGUAGE TemplateHaskell #-} 75 | 76 | import qualified Language.C.Inline as C 77 | 78 | C.include "" 79 | 80 | main :: IO () 81 | main = do 82 | x <- [C.block| int { 83 | // Read and sum 5 integers 84 | int i, sum = 0, tmp; 85 | for (i = 0; i < 5; i++) { 86 | scanf("%d", &tmp); 87 | sum += tmp; 88 | } 89 | return sum; 90 | } |] 91 | print x 92 | ``` 93 | 94 | Just as with `C.exp`, we need a type annotation on the entire C block. 95 | The annotation specifies the return type. That is, the type of the 96 | expression in any return statement. 97 | 98 | ## Capturing Haskell variables -- parameter declaration 99 | 100 | `inline-c` allows referring to Haskell variables inside C expressions 101 | and code blocks. We do so by "anti-quoting" them. 102 | 103 | Let's say that we wanted to parameterize the function we wrote above 104 | by how many numbers we should read. We can do so by defining a Haskell 105 | function whose parameter we can refer to from within C: 106 | 107 | ``` 108 | {-# LANGUAGE QuasiQuotes #-} 109 | {-# LANGUAGE TemplateHaskell #-} 110 | import qualified Language.C.Inline as C 111 | import Foreign.C.Types 112 | 113 | C.include "" 114 | 115 | -- | @readAndSum n@ reads @n@ numbers from standard input and returns 116 | -- their sum. 117 | readAndSum :: CInt -> IO CInt 118 | readAndSum n = [C.block| int { 119 | // Read and sum n integers 120 | int i, sum = 0, tmp; 121 | for (i = 0; i < $(int n); i++) { 122 | scanf("%d", &tmp); 123 | sum += tmp; 124 | } 125 | return sum; 126 | } |] 127 | 128 | main :: IO () 129 | main = do 130 | x <- readAndSum 5 131 | print x 132 | ``` 133 | 134 | Here, the Haskell variable `n` is captured right where we need it using 135 | `$(int n)`. Standard anti-quotation (we'll talk about additional ones 136 | later) consists of a `$` followed by a C declaration in parenthesis. 137 | Note that any valid Haskell identifiers can be used when anti-quoting, 138 | including ones including constructors, qualified names, names containing 139 | unicode, etc. 140 | 141 | For each anti-quotation, a variable with a matching type is expected in 142 | the Haskell environment. In this case `inline-c` expects a variable 143 | named `n` of type `CInt`, which is the case. 144 | 145 | ## What can be captured and returned? 146 | 147 | All C types correspond to exactly one Haskell type. Basic types (`int`, 148 | `long`, `double`, `float`, etc.) get converted to their Haskell 149 | equivalents `CInt`, `CLong`, `CDouble`, `CFloat`. Pointers and arrays 150 | get converted to `Ptr`. Function pointers get converted to `FunPtr`. 151 | 152 | `inline-c` can also handle user-defined structs and enums, provided that 153 | they are instances of `Storable` and that you tell `inline-c` about them 154 | using [contexts](#contexts). 155 | 156 | ## Contexts 157 | 158 | Everything beyond the base functionality provided by `inline-c` is 159 | specified in a structure that we call "`Context`". From a user 160 | perspective, if we want to use anything but the default context 161 | (`C.baseCtx`), we must set the `C.Context` explicitly using the 162 | `C.context` function. The next two sections include several examples. 163 | 164 | The `C.Context` allows to extend `inline-c` to support 165 | 166 | * Custom C types beyond the basic ones; 167 | * And [additional anti-quoters](#more-anti-quoters). 168 | 169 | `C.Context`s can be composed using their `Monoid` instance. 170 | 171 | Ideally a `C.Context` will be provided for each C library that should be 172 | used with `inline-c`. The user can then combine multiple contexts 173 | together if multiple libraries are to be used in the same program. See 174 | the [`inline-c-nag` package](https://github.com/fpco/inline-c-nag) for 175 | an example of using a `C.Context` tailored for a library. 176 | 177 | For information regarding how to define `C.Context`s, see the 178 | Haddock-generated API documentation for `Language.C.Inline.Context`. 179 | 180 | ## More anti-quoters 181 | 182 | Besides the basic anti-quoter, which captures variables as they are, 183 | some more anti-quoters are provided with additional functionality. As 184 | mentioned, `inline-c` can easily be extended with anti-quoters defined 185 | by the user, using [contexts](#contexts). 186 | 187 | ### Vectors 188 | 189 | The `vec-len` and `vec-ptr` anti-quoters in the `C.vecCtx` context let us 190 | easily use [Haskell vectors](http://hackage.haskell.org/package/vector) 191 | in C. Continuing along the "summing" theme, we can write code that sums 192 | Haskell vectors in C: 193 | 194 | ``` 195 | {-# LANGUAGE QuasiQuotes #-} 196 | {-# LANGUAGE TemplateHaskell #-} 197 | import qualified Language.C.Inline as C 198 | import qualified Data.Vector.Storable as V 199 | import qualified Data.Vector.Storable.Mutable as VM 200 | import Data.Monoid ((<>)) 201 | import Foreign.C.Types 202 | 203 | -- To use the vector anti-quoters, we need the 'C.vecCtx' along with the 204 | -- 'C.baseCtx'. 205 | C.context (C.baseCtx <> C.vecCtx) 206 | 207 | sumVec :: VM.IOVector CDouble -> IO CDouble 208 | sumVec vec = [C.block| double { 209 | double sum = 0; 210 | int i; 211 | for (i = 0; i < $vec-len:vec; i++) { 212 | sum += $vec-ptr:(double *vec)[i]; 213 | } 214 | return sum; 215 | } |] 216 | 217 | main :: IO () 218 | main = do 219 | x <- sumVec =<< V.thaw (V.fromList [1,2,3]) 220 | print x 221 | ``` 222 | 223 | The `vec-len` anti-quoter is used simply by specifying the vector we 224 | want to get the length of (in our case, `vec`). To use the `vec-ptr` 225 | anti-quoter it is also required to specify the pointer type we want. 226 | Since `vec` is a vector of `CDouble`s, we want a pointer to `double`s. 227 | 228 | ## ByteStrings 229 | 230 | The `bs-len` and `bs-ptr` anti-quoters in the `C.bsCtx` context work 231 | exactly the same as the `vec-len` and `vec-ptr` counterparts, but with 232 | strict `ByteString`s. The only difference is that it is not necessary to 233 | specify the type of the pointer from C -- it is always going to be 234 | `char *`: 235 | 236 | ``` 237 | {-# LANGUAGE TemplateHaskell #-} 238 | {-# LANGUAGE QuasiQuotes #-} 239 | import qualified Data.ByteString as BS 240 | import Data.Monoid ((<>)) 241 | import Foreign.C.Types 242 | import qualified Language.C.Inline as C 243 | 244 | C.context (C.baseCtx <> C.bsCtx) 245 | 246 | -- | Count the number of set bits in a 'BS.ByteString'. 247 | countSetBits :: BS.ByteString -> IO CInt 248 | countSetBits bs = [C.block| 249 | int { 250 | int i, bits = 0; 251 | for (i = 0; i < $bs-len:bs; i++) { 252 | char ch = $bs-ptr:bs[i]; 253 | bits += (ch * 01001001001ULL & 042104210421ULL) % 017; 254 | } 255 | return bits; 256 | } 257 | |] 258 | ``` 259 | 260 | ### Function pointers 261 | 262 | Using the `fun` anti-quoter, present in the `C.funCtx` context, we can 263 | easily turn Haskell function into function pointers. 264 | 265 | ``` 266 | {-# LANGUAGE QuasiQuotes #-} 267 | {-# LANGUAGE TemplateHaskell #-} 268 | import qualified Language.C.Inline as C 269 | 270 | -- To use the function pointer anti-quoter, we need the 'C.funCtx' along with 271 | -- the 'C.baseCtx'. 272 | C.context (C.baseCtx <> C.funCtx) 273 | 274 | ackermann :: CLong -> CLong -> CLong 275 | ackermann m n 276 | | m == 0 = n + 1 277 | | m > 0 && n == 0 = ackermann (m - 1) 1 278 | | otherwise = ackermann (m - 1) (ackermann m (n - 1)) 279 | 280 | main :: IO () 281 | main = do 282 | let ackermannIO m n = return $ ackermann m n 283 | let x = 3 284 | let y = 4 285 | z <- [C.exp| long{ 286 | $fun:(long (*ackermannIO)(long, long))($(long x), $(long y)) 287 | } |] 288 | print z 289 | ``` 290 | 291 | In this example, we capture a Haskell function of type `CLong -> CLong 292 | -> IO CLong`, `ackermannIO`, to a function pointer in C, using the `fun` 293 | anti-quoter. Note how we need to specify the function pointer type when 294 | we capture `ackermannIO`, using standard C declaration syntax. Also 295 | note that the `fun` anti-quoter works with `IO` functions, and so we 296 | needed to modify `ackermann` to make it have the right type. 297 | 298 | In general, when anti-quoting, if the type can be inferred (like in the 299 | case of `vec-len`), only the Haskell identifier appears. If it can't, 300 | the target C type and the Haskell identifier are mentioned using C 301 | declaration syntax. 302 | 303 | ## GHCi 304 | 305 | Currently `inline-c` does not work in interpreted mode. However, GHCi 306 | can still be used using the `-fobject-code` flag. For speed, we 307 | recommend passing `-fobject-code -O0`, for example 308 | 309 | ``` 310 | stack ghci --ghci-options='-fobject-code -O0' 311 | ``` 312 | 313 | or 314 | 315 | ``` 316 | cabal repl --ghc-options='-fobject-code -O0' 317 | ``` 318 | 319 | [ghc-manual-quasiquotation]: 320 | https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell-quasi-quotation 321 | [ghc-manual-template-haskell]: 322 | https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell 323 | -------------------------------------------------------------------------------- /inline-c/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /inline-c/changelog.md: -------------------------------------------------------------------------------- 1 | - 0.9.1.10: 2 | * Add -fcompact-unwind for darwin exceptions(#131). 3 | * Fix Cpp.Exception error message line numbers(#133). 4 | * Skip generating foreign calls under ghcide(HSL), generate stubs instead(#128). 5 | * Add ctxRawObjectCompile option to support CUDA(#147). 6 | - 0.9.1.8: Tighten ansi-wl-pprint upper bound, see issue #144. 7 | - 0.9.1.7: Allow arbitrary number of C++ templates, see PR #141. 8 | - 0.9.1.6: Fix mistakenly unsafe call, see issue #137. 9 | - 0.9.1.5: Support multi-token types in C++ template arguments, see issue #125 and PR #126. 10 | - 0.9.1.4: Support GHC 8.10, including better C++ flags handling, see PR #121. 11 | - 0.9.1.3: Work around spurious test failures, see PR #118. 12 | - 0.9.1.2: Update haddock for `Language.C.Inline.Interruptible.pure`. 13 | - 0.9.1.1: Use `unsafeDupablePerformIO` rather than `unsafePerformIO`. See issue #115 and PR #117. 14 | - 0.9.1.0: Add `Language.C.Inline.substitute` and `Language.C.Inline.getHaskellType`. 15 | - 0.9.0.0: Add support for C++ namespace and template. 16 | - 0.8.0.1: Compatibility with GHC 8.8 17 | - 0.8: Add code locations. 18 | - 0.7.0.1: Add more docs for `funPtr` 19 | - 0.7.0.0: Add `funPtr` quasi-quoter 20 | - 0.6.0.6: Support GHC 8.4 21 | - 0.6.0.5: Update readme 22 | - 0.6.0.4: Remove QuickCheck dependency 23 | - 0.6.0.3: Remove cryptohash dependencies 24 | - 0.6.0.2: Update haddock 25 | - 0.6.0.0: Use `addDependentFile` so separate compilation is not needed. 26 | - 0.5.6.0: Add `ForeignPtr` anti-quoter 27 | - 0.5.5.9: Make tests work with QuickCheck < 2.9 28 | - 0.5.5.8: Add workaround for QuickCheck-2.9 bug. See issue #51 29 | - 0.5.5.2: Add docs regarding internals. See issue #41. 30 | - 0.5.5.1: Add support for Interruptible calls. The version skip is 31 | simply because I forgot to update the changelog for 0.5.5.0. 32 | - 0.5.4.3: Fix haddock docs. 33 | - 0.5.4.2: Generate unique C names by prefixing the already generated 34 | name with the Haskell module name. See issue #25. 35 | - 0.5.4.1: Do not generate C code when haddock is type checking. See 36 | issue #24. 37 | - 0.5.4.0: Allow Haskell identifiers in anti-quotes. See issue #23. 38 | - 0.5.3.4: Fix `bsCtx` docs. 39 | - 0.5.3.3: 40 | * Fix errors when using parallel builds. See issue #22. 41 | * Use `fail` rather than `error` in the `Q` monad. 42 | - 0.5.3.2: Make type errors with default anti-quoter much saner. 43 | - 0.5.3.1: Fix leak of `FunPtr` when using `funCtx`. 44 | - 0.5.3.0: Recognize more standard library types. See pull request #19. 45 | - 0.5.2.1: Convert `signed char` to `CSChar`. See pull request #18. 46 | - 0.5.2.0: Make `bs-ptr` use `char` instead of `unsigned char`. See 47 | issue #16. 48 | -------------------------------------------------------------------------------- /inline-c/examples/gsl-ode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE MultiWayIf #-} 6 | import Unsafe.Coerce (unsafeCoerce) 7 | import Data.Monoid ((<>)) 8 | import qualified Data.Vector.Storable as V 9 | import qualified Data.Vector.Storable.Mutable as VM 10 | import Foreign.C.Types 11 | import Foreign.ForeignPtr (newForeignPtr_) 12 | import Foreign.Ptr (Ptr) 13 | import Foreign.Storable (Storable) 14 | import qualified Language.C.Inline as C 15 | import qualified Language.C.Inline.Unsafe as CU 16 | import System.IO.Unsafe (unsafePerformIO) 17 | import Control.Monad (forM_) 18 | import System.IO (withFile, hPutStrLn, IOMode(..)) 19 | 20 | C.context (C.baseCtx <> C.vecCtx <> C.funCtx) 21 | 22 | C.include "" 23 | C.include "" 24 | C.include "" 25 | 26 | -- | Solves a system of ODEs. Every 'V.Vector' involved must be of the 27 | -- same size. 28 | {-# NOINLINE solveOdeC #-} 29 | solveOdeC 30 | :: (CDouble -> V.Vector CDouble -> V.Vector CDouble) 31 | -- ^ ODE to Solve 32 | -> CDouble 33 | -- ^ Start 34 | -> V.Vector CDouble 35 | -- ^ Solution at start point 36 | -> CDouble 37 | -- ^ End 38 | -> Either String (V.Vector CDouble) 39 | -- ^ Solution at end point, or error. 40 | solveOdeC fun x0 f0 xend = unsafePerformIO $ do 41 | let dim = V.length f0 42 | let dim_c = fromIntegral dim -- This is in CInt 43 | -- Convert the function to something of the right type to C. 44 | let funIO x y f _ptr = do 45 | -- Convert the pointer we get from C (y) to a vector, and then 46 | -- apply the user-supplied function. 47 | fImm <- fun x <$> vectorFromC dim y 48 | -- Fill in the provided pointer with the resulting vector. 49 | vectorToC fImm dim f 50 | -- Unsafe since the function will be called many times. 51 | [CU.exp| int{ GSL_SUCCESS } |] 52 | -- Create a mutable vector from the initial solution. This will be 53 | -- passed to the ODE solving function provided by GSL, and will 54 | -- contain the final solution. 55 | fMut <- V.thaw f0 56 | res <- [C.block| int { 57 | gsl_odeiv2_system sys = { 58 | $fun:(int (* funIO) (double t, const double y[], double dydt[], void * params)), 59 | // The ODE to solve, converted to function pointer using the `fun` 60 | // anti-quoter 61 | NULL, // We don't provide a Jacobian 62 | $(int dim_c), // The dimension 63 | NULL // We don't need the parameter pointer 64 | }; 65 | // Create the driver, using some sensible values for the stepping 66 | // function and the tolerances 67 | gsl_odeiv2_driver *d = gsl_odeiv2_driver_alloc_y_new ( 68 | &sys, gsl_odeiv2_step_rk8pd, 1e-6, 1e-6, 0.0); 69 | // Finally, apply the driver. 70 | int status = gsl_odeiv2_driver_apply( 71 | d, &$(double x0), $(double xend), $vec-ptr:(double *fMut)); 72 | // Free the driver 73 | gsl_odeiv2_driver_free(d); 74 | return status; 75 | } |] 76 | -- Check the error code 77 | maxSteps <- [C.exp| int{ GSL_EMAXITER } |] 78 | smallStep <- [C.exp| int{ GSL_ENOPROG } |] 79 | good <- [C.exp| int{ GSL_SUCCESS } |] 80 | if | res == good -> Right <$> V.freeze fMut 81 | | res == maxSteps -> return $ Left "Too many steps" 82 | | res == smallStep -> return $ Left "Step size dropped below minimum allowed size" 83 | | otherwise -> return $ Left $ "Unknown error code " ++ show res 84 | 85 | solveOde 86 | :: (Double -> V.Vector Double -> V.Vector Double) 87 | -- ^ ODE to Solve 88 | -> Double 89 | -- ^ Start 90 | -> V.Vector Double 91 | -- ^ Solution at start point 92 | -> Double 93 | -- ^ End 94 | -> Either String (V.Vector Double) 95 | -- ^ Solution at end point, or error. 96 | solveOde fun x0 f0 xend = 97 | unsafeCoerce $ solveOdeC (unsafeCoerce fun) (unsafeCoerce x0) (unsafeCoerce f0) (unsafeCoerce xend) 98 | 99 | lorenz 100 | :: Double 101 | -- ^ Starting point 102 | -> V.Vector Double 103 | -- ^ Solution at starting point 104 | -> Double 105 | -- ^ End point 106 | -> Either String (V.Vector Double) 107 | lorenz x0 f0 xend = solveOde fun x0 f0 xend 108 | where 109 | sigma = 10.0; 110 | _R = 28.0; 111 | b = 8.0 / 3.0; 112 | 113 | fun _x y = 114 | let y0 = y V.! 0 115 | y1 = y V.! 1 116 | y2 = y V.! 2 117 | in V.fromList 118 | [ sigma * ( y1 - y0 ) 119 | , _R * y0 - y1 - y0 * y2 120 | , -b * y2 + y0 * y1 121 | ] 122 | 123 | main :: IO () 124 | main = withFile "lorenz.csv" WriteMode $ \h -> 125 | forM_ pts $ \(x,y) -> 126 | hPutStrLn h $ show x ++ ", " ++ show y 127 | where 128 | pts = [(f V.! 0, f V.! 2) | (_x, f) <- go 0 (V.fromList [10.0 , 1.0 , 1.0])] 129 | 130 | go x f | x > 40 = 131 | [(x, f)] 132 | go x f = 133 | let x' = x + 0.01 134 | Right f' = lorenz x f x' 135 | in (x, f) : go x' f' 136 | 137 | -- Utils 138 | 139 | vectorFromC :: Storable a => Int -> Ptr a -> IO (V.Vector a) 140 | vectorFromC len ptr = do 141 | ptr' <- newForeignPtr_ ptr 142 | V.freeze $ VM.unsafeFromForeignPtr0 ptr' len 143 | 144 | vectorToC :: Storable a => V.Vector a -> Int -> Ptr a -> IO () 145 | vectorToC vec len ptr = do 146 | ptr' <- newForeignPtr_ ptr 147 | V.copy (VM.unsafeFromForeignPtr0 ptr' len) vec 148 | -------------------------------------------------------------------------------- /inline-c/inline-c.cabal: -------------------------------------------------------------------------------- 1 | name: inline-c 2 | version: 0.9.1.10 3 | synopsis: Write Haskell source files including C code inline. No FFI required. 4 | description: See . 5 | license: MIT 6 | license-file: LICENSE 7 | author: Francesco Mazzoli, Mathieu Boespflug 8 | maintainer: f@mazzo.li 9 | copyright: (c) 2015-2016 FP Complete Corporation, (c) 2017-2019 Francesco Mazzoli 10 | category: FFI 11 | tested-with: GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.2 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | Extra-Source-Files: README.md, changelog.md 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/fpco/inline-c 19 | 20 | flag gsl-example 21 | description: Build GSL example 22 | default: False 23 | 24 | library 25 | exposed-modules: Language.C.Inline 26 | , Language.C.Inline.Context 27 | , Language.C.Inline.HaskellIdentifier 28 | , Language.C.Inline.Internal 29 | , Language.C.Inline.Unsafe 30 | , Language.C.Inline.Interruptible 31 | , Language.C.Types 32 | , Language.C.Types.Parse 33 | other-modules: Language.C.Inline.FunPtr 34 | ghc-options: -Wall 35 | build-depends: base >=4.7 && <5 36 | , prettyprinter >=1.7 37 | , bytestring 38 | , containers 39 | , hashable 40 | , mtl 41 | , parsec >= 3 42 | , parsers 43 | , template-haskell >= 2.12.0.0 44 | , transformers >= 0.1.3.0 45 | , unordered-containers 46 | , vector 47 | hs-source-dirs: src 48 | default-language: Haskell2010 49 | 50 | test-suite tests 51 | type: exitcode-stdio-1.0 52 | hs-source-dirs: test 53 | main-is: tests.hs 54 | other-modules: Dummy 55 | , Language.C.Inline.ContextSpec 56 | , Language.C.Inline.ParseSpec 57 | , Language.C.Types.ParseSpec 58 | build-depends: base >=4 && <5 59 | , QuickCheck 60 | , containers 61 | , hashable 62 | , hspec >= 2 63 | , inline-c 64 | , parsers 65 | , QuickCheck 66 | , prettyprinter 67 | , raw-strings-qq 68 | , regex-posix 69 | , template-haskell 70 | , transformers 71 | , unordered-containers 72 | , vector 73 | , split 74 | default-language: Haskell2010 75 | ghc-options: -Wall 76 | cc-options: -Wall -Werror 77 | 78 | executable gsl-ode 79 | hs-source-dirs: examples 80 | main-is: gsl-ode.hs 81 | default-language: Haskell2010 82 | extra-libraries: gsl gslcblas m 83 | ghc-options: -Wall 84 | cc-options: -Wall -Werror 85 | 86 | if flag(gsl-example) 87 | buildable: True 88 | build-depends: base >=4 && <5 89 | , inline-c 90 | , vector 91 | else 92 | buildable: False 93 | -------------------------------------------------------------------------------- /inline-c/src/Language/C/Inline.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | -- | Enable painless embedding of C code in Haskell code. If you're interested 12 | -- in how to use the library, skip to the "Inline C" section. To build, read the 13 | -- first two sections. 14 | -- 15 | -- This module is intended to be imported qualified: 16 | -- 17 | -- @ 18 | -- import qualified "Language.C.Inline" as C 19 | -- @ 20 | 21 | module Language.C.Inline 22 | ( -- * GHCi 23 | -- $building 24 | 25 | -- * Contexts 26 | Context 27 | , baseCtx 28 | , fptrCtx 29 | , funCtx 30 | , vecCtx 31 | , bsCtx 32 | , context 33 | 34 | -- * Substitution 35 | , substitute 36 | , getHaskellType 37 | 38 | -- * Inline C 39 | -- $quoting 40 | , exp 41 | , pure 42 | , block 43 | , include 44 | , verbatim 45 | , emitBlock 46 | 47 | -- * 'Ptr' utils 48 | , withPtr 49 | , withPtr_ 50 | , WithPtrs(..) 51 | 52 | -- * 'FunPtr' utils 53 | , funPtr 54 | -- ** 'FunPtr' conversion 55 | -- 56 | -- Functions to quickly convert from/to 'FunPtr's. They're provided here 57 | -- since they can be useful to work with Haskell functions in C, and 58 | -- vice-versa. However, consider using 'funCtx' if you're doing this 59 | -- a lot. 60 | , mkFunPtr 61 | , mkFunPtrFromName 62 | , peekFunPtr 63 | 64 | -- * C types re-exports 65 | -- 66 | -- Re-export these to avoid errors when `inline-c` generates FFI calls GHC 67 | -- needs the constructors for those types. 68 | , module Foreign.C.Types 69 | ) where 70 | 71 | #if __GLASGOW_HASKELL__ < 710 72 | import Prelude hiding (exp) 73 | #else 74 | import Prelude hiding (exp, pure) 75 | #endif 76 | 77 | import Control.Monad (void) 78 | import Foreign.C.Types 79 | import Foreign.Marshal.Alloc (alloca) 80 | import Foreign.Ptr (Ptr) 81 | import Foreign.Storable (peek, Storable) 82 | import qualified Language.Haskell.TH as TH 83 | import qualified Language.Haskell.TH.Quote as TH 84 | 85 | import Language.C.Inline.Context 86 | import Language.C.Inline.Internal 87 | import Language.C.Inline.FunPtr 88 | 89 | -- $building 90 | -- 91 | -- Currently @inline-c@ does not work in interpreted mode. However, GHCi 92 | -- can still be used using the @-fobject-code@ flag. For speed, we 93 | -- reccomend passing @-fobject-code -O0@, for example 94 | -- 95 | -- @ 96 | -- stack ghci --ghci-options='-fobject-code -O0' 97 | -- @ 98 | -- 99 | -- or 100 | -- 101 | -- @ 102 | -- cabal repl --ghc-options='-fobject-code -O0' 103 | -- @ 104 | 105 | ------------------------------------------------------------------------ 106 | -- Quoting sugar 107 | 108 | -- $quoting 109 | -- 110 | -- The quasiquoters below are the main interface to this library, for inlining 111 | -- C code into Haskell source files. 112 | -- 113 | -- In general, quasiquoters are used like so: 114 | -- 115 | -- @ 116 | -- [C.XXX| int { \ } |] 117 | -- @ 118 | -- 119 | -- Where @C.XXX@ is one of the quasi-quoters defined in this section. 120 | -- 121 | -- This syntax stands for a piece of typed C, decorated with a type: 122 | -- 123 | -- * The first type to appear (@int@ in the example) is the type of said C code. 124 | -- 125 | -- * The syntax of the @\@ depends on on the quasi-quoter used, and the 126 | -- anti-quoters available. The @exp@ quasi-quoter expects a C expression. The 127 | -- @block@ quasi-quoter expects a list of statements, like the body of 128 | -- a function. Just like a C function, a block has a return type, matching the 129 | -- type of any values in any @return@ statements appearing in the block. 130 | -- 131 | -- See also the @README.md@ file for more documentation. 132 | -- 133 | -- === Anti-quoters 134 | -- 135 | -- Haskell variables can be captured using anti-quoters. @inline-c@ 136 | -- provides a basic anti-quoting mechanism extensible with user-defined 137 | -- anti-quoters (see "Language.C.Inline.Context"). The basic 138 | -- anti-quoter lets you capture Haskell variables, for 139 | -- example we might say 140 | -- 141 | -- @ 142 | -- let x = pi / 3 in ['C.exp'| double { cos($(double x)) } |] 143 | -- @ 144 | -- 145 | -- Which would capture the Haskell variable @x@ of type @'CDouble'@. 146 | -- 147 | -- In C expressions the @$@ character is denoted using @$$@. 148 | -- 149 | -- === Variable capture and the typing relation 150 | -- 151 | -- The Haskell type of the inlined expression is determined by the specified 152 | -- C return type. The relation between the C type and the Haskell type is 153 | -- defined in the current 'Context' -- see 'convertCType'. C pointers and 154 | -- arrays are both converted to Haskell @'Ptr'@s, and function pointers are 155 | -- converted to @'FunPtr'@s. Sized arrays are not supported. 156 | -- 157 | -- Similarly, when capturing Haskell variables using anti-quoting, their 158 | -- type is assumed to be of the Haskell type corresponding to the C type 159 | -- provided. For example, if we capture variable @x@ using @double x@ 160 | -- in the parameter list, the code will expect a variable @x@ of type 161 | -- 'CDouble' in Haskell (when using 'baseCtx'). 162 | -- 163 | -- === Purity 164 | -- 165 | -- The 'exp' and 'block' quasi-quotes denote computations in the 'IO' monad. 166 | -- 'pure' denotes a pure value, expressed as a C expression. 167 | -- 168 | -- === Safe and @unsafe@ calls 169 | -- 170 | -- @unsafe@ variants of the quasi-quoters are provided in 171 | -- "Language.C.Inline.Unsafe" to call the C code unsafely, in the sense that the 172 | -- C code will block the RTS, but with the advantage of a faster call to the 173 | -- foreign code. See 174 | -- . 175 | -- 176 | -- == Examples 177 | -- 178 | -- === Inline C expression 179 | -- 180 | -- @ 181 | -- {-\# LANGUAGE QuasiQuotes \#-} 182 | -- import qualified "Language.C.Inline" as C 183 | -- import qualified "Language.C.Inline.Unsafe" as CU 184 | -- import "Foreign.C.Types" 185 | -- 186 | -- C.'include' "\" 187 | -- 188 | -- c_cos :: 'CDouble' -> IO 'CDouble' 189 | -- c_cos x = [C.exp| double { cos($(double x)) } |] 190 | -- 191 | -- faster_c_cos :: 'CDouble' -> IO 'CDouble' 192 | -- faster_c_cos x = [CU.exp| double { cos($(double x)) } |] 193 | -- @ 194 | -- 195 | -- === Inline C statements 196 | -- 197 | -- @ 198 | -- {-\# LANGUAGE QuasiQuotes \#-} 199 | -- {-\# LANGUAGE TemplateHaskell \#-} 200 | -- import qualified Data.Vector.Storable.Mutable as V 201 | -- import qualified "Language.C.Inline" as C 202 | -- import "Foreign.C.Types" 203 | -- 204 | -- C.'include' "\" 205 | -- 206 | -- parseVector :: 'CInt' -> 'IO' (V.IOVector 'CDouble') 207 | -- parseVector len = do 208 | -- vec <- V.new $ 'fromIntegral' len0 209 | -- V.unsafeWith vec $ \\ptr -> [C.'block'| void { 210 | -- int i; 211 | -- for (i = 0; i < $(int len); i++) { 212 | -- scanf("%lf ", &$(double *ptr)[i]); 213 | -- } 214 | -- } |] 215 | -- 'return' vec 216 | -- @ 217 | -- 218 | -- == How it works 219 | -- 220 | -- For each quasi-quotation of C code, a C function is generated in a C file 221 | -- corresponding to the current Haskell file. Every inline C expression will result 222 | -- in a corresponding C function. 223 | -- For example, if we define @c_cos@ 224 | -- as in the example above in @CCos.hs@, we will get a file containing 225 | -- 226 | -- @ 227 | -- #include 228 | -- 229 | -- double inline_c_Main_0_a03fba228a6d8e36ea7d69381f87bade594c949d(double x_inline_c_0) { 230 | -- return cos(x_inline_c_0); 231 | -- } 232 | -- @ 233 | -- 234 | -- Every anti-quotation will correspond to an argument in the C function. If the same 235 | -- Haskell variable is anti-quoted twice, this will result in two arguments. 236 | -- 237 | -- The C function is then automatically compiled and invoked from Haskell with the correct arguments passed in. 238 | 239 | -- | C expressions. 240 | exp :: TH.QuasiQuoter 241 | exp = genericQuote IO $ inlineExp TH.Safe 242 | 243 | -- | Variant of 'exp', for use with expressions known to have no side effects. 244 | -- 245 | -- __BEWARE__: Use this function with caution, only when you know what you are 246 | -- doing. If an expression does in fact have side-effects, then indiscriminate 247 | -- use of 'pure' may endanger referential transparency, and in principle even 248 | -- type safety. Also note that the function might be called multiple times, 249 | -- given that 'System.IO.Unsafe.unsafeDupablePerformIO' is used to call the 250 | -- provided C code. Please refer to the documentation for 251 | -- 'System.IO.Unsafe.unsafePerformIO' for more details. 252 | -- [unsafeDupablePerformIO is used to ensure good performance using the 253 | -- threaded runtime](https://github.com/fpco/inline-c/issues/115). 254 | pure :: TH.QuasiQuoter 255 | pure = genericQuote Pure $ inlineExp TH.Safe 256 | 257 | -- | C code blocks (i.e. statements). 258 | block :: TH.QuasiQuoter 259 | block = genericQuote IO $ inlineItems TH.Safe False Nothing 260 | 261 | -- | Easily get a 'FunPtr': 262 | -- 263 | -- @ 264 | -- let fp :: FunPtr (Ptr CInt -> IO ()) = [C.funPtr| void poke42(int *ptr) { *ptr = 42; } |] 265 | -- @ 266 | -- 267 | -- Especially useful to generate finalizers that require C code. 268 | -- 269 | -- Most importantly, this allows you to write `Foreign.ForeignPtr.newForeignPtr` invocations conveniently: 270 | -- 271 | -- @ 272 | -- do 273 | -- let c_finalizer_funPtr = 274 | -- [C.funPtr| void myfree(char * ptr) { free(ptr); } |] 275 | -- fp <- newForeignPtr c_finalizer_funPtr objPtr 276 | -- @ 277 | -- 278 | -- Using where possible `Foreign.ForeignPtr.newForeignPtr` is superior to 279 | -- resorting to its delayed-by-a-thread alternative `Foreign.Concurrent.newForeignPtr` 280 | -- from "Foreign.Concurrent" which takes an @IO ()@ Haskell finaliser action: 281 | -- With the non-concurrent `newForeignPtr` you can guarantee that the finaliser 282 | -- will actually be run 283 | -- 284 | -- * when a GC is executed under memory pressure, because it can point directly 285 | -- to a C function that doesn't have to run any Haskell code (which is 286 | -- problematic when you're out of memory) 287 | -- * when the program terminates (`Foreign.Concurrent.newForeignPtr`'s finaliser 288 | -- will likely NOT be called if your main thread exits, making your program 289 | -- e.g. not Valgrind-clean if your finaliser is @free@ or C++'s @delete@). 290 | -- 291 | -- `funPtr` makes the normal `newForeignPtr` as convenient as its concurrent 292 | -- counterpart. 293 | funPtr :: TH.QuasiQuoter 294 | funPtr = funPtrQuote TH.Unsafe -- doesn't make much sense for this to be "safe", but it'd be good to verify what this means 295 | 296 | -- | Emits a CPP include directive for C code associated with the current 297 | -- module. To avoid having to escape quotes, the function itself adds them when 298 | -- appropriate, so that 299 | -- 300 | -- @ 301 | -- include "foo.h" ==> #include "foo.h" 302 | -- @ 303 | -- 304 | -- but 305 | -- 306 | -- @ 307 | -- include "\" ==> #include \ 308 | -- @ 309 | include :: String -> TH.DecsQ 310 | include s 311 | | null s = fail "inline-c: empty string (include)" 312 | | head s == '<' = verbatim $ "#include " ++ s 313 | | otherwise = verbatim $ "#include \"" ++ s ++ "\"" 314 | 315 | -- | Emits an arbitrary C string to the C code associated with the 316 | -- current module. Use with care. 317 | verbatim :: String -> TH.DecsQ 318 | verbatim s = do 319 | void $ emitVerbatim s 320 | return [] 321 | 322 | ------------------------------------------------------------------------ 323 | -- 'Ptr' utils 324 | 325 | -- | Like 'alloca', but also peeks the contents of the 'Ptr' and returns 326 | -- them once the provided action has finished. 327 | withPtr :: (Storable a) => (Ptr a -> IO b) -> IO (a, b) 328 | withPtr f = do 329 | alloca $ \ptr -> do 330 | x <- f ptr 331 | y <- peek ptr 332 | return (y, x) 333 | 334 | withPtr_ :: (Storable a) => (Ptr a -> IO ()) -> IO a 335 | withPtr_ f = do 336 | (x, ()) <- withPtr f 337 | return x 338 | 339 | -- | Type class with methods useful to allocate and peek multiple 340 | -- pointers at once: 341 | -- 342 | -- @ 343 | -- withPtrs_ :: (Storable a, Storable b) => ((Ptr a, Ptr b) -> IO ()) -> IO (a, b) 344 | -- withPtrs_ :: (Storable a, Storable b, Storable c) => ((Ptr a, Ptr b, Ptr c) -> IO ()) -> IO (a, b, c) 345 | -- ... 346 | -- @ 347 | class WithPtrs a where 348 | type WithPtrsPtrs a :: * 349 | withPtrs :: (WithPtrsPtrs a -> IO b) -> IO (a, b) 350 | 351 | withPtrs_ :: (WithPtrsPtrs a -> IO ()) -> IO a 352 | withPtrs_ f = do 353 | (x, _) <- withPtrs f 354 | return x 355 | 356 | instance (Storable a, Storable b) => WithPtrs (a, b) where 357 | type WithPtrsPtrs (a, b) = (Ptr a, Ptr b) 358 | withPtrs f = do 359 | (a, (b, x)) <- withPtr $ \a -> withPtr $ \b -> f (a, b) 360 | return ((a, b), x) 361 | 362 | instance (Storable a, Storable b, Storable c) => WithPtrs (a, b, c) where 363 | type WithPtrsPtrs (a, b, c) = (Ptr a, Ptr b, Ptr c) 364 | withPtrs f = do 365 | (a, ((b, c), x)) <- withPtr $ \a -> withPtrs $ \(b, c) -> f (a, b, c) 366 | return ((a, b, c), x) 367 | 368 | instance (Storable a, Storable b, Storable c, Storable d) => WithPtrs (a, b, c, d) where 369 | type WithPtrsPtrs (a, b, c, d) = (Ptr a, Ptr b, Ptr c, Ptr d) 370 | withPtrs f = do 371 | (a, ((b, c, d), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d) -> f (a, b, c, d) 372 | return ((a, b, c, d), x) 373 | 374 | instance (Storable a, Storable b, Storable c, Storable d, Storable e) => WithPtrs (a, b, c, d, e) where 375 | type WithPtrsPtrs (a, b, c, d, e) = (Ptr a, Ptr b, Ptr c, Ptr d, Ptr e) 376 | withPtrs f = do 377 | (a, ((b, c, d, e), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d, e) -> f (a, b, c, d, e) 378 | return ((a, b, c, d, e), x) 379 | 380 | instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => WithPtrs (a, b, c, d, e, f) where 381 | type WithPtrsPtrs (a, b, c, d, e, f) = (Ptr a, Ptr b, Ptr c, Ptr d, Ptr e, Ptr f) 382 | withPtrs fun = do 383 | (a, ((b, c, d, e, f), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d, e, f) -> fun (a, b, c, d, e, f) 384 | return ((a, b, c, d, e, f), x) 385 | 386 | instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => WithPtrs (a, b, c, d, e, f, g) where 387 | type WithPtrsPtrs (a, b, c, d, e, f, g) = (Ptr a, Ptr b, Ptr c, Ptr d, Ptr e, Ptr f, Ptr g) 388 | withPtrs fun = do 389 | (a, ((b, c, d, e, f, g), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d, e, f, g) -> fun (a, b, c, d, e, f, g) 390 | return ((a, b, c, d, e, f, g), x) 391 | 392 | ------------------------------------------------------------------------ 393 | -- setContext alias 394 | 395 | -- | Sets the 'Context' for the current module. This function, if 396 | -- called, must be called before any of the other TH functions in this 397 | -- module. Fails if that's not the case. 398 | context :: Context -> TH.DecsQ 399 | context ctx = do 400 | setContext ctx 401 | return [] 402 | -------------------------------------------------------------------------------- /inline-c/src/Language/C/Inline/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE QuasiQuotes #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | 19 | -- | A 'Context' is used to define the capabilities of the Template Haskell code 20 | -- that handles the inline C code. See the documentation of the data type for 21 | -- more details. 22 | -- 23 | -- In practice, a 'Context' will have to be defined for each library that 24 | -- defines new C types, to allow the TemplateHaskell code to interpret said 25 | -- types correctly. 26 | 27 | module Language.C.Inline.Context 28 | ( -- * 'TypesTable' 29 | TypesTable 30 | , Purity(..) 31 | , convertType 32 | , CArray 33 | , typeNamesFromTypesTable 34 | 35 | -- * 'AntiQuoter' 36 | , AntiQuoter(..) 37 | , AntiQuoterId 38 | , SomeAntiQuoter(..) 39 | , AntiQuoters 40 | 41 | -- * 'Context' 42 | , Context(..) 43 | , baseCtx 44 | , fptrCtx 45 | , funCtx 46 | , vecCtx 47 | , VecCtx(..) 48 | , bsCtx 49 | ) where 50 | 51 | import Control.Applicative ((<|>)) 52 | import Control.Monad (mzero, forM) 53 | import Control.Monad.Trans.Class (lift) 54 | import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) 55 | import qualified Data.ByteString as BS 56 | import qualified Data.ByteString.Unsafe as BS 57 | import Data.Coerce 58 | import Data.Int (Int8, Int16, Int32, Int64) 59 | import qualified Data.Map as Map 60 | import Data.Typeable (Typeable) 61 | import qualified Data.Vector.Storable as V 62 | import qualified Data.Vector.Storable.Mutable as VM 63 | import Data.Word (Word8, Word16, Word32, Word64) 64 | import Foreign.C.Types 65 | import Foreign.ForeignPtr (withForeignPtr) 66 | import Foreign.Ptr (Ptr, FunPtr, freeHaskellFunPtr) 67 | import Foreign.Storable (Storable) 68 | import qualified Language.Haskell.TH as TH 69 | import qualified Language.Haskell.TH.Syntax as TH 70 | import qualified Text.Parser.Token as Parser 71 | import qualified Data.HashSet as HashSet 72 | 73 | 74 | #if MIN_VERSION_base(4,9,0) 75 | import Data.Semigroup (Semigroup, (<>)) 76 | #else 77 | import Data.Monoid ((<>)) 78 | #endif 79 | 80 | #if __GLASGOW_HASKELL__ < 710 81 | import Data.Monoid (Monoid(..)) 82 | import Data.Traversable (traverse) 83 | #endif 84 | 85 | import Language.C.Inline.FunPtr 86 | import qualified Language.C.Types as C 87 | import Language.C.Inline.HaskellIdentifier 88 | 89 | -- | A mapping from 'C.TypeSpecifier's to Haskell types. Needed both to 90 | -- parse C types, and to convert them to Haskell types. 91 | type TypesTable = Map.Map C.TypeSpecifier TH.TypeQ 92 | 93 | -- | A data type to indicate whether the user requested pure or IO 94 | -- function from Haskell 95 | data Purity 96 | = Pure 97 | | IO 98 | deriving (Eq, Show) 99 | 100 | -- | Specifies how to parse and process an antiquotation in the C code. 101 | -- 102 | -- All antiquotations (apart from plain variable capture) have syntax 103 | -- 104 | -- @ 105 | -- $XXX:YYY 106 | -- @ 107 | -- 108 | -- Where @XXX@ is the name of the antiquoter and @YYY@ is something 109 | -- parseable by the respective 'aqParser'. 110 | data AntiQuoter a = AntiQuoter 111 | { aqParser :: forall m. C.CParser HaskellIdentifier m => m (C.CIdentifier, C.Type C.CIdentifier, a) 112 | -- ^ Parses the body of the antiquotation, returning a hint for the name to 113 | -- assign to the variable that will replace the anti-quotation, the type of 114 | -- said variable, and some arbitrary data which will then be fed to 115 | -- 'aqMarshaller'. 116 | -- 117 | -- The 'C.Type' has 'Void' as an identifier type to make sure that 118 | -- no names appear in it. 119 | , aqMarshaller :: Purity -> TypesTable -> C.Type C.CIdentifier -> a -> TH.Q (TH.Type, TH.Exp) 120 | -- ^ Takes the requested purity, the current 'TypesTable', and the 121 | -- type and the body returned by 'aqParser'. 122 | -- 123 | -- Returns the Haskell type for the parameter, and the Haskell expression 124 | -- that will be passed in as the parameter. 125 | -- 126 | -- If the the type returned is @ty@, the 'TH.Exp' __must__ have type @forall 127 | -- a. (ty -> IO a) -> IO a@. This allows to do resource handling when 128 | -- preparing C values. 129 | -- 130 | -- Care must be taken regarding 'Purity'. Specifically, the generated IO 131 | -- computation must be idempotent to guarantee its safety when used in pure 132 | -- code. We cannot prevent the IO computation from being inlined, hence 133 | -- potentially duplicated. If non-idempotent marshallers are required (e.g. 134 | -- if an update to some global state is needed), it is best to throw an 135 | -- error when 'Purity' is 'Pure' (for example "you cannot use context X with 136 | -- @pure@"), which will show up at compile time. 137 | } 138 | 139 | -- | An identifier for a 'AntiQuoter'. 140 | type AntiQuoterId = String 141 | 142 | -- | Existential wrapper around 'AntiQuoter'. 143 | data SomeAntiQuoter = forall a. (Eq a, Typeable a) => SomeAntiQuoter (AntiQuoter a) 144 | 145 | type AntiQuoters = Map.Map AntiQuoterId SomeAntiQuoter 146 | 147 | -- | A 'Context' stores various information needed to produce the files with 148 | -- the C code derived from the inline C snippets. 149 | -- 150 | -- 'Context's can be composed with their 'Monoid' instance, where 'mappend' is 151 | -- right-biased -- in @'mappend' x y@ @y@ will take precedence over @x@. 152 | data Context = Context 153 | { ctxTypesTable :: TypesTable 154 | -- ^ Needed to convert C types to Haskell types. 155 | , ctxAntiQuoters :: AntiQuoters 156 | -- ^ Needed to parse and process antiquotations. 157 | , ctxOutput :: Maybe (String -> String) 158 | -- ^ This function is used to post-process the functions generated 159 | -- from the C snippets. Currently just used to specify C linkage 160 | -- when generating C++ code. 161 | , ctxForeignSrcLang :: Maybe TH.ForeignSrcLang 162 | -- ^ TH.LangC by default 163 | , ctxEnableCpp :: Bool 164 | -- ^ Compile source code to raw object. 165 | , ctxRawObjectCompile :: Maybe (String -> TH.Q FilePath) 166 | } 167 | 168 | 169 | #if MIN_VERSION_base(4,9,0) 170 | instance Semigroup Context where 171 | ctx2 <> ctx1 = Context 172 | { ctxTypesTable = ctxTypesTable ctx1 <> ctxTypesTable ctx2 173 | , ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2 174 | , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2 175 | , ctxForeignSrcLang = ctxForeignSrcLang ctx1 <|> ctxForeignSrcLang ctx2 176 | , ctxEnableCpp = ctxEnableCpp ctx1 || ctxEnableCpp ctx2 177 | , ctxRawObjectCompile = ctxRawObjectCompile ctx1 <|> ctxRawObjectCompile ctx2 178 | } 179 | #endif 180 | 181 | instance Monoid Context where 182 | mempty = Context 183 | { ctxTypesTable = mempty 184 | , ctxAntiQuoters = mempty 185 | , ctxOutput = Nothing 186 | , ctxForeignSrcLang = Nothing 187 | , ctxEnableCpp = False 188 | , ctxRawObjectCompile = Nothing 189 | } 190 | 191 | #if !MIN_VERSION_base(4,11,0) 192 | mappend ctx2 ctx1 = Context 193 | { ctxTypesTable = ctxTypesTable ctx1 <> ctxTypesTable ctx2 194 | , ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2 195 | , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2 196 | , ctxForeignSrcLang = ctxForeignSrcLang ctx1 <|> ctxForeignSrcLang ctx2 197 | , ctxEnableCpp = ctxEnableCpp ctx1 || ctxEnableCpp ctx2 198 | , ctxRawObjectCompile = ctxRawObjectCompile ctx1 <|> ctxRawObjectCompile ctx2 199 | } 200 | #endif 201 | 202 | -- | Context useful to work with vanilla C. Used by default. 203 | -- 204 | -- 'ctxTypesTable': converts C basic types to their counterparts in 205 | -- "Foreign.C.Types". 206 | -- 207 | -- No 'ctxAntiQuoters'. 208 | baseCtx :: Context 209 | baseCtx = mempty 210 | { ctxTypesTable = baseTypesTable 211 | } 212 | 213 | baseTypesTable :: Map.Map C.TypeSpecifier TH.TypeQ 214 | baseTypesTable = Map.fromList 215 | [ (C.Void, [t| () |]) 216 | -- Types from Foreign.C.Types in the order in which they are presented there, 217 | -- along with its documentation's section headers. 218 | -- 219 | -- Integral types 220 | , (C.Bool, [t| CBool |]) 221 | , (C.Char Nothing, [t| CChar |]) 222 | , (C.Char (Just C.Signed), [t| CSChar |]) 223 | , (C.Char (Just C.Unsigned), [t| CUChar |]) 224 | , (C.Short C.Signed, [t| CShort |]) 225 | , (C.Short C.Unsigned, [t| CUShort |]) 226 | , (C.Int C.Signed, [t| CInt |]) 227 | , (C.Int C.Unsigned, [t| CUInt |]) 228 | , (C.Long C.Signed, [t| CLong |]) 229 | , (C.Long C.Unsigned, [t| CULong |]) 230 | , (C.TypeName "ptrdiff_t", [t| CPtrdiff |]) 231 | , (C.TypeName "size_t", [t| CSize |]) 232 | , (C.TypeName "wchar_t", [t| CWchar |]) 233 | , (C.TypeName "sig_atomic_t", [t| CSigAtomic |]) 234 | , (C.LLong C.Signed, [t| CLLong |]) 235 | , (C.LLong C.Unsigned, [t| CULLong |]) 236 | , (C.TypeName "intptr_t", [t| CIntPtr |]) 237 | , (C.TypeName "uintptr_t", [t| CUIntPtr |]) 238 | , (C.TypeName "intmax_t", [t| CIntMax |]) 239 | , (C.TypeName "uintmax_t", [t| CUIntMax |]) 240 | -- Numeric types 241 | , (C.TypeName "clock_t", [t| CClock |]) 242 | , (C.TypeName "time_t", [t| CTime |]) 243 | , (C.TypeName "useconds_t", [t| CUSeconds |]) 244 | , (C.TypeName "suseconds_t", [t| CSUSeconds |]) 245 | -- Floating types 246 | , (C.Float, [t| CFloat |]) 247 | , (C.Double, [t| CDouble |]) 248 | -- Other types 249 | , (C.TypeName "FILE", [t| CFile |]) 250 | , (C.TypeName "fpos_t", [t| CFpos |]) 251 | , (C.TypeName "jmp_buf", [t| CJmpBuf |]) 252 | -- Types from stdint.h that can be statically mapped to their Haskell 253 | -- equivalents. Excludes int_fast*_t and int_least*_t and the corresponding 254 | -- unsigned types, since their sizes are platform-specific. 255 | , (C.TypeName "int8_t", [t| Int8 |]) 256 | , (C.TypeName "int16_t", [t| Int16 |]) 257 | , (C.TypeName "int32_t", [t| Int32 |]) 258 | , (C.TypeName "int64_t", [t| Int64 |]) 259 | , (C.TypeName "uint8_t", [t| Word8 |]) 260 | , (C.TypeName "uint16_t", [t| Word16 |]) 261 | , (C.TypeName "uint32_t", [t| Word32 |]) 262 | , (C.TypeName "uint64_t", [t| Word64 |]) 263 | ] 264 | 265 | -- | An alias for 'Ptr'. 266 | type CArray = Ptr 267 | 268 | ------------------------------------------------------------------------ 269 | -- Type conversion 270 | 271 | -- | Given a 'Context', it uses its 'ctxTypesTable' to convert 272 | -- arbitrary C types. 273 | convertType 274 | :: Purity 275 | -> TypesTable 276 | -> C.Type C.CIdentifier 277 | -> TH.Q (Maybe TH.Type) 278 | convertType purity cTypes = runMaybeT . go 279 | where 280 | goDecl = go . C.parameterDeclarationType 281 | 282 | go :: C.Type C.CIdentifier -> MaybeT TH.Q TH.Type 283 | go cTy = do 284 | case cTy of 285 | C.TypeSpecifier _specs (C.Template ident' cTys) -> do 286 | -- let symbol = TH.LitT (TH.StrTyLit (C.unCIdentifier ident')) 287 | symbol <- case Map.lookup (C.TypeName ident') cTypes of 288 | Nothing -> mzero 289 | Just ty -> return ty 290 | hsTy <- forM cTys $ \cTys' -> go (C.TypeSpecifier undefined cTys') 291 | case hsTy of 292 | [] -> fail $ "Can not find template parameters." 293 | (a:[]) -> 294 | lift $ TH.AppT <$> symbol <*> return a 295 | other -> 296 | let tuple = foldl (\tuple arg -> TH.AppT tuple arg) (TH.PromotedTupleT (length other)) other 297 | in lift $ TH.AppT <$> symbol <*> return tuple 298 | C.TypeSpecifier _specs (C.TemplateConst num) -> do 299 | let n = (TH.LitT (TH.NumTyLit (read num))) 300 | lift [t| $(return n) |] 301 | C.TypeSpecifier _specs (C.TemplatePointer cSpec) -> do 302 | case Map.lookup cSpec cTypes of 303 | Nothing -> mzero 304 | Just ty -> lift [t| Ptr $(ty) |] 305 | C.TypeSpecifier _specs cSpec -> 306 | case Map.lookup cSpec cTypes of 307 | Nothing -> mzero 308 | Just ty -> lift ty 309 | C.Ptr _quals (C.Proto retType pars) -> do 310 | hsRetType <- go retType 311 | hsPars <- mapM goDecl pars 312 | lift [t| FunPtr $(buildArr hsPars hsRetType) |] 313 | C.Ptr _quals cTy' -> do 314 | hsTy <- go cTy' 315 | lift [t| Ptr $(return hsTy) |] 316 | C.Array _mbSize cTy' -> do 317 | hsTy <- go cTy' 318 | lift [t| CArray $(return hsTy) |] 319 | C.Proto _retType _pars -> do 320 | -- We cannot convert standalone prototypes 321 | mzero 322 | 323 | buildArr [] hsRetType = 324 | case purity of 325 | Pure -> [t| $(return hsRetType) |] 326 | IO -> [t| IO $(return hsRetType) |] 327 | buildArr (hsPar : hsPars) hsRetType = 328 | [t| $(return hsPar) -> $(buildArr hsPars hsRetType) |] 329 | 330 | typeNamesFromTypesTable :: TypesTable -> C.TypeNames 331 | typeNamesFromTypesTable cTypes = HashSet.fromList 332 | [ id' | C.TypeName id' <- Map.keys cTypes ] 333 | 334 | ------------------------------------------------------------------------ 335 | -- Useful contexts 336 | 337 | getHsVariable :: String -> HaskellIdentifier -> TH.ExpQ 338 | getHsVariable err s = do 339 | mbHsName <- TH.lookupValueName $ unHaskellIdentifier s 340 | case mbHsName of 341 | Nothing -> fail $ "Cannot capture Haskell variable " ++ unHaskellIdentifier s ++ 342 | ", because it's not in scope. (" ++ err ++ ")" 343 | Just hsName -> TH.varE hsName 344 | 345 | convertType_ :: String -> Purity -> TypesTable -> C.Type C.CIdentifier -> TH.Q TH.Type 346 | convertType_ err purity cTypes cTy = do 347 | mbHsType <- convertType purity cTypes cTy 348 | case mbHsType of 349 | Nothing -> fail $ "Cannot convert C type (" ++ err ++ ")" 350 | Just hsType -> return hsType 351 | 352 | -- | This 'Context' adds support for 'ForeignPtr' arguments. It adds a unique 353 | -- marshaller called @fptr-ptr@. For example, @$fptr-ptr:(int *x)@ extracts the 354 | -- bare C pointer out of foreign pointer @x@. 355 | fptrCtx :: Context 356 | fptrCtx = mempty 357 | { ctxAntiQuoters = Map.fromList [("fptr-ptr", SomeAntiQuoter fptrAntiQuoter)] 358 | } 359 | 360 | fptrAntiQuoter :: AntiQuoter HaskellIdentifier 361 | fptrAntiQuoter = AntiQuoter 362 | { aqParser = cDeclAqParser 363 | , aqMarshaller = \purity cTypes cTy cId -> do 364 | hsTy <- convertType_ "fptrCtx" purity cTypes cTy 365 | hsExp <- getHsVariable "fptrCtx" cId 366 | hsExp' <- [| withForeignPtr (coerce $(return hsExp)) |] 367 | return (hsTy, hsExp') 368 | } 369 | 370 | -- | This 'Context' includes a 'AntiQuoter' that removes the need for 371 | -- explicitely creating 'FunPtr's, named @"fun"@ along with one which 372 | -- allocates new memory which must be manually freed named @"fun-alloc"@. 373 | -- 374 | -- For example, we can capture function @f@ of type @CInt -> CInt -> IO 375 | -- CInt@ in C code using @$fun:(int (*f)(int, int))@. 376 | -- 377 | -- When used in a @pure@ embedding, the Haskell function will have to be 378 | -- pure too. Continuing the example above we'll have @CInt -> CInt -> 379 | -- IO CInt@. 380 | -- 381 | -- Does not include the 'baseCtx', since most of the time it's going to 382 | -- be included as part of larger contexts. 383 | -- 384 | -- IMPORTANT: When using the @fun@ anti quoter, one must be aware that 385 | -- the function pointer which is automatically generated is freed when 386 | -- the code contained in the block containing the anti quoter exits. 387 | -- Thus, if you need the function pointer to be longer-lived, you must 388 | -- allocate it and free it manually using 'freeHaskellFunPtr'. 389 | -- We provide utilities to easily 390 | -- allocate them (see 'Language.C.Inline.mkFunPtr'). 391 | -- 392 | -- IMPORTANT: When using the @fun-alloc@ anti quoter, one must free the allocated 393 | -- function pointer. The GHC runtime provides a function to do this, 394 | -- 'hs_free_fun_ptr' available in the 'HsFFI.h' header. 395 | 396 | funCtx :: Context 397 | funCtx = mempty 398 | { ctxAntiQuoters = Map.fromList [("fun", SomeAntiQuoter funPtrAntiQuoter) 399 | ,("fun-alloc", SomeAntiQuoter funAllocPtrAntiQuoter)] 400 | } 401 | 402 | funPtrAntiQuoter :: AntiQuoter HaskellIdentifier 403 | funPtrAntiQuoter = AntiQuoter 404 | { aqParser = cDeclAqParser 405 | , aqMarshaller = \purity cTypes cTy cId -> do 406 | hsTy <- convertType_ "funCtx" purity cTypes cTy 407 | hsExp <- getHsVariable "funCtx" cId 408 | case hsTy of 409 | TH.AppT (TH.ConT n) hsTy' | n == ''FunPtr -> do 410 | hsExp' <- [| \cont -> do 411 | funPtr <- $(mkFunPtr (return hsTy')) $(return hsExp) 412 | x <- cont funPtr 413 | freeHaskellFunPtr funPtr 414 | return x 415 | |] 416 | return (hsTy, hsExp') 417 | _ -> fail "The `fun' marshaller captures function pointers only" 418 | } 419 | 420 | funAllocPtrAntiQuoter :: AntiQuoter HaskellIdentifier 421 | funAllocPtrAntiQuoter = AntiQuoter 422 | { aqParser = cDeclAqParser 423 | , aqMarshaller = \purity cTypes cTy cId -> do 424 | hsTy <- convertType_ "funCtx" purity cTypes cTy 425 | hsExp <- getHsVariable "funCtx" cId 426 | case hsTy of 427 | TH.AppT (TH.ConT n) hsTy' | n == ''FunPtr -> do 428 | hsExp' <- [| \cont -> do 429 | funPtr <- $(mkFunPtr (return hsTy')) $(return hsExp) 430 | cont funPtr 431 | |] 432 | return (hsTy, hsExp') 433 | _ -> fail "The `fun-alloc' marshaller captures function pointers only" 434 | } 435 | 436 | -- | This 'Context' includes two 'AntiQuoter's that allow to easily use 437 | -- Haskell vectors in C. 438 | -- 439 | -- Specifically, the @vec-len@ and @vec-ptr@ will get the length and the 440 | -- pointer underlying mutable ('V.IOVector') and immutable ('V.Vector') 441 | -- storable vectors. 442 | -- 443 | -- Note that if you use 'vecCtx' to manipulate immutable vectors you 444 | -- must make sure that the vector is not modified in the C code. 445 | -- 446 | -- To use @vec-len@, simply write @$vec-len:x@, where @x@ is something 447 | -- of type @'V.IOVector' a@ or @'V.Vector' a@, for some @a@. To use 448 | -- @vec-ptr@ you need to specify the type of the pointer, 449 | -- e.g. @$vec-len:(int *x)@ will work if @x@ has type @'V.IOVector' 450 | -- 'CInt'@. 451 | vecCtx :: Context 452 | vecCtx = mempty 453 | { ctxAntiQuoters = Map.fromList 454 | [ ("vec-ptr", SomeAntiQuoter vecPtrAntiQuoter) 455 | , ("vec-len", SomeAntiQuoter vecLenAntiQuoter) 456 | ] 457 | } 458 | 459 | -- | Type class used to implement the anti-quoters in 'vecCtx'. 460 | class VecCtx a where 461 | type VecCtxScalar a :: * 462 | 463 | vecCtxLength :: a -> Int 464 | vecCtxUnsafeWith :: a -> (Ptr (VecCtxScalar a) -> IO b) -> IO b 465 | 466 | instance Storable a => VecCtx (V.Vector a) where 467 | type VecCtxScalar (V.Vector a) = a 468 | 469 | vecCtxLength = V.length 470 | vecCtxUnsafeWith = V.unsafeWith 471 | 472 | instance Storable a => VecCtx (VM.IOVector a) where 473 | type VecCtxScalar (VM.IOVector a) = a 474 | 475 | vecCtxLength = VM.length 476 | vecCtxUnsafeWith = VM.unsafeWith 477 | 478 | vecPtrAntiQuoter :: AntiQuoter HaskellIdentifier 479 | vecPtrAntiQuoter = AntiQuoter 480 | { aqParser = cDeclAqParser 481 | , aqMarshaller = \purity cTypes cTy cId -> do 482 | hsTy <- convertType_ "vecCtx" purity cTypes cTy 483 | hsExp <- getHsVariable "vecCtx" cId 484 | hsExp' <- [| vecCtxUnsafeWith $(return hsExp) |] 485 | return (hsTy, hsExp') 486 | } 487 | 488 | vecLenAntiQuoter :: AntiQuoter HaskellIdentifier 489 | vecLenAntiQuoter = AntiQuoter 490 | { aqParser = do 491 | hId <- C.parseIdentifier 492 | useCpp <- C.parseEnableCpp 493 | let cId = mangleHaskellIdentifier useCpp hId 494 | return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId) 495 | , aqMarshaller = \_purity _cTypes cTy cId -> do 496 | case cTy of 497 | C.TypeSpecifier _ (C.Long C.Signed) -> do 498 | hsExp <- getHsVariable "vecCtx" cId 499 | hsExp' <- [| fromIntegral (vecCtxLength $(return hsExp)) |] 500 | hsTy <- [t| CLong |] 501 | hsExp'' <- [| \cont -> cont $(return hsExp') |] 502 | return (hsTy, hsExp'') 503 | _ -> do 504 | fail "impossible: got type different from `long' (vecCtx)" 505 | } 506 | 507 | 508 | -- | 'bsCtx' serves exactly the same purpose as 'vecCtx', but only for 509 | -- 'BS.ByteString'. @vec-ptr@ becomes @bs-ptr@, and @vec-len@ becomes 510 | -- @bs-len@. You don't need to specify the type of the pointer in 511 | -- @bs-ptr@, it will always be @char*@. 512 | -- 513 | -- Moreover, @bs-cstr@ works as @bs-ptr@ but it provides a null-terminated 514 | -- copy of the given 'BS.ByteString'. 515 | bsCtx :: Context 516 | bsCtx = mempty 517 | { ctxAntiQuoters = Map.fromList 518 | [ ("bs-ptr", SomeAntiQuoter bsPtrAntiQuoter) 519 | , ("bs-len", SomeAntiQuoter bsLenAntiQuoter) 520 | , ("bs-cstr", SomeAntiQuoter bsCStrAntiQuoter) 521 | ] 522 | } 523 | 524 | bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier 525 | bsPtrAntiQuoter = AntiQuoter 526 | { aqParser = do 527 | hId <- C.parseIdentifier 528 | useCpp <- C.parseEnableCpp 529 | let cId = mangleHaskellIdentifier useCpp hId 530 | return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId) 531 | , aqMarshaller = \_purity _cTypes cTy cId -> do 532 | case cTy of 533 | C.Ptr _ (C.TypeSpecifier _ (C.Char Nothing)) -> do 534 | hsTy <- [t| Ptr CChar |] 535 | hsExp <- getHsVariable "bsCtx" cId 536 | hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont ptr |] 537 | return (hsTy, hsExp') 538 | _ -> 539 | fail "impossible: got type different from `char *' (bsCtx)" 540 | } 541 | 542 | bsLenAntiQuoter :: AntiQuoter HaskellIdentifier 543 | bsLenAntiQuoter = AntiQuoter 544 | { aqParser = do 545 | hId <- C.parseIdentifier 546 | useCpp <- C.parseEnableCpp 547 | let cId = mangleHaskellIdentifier useCpp hId 548 | return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId) 549 | , aqMarshaller = \_purity _cTypes cTy cId -> do 550 | case cTy of 551 | C.TypeSpecifier _ (C.Long C.Signed) -> do 552 | hsExp <- getHsVariable "bsCtx" cId 553 | hsExp' <- [| fromIntegral (BS.length $(return hsExp)) |] 554 | hsTy <- [t| CLong |] 555 | hsExp'' <- [| \cont -> cont $(return hsExp') |] 556 | return (hsTy, hsExp'') 557 | _ -> do 558 | fail "impossible: got type different from `long' (bsCtx)" 559 | } 560 | 561 | bsCStrAntiQuoter :: AntiQuoter HaskellIdentifier 562 | bsCStrAntiQuoter = AntiQuoter 563 | { aqParser = do 564 | hId <- C.parseIdentifier 565 | useCpp <- C.parseEnableCpp 566 | let cId = mangleHaskellIdentifier useCpp hId 567 | return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId) 568 | , aqMarshaller = \_purity _cTypes cTy cId -> do 569 | case cTy of 570 | C.Ptr _ (C.TypeSpecifier _ (C.Char Nothing)) -> do 571 | hsTy <- [t| Ptr CChar |] 572 | hsExp <- getHsVariable "bsCtx" cId 573 | hsExp' <- [| \cont -> BS.useAsCString $(return hsExp) $ \ptr -> cont ptr |] 574 | return (hsTy, hsExp') 575 | _ -> 576 | fail "impossible: got type different from `char *' (bsCtx)" 577 | } 578 | 579 | 580 | -- Utils 581 | ------------------------------------------------------------------------ 582 | 583 | cDeclAqParser 584 | :: C.CParser HaskellIdentifier m 585 | => m (C.CIdentifier, C.Type C.CIdentifier, HaskellIdentifier) 586 | cDeclAqParser = do 587 | cTy <- Parser.parens C.parseParameterDeclaration 588 | useCpp <- C.parseEnableCpp 589 | case C.parameterDeclarationId cTy of 590 | Nothing -> fail "Every captured function must be named (funCtx)" 591 | Just hId -> do 592 | let cId = mangleHaskellIdentifier useCpp hId 593 | cTy' <- deHaskellifyCType $ C.parameterDeclarationType cTy 594 | return (cId, cTy', hId) 595 | 596 | deHaskellifyCType 597 | :: C.CParser HaskellIdentifier m 598 | => C.Type HaskellIdentifier -> m (C.Type C.CIdentifier) 599 | deHaskellifyCType = traverse $ \hId -> do 600 | useCpp <- C.parseEnableCpp 601 | case C.cIdentifierFromString useCpp (unHaskellIdentifier hId) of 602 | Left err -> fail $ "Illegal Haskell identifier " ++ unHaskellIdentifier hId ++ 603 | " in C type:\n" ++ err 604 | Right x -> return x 605 | -------------------------------------------------------------------------------- /inline-c/src/Language/C/Inline/FunPtr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Language.C.Inline.FunPtr 6 | ( mkFunPtr 7 | , mkFunPtrFromName 8 | , peekFunPtr 9 | , uniqueFfiImportName 10 | ) where 11 | 12 | import Data.Maybe (isJust) 13 | import Foreign.Ptr (FunPtr) 14 | import System.Environment (lookupEnv) 15 | import qualified Language.Haskell.TH as TH 16 | import qualified Language.Haskell.TH.Syntax as TH 17 | 18 | ------------------------------------------------------------------------ 19 | -- FFI wrappers 20 | 21 | -- | @$('mkFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |] @ generates a foreign import 22 | -- wrapper of type 23 | -- 24 | -- @ 25 | -- ('CDouble' -> 'IO' 'CDouble') -> 'IO' ('FunPtr' ('CDouble' -> 'IO' 'CDouble')) 26 | -- @ 27 | -- 28 | -- And invokes it. 29 | mkFunPtr :: TH.TypeQ -> TH.ExpQ 30 | mkFunPtr hsTy = do 31 | ffiImportName <- uniqueFfiImportName 32 | -- See note [ghcide-support] 33 | usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__" 34 | if usingGhcide 35 | then do 36 | [e|error "inline-c: A 'usingGhcide' mkFunPtr stub was evaluated -- this should not happen" :: $(hsTy) -> IO (FunPtr $(hsTy)) |] 37 | else do -- Actual foreign function call generation. 38 | dec <- TH.forImpD TH.CCall TH.Safe "wrapper" ffiImportName [t| $(hsTy) -> IO (FunPtr $(hsTy)) |] 39 | TH.addTopDecls [dec] 40 | TH.varE ffiImportName 41 | 42 | -- | @$('mkFunPtrFromName' 'foo)@, if @foo :: 'CDouble' -> 'IO' 43 | -- 'CDouble'@, splices in an expression of type @'IO' ('FunPtr' 44 | -- ('CDouble' -> 'IO' 'CDouble'))@. 45 | mkFunPtrFromName :: TH.Name -> TH.ExpQ 46 | mkFunPtrFromName name = do 47 | i <- TH.reify name 48 | case i of 49 | #if MIN_VERSION_template_haskell(2,11,0) 50 | TH.VarI _ ty _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |] 51 | #else 52 | TH.VarI _ ty _ _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |] 53 | #endif 54 | _ -> fail "mkFunPtrFromName: expecting a variable as argument." 55 | 56 | -- | @$('peekFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |])@ generates a foreign import 57 | -- dynamic of type 58 | -- 59 | -- @ 60 | -- 'FunPtr' ('CDouble' -> 'IO' 'CDouble') -> ('CDouble' -> 'IO' 'CDouble') 61 | -- @ 62 | -- 63 | -- And invokes it. 64 | peekFunPtr :: TH.TypeQ -> TH.ExpQ 65 | peekFunPtr hsTy = do 66 | ffiImportName <- uniqueFfiImportName 67 | usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__" 68 | -- See note [ghcide-support] 69 | if usingGhcide 70 | then do 71 | [e|error "inline-c: A 'usingGhcide' peekFunPtr stub was evaluated -- this should not happen" :: FunPtr $(hsTy) -> $(hsTy) |] 72 | else do -- Actual foreign function call generation. 73 | dec <- TH.forImpD TH.CCall TH.Safe "dynamic" ffiImportName [t| FunPtr $(hsTy) -> $(hsTy) |] 74 | TH.addTopDecls [dec] 75 | TH.varE ffiImportName 76 | 77 | -- TODO absurdly, I need to 'newName' twice for things to work. I found 78 | -- this hack in language-c-inline. Why is this? 79 | uniqueFfiImportName :: TH.Q TH.Name 80 | uniqueFfiImportName = TH.newName . show =<< TH.newName "inline_c_ffi" 81 | -------------------------------------------------------------------------------- /inline-c/src/Language/C/Inline/HaskellIdentifier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | module Language.C.Inline.HaskellIdentifier 8 | ( HaskellIdentifier 9 | , unHaskellIdentifier 10 | , haskellIdentifierFromString 11 | , haskellCParserContext 12 | , parseHaskellIdentifier 13 | , mangleHaskellIdentifier 14 | 15 | -- * for testing 16 | , haskellReservedWords 17 | ) where 18 | 19 | import Control.Applicative ((<|>)) 20 | import Control.Monad (when, msum, void) 21 | import Data.Char (ord) 22 | import qualified Data.HashSet as HashSet 23 | import Data.Hashable (Hashable) 24 | import Data.List (intercalate, partition, intersperse) 25 | import Data.Monoid ((<>)) 26 | import Data.String (IsString(..)) 27 | import Data.Typeable (Typeable) 28 | import Numeric (showHex) 29 | import Text.Parser.Char (upper, lower, digit, char) 30 | import Text.Parser.Combinators (many, eof, try, unexpected, ()) 31 | import Text.Parser.Token (IdentifierStyle(..), highlight, TokenParsing) 32 | import qualified Text.Parser.Token.Highlight as Highlight 33 | import qualified Prettyprinter as PP 34 | 35 | import qualified Language.C.Types.Parse as C 36 | 37 | #if __GLASGOW_HASKELL__ < 710 38 | import Control.Applicative ((<*), (<$>), (<*>)) 39 | #endif 40 | 41 | -- | A possibly qualified Haskell identifier. 42 | newtype HaskellIdentifier = HaskellIdentifier {unHaskellIdentifier :: String} 43 | deriving (Typeable, Eq, Ord, Show, Hashable) 44 | 45 | instance IsString HaskellIdentifier where 46 | fromString s = 47 | case haskellIdentifierFromString True s of 48 | Left err -> error $ "HaskellIdentifier fromString: invalid string " ++ s ++ ":\n" ++ err 49 | Right x -> x 50 | 51 | instance PP.Pretty HaskellIdentifier where 52 | pretty = fromString . unHaskellIdentifier 53 | 54 | haskellIdentifierFromString :: Bool -> String -> Either String HaskellIdentifier 55 | haskellIdentifierFromString useCpp s = 56 | case C.runCParser cpc "haskellIdentifierFromString" s (parseHaskellIdentifier <* eof) of 57 | Left err -> Left $ show err 58 | Right x -> Right x 59 | where 60 | cpc = haskellCParserContext useCpp HashSet.empty 61 | 62 | haskellCParserContext :: Bool -> C.TypeNames -> C.CParserContext HaskellIdentifier 63 | haskellCParserContext useCpp typeNames = C.CParserContext 64 | { C.cpcTypeNames = typeNames 65 | , C.cpcParseIdent = parseHaskellIdentifier 66 | , C.cpcIdentName = "Haskell identifier" 67 | , C.cpcIdentToString = unHaskellIdentifier 68 | , C.cpcEnableCpp = useCpp 69 | } 70 | 71 | -- | See 72 | -- . 73 | haskellIdentStyle :: C.CParser i m => IdentifierStyle m 74 | haskellIdentStyle = IdentifierStyle 75 | { _styleName = "Haskell identifier" 76 | , _styleStart = small 77 | , _styleLetter = small <|> large <|> digit <|> char '\'' 78 | , _styleReserved = haskellReservedWords 79 | , _styleHighlight = Highlight.Identifier 80 | , _styleReservedHighlight = Highlight.ReservedIdentifier 81 | } 82 | where 83 | small = lower <|> char '_' 84 | large = upper 85 | 86 | -- We disallow both Haskell reserved words and C reserved words. 87 | haskellReservedWords :: HashSet.HashSet String 88 | haskellReservedWords = C.cReservedWords <> HashSet.fromList 89 | [ "case", "class", "data", "default", "deriving", "do", "else" 90 | , "foreign", "if", "import", "in", "infix", "infixl" 91 | , "infixr", "instance", "let", "module", "newtype", "of" 92 | , "then", "type", "where" 93 | ] 94 | 95 | -- | See 96 | -- . 97 | parseHaskellIdentifier :: forall i m. C.CParser i m => m HaskellIdentifier 98 | parseHaskellIdentifier = do 99 | segments <- go 100 | return $ HaskellIdentifier $ intercalate "." segments 101 | where 102 | small = lower <|> char '_' 103 | large = upper 104 | 105 | conid :: m String 106 | conid = try $ highlight Highlight.Identifier $ 107 | ((:) <$> large <*> many (small <|> large <|> digit <|> char '\'')) "Haskell constructor" 108 | 109 | varid :: m String 110 | varid = identNoLex haskellIdentStyle 111 | 112 | go = msum 113 | [ do con <- conid 114 | msum 115 | [ do void $ char '.' 116 | (con :) <$> go 117 | , return [con] 118 | ] 119 | , do var <- varid 120 | return [var] 121 | ] 122 | 123 | -- | Mangles an 'HaskellIdentifier' to produce a valid 'C.CIdentifier' 124 | -- which still sort of resembles the 'HaskellIdentifier'. 125 | mangleHaskellIdentifier :: Bool -> HaskellIdentifier -> C.CIdentifier 126 | mangleHaskellIdentifier useCpp (HaskellIdentifier hs) = 127 | -- The leading underscore if we have no valid chars is because then 128 | -- we'd have an identifier starting with numbers. 129 | let cs = (if null valid then "_" else "") ++ 130 | valid ++ 131 | (if null mangled || null valid then "" else "_") ++ 132 | mangled 133 | in case C.cIdentifierFromString useCpp cs of 134 | Left err -> error $ "mangleHaskellIdentifier: produced bad C identifier\n" ++ err 135 | Right x -> x 136 | where 137 | (valid, invalid) = partition (`elem` C.cIdentLetter) hs 138 | 139 | mangled = concat $ intersperse "_" $ map (`showHex` "") $ map ord invalid 140 | 141 | -- Utils 142 | ------------------------------------------------------------------------ 143 | 144 | identNoLex :: (TokenParsing m, Monad m, IsString s) => IdentifierStyle m -> m s 145 | identNoLex s = fmap fromString $ try $ do 146 | name <- highlight (_styleHighlight s) 147 | ((:) <$> _styleStart s <*> many (_styleLetter s) _styleName s) 148 | when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name 149 | return name 150 | 151 | -------------------------------------------------------------------------------- /inline-c/src/Language/C/Inline/Interruptible.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | @interruptible@ variants of the "Language.C.Inline" quasi-quoters, to call 4 | -- interruptible C code. See 5 | -- for more information. 6 | -- 7 | -- This module is intended to be imported qualified: 8 | -- 9 | -- @ 10 | -- import qualified "Language.C.Inline.Interruptible" as CI 11 | -- @ 12 | 13 | module Language.C.Inline.Interruptible 14 | ( exp 15 | , pure 16 | , block 17 | ) where 18 | 19 | #if __GLASGOW_HASKELL__ < 710 20 | import Prelude hiding (exp) 21 | #else 22 | import Prelude hiding (exp, pure) 23 | #endif 24 | 25 | import qualified Language.Haskell.TH.Quote as TH 26 | import qualified Language.Haskell.TH.Syntax as TH 27 | 28 | import Language.C.Inline.Context 29 | import Language.C.Inline.Internal 30 | 31 | -- | C expressions. 32 | exp :: TH.QuasiQuoter 33 | exp = genericQuote IO $ inlineExp TH.Interruptible 34 | 35 | -- | Variant of 'exp', for use with expressions known to have no side effects. 36 | -- 37 | -- __BEWARE__: Use this function with caution, only when you know what you are 38 | -- doing. If an expression does in fact have side-effects, then indiscriminate 39 | -- use of 'pure' may endanger referential transparency, and in principle even 40 | -- type safety. Also note that the function may run more than once and that it 41 | -- may run in parallel with itself, given that 42 | -- 'System.IO.Unsafe.unsafeDupablePerformIO' is used to call the provided C 43 | -- code [to ensure good performance using the threaded 44 | -- runtime](https://github.com/fpco/inline-c/issues/115). Please refer to the 45 | -- documentation for 'System.IO.Unsafe.unsafeDupablePerformIO' for more 46 | -- details. 47 | pure :: TH.QuasiQuoter 48 | pure = genericQuote Pure $ inlineExp TH.Interruptible 49 | 50 | -- | C code blocks (i.e. statements). 51 | block :: TH.QuasiQuoter 52 | block = genericQuote IO $ inlineItems TH.Interruptible False Nothing 53 | -------------------------------------------------------------------------------- /inline-c/src/Language/C/Inline/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | @unsafe@ variants of the "Language.C.Inline" quasi-quoters, to call the C code 4 | -- unsafely in the sense of 5 | -- . 6 | -- In GHC, unsafe foreign calls are faster than safe foreign calls, but the user 7 | -- must guarantee the control flow will never enter Haskell code (via a callback 8 | -- or otherwise) before the call is done. 9 | -- 10 | -- This module is intended to be imported qualified: 11 | -- 12 | -- @ 13 | -- import qualified "Language.C.Inline.Unsafe" as CU 14 | -- @ 15 | 16 | module Language.C.Inline.Unsafe 17 | ( exp 18 | , pure 19 | , block 20 | ) where 21 | 22 | #if __GLASGOW_HASKELL__ < 710 23 | import Prelude hiding (exp) 24 | #else 25 | import Prelude hiding (exp, pure) 26 | #endif 27 | 28 | import qualified Language.Haskell.TH.Quote as TH 29 | import qualified Language.Haskell.TH.Syntax as TH 30 | 31 | import Language.C.Inline.Context 32 | import Language.C.Inline.Internal 33 | 34 | -- | C expressions. 35 | exp :: TH.QuasiQuoter 36 | exp = genericQuote IO $ inlineExp TH.Unsafe 37 | 38 | -- | Variant of 'exp', for use with expressions known to have no side effects. 39 | -- 40 | -- __BEWARE__: Use this function with caution, only when you know what you are 41 | -- doing. If an expression does in fact have side-effects, then indiscriminate 42 | -- use of 'pure' may endanger referential transparency, and in principle even 43 | -- type safety. Also note that the function may run more than once and that it 44 | -- may run in parallel with itself, given that 45 | -- 'System.IO.Unsafe.unsafeDupablePerformIO' is used to call the provided C 46 | -- code [to ensure good performance using the threaded 47 | -- runtime](https://github.com/fpco/inline-c/issues/115). Please refer to the 48 | -- documentation for 'System.IO.Unsafe.unsafeDupablePerformIO' for more 49 | -- details. 50 | pure :: TH.QuasiQuoter 51 | pure = genericQuote Pure $ inlineExp TH.Unsafe 52 | 53 | -- | C code blocks (i.e. statements). 54 | block :: TH.QuasiQuoter 55 | block = genericQuote IO $ inlineItems TH.Unsafe False Nothing 56 | -------------------------------------------------------------------------------- /inline-c/src/Language/C/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveFoldable #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE DeriveTraversable #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TupleSections #-} 14 | 15 | -- | Views of C datatypes. While "Language.C.Types.Parse" defines datatypes for 16 | -- representing the concrete syntax tree of C types, this module provides 17 | -- friendlier views of C types, by turning them into a data type matching more 18 | -- closely how we read and think about types, both in Haskell and in C. To 19 | -- appreciate the difference, look at the difference between 20 | -- 'P.ParameterDeclaration' and 'ParameterDeclaration'. 21 | -- 22 | -- As a bonus, routines are provided for describing types in natural language 23 | -- (English) -- see 'describeParameterDeclaration' and 'describeType'. 24 | 25 | module Language.C.Types 26 | ( -- * Types 27 | P.CIdentifier 28 | , P.unCIdentifier 29 | , P.cIdentifierFromString 30 | , P.StorageClassSpecifier(..) 31 | , P.TypeQualifier(..) 32 | , P.FunctionSpecifier(..) 33 | , P.ArrayType(..) 34 | , Specifiers(..) 35 | , Type(..) 36 | , TypeSpecifier(..) 37 | , Sign(..) 38 | , ParameterDeclaration(..) 39 | 40 | -- * Parsing 41 | , P.TypeNames 42 | , P.CParser 43 | , P.CParserContext 44 | , P.cCParserContext 45 | , P.runCParser 46 | , P.quickCParser 47 | , P.quickCParser_ 48 | , parseParameterDeclaration 49 | , parseParameterList 50 | , parseIdentifier 51 | , parseEnableCpp 52 | , parseType 53 | 54 | -- * Convert to and from high-level views 55 | , UntangleErr(..) 56 | , untangleParameterDeclaration 57 | , tangleParameterDeclaration 58 | 59 | -- * To english 60 | , describeParameterDeclaration 61 | , describeType 62 | ) where 63 | 64 | import Control.Arrow (second) 65 | import Control.Monad (when, unless, forM_, forM) 66 | import Control.Monad.State (execState, modify) 67 | import Control.Monad.Reader (ask) 68 | import Data.List (partition, intersperse) 69 | import Data.Maybe (fromMaybe) 70 | import Data.String (fromString) 71 | import Data.Typeable (Typeable) 72 | import Prettyprinter ((<+>)) 73 | import qualified Prettyprinter as PP 74 | import qualified Prettyprinter.Render.String as PP 75 | 76 | #if MIN_VERSION_base(4,9,0) 77 | import Data.Semigroup (Semigroup, (<>)) 78 | #else 79 | import Data.Monoid ((<>)) 80 | #endif 81 | 82 | #if __GLASGOW_HASKELL__ < 710 83 | import Data.Foldable (Foldable) 84 | import Data.Functor ((<$>)) 85 | import Data.Monoid (Monoid(..)) 86 | import Data.Traversable (Traversable) 87 | #endif 88 | 89 | import qualified Language.C.Types.Parse as P 90 | 91 | ------------------------------------------------------------------------ 92 | -- Proper types 93 | 94 | data TypeSpecifier 95 | = Void 96 | | Bool 97 | | Char (Maybe Sign) 98 | | Short Sign 99 | | Int Sign 100 | | Long Sign 101 | | LLong Sign 102 | | Float 103 | | Double 104 | | LDouble 105 | | TypeName P.CIdentifier 106 | | Struct P.CIdentifier 107 | | Enum P.CIdentifier 108 | | Template P.CIdentifier [TypeSpecifier] 109 | | TemplateConst String 110 | | TemplatePointer TypeSpecifier 111 | deriving (Typeable, Show, Eq, Ord) 112 | 113 | data Specifiers = Specifiers 114 | { storageClassSpecifiers :: [P.StorageClassSpecifier] 115 | , typeQualifiers :: [P.TypeQualifier] 116 | , functionSpecifiers :: [P.FunctionSpecifier] 117 | } deriving (Typeable, Show, Eq) 118 | 119 | #if MIN_VERSION_base(4,9,0) 120 | instance Semigroup Specifiers where 121 | Specifiers x1 y1 z1 <> Specifiers x2 y2 z2 = 122 | Specifiers (x1 ++ x2) (y1 ++ y2) (z1 ++ z2) 123 | #endif 124 | 125 | instance Monoid Specifiers where 126 | mempty = Specifiers [] [] [] 127 | 128 | #if !MIN_VERSION_base(4,11,0) 129 | mappend (Specifiers x1 y1 z1) (Specifiers x2 y2 z2) = 130 | Specifiers (x1 ++ x2) (y1 ++ y2) (z1 ++ z2) 131 | #endif 132 | 133 | data Type i 134 | = TypeSpecifier Specifiers TypeSpecifier 135 | | Ptr [P.TypeQualifier] (Type i) 136 | | Array (P.ArrayType i) (Type i) 137 | | Proto (Type i) [ParameterDeclaration i] 138 | deriving (Typeable, Show, Eq, Functor, Foldable, Traversable) 139 | 140 | data Sign 141 | = Signed 142 | | Unsigned 143 | deriving (Typeable, Show, Eq, Ord) 144 | 145 | data ParameterDeclaration i = ParameterDeclaration 146 | { parameterDeclarationId :: Maybe i 147 | , parameterDeclarationType :: (Type i) 148 | } deriving (Typeable, Show, Eq, Functor, Foldable, Traversable) 149 | 150 | ------------------------------------------------------------------------ 151 | -- Conversion 152 | 153 | data UntangleErr 154 | = MultipleDataTypes [P.DeclarationSpecifier] 155 | | NoDataTypes [P.DeclarationSpecifier] 156 | | IllegalSpecifiers String [P.TypeSpecifier] 157 | deriving (Typeable, Show, Eq) 158 | 159 | failConversion :: UntangleErr -> Either UntangleErr a 160 | failConversion = Left 161 | 162 | untangleParameterDeclaration 163 | :: P.ParameterDeclaration i -> Either UntangleErr (ParameterDeclaration i) 164 | untangleParameterDeclaration P.ParameterDeclaration{..} = do 165 | (specs, tySpec) <- untangleDeclarationSpecifiers parameterDeclarationSpecifiers 166 | let baseTy = TypeSpecifier specs tySpec 167 | (mbS, ty) <- case parameterDeclarationDeclarator of 168 | P.IsDeclarator decltor -> do 169 | (s, ty) <- untangleDeclarator baseTy decltor 170 | return (Just s, ty) 171 | P.IsAbstractDeclarator decltor -> 172 | (Nothing, ) <$> untangleAbstractDeclarator baseTy decltor 173 | return $ ParameterDeclaration mbS ty 174 | 175 | untangleDeclarationSpecifiers 176 | :: [P.DeclarationSpecifier] -> Either UntangleErr (Specifiers, TypeSpecifier) 177 | untangleDeclarationSpecifiers declSpecs = do 178 | let (pStorage, pTySpecs, pTyQuals, pFunSpecs) = flip execState ([], [], [], []) $ do 179 | forM_ (reverse declSpecs) $ \declSpec -> case declSpec of 180 | P.StorageClassSpecifier x -> modify $ \(a, b, c, d) -> (x:a, b, c, d) 181 | P.TypeSpecifier x -> modify $ \(a, b, c, d) -> (a, x:b, c, d) 182 | P.TypeQualifier x -> modify $ \(a, b, c, d) -> (a, b, x:c, d) 183 | P.FunctionSpecifier x -> modify $ \(a, b, c, d) -> (a, b, c, x:d) 184 | tySpec <- type2type pTySpecs 185 | return (Specifiers pStorage pTyQuals pFunSpecs, tySpec) 186 | where 187 | type2type pTySpecs = do 188 | -- Split data type and specifiers 189 | let (dataTypes, specs) = 190 | partition (\x -> not (x `elem` [P.SIGNED, P.UNSIGNED, P.LONG, P.SHORT])) pTySpecs 191 | let illegalSpecifiers s = failConversion $ IllegalSpecifiers s specs 192 | -- Find out sign, if present 193 | mbSign0 <- case filter (== P.SIGNED) specs of 194 | [] -> return Nothing 195 | [_] -> return $ Just Signed 196 | _:_ -> illegalSpecifiers "conflicting/duplicate sign information" 197 | mbSign <- case (mbSign0, filter (== P.UNSIGNED) specs) of 198 | (Nothing, []) -> return Nothing 199 | (Nothing, [_]) -> return $ Just Unsigned 200 | (Just b, []) -> return $ Just b 201 | _ -> illegalSpecifiers "conflicting/duplicate sign information" 202 | let sign = fromMaybe Signed mbSign 203 | -- Find out length 204 | let longs = length $ filter (== P.LONG) specs 205 | let shorts = length $ filter (== P.SHORT) specs 206 | when (longs > 0 && shorts > 0) $ illegalSpecifiers "both long and short" 207 | -- Find out data type 208 | dataType <- case dataTypes of 209 | [x] -> return x 210 | [] | mbSign0 == Just Signed -> return P.INT -- "The Case of 'signed' not including 'signed int'" 211 | [] | mbSign == Just Unsigned -> return P.INT -- "The Case of 'unsigned' not including 'unsigned int'" 212 | [] | longs > 0 || shorts > 0 -> return P.INT 213 | [] -> failConversion $ NoDataTypes declSpecs 214 | _:_ -> failConversion $ MultipleDataTypes declSpecs 215 | -- Check if things are compatible with one another 216 | let checkNoSpecs = 217 | unless (null specs) $ illegalSpecifiers "expecting no specifiers" 218 | let checkNoLength = 219 | when (longs > 0 || shorts > 0) $ illegalSpecifiers "unexpected long/short" 220 | case dataType of 221 | P.Template s args -> do 222 | checkNoSpecs 223 | args' <- forM args type2type 224 | return $ Template s args' 225 | P.TemplateConst s -> do 226 | checkNoSpecs 227 | return $ TemplateConst s 228 | P.TemplatePointer s -> do 229 | checkNoSpecs 230 | s' <- type2type [s] 231 | return $ TemplatePointer s' 232 | P.TypeName s -> do 233 | checkNoSpecs 234 | return $ TypeName s 235 | P.Struct s -> do 236 | checkNoSpecs 237 | return $ Struct s 238 | P.Enum s -> do 239 | checkNoSpecs 240 | return $ Enum s 241 | P.VOID -> do 242 | checkNoSpecs 243 | return Void 244 | P.BOOL -> do 245 | checkNoLength 246 | return $ Bool 247 | P.CHAR -> do 248 | checkNoLength 249 | return $ Char mbSign 250 | P.INT | longs == 0 && shorts == 0 -> do 251 | return $ Int sign 252 | P.INT | longs == 1 -> do 253 | return $ Long sign 254 | P.INT | longs == 2 -> do 255 | return $ LLong sign 256 | P.INT | shorts == 1 -> do 257 | return $ Short sign 258 | P.INT -> do 259 | illegalSpecifiers "too many long/short" 260 | P.FLOAT -> do 261 | checkNoLength 262 | return Float 263 | P.DOUBLE -> do 264 | if longs == 1 265 | then return LDouble 266 | else do 267 | checkNoLength 268 | return Double 269 | _ -> do 270 | error $ "untangleDeclarationSpecifiers impossible: " ++ show dataType 271 | 272 | untangleDeclarator 273 | :: forall i. Type i -> P.Declarator i -> Either UntangleErr (i, Type i) 274 | untangleDeclarator ty0 (P.Declarator ptrs0 directDecltor) = go ty0 ptrs0 275 | where 276 | go :: Type i -> [P.Pointer] -> Either UntangleErr (i, Type i) 277 | go ty [] = goDirect ty directDecltor 278 | go ty (P.Pointer quals : ptrs) = go (Ptr quals ty) ptrs 279 | 280 | goDirect :: Type i -> P.DirectDeclarator i -> Either UntangleErr (i, Type i) 281 | goDirect ty direct0 = case direct0 of 282 | P.DeclaratorRoot s -> return (s, ty) 283 | P.ArrayOrProto direct (P.Array arrayType) -> 284 | goDirect (Array arrayType ty) direct 285 | P.ArrayOrProto direct (P.Proto params) -> do 286 | params' <- mapM untangleParameterDeclaration params 287 | goDirect (Proto ty params') direct 288 | P.DeclaratorParens decltor -> 289 | untangleDeclarator ty decltor 290 | 291 | untangleAbstractDeclarator 292 | :: forall i. Type i -> P.AbstractDeclarator i -> Either UntangleErr (Type i) 293 | untangleAbstractDeclarator ty0 (P.AbstractDeclarator ptrs0 mbDirectDecltor) = 294 | go ty0 ptrs0 295 | where 296 | go :: Type i -> [P.Pointer] -> Either UntangleErr (Type i) 297 | go ty [] = case mbDirectDecltor of 298 | Nothing -> return ty 299 | Just directDecltor -> goDirect ty directDecltor 300 | go ty (P.Pointer quals : ptrs) = go (Ptr quals ty) ptrs 301 | 302 | goDirect :: Type i -> P.DirectAbstractDeclarator i -> Either UntangleErr (Type i) 303 | goDirect ty direct0 = case direct0 of 304 | P.ArrayOrProtoThere direct (P.Array arrayType) -> 305 | goDirect (Array arrayType ty) direct 306 | P.ArrayOrProtoThere direct (P.Proto params) -> do 307 | params' <- mapM untangleParameterDeclaration params 308 | goDirect (Proto ty params') direct 309 | P.ArrayOrProtoHere (P.Array arrayType) -> 310 | return $ Array arrayType ty 311 | P.ArrayOrProtoHere (P.Proto params) -> do 312 | params' <- mapM untangleParameterDeclaration params 313 | return $ Proto ty params' 314 | P.AbstractDeclaratorParens decltor -> 315 | untangleAbstractDeclarator ty decltor 316 | 317 | ------------------------------------------------------------------------ 318 | -- Tangling 319 | 320 | tangleParameterDeclaration 321 | :: forall i. ParameterDeclaration i -> P.ParameterDeclaration i 322 | tangleParameterDeclaration (ParameterDeclaration mbId ty00) = 323 | uncurry P.ParameterDeclaration $ case mbId of 324 | Nothing -> second P.IsAbstractDeclarator $ goAbstractDirect ty00 Nothing 325 | Just id' -> second P.IsDeclarator $ goConcreteDirect ty00 $ P.DeclaratorRoot id' 326 | where 327 | goAbstractDirect 328 | :: Type i -> Maybe (P.DirectAbstractDeclarator i) 329 | -> ([P.DeclarationSpecifier], P.AbstractDeclarator i) 330 | goAbstractDirect ty0 mbDirect = case ty0 of 331 | TypeSpecifier specifiers tySpec -> 332 | let declSpecs = tangleTypeSpecifier specifiers tySpec 333 | in (declSpecs, P.AbstractDeclarator [] mbDirect) 334 | Ptr tyQuals ty -> 335 | goAbstract ty [P.Pointer tyQuals] mbDirect 336 | Array arrType ty -> 337 | let arr = P.Array arrType 338 | in case mbDirect of 339 | Nothing -> 340 | goAbstractDirect ty $ Just $ P.ArrayOrProtoHere arr 341 | Just decltor -> 342 | goAbstractDirect ty $ Just $ P.ArrayOrProtoThere decltor arr 343 | Proto ty params -> 344 | let proto = P.Proto $ map tangleParameterDeclaration params 345 | in case mbDirect of 346 | Nothing -> 347 | goAbstractDirect ty $ Just $ P.ArrayOrProtoHere proto 348 | Just decltor -> 349 | goAbstractDirect ty $ Just $ P.ArrayOrProtoThere decltor proto 350 | 351 | goAbstract 352 | :: Type i -> [P.Pointer] -> Maybe (P.DirectAbstractDeclarator i) 353 | -> ([P.DeclarationSpecifier], P.AbstractDeclarator i) 354 | goAbstract ty0 ptrs mbDirect = case ty0 of 355 | TypeSpecifier specifiers tySpec -> 356 | let declSpecs = tangleTypeSpecifier specifiers tySpec 357 | in (declSpecs, P.AbstractDeclarator ptrs mbDirect) 358 | Ptr tyQuals ty -> 359 | goAbstract ty (P.Pointer tyQuals : ptrs) mbDirect 360 | Array{} -> 361 | goAbstractDirect ty0 $ Just $ P.AbstractDeclaratorParens $ 362 | P.AbstractDeclarator ptrs mbDirect 363 | Proto{} -> 364 | goAbstractDirect ty0 $ Just $ P.AbstractDeclaratorParens $ 365 | P.AbstractDeclarator ptrs mbDirect 366 | 367 | goConcreteDirect 368 | :: Type i -> P.DirectDeclarator i 369 | -> ([P.DeclarationSpecifier], P.Declarator i) 370 | goConcreteDirect ty0 direct = case ty0 of 371 | TypeSpecifier specifiers tySpec -> 372 | let declSpecs = tangleTypeSpecifier specifiers tySpec 373 | in (declSpecs, P.Declarator [] direct) 374 | Ptr tyQuals ty -> 375 | goConcrete ty [P.Pointer tyQuals] direct 376 | Array arrType ty -> 377 | goConcreteDirect ty $ P.ArrayOrProto direct $ P.Array arrType 378 | Proto ty params -> 379 | goConcreteDirect ty $ P.ArrayOrProto direct $ 380 | P.Proto $ map tangleParameterDeclaration params 381 | 382 | goConcrete 383 | :: Type i -> [P.Pointer] -> P.DirectDeclarator i 384 | -> ([P.DeclarationSpecifier], P.Declarator i) 385 | goConcrete ty0 ptrs direct = case ty0 of 386 | TypeSpecifier specifiers tySpec -> 387 | let declSpecs = tangleTypeSpecifier specifiers tySpec 388 | in (declSpecs, P.Declarator ptrs direct) 389 | Ptr tyQuals ty -> 390 | goConcrete ty (P.Pointer tyQuals : ptrs) direct 391 | Array{} -> 392 | goConcreteDirect ty0 $ P.DeclaratorParens $ P.Declarator ptrs direct 393 | Proto{} -> 394 | goConcreteDirect ty0 $ P.DeclaratorParens $ P.Declarator ptrs direct 395 | 396 | tangleTypeSpecifier :: Specifiers -> TypeSpecifier -> [P.DeclarationSpecifier] 397 | tangleTypeSpecifier (Specifiers storages tyQuals funSpecs) tySpec = 398 | let pTySpecs ty = case ty of 399 | Void -> [P.VOID] 400 | Bool -> [P.BOOL] 401 | Char Nothing -> [P.CHAR] 402 | Char (Just Signed) -> [P.SIGNED, P.CHAR] 403 | Char (Just Unsigned) -> [P.UNSIGNED, P.CHAR] 404 | Short Signed -> [P.SHORT] 405 | Short Unsigned -> [P.UNSIGNED, P.SHORT] 406 | Int Signed -> [P.INT] 407 | Int Unsigned -> [P.UNSIGNED] 408 | Long Signed -> [P.LONG] 409 | Long Unsigned -> [P.UNSIGNED, P.LONG] 410 | LLong Signed -> [P.LONG, P.LONG] 411 | LLong Unsigned -> [P.UNSIGNED, P.LONG, P.LONG] 412 | Float -> [P.FLOAT] 413 | Double -> [P.DOUBLE] 414 | LDouble -> [P.LONG, P.DOUBLE] 415 | TypeName s -> [P.TypeName s] 416 | Struct s -> [P.Struct s] 417 | Enum s -> [P.Enum s] 418 | Template s types -> [P.Template s (map pTySpecs types)] 419 | TemplateConst s -> [P.TemplateConst s] 420 | TemplatePointer type' -> [P.TemplatePointer (head (pTySpecs type'))] 421 | in map P.StorageClassSpecifier storages ++ 422 | map P.TypeQualifier tyQuals ++ 423 | map P.FunctionSpecifier funSpecs ++ 424 | map P.TypeSpecifier (pTySpecs tySpec) 425 | 426 | ------------------------------------------------------------------------ 427 | -- To english 428 | 429 | describeParameterDeclaration :: PP.Pretty i => ParameterDeclaration i -> PP.Doc ann 430 | describeParameterDeclaration (ParameterDeclaration mbId ty) = 431 | let idDoc = case mbId of 432 | Nothing -> "" 433 | Just id' -> PP.pretty id' <+> "is a " 434 | in idDoc <> describeType ty 435 | 436 | describeType :: PP.Pretty i => Type i -> PP.Doc ann 437 | describeType ty0 = case ty0 of 438 | TypeSpecifier specs tySpec -> engSpecs specs <> PP.pretty tySpec 439 | Ptr quals ty -> engQuals quals <> "ptr to" <+> describeType ty 440 | Array arrTy ty -> engArrTy arrTy <> "of" <+> describeType ty 441 | Proto retTy params -> 442 | "function from" <+> engParams params <> "returning" <+> describeType retTy 443 | where 444 | engSpecs (Specifiers [] [] []) = "" 445 | engSpecs (Specifiers x y z) = 446 | let xs = map P.StorageClassSpecifier x ++ map P.TypeQualifier y ++ 447 | map P.FunctionSpecifier z 448 | in PP.hsep (map PP.pretty xs) <> " " 449 | 450 | engQuals = PP.hsep . map PP.pretty 451 | 452 | engArrTy arrTy = case arrTy of 453 | P.VariablySized -> "variably sized array " 454 | P.SizedByInteger n -> "array of size" <+> fromString (show n) <> " " 455 | P.SizedByIdentifier s -> "array of size" <+> PP.pretty s <> " " 456 | P.Unsized -> "array " 457 | 458 | engParams [] = "" 459 | engParams params0 = "(" <> go params0 <> ") " 460 | where 461 | go xs = case xs of 462 | [] -> "" 463 | [x] -> describeParameterDeclaration x 464 | (x:xs') -> describeParameterDeclaration x <> "," <+> go xs' 465 | 466 | ------------------------------------------------------------------------ 467 | -- Convenient parsing 468 | 469 | untangleParameterDeclaration' 470 | :: (P.CParser i m, PP.Pretty i) 471 | => P.ParameterDeclaration i -> m (ParameterDeclaration i) 472 | untangleParameterDeclaration' pDecl = 473 | case untangleParameterDeclaration pDecl of 474 | Left err -> fail $ pretty80 $ 475 | PP.vsep ["Error while parsing declaration:", PP.pretty err, PP.pretty pDecl] 476 | Right x -> return x 477 | 478 | parseParameterDeclaration 479 | :: (P.CParser i m, PP.Pretty i) => m (ParameterDeclaration i) 480 | parseParameterDeclaration = 481 | untangleParameterDeclaration' =<< P.parameter_declaration 482 | 483 | parseParameterList 484 | :: (P.CParser i m, PP.Pretty i) 485 | => m [ParameterDeclaration i] 486 | parseParameterList = 487 | mapM untangleParameterDeclaration' =<< P.parameter_list 488 | 489 | parseIdentifier :: P.CParser i m => m i 490 | parseIdentifier = P.identifier_no_lex 491 | 492 | parseEnableCpp :: P.CParser i m => m Bool 493 | parseEnableCpp = do 494 | ctx <- ask 495 | return (P.cpcEnableCpp ctx) 496 | 497 | parseType :: (P.CParser i m, PP.Pretty i) => m (Type i) 498 | parseType = parameterDeclarationType <$> parseParameterDeclaration 499 | 500 | ------------------------------------------------------------------------ 501 | -- Pretty 502 | 503 | instance PP.Pretty TypeSpecifier where 504 | pretty tySpec = case tySpec of 505 | Void -> "void" 506 | Bool -> "bool" 507 | Char Nothing -> "char" 508 | Char (Just Signed) -> "signed char" 509 | Char (Just Unsigned) -> "unsigned char" 510 | Short Signed -> "short" 511 | Short Unsigned -> "unsigned short" 512 | Int Signed -> "int" 513 | Int Unsigned -> "unsigned" 514 | Long Signed -> "long" 515 | Long Unsigned -> "unsigned long" 516 | LLong Signed -> "long long" 517 | LLong Unsigned -> "unsigned long long" 518 | Float -> "float" 519 | Double -> "double" 520 | LDouble -> "long double" 521 | TypeName s -> PP.pretty s 522 | Struct s -> "struct" <+> PP.pretty s 523 | Enum s -> "enum" <+> PP.pretty s 524 | Template s args -> PP.pretty s <+> "<" <+> mconcat (intersperse "," (map PP.pretty args)) <+> ">" 525 | TemplateConst s -> PP.pretty s 526 | TemplatePointer s -> PP.pretty s <+> "*" 527 | 528 | instance PP.Pretty UntangleErr where 529 | pretty err = case err of 530 | MultipleDataTypes specs -> 531 | PP.vsep ["Multiple data types in", PP.prettyList specs] 532 | IllegalSpecifiers s specs -> 533 | PP.vsep ["Illegal specifiers," <+> fromString s <> ", in", PP.prettyList specs] 534 | NoDataTypes specs -> 535 | PP.vsep ["No data types in", PP.prettyList specs] 536 | 537 | instance PP.Pretty i => PP.Pretty (ParameterDeclaration i) where 538 | pretty = PP.pretty . tangleParameterDeclaration 539 | 540 | instance PP.Pretty i => PP.Pretty (Type i) where 541 | pretty ty = 542 | PP.pretty $ tangleParameterDeclaration $ ParameterDeclaration Nothing ty 543 | 544 | ------------------------------------------------------------------------ 545 | -- Utils 546 | 547 | pretty80 :: PP.Doc ann -> String 548 | pretty80 x = PP.renderString $ PP.layoutSmart (PP.LayoutOptions { PP.layoutPageWidth = PP.AvailablePerLine 80 0.8 }) x 549 | -------------------------------------------------------------------------------- /inline-c/test/Dummy.hs: -------------------------------------------------------------------------------- 1 | -- | This module exists because of TH staging restrictions. 2 | module Dummy (dummyFun) where 3 | 4 | import Foreign.C.Types 5 | 6 | dummyFun :: CDouble -> IO CDouble 7 | dummyFun x = return $ cos x 8 | -------------------------------------------------------------------------------- /inline-c/test/Language/C/Inline/ContextSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE DataKinds #-} 10 | module Language.C.Inline.ContextSpec (spec) where 11 | 12 | import Control.Monad.Trans.Class (lift) 13 | import Data.Word 14 | import qualified Data.Map as Map 15 | import qualified Test.Hspec as Hspec 16 | import Text.Parser.Char 17 | import Text.Parser.Combinators 18 | import qualified Language.Haskell.TH as TH 19 | import Foreign.C.Types 20 | import Foreign.Ptr (Ptr, FunPtr) 21 | 22 | #if __GLASGOW_HASKELL__ < 710 23 | import Control.Applicative ((<*), (*>)) 24 | #endif 25 | 26 | import qualified Language.C.Types as C 27 | import qualified Language.C.Types.Parse as P 28 | import Language.C.Inline.Context 29 | import GHC.Exts( IsString(..) ) 30 | 31 | data Vec a 32 | data Ary a 33 | 34 | spec :: Hspec.SpecWith () 35 | spec = do 36 | Hspec.it "converts simple type correctly (1)" $ do 37 | shouldBeType (cty "int") [t| CInt |] 38 | Hspec.it "converts simple type correctly (2)" $ do 39 | shouldBeType (cty "char") [t| CChar |] 40 | Hspec.it "converts bool" $ do 41 | shouldBeType (cty "bool") [t| CBool |] 42 | Hspec.it "converts void" $ do 43 | shouldBeType (cty "void") [t| () |] 44 | Hspec.it "converts signed" $ do 45 | shouldBeType (cty "signed") [t| CInt |] 46 | Hspec.it "converts unsigned" $ do 47 | shouldBeType (cty "unsigned") [t| CUInt |] 48 | Hspec.it "converts standard library types (1)" $ do 49 | shouldBeType (cty "FILE") [t| CFile |] 50 | Hspec.it "converts standard library types (2)" $ do 51 | shouldBeType (cty "uint16_t") [t| Word16 |] 52 | Hspec.it "converts standard library types (3)" $ do 53 | shouldBeType (cty "jmp_buf") [t| CJmpBuf |] 54 | Hspec.it "converts single ptr type" $ do 55 | shouldBeType (cty "long*") [t| Ptr CLong |] 56 | Hspec.it "converts double ptr type" $ do 57 | shouldBeType (cty "unsigned long**") [t| Ptr (Ptr CULong) |] 58 | Hspec.it "converts arrays" $ do 59 | shouldBeType (cty "double[]") [t| CArray CDouble |] 60 | Hspec.it "converts named things" $ do 61 | shouldBeType (cty "unsigned int foo[]") [t| CArray CUInt |] 62 | Hspec.it "converts arrays of pointers" $ do 63 | shouldBeType 64 | (cty "unsigned short *foo[]") [t| CArray (Ptr CUShort) |] 65 | Hspec.it "ignores qualifiers" $ do 66 | shouldBeType (cty "const short*") [t| Ptr CShort |] 67 | Hspec.it "ignores storage information" $ do 68 | shouldBeType (cty "extern unsigned long") [t| CULong |] 69 | Hspec.it "converts sized arrays" $ do 70 | shouldBeType (cty "float[4]") [t| CArray CFloat |] 71 | Hspec.it "converts variably sized arrays" $ do 72 | shouldBeType (cty "float[*]") [t| CArray CFloat |] 73 | Hspec.it "converts function pointers" $ do 74 | shouldBeType 75 | (cty "int (*f)(unsigned char, float)") 76 | [t| FunPtr (CUChar -> CFloat -> IO CInt) |] 77 | Hspec.it "converts complicated function pointers (1)" $ do 78 | -- pointer to function returning pointer to function returning int 79 | shouldBeType 80 | (cty "int (*(*)())()") [t| FunPtr (IO (FunPtr (IO CInt))) |] 81 | Hspec.it "converts complicated function pointerst (2)" $ do 82 | -- foo is an array of pointer to pointer to function returning 83 | -- pointer to array of pointer to char 84 | shouldBeType 85 | (cty "char *(*(**foo [])())[]") 86 | [t| CArray (Ptr (FunPtr (IO (Ptr (CArray (Ptr CChar)))))) |] 87 | Hspec.it "converts complicated function pointers (3)" $ do 88 | -- foo is an array of pointer to pointer to function taking int 89 | -- returning pointer to array of pointer to char 90 | shouldBeType 91 | (cty "char *(*(**foo [])(int x))[]") 92 | [t| CArray (Ptr (FunPtr (CInt -> IO (Ptr (CArray (Ptr CChar)))))) |] 93 | Hspec.it "converts vector" $ do 94 | shouldBeType (cty "vector") [t| Vec CInt |] 95 | Hspec.it "converts std::vector" $ do 96 | shouldBeType (cty "std::vector") [t| Vec CInt |] 97 | Hspec.it "converts std::vector*" $ do 98 | shouldBeType (cty "std::vector*") [t| Ptr (Vec CInt) |] 99 | Hspec.it "converts array" $ do 100 | shouldBeType (cty "array") [t| Ary '(CInt,10) |] 101 | Hspec.it "converts array*" $ do 102 | shouldBeType (cty "array*") [t| Ptr (Ary '(CInt,10)) |] 103 | where 104 | goodConvert cTy = do 105 | mbHsTy <- TH.runQ $ convertType IO baseTypes cTy 106 | case mbHsTy of 107 | Nothing -> error $ "Could not convert type (goodConvert)" 108 | Just hsTy -> return hsTy 109 | 110 | shouldBeType cTy hsTy = do 111 | x <- goodConvert cTy 112 | y <- TH.runQ hsTy 113 | x `Hspec.shouldBe` y 114 | 115 | assertParse p s = 116 | case C.runCParser (C.cCParserContext True (typeNamesFromTypesTable baseTypes)) "spec" s (lift spaces *> p <* lift eof) of 117 | Left err -> error $ "Parse error (assertParse): " ++ show err 118 | Right x -> x 119 | 120 | cty s = C.parameterDeclarationType $ assertParse C.parseParameterDeclaration s 121 | 122 | baseTypes = ctxTypesTable baseCtx `mappend` Map.fromList [ 123 | (C.TypeName (fromString "vector" :: P.CIdentifier), [t|Vec|]), 124 | (C.TypeName (fromString "std::vector" :: P.CIdentifier), [t|Vec|]), 125 | (C.TypeName (fromString "array" :: P.CIdentifier), [t|Ary|]) 126 | ] 127 | -------------------------------------------------------------------------------- /inline-c/test/Language/C/Inline/ParseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | module Language.C.Inline.ParseSpec (spec) where 11 | 12 | import Control.Exception (evaluate) 13 | import Control.Monad (void) 14 | import Control.Monad.Trans.Class (lift) 15 | import qualified Data.HashSet as HashSet 16 | import Data.Monoid ((<>)) 17 | import qualified Test.Hspec as Hspec 18 | import Text.Parser.Char 19 | import Text.Parser.Combinators 20 | import Text.RawString.QQ (r) 21 | import Text.Regex.Posix ((=~)) 22 | 23 | #if __GLASGOW_HASKELL__ < 710 24 | import Control.Applicative ((<*), (*>)) 25 | #endif 26 | 27 | import Language.C.Inline.Context 28 | import Language.C.Inline.HaskellIdentifier 29 | import Language.C.Inline.Internal 30 | import qualified Language.C.Types as C 31 | 32 | spec :: Hspec.SpecWith () 33 | spec = do 34 | Hspec.describe "parsing" $ do 35 | Hspec.it "parses simple C expression" $ do 36 | (retType, params, cExp) <- goodParse [r| 37 | int { (int) ceil($(double x) + ((double) $(float y))) } 38 | |] 39 | retType `Hspec.shouldBe` (cty "int") 40 | params `shouldMatchParameters` [(cty "double", Plain "x"), (cty "float", Plain "y")] 41 | cExp `shouldMatchBody` " (int) ceil(x[a-z0-9_]+ \\+ ((double) y[a-z0-9_]+)) " 42 | Hspec.it "accepts anti quotes" $ do 43 | void $ goodParse [r| int { $(int x) } |] 44 | Hspec.it "accepts anti quotes with pointer" $ do 45 | void $ goodParse [r| int* { $(int* x) } |] 46 | Hspec.it "rejects if bad braces (1)" $ do 47 | badParse [r| int x |] 48 | Hspec.it "rejects if bad braces (2)" $ do 49 | badParse [r| int { x |] 50 | Hspec.it "parses function pointers" $ do 51 | void $ goodParse [r| int(int (*add)(int, int)) { add(3, 4) } |] 52 | Hspec.it "parses returning function pointers" $ do 53 | (retType, params, cExp) <- 54 | goodParse [r| double (*)(double) { &cos } |] 55 | retType `Hspec.shouldBe` (cty "double (*)(double)") 56 | params `shouldMatchParameters` [] 57 | cExp `shouldMatchBody` " &cos " 58 | Hspec.it "parses Haskell identifier (1)" $ do 59 | (retType, params, cExp) <- goodParse [r| double { $(double x') } |] 60 | retType `Hspec.shouldBe` (cty "double") 61 | params `shouldMatchParameters` [(cty "double", Plain "x'")] 62 | cExp `shouldMatchBody` " x[a-z0-9_]+ " 63 | Hspec.it "parses Haskell identifier (2)" $ do 64 | (retType, params, cExp) <- goodParse [r| double { $(double ä') } |] 65 | retType `Hspec.shouldBe` (cty "double") 66 | params `shouldMatchParameters` [(cty "double", Plain "ä'")] 67 | cExp `shouldMatchBody` " [a-z0-9_]+ " 68 | Hspec.it "parses Haskell identifier (3)" $ do 69 | (retType, params, cExp) <- goodParse [r| int { $(int Foo.bar) } |] 70 | retType `Hspec.shouldBe` (cty "int") 71 | params `shouldMatchParameters` [(cty "int", Plain "Foo.bar")] 72 | cExp `shouldMatchBody` " Foobar[a-z0-9_]+ " 73 | Hspec.it "does not parse Haskell identifier in bad position" $ do 74 | badParse [r| double (*)(double Foo.bar) { 3.0 } |] 75 | where 76 | ctx = baseCtx <> funCtx 77 | 78 | assertParse ctxF p s = 79 | case C.runCParser (ctxF HashSet.empty) "spec" s (lift spaces *> p <* lift eof) of 80 | Left err -> error $ "Parse error (assertParse): " ++ show err 81 | Right x -> x 82 | 83 | -- We use show + length to fully evaluate the result -- there 84 | -- might be exceptions hiding. TODO get rid of exceptions. 85 | strictParse 86 | :: String 87 | -> IO (C.Type C.CIdentifier, [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String) 88 | strictParse s = do 89 | let ParseTypedC retType pars body = 90 | assertParse (haskellCParserContext True) (parseTypedC True (ctxAntiQuoters ctx)) s 91 | void $ evaluate $ length $ show (retType, pars, body) 92 | return (retType, pars, body) 93 | 94 | goodParse = strictParse 95 | badParse s = strictParse s `Hspec.shouldThrow` Hspec.anyException 96 | 97 | cty :: String -> C.Type C.CIdentifier 98 | cty s = C.parameterDeclarationType $ 99 | assertParse (C.cCParserContext True) C.parseParameterDeclaration s 100 | 101 | shouldMatchParameters 102 | :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)] 103 | -> [(C.Type C.CIdentifier, ParameterType)] 104 | -> Hspec.Expectation 105 | shouldMatchParameters pars pars' = 106 | [(x, y) | (_, x, y) <- pars] `Hspec.shouldMatchList` pars' 107 | 108 | shouldMatchBody :: String -> String -> Hspec.Expectation 109 | shouldMatchBody x y = do 110 | let f ch' = case ch' of 111 | '(' -> "\\(" 112 | ')' -> "\\)" 113 | ch -> [ch] 114 | (x =~ concatMap f y) `Hspec.shouldBe` True 115 | -------------------------------------------------------------------------------- /inline-c/test/Language/C/Types/ParseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE CPP #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | module Language.C.Types.ParseSpec (spec) where 9 | 10 | import Control.Applicative 11 | import Control.Monad.Trans.Class (lift) 12 | import Data.Hashable (Hashable) 13 | import qualified Test.Hspec as Hspec 14 | import qualified Test.Hspec.QuickCheck 15 | import qualified Test.QuickCheck as QC 16 | import Text.Parser.Char 17 | import Text.Parser.Combinators 18 | import qualified Prettyprinter as PP 19 | import qualified Prettyprinter.Render.String as PP 20 | import Data.Typeable (Typeable) 21 | import qualified Data.HashSet as HashSet 22 | import Data.List (intercalate) 23 | import Data.String (fromString) 24 | import Data.Maybe (mapMaybe) 25 | import Data.List.Split (splitOn) 26 | 27 | import Language.C.Types.Parse 28 | import qualified Language.C.Types as Types 29 | import Language.C.Inline.HaskellIdentifier 30 | 31 | import Prelude -- Fix for 7.10 unused warnings. 32 | 33 | spec :: Hspec.SpecWith () 34 | -- modifyMaxDiscardRatio: 35 | -- 'isGoodType' and 'isGoodHaskellIdentifierType' usually make it within the 36 | -- discard ratio of 10, but we increase the ratio to avoid spurious build failures 37 | spec = Test.Hspec.QuickCheck.modifyMaxDiscardRatio (const 20) $ do 38 | Hspec.it "parses everything which is pretty-printable (C)" $ do 39 | #if MIN_VERSION_QuickCheck(2,9,0) 40 | QC.property $ QC.again $ do -- Work around 41 | #else 42 | QC.property $ do 43 | #endif 44 | ParameterDeclarationWithTypeNames typeNames ty <- 45 | arbitraryParameterDeclarationWithTypeNames unCIdentifier 46 | return $ isGoodType ty QC.==> 47 | let ty' = assertParse (cCParserContext True typeNames) parameter_declaration (prettyOneLine (PP.pretty ty)) 48 | in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty' 49 | Hspec.it "parses everything which is pretty-printable (Haskell)" $ do 50 | #if MIN_VERSION_QuickCheck(2,9,0) 51 | QC.property $ QC.again $ do -- Work around 52 | #else 53 | QC.property $ do 54 | #endif 55 | ParameterDeclarationWithTypeNames typeNames ty <- 56 | arbitraryParameterDeclarationWithTypeNames unHaskellIdentifier 57 | return $ isGoodHaskellIdentifierType typeNames ty QC.==> 58 | let ty' = assertParse (haskellCParserContext True typeNames) parameter_declaration (prettyOneLine (PP.pretty ty)) 59 | in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty' 60 | 61 | ------------------------------------------------------------------------ 62 | -- Utils 63 | 64 | assertParse 65 | :: (Hashable i) 66 | => CParserContext i -> (forall m. CParser i m => m a) -> String -> a 67 | assertParse ctx p s = 68 | case runCParser ctx "spec" s (lift spaces *> p <* lift eof) of 69 | Left err -> error $ "Parse error (assertParse): " ++ show err ++ " parsed string " ++ show s ++ " with type names " ++ show (cpcTypeNames ctx) 70 | Right x -> x 71 | 72 | prettyOneLine :: PP.Doc ann -> String 73 | prettyOneLine x = PP.renderString $ PP.layoutCompact x 74 | 75 | isGoodType :: ParameterDeclaration i -> Bool 76 | isGoodType ty = 77 | case Types.untangleParameterDeclaration ty of 78 | Left{} -> False 79 | Right{} -> True 80 | 81 | isGoodHaskellIdentifierType :: TypeNames -> ParameterDeclaration HaskellIdentifier -> Bool 82 | isGoodHaskellIdentifierType typeNames ty0 = 83 | case Types.untangleParameterDeclaration ty0 of 84 | Left{} -> False 85 | Right ty -> 86 | case Types.parameterDeclarationId ty of 87 | Nothing -> True 88 | Just i -> let 89 | -- see 90 | leadingSegment : _ = splitOn "." (unHaskellIdentifier i) 91 | in case cIdentifierFromString True leadingSegment of 92 | Left{} -> True 93 | Right seg -> not (seg `HashSet.member` typeNames) 94 | 95 | ------------------------------------------------------------------------ 96 | -- Arbitrary 97 | 98 | data OneOfSized a 99 | = Anyhow a 100 | | IfPositive a 101 | deriving (Typeable, Eq, Show) 102 | 103 | -- | Precondition: there is at least one 'Anyhow' in the list. 104 | oneOfSized :: [OneOfSized (QC.Gen a)] -> QC.Gen a 105 | oneOfSized xs = QC.sized $ \n -> do 106 | let f (Anyhow a) = Just a 107 | f (IfPositive x) | n > 0 = Just x 108 | f (IfPositive _) = Nothing 109 | QC.oneof $ mapMaybe f xs 110 | 111 | halveSize :: QC.Gen a -> QC.Gen a 112 | halveSize m = QC.sized $ \n -> QC.resize (n `div` 2) m 113 | 114 | instance QC.Arbitrary CIdentifier where 115 | arbitrary = do 116 | s <- ((:) <$> QC.elements cIdentStart <*> QC.listOf (QC.elements cIdentLetter)) 117 | if HashSet.member s cReservedWords 118 | then QC.arbitrary 119 | else return $ fromString s 120 | 121 | -- | Type used to generate an 'QC.Arbitrary' 'ParameterDeclaration' with 122 | -- arbitrary allowed type names. 123 | data ParameterDeclarationWithTypeNames i = ParameterDeclarationWithTypeNames 124 | { _pdwtnTypeNames :: HashSet.HashSet CIdentifier 125 | , _pdwtnParameterDeclaration :: (ParameterDeclaration i) 126 | } deriving (Typeable, Eq, Show) 127 | 128 | data ArbitraryContext i = ArbitraryContext 129 | { acTypeNames :: TypeNames 130 | , acIdentToString :: i -> String 131 | } 132 | 133 | arbitraryParameterDeclarationWithTypeNames 134 | :: (QC.Arbitrary i, Hashable i) 135 | => (i -> String) 136 | -> QC.Gen (ParameterDeclarationWithTypeNames i) 137 | arbitraryParameterDeclarationWithTypeNames identToString = do 138 | names <- HashSet.fromList <$> QC.listOf QC.arbitrary 139 | let ctx = ArbitraryContext names identToString 140 | decl <- arbitraryParameterDeclarationFrom ctx 141 | return $ ParameterDeclarationWithTypeNames names decl 142 | 143 | arbitraryDeclarationSpecifierFrom 144 | :: (QC.Arbitrary i, Hashable i) => ArbitraryContext i -> QC.Gen DeclarationSpecifier 145 | arbitraryDeclarationSpecifierFrom typeNames = QC.oneof $ 146 | [ StorageClassSpecifier <$> QC.arbitrary 147 | , TypeQualifier <$> QC.arbitrary 148 | , FunctionSpecifier <$> QC.arbitrary 149 | , TypeSpecifier <$> arbitraryTypeSpecifierFrom typeNames 150 | ] 151 | 152 | instance QC.Arbitrary StorageClassSpecifier where 153 | arbitrary = QC.oneof 154 | [ return TYPEDEF 155 | , return EXTERN 156 | , return STATIC 157 | , return AUTO 158 | , return REGISTER 159 | ] 160 | 161 | arbitraryTypeSpecifierFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen TypeSpecifier 162 | arbitraryTypeSpecifierFrom ctx = QC.oneof $ 163 | [ return VOID 164 | , return CHAR 165 | , return SHORT 166 | , return INT 167 | , return LONG 168 | , return FLOAT 169 | , return DOUBLE 170 | , return SIGNED 171 | , return UNSIGNED 172 | , Struct <$> arbitraryCIdentifierFrom ctx 173 | , Enum <$> arbitraryCIdentifierFrom ctx 174 | ] ++ if HashSet.null (acTypeNames ctx) then [] 175 | else [TypeName <$> QC.elements (HashSet.toList (acTypeNames ctx))] 176 | 177 | instance QC.Arbitrary TypeQualifier where 178 | arbitrary = QC.oneof 179 | [ return CONST 180 | , return RESTRICT 181 | , return VOLATILE 182 | ] 183 | 184 | instance QC.Arbitrary FunctionSpecifier where 185 | arbitrary = QC.oneof 186 | [ return INLINE 187 | ] 188 | 189 | arbitraryDeclaratorFrom 190 | :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (Declarator i) 191 | arbitraryDeclaratorFrom typeNames = halveSize $ 192 | Declarator <$> QC.arbitrary <*> arbitraryDirectDeclaratorFrom typeNames 193 | 194 | arbitraryCIdentifierFrom 195 | :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen CIdentifier 196 | arbitraryCIdentifierFrom ctx = 197 | arbitraryIdentifierFrom ctx{acIdentToString = unCIdentifier} 198 | 199 | arbitraryIdentifierFrom 200 | :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen i 201 | arbitraryIdentifierFrom ctx = do 202 | id' <- QC.arbitrary 203 | if isTypeName True (acTypeNames ctx) (acIdentToString ctx id') 204 | then arbitraryIdentifierFrom ctx 205 | else return id' 206 | 207 | arbitraryDirectDeclaratorFrom 208 | :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectDeclarator i) 209 | arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized $ 210 | [ Anyhow $ DeclaratorRoot <$> arbitraryIdentifierFrom typeNames 211 | , IfPositive $ DeclaratorParens <$> arbitraryDeclaratorFrom typeNames 212 | , IfPositive $ ArrayOrProto 213 | <$> arbitraryDirectDeclaratorFrom typeNames 214 | <*> arbitraryArrayOrProtoFrom typeNames 215 | ] 216 | 217 | arbitraryArrayOrProtoFrom 218 | :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ArrayOrProto i) 219 | arbitraryArrayOrProtoFrom typeNames = halveSize $ oneOfSized $ 220 | [ Anyhow $ Array <$> arbitraryArrayTypeFrom typeNames 221 | , IfPositive $ Proto <$> QC.listOf (arbitraryParameterDeclarationFrom typeNames) 222 | ] 223 | 224 | arbitraryArrayTypeFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ArrayType i) 225 | arbitraryArrayTypeFrom typeNames = QC.oneof 226 | [ return VariablySized 227 | , SizedByInteger . QC.getNonNegative <$> QC.arbitrary 228 | , SizedByIdentifier <$> arbitraryIdentifierFrom typeNames 229 | , return Unsized 230 | ] 231 | 232 | instance QC.Arbitrary Pointer where 233 | arbitrary = Pointer <$> QC.arbitrary 234 | 235 | arbitraryParameterDeclarationFrom 236 | :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ParameterDeclaration i) 237 | arbitraryParameterDeclarationFrom typeNames = halveSize $ 238 | ParameterDeclaration 239 | <$> QC.listOf1 (arbitraryDeclarationSpecifierFrom typeNames) 240 | <*> QC.oneof 241 | [ IsDeclarator <$> arbitraryDeclaratorFrom typeNames 242 | , IsAbstractDeclarator <$> arbitraryAbstractDeclaratorFrom typeNames 243 | ] 244 | 245 | arbitraryAbstractDeclaratorFrom 246 | :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (AbstractDeclarator i) 247 | arbitraryAbstractDeclaratorFrom typeNames = halveSize $ do 248 | ptrs <- QC.arbitrary 249 | decl <- if null ptrs 250 | then Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames 251 | else oneOfSized 252 | [ Anyhow $ return Nothing 253 | , IfPositive $ Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames 254 | ] 255 | return $ AbstractDeclarator ptrs decl 256 | 257 | arbitraryDirectAbstractDeclaratorFrom 258 | :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectAbstractDeclarator i) 259 | arbitraryDirectAbstractDeclaratorFrom typeNames = halveSize $ oneOfSized $ 260 | [ Anyhow $ ArrayOrProtoHere <$> arbitraryArrayOrProtoFrom typeNames 261 | , IfPositive $ AbstractDeclaratorParens <$> arbitraryAbstractDeclaratorFrom typeNames 262 | , IfPositive $ ArrayOrProtoThere 263 | <$> arbitraryDirectAbstractDeclaratorFrom typeNames 264 | <*> arbitraryArrayOrProtoFrom typeNames 265 | ] 266 | 267 | instance QC.Arbitrary HaskellIdentifier where 268 | arbitrary = do 269 | modIds <- QC.listOf arbitraryModId 270 | id_ <- QC.oneof [arbitraryConId, arbitraryVarId] 271 | if HashSet.member id_ haskellReservedWords 272 | then QC.arbitrary 273 | else return $ fromString $ intercalate "." $ modIds ++ [id_] 274 | where 275 | arbitraryModId = arbitraryConId 276 | 277 | arbitraryConId = 278 | ((:) <$> QC.elements large <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\'']))) 279 | 280 | arbitraryVarId = 281 | ((:) <$> QC.elements small <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\'']))) 282 | 283 | -- We currently do not generate unicode identifiers. 284 | large = ['A'..'Z'] 285 | small = ['a'..'z'] ++ ['_'] 286 | digit' = ['0'..'9'] 287 | -------------------------------------------------------------------------------- /inline-c/test/tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE ForeignFunctionInterface #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | import Control.Monad (void) 6 | import Data.Monoid ((<>)) 7 | import qualified Data.Vector.Storable.Mutable as V 8 | import Foreign.C.Types 9 | import Foreign.ForeignPtr (mallocForeignPtrBytes) 10 | import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) 11 | import qualified Language.Haskell.TH as TH 12 | import Prelude 13 | import qualified Test.Hspec as Hspec 14 | import Text.RawString.QQ (r) 15 | import Foreign.Marshal.Alloc (alloca) 16 | import Foreign.Storable (peek, poke) 17 | 18 | import qualified Language.C.Inline as C 19 | import qualified Language.C.Inline.Unsafe as CU 20 | import qualified Language.C.Inline.Interruptible as CI 21 | import qualified Language.C.Inline.Internal as C 22 | import qualified Language.C.Inline.ContextSpec 23 | import qualified Language.C.Inline.ParseSpec 24 | import qualified Language.C.Types as C 25 | import qualified Language.C.Types.ParseSpec 26 | 27 | import Dummy 28 | 29 | C.context (C.baseCtx <> C.fptrCtx <> C.funCtx <> C.vecCtx <> C.bsCtx) 30 | 31 | C.include "" 32 | C.include "" 33 | C.include "" 34 | C.include "" 35 | 36 | C.verbatim [r| 37 | int francescos_mul(int x, int y) { 38 | return x * y; 39 | } 40 | |] 41 | 42 | foreign import ccall "francescos_mul" francescos_mul :: Int -> Int -> Int 43 | 44 | main :: IO () 45 | main = Hspec.hspec $ do 46 | Hspec.describe "Language.C.Types.Parse" Language.C.Types.ParseSpec.spec 47 | Hspec.describe "Language.C.Inline.Context" Language.C.Inline.ContextSpec.spec 48 | Hspec.describe "Language.C.Inline.Parse" Language.C.Inline.ParseSpec.spec 49 | Hspec.describe "TH integration" $ do 50 | Hspec.it "inlineCode" $ do 51 | let c_add = $(C.inlineCode $ C.Code 52 | TH.Unsafe -- Call safety 53 | Nothing 54 | [t| Int -> Int -> Int |] -- Call type 55 | "francescos_add" -- Call name 56 | -- C Code 57 | [r| int francescos_add(int x, int y) { int z = x + y; return z; } |] 58 | False) -- not a function pointer 59 | c_add 3 4 `Hspec.shouldBe` 7 60 | Hspec.it "inlineItems" $ do 61 | let c_add3 = $(do 62 | here <- TH.location 63 | C.inlineItems 64 | TH.Unsafe 65 | False -- not a function pointer 66 | Nothing -- no postfix 67 | here 68 | [t| CInt -> CInt |] 69 | (C.quickCParser_ True "int" C.parseType) 70 | [("x", C.quickCParser_ True "int" C.parseType)] 71 | [r| return x + 3; |]) 72 | c_add3 1 `Hspec.shouldBe` 1 + 3 73 | Hspec.it "inlineExp" $ do 74 | let x = $(do 75 | here <- TH.location 76 | C.inlineExp 77 | TH.Safe 78 | here 79 | [t| CInt |] 80 | (C.quickCParser_ True "int" C.parseType) 81 | [] 82 | [r| 1 + 4 |]) 83 | x `Hspec.shouldBe` 1 + 4 84 | Hspec.it "inlineCode" $ do 85 | francescos_mul 3 4 `Hspec.shouldBe` 12 86 | Hspec.it "exp" $ do 87 | let x = 3 88 | let y = 4 89 | z <- [C.exp| int{ $(int x) + $(int y) + 5 } |] 90 | z `Hspec.shouldBe` x + y + 5 91 | Hspec.it "pure" $ do 92 | let x = 2 93 | let y = 10 94 | let z = [C.pure| int{ $(int x) + 10 + $(int y) } |] 95 | z `Hspec.shouldBe` x + y + 10 96 | Hspec.it "unsafe exp" $ do 97 | let x = 2 98 | let y = 10 99 | z <- [CU.exp| int{ 7 + $(int x) + $(int y) } |] 100 | z `Hspec.shouldBe` x + y + 7 101 | Hspec.it "interruptible exp" $ do 102 | let x = 2 103 | let y = 10 104 | z <- [CI.exp| int{ 7 + $(int x) + $(int y) } |] 105 | z `Hspec.shouldBe` x + y + 7 106 | Hspec.it "void exp" $ do 107 | [C.exp| void { printf("Hello\n") } |] 108 | Hspec.it "Foreign.C.Types library types" $ do 109 | let x = 1 110 | pd <- [C.block| ptrdiff_t { char a[2]; return &a[1] - &a[0] + $(ptrdiff_t x); } |] 111 | pd `Hspec.shouldBe` 2 112 | sz <- [C.exp| size_t { sizeof (char) } |] 113 | sz `Hspec.shouldBe` 1 114 | um <- [C.exp| uintmax_t { UINTMAX_MAX } |] 115 | um `Hspec.shouldBe` maxBound 116 | Hspec.it "stdint.h types" $ do 117 | let x = 2 118 | i16 <- [C.exp| int16_t { 1 + $(int16_t x) } |] 119 | i16 `Hspec.shouldBe` 3 120 | let y = 9 121 | u32 <- [C.exp| uint32_t { $(uint32_t y) * 7 } |] 122 | u32 `Hspec.shouldBe` 63 123 | Hspec.it "foreign pointer argument" $ do 124 | fptr <- mallocForeignPtrBytes 32 125 | ptr <- [C.exp| int* { $fptr-ptr:(int *fptr) } |] 126 | ptr `Hspec.shouldBe` unsafeForeignPtrToPtr fptr 127 | Hspec.it "function pointer argument" $ do 128 | let ackermann m n 129 | | m == 0 = n + 1 130 | | m > 0 && n == 0 = ackermann (m - 1) 1 131 | | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1)) 132 | | otherwise = error "ackermann" 133 | ackermannPtr <- $(C.mkFunPtr [t| CInt -> CInt -> IO CInt |]) $ \m n -> return $ ackermann m n 134 | let x = 3 135 | let y = 4 136 | z <- [C.exp| int { $(int (*ackermannPtr)(int, int))($(int x), $(int y)) } |] 137 | z `Hspec.shouldBe` ackermann x y 138 | Hspec.it "function pointer result" $ do 139 | c_add <- [C.exp| int (*)(int, int) { &francescos_add } |] 140 | x <- $(C.peekFunPtr [t| CInt -> CInt -> IO CInt |]) c_add 1 2 141 | x `Hspec.shouldBe` 1 + 2 142 | Hspec.it "quick function pointer argument" $ do 143 | let ackermann m n 144 | | m == 0 = n + 1 145 | | m > 0 && n == 0 = ackermann (m - 1) 1 146 | | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1)) 147 | | otherwise = error "ackermann" 148 | let ackermann_ m n = return $ ackermann m n 149 | let x = 3 150 | let y = 4 151 | z <- [C.exp| int { $fun:(int (*ackermann_)(int, int))($(int x), $(int y)) } |] 152 | z `Hspec.shouldBe` ackermann x y 153 | Hspec.it "function pointer argument (pure)" $ do 154 | let ackermann m n 155 | | m == 0 = n + 1 156 | | m > 0 && n == 0 = ackermann (m - 1) 1 157 | | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1)) 158 | | otherwise = error "ackermann" 159 | ackermannPtr <- $(C.mkFunPtr [t| CInt -> CInt -> CInt |]) ackermann 160 | let x = 3 161 | let y = 4 162 | let z = [C.pure| int { $(int (*ackermannPtr)(int, int))($(int x), $(int y)) } |] 163 | z `Hspec.shouldBe` ackermann x y 164 | Hspec.it "quick function pointer argument (pure)" $ do 165 | let ackermann m n 166 | | m == 0 = n + 1 167 | | m > 0 && n == 0 = ackermann (m - 1) 1 168 | | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1)) 169 | | otherwise = error "ackermann" 170 | let x = 3 171 | let y = 4 172 | let z = [C.pure| int { $fun:(int (*ackermann)(int, int))($(int x), $(int y)) } |] 173 | z `Hspec.shouldBe` ackermann x y 174 | Hspec.it "test mkFunPtrFromName" $ do 175 | fun <- $(C.mkFunPtrFromName 'dummyFun) 176 | z <- [C.exp| double { $(double (*fun)(double))(3.0) } |] 177 | z' <- dummyFun 3.0 178 | z `Hspec.shouldBe` z' 179 | Hspec.it "vectors" $ do 180 | let n = 10 181 | vec <- V.replicate (fromIntegral n) 3 182 | sum' <- V.unsafeWith vec $ \ptr -> [C.block| int { 183 | int i; 184 | int x = 0; 185 | for (i = 0; i < $(int n); i++) { 186 | x += $(int *ptr)[i]; 187 | } 188 | return x; 189 | } |] 190 | sum' `Hspec.shouldBe` 3 * 10 191 | Hspec.it "quick vectors" $ do 192 | vec <- V.replicate 10 3 193 | sum' <- [C.block| int { 194 | int i; 195 | int x = 0; 196 | for (i = 0; i < $vec-len:vec; i++) { 197 | x += $vec-ptr:(int *vec)[i]; 198 | } 199 | return x; 200 | } |] 201 | sum' `Hspec.shouldBe` 3 * 10 202 | Hspec.it "bytestrings" $ do 203 | let bs = "foo" 204 | bits <- [C.block| int { 205 | int i, bits = 0; 206 | for (i = 0; i < $bs-len:bs; i++) { 207 | char ch = $bs-ptr:bs[i]; 208 | bits += (ch * 01001001001ULL & 042104210421ULL) % 017; 209 | } 210 | return bits; 211 | } |] 212 | bits `Hspec.shouldBe` 16 213 | Hspec.it "Haskell identifiers" $ do 214 | let x' = 3 215 | void $ [C.exp| int { $(int x') } |] 216 | let ä = 3 217 | void $ [C.exp| int { $(int ä) } |] 218 | void $ [C.exp| int { $(int Prelude.maxBound) } |] 219 | Hspec.it "Function pointers" $ do 220 | alloca $ \x_ptr -> do 221 | poke x_ptr 7 222 | let fp = [C.funPtr| void poke42(int *ptr) { *ptr = 42; } |] 223 | [C.exp| void { $(void (*fp)(int *))($(int *x_ptr)) } |] 224 | x <- peek x_ptr 225 | x `Hspec.shouldBe` 42 226 | Hspec.it "cpp namespace identifiers" $ do 227 | C.cIdentifierFromString True "Test::Test" `Hspec.shouldBe` Right "Test::Test" 228 | Hspec.it "cpp template identifiers" $ do 229 | C.cIdentifierFromString True "std::vector" `Hspec.shouldBe` Right "std::vector" 230 | -------------------------------------------------------------------------------- /sample-cabal-project/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, FP Complete Corporation 2 | All rights reserved. 3 | -------------------------------------------------------------------------------- /sample-cabal-project/sample-cabal-project.cabal: -------------------------------------------------------------------------------- 1 | name: sample-cabal-project 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Francesco Mazzoli 6 | maintainer: francesco@fpcomplete.com 7 | copyright: (c) 2015 FP Complete Corporation 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | executable sample-cabal-project 12 | main-is: Main.hs 13 | hs-source-dirs: src 14 | build-depends: base >=4 && <5 15 | , inline-c 16 | default-language: Haskell2010 17 | 18 | cc-options: -Wall 19 | ghc-options: -Wall 20 | -------------------------------------------------------------------------------- /sample-cabal-project/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE ForeignFunctionInterface #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | import Foreign.C.Types 6 | import qualified Language.C.Inline as C 7 | import qualified Language.C.Inline.Unsafe as CU 8 | 9 | C.include "" 10 | C.include "" 11 | 12 | test_cexp :: CDouble -> CDouble -> IO CDouble 13 | test_cexp x y = 14 | [C.exp| double{ cos($(double x)) + cos($(double y)) } |] 15 | 16 | test_cexp_unsafe :: CDouble -> CDouble -> IO CDouble 17 | test_cexp_unsafe x y = 18 | [CU.exp| double{ cos($(double x)) + cos($(double y)) } |] 19 | 20 | test_voidExp :: IO () 21 | test_voidExp = [C.exp| void { printf("Hello\n") } |] 22 | 23 | main :: IO () 24 | main = do 25 | print =<< test_cexp 3 4 26 | print =<< test_cexp_unsafe 3 4 27 | test_voidExp 28 | -------------------------------------------------------------------------------- /stack-lts-20.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | packages: 3 | - inline-c 4 | - inline-c-cpp 5 | - inline-c-objc 6 | - inline-c-cuda 7 | - sample-cabal-project 8 | -------------------------------------------------------------------------------- /stack-lts-21.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.13 2 | packages: 3 | - inline-c 4 | - inline-c-cpp 5 | - inline-c-objc 6 | - inline-c-cuda 7 | - sample-cabal-project 8 | -------------------------------------------------------------------------------- /stack-nightly.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2023-09-24 2 | packages: 3 | - inline-c 4 | - inline-c-cpp 5 | - inline-c-objc 6 | - inline-c-cuda 7 | - sample-cabal-project 8 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | stack-lts-21.yaml --------------------------------------------------------------------------------