diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/gsl-ode.c b/examples/gsl-ode.c new file mode 100644 --- /dev/null +++ b/examples/gsl-ode.c @@ -0,0 +1,50 @@ + +#include + +#include + +#include + +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 ); +} + diff --git a/examples/gsl-ode.hs b/examples/gsl-ode.hs new file mode 100644 --- /dev/null +++ b/examples/gsl-ode.hs @@ -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 "" +C.include "" +C.include "" + +-- | 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 diff --git a/inline-c.cabal b/inline-c.cabal new file mode 100644 --- /dev/null +++ b/inline-c.cabal @@ -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 . +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 diff --git a/src/Language/C/Inline.hs b/src/Language/C/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Inline.hs @@ -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 { \ } |] +-- @ +-- +-- 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 @\@ 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 +-- . +-- +-- == 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' "\" +-- +-- 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' "\" +-- +-- 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 "\" ==> #include \ +-- @ +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 [] diff --git a/src/Language/C/Inline/Context.hs b/src/Language/C/Inline/Context.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Inline/Context.hs @@ -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)" + } diff --git a/src/Language/C/Inline/FunPtr.hs b/src/Language/C/Inline/FunPtr.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Inline/FunPtr.hs @@ -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" diff --git a/src/Language/C/Inline/Internal.hs b/src/Language/C/Inline/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Inline/Internal.hs @@ -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 . + +-- | 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 _ = "<>" + +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)) "" diff --git a/src/Language/C/Inline/Unsafe.hs b/src/Language/C/Inline/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Inline/Unsafe.hs @@ -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 +-- . +-- 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 diff --git a/src/Language/C/Types.hs b/src/Language/C/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Types.hs @@ -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) "" diff --git a/src/Language/C/Types/Parse.hs b/src/Language/C/Types/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Types/Parse.hs @@ -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 +-- . +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 , +-- 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 \ +-- +-- extern char yytext[]; +-- extern int column; +-- +-- void yyerror(char const *s) +-- { +-- fflush(stdout); +-- printf("\n%*s\n%*s\n", column, "^", column, s); +-- } +-- @ diff --git a/test/tests.c b/test/tests.c new file mode 100644 --- /dev/null +++ b/test/tests.c @@ -0,0 +1,96 @@ + +#include + +#include + + +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; + +} + diff --git a/test/tests.hs b/test/tests.hs new file mode 100644 --- /dev/null +++ b/test/tests.hs @@ -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 "" +C.include "" + +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