clr-inline 0.1.0.0 → 0.2.0
raw patch · 14 files changed
+551/−178 lines, 14 filesdep +case-insensitivedep +parsecdep +splitdep ~basesetup-changed
Dependencies added: case-insensitive, parsec, split
Dependency ranges changed: base
Files
- CHANGELOG.md +4/−1
- README.md +10/−2
- Setup.hs +1/−18
- bench/Main.hs +3/−1
- clr-inline.cabal +133/−62
- src/Clr/CSharp/Inline.hs +6/−1
- src/Clr/FSharp/Gen.hs +21/−1
- src/Clr/Inline.hs +2/−0
- src/Clr/Inline/Cabal.hs +1/−1
- src/Clr/Inline/Quoter.hs +81/−21
- src/Clr/Inline/Types.hs +77/−36
- src/Clr/Inline/Utils/Embed.hs +1/−1
- src/Clr/Inline/Utils/Parse.hs +131/−29
- test/InlineSpec.hs +80/−4
CHANGELOG.md view
@@ -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.
README.md view
@@ -3,7 +3,7 @@ [](https://gitlab.com/tim-m89/clr-haskell/commits/master) [](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
Setup.hs view
@@ -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
bench/Main.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE StaticPointers #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeInType #-}+{-# LANGUAGE DataKinds #-}+module Bench where import Clr.Inline import Criterion
clr-inline.cabal view
@@ -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
src/Clr/CSharp/Inline.hs view
@@ -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 "}"
src/Clr/FSharp/Gen.hs view
@@ -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
src/Clr/Inline.hs view
@@ -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
src/Clr/Inline/Cabal.hs view
@@ -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)
src/Clr/Inline/Quoter.hs view
@@ -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)
src/Clr/Inline/Types.hs view
@@ -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
src/Clr/Inline/Utils/Embed.hs view
@@ -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
src/Clr/Inline/Utils/Parse.hs view
@@ -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
test/InlineSpec.hs view
@@ -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<int,int>() |] @@ -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"