cinvoke-0.1: examples/CCall.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-
:a libx /usr/lib/libX11.so
display = i libx:XOpenDisplay ":0"
i libx:XDisplayWidth display 0
i libx:XDisplayHeight display 0
i libx:XCloseDisplay display
-}
module Main where
import Control.Arrow
import Control.Applicative hiding (Alternative(..), many)
import Control.Monad.State.Strict
import Control.Exception hiding (try)
import qualified Control.Exception as Exc
import Control.Concurrent (threadDelay)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.List
import Data.Int
import Data.Word
import Data.Char
import Text.ParserCombinators.Parsec
import System.Console.Haskeline
import System.Directory
import System.IO
import System.Mem (performGC)
import Foreign.C.Types
import Foreign.Ptr
import Foreign.CInvoke
import Prelude hiding (catch)
pRead :: Read a => CharParser st a
pRead = do
s <- getInput
case reads s of
[] -> fail "no reads result"
[(a, s')] -> setInput s' >> return a
_ -> fail "ambiguous reads result"
strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace
data Val = I CInt
| IL CLong
| I8 Int8
| I16 Int16
| I32 Int32
| I64 Int64
| U CUInt
| UL CULong
| U8 Word8
| U16 Word16
| U32 Word32
| U64 Word64
| Z CSize
| F CFloat
| D CDouble
| P (Ptr ())
| S String
deriving (Eq, Show)
valToArg val = case val of
I x -> argCInt x
IL x -> argCLong x
I8 x -> argInt8 x
I16 x -> argInt16 x
I32 x -> argInt32 x
I64 x -> argInt64 x
U x -> argCUInt x
UL x -> argCULong x
U8 x -> argWord8 x
U16 x -> argWord16 x
U32 x -> argWord32 x
U64 x -> argWord64 x
Z x -> argCSize x
F x -> argCFloat x
D x -> argCDouble x
P x -> argPtr x
S x -> argString x
pIdent :: CharParser st String
pIdent = liftM2 (:) (char '_' <|> letter) (many $ char '_' <|> alphaNum) <?> "identifier"
pArg :: CharParser Env Val
pArg = liftM S pRead
<|> do
i <- pRead :: CharParser st Integer
t <- many alphaNum
case t of
"" -> return $ I $ fromIntegral i
"i" -> return $ I $ fromIntegral i
"l" -> return $ IL $ fromIntegral i
"i8" -> return $ I8 $ fromIntegral i
"i16" -> return $ I16 $ fromIntegral i
"i32" -> return $ I32 $ fromIntegral i
"i64" -> return $ I64 $ fromIntegral i
"u" -> return $ U $ fromIntegral i
"ul" -> return $ UL $ fromIntegral i
"u8" -> return $ U8 $ fromIntegral i
"u16" -> return $ U16 $ fromIntegral i
"u32" -> return $ U32 $ fromIntegral i
"u64" -> return $ U64 $ fromIntegral i
"p" -> return $ P $ plusPtr nullPtr $ fromIntegral i
"z" -> return $ Z $ fromIntegral i
_ -> fail "invalid type"
<|> do
x <- pRead :: CharParser st Double
t <- many alphaNum
case t of
"" -> return $ D $ realToFrac x
"f" -> return $ F $ realToFrac x
_ -> fail "invalid type"
<|> do
ident <- pIdent
(env, _) <- getState
case Map.lookup ident env of
Nothing -> fail "no such identifier"
Just v -> return v
pRet :: CharParser st (Maybe (RetType Val))
pRet = do
t <- many1 alphaNum
case t of
"v" -> return Nothing
"i" -> return $ Just $ fmap I retCInt
"l" -> return $ Just $ fmap IL retCLong
"i8" -> return $ Just $ fmap I8 retInt8
"i16" -> return $ Just $ fmap I16 retInt16
"i32" -> return $ Just $ fmap I32 retInt32
"i64" -> return $ Just $ fmap I64 retInt64
"u" -> return $ Just $ fmap U retCUInt
"ul" -> return $ Just $ fmap UL retCULong
"u8" -> return $ Just $ fmap U8 retWord8
"u16" -> return $ Just $ fmap U16 retWord16
"u32" -> return $ Just $ fmap U32 retWord32
"u64" -> return $ Just $ fmap U64 retWord64
"p" -> return $ Just $ fmap P (retPtr retVoid)
"z" -> return $ Just $ fmap Z retCSize
"f" -> return $ Just $ fmap F retCFloat
"d" -> return $ Just $ fmap D retCDouble
"s" -> return $ Just $ fmap S retString
_ -> fail "invalid type"
type EnvVal = Map String Val
type EnvLib = Map String (FilePath, Library)
type Env = (EnvVal, EnvLib)
pFun = do
libName <- pIdent
char ':'
sym <- pIdent
return (libName, sym)
pCall :: CharParser Env ((String, String), RetType (Maybe (Bool, String, Val)), [Val])
pCall = do
mbAssign <- optionMaybe $ try $ pIdent <* (spaces >> char '=' >> spaces)
mbRet <- pRet
space
fun <- pFun
vals <- many (space >> pArg)
case (mbAssign, mbRet) of
(Just ident, Just retType) -> return (fun, Just . (,,) False ident <$> retType, vals)
(Nothing , Just retType) -> return (fun, Just . (,,) True "it" <$> retType, vals)
(Nothing , Nothing ) -> return (fun, const Nothing <$> retVoid, vals)
(Just ident, Nothing) -> fail "cannot assign void"
repl env libs context = do
s <- fromMaybe ":q" <$> getInputLine "> "
case s of
_ | all isSpace s -> repl env libs context
":c" -> outputStrLn (show context) >> repl env libs context
':':'f':' ':s -> case runParser (spaces >> pFun) (env, libs) "repl" s of
Left err -> outputStrLn (show err) >> repl env libs context
Right (libName, sym) -> do
lib <- case Map.lookup libName libs of
Nothing -> outputStrLn "No such library"
Just (_, lib) -> do
liftIO $ (loadSymbol lib sym >>= print)
`Exc.catch` (\(e :: FFIException) -> print e)
repl env libs context
":q" -> liftIO (performGC >> threadDelay (10^5)) >> return ()
":p" -> do
forM_ (Map.toList env) $ \(ident, val) -> outputStrLn $ ident ++ " = " ++ show val
repl env libs context
":l" -> do
forM_ (Map.toList libs) $ \(name, (path,lib)) -> do
outputStrLn $ name ++ ": " ++ path ++ " (" ++ show lib ++ ")"
repl env libs context
':':'a':' ':s -> do
let (name, path) = second (drop 1) $ break isSpace $ strip s
eiLib <- liftIO (Exc.try $ loadLibrary context path :: IO (Either FFIException Library))
case eiLib of
Left e -> outputStrLn (show e) >> repl env libs context
Right lib -> repl env (Map.insert name (path, lib) libs) context
':':'u':' ':s -> do
repl env (Map.delete (strip s) libs) context
":gc" -> liftIO performGC >> repl env libs context
_ -> do
case words s of
[ident] -> do
case Map.lookup ident env of
Nothing -> outputStrLn $ "No such identifier: " ++ show ident
Just val -> outputStrLn $ show val
repl env libs context
_ -> case runParser pCall (env, libs) "repl" s of
Left err-> outputStrLn (show err) >> repl env libs context
Right ((libName, sym), retType, vals)
-> case Map.lookup libName libs of
Nothing -> outputStrLn "no such library" >> repl env libs context
Just (_, lib) -> do
eiFun <- liftIO (Exc.try $ loadSymbol lib sym :: IO (Either FFIException Symbol))
case eiFun of
Left e -> outputStrLn (show e) >> repl env libs context
Right fun -> do
mbVal <- liftIO $ cinvoke fun retType $ map valToArg vals
case mbVal of
Nothing -> repl env libs context
Just (wantShow, ident, val) -> do
when wantShow
$ outputStrLn $ show val
repl (Map.insert ident val env) libs context
main = do
cxt <- newContext
appDir <- getAppUserDataDirectory "CCall"
let settings = defaultSettings{historyFile = Just $ appDir ++ "_history"}
runInputT settings $ repl Map.empty Map.empty cxt