Update examples

testsuite/load/io/Makefile

@@ -0,0 +1,6 @@
+TEST= load/io
+
+EXTRA_OBJS=TestIO.o
+
+TOP=../../..
+include ../../build.mk

testsuite/load/io/TestIO.hs

@@ -0,0 +1,84 @@
+{-# OPTIONS -cpp #-}
+--
+-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
+-- LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html)
+--
+
+module TestIO ( resource, resource_dyn )  where
+
+import API
+import Data.Dynamic
+
+import System.IO
+import System.Posix.Types   ( ProcessID, Fd )
+import System.Posix.Process ( forkProcess, executeFile, getProcessID )
+import System.Posix.IO      ( createPipe, stdInput, 
+                              stdOutput, fdToHandle, closeFd, dupTo )
+
+resource = testio { field = date }
+
+resource_dyn :: Dynamic
+resource_dyn = toDyn resource
+
+--
+-- call a shell command , returning it's output
+--
+date :: IO String
+date = do (hdl,_,_) <- catch (popen "/bin/date") (\_->error "popen failed")
+          hGetLine hdl 
+
+------------------------------------------------------------------------
+--
+-- my implementation of $val = `cmd`; (if this was perl)
+--
+-- provide similar functionality to popen(3), 
+-- along with bidirectional ipc via pipes
+-- return's the pid of the child process
+--
+-- there are two different forkProcess functions. the pre-620 was a
+-- unix-fork style function, and the modern function has semantics more
+-- like the Awkward-Squad paper. We provide implementations of popen
+-- using both versions, depending on which GHC the user wants to try.
+-- 
+
+popen :: FilePath -> IO (Handle, Handle, ProcessID)
+popen cmd = do
+        (pr, pw) <- createPipe
+        (cr, cw) <- createPipe    
+
+        -- parent --
+        let parent = do closeFd cw
+                        closeFd pr
+        -- child --
+        let child  = do closeFd pw
+                        closeFd cr 
+                        exec cmd (pr,cw)
+                        error "exec cmd failed!" -- typing only
+
+-- if the parser front end understood cpp, this would work
+-- #if __GLASGOW_HASKELL__ >= 601
+        pid <- forkProcess child -- fork child
+        parent                   -- and run parent code
+-- #else
+--          p   <- forkProcess
+--          pid <- case p of
+--                  Just pid -> parent >> return pid
+--                  Nothing  -> child
+-- #endif
+
+        hcr <- fdToHandle cr
+        hpw <- fdToHandle pw
+
+        return (hcr,hpw,pid)
+
+--
+-- execve cmd in the child process, dup'ing the file descriptors passed
+-- as arguments to become the child's stdin and stdout.
+--
+exec :: FilePath -> (Fd,Fd) -> IO ()
+exec cmd (pr,cw) = do
+        dupTo pr stdInput
+        dupTo cw stdOutput
+        executeFile cmd False [] Nothing
+
+------------------------------------------------------------------------

testsuite/load/io/api/API.hs

@@ -0,0 +1,16 @@
+{-# OPTIONS -fglasgow-exts #-}
+
+module API where
+
+import Data.Dynamic
+
+data TestIO = TestIO { 
+                field :: IO String 
+        }
+   deriving (Typeable, Show)
+
+instance Show (IO String) where
+    show _ = "<<io action>>"
+
+testio :: TestIO
+testio = TestIO { field = return "default value" }

testsuite/load/io/prog/Main.hs

@@ -0,0 +1,15 @@
+{-# OPTIONS -cpp #-}
+
+#include "../../../../config.h"
+
+import System.Plugins
+import API
+
+main :: IO ()
+main = do
+        m_v <- load "../TestIO.o" ["../api"] [] "resource"
+        v <- case m_v of
+                LoadFailure _   -> error "load failed"
+                LoadSuccess _ v -> return v
+        s <- field v
+        if null s then print False else print True

testsuite/load/io/prog/expected

@@ -0,0 +1 @@
+True

testsuite/load/load_0/Makefile

@@ -0,0 +1,6 @@
+TEST= load/load_0
+
+EXTRA_OBJS=Test.o
+
+TOP=../../..
+include ../../build.mk

testsuite/load/load_0/Test.hs

@@ -0,0 +1,6 @@
+
+module Test where
+
+import API
+
+resource = test { field = "success" }

testsuite/load/load_0/api/API.hs

@@ -0,0 +1,8 @@
+module API where
+
+data Test = Test { 
+                field :: String 
+        }
+
+test :: Test
+test = Test { field = "default value" }

testsuite/load/load_0/prog/Main.hs

@@ -0,0 +1,11 @@
+
+import System.Plugins
+import API
+
+main = do
+        m_v <- load_ "../Test.o" ["../api"] "resource"
+        v <- case m_v of
+                LoadFailure _   -> error "load failed"
+                LoadSuccess _ v -> return v
+        let s = field v
+        print s

testsuite/load/load_0/prog/expected

@@ -0,0 +1 @@
+"success"

testsuite/load/loadpkg/Main.hs

@@ -0,0 +1,4 @@
+
+import System.Plugins
+
+main = loadPackageWith "posix" []

testsuite/load/loadpkg/Makefile

@@ -0,0 +1,4 @@
+TEST= load/loadpkg
+
+TOP=../../..
+include ../../eval.mk

testsuite/load/null/Makefile

@@ -0,0 +1,4 @@
+TEST= load/null
+EXTRA_OBJS=Null.o
+TOP=../../..
+include ../../build.mk

testsuite/load/null/Null.hs

@@ -0,0 +1,11 @@
+module Null ( resource, resource_dyn )  where
+
+import API
+import Data.Dynamic
+import Prelude hiding (null)
+
+resource = null
+
+-- ! this has to be special: it can't be overridden by the user.
+resource_dyn :: Dynamic
+resource_dyn = toDyn resource

testsuite/load/null/api/API.hs

@@ -0,0 +1,12 @@
+{-# OPTIONS -fglasgow-exts #-}
+
+module API where
+
+import Data.Dynamic
+
+data Null = Null { a, b :: Int }
+   deriving (Typeable, Show)
+
+null :: Null
+null = Null { a = 42 , b = 1 }
+

testsuite/load/null/prog/Main.hs

@@ -0,0 +1,17 @@
+{-# OPTIONS -cpp #-}
+
+#include "../../../../config.h"
+
+import System.Plugins
+import API
+
+-- an example where we just want to load an object and run it
+
+main = do 
+    let includes = [TOP ++ "/testsuite/load/null/api"]
+    m_v <- load "../Null.o" includes [] "resource"
+    v <- case m_v of
+        LoadSuccess _ v -> return v
+        _               -> error "load failed"
+                
+    putStrLn ( show (a v) )

testsuite/load/null/prog/expected

@@ -0,0 +1 @@
+42

testsuite/load/thiemann0/Makefile

@@ -0,0 +1,6 @@
+TEST= load/thiemann0
+
+#EXTRA_OBJS=Test.o
+
+TOP=../../..
+include ../../build.mk

testsuite/load/thiemann0/Test.hs

@@ -0,0 +1,11 @@
+
+-- P.Thiemann reports that 'import Char' leads to undefined symbol for
+-- __stginit_Char_.
+
+module Test where
+
+import API
+import Char
+
+resource = test { field = map toUpper "success" }
+

testsuite/load/thiemann0/api/API.hs

@@ -0,0 +1,8 @@
+module API where
+
+data Test = Test { 
+                field :: String 
+        }
+
+test :: Test
+test = Test { field = "default value" }

testsuite/load/thiemann0/prog/Main.hs

@@ -0,0 +1,16 @@
+
+import System.Plugins
+import API
+
+main = do
+        status <- make "../Test.hs" ["-i../api"]
+        obj    <- case status of
+                    MakeSuccess _ o -> return o
+                    MakeFailure e   -> mapM_ putStrLn e >> error "failed"
+
+        m_v <- load_ obj ["../api"] "resource"
+        v <- case m_v of
+                LoadFailure _   -> error "load failed"
+                LoadSuccess _ v -> return v
+        let s = field v
+        print s

testsuite/load/thiemann0/prog/expected

@@ -0,0 +1 @@
+"SUCCESS"

testsuite/load/thiemann2/C.hs

@@ -0,0 +1,6 @@
+module C where
+
+import API
+import qualified A
+
+resource = let Test s = A.resource in Test { field = s }

testsuite/load/thiemann2/Makefile

@@ -0,0 +1,6 @@
+TEST= load/thiemann2
+EXTRAFLAGS+=-iprog
+
+TOP=../../..
+include ../../build.mk
+

testsuite/load/thiemann2/api/API.hs

@@ -0,0 +1,8 @@
+module API where
+
+data Test = Test { 
+                field :: String 
+        }
+
+test :: Test
+test = Test { field = "default value" }

testsuite/load/thiemann2/prog/A.hs

@@ -0,0 +1,8 @@
+module A where
+
+import API
+
+import qualified B
+
+resource = Test { field = B.resource }
+

testsuite/load/thiemann2/prog/B.hs

@@ -0,0 +1,3 @@
+module B where
+
+resource = "i'm in b"

testsuite/load/thiemann2/prog/Main.hs

@@ -0,0 +1,20 @@
+
+import System.Plugins
+import API
+
+import A
+
+main = do
+        -- compile C (A and B are already compiled)
+        status <- makeAll "../C.hs" ["-i../api"]
+        obj    <- case status of
+                    MakeSuccess _ o -> return o
+                    MakeFailure e   -> mapM_ putStrLn e >> error "failed"
+
+        -- should load C
+        m_v <- load_ obj ["../api","."] "resource"
+        v <- case m_v of
+                LoadFailure _   -> error "load failed"
+                LoadSuccess _ v -> return v
+        let s = field v
+        print s

testsuite/load/thiemann2/prog/expected

@@ -0,0 +1 @@
+"i'm in b"

testsuite/load/unloadpkg/Main.hs

@@ -0,0 +1,6 @@
+
+import System.Plugins
+
+main = do loadPackage "posix"
+          unloadPackage  "posix"
+          loadPackage "posix"

testsuite/load/unloadpkg/Makefile

@@ -0,0 +1,4 @@
+TEST= load/unloadpkg
+
+TOP=../../..
+include ../../eval.mk