clr-inline 0.2.0 → 0.2.0.1
raw patch · 14 files changed
+432/−347 lines, 14 filesdep +pipesdep ~clr-host
Dependencies added: pipes
Dependency ranges changed: clr-host
Files
- README.md +2/−0
- clr-inline.cabal +14/−6
- src/Clr/CSharp/Inline.hs +1/−1
- src/Clr/FSharp/Gen.hs +3/−3
- src/Clr/Inline.hs +1/−0
- src/Clr/Inline/IEnumerable.hs +20/−0
- src/Clr/Inline/Quoter.hs +25/−12
- src/Clr/Inline/Types.hs +25/−98
- src/Clr/Inline/Types/Parse.hs +185/−0
- src/Clr/Inline/Types/Quote.hs +109/−0
- src/Clr/Inline/Utils/Parse.hs +0/−187
- test/InlineSpec.hs +3/−34
- test/ParseSpec.hs +43/−0
- test/Spec.hs +1/−6
README.md view
@@ -1,5 +1,7 @@ clr-inline ==============+[](https://hackage.haskell.org/package/clr-inline)+[](http://stackage.org/nightly/package/clr-inline) [](https://gitlab.com/tim-m89/clr-haskell/commits/master) [](https://ci.appveyor.com/project/tim-m89/clr-haskell)
clr-inline.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: clr-inline-version: 0.2.0+version: 0.2.0.1 synopsis: Quasiquoters for inline C# and F# description: Please see README.md category: Language, FFI, CLR, .NET@@ -35,7 +35,7 @@ , bytestring , Cabal , case-insensitive- , clr-host+ , clr-host >= 0.2.0.1 , clr-marshal , containers , directory@@ -44,6 +44,7 @@ , here , lens , parsec+ , pipes , process , split , template-haskell@@ -57,12 +58,14 @@ Clr.CSharp.Inline Clr.FSharp.Gen Clr.FSharp.Inline+ Clr.Inline.IEnumerable Clr.Inline.Quoter Clr.Inline.State Clr.Inline.Types+ Clr.Inline.Types.Parse+ Clr.Inline.Types.Quote Clr.Inline.Utils Clr.Inline.Utils.Embed- Clr.Inline.Utils.Parse Paths_clr_inline default-language: Haskell2010 @@ -78,7 +81,7 @@ , bytestring , Cabal , case-insensitive- , clr-host+ , clr-host >= 0.2.0.1 , clr-marshal , containers , directory@@ -87,6 +90,7 @@ , here , lens , parsec+ , pipes , process , split , template-haskell@@ -100,13 +104,16 @@ Clr.Inline Clr.Inline.Cabal Clr.Inline.Config+ Clr.Inline.IEnumerable Clr.Inline.Quoter Clr.Inline.State Clr.Inline.Types+ Clr.Inline.Types.Parse+ Clr.Inline.Types.Quote Clr.Inline.Utils Clr.Inline.Utils.Embed- Clr.Inline.Utils.Parse InlineSpec+ ParseSpec default-language: Haskell2010 benchmark benchmark@@ -121,7 +128,7 @@ , bytestring , Cabal , case-insensitive- , clr-host+ , clr-host >= 0.2.0.1 , clr-marshal , containers , directory@@ -130,6 +137,7 @@ , here , lens , parsec+ , pipes , process , split , template-haskell
src/Clr/CSharp/Inline.hs view
@@ -92,7 +92,7 @@ (intercalate ", " [ printf "%s %s" t a | (a, argDetails) <- Map.toList args , let t = case argDetails of- Value (ClrType t) -> t+ Value (ClrTypeSymbol t) -> t Delegate{} -> error "delegates not yet supported in the C# quoter." ]) yield $ printf "#line %d \"%s\"" (fst $ loc_start loc) (loc_filename loc)
src/Clr/FSharp/Gen.hs view
@@ -48,10 +48,10 @@ other -> unwords [printf "(%s:%s)" a argType | (a, argDetails) <- other , let argType = case argDetails of- Value (ClrType t) -> t+ Value (ClrTypeSymbol 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]))+ Delegate _ args Nothing -> printf "System.Action<%s>" (intercalate "," (map getClrTypeSymbol args))+ Delegate _ args (Just res) -> printf "System.Func<%s>" (intercalate "," (map getClrTypeSymbol args ++ [getClrTypeSymbol res])) ] yield $ printf "#line %d \"%s\"" (fst $ loc_start loc) (loc_filename loc) yield $ printf " static member %s %s =" (getMethodName exp) argsString
src/Clr/Inline.hs view
@@ -20,4 +20,5 @@ import Clr.Host.BStr import Clr.Host.GCHandle import Clr.Inline.Types+import Clr.Inline.Types.Quote import Foreign
+ src/Clr/Inline/IEnumerable.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+module Clr.Inline.IEnumerable where++import Clr.Inline+import Control.Monad+import Pipes++[fsharp|open System.Collections|]++toProducer :: Clr "IEnumerable" -> Producer (Clr "obj") IO ()+toProducer enumerable = do+ enumerator <- liftIO [fsharp| IEnumerator{ ($enumerable:IEnumerable).GetEnumerator() } |]+ let loop = do+ nxt <- liftIO [fsharp| bool{ ($enumerator:IEnumerator).MoveNext()} |]+ when nxt $ do+ cur <- liftIO [fsharp| obj{ ($enumerator:IEnumerator).Current } |]+ yield cur+ loop+ loop
src/Clr/Inline/Quoter.hs view
@@ -20,7 +20,8 @@ import Clr.MarshalF import Clr.Inline.State import Clr.Inline.Types-import Clr.Inline.Utils.Parse+import Clr.Inline.Types.Parse+import Clr.Inline.Types.Quote import Clr.Inline.Utils.Embed import Control.Lens import Control.Monad@@ -49,12 +50,12 @@ 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 :: ClrType -> 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)+parseArgDetails (Fun [Unit] a) = Delegate () [] (Just $ renderClrType a)+parseArgDetails (Fun args Unit) = Delegate () (map renderClrType args) Nothing+parseArgDetails (Fun args res ) = Delegate () (map renderClrType args) (Just $ renderClrType res)+parseArgDetails other = Value (renderClrType other) data ClrInlinedExpDetails (language :: Symbol) argType = ClrInlinedExpDetails { language :: Proxy language@@ -75,15 +76,27 @@ data ClrInlinedGroup language = ClrInlinedGroup { mod :: Module- , units :: [ClrInlinedUnit language ClrType]+ , units :: [ClrInlinedUnit language ClrTypeSymbol] } getNamespace :: Module -> String-getNamespace (Module (PkgName pkg) _) = printf "Clr.Inline.%s" pkg-getMethodName ClrInlinedExpDetails{..} = printf "%s_quote_%d" (symbolVal language) unitId+getNamespace (Module (PkgName pkg) _) = printf "Clr.Inline.%s" (mapMaybe escape pkg)+ where+ escape '-' = Just '_'+ escape '.' = Just '_'+ escape x+ | isAlpha x = Just x+ | otherwise = Nothing+ getMethodName :: KnownSymbol language => ClrInlinedExpDetails language a -> String+getMethodName ClrInlinedExpDetails{..} = printf "%s_quote_%d" (symbolVal language) unitId+ getClassName :: Module -> String-getClassName (Module _ (ModName n)) = n+getClassName (Module _ (ModName n)) = map escape n+ where+ escape '.' = '_'+ escape x = x+ getAssemblyName, getFullClassName :: KnownSymbol language => Proxy language -> Module -> String getAssemblyName language (Module (PkgName p) (ModName m)) = printf "%s_%s_%s" p m (symbolVal language) getFullClassName language mod =@@ -133,8 +146,8 @@ 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+ argClrTypes <- mapM (fmap getClrTypeSymbol . lookupQuotableClrType) args+ resClrType <- traverse (fmap getClrTypeSymbol . lookupQuotableClrType) res let argCount = case args of ["unit"] -> 0 ; other -> genericLength other DoE (init -> stmts) <- [| do wrapper <-
src/Clr/Inline/Types.hs view
@@ -1,45 +1,47 @@-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-} module Clr.Inline.Types ( ClrPtr(..) , Clr(..)- , ClrType(..)- , Quotable+ , ClrType(Con, Unit, ..)+ , ClrTypeSymbol(..)+ , renderClrType , TextBStr(..)- , lookupDelegateMarshalType- , lookupQuotableClrType- , lookupQuotableMarshalType- , lookupQuotableUnmarshalType ) where import Clr.Host.GCHandle import Clr.Host.BStr import Clr.Marshal import Data.Coerce-import Data.Int-import Data.Maybe-import Data.Monoid+import Data.List 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.+data ClrType = TyCon String [ClrType]+ | Fun [ClrType] ClrType+ | Array Int ClrType+ deriving (Eq, Show)++renderClrType :: ClrType -> String+renderClrType = show where+ show (Array dim x) = concat [show x, "[", replicate (pred dim) ',', "]"]+ show (TyCon con []) = con+ show (TyCon con args) = concat [con,"<",intercalate "," (map show args),">"]+ show (Fun args res) = intercalate "->" $ map show (args ++ [res])++pattern Unit :: ClrType+pattern Unit = TyCon "unit" []+pattern Con :: String -> ClrType+pattern Con x = TyCon x []++-- | A type indexed pointer to a Clr object. 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.+-- | A type indexed pointer to a Clr object with GC managed lifetime. newtype Clr (name::Symbol) = Clr (ForeignPtr Int) -- Returning from a CLR function that was called from Haskell@@ -63,84 +65,9 @@ fp <- newForeignPtr (unsafeDupablePerformIO gcHandleFinalizer) (coerce x') f $ Clr fp -newtype ClrType = ClrType {getClrType :: String} deriving Show-type MarshalType = Type+newtype ClrTypeSymbol = ClrTypeSymbol {getClrTypeSymbol :: String} deriving Show 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 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-instance Quotable "int16" "System.Int16" Int16 Int16-instance Quotable "int32" "System.Int32" Int32 Int32-instance Quotable "int64" "System.Int64" Int64 Int64-instance Quotable "long" "System.Int64" Int64 Int64-instance Quotable "uint16" "System.UInt16" Word16 Word16-instance Quotable "word16" "System.UInt16" Word16 Word16-instance Quotable "uint32" "System.UInt32" Word32 Word32-instance Quotable "word32" "System.UInt32" Word32 Word32-instance Quotable "uint64" "System.UInt64" Word64 Word64-instance Quotable "word64" "System.UInt64" Word64 Word64-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)--lookupQuotable :: Show a => ([InstanceDec] -> a) -> String -> Q a-lookupQuotable extract quote = do- let ty = LitT (StrTyLit quote)- a <- newName "clr"- b <- newName "rep"- c <- newName "haskell"- 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 extract s- where- 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 MarshalType-lookupQuotableMarshalType s = lookupQuotable extract s- where- 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--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/Types/Parse.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE LambdaCase #-}+module Clr.Inline.Types.Parse where++import Clr.Inline.Types+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)++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 {parenthised :: Bool, name:: !String, typ :: !(Maybe ClrType)}+ deriving (Eq, Show)++normalizeProgram :: [Section] -> [Section]+normalizeProgram (Other a : Other b : rest) = Other(a++b) : normalizeProgram rest+normalizeProgram (x:xx) = x : normalizeProgram xx+normalizeProgram [] = []++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 String+conP = (:) <$> satisfyChar isTypeIdent <*> many(satisfyChar isTypeIdent)+ where+ isTypeIdent x = isAlphaNum x || x `elem` ("._-*"::String)++tyconP,tyconFunP,typP :: Parser ClrType+tyconP =+ TyCon <$> conP <*>+ ( between (char '<') (char '>') (typP `sepBy` char ',')+ <|> pure [])++tyconFunP = rebuild <$> tyconP <*> optionMaybe (arrow *> tyconFunP)+ where+ rebuild :: ClrType -> Maybe ClrType -> ClrType+ rebuild con Nothing = con+ rebuild con (Just (Fun args' res)) = Fun (args' ++ [con]) res+ rebuild con (Just res) = Fun [con] res++typP = flip ($) <$> tyconFunP <*> (foldr (.) id <$> many arrayP)+ where+ arrayP = Array . succ . length <$> between (char '[') (char ']') (many (char ','))++pattern CI :: CI.FoldCase s => CI.CI s -> s+pattern CI s <- (CI.mk -> s)++-- TODO tokenizing quoted strings+tokenized :: Iso' String [Section]+tokenized = iso parse untokenize+ where+ parse x = case runParser topP () "" (tokenize x) of+ Right res -> res+ Left e -> error $ show e++ untokenize :: [Section] -> String+ untokenize [] = []+ untokenize (Other s: rest) = s ++ untokenize rest+ untokenize (Antiquote True v Nothing : rest) = '$':'(':v ++ ')':untokenize rest+ untokenize (Antiquote True v (Just t) : rest) = '$':'(':v ++ ':' : renderClrType t ++ ')':untokenize rest+ untokenize (Antiquote False v Nothing : rest) = '$' : v ++ untokenize rest+ untokenize (Antiquote False v (Just t) : rest) = '$' : v ++ ':' : renderClrType 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 ClrType, 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 )+ | Just _ <- acc ^? at v = (acc, Other (transf v))+ | otherwise = error $ "The first occurrence of an antiquote must include a type ann. (" ++ v ++ ")"++-- | Fix different systems silly line ending conventions+-- https://ghc.haskell.org/trac/ghc/ticket/11215+normaliseLineEndings :: String -> String+normaliseLineEndings [] = []+normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows+normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X+normaliseLineEndings ( c :s) = c : normaliseLineEndings s++initAndLast :: String -> Maybe (String, Char)+initAndLast = loopInitAndLast id where+ loopInitAndLast _ [ ] = Nothing+ loopInitAndLast acc [x] = Just (acc "", x)+ loopInitAndLast acc (x:xx) = loopInitAndLast (acc . (x:)) xx++-- | Parses expressions of the form "ty{e}" and returns (ty, e)+parseBody :: String -> (String, String)+parseBody e =+ case span ('{' /=) (trim e) of+ (typeString, exp') ->+ case initAndLast (drop 1 exp') of+ Just (exp,'}') -> (trim typeString, exp)+ _ -> ("void", e)++data ParseResult = ParseResult+ { body, returnType :: String+ , args :: Map String ClrType+ }++parse :: (String -> String) -> String -> ParseResult+parse transf inline = ParseResult b ret args where+ (ret, inline') = parseBody inline+ (args, b) = extractArgs transf inline'
+ src/Clr/Inline/Types/Quote.hs view
@@ -0,0 +1,109 @@++{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS -Wno-partial-type-signatures #-}+module Clr.Inline.Types.Quote+ ( Quotable+ , lookupDelegateMarshalType+ , lookupQuotableClrType+ , MarshalType+ , lookupQuotableMarshalType+ , lookupQuotableUnmarshalType+ ) where++import Clr.Host.BStr+import Clr.Marshal+import Clr.Inline.Types+import Data.Int+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import Data.Word+import GHC.TypeLits+import Language.Haskell.TH+import Text.Printf++-- | Extensible mapping between quotable CLR types and Haskell types+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+instance Quotable "int16" "System.Int16" Int16 Int16+instance Quotable "int32" "System.Int32" Int32 Int32+instance Quotable "int64" "System.Int64" Int64 Int64+instance Quotable "long" "System.Int64" Int64 Int64+instance Quotable "uint16" "System.UInt16" Word16 Word16+instance Quotable "word16" "System.UInt16" Word16 Word16+instance Quotable "uint32" "System.UInt32" Word32 Word32+instance Quotable "word32" "System.UInt32" Word32 Word32+instance Quotable "uint64" "System.UInt64" Word64 Word64+instance Quotable "word64" "System.UInt64" Word64 Word64+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)++lookupQuotable :: Show a => ([InstanceDec] -> a) -> String -> Q a+lookupQuotable extract quote = do+ let ty = LitT (StrTyLit quote)+ a <- newName "clr"+ b <- newName "rep"+ c <- newName "haskell"+ 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 :: String -> String -> _ -> _ -> [Dec] -> _+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 ClrTypeSymbol+lookupQuotableClrType s = lookupQuotable extract s+ where+ extract = extractMostSpecificInstance s "Clr" specific general+ specific _ (LitT (StrTyLit s)) _ _ = Just $ ClrTypeSymbol s+ specific _ _ _ _ = Nothing+ general quote@VarT{} clr@VarT{} _ _ | quote == clr = Just $ ClrTypeSymbol s+ general _ _ _ _ = Nothing++type MarshalType = Type++lookupQuotableMarshalType :: String -> Q MarshalType+lookupQuotableMarshalType s = lookupQuotable extract s+ where+ 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++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/Parse.hs
@@ -1,187 +0,0 @@-{-# 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)--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 {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 [Section]-tokenized = iso parse untokenize- where- parse x = case runParser topP () "" (tokenize x) of- Right res -> res- Left e -> error $ show e-- untokenize :: [Section] -> String- untokenize [] = []- untokenize (Other s: rest) = s ++ untokenize rest- 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 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 )- | Just _ <- acc ^? at v = (acc, Other (transf v))- | otherwise = error $ "The first occurrence of an antiquote must include a type ann. (" ++ v ++ ")"---- | Fix different systems silly line ending conventions--- https://ghc.haskell.org/trac/ghc/ticket/11215-normaliseLineEndings :: String -> String-normaliseLineEndings [] = []-normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows-normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X-normaliseLineEndings ( c :s) = c : normaliseLineEndings s--initAndLast :: String -> Maybe (String, Char)-initAndLast = loopInitAndLast id where- loopInitAndLast _ [ ] = Nothing- loopInitAndLast acc [x] = Just (acc "", x)- loopInitAndLast acc (x:xx) = loopInitAndLast (acc . (x:)) xx---- | Parses expressions of the form "ty{e}" and returns (ty, e)-parseBody :: String -> (String, String)-parseBody e =- case span ('{' /=) (trim e) of- (typeString, exp') ->- case initAndLast (drop 1 exp') of- Just (exp,'}') -> (trim typeString, exp)- _ -> ("void", e)--data ParseResult = ParseResult- { body, returnType :: String- , args :: Map String QuotedType- }--parse :: (String -> String) -> String -> ParseResult-parse transf inline = ParseResult b ret args where- (ret, inline') = parseBody inline- (args, b) = extractArgs transf inline'
test/InlineSpec.hs view
@@ -5,13 +5,13 @@ {-# LANGUAGE StaticPointers #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -Wno-missing-signatures #-}-module InlineSpec where+module InlineSpec (module InlineSpec) where import Control.Concurrent import Control.Monad import Control.Lens import Clr.Inline-import Clr.Inline.Utils.Parse+import Clr.Inline.Types.Parse import Data.Int import Data.String import Data.Text as Text (pack)@@ -31,38 +31,7 @@ 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))]-+spec = qqSpec h_i = 2 :: Int h_i16 = 2 :: Int16
+ test/ParseSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE PatternSynonyms #-}+module ParseSpec(spec) where++import Clr.Inline.Types+import Clr.Inline.Types.Parse+import Control.Lens+import Test.Hspec++spec :: Spec+spec = parseSpec++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:int[]" $ "$foo:int[]" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just $ Array 1 $ Con "int")]+ it "$foo:int[,]" $ "$foo:int[,]" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just $ Array 2 $ Con "int")]+ it "$foo:int[][]" $ "$foo:int[][]" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just $ Array 1 $ Array 1 $ Con "int")]+-- 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))]+ it "$foo:IEnumerable<int>" $ "$foo:IEnumerable<int>" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just $ TyCon "IEnumerable" [Con "int"])]+ it "$foo:Map<int,bool>" $ "$foo:Map<int,bool>" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just $ TyCon "Map" [Con "int", Con "bool"])]+ it "$foo:IEnumerable<int>[]" $ "$foo:IEnumerable<int>[]"`shouldRoundtripAndParseTo` [Antiquote False "foo" (Just $ Array 1 $ TyCon "IEnumerable" [Con "int"])]
test/Spec.hs view
@@ -1,6 +1,1 @@--import qualified InlineSpec-import Test.Hspec--main :: IO ()-main = hspec InlineSpec.spec+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}