838f8c0aca
- Adapted the package to work with GHC 6.12 - Plugins that depend on the old base3 are currently not correctly loaded as the plugin loaded misses the dependence on syb (leading to unresolved symbols) - Cleaned up most of the testsuite (there are still some outstanding failures, of which only one demonstrates a bug in the plugins library as far as I can see — see previous bullet point) - Cleaned out a little cruft (but more could be done)
313 lines
11 KiB
Haskell
313 lines
11 KiB
Haskell
--
|
|
-- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons
|
|
--
|
|
-- This library is free software; you can redistribute it and/or
|
|
-- modify it under the terms of the GNU Lesser General Public
|
|
-- License as published by the Free Software Foundation; either
|
|
-- version 2.1 of the License, or (at your option) any later version.
|
|
--
|
|
-- This library is distributed in the hope that it will be useful,
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
-- Lesser General Public License for more details.
|
|
--
|
|
-- You should have received a copy of the GNU Lesser General Public
|
|
-- License along with this library; if not, write to the Free Software
|
|
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
|
|
-- USA
|
|
--
|
|
|
|
--
|
|
-- | Evaluate Haskell at runtime, using runtime compilation and dynamic
|
|
-- loading. Arguments are compiled to native code, and dynamically
|
|
-- loaded, returning a Haskell value representing the compiled argument.
|
|
-- The underlying implementation treats 'String' arguments as the source
|
|
-- for plugins to be compiled at runtime.
|
|
--
|
|
|
|
module System.Eval.Haskell (
|
|
eval,
|
|
eval_,
|
|
unsafeEval,
|
|
unsafeEval_,
|
|
typeOf,
|
|
mkHsValues,
|
|
|
|
{-
|
|
hs_eval_b, -- return a Bool
|
|
hs_eval_c, -- return a CChar
|
|
hs_eval_i, -- return a CInt
|
|
hs_eval_s, -- return a CString
|
|
-}
|
|
|
|
module System.Eval.Utils,
|
|
|
|
) where
|
|
|
|
import System.Eval.Utils
|
|
import System.Plugins.Make
|
|
import System.Plugins.Load
|
|
|
|
import Data.Dynamic ( Dynamic )
|
|
import Data.Typeable ( Typeable )
|
|
|
|
import Data.Either ( )
|
|
import Data.Map as Map
|
|
import Data.Char
|
|
|
|
import System.IO ( )
|
|
import System.Directory
|
|
import System.Random
|
|
import System.IO.Unsafe
|
|
|
|
-- import Foreign.C
|
|
-- import Foreign
|
|
|
|
-- | 'eval' provides a typesafe (to a limit) form of runtime evaluation
|
|
-- for Haskell -- a limited form of /runtime metaprogramming/. The
|
|
-- 'String' argument to 'eval' is a Haskell source fragment to evaluate
|
|
-- at rutime. @imps@ are a list of module names to use in the context of
|
|
-- the compiled value.
|
|
--
|
|
-- The value returned by 'eval' is constrained to be 'Typeable' --
|
|
-- meaning we can perform a /limited/ runtime typecheck, using the
|
|
-- 'dynload' function. One consequence of this is that the code must
|
|
-- evaluate to a monomorphic value (which will be wrapped in a
|
|
-- 'Dynamic').
|
|
--
|
|
-- If the evaluated code typechecks under the 'Typeable' constraints,
|
|
-- 'Just v' is returned. 'Nothing' indicates typechecking failed.
|
|
-- Typechecking may fail at two places: when compiling the argument, or
|
|
-- when typechecking the splice point. 'eval' resembles a
|
|
-- metaprogramming 'run' operator for /closed/ source fragments.
|
|
--
|
|
-- To evaluate polymorphic values you need to wrap them in data
|
|
-- structures using rank-N types.
|
|
--
|
|
-- Examples:
|
|
--
|
|
-- > do i <- eval "1 + 6 :: Int" [] :: IO (Maybe Int)
|
|
-- > when (isJust i) $ putStrLn (show (fromJust i))
|
|
--
|
|
eval :: Typeable a => String -> [Import] -> IO (Maybe a)
|
|
eval src imps = do
|
|
pwd <- getCurrentDirectory
|
|
(cmdline,loadpath) <- getPaths
|
|
tmpf <- mkUniqueWith dynwrap src imps
|
|
status <- make tmpf cmdline
|
|
m_rsrc <- case status of
|
|
MakeSuccess _ obj -> do
|
|
m_v <- dynload obj [pwd] loadpath symbol
|
|
case m_v of LoadFailure _ -> return Nothing
|
|
LoadSuccess _ rsrc -> return $ Just rsrc
|
|
MakeFailure err -> mapM_ putStrLn err >> return Nothing
|
|
makeCleaner tmpf
|
|
return m_rsrc
|
|
|
|
--
|
|
-- | 'eval_' is a variety of 'eval' with all the internal hooks
|
|
-- available. You are able to set any extra arguments to the compiler
|
|
-- (for example, optimisation flags) or dynamic loader, as well as
|
|
-- having any errors returned in an 'Either' type.
|
|
--
|
|
eval_ :: Typeable a =>
|
|
String -- ^ code to compile
|
|
-> [Import] -- ^ any imports
|
|
-> [String] -- ^ extra make flags
|
|
-> [FilePath] -- ^ (package.confs) for load
|
|
-> [FilePath] -- ^ include paths load is to search in
|
|
-> IO (Either [String] (Maybe a)) -- ^ either errors, or maybe a well typed value
|
|
|
|
eval_ src mods args ldflags incs = do
|
|
pwd <- getCurrentDirectory
|
|
(cmdline,loadpath) <- getPaths -- find path to altdata
|
|
tmpf <- mkUniqueWith dynwrap src mods
|
|
status <- make tmpf $ ["-O0"] ++ cmdline ++ args
|
|
m_rsrc <- case status of
|
|
MakeSuccess _ obj -> do
|
|
m_v <- dynload obj (pwd:incs) (loadpath++ldflags) symbol
|
|
return $ case m_v of LoadFailure e -> Left e
|
|
LoadSuccess _ rsrc -> Right (Just rsrc)
|
|
MakeFailure err -> return $ Left err
|
|
makeCleaner tmpf
|
|
return m_rsrc
|
|
|
|
-- | Sometimes when constructing string fragments to evaluate, the
|
|
-- programmer is able to provide some other constraint on the evaluated
|
|
-- string, such that the evaluated expression will be typesafe, without
|
|
-- requiring a 'Typeable' constraint. In such cases, the monomorphic
|
|
-- restriction is annoying. 'unsafeEval' removes any splice-point
|
|
-- typecheck, with an accompanying obligation on the programmer to
|
|
-- ensure that the fragment evaluated will be typesafe at the point it
|
|
-- is spliced.
|
|
--
|
|
-- An example of how to do this would be to wrap the fragment in a call
|
|
-- to 'show'. The augmented fragment would then be checked when compiled
|
|
-- to return a 'String', and the programmer can rely on this, without
|
|
-- requiring a splice-point typecheck, and thus no 'Typeable'
|
|
-- restriction.
|
|
--
|
|
-- Note that if you get the proof wrong, your program will likely
|
|
-- segfault.
|
|
--
|
|
-- Example:
|
|
--
|
|
-- > do s <- unsafeEval "map toUpper \"haskell\"" ["Data.Char"]
|
|
-- > when (isJust s) $ putStrLn (fromJust s)
|
|
--
|
|
unsafeEval :: String -> [Import] -> IO (Maybe a)
|
|
unsafeEval src mods = do
|
|
pwd <- getCurrentDirectory
|
|
tmpf <- mkUniqueWith wrap src mods
|
|
status <- make tmpf []
|
|
m_rsrc <- case status of
|
|
MakeSuccess _ obj -> do
|
|
m_v <- load obj [pwd] [] symbol
|
|
case m_v of LoadFailure _ -> return Nothing
|
|
LoadSuccess _ rsrc -> return $ Just rsrc
|
|
MakeFailure err -> mapM_ putStrLn err >> return Nothing
|
|
makeCleaner tmpf
|
|
return m_rsrc
|
|
|
|
--
|
|
-- | 'unsafeEval_' is a form of 'unsafeEval' with all internal hooks
|
|
-- exposed. This is useful for application wishing to return error
|
|
-- messages to users, to specify particular libraries to link against
|
|
-- and so on.
|
|
--
|
|
unsafeEval_ :: String -- ^ code to compile
|
|
-> [Import] -- ^ any imports
|
|
-> [String] -- ^ make flags
|
|
-> [FilePath] -- ^ (package.confs) for load
|
|
-> [FilePath] -- ^ include paths load is to search in
|
|
-> IO (Either [String] a)
|
|
|
|
unsafeEval_ src mods args ldflags incs = do
|
|
pwd <- getCurrentDirectory
|
|
tmpf <- mkUniqueWith wrap src mods
|
|
status <- make tmpf args
|
|
e_rsrc <- case status of
|
|
MakeSuccess _ obj -> do
|
|
m_v <- load obj (pwd:incs) ldflags symbol
|
|
case m_v of LoadFailure e -> return $ Left e
|
|
LoadSuccess _ rsrc -> return $ Right rsrc
|
|
MakeFailure err -> return $ Left err
|
|
makeCleaner tmpf
|
|
return e_rsrc
|
|
------------------------------------------------------------------------
|
|
--
|
|
-- | 'mkHsValues' is a helper function for converting 'Data.Map's
|
|
-- of names and values into Haskell code. It relies on the assumption of
|
|
-- names and values into Haskell code. It relies on the assumption that
|
|
-- the passed values' Show instances produce valid Haskell literals
|
|
-- (this is true for all Prelude types).
|
|
--
|
|
mkHsValues :: (Show a) => Map.Map String a -> String
|
|
mkHsValues values = concat $ elems $ Map.mapWithKey convertToHs values
|
|
where convertToHs :: (Show a) => String -> a -> String
|
|
convertToHs name value = name ++ " = " ++ show value ++ "\n"
|
|
------------------------------------------------------------------------
|
|
--
|
|
-- | Return a compiled value's type, by using Dynamic to get a
|
|
-- representation of the inferred type.
|
|
--
|
|
typeOf :: String -> [Import] -> IO String
|
|
typeOf src mods = do
|
|
pwd <- getCurrentDirectory
|
|
(cmdline,loadpath) <- getPaths
|
|
tmpf <- mkUniqueWith dynwrap src mods
|
|
status <- make tmpf cmdline
|
|
ty <- case status of
|
|
MakeSuccess _ obj -> do
|
|
m_v <- load obj [pwd] loadpath symbol :: IO (LoadStatus Dynamic)
|
|
case m_v of
|
|
LoadFailure _ -> return "<failure>"
|
|
LoadSuccess _ v -> return $ (init . tail) $ show v
|
|
|
|
MakeFailure err -> mapM_ putStrLn err >> return []
|
|
makeCleaner tmpf
|
|
return ty
|
|
|
|
dynwrap :: String -> String -> [Import] -> String
|
|
dynwrap expr nm mods =
|
|
"module "++nm++ "( resource ) where\n" ++
|
|
concatMap (\m-> "import "++m++"\n") mods ++
|
|
"import Data.Dynamic\n" ++
|
|
"resource = let { "++x++" = \n" ++
|
|
"{-# LINE 1 \"<eval>\" #-}\n" ++ expr ++ ";} in toDyn "++x
|
|
where
|
|
x = ident ()
|
|
|
|
ident () = unsafePerformIO $
|
|
sequence (take 3 (repeat $ getStdRandom (randomR (97,122)) >>= return . chr))
|
|
|
|
-- ---------------------------------------------------------------------
|
|
-- unsafe wrapper
|
|
--
|
|
wrap :: String -> String -> [Import] -> String
|
|
wrap expr nm mods =
|
|
"module "++nm++ "( resource ) where\n" ++
|
|
concatMap (\m-> "import "++m++"\n") mods ++
|
|
"resource = let { "++x++" = \n" ++
|
|
"{-# LINE 1 \"<Plugins.Eval>\" #-}\n" ++ expr ++ ";} in "++x
|
|
where
|
|
x = ident ()
|
|
|
|
-- what is this big variable name?
|
|
-- its a random value, so that it won't clash if the accidently mistype
|
|
-- an unbound 'x' or 'v' in their code.. it won't reveal the internal
|
|
-- structure of the wrapper, which is annoying in irc use by lambdabot
|
|
|
|
{-
|
|
------------------------------------------------------------------------
|
|
--
|
|
-- And for our friends in foreign parts
|
|
--
|
|
-- TODO needs to accept char** to import list
|
|
--
|
|
|
|
--
|
|
-- return NULL pointer if an error occured.
|
|
--
|
|
|
|
foreign export ccall hs_eval_b :: CString -> IO (Ptr CInt)
|
|
foreign export ccall hs_eval_c :: CString -> IO (Ptr CChar)
|
|
foreign export ccall hs_eval_i :: CString -> IO (Ptr CInt)
|
|
foreign export ccall hs_eval_s :: CString -> IO CString
|
|
|
|
------------------------------------------------------------------------
|
|
--
|
|
-- TODO implement a marshalling for Dynamics, so that we can pass that
|
|
-- over to the C side for checking.
|
|
--
|
|
|
|
hs_eval_b :: CString -> IO (Ptr CInt)
|
|
hs_eval_b s = do m_v <- eval_cstring s
|
|
case m_v of Nothing -> return nullPtr
|
|
Just v -> new (fromBool v)
|
|
|
|
hs_eval_c :: CString -> IO (Ptr CChar)
|
|
hs_eval_c s = do m_v <- eval_cstring s
|
|
case m_v of Nothing -> return nullPtr
|
|
Just v -> new (castCharToCChar v)
|
|
|
|
-- should be Integral
|
|
hs_eval_i :: CString -> IO (Ptr CInt)
|
|
hs_eval_i s = do m_v <- eval_cstring s :: IO (Maybe Int)
|
|
case m_v of Nothing -> return nullPtr
|
|
Just v -> new (fromIntegral v :: CInt)
|
|
|
|
hs_eval_s :: CString -> IO CString
|
|
hs_eval_s s = do m_v <- eval_cstring s
|
|
case m_v of Nothing -> return nullPtr
|
|
Just v -> newCString v
|
|
|
|
--
|
|
-- convenience
|
|
--
|
|
eval_cstring :: Typeable a => CString -> IO (Maybe a)
|
|
eval_cstring cs = do s <- peekCString cs
|
|
eval s [] -- TODO use eval()
|
|
|
|
-}
|