{-# 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