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