{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MonoLocalBinds #-}
module Language.C.Inline.Internal
(
setContext
, getContext
, Substitutions(..)
, substitute
, getHaskellType
, emitVerbatim
, Code(..)
, inlineCode
, inlineExp
, inlineItems
, SomeEq
, toSomeEq
, fromSomeEq
, ParameterType(..)
, ParseTypedC(..)
, parseTypedC
, runParserInQ
, splitTypedC
, genericQuote
, funPtrQuote
) where
import Control.Applicative
import Control.Monad (forM, void, msum)
import Control.Monad.State (evalStateT, StateT, get, put)
import Control.Monad.Trans.Class (lift)
import Data.Foldable (forM_)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Traversable (for)
import Data.Typeable (Typeable, cast)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as TH
import qualified Language.Haskell.TH.Syntax as TH
import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Pos as Parsec
import qualified Text.Parser.Char as Parser
import qualified Text.Parser.Combinators as Parser
import qualified Text.Parser.LookAhead as Parser
import qualified Text.Parser.Token as Parser
import Text.PrettyPrint.ANSI.Leijen ((<+>))
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import qualified Data.List as L
import qualified Data.Char as C
import Data.Hashable (Hashable)
import Foreign.Ptr (FunPtr)
import qualified Data.Map as M
#define USE_GETQ (__GLASGOW_HASKELL__ > 710 || (__GLASGOW_HASKELL__ == 710 && __GLASGOW_HASKELL_PATCHLEVEL1__ >= 3))
#if !USE_GETQ
import Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, readMVar)
#endif
import Language.C.Inline.Context
import Language.C.Inline.FunPtr
import Language.C.Inline.HaskellIdentifier
import qualified Language.C.Types as C
data ModuleState = ModuleState
{ ModuleState -> Context
msContext :: Context
, ModuleState -> Int
msGeneratedNames :: Int
, ModuleState -> [[Char]]
msFileChunks :: [String]
} deriving (Typeable)
getModuleState :: TH.Q (Maybe ModuleState)
putModuleState :: ModuleState -> TH.Q ()
#if USE_GETQ
getModuleState :: Q (Maybe ModuleState)
getModuleState = forall a. Typeable a => Q (Maybe a)
TH.getQ
putModuleState :: ModuleState -> Q ()
putModuleState = forall a. Typeable a => a -> Q ()
TH.putQ
#else
type ModuleId = String
getModuleId :: TH.Q ModuleId
getModuleId = TH.loc_filename <$> TH.location
{-# NOINLINE moduleStatesVar #-}
moduleStatesVar :: MVar (Map.Map ModuleId ModuleState)
moduleStatesVar = unsafePerformIO $ newMVar Map.empty
getModuleState = do
moduleStates <- TH.runIO (readMVar moduleStatesVar)
moduleId <- getModuleId
return (Map.lookup moduleId moduleStates)
putModuleState ms = do
moduleId <- getModuleId
TH.runIO (modifyMVar_ moduleStatesVar (return . Map.insert moduleId ms))
#endif
initialiseModuleState
:: Maybe Context
-> TH.Q Context
initialiseModuleState :: Maybe Context -> Q Context
initialiseModuleState Maybe Context
mbContext = do
Maybe ModuleState
mbModuleState <- Q (Maybe ModuleState)
getModuleState
case Maybe ModuleState
mbModuleState of
Just ModuleState
moduleState -> forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleState -> Context
msContext ModuleState
moduleState)
Maybe ModuleState
Nothing -> do
Q () -> Q ()
TH.addModFinalizer forall a b. (a -> b) -> a -> b
$ do
Maybe ModuleState
mbMs <- Q (Maybe ModuleState)
getModuleState
ModuleState
ms <- case Maybe ModuleState
mbMs of
Maybe ModuleState
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: ModuleState not present (initialiseModuleState)"
Just ModuleState
ms -> forall (m :: * -> *) a. Monad m => a -> m a
return ModuleState
ms
let lang :: ForeignSrcLang
lang = forall a. a -> Maybe a -> a
fromMaybe ForeignSrcLang
TH.LangC (Context -> Maybe ForeignSrcLang
ctxForeignSrcLang Context
context)
#if MIN_VERSION_base(4,12,0)
ForeignSrcLang -> [Char] -> Q ()
TH.addForeignSource ForeignSrcLang
lang (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. [a] -> [a]
reverse (ModuleState -> [[Char]]
msFileChunks ModuleState
ms)))
#else
TH.addForeignFile lang (concat (reverse (msFileChunks ms)))
#endif
let moduleState :: ModuleState
moduleState = ModuleState
{ msContext :: Context
msContext = Context
context
, msGeneratedNames :: Int
msGeneratedNames = Int
0
, msFileChunks :: [[Char]]
msFileChunks = forall a. Monoid a => a
mempty
}
ModuleState -> Q ()
putModuleState ModuleState
moduleState
forall (m :: * -> *) a. Monad m => a -> m a
return Context
context
where
context :: Context
context = forall a. a -> Maybe a -> a
fromMaybe Context
baseCtx Maybe Context
mbContext
getContext :: TH.Q Context
getContext :: Q Context
getContext = Maybe Context -> Q Context
initialiseModuleState forall a. Maybe a
Nothing
modifyModuleState :: (ModuleState -> (ModuleState, a)) -> TH.Q a
modifyModuleState :: forall a. (ModuleState -> (ModuleState, a)) -> Q a
modifyModuleState ModuleState -> (ModuleState, a)
f = do
Maybe ModuleState
mbModuleState <- Q (Maybe ModuleState)
getModuleState
case Maybe ModuleState
mbModuleState of
Maybe ModuleState
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: ModuleState not present (modifyModuleState)"
Just ModuleState
ms -> do
let (ModuleState
ms', a
x) = ModuleState -> (ModuleState, a)
f ModuleState
ms
ModuleState -> Q ()
putModuleState ModuleState
ms'
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
setContext :: Context -> TH.Q ()
setContext :: Context -> Q ()
setContext Context
ctx = do
Maybe ModuleState
mbModuleState <- Q (Maybe ModuleState)
getModuleState
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ModuleState
mbModuleState forall a b. (a -> b) -> a -> b
$ \ModuleState
_ms ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: The module has already been initialised (setContext)."
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Maybe Context -> Q Context
initialiseModuleState forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Context
ctx
bumpGeneratedNames :: TH.Q Int
bumpGeneratedNames :: Q Int
bumpGeneratedNames = do
forall a. (ModuleState -> (ModuleState, a)) -> Q a
modifyModuleState forall a b. (a -> b) -> a -> b
$ \ModuleState
ms ->
let c' :: Int
c' = ModuleState -> Int
msGeneratedNames ModuleState
ms
in (ModuleState
ms{msGeneratedNames :: Int
msGeneratedNames = Int
c' forall a. Num a => a -> a -> a
+ Int
1}, Int
c')
emitVerbatim :: String -> TH.DecsQ
emitVerbatim :: [Char] -> DecsQ
emitVerbatim [Char]
s = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe Context -> Q Context
initialiseModuleState forall a. Maybe a
Nothing)
let chunk :: [Char]
chunk = [Char]
"\n" forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
forall a. (ModuleState -> (ModuleState, a)) -> Q a
modifyModuleState forall a b. (a -> b) -> a -> b
$ \ModuleState
ms ->
(ModuleState
ms{msFileChunks :: [[Char]]
msFileChunks = [Char]
chunk forall a. a -> [a] -> [a]
: ModuleState -> [[Char]]
msFileChunks ModuleState
ms}, ())
forall (m :: * -> *) a. Monad m => a -> m a
return []
data Code = Code
{ Code -> Safety
codeCallSafety :: TH.Safety
, Code -> Maybe Loc
codeLoc :: Maybe TH.Loc
, Code -> TypeQ
codeType :: TH.TypeQ
, Code -> [Char]
codeFunName :: String
, Code -> [Char]
codeDefs :: String
, Code -> Bool
codeFunPtr :: Bool
}
inlineCode :: Code -> TH.ExpQ
inlineCode :: Code -> ExpQ
inlineCode Code{Bool
[Char]
Maybe Loc
TypeQ
Safety
codeFunPtr :: Bool
codeDefs :: [Char]
codeFunName :: [Char]
codeType :: TypeQ
codeLoc :: Maybe Loc
codeCallSafety :: Safety
codeFunPtr :: Code -> Bool
codeDefs :: Code -> [Char]
codeFunName :: Code -> [Char]
codeType :: Code -> TypeQ
codeLoc :: Code -> Maybe Loc
codeCallSafety :: Code -> Safety
..} = do
Context
ctx <- Q Context
getContext
let out :: [Char] -> [Char]
out = forall a. a -> Maybe a -> a
fromMaybe forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Context -> Maybe ([Char] -> [Char])
ctxOutput Context
ctx
let directive :: [Char]
directive = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\Loc
l -> [Char]
"#line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Loc -> CharPos
TH.loc_start Loc
l) forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Loc -> [Char]
TH.loc_filename Loc
l ) forall a. [a] -> [a] -> [a]
++ [Char]
"\n") Maybe Loc
codeLoc
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ [Char] -> DecsQ
emitVerbatim forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
out forall a b. (a -> b) -> a -> b
$ [Char]
directive forall a. [a] -> [a] -> [a]
++ [Char]
codeDefs
Name
ffiImportName <- Q Name
uniqueFfiImportName
Dec
dec <- if Bool
codeFunPtr
then
forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> [Char] -> Name -> m Type -> m Dec
TH.forImpD Callconv
TH.CCall Safety
codeCallSafety ([Char]
"&" forall a. [a] -> [a] -> [a]
++ [Char]
codeFunName) Name
ffiImportName [t| FunPtr $(codeType) |]
else forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> [Char] -> Name -> m Type -> m Dec
TH.forImpD Callconv
TH.CCall Safety
codeCallSafety [Char]
codeFunName Name
ffiImportName TypeQ
codeType
[Dec] -> Q ()
TH.addTopDecls [Dec
dec]
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
ffiImportName
uniqueCName :: Maybe String -> TH.Q String
uniqueCName :: Maybe [Char] -> Q [Char]
uniqueCName Maybe [Char]
mbPostfix = do
Int
c' <- Q Int
bumpGeneratedNames
[Char]
module_ <- Loc -> [Char]
TH.loc_module forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
TH.location
let replaceDot :: Char -> Char
replaceDot Char
'.' = Char
'_'
replaceDot Char
c = Char
c
let postfix :: [Char]
postfix = case Maybe [Char]
mbPostfix of
Maybe [Char]
Nothing -> [Char]
""
Just [Char]
s -> [Char]
"_" forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
"_"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
"inline_c_" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replaceDot [Char]
module_ forall a. [a] -> [a] -> [a]
++ [Char]
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
c' forall a. [a] -> [a] -> [a]
++ [Char]
postfix
inlineExp
:: TH.Safety
-> TH.Loc
-> TH.TypeQ
-> C.Type C.CIdentifier
-> [(C.CIdentifier, C.Type C.CIdentifier)]
-> String
-> TH.ExpQ
inlineExp :: Safety
-> Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
inlineExp Safety
callSafety Loc
loc TypeQ
type_ Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier)]
cParams [Char]
cExp =
Safety
-> Bool
-> Maybe [Char]
-> Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
inlineItems Safety
callSafety Bool
False forall a. Maybe a
Nothing Loc
loc TypeQ
type_ Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier)]
cParams [Char]
cItems
where
cItems :: [Char]
cItems = case Type CIdentifier
cRetType of
C.TypeSpecifier Specifiers
_quals TypeSpecifier
C.Void -> [Char]
cExp forall a. [a] -> [a] -> [a]
++ [Char]
";"
Type CIdentifier
_ -> [Char]
"return (" forall a. [a] -> [a] -> [a]
++ [Char]
cExp forall a. [a] -> [a] -> [a]
++ [Char]
");"
inlineItems
:: TH.Safety
-> Bool
-> Maybe String
-> TH.Loc
-> TH.TypeQ
-> C.Type C.CIdentifier
-> [(C.CIdentifier, C.Type C.CIdentifier)]
-> String
-> TH.ExpQ
inlineItems :: Safety
-> Bool
-> Maybe [Char]
-> Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
inlineItems Safety
callSafety Bool
funPtr Maybe [Char]
mbPostfix Loc
loc TypeQ
type_ Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier)]
cParams [Char]
cItems = do
let mkParam :: (i, Type i) -> ParameterDeclaration i
mkParam (i
id', Type i
paramTy) = forall i. Maybe i -> Type i -> ParameterDeclaration i
C.ParameterDeclaration (forall a. a -> Maybe a
Just i
id') Type i
paramTy
let proto :: Type CIdentifier
proto = forall i. Type i -> [ParameterDeclaration i] -> Type i
C.Proto Type CIdentifier
cRetType (forall a b. (a -> b) -> [a] -> [b]
map forall {i}. (i, Type i) -> ParameterDeclaration i
mkParam [(CIdentifier, Type CIdentifier)]
cParams)
Context
ctx <- Q Context
getContext
[Char]
funName <- Maybe [Char] -> Q [Char]
uniqueCName Maybe [Char]
mbPostfix
CIdentifier
cFunName <- case Bool -> [Char] -> Either [Char] CIdentifier
C.cIdentifierFromString (Context -> Bool
ctxEnableCpp Context
ctx) [Char]
funName of
Left [Char]
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"inlineItems: impossible, generated bad C identifier " forall a. [a] -> [a] -> [a]
++
[Char]
"funName:\n" forall a. [a] -> [a] -> [a]
++ [Char]
err
Right CIdentifier
x -> forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
x
let decl :: ParameterDeclaration CIdentifier
decl = forall i. Maybe i -> Type i -> ParameterDeclaration i
C.ParameterDeclaration (forall a. a -> Maybe a
Just CIdentifier
cFunName) Type CIdentifier
proto
let defs :: [Char]
defs = forall a. Pretty a => a -> [Char]
prettyOneLine ParameterDeclaration CIdentifier
decl forall a. [a] -> [a] -> [a]
++ [Char]
" { " forall a. [a] -> [a] -> [a]
++ [Char]
cItems forall a. [a] -> [a] -> [a]
++ [Char]
" }\n"
Code -> ExpQ
inlineCode forall a b. (a -> b) -> a -> b
$ Code
{ codeCallSafety :: Safety
codeCallSafety = Safety
callSafety
, codeLoc :: Maybe Loc
codeLoc = forall a. a -> Maybe a
Just Loc
loc
, codeType :: TypeQ
codeType = TypeQ
type_
, codeFunName :: [Char]
codeFunName = [Char]
funName
, codeDefs :: [Char]
codeDefs = [Char]
defs
, codeFunPtr :: Bool
codeFunPtr = Bool
funPtr
}
runParserInQ
:: (Hashable ident)
=> String
-> C.CParserContext ident
-> (forall m. C.CParser ident m => m a) -> TH.Q a
runParserInQ :: forall ident a.
Hashable ident =>
[Char]
-> CParserContext ident
-> (forall (m :: * -> *). CParser ident m => m a)
-> Q a
runParserInQ [Char]
s CParserContext ident
ctx forall (m :: * -> *). CParser ident m => m a
p = do
Loc
loc <- Q Loc
TH.location
let (Int
line, Int
col) = Loc -> CharPos
TH.loc_start Loc
loc
let parsecLoc :: SourcePos
parsecLoc = [Char] -> Int -> Int -> SourcePos
Parsec.newPos (Loc -> [Char]
TH.loc_filename Loc
loc) Int
line Int
col
let p' :: ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
p' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) s u. Monad m => SourcePos -> ParsecT s u m ()
Parsec.setPosition SourcePos
parsecLoc) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CParser ident m => m a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Parsing m => m ()
Parser.eof
case forall s i a.
Stream s Identity Char =>
CParserContext i
-> [Char]
-> s
-> ReaderT (CParserContext i) (Parsec s ()) a
-> Either ParseError a
C.runCParser CParserContext ident
ctx (Loc -> [Char]
TH.loc_filename Loc
loc) [Char]
s ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
p' of
Left ParseError
err -> do
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show ParseError
err
Right a
res -> do
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
data SomeEq = forall a. (Typeable a, Eq a) => SomeEq a
instance Eq SomeEq where
SomeEq a
x == :: SomeEq -> SomeEq -> Bool
== SomeEq a
y = case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x of
Maybe a
Nothing -> Bool
False
Just a
x' -> a
x' forall a. Eq a => a -> a -> Bool
== a
y
instance Show SomeEq where
show :: SomeEq -> [Char]
show SomeEq
_ = [Char]
"<<SomeEq>>"
toSomeEq :: (Eq a, Typeable a) => a -> SomeEq
toSomeEq :: forall a. (Eq a, Typeable a) => a -> SomeEq
toSomeEq a
x = forall a. (Typeable a, Eq a) => a -> SomeEq
SomeEq a
x
fromSomeEq :: (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq :: forall a. (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq (SomeEq a
x) = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x
data ParameterType
= Plain HaskellIdentifier
| AntiQuote AntiQuoterId SomeEq
deriving (Int -> ParameterType -> [Char] -> [Char]
[ParameterType] -> [Char] -> [Char]
ParameterType -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ParameterType] -> [Char] -> [Char]
$cshowList :: [ParameterType] -> [Char] -> [Char]
show :: ParameterType -> [Char]
$cshow :: ParameterType -> [Char]
showsPrec :: Int -> ParameterType -> [Char] -> [Char]
$cshowsPrec :: Int -> ParameterType -> [Char] -> [Char]
Show, ParameterType -> ParameterType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParameterType -> ParameterType -> Bool
$c/= :: ParameterType -> ParameterType -> Bool
== :: ParameterType -> ParameterType -> Bool
$c== :: ParameterType -> ParameterType -> Bool
Eq)
data ParseTypedC = ParseTypedC
{ ParseTypedC -> Type CIdentifier
ptcReturnType :: C.Type C.CIdentifier
, ParseTypedC -> [(CIdentifier, Type CIdentifier, ParameterType)]
ptcParameters :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)]
, ParseTypedC -> [Char]
ptcBody :: String
}
newtype Substitutions = Substitutions { Substitutions -> Map [Char] ([Char] -> [Char])
unSubstitutions :: M.Map String (String -> String) }
applySubstitutions :: String -> TH.Q String
applySubstitutions :: [Char] -> Q [Char]
applySubstitutions [Char]
str = do
Map [Char] ([Char] -> [Char])
subs <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Substitutions -> Map [Char] ([Char] -> [Char])
unSubstitutions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typeable a => Q (Maybe a)
TH.getQ
let substitution :: ParsecT [Char] () Identity [Char]
substitution = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> [(k, a)]
M.toList Map [Char] ([Char] -> [Char])
subs) forall a b. (a -> b) -> a -> b
$ \( [Char]
subName, [Char] -> [Char]
subFunc ) ->
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
Parsec.try forall a b. (a -> b) -> a -> b
$ do
[Char]
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
Parsec.string (Char
'@' forall a. a -> [a] -> [a]
: [Char]
subName forall a. [a] -> [a] -> [a]
++ [Char]
"(")
[Char]
subArg <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
Parsec.manyTill forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
Parsec.anyChar (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
Parsec.char Char
')')
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [Char]
subFunc [Char]
subArg)
let someChar :: ParsecT [Char] u Identity [Char]
someChar = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
Parsec.anyChar
case forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
Parsec.parse (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT [Char] () Identity [Char]
substitution forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {u}. ParsecT [Char] u Identity [Char]
someChar)) [Char]
"" [Char]
str of
Left ParseError
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Substitution failed (should be impossible)"
Right [[Char]]
chunks -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
chunks)
substitute :: [ ( String, String -> String ) ] -> TH.Q a -> TH.Q a
substitute :: forall a. [([Char], [Char] -> [Char])] -> Q a -> Q a
substitute [([Char], [Char] -> [Char])]
subsList Q a
cont = do
Map [Char] ([Char] -> [Char])
oldSubs <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Substitutions -> Map [Char] ([Char] -> [Char])
unSubstitutions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typeable a => Q (Maybe a)
TH.getQ
let subs :: Map [Char] ([Char] -> [Char])
subs = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [([Char], [Char] -> [Char])]
subsList
let conflicting :: Map [Char] ([Char] -> [Char])
conflicting = forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.intersection Map [Char] ([Char] -> [Char])
subs Map [Char] ([Char] -> [Char])
oldSubs
Substitutions
newSubs <-
if forall k a. Map k a -> Bool
M.null Map [Char] ([Char] -> [Char])
conflicting
then forall (m :: * -> *) a. Monad m => a -> m a
return (Map [Char] ([Char] -> [Char]) -> Substitutions
Substitutions (forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map [Char] ([Char] -> [Char])
oldSubs Map [Char] ([Char] -> [Char])
subs))
else forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Conflicting substitutions `" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall k a. Map k a -> [k]
M.keys Map [Char] ([Char] -> [Char])
conflicting) forall a. [a] -> [a] -> [a]
++ [Char]
"`")
forall a. Typeable a => a -> Q ()
TH.putQ Substitutions
newSubs forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Q a
cont forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Typeable a => a -> Q ()
TH.putQ (Map [Char] ([Char] -> [Char]) -> Substitutions
Substitutions Map [Char] ([Char] -> [Char])
oldSubs)
getHaskellType :: Bool -> String -> TH.TypeQ
getHaskellType :: Bool -> [Char] -> TypeQ
getHaskellType Bool
pureFunctions [Char]
cTypeStr = do
Context
ctx <- Q Context
getContext
let cParseCtx :: CParserContext CIdentifier
cParseCtx = Bool -> TypeNames -> CParserContext CIdentifier
C.cCParserContext (Context -> Bool
ctxEnableCpp Context
ctx) (TypesTable -> TypeNames
typeNamesFromTypesTable (Context -> TypesTable
ctxTypesTable Context
ctx))
Type CIdentifier
cType <- forall ident a.
Hashable ident =>
[Char]
-> CParserContext ident
-> (forall (m :: * -> *). CParser ident m => m a)
-> Q a
runParserInQ [Char]
cTypeStr CParserContext CIdentifier
cParseCtx forall i (m :: * -> *). (CParser i m, Pretty i) => m (Type i)
C.parseType
Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx (if Bool
pureFunctions then Purity
Pure else Purity
IO) Type CIdentifier
cType
parseTypedC
:: forall m. C.CParser HaskellIdentifier m
=> Bool -> AntiQuoters -> m ParseTypedC
parseTypedC :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
Bool -> AntiQuoters -> m ParseTypedC
parseTypedC Bool
useCpp AntiQuoters
antiQs = do
forall (m :: * -> *). CharParsing m => m ()
Parser.spaces
Type CIdentifier
cRetType <- forall (n :: * -> *).
MonadFail n =>
Type HaskellIdentifier -> n (Type CIdentifier)
purgeHaskellIdentifiers forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall i (m :: * -> *). (CParser i m, Pretty i) => m (Type i)
C.parseType
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'{'
([(CIdentifier, Type CIdentifier, ParameterType)]
cParams, [Char]
cBody) <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseBody Int
0
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type CIdentifier
-> [(CIdentifier, Type CIdentifier, ParameterType)]
-> [Char]
-> ParseTypedC
ParseTypedC Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier, ParameterType)]
cParams [Char]
cBody
where
parseBody
:: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
parseBody :: StateT
Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseBody = do
[Char]
s <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m [a]
Parser.manyTill forall (m :: * -> *). CharParsing m => m Char
Parser.anyChar forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
Parser.lookAhead (forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'$')
([(CIdentifier, Type CIdentifier, ParameterType)]
decls, [Char]
s') <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
[ do forall (m :: * -> *) a. Parsing m => m a -> m a
Parser.try forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). TokenParsing m => Char -> m Char
Parser.symbolic Char
'}'
forall (m :: * -> *). Parsing m => m ()
Parser.eof
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Char]
"")
, do forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}'
([(CIdentifier, Type CIdentifier, ParameterType)]
decls, [Char]
s') <- StateT
Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseBody
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier, Type CIdentifier, ParameterType)]
decls, [Char]
"}" forall a. [a] -> [a] -> [a]
++ [Char]
s')
, do forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'$'
([(CIdentifier, Type CIdentifier, ParameterType)]
decls1, [Char]
s1) <- forall a. StateT Int m ([a], [Char])
parseEscapedDollar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StateT
Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseAntiQuote forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StateT
Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseTypedCapture
([(CIdentifier, Type CIdentifier, ParameterType)]
decls2, [Char]
s2) <- StateT
Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseBody
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier, Type CIdentifier, ParameterType)]
decls1 forall a. [a] -> [a] -> [a]
++ [(CIdentifier, Type CIdentifier, ParameterType)]
decls2, [Char]
s1 forall a. [a] -> [a] -> [a]
++ [Char]
s2)
]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier, Type CIdentifier, ParameterType)]
decls, [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
s')
where
parseAntiQuote
:: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
parseAntiQuote :: StateT
Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseAntiQuote = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
[ do forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Parsing m => m a -> m a
Parser.try (forall (m :: * -> *). CharParsing m => [Char] -> m [Char]
Parser.string forall a b. (a -> b) -> a -> b
$ [Char]
antiQId forall a. [a] -> [a] -> [a]
++ [Char]
":") forall (m :: * -> *) a. Parsing m => m a -> [Char] -> m a
Parser.<?> [Char]
"anti quoter id"
(CIdentifier
s, Type CIdentifier
cTy, a
x) <- forall a.
AntiQuoter a
-> forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, a)
aqParser AntiQuoter a
antiQ
CIdentifier
id' <- CIdentifier -> StateT Int m CIdentifier
freshId CIdentifier
s
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier
id', Type CIdentifier
cTy, [Char] -> SomeEq -> ParameterType
AntiQuote [Char]
antiQId (forall a. (Eq a, Typeable a) => a -> SomeEq
toSomeEq a
x))], CIdentifier -> [Char]
C.unCIdentifier CIdentifier
id')
| ([Char]
antiQId, SomeAntiQuoter AntiQuoter a
antiQ) <- forall k a. Map k a -> [(k, a)]
Map.toList AntiQuoters
antiQs
]
parseEscapedDollar :: StateT Int m ([a], String)
parseEscapedDollar :: forall a. StateT Int m ([a], [Char])
parseEscapedDollar = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'$'
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Char]
"$")
parseTypedCapture
:: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
parseTypedCapture :: StateT
Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseTypedCapture = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). TokenParsing m => Char -> m Char
Parser.symbolic Char
'('
ParameterDeclaration HaskellIdentifier
decl <- forall i (m :: * -> *).
(CParser i m, Pretty i) =>
m (ParameterDeclaration i)
C.parseParameterDeclaration
Type CIdentifier
declType <- forall (n :: * -> *).
MonadFail n =>
Type HaskellIdentifier -> n (Type CIdentifier)
purgeHaskellIdentifiers forall a b. (a -> b) -> a -> b
$ forall i. ParameterDeclaration i -> Type i
C.parameterDeclarationType ParameterDeclaration HaskellIdentifier
decl
HaskellIdentifier
hId <- case forall i. ParameterDeclaration i -> Maybe i
C.parameterDeclarationId ParameterDeclaration HaskellIdentifier
decl of
Maybe HaskellIdentifier
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> [Char]
pretty80 forall a b. (a -> b) -> a -> b
$
Doc
"Un-named captured variable in decl" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
PP.pretty ParameterDeclaration HaskellIdentifier
decl
Just HaskellIdentifier
hId -> forall (m :: * -> *) a. Monad m => a -> m a
return HaskellIdentifier
hId
CIdentifier
id' <- CIdentifier -> StateT Int m CIdentifier
freshId forall a b. (a -> b) -> a -> b
$ Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
')'
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier
id', Type CIdentifier
declType, HaskellIdentifier -> ParameterType
Plain HaskellIdentifier
hId)], CIdentifier -> [Char]
C.unCIdentifier CIdentifier
id')
freshId :: CIdentifier -> StateT Int m CIdentifier
freshId CIdentifier
s = do
Int
c <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ Int
c forall a. Num a => a -> a -> a
+ Int
1
case Bool -> [Char] -> Either [Char] CIdentifier
C.cIdentifierFromString Bool
useCpp (CIdentifier -> [Char]
C.unCIdentifier CIdentifier
s forall a. [a] -> [a] -> [a]
++ [Char]
"_inline_c_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
c) of
Left [Char]
_err -> forall a. HasCallStack => [Char] -> a
error [Char]
"freshId: The impossible happened"
Right CIdentifier
x -> forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
x
purgeHaskellIdentifiers
#if MIN_VERSION_base(4,13,0)
:: forall n. MonadFail n
#else
:: forall n. (Applicative n, Monad n)
#endif
=> C.Type HaskellIdentifier -> n (C.Type C.CIdentifier)
purgeHaskellIdentifiers :: forall (n :: * -> *).
MonadFail n =>
Type HaskellIdentifier -> n (Type CIdentifier)
purgeHaskellIdentifiers Type HaskellIdentifier
cTy = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Type HaskellIdentifier
cTy forall a b. (a -> b) -> a -> b
$ \HaskellIdentifier
hsIdent -> do
let hsIdentS :: [Char]
hsIdentS = HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
hsIdent
case Bool -> [Char] -> Either [Char] CIdentifier
C.cIdentifierFromString Bool
useCpp [Char]
hsIdentS of
Left [Char]
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Haskell identifier " forall a. [a] -> [a] -> [a]
++ [Char]
hsIdentS forall a. [a] -> [a] -> [a]
++ [Char]
" in illegal position" forall a. [a] -> [a] -> [a]
++
[Char]
"in C type\n" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
pretty80 Type HaskellIdentifier
cTy forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++
[Char]
"A C identifier was expected, but:\n" forall a. [a] -> [a] -> [a]
++ [Char]
err
Right CIdentifier
cIdent -> forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
cIdent
quoteCode
:: (String -> TH.ExpQ)
-> TH.QuasiQuoter
quoteCode :: ([Char] -> ExpQ) -> QuasiQuoter
quoteCode [Char] -> ExpQ
p = TH.QuasiQuoter
{ quoteExp :: [Char] -> ExpQ
TH.quoteExp = [Char] -> ExpQ
p
, quotePat :: [Char] -> Q Pat
TH.quotePat = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: quotePat not implemented (quoteCode)"
, quoteType :: [Char] -> TypeQ
TH.quoteType = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: quoteType not implemented (quoteCode)"
, quoteDec :: [Char] -> DecsQ
TH.quoteDec = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: quoteDec not implemented (quoteCode)"
}
cToHs :: Context -> Purity -> C.Type C.CIdentifier -> TH.TypeQ
cToHs :: Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
purity Type CIdentifier
cTy = do
Maybe Type
mbHsTy <- Purity -> TypesTable -> Type CIdentifier -> Q (Maybe Type)
convertType Purity
purity (Context -> TypesTable
ctxTypesTable Context
ctx) Type CIdentifier
cTy
case Maybe Type
mbHsTy of
Maybe Type
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Could not resolve Haskell type for C type " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
pretty80 Type CIdentifier
cTy
Just Type
hsTy -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsTy
genericQuote
:: Purity
-> (TH.Loc -> TH.TypeQ -> C.Type C.CIdentifier -> [(C.CIdentifier, C.Type C.CIdentifier)] -> String -> TH.ExpQ)
-> TH.QuasiQuoter
genericQuote :: Purity
-> (Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ)
-> QuasiQuoter
genericQuote Purity
purity Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
build = ([Char] -> ExpQ) -> QuasiQuoter
quoteCode forall a b. (a -> b) -> a -> b
$ \[Char]
rawStr -> do
Context
ctx <- Q Context
getContext
Loc
here <- Q Loc
TH.location
[Char]
s <- [Char] -> Q [Char]
applySubstitutions [Char]
rawStr
ParseTypedC Type CIdentifier
cType [(CIdentifier, Type CIdentifier, ParameterType)]
cParams [Char]
cExp <-
forall ident a.
Hashable ident =>
[Char]
-> CParserContext ident
-> (forall (m :: * -> *). CParser ident m => m a)
-> Q a
runParserInQ [Char]
s
(Bool -> TypeNames -> CParserContext HaskellIdentifier
haskellCParserContext (Context -> Bool
ctxEnableCpp Context
ctx) (TypesTable -> TypeNames
typeNamesFromTypesTable (Context -> TypesTable
ctxTypesTable Context
ctx)))
(forall (m :: * -> *).
CParser HaskellIdentifier m =>
Bool -> AntiQuoters -> m ParseTypedC
parseTypedC (Context -> Bool
ctxEnableCpp Context
ctx) (Context -> AntiQuoters
ctxAntiQuoters Context
ctx))
Type
hsType <- Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
purity Type CIdentifier
cType
[(Type, Exp)]
hsParams <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(CIdentifier, Type CIdentifier, ParameterType)]
cParams forall a b. (a -> b) -> a -> b
$ \(CIdentifier
_cId, Type CIdentifier
cTy, ParameterType
parTy) -> do
case ParameterType
parTy of
Plain HaskellIdentifier
s' -> do
Type
hsTy <- Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
purity Type CIdentifier
cTy
let hsName :: Name
hsName = [Char] -> Name
TH.mkName (HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
s')
Exp
hsExp <- [| \cont -> cont ($(TH.varE hsName) :: $(return hsTy)) |]
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp)
AntiQuote [Char]
antiId SomeEq
dyn -> do
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
antiId (Context -> AntiQuoters
ctxAntiQuoters Context
ctx) of
Maybe SomeAntiQuoter
Nothing ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"IMPOSSIBLE: could not find anti-quoter " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
antiId forall a. [a] -> [a] -> [a]
++
[Char]
". (genericQuote)"
Just (SomeAntiQuoter AntiQuoter a
antiQ) -> case forall a. (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq SomeEq
dyn of
Maybe a
Nothing ->
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"IMPOSSIBLE: could not cast value for anti-quoter " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> [Char]
show [Char]
antiId forall a. [a] -> [a] -> [a]
++ [Char]
". (genericQuote)"
Just a
x ->
forall a.
AntiQuoter a
-> Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp)
aqMarshaller AntiQuoter a
antiQ Purity
purity (Context -> TypesTable
ctxTypesTable Context
ctx) Type CIdentifier
cTy a
x
let hsFunType :: TypeQ
hsFunType = Type -> [Type] -> TypeQ
convertCFunSig Type
hsType forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Type, Exp)]
hsParams
let cParams' :: [(CIdentifier, Type CIdentifier)]
cParams' = [(CIdentifier
cId, Type CIdentifier
cTy) | (CIdentifier
cId, Type CIdentifier
cTy, ParameterType
_) <- [(CIdentifier, Type CIdentifier, ParameterType)]
cParams]
Exp
ioCall <- Context -> ExpQ -> [Exp] -> [Name] -> ExpQ
buildFunCall Context
ctx (Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
build Loc
here TypeQ
hsFunType Type CIdentifier
cType [(CIdentifier, Type CIdentifier)]
cParams' [Char]
cExp) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Type, Exp)]
hsParams) []
case Purity
purity of
Purity
Pure -> [| unsafeDupablePerformIO $(return ioCall) |]
Purity
IO -> forall (m :: * -> *) a. Monad m => a -> m a
return Exp
ioCall
where
buildFunCall :: Context -> TH.ExpQ -> [TH.Exp] -> [TH.Name] -> TH.ExpQ
buildFunCall :: Context -> ExpQ -> [Exp] -> [Name] -> ExpQ
buildFunCall Context
_ctx ExpQ
f [] [Name]
args =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
f' Name
arg -> [| $f' $(TH.varE arg) |]) ExpQ
f [Name]
args
buildFunCall Context
ctx ExpQ
f (Exp
hsExp : [Exp]
params) [Name]
args =
[| $(return hsExp) $ \arg ->
$(buildFunCall ctx f params (args ++ ['arg]))
|]
convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ
convertCFunSig :: Type -> [Type] -> TypeQ
convertCFunSig Type
retType [Type]
params0 = do
[Type] -> TypeQ
go [Type]
params0
where
go :: [Type] -> TypeQ
go [] =
[t| IO $(return retType) |]
go (Type
paramType : [Type]
params) = do
[t| $(return paramType) -> $(go params) |]
splitTypedC :: String -> (String, String)
splitTypedC :: [Char] -> ([Char], [Char])
splitTypedC [Char]
s = ([Char] -> [Char]
trim [Char]
ty, case [Char]
body of
[] -> []
[Char]
r -> [Char]
r)
where ([Char]
ty, [Char]
body) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
'{') [Char]
s
trim :: [Char] -> [Char]
trim [Char]
x = forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
C.isSpace (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
C.isSpace [Char]
x)
data FunPtrDecl = FunPtrDecl
{ FunPtrDecl -> Type CIdentifier
funPtrReturnType :: C.Type C.CIdentifier
, FunPtrDecl -> [(CIdentifier, Type CIdentifier)]
funPtrParameters :: [(C.CIdentifier, C.Type C.CIdentifier)]
, FunPtrDecl -> [Char]
funPtrBody :: String
, FunPtrDecl -> Maybe [Char]
funPtrName :: Maybe String
} deriving (FunPtrDecl -> FunPtrDecl -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FunPtrDecl -> FunPtrDecl -> Bool
$c/= :: FunPtrDecl -> FunPtrDecl -> Bool
== :: FunPtrDecl -> FunPtrDecl -> Bool
$c== :: FunPtrDecl -> FunPtrDecl -> Bool
Eq, Int -> FunPtrDecl -> [Char] -> [Char]
[FunPtrDecl] -> [Char] -> [Char]
FunPtrDecl -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [FunPtrDecl] -> [Char] -> [Char]
$cshowList :: [FunPtrDecl] -> [Char] -> [Char]
show :: FunPtrDecl -> [Char]
$cshow :: FunPtrDecl -> [Char]
showsPrec :: Int -> FunPtrDecl -> [Char] -> [Char]
$cshowsPrec :: Int -> FunPtrDecl -> [Char] -> [Char]
Show)
funPtrQuote :: TH.Safety -> TH.QuasiQuoter
funPtrQuote :: Safety -> QuasiQuoter
funPtrQuote Safety
callSafety = ([Char] -> ExpQ) -> QuasiQuoter
quoteCode forall a b. (a -> b) -> a -> b
$ \[Char]
rawCode -> do
Loc
loc <- Q Loc
TH.location
Context
ctx <- Q Context
getContext
[Char]
code <- [Char] -> Q [Char]
applySubstitutions [Char]
rawCode
FunPtrDecl{[Char]
[(CIdentifier, Type CIdentifier)]
Maybe [Char]
Type CIdentifier
funPtrName :: Maybe [Char]
funPtrBody :: [Char]
funPtrParameters :: [(CIdentifier, Type CIdentifier)]
funPtrReturnType :: Type CIdentifier
funPtrName :: FunPtrDecl -> Maybe [Char]
funPtrBody :: FunPtrDecl -> [Char]
funPtrParameters :: FunPtrDecl -> [(CIdentifier, Type CIdentifier)]
funPtrReturnType :: FunPtrDecl -> Type CIdentifier
..} <- forall ident a.
Hashable ident =>
[Char]
-> CParserContext ident
-> (forall (m :: * -> *). CParser ident m => m a)
-> Q a
runParserInQ [Char]
code (Bool -> TypeNames -> CParserContext CIdentifier
C.cCParserContext (Context -> Bool
ctxEnableCpp Context
ctx) (TypesTable -> TypeNames
typeNamesFromTypesTable (Context -> TypesTable
ctxTypesTable Context
ctx))) forall (m :: * -> *). CParser CIdentifier m => m FunPtrDecl
parse
Type
hsRetType <- Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
IO Type CIdentifier
funPtrReturnType
[Type]
hsParams <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(CIdentifier, Type CIdentifier)]
funPtrParameters (\(CIdentifier
_ident, Type CIdentifier
typ_) -> Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
IO Type CIdentifier
typ_)
let hsFunType :: TypeQ
hsFunType = Type -> [Type] -> TypeQ
convertCFunSig Type
hsRetType [Type]
hsParams
Safety
-> Bool
-> Maybe [Char]
-> Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
inlineItems Safety
callSafety Bool
True Maybe [Char]
funPtrName Loc
loc TypeQ
hsFunType Type CIdentifier
funPtrReturnType [(CIdentifier, Type CIdentifier)]
funPtrParameters [Char]
funPtrBody
where
convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ
convertCFunSig :: Type -> [Type] -> TypeQ
convertCFunSig Type
retType [Type]
params0 = do
[Type] -> TypeQ
go [Type]
params0
where
go :: [Type] -> TypeQ
go [] =
[t| IO $(return retType) |]
go (Type
paramType : [Type]
params) = do
[t| $(return paramType) -> $(go params) |]
parse :: C.CParser C.CIdentifier m => m FunPtrDecl
parse :: forall (m :: * -> *). CParser CIdentifier m => m FunPtrDecl
parse = do
forall (m :: * -> *). CharParsing m => m ()
Parser.spaces
C.ParameterDeclaration Maybe CIdentifier
mbName Type CIdentifier
protoTyp <- forall i (m :: * -> *).
(CParser i m, Pretty i) =>
m (ParameterDeclaration i)
C.parseParameterDeclaration
case Type CIdentifier
protoTyp of
C.Proto Type CIdentifier
retType [ParameterDeclaration CIdentifier]
paramList -> do
[(CIdentifier, Type CIdentifier)]
args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ParameterDeclaration CIdentifier]
paramList forall a b. (a -> b) -> a -> b
$ \ParameterDeclaration CIdentifier
decl -> case forall i. ParameterDeclaration i -> Maybe i
C.parameterDeclarationId ParameterDeclaration CIdentifier
decl of
Maybe CIdentifier
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> [Char]
pretty80 forall a b. (a -> b) -> a -> b
$
Doc
"Un-named captured variable in decl" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
PP.pretty ParameterDeclaration CIdentifier
decl
Just CIdentifier
declId -> forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
declId, forall i. ParameterDeclaration i -> Type i
C.parameterDeclarationType ParameterDeclaration CIdentifier
decl)
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *). TokenParsing m => Char -> m Char
Parser.symbolic Char
'{')
[Char]
body <- forall (m :: * -> *). CParser CIdentifier m => m [Char]
parseBody
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtrDecl
{ funPtrReturnType :: Type CIdentifier
funPtrReturnType = Type CIdentifier
retType
, funPtrParameters :: [(CIdentifier, Type CIdentifier)]
funPtrParameters = [(CIdentifier, Type CIdentifier)]
args
, funPtrBody :: [Char]
funPtrBody = [Char]
body
, funPtrName :: Maybe [Char]
funPtrName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CIdentifier -> [Char]
C.unCIdentifier Maybe CIdentifier
mbName
}
Type CIdentifier
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Expecting function declaration"
parseBody :: C.CParser C.CIdentifier m => m String
parseBody :: forall (m :: * -> *). CParser CIdentifier m => m [Char]
parseBody = do
[Char]
s <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m [a]
Parser.manyTill forall (m :: * -> *). CharParsing m => m Char
Parser.anyChar forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
Parser.lookAhead (forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}')
[Char]
s' <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
[ do forall (m :: * -> *) a. Parsing m => m a -> m a
Parser.try forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). TokenParsing m => Char -> m Char
Parser.symbolic Char
'}'
forall (m :: * -> *). Parsing m => m ()
Parser.eof
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
, do forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}'
[Char]
s' <- forall (m :: * -> *). CParser CIdentifier m => m [Char]
parseBody
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"}" forall a. [a] -> [a] -> [a]
++ [Char]
s')
]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
s')
pretty80 :: PP.Pretty a => a -> String
pretty80 :: forall a. Pretty a => a -> [Char]
pretty80 a
x = SimpleDoc -> [Char] -> [Char]
PP.displayS (Float -> Int -> Doc -> SimpleDoc
PP.renderPretty Float
0.8 Int
80 (forall a. Pretty a => a -> Doc
PP.pretty a
x)) [Char]
""
prettyOneLine :: PP.Pretty a => a -> String
prettyOneLine :: forall a. Pretty a => a -> [Char]
prettyOneLine a
x = SimpleDoc -> [Char] -> [Char]
PP.displayS (Doc -> SimpleDoc
PP.renderCompact (forall a. Pretty a => a -> Doc
PP.pretty a
x)) [Char]
""