Commit 2c0797cc authored by bbr's avatar bbr
Browse files

small conflicts merged

Merge branch 'gui' into oracle

Conflicts:

	src/lib/All_Libraries.curry
	src/lib/ExternalFunctionsIO.hs
	src/lib/ExternalFunctionsPrelude.hs
	src/lib/IO.curry
parents b83f5bc1 48dcf1bb
......@@ -18,7 +18,6 @@ module All_Libraries (
--module GUI,
module Integer,
module IO,
--module IOChoice,
module IOExts,
--module KeyDB,
module List,
......@@ -94,7 +93,6 @@ import Float
--import GUI
import Integer
import IO
--import IOChoice
import IOExts
--import KeyDB
import List(find)
......
......@@ -16,6 +16,22 @@ import Char
import List(delete)
import Time
import System
import Directory
-- names of lock/logfiles
pidfile, logfile, lockfile :: String
pidfile="/tmp/PAKCS_CPNSD_PID"
logfile="/tmp/PAKCS_CPNSD_LOG"
lockfile="/tmp/PAKCS_CPNSD.LOCK" -- for startup control
{-
initialize :: IO ()
initialize = do
ex <- doesFileExist pidfile
if ex then do
readFile pidfile >>=
-}
-- If we connect to a port with symbolic name pn, we first connect
-- to the CPNS of the host named by pn to get the physical socket
......
......@@ -4,14 +4,23 @@ import Curry
import CurryPrelude
import System.IO
type C_Handle = Prim Handle
-- somehow using an either type did not get the curry class for prim through.
data IOHandle = One Handle | Two Handle Handle deriving (Show,Eq)
type C_Handle = Prim IOHandle
instance Read Handle where
inputHandle, outputHandle :: IOHandle -> Handle
inputHandle (One h) = h
inputHandle (Two h _) = h
outputHandle (One h) = h
outputHandle (Two _ h) = h
instance Read IOHandle where
readsPrec = error "reading Handle"
instance Generate Handle where
genFree _ = error "free variable of type IO.Handle"
genPattern _ = error "free variable of type IO.Handle"
instance Generate IOHandle where
genFree _ = error "free variable of type IO-Handle"
genPattern _ = error "narrowing type IO.Handle"
......@@ -6,6 +6,7 @@ import InstancesIO
import qualified System.IO as SI
import Control.Concurrent
import qualified Control.Exception as CE
instance ConvertCH C_IOMode SI.IOMode where
toCurry SI.ReadMode = C_ReadMode
......@@ -26,31 +27,64 @@ instance ConvertCH C_SeekMode SI.SeekMode where
fromCurry C_SeekFromEnd = SI.SeekFromEnd
stdin :: Result C_Handle
stdin _ = PrimValue SI.stdin
stdin _ = PrimValue (One SI.stdin)
stdout :: Result C_Handle
stdout _ = PrimValue SI.stdout
stdout _ = PrimValue (One SI.stdout)
stderr :: Result C_Handle
stderr _ = PrimValue SI.stderr
stderr _ = PrimValue (One SI.stderr)
prim_openFile :: List C_Char -> C_IOMode -> Result (C_IO C_Handle)
prim_openFile = ioFunc2 SI.openFile
prim_openFile = ioFunc2 (\ s m -> do
h <- SI.openFile s m
return (One h))
prim_hClose :: C_Handle -> Result (C_IO T0)
prim_hClose = ioFunc1 SI.hClose
prim_hClose = ioFunc1 (\ eh -> case eh of
One h -> SI.hClose h
Two h1 h2 -> SI.hClose h1 >> SI.hClose h2)
prim_hFlush :: C_Handle -> Result (C_IO T0)
prim_hFlush = ioFunc1 SI.hFlush
prim_hFlush = ioFunc1 (SI.hFlush . outputHandle)
prim_hIsEOF :: C_Handle -> Result (C_IO C_Bool)
prim_hIsEOF = ioFunc1 SI.hIsEOF
prim_hIsEOF = ioFunc1 (SI.hIsEOF . inputHandle)
prim_hSeek :: C_Handle -> C_SeekMode -> C_Int -> Result (C_IO T0)
prim_hSeek = ioFunc3 SI.hSeek
prim_hSeek = ioFunc3 (\ h -> SI.hSeek (inputHandle h))
prim_hWaitForInput :: C_Handle -> C_Int -> Result (C_IO C_Bool)
prim_hWaitForInput = ioFunc2 SI.hWaitForInput
prim_hWaitForInput = ioFunc2 (\ h -> myhWaitForInput (inputHandle h))
myhWaitForInput :: SI.Handle -> Int -> IO Bool
myhWaitForInput h i =
if i < 0
then SI.hIsEOF h >>= return . not
else SI.hWaitForInput h i
selectHandle :: [IOHandle] -> Int -> IO Int
selectHandle handles t = do
mvar <- newEmptyMVar
threads <- mapM (\ (i,h) -> forkIO (waitOnHandle (inputHandle h) i t mvar))
(zip [0..] handles)
inspectRes (length handles) mvar threads
inspectRes :: Int -> MVar (Maybe Int) -> [ThreadId] -> IO Int
inspectRes 0 _ _ = return (-1)
inspectRes n mvar threads = do
res <- readMVar mvar
case res of
Nothing -> inspectRes (n-1) mvar threads
Just v -> mapM_ killThread threads >> return v
waitOnHandle :: SI.Handle -> Int -> Int -> MVar (Maybe Int) -> IO ()
waitOnHandle h v t mvar = do
ready <- myhWaitForInput h t
putMVar mvar (if ready then Just v else Nothing)
prim_hWaitForInputs :: List C_Handle -> C_Int -> Result (C_IO C_Int)
prim_hWaitForInputs = ioFunc2 selectHandle
selectHandle :: [SI.Handle] -> Int -> IO Int
selectHandle handles t = do
......@@ -69,14 +103,14 @@ prim_hWaitForInputs :: List C_Handle -> C_Int -> Result (C_IO C_Int)
prim_hWaitForInputs = ioFunc2 selectHandle
prim_hGetChar :: C_Handle -> Result (C_IO C_Char)
prim_hGetChar = ioFunc1 SI.hGetChar
prim_hGetChar = ioFunc1 (SI.hGetChar . inputHandle)
prim_hPutChar :: C_Handle -> C_Char -> Result (C_IO T0)
prim_hPutChar = ioFunc2 SI.hPutChar
prim_hPutChar = ioFunc2 (SI.hPutChar . outputHandle)
prim_hIsReadable :: C_Handle -> Result (C_IO C_Bool)
prim_hIsReadable = ioFunc1 SI.hIsReadable
prim_hIsReadable = ioFunc1 (SI.hIsReadable . inputHandle)
prim_hIsWritable :: C_Handle -> Result (C_IO C_Bool)
prim_hIsWritable = ioFunc1 SI.hIsWritable
prim_hIsWritable = ioFunc1 (SI.hIsWritable . outputHandle)
module ExternalFunctionsIOChoice where
import Curry
import CurryPrelude
import CurryIO
import Control.Concurrent
import System.IO
import Network
selectHandle :: Int -> [Handle] -> IO (Maybe Int)
selectHandle t has = do
mvar <- newEmptyMVar
threads <- mapM (\ (i,h) -> forkIO (waitOnHandle h i t mvar)) (zip [0..] has)
res <- readMVar mvar
mapM_ killThread threads
return res
waitOnHandle :: Handle -> Int -> Int -> MVar (Maybe Int) -> IO ()
waitOnHandle h v t mvar = do
ready <- hWaitForInput h t
putMVar mvar (if ready then Just v else Nothing)
prim_hSelectHandle :: C_Int -> List C_Handle -> Result (C_IO (C_Maybe C_Int))
prim_hSelectHandle = ioFunc2 selectHandle
......@@ -10,7 +10,8 @@ import System.Process
import Network
import qualified Network.Socket as SO
import System.IO.Unsafe
import Control.Concurrent
import System.IO
instance Eq (List C_Char) where
List == List = True
......@@ -33,9 +34,19 @@ setAssocs as = Ref.writeIORef assocs as
prim_execCmd :: List C_Char -> Result (C_IO (T3 C_Handle C_Handle C_Handle))
prim_execCmd = ioFunc1 (\s -> do
(h1,h2,h3,_) <- runInteractiveCommand s
return (h1,h2,h3))
prim_connectToCmd = error "connectToCmd not yet implemented"
return (One h1,One h2,One h3))
prim_connectToCmd :: List C_Char -> Result (C_IO C_Handle)
prim_connectToCmd = ioFunc1 (\s -> do
(hin,hout,herr,_) <- runInteractiveCommand s
forkIO (forwardError herr)
return (Two hout hin))
forwardError :: Handle -> IO ()
forwardError h = do
eof <- hIsEOF h
if eof then return ()
else hGetLine h >>= hPutStrLn System.IO.stderr >> forwardError h
prim_setAssoc :: List C_Char -> List C_Char -> Result (C_IO T0)
prim_setAssoc key val = ioFunc0 (do
......
module ExternalFunctionsPrelude where
import Prelude hiding ((==),(>>=),return)
import Prelude hiding ((==),(>>=),return,catch)
import qualified Prelude ((==),(>>=),return)
import Data.Char (ord,chr)
import Curry
......@@ -10,6 +10,7 @@ import DataPrelude
import System.IO.Unsafe
import InstancesPrelude
import Data.IORef
import Control.Exception (catch)
import qualified Debug.Trace as D
......@@ -296,8 +297,32 @@ prim_writeFile = ioFunc2 writeFile
prim_appendFile :: C_String -> C_String -> Result (C_IO T0)
prim_appendFile = ioFunc2 appendFile
catchFail :: C_IO a -> C_IO a -> Result (C_IO a)
catchFail act err _ = error "catchFail not supported yet" --catch act (const err)
catchFail :: Curry a => C_IO a -> C_IO a -> Result (C_IO a)
catchFail (C_IO act) err _ =
C_IO (\ st -> catch (act st) (const (hnfCTC exec2 err st)))
catchFail (C_IOFail _) err _ = err
catchFail (C_IOOr ref bs) err (Just st) = case fromStore st ref of
Nothing -> searchValCatch (zipWith (mkChoice st ref) [0..] bs) err
Just i -> catchFail (bs !! i) err (Just st)
catchFail (C_IOSusp _ contRef) err _ = C_IO (\ st -> do
cont <- readIORef contRef
case cont () of
Nothing -> hnfCTC exec2 err st
Just v -> hnfCTC exec2 (catchFail v err st) st)
searchValCatch :: Curry a => [(Store,C_IO a)] -> C_IO a -> C_IO a
searchValCatch [] err = err
searchValCatch ((st,C_IO act) : _) err = catchFail (C_IO act) err (Just st)
searchValCatch ((_ ,C_IOFail _) : xs) err = searchValCatch xs err
searchValCatch ((st,C_IOOr ref bs) : xs) err =
searchValCatch (zipWith (mkChoice st ref) [0..] bs ++ xs) err
searchValCatch ((_,C_IOSusp _ contRef) : xs) err = C_IO (\ st0 -> do
cont <- readIORef contRef
case cont () of
Nothing -> hnfCTC exec2 (searchValCatch xs err) st0
Just v -> hnfCTC exec2 (searchValCatch xs err) st0)
prim_show :: (Show a,Curry a) => a -> Result C_String
prim_show x _ = toCurry (show x)
......
......@@ -33,17 +33,17 @@ prim_socketListen = CurryPrelude.ioFunc2 listen
prim_socketAccept :: C_Socket -> Result (C_IO (T2 (List C_Char) C_Handle))
prim_socketAccept = ioFunc1 (\ s -> Network.accept s >>= \ (h,s,_) -> return (s,h))
prim_socketAccept = ioFunc1 (\ s -> Network.accept s >>= \ (h,s,_) -> return (s,One h))
prim_waitForSocketAccept :: C_Socket -> C_Int -> Result (C_IO (C_Maybe (T2 (List C_Char) C_Handle)))
prim_waitForSocketAccept = CurryPrelude.ioFunc2 wait
wait :: Socket -> Int -> IO (Maybe (String,Handle))
wait :: Socket -> Int -> IO (Maybe (String,IOHandle))
wait s t = do
mv <- newEmptyMVar
tacc <- forkIO (Network.accept s >>= \ (h,s,_) -> putMVar mv (Just (s,h)))
tacc <- forkIO (Network.accept s >>= \ (h,s,_) -> putMVar mv (Just (s,One h)))
ttim <- forkIO (threadDelay (t*1000) >> putMVar mv Nothing)
res <- takeMVar mv
maybe (killThread tacc) (\_ -> killThread ttim) res
......@@ -53,6 +53,6 @@ wait s t = do
prim_connectToSocket :: List C_Char -> C_Int -> Result (C_IO C_Handle)
prim_connectToSocket = ioFunc2 connectTo
prim_connectToSocket = ioFunc2 (\ s i -> connectTo s i >>= return . One)
......@@ -8,6 +8,7 @@ import qualified System.CPUTime as SC
import System.Cmd
import System.Exit
import qualified Network.BSD as NB
import System.Posix.Process
instance ConvertCH C_Int ExitCode where
toCurry ExitSuccess = toCurry (0::Integer)
......@@ -33,7 +34,7 @@ getHostname :: Result (C_IO (List C_Char))
getHostname = ioFunc0 NB.getHostName
getPID :: Result (C_IO C_Int)
getPID = error "getPID not provided"
getPID = ioFunc0 (getProcessID >>= return . toInteger)
getProgName :: Result (C_IO (List C_Char))
getProgName = ioFunc0 (Curry.getProgName)
......
[ForFunction "prim_hSelectHandle"]
\ No newline at end of file
......@@ -88,6 +88,7 @@ fourToInt C_F0 = 0
fourToInt C_F1 = 1
fourToInt C_F2 = 2
fourToInt C_F3 = 3
fourToInt x = error $ "fourToInt "++show x
intToFour :: Int -> C_Four
intToFour 0 = C_F0
......@@ -107,7 +108,7 @@ charToSc c = SearchChar (intToFour d64) (intToFour d16) (intToFour d4) (intToFou
(d4,m4) = divMod m16 4
instance Show C_Four where
show _ = error "you won't see four"
show _ = error "probably someone used $# instead of $## for an external character function"
instance Show C_Char where
show (C_Char c) = show c
......@@ -669,13 +670,13 @@ instance Curry C_Four where
strEq C_F1 C_F1 _ = strEqSuccess
strEq C_F2 C_F2 _ = strEqSuccess
strEq C_F3 C_F3 _ = strEqSuccess
strEq x0 _ _ = strEqFail(typeName(x0))
strEq x0 _ _ = strEqFail(typeName(x0))
eq C_F0 C_F0 _ = C_True
eq C_F1 C_F1 _ = C_True
eq C_F2 C_F2 _ = C_True
eq C_F3 C_F3 _ = C_True
eq _ _ _ = C_False
eq _ _ _ = C_False
propagate _ C_F0 _ = C_F0
propagate _ C_F1 _ = C_F1
......
This diff is collapsed.
......@@ -74,7 +74,7 @@ isEOF = hIsEOF stdin
--- the position is set relative to the beginning of the file,
--- to the end of the file, or to the current position, respectively.
hSeek :: Handle -> SeekMode -> Int -> IO ()
hSeek h sm pos = ((prim_hSeek $# h) $# sm) $# pos
hSeek h sm pos = ((prim_hSeek $# h) $# sm) $## pos
prim_hSeek :: Handle -> SeekMode -> Int -> IO ()
prim_hSeek external
......@@ -87,7 +87,7 @@ prim_hSeek external
--- @param timeout - milliseconds to wait for input (< 0 : no time out)
hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput h i = (prim_hWaitForInput $# h) $# i
hWaitForInput h i = (prim_hWaitForInput $# h) $## i
prim_hWaitForInput :: Handle -> Int -> IO Bool
prim_hWaitForInput external
......@@ -102,7 +102,7 @@ prim_hWaitForInput external
--- if (handles!!i) has data available
hWaitForInputs :: [Handle] -> Int -> IO Int
hWaitForInputs handles timeout =
(prim_hWaitForInputs $## handles) $# timeout
(prim_hWaitForInputs $## handles) $## timeout
prim_hWaitForInputs :: [Handle] -> Int -> IO Int
prim_hWaitForInputs external
......@@ -142,7 +142,7 @@ getContents = hGetContents stdin
--- Puts a character to an output handle.
hPutChar :: Handle -> Char -> IO ()
hPutChar h c = (prim_hPutChar $# h) $# c
hPutChar h c = (prim_hPutChar $# h) $## c
prim_hPutChar :: Handle -> Char -> IO ()
prim_hPutChar external
......
--------------------------------------------------------------
--- Library for IO operations on handles
--- that involve some kind of commited choice.
---
--- @author Bernd Braßel, Frank Huch
--- @version July 2006
--------------------------------------------------------------
module IOChoice (selectHandle) where
import IO
--- Waits until input is available on at least one of the given handles.
--- If no input is available within t milliseconds, it returns Nothing,
--- otherwise it returns the handle with the available data and the
--- corresponding value.
--- @param timeout - milliseconds to wait for input (< 0 : no time out)
--- @param handles - a list of handles for input streams and associated values
--- @return Nothing if no input is available within the time out,
--- otherwise (Just i) if (handles!!i) has data available
selectHandle :: Int -> [(Handle,a)] -> IO (Maybe a)
selectHandle timeout handles = do
rs <- mapIO isReady handles
let readyHandles = filter fst rs
if null readyHandles
then do nr <- prim_hSelectHandle timeout (map fst handles)
return (maybe Nothing (Just . snd . (handles !!)) nr)
else return (Just (snd (snd (head readyHandles))))
where
isReady (h,v) = do b <- hReady h
return (b,(h,v))
prim_hSelectHandle :: Int -> [Handle] -> IO (Maybe Int)
prim_hSelectHandle external
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment