diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,8 @@ # Revision history for clr-inline -## 0.1.0.0 -- YYYY-mm-dd +## 0.2.0 -- 2017-08-05 +* Experimental support for Haskell lambdas in the F# backend. + +## 0.1.0.0 -- 2017-04-25 * First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ [![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://img.shields.io/appveyor/ci/TimMatthews/clr-haskell.svg?label=Windows%20build)](https://ci.appveyor.com/project/tim-m89/clr-haskell) -**NOTE: you will need GHC >= 8.2 to use this package in Windows. +NOTE: you will need GHC >= 8.2 to use this package in Windows. What is clr-inline ======================= @@ -51,7 +51,10 @@ * Inline F# / C# in Haskell. * Automatic unmarshalling of CLR primitive types into Haskell. * Reference types support including arrays and generics. -* Refer to Haskell non-function values inside F# / C# quotations. +* Refer to (`Quotable`) Haskell values inside F# / C# quotations. +* Experimental support for Haskell lambdas in F#. + * See the InlineSpec.hs test module for examples of usage. + * Only mscorlib types are admitted, type resolution will crash at runtime otherwise. Getting Started =================== @@ -72,6 +75,11 @@ Cabal requires that the CLR compiler is in the application path at `cabal configure` time. The module `Clr.Inline.Cabal` provides an optional Cabal user hook that can be added to a cabal Setup script to check for this automatically + +Bug [#14090] in GHC 8.2.1 requires that the **StaticPointers** language extension is turned on in every module that +contains an inline F# or C# block. Moreover, the modules must have an unrestricted export list. + +[#14090]: http://ghc.haskell.org/trac/ghc/ticket/14090 The quasiquoters look for the F#/C# compiler binaries in the application path. External dependencies and additional search paths can be provided to diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,19 +1,2 @@ -import Clr.Host.Config -import Clr.Inline.Config import Distribution.Simple -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program -import Distribution.Verbosity as Verbosity - -main = defaultMainWithHooks simpleUserHooks { confHook = checkCompilers } - -checkCompilers gh cf = do - lbi <- confHook simpleUserHooks gh cf - _ <- requireProgram Verbosity.normal csharpCompiler (withPrograms lbi) - _ <- requireProgram Verbosity.normal fsharpCompiler (withPrograms lbi) - return lbi - -fsharpCompiler, csharpCompiler :: Program -csharpCompiler = simpleProgram (configCSharpPath defaultConfig) -fsharpCompiler = simpleProgram (configFSharpPath defaultConfig) - +main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeInType #-} +{-# LANGUAGE DataKinds #-} +module Bench where import Clr.Inline import Criterion diff --git a/clr-inline.cabal b/clr-inline.cabal --- a/clr-inline.cabal +++ b/clr-inline.cabal @@ -1,70 +1,141 @@ -name: clr-inline -version: 0.1.0.0 -synopsis: Quasiquoters for inline C# and F# -description: Please see README.md -license: BSD3 -license-file: LICENSE -author: Jose Iborra -maintainer: pepeiborra@gmail.com -copyright: 2017 Jose Iborra -category: Language, FFI, CLR, .NET -build-type: Simple -homepage: https://gitlab.com/tim-m89/clr-haskell -bug-reports: https://gitlab.com/tim-m89/clr-haskell/issues -extra-source-files: - CHANGELOG.md - README.md -cabal-version: >=1.10 +-- This file has been generated from package.yaml by hpack version 0.17.1. +-- +-- see: https://github.com/sol/hpack +name: clr-inline +version: 0.2.0 +synopsis: Quasiquoters for inline C# and F# +description: Please see README.md +category: Language, FFI, CLR, .NET +homepage: https://gitlab.com/tim-m89/clr-haskell +bug-reports: https://gitlab.com/tim-m89/clr-haskell/issues +author: Jose Iborra +maintainer: pepeiborra@gmail.com +copyright: 2017 Jose Iborra +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + CHANGELOG.md + README.md + source-repository head - type: git - location: https://gitlab.com/tim-m89/clr-haskell/tree/master + type: git + location: https://gitlab.com/tim-m89/clr-haskell/tree/master library - hs-source-dirs: src - exposed-modules: Clr.Inline - Clr.Inline.Cabal - Clr.Inline.Config - other-modules: - Clr.CSharp.Inline - Clr.FSharp.Inline - Clr.Inline.State - Clr.Inline.Types - Clr.Inline.Utils - Clr.Inline.Utils.Parse - Clr.Inline.Utils.Embed - Clr.Inline.Quoter - Clr.FSharp.Gen - build-depends: base >=4.9 && <4.10, - bytestring, - Cabal, - clr-host, - clr-marshal, - containers, - directory, - extra, - filepath, - here, - lens, - process, - template-haskell, - temporary, - text, - transformers - default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing + hs-source-dirs: + src + ghc-options: -Wall -Wno-name-shadowing + build-depends: + text + , base >=4.9 && <5 + , bytestring + , Cabal + , case-insensitive + , clr-host + , clr-marshal + , containers + , directory + , extra + , filepath + , here + , lens + , parsec + , process + , split + , template-haskell + , temporary + , transformers + exposed-modules: + Clr.Inline + Clr.Inline.Cabal + Clr.Inline.Config + other-modules: + Clr.CSharp.Inline + Clr.FSharp.Gen + Clr.FSharp.Inline + Clr.Inline.Quoter + Clr.Inline.State + Clr.Inline.Types + Clr.Inline.Utils + Clr.Inline.Utils.Embed + Clr.Inline.Utils.Parse + Paths_clr_inline + default-language: Haskell2010 -benchmark benchmark +test-suite spec type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: bench - build-depends: base, clr-inline, criterion, text - default-language: Haskell2010 + main-is: Spec.hs + hs-source-dirs: + src + test + build-depends: + text + , base >=4.9 && <5 + , bytestring + , Cabal + , case-insensitive + , clr-host + , clr-marshal + , containers + , directory + , extra + , filepath + , here + , lens + , parsec + , process + , split + , template-haskell + , temporary + , transformers + , hspec + other-modules: + Clr.CSharp.Inline + Clr.FSharp.Gen + Clr.FSharp.Inline + Clr.Inline + Clr.Inline.Cabal + Clr.Inline.Config + Clr.Inline.Quoter + Clr.Inline.State + Clr.Inline.Types + Clr.Inline.Utils + Clr.Inline.Utils.Embed + Clr.Inline.Utils.Parse + InlineSpec + default-language: Haskell2010 -test-suite spec +benchmark benchmark type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: test - build-depends: base, clr-inline, hspec, text - default-language: Haskell2010 - other-modules: InlineSpec + main-is: Main.hs + hs-source-dirs: + bench + ghc-options: -main-is Bench.main + build-depends: + text + , base >=4.9 && <5 + , bytestring + , Cabal + , case-insensitive + , clr-host + , clr-marshal + , containers + , directory + , extra + , filepath + , here + , lens + , parsec + , process + , split + , template-haskell + , temporary + , transformers + , base + , clr-inline + , criterion + default-language: Haskell2010 diff --git a/src/Clr/CSharp/Inline.hs b/src/Clr/CSharp/Inline.hs --- a/src/Clr/CSharp/Inline.hs +++ b/src/Clr/CSharp/Inline.hs @@ -89,7 +89,12 @@ " public static %s %s (%s) { " returnType (getMethodName exp) - (intercalate ", " [printf "%s %s" t a | (a, ClrType t) <- Map.toList args]) + (intercalate ", " [ printf "%s %s" t a + | (a, argDetails) <- Map.toList args + , let t = case argDetails of + Value (ClrType t) -> t + Delegate{} -> error "delegates not yet supported in the C# quoter." + ]) yield $ printf "#line %d \"%s\"" (fst $ loc_start loc) (loc_filename loc) forM_ (lines body) $ \l -> yield $ printf " %s" l yield "}" diff --git a/src/Clr/FSharp/Gen.hs b/src/Clr/FSharp/Gen.hs --- a/src/Clr/FSharp/Gen.hs +++ b/src/Clr/FSharp/Gen.hs @@ -10,9 +10,11 @@ import Clr.Inline.Utils import Clr.Inline.Utils.Embed import Clr.Inline.Types +import Control.Lens hiding ((<.>)) import Control.Monad import Control.Monad.Trans.Writer import qualified Data.ByteString as BS +import Data.List import qualified Data.Map as Map import Data.Proxy import Language.Haskell.TH.Syntax @@ -25,6 +27,9 @@ name :: Proxy "fsharp" name = Proxy +paramNames :: [String] +paramNames = [printf "x%d" x | x <- [0::Int ..] ] + genCode :: ClrInlinedGroup "fsharp" -> String genCode ClrInlinedGroup {units, mod} = unlines $ @@ -40,11 +45,26 @@ let argsString = case Map.toList args of [] -> "()" - other -> unwords [printf "(%s:%s)" a t | (a, ClrType t) <- other] + other -> unwords [printf "(%s:%s)" a argType + | (a, argDetails) <- other + , let argType = case argDetails of + Value (ClrType t) -> t + Delegate _ [] Nothing -> "System.Action" + Delegate _ args Nothing -> printf "System.Action<%s>" (intercalate "," (map getClrType args)) + Delegate _ args (Just res) -> printf "System.Func<%s>" (intercalate "," (map getClrType args ++ [getClrType res])) + ] + yield $ printf "#line %d \"%s\"" (fst $ loc_start loc) (loc_filename loc) yield $ printf " static member %s %s =" (getMethodName exp) argsString + iforMOf_ (ifolded<._Delegate) args $ \ argName (_,args,_) -> do + let params = take (length args) paramNames + formalParams = case params of [] -> "()" ; aa -> unwords aa + actualParams = intercalate "," params + yield $ printf " let %s %s = %s.Invoke(%s) in" argName formalParams argName actualParams + yield " (" yield $ printf "#line %d \"%s\"" (fst $ loc_start loc) (loc_filename loc) forM_ (lines body) $ \l -> yield $ printf " %s" l + yield " )" compile :: ClrInlineConfig -> ClrInlinedGroup "fsharp" -> IO ClrBytecode compile ClrInlineConfig {..} m@ClrInlinedGroup {..} = do diff --git a/src/Clr/Inline.hs b/src/Clr/Inline.hs --- a/src/Clr/Inline.hs +++ b/src/Clr/Inline.hs @@ -4,6 +4,7 @@ , fsharp , fsharp' , startClr + , GCHandle(..) , Quotable -- * Reexports for generated code , FunPtr @@ -17,5 +18,6 @@ import Clr.FSharp.Inline import Clr.Host import Clr.Host.BStr +import Clr.Host.GCHandle import Clr.Inline.Types import Foreign diff --git a/src/Clr/Inline/Cabal.hs b/src/Clr/Inline/Cabal.hs --- a/src/Clr/Inline/Cabal.hs +++ b/src/Clr/Inline/Cabal.hs @@ -1,6 +1,5 @@ module Clr.Inline.Cabal (ensureFSharp, ensureCSharp) where -import Clr.Host.Config import Clr.Inline.Config import Distribution.Simple import Distribution.Simple.LocalBuildInfo @@ -31,6 +30,7 @@ csharpCompiler = simpleProgram (configCSharpPath defaultConfig) fsharpCompiler = simpleProgram (configFSharpPath defaultConfig) +check :: Program -> (gh -> cf -> IO LocalBuildInfo) -> gh -> cf -> IO LocalBuildInfo check pgm base gh cf = do lbi <- base gh cf _ <- requireProgram Verbosity.normal pgm (withPrograms lbi) diff --git a/src/Clr/Inline/Quoter.hs b/src/Clr/Inline/Quoter.hs --- a/src/Clr/Inline/Quoter.hs +++ b/src/Clr/Inline/Quoter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} @@ -10,15 +11,21 @@ {-# LANGUAGE ScopedTypeVariables #-} module Clr.Inline.Quoter where -import Clr.Marshal.Host (GetMethodStubDelegate, makeGetMethodStubDelegate, unsafeGetPointerToMethod) +import Clr.Host.DriverEntryPoints (unsafeGetPointerToMethod) +import Clr.Host.Method (GetMethodStubDelegate, makeGetMethodStubDelegate) import Clr.Host.BStr +import Clr.Host.Delegate +import Clr.Host.GCHandle import Clr.Marshal +import Clr.MarshalF import Clr.Inline.State import Clr.Inline.Types import Clr.Inline.Utils.Parse import Clr.Inline.Utils.Embed import Control.Lens +import Control.Monad import Data.Char +import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe @@ -30,12 +37,31 @@ import System.IO.Unsafe import Text.Printf +data ArgDetails name a + = Value { _quotedType :: a} + | Delegate { _delegateName :: name + , _quotedArgs :: [a] + , _quotedReturn :: Maybe a} +makeLenses ''ArgDetails +makePrisms ''ArgDetails + +quotes :: Traversal (ArgDetails name a) (ArgDetails name a') a a' +quotes f (Value q) = Value <$> f q +quotes f (Delegate n aa r) = Delegate n <$> traverse f aa <*> traverse f r + +parseArgDetails :: QuotedType -> ArgDetails () String +parseArgDetails (Fun [Unit] Unit) = Delegate () [] Nothing +parseArgDetails (Fun [Unit] a) = Delegate () [] (Just $ renderQuotedType a) +parseArgDetails (Fun args Unit) = Delegate () (map renderQuotedType args) Nothing +parseArgDetails (Fun args res ) = Delegate () (map renderQuotedType args) (Just $ renderQuotedType res) +parseArgDetails other = Value (renderQuotedType other) + data ClrInlinedExpDetails (language :: Symbol) argType = ClrInlinedExpDetails { language :: Proxy language , unitId :: Int , stubName :: Name , body :: String - , args :: Map String argType + , args :: Map String (ArgDetails Name argType) , loc :: Loc , returnType :: String } @@ -70,21 +96,25 @@ toClrArg :: String -> String toClrArg x = "arg_" ++ x - getValueName :: String -> Q Name getValueName a = fromMaybe (error $ "Identifier not in scope: " ++ a) <$> lookupValueName a generateFFIStub :: KnownSymbol language => ClrInlinedExpDetails language String -> Q [Dec] generateFFIStub ClrInlinedExpDetails{..} = do - resTy <- [t| IO $(lookupQuotableMarshalType returnType)|] - argsTyped <- traverse lookupQuotableMarshalType args - let funTy = return $ foldr (\t u -> ArrowT `AppT` t `AppT` u) resTy (Map.elems argsTyped) + let resTy = [t| IO $(lookupQuotableMarshalType returnType)|] + argTy (Value q) = lookupQuotableMarshalType q + -- The representation of a delegate is GCHandle Int + argTy Delegate{} = [t| GCHandle Int |] + mkFunTy = foldrOf folded (\t u -> arrowT `appT` argTy t `appT` u) -- This is what we'd like to write: -- [d| foreign import ccall "dynamic" $stubName :: $([t|FunPtr $funTy -> $funTy|]) |] -- Unfort. splicing languages into foreign import decl is not supported, so we have to write: -- TODO Convert every type to its Marshalled counterpart - ffiStub <- ForeignD . ImportF CCall Safe "dynamic" stubName <$> [t|FunPtr $funTy -> $funTy|] - return [ffiStub] + ffiStub <- let funTy = mkFunTy resTy args in ForeignD . ImportF CCall Safe "dynamic" stubName <$> [t|FunPtr $funTy -> $funTy|] + delegateStubs <- forM (toListOf (folded._Delegate) args) $ \(stubName, argTys, resTy) -> + let funTy = lookupDelegateMarshalType argTys (maybe [t|()|] lookupQuotableMarshalType resTy) + in ForeignD . ImportF CCall Safe "wrapper" stubName <$> [t| $funTy -> IO(FunPtr $funTy) |] + return $ ffiStub : delegateStubs getMethodStubRaw :: (GetMethodStubDelegate a) getMethodStubRaw = unsafeDupablePerformIO $ makeGetMethodStubDelegate <$> unsafeGetPointerToMethod "GetMethodStub" @@ -92,20 +122,49 @@ invoke :: String -> String -> FunPtr a invoke c m = unsafeDupablePerformIO $ marshal c $ \c -> marshal m $ \m -> return $ getMethodStubRaw c m (BStr nullPtr) -generateClrCall :: KnownSymbol language => Module -> ClrInlinedExpDetails language a -> ExpQ +createDelegate :: String -> [String] -> (f -> IO (FunPtr f)) -> IO (f -> IO (GCHandle Int)) +createDelegate name types = getDelegateConstructorStub clrtype + where + clrtype + | null types = name + | otherwise = printf "%s`%d[%s]" name (length types) (intercalate "," types) + +generateClrCall :: KnownSymbol language => Module -> ClrInlinedExpDetails language String -> ExpQ generateClrCall mod exp@ClrInlinedExpDetails{..} = do + argsWithDelegates <- iforMOf (itraversed <. _Delegate) args $ \n (stubN,args,res) -> do + delName <- newName (printf "delegate_%s" n) + argClrTypes <- mapM (fmap getClrType . lookupQuotableClrType) args + resClrType <- traverse (fmap getClrType . lookupQuotableClrType) res + let argCount = case args of ["unit"] -> 0 ; other -> genericLength other + DoE (init -> stmts) <- + [| do wrapper <- + case resClrType of + Nothing -> createDelegate "System.Action" argClrTypes $(varE stubN) + Just ty -> createDelegate "System.Func" (argClrTypes ++ [ty]) $(varE stubN) + $(varP delName) <- wrapper $ marshalF' (Proxy :: $([t| Proxy $(litT$ numTyLit argCount)|])) $(varE =<< getValueName n) + return () + |] + return ((delName, stmts), args, res) let argExps = - [ [| marshal $(varE =<< getValueName a)|] - | a <- Map.keys args + [ case argDetails of + Value{} -> [| marshal $(varE =<< getValueName a)|] + Delegate{_delegateName = (d,_stmts)} -> [| \k -> k $(varE d) |] + | (a, argDetails) <- Map.toList argsWithDelegates ] roll m f = [|$m . ($f .)|] - [| do unembedBytecode - let stub = invoke $(liftString $ getFullClassName language mod) $(liftString $ getMethodName exp) - let stub_f = $(varE stubName) stub - result <- $(foldr roll [|id|] argExps) stub_f - unmarshalAuto (Proxy :: $([t| Proxy $(litT $ strTyLit returnType) |])) result - |] + delegateStmts = concatOf (folded._Delegate._1._2) argsWithDelegates + DoE (splitAt 3 -> (part1, part2)) <- + [| do unembedBytecode + let stub = invoke $(liftString $ getFullClassName language mod) $(liftString $ getMethodName exp) + let stub_f = $(varE stubName) stub + result <- $(foldr roll [|id|] argExps) stub_f + unmarshal result :: IO $(lookupQuotableUnmarshalType returnType) + |] + return $ DoE (part1 ++ delegateStmts ++ part2) +marshalF' :: forall (n::Nat) from to . MarshalF n from to => Proxy n -> from -> to +marshalF' Proxy = marshalF @n + -- | Runs after the whole module has been loaded and is responsible for generating: -- - A clr assembly with all the inline code, embedding it into the module. clrGenerator @@ -114,9 +173,8 @@ clrGenerator language hsmod compile = do FinalizerState {wrappers} <- getFinalizerState @(ClrInlinedUnit language String) typedWrappers <- - mapMOf (traversed . _ClrInlinedExp . _args) (fmap (Map.mapKeysMonotonic toClrArg) . traverse lookupQuotableClrType) wrappers + mapMOf (traversed . _ClrInlinedExp . _args) (fmap (Map.mapKeysMonotonic toClrArg) . traverseOf (traverse.quotes) lookupQuotableClrType) wrappers let mod = ClrInlinedGroup hsmod typedWrappers - _ <- runIO $ compile mod -- Embed the bytecodes embedBytecode (symbolVal language) =<< runIO (compile mod) @@ -132,16 +190,18 @@ clrQuoteExp language clrCompile body = do count <- getFinalizerCount @(ClrInlinedUnit language String) mod <- thisModule - stubName <- newName $ printf "%s_stub_%d" (symbolVal language) count + let stubString = printf "%s_stub_%d" (symbolVal language) count + stubName <- newName stubString loc <- location let ParseResult parsedBody resultType antis = parse toClrArg body + argDetails <- iforM antis $ \i x -> traverseOf (_Delegate._1) (\_ -> newName $ printf "%s_%s" stubString i) (parseArgDetails x) let inlinedUnit = ClrInlinedExpDetails language count stubName (normaliseLineEndings parsedBody) - antis + argDetails loc resultType pushWrapperGen (clrGenerator language mod clrCompile) $ return (ClrInlinedExp inlinedUnit :: ClrInlinedUnit language String) diff --git a/src/Clr/Inline/Types.hs b/src/Clr/Inline/Types.hs --- a/src/Clr/Inline/Types.hs +++ b/src/Clr/Inline/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -5,55 +6,73 @@ {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -module Clr.Inline.Types where +module Clr.Inline.Types + ( ClrPtr(..) + , Clr(..) + , ClrType(..) + , Quotable + , TextBStr(..) + , lookupDelegateMarshalType + , lookupQuotableClrType + , lookupQuotableMarshalType + , lookupQuotableUnmarshalType + ) where +import Clr.Host.GCHandle import Clr.Host.BStr import Clr.Marshal -import Clr.Marshal.Host +import Data.Coerce import Data.Int -import Data.IORef import Data.Maybe -import Data.Proxy +import Data.Monoid import Data.Text (Text) import Data.Word import Foreign import GHC.TypeLits import Language.Haskell.TH import System.IO.Unsafe +import Text.Printf -- | A pointer to a Clr object. -- The only way to access the contents is via clr-inline quotations. -newtype ClrPtr (name::Symbol)= ClrPtr Int64 +newtype ClrPtr (name::Symbol)= ClrPtr (GCHandle Int) -- | A wrapper around a 'ClrPtr', which will be released once this -- wrapper is no longer referenced. -- The only way to access the contents is in clr-inline quotations. -data Clr (name::Symbol) = Clr (ClrPtr name) (IORef ()) - -foreign import ccall "dynamic" releaseObject :: FunPtr (Int64 -> IO ()) -> (Int64 -> IO ()) +newtype Clr (name::Symbol) = Clr (ForeignPtr Int) +-- Returning from a CLR function that was called from Haskell instance Unmarshal (ClrPtr n) (Clr n) where - unmarshal o@(ClrPtr id) = do - ref <- newIORef () - _ <- mkWeakIORef ref $ do - let f = unsafeDupablePerformIO (unsafeGetPointerToMethod "ReleaseObject") - releaseObject f id - return (Clr o ref) + unmarshal (ClrPtr id) = do + ptr <- newForeignPtr (unsafeDupablePerformIO gcHandleFinalizer) (coerce id) + return (Clr ptr) +-- Returning from a Haskell function that was called by the CLR +instance {-# OVERLAPPING #-} Unmarshal (Clr t) (ClrPtr t) where + unmarshal (Clr x) = withForeignPtr x $ \x'-> ClrPtr <$> newHandle (coerce x') + +-- Calling a CLR function from Haskell instance Marshal (Clr n) (ClrPtr n) where - marshal (Clr ptr ref) f = do - () <- readIORef ref - f ptr + marshal (Clr ptr) f = withForeignPtr ptr $ \p -> f (ClrPtr $ coerce p) +-- Calling a Haskell function from the CLR +instance {-# OVERLAPPING #-} Marshal (ClrPtr t) (Clr t) where + marshal (ClrPtr x) f = do + x' <- newHandle x + fp <- newForeignPtr (unsafeDupablePerformIO gcHandleFinalizer) (coerce x') + f $ Clr fp + newtype ClrType = ClrType {getClrType :: String} deriving Show +type MarshalType = Type newtype TextBStr = TextBStr BStr instance Unmarshal TextBStr Text where unmarshal (TextBStr t) = unmarshal t instance Marshal Text TextBStr where marshal x f = marshal x (f . TextBStr) -- | Extensible mapping between quotable CLR types and Haskell types -class Unmarshal marshal haskell => - Quotable (quoted::Symbol) (clr::Symbol) marshal haskell | marshal -> haskell clr +class Unmarshal marshal unmarshal => + Quotable (quoted::Symbol) (clr::Symbol) marshal unmarshal instance Quotable "bool" "System.Boolean" Bool Bool instance Quotable "double" "System.Double" Double Double instance Quotable "int" "System.Int32" Int Int @@ -70,8 +89,9 @@ instance Quotable "string" "System.String" BStr String instance Quotable "text" "System.String" TextBStr Text instance Quotable "void" "System.Void" () () +instance Quotable "unit" "Microsoft.FSharp.Core.Unit" () () -- | All reference types are handled by this instance. -instance Quotable a a (ClrPtr a) (Clr a) +instance Quotable a a (ClrPtr a) (Clr a) lookupQuotable :: Show a => ([InstanceDec] -> a) -> String -> Q a lookupQuotable extract quote = do @@ -82,24 +102,45 @@ instances <- reifyInstances ''Quotable [ ty, VarT a, VarT b, VarT c ] return $ extract instances +handleOverlappingInstances :: String -> String -> [Dec] -> a +handleOverlappingInstances msg s instances = error $ printf "Overlapping %s instances for Quotable %s: %s" msg s (show names) -- (show instances) + where + names = [ quote | InstanceD _ _ (_ `AppT` quote `AppT` _ `AppT` _ `AppT` _) _ <- instances ] + +extractMostSpecificInstance s msg f1 f2 instances = + fromMaybe (handleOverlappingInstances msg s instances) . getFirst $ + foldMap (apply f1) instances <> foldMap (apply f2) instances + where + apply f (InstanceD _ _ (_ `AppT` quote `AppT` clr `AppT` marshal `AppT` unmarshal) _) = First $ f quote clr marshal unmarshal + apply _ _ = error "unreachable" + lookupQuotableClrType :: String -> Q ClrType -lookupQuotableClrType s = lookupQuotable extractClrType s +lookupQuotableClrType s = lookupQuotable extract s where - extractClrType instances = fromMaybe (general instances) $ listToMaybe $ mapMaybe specific instances - specific (InstanceD _ _ (_ `AppT` _ `AppT` LitT (StrTyLit s) `AppT` _ `AppT` _) _) = Just $ ClrType s - specific _ = Nothing - general [InstanceD _ _ (_ `AppT` quote `AppT` clr `AppT` _ `AppT` _) _] | quote == clr = ClrType s - general _ = error $ "Overlapping instances for Quotable " ++ s + extract = extractMostSpecificInstance s "Clr" specific general + specific _ (LitT (StrTyLit s)) _ _ = Just $ ClrType s + specific _ _ _ _ = Nothing + general quote@VarT{} clr@VarT{} _ _ | quote == clr = Just $ ClrType s + general _ _ _ _ = Nothing -lookupQuotableMarshalType :: String -> Q Type -lookupQuotableMarshalType s = lookupQuotable extractMarshalType s +lookupQuotableMarshalType :: String -> Q MarshalType +lookupQuotableMarshalType s = lookupQuotable extract s where - extractMarshalType instances = fromMaybe (general instances) $ listToMaybe $ mapMaybe specific instances - specific (InstanceD _ _ (_ `AppT` quote `AppT` clr `AppT` _ `AppT` _) _) | quote == clr = Nothing - specific (InstanceD _ _ (_ `AppT` _ `AppT` _ `AppT` marshalTy `AppT` _) _) = Just marshalTy - specific _ = Nothing - general [InstanceD _ _ (_ `AppT` quote `AppT` clr `AppT` AppT (ConT clrPtr) _ `AppT` _) _] | quote == clr && clrPtr == ''ClrPtr = AppT (ConT clrPtr) (LitT (StrTyLit s)) - general _ = error $ "Overlapping instances for Quotable " ++ s + extract = extractMostSpecificInstance s "Marshal" specific general + specific LitT{} LitT{} marshalTy _ = Just marshalTy + specific _ _ _ _ = Nothing + general quote@VarT{} clr@VarT{} (con `AppT` v) _ | quote == clr && quote == v= Just $ AppT con (LitT (StrTyLit s)) + general _ _ _ _ = Nothing -unmarshalAuto :: Quotable quote clr a unmarshal => Proxy quote -> a -> IO unmarshal -unmarshalAuto _ = unmarshal +lookupDelegateMarshalType :: [String] -> TypeQ -> Q MarshalType +lookupDelegateMarshalType args resTy = + foldr (\t u -> arrowT `appT` lookupQuotableMarshalType t `appT` u) [t| IO $(resTy) |] args + +lookupQuotableUnmarshalType :: String -> Q Type +lookupQuotableUnmarshalType s = lookupQuotable extract s + where + extract = extractMostSpecificInstance s "Unmarshal" specific general + specific LitT{} LitT{} _ unmarshalTy = Just unmarshalTy + specific _ _ _ _ = Nothing + general quote@VarT{} clr@VarT{} _ (con `AppT` v) | quote == clr && quote == v = Just $ AppT con (LitT (StrTyLit s)) + general _ _ _ _ = Nothing diff --git a/src/Clr/Inline/Utils/Embed.hs b/src/Clr/Inline/Utils/Embed.hs --- a/src/Clr/Inline/Utils/Embed.hs +++ b/src/Clr/Inline/Utils/Embed.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} module Clr.Inline.Utils.Embed where -import Clr.Marshal.Host +import Clr.Host.DriverEntryPoints import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as BS diff --git a/src/Clr/Inline/Utils/Parse.hs b/src/Clr/Inline/Utils/Parse.hs --- a/src/Clr/Inline/Utils/Parse.hs +++ b/src/Clr/Inline/Utils/Parse.hs @@ -1,53 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} module Clr.Inline.Utils.Parse where import Control.Lens +import qualified Data.CaseInsensitive as CI import Data.Char import Data.List.Extra import Data.Map (Map) +import Data.Maybe import qualified Data.Map as Map +import Text.Parsec.Combinator +import Text.Parsec.Pos +import Text.Parsec.Prim +import Prelude hiding (getChar) -data Token = +type Parser a = Parsec [Token] () a + +data Token = Char Char | Dollar | Arrow deriving Eq + +tokenize :: String -> [Token] +tokenize ('[':'~':'|': rest) = Char '[' : Char '|' : tokenize rest +tokenize ('|':'~':']': rest) = Char '|' : Char ']' : tokenize rest +tokenize ('$':'$':xx) = Char '$' : tokenize xx +tokenize ('-':'>':xx) = Arrow : tokenize xx +tokenize ('$':xx) = Dollar : tokenize xx +tokenize (x:xx) = Char x : tokenize xx +tokenize [] = [] + +isChar :: Token -> Bool +isChar = isJust . getChar + +getChar :: Token -> Maybe Char +getChar (Char c) = Just c +getChar _ = Nothing + +isDollar :: Token -> Bool +isDollar = not . isChar + +tokenToString :: Token -> String +tokenToString (Char c) = [c] +tokenToString Dollar = "$" +tokenToString Arrow = "->" + +instance Show Token where + show = tokenToString + +data Section = Other String - | Antiquote String (Maybe String) - deriving Show + | Antiquote {parenthised :: Bool, name:: !String, typ :: !(Maybe QuotedType)} + deriving (Eq, Show) +normalizeProgram :: [Section] -> [Section] +normalizeProgram (Other a : Other b : rest) = Other(a++b) : normalizeProgram rest +normalizeProgram (x:xx) = x : normalizeProgram xx +normalizeProgram [] = [] + +data QuotedType = Con String + | Fun [QuotedType] QuotedType + | Unit + deriving (Eq, Show) + +renderQuotedType :: QuotedType -> String +renderQuotedType = show where + show (Con x) = x + show Unit = "unit" + show (Fun args res) = intercalate "->" $ map show (args ++ [res]) + +satisfy :: (Token -> Maybe a) -> Parser a +satisfy = tokenPrim show (\pos t _cs -> updatePosString pos (tokenToString t)) + +dollar :: Parser () +dollar = satisfy (\case Dollar -> Just () ; _ -> Nothing) +arrow :: Parser String +arrow = const "->" <$> satisfy (\case Arrow -> Just () ; _ -> Nothing) + + +char :: Char -> Parser Char +char c = satisfyChar (== c) + +string :: String -> Parser String +string = mapM char + +satisfyChar :: (Char -> Bool) -> Parser Char +satisfyChar f = satisfy (\case Char c | f c -> Just c ; _ -> Nothing) + +topP :: Parser [Section] +topP = (normalizeProgram <$> many sectionP) <* eof + +sectionP :: Parser Section +sectionP = (dollar *> (antiquoteP False <|> otherP "$")) <|> + otherP "" + +otherP :: String -> Parser Section +otherP prefix = Other . (prefix ++) . concat <$> many1 (((:[]) <$> satisfy getChar) <|> arrow) + +antiquoteP :: Bool -> Parser Section +antiquoteP parenthised = parens (antiquoteP True) <|> + (Antiquote parenthised <$> identP <*> option Nothing (Just <$> (char ':' *> typP))) + +parens :: Parser a -> Parser a +parens = between (char '(') (char ')') + +identP :: Parser String +identP = (:) <$> satisfyChar isAlpha <*> many(satisfyChar isIdent) + where + isIdent x = isAlphaNum x || x == '_' + +conP :: Parser QuotedType +conP = (readType .) . (:) <$> satisfyChar isTypeIdent <*> many(satisfyChar isTypeIdent) + where + isTypeIdent x = isAlphaNum x || x `elem` ("[]<>.,_-*"::String) + readType (CI "unit") = Unit + readType other = Con other + +typP :: Parser QuotedType +typP = rebuild <$> conP <*> optionMaybe (arrow *> typP) + where + rebuild :: QuotedType -> Maybe QuotedType -> QuotedType + rebuild con Nothing = con + rebuild con (Just (Fun args' res)) = Fun (args' ++ [con]) res + rebuild con (Just res) = Fun [con] res + +pattern CI s <- (CI.mk -> s) + -- TODO tokenizing quoted strings -tokenized :: Iso' String [Token] -tokenized = iso (tokenize (Other [])) untokenize +tokenized :: Iso' String [Section] +tokenized = iso parse untokenize where - tokenize :: Token -> String -> [Token] - -- Tokenizing inside clr code - tokenize (Other acc) [] = [Other (reverse acc)] - -- Start an antiquote - tokenize (Other acc) ('$':rest) = Other (reverse acc) : tokenize (Antiquote "" Nothing) rest - -- Escape F# array notation - tokenize (Other ('~':'|':acc)) (']':rest) = tokenize (Other (']':'|':acc)) rest - tokenize (Other ('~':'[':acc)) ('|':rest) = tokenize (Other ('|':'[':acc)) rest - tokenize (Other acc) (c :rest) = tokenize (Other (c:acc)) rest - -- Tokenizing inside an antiquote - tokenize (Antiquote s t) [] = [Antiquote (reverse s) (reverse <$> t)] - tokenize (Antiquote s t) (c : rest) | isBreak c = Antiquote (reverse s) (reverse <$> t) : tokenize (Other [c]) rest - tokenize (Antiquote s Nothing) (':':rest) = tokenize (Antiquote s (Just "")) rest - tokenize (Antiquote s Nothing) (c :rest) = tokenize (Antiquote (c:s) Nothing) rest - tokenize (Antiquote s (Just t)) (c :rest) = tokenize (Antiquote s (Just (c:t))) rest + parse x = case runParser topP () "" (tokenize x) of + Right res -> res + Left e -> error $ show e - untokenize :: [Token] -> String + untokenize :: [Section] -> String untokenize [] = [] untokenize (Other s: rest) = s ++ untokenize rest - untokenize (Antiquote v Nothing : rest) = '$' : v ++ untokenize rest - untokenize (Antiquote v (Just t) : rest) = '$' : v ++ ':' : t ++ untokenize rest - - isBreak c = isSpace c || c == ')' + untokenize (Antiquote True v Nothing : rest) = '$':'(':v ++ ')':untokenize rest + untokenize (Antiquote True v (Just t) : rest) = '$':'(':v ++ ':' : renderQuotedType t ++ ')':untokenize rest + untokenize (Antiquote False v Nothing : rest) = '$' : v ++ untokenize rest + untokenize (Antiquote False v (Just t) : rest) = '$' : v ++ ':' : renderQuotedType t ++ untokenize rest -- | Looks for antiquotes of the form $foo in the given string -- Returns the antiquotes found, and a new string with the -- antiquotes transformed -extractArgs :: (String -> String) -> String -> (Map String String, String) +extractArgs :: (String -> String) -> String -> (Map String QuotedType, String) extractArgs transf = mapAccumROf (tokenized.traversed) f mempty where f acc (Other s) = (acc, Other s) - f acc (Antiquote v (Just t)) = (Map.insert v t acc, Other (transf v)) - f acc (Antiquote v Nothing) + f acc (Antiquote _ v (Just t)) = (Map.insert v t acc, Other (transf v)) + f acc (Antiquote _ v Nothing ) | Just _ <- acc ^? at v = (acc, Other (transf v)) | otherwise = error $ "The first occurrence of an antiquote must include a type ann. (" ++ v ++ ")" @@ -76,7 +178,7 @@ data ParseResult = ParseResult { body, returnType :: String - , args :: Map String String + , args :: Map String QuotedType } parse :: (String -> String) -> String -> ParseResult diff --git a/test/InlineSpec.hs b/test/InlineSpec.hs --- a/test/InlineSpec.hs +++ b/test/InlineSpec.hs @@ -2,13 +2,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -Wno-missing-signatures #-} module InlineSpec where import Control.Concurrent import Control.Monad +import Control.Lens import Clr.Inline +import Clr.Inline.Utils.Parse import Data.Int +import Data.String import Data.Text as Text (pack) import Data.Word import Test.Hspec @@ -24,11 +29,41 @@ open System.Collections.Generic |] -type SystemDateTime = Clr "System.DateTime" -type DateTime = Clr "DateTime" +type DateTime = Clr "System.DateTime" main = hspec spec +spec = do + describe "Parsing antiquotes" parseSpec + describe "QuasiQuoting" qqSpec + +shouldParseTo program result = do + let p = view tokenized program + p `shouldBe` result + +shouldRoundtripAndParseTo program result = do + let p = view tokenized program + p `shouldBe` result + review tokenized p `shouldBe` program + +parseSpec :: Spec +parseSpec = do + it "$foo" $ "$foo" `shouldRoundtripAndParseTo` [Antiquote False "foo" Nothing] + it "$foo:int" $ "$foo:int" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just (Con "int"))] + it "$foo:unit" $ "$foo:unit" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just Unit)] + it "$(foo:unit)" $ "$(foo:unit)" `shouldRoundtripAndParseTo` [Antiquote True "foo" (Just Unit)] + it "($foo:unit)" $ "($foo:unit)" `shouldRoundtripAndParseTo` [Other "(", Antiquote False "foo" (Just Unit), Other ")"] + it "$$foo" $ "$$foo" `shouldParseTo` [Other "$foo"] +-- it "\"$foo\"" $ "\"$foo\"" `shouldRoundtripAndParseTo` [Other "\"$foo\""] TODO + it "1 $ 2" $ "1 $ 2" `shouldRoundtripAndParseTo` [Other "1 $ 2"] + it "1 $ 2" $ "1 $ 2" `shouldRoundtripAndParseTo` [Other "1 $ 2"] + it "a->b" $ "a->b" `shouldRoundtripAndParseTo` [Other "a->b"] + it "$a->b" $ "$a->b" `shouldRoundtripAndParseTo` [Antiquote False "a" Nothing, Other "->b"] + it "$foo:a->b" $ "$foo:a->b" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just (Fun [Con "a"] (Con "b")))] + it "$foo:unit->b" $ "$foo:unit->b" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just (Fun [Unit] (Con "b")))] + it "$foo:unit->unit" $ "$foo:unit->unit" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just (Fun [Unit] Unit))] + + h_i = 2 :: Int h_i16 = 2 :: Int16 h_i32 = 2 :: Int32 @@ -41,9 +76,19 @@ h_s = "Hello from Haskell" h_t = Text.pack h_s -spec :: Spec -spec = beforeAll_ startClr $ do +topHandler = + [csharp| + AppDomain currentDomain = default(AppDomain); + currentDomain = AppDomain.CurrentDomain; + currentDomain.UnhandledException += (sender, args) => { + Console.WriteLine(((Exception)args.ExceptionObject).GetBaseException().ToString()); + if(((Exception)args.ExceptionObject).GetBaseException().StackTrace == null) + Console.WriteLine("Stack trace is null"); + }; + |] +qqSpec :: Spec +qqSpec = beforeAll_ (startClr >> topHandler) $ do it "F# inlines pick up imports" $ [fsharp| ignore <| Dictionary() |] @@ -99,6 +144,9 @@ it "F# handles two antiquotations" $ [fsharp|bool{$h_i32:int32 + $h_i:int = 4}|] `shouldReturn` True + it "Types are optional in repeated occurrences of an antiquotation" $ + [fsharp|bool{$h_i32:int32 = $h_i32}|] `shouldReturn` True + it "F# tuples are handled correctly" $ do tuple <- [fsharp| int*bool{8,true}|] [fsharp| bool{snd $tuple:int*bool}|] `shouldReturn` True @@ -148,6 +196,34 @@ return a; }|] [csharp|int{return ($i_array:int[])[2];}|] `shouldReturn` 2 + + it "F# lambdas over struct types are handled" $ do + let addOneDay (x :: DateTime) = + [fsharp| System.DateTime{ ($x:System.DateTime).AddDays(1.0)}|] + [fsharp| int{ + let d = ($addOneDay:System.DateTime->System.DateTime) (DateTime(2017,1,1)) in d.Day + }|] `shouldReturn` 2 + + it "F# lambdas over value types are handled" $ do + let addOne x = x + 1 + [fsharp| int{ ($addOne:int->int) 1}|] `shouldReturn` 2 + + it "F# lambdas over strings are handled" $ do + let addOne x = x ++ "1" + [fsharp| string{ + match box ($addOne:string->string) with + | null -> "null" + | :? (string->string) as f -> f "success" + | other -> other.GetType().ToString() + }|] `shouldReturn` "success1" + + it "Unit lambdas from monadic actions" $ do + let action :: IO String = return "hello" + [fsharp| string{ $action:unit->string ()}|] `shouldReturn` "hello" + + it "Unit unit lambdas" $ do + let action :: IO () = return () + [fsharp| void{ $action:unit->unit ()} |] `shouldReturn` () gcUntil cond = do let loop 10 = error "gc: tried too many times"