diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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" () +``` diff --git a/clr-typed.cabal b/clr-typed.cabal --- a/clr-typed.cabal +++ b/clr-typed.cabal @@ -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 diff --git a/src/Clr.hs b/src/Clr.hs --- a/src/Clr.hs +++ b/src/Clr.hs @@ -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) diff --git a/src/Clr/Bridge.hs b/src/Clr/Bridge.hs --- a/src/Clr/Bridge.hs +++ b/src/Clr/Bridge.hs @@ -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 diff --git a/src/Clr/Constructor.hs b/src/Clr/Constructor.hs --- a/src/Clr/Constructor.hs +++ b/src/Clr/Constructor.hs @@ -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 diff --git a/src/Clr/Curry.hs b/src/Clr/Curry.hs --- a/src/Clr/Curry.hs +++ b/src/Clr/Curry.hs @@ -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 diff --git a/src/Clr/Delegate.hs b/src/Clr/Delegate.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Delegate.hs @@ -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 + diff --git a/src/Clr/ListTuple.hs b/src/Clr/ListTuple.hs --- a/src/Clr/ListTuple.hs +++ b/src/Clr/ListTuple.hs @@ -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") diff --git a/src/Clr/Method/Instance.hs b/src/Clr/Method/Instance.hs --- a/src/Clr/Method/Instance.hs +++ b/src/Clr/Method/Instance.hs @@ -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 diff --git a/src/Clr/Method/Static.hs b/src/Clr/Method/Static.hs --- a/src/Clr/Method/Static.hs +++ b/src/Clr/Method/Static.hs @@ -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 diff --git a/src/Clr/Object.hs b/src/Clr/Object.hs --- a/src/Clr/Object.hs +++ b/src/Clr/Object.hs @@ -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 + diff --git a/src/Clr/Property.hs b/src/Clr/Property.hs --- a/src/Clr/Property.hs +++ b/src/Clr/Property.hs @@ -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) + + + diff --git a/src/Clr/Types.hs b/src/Clr/Types.hs --- a/src/Clr/Types.hs +++ b/src/Clr/Types.hs @@ -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 diff --git a/src/Clr/UnmarshalAs.hs b/src/Clr/UnmarshalAs.hs deleted file mode 100644 --- a/src/Clr/UnmarshalAs.hs +++ /dev/null @@ -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 - - diff --git a/test/Bindings.hs b/test/Bindings.hs deleted file mode 100644 --- a/test/Bindings.hs +++ /dev/null @@ -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)" diff --git a/test/Instances.hs b/test/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Instances.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 ()