module Language.C.Inline.Internal
(
setContext
, getContext
, emitVerbatim
, Code(..)
, inlineCode
, inlineExp
, inlineItems
, SomeEq
, toSomeEq
, fromSomeEq
, ParameterType(..)
, ParseTypedC(..)
, parseTypedC
, runParserInQ
, genericQuote
) where
import Control.Applicative
import Control.Exception (catch, throwIO)
import Control.Monad (forM, void, msum, unless)
import Control.Monad.State (evalStateT, StateT, get, put)
import Control.Monad.Trans.Class (lift)
import qualified Crypto.Hash as CryptoHash
import qualified Data.Binary as Binary
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.Directory (removeFile)
import System.FilePath (addExtension, dropExtension)
import System.IO.Error (isDoesNotExistError)
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 System.Environment (getProgName)
#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
{ msContext :: Context
, msGeneratedNames :: Int
} deriving (Typeable)
getModuleState :: TH.Q (Maybe ModuleState)
putModuleState :: ModuleState -> TH.Q ()
#if USE_GETQ
getModuleState = TH.getQ
putModuleState = TH.putQ
#else
type ModuleId = String
getModuleId :: TH.Q ModuleId
getModuleId = TH.loc_filename <$> TH.location
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 mbContext = do
mbcFile <- cSourceLoc context
mbModuleState <- getModuleState
case mbModuleState of
Just moduleState -> return (msContext moduleState)
Nothing -> do
TH.runIO $ forM_ mbcFile $ \cFile -> removeIfExists cFile
let moduleState = ModuleState
{ msContext = context
, msGeneratedNames = 0
}
putModuleState moduleState
return context
where
context = fromMaybe baseCtx mbContext
getContext :: TH.Q Context
getContext = initialiseModuleState Nothing
modifyModuleState :: (ModuleState -> (ModuleState, a)) -> TH.Q a
modifyModuleState f = do
mbModuleState <- getModuleState
case mbModuleState of
Nothing -> fail "inline-c: ModuleState not present"
Just ms -> do
let (ms', x) = f ms
putModuleState ms'
return x
setContext :: Context -> TH.Q ()
setContext ctx = do
mbModuleState <- getModuleState
forM_ mbModuleState $ \_ms ->
fail "inline-c: The module has already been initialised (setContext)."
void $ initialiseModuleState $ Just ctx
bumpGeneratedNames :: TH.Q Int
bumpGeneratedNames = do
modifyModuleState $ \ms ->
let c' = msGeneratedNames ms
in (ms{msGeneratedNames = c' + 1}, c')
cSourceLoc :: Context -> TH.Q (Maybe FilePath)
cSourceLoc ctx = do
prog <- TH.runIO getProgName
let emitCode = prog /= "haddock"
if not emitCode
then return Nothing
else do
thisFile <- TH.loc_filename <$> TH.location
let ext = fromMaybe "c" $ ctxFileExtension ctx
return $ Just $ dropExtension thisFile `addExtension` ext
removeIfExists :: FilePath -> IO ()
removeIfExists fileName = removeFile fileName `catch` handleExists
where
handleExists e = unless (isDoesNotExistError e) $ throwIO e
emitVerbatim :: String -> TH.DecsQ
emitVerbatim s = do
ctx <- getContext
mbCFile <- cSourceLoc ctx
case mbCFile of
Nothing -> return ()
Just cFile -> TH.runIO $ appendFile cFile $ "\n" ++ s ++ "\n"
return []
data Code = Code
{ codeCallSafety :: TH.Safety
, codeType :: TH.TypeQ
, codeFunName :: String
, codeDefs :: String
}
inlineCode :: Code -> TH.ExpQ
inlineCode Code{..} = do
ctx <- getContext
let out = fromMaybe id $ ctxOutput ctx
void $ emitVerbatim $ out codeDefs
ffiImportName <- uniqueFfiImportName
dec <- TH.forImpD TH.CCall codeCallSafety codeFunName ffiImportName codeType
TH.addTopDecls [dec]
TH.varE ffiImportName
uniqueCName
:: String
-> TH.Q String
uniqueCName x = do
c' <- bumpGeneratedNames
let unique :: CryptoHash.Digest CryptoHash.SHA1 = CryptoHash.hashlazy $ Binary.encode x
module_ <- TH.loc_module <$> TH.location
let replaceDot '.' = '_'
replaceDot c = c
return $ "inline_c_" ++ map replaceDot module_ ++ "_" ++ show c' ++ "_" ++ show unique
inlineExp
:: TH.Safety
-> TH.TypeQ
-> C.Type C.CIdentifier
-> [(C.CIdentifier, C.Type C.CIdentifier)]
-> String
-> TH.ExpQ
inlineExp callSafety type_ cRetType cParams cExp =
inlineItems callSafety type_ cRetType cParams cItems
where
cItems = case cRetType of
C.TypeSpecifier _quals C.Void -> cExp ++ ";"
_ -> "return (" ++ cExp ++ ");"
inlineItems
:: TH.Safety
-> TH.TypeQ
-> C.Type C.CIdentifier
-> [(C.CIdentifier, C.Type C.CIdentifier)]
-> String
-> TH.ExpQ
inlineItems callSafety type_ cRetType cParams cItems = do
let mkParam (id', paramTy) = C.ParameterDeclaration (Just id') paramTy
let proto = C.Proto cRetType (map mkParam cParams)
funName <- uniqueCName $ show proto ++ cItems
cFunName <- case C.cIdentifierFromString funName of
Left err -> fail $ "inlineItems: impossible, generated bad C identifier " ++
"funName:\n" ++ err
Right x -> return x
let decl = C.ParameterDeclaration (Just cFunName) proto
let defs =
prettyOneLine decl ++ " {\n" ++
cItems ++ "\n}\n"
inlineCode $ Code
{ codeCallSafety = callSafety
, codeType = type_
, codeFunName = funName
, codeDefs = defs
}
runParserInQ
:: String -> C.TypeNames -> (forall m. C.CParser HaskellIdentifier m => m a) -> TH.Q a
runParserInQ s typeNames' p = do
loc <- TH.location
let (line, col) = TH.loc_start loc
let parsecLoc = Parsec.newPos (TH.loc_filename loc) line col
let p' = lift (Parsec.setPosition parsecLoc) *> p <* lift Parser.eof
case C.runCParser (haskellCParserContext typeNames') (TH.loc_filename loc) s p' of
Left err -> do
fail $ show err
Right res -> do
return res
data SomeEq = forall a. (Typeable a, Eq a) => SomeEq a
instance Eq SomeEq where
SomeEq x == SomeEq y = case cast x of
Nothing -> False
Just x' -> x' == y
instance Show SomeEq where
show _ = "<<SomeEq>>"
toSomeEq :: (Eq a, Typeable a) => a -> SomeEq
toSomeEq x = SomeEq x
fromSomeEq :: (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq (SomeEq x) = cast x
data ParameterType
= Plain HaskellIdentifier
| AntiQuote AntiQuoterId SomeEq
deriving (Show, Eq)
data ParseTypedC = ParseTypedC
{ ptcReturnType :: C.Type C.CIdentifier
, ptcParameters :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)]
, ptcBody :: String
}
parseTypedC
:: forall m. C.CParser HaskellIdentifier m
=> AntiQuoters -> m ParseTypedC
parseTypedC antiQs = do
Parser.spaces
cRetType <- purgeHaskellIdentifiers =<< C.parseType
void $ Parser.char '{'
(cParams, cBody) <- evalStateT parseBody 0
return $ ParseTypedC cRetType cParams cBody
where
parseBody
:: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
parseBody = do
s <- Parser.manyTill Parser.anyChar $
Parser.lookAhead (Parser.char '}' <|> Parser.char '$')
(decls, s') <- msum
[ do Parser.try $ do
void $ Parser.symbolic '}'
Parser.eof
return ([], "")
, do void $ Parser.char '}'
(decls, s') <- parseBody
return (decls, "}" ++ s')
, do void $ Parser.char '$'
(decls1, s1) <- parseEscapedDollar <|> parseAntiQuote <|> parseTypedCapture
(decls2, s2) <- parseBody
return (decls1 ++ decls2, s1 ++ s2)
]
return (decls, s ++ s')
where
parseAntiQuote
:: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
parseAntiQuote = msum
[ do void $ Parser.try (Parser.string $ antiQId ++ ":") Parser.<?> "anti quoter id"
(s, cTy, x) <- aqParser antiQ
id' <- freshId s
return ([(id', cTy, AntiQuote antiQId (toSomeEq x))], C.unCIdentifier id')
| (antiQId, SomeAntiQuoter antiQ) <- Map.toList antiQs
]
parseEscapedDollar :: StateT Int m ([a], String)
parseEscapedDollar = do
void $ Parser.char '$'
return ([], "$")
parseTypedCapture
:: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
parseTypedCapture = do
void $ Parser.symbolic '('
decl <- C.parseParameterDeclaration
declType <- purgeHaskellIdentifiers $ C.parameterDeclarationType decl
hId <- case C.parameterDeclarationId decl of
Nothing -> fail $ pretty80 $
"Un-named captured variable in decl" <+> PP.pretty decl
Just hId -> return hId
id' <- freshId $ mangleHaskellIdentifier hId
void $ Parser.char ')'
return ([(id', declType, Plain hId)], C.unCIdentifier id')
freshId s = do
c <- get
put $ c + 1
case C.cIdentifierFromString (C.unCIdentifier s ++ "_inline_c_" ++ show c) of
Left _err -> error "freshId: The impossible happened"
Right x -> return x
purgeHaskellIdentifiers
:: forall n. (Applicative n, Monad n)
=> C.Type HaskellIdentifier -> n (C.Type C.CIdentifier)
purgeHaskellIdentifiers cTy = for cTy $ \hsIdent -> do
let hsIdentS = unHaskellIdentifier hsIdent
case C.cIdentifierFromString hsIdentS of
Left err -> fail $ "Haskell identifier " ++ hsIdentS ++ " in illegal position" ++
"in C type\n" ++ pretty80 cTy ++ "\n" ++
"A C identifier was expected, but:\n" ++ err
Right cIdent -> return cIdent
quoteCode
:: (String -> TH.ExpQ)
-> TH.QuasiQuoter
quoteCode p = TH.QuasiQuoter
{ TH.quoteExp = p
, TH.quotePat = fail "inline-c: quotePat not implemented (quoteCode)"
, TH.quoteType = fail "inline-c: quoteType not implemented (quoteCode)"
, TH.quoteDec = fail "inline-c: quoteDec not implemented (quoteCode)"
}
genericQuote
:: Purity
-> (TH.TypeQ -> C.Type C.CIdentifier -> [(C.CIdentifier, C.Type C.CIdentifier)] -> String -> TH.ExpQ)
-> TH.QuasiQuoter
genericQuote purity build = quoteCode $ \s -> do
ctx <- getContext
ParseTypedC cType cParams cExp <-
runParserInQ s (typeNamesFromTypesTable (ctxTypesTable ctx)) $ parseTypedC $ ctxAntiQuoters ctx
hsType <- cToHs ctx cType
hsParams <- forM cParams $ \(_cId, cTy, parTy) -> do
case parTy of
Plain s' -> do
hsTy <- cToHs ctx cTy
let hsName = TH.mkName (unHaskellIdentifier s')
hsExp <- [| \cont -> cont ($(TH.varE hsName) :: $(return hsTy)) |]
return (hsTy, hsExp)
AntiQuote antiId dyn -> do
case Map.lookup antiId (ctxAntiQuoters ctx) of
Nothing ->
fail $ "IMPOSSIBLE: could not find anti-quoter " ++ show antiId ++
". (genericQuote)"
Just (SomeAntiQuoter antiQ) -> case fromSomeEq dyn of
Nothing ->
fail $ "IMPOSSIBLE: could not cast value for anti-quoter " ++
show antiId ++ ". (genericQuote)"
Just x ->
aqMarshaller antiQ purity (ctxTypesTable ctx) cTy x
let hsFunType = convertCFunSig hsType $ map fst hsParams
let cParams' = [(cId, cTy) | (cId, cTy, _) <- cParams]
ioCall <- buildFunCall ctx (build hsFunType cType cParams' cExp) (map snd hsParams) []
case purity of
Pure -> [| unsafePerformIO $(return ioCall) |]
IO -> return ioCall
where
cToHs :: Context -> C.Type C.CIdentifier -> TH.TypeQ
cToHs ctx cTy = do
mbHsTy <- convertType purity (ctxTypesTable ctx) cTy
case mbHsTy of
Nothing -> fail $ "Could not resolve Haskell type for C type " ++ pretty80 cTy
Just hsTy -> return hsTy
buildFunCall :: Context -> TH.ExpQ -> [TH.Exp] -> [TH.Name] -> TH.ExpQ
buildFunCall _ctx f [] args =
foldl (\f' arg -> [| $f' $(TH.varE arg) |]) f args
buildFunCall ctx f (hsExp : params) args =
[| $(return hsExp) $ \arg ->
$(buildFunCall ctx f params (args ++ ['arg]))
|]
convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ
convertCFunSig retType params0 = do
go params0
where
go [] =
[t| IO $(return retType) |]
go (paramType : params) = do
[t| $(return paramType) -> $(go params) |]
pretty80 :: PP.Pretty a => a -> String
pretty80 x = PP.displayS (PP.renderPretty 0.8 80 (PP.pretty x)) ""
prettyOneLine :: PP.Pretty a => a -> String
prettyOneLine x = PP.displayS (PP.renderCompact (PP.pretty x)) ""