packages feed

clr-bindings 0.1.0.0 → 0.2.0

raw patch · 10 files changed

+458/−243 lines, 10 filesnew-uploader

Files

clr-bindings.cabal view
@@ -1,12 +1,12 @@ name:                clr-bindings-version:             0.1.0.0+version:             0.2.0 synopsis:            Glue between clr-host and clr-typed description:         Please see README.md homepage:            https://gitlab.com/tim-m89/clr-haskell/tree/master/libs/clr-bindings license:             BSD3 license-file:        LICENSE author:              Tim Matthews-maintainer:          tim.matthews7@gmail.com+maintainer:          pepeiborra@gmail.com copyright:           2017 Tim Matthews category:            Language, FFI, CLR, .NET build-type:          Simple@@ -19,12 +19,14 @@ library   hs-source-dirs:      src   exposed-modules:     Clr.Bindings-                     , Clr.Bindings.Box                      , Clr.Bindings.BStr                      , Clr.Bindings.DynImports-                     , Clr.Bindings.ImportGen+                     , Clr.Bindings.Exception                      , Clr.Bindings.IEnumerable+                     , Clr.Bindings.ImportGen                      , Clr.Bindings.Object+                     , Clr.Bindings.Object.Internal+                     , Clr.Bindings.WrapImports   build-depends:       base >= 4.7 && < 5, clr-typed, clr-host, clr-marshal, text, template-haskell, pipes   default-language:    Haskell2010
src/Clr/Bindings.hs view
@@ -1,34 +1,21 @@ module Clr.Bindings-  ( module Clr.Bindings.Box+  ( module Clr.Bindings.BStr   , module Clr.Bindings.DynImports-  , module Clr.Bindings.BStr+  , module Clr.Bindings.Object+  , module Clr.Bindings.WrapImports   , BStr(..)-  , saveDynamicAssembly   ) where  -import Clr.Marshal--import Clr.Host import Clr.Host.BStr -import Clr.Bindings.Box-import Clr.Bindings.DynImports-import Clr.Marshal.Host import Clr.Bindings.BStr+import Clr.Bindings.DynImports import Clr.Bindings.Object+import Clr.Bindings.WrapImports -import Data.Word-import Foreign.Ptr  --- | 'saveDynamicAssembly' saves the assembly containing the dynamically-generated---   wrapper stubs to disk (for debugging purposes).-saveDynamicAssembly :: IO ()-saveDynamicAssembly = unsafeGetPointerToMethod "SaveDynamicAssembly" >>=  makeSaveDynamicAssemblyDelegate--type SaveDynamicAssemblyDelegate = IO ()-foreign import ccall "dynamic" makeSaveDynamicAssemblyDelegate :: FunPtr SaveDynamicAssemblyDelegate -> SaveDynamicAssemblyDelegate
src/Clr/Bindings/BStr.hs view
@@ -6,7 +6,6 @@ import Clr import Clr.Bridge import Clr.Marshal-import Clr.UnmarshalAs  import Clr.Host.BStr @@ -19,13 +18,4 @@   type instance BridgeTypePrim (T "System.String" '[]) = BStr------- NB: This next line specifies that all methods--- returning a System.String, get the result--- converted to a Text. This needs a bit of work,--- but polymorphism in the return type is going--- to make compilation a lot harder. TODO.----type instance UnmarshalAs BStr = Text
− src/Clr/Bindings/Box.hs 
@@ -1,161 +0,0 @@-{-# LANGUAGE TypeApplications, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances #-}--module Clr.Bindings.Box where--import Clr-import Clr.Marshal--import Clr.Host.BStr--import Clr.Marshal.Host-import Clr.Bindings.BStr--import Data.Int-import Data.Text-import Data.Text.Foreign-import Data.Word-import Foreign.Marshal.Alloc-import Foreign.Ptr-import Foreign.Storable----- | @'getBoxStub' t@ returns a function pointer to a function that, when---   called, returns a boxed object reference to the given type.-getBoxStub :: String -> IO (FunPtr f)-getBoxStub typeName = marshal typeName $ \typeName'-> do-  stub <- getBoxStubRaw-  return $ stub typeName'--getBoxStubRaw :: IO (GetBoxStubDelegate a)-getBoxStubRaw = unsafeGetPointerToMethod "GetBoxStub" >>= return . makeGetBoxStubDelegate--type GetBoxStubDelegate a = BStr -> FunPtr a-foreign import ccall "dynamic" makeGetBoxStubDelegate :: FunPtr (GetBoxStubDelegate a) -> GetBoxStubDelegate a------- Text-----instance Marshal Text (ObjectID obj) where-  marshal x f = marshal @Text @BStr x $ \ptr-> do-    stub <- boxStringStub-    obj <- stub ptr-    f obj--type BoxStringStub a = BStr -> IO (ObjectID a)-foreign import ccall "dynamic" makeBoxStringStub :: FunPtr (BoxStringStub a) -> (BoxStringStub a)--boxStringStub :: IO (BoxStringStub a)-boxStringStub = getBoxStub "System.String" >>= return . makeBoxStringStub------- String-----instance Marshal String (ObjectID a) where-  marshal x f = marshal (pack x) f------- Int8-----instance Marshal Int8 (ObjectID obj) where-  marshal x f = boxInt8Stub >>= \stub-> stub x >>= f--type BoxInt8Stub a = Int8 -> IO (ObjectID a)-foreign import ccall "dynamic" makeBoxInt8Stub :: FunPtr (BoxInt8Stub a) -> (BoxInt8Stub a)--boxInt8Stub :: IO (BoxInt8Stub a)-boxInt8Stub = getBoxStub "System.SByte" >>= return . makeBoxInt8Stub------- Word8-----instance Marshal Word8 (ObjectID obj) where-  marshal x f = boxWord8Stub >>= \stub-> stub x >>= f--type BoxWord8Stub a = Word8 -> IO (ObjectID a)-foreign import ccall "dynamic" makeBoxWord8Stub :: FunPtr (BoxWord8Stub a) -> (BoxWord8Stub a)--boxWord8Stub :: IO (BoxWord8Stub a)-boxWord8Stub = getBoxStub "System.Byte" >>= return . makeBoxWord8Stub------- Int16-----instance Marshal Int16 (ObjectID obj) where-  marshal x f = boxInt16Stub >>= \stub-> stub x >>= f--type BoxInt16Stub a = Int16 -> IO (ObjectID a)-foreign import ccall "dynamic" makeBoxInt16Stub :: FunPtr (BoxInt16Stub a) -> (BoxInt16Stub a)--boxInt16Stub :: IO (BoxInt16Stub a)-boxInt16Stub = getBoxStub "System.Int16" >>= return . makeBoxInt16Stub------- Word16-----instance Marshal Word16 (ObjectID obj) where-  marshal x f = boxWord16Stub >>= \stub-> stub x >>= f--type BoxWord16Stub a = Word16 -> IO (ObjectID a)-foreign import ccall "dynamic" makeBoxWord16Stub :: FunPtr (BoxWord16Stub a) -> (BoxWord16Stub a)--boxWord16Stub :: IO (BoxWord16Stub a)-boxWord16Stub = getBoxStub "System.UInt16" >>= return . makeBoxWord16Stub------- Int32-----instance Marshal Int32 (ObjectID obj) where-  marshal x f = boxInt32Stub >>= \stub-> stub x >>= f--type BoxInt32Stub a = Int32 -> IO (ObjectID a)-foreign import ccall "dynamic" makeBoxInt32Stub :: FunPtr (BoxInt32Stub a) -> (BoxInt32Stub a)--boxInt32Stub :: IO (BoxInt32Stub a)-boxInt32Stub = getBoxStub "System.Int32" >>= return . makeBoxInt32Stub------- Word32-----instance Marshal Word32 (ObjectID obj) where-  marshal x f = boxWord32Stub >>= \stub-> stub x >>= f--type BoxWord32Stub a = Word32 -> IO (ObjectID a)-foreign import ccall "dynamic" makeBoxWord32Stub :: FunPtr (BoxWord32Stub a) -> (BoxWord32Stub a)--boxWord32Stub :: IO (BoxWord32Stub a)-boxWord32Stub = getBoxStub "System.UInt32" >>= return . makeBoxWord32Stub------- Int64-----instance Marshal Int64 (ObjectID obj) where-  marshal x f = boxInt64Stub >>= \stub-> stub x >>= f--type BoxInt64Stub a = Int64 -> IO (ObjectID a)-foreign import ccall "dynamic" makeBoxInt64Stub :: FunPtr (BoxInt64Stub a) -> (BoxInt64Stub a)--boxInt64Stub :: IO (BoxInt64Stub a)-boxInt64Stub = getBoxStub "System.Int64" >>= return . makeBoxInt64Stub------- Word64-----instance Marshal Word64 (ObjectID obj) where-  marshal x f = boxWord64Stub >>= \stub-> stub x >>= f--type BoxWord64Stub a = Word64 -> IO (ObjectID a)-foreign import ccall "dynamic" makeBoxWord64Stub :: FunPtr (BoxWord64Stub a) -> (BoxWord64Stub a)--boxWord64Stub :: IO (BoxWord64Stub a)-boxWord64Stub = getBoxStub "System.UInt64" >>= return . makeBoxWord64Stub-
src/Clr/Bindings/DynImports.hs view
@@ -9,7 +9,8 @@ import Clr.Property import Clr.TypeString -import Clr.Marshal.Host+import Clr.Host+import Clr.Host.Method  import Data.Kind import Foreign.Ptr@@ -46,22 +47,22 @@ -- which is specified by implementing a _DynImport_ class -- class MethodDynImportI1 t m arg0 where-  methodDynImportI1 :: DynamicImportType (BridgeType t -> IngoreUnitType (BridgeType arg0) (IO (BridgeTypeM (ResultTypeI1 t m arg0))))+  methodDynImportI1 :: DynamicImportType (BridgeType t -> IngoreUnitType (BridgeType arg0) (IO (BridgeType (ResultTypeI1 t m arg0))))  class MethodDynImportI2 t m arg0 arg1 where-  methodDynImportI2 :: DynamicImportType (BridgeType t -> BridgeType arg0 -> BridgeType arg1 -> IO (BridgeTypeM (ResultTypeI2 t m arg0 arg1)))+  methodDynImportI2 :: DynamicImportType (BridgeType t -> BridgeType arg0 -> BridgeType arg1 -> IO (BridgeType (ResultTypeI2 t m arg0 arg1)))  class MethodDynImportI3 t m arg0 arg1 arg2 where-  methodDynImportI3 :: DynamicImportType (BridgeType t -> BridgeType arg0 -> BridgeType arg1 -> BridgeType arg2 -> IO (BridgeTypeM (ResultTypeI3 t m arg0 arg1 arg2)))+  methodDynImportI3 :: DynamicImportType (BridgeType t -> BridgeType arg0 -> BridgeType arg1 -> BridgeType arg2 -> IO (BridgeType (ResultTypeI3 t m arg0 arg1 arg2)))  class MethodDynImportS1 t m arg0 where-  methodDynImportS1 :: DynamicImportType (IngoreUnitType (BridgeType arg0) (IO (BridgeTypeM (ResultTypeS1 t m arg0))))+  methodDynImportS1 :: DynamicImportType (IngoreUnitType (BridgeType arg0) (IO (BridgeType (ResultTypeS1 t m arg0))))  class MethodDynImportS2 t m arg0 arg1 where-  methodDynImportS2 :: DynamicImportType (BridgeType arg0 -> BridgeType arg1 -> IO (BridgeTypeM (ResultTypeS2 t m arg0 arg1)))+  methodDynImportS2 :: DynamicImportType (BridgeType arg0 -> BridgeType arg1 -> IO (BridgeType (ResultTypeS2 t m arg0 arg1)))  class MethodDynImportS3 t m arg0 arg1 arg2 where-  methodDynImportS3 :: DynamicImportType (BridgeType arg0 -> BridgeType arg1 -> BridgeType arg2 -> IO (BridgeTypeM (ResultTypeS3 t m arg0 arg1 arg2)))+  methodDynImportS3 :: DynamicImportType (BridgeType arg0 -> BridgeType arg1 -> BridgeType arg2 -> IO (BridgeType (ResultTypeS3 t m arg0 arg1 arg2)))  class ConstructorDynImport1 t arg0 where   constructorDynImport1 :: DynamicImportType (IngoreUnitType (BridgeType arg0) (IO (BridgeType t)))@@ -94,12 +95,12 @@          , TString arg0          , MethodResultI1 t m arg0          , MethodDynImportI1 t m arg0-         , HandleUnit (IngoreUnitType (BridgeType arg0) (IO (BridgeTypeM (ResultTypeI1 t m arg0)))) (BridgeType arg0) (IO (BridgeTypeM (ResultTypeI1 t m arg0)))+         , HandleUnit (IngoreUnitType (BridgeType arg0) (IO (BridgeType (ResultTypeI1 t m arg0)))) (BridgeType arg0) (IO (BridgeType (ResultTypeI1 t m arg0)))          ) => MethodInvokeI1 t m arg0 where   rawInvokeI1 obj x = do     fp   <- getMethodStub (tString @t) (tString @m) (tString @arg0)     let f = methodDynImportI1 @t @m @arg0 fp-    handleUnit @(IngoreUnitType (BridgeType arg0) (IO (BridgeTypeM (ResultTypeI1 t m arg0)))) @(BridgeType arg0) @(IO (BridgeTypeM (ResultTypeI1 t m arg0))) (f obj) x+    handleUnit @(IngoreUnitType (BridgeType arg0) (IO (BridgeType (ResultTypeI1 t m arg0)))) @(BridgeType arg0) @(IO (BridgeType (ResultTypeI1 t m arg0))) (f obj) x  instance ( TString t          , TString m@@ -125,12 +126,12 @@          , TString arg0          , MethodResultS1 t m arg0          , MethodDynImportS1 t m arg0-         , HandleUnit (IngoreUnitType (BridgeType arg0) (IO (BridgeTypeM (ResultTypeS1 t m arg0)))) (BridgeType arg0) (IO (BridgeTypeM (ResultTypeS1 t m arg0)))+         , HandleUnit (IngoreUnitType (BridgeType arg0) (IO (BridgeType (ResultTypeS1 t m arg0)))) (BridgeType arg0) (IO (BridgeType (ResultTypeS1 t m arg0)))          ) => MethodInvokeS1 t m arg0 where   rawInvokeS1 x = do     fp   <- getMethodStub (tString @t) (tString @m) (tString @arg0)     let f = methodDynImportS1 @t @m @arg0 fp-    handleUnit @(IngoreUnitType (BridgeType arg0) (IO (BridgeTypeM (ResultTypeS1 t m arg0)))) @(BridgeType arg0) @(IO (BridgeTypeM (ResultTypeS1 t m arg0))) f x+    handleUnit @(IngoreUnitType (BridgeType arg0) (IO (BridgeType (ResultTypeS1 t m arg0)))) @(BridgeType arg0) @(IO (BridgeType (ResultTypeS1 t m arg0))) f x  instance ( TString t          , TString m
+ src/Clr/Bindings/Exception.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE GADTs, DataKinds, KindSignatures, PolyKinds, TypeFamilies, TypeOperators, RankNTypes, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, ScopedTypeVariables, ExistentialQuantification #-}+{-# LANGUAGE UndecidableInstances, TypeApplications, AllowAmbiguousTypes, TypeInType, TypeFamilyDependencies, FunctionalDependencies #-}++module Clr.Bindings.Exception(catch) where++import Clr+import Clr.Bridge+import Clr.Curry+import Clr.Resolver+import Clr.TypeString+import Clr.Types++import Clr.Bindings.BStr+import Clr.Bindings.DynImports+import Clr.Bindings.Object+import Clr.Bindings.WrapImports++import Clr.Host.BStr+import Clr.Host.GCHandle++import Clr.Marshal+import Clr.MarshalF++import Control.Concurrent+import GHC.TypeLits+import Data.Kind+import Data.Typeable+import Foreign.Ptr++import Data.Text++-- Synonyms to help prevent typos later on+type T_Exception            = T "System.Exception" '[]+type T_Driver               = T "Salsa.Driver" '[]+type T_TryDelegate   a      = T "Salsa.TryDelegate" '[a]+type T_CatchDelegate a ex   = T "Salsa.CatchDelegate" '[a, ex]+type T_RunCatchHandler a ex = T "RunCatchHandler" '[a, ex]++-- Only 1 overload candidate for RunCatchHandler+type instance Candidates T_Driver (T_RunCatchHandler a ex) = '[ '[ T_TryDelegate a, T_CatchDelegate a ex] ]++-- We have 2 delegate types, 1 for the try handler+instance Delegate (T_TryDelegate a) where+  type DelegateArgTypes   (T_TryDelegate a)      = '[]+  type DelegateResultType (T_TryDelegate a)      = a++-- And another for the catch handler+instance Delegate (T_CatchDelegate a ex) where+  type DelegateArgTypes   (T_CatchDelegate a ex) = '[ ex ]+  type DelegateResultType (T_CatchDelegate a ex) = a++-- Foreign imports for non primitive results+foreign import ccall "wrapper" wrapTryDelegateObj      :: (IO (GCHandle a)) -> IO (FunPtr (IO (GCHandle a)))+foreign import ccall "wrapper" wrapCatchDelegateObj    :: (GCHandle ex -> IO (GCHandle a)) -> IO (FunPtr (GCHandle ex -> IO (GCHandle a)))+foreign import ccall "dynamic" makeRunCatchHandlerObj  :: FunPtr (GCHandle tryD -> GCHandle catchD -> IO (GCHandle a)) -> (GCHandle tryD -> GCHandle catchD -> IO (GCHandle a))++-- Foreign imports for string results+foreign import ccall "wrapper" wrapTryDelegateBStr     :: (IO BStr) -> IO (FunPtr (IO BStr))+foreign import ccall "wrapper" wrapCatchDelegateBStr   :: (GCHandle ex -> IO BStr) -> IO (FunPtr (GCHandle ex -> IO BStr))+foreign import ccall "dynamic" makeRunCatchHandlerBStr :: FunPtr (GCHandle tryD -> GCHandle catchD -> IO BStr) -> (GCHandle tryD -> GCHandle catchD -> IO BStr)++-- TODO: foreign imports for other prims++-- Run catch handler is a static method of 2 args with this result type+instance MethodResultS2 T_Driver (T_RunCatchHandler a ex) (T_TryDelegate a) (T_CatchDelegate a ex) where+  type ResultTypeS2 T_Driver (T_RunCatchHandler a ex) (T_TryDelegate a) (T_CatchDelegate a ex) = a++-- Wrapper / Dyn import mappings for object result type+instance {-# OVERLAPS #-} (IsPrimType a ~ 'False, BridgeType a ~ GCHandle a) => WrapperImport (T_TryDelegate a) where+  wrapperImport = wrapTryDelegateObj+instance {-# OVERLAPS #-} (IsPrimType a ~ 'False, BridgeType a ~ GCHandle a, BridgeType ex ~ GCHandle ex) => WrapperImport (T_CatchDelegate a ex) where+  wrapperImport = wrapCatchDelegateObj+instance {-# OVERLAPS #-} (IsPrimType a ~ 'False, BridgeType a ~ GCHandle a) => MethodDynImportS2 T_Driver (T_RunCatchHandler a ex) (T_TryDelegate a) (T_CatchDelegate a ex) where+  methodDynImportS2 = makeRunCatchHandlerObj++-- Wrapper / Dyn import mappings for string result type+instance {-# OVERLAPS #-} WrapperImport (T_TryDelegate T_string) where+  wrapperImport = wrapTryDelegateBStr+instance {-# OVERLAPS #-} (BridgeType ex ~ GCHandle ex) => WrapperImport (T_CatchDelegate T_string ex) where+  wrapperImport = wrapCatchDelegateBStr+instance {-# OVERLAPS #-} MethodDynImportS2 T_Driver (T_RunCatchHandler T_string ex) (T_TryDelegate T_string) (T_CatchDelegate T_string ex) where+  methodDynImportS2 = makeRunCatchHandlerBStr++-- TODO: Wrapper / Dyn import mappings for other prims++-- The function that is exported+catch :: forall haskResult t_dTry t_dCatch t_handler t_ex t_args t_result b_try b_catch b_result .+          -- Types we know the most about+          ( t_ex `Implements` T_Exception ~ 'True+          , t_dTry    ~ (T_TryDelegate   t_result)+          , t_dCatch  ~ (T_CatchDelegate t_result t_ex)+          , t_handler ~ (T_RunCatchHandler t_result t_ex)+          -- Common contraints between types+          , IsPrimType t_ex ~ 'False+          , BridgeType t_ex ~ GCHandle t_ex+          , TString t_result+          , TString t_ex+          , t_result ~ HaskToClr haskResult+          , BridgeType t_result ~ b_result+          , Unmarshal haskResult b_result+          , Unmarshal b_result haskResult+          -- Constraints for the try delegate+          , t_dTry ~ (T_TryDelegate t_result)+          , Delegate t_dTry+          , DelegateArity t_dTry ~ 0+          , DelegateConstructorN 0 t_dTry+          , DelegateBridgeType t_dTry ~ b_try+          , DelegateResultType t_dTry ~ t_result+          , MarshalF 0 (IO haskResult) b_try+          -- Constraints for the catch delegate+          , t_dCatch ~ (T_CatchDelegate t_result t_ex)+          , Delegate t_dCatch+          , DelegateArity t_dCatch ~ 1+          , DelegateConstructorN 1 t_dCatch+          , DelegateBridgeType t_dCatch ~ b_catch+          , DelegateResultType t_dCatch ~ t_result+          , MarshalF 1 (Object t_ex -> IO haskResult) b_catch+          -- Constraints for the RunCatchHandler static method+          , t_args ~ '[ t_dTry, t_dCatch ]+          , ResolveMember t_args (Candidates T_Driver t_handler) ~ t_args+          , MethodS 2 T_Driver t_handler t_args+          ) => IO haskResult -> (Object t_ex -> IO haskResult) -> IO haskResult+catch tryF catchF = do+  tryD   <- makeTryDelegate tryF+  catchD <- makeCatchDelegate catchF+  runCatchHandler (tryD, catchD)++-- How to build a try delegate+makeTryDelegate :: forall t_dTry b_try t_result haskResult .+                    ( t_dTry ~ (T_TryDelegate t_result)+                    , Delegate t_dTry+                    , DelegateArity t_dTry ~ 0+                    , DelegateConstructorN 0 t_dTry+                    , DelegateBridgeType t_dTry ~ b_try+                    , DelegateResultType t_dTry ~ t_result+                    , MarshalF 0 (IO haskResult) b_try+                    , TString t_result+                    ) => IO haskResult -> IO (Object (T_TryDelegate t_result))+makeTryDelegate f = delegate @t_dTry f++-- How to build a catch delegate+makeCatchDelegate :: forall t_dCatch b_catch t_result haskResult t_ex .+                    ( t_ex `Implements` T_Exception ~ 'True+                    , t_dCatch ~ (T_CatchDelegate t_result t_ex)+                    , Delegate t_dCatch+                    , DelegateArity t_dCatch ~ 1+                    , DelegateConstructorN 1 t_dCatch+                    , DelegateBridgeType t_dCatch ~ b_catch+                    , DelegateResultType t_dCatch ~ t_result+                    , MarshalF 1 (Object t_ex -> IO haskResult) b_catch+                    , TString t_result+                    , TString t_ex+                    , IsPrimType t_ex ~ 'False+                    , BridgeType t_ex ~ GCHandle t_ex+                    , t_result ~ HaskToClr haskResult+                    , Unmarshal haskResult (BridgeType t_result)+                    ) => (Object t_ex -> IO haskResult) -> IO (Object (T_CatchDelegate t_result t_ex))+makeCatchDelegate f = delegate @t_dCatch f++-- The static method called to run this+runCatchHandler :: forall b_result haskResult t_result t_ex t_args t_dTry t_dCatch t_handler .+                    ( t_ex `Implements` T_Exception ~ 'True+                    , t_dTry    ~ (T_TryDelegate   t_result)+                    , t_dCatch  ~ (T_CatchDelegate t_result t_ex)+                    , t_handler ~ (T_RunCatchHandler t_result t_ex)+                    , t_args ~ '[ t_dTry, t_dCatch ]+                    , ResolveMember t_args (Candidates T_Driver t_handler) ~ t_args+                    , MethodS 2 T_Driver t_handler t_args+                    , BridgeType t_result ~ b_result+                    , Unmarshal b_result haskResult+                    ) => (Object (T_TryDelegate t_result), Object (T_CatchDelegate t_result t_ex))  -> IO haskResult+runCatchHandler (tryDel, catchDel) = invokeS @t_handler @T_Driver @b_result @haskResult (tryDel, catchDel)
src/Clr/Bindings/IEnumerable.hs view
@@ -7,16 +7,18 @@  import Clr import Clr.Bridge-import Clr.Marshal-import Clr.Marshal.Host-import Clr.UnmarshalAs+import Clr.Resolver import Clr.TypeString +import Clr.Marshal+ import Clr.Host import Clr.Host.BStr+import Clr.Host.GCHandle  import Clr.Bindings.BStr import Clr.Bindings.DynImports+import Clr.Bindings.Object  import Data.Kind import Data.Type.Bool@@ -46,22 +48,22 @@ type instance SuperTypes (T_IEnumerable t) = '[ T_IEnumerable', T_object ] type instance SuperTypes (T_IEnumerator t) = '[ T_IEnumerator', T_object ] -foreign import ccall "dynamic" makeGetEnumerator      :: FunPtr (ObjectID a -> IO (ObjectID b)) -> (ObjectID a -> IO (ObjectID b))-foreign import ccall "dynamic" makeEnumeratorMoveNext :: FunPtr (ObjectID (T_IEnumerator') -> IO Bool) -> (ObjectID (T_IEnumerator') -> IO Bool)+foreign import ccall "dynamic" makeGetEnumerator      :: FunPtr (GCHandle a -> IO (GCHandle b)) -> (GCHandle a -> IO (GCHandle b))+foreign import ccall "dynamic" makeEnumeratorMoveNext :: FunPtr (GCHandle (T_IEnumerator') -> IO Bool) -> (GCHandle (T_IEnumerator') -> IO Bool) -foreign import ccall "dynamic" makeEnumeratorCurrentBStr  :: FunPtr (ObjectID (T_IEnumerator elem) -> IO BStr) -> (ObjectID (T_IEnumerator elem) -> IO BStr)-foreign import ccall "dynamic" makeEnumeratorCurrentBool  :: FunPtr (ObjectID (T_IEnumerator elem) -> IO Bool) -> (ObjectID (T_IEnumerator elem) -> IO Bool)+foreign import ccall "dynamic" makeEnumeratorCurrentBStr  :: FunPtr (GCHandle (T_IEnumerator elem) -> IO BStr) -> (GCHandle (T_IEnumerator elem) -> IO BStr)+foreign import ccall "dynamic" makeEnumeratorCurrentBool  :: FunPtr (GCHandle (T_IEnumerator elem) -> IO Bool) -> (GCHandle (T_IEnumerator elem) -> IO Bool) -- TODO: makeEnumCurrent_ for every other prim type-foreign import ccall "dynamic" makeEnumeratorCurrentObj   :: FunPtr (ObjectID (T_IEnumerator elem) -> IO (ObjectID elem)) -> (ObjectID (T_IEnumerator elem) -> IO (ObjectID elem))+foreign import ccall "dynamic" makeEnumeratorCurrentObj   :: FunPtr (GCHandle (T_IEnumerator elem) -> IO (GCHandle elem)) -> (GCHandle (T_IEnumerator elem) -> IO (GCHandle elem))  instance MethodResultI1 (T_IEnumerable t) (T_GetEnumerator) () where-  type ResultTypeI1 (T_IEnumerable t) (T_GetEnumerator) () = 'Just (T_IEnumerator t)+  type ResultTypeI1 (T_IEnumerable t) (T_GetEnumerator) () = (T_IEnumerator t)  instance MethodDynImportI1 (T_IEnumerable t) (T_GetEnumerator) () where   methodDynImportI1 = makeGetEnumerator  instance MethodResultI1 T_IEnumerator' T_MoveNext () where-  type ResultTypeI1 T_IEnumerator' T_MoveNext () = 'Just T_bool+  type ResultTypeI1 T_IEnumerator' T_MoveNext () = T_bool  instance MethodDynImportI1 T_IEnumerator' T_MoveNext () where   methodDynImportI1 = makeEnumeratorMoveNext@@ -97,7 +99,6 @@ ienumCurrent :: forall elem propertyBridge propertyHask .   ( PropertyGetI (T_IEnumerator elem) T_Current   , BridgeType (PropertyTypeI (T_IEnumerator elem) T_Current) ~ propertyBridge-  , UnmarshalAs propertyBridge ~ propertyHask   , Unmarshal propertyBridge propertyHask   ) => Object (T_IEnumerator elem) -> IO propertyHask ienumCurrent ienum = getPropI @T_Current ienum@@ -111,7 +112,6 @@   , TString elem   , PropertyGetI (T_IEnumerator elem) T_Current   , BridgeType (PropertyTypeI (T_IEnumerator elem) T_Current) ~ elemBridge-  , UnmarshalAs elemBridge ~ elemHask   , Unmarshal elemBridge elemHask   ) => Object t -> Producer elemHask IO () toProducer ienumerable = do@@ -121,7 +121,6 @@ toProducer' :: forall elem elemBridge elemHask .   ( PropertyGetI (T_IEnumerator elem) T_Current   , BridgeType (PropertyTypeI (T_IEnumerator elem) T_Current) ~ elemBridge-  , UnmarshalAs elemBridge ~ elemHask   , Unmarshal elemBridge elemHask   ) => Object (T_IEnumerator elem) -> Producer elemHask IO () toProducer' ienumerator = do@@ -138,7 +137,6 @@   , TString elem   , PropertyGetI (T_IEnumerator elem) T_Current   , BridgeType (PropertyTypeI (T_IEnumerator elem) T_Current) ~ elemBridge-  , UnmarshalAs elemBridge ~ elemHask   , Unmarshal elemBridge elemHask   ) => Object t -> IO [elemHask] toListM ienumerable = Pipes.Prelude.toListM $ toProducer ienumerable
src/Clr/Bindings/Object.hs view
@@ -1,41 +1,58 @@-{-# LANGUAGE TypeInType, TypeApplications, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}+{-# LANGUAGE TypeInType, TypeApplications, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, TypeOperators, ScopedTypeVariables, AllowAmbiguousTypes #-} -module Clr.Bindings.Object where+module Clr.Bindings.Object+ ( objectToString+ , objectGetType+ , downCast+ ) where  import Clr import Clr.TypeString +import Clr.Marshal+ import Clr.Host import Clr.Host.BStr+import Clr.Host.GCHandle  import Clr.Bindings.DynImports-import Clr.Marshal.Host import Clr.Bindings.BStr--import Foreign.Ptr---type T_ToString = T "ToString" '[]--type instance SuperTypes T_object = '[ ]--type instance Members T_object = '[ T_ToString, T "GetType" '[] ]--type instance Candidates T_object  T_ToString       = '[ '[ ] ]-type instance Candidates T_object (T "GetType" '[]) = '[ '[ ] ]+import Clr.Bindings.Object.Internal -foreign import ccall "dynamic" makeToString :: FunPtr (ObjectID t -> IO BStr) -> (ObjectID t -> IO BStr)-foreign import ccall "dynamic" makeGetType  :: FunPtr (ObjectID t -> IO (ObjectID (T "System.Type" '[]))) -> (ObjectID t -> IO (ObjectID (T "System.Type" '[])))+import Data.Text as T -instance MethodResultI1 T_object T_ToString () where-  type ResultTypeI1 T_object T_ToString () = 'Just T_string+--+-- System.Object.ToString()+--+objectToString :: (t  `Implements` T_object ~ 'True) => Object t -> IO T.Text+objectToString o = do+  let o' = upCast o :: Object T_object+  invokeI @T_ToString o' () -instance MethodResultI1 T_object (T "GetType" '[]) () where-  type ResultTypeI1 T_object (T "GetType" '[]) () = 'Just (T "System.Type" '[])+--+-- System.Object.GetType()+--+objectGetType :: (t  `Implements` T_object ~ 'True) => Object t -> IO (Object T_Type)+objectGetType o = do+  let o' = upCast o :: Object T_object+  invokeI @T_GetType o' () -instance MethodDynImportI1 T_object T_ToString () where-  methodDynImportI1 = makeToString+--+-- `downCast @typ o` is `Just o` casted to typ if possible, otherwise Nothing+--+downCast :: forall ts t t' .+ ( MakeT ts ~ t'                           -- Shorthand to long notation conversion+ , TString t'                              -- And the result of the above can be turned into a runtime string+ , t  `Implements` T_object ~ 'True        -- Supplied object must at least inherit from Object so we can call Object.GetType+ , t' `Implements` t ~ 'True               -- Ensure the desired cast is not something meaningless like cat -> dog at compile time+ ) => Object t -> IO (Maybe (Object t'))+downCast o = do+  typ  <- objectGetType o+  typ' <- typeGetType (T.pack (tString @t'))+  canDownCast <- typ' `typeIsAssignableFrom` typ+  if canDownCast then+    return $ Just $ unsafeDownCast o+  else+    return Nothing -instance MethodDynImportI1 T_object (T "GetType" '[]) () where-  methodDynImportI1 = makeGetType
+ src/Clr/Bindings/Object/Internal.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TypeInType, TypeApplications, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}++module Clr.Bindings.Object.Internal+  ( typeGetType+  , typeIsAssignableFrom+  , T_Type+  , T_ToString+  , T_GetType+  ) where++import Clr+import Clr.Bridge+import Clr.Resolver+import Clr.TypeString++import Clr.Marshal++import Clr.Host+import Clr.Host.BStr+import Clr.Host.GCHandle++import Clr.Bindings.DynImports+import Clr.Bindings.BStr++import Data.Coerce+import Foreign.Ptr+import Foreign.ForeignPtr++import Data.Text as T++--+-- Synonyms for other types referenced here+--+type T_Type = T "System.Type" '[]++--+-- Object methods+--+type T_Equals              = T "Equals" '[]+type T_Finalize            = T "Finalize" '[]+type T_GetHashCode         = T "GetHashCode" '[]+type T_MemberwiseClone     = T "MemberwiseClone" '[]+type ReferenceEquals       = T "ReferenceEquals" '[]+type T_ToString            = T "ToString" '[]++--+-- Type members+--+type T_FullName            = T "FullName" '[]+type T_GetGenericArguments = T "GetGenericArguments" '[]+type T_GetMembers          = T "GetMembers" '[]+type T_IsAssignableFrom    = T "IsAssignableFrom" '[]+type T_Namespace           = T "Namespace" '[]++-- Members that share the same name on both Object & Type+type T_GetType             = T "GetType"  '[]++type instance SuperTypes T_object = '[ ]++--+-- Member instance declarations. Only are few are used internally, but the others must be declared also+-- as Haskell always exports & imports instances. The import generator must then skip over these.+--+type instance Members T_object = '[ T_ToString, T_GetType ]++-- Doesn't yet conver all members of System.Type. TODO+type instance Members T_Type   = '[ T_FullName+                                  , T_GetGenericArguments+                                  , T_GetMembers+                                  , T_GetType+                                  , T_IsAssignableFrom+                                  , T_Namespace              ]++type instance Candidates T_object T_ToString          = '[ '[ ] ]+type instance Candidates T_object T_GetType           = '[ '[ ] ]+type instance Candidates T_Type   T_GetType           = '[ '[ T_string ] ]+type instance Candidates T_Type   T_IsAssignableFrom  = '[ '[ T_Type ] ]++foreign import ccall "dynamic" makeObjToString          :: FunPtr (GCHandle t -> IO BStr) -> (GCHandle t -> IO BStr)+foreign import ccall "dynamic" makeObjGetType           :: FunPtr (GCHandle t -> IO (GCHandle (T "System.Type" '[]))) -> (GCHandle t -> IO (GCHandle (T "System.Type" '[])))+foreign import ccall "dynamic" makeTypeGetType          :: FunPtr (BStr -> IO (GCHandle T_Type)) -> (BStr -> IO (GCHandle T_Type))+foreign import ccall "dynamic" makeTypeIsAssignableFrom :: FunPtr (GCHandle T_Type -> GCHandle T_Type -> IO Bool) -> (GCHandle T_Type -> GCHandle T_Type -> IO Bool)++instance MethodResultI1 T_object T_ToString () where+  type ResultTypeI1 T_object T_ToString () = T_string++instance MethodResultI1 T_object T_GetType () where+  type ResultTypeI1 T_object T_GetType () = T_Type++instance MethodResultS1 T_Type T_GetType T_string where+  type ResultTypeS1 T_Type T_GetType T_string = T_Type++instance MethodResultI1 T_Type T_IsAssignableFrom T_Type where+  type ResultTypeI1 T_Type T_IsAssignableFrom T_Type = T_bool++instance MethodDynImportI1 T_object T_ToString () where+  methodDynImportI1 = makeObjToString++instance MethodDynImportI1 T_object T_GetType () where+  methodDynImportI1 = makeObjGetType++instance MethodDynImportS1 T_Type T_GetType T_string where+  methodDynImportS1 = makeTypeGetType++instance MethodDynImportI1 T_Type T_IsAssignableFrom T_Type where+  methodDynImportI1 = makeTypeIsAssignableFrom++--+-- System.Type.GetType(System.String)+--+typeGetType :: T.Text -> IO (Object T_Type)+typeGetType = invokeS @T_GetType @T_Type++--+-- System.Type.IsAssignableFrom(System.Type)+--+typeIsAssignableFrom :: Object T_Type -> Object T_Type -> IO (Bool)+typeIsAssignableFrom t1 t2 = invokeI @T_IsAssignableFrom t1 t2++--+-- Marshaling Object <-> GCHandle+--++-- clr-typed doesn't know of GCHandle as it is provided by clr-host+type instance BridgeTypeObject t = GCHandle t++-- Calling a CLR function from Haskell+instance {-# OVERLAPS #-} Marshal (Object t) (GCHandle t) where+  marshal (Object x) f = withForeignPtr x $ \x'-> f $ coerce x'++-- Calling a Haskell function from the CLR+instance {-# OVERLAPS #-} (TString t) => Marshal (GCHandle t) (Object t) where+  marshal x f = do+    x' <- newHandle x+    finalizer <- gcHandleFinalizer+    fp <- newForeignPtr finalizer (coerce x')+    f $ Object fp++-- Returning from a CLR function that was called from Haskell+instance {-# OVERLAPPING #-} (TString t) => Unmarshal (GCHandle t) (Object t) where+  unmarshal x = do+    finalizer <- gcHandleFinalizer+    fp <- newForeignPtr finalizer (coerce x)+    return $ Object fp++-- Returning from a Haskell function that was called by the CLR+instance {-# OVERLAPPING #-} (TString t) => Unmarshal (Object t) (GCHandle t) where+  unmarshal (Object x) = withForeignPtr x $ \x'-> newHandle $ coerce x'++
+ src/Clr/Bindings/WrapImports.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TypeInType, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, TypeApplications, ScopedTypeVariables, AllowAmbiguousTypes, UndecidableInstances #-}++module Clr.Bindings.WrapImports where++import Clr.Object+import Clr.Bridge+import Clr.Delegate+import Clr.TypeString++import Clr.Host+import Clr.Host.BStr+import Clr.Host.GCHandle+import Clr.Host.Delegate++import Clr.Marshal++import Data.Kind+import Foreign.Ptr++--+-- WrapperImportType t is the type of a function from a `t` to a `FunPtr t`+--+type WrapperImportType t = t -> IO (FunPtr t)++class WrapperImport t where+  wrapperImport :: WrapperImportType (DelegateBridgeType t)++instance ( TString t+         , Delegate t+         , BridgeType t ~ GCHandle t+         , DelegateArgTypes t ~ '[]+         , WrapperImport t+         ) => DelegateConstructor0 t where+  rawConstructDelegate0 f = do+    delCtor <- getDelegateConstructorStub (tString @t) (wrapperImport @t)+    delCtor f++instance ( TString t+         , Delegate t+         , BridgeType t ~ GCHandle t+         , DelegateArgTypes t ~ '[ a0 ]+         , WrapperImport t+         ) => DelegateConstructor1 t where+  rawConstructDelegate1 f = do+    delCtor <- getDelegateConstructorStub (tString @t) (wrapperImport @t)+    delCtor f++instance ( TString t+         , Delegate t+         , BridgeType t ~ GCHandle t+         , DelegateArgTypes t ~ '[ a0, a1 ]+         , WrapperImport t+         ) => DelegateConstructor2 t where+  rawConstructDelegate2 f = do+    delCtor <- getDelegateConstructorStub (tString @t) (wrapperImport @t)+    delCtor f++