Import hs-plugins cvs
This commit is contained in:
Don Stewart
27
src/eval/Eval.hs
Normal file
27
src/eval/Eval.hs
Normal file
@ -0,0 +1,27 @@
|
||||
--
|
||||
-- Copyright (C) 2004 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
|
||||
--
|
||||
|
||||
module Eval (
|
||||
module Eval.Haskell,
|
||||
module Eval.Meta,
|
||||
) where
|
||||
|
||||
import Eval.Haskell {-all-}
|
||||
import Eval.Meta {-all-}
|
||||
|
||||
250
src/eval/Eval/Haskell.hs
Normal file
250
src/eval/Eval/Haskell.hs
Normal file
@ -0,0 +1,250 @@
|
||||
{-# OPTIONS -fglasgow-exts -fffi #-}
|
||||
--
|
||||
-- Copyright (C) 2004 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
|
||||
--
|
||||
|
||||
--
|
||||
-- compile and run haskell strings at runtime.
|
||||
--
|
||||
|
||||
module Eval.Haskell (
|
||||
eval,
|
||||
eval_,
|
||||
unsafeEval,
|
||||
unsafeEval_,
|
||||
typeOf,
|
||||
|
||||
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 Eval.Utils,
|
||||
|
||||
) where
|
||||
|
||||
import Eval.Utils
|
||||
|
||||
import Plugins.Make
|
||||
import Plugins.Load
|
||||
|
||||
import AltData.Dynamic
|
||||
import AltData.Typeable ( Typeable )
|
||||
|
||||
import Data.Either
|
||||
|
||||
import System.IO
|
||||
import System.Directory
|
||||
|
||||
import Foreign.C
|
||||
import Foreign
|
||||
|
||||
--
|
||||
-- ok. the idea is: the have either installed the library, in which case
|
||||
-- is is registered, and the path to altdata is known to ghc, so just
|
||||
-- saying "-package altdata" will work. if not, we search in the build
|
||||
-- dir just in case. this should work for inplace work.
|
||||
--
|
||||
-- TODO could have a few extra package.conf search paths in here,
|
||||
-- including PREFIX.
|
||||
--
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- return a compiled value, and type check it first
|
||||
--
|
||||
-- TODO make this faster.
|
||||
--
|
||||
eval :: Typeable a => String -> [Import] -> IO (Maybe a)
|
||||
eval src mods = do
|
||||
pwd <- getCurrentDirectory
|
||||
(cmdline,loadpath) <- getPaths
|
||||
tmpf <- mkUniqueWith dynwrap src mods
|
||||
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
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- Version of eval with all the buttons available.
|
||||
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 $ ["-Onot"] ++ 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
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- unsafe because it doesn't use Dynamic types
|
||||
-- useful for not having to provide type constraints to values, or when
|
||||
-- you want to easily deal with polymorphic values.
|
||||
--
|
||||
unsafeEval :: String -> [Import] -> IO (Maybe a)
|
||||
unsafeEval src mods = do
|
||||
pwd <- getCurrentDirectory
|
||||
tmpf <- mkUniqueWith wrap src mods
|
||||
status <- make tmpf ["-Onot"]
|
||||
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
|
||||
|
||||
--
|
||||
-- like unsafeEval, except you can supply extra args to make and load,
|
||||
-- and the error messages are returned too.
|
||||
--
|
||||
-- Need to be able to specify a search path to look in.
|
||||
--
|
||||
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 $ ["-Onot"] ++ 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
|
||||
|
||||
------------------------------------------------------------------------
|
||||
--
|
||||
-- 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
|
||||
case m_v of
|
||||
LoadFailure _ -> return "<failure>"
|
||||
LoadSuccess _ (v::Dynamic) -> return $ (init . tail) $ show v
|
||||
|
||||
MakeFailure err -> mapM_ putStrLn err >> return []
|
||||
makeCleaner tmpf
|
||||
return ty
|
||||
|
||||
--
|
||||
-- note that the wrapper uses our altdata library for dynamic typing.
|
||||
-- hence it needs to see the path to the altdata package. grr. is it
|
||||
-- installed or not? what path does it have?
|
||||
--
|
||||
dynwrap :: String -> String -> [Import] -> String
|
||||
dynwrap expr nm mods =
|
||||
"module "++nm++ "( resource ) where\n" ++
|
||||
concatMap (\m-> "import "++m++"\n") mods ++
|
||||
"import AltData.Dynamic\n" ++
|
||||
"resource = let { v = \n" ++
|
||||
"{-# LINE 1 \"<eval>\" #-}\n" ++ expr ++ ";} in toDyn v"
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- unsafe wrapper
|
||||
--
|
||||
wrap :: String -> String -> [Import] -> String
|
||||
wrap expr nm mods =
|
||||
"module "++nm++ "( resource ) where\n" ++
|
||||
concatMap (\m-> "import "++m++"\n") mods ++
|
||||
"resource = let { v = \n" ++
|
||||
"{-# LINE 1 \"<Plugins.Eval>\" #-}\n" ++ expr ++ ";} in v"
|
||||
|
||||
------------------------------------------------------------------------
|
||||
--
|
||||
-- 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()
|
||||
|
||||
96
src/eval/Eval/Meta.hs
Normal file
96
src/eval/Eval/Meta.hs
Normal file
@ -0,0 +1,96 @@
|
||||
{-# OPTIONS -cpp -fth #-}
|
||||
--
|
||||
-- Copyright (C) 2004 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
|
||||
--
|
||||
|
||||
--
|
||||
-- an implementation of the staged compilation primitives from
|
||||
-- "Dynamic Typing as Staged Type Inference"
|
||||
-- Shields, Sheard and Jones, 1998
|
||||
-- http://doi.acm.org/10.1145/268946.268970
|
||||
--
|
||||
|
||||
module Eval.Meta (
|
||||
|
||||
run,
|
||||
defer,
|
||||
splice,
|
||||
|
||||
) where
|
||||
|
||||
import Eval.Haskell ( eval )
|
||||
import AltData.Typeable ( Typeable )
|
||||
|
||||
#if __GLASGOW_HASKELL__ > 602
|
||||
import Language.Haskell.TH ( ExpQ, pprint, runQ )
|
||||
#else
|
||||
import Language.Haskell.THSyntax ( ExpQ, pprExp, runQ )
|
||||
import Text.PrettyPrint ( render )
|
||||
#endif
|
||||
|
||||
import System.IO.Unsafe ( unsafePerformIO )
|
||||
|
||||
type ExpR = String -- hack for splicing
|
||||
|
||||
--
|
||||
-- defer the evaluation of an expression by one stage.
|
||||
-- uses [| |] just for the nice syntax.
|
||||
--
|
||||
-- defer [| 1 + 1 |] --> (1 + 1)
|
||||
--
|
||||
defer :: ExpQ -> ExpR
|
||||
#if __GLASGOW_HASKELL__ > 602
|
||||
defer e = pprint (unsafePerformIO (runQ e))
|
||||
#else
|
||||
defer e = render $ pprExp (unsafePerformIO (runQ e))
|
||||
#endif
|
||||
|
||||
--
|
||||
-- evaluate 'e' to a deferred expression, and evaluate the result.
|
||||
--
|
||||
-- run( defer [|1+1|] ) --> 2
|
||||
--
|
||||
run :: (Show t, Typeable t) => ExpR -> t
|
||||
run e = case unsafePerformIO (eval e imports) of
|
||||
Nothing -> error "source failed to compile"
|
||||
Just a -> a
|
||||
|
||||
--
|
||||
-- evaluate 'e' to a deferred expression. then splice the result back in
|
||||
-- to the surrounding deferred expression. splice() is only legal within
|
||||
-- deferred expressions.
|
||||
--
|
||||
-- let code = defer [| 1 + 1 |] in defer [| splice(code) + 2 |]
|
||||
-- -->
|
||||
-- defer [| 1 + 1 + 2 |]
|
||||
--
|
||||
-- defer( "\x -> " ++ splice (v) )
|
||||
--
|
||||
splice :: Show t => t -> ExpR
|
||||
splice e = show e
|
||||
|
||||
--
|
||||
-- libraries needed
|
||||
--
|
||||
imports =
|
||||
[
|
||||
"GHC.Base",
|
||||
"GHC.Num",
|
||||
"GHC.List"
|
||||
]
|
||||
|
||||
121
src/eval/Eval/Utils.hs
Normal file
121
src/eval/Eval/Utils.hs
Normal file
@ -0,0 +1,121 @@
|
||||
{-# OPTIONS -fglasgow-exts -fffi -cpp #-}
|
||||
--
|
||||
-- Copyright (C) 2004 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
|
||||
--
|
||||
|
||||
--
|
||||
-- compile and run haskell strings at runtime.
|
||||
--
|
||||
|
||||
module Eval.Utils (
|
||||
|
||||
Import,
|
||||
symbol,
|
||||
escape,
|
||||
getPaths,
|
||||
find_altdata_pkgconf,
|
||||
|
||||
mkUniqueWith,
|
||||
cleanup,
|
||||
|
||||
module Data.Maybe,
|
||||
module Control.Monad,
|
||||
|
||||
) where
|
||||
|
||||
import Plugins.Load ( Symbol )
|
||||
import Plugins.Utils
|
||||
import Plugins.Consts ( top {- :{ -} )
|
||||
|
||||
import System.IO
|
||||
import System.Directory
|
||||
|
||||
import Data.Char
|
||||
|
||||
--
|
||||
-- we export these so that eval() users have a nice time
|
||||
--
|
||||
import Data.Maybe
|
||||
import Control.Monad
|
||||
|
||||
--
|
||||
-- imports Foo's
|
||||
--
|
||||
type Import = String
|
||||
|
||||
--
|
||||
-- distinguished symbol name
|
||||
--
|
||||
symbol :: Symbol
|
||||
symbol = "resource"
|
||||
|
||||
--
|
||||
-- turn a Haskell string into a printable version of the same string
|
||||
--
|
||||
escape s = concatMap (\c -> showLitChar c $ "") s
|
||||
|
||||
--
|
||||
-- For Dynamic eval's, work out the compile and load command lines
|
||||
--
|
||||
getPaths :: IO ([String],[String])
|
||||
getPaths = do
|
||||
m_pkg <- find_altdata_pkgconf
|
||||
let load_path = if isJust m_pkg then fromJust m_pkg else []
|
||||
let make_line =
|
||||
let compulsory = ["-Onot","-fglasgow-exts","-package","altdata"]
|
||||
in if not $ null load_path
|
||||
then "-package-conf":load_path:compulsory
|
||||
else compulsory
|
||||
let load_path' = if null load_path then [] else [load_path]
|
||||
return (make_line,load_path')
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- if we are in-tree eval() needs to use the inplace package.conf to
|
||||
-- find altdata, otherwise we need it to be in the ghc package system.
|
||||
--
|
||||
-- fixing Typeable/Dynamic in ghc obsoletes this code. as would adding
|
||||
-- an extra param to eval, which I don't want to do.
|
||||
--
|
||||
find_altdata_pkgconf :: IO (Maybe String)
|
||||
find_altdata_pkgconf = do
|
||||
let f = top </> "plugins.conf.inplace"
|
||||
b <- doesFileExist f
|
||||
return $ if b
|
||||
then Just f
|
||||
else Nothing
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- create the tmp file, and write source into it, using wrapper to
|
||||
-- create extra .hs src.
|
||||
--
|
||||
mkUniqueWith :: (String -> String -> [Import] -> String)
|
||||
-> String
|
||||
-> [Import] -> IO FilePath
|
||||
|
||||
mkUniqueWith wrapper src mods = do
|
||||
(tmpf,hdl) <- hMkUnique
|
||||
let nm = mkModid (basename tmpf) -- used as a module name
|
||||
src' = wrapper src nm mods
|
||||
hPutStr hdl src' >> hFlush hdl >> hClose hdl >> return tmpf
|
||||
|
||||
--
|
||||
-- remove all the tmp files
|
||||
--
|
||||
cleanup :: String -> String -> IO ()
|
||||
cleanup a b = mapM_ removeFile [a, b, replaceSuffix b ".hi"]
|
||||
|
||||
12
src/eval/Makefile
Normal file
12
src/eval/Makefile
Normal file
@ -0,0 +1,12 @@
|
||||
PKG = eval
|
||||
UPKG = Eval
|
||||
|
||||
TOP=../..
|
||||
include ../build.mk
|
||||
|
||||
HC_OPTS += -package-conf $(TOP)/plugins.conf.inplace
|
||||
HC_OPTS += -package plugins
|
||||
|
||||
GHC6_3_HC_OPTS += -package template-haskell
|
||||
|
||||
install: install-me
|
||||
60
src/eval/eval.conf.in.cpp
Normal file
60
src/eval/eval.conf.in.cpp
Normal file
@ -0,0 +1,60 @@
|
||||
#if CABAL == 0 && GLASGOW_HASKELL < 604
|
||||
Package {
|
||||
name = "eval",
|
||||
auto = False,
|
||||
hs_libraries = [ "HSeval" ],
|
||||
#ifdef INSTALLING
|
||||
import_dirs = [ "${LIBDIR}/imports" ],
|
||||
library_dirs = [ "${LIBDIR}/" ],
|
||||
#else
|
||||
import_dirs = [ "${TOP}/src/eval" ],
|
||||
library_dirs = [ "${TOP}/src/eval" ],
|
||||
#endif
|
||||
include_dirs = [],
|
||||
c_includes = [],
|
||||
source_dirs = [],
|
||||
extra_libraries = [],
|
||||
package_deps = [ "plugins"
|
||||
#if GLASGOW_HASKELL >= 603
|
||||
, "template-haskell"
|
||||
#endif
|
||||
],
|
||||
extra_ghc_opts = [],
|
||||
extra_cc_opts = [],
|
||||
extra_ld_opts = []
|
||||
}
|
||||
#else
|
||||
|
||||
name: eval
|
||||
version: 0.9.8
|
||||
license: LGPL
|
||||
maintainer: dons@cse.unsw.edu.au
|
||||
exposed: True
|
||||
exposed-modules:
|
||||
Eval.Haskell,
|
||||
Eval.Meta,
|
||||
Eval.Utils,
|
||||
Eval
|
||||
|
||||
hidden-modules:
|
||||
#ifdef INSTALLING
|
||||
import-dirs: LIBDIR/imports
|
||||
library-dirs: LIBDIR
|
||||
#else
|
||||
import-dirs: TOP/src/eval
|
||||
library-dirs: TOP/src/eval
|
||||
#endif
|
||||
hs-libraries: HSeval
|
||||
extra-libraries:
|
||||
include-dirs:
|
||||
includes:
|
||||
depends: plugins, template-haskell
|
||||
hugs-options:
|
||||
cc-options:
|
||||
ld-options:
|
||||
framework-dirs:
|
||||
frameworks:
|
||||
haddock-interfaces:
|
||||
haddock-html:
|
||||
|
||||
#endif
|
||||
Reference in New Issue
Block a user