Browse Source

some test code

addedsingle
Alberto G. Corona 5 years ago
parent
commit
05ad2fe794
  1. 9
      bash.exe.stackdump
  2. 10
      src/Transient/MapReduce.hs
  3. BIN
      src/Transient/Move/Services/CUsersmagocoalAppDataRoamingcabalbin
  4. 12
      src/Transient/Move/Utils.hs
  5. 9
      stack.yaml1
  6. 65
      tests/Stream.hs
  7. 61
      tests/Test.hs
  8. 8
      tests/Test2.hs
  9. BIN
      tests/TestSuite
  10. 21
      tests/TestSuite.hs
  11. 24
      tests/cell.hs
  12. 1
      void.hs

9
bash.exe.stackdump

@ -0,0 +1,9 @@
Stack trace:
Frame Function Args
000005FC358 0018007198E (001802596AD, 0018020EE46, 000005FC358, 000005FB250)
000005FC358 00180046E22 (000005FC2B8, 00000000000, 00000000000, 00000000000)
000005FC358 00180046E62 (00180259769, 000005FC208, 000005FC358, 00000000000)
000005FC358 001800BCD0F (00000000000, 00000000000, 00000000000, 00000000000)
000005FC358 001800BCF2F (000005FC380, 00000000000, 00000000000, 00000000000)
000005FC400 001800BE1CA (000005FC380, 00000000000, 00000000000, 00000000000)
End of stack trace

10
src/Transient/MapReduce.hs

@ -250,16 +250,6 @@ reduce red (dds@(DDS mx))= loggedc $ do
$ (i,map (\(k,vs) -> (k,foldl1 red vs)) kvs)
foldthemAndSend ikvs = loggedc $ do
(i,folded) <- local $ foldthem ikvs
runAt (nodes !! i) $ local $ putMailbox box $ Reduce folded
sendEnd nodes = onNodes nodes . local $ putMailbox box (EndReduce `asTypeOf` paramOf dds)
-- !> ("send ENDREDUCE",mynode)
onNodes nodes f= foldr (<|>) empty $ map (\n -> runAt n f) nodes

BIN
src/Transient/Move/Services/CUsersmagocoalAppDataRoamingcabalbin

Binary file not shown.

12
src/Transient/Move/Utils.hs

@ -73,12 +73,14 @@ inputNodes= do
r <- input (const True) "Host to connect to: (none): "
if r == "" then stop else return r
port <- local $ input (const True) "port?"
port <- local $ input (const True) "port? "
connectit <- local $ input (\x -> x=="y" || x== "n") "connect to get his list of nodes?"
connectit <- local $ input (\x -> x=="y" || x== "n") "connect to the node to get his list of nodes?"
nnode <- localIO $ createNode host port
if connectit== "y" then connect' nnode
else local $ addNodes [nnode]
else local $ do
liftIO $ putStr "Added node: ">> print nnode
addNodes [nnode]
empty
@ -109,8 +111,8 @@ simpleWebApp port app = do
initWebApp :: Node -> Cloud () -> TransIO ()
initWebApp node app= do
conn <- defConnection
setData conn{myNode = node}
serverNode <- getWebServerNode :: TransIO Node
setData conn{myNode = node}
serverNode <- getWebServerNode :: TransIO Node
mynode <- if isBrowserInstance
then liftIO $ createWebNode

9
stack.yaml1

@ -0,0 +1,9 @@
resolver: lts-6.6
packages:
- '.'
- location:
git: https://github.com/agocorona/transient.git
commit: 5d67ec5b47166110abc7d1a3e1d3618aa5b3f25e
extra-dep: true
extra-package-dbs: []
flags: {}

65
tests/Stream.hs

@ -0,0 +1,65 @@
import Control.Concurrent.Async
import Control.Concurrent
import Control.Applicative
newtype Stream a = Stream{ runStream :: IO [Async a]}
instance Functor Stream where
fmap f (Stream mxs) = Stream $ do
xs <- mxs
return [fmap f x | x <- xs]
instance Applicative Stream where
pure x= Stream $ do
z <- async $ return x
return [z]
(Stream mfs) <*> (Stream mas) = Stream $do
as <- mas
fs <- mfs
sequence [
async $ ( wait f) <*> ( wait a)
| f <- fs, a <- as]
instance Alternative Stream where
empty= Stream $ return []
x <|> y = Stream $ do
xs <- runStream x
if null xs then runStream y
else return xs
instance Monad Stream where
return = pure
(Stream mxs) >>= f = Stream $ do
xs <- mxs
rs <- mapM wait xs
rr <- sequence [ runStream $ f r | r <- rs]
return $ concat rr
stream :: [IO a] -> Stream a
stream ioa= Stream $ mapM async ioa
stream' :: [a] -> Stream a
stream' = Stream . mapM (async . return)
waitStream :: Stream a -> IO [a]
waitStream (Stream mxs)= do
xs <- mxs
mapM wait xs
main= do
r <- waitStream $ stream' [1..10]
print r
r <- waitStream $ do
x <- stream' [1..100]
return $ 2 * x
print r
where
fact 0 = 1
fact n= n * fact (n -1)

61
tests/Test.hs

@ -1,18 +1,53 @@
import Control.Concurrent.Async
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
main = do
master <- newBroadcastTChanIO
newtype Stream a = Stream{ runStream :: IO [Async a]}
forM_ [1..10] $ \i -> do
chan <- atomically $ dupTChan master
forkIO $
forever $ do
x <- atomically $ readTChan chan
putStrLn $ "Thread " ++ show i ++ ": " ++ show x
instance Functor Stream where
fmap f (Stream mxs) = Stream $ do
xs <- mxs
return [fmap f x | x <- xs]
atomically $ writeTChan master "h"
instance Applicative Stream where
pure x= Stream $ do
z <- async $ return x
return [z]
(Stream mfs) <*> (Stream mas) = Stream $do
as <- mas
fs <- mfs
sequence [
async $ ( wait f) <*> ( wait a)
| f <- fs, a <- as]
instance Monad Stream where
return = pure
(Stream mxs) >>= f = Stream $ do
xs <- mxs
rs <- mapM wait xs
rr <- sequence [ runStream $ f r | r <- rs]
return $ concat rr
stream :: [IO a] -> Stream a
stream ioa= Stream $ mapM async ioa
waitStream :: Stream a -> IO [a]
waitStream (Stream mxs)= do
xs <- mxs
mapM wait xs
main= do
r <- waitStream $ stream $ map return [1..10]
print r
r <- waitStream $ do
x <- stream $ map (\x -> do threadDelay 1000000; return x) [1..100]
return $ 2 * x
print r
where
fact 0 = 1
fact n= n * fact (n -1)
-- Give threads time to complete
threadDelay 1000000

8
tests/Test2.hs

@ -37,7 +37,13 @@ import System.IO.Unsafe
main= keep $ initNode $ test
main= do
node1 <- createNode "localhost" 2000
node2 <- createNode "localhost" 2001
runCloudIO $ do
listen node1 <|> listen node2 <|> return ()
r <- local empty <|> runAt node2 (local (return "hello"))
localIO $ print r
test :: Cloud ()

BIN
tests/TestSuite

Binary file not shown.

21
tests/TestSuite.hs

@ -22,6 +22,8 @@ import Control.Exception.Base
import qualified Data.Map as M
import System.Exit
import Control.Monad.State
#define _UPK_(x) {-# UNPACK #-} !(x)
@ -40,30 +42,20 @@ main= do
n2003= nodes !! 3
r <-runCloudIO $ do
runNodes nodes
-- local $ option "s" "start"
local $ do
liftIO $ putStrLn "--------------checking parallel execution, events --------"
ev <- newEVar
r <- collect 3 $ readEVar ev <|> ((choose [1..3] >>= writeEVar ev) >> stop)
assert (sort r== [1,2,3]) $ liftIO $ print r
localIO $ putStrLn "------checking Alternative distributed--------"
r <- local $ collect' 3 1 0 $
r <- local $ collect 3 $
runCloud $ (runAt n2000 (shouldRun(2000) >> return "hello"))
<|> (runAt n2001 (shouldRun(2001) >> return "world" ))
<|> (runAt n2002 (shouldRun(2002) >> return "world2" ))
loggedc $ assert(sort r== ["hello", "world","world2"]) $ lliftIO $ print r
lliftIO $ putStrLn "--------------checking Applicative distributed--------"
r <- loggedc $(runAt n2000 (shouldRun(2000) >> return "hello "))
<> (runAt n2001 (shouldRun(2001) >> return "world " ))
<> (runAt n2002 (shouldRun(2002) >> return "world2" ))
localIO $ print r
assert(r== "hello world world2") $ lliftIO $ print r
@ -83,19 +75,20 @@ main= do
local $ exit ()
lliftIO $ print "SUCCES"
local $ exit ()
exitSuccess
--getEffects :: Loggable a => Cloud [(Node, a)]
--getEffects=lliftIO $ readIORef effects
--
runNodes nodes= foldl (<|>) empty (map listen nodes) <|> return()
runNodes nodes= foldl (<|>) empty (map listen nodes) <|> return () -- (onAll $ async $ return())
--
--
--delEffects= lliftIO $ writeIORef effects []

24
tests/cell.hs

@ -16,30 +16,26 @@ import Control.Concurrent(threadDelay)
main= keep $ do
port <- getPort
initWebApp port $ onBrowser $ local $ render $ do
main= keep $ initNode $ onBrowser $ local $ render $ do
mk cellA (Just 1) <|> mk cellB (Just 2)
calc
where
cellA = scell "cella" $ runCloud $ do
lliftIO $ print "local"
atRemote $ do
lliftIO $ print "running cella at server"
return 2
atRemote $ local $ do
v <- norender $ gcell "cellb"
liftIO $ print "running cella at server"
return $ 2 * v
cellB = scell "cellb" $ runCloud $ do
lliftIO $ print "local2"
atRemote $ do
lliftIO $ print "running cellb at server"
return 4
atRemote $ local $ do
v <- norender $ gcell "cella"
liftIO $ print "running cellb at server"
return $ 4 * v
main2= keep $ do
port <- getPort
initWebApp port $ onBrowser $ do
main2= keep $ initNode $ onBrowser $ do
local $ render $ rawHtml $ h1 ("laps" :: String)

1
void.hs

@ -0,0 +1 @@
main= return()
Loading…
Cancel
Save