--- /dev/null
+main = putStr "Hello, world\n"
--- /dev/null
+Hello, world
--- /dev/null
+import System (getEnv)
+
+main =
+ getEnv "TERM" >>= \ term ->
+ putStr term >>
+ putChar '\n' >>
+ getEnv "One fish, two fish, red fish, blue fish" >>= \ fish ->
+ putStr fish >>
+ putChar '\n'
+
+
+
+
--- /dev/null
+import System (getProgName, getArgs)
+
+main =
+ getProgName >>= \ argv0 ->
+ putStr argv0 >>
+ getArgs >>= \ argv ->
+ sequence (map (\ x -> putChar ' ' >> putStr x) argv) >>
+ putChar '\n'
+
--- /dev/null
+io003 with some arguments
--- /dev/null
+import System (exitWith, ExitCode(..))
+
+main = exitWith (ExitFailure 42)
--- /dev/null
+import System (system, ExitCode(..), exitWith)
+
+main =
+ system "cat dog 1>/dev/null 2>&1" >>= \ ec ->
+ case ec of
+ ExitSuccess -> putStr "What?!?\n" >> fail (userError "dog succeeded")
+ ExitFailure _ ->
+ system "cat Main.hs 2>/dev/null" >>= \ ec ->
+ case ec of
+ ExitSuccess -> exitWith ExitSuccess
+ ExitFailure _ -> putStr "What?!?\n" >> fail (userError "cat failed")
--- /dev/null
+import System (system, ExitCode(..), exitWith)
+
+main =
+ system "cat dog 1>/dev/null 2>&1" >>= \ ec ->
+ case ec of
+ ExitSuccess -> putStr "What?!?\n" >> fail (userError "dog succeeded")
+ ExitFailure _ ->
+ system "cat Main.hs 2>/dev/null" >>= \ ec ->
+ case ec of
+ ExitSuccess -> exitWith ExitSuccess
+ ExitFailure _ -> putStr "What?!?\n" >> fail (userError "cat failed")
--- /dev/null
+import IO -- 1.3
+
+main =
+ hClose stderr >>
+ hPutStr stderr "junk" `catch` \ err -> if isIllegalOperation err then putStr "Okay\n" else error "Not okay\n"
+
--- /dev/null
+import IO -- 1.3
+
+main =
+ openFile "io007.in" ReadMode >>= \ hIn ->
+ hPutStr hIn "test" `catch`
+ \ err ->
+ if isIllegalOperation err then
+ hGetContents hIn >>= \ stuff ->
+ hPutStr stdout stuff
+ else
+ error "Oh dear\n"
--- /dev/null
+main =
+ openFile "io007.in" ReadMode >>= \ hIn ->
+ hPutStr hIn "test" `handle`
+ \ (IllegalOperation _) ->
+ hGetContents hIn >>= \ stuff ->
+ hPutStr stdout stuff
--- /dev/null
+module Main(main) where
+
+import IO -- 1.3
+--import IOBase -- tryIO 1.3
+--import GHCio
+
+import Directory (removeFile)
+
+main =
+ openFile "io008.in" ReadMode >>= \ hIn ->
+ openFile "io008.out" ReadWriteMode >>= \ hOut ->
+ removeFile "io008.out" >>
+ hGetPosn hIn >>= \ bof ->
+ copy hIn hOut >>
+ hSetPosn bof >>
+ copy hIn hOut >>
+ hSeek hOut AbsoluteSeek 0 >>
+ hGetContents hOut >>= \ stuff ->
+ putStr stuff
+
+copy :: Handle -> Handle -> IO ()
+copy hIn hOut =
+ try (hGetChar hIn) >>=
+ either (\ err -> if isEOFError err then return () else error "copy") ( \ x -> hPutChar hOut x >> copy hIn hOut)
--- /dev/null
+123456789*123456789*123456789*123456789*123456789*123456789*123456789*12
+ 1 2 3 4 5 6 7
+123456789*123456789*123456789*123456789*123456789*123456789*123456789*12
+ 1 2 3 4 5 6 7
--- /dev/null
+import Directory (getDirectoryContents)
+import QSort (sort)
+
+main =
+ getDirectoryContents "." >>= \ names ->
+ print (sort names)
--- /dev/null
+[".", "..", ".depend", "CVS", "Main.hi", "Main.hs", "Main.o", "Makefile", "io009", "io009.stdout"]
--- /dev/null
+import Directory (getCurrentDirectory, setCurrentDirectory,
+ createDirectory, removeDirectory, getDirectoryContents)
+
+main =
+ getCurrentDirectory >>= \ oldpwd ->
+ createDirectory "foo" >>
+ setCurrentDirectory "foo" >>
+ getDirectoryContents "." >>= \ [n1, n2] ->
+ if dot n1 && dot n2 then
+ setCurrentDirectory oldpwd >>
+ removeDirectory "foo" >>
+ putStr "Okay\n"
+ else
+ fail (userError "Oops")
+
+
+dot :: String -> Bool
+dot "." = True
+dot ".." = True
+dot _ = False
--- /dev/null
+import IO -- 1.3
+
+import Directory
+import GlaExts (trace)
+
+main =
+ createDirectory "foo" >>
+ openFile "foo/bar" WriteMode >>= \ h ->
+ hPutStr h "Okay\n" >>
+ hClose h >>
+ renameFile "foo/bar" "foo/baz" >>
+ renameDirectory "foo" "bar" >>
+ openFile "bar/baz" ReadMode >>= \ h ->
+ hGetContents h >>= \ stuff ->
+ putStr stuff >>
+ hClose h >>
+ removeFile "bar/baz" >>
+ removeDirectory "bar"
--- /dev/null
+import IO -- 1.3
+
+import CPUTime
+
+main =
+ openFile "/dev/null" WriteMode >>= \ h ->
+ hPrint h (nfib 30) >>
+ getCPUTime >>= \ t ->
+ print t
+
+nfib :: Integer -> Integer
+nfib n
+ | n <= 1 = 1
+ | otherwise = (n1 + n2 + 1)
+ where
+ n1 = nfib (n-1)
+ n2 = nfib (n-2)
--- /dev/null
+import IO -- 1.3
+
+main =
+ openFile "io013.in" ReadMode >>= \ h ->
+ hFileSize h >>= \ sz ->
+ print sz >>
+ hSeek h SeekFromEnd (-3) >>
+ hGetChar h >>= \ x ->
+ putStr (x:"\n") >>
+ hSeek h RelativeSeek (-2) >>
+ hGetChar h >>= \ w ->
+ putStr (w:"\n") >>
+ hIsSeekable h >>= \ True ->
+ hClose h >>
+ openFile "/dev/null" ReadMode >>= \ h ->
+ hIsSeekable h >>= \ False ->
+ hClose h
+
--- /dev/null
+import IO -- 1.3
+
+main =
+ accumulate (map hIsOpen [stdin, stdout, stderr]) >>= \ opens ->
+ print opens >>
+ accumulate (map hIsClosed [stdin, stdout, stderr]) >>= \ closeds ->
+ print closeds >>
+ accumulate (map hIsReadable [stdin, stdout, stderr]) >>= \ readables ->
+ print readables >>
+ accumulate (map hIsWritable [stdin, stdout, stderr]) >>= \ writables ->
+ print writables >>
+ accumulate (map hIsBlockBuffered [stdin, stdout, stderr]) >>= \ buffereds ->
+ print buffereds >>
+ accumulate (map hIsLineBuffered [stdin, stdout, stderr]) >>= \ buffereds ->
+ print buffereds >>
+ accumulate (map hIsNotBuffered [stdin, stdout, stderr]) >>= \ buffereds ->
+ print buffereds
+ where
+ -- these didn't make it into 1.3
+ hIsBlockBuffered h = hGetBuffering h >>= \ b -> return $ case b of { BlockBuffering _ -> True; _ -> False }
+ hIsLineBuffered h = hGetBuffering h >>= \ b -> return $ case b of { LineBuffering -> True; _ -> False }
+ hIsNotBuffered h = hGetBuffering h >>= \ b -> return $ case b of { NoBuffering -> True; _ -> False }
--- /dev/null
+[True, True, True]
+[False, False, False]
+[True, False, False]
+[False, True, True]
+[True, True, False]
+[False, False, False]
+[False, False, True]
--- /dev/null
+import IO -- 1.3
+
+main =
+ isEOF >>= \ eof ->
+ if eof then
+ return ()
+ else
+ getChar >>= \ c ->
+ putChar c >>
+ main
--- /dev/null
+import IO -- 1.3
+
+main =
+ isEOF >>= \ eof ->
+ if eof then
+ return ()
+ else
+ getChar >>= \ c ->
+ putChar c >>
+ main
--- /dev/null
+import IO -- 1.3
+
+import System (getArgs)
+import Char (toUpper)
+
+main = getArgs >>= \ [f1,f2] ->
+ openFile f1 ReadMode >>= \ h1 ->
+ openFile f2 WriteMode >>= \ h2 ->
+ copyFile h1 h2 >>
+ hClose h1 >>
+ hClose h2
+
+copyFile h1 h2 =
+ hIsEOF h1 >>= \ eof ->
+ if eof then
+ return ()
+ else
+ hGetChar h1 >>= \ c ->
+ hPutChar h2 (toUpper c) >>
+ copyFile h1 h2
+
--- /dev/null
+import IO -- 1.3
+
+main =
+ hSetBuffering stdout NoBuffering >>
+ putStr "Enter an integer: " >>
+ readLine >>= \ x1 ->
+ putStr "Enter another integer: " >>
+ readLine >>= \ x2 ->
+ putStr ("Their sum is " ++ show (read x1+ read x2) ++ "\n")
+
+ where readLine = isEOF >>= \ eof ->
+ if eof then return []
+ else getChar >>= \ c ->
+ if c `elem` ['\n','\r'] then
+ return []
+ else
+ readLine >>= \ cs ->
+ return (c:cs)
+
--- /dev/null
+Enter an integer: Enter another integer: Their sum is 35
--- /dev/null
+-- Sigbjorn and I don't understand what this test is meant to do
+-- It simply hangs on stdin!
+
+import IO -- 1.3
+
+import System(getArgs)
+
+main = getArgs >>= \ [user,host] ->
+ let username = (user ++ "@" ++ host) in
+ openFile username ReadWriteMode >>= \ cd ->
+ hSetBuffering stdin NoBuffering >>
+ hSetBuffering stdout NoBuffering >>
+ hSetBuffering cd NoBuffering >>
+ hPutStr cd speakString >>
+ speak cd
+
+speakString = "Someone wants to speak with you\n"
+
+speak cd =
+ (hReady cd >>= \ ready ->
+ if ready then (hGetChar cd >>= putChar)
+ else return () >>
+
+ hReady stdin >>= \ ready ->
+ if ready then (getChar >>= hPutChar cd)
+ else return ()) >>
+
+ speak cd
--- /dev/null
+import Time
+
+main =
+ getClockTime >>= \ time ->
+ print time >>
+
+ let (CalendarTime year month mday hour min sec psec
+ wday yday timezone gmtoff isdst) = toUTCTime time
+ in
+ putStr (wdays !! wday) >>
+ putStr (' ' : months !! month) >>
+ putStr (' ' : shows2 mday (' ' : shows2 hour (':' : shows2 min (':' : shows2 sec
+ (' ' : timezone ++ ' ' : shows year "\n")))))
+
+ where
+ wdays = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
+ months = ["Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
+ shows2 x = showString (pad2 x)
+ pad2 x = case show x of
+ c@[_] -> '0' : c
+ cs -> cs
--- /dev/null
+import Time
+
+main =
+ getClockTime >>= \ time ->
+ let (CalendarTime year month mday hour min sec psec
+ wday yday timezone gmtoff isdst) = toUTCTime time
+ time' = toClockTime (CalendarTime (year - 1) month mday hour min sec psec
+ wday yday timezone gmtoff isdst)
+ in
+ print time >>
+ putChar '\n' >>
+ print time' >>
+ putChar '\n'
--- /dev/null
+import IO -- 1.3
+
+main =
+ hSetBuffering stdin NoBuffering >>
+ hSetBuffering stdout NoBuffering >>
+ interact id
--- /dev/null
+{- server
+
+The purpose of this test driver is to test TCP Stream sockets.
+All values have been hard coded since the BSD library is not used to
+query the databases for the values. In therory this code is thus not
+portable but net007/Main.hs provides a portable version using the BSD
+module.
+
+This creates a stream socket bound to port 5000 and waits for incoming
+messages it then reads all available data before closing the
+connection to that peer.
+
+No form of error checking is provided other than that already provided
+by module SocketPrim.
+
+
+TESTS:
+ socket
+ bindSocket
+ listen
+ accept
+ readSocket
+ sClose
+
+-}
+
+
+module Main where
+
+import SocketPrim
+
+
+main =
+ socket AF_INET Stream 6 >>= \ s ->
+ bindSocket s (SockAddrInet 5000 iNADDR_ANY) >>
+ listen s 5 >>
+
+ let
+ loop =
+ accept s >>= \ (s',peerAddr) ->
+ putStr "*** Start of Transfer ***\n" >>
+ let
+ read_all =
+ readSocket s' 4 >>= \ (str, nbytes) ->
+ if nbytes /= 0 then
+ putStr str >>
+ read_all
+ else
+ putStr "\n*** End of Transfer ***\n" >>
+ sClose s'
+ in
+ read_all
+ in
+ loop
+
--- /dev/null
+{- client
+
+Client side to net001/Main.hs.
+
+Note that the machine IP numbers have been hard coded into this
+program so it is unlikely that you will be able to run this test if
+you are not at dcs.gla.ac.uk :-(
+
+The reason for this is to aviod using the BSD module at this stage of
+testing.
+
+
+TESTS:
+ socket
+ connect
+ writeSocket
+ shutdown
+ inet_addr
+-}
+
+
+module Main where
+
+import SocketPrim
+
+
+starbuck = "130.209.240.81" -- SunOS 4.1.3 1 sun4c
+marcus = "130.209.247.2" -- SunOS 4.1.3 6 sun4m
+avon = "130.209.247.4" -- OSF1 V2.0 240 alpha
+karkar = "130.209.247.3" -- OSF1 V2.0 240 alpha
+
+message = "Hello World"
+
+
+main =
+ socket AF_INET Stream 6 >>= \ s ->
+ connect s (SockAddrInet 5000 (inet_addr avon)) >>
+
+ writeSocket s message >>
+ shutdown s 2 >>
+ sClose s
+
--- /dev/null
+{- server
+
+As for net001 but gets the system to allocate the next free port
+number. It also prints out the IP number of the peer.
+
+TESTS:
+ getSocketName
+ inet_ntoa
+
+-}
+
+module Main where
+
+import SocketPrim
+
+
+main =
+ socket AF_INET Stream 6 >>= \ s ->
+ bindSocket s (SockAddrInet aNY_PORT iNADDR_ANY) >>
+ getSocketName s >>= \ (SockAddrInet port _) ->
+ putStr ("Allocated Port Number: " ++ show port ++ "\n") >>
+ listen s 5 >>
+
+
+ let
+ loop =
+ accept s >>= \ (s',(SockAddrInet _ haddr)) ->
+ putStr ("*** Start of Transfer from: " ++
+ (inet_ntoa haddr) ++ "***\n") >>
+ let
+ read_all =
+ readSocket s' 4 >>= \ (str, nbytes) ->
+ if nbytes /= 0 then
+ putStr str >>
+ read_all
+ else
+ putStr "\n*** End of Transfer ***\n" >>
+ sClose s'
+ in
+ read_all
+ in
+ loop
+
--- /dev/null
+{- client
+
+As for net002 but reads port number and message as arguments.
+It also prints out the IP number of the peer machine.
+
+
+
+TESTS:
+ getPeerName
+-}
+
+
+module Main(main) where
+
+import SocketPrim
+import System
+
+
+starbuck = "130.209.240.81"
+marcus = "130.209.247.2"
+
+
+main =
+ getArgs >>= \ [port, message] ->
+ socket AF_INET Stream 6 >>= \ s ->
+ connect s (SockAddrInet (read port) (inet_addr starbuck)) >>
+
+ getPeerName s >>= \ (SockAddrInet p haddr) ->
+ putStr ("Connected to : " ++ (inet_ntoa haddr) ++ "\n") >>
+ writeSocket s message >>
+ shutdown s 2 >>
+ sClose s
+
--- /dev/null
+{- server
+
+Server as net001 but for Unix Domain Datagram sockets.
+
+TESTS:
+ socket
+ bindSocket
+ readSocket
+
+-}
+
+
+module Main where
+
+import SocketPrim
+
+
+main =
+ socket AF_UNIX Datagram 0 >>= \ s ->
+ bindSocket s (SockAddrUnix "sock") >>
+
+ let
+ loop =
+ putStr "*** Start of Transfer ***\n" >>
+ let
+ read_all =
+ readSocket s 1024 >>= \ (str, nbytes) ->
+ if nbytes /= 0 then
+ putStr str >>
+ read_all
+ else
+ putStr "\n*** End of Transfer ***\n"
+ in
+ read_all
+ in
+ loop
+
--- /dev/null
+{- client
+
+Client side of net005
+
+TESTS:
+ socket
+ connect
+ writeSocket
+ shutdown
+ sClose
+-}
+
+
+module Main where
+
+import SocketPrim
+
+message = "Hello World"
+
+
+main =
+ socket AF_UNIX Datagram 0 >>= \ s ->
+ connect s (SockAddrUnix "sock") >>
+
+ writeSocket s message >>
+ shutdown s ShutdownBoth >>
+ sClose s
--- /dev/null
+{- server
+
+As net003 but uses the BSD module for portability. Also prints the
+common name of the host rather than its IP number.
+
+TESTS:
+ getProtocolNumber
+ getSocketName
+ getHostByAddr
+
+-}
+
+module Main where
+
+import BSD
+import SocketPrim
+
+main =
+ getProtocolNumber "tcp" >>= \ proto ->
+ socket AF_INET Stream proto >>= \ s ->
+ bindSocket s (SockAddrInet aNY_PORT iNADDR_ANY) >>
+ getSocketName s >>= \ (SockAddrInet port _) ->
+ putStr ("Allocated Port Number: " ++ show port ++ "\n") >>
+ listen s 5 >>
+
+
+ let
+ loop =
+ accept s >>= \ (s',(SockAddrInet _ haddr)) ->
+ getHostByAddr AF_INET haddr >>= \ (HostEntry hname _ _ _) ->
+ putStr ("*** Start of Transfer from: " ++ hname ++ "***\n") >>
+ let
+ read_all =
+ readSocket s' 4 >>= \ (str, nbytes) ->
+ if nbytes /= 0 then
+ putStr str >>
+ read_all
+ else
+ putStr "\n*** End of Transfer ***\n" >>
+ sClose s'
+ in
+ read_all
+ in
+ loop
--- /dev/null
+module Main where
+
+import SocketPrim
+import BSD
+import System
+
+main =
+ getArgs >>= \ [host, port, message] ->
+ getProtocolNumber "tcp" >>= \ proto ->
+ socket AF_INET Stream proto >>= \ s ->
+ getHostByName host >>= \ (HostEntry _ _ _ haddrs) ->
+ connect s (SockAddrInet (read port)
+ (head haddrs)) >>
+
+ getPeerName s >>= \ (SockAddrInet _ haddr) ->
+ getHostByAddr AF_INET haddr >>= \ (HostEntry hname _ _ _) ->
+ putStr ("Connected to : " ++ hname ++ "\n") >>
+ writeSocket s message >>
+ shutdown s ShutdownBoth >>
+ sClose s
+
--- /dev/null
+-- Sigbjorn and I don't understand what this test is meant to do
+-- It simply hangs on stdin!
+
+import IO -- 1.3
+
+import System(getArgs)
+
+main = getArgs >>= \ [user,host] ->
+ let username = (user ++ "@" ++ host) in
+ openFile username ReadWriteMode >>= \ cd ->
+ hSetBuffering stdin NoBuffering >>
+ hSetBuffering stdout NoBuffering >>
+ hSetBuffering cd NoBuffering >>
+ hPutStr cd speakString >>
+ speak cd
+
+speakString = "Someone wants to speak with you\n"
+
+speak cd =
+ (hReady cd >>= \ ready ->
+ if ready then (hGetChar cd >>= putChar)
+ else return () >>
+
+ hReady stdin >>= \ ready ->
+ if ready then (getChar >>= hPutChar cd)
+ else return ()) >>
+
+ speak cd
--- /dev/null
+import Posix
+
+main =
+ getParentProcessID >>= \ ppid ->
+ getProcessID >>= \ pid ->
+ putStr "Parent Process ID: " >>
+ print ppid >>
+ putStr "\nProcess ID: " >>
+ print pid >>
+ putStr "\nforking ps uxww" >>
+ print ppid >>
+ putChar '\n' >>
+ forkProcess >>= \ child ->
+ case child of
+ Nothing -> executeFile "ps" True ["uxww" ++ show ppid] Nothing
+ Just x -> doParent x pid
+
+doParent cpid pid =
+ getProcessStatus True False cpid >>
+ putStr "\nChild finished. Now exec'ing ps uxww" >>
+ print pid >>
+ putChar '\n' >>
+ executeFile "ps" True ["uxww" ++ show pid] Nothing
--- /dev/null
+import Posix
+
+main =
+ executeFile "printenv" True [] (Just [("ONE","1"),("TWO","2")])
--- /dev/null
+ONE=1
+TWO=2
--- /dev/null
+import IO
+import Posix
+
+main =
+ openFile "po003.out" WriteMode >>= \ h ->
+ runProcess "pwd" [] Nothing (Just "/usr/tmp") Nothing (Just h) Nothing
--- /dev/null
+import Posix
+import System(ExitCode(..), exitWith)
+
+main =
+ forkProcess >>= \ maybe_pid ->
+ case maybe_pid of
+ Nothing -> raiseSignal floatingPointException
+ _ -> doParent
+
+doParent =
+ getAnyProcessStatus True False >>= \ (Just (pid, tc)) ->
+ case tc of
+ Terminated sig | sig == floatingPointException -> forkChild2
+ _ -> fail (userError "unexpected termination cause")
+
+forkChild2 =
+ forkProcess >>= \ maybe_pid ->
+ case maybe_pid of
+ Nothing -> exitImmediately (ExitFailure 42)
+ _ -> doParent2
+
+doParent2 =
+ getAnyProcessStatus True False >>= \ (Just (pid, tc)) ->
+ case tc of
+ Exited (ExitFailure 42) -> forkChild3
+ _ -> fail (userError "unexpected termination cause (2)")
+
+forkChild3 =
+ forkProcess >>= \ maybe_pid ->
+ case maybe_pid of
+ Nothing -> exitImmediately (ExitSuccess)
+ _ -> doParent3
+
+doParent3 =
+ getAnyProcessStatus True False >>= \ (Just (pid, tc)) ->
+ case tc of
+ Exited ExitSuccess -> forkChild4
+ _ -> fail (userError "unexpected termination cause (3)")
+
+forkChild4 =
+ forkProcess >>= \ maybe_pid ->
+ case maybe_pid of
+ Nothing -> raiseSignal softwareStop
+ _ -> doParent4
+
+doParent4 =
+ getAnyProcessStatus True True >>= \ (Just (pid, tc)) ->
+ case tc of
+ Stopped sig | sig == softwareStop -> enoughAlready pid
+ _ -> fail (userError "unexpected termination cause (4)")
+
+enoughAlready pid =
+ signalProcess killProcess pid >>
+ getAnyProcessStatus True True >>= \ (Just (pid, tc)) ->
+ case tc of
+ Terminated sig | sig == killProcess -> putStr "I'm happy.\n"
+ _ -> fail (userError "unexpected termination cause (5)")
+
--- /dev/null
+I'm happy.
--- /dev/null
+import Posix
+
+main =
+ getEnvVar "TERM" >>= \ term ->
+ putStr term >>
+ putChar '\n' >>
+ setEnvironment [("one","1"),("two","2")] >>
+ getEnvironment >>= \ env ->
+ print env >>
+ putChar '\n' >>
+ setEnvVar "foo" "bar" >>
+ getEnvironment >>= \ env ->
+ print env >>
+ putChar '\n' >>
+ setEnvVar "foo" "baz" >>
+ getEnvironment >>= \ env ->
+ print env >>
+ putChar '\n' >>
+ setEnvVar "fu" "bar" >>
+ getEnvironment >>= \ env ->
+ print env >>
+ putChar '\n' >>
+ removeEnvVar "foo" >>
+ getEnvironment >>= \ env ->
+ print env >>
+ putChar '\n' >>
+ setEnvironment [] >>
+ getEnvironment >>= \ env ->
+ print env >>
+ putChar '\n'
--- /dev/null
+import Posix
+
+main =
+ epochTime >>= \ start ->
+ sleep 5 >>
+ let timeleft = 0 in
+ epochTime >>= \ finish ->
+ putStr "Started: " >>
+ print start >>
+ putStr "\nSlept: " >>
+ print (5 - timeleft) >>
+ putStr "\nFinished: " >>
+ print finish >>
+ putChar '\n'
--- /dev/null
+import Posix
+
+main =
+ installHandler keyboardSignal (Catch doCtrlC) Nothing >>
+ getTerminalAttributes stdInput >>= \ ta ->
+ case (controlChar ta Interrupt) of
+ Nothing -> fixMe ta
+ Just x -> continue x
+
+fixMe ta =
+ putStr "Oops...no interrupt character?\nI can fix that...\n" >>
+ setTerminalAttributes stdInput (withCC ta (Interrupt, '\ETX')) Immediately >>
+ getTerminalAttributes stdInput >>= \ ta ->
+ case (controlChar ta Interrupt) of
+ Nothing -> putStr "...Then again, maybe I can't\n"
+ Just x -> continue x
+
+continue x =
+ putStr "Press '" >>
+ putStr (ccStr x) >>
+ putStr "'.\n" >>
+ awaitSignal Nothing >>
+ putStr "How did I get here?\n"
+
+doCtrlC =
+ putStr "Caught an interrupt.\n"
+
+ccStr '\DEL' = "^?"
+ccStr x
+ | x >= ' ' = [x]
+ | otherwise = ['^', (toEnum (fromEnum x + fromEnum '@'))]
--- /dev/null
+import Posix
+
+main =
+ installHandler realTimeAlarm (Catch alarmclock) Nothing >>
+ putStr "Scheduling an alarm in 5 seconds...\n" >>
+ scheduleAlarm 5 >>
+ putStr "Sleeping one minute.\n" >>
+ sleep 60 >>
+ putStr "How did I get here?\n"
+
+alarmclock =
+ putStr "The alarm went off.\n"
--- /dev/null
+import Posix
+
+main =
+ putStr "Blocking real time alarms.\n" >>
+ blockSignals (addSignal realTimeAlarm emptySignalSet) >>
+ putStr "Scheduling an alarm in 2 seconds...\n" >>
+ scheduleAlarm 2 >>
+ putStr "Sleeping 5 seconds.\n" >>
+ sleep 5 >>
+ getPendingSignals >>= \ ints ->
+ putStr "Checking pending interrupts for RealTimeAlarm\n" >>
+ print (inSignalSet realTimeAlarm ints) >>
+ putChar '\n'
+
--- /dev/null
+import Posix
+
+main =
+ getUserEntryForName "mattson" >>= \ mattson ->
+ getUserEntryForName "partain" >>= \ partain ->
+ putStr (ue2String mattson) >>
+ putChar '\n' >>
+ putStr (ue2String partain) >>
+ putChar '\n' >>
+ getUserEntryForID (userID mattson) >>= \ muid ->
+ getUserEntryForID (userID partain) >>= \ puid ->
+ putStr (ue2String muid) >>
+ putChar '\n' >>
+ putStr (ue2String puid) >>
+ putChar '\n'
+
+ue2String ue =
+ name ++ (':' : (show uid) ++ (':' : (show gid) ++ (':' : home ++ (':' : shell))))
+ where
+ name = userName ue
+ uid = userID ue
+ gid = userGroupID ue
+ home = homeDirectory ue
+ shell = userShell ue
--- /dev/null
+mattson:104:401:/users/fp/mattson:/bin/csh
+partain:184:401:/users/fp/partain:/usr/local/bin/tcsh
+mattson:104:401:/users/fp/mattson:/bin/csh
+partain:184:401:/users/fp/partain:/usr/local/bin/tcsh
--- /dev/null
+import Posix
+
+main =
+ getGroupEntryForName "grasp" >>= \ grasp ->
+ getGroupEntryForName "staff" >>= \ staff ->
+ putStr (ge2String grasp) >>
+ putChar '\n' >>
+ putStr (ge2String staff) >>
+ putChar '\n' >>
+ getGroupEntryForID (groupID grasp) >>= \ guid ->
+ getGroupEntryForID (groupID staff) >>= \ suid ->
+ putStr (ge2String guid) >>
+ putChar '\n' >>
+ putStr (ge2String suid) >>
+ putChar '\n'
+
+ge2String ge =
+ name ++ (':' : (show gid) ++ (':' : members))
+ where
+ name = groupName ge
+ gid = groupID ge
+ members = foldr (\x y -> x ++ (',' : y)) "" (groupMembers ge)
--- /dev/null
+grasp:401:andre,andy,ap,areid,cvh,dm,dnt,gnik,grasp,hwloidl,jan,johan,jonathan,jtod,kh,laszlo,mattson,partain,sansom,satnam,sewardj,sharpkm,simonm,simonpj,sof,trinder,wadler,
+staff:9:aileen,alexa,ali,alison,andy,anne,ansftp,aran,arthur,audit,bill,botech,bw,carol,carron,cathy,conftp,cs2head,cvh,dam,darryn,daw,dcg,debbie,del,deptlib,dkm,dlg,dm,dnt,ellen,f131mgr,fabio,fairouz,faxback,fido,finance,fiona,footsie,george,gilbert,gilles,gsm,handbook,harrismi,helen,hme,hmg,huw,iain,id,igr,iii,imis-doc,imm,inei,infoman,ingres,inventdb,irfest,isabel,jacksonn,jacqui,james,janice,jej,jim,jl,jmm,johnson,jon,jstack,jtod,jwp,keith,kempj,kh,kieran,kimb,kirsten,kmssys,laurent,lewis,lisa,lizbeth,logiej,love,lyons,maclib,macneisd,margaret,mark,mary,mattson,meurig,mjj,mmi,monica,mossin,mpa,muffy,nk,norman,partain,pd,pdg,pete,pp,ps,quintin,rab,ray,rdm,reh,replib,rff,rffingres,rich,rios,rjw,rn,ron,ruffin,rwi,sanderso,sandy,sansom,satnam,sheila,sid,simonm,simonpj,slurry,softlib,stephen,steve,stevem,stuart,support,susan,tania,tech,teresa,tfm,tommyk,tracy,trinder,types,typesftp,wadler,wf,xadmin,
+grasp:401:andre,andy,ap,areid,cvh,dm,dnt,gnik,grasp,hwloidl,jan,johan,jonathan,jtod,kh,laszlo,mattson,partain,sansom,satnam,sewardj,sharpkm,simonm,simonpj,sof,trinder,wadler,
+staff:9:aileen,alexa,ali,alison,andy,anne,ansftp,aran,arthur,audit,bill,botech,bw,carol,carron,cathy,conftp,cs2head,cvh,dam,darryn,daw,dcg,debbie,del,deptlib,dkm,dlg,dm,dnt,ellen,f131mgr,fabio,fairouz,faxback,fido,finance,fiona,footsie,george,gilbert,gilles,gsm,handbook,harrismi,helen,hme,hmg,huw,iain,id,igr,iii,imis-doc,imm,inei,infoman,ingres,inventdb,irfest,isabel,jacksonn,jacqui,james,janice,jej,jim,jl,jmm,johnson,jon,jstack,jtod,jwp,keith,kempj,kh,kieran,kimb,kirsten,kmssys,laurent,lewis,lisa,lizbeth,logiej,love,lyons,maclib,macneisd,margaret,mark,mary,mattson,meurig,mjj,mmi,monica,mossin,mpa,muffy,nk,norman,partain,pd,pdg,pete,pp,ps,quintin,rab,ray,rdm,reh,replib,rff,rffingres,rich,rios,rjw,rn,ron,ruffin,rwi,sanderso,sandy,sansom,satnam,sheila,sid,simonm,simonpj,slurry,softlib,stephen,steve,stevem,stuart,support,susan,tania,tech,teresa,tfm,tommyk,tracy,trinder,types,typesftp,wadler,wf,xadmin,
--- /dev/null
+import Posix
+import IO -- 1.3
+
+main =
+ createFile "po012.out" stdFileMode >>= \ fd ->
+ installHandler processStatusChanged (Catch (reap1 fd)) Nothing >>
+ ls >>
+ awaitSignal Nothing
+
+ls =
+ runProcess "ls" ["-l"] Nothing Nothing Nothing Nothing Nothing
+
+reap1 fd =
+ hPutStrLn stderr "Reaper1" >>
+ getAnyProcessStatus True False >>
+ installHandler processStatusChanged (Catch (reap2 fd)) Nothing >>
+ fdWrite fd (take 666 (repeat 'x')) >>
+ ls >>
+ awaitSignal Nothing
+
+reap2 fd =
+ hPutStrLn stderr "Reaper2" >>
+ getAnyProcessStatus True False >>
+ installHandler processStatusChanged (Catch (reap3 fd)) Nothing >>
+ setFileMode "po012.out"
+ (foldr1 unionFileModes [ownerReadMode,ownerWriteMode,groupReadMode,otherReadMode]) >>
+ ls >>
+ awaitSignal Nothing
+
+reap3 fd =
+ hPutStrLn stderr "Reaper3" >>
+ getAnyProcessStatus True False >>
+ installHandler processStatusChanged (Catch (reap4 fd)) Nothing >>
+ setFileTimes "po012.out" 0 0 >>
+ ls >>
+ awaitSignal Nothing
+
+reap4 fd =
+ hPutStrLn stderr "Reaper4" >>
+ getAnyProcessStatus True False >>
+ installHandler processStatusChanged (Catch (reap5 fd)) Nothing >>
+ --removeLink "po012.out" >>
+ ls >>
+ awaitSignal Nothing
+
+reap5 fd =
+ hPutStrLn stderr "Reaper5" >>
+ getAnyProcessStatus True False >>
+ fdSeek fd SeekFromEnd 0 >>= \ bytes ->
+ if bytes == 666 then
+ fdSeek fd AbsoluteSeek 0 >>
+ hPutStrLn stderr "Reaper5" >>
+ fdRead fd 666 >>= \ (str, _) ->
+ if str == (take 666 (repeat 'x')) then
+ putStr "Okay\n"
+ else
+ putStr "Read failed\n"
+ else
+ putStr "Seek returned wrong size\n"
--- /dev/null
+\begin{code}
+module Main(main) where
+
+--import PreludeGlaST
+--old:import GHCio(stThen)
+--old:import PreludeGlaMisc
+
+main = makeStablePtr test >>= \ stablePtr ->
+ ((_casm_GC_ ``SaveAllStgRegs(); test1(%0); RestoreAllStgRegs();'' stablePtr)
+ :: PrimIO ())
+ >>= \ _ ->
+ return ()
+
+test :: IO Int
+test =
+ let f x = sum [1..x]
+ f :: Int -> Int
+ in
+ _ccall_ printf
+ "The stable pointer has just been used to print this number %d\n" (f 100)
+ >>= \ _ ->
+ return 5
+\end{code}
+
+This is a rather exciting experiment in using the new call
+@makeStablePtr#@ and @performIO@. It doesn't do much but it took an
+incredible effort to get it to do it.
+
+\begin{code}[C-code]
+#define NULL_REG_MAP
+#include "stgdefs.h"
+
+int
+test1( stableIOPtr )
+ StgStablePtr stableIOPtr;
+{
+ int i;
+ int result;
+
+ printf("Using stable pointer %x\n", stableIOPtr);
+
+ for( i = 0; i != 10; i = i + 1 ) {
+ printf( "Calling stable pointer for %dth time\n", i );
+ performIO( stableIOPtr );
+ printf( "Returned after stable pointer\n" );
+ }
+
+ return 1;
+}
+\end{code}
--- /dev/null
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+SRC_HC_OPTS += -fglasgow-exts
+include $(TOP)/mk/target.mk
+
--- /dev/null
+#define UpdateStgRegs _SaveStgRegs()
+#define ReloadStgRegs _RestoreStgRegs()
projects / ghc-hetmet.git / commitdiff