diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ clr-inline ============== +[![Hackage](https://img.shields.io/hackage/v/clr-inline.svg)](https://hackage.haskell.org/package/clr-inline) +[![Stackage Nightly](http://stackage.org/package/clr-inline/badge/nightly)](http://stackage.org/nightly/package/clr-inline) [![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) diff --git a/clr-inline.cabal b/clr-inline.cabal --- a/clr-inline.cabal +++ b/clr-inline.cabal @@ -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 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 @@ -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) 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 @@ -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 diff --git a/src/Clr/Inline.hs b/src/Clr/Inline.hs --- a/src/Clr/Inline.hs +++ b/src/Clr/Inline.hs @@ -20,4 +20,5 @@ import Clr.Host.BStr import Clr.Host.GCHandle import Clr.Inline.Types +import Clr.Inline.Types.Quote import Foreign diff --git a/src/Clr/Inline/IEnumerable.hs b/src/Clr/Inline/IEnumerable.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Inline/IEnumerable.hs @@ -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 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 @@ -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 <- 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,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 diff --git a/src/Clr/Inline/Types/Parse.hs b/src/Clr/Inline/Types/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Inline/Types/Parse.hs @@ -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' diff --git a/src/Clr/Inline/Types/Quote.hs b/src/Clr/Inline/Types/Quote.hs new file mode 100644 --- /dev/null +++ b/src/Clr/Inline/Types/Quote.hs @@ -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 diff --git a/src/Clr/Inline/Utils/Parse.hs b/src/Clr/Inline/Utils/Parse.hs deleted file mode 100644 --- a/src/Clr/Inline/Utils/Parse.hs +++ /dev/null @@ -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' diff --git a/test/InlineSpec.hs b/test/InlineSpec.hs --- a/test/InlineSpec.hs +++ b/test/InlineSpec.hs @@ -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 diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/ParseSpec.hs @@ -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" $ "$foo:IEnumerable" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just $ TyCon "IEnumerable" [Con "int"])] + it "$foo:Map" $ "$foo:Map" `shouldRoundtripAndParseTo` [Antiquote False "foo" (Just $ TyCon "Map" [Con "int", Con "bool"])] + it "$foo:IEnumerable[]" $ "$foo:IEnumerable[]"`shouldRoundtripAndParseTo` [Antiquote False "foo" (Just $ Array 1 $ TyCon "IEnumerable" [Con "int"])] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,1 @@ - -import qualified InlineSpec -import Test.Hspec - -main :: IO () -main = hspec InlineSpec.spec +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}