packages feed

clr-typed 0.1.0.0 → 0.2.0

raw patch · 17 files changed

+575/−395 lines, 17 filesdep +hspecnew-uploader

Dependencies added: hspec

Files

+ README.md view
@@ -0,0 +1,47 @@+# clr-typed - A strongly typed Haskell interface to the CLR type system++## Status++[![unix build status](https://gitlab.com/tim-m89/clr-haskell/badges/master/build.svg)](https://gitlab.com/tim-m89/clr-haskell/commits/master)[![Windows Build status](https://ci.appveyor.com/api/projects/status/073rvyuyvxrcqvsw?svg=true&label=Windows%20build)](https://ci.appveyor.com/project/TimMatthews/clr-haskell)++## Overview++This package provides a library to implement a strongly typed flavour for CLR <-> Haskell interoperability. It includes an encoding of OOP type system semantics within the GHC Haskell type system.++See the [**example**](https://gitlab.com/tim-m89/clr-haskell/blob/master/examples/clr-typed-demo/src/Main.hs) for what it is currently capable of and how to use it.++## What it looks like++* CLR member & type names are specified with a type level [`Symbol`](https://downloads.haskell.org/~ghc/latest/docs/html/libraries/base-4.9.0.0/GHC-TypeLits.html#t:Symbol), and are expected to be applied via the `TypeApplications` extension.+* Arguments are tupled, so that overload resolution can see the full type up front. Unit is used for argument-less methods.+* Method identifier comes first due to type applications.++```haskell+resulta <- invokeI @"ObjMethodName" object ()  -- No arguments+resultb <- invokeI @"ObjMethodName" object "arg0"+resultc <- invokeI @"ObjMethodName" object ("arg1", 3, "hi")++```+* Similarly for static methods. Method identifier again comes first for consistency with instance methods.++```haskell+invokeS @"DoStuff" @"SomeClass" ()+```++* Constructors are used in a similar fashion++```haskell+obj <- new @"SomeType" ()+```++* Generic type instantiations are done using a promoted tuple instead of just a Symbol++```haskell+strList <- new @'("List", "String") ()+```++* Generics may be used in a method identifier position in the same way++```haskell+invokeS @'("SomeGenericMethod", "Integer") @"SomeClass" ()+```
clr-typed.cabal view
@@ -1,5 +1,5 @@ name:                clr-typed-version:             0.1.0.0+version:             0.2.0 synopsis:            A strongly typed Haskell interface to the CLR type system description:         Please see README.md homepage:            https://gitlab.com/tim-m89/clr-haskell/tree/master/libs/clr-typed@@ -7,16 +7,16 @@ license:             BSD3 license-file:        LICENSE author:              Tim Matthews-maintainer:          tim.matthews7@gmail.com+maintainer:          pepeiborra@gmail.com copyright:           Copyright: (c) 2016-2017 Tim Matthews category:            Language, FFI, CLR, .NET build-type:          Simple-extra-source-files:  test/Bindings.hs+extra-source-files:  README.md cabal-version:       >=1.10  source-repository head     type:            git-    location:        https://gitlab.com/tim-m89/clr-haskell/tree/master+    location:        https://gitlab.com/tim-m89/clr-haskell/tree/master/libs/clr-typed  library   hs-source-dirs:      src@@ -24,13 +24,13 @@                      , Clr.Bridge                      , Clr.Constructor                      , Clr.Curry+                     , Clr.Delegate                      , Clr.Inheritance                      , Clr.ListTuple-                     , Clr.UnmarshalAs                      , Clr.Method.Instance                      , Clr.Method.Static-                     , Clr.Property                      , Clr.Object+                     , Clr.Property                      , Clr.Resolver                      , Clr.Resolver.BetterConversion                      , Clr.Resolver.ImplicitConversions@@ -43,12 +43,12 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Spec.hs-  other-modules:       Bindings+  other-modules:       Instances   build-depends:       base                      , clr-typed+                     , clr-marshal+                     , hspec+                     , text   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall   default-language:    Haskell2010 -source-repository head-  type:     git-  location: https://gitlab.com/tim-m89/clr-typed
src/Clr.hs view
@@ -10,8 +10,9 @@   , setPropI   , getPropS   , setPropS-  , Candidates+  , delegate   , module Clr.Constructor+  , module Clr.Delegate   , module Clr.Inheritance   , module Clr.ListTuple   , module Clr.Method.Instance@@ -24,126 +25,15 @@ import Clr.Bridge import Clr.Constructor import Clr.Curry+import Clr.Delegate import Clr.Inheritance import Clr.ListTuple import Clr.Marshal+import Clr.MarshalF import Clr.Method.Instance import Clr.Method.Static import Clr.Object import Clr.Property import Clr.Resolver import Clr.Types-import Clr.UnmarshalAs -import Data.Int-import Data.Kind-import Data.Type.Bool-import GHC.TypeLits------- Static method invocation----invokeS :: forall ms ts m t argsClrUnResolved argsClr argsHask argCount argsBridge resultBridge resultHask .-            ( MakeT ms ~ m-            , MakeT ts ~ t-            , TupleSize argsHask ~ argCount-            , HaskToClrL (TupleToList argsHask) ~ argsClrUnResolved-            , ResolveMember argsClrUnResolved (Candidates t m) ~ argsClr-            , MethodS argCount t m argsClr-            , ListToTuple (BridgeTypeL argsClr) ~ argsBridge-            , BridgeTypeM (ResultTypeS argCount t m argsClr) ~ resultBridge-            , Marshal argsHask argsBridge-            , UnmarshalAs resultBridge ~ resultHask-            , Unmarshal resultBridge resultHask-            , Curry argCount (argsBridge -> IO resultBridge) (CurryT' argCount argsBridge (IO resultBridge))-            ) => argsHask -> IO resultHask-invokeS x = marshal @argsHask @argsBridge @resultBridge x (\tup-> uncurryN @argCount (rawInvokeS @argCount @t @m @argsClr) tup) >>= unmarshal------- Instance method invocation----invokeI :: forall ms m tBase tDerived argsClrUnResolved argsClr argsHask argCount argsBridge resultBridge resultHask .-            ( MakeT ms ~ m-            , TupleSize argsHask ~ argCount-            , ResolveBaseType tDerived m ~ tBase-            , tDerived `Implements` tBase ~ 'True-            , HaskToClrL (TupleToList argsHask) ~ argsClrUnResolved-            , ResolveMember argsClrUnResolved (Candidates tBase m) ~ argsClr-            , MethodI argCount tBase m argsClr-            , ListToTuple (BridgeTypeL argsClr) ~ argsBridge-            , BridgeTypeM (ResultTypeI argCount tBase m argsClr) ~ resultBridge-            , Marshal argsHask argsBridge-            , Marshal (Object tBase) (BridgeType tBase)-            , UnmarshalAs resultBridge ~ resultHask-            , Unmarshal resultBridge resultHask-            , Curry argCount (argsBridge -> IO resultBridge) (CurryT' argCount argsBridge (IO resultBridge))-            ) => Object tDerived -> argsHask -> IO resultHask-invokeI obj x = marshal @argsHask @argsBridge @resultBridge x (\tup-> marshal @(Object tBase) @(BridgeType tBase) @resultBridge (upCast obj) (\obj'-> uncurryN @argCount (rawInvokeI @argCount @tBase @m @argsClr obj') tup)) >>= unmarshal------- Constructor invocation----new :: forall ts t argsClrUnResolved argsClr argsHask argCount argsBridge resultBridge .-        ( MakeT ts ~ t-        , TupleSize argsHask ~ argCount-        , HaskToClrL (TupleToList argsHask) ~ argsClrUnResolved-        , ResolveMember argsClrUnResolved (Candidates t t) ~ argsClr-        , Constructor argCount t argsClr-        , ListToTuple (BridgeTypeL argsClr) ~ argsBridge-        , Marshal argsHask argsBridge-        , Unmarshal (BridgeType t) (Object t)-        , Curry argCount (argsBridge -> (IO (BridgeType t))) (CurryT' argCount argsBridge (IO (BridgeType t)))-        ) => argsHask -> IO (Object t)-new x = marshal @argsHask @argsBridge @(BridgeType t) x (\tup-> uncurryN @argCount (rawNew @argCount @t @argsClr) tup) >>= unmarshal------- Instance properties----getPropI :: forall ms m tBase tDerived propertyBridge propertyHask .-            ( MakeT ms ~ m-            , ResolveBaseType tDerived m ~ tBase-            , tDerived `Implements` tBase ~ 'True-            , PropertyI tBase m-            , PropertyGetI tBase m-            , BridgeType (PropertyTypeI tBase m) ~ propertyBridge-            , Marshal (Object tBase) (BridgeType tBase)-            , UnmarshalAs propertyBridge ~ propertyHask-            , Unmarshal propertyBridge propertyHask-            ) => Object tDerived -> IO propertyHask-getPropI obj = marshal @(Object tBase) @(BridgeType tBase) @propertyBridge (upCast obj) (\obj'-> (rawGetPropI @tBase @m obj')) >>= unmarshal--setPropI :: forall ms m tBase tDerived propertyBridge propertyHask .-            ( MakeT ms ~ m-            , ResolveBaseType tDerived m ~ tBase-            , tDerived `Implements` tBase ~ 'True-            , PropertyI tBase m-            , PropertySetI tBase m-            , BridgeType (PropertyTypeI tBase m) ~ propertyBridge-            , Marshal (Object tBase) (BridgeType tBase)-            , Marshal propertyHask propertyBridge-            ) => Object tDerived -> propertyHask -> IO ()-setPropI obj x = marshal @(Object tBase) @(BridgeType tBase) @() (upCast obj) (\obj'-> marshal @propertyHask @propertyBridge @() x (\prop-> rawSetPropI @tBase @m obj' prop))------- Static properties----getPropS :: forall ms ts m t propertyBridge propertyHask .-            ( MakeT ms ~ m-            , MakeT ts ~ t-            , PropertyS t m-            , PropertyGetS t m-            , BridgeType (PropertyTypeS t m) ~ propertyBridge-            , UnmarshalAs propertyBridge ~ propertyHask-            , Unmarshal propertyBridge propertyHask-            ) => IO propertyHask-getPropS = rawGetPropS @t @m >>= unmarshal--setPropS :: forall ms ts m t propertyBridge propertyHask .-            ( MakeT ms ~ m-            , MakeT ts ~ t-            , PropertyS t m-            , PropertySetS t m-            , BridgeType (PropertyTypeS t m) ~ propertyBridge-            , Marshal propertyHask propertyBridge-            ) => propertyHask -> IO ()-setPropS x = marshal @propertyHask @propertyBridge @() x (\prop-> rawSetPropS @t @m prop)
src/Clr/Bridge.hs view
@@ -20,14 +20,7 @@ -- type family BridgeType (x::Type) :: Type where   BridgeType () = ()-  BridgeType t  = If (IsPrimType t) (BridgeTypePrim t) (ObjectID t)------- Maybe on bridge types, choosing () for Nothing----type family BridgeTypeM (x::Maybe Type) :: Type where-  BridgeTypeM 'Nothing  = ()-  BridgeTypeM ('Just x) = BridgeType x+  BridgeType t  = If (IsPrimType t) (BridgeTypePrim t) (BridgeTypeObject t)  -- -- Bridge types of each primitive@@ -48,6 +41,14 @@ type instance BridgeTypePrim (T "System.Single"  '[]) = CFloat type instance BridgeTypePrim (T "System.Double"  '[]) = CDouble type instance BridgeTypePrim (T "System.Boolean" '[]) = Bool+type instance BridgeTypePrim (T "System.Void"    '[]) = ()+++--+-- Bridge type of Object is left uninstantiated in this package+--++type family BridgeTypeObject (x::Type)  -- -- Bridge type that operates on lists
src/Clr/Constructor.hs view
@@ -7,10 +7,16 @@   , Constructor1(..)   , Constructor2(..)   , Constructor3(..)+  , new   ) where  import Clr.Bridge import Clr.Curry+import Clr.ListTuple+import Clr.Marshal+import Clr.Object+import Clr.Resolver+import Clr.Types  import GHC.TypeLits import Data.Kind@@ -45,4 +51,21 @@  instance (Constructor3 t a0 a1 a2) => Constructor 3 t '[a0, a1, a2] where   rawNew = rawNew3 @t @a0 @a1 @a2++--+-- API+--++new :: forall ts t argsClrUnResolved argsClr argsHask argCount argsBridge resultBridge .+        ( MakeT ts ~ t+        , ArgCount argsHask ~ argCount+        , HaskToClrL (TupleToList argsHask) ~ argsClrUnResolved+        , ResolveMember argsClrUnResolved (Candidates t t) ~ argsClr+        , Constructor argCount t argsClr+        , ListToTuple (BridgeTypeL argsClr) ~ argsBridge+        , Marshal argsHask argsBridge+        , Unmarshal (BridgeType t) (Object t)+        , Curry argCount (argsBridge -> (IO (BridgeType t))) (CurryT' argCount argsBridge (IO (BridgeType t)))+        ) => argsHask -> IO (Object t)+new x = marshal @argsHask @argsBridge @(BridgeType t) x (\tup-> uncurryN @argCount (rawNew @argCount @t @argsClr) tup) >>= unmarshal
src/Clr/Curry.hs view
@@ -21,6 +21,7 @@   CurryT' 3 (a,b,c) r = a -> b -> c -> r   CurryT' 2 (a,b) r = a -> b -> r   CurryT' 1 a r = a -> r+  CurryT' 0 a r = r  -- -- Curry is like that from the tuple package, except that we use id
+ src/Clr/Delegate.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE GADTs, DataKinds, KindSignatures, PolyKinds, TypeFamilies, TypeOperators, RankNTypes, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, ScopedTypeVariables, ExistentialQuantification #-}+{-# LANGUAGE UndecidableInstances, TypeApplications, AllowAmbiguousTypes, TypeInType, TypeFamilyDependencies, FunctionalDependencies #-}++module Clr.Delegate where++import Clr.Bridge+import Clr.Curry+import Clr.ListTuple+import Clr.Marshal+import Clr.MarshalF+import Clr.Object+import Clr.Resolver+import Clr.Types++import GHC.TypeLits+import Data.Kind++class Delegate t where+  type DelegateArgTypes   t :: [Type]+  type DelegateResultType t :: Type++type family DelegateArgN (t::Type) (n::Nat) :: Type where+  DelegateArgN t n = (DelegateArgTypes t) `Index` n++class Delegate t => DelegateConstructor0 (t::Type) where+  rawConstructDelegate0 :: (IO (BridgeType (DelegateResultType t))) -> (IO (BridgeType t))++class Delegate t => DelegateConstructor1 (t::Type) where+  rawConstructDelegate1 :: (BridgeType (DelegateArgN t 0)  -> IO (BridgeType (DelegateResultType t))) -> (IO (BridgeType t))++class Delegate t => DelegateConstructor2 (t::Type) where+  rawConstructDelegate2 :: (BridgeType (DelegateArgN t 0)  -> BridgeType (DelegateArgN t 1) -> IO (BridgeType (DelegateResultType t))) -> (IO (BridgeType t))++class Delegate t => DelegateConstructor3 (t::Type) where+  rawConstructDelegate3 :: (BridgeType (DelegateArgN t 0)  -> BridgeType (DelegateArgN t 1) -> BridgeType (DelegateArgN t 2) -> IO (BridgeType (DelegateResultType t))) -> (IO (BridgeType t))++type family DelegateArity (t::Type) :: Nat where+  DelegateArity t = ListSize (DelegateArgTypes t)++type family DelegateBridgeType (t::Type) :: Type where+  DelegateBridgeType t = CurryT' (DelegateArity t) (BridgeTypes (DelegateArgTypes t)) (IO (BridgeType (DelegateResultType t)))++class Delegate t => DelegateConstructorN (n::Nat) (t::Type) where+  rawConstructDelegate :: DelegateBridgeType t -> IO (BridgeType t)++instance ( DelegateArity t ~ 0+         , DelegateConstructor0 t+         ) => DelegateConstructorN 0 t where+  rawConstructDelegate = rawConstructDelegate0 @t++instance ( DelegateArity t ~ 1+         , DelegateArgTypes t ~ '[a0]+         , DelegateConstructor1 t+         ) => DelegateConstructorN 1 t where+  rawConstructDelegate = rawConstructDelegate1 @t++instance ( DelegateArity t ~ 2+         , DelegateArgTypes t ~ '[a0, a1]+         , DelegateConstructor2 t+         ) => DelegateConstructorN 2 t where+  rawConstructDelegate = rawConstructDelegate2 @t++instance ( DelegateArity t ~ 3+         , DelegateArgTypes t ~ '[a0, a1, a2]+         , DelegateConstructor3 t+         ) => DelegateConstructorN 3 t where+  rawConstructDelegate = rawConstructDelegate3 @t++--+-- API+--++delegate :: forall ds d ht bt n .+            ( MakeT ds ~ d+            , Delegate d+            , DelegateBridgeType d ~ bt+            , DelegateArity d ~ n+            , MarshalF n ht bt+            , DelegateConstructorN n d+            , Unmarshal (BridgeType d) (Object d)+            ) => ht -> IO (Object d)+delegate f = rawConstructDelegate @n @d (marshalF @n @ht @bt f) >>= unmarshal+
src/Clr/ListTuple.hs view
@@ -41,25 +41,22 @@   TupleToList (a,b,c,d,e,f,g,h,i)     = '[a, b, c, d, e, f, g, h, i]   TupleToList (a,b,c,d,e,f,g,h,i,j)   = '[a, b, c, d, e, f, g, h, i, j]   TupleToList (a,b,c,d,e,f,g,h,i,j,k) = '[a, b, c, d, e, f, g, h, i, j, k]-  TupleToList (a)                     = '[a]+  TupleToList (a)                     = '[a]  -- NB: "(a)" denotes anything that didn't match above, this could be either a non-tuple or a tuple bigger than what above could match on  -- -- Size of a tuple -- type family TupleSize (x::tupleKind) :: Nat where-  TupleSize (a,b,c,d,e,f,g,h,i,j,k) = 11-  TupleSize (a,b,c,d,e,f,g,h,i,j) = 10-  TupleSize (a,b,c,d,e,f,g,h,i) = 9-  TupleSize (a,b,c,d,e,f,g,h) = 8-  TupleSize (a,b,c,d,e,f,g) = 7-  TupleSize (a,b,c,d,e,f) = 6-  TupleSize (a,b,c,d,e) = 5-  TupleSize (a,b,c,d) = 4-  TupleSize (a,b,c) = 3-  TupleSize (a,b) = 2-  TupleSize (a) = 1+  TupleSize a = ListSize (TupleToList a) -- NB: the size of '()' is considered 0, and anything non tuple or bigger than what 'TupleToList' matches on is 1.  --+-- ArgCount is like TupleSize, except evaluates to 1 for '()', which only makes sens given how it is currently used+--+type family ArgCount (x::tupleKind) :: Nat where+  ArgCount () = 1+  ArgCount a  = TupleSize a++-- -- Size of a list -- type family ListSize (x::k) :: Nat where@@ -99,6 +96,12 @@ -- PrependIf b x xs evaluates to xs when b is false and x : xs when b is true -- type family PrependIf (b :: Bool) (x :: k) (xs :: [k]) :: [k] where-    PrependIf 'True  x xs = x ': xs-    PrependIf 'False x xs = xs+  PrependIf 'True  x xs = x ': xs+  PrependIf 'False x xs = xs+++type family Index (x::[t]) (n::Nat) :: t where+  Index (x ': xs) 0 = x+  Index (x ': xs) n = Index xs (n-1)+  Index     xs    n = TypeError (Text "Out of bounds")
src/Clr/Method/Instance.hs view
@@ -10,10 +10,17 @@   , MethodInvokeI1(..)   , MethodInvokeI2(..)   , MethodInvokeI3(..)+  , invokeI   ) where  import Clr.Bridge import Clr.Curry+import Clr.Inheritance+import Clr.ListTuple+import Clr.Marshal+import Clr.Object+import Clr.Resolver+import Clr.Types  import GHC.TypeLits import Data.Kind@@ -23,33 +30,33 @@ --  class MethodResultI1 (t::Type) (m::Type) (arg0::Type) where-  type ResultTypeI1 t m arg0 :: Maybe Type+  type ResultTypeI1 t m arg0 :: Type  class MethodResultI2 (t::Type) (m::Type) (arg0::Type) (arg1::Type) where-  type ResultTypeI2 t m arg0 arg1 :: Maybe Type+  type ResultTypeI2 t m arg0 arg1 :: Type  class MethodResultI3 (t::Type) (m::Type) (arg0::Type) (arg1::Type) (arg2::Type) where-  type ResultTypeI3 t m arg0 arg1 arg2 :: Maybe Type+  type ResultTypeI3 t m arg0 arg1 arg2 :: Type  class MethodResultI1 (t::Type) (m::Type) (arg0::Type)    => MethodInvokeI1 (t::Type) (m::Type) (arg0::Type) where-  rawInvokeI1 :: (BridgeType t) -> (BridgeType arg0) -> (IO (BridgeTypeM (ResultTypeI1 t m arg0)))+  rawInvokeI1 :: (BridgeType t) -> (BridgeType arg0) -> (IO (BridgeType (ResultTypeI1 t m arg0)))  class MethodResultI2 (t::Type) (m::Type) (arg0::Type) (arg1::Type)    => MethodInvokeI2 (t::Type) (m::Type) (arg0::Type) (arg1::Type) where-  rawInvokeI2 :: (BridgeType t) -> (BridgeType arg0) -> (BridgeType arg1) -> (IO (BridgeTypeM (ResultTypeI2 t m arg0 arg1)))+  rawInvokeI2 :: (BridgeType t) -> (BridgeType arg0) -> (BridgeType arg1) -> (IO (BridgeType (ResultTypeI2 t m arg0 arg1)))  class MethodResultI3 (t::Type) (m::Type) (arg0::Type) (arg1::Type) (arg2::Type)    => MethodInvokeI3 (t::Type) (m::Type) (arg0::Type) (arg1::Type) (arg2::Type) where-  rawInvokeI3 :: (BridgeType t) -> (BridgeType arg0) -> (BridgeType arg1) -> (BridgeType arg2) -> (IO (BridgeTypeM (ResultTypeI3 t m arg0 arg1 arg2)))+  rawInvokeI3 :: (BridgeType t) -> (BridgeType arg0) -> (BridgeType arg1) -> (BridgeType arg2) -> (IO (BridgeType (ResultTypeI3 t m arg0 arg1 arg2)))  -- -- Unification of instance methods --  class MethodI (n::Nat) (t::Type) (m::Type) (args::[Type]) where-  type ResultTypeI n t m args :: Maybe Type-  rawInvokeI :: (BridgeType t) -> CurryT' n (BridgeTypes args) (IO (BridgeTypeM (ResultTypeI n t m args)))+  type ResultTypeI n t m args :: Type+  rawInvokeI :: (BridgeType t) -> CurryT' n (BridgeTypes args) (IO (BridgeType (ResultTypeI n t m args)))  instance (MethodInvokeI1 t m ()) => MethodI 1 t m '[] where   type ResultTypeI 1 t m '[] = ResultTypeI1 t m ()@@ -66,4 +73,25 @@ instance (MethodInvokeI3 t m a0 a1 a2) => MethodI 3 t m '[a0, a1, a2] where   type ResultTypeI 3 t m '[a0, a1, a2] = ResultTypeI3 t m a0 a1 a2   rawInvokeI = rawInvokeI3 @t @m @a0 @a1 @a2++--+-- API+--++invokeI :: forall ms resultBridge resultHask m tBase tDerived argsClrUnResolved argsClr argsHask argCount argsBridge .+            ( MakeT ms ~ m+            , ArgCount argsHask ~ argCount+            , ResolveBaseType tDerived m ~ tBase+            , tDerived `Implements` tBase ~ 'True+            , HaskToClrL (TupleToList argsHask) ~ argsClrUnResolved+            , ResolveMember argsClrUnResolved (Candidates tBase m) ~ argsClr+            , MethodI argCount tBase m argsClr+            , ListToTuple (BridgeTypeL argsClr) ~ argsBridge+            , BridgeType (ResultTypeI argCount tBase m argsClr) ~ resultBridge+            , Marshal argsHask argsBridge+            , Marshal (Object tBase) (BridgeType tBase)+            , Unmarshal resultBridge resultHask+            , Curry argCount (argsBridge -> IO resultBridge) (CurryT' argCount argsBridge (IO resultBridge))+            ) => Object tDerived -> argsHask -> IO resultHask+invokeI obj x = marshal @argsHask @argsBridge @resultBridge x (\tup-> marshal @(Object tBase) @(BridgeType tBase) @resultBridge (upCast obj) (\obj'-> uncurryN @argCount (rawInvokeI @argCount @tBase @m @argsClr obj') tup)) >>= unmarshal
src/Clr/Method/Static.hs view
@@ -10,10 +10,16 @@   , MethodInvokeS1(..)   , MethodInvokeS2(..)   , MethodInvokeS3(..)+  , invokeS   ) where  import Clr.Bridge import Clr.Curry+import Clr.ListTuple+import Clr.Marshal+import Clr.Object+import Clr.Resolver+import Clr.Types  import GHC.TypeLits import Data.Kind@@ -24,33 +30,33 @@ --  class MethodResultS1 (t::Type) (m::Type) (arg0::Type) where-  type ResultTypeS1 t m arg0 :: Maybe Type+  type ResultTypeS1 t m arg0 :: Type  class MethodResultS2 (t::Type) (m::Type) (arg0::Type) (arg1::Type) where-  type ResultTypeS2 t m arg0 arg1 :: Maybe Type+  type ResultTypeS2 t m arg0 arg1 :: Type  class MethodResultS3 (t::Type) (m::Type) (arg0::Type) (arg1::Type) (arg2::Type) where-  type ResultTypeS3 t m arg0 arg1 arg2 :: Maybe Type+  type ResultTypeS3 t m arg0 arg1 arg2 :: Type  class MethodResultS1 (t::Type) (m::Type) (arg0::Type)    => MethodInvokeS1 (t::Type) (m::Type) (arg0::Type) where-  rawInvokeS1 :: (BridgeType arg0) -> (IO (BridgeTypeM (ResultTypeS1 t m arg0)))+  rawInvokeS1 :: (BridgeType arg0) -> (IO (BridgeType (ResultTypeS1 t m arg0)))  class MethodResultS2 (t::Type) (m::Type) (arg0::Type) (arg1::Type)    => MethodInvokeS2 (t::Type) (m::Type) (arg0::Type) (arg1::Type) where-  rawInvokeS2 :: (BridgeType arg0) -> (BridgeType arg1) -> (IO (BridgeTypeM (ResultTypeS2 t m arg0 arg1)))+  rawInvokeS2 :: (BridgeType arg0) -> (BridgeType arg1) -> (IO (BridgeType (ResultTypeS2 t m arg0 arg1)))  class MethodResultS3 (t::Type) (m::Type) (arg0::Type) (arg1::Type) (arg2::Type)    => MethodInvokeS3 (t::Type) (m::Type) (arg0::Type) (arg1::Type) (arg2::Type) where-  rawInvokeS3 :: (BridgeType arg0) -> (BridgeType arg1) -> (BridgeType arg2) -> (IO (BridgeTypeM (ResultTypeS3 t m arg0 arg1 arg2)))+  rawInvokeS3 :: (BridgeType arg0) -> (BridgeType arg1) -> (BridgeType arg2) -> (IO (BridgeType (ResultTypeS3 t m arg0 arg1 arg2)))  -- -- Unification of static methods --  class MethodS (n::Nat) (t::Type) (m::Type) (args::[Type]) where-  type ResultTypeS n t m args :: Maybe Type-  rawInvokeS :: CurryT' n (BridgeTypes args) (IO (BridgeTypeM (ResultTypeS n t m args)))+  type ResultTypeS n t m args :: Type+  rawInvokeS :: CurryT' n (BridgeTypes args) (IO (BridgeType (ResultTypeS n t m args)))  instance (MethodInvokeS1 t m ()) => MethodS 1 t m '[] where   type ResultTypeS 1 t m '[] = ResultTypeS1 t m ()@@ -67,4 +73,23 @@ instance (MethodInvokeS3 t m a0 a1 a2) => MethodS 3 t m '[a0, a1, a2] where   type ResultTypeS 3 t m '[a0, a1, a2] = ResultTypeS3 t m a0 a1 a2   rawInvokeS = rawInvokeS3 @t @m @a0 @a1 @a2++--+-- API+--++invokeS :: forall ms ts resultBridge resultHask m t argsClrUnResolved argsClr argsHask argCount argsBridge .+            ( MakeT ms ~ m+            , MakeT ts ~ t+            , ArgCount argsHask ~ argCount+            , HaskToClrL (TupleToList argsHask) ~ argsClrUnResolved+            , ResolveMember argsClrUnResolved (Candidates t m) ~ argsClr+            , MethodS argCount t m argsClr+            , ListToTuple (BridgeTypeL argsClr) ~ argsBridge+            , BridgeType (ResultTypeS argCount t m argsClr) ~ resultBridge+            , Marshal argsHask argsBridge+            , Unmarshal resultBridge resultHask+            , Curry argCount (argsBridge -> IO resultBridge) (CurryT' argCount argsBridge (IO resultBridge))+            ) => argsHask -> IO resultHask+invokeS x = marshal @argsHask @argsBridge @resultBridge x (\tup-> uncurryN @argCount (rawInvokeS @argCount @t @m @argsClr) tup) >>= unmarshal
src/Clr/Object.hs view
@@ -5,30 +5,18 @@  import Clr.Marshal import Clr.Types+import Clr.TypeString import Data.Kind import Data.Int------- A unique indentifier for a particular ref type.--- Just a place holder for now might need to something else such as pointer later on----newtype ObjectID typ = ObjectID Int64+import Foreign.ForeignPtr  -- -- An object is just its unique identifer + information of its type -- data Object (typ::Type) where-  Object :: ObjectID typ -> Object typ+  Object :: (TString typ) => ForeignPtr Int -> Object typ  ------ Marshaling objects----instance {-# OVERLAPS #-} Marshal (Object t) (ObjectID t) where-  marshal (Object x) f = f x--instance {-# OVERLAPPING #-} Unmarshal (ObjectID t) (Object t) where-  unmarshal oid = return $ Object oid- type instance HaskToClr (Object t) = t+
src/Clr/Property.hs view
@@ -6,10 +6,20 @@  import Clr.Bridge import Clr.Curry+import Clr.Inheritance+import Clr.ListTuple+import Clr.Marshal+import Clr.Object+import Clr.Resolver+import Clr.Types  import GHC.TypeLits import Data.Kind +--+-- Unused at the moment+--+ data PropertyAccessEnum = PropRead | PropWrite | PropReadWrite  type family PropertyAccess (t::Type) (m::Type) :: PropertyAccessEnum@@ -40,5 +50,62 @@  class PropertyS (t::Type) (m::Type) => PropertySetS (t::Type) (m::Type) where   rawSetPropS :: BridgeType (PropertyTypeS t m) -> IO ()++--+-- API+--++--+-- Instance properties+--+getPropI :: forall ms propertyBridge propertyHask m tBase tDerived .+            ( MakeT ms ~ m+            , ResolveBaseType tDerived m ~ tBase+            , tDerived `Implements` tBase ~ 'True+            , PropertyI tBase m+            , PropertyGetI tBase m+            , BridgeType (PropertyTypeI tBase m) ~ propertyBridge+            , Marshal (Object tBase) (BridgeType tBase)+            , Unmarshal propertyBridge propertyHask+            ) => Object tDerived -> IO propertyHask+getPropI obj = marshal @(Object tBase) @(BridgeType tBase) @propertyBridge (upCast obj) (\obj'-> (rawGetPropI @tBase @m obj')) >>= unmarshal++setPropI :: forall ms propertyBridge propertyHask m tBase tDerived .+            ( MakeT ms ~ m+            , ResolveBaseType tDerived m ~ tBase+            , tDerived `Implements` tBase ~ 'True+            , PropertyI tBase m+            , PropertySetI tBase m+            , BridgeType (PropertyTypeI tBase m) ~ propertyBridge+            , Marshal (Object tBase) (BridgeType tBase)+            , Marshal propertyHask propertyBridge+            ) => Object tDerived -> propertyHask -> IO ()+setPropI obj x = marshal @(Object tBase) @(BridgeType tBase) @() (upCast obj) (\obj'-> marshal @propertyHask @propertyBridge @() x (\prop-> rawSetPropI @tBase @m obj' prop))++--+-- Static properties+--+getPropS :: forall ms ts propertyBridge propertyHask m t .+            ( MakeT ms ~ m+            , MakeT ts ~ t+            , PropertyS t m+            , PropertyGetS t m+            , BridgeType (PropertyTypeS t m) ~ propertyBridge+            , Unmarshal propertyBridge propertyHask+            ) => IO propertyHask+getPropS = rawGetPropS @t @m >>= unmarshal++setPropS :: forall ms ts propertyBridge propertyHask m t .+            ( MakeT ms ~ m+            , MakeT ts ~ t+            , PropertyS t m+            , PropertySetS t m+            , BridgeType (PropertyTypeS t m) ~ propertyBridge+            , Marshal propertyHask propertyBridge+            ) => propertyHask -> IO ()+setPropS x = marshal @propertyHask @propertyBridge @() x (\prop-> rawSetPropS @t @m prop)+++
src/Clr/Types.hs view
@@ -67,7 +67,8 @@                   , T "System.UIntPtr" '[]                   , T "System.Char"    '[]                   , T "System.Single"  '[]-                  , T "System.Double"  '[] ]+                  , T "System.Double"  '[]+                  , T "System.Void"    '[] ]  type family IsPrimType (t::Type) :: Bool where   IsPrimType t = t `Elem` PrimTypes@@ -119,6 +120,7 @@ type T_string  = T "System.String"  '[] type T_char    = T "System.Char"    '[] type T_bool    = T "System.Boolean" '[]+type T_void    = T "System.Void"    '[]  -- -- Declaration of all compile type chooseable members of a particular type
− src/Clr/UnmarshalAs.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-}--module Clr.UnmarshalAs where--import Clr.Marshal-import Clr.Object--import Data.Int-import Data.Kind-import Data.Word-import Foreign.C------- Declares how to automatically convert from the bridge type of methods result to a high level Haskell type--- TODO: Can we do without this the end user can choose between String or Text for example?-type family   UnmarshalAs (x::Type)   :: Type-type instance UnmarshalAs (ObjectID t) = (Object t)-type instance UnmarshalAs ()           = ()-type instance UnmarshalAs Bool         = Bool-type instance UnmarshalAs Word8        = Word8-type instance UnmarshalAs Word16       = Word16-type instance UnmarshalAs Word32       = Word32-type instance UnmarshalAs Word64       = Word64-type instance UnmarshalAs Int8         = Int8-type instance UnmarshalAs Int16        = Int16-type instance UnmarshalAs Int32        = Int32-type instance UnmarshalAs Int64        = Int64-type instance UnmarshalAs Int          = Int-type instance UnmarshalAs CFloat       = Float-type instance UnmarshalAs CDouble      = Double-type instance UnmarshalAs Float        = Float-type instance UnmarshalAs Double       = Double--
− test/Bindings.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE TypeInType, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, AllowAmbiguousTypes, ScopedTypeVariables, TypeApplications, TypeOperators #-}--module Bindings where--import Clr-import Clr.Bridge-import Data.Int-import Data.Word-import Foreign.Ptr------- Just for testing----type instance BridgeTypePrim (T "System.String"  '[]) = String------- Static method----writeLineRaw1 :: String -> IO ()-writeLineRaw1 cs = putStrLn "Console.WriteLine(String)"-writeLineRaw2 :: String -> String -> IO ()-writeLineRaw2 cs1 cs2 = putStrLn "Console.WriteLine(String, String)"--instance MethodS1 (T "System.Console" '[]) (T "WriteLine" '[]) (T "System.String" '[]) where-  type ResultTypeS1 (T "System.Console" '[]) (T "WriteLine" '[]) (T "System.String" '[]) = 'Nothing-  rawInvokeS1 = writeLineRaw1--instance MethodS2 (T "System.Console" '[]) (T "WriteLine" '[]) (T "System.String" '[]) (T "System.String" '[]) where-  type ResultTypeS2 (T "System.Console" '[]) (T "WriteLine" '[]) (T "System.String" '[]) (T "System.String" '[]) = 'Nothing-  rawInvokeS2 = writeLineRaw2--type instance Candidates (T "System.Console" '[]) (T "WriteLine" '[]) = '[ '[ T "System.String" '[]], '[T "System.String" '[], T "System.String" '[]]]------- Base type-----type instance SuperTypes (T "BaseType" '[]) = '[ (T "System.Object" '[]) ]--instance Constructor1 (T "BaseType" '[]) () where-  rawNew1 () = putStrLn "Constructed BaseType" >> return (ObjectID 1)--type instance Candidates (T "BaseType" '[]) (T "BaseType" '[]) = '[ '[] ]-type instance Candidates (T "BaseType" '[]) (T "Foo" '[]) = '[ '[ T "System.String" '[] ], '[ T "System.Int64" '[] ], '[ T "System.Int32" '[] ]]-type instance Candidates (T "BaseType" '[]) (T "Bar" '[]) = '[ '[ T "System.String" '[] ], '[ T "System.Int64" '[] ], '[ T "System.Int32" '[] ]]--type instance Members (T "BaseType" '[]) = '[(T "Foo" '[]), (T "Bar" '[])]---- Foo-instance MethodI1 (T "BaseType" '[]) (T "Foo" '[]) (T "System.String" '[]) where-  type ResultTypeI1 (T "BaseType" '[]) (T "Foo" '[]) (T "System.String" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeBaseTypeFooStr--instance MethodI1 (T "BaseType" '[]) (T "Foo" '[]) (T "System.Int64" '[]) where-  type ResultTypeI1 (T "BaseType" '[]) (T "Foo" '[]) (T "System.Int64" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeBaseTypeFooInt64--instance MethodI1 (T "BaseType" '[]) (T "Foo" '[]) (T "System.Int32" '[]) where-  type ResultTypeI1 (T "BaseType" '[]) (T "Foo" '[]) (T "System.Int32" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeBaseTypeFooInt32--rawInvokeBaseTypeFooStr :: ObjectID t -> String -> IO ()-rawInvokeBaseTypeFooStr d s = putStrLn "BaseType.Foo(String)"--rawInvokeBaseTypeFooInt64 :: ObjectID t -> Int64 -> IO ()-rawInvokeBaseTypeFooInt64 d s = putStrLn "BaseType.Foo(Int64)"--rawInvokeBaseTypeFooInt32 :: ObjectID t -> Int32 -> IO ()-rawInvokeBaseTypeFooInt32 d s = putStrLn "BaseType.Foo(Int32)"---- Bar-instance MethodI1 (T "BaseType" '[]) (T "Bar" '[]) (T "System.String" '[]) where-  type ResultTypeI1 (T "BaseType" '[]) (T "Bar" '[]) (T "System.String" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeBaseTypeBarStr--instance MethodI1 (T "BaseType" '[]) (T "Bar" '[]) (T "System.Int64" '[]) where-  type ResultTypeI1 (T "BaseType" '[]) (T "Bar" '[]) (T "System.Int64" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeBaseTypeBarInt64--instance MethodI1 (T "BaseType" '[]) (T "Bar" '[]) (T "System.Int32" '[]) where-  type ResultTypeI1 (T "BaseType" '[]) (T "Bar" '[]) (T "System.Int32" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeBaseTypeBarInt32--rawInvokeBaseTypeBarStr :: ObjectID t -> String -> IO ()-rawInvokeBaseTypeBarStr d s = putStrLn "BaseType.Bar(String)"--rawInvokeBaseTypeBarInt64 :: ObjectID t -> Int64 -> IO ()-rawInvokeBaseTypeBarInt64 d s = putStrLn "BaseType.Bar(Int64)"--rawInvokeBaseTypeBarInt32 :: ObjectID t -> Int32 -> IO ()-rawInvokeBaseTypeBarInt32 d s = putStrLn "BaseType.Bar(Int32)"------- Derived type-----type instance SuperTypes (T "DerivedType" '[]) = '[ (T "BaseType" '[]) ]--instance Constructor1 (T "DerivedType" '[]) () where-  rawNew1 () = putStrLn "Constructed DerivedType" >> return (ObjectID 1)--type instance Candidates (T "DerivedType" '[]) (T "DerivedType" '[]) = '[ '[] ]-type instance Candidates (T "DerivedType" '[]) (T "Foo" '[]) = '[ '[ T "System.String" '[] ], '[ T "System.Int64" '[] ], '[ T "System.Int32" '[] ]]--type instance Members (T "DerivedType" '[]) = '[(T "Foo" '[])]--instance MethodI1 (T "DerivedType" '[]) (T "Foo" '[]) (T "System.String" '[]) where-  type ResultTypeI1 (T "DerivedType" '[]) (T "Foo" '[]) (T "System.String" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeDerivedTypeStr--instance MethodI1 (T "DerivedType" '[]) (T "Foo" '[]) (T "System.Int64" '[]) where-  type ResultTypeI1 (T "DerivedType" '[]) (T "Foo" '[]) (T "System.Int64" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeDerivedTypeInt64--instance MethodI1 (T "DerivedType" '[]) (T "Foo" '[]) (T "System.Int32" '[]) where-  type ResultTypeI1 (T "DerivedType" '[]) (T "Foo" '[]) (T "System.Int32" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeDerivedTypeInt32--rawInvokeDerivedTypeStr :: ObjectID t -> String -> IO ()-rawInvokeDerivedTypeStr d s = putStrLn "DerivedType.Foo(String)"--rawInvokeDerivedTypeInt64 :: ObjectID t -> Int64 -> IO ()-rawInvokeDerivedTypeInt64 d s = putStrLn "DerivedType.Foo(Int64)"--rawInvokeDerivedTypeInt32 :: ObjectID t -> Int32 -> IO ()-rawInvokeDerivedTypeInt32 d s = putStrLn "DerivedType.Foo(Int32)"--type instance SuperTypes (T "MyGenType" '[gt0]) = '[ T "System.Object" '[], T "IEnumerable" '[], T "IEnumerable" '[gt0] ]--instance Constructor1 (T "MyGenType" '[gt0]) () where-  rawNew1 () = putStrLn "Constructed MyGenType" >> return (ObjectID 1)--type instance Candidates (T "MyGenType" '[gt0]) (T "MyGenType" '[gt0]) = '[ '[] ]-type instance Candidates (T "MyGenType" '[gt0]) (T "Add" '[]) = '[ '[ gt0 ] ]--type instance Members (T "MyGenType" '[gt0]) = '[(T "Add" '[])]--instance MethodI1 (T "MyGenType" '[(T "System.String" '[])]) (T "Add" '[]) (T "System.String" '[]) where-  type ResultTypeI1 (T "MyGenType" '[(T "System.String" '[])]) (T "Add" '[]) (T "System.String" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeMyGenTypeAddStr--instance MethodI1 (T "MyGenType" '[(T "System.Int32" '[])]) (T "Add" '[]) (T "System.Int32" '[]) where-  type ResultTypeI1 (T "MyGenType" '[(T "System.Int32" '[])]) (T "Add" '[]) (T "System.Int32" '[]) = 'Nothing-  rawInvokeI1 = rawInvokeMyGenTypeAddInt--rawInvokeMyGenTypeAddStr :: ObjectID t -> String -> IO ()-rawInvokeMyGenTypeAddStr oid s = putStrLn "MyGenType.Add(String)"--rawInvokeMyGenTypeAddInt :: ObjectID t -> Int32 -> IO ()-rawInvokeMyGenTypeAddInt oid s = putStrLn "MyGenType.Add(Int32)"
+ test/Instances.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE TypeInType, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, AllowAmbiguousTypes, ScopedTypeVariables, TypeApplications, TypeOperators #-}++module Instances where++import Clr+import Clr.Bridge+import Clr.Resolver+import Clr.TypeString++import Clr.Marshal++import Data.Coerce+import Data.Int+import Data.Word+import Foreign.ForeignPtr++import Data.Text++-- Just for testing. Actual use is BStr+type instance BridgeTypePrim T_string = String++-- Also just for this test.+newtype ObjectID t = ObjectID (ForeignPtr Int)+type instance BridgeTypeObject t = ObjectID t++instance {-# OVERLAPS #-} Marshal (Object t) (ObjectID t) where+  marshal (Object x) f = f $ coerce x+instance {-# OVERLAPS #-} (TString t) => Marshal (ObjectID t) (Object t) where+  marshal x f = f (Object $ coerce x)+instance {-# OVERLAPPING #-} (TString t) => Unmarshal (ObjectID t) (Object t) where+  unmarshal oid = return $ Object $ coerce oid++-- Synonyms while we have to still write this manually+type T_Console      = T "System.Console" '[]+type T_BaseType     = T "BaseType" '[]+type T_DerivedType  = T "DerivedType" '[]+type T_StringIntDel = T "StringIntDel" '[]++-- Synonyms for methods+type T_WriteLine = T "WriteLine" '[]+type T_Foo       = T "Foo" '[]+type T_Bar       = T "Bar" '[]+type T_Add       = T "Add" '[]++type instance SuperTypes T_BaseType             = '[ T_object ]+type instance SuperTypes T_DerivedType          = '[ T_BaseType ]+type instance SuperTypes (T "MyGenType" '[gt0]) = '[ T_object, T "IEnumerable" '[], T "IEnumerable" '[gt0] ]++type instance Members T_BaseType             = '[T_Foo, T_Bar]+type instance Members T_DerivedType          = '[T_Foo]+type instance Members (T "MyGenType" '[gt0]) = '[T_Add]++type instance Candidates T_Console T_WriteLine = '[ '[T_string], '[T_string, T_string] ]+type instance Candidates T_BaseType T_BaseType = '[ '[] ]+type instance Candidates T_BaseType T_Foo = '[ '[ T_string ], '[ T_long ], '[ T_int ] ]+type instance Candidates T_BaseType T_Bar = '[ '[ T_string ], '[ T_long ], '[ T_int ] ]+type instance Candidates T_DerivedType T_DerivedType = '[ '[] ]+type instance Candidates T_DerivedType T_Foo = '[ '[ T_string ], '[ T_long ], '[ T_int ]]+type instance Candidates (T "MyGenType" '[gt0]) (T "MyGenType" '[gt0]) = '[ '[] ]+type instance Candidates (T "MyGenType" '[gt0]) (T_Add) = '[ '[ gt0 ] ]++writeLineRaw1 :: String -> IO String+writeLineRaw1 cs = return "Console.WriteLine(String)"+writeLineRaw2 :: String -> String -> IO String+writeLineRaw2 cs1 cs2 = return "Console.WriteLine(String,String)"+rawInvokeBaseTypeFooStr :: ObjectID t -> String -> IO String+rawInvokeBaseTypeFooStr d s = return "BaseType.Foo(String)"+rawInvokeBaseTypeFooInt64 :: ObjectID t -> Int64 -> IO String+rawInvokeBaseTypeFooInt64 d s = return "BaseType.Foo(Int64)"+rawInvokeBaseTypeFooInt32 :: ObjectID t -> Int32 -> IO String+rawInvokeBaseTypeFooInt32 d s = return "BaseType.Foo(Int32)"+rawInvokeDerivedTypeStr :: ObjectID t -> String -> IO String+rawInvokeDerivedTypeStr d s = return "DerivedType.Foo(String)"+rawInvokeDerivedTypeInt64 :: ObjectID t -> Int64 -> IO String+rawInvokeDerivedTypeInt64 d s = return "DerivedType.Foo(Int64)"+rawInvokeDerivedTypeInt32 :: ObjectID t -> Int32 -> IO String+rawInvokeDerivedTypeInt32 d s = return "DerivedType.Foo(Int32)"+rawInvokeBaseTypeBarStr :: ObjectID t -> String -> IO String+rawInvokeBaseTypeBarStr d s = return "BaseType.Bar(String)"+rawInvokeBaseTypeBarInt64 :: ObjectID t -> Int64 -> IO String+rawInvokeBaseTypeBarInt64 d s = return "BaseType.Bar(Int64)"+rawInvokeBaseTypeBarInt32 :: ObjectID t -> Int32 -> IO String+rawInvokeBaseTypeBarInt32 d s = return "BaseType.Bar(Int32)"+rawInvokeMyGenTypeAddStr :: ObjectID t -> String -> IO String+rawInvokeMyGenTypeAddStr oid s = return "MyGenType.Add(String)"+rawInvokeMyGenTypeAddInt :: ObjectID t -> Int32 -> IO String+rawInvokeMyGenTypeAddInt oid s = return "MyGenType.Add(Int32)"+++instance MethodResultS1 T_Console T_WriteLine T_string where+  type ResultTypeS1 T_Console T_WriteLine T_string = T_string++instance MethodInvokeS1 T_Console T_WriteLine T_string where+  rawInvokeS1 = writeLineRaw1++instance MethodResultS2 T_Console T_WriteLine T_string T_string where+  type ResultTypeS2 T_Console T_WriteLine T_string T_string = T_string++instance MethodInvokeS2 T_Console T_WriteLine T_string T_string where+  rawInvokeS2 = writeLineRaw2++instance Constructor1 T_BaseType () where+  rawNew1 () = return (ObjectID undefined)++instance MethodResultI1 T_BaseType T_Foo T_string where+  type ResultTypeI1 T_BaseType T_Foo T_string = T_string++instance MethodInvokeI1 T_BaseType T_Foo T_string where+  rawInvokeI1 = rawInvokeBaseTypeFooStr++instance MethodResultI1 T_BaseType T_Foo T_long where+  type ResultTypeI1 T_BaseType T_Foo T_long = T_string++instance MethodInvokeI1 T_BaseType T_Foo T_long where+  rawInvokeI1 = rawInvokeBaseTypeFooInt64++instance MethodResultI1 T_BaseType T_Foo T_int where+  type ResultTypeI1 T_BaseType T_Foo T_int = T_string++instance MethodInvokeI1 T_BaseType T_Foo T_int where+  rawInvokeI1 = rawInvokeBaseTypeFooInt32++instance MethodResultI1 T_BaseType T_Bar T_string where+  type ResultTypeI1 T_BaseType T_Bar T_string = T_string++instance MethodInvokeI1 T_BaseType T_Bar T_string where+  rawInvokeI1 = rawInvokeBaseTypeBarStr++instance MethodResultI1 T_BaseType T_Bar T_long where+  type ResultTypeI1 T_BaseType T_Bar T_long = T_string++instance MethodInvokeI1 T_BaseType T_Bar T_long where+  rawInvokeI1 = rawInvokeBaseTypeBarInt64++instance MethodResultI1 T_BaseType T_Bar T_int where+  type ResultTypeI1 T_BaseType T_Bar T_int = T_string++instance MethodInvokeI1 T_BaseType T_Bar T_int where+  rawInvokeI1 = rawInvokeBaseTypeBarInt32++instance Constructor1 T_DerivedType () where+  rawNew1 () = return (ObjectID undefined)++instance MethodResultI1 T_DerivedType T_Foo T_string where+  type ResultTypeI1 T_DerivedType T_Foo T_string = T_string++instance MethodInvokeI1 T_DerivedType T_Foo T_string where+  rawInvokeI1 = rawInvokeDerivedTypeStr++instance MethodResultI1 T_DerivedType T_Foo T_long where+  type ResultTypeI1 T_DerivedType T_Foo T_long = T_string++instance MethodInvokeI1 T_DerivedType T_Foo T_long where+  rawInvokeI1 = rawInvokeDerivedTypeInt64++instance MethodResultI1 T_DerivedType T_Foo T_int where+  type ResultTypeI1 T_DerivedType T_Foo T_int = T_string++instance MethodInvokeI1 T_DerivedType T_Foo T_int where+  rawInvokeI1 = rawInvokeDerivedTypeInt32++instance Constructor1 (T "MyGenType" '[gt0]) () where+  rawNew1 () = return (ObjectID undefined)++instance MethodResultI1 (T "MyGenType" '[T_string]) T_Add T_string where+  type ResultTypeI1 (T "MyGenType" '[T_string]) T_Add T_string = T_string++instance MethodInvokeI1 (T "MyGenType" '[T_string]) T_Add T_string where+  rawInvokeI1 = rawInvokeMyGenTypeAddStr++instance MethodResultI1 (T "MyGenType" '[T_int]) T_Add T_int where+  type ResultTypeI1 (T "MyGenType" '[T_int]) T_Add T_int = T_string++instance MethodInvokeI1 (T "MyGenType" '[T_int]) T_Add T_int where+  rawInvokeI1 = rawInvokeMyGenTypeAddInt++instance Delegate T_StringIntDel where+  type DelegateArgTypes   T_StringIntDel = '[ T_string ]+  type DelegateResultType T_StringIntDel = T_int++instance DelegateConstructor1 T_StringIntDel where+  rawConstructDelegate1 f = return (ObjectID undefined :: ObjectID T_StringIntDel)++instance Marshal String Text where+  marshal s f = f $ pack s
test/Spec.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE TypeApplications, TypeInType, TypeFamilies #-} +import Test.Hspec+ import Clr-import Bindings()+import Instances()  import Data.Int(Int32, Int64)---- not really a proper test suite but something that should compile with expected output that is manually looked at+import Data.Text +-- TODO: I used the next lines once for manual testing in GHCI. The order of finding the super type matters when looking up the base type+-- Turn these next lines into something testable again. type instance SuperTypes (T "1" '[]) = '[] type instance SuperTypes (T "2" '[]) = '[ T "1" '[] ] type instance SuperTypes (T "3" '[]) = '[]@@ -17,34 +20,53 @@ type instance SuperTypes (T "8" '[]) = '[ T "6" '[], T "7" '[], T "5" '[]] type instance SuperTypes (T "9" '[]) = '[ T "8" '[] ] +-- Each of the following haskell functions are compatible+-- with a delegate of type System.String -> System.Int32+h1 :: String -> Int32+h1 = undefined+h2 :: Text -> Int32+h2 = undefined+h3 :: String -> IO Int32+h3 = undefined+h4 :: Text -> IO Int32+h4 = undefined+-- But this isn't+h5 :: String -> String+h5 = undefined  main :: IO () main = do-  putStrLn ""-  base <- new @"BaseType" ()                                 -- Constructors-  derived <- new @"DerivedType" ()-  putStrLn ""-  invokeS @"WriteLine" @"System.Console" "Hi!"               -- Static method invocation-  invokeS @"WriteLine" @"System.Console" ("Hello", "Again")  -- Overloaded-  putStrLn ""-  invokeI @"Foo" base "hi"                                   -- Instance method invocation-  invokeI @"Foo" base (2::Int32)-  invokeI @"Foo" base (2::Int64)-  putStrLn ""-  invokeI @"Foo" derived "hi"-  invokeI @"Foo" derived (2::Int32)-  invokeI @"Foo" derived (2::Int64)-  putStrLn ""-  invokeI @"Bar" base "hi"-  invokeI @"Bar" base (2::Int32)-  invokeI @"Bar" base (2::Int64)-  putStrLn ""-  invokeI @"Bar" derived "hi"                                -- DerivedType doesn't implement Bar so should call it on base type-  invokeI @"Bar" derived (2::Int32)-  invokeI @"Bar" derived (2::Int64)-  putStrLn ""-  myGenType <- new @'("MyGenType", "System.String") ()       -- Generic type-  invokeI @"Add" myGenType "hello"---  invokeI @"Add" myGenType (2::Int32)                      -- This would be a compilation error-  putStrLn ""+  base    <- new @"BaseType" ()                              :: IO (Object (T "BaseType" '[]))                       -- Constructors+  derived <- new @"DerivedType" ()                        -- :: IO (Object (T "DerivedType" '[]))                    -- Compiling fine with & without this signature++  invokeS @"WriteLine" @"System.Console" "Hi!"              `shouldReturn` "Console.WriteLine(String)"               -- Static method invocation+  invokeS @"WriteLine" @"System.Console" ("Hello", "Again") `shouldReturn` "Console.WriteLine(String,String)"        -- Overloaded++  invokeI @"Foo" base "hi"                                  `shouldReturn` "BaseType.Foo(String)"                    -- Instance method invocation+  invokeI @"Foo" base (2::Int32)                            `shouldReturn` "BaseType.Foo(Int32)"+  invokeI @"Foo" base (2::Int64)                            `shouldReturn` "BaseType.Foo(Int64)"++  invokeI @"Foo" derived "hi"                               `shouldReturn` "DerivedType.Foo(String)"+  invokeI @"Foo" derived (2::Int32)                         `shouldReturn` "DerivedType.Foo(Int32)"+  invokeI @"Foo" derived (2::Int64)                         `shouldReturn` "DerivedType.Foo(Int64)"++  invokeI @"Bar" base "hi"                                  `shouldReturn` "BaseType.Bar(String)"+  invokeI @"Bar" base (2::Int32)                            `shouldReturn` "BaseType.Bar(Int32)"+  invokeI @"Bar" base (2::Int64)                            `shouldReturn` "BaseType.Bar(Int64)"++  invokeI @"Bar" derived "hi"                               `shouldReturn` "BaseType.Bar(String)"                    -- DerivedType doesn't implement Bar so should call it on base type+  invokeI @"Bar" derived (2::Int32)                         `shouldReturn` "BaseType.Bar(Int32)"+  invokeI @"Bar" derived (2::Int64)                         `shouldReturn` "BaseType.Bar(Int64)"++  myGenType <- new @'("MyGenType", "System.String") ()       :: IO (Object (T "MyGenType" '[T "System.String" '[]])) -- Generic type+  invokeI @"Add" myGenType "hello"                          `shouldReturn` "MyGenType.Add(String)"+--invokeI @"Add" myGenType (2::Int32)                        -- This would be a compilation error++  _ <- delegate @"StringIntDel" h1                           -- Constructing a delegate from a haskell function+  _ <- delegate @"StringIntDel" h2+  _ <- delegate @"StringIntDel" h3+  _ <- delegate @"StringIntDel" h4+--_ <- delegate @"StringIntDel" h5                           -- This would also be a compilation error++  return ()