module System.Eval.Haskell (
eval,
eval_,
unsafeEval,
unsafeEval_,
typeOf,
mkHsValues,
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
eval :: Typeable a => String -> [Import] -> IO (Maybe a)
eval :: String -> [String] -> IO (Maybe a)
eval String
src [String]
imps = do
String
pwd <- IO String
getCurrentDirectory
([String]
cmdline,[String]
loadpath) <- IO ([String], [String])
getPaths
String
tmpf <- (String -> String -> [String] -> String)
-> String -> [String] -> IO String
mkUniqueWith String -> String -> [String] -> String
dynwrap String
src [String]
imps
MakeStatus
status <- String -> [String] -> IO MakeStatus
make String
tmpf [String]
cmdline
Maybe a
m_rsrc <- case MakeStatus
status of
MakeSuccess MakeCode
_ String
obj -> do
LoadStatus a
m_v <- String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
Typeable a =>
String -> [String] -> [String] -> String -> IO (LoadStatus a)
dynload String
obj [String
pwd] [String]
loadpath String
symbol
case LoadStatus a
m_v of LoadFailure [String]
_ -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
LoadSuccess Module
_ a
rsrc -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
rsrc
MakeFailure [String]
err -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
err IO () -> IO (Maybe a) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
String -> IO ()
makeCleaner String
tmpf
Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
m_rsrc
eval_ :: Typeable a =>
String
-> [Import]
-> [String]
-> [FilePath]
-> [FilePath]
-> IO (Either [String] (Maybe a))
eval_ :: String
-> [String]
-> [String]
-> [String]
-> [String]
-> IO (Either [String] (Maybe a))
eval_ String
src [String]
mods [String]
args [String]
ldflags [String]
incs = do
String
pwd <- IO String
getCurrentDirectory
([String]
cmdline,[String]
loadpath) <- IO ([String], [String])
getPaths
String
tmpf <- (String -> String -> [String] -> String)
-> String -> [String] -> IO String
mkUniqueWith String -> String -> [String] -> String
dynwrap String
src [String]
mods
MakeStatus
status <- String -> [String] -> IO MakeStatus
make String
tmpf ([String] -> IO MakeStatus) -> [String] -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ [String
"-O0"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
cmdline [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args
Either [String] (Maybe a)
m_rsrc <- case MakeStatus
status of
MakeSuccess MakeCode
_ String
obj -> do
LoadStatus a
m_v <- String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
Typeable a =>
String -> [String] -> [String] -> String -> IO (LoadStatus a)
dynload String
obj (String
pwdString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
incs) ([String]
loadpath[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
ldflags) String
symbol
Either [String] (Maybe a) -> IO (Either [String] (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] (Maybe a) -> IO (Either [String] (Maybe a)))
-> Either [String] (Maybe a) -> IO (Either [String] (Maybe a))
forall a b. (a -> b) -> a -> b
$ case LoadStatus a
m_v of LoadFailure [String]
e -> [String] -> Either [String] (Maybe a)
forall a b. a -> Either a b
Left [String]
e
LoadSuccess Module
_ a
rsrc -> Maybe a -> Either [String] (Maybe a)
forall a b. b -> Either a b
Right (a -> Maybe a
forall a. a -> Maybe a
Just a
rsrc)
MakeFailure [String]
err -> Either [String] (Maybe a) -> IO (Either [String] (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] (Maybe a) -> IO (Either [String] (Maybe a)))
-> Either [String] (Maybe a) -> IO (Either [String] (Maybe a))
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] (Maybe a)
forall a b. a -> Either a b
Left [String]
err
String -> IO ()
makeCleaner String
tmpf
Either [String] (Maybe a) -> IO (Either [String] (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return Either [String] (Maybe a)
m_rsrc
unsafeEval :: String -> [Import] -> IO (Maybe a)
unsafeEval :: String -> [String] -> IO (Maybe a)
unsafeEval String
src [String]
mods = do
String
pwd <- IO String
getCurrentDirectory
String
tmpf <- (String -> String -> [String] -> String)
-> String -> [String] -> IO String
mkUniqueWith String -> String -> [String] -> String
wrap String
src [String]
mods
MakeStatus
status <- String -> [String] -> IO MakeStatus
make String
tmpf []
Maybe a
m_rsrc <- case MakeStatus
status of
MakeSuccess MakeCode
_ String
obj -> do
LoadStatus a
m_v <- String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
obj [String
pwd] [] String
symbol
case LoadStatus a
m_v of LoadFailure [String]
_ -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
LoadSuccess Module
_ a
rsrc -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
rsrc
MakeFailure [String]
err -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
err IO () -> IO (Maybe a) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
String -> IO ()
makeCleaner String
tmpf
Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
m_rsrc
unsafeEval_ :: String
-> [Import]
-> [String]
-> [FilePath]
-> [FilePath]
-> IO (Either [String] a)
unsafeEval_ :: String
-> [String]
-> [String]
-> [String]
-> [String]
-> IO (Either [String] a)
unsafeEval_ String
src [String]
mods [String]
args [String]
ldflags [String]
incs = do
String
pwd <- IO String
getCurrentDirectory
String
tmpf <- (String -> String -> [String] -> String)
-> String -> [String] -> IO String
mkUniqueWith String -> String -> [String] -> String
wrap String
src [String]
mods
MakeStatus
status <- String -> [String] -> IO MakeStatus
make String
tmpf [String]
args
Either [String] a
e_rsrc <- case MakeStatus
status of
MakeSuccess MakeCode
_ String
obj -> do
LoadStatus a
m_v <- String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
obj (String
pwdString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
incs) [String]
ldflags String
symbol
case LoadStatus a
m_v of LoadFailure [String]
e -> Either [String] a -> IO (Either [String] a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] a -> IO (Either [String] a))
-> Either [String] a -> IO (Either [String] a)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] a
forall a b. a -> Either a b
Left [String]
e
LoadSuccess Module
_ a
rsrc -> Either [String] a -> IO (Either [String] a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] a -> IO (Either [String] a))
-> Either [String] a -> IO (Either [String] a)
forall a b. (a -> b) -> a -> b
$ a -> Either [String] a
forall a b. b -> Either a b
Right a
rsrc
MakeFailure [String]
err -> Either [String] a -> IO (Either [String] a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] a -> IO (Either [String] a))
-> Either [String] a -> IO (Either [String] a)
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] a
forall a b. a -> Either a b
Left [String]
err
String -> IO ()
makeCleaner String
tmpf
Either [String] a -> IO (Either [String] a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either [String] a
e_rsrc
mkHsValues :: (Show a) => Map.Map String a -> String
mkHsValues :: Map String a -> String
mkHsValues Map String a
values = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Map String String -> [String]
forall k a. Map k a -> [a]
elems (Map String String -> [String]) -> Map String String -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> a -> String) -> Map String a -> Map String String
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey String -> a -> String
forall a. Show a => String -> a -> String
convertToHs Map String a
values
where convertToHs :: (Show a) => String -> a -> String
convertToHs :: String -> a -> String
convertToHs String
name a
value = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
typeOf :: String -> [Import] -> IO String
typeOf :: String -> [String] -> IO String
typeOf String
src [String]
mods = do
String
pwd <- IO String
getCurrentDirectory
([String]
cmdline,[String]
loadpath) <- IO ([String], [String])
getPaths
String
tmpf <- (String -> String -> [String] -> String)
-> String -> [String] -> IO String
mkUniqueWith String -> String -> [String] -> String
dynwrap String
src [String]
mods
MakeStatus
status <- String -> [String] -> IO MakeStatus
make String
tmpf [String]
cmdline
String
ty <- case MakeStatus
status of
MakeSuccess MakeCode
_ String
obj -> do
LoadStatus Dynamic
m_v <- String -> [String] -> [String] -> String -> IO (LoadStatus Dynamic)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
obj [String
pwd] [String]
loadpath String
symbol :: IO (LoadStatus Dynamic)
case LoadStatus Dynamic
m_v of
LoadFailure [String]
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"<failure>"
LoadSuccess Module
_ Dynamic
v -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ (String -> String
forall a. [a] -> [a]
init (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
tail) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Dynamic -> String
forall a. Show a => a -> String
show Dynamic
v
MakeFailure [String]
err -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
err IO () -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return []
String -> IO ()
makeCleaner String
tmpf
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ty
dynwrap :: String -> String -> [Import] -> String
dynwrap :: String -> String -> [String] -> String
dynwrap String
expr String
nm [String]
mods =
String
"module "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nmString -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"( resource ) where\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
(String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
m-> String
"import "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
mString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n") [String]
mods String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"import Data.Dynamic\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"resource = let { "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" = \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"{-# LINE 1 \"<eval>\" #-}\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";} in toDyn "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
x
where
x :: String
x = () -> String
ident ()
ident :: () -> String
ident () = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$
[IO Char] -> IO String
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Int -> [IO Char] -> [IO Char]
forall a. Int -> [a] -> [a]
Prelude.take Int
3 (IO Char -> [IO Char]
forall a. a -> [a]
repeat (IO Char -> [IO Char]) -> IO Char -> [IO Char]
forall a b. (a -> b) -> a -> b
$ (StdGen -> (Int, StdGen)) -> IO Int
forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
getStdRandom ((Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
97,Int
122)) IO Int -> (Int -> IO Char) -> IO Char
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> IO Char) -> (Int -> Char) -> Int -> IO Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
chr))
wrap :: String -> String -> [Import] -> String
wrap :: String -> String -> [String] -> String
wrap String
expr String
nm [String]
mods =
String
"module "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nmString -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"( resource ) where\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
(String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
m-> String
"import "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
mString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n") [String]
mods String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"resource = let { "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" = \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"{-# LINE 1 \"<Plugins.Eval>\" #-}\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";} in "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
x
where
x :: String
x = () -> String
ident ()