content: --
  -- 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 (Prelude.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 accidentally 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 occurred.
  --
  
  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()
  
  -}
  