clr-marshal (empty) → 0.1.0.0

raw patch · 5 files changed

+196/−0 lines, 5 filesdep +basedep +clr-hostdep +textsetup-changed

Dependencies added: base, clr-host, text

Files

LICENSE +30/−0
Setup.hs +2/−0
clr-marshal.cabal +26/−0
src/Clr/Marshal.hs +91/−0
src/Clr/Marshal/Host.hs +47/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2016-2017, Tim Matthews++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.++    * Neither the name of Tim Matthews nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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+OWNER OR CONTRIBUTORS 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ clr-marshal.cabal view

@@ -0,0 +1,26 @@+name:                clr-marshal+version:             0.1.0.0+synopsis:            Marshaling for the clr+description:         A common dependency for other clr packages, marshalling between Haskell & CLR data types.+homepage:            https://gitlab.com/tim-m89/clr-haskell/tree/master/libs/clr-marshal+cabal-version:       >=1.10+build-type:          Simple+license:             BSD3+license-file:        LICENSE+author:              Tim Matthews+maintainer:          tim.matthews7@gmail.com+copyright:           Copyright: (c) 2016-2017 Tim Matthews+category:            Language, FFI, CLR, .NET++source-repository head+    type:            git+    location:        https://gitlab.com/tim-m89/clr-haskell/tree/master++library+  hs-source-dirs:      src+  default-language:    Haskell2010+  exposed-modules:     Clr.Marshal+                       Clr.Marshal.Host+  build-depends:       base >= 4.7 && < 5+                     , clr-host+                     , text

+ src/Clr/Marshal.hs view

@@ -0,0 +1,91 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE BangPatterns #-}+module Clr.Marshal where++import Clr.Host.BStr+import Data.Coerce+import Data.Text+import Data.Text.Foreign+import Data.Word++import Foreign.Ptr+import Foreign.Storable++--+-- Conversion from a high level Haskell type a a raw bridge type+--+class Marshal a b where+  marshal :: a -> (b -> IO c) -> IO c++--+-- identity instance+--+instance {-# OVERLAPPABLE #-} (a ~ b) => Marshal a b where+  marshal x f = f x++--+-- 2-tuple instance+--+instance {-# OVERLAPS #-} (Marshal a1 b1, Marshal a2 b2) => Marshal (a1, a2) (b1, b2) where+  marshal (x1,x2) f = marshal x1 $ \x1'-> marshal x2 $ \x2'-> f (x1', x2')++--+-- 3-tuple instance+--+instance {-# OVERLAPS #-} (Marshal a1 b1, Marshal a2 b2, Marshal a3 b3) => Marshal (a1, a2, a3) (b1, b2, b3) where+  marshal (x1,x2,x3) f = marshal x1 $ \x1'-> marshal x2 $ \x2'-> marshal x3 $ \x3'-> f (x1', x2', x3')++--+-- 4-tuple instance+--+instance {-# OVERLAPS #-} (Marshal a1 b1, Marshal a2 b2, Marshal a3 b3, Marshal a4 b4) => Marshal (a1, a2, a3, a4) (b1, b2, b3, b4) where+  marshal (x1,x2,x3,x4) f = marshal x1 $ \x1'-> marshal x2 $ \x2'-> marshal x3 $ \x3'-> marshal x4 $ \x4'-> f (x1', x2', x3', x4')++--+-- 5-tuple instance+--+instance {-# OVERLAPS #-} (Marshal a1 b1, Marshal a2 b2, Marshal a3 b3, Marshal a4 b4, Marshal a5 b5) => Marshal (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) where+  marshal (x1,x2,x3,x4,x5) f = marshal x1 $ \x1'-> marshal x2 $ \x2'-> marshal x3 $ \x3'-> marshal x4 $ \x4'-> marshal x5 $ \x5'-> f (x1', x2', x3', x4', x5')++--+-- BStr instance+--+instance Marshal Text BStr where+  marshal x f = do+    bstr <- useAsPtr x (\p-> \l-> allocBStr p l)+    !res <- f bstr+    freeBStr bstr+    return res++instance Marshal String BStr where+  marshal x f = marshal (pack x) f++--+-- Conversion from a raw bridge type of a methods result to a high level Haskell type+--+class Unmarshal a b where+  unmarshal :: a -> IO b++--+-- Identity instance+--+instance {-# OVERLAPPABLE #-} a ~ b => Unmarshal a b where+  unmarshal = return++--+-- BStr instances+--+instance Unmarshal BStr Text where+  unmarshal x = do+    let charSize = 2+    let ptrData   = coerce x              :: Ptr Word16+    let ptrLen    = plusPtr ptrData (-4)  :: Ptr Word16+    lenBytes     <- peek ptrLen+    !t <- fromPtr ptrData $ fromIntegral $ lenBytes `div` charSize+    freeBStr x+    return t++instance Unmarshal BStr String where+  unmarshal x = unmarshal x >>= return . unpack

+ src/Clr/Marshal/Host.hs view

@@ -0,0 +1,47 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Clr.Marshal.Host where++import Clr.Marshal++import Clr.Host+import Clr.Host.BStr++import Data.Coerce+import Data.Word+import Foreign.Ptr++-- | @'unsafeGetPointerToMethod' m@ returns a function pointer to the method @m@+--  as implemented in the Salsa .NET driver assembly (Salsa.dll).  It is safe only+--  if the type of the resulting function pointer matches that of the method given.+unsafeGetPointerToMethod :: String -> IO (FunPtr a)+unsafeGetPointerToMethod methodName = do+  result <- marshal methodName $ \(methodName'::BStr) -> getPointerToMethodRaw >>= \f-> f $ coerce methodName'+  if result == nullFunPtr+    then error $ "Unable to execute Salsa.dll method '" ++ methodName ++ "'."+    else return result++getPointerToMethodRaw :: IO (GetPtrToMethod a)+getPointerToMethodRaw = getPtrToMethod_get >>= return . makeGetPtrToMethod++foreign import ccall "dynamic" makeGetPtrToMethod :: GetPtrToMethodFunPtr a -> GetPtrToMethod a++-- | @'getMethodStub' c m s@ returns a function pointer to a function that, when+--   called, invokes the method with name @m@ and signature @s@ in class @c@.+--+--   @s@ should be a semi-colon delimited list of parameter types indicating the+--   desired overload of the given method.+getMethodStub :: String -> String -> String -> IO (FunPtr f)+getMethodStub className methodName parameterTypeNames = do+  marshal className $ \className' ->+    marshal methodName $ \methodName' ->+      marshal parameterTypeNames $ \parameterTypeNames' ->+        getMethodStubRaw >>= \f-> return $ f className' methodName' parameterTypeNames'++getMethodStubRaw :: IO (GetMethodStubDelegate a)+getMethodStubRaw = unsafeGetPointerToMethod "GetMethodStub" >>= return . makeGetMethodStubDelegate++type GetMethodStubDelegate a = BStr -> BStr -> BStr -> FunPtr a+foreign import ccall "dynamic" makeGetMethodStubDelegate :: FunPtr (GetMethodStubDelegate a) -> GetMethodStubDelegate a++