diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2011-2013, Ian-Woo Kim. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,10 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> import Distribution.PackageDescription +> --import System.Process +> main = defaultMain +> --main = defaultMainWithHooks testUserHooks +> --testUserHooks = simpleUserHooks { +> -- preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo +> -- } diff --git a/csrc/MacroPatternMatch.h b/csrc/MacroPatternMatch.h new file mode 100644 --- /dev/null +++ b/csrc/MacroPatternMatch.h @@ -0,0 +1,20 @@ +#ifndef __MACROPATTERNMATCH__ +#define __MACROPATTERNMATCH__ + + +#define CAT(a,...) PRIMITIVE_CAT(a, __VA_ARGS__ ) +#define PRIMITIVE_CAT(a,...) a ## __VA_ARGS__ + +#define IIF(c) PRIMITIVE_CAT(IIF_, c) +#define IIF_0(t, ...) __VA_ARGS__ +#define IIF_1(t, ...) t + +#define CHECK_N(x, n, ... ) n +#define CHECK(...) CHECK_N (__VA_ARGS__, 0, ) +#define PROBE(x) x, 1, + +#define IS_PAREN(x) CHECK(IS_PAREN_PROBE x) +#define IS_PAREN_PROBE(...) PROBE(~) + +#endif // __MACROPATTERNMATCH__ + diff --git a/fficxx-runtime.cabal b/fficxx-runtime.cabal new file mode 100644 --- /dev/null +++ b/fficxx-runtime.cabal @@ -0,0 +1,29 @@ +Name: fficxx-runtime +Version: 0.1 +Synopsis: Runtime for fficxx-generated library +Description: Runtime for fficxx-generated library +License: BSD3 +License-file: LICENSE +Author: Ian-Woo Kim +Maintainer: Ian-Woo Kim +Build-Type: Simple +Category: FFI Tools +Cabal-Version: >= 1.8 +Data-files: + +Source-repository head + type: git + location: http://www.github.com/wavewave/fficxx-runtime + +Library + hs-source-dirs: lib + ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind + ghc-prof-options: -caf-all -auto-all + Build-Depends: + base == 4.* + + Exposed-Modules: + FFICXX.Runtime.Cast + + Include-dirs: csrc + Install-includes: MacroPatternMatch.h diff --git a/lib/FFICXX/Runtime/Cast.hs b/lib/FFICXX/Runtime/Cast.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Runtime/Cast.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, + FlexibleInstances, TypeSynonymInstances, + EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables, + GADTs #-} + +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Runtime.Cast +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module FFICXX.Runtime.Cast where + +import Data.Word +import Foreign.C +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Marshal.Array + +import System.IO.Unsafe + +class Castable a b where + cast :: a -> b + uncast :: b -> a + +class FPtr a where + type Raw a :: * + get_fptr :: a -> ForeignPtr (Raw a) + cast_fptr_to_obj :: ForeignPtr (Raw a) -> a + +class Existable a where + data Exist a :: * + +data BottomType + +class GADTTypeable a where + data GADTType a :: * -> * + data EGADTType a :: * + + + + +{- +-- eliminate this for the time being to have a solution with Repl +instance Castable a a where + cast = id + uncast = id +-} + +instance Castable () () where + cast = id + uncast = id + +instance Castable Int CInt where + cast = fromIntegral + uncast = fromIntegral + +instance Castable Word CUInt where + cast = fromIntegral + uncast = fromIntegral + +instance Castable Double CDouble where + cast = realToFrac + uncast = realToFrac + +instance Castable [Double] (Ptr CDouble) where + cast xs = unsafePerformIO (newArray (map realToFrac xs)) + uncast _c_xs = undefined + +instance Castable [Int] (Ptr CInt) where + cast xs = unsafePerformIO (newArray (map fromIntegral xs)) + uncast _c_xs = undefined + +instance Castable String CString where + cast x = unsafePerformIO (newCString x) + uncast x = unsafePerformIO (peekCString x) + +instance Castable [String] (Ptr CString) where + cast xs = unsafePerformIO (mapM newCString xs >>= newArray) + uncast _c_xs = undefined + +instance (Castable a a', Castable b b') => Castable (a->b) (a'->b') where + cast f = cast . f . uncast + uncast f = uncast . f . cast + + +xformnull :: (Castable a ca) => (IO ca) -> IO a +xformnull f = f >>= return . uncast + +xform0 :: (Castable a ca, Castable y cy) + => (ca -> IO cy) -> a -> IO y +xform0 f a = f (cast a) >>= return . uncast + +xform1 :: (Castable a ca, Castable x1 cx1, Castable y cy) + => (ca -> cx1 -> IO cy) -> a -> x1 -> IO y +xform1 f a x1 = f (cast a) (cast x1) >>= return . uncast + +xform2 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable y cy) + => (ca -> cx1 -> cx2 -> IO cy) -> a -> x1 -> x2-> IO y +xform2 f a x1 x2 = f (cast a) (cast x1) (cast x2) >>= return . uncast + +xform3 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable y cy) + => (ca -> cx1 -> cx2 -> cx3 -> IO cy) -> a -> x1 -> x2 -> x3 -> IO y +xform3 f a x1 x2 x3 = f (cast a) (cast x1) (cast x2) (cast x3) >>= return . uncast + +xform4 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4, Castable y cy) + => (ca -> cx1 -> cx2 -> cx3 -> cx4 -> IO cy) -> a -> x1 -> x2 -> x3 -> x4 -> IO y +xform4 f a x1 x2 x3 x4 = f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) >>= return . uncast + +xform5 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4, + Castable x5 cx5, Castable y cy) + => (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> IO cy) -> a -> x1 -> x2 -> x3 -> x4 -> x5 -> IO y +xform5 f a x1 x2 x3 x4 x5 = f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) >>= return . uncast + +xform6 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4, + Castable x5 cx5, Castable x6 cx6, Castable y cy) + => (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> IO cy) + -> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> IO y +xform6 f a x1 x2 x3 x4 x5 x6 = + f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) + >>= return . uncast + +xform7 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4, + Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable y cy) + => (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> IO cy) + -> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> IO y +xform7 f a x1 x2 x3 x4 x5 x6 x7 = + f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7) + >>= return . uncast + +xform8 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4, + Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable x8 cx8, Castable y cy) + => (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> cx8 -> IO cy) + -> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> x8 -> IO y +xform8 f a x1 x2 x3 x4 x5 x6 x7 x8 = + f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7) (cast x8) + >>= return . uncast + +xform9 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4, + Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable x8 cx8, Castable x9 cx9, + Castable y cy) + => (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> cx8 -> cx9 -> IO cy) + -> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> x8 -> x9 -> IO y +xform9 f a x1 x2 x3 x4 x5 x6 x7 x8 x9 = + f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7) (cast x8) (cast x9) + >>= return . uncast + +xform10 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4, + Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable x8 cx8, Castable x9 cx9, + Castable x10 cx10, Castable y cy) + => (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> cx8 -> cx9 -> cx10 -> IO cy) + -> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> x8 -> x9 -> x10 -> IO y +xform10 f a x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 = + f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7) (cast x8) (cast x9) (cast x10) >>= return . uncast + +xform11 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4, + Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable x8 cx8, Castable x9 cx9, + Castable x10 cx10, Castable x11 cx11, Castable y cy) + => (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> cx8 -> cx9 -> cx10 -> cx11 -> IO cy) + -> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> x8 -> x9 -> x10 -> x11 -> IO y +xform11 f a x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 = + f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7) (cast x8) (cast x9) (cast x10) (cast x11) >>= return . uncast +