inline-c (empty) → 0.5.0.0
raw patch · 14 files changed
+3245/−0 lines, 14 filesdep +Chartdep +Chart-cairodep +QuickChecksetup-changed
Dependencies added: Chart, Chart-cairo, QuickCheck, ansi-wl-pprint, base, binary, bytestring, containers, cryptohash, directory, filepath, hspec, inline-c, mtl, parsec, parsers, raw-strings-qq, regex-posix, template-haskell, transformers, unordered-containers, vector
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- examples/gsl-ode.c +50/−0
- examples/gsl-ode.hs +151/−0
- inline-c.cabal +87/−0
- src/Language/C/Inline.hs +357/−0
- src/Language/C/Inline/Context.hs +408/−0
- src/Language/C/Inline/FunPtr.hs +61/−0
- src/Language/C/Inline/Internal.hs +518/−0
- src/Language/C/Inline/Unsafe.hs +49/−0
- src/Language/C/Types.hs +480/−0
- src/Language/C/Types/Parse.hs +808/−0
- test/tests.c +96/−0
- test/tests.hs +158/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 FP Complete Corporation.++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/gsl-ode.c view
@@ -0,0 +1,50 @@++#include <gsl/gsl_errno.h>++#include <gsl/gsl_matrix.h>++#include <gsl/gsl_odeiv2.h>++int inline_c_0_31a6738e02530b20854a5ca8638293b1032edaf3() {+return ( GSL_SUCCESS );+}+++int inline_c_1_47df0b9eb63f3a30404e3c62c19a67e120afdfc6(int (* funIO_inline_c_0)(double t, const double y[], double dydt[], void * params), int dim_c_inline_c_1, double x0_inline_c_2, double xend_inline_c_3, double * fMut_inline_c_4) {++ gsl_odeiv2_system sys = {+ funIO_inline_c_0,+ // The ODE to solve, converted to function pointer using the `fun`+ // anti-quoter+ NULL, // We don't provide a Jacobian+ dim_c_inline_c_1, // The dimension+ NULL // We don't need the parameter pointer+ };+ // Create the driver, using some sensible values for the stepping+ // function and the tolerances+ gsl_odeiv2_driver *d = gsl_odeiv2_driver_alloc_y_new (+ &sys, gsl_odeiv2_step_rk8pd, 1e-6, 1e-6, 0.0);+ // Finally, apply the driver.+ int status = gsl_odeiv2_driver_apply(+ d, &x0_inline_c_2, xend_inline_c_3, fMut_inline_c_4);+ // Free the driver+ gsl_odeiv2_driver_free(d);+ return status;+ +}+++int inline_c_2_189238c774f5c8439b92bfd53fe3cdd4e56f6e81() {+return ( GSL_EMAXITER );+}+++int inline_c_3_b4b4adc018e7fe003e77992771fc803668198b63() {+return ( GSL_ENOPROG );+}+++int inline_c_4_31a6738e02530b20854a5ca8638293b1032edaf3() {+return ( GSL_SUCCESS );+}+
+ examples/gsl-ode.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE MultiWayIf #-}+import Data.Coerce (coerce)+import Data.Monoid ((<>))+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as VM+import Foreign.C.Types+import Foreign.ForeignPtr (newForeignPtr_)+import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable)+import qualified Graphics.Rendering.Chart.Backend.Cairo as Chart+import qualified Graphics.Rendering.Chart.Easy as Chart+import qualified Language.C.Inline as C+import qualified Language.C.Inline.Unsafe as CU+import System.IO.Unsafe (unsafePerformIO)++#if __GLASGOW_HASKELL__ < 710+import Data.Functor ((<$>))+#endif++C.context (C.baseCtx <> C.vecCtx <> C.funCtx)++C.include "<gsl/gsl_errno.h>"+C.include "<gsl/gsl_matrix.h>"+C.include "<gsl/gsl_odeiv2.h>"++-- | Solves a system of ODEs. Every 'V.Vector' involved must be of the+-- same size.+{-# NOINLINE solveOdeC #-}+solveOdeC+ :: (CDouble -> V.Vector CDouble -> V.Vector CDouble)+ -- ^ ODE to Solve+ -> CDouble+ -- ^ Start+ -> V.Vector CDouble+ -- ^ Solution at start point+ -> CDouble+ -- ^ End+ -> Either String (V.Vector CDouble)+ -- ^ Solution at end point, or error.+solveOdeC fun x0 f0 xend = unsafePerformIO $ do+ let dim = V.length f0+ let dim_c = fromIntegral dim -- This is in CInt+ -- Convert the function to something of the right type to C.+ let funIO x y f _ptr = do+ -- Convert the pointer we get from C (y) to a vector, and then+ -- apply the user-supplied function.+ fImm <- fun x <$> vectorFromC dim y+ -- Fill in the provided pointer with the resulting vector.+ vectorToC fImm dim f+ -- Unsafe since the function will be called many times.+ [CU.exp| int{ GSL_SUCCESS } |]+ -- Create a mutable vector from the initial solution. This will be+ -- passed to the ODE solving function provided by GSL, and will+ -- contain the final solution.+ fMut <- V.thaw f0+ res <- [C.block| int {+ gsl_odeiv2_system sys = {+ $fun:(int (* funIO) (double t, const double y[], double dydt[], void * params)),+ // The ODE to solve, converted to function pointer using the `fun`+ // anti-quoter+ NULL, // We don't provide a Jacobian+ $(int dim_c), // The dimension+ NULL // We don't need the parameter pointer+ };+ // Create the driver, using some sensible values for the stepping+ // function and the tolerances+ gsl_odeiv2_driver *d = gsl_odeiv2_driver_alloc_y_new (+ &sys, gsl_odeiv2_step_rk8pd, 1e-6, 1e-6, 0.0);+ // Finally, apply the driver.+ int status = gsl_odeiv2_driver_apply(+ d, &$(double x0), $(double xend), $vec-ptr:(double *fMut));+ // Free the driver+ gsl_odeiv2_driver_free(d);+ return status;+ } |]+ -- Check the error code+ maxSteps <- [C.exp| int{ GSL_EMAXITER } |]+ smallStep <- [C.exp| int{ GSL_ENOPROG } |]+ good <- [C.exp| int{ GSL_SUCCESS } |]+ if | res == good -> Right <$> V.freeze fMut+ | res == maxSteps -> return $ Left "Too many steps"+ | res == smallStep -> return $ Left "Step size dropped below minimum allowed size"+ | otherwise -> return $ Left $ "Unknown error code " ++ show res++solveOde+ :: (Double -> V.Vector Double -> V.Vector Double)+ -- ^ ODE to Solve+ -> Double+ -- ^ Start+ -> V.Vector Double+ -- ^ Solution at start point+ -> Double+ -- ^ End+ -> Either String (V.Vector Double)+ -- ^ Solution at end point, or error.+solveOde fun x0 f0 xend =+ coerce $ solveOdeC (coerce fun) (coerce x0) (coerce f0) (coerce xend)++lorenz+ :: Double+ -- ^ Starting point+ -> V.Vector Double+ -- ^ Solution at starting point+ -> Double+ -- ^ End point+ -> Either String (V.Vector Double)+lorenz x0 f0 xend = solveOde fun x0 f0 xend+ where+ sigma = 10.0;+ _R = 28.0;+ b = 8.0 / 3.0;++ fun _x y =+ let y0 = y V.! 0+ y1 = y V.! 1+ y2 = y V.! 2+ in V.fromList+ [ sigma * ( y1 - y0 )+ , _R * y0 - y1 - y0 * y2+ , -b * y2 + y0 * y1+ ]++main :: IO ()+main = Chart.toFile Chart.def "lorenz.png" $ do+ Chart.layout_title Chart..= "Lorenz"+ Chart.plot $ Chart.line "curve" [pts]+ where+ pts = [(f V.! 0, f V.! 2) | (_x, f) <- go 0 (V.fromList [10.0 , 1.0 , 1.0])]++ go x f | x > 40 =+ [(x, f)]+ go x f =+ let x' = x + 0.01+ Right f' = lorenz x f x'+ in (x, f) : go x' f'++-- Utils++vectorFromC :: Storable a => Int -> Ptr a -> IO (V.Vector a)+vectorFromC len ptr = do+ ptr' <- newForeignPtr_ ptr+ V.freeze $ VM.unsafeFromForeignPtr0 ptr' len++vectorToC :: Storable a => V.Vector a -> Int -> Ptr a -> IO ()+vectorToC vec len ptr = do+ ptr' <- newForeignPtr_ ptr+ V.copy (VM.unsafeFromForeignPtr0 ptr' len) vec
+ inline-c.cabal view
@@ -0,0 +1,87 @@+name: inline-c+version: 0.5.0.0+synopsis: Write Haskell source files including C code inline. No FFI required.+description: See <https://github.com/fpco/inline-c/blob/master/README.md>.+license: MIT+license-file: LICENSE+author: Francesco Mazzoli, Mathieu Boespflug+maintainer: francesco@fpcomplete.com+copyright: (c) 2015 FP Complete Corporation+category: FFI+tested-with: GHC == 7.8.4, GHC == 7.10.1+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/fpco/inline-c++flag gsl-example+ description: Build GSL example+ default: False++library+ exposed-modules: Language.C.Inline+ , Language.C.Inline.Context+ , Language.C.Inline.Internal+ , Language.C.Inline.Unsafe+ , Language.C.Types+ , Language.C.Types.Parse+ other-modules: Language.C.Inline.FunPtr+ ghc-options: -Wall+ build-depends: base >=4.7 && <5+ , QuickCheck+ , ansi-wl-pprint+ , binary+ , bytestring+ , containers+ , cryptohash+ , directory+ , filepath+ , mtl+ , parsec >= 3+ , parsers+ , template-haskell >= 2.9+ , transformers >= 0.1.3.0+ , unordered-containers+ , vector+ hs-source-dirs: src+ default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: tests.hs+ c-sources: test/tests.c+ build-depends: base >=4 && <5+ , ansi-wl-pprint+ , containers+ , hspec >= 2+ , inline-c+ , parsers+ , QuickCheck+ , raw-strings-qq+ , regex-posix+ , template-haskell+ , transformers+ , vector+ default-language: Haskell2010+ ghc-options: -Wall++executable gsl-ode+ hs-source-dirs: examples+ main-is: gsl-ode.hs+ c-sources: examples/gsl-ode.c+ default-language: Haskell2010+ extra-libraries: gsl gslcblas m+ ghc-options: -Wall++ if flag(gsl-example)+ buildable: True+ build-depends: base >=4 && <5+ , inline-c+ , vector+ , Chart+ , Chart-cairo+ else+ buildable: False
+ src/Language/C/Inline.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -fno-warn-orphans #-} -- This is used for IsString C.Id++-- | Enable painless embedding of C code in Haskell code. If you're interested+-- in how to use the library, skip to the "Inline C" section. To build, read the+-- first two sections.+--+-- This module is intended to be imported qualified:+--+-- @+-- import qualified "Language.C.Inline" as C+-- @++module Language.C.Inline+ ( -- * Build process+ -- $building++ -- * Contexts+ Context+ , baseCtx+ , funCtx+ , vecCtx+ , bsCtx+ , context++ -- * Inline C+ -- $quoting+ , exp+ , pure+ , block+ , include+ , verbatim++ -- * 'Ptr' utils+ , withPtr+ , withPtr_+ , WithPtrs(..)++ -- * 'FunPtr' utils+ --+ -- Functions to quickly convert from/to 'FunPtr's. They're provided here+ -- since they can be useful to work with Haskell functions in C, and+ -- vice-versa. However, consider using 'funCtx' if you're doing this+ -- a lot.+ , mkFunPtr+ , mkFunPtrFromName+ , peekFunPtr++ -- * C types re-exports+ --+ -- Re-export these to avoid errors when `inline-c` generates FFI calls GHC+ -- needs the constructors for those types.+ , module Foreign.C.Types+ ) where++#if __GLASGOW_HASKELL__ < 710+import Prelude hiding (exp)+#else+import Prelude hiding (exp, pure)+#endif++import Control.Monad (void)+import Foreign.C.Types+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (Ptr)+import Foreign.Storable (peek, Storable)+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TH++import Language.C.Inline.Context+import Language.C.Inline.Internal+import Language.C.Inline.FunPtr++-- $building+--+-- Each module that uses at least one of the TH functions in this module gets+-- a C file associated to it, where the filename of said file will be the same+-- as the module but with a `.c` extension. This C file must be built after the+-- Haskell code and linked appropriately. If you use cabal, all you have to do+-- is declare each associated C file in the @.cabal@ file.+--+-- For example:+--+-- @+-- executable foo+-- main-is: Main.hs, Foo.hs, Bar.hs+-- hs-source-dirs: src+-- -- Here the corresponding C sources must be listed for every module+-- -- that uses C code. In this example, Main.hs and Bar.hs do, but+-- -- Foo.hs does not.+-- c-sources: src\/Main.c, src\/Bar.c+-- -- These flags will be passed to the C compiler+-- cc-options: -Wall -O2+-- -- Libraries to link the code with.+-- extra-libraries: -lm+-- ...+-- @+--+-- Note that currently @cabal repl@ is not supported, because the C code is not+-- compiled and linked appropriately.+--+-- If we were to compile the above manually, we could:+--+-- @+-- $ ghc -c Main.hs+-- $ cc -c Main.c -o Main_c.o+-- $ ghc Foo.hs+-- $ ghc Bar.hs+-- $ cc -c Bar.c -o Bar_c.o+-- $ ghc Main.o Foo.o Bar.o Main_c.o Bar_c.o -lm -o Main+-- @++------------------------------------------------------------------------+-- Quoting sugar++-- $quoting+--+-- The quasiquoters below are the main interface to this library, for inlining+-- C code into Haskell source files.+--+-- In general, quasiquoters are used like so:+--+-- @+-- [C.XXX| int { \<C code\> } |]+-- @+--+-- Where @C.XXX@ is one of the quasi-quoters defined in this section.+--+-- This syntax stands for a piece of typed C, decorated with a type:+--+-- * The first type to appear (@int@ in the example) is the type of said C code.+--+-- * The syntax of the @\<C code\>@ depends on on the quasi-quoter used, and the+-- anti-quoters available. The @exp@ quasi-quoter expects a C expression. The+-- @block@ quasi-quoter expects a list of statements, like the body of+-- a function. Just like a C function, a block has a return type, matching the+-- type of any values in any @return@ statements appearing in the block.+--+-- See also the @README.md@ file for more documentation.+--+-- === Anti-quoters+--+-- Haskell variables can be captured using anti-quoters. @inline-c@+-- provides a basic anti-quoting mechanism extensible with user-defined+-- anti-quoters (see "Language.C.Inline.Context"). The basic+-- anti-quoter lets you capture Haskell variables, for+-- example we might say+--+-- @+-- let x = pi / 3 in ['C.exp'| double { cos($(double x)) } |]+-- @+--+-- Which would capture the Haskell variable @x@ of type @'CDouble'@.+--+-- In C expressions the @$@ character is denoted using @$$@.+--+-- === Variable capture and the typing relation+--+-- The Haskell type of the inlined expression is determined by the specified+-- C return type. The relation between the C type and the Haskell type is+-- defined in the current 'Context' -- see 'convertCType'. C pointers and+-- arrays are both converted to Haskell @'Ptr'@s, and function pointers are+-- converted to @'FunPtr'@s. Sized arrays are not supported.+--+-- Similarly, when capturing Haskell variables using anti-quoting, their+-- type is assumed to be of the Haskell type corresponding to the C type+-- provided. For example, if we capture variable @x@ using @double x@+-- in the parameter list, the code will expect a variable @x@ of type+-- 'CDouble' in Haskell (when using 'baseCtx').+--+-- === Purity+--+-- The 'exp' and 'block' quasi-quotes denote computations in the 'IO' monad.+-- 'pure' denotes a pure value, expressed as a C expression.+--+-- === Safe and @unsafe@ calls+--+-- @unsafe@ variants of the quasi-quoters are provided in+-- "Language.C.Inline.Unsafe" to call the C code unsafely, in the sense that the+-- C code will block the RTS, but with the advantage of a faster call to the+-- foreign code. See+-- <https://www.haskell.org/onlinereport/haskell2010/haskellch8.html#x15-1590008.4.3>.+--+-- == Examples+--+-- === Inline C expression+--+-- @+-- {-\# LANGUAGE QuasiQuotes \#-}+-- import qualified "Language.C.Inline" as C+-- import qualified "Language.C.Inline.Unsafe" as CU+-- import "Foreign.C.Types"+--+-- C.'include' "\<math.h\>"+--+-- c_cos :: 'CDouble' -> IO 'CDouble'+-- c_cos x = [C.exp| double { cos($(double x)) } |]+--+-- faster_c_cos :: 'CDouble' -> IO 'CDouble'+-- faster_c_cos x = [CU.exp| double { cos($(double x)) } |]+-- @+--+-- === Inline C statements+--+-- @+-- {-\# LANGUAGE QuasiQuotes \#-}+-- {-\# LANGUAGE TemplateHaskell \#-}+-- import qualified Data.Vector.Storable.Mutable as V+-- import qualified "Language.C.Inline" as C+-- import "Foreign.C.Types"+--+-- C.'include' "\<stdio.h\>"+--+-- parseVector :: 'CInt' -> 'IO' (V.IOVector 'CDouble')+-- parseVector len = do+-- vec <- V.new $ 'fromIntegral' len0+-- V.unsafeWith vec $ \\ptr -> [C.'block'| void {+-- int i;+-- for (i = 0; i < $(int len); i++) {+-- scanf("%lf ", &$(double *ptr)[i]);+-- }+-- } |]+-- 'return' vec+-- @++-- | C expressions.+exp :: TH.QuasiQuoter+exp = genericQuote IO $ inlineExp TH.Safe++-- | Variant of 'exp', for use with expressions known to have no side effects.+--+-- BEWARE: use this function with caution, only when you know what you are+-- doing. If an expression does in fact have side-effects, then indiscriminate+-- use of 'pure' may endanger referential transparency, and in principle even+-- type safety.+pure :: TH.QuasiQuoter+pure = genericQuote Pure $ inlineExp TH.Safe++-- | C code blocks (i.e. statements).+block :: TH.QuasiQuoter+block = genericQuote IO $ inlineItems TH.Safe++-- | Emits a CPP include directive for C code associated with the current+-- module. To avoid having to escape quotes, the function itself adds them when+-- appropriate, so that+--+-- @+-- include "foo.h" ==> #include "foo.h"+-- @+--+-- but+--+-- @+-- include "\<foo\>" ==> #include \<foo\>+-- @+include :: String -> TH.DecsQ+include s+ | null s = error "inline-c: empty string (include)"+ | head s == '<' = verbatim $ "#include " ++ s+ | otherwise = verbatim $ "#include \"" ++ s ++ "\""++-- | Emits an arbitrary C string to the C code associated with the+-- current module. Use with care.+verbatim :: String -> TH.DecsQ+verbatim s = do+ void $ emitVerbatim s+ return []++------------------------------------------------------------------------+-- 'Ptr' utils++-- | Like 'alloca', but also peeks the contents of the 'Ptr' and returns+-- them once the provided action has finished.+withPtr :: (Storable a) => (Ptr a -> IO b) -> IO (a, b)+withPtr f = do+ alloca $ \ptr -> do+ x <- f ptr+ y <- peek ptr+ return (y, x)++withPtr_ :: (Storable a) => (Ptr a -> IO ()) -> IO a+withPtr_ f = do+ (x, ()) <- withPtr f+ return x++-- | Type class with methods useful to allocate and peek multiple+-- pointers at once:+--+-- @+-- withPtrs_ :: (Storable a, Storable b) => ((Ptr a, Ptr b) -> IO ()) -> IO (a, b)+-- withPtrs_ :: (Storable a, Storable b, Storable c) => ((Ptr a, Ptr b, Ptr c) -> IO ()) -> IO (a, b, c)+-- ...+-- @+class WithPtrs a where+ type WithPtrsPtrs a :: *+ withPtrs :: (WithPtrsPtrs a -> IO b) -> IO (a, b)++ withPtrs_ :: (WithPtrsPtrs a -> IO ()) -> IO a+ withPtrs_ f = do+ (x, _) <- withPtrs f+ return x++instance (Storable a, Storable b) => WithPtrs (a, b) where+ type WithPtrsPtrs (a, b) = (Ptr a, Ptr b)+ withPtrs f = do+ (a, (b, x)) <- withPtr $ \a -> withPtr $ \b -> f (a, b)+ return ((a, b), x)++instance (Storable a, Storable b, Storable c) => WithPtrs (a, b, c) where+ type WithPtrsPtrs (a, b, c) = (Ptr a, Ptr b, Ptr c)+ withPtrs f = do+ (a, ((b, c), x)) <- withPtr $ \a -> withPtrs $ \(b, c) -> f (a, b, c)+ return ((a, b, c), x)++instance (Storable a, Storable b, Storable c, Storable d) => WithPtrs (a, b, c, d) where+ type WithPtrsPtrs (a, b, c, d) = (Ptr a, Ptr b, Ptr c, Ptr d)+ withPtrs f = do+ (a, ((b, c, d), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d) -> f (a, b, c, d)+ return ((a, b, c, d), x)++instance (Storable a, Storable b, Storable c, Storable d, Storable e) => WithPtrs (a, b, c, d, e) where+ type WithPtrsPtrs (a, b, c, d, e) = (Ptr a, Ptr b, Ptr c, Ptr d, Ptr e)+ withPtrs f = do+ (a, ((b, c, d, e), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d, e) -> f (a, b, c, d, e)+ return ((a, b, c, d, e), x)++instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => WithPtrs (a, b, c, d, e, f) where+ type WithPtrsPtrs (a, b, c, d, e, f) = (Ptr a, Ptr b, Ptr c, Ptr d, Ptr e, Ptr f)+ withPtrs fun = do+ (a, ((b, c, d, e, f), x)) <- withPtr $ \a -> withPtrs $ \(b, c, d, e, f) -> fun (a, b, c, d, e, f)+ return ((a, b, c, d, e, f), x)++instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => WithPtrs (a, b, c, d, e, f, g) where+ type WithPtrsPtrs (a, b, c, d, e, f, g) = (Ptr a, Ptr b, Ptr c, Ptr d, Ptr e, Ptr f, Ptr g)+ withPtrs fun = do+ (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)+ return ((a, b, c, d, e, f, g), x)++------------------------------------------------------------------------+-- setContext alias++-- | Sets the 'Context' for the current module. This function, if+-- called, must be called before any of the other TH functions in this+-- module. Fails if that's not the case.+context :: Context -> TH.DecsQ+context ctx = do+ setContext ctx+ return []
+ src/Language/C/Inline/Context.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | A 'Context' is used to define the capabilities of the Template Haskell code+-- that handles the inline C code. See the documentation of the data type for+-- more details.+--+-- In practice, a 'Context' will have to be defined for each library that+-- defines new C types, to allow the TemplateHaskell code to interpret said+-- types correctly.++module Language.C.Inline.Context+ ( -- * 'TypesTable'+ TypesTable+ , Purity(..)+ , convertType+ , CArray+ , isTypeName++ -- * 'AntiQuoter'+ , AntiQuoter(..)+ , AntiQuoterId+ , SomeAntiQuoter(..)+ , AntiQuoters++ -- * 'Context'+ , Context(..)+ , baseCtx+ , funCtx+ , vecCtx+ , VecCtx(..)+ , bsCtx+ ) where++import Control.Applicative ((<|>))+import Control.Monad (mzero)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.Map as Map+import Data.Monoid ((<>))+import Data.Typeable (Typeable)+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as VM+import Foreign.C.Types+import Foreign.Ptr (Ptr, FunPtr, castPtr)+import Foreign.Storable (Storable)+import qualified Language.Haskell.TH as TH+import qualified Text.Parser.Token as Parser++#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (Monoid(..))+#endif++import Language.C.Inline.FunPtr+import qualified Language.C.Types as C++-- | A mapping from 'C.TypeSpecifier's to Haskell types. Needed both to+-- parse C types, and to convert them to Haskell types.+type TypesTable = Map.Map C.TypeSpecifier TH.TypeQ++-- | A data type to indicate whether the user requested pure or IO+-- function from Haskell+data Purity+ = Pure+ | IO+ deriving (Eq, Show)++-- | Specifies how to parse and process an antiquotation in the C code.+--+-- All antiquotations (apart from plain variable capture) have syntax+--+-- @+-- $XXX:YYY+-- @+--+-- Where @XXX@ is the name of the antiquoter and @YYY@ is something+-- parseable by the respective 'aqParser'.+data AntiQuoter a = AntiQuoter+ { aqParser :: forall m. C.CParser m => m (String, C.Type, a)+ -- ^ Parses the body of the antiquotation, returning a hint for the name to+ -- assign to the variable that will replace the anti-quotation, the type of+ -- said variable, and some arbitrary data which will then be fed to+ -- 'aqMarshaller'.+ , aqMarshaller :: Purity -> TypesTable -> C.Type -> a -> TH.Q (TH.Type, TH.Exp)+ -- ^ Takes the requested purity, the current 'TypesTable', and the+ -- type and the body returned by 'aqParser'.+ --+ -- Returns the Haskell type for the parameter, and the Haskell expression+ -- that will be passed in as the parameter.+ --+ -- If the the type returned is @ty@, the 'TH.Exp' __must__ have type @forall+ -- a. (ty -> IO a) -> IO a@. This allows to do resource handling when+ -- preparing C values.+ --+ -- Care must be taken regarding 'Purity'. Specifically, the generated IO+ -- computation must be idempotent to guarantee its safety when used in pure+ -- code. We cannot prevent the IO computation from being inlined, hence+ -- potentially duplicated. If non-idempotent marshallers are required (e.g.+ -- if an update to some global state is needed), it is best to throw an+ -- error when 'Purity' is 'Pure' (for example "you cannot use context X with+ -- @pure@"), which will show up at compile time.+ }++-- | An identifier for a 'AntiQuoter'.+type AntiQuoterId = String++-- | Existential wrapper around 'AntiQuoter'.+data SomeAntiQuoter = forall a. (Eq a, Typeable a) => SomeAntiQuoter (AntiQuoter a)++type AntiQuoters = Map.Map AntiQuoterId SomeAntiQuoter++-- | A 'Context' stores various information needed to produce the files with+-- the C code derived from the inline C snippets.+--+-- 'Context's can be composed with their 'Monoid' instance, where 'mappend' is+-- right-biased -- in @'mappend' x y@ @y@ will take precedence over @x@.+data Context = Context+ { ctxTypesTable :: TypesTable+ -- ^ Needed to convert C types to Haskell types.+ , ctxAntiQuoters :: AntiQuoters+ -- ^ Needed to parse and process antiquotations.+ , ctxFileExtension :: Maybe String+ -- ^ Will determine the extension of the file containing the inline+ -- C snippets.+ , ctxOutput :: Maybe (String -> String)+ -- ^ This function is used to post-process the functions generated+ -- from the C snippets. Currently just used to specify C linkage+ -- when generating C++ code.+ }++instance Monoid Context where+ mempty = Context+ { ctxTypesTable = mempty+ , ctxAntiQuoters = mempty+ , ctxFileExtension = Nothing+ , ctxOutput = Nothing+ }++ mappend ctx2 ctx1 = Context+ { ctxTypesTable = ctxTypesTable ctx1 <> ctxTypesTable ctx2+ , ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2+ , ctxFileExtension = ctxFileExtension ctx1 <|> ctxFileExtension ctx2+ , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2+ }++-- | Context useful to work with vanilla C. Used by default.+--+-- 'ctxTypesTable': converts C basic types to their counterparts in+-- "Foreign.C.Types".+--+-- No 'ctxAntiQuoters'.+baseCtx :: Context+baseCtx = mempty+ { ctxTypesTable = baseTypesTable+ }++baseTypesTable :: Map.Map C.TypeSpecifier TH.TypeQ+baseTypesTable = Map.fromList+ [ (C.Void, [t| () |])+ , (C.Char Nothing, [t| CChar |])+ , (C.Char (Just C.Signed), [t| CChar |])+ , (C.Char (Just C.Unsigned), [t| CUChar |])+ , (C.Short C.Signed, [t| CShort |])+ , (C.Short C.Unsigned, [t| CUShort |])+ , (C.Int C.Signed, [t| CInt |])+ , (C.Int C.Unsigned, [t| CUInt |])+ , (C.Long C.Signed, [t| CLong |])+ , (C.Long C.Unsigned, [t| CULong |])+ , (C.LLong C.Signed, [t| CLLong |])+ , (C.LLong C.Unsigned, [t| CULLong |])+ , (C.Float, [t| CFloat |])+ , (C.Double, [t| CDouble |])+ ]++-- | An alias for 'Ptr'.+type CArray = Ptr++------------------------------------------------------------------------+-- Type conversion++-- | Given a 'Context', it uses its 'ctxTypesTable' to convert+-- arbitrary C types.+convertType+ :: Purity+ -> TypesTable+ -> C.Type+ -> TH.Q (Maybe TH.Type)+convertType purity cTypes = runMaybeT . go+ where+ goDecl = go . C.parameterDeclarationType++ go :: C.Type -> MaybeT TH.Q TH.Type+ go cTy = case cTy of+ C.TypeSpecifier _specs cSpec ->+ case Map.lookup cSpec cTypes of+ Nothing -> mzero+ Just ty -> lift ty+ C.Ptr _quals (C.Proto retType pars) -> do+ hsRetType <- go retType+ hsPars <- mapM goDecl pars+ lift [t| FunPtr $(buildArr hsPars hsRetType) |]+ C.Ptr _quals cTy' -> do+ hsTy <- go cTy'+ lift [t| Ptr $(return hsTy) |]+ C.Array _mbSize cTy' -> do+ hsTy <- go cTy'+ lift [t| CArray $(return hsTy) |]+ C.Proto _retType _pars -> do+ -- We cannot convert standalone prototypes+ mzero++ buildArr [] hsRetType =+ case purity of+ Pure -> [t| $(return hsRetType) |]+ IO -> [t| IO $(return hsRetType) |]+ buildArr (hsPar : hsPars) hsRetType =+ [t| $(return hsPar) -> $(buildArr hsPars hsRetType) |]++isTypeName :: TypesTable -> C.Identifier -> Bool+isTypeName cTypes id' = Map.member (C.TypeName id') cTypes++------------------------------------------------------------------------+-- Useful contexts++getHsVariable :: String -> String -> TH.ExpQ+getHsVariable err s = do+ mbHsName <- TH.lookupValueName s+ case mbHsName of+ Nothing -> error $ "Cannot capture Haskell variable " ++ s +++ ", because it's not in scope. (" ++ err ++ ")"+ Just hsName -> TH.varE hsName++convertType_ :: String -> Purity -> TypesTable -> C.Type -> TH.Q TH.Type+convertType_ err purity cTypes cTy = do+ mbHsType <- convertType purity cTypes cTy+ case mbHsType of+ Nothing -> error $ "Cannot convert C type (" ++ err ++ ")"+ Just hsType -> return hsType++-- | This 'Context' includes a 'AntiQuoter' that removes the need for+-- explicitely creating 'FunPtr's, named @"fun"@.+--+-- For example, we can capture function @f@ of type @CInt -> CInt -> IO+-- CInt@ in C code using @$fun:(int (*f)(int, int))@.+--+-- When used in a @pure@ embedding, the Haskell function will have to be+-- pure too. Continuing the example above we'll have @CInt -> CInt ->+-- IO CInt@.+--+-- Does not include the 'baseCtx', since most of the time it's going to+-- be included as part of larger contexts.+funCtx :: Context+funCtx = mempty+ { ctxAntiQuoters = Map.fromList [("fun", SomeAntiQuoter funPtrAntiQuoter)]+ }++funPtrAntiQuoter :: AntiQuoter String+funPtrAntiQuoter = AntiQuoter+ { aqParser = do+ cTy <- Parser.parens C.parseParameterDeclaration+ case C.parameterDeclarationId cTy of+ Nothing -> error "Every captured function must be named (funCtx)"+ Just id' -> do+ let s = C.unIdentifier id'+ return (s, C.parameterDeclarationType cTy, s)+ , aqMarshaller = \purity cTypes cTy cId -> do+ hsTy <- convertType_ "funCtx" purity cTypes cTy+ hsExp <- getHsVariable "funCtx" cId+ case hsTy of+ TH.AppT (TH.ConT n) hsTy' | n == ''FunPtr -> do+ hsExp' <- [| \cont -> cont =<< $(mkFunPtr (return hsTy')) $(return hsExp) |]+ return (hsTy, hsExp')+ _ -> error "The `fun' marshaller captures function pointers only"+ }++-- | This 'Context' includes two 'AntiQuoter's that allow to easily use+-- Haskell vectors in C.+--+-- Specifically, the @vec-len@ and @vec-ptr@ will get the length and the+-- pointer underlying mutable ('V.IOVector') and immutable ('V.Vector')+-- storable vectors.+--+-- Note that if you use 'vecCtx' to manipulate immutable vectors you+-- must make sure that the vector is not modified in the C code.+--+-- To use @vec-len@, simply write @$vec-len:x@, where @x@ is something+-- of type @'V.IOVector' a@ or @'V.Vector' a@, for some @a@. To use+-- @vec-ptr@ you need to specify the type of the pointer,+-- e.g. @$vec-len:(int *x)@ will work if @x@ has type @'V.IOVector'+-- 'CInt'@.+vecCtx :: Context+vecCtx = mempty+ { ctxAntiQuoters = Map.fromList+ [ ("vec-ptr", SomeAntiQuoter vecPtrAntiQuoter)+ , ("vec-len", SomeAntiQuoter vecLenAntiQuoter)+ ]+ }++-- | Type class used to implement the anti-quoters in 'vecCtx'.+class VecCtx a where+ type VecCtxScalar a :: *++ vecCtxLength :: a -> Int+ vecCtxUnsafeWith :: a -> (Ptr (VecCtxScalar a) -> IO b) -> IO b++instance Storable a => VecCtx (V.Vector a) where+ type VecCtxScalar (V.Vector a) = a++ vecCtxLength = V.length+ vecCtxUnsafeWith = V.unsafeWith++instance Storable a => VecCtx (VM.IOVector a) where+ type VecCtxScalar (VM.IOVector a) = a++ vecCtxLength = VM.length+ vecCtxUnsafeWith = VM.unsafeWith++vecPtrAntiQuoter :: AntiQuoter String+vecPtrAntiQuoter = AntiQuoter+ { aqParser = do+ cTy <- Parser.parens C.parseParameterDeclaration+ case C.parameterDeclarationId cTy of+ Nothing -> error "Every captured vector must be named (vecCtx)"+ Just id' -> do+ let s = C.unIdentifier id'+ return (s, C.parameterDeclarationType cTy, s)+ , aqMarshaller = \purity cTypes cTy cId -> do+ hsTy <- convertType_ "vecCtx" purity cTypes cTy+ hsExp <- getHsVariable "vecCtx" cId+ hsExp' <- [| vecCtxUnsafeWith $(return hsExp) |]+ return (hsTy, hsExp')+ }++vecLenAntiQuoter :: AntiQuoter String+vecLenAntiQuoter = AntiQuoter+ { aqParser = do+ cId <- C.parseIdentifier+ let s = C.unIdentifier cId+ return (s, C.TypeSpecifier mempty (C.Long C.Signed), s)+ , aqMarshaller = \_purity _cTypes cTy cId -> do+ case cTy of+ C.TypeSpecifier _ (C.Long C.Signed) -> do+ hsExp <- getHsVariable "vecCtx" cId+ hsExp' <- [| fromIntegral (vecCtxLength $(return hsExp)) |]+ hsTy <- [t| CLong |]+ hsExp'' <- [| \cont -> cont $(return hsExp') |]+ return (hsTy, hsExp'')+ _ -> do+ error "impossible: got type different from `long' (vecCtx)"+ }+++-- | 'bsCtx' serves exactly the same purpose as 'vecCtx', but only for+-- 'BS.ByteString'. @vec-ptr@ becomes @bs-ptr@, and @vec-len@ becomes+-- @bs-len@. You don't need to specify the type of the pointer in+-- @bs-ptr@, it will always be @unsigned char*@.+bsCtx :: Context+bsCtx = mempty+ { ctxAntiQuoters = Map.fromList+ [ ("bs-ptr", SomeAntiQuoter bsPtrAntiQuoter)+ , ("bs-len", SomeAntiQuoter bsLenAntiQuoter)+ ]+ }++bsPtrAntiQuoter :: AntiQuoter String+bsPtrAntiQuoter = AntiQuoter+ { aqParser = do+ cId <- C.parseIdentifier+ let s = C.unIdentifier cId+ return (s, C.Ptr [] (C.TypeSpecifier mempty (C.Char (Just C.Unsigned))), s)+ , aqMarshaller = \_purity _cTypes cTy cId -> do+ case cTy of+ C.Ptr _ (C.TypeSpecifier _ (C.Char (Just C.Unsigned))) -> do+ hsTy <- [t| Ptr CUChar |]+ hsExp <- getHsVariable "bsCtx" cId+ hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont (castPtr ptr) |]+ return (hsTy, hsExp')+ _ ->+ error "impossible: got type different from `unsigned char' (bsCtx)"+ }++bsLenAntiQuoter :: AntiQuoter String+bsLenAntiQuoter = AntiQuoter+ { aqParser = do+ cId <- C.parseIdentifier+ let s = C.unIdentifier cId+ return (s, C.TypeSpecifier mempty (C.Long C.Signed), s)+ , aqMarshaller = \_purity _cTypes cTy cId -> do+ case cTy of+ C.TypeSpecifier _ (C.Long C.Signed) -> do+ hsExp <- getHsVariable "bsCtx" cId+ hsExp' <- [| fromIntegral (BS.length $(return hsExp)) |]+ hsTy <- [t| CLong |]+ hsExp'' <- [| \cont -> cont $(return hsExp') |]+ return (hsTy, hsExp'')+ _ -> do+ error "impossible: got type different from `long' (bsCtx)"+ }
+ src/Language/C/Inline/FunPtr.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Language.C.Inline.FunPtr+ ( mkFunPtr+ , mkFunPtrFromName+ , peekFunPtr+ , uniqueFfiImportName+ ) where++import Foreign.Ptr (FunPtr)+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH++------------------------------------------------------------------------+-- FFI wrappers++-- | @$('mkFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |] @ generates a foreign import+-- wrapper of type+--+-- @+-- ('CDouble' -> 'IO' 'CDouble') -> 'IO' ('FunPtr' ('CDouble' -> 'IO' 'CDouble'))+-- @+--+-- And invokes it.+mkFunPtr :: TH.TypeQ -> TH.ExpQ+mkFunPtr hsTy = do+ ffiImportName <- uniqueFfiImportName+ dec <- TH.forImpD TH.CCall TH.Safe "wrapper" ffiImportName [t| $(hsTy) -> IO (FunPtr $(hsTy)) |]+ TH.addTopDecls [dec]+ TH.varE ffiImportName++-- | @$('mkFunPtrFromName' 'foo)@, if @foo :: 'CDouble' -> 'IO'+-- 'CDouble'@, splices in an expression of type @'IO' ('FunPtr'+-- ('CDouble' -> 'IO' 'CDouble'))@.+mkFunPtrFromName :: TH.Name -> TH.ExpQ+mkFunPtrFromName name = do+ i <- TH.reify name+ case i of+ TH.VarI _ ty _ _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |]+ _ -> error "mkFunPtrFromName: expecting a variable as argument."++-- | @$('peekFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |])@ generates a foreign import+-- dynamic of type+--+-- @+-- 'FunPtr' ('CDouble' -> 'IO' 'CDouble') -> ('CDouble' -> 'IO' 'CDouble')+-- @+--+-- And invokes it.+peekFunPtr :: TH.TypeQ -> TH.ExpQ+peekFunPtr hsTy = do+ ffiImportName <- uniqueFfiImportName+ dec <- TH.forImpD TH.CCall TH.Safe "dynamic" ffiImportName [t| FunPtr $(hsTy) -> $(hsTy) |]+ TH.addTopDecls [dec]+ TH.varE ffiImportName++-- TODO absurdly, I need to 'newName' twice for things to work. I found+-- this hack in language-c-inline. Why is this?+uniqueFfiImportName :: TH.Q TH.Name+uniqueFfiImportName = TH.newName . show =<< TH.newName "inline_c_ffi"
+ src/Language/C/Inline/Internal.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}++module Language.C.Inline.Internal+ ( -- * Context handling+ setContext+ , getContext++ -- * Emitting and invoking C code+ --+ -- | The functions in this section let us access more the C file+ -- associated with the current module. They can be used to build+ -- additional features on top of the basic machinery. All of+ -- @inline-c@ is based upon the functions defined here.++ -- ** Emitting C code+ , emitVerbatim++ -- ** Inlining C code+ -- $embedding+ , Code(..)+ , inlineCode+ , inlineExp+ , inlineItems++ -- * Parsing+ --+ -- | These functions are used to parse the anti-quotations. They're+ -- exposed for testing purposes, you really should not use them.+ , SomeEq+ , toSomeEq+ , fromSomeEq+ , ParameterType(..)+ , ParseTypedC(..)+ , parseTypedC+ , runParserInQ++ -- * Utility functions for writing quasiquoters+ , genericQuote+ ) where++import Control.Applicative+import Control.Exception (catch, throwIO)+import Control.Monad (forM, void, msum, when, unless)+import Control.Monad.State (evalStateT, StateT, get, put)+import Control.Monad.Trans.Class (lift)+import qualified Crypto.Hash as CryptoHash+import qualified Data.Binary as Binary+import Data.Foldable (forM_)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Typeable (Typeable, cast)+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TH+import qualified Language.Haskell.TH.Syntax as TH+import System.Directory (removeFile)+import System.FilePath (addExtension, dropExtension)+import System.IO.Error (isDoesNotExistError)+import System.IO.Unsafe (unsafePerformIO)+import qualified Text.Parsec as Parsec+import qualified Text.Parsec.Pos as Parsec+import qualified Text.Parser.Char as Parser+import qualified Text.Parser.Combinators as Parser+import qualified Text.Parser.LookAhead as Parser+import qualified Text.Parser.Token as Parser+import Text.PrettyPrint.ANSI.Leijen ((<+>))+import qualified Text.PrettyPrint.ANSI.Leijen as PP++import qualified Language.C.Types as C+import Language.C.Inline.Context+import Language.C.Inline.FunPtr++data ModuleState = ModuleState+ { msModuleName :: String+ , msContext :: Context+ , msGeneratedNames :: Int+ }++{-# NOINLINE moduleStateRef #-}+moduleStateRef :: IORef (Maybe ModuleState)+moduleStateRef = unsafePerformIO $ newIORef Nothing++-- | Make sure that 'moduleStateRef' and the respective C file are up+-- to date.+initialiseModuleState+ :: Maybe Context+ -- ^ The 'Context' to use if we initialise the module. If 'Nothing',+ -- 'baseCtx' will be used.+ -> TH.Q Context+initialiseModuleState mbContext = do+ cFile <- cSourceLoc context+ mbModuleState <- TH.runIO $ readIORef moduleStateRef+ thisModule <- TH.loc_module <$> TH.location+ let recordThisModule = TH.runIO $ do+ -- If the file exists and this is the first time we write+ -- something from this module (in other words, if we are+ -- recompiling the module), kill the file first.+ removeIfExists cFile+ writeIORef moduleStateRef $ Just ModuleState+ { msModuleName = thisModule+ , msContext = context+ , msGeneratedNames = 0+ }+ return context+ case mbModuleState of+ Nothing -> recordThisModule+ Just ms | msModuleName ms == thisModule -> return $ msContext ms+ Just _ms -> recordThisModule+ where+ context = fromMaybe baseCtx mbContext++-- | Gets the current 'Context'. Also makes sure that the current+-- module is initialised.+getContext :: TH.Q Context+getContext = initialiseModuleState Nothing++getModuleState :: TH.Q ModuleState+getModuleState = do+ mbModuleState <- TH.runIO $ readIORef moduleStateRef+ thisModule <- TH.loc_module <$> TH.location+ case mbModuleState of+ Nothing -> error "inline-c: ModuleState not present"+ Just ms | msModuleName ms == thisModule -> return ms+ Just _ms -> error "inline-c: stale ModuleState"++-- $context+--+-- The inline C functions ('cexp', 'c', etc.) need a 'Context' to+-- operate. Said context can be explicitely set with 'setContext'.+-- Otherwise, at the first usage of one of the TH functions in this+-- module the 'Context' is implicitely set to 'baseCtx'.++-- | Sets the 'Context' for the current module. This function, if+-- called, must be called before any of the other TH functions in this+-- module. Fails if that's not the case.+setContext :: Context -> TH.Q ()+setContext ctx = do+ mbModuleState <- TH.runIO $ readIORef moduleStateRef+ forM_ mbModuleState $ \ms -> do+ thisModule <- TH.loc_module <$> TH.location+ when (msModuleName ms == thisModule) $+ error "inline-c: The module has already been initialised (setContext)."+ void $ initialiseModuleState $ Just ctx++bumpGeneratedNames :: TH.Q Int+bumpGeneratedNames = do+ ms <- getModuleState+ TH.runIO $ do+ let c' = msGeneratedNames ms+ writeIORef moduleStateRef $ Just ms{msGeneratedNames = c' + 1}+ return c'++------------------------------------------------------------------------+-- Emitting++cSourceLoc :: Context -> TH.Q FilePath+cSourceLoc ctx = do+ thisFile <- TH.loc_filename <$> TH.location+ let ext = fromMaybe "c" $ ctxFileExtension ctx+ return $ dropExtension thisFile `addExtension` ext++removeIfExists :: FilePath -> IO ()+removeIfExists fileName = removeFile fileName `catch` handleExists+ where+ handleExists e = unless (isDoesNotExistError e) $ throwIO e++-- | Simply appends some string to the module's C file. Use with care.+emitVerbatim :: String -> TH.DecsQ+emitVerbatim s = do+ ctx <- getContext+ cFile <- cSourceLoc ctx+ TH.runIO $ appendFile cFile $ "\n" ++ s ++ "\n"+ return []++------------------------------------------------------------------------+-- Inlining++-- $embedding+--+-- We use the 'Code' data structure to represent some C code that we+-- want to emit to the module's C file and immediately generate a+-- foreign call to. For this reason, 'Code' includes both some C+-- definition, and enough information to be able to generate a foreign+-- call -- specifically the name of the function to call and the Haskell+-- type.+--+-- All the quasi-quoters work by constructing a 'Code' and calling+-- 'inlineCode'.++-- | Data type representing a list of C definitions with a typed and named entry+-- function.+--+-- We use it as a basis to inline and call C code.+data Code = Code+ { codeCallSafety :: TH.Safety+ -- ^ Safety of the foreign call.+ , codeType :: TH.TypeQ+ -- ^ Type of the foreign call.+ , codeFunName :: String+ -- ^ Name of the function to call in the code below.+ , codeDefs :: String+ -- ^ The C code.+ }++-- TODO use the #line CPP macro to have the functions in the C file+-- refer to the source location in the Haskell file they come from.+--+-- See <https://gcc.gnu.org/onlinedocs/cpp/Line-Control.html>.++-- | Inlines a piece of code inline. The resulting 'TH.Exp' will have+-- the type specified in the 'codeType'.+--+-- In practice, this function outputs the C code to the module's C file,+-- and then inserts a foreign call of type 'codeType' calling the+-- provided 'codeFunName'.+--+-- Example:+--+-- @+-- c_add :: Int -> Int -> Int+-- c_add = $(inlineCode $ Code+-- TH.Unsafe -- Call safety+-- [t| Int -> Int -> Int |] -- Call type+-- "francescos_add" -- Call name+-- -- C Code+-- \"int francescos_add(int x, int y) { int z = x + y; return z; }\")+-- @+inlineCode :: Code -> TH.ExpQ+inlineCode Code{..} = do+ -- Write out definitions+ ctx <- getContext+ let out = fromMaybe id $ ctxOutput ctx+ void $ emitVerbatim $ out codeDefs+ -- Create and add the FFI declaration.+ ffiImportName <- uniqueFfiImportName+ dec <- TH.forImpD TH.CCall codeCallSafety codeFunName ffiImportName codeType+ TH.addTopDecls [dec]+ TH.varE ffiImportName++uniqueCName :: String -> TH.Q String+uniqueCName x = do+ c' <- bumpGeneratedNames+ let unique :: CryptoHash.Digest CryptoHash.SHA1 = CryptoHash.hashlazy $ Binary.encode x+ return $ "inline_c_" ++ show c' ++ "_" ++ show unique++-- | Same as 'inlineCItems', but with a single expression.+--+-- @+-- c_cos :: Double -> Double+-- c_cos = $(inlineExp+-- TH.Unsafe+-- [t| Double -> Double |]+-- (quickCParser_ \"double\" parseType)+-- [("x", quickCParser_ \"double\") parseType]+-- "cos(x)")+-- @+inlineExp+ :: TH.Safety+ -- ^ Safety of the foreign call+ -> TH.TypeQ+ -- ^ Type of the foreign call+ -> C.Type+ -- ^ Return type of the C expr+ -> [(C.Identifier, C.Type)]+ -- ^ Parameters of the C expr+ -> String+ -- ^ The C expression+ -> TH.ExpQ+inlineExp callSafety type_ cRetType cParams cExp =+ inlineItems callSafety type_ cRetType cParams cItems+ where+ cItems = case cRetType of+ C.TypeSpecifier _quals C.Void -> cExp ++ ";"+ _ -> "return (" ++ cExp ++ ");"++-- | Same as 'inlineCode', but accepts a string containing a list of C+-- statements instead instead than a full-blown 'Code'. A function+-- containing the provided statement will be automatically generated.+--+-- @+-- c_cos :: Double -> Double+-- c_cos = $(inlineItems+-- TH.Unsafe+-- [t| Double -> Double |]+-- (quickCParser_ \"double\" parseType)+-- [("x", quickCParser_ \"double\" parseType)]+-- "return cos(x);")+-- @+inlineItems+ :: TH.Safety+ -- ^ Safety of the foreign call+ -> TH.TypeQ+ -- ^ Type of the foreign call+ -> C.Type+ -- ^ Return type of the C expr+ -> [(C.Identifier, C.Type)]+ -- ^ Parameters of the C expr+ -> String+ -- ^ The C items+ -> TH.ExpQ+inlineItems callSafety type_ cRetType cParams cItems = do+ let mkParam (id', paramTy) = C.ParameterDeclaration (Just id') paramTy+ let proto = C.Proto cRetType (map mkParam cParams)+ funName <- uniqueCName $ show proto ++ cItems+ let decl = C.ParameterDeclaration (Just (C.Identifier funName)) proto+ let defs =+ prettyOneLine decl ++ " {\n" +++ cItems ++ "\n}\n"+ inlineCode $ Code+ { codeCallSafety = callSafety+ , codeType = type_+ , codeFunName = funName+ , codeDefs = defs+ }++------------------------------------------------------------------------+-- Parsing++runParserInQ+ :: String -> C.IsTypeName -> (forall m. C.CParser m => m a) -> TH.Q a+runParserInQ s isTypeName' p = do+ loc <- TH.location+ let (line, col) = TH.loc_start loc+ let parsecLoc = Parsec.newPos (TH.loc_filename loc) line col+ let p' = lift (Parsec.setPosition parsecLoc) *> p <* lift Parser.eof+ case C.runCParser isTypeName' (TH.loc_filename loc) s p' of+ Left err -> do+ -- TODO consider prefixing with "error while parsing C" or similar+ error $ show err+ Right res -> do+ return res++data SomeEq = forall a. (Typeable a, Eq a) => SomeEq a++instance Eq SomeEq where+ SomeEq x == SomeEq y = case cast x of+ Nothing -> False+ Just x' -> x' == y++instance Show SomeEq where+ show _ = "<<SomeEq>>"++toSomeEq :: (Eq a, Typeable a) => a -> SomeEq+toSomeEq x = SomeEq x++fromSomeEq :: (Eq a, Typeable a) => SomeEq -> Maybe a+fromSomeEq (SomeEq x) = cast x++data ParameterType+ = Plain String -- The name of the captured variable+ | AntiQuote AntiQuoterId SomeEq+ deriving (Show, Eq)++data ParseTypedC = ParseTypedC+ { ptcReturnType :: C.Type+ , ptcParameters :: [(C.Identifier, C.Type, ParameterType)]+ , ptcBody :: String+ }++parseTypedC+ :: forall m. C.CParser m+ => AntiQuoters -> m ParseTypedC+ -- ^ Returns the return type, the captured variables, and the body.+parseTypedC antiQs = do+ -- Parse return type (consume spaces first)+ Parser.spaces+ cRetType <- C.parseType+ -- Parse the body+ void $ Parser.char '{'+ (cParams, cBody) <- evalStateT parseBody 0+ return $ ParseTypedC cRetType cParams cBody+ where+ parseBody :: StateT Int m ([(C.Identifier, C.Type, ParameterType)], String)+ parseBody = do+ -- Note that this code does not use "lexing" combinators (apart+ -- when appropriate) because we want to make sure to preserve+ -- whitespace after we substitute things.+ s <- Parser.manyTill Parser.anyChar $+ Parser.lookAhead (Parser.char '}' <|> Parser.char '$')+ let parseEscapedDollar = do+ void $ Parser.char '$'+ return ([], "$")+ let parseTypedCapture = do+ void $ Parser.symbolic '('+ decl <- C.parseParameterDeclaration+ s' <- case C.parameterDeclarationId decl of+ Nothing -> fail $ pretty80 $+ "Un-named captured variable in decl" <+> PP.pretty decl+ Just id' -> return $ C.unIdentifier id'+ id' <- freshId s'+ void $ Parser.char ')'+ return ([(id', C.parameterDeclarationType decl, Plain s')], C.unIdentifier id')+ (decls, s') <- msum+ [ do Parser.try $ do -- Try because we might fail to parse the 'eof'+ -- 'symbolic' because we want to consume whitespace+ void $ Parser.symbolic '}'+ Parser.eof+ return ([], "")+ , do void $ Parser.char '}'+ (decls, s') <- parseBody+ return (decls, "}" ++ s')+ , do void $ Parser.char '$'+ (decls1, s1) <- parseEscapedDollar <|> parseAntiQuote <|> parseTypedCapture+ (decls2, s2) <- parseBody+ return (decls1 ++ decls2, s1 ++ s2)+ ]+ return (decls, s ++ s')+ where++ parseAntiQuote :: StateT Int m ([(C.Identifier, C.Type, ParameterType)], String)+ parseAntiQuote = msum+ [ do void $ Parser.try (Parser.string $ antiQId ++ ":") Parser.<?> "anti quoter id"+ (s, cTy, x) <- aqParser antiQ+ id' <- freshId s+ return ([(id', cTy, AntiQuote antiQId (toSomeEq x))], C.unIdentifier id')+ | (antiQId, SomeAntiQuoter antiQ) <- Map.toList antiQs+ ]++ freshId s = do+ c <- get+ put $ c + 1+ return $ C.Identifier $ s ++ "_inline_c_" ++ show c++quoteCode+ :: (String -> TH.ExpQ)+ -- ^ The parser+ -> TH.QuasiQuoter+quoteCode p = TH.QuasiQuoter+ { TH.quoteExp = p+ , TH.quotePat = error "inline-c: quotePat not implemented (quoteCode)"+ , TH.quoteType = error "inline-c: quoteType not implemented (quoteCode)"+ , TH.quoteDec = error "inline-c: quoteDec not implemented (quoteCode)"+ }++genericQuote+ :: Purity+ -> (TH.TypeQ -> C.Type -> [(C.Identifier, C.Type)] -> String -> TH.ExpQ)+ -- ^ Function taking that something and building an expression, see+ -- 'inlineExp' for other args.+ -> TH.QuasiQuoter+genericQuote purity build = quoteCode $ \s -> do+ ctx <- getContext+ ParseTypedC cType cParams cExp <-+ runParserInQ s (isTypeName (ctxTypesTable ctx)) $ parseTypedC $ ctxAntiQuoters ctx+ hsType <- cToHs ctx cType+ hsParams <- forM cParams $ \(_cId, cTy, parTy) -> do+ case parTy of+ Plain s' -> do+ hsTy <- cToHs ctx cTy+ mbHsName <- TH.lookupValueName s'+ hsExp <- case mbHsName of+ Nothing -> do+ error $ "Cannot capture Haskell variable " ++ s' +++ ", because it's not in scope. (genericQuote)"+ Just hsName -> do+ hsExp <- TH.varE hsName+ [| \cont -> cont $(return hsExp) |]+ return (hsTy, hsExp)+ AntiQuote antiId dyn -> do+ case Map.lookup antiId (ctxAntiQuoters ctx) of+ Nothing ->+ error $ "IMPOSSIBLE: could not find anti-quoter " ++ show antiId +++ ". (genericQuote)"+ Just (SomeAntiQuoter antiQ) -> case fromSomeEq dyn of+ Nothing ->+ error $ "IMPOSSIBLE: could not cast value for anti-quoter " +++ show antiId ++ ". (genericQuote)"+ Just x ->+ aqMarshaller antiQ purity (ctxTypesTable ctx) cTy x+ let hsFunType = convertCFunSig hsType $ map fst hsParams+ let cParams' = [(cId, cTy) | (cId, cTy, _) <- cParams]+ ioCall <- buildFunCall ctx (build hsFunType cType cParams' cExp) (map snd hsParams) []+ -- If the user requested a pure function, make it so.+ case purity of+ Pure -> [| unsafePerformIO $(return ioCall) |]+ IO -> return ioCall+ where+ cToHs :: Context -> C.Type -> TH.TypeQ+ cToHs ctx cTy = do+ mbHsTy <- convertType purity (ctxTypesTable ctx) cTy+ case mbHsTy of+ Nothing -> error $ "Could not resolve Haskell type for C type " ++ pretty80 cTy+ Just hsTy -> return hsTy++ buildFunCall :: Context -> TH.ExpQ -> [TH.Exp] -> [TH.Name] -> TH.ExpQ+ buildFunCall _ctx f [] args =+ foldl (\f' arg -> [| $f' $(TH.varE arg) |]) f args+ buildFunCall ctx f (hsExp : params) args =+ [| $(return hsExp) $ \arg ->+ $(buildFunCall ctx f params (args ++ ['arg]))+ |]++ convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ+ convertCFunSig retType params0 = do+ go params0+ where+ go [] =+ [t| IO $(return retType) |]+ go (paramType : params) = do+ [t| $(return paramType) -> $(go params) |]++------------------------------------------------------------------------+-- Utils++pretty80 :: PP.Pretty a => a -> String+pretty80 x = PP.displayS (PP.renderPretty 0.8 80 (PP.pretty x)) ""++prettyOneLine :: PP.Pretty a => a -> String+prettyOneLine x = PP.displayS (PP.renderCompact (PP.pretty x)) ""
+ src/Language/C/Inline/Unsafe.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE CPP #-}++-- | @unsafe@ variants of the "Language.C.Inline" quasi-quoters, to call the C code+-- unsafely in the sense of+-- <https://www.haskell.org/onlinereport/haskell2010/haskellch8.html#x15-1590008.4.3>.+-- In GHC, unsafe foreign calls are faster than safe foreign calls, but the user+-- must guarantee the control flow will never enter Haskell code (via a callback+-- or otherwise) before the call is done.+--+-- This module is intended to be imported qualified:+--+-- @+-- import qualified "Language.C.Inline.Unsafe" as CU+-- @++module Language.C.Inline.Unsafe+ ( exp+ , pure+ , block+ ) where++#if __GLASGOW_HASKELL__ < 710+import Prelude hiding (exp)+#else+import Prelude hiding (exp, pure)+#endif++import qualified Language.Haskell.TH.Quote as TH+import qualified Language.Haskell.TH.Syntax as TH++import Language.C.Inline.Context+import Language.C.Inline.Internal++-- | C expressions.+exp :: TH.QuasiQuoter+exp = genericQuote IO $ inlineExp TH.Unsafe++-- | Variant of 'exp', for use with expressions known to have no side effects.+--+-- BEWARE: use this function with caution, only when you know what you are+-- doing. If an expression does in fact have side-effects, then indiscriminate+-- use of 'pure' may endanger referential transparency, and in principle even+-- type safety.+pure :: TH.QuasiQuoter+pure = genericQuote Pure $ inlineExp TH.Unsafe++-- | C code blocks (i.e. statements).+block :: TH.QuasiQuoter+block = genericQuote IO $ inlineItems TH.Unsafe
+ src/Language/C/Types.hs view
@@ -0,0 +1,480 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++-- | Views of C datatypes. While "Language.C.Types.Parse" defines datatypes for+-- representing the concrete syntax tree of C types, this module provides+-- friendlier views of C types, by turning them into a data type matching more+-- closely how we read and think about types, both in Haskell and in C. To+-- appreciate the difference, look at the difference between+-- 'P.ParameterDeclaration' and 'ParameterDeclaration'.+--+-- As a bonus, routines are provided for describing types in natural language+-- (English) -- see 'describeParameterDeclaration' and 'describeType'.++module Language.C.Types+ ( -- * Types+ P.Identifier(..)+ , P.StorageClassSpecifier(..)+ , P.TypeQualifier(..)+ , P.FunctionSpecifier(..)+ , P.ArrayType(..)+ , Specifiers(..)+ , Type(..)+ , TypeSpecifier(..)+ , Sign(..)+ , ParameterDeclaration(..)++ -- * Parsing+ , P.IsTypeName+ , P.CParser+ , P.runCParser+ , P.quickCParser+ , P.quickCParser_+ , parseParameterDeclaration+ , parseParameterList+ , parseIdentifier+ , parseType++ -- * Convert to and from high-level views+ , UntangleErr(..)+ , untangleParameterDeclaration+ , tangleParameterDeclaration++ -- * To english+ , describeParameterDeclaration+ , describeType+ ) where++import Control.Arrow (second)+import Control.Monad (when, unless, forM_)+import Control.Monad.State (execState, modify)+import Data.List (partition)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Typeable (Typeable)+import Text.PrettyPrint.ANSI.Leijen ((</>), (<+>))+import qualified Text.PrettyPrint.ANSI.Leijen as PP++#if __GLASGOW_HASKELL__ < 710+import Data.Functor ((<$>))+import Data.Monoid (Monoid(..))+#endif++import qualified Language.C.Types.Parse as P++------------------------------------------------------------------------+-- Proper types++data TypeSpecifier+ = Void+ | Char (Maybe Sign)+ | Short Sign+ | Int Sign+ | Long Sign+ | LLong Sign+ | Float+ | Double+ | LDouble+ | TypeName P.Identifier+ | Struct P.Identifier+ | Enum P.Identifier+ deriving (Typeable, Show, Eq, Ord)++data Specifiers = Specifiers+ { storageClassSpecifiers :: [P.StorageClassSpecifier]+ , typeQualifiers :: [P.TypeQualifier]+ , functionSpecifiers :: [P.FunctionSpecifier]+ } deriving (Typeable, Show, Eq)++instance Monoid Specifiers where+ mempty = Specifiers [] [] []++ mappend (Specifiers x1 y1 z1) (Specifiers x2 y2 z2) =+ Specifiers (x1 ++ x2) (y1 ++ y2) (z1 ++ z2)++data Type+ = TypeSpecifier Specifiers TypeSpecifier+ | Ptr [P.TypeQualifier] Type+ | Array P.ArrayType Type+ | Proto Type [ParameterDeclaration]+ deriving (Typeable, Show, Eq)++data Sign+ = Signed+ | Unsigned+ deriving (Typeable, Show, Eq, Ord)++data ParameterDeclaration = ParameterDeclaration+ { parameterDeclarationId :: Maybe P.Identifier+ , parameterDeclarationType :: Type+ } deriving (Typeable, Show, Eq)++------------------------------------------------------------------------+-- Conversion++data UntangleErr+ = MultipleDataTypes [P.DeclarationSpecifier]+ | NoDataTypes [P.DeclarationSpecifier]+ | IllegalSpecifiers String [P.TypeSpecifier]+ deriving (Typeable, Show, Eq)++failConversion :: UntangleErr -> Either UntangleErr a+failConversion = Left++untangleParameterDeclaration+ :: P.ParameterDeclaration -> Either UntangleErr ParameterDeclaration+untangleParameterDeclaration P.ParameterDeclaration{..} = do+ (specs, tySpec) <- untangleDeclarationSpecifiers parameterDeclarationSpecifiers+ let baseTy = TypeSpecifier specs tySpec+ (mbS, ty) <- case parameterDeclarationDeclarator of+ Left decltor -> do+ (s, ty) <- untangleDeclarator baseTy decltor+ return (Just s, ty)+ Right decltor -> (Nothing, ) <$> untangleAbstractDeclarator baseTy decltor+ return $ ParameterDeclaration mbS ty++untangleDeclarationSpecifiers+ :: [P.DeclarationSpecifier] -> Either UntangleErr (Specifiers, TypeSpecifier)+untangleDeclarationSpecifiers declSpecs = do+ let (pStorage, pTySpecs, pTyQuals, pFunSpecs) = flip execState ([], [], [], []) $ do+ forM_ (reverse declSpecs) $ \declSpec -> case declSpec of+ P.StorageClassSpecifier x -> modify $ \(a, b, c, d) -> (x:a, b, c, d)+ P.TypeSpecifier x -> modify $ \(a, b, c, d) -> (a, x:b, c, d)+ P.TypeQualifier x -> modify $ \(a, b, c, d) -> (a, b, x:c, d)+ P.FunctionSpecifier x -> modify $ \(a, b, c, d) -> (a, b, c, x:d)+ -- Split data type and specifiers+ let (dataTypes, specs) =+ partition (\x -> not (x `elem` [P.SIGNED, P.UNSIGNED, P.LONG, P.SHORT])) pTySpecs+ let illegalSpecifiers s = failConversion $ IllegalSpecifiers s specs+ -- Find out sign, if present+ mbSign0 <- case filter (== P.SIGNED) specs of+ [] -> return Nothing+ [_] -> return $ Just Signed+ _:_ -> illegalSpecifiers "conflicting/duplicate sign information"+ mbSign <- case (mbSign0, filter (== P.UNSIGNED) specs) of+ (Nothing, []) -> return Nothing+ (Nothing, [_]) -> return $ Just Unsigned+ (Just b, []) -> return $ Just b+ _ -> illegalSpecifiers "conflicting/duplicate sign information"+ let sign = fromMaybe Signed mbSign+ -- Find out length+ let longs = length $ filter (== P.LONG) specs+ let shorts = length $ filter (== P.SHORT) specs+ when (longs > 0 && shorts > 0) $ illegalSpecifiers "both long and short"+ -- Find out data type+ dataType <- case dataTypes of+ [x] -> return x+ [] | longs > 0 || shorts > 0 -> return P.INT+ [] -> failConversion $ NoDataTypes declSpecs+ _:_ -> failConversion $ MultipleDataTypes declSpecs+ -- Check if things are compatible with one another+ let checkNoSpecs =+ unless (null specs) $ illegalSpecifiers "expecting no specifiers"+ let checkNoLength =+ when (longs > 0 || shorts > 0) $ illegalSpecifiers "unexpected long/short"+ tySpec <- case dataType of+ P.TypeName s -> do+ checkNoSpecs+ return $ TypeName s+ P.Struct s -> do+ checkNoSpecs+ return $ Struct s+ P.Enum s -> do+ checkNoSpecs+ return $ Enum s+ P.VOID -> do+ checkNoSpecs+ return Void+ P.CHAR -> do+ checkNoLength+ return $ Char mbSign+ P.INT | longs == 0 && shorts == 0 -> do+ return $ Int sign+ P.INT | longs == 1 -> do+ return $ Long sign+ P.INT | longs == 2 -> do+ return $ LLong sign+ P.INT | shorts == 1 -> do+ return $ Short sign+ P.INT -> do+ illegalSpecifiers "too many long/short"+ P.FLOAT -> do+ checkNoLength+ return Float+ P.DOUBLE -> do+ if longs == 1+ then return LDouble+ else do+ checkNoLength+ return Double+ _ -> do+ error $ "untangleDeclarationSpecifiers impossible: " ++ show dataType+ return (Specifiers pStorage pTyQuals pFunSpecs, tySpec)++untangleDeclarator+ :: Type -> P.Declarator -> Either UntangleErr (P.Identifier, Type)+untangleDeclarator ty0 (P.Declarator ptrs0 directDecltor) = go ty0 ptrs0+ where+ go :: Type -> [P.Pointer] -> Either UntangleErr (P.Identifier, Type)+ go ty [] = goDirect ty directDecltor+ go ty (P.Pointer quals : ptrs) = go (Ptr quals ty) ptrs++ goDirect :: Type -> P.DirectDeclarator -> Either UntangleErr (P.Identifier, Type)+ goDirect ty direct0 = case direct0 of+ P.DeclaratorRoot s -> return (s, ty)+ P.ArrayOrProto direct (P.Array arrayType) ->+ goDirect (Array arrayType ty) direct+ P.ArrayOrProto direct (P.Proto params) -> do+ params' <- mapM untangleParameterDeclaration params+ goDirect (Proto ty params') direct+ P.DeclaratorParens decltor ->+ untangleDeclarator ty decltor++untangleAbstractDeclarator+ :: Type -> P.AbstractDeclarator -> Either UntangleErr Type+untangleAbstractDeclarator ty0 (P.AbstractDeclarator ptrs0 mbDirectDecltor) =+ go ty0 ptrs0+ where+ go :: Type -> [P.Pointer] -> Either UntangleErr Type+ go ty [] = case mbDirectDecltor of+ Nothing -> return ty+ Just directDecltor -> goDirect ty directDecltor+ go ty (P.Pointer quals : ptrs) = go (Ptr quals ty) ptrs++ goDirect :: Type -> P.DirectAbstractDeclarator -> Either UntangleErr Type+ goDirect ty direct0 = case direct0 of+ P.ArrayOrProtoThere direct (P.Array arrayType) ->+ goDirect (Array arrayType ty) direct+ P.ArrayOrProtoThere direct (P.Proto params) -> do+ params' <- mapM untangleParameterDeclaration params+ goDirect (Proto ty params') direct+ P.ArrayOrProtoHere (P.Array arrayType) ->+ return $ Array arrayType ty+ P.ArrayOrProtoHere (P.Proto params) -> do+ params' <- mapM untangleParameterDeclaration params+ return $ Proto ty params'+ P.AbstractDeclaratorParens decltor ->+ untangleAbstractDeclarator ty decltor++------------------------------------------------------------------------+-- Tangling++tangleParameterDeclaration :: ParameterDeclaration -> P.ParameterDeclaration+tangleParameterDeclaration (ParameterDeclaration mbId ty00) =+ uncurry P.ParameterDeclaration $ case mbId of+ Nothing -> second Right $ goAbstractDirect ty00 Nothing+ Just id' -> second Left $ goConcreteDirect ty00 $ P.DeclaratorRoot id'+ where+ goAbstractDirect+ :: Type -> Maybe P.DirectAbstractDeclarator+ -> ([P.DeclarationSpecifier], P.AbstractDeclarator)+ goAbstractDirect ty0 mbDirect = case ty0 of+ TypeSpecifier specifiers tySpec ->+ let declSpecs = tangleTypeSpecifier specifiers tySpec+ in (declSpecs, P.AbstractDeclarator [] mbDirect)+ Ptr tyQuals ty ->+ goAbstract ty [P.Pointer tyQuals] mbDirect+ Array arrType ty ->+ let arr = P.Array arrType+ in case mbDirect of+ Nothing ->+ goAbstractDirect ty $ Just $ P.ArrayOrProtoHere arr+ Just decltor ->+ goAbstractDirect ty $ Just $ P.ArrayOrProtoThere decltor arr+ Proto ty params ->+ let proto = P.Proto $ map tangleParameterDeclaration params+ in case mbDirect of+ Nothing ->+ goAbstractDirect ty $ Just $ P.ArrayOrProtoHere proto+ Just decltor ->+ goAbstractDirect ty $ Just $ P.ArrayOrProtoThere decltor proto++ goAbstract+ :: Type -> [P.Pointer] -> Maybe P.DirectAbstractDeclarator+ -> ([P.DeclarationSpecifier], P.AbstractDeclarator)+ goAbstract ty0 ptrs mbDirect = case ty0 of+ TypeSpecifier specifiers tySpec ->+ let declSpecs = tangleTypeSpecifier specifiers tySpec+ in (declSpecs, P.AbstractDeclarator ptrs mbDirect)+ Ptr tyQuals ty ->+ goAbstract ty (P.Pointer tyQuals : ptrs) mbDirect+ Array{} ->+ goAbstractDirect ty0 $ Just $ P.AbstractDeclaratorParens $+ P.AbstractDeclarator ptrs mbDirect+ Proto{} ->+ goAbstractDirect ty0 $ Just $ P.AbstractDeclaratorParens $+ P.AbstractDeclarator ptrs mbDirect++ goConcreteDirect+ :: Type -> P.DirectDeclarator+ -> ([P.DeclarationSpecifier], P.Declarator)+ goConcreteDirect ty0 direct = case ty0 of+ TypeSpecifier specifiers tySpec ->+ let declSpecs = tangleTypeSpecifier specifiers tySpec+ in (declSpecs, P.Declarator [] direct)+ Ptr tyQuals ty ->+ goConcrete ty [P.Pointer tyQuals] direct+ Array arrType ty ->+ goConcreteDirect ty $ P.ArrayOrProto direct $ P.Array arrType+ Proto ty params ->+ goConcreteDirect ty $ P.ArrayOrProto direct $+ P.Proto $ map tangleParameterDeclaration params++ goConcrete+ :: Type -> [P.Pointer] -> P.DirectDeclarator+ -> ([P.DeclarationSpecifier], P.Declarator)+ goConcrete ty0 ptrs direct = case ty0 of+ TypeSpecifier specifiers tySpec ->+ let declSpecs = tangleTypeSpecifier specifiers tySpec+ in (declSpecs, P.Declarator ptrs direct)+ Ptr tyQuals ty ->+ goConcrete ty (P.Pointer tyQuals : ptrs) direct+ Array{} ->+ goConcreteDirect ty0 $ P.DeclaratorParens $ P.Declarator ptrs direct+ Proto{} ->+ goConcreteDirect ty0 $ P.DeclaratorParens $ P.Declarator ptrs direct++tangleTypeSpecifier :: Specifiers -> TypeSpecifier -> [P.DeclarationSpecifier]+tangleTypeSpecifier (Specifiers storages tyQuals funSpecs) tySpec =+ let pTySpecs = case tySpec of+ Void -> [P.VOID]+ Char Nothing -> [P.CHAR]+ Char (Just Signed) -> [P.SIGNED, P.CHAR]+ Char (Just Unsigned) -> [P.UNSIGNED, P.CHAR]+ Short Signed -> [P.SHORT]+ Short Unsigned -> [P.UNSIGNED, P.SHORT]+ Int Signed -> [P.INT]+ Int Unsigned -> [P.UNSIGNED]+ Long Signed -> [P.LONG]+ Long Unsigned -> [P.UNSIGNED, P.LONG]+ LLong Signed -> [P.LONG, P.LONG]+ LLong Unsigned -> [P.UNSIGNED, P.LONG, P.LONG]+ Float -> [P.FLOAT]+ Double -> [P.DOUBLE]+ LDouble -> [P.LONG, P.DOUBLE]+ TypeName s -> [P.TypeName s]+ Struct s -> [P.Struct s]+ Enum s -> [P.Enum s]+ in map P.StorageClassSpecifier storages +++ map P.TypeQualifier tyQuals +++ map P.FunctionSpecifier funSpecs +++ map P.TypeSpecifier pTySpecs++------------------------------------------------------------------------+-- To english++describeParameterDeclaration :: ParameterDeclaration -> PP.Doc+describeParameterDeclaration (ParameterDeclaration mbId ty) =+ let idDoc = case mbId of+ Nothing -> ""+ Just id' -> PP.pretty id' <+> "is a "+ in idDoc <> describeType ty++describeType :: Type -> PP.Doc+describeType ty0 = case ty0 of+ TypeSpecifier specs tySpec -> engSpecs specs <> PP.pretty tySpec+ Ptr quals ty -> engQuals quals <> "ptr to" <+> describeType ty+ Array arrTy ty -> engArrTy arrTy <> "of" <+> describeType ty+ Proto retTy params ->+ "function from" <+> engParams params <> "returning" <+> describeType retTy+ where+ engSpecs (Specifiers [] [] []) = ""+ engSpecs (Specifiers x y z) =+ let xs = map P.StorageClassSpecifier x ++ map P.TypeQualifier y +++ map P.FunctionSpecifier z+ in PP.hsep (map PP.pretty xs) <> " "++ engQuals = PP.hsep . map PP.pretty++ engArrTy arrTy = case arrTy of+ P.VariablySized -> "variably sized array "+ P.SizedByInteger n -> "array of size" <+> PP.text (show n) <> " "+ P.SizedByIdentifier s -> "array of size" <+> PP.pretty s <> " "+ P.Unsized -> "array "++ engParams [] = ""+ engParams params0 = "(" <> go params0 <> ") "+ where+ go xs = case xs of+ [] -> ""+ [x] -> describeParameterDeclaration x+ (x:xs') -> describeParameterDeclaration x <> "," <+> go xs'++------------------------------------------------------------------------+-- Convenient parsing++untangleParameterDeclaration'+ :: P.CParser m => P.ParameterDeclaration -> m ParameterDeclaration+untangleParameterDeclaration' pDecl =+ case untangleParameterDeclaration pDecl of+ Left err -> fail $ pretty80 $+ "Error while parsing declaration:" </> PP.pretty err </> PP.pretty pDecl+ Right x -> return x++parseParameterDeclaration :: P.CParser m => m ParameterDeclaration+parseParameterDeclaration =+ untangleParameterDeclaration' =<< P.parameter_declaration++parseParameterList :: P.CParser m => m [ParameterDeclaration]+parseParameterList =+ mapM untangleParameterDeclaration' =<< P.parameter_list++parseIdentifier :: P.CParser m => m P.Identifier+parseIdentifier = P.identifier_no_lex++parseType :: P.CParser m => m Type+parseType = parameterDeclarationType <$> parseParameterDeclaration++------------------------------------------------------------------------+-- Pretty++instance PP.Pretty TypeSpecifier where+ pretty tySpec = case tySpec of+ Void -> "void"+ Char Nothing -> "char"+ Char (Just Signed) -> "signed char"+ Char (Just Unsigned) -> "unsigned char"+ Short Signed -> "short"+ Short Unsigned -> "unsigned short"+ Int Signed -> "int"+ Int Unsigned -> "unsigned"+ Long Signed -> "long"+ Long Unsigned -> "unsigned long"+ LLong Signed -> "long long"+ LLong Unsigned -> "unsigned long long"+ Float -> "float"+ Double -> "double"+ LDouble -> "long double"+ TypeName s -> PP.pretty s+ Struct s -> "struct" <+> PP.pretty s+ Enum s -> "enum" <+> PP.pretty s++instance PP.Pretty UntangleErr where+ pretty err = case err of+ MultipleDataTypes specs ->+ "Multiple data types in" </> PP.prettyList specs+ IllegalSpecifiers s specs ->+ "Illegal specifiers, " <+> PP.text s <+> ", in" </> PP.prettyList specs+ NoDataTypes specs ->+ "No data types in " </> PP.prettyList specs++instance PP.Pretty ParameterDeclaration where+ pretty = PP.pretty . tangleParameterDeclaration++instance PP.Pretty Type where+ pretty ty =+ PP.pretty $ tangleParameterDeclaration $ ParameterDeclaration Nothing ty++------------------------------------------------------------------------+-- Utils++pretty80 :: PP.Doc -> String+pretty80 x = PP.displayS (PP.renderPretty 0.8 80 x) ""
+ src/Language/C/Types/Parse.hs view
@@ -0,0 +1,808 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A parser for C99 declarations. Currently, the parser has the following limitations:+--+-- * Array sizes can only be @*@, @n@ (where n is a positive integer), @x@+-- (where @x@ is a C identifier). In C99 they can be arbitrary expressions. See+-- the @'ArrayType'@ data type.+--+-- * @_Bool@, @_Complex@, and @_Imaginary@ are not present.+--+-- * Untyped parameter lists (pre-K&R C) are not allowed.+--+-- The parser is incremental and generic (see 'CParser'). 'PP.Pretty'+-- and 'QC.Arbitrary' instances are provided for all the data types.+--+-- The entry point if you want to parse C declarations is+-- @'parameter_declaration'@.++module Language.C.Types.Parse+ ( -- * Parser type+ CParser+ , IsTypeName+ , runCParser+ , quickCParser+ , quickCParser_++ -- * Types and parsing+ , Identifier(..)+ , identifier+ , identifier_no_lex+ , DeclarationSpecifier(..)+ , declaration_specifiers+ , StorageClassSpecifier(..)+ , storage_class_specifier+ , TypeSpecifier(..)+ , type_specifier+ , TypeQualifier(..)+ , type_qualifier+ , FunctionSpecifier(..)+ , function_specifier+ , Declarator(..)+ , declarator+ , DirectDeclarator(..)+ , direct_declarator+ , ArrayOrProto(..)+ , array_or_proto+ , ArrayType(..)+ , array_type+ , Pointer(..)+ , pointer+ , ParameterDeclaration(..)+ , parameter_declaration+ , parameter_list+ , AbstractDeclarator(..)+ , abstract_declarator+ , DirectAbstractDeclarator(..)+ , direct_abstract_declarator++ -- * YACC grammar+ -- $yacc++ -- * Testing utilities+ , ParameterDeclarationWithTypeNames(..)+ ) where++import Control.Applicative+import Control.Monad (msum, void, MonadPlus, unless, when)+import Control.Monad.Reader (MonadReader, ask, runReaderT, ReaderT)+import Data.Functor.Identity (Identity)+import qualified Data.HashSet as HashSet+import Data.Maybe (mapMaybe)+import Data.Monoid ((<>))+import qualified Data.Set as Set+import Data.String (IsString(..))+import Data.Typeable (Typeable)+import qualified Test.QuickCheck as QC+import qualified Text.Parsec as Parsec+import Text.Parser.Char+import Text.Parser.Combinators+import Text.Parser.LookAhead+import Text.Parser.Token+import qualified Text.Parser.Token.Highlight as Highlight+import Text.PrettyPrint.ANSI.Leijen (Pretty(..), (<+>), Doc, hsep)+import qualified Text.PrettyPrint.ANSI.Leijen as PP++------------------------------------------------------------------------+-- Parser++-- | Function used to determine whether an 'C.Id' is a type name.+type IsTypeName = Identifier -> Bool++-- | All the parsing is done using the type classes provided by the+-- @parsers@ package. You can use the parsing routines with any of the parsers+-- that implement the classes, such as @parsec@ or @trifecta@.+--+-- The 'MonadReader' with 'IsTypeName' is required for parsing C, see+-- <http://en.wikipedia.org/wiki/The_lexer_hack>.+type CParser m = (Monad m, Functor m, Applicative m, MonadPlus m, Parsing m, CharParsing m, TokenParsing m, LookAheadParsing m, MonadReader IsTypeName m)++-- | Runs a @'CParser'@ using @parsec@.+runCParser+ :: Parsec.Stream s Identity Char+ => IsTypeName+ -- ^ Function determining if an identifier is a type name.+ -> String+ -- ^ Source name.+ -> s+ -- ^ String to parse.+ -> (ReaderT IsTypeName (Parsec.Parsec s ()) a)+ -- ^ Parser. Anything with type @forall m. CParser m => m a@ is a+ -- valid argument.+ -> Either Parsec.ParseError a+runCParser isTypeName fn s p = Parsec.parse (runReaderT p isTypeName) fn s++-- | Useful for quick testing. Uses @\"quickCParser\"@ as source name, and throws+-- an 'error' if parsing fails.+quickCParser+ :: IsTypeName+ -- ^ Function determining if an identifier is a type name.+ -> String+ -- ^ String to parse.+ -> (ReaderT IsTypeName (Parsec.Parsec String ()) a)+ -- ^ Parser. Anything with type @forall m. CParser m => m a@ is a+ -- valid argument.+ -> a+quickCParser isTypeName s p = case runCParser isTypeName "quickCParser" s p of+ Left err -> error $ "quickCParser: " ++ show err+ Right x -> x++-- | Like 'quickCParser', but uses @'const' 'False'@ as 'IsTypeName'.+quickCParser_+ :: String+ -- ^ String to parse.+ -> (ReaderT IsTypeName (Parsec.Parsec String ()) a)+ -- ^ Parser. Anything with type @forall m. CParser m => m a@ is a+ -- valid argument.+ -> a+quickCParser_ = quickCParser (const False)++newtype Identifier = Identifier {unIdentifier :: String}+ deriving (Typeable, Eq, Ord, Show)++instance IsString Identifier where+ fromString s =+ case runCParser (const False) "fromString" s (identifier_no_lex <* eof) of+ Left _err -> error $ "Identifier fromString: invalid string " ++ show s+ Right x -> x++identLetter :: CParser m => m Char+identLetter = oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['_']++reservedWords :: HashSet.HashSet String+reservedWords = HashSet.fromList+ [ "auto", "else", "long", "switch"+ , "break", "enum", "register", "typedef"+ , "case", "extern", "return", "union"+ , "char", "float", "short", "unsigned"+ , "const", "for", "signed", "void"+ , "continue", "goto", "sizeof", "volatile"+ , "default", "if", "static", "while"+ , "do", "int", "struct", "double"+ ]++identStyle :: CParser m => IdentifierStyle m+identStyle = IdentifierStyle+ { _styleName = "C identifier"+ , _styleStart = identLetter+ , _styleLetter = identLetter <|> digit+ , _styleReserved = reservedWords+ , _styleHighlight = Highlight.Identifier+ , _styleReservedHighlight = Highlight.ReservedIdentifier+ }++data DeclarationSpecifier+ = StorageClassSpecifier StorageClassSpecifier+ | TypeSpecifier TypeSpecifier+ | TypeQualifier TypeQualifier+ | FunctionSpecifier FunctionSpecifier+ deriving (Typeable, Eq, Show)++declaration_specifiers :: forall m. CParser m => m [DeclarationSpecifier]+declaration_specifiers = many1 $ msum+ [ StorageClassSpecifier <$> storage_class_specifier+ , TypeSpecifier <$> type_specifier+ , TypeQualifier <$> type_qualifier+ , FunctionSpecifier <$> function_specifier+ ]++data StorageClassSpecifier+ = TYPEDEF+ | EXTERN+ | STATIC+ | AUTO+ | REGISTER+ deriving (Typeable, Eq, Show)++storage_class_specifier :: CParser m => m StorageClassSpecifier+storage_class_specifier = msum+ [ TYPEDEF <$ reserve identStyle "typedef"+ , EXTERN <$ reserve identStyle "extern"+ , STATIC <$ reserve identStyle "static"+ , AUTO <$ reserve identStyle "auto"+ , REGISTER <$ reserve identStyle "register"+ ]++data TypeSpecifier+ = VOID+ | CHAR+ | SHORT+ | INT+ | LONG+ | FLOAT+ | DOUBLE+ | SIGNED+ | UNSIGNED+ | Struct Identifier+ | Enum Identifier+ | TypeName Identifier+ deriving (Typeable, Eq, Show)++type_specifier :: CParser m => m TypeSpecifier+type_specifier = msum+ [ VOID <$ reserve identStyle "void"+ , CHAR <$ reserve identStyle "char"+ , SHORT <$ reserve identStyle "short"+ , INT <$ reserve identStyle "int"+ , LONG <$ reserve identStyle "long"+ , FLOAT <$ reserve identStyle "float"+ , DOUBLE <$ reserve identStyle "double"+ , SIGNED <$ reserve identStyle "signed"+ , UNSIGNED <$ reserve identStyle "unsigned"+ , Struct <$> (reserve identStyle "struct" >> identifier)+ , Enum <$> (reserve identStyle "enum" >> identifier)+ , TypeName <$> type_name+ ]++identifier :: CParser m => m Identifier+identifier =+ try (do s <- ident identStyle+ isTypeName <- ask+ when (isTypeName s) $+ fail "expecting identifier, got type name"+ return s)+ <?> "identifier"++type_name :: CParser m => m Identifier+type_name =+ try (do s <- ident identStyle+ isTypeName <- ask+ unless (isTypeName s) $+ fail "expecting type name, got identifier"+ return s)+ <?> "type name"++data TypeQualifier+ = CONST+ | RESTRICT+ | VOLATILE+ deriving (Typeable, Eq, Show)++type_qualifier :: CParser m => m TypeQualifier+type_qualifier = msum+ [ CONST <$ reserve identStyle "const"+ , RESTRICT <$ reserve identStyle "restrict"+ , VOLATILE <$ reserve identStyle "volatile"+ ]++data FunctionSpecifier+ = INLINE+ deriving (Typeable, Eq, Show)++function_specifier :: CParser m => m FunctionSpecifier+function_specifier = msum+ [ INLINE <$ reserve identStyle "inline"+ ]++data Declarator = Declarator+ { declaratorPointers :: [Pointer]+ , declaratorDirect :: DirectDeclarator+ } deriving (Typeable, Eq, Show)++declarator :: CParser m => m Declarator+declarator = (Declarator <$> many pointer <*> direct_declarator) <?> "declarator"++data DirectDeclarator+ = DeclaratorRoot Identifier+ | ArrayOrProto DirectDeclarator ArrayOrProto+ | DeclaratorParens Declarator+ deriving (Typeable, Eq, Show)++data ArrayOrProto+ = Array ArrayType+ | Proto [ParameterDeclaration] -- We don't include old prototypes.+ deriving (Typeable, Eq, Show)++array_or_proto :: CParser m => m ArrayOrProto+array_or_proto = msum+ [ Array <$> brackets array_type+ , Proto <$> parens parameter_list+ ]++-- TODO handle more stuff in array brackets+data ArrayType+ = VariablySized+ | Unsized+ | SizedByInteger Integer+ | SizedByIdentifier Identifier+ deriving (Typeable, Eq, Show)++array_type :: CParser m => m ArrayType+array_type = msum+ [ VariablySized <$ symbolic '*'+ , SizedByInteger <$> natural+ , SizedByIdentifier <$> identifier+ , return Unsized+ ]++direct_declarator :: CParser m => m DirectDeclarator+direct_declarator =+ (do ddecltor <- msum+ [ DeclaratorRoot <$> identifier+ , DeclaratorParens <$> parens declarator+ ]+ aops <- many array_or_proto+ return $ foldl ArrayOrProto ddecltor aops)++data Pointer+ = Pointer [TypeQualifier]+ deriving (Typeable, Eq, Show)++pointer :: CParser m => m Pointer+pointer = do+ void $ symbolic '*'+ Pointer <$> many type_qualifier++parameter_list :: CParser m => m [ParameterDeclaration]+parameter_list =+ sepBy parameter_declaration $ symbolic ','++data ParameterDeclaration = ParameterDeclaration+ { parameterDeclarationSpecifiers :: [DeclarationSpecifier]+ , parameterDeclarationDeclarator :: Either Declarator AbstractDeclarator+ } deriving (Typeable, Eq, Show)++parameter_declaration :: CParser m => m ParameterDeclaration+parameter_declaration =+ ParameterDeclaration+ <$> declaration_specifiers+ <*> mbabstract+ where+ mbabstract =+ Left <$> try declarator <|>+ Right <$> try abstract_declarator <|>+ return (Right (AbstractDeclarator [] Nothing))++data AbstractDeclarator = AbstractDeclarator+ { abstractDeclaratorPointers :: [Pointer]+ , abstractDeclaratorDirect :: Maybe DirectAbstractDeclarator+ } deriving (Typeable, Eq, Show)++abstract_declarator :: CParser m => m AbstractDeclarator+abstract_declarator = do+ ptrs <- many pointer+ -- If there are no pointers, there must be an abstract declarator.+ let p = if null ptrs+ then Just <$> direct_abstract_declarator+ else (Just <$> try direct_abstract_declarator) <|> return Nothing+ AbstractDeclarator ptrs <$> p++data DirectAbstractDeclarator+ = ArrayOrProtoHere ArrayOrProto+ | ArrayOrProtoThere DirectAbstractDeclarator ArrayOrProto+ | AbstractDeclaratorParens AbstractDeclarator+ deriving (Typeable, Eq, Show)++direct_abstract_declarator :: CParser m => m DirectAbstractDeclarator+direct_abstract_declarator =+ (do ddecltor <- msum+ [ try (ArrayOrProtoHere <$> array_or_proto)+ , AbstractDeclaratorParens <$> parens abstract_declarator+ ] <?> "array, prototype, or parenthesised abstract declarator"+ aops <- many array_or_proto+ return $ foldl ArrayOrProtoThere ddecltor aops)++-- | This parser parses an 'Id' and nothing else -- it does not consume+-- trailing spaces and the like.+identifier_no_lex :: CParser m => m Identifier+identifier_no_lex =+ try (do s <- Identifier <$> ((:) <$> identLetter <*> many (identLetter <|> digit))+ isTypeName <- ask+ when (isTypeName s) $+ fail "expecting identifier, got type name"+ return s)+ <?> "identifier"++------------------------------------------------------------------------+-- Pretty printing++instance Pretty Identifier where+ pretty = PP.text . unIdentifier++instance Pretty DeclarationSpecifier where+ pretty dspec = case dspec of+ StorageClassSpecifier x -> pretty x+ TypeSpecifier x -> pretty x+ TypeQualifier x -> pretty x+ FunctionSpecifier x -> pretty x++instance Pretty StorageClassSpecifier where+ pretty storage = case storage of+ TYPEDEF -> "typedef"+ EXTERN -> "extern"+ STATIC -> "static"+ AUTO -> "auto"+ REGISTER -> "register"++instance Pretty TypeSpecifier where+ pretty tySpec = case tySpec of+ VOID -> "void"+ CHAR -> "char"+ SHORT -> "short"+ INT -> "int"+ LONG -> "long"+ FLOAT -> "float"+ DOUBLE -> "double"+ SIGNED -> "signed"+ UNSIGNED -> "unsigned"+ Struct x -> "struct" <+> pretty x+ Enum x -> "enum" <+> pretty x+ TypeName x -> pretty x++instance Pretty TypeQualifier where+ pretty tyQual = case tyQual of+ CONST -> "const"+ RESTRICT -> "restrict"+ VOLATILE -> "volatile"++instance Pretty FunctionSpecifier where+ pretty funSpec = case funSpec of+ INLINE -> "inline"++instance Pretty Declarator where+ pretty (Declarator ptrs ddecltor) = case ptrs of+ [] -> pretty ddecltor+ _:_ -> prettyPointers ptrs <+> pretty ddecltor++prettyPointers :: [Pointer] -> Doc+prettyPointers [] = ""+prettyPointers (x : xs) = pretty x <> prettyPointers xs++instance Pretty Pointer where+ pretty (Pointer tyQual) = "*" <> hsep (map pretty tyQual)++instance Pretty DirectDeclarator where+ pretty decltor = case decltor of+ DeclaratorRoot x -> pretty x+ DeclaratorParens x -> "(" <> pretty x <> ")"+ ArrayOrProto ddecltor aorp -> pretty ddecltor <> pretty aorp++instance Pretty ArrayOrProto where+ pretty aorp = case aorp of+ Array x -> "[" <> pretty x <> "]"+ Proto x -> "(" <> prettyParams x <> ")"++prettyParams :: (Pretty a) => [a] -> Doc+prettyParams xs = case xs of+ [] -> ""+ [x] -> pretty x+ x : xs'@(_:_) -> pretty x <> "," <+> prettyParams xs'++instance Pretty ArrayType where+ pretty at = case at of+ VariablySized -> "*"+ SizedByInteger n -> pretty n+ SizedByIdentifier s -> pretty s+ Unsized -> ""++instance Pretty ParameterDeclaration where+ pretty (ParameterDeclaration declSpecs decltor) = case declSpecs of+ [] -> decltorDoc+ _:_ -> hsep (map pretty declSpecs) <+> decltorDoc+ where+ decltorDoc = case decltor of+ Left x -> pretty x+ Right x -> pretty x++instance Pretty AbstractDeclarator where+ pretty (AbstractDeclarator ptrs mbDecltor) = case (ptrs, mbDecltor) of+ (_, Nothing) -> prettyPointers ptrs+ ([], Just x) -> pretty x+ (_:_, Just x) -> prettyPointers ptrs <+> pretty x++instance Pretty DirectAbstractDeclarator where+ pretty ddecltor = case ddecltor of+ AbstractDeclaratorParens x -> "(" <> pretty x <> ")"+ ArrayOrProtoHere aop -> pretty aop+ ArrayOrProtoThere ddecltor' aop -> pretty ddecltor' <> pretty aop++------------------------------------------------------------------------+-- Arbitrary++data OneOfSized a+ = Anyhow a+ | IfPositive a+ deriving (Typeable, Eq, Show)++-- | Precondition: there is at least one 'Anyhow' in the list.+oneOfSized :: [OneOfSized (QC.Gen a)] -> QC.Gen a+oneOfSized xs = QC.sized $ \n -> do+ let f (Anyhow a) = Just a+ f (IfPositive x) | n > 0 = Just x+ f (IfPositive _) = Nothing+ QC.oneof $ mapMaybe f xs++halveSize :: QC.Gen a -> QC.Gen a+halveSize m = QC.sized $ \n -> QC.resize (n `div` 2) m++arbitraryIdentifier :: QC.Gen Identifier+arbitraryIdentifier = do+ s <- ((:) <$> QC.elements letters <*> QC.listOf (QC.elements (letters ++ digits)))+ if HashSet.member s reservedWords+ then arbitraryIdentifier+ else return $ Identifier s+ where+ letters = ['a'..'z'] ++ ['A'..'Z'] ++ ['_']+ digits = ['0'..'9']++-- | Type used to generate an 'QC.Arbitrary' 'ParameterDeclaration' with+-- arbitrary allowed type names.+data ParameterDeclarationWithTypeNames = ParameterDeclarationWithTypeNames+ { pdwtnTypeNames :: Set.Set Identifier+ , pdwtnParameterDeclaration :: ParameterDeclaration+ } deriving (Typeable, Eq, Show)++instance QC.Arbitrary ParameterDeclarationWithTypeNames where+ arbitrary = do+ names <- Set.fromList <$> QC.listOf arbitraryIdentifier+ decl <- arbitraryParameterDeclarationFrom names+ return $ ParameterDeclarationWithTypeNames names decl++arbitraryDeclarationSpecifierFrom :: Set.Set Identifier -> QC.Gen DeclarationSpecifier+arbitraryDeclarationSpecifierFrom typeNames = QC.oneof $+ [ StorageClassSpecifier <$> QC.arbitrary+ , TypeQualifier <$> QC.arbitrary+ , FunctionSpecifier <$> QC.arbitrary+ , TypeSpecifier <$> arbitraryTypeSpecifierFrom typeNames+ ]++instance QC.Arbitrary StorageClassSpecifier where+ arbitrary = QC.oneof+ [ return TYPEDEF+ , return EXTERN+ , return STATIC+ , return AUTO+ , return REGISTER+ ]++arbitraryTypeSpecifierFrom :: Set.Set Identifier -> QC.Gen TypeSpecifier+arbitraryTypeSpecifierFrom typeNames = QC.oneof $+ [ return VOID+ , return CHAR+ , return SHORT+ , return INT+ , return LONG+ , return FLOAT+ , return DOUBLE+ , return SIGNED+ , return UNSIGNED+ , Struct <$> arbitraryIdentifierFrom typeNames+ , Enum <$> arbitraryIdentifierFrom typeNames+ ] ++ if Set.null typeNames then []+ else [TypeName <$> QC.elements (Set.toList typeNames)]++instance QC.Arbitrary TypeQualifier where+ arbitrary = QC.oneof+ [ return CONST+ , return RESTRICT+ , return VOLATILE+ ]++instance QC.Arbitrary FunctionSpecifier where+ arbitrary = QC.oneof+ [ return INLINE+ ]++arbitraryDeclaratorFrom :: Set.Set Identifier -> QC.Gen Declarator+arbitraryDeclaratorFrom typeNames = halveSize $+ Declarator <$> QC.arbitrary <*> arbitraryDirectDeclaratorFrom typeNames++arbitraryIdentifierFrom :: Set.Set Identifier -> QC.Gen Identifier+arbitraryIdentifierFrom typeNames = do+ id' <- arbitraryIdentifier+ if Set.member id' typeNames+ then arbitraryIdentifierFrom typeNames+ else return id'++arbitraryDirectDeclaratorFrom :: Set.Set Identifier -> QC.Gen DirectDeclarator+arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized $+ [ Anyhow $ DeclaratorRoot <$> arbitraryIdentifierFrom typeNames+ , IfPositive $ DeclaratorParens <$> arbitraryDeclaratorFrom typeNames+ , IfPositive $ ArrayOrProto+ <$> arbitraryDirectDeclaratorFrom typeNames+ <*> arbitraryArrayOrProtoFrom typeNames+ ]++arbitraryArrayOrProtoFrom :: Set.Set Identifier -> QC.Gen ArrayOrProto+arbitraryArrayOrProtoFrom typeNames = halveSize $ oneOfSized $+ [ Anyhow $ Array <$> arbitraryArrayTypeFrom typeNames+ , IfPositive $ Proto <$> QC.listOf (arbitraryParameterDeclarationFrom typeNames)+ ]++arbitraryArrayTypeFrom :: Set.Set Identifier -> QC.Gen ArrayType+arbitraryArrayTypeFrom typeNames = QC.oneof+ [ return VariablySized+ , SizedByInteger . QC.getNonNegative <$> QC.arbitrary+ , SizedByIdentifier <$> arbitraryIdentifierFrom typeNames+ , return Unsized+ ]++instance QC.Arbitrary Pointer where+ arbitrary = Pointer <$> QC.arbitrary++arbitraryParameterDeclarationFrom :: Set.Set Identifier -> QC.Gen ParameterDeclaration+arbitraryParameterDeclarationFrom typeNames = halveSize $+ ParameterDeclaration+ <$> QC.listOf1 (arbitraryDeclarationSpecifierFrom typeNames)+ <*> QC.oneof+ [ Left <$> arbitraryDeclaratorFrom typeNames+ , Right <$> arbitraryAbstractDeclaratorFrom typeNames+ ]++arbitraryAbstractDeclaratorFrom :: Set.Set Identifier -> QC.Gen AbstractDeclarator+arbitraryAbstractDeclaratorFrom typeNames = halveSize $ do+ ptrs <- QC.arbitrary+ decl <- if null ptrs+ then Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames+ else oneOfSized+ [ Anyhow $ return Nothing+ , IfPositive $ Just <$> arbitraryDirectAbstractDeclaratorFrom typeNames+ ]+ return $ AbstractDeclarator ptrs decl++arbitraryDirectAbstractDeclaratorFrom+ :: Set.Set Identifier -> QC.Gen DirectAbstractDeclarator+arbitraryDirectAbstractDeclaratorFrom typeNames = halveSize $ oneOfSized $+ [ Anyhow $ ArrayOrProtoHere <$> arbitraryArrayOrProtoFrom typeNames+ , IfPositive $ AbstractDeclaratorParens <$> arbitraryAbstractDeclaratorFrom typeNames+ , IfPositive $ ArrayOrProtoThere+ <$> arbitraryDirectAbstractDeclaratorFrom typeNames+ <*> arbitraryArrayOrProtoFrom typeNames+ ]++------------------------------------------------------------------------+-- Utils++many1 :: CParser m => m a -> m [a]+many1 p = (:) <$> p <*> many p++------------------------------------------------------------------------+-- YACC grammar++-- $yacc+--+-- The parser above is derived from a modification of the YACC grammar+-- for C99 found at <http://www.quut.com/c/ANSI-C-grammar-y-1999.html>,+-- reproduced below.+--+-- @+-- %token IDENTIFIER TYPE_NAME INTEGER+--+-- %token TYPEDEF EXTERN STATIC AUTO REGISTER INLINE RESTRICT+-- %token CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE CONST VOLATILE VOID+-- %token BOOL COMPLEX IMAGINARY+-- %token STRUCT UNION ENUM+--+-- %start parameter_list+-- %%+--+-- declaration_specifiers+-- : storage_class_specifier+-- | storage_class_specifier declaration_specifiers+-- | type_specifier+-- | type_specifier declaration_specifiers+-- | type_qualifier+-- | type_qualifier declaration_specifiers+-- | function_specifier+-- | function_specifier declaration_specifiers+-- ;+--+-- storage_class_specifier+-- : TYPEDEF+-- | EXTERN+-- | STATIC+-- | AUTO+-- | REGISTER+-- ;+--+-- type_specifier+-- : VOID+-- | CHAR+-- | SHORT+-- | INT+-- | LONG+-- | FLOAT+-- | DOUBLE+-- | SIGNED+-- | UNSIGNED+-- | BOOL+-- | COMPLEX+-- | IMAGINARY+-- | STRUCT IDENTIFIER+-- | UNION IDENTIFIER+-- | ENUM IDENTIFIER+-- | TYPE_NAME+-- ;+--+-- type_qualifier+-- : CONST+-- | RESTRICT+-- | VOLATILE+-- ;+--+-- function_specifier+-- : INLINE+-- ;+--+-- declarator+-- : pointer direct_declarator+-- | direct_declarator+-- ;+--+-- direct_declarator+-- : IDENTIFIER+-- | '(' declarator ')'+-- | direct_declarator '[' type_qualifier_list ']'+-- | direct_declarator '[' type_qualifier_list '*' ']'+-- | direct_declarator '[' '*' ']'+-- | direct_declarator '[' IDENTIFIER ']'+-- | direct_declarator '[' INTEGER ']'+-- | direct_declarator '[' ']'+-- | direct_declarator '(' parameter_list ')'+-- | direct_declarator '(' ')'+-- ;+--+-- pointer+-- : '*'+-- | '*' type_qualifier_list+-- | '*' pointer+-- | '*' type_qualifier_list pointer+-- ;+--+-- type_qualifier_list+-- : type_qualifier+-- | type_qualifier_list type_qualifier+-- ;+--+-- parameter_list+-- : parameter_declaration+-- | parameter_list ',' parameter_declaration+-- ;+--+-- parameter_declaration+-- : declaration_specifiers declarator+-- | declaration_specifiers abstract_declarator+-- | declaration_specifiers+-- ;+--+-- abstract_declarator+-- : pointer+-- | direct_abstract_declarator+-- | pointer direct_abstract_declarator+-- ;+--+-- direct_abstract_declarator+-- : '(' abstract_declarator ')'+-- | '[' ']'+-- | direct_abstract_declarator '[' ']'+-- | '[' '*' ']'+-- | direct_abstract_declarator '[' '*' ']'+-- | '[' IDENTIFIER ']'+-- | direct_abstract_declarator '[' IDENTIFIER ']'+-- | '[' INTEGER ']'+-- | direct_abstract_declarator '[' INTEGER ']'+-- | '(' ')'+-- | '(' parameter_list ')'+-- | direct_abstract_declarator '(' ')'+-- | direct_abstract_declarator '(' parameter_list ')'+-- ;+--+-- %%+-- #include \<stdio.h\>+--+-- extern char yytext[];+-- extern int column;+--+-- void yyerror(char const *s)+-- {+-- fflush(stdout);+-- printf("\n%*s\n%*s\n", column, "^", column, s);+-- }+-- @
+ test/tests.c view
@@ -0,0 +1,96 @@++#include <math.h>++#include <stdio.h>+++int francescos_mul(int x, int y) {+ return x * y;+}+++ int francescos_add(int x, int y) { int z = x + y; return z; } ++int inline_c_0_af51326c4d54f2333cd5e65d63fa1335afd44e7f(int x) {+ return x + 3; +}+++int inline_c_1_7ac34f446e8519c3b967b9fafdc79c95552f35e4() {+return ( 1 + 4 );+}+++int inline_c_2_16f19661d53c3abae15931d85a5e2829ecb039aa(int x_inline_c_0, int y_inline_c_1) {+return ( x_inline_c_0 + y_inline_c_1 + 5 );+}+++int inline_c_3_40bee96de703884c6b206e411631395b9aef5976(int x_inline_c_0, int y_inline_c_1) {+return ( x_inline_c_0 + 10 + y_inline_c_1 );+}+++int inline_c_4_e6943496092d6a4a410b30efda2403f1340ee8cc(int x_inline_c_0, int y_inline_c_1) {+return ( 7 + x_inline_c_0 + y_inline_c_1 );+}+++void inline_c_5_bbad659b194c6226bc20ec8262bc1c599dddeb28() {+ printf("Hello\n") ;+}+++int inline_c_6_71dfd9b850f6e2091e021139a58b74df94cd7303(int (* ackermannPtr_inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) {+return ( ackermannPtr_inline_c_0(x_inline_c_1, y_inline_c_2) );+}+++int (* inline_c_7_7e6957a671db751a0a5b5e9721b3c45002fab68f())(int , int ) {+return ( &francescos_add );+}+++int inline_c_8_b58cd0af8a50791fe277023774ffe88ee7e037bd(int (* ackermann__inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) {+return ( ackermann__inline_c_0(x_inline_c_1, y_inline_c_2) );+}+++int inline_c_9_71dfd9b850f6e2091e021139a58b74df94cd7303(int (* ackermannPtr_inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) {+return ( ackermannPtr_inline_c_0(x_inline_c_1, y_inline_c_2) );+}+++int inline_c_10_8ef64f450bca60833a113574529facc22cb4a0a0(int (* ackermann_inline_c_0)(int , int ), int x_inline_c_1, int y_inline_c_2) {+return ( ackermann_inline_c_0(x_inline_c_1, y_inline_c_2) );+}+++double inline_c_11_05403b76080812d04e00ce2b31b2068dad1b2342(double (* fun_inline_c_0)(double )) {+return ( fun_inline_c_0(3.0) );+}+++int inline_c_12_963ff572b13b7aaee0f9f8092a567eb35a8c2088(int n_inline_c_0, int * ptr_inline_c_1) {++ int i;+ int x = 0;+ for (i = 0; i < n_inline_c_0; i++) {+ x += ptr_inline_c_1[i];+ }+ return x;+ +}+++int inline_c_13_e2ee2f14cc17b81ea1e818bb96b23439a1810c23(long vec_inline_c_0, int * vec_inline_c_1) {++ int i;+ int x = 0;+ for (i = 0; i < vec_inline_c_0; i++) {+ x += vec_inline_c_1[i];+ }+ return x;+ +}+
+ test/tests.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings #-}+import Data.Monoid ((<>))+import qualified Data.Vector.Storable.Mutable as V+import Foreign.C.Types+import qualified Language.Haskell.TH as TH+import qualified Test.Hspec as Hspec+import Text.RawString.QQ (r)++import qualified Language.C.Inline as C+import qualified Language.C.Inline.Unsafe as CU+import qualified Language.C.Inline.Internal as C+import qualified Language.C.Inline.ContextSpec+import qualified Language.C.Inline.ParseSpec+import qualified Language.C.Types as C+import qualified Language.C.Types.ParseSpec++import Dummy++C.context (C.baseCtx <> C.funCtx <> C.vecCtx)++C.include "<math.h>"+C.include "<stdio.h>"++C.verbatim [r|+int francescos_mul(int x, int y) {+ return x * y;+}+|]++foreign import ccall "francescos_mul" francescos_mul :: Int -> Int -> Int++main :: IO ()+main = Hspec.hspec $ do+ Hspec.describe "Language.C.Types.Parse" Language.C.Types.ParseSpec.spec+ Hspec.describe "Language.C.Inline.Context" Language.C.Inline.ContextSpec.spec+ Hspec.describe "Language.C.Inline.Parse" Language.C.Inline.ParseSpec.spec+ Hspec.describe "TH integration" $ do+ Hspec.it "inlineCode" $ do+ let c_add = $(C.inlineCode $ C.Code+ TH.Unsafe -- Call safety+ [t| Int -> Int -> Int |] -- Call type+ "francescos_add" -- Call name+ -- C Code+ [r| int francescos_add(int x, int y) { int z = x + y; return z; } |])+ c_add 3 4 `Hspec.shouldBe` 7+ Hspec.it "inlineItems" $ do+ let c_add3 = $(C.inlineItems+ TH.Unsafe+ [t| CInt -> CInt |]+ (C.quickCParser_ "int" C.parseType)+ [("x", C.quickCParser_ "int" C.parseType)]+ [r| return x + 3; |])+ c_add3 1 `Hspec.shouldBe` 1 + 3+ Hspec.it "inlineExp" $ do+ let x = $(C.inlineExp+ TH.Safe+ [t| CInt |]+ (C.quickCParser_ "int" C.parseType)+ []+ [r| 1 + 4 |])+ x `Hspec.shouldBe` 1 + 4+ Hspec.it "inlineCode" $ do+ francescos_mul 3 4 `Hspec.shouldBe` 12+ Hspec.it "exp" $ do+ let x = 3+ let y = 4+ z <- [C.exp| int{ $(int x) + $(int y) + 5 } |]+ z `Hspec.shouldBe` x + y + 5+ Hspec.it "pure" $ do+ let x = 2+ let y = 10+ let z = [C.pure| int{ $(int x) + 10 + $(int y) } |]+ z `Hspec.shouldBe` x + y + 10+ Hspec.it "unsafe exp" $ do+ let x = 2+ let y = 10+ z <- [CU.exp| int{ 7 + $(int x) + $(int y) } |]+ z `Hspec.shouldBe` x + y + 7+ Hspec.it "void exp" $ do+ [C.exp| void { printf("Hello\n") } |]+ Hspec.it "function pointer argument" $ do+ let ackermann m n+ | m == 0 = n + 1+ | m > 0 && n == 0 = ackermann (m - 1) 1+ | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1))+ | otherwise = error "ackermann"+ ackermannPtr <- $(C.mkFunPtr [t| CInt -> CInt -> IO CInt |]) $ \m n -> return $ ackermann m n+ let x = 3+ let y = 4+ z <- [C.exp| int { $(int (*ackermannPtr)(int, int))($(int x), $(int y)) } |]+ z `Hspec.shouldBe` ackermann x y+ Hspec.it "function pointer result" $ do+ c_add <- [C.exp| int (*)(int, int) { &francescos_add } |]+ x <- $(C.peekFunPtr [t| CInt -> CInt -> IO CInt |]) c_add 1 2+ x `Hspec.shouldBe` 1 + 2+ Hspec.it "quick function pointer argument" $ do+ let ackermann m n+ | m == 0 = n + 1+ | m > 0 && n == 0 = ackermann (m - 1) 1+ | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1))+ | otherwise = error "ackermann"+ let ackermann_ m n = return $ ackermann m n+ let x = 3+ let y = 4+ z <- [C.exp| int { $fun:(int (*ackermann_)(int, int))($(int x), $(int y)) } |]+ z `Hspec.shouldBe` ackermann x y+ Hspec.it "function pointer argument (pure)" $ do+ let ackermann m n+ | m == 0 = n + 1+ | m > 0 && n == 0 = ackermann (m - 1) 1+ | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1))+ | otherwise = error "ackermann"+ ackermannPtr <- $(C.mkFunPtr [t| CInt -> CInt -> CInt |]) ackermann+ let x = 3+ let y = 4+ let z = [C.pure| int { $(int (*ackermannPtr)(int, int))($(int x), $(int y)) } |]+ z `Hspec.shouldBe` ackermann x y+ Hspec.it "quick function pointer argument (pure)" $ do+ let ackermann m n+ | m == 0 = n + 1+ | m > 0 && n == 0 = ackermann (m - 1) 1+ | m > 0 && n > 0 = ackermann (m - 1) (ackermann m (n - 1))+ | otherwise = error "ackermann"+ let x = 3+ let y = 4+ let z = [C.pure| int { $fun:(int (*ackermann)(int, int))($(int x), $(int y)) } |]+ z `Hspec.shouldBe` ackermann x y+ Hspec.it "test mkFunPtrFromName" $ do+ fun <- $(C.mkFunPtrFromName 'dummyFun)+ z <- [C.exp| double { $(double (*fun)(double))(3.0) } |]+ z' <- dummyFun 3.0+ z `Hspec.shouldBe` z'+ Hspec.it "vectors" $ do+ let n = 10+ vec <- V.replicate (fromIntegral n) 3+ sum' <- V.unsafeWith vec $ \ptr -> [C.block| int {+ int i;+ int x = 0;+ for (i = 0; i < $(int n); i++) {+ x += $(int *ptr)[i];+ }+ return x;+ } |]+ sum' `Hspec.shouldBe` 3 * 10+ Hspec.it "quick vectors" $ do+ vec <- V.replicate 10 3+ sum' <- [C.block| int {+ int i;+ int x = 0;+ for (i = 0; i < $vec-len:vec; i++) {+ x += $vec-ptr:(int *vec)[i];+ }+ return x;+ } |]+ sum' `Hspec.shouldBe` 3 * 10