Commit 340fd1c7 authored by Michael Hanus 's avatar Michael Hanus

Packages updated

parent 7ff71421
......@@ -11,9 +11,11 @@
--- Curry syntax (`showCurryType`, `showCurryExpr`,...).
---
--- @author Michael Hanus
--- @version September 2016
--- @version March 2019
------------------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module FlatCurry.Show(showFlatProg,showFlatType,showFlatFunc,
showCurryType,isClassContext,
showCurryExpr,showCurryId,showCurryVar)
......@@ -35,13 +37,16 @@ showFlatProg (Prog modname imports types funcs ops) =
++ "\n " ++ showFlatList showFlatOp ops
++ "\n )\n"
showFlatVisibility :: Visibility -> String
showFlatVisibility Public = " Public "
showFlatVisibility Private = " Private "
showFlatFixity :: Fixity -> String
showFlatFixity InfixOp = " InfixOp "
showFlatFixity InfixlOp = " InfixlOp "
showFlatFixity InfixrOp = " InfixrOp "
showFlatOp :: OpDecl -> String
showFlatOp (Op name fix prec) =
"(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")"
......@@ -55,6 +60,7 @@ showFlatType (TypeSyn name vis tpars texp) =
++ showFlatList show tpars
++ showFlatTypeExpr texp ++ ")"
showFlatCons :: ConsDecl -> String
showFlatCons (Cons cname arity vis types) =
"(Cons " ++ show cname ++ " " ++ show arity
++ showFlatVisibility vis
......@@ -67,6 +73,7 @@ showFlatFunc (Func name arity vis ftype rl) =
"\n " ++ showFlatTypeExpr ftype ++
"\n " ++ showFlatRule rl ++ ")"
showFlatRule :: Rule -> String
showFlatRule (Rule params expr) =
" (Rule " ++ showFlatList show params
++ showFlatExpr expr ++ ")"
......@@ -109,13 +116,16 @@ showFlatExpr (Case Flex e bs) =
showFlatExpr (Typed e ty) =
"(Typed " ++ showFlatExpr e ++ ' ' : showFlatTypeExpr ty ++ ")"
showFlatLit :: Literal -> String
showFlatLit (Intc i) = "(Intc " ++ show i ++ ")"
showFlatLit (Floatc f) = "(Floatc " ++ show f ++ ")"
showFlatLit (Charc c) = "(Charc " ++ show c ++ ")"
showFlatBranch :: BranchExpr -> String
showFlatBranch (Branch p e) = "(Branch " ++ showFlatPattern p
++ showFlatExpr e ++ ")"
showFlatPattern :: Pattern -> String
showFlatPattern (Pattern qn xs) =
"(Pattern " ++ show qn
++ showFlatList show xs ++ ")"
......@@ -127,7 +137,7 @@ showFlatList :: (a->String) -> [a] -> String
showFlatList format elems = " [" ++ showFlatListElems format elems ++ "] "
showFlatListElems :: (a->String) -> [a] -> String
showFlatListElems format elems = concat (intersperse "," (map format elems))
showFlatListElems format elems = intercalate "," (map format elems)
------------------------------------------------------------------------------
......@@ -139,7 +149,7 @@ showFlatListElems format elems = concat (intersperse "," (map format elems))
--- @param texpr - the FlatCurry type expression to be formatted
--- @return the String representation of the formatted type expression
showCurryType :: ((String,String) -> String) -> Bool -> TypeExpr -> String
showCurryType :: (QName -> String) -> Bool -> TypeExpr -> String
showCurryType tf nested texp = case texp of
FuncType t1 t2 -> maybe (showCurryType_ tf nested texp)
(\ (cn,cv) -> showBracketsIf nested $
......@@ -198,7 +208,7 @@ isFuncType (ForallType _ te) = isFuncType te
--- @param expr - the FlatCurry expression to be formatted
--- @return the String representation of the formatted expression
showCurryExpr :: ((String,String) -> String) -> Bool -> Int -> Expr -> String
showCurryExpr :: (QName -> String) -> Bool -> Int -> Expr -> String
showCurryExpr _ _ _ (Var n) = showCurryVar n
......@@ -219,7 +229,7 @@ showCurryExpr tf nested b (Comb ct cf [e1,e2])
= if isStringConstant (Comb ct cf [e1,e2])
then "\"" ++ showCurryStringConstant (Comb ct cf [e1,e2]) ++ "\""
else "[" ++
concat (intersperse "," (showCurryFiniteList tf b (Comb ct cf [e1,e2])))
intercalate "," (showCurryFiniteList tf b (Comb ct cf [e1,e2]))
++ "]"
| snd cf == "(,)" -- pair constructor?
= "(" ++ showCurryExpr tf False b e1 ++ "," ++
......@@ -237,7 +247,7 @@ showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es))
sceBlanks b ++ " else " ++ showCurryExpr tf False (b+2) e3)
| take 2 (snd cf) == "(," -- tuple constructor?
= "(" ++
concat (intersperse "," (map (showCurryExpr tf False b) (e1:e2:e3:es)))
intercalate "," (map (showCurryExpr tf False b) (e1:e2:e3:es))
++ ")"
| otherwise
= showBracketsIf nested
......@@ -246,15 +256,17 @@ showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es))
showCurryExpr tf nested b (Let bindings exp) =
showBracketsIf nested
("\n"++sceBlanks b++"let " ++ concat (intersperse ("\n "++sceBlanks b)
(map (\ (x,e)->showCurryVar x ++" = "++showCurryExpr tf False (b+4) e) bindings)) ++
("\n"++sceBlanks b++" in ") ++ showCurryExpr tf False (b+4) exp)
("\n" ++ sceBlanks b ++ "let " ++
intercalate ("\n " ++ sceBlanks b)
(map (\ (x,e) -> showCurryVar x ++ " = " ++
showCurryExpr tf False (b+4) e) bindings) ++
("\n" ++ sceBlanks b ++ " in ") ++ showCurryExpr tf False (b+4) exp)
showCurryExpr tf nested b (Free [] e) = showCurryExpr tf nested b e
showCurryExpr tf nested b (Free (x:xs) e) =
showBracketsIf nested
("let " ++ concat (intersperse "," (map showCurryVar (x:xs))) ++
("let " ++ intercalate "," (map showCurryVar (x:xs)) ++
" free in " ++ showCurryExpr tf False b e)
showCurryExpr tf nested b (Or e1 e2) =
......@@ -269,19 +281,24 @@ showCurryExpr tf nested b (Case ctype e cs) =
showCurryElems (showCurryCase tf (b+2)) cs ++ sceBlanks b)
showCurryExpr tf nested b (Typed e ty) =
showBracketsIf nested (showCurryExpr tf True b e ++ " :: " ++ showCurryType tf False ty)
showBracketsIf nested
(showCurryExpr tf True b e ++ " :: " ++ showCurryType tf False ty)
showCurryVar :: Show a => a -> String
showCurryVar i = "v" ++ show i
--- Shows an identifier in Curry form. Thus, operators are enclosed in brackets.
showCurryId :: String -> String
showCurryId name | isAlpha (head name) = name
| name == "[]" = name
| otherwise = ('(':name)++")"
showCurryLit :: Literal -> String
showCurryLit (Intc i) = show i
showCurryLit (Floatc f) = show f
showCurryLit (Charc c) = show c
showCurryCase :: (QName -> String) -> Int -> BranchExpr -> String
showCurryCase tf b (Branch (Pattern l vs) e) =
sceBlanks b ++ showPattern (tf l) vs
++ " -> " ++ showCurryExpr tf False b e ++ "\n"
......@@ -296,38 +313,43 @@ showCurryCase tf b (Branch (Pattern l vs) e) =
else showCurryVar x1 ++ " " ++ c ++ " " ++ showCurryVar x2
showPattern c (x1:x2:x3:xs) =
if take 2 c == "(," -- tuple constructor?
then "("++ concat (intersperse "," (map showCurryVar (x1:x2:x3:xs))) ++")"
then "(" ++ intercalate "," (map showCurryVar (x1:x2:x3:xs)) ++ ")"
else c ++ " " ++ showCurryElems showCurryVar (x1:x2:x3:xs)
showCurryCase tf b (Branch (LPattern l) e) =
sceBlanks b ++ showCurryLit l ++ " "
++ " -> " ++ showCurryExpr tf False b e ++ "\n"
showCurryFiniteList _ _ (Comb _ ("Prelude","[]") []) = []
showCurryFiniteList :: (QName -> String) -> Int -> Expr -> [String]
showCurryFiniteList _ _ (Comb _ ("Prelude","[]") []) = []
showCurryFiniteList tf b (Comb _ ("Prelude",":") [e1,e2]) =
showCurryExpr tf False b e1 : showCurryFiniteList tf b e2
-- show a string constant
showCurryStringConstant :: Expr -> String
showCurryStringConstant (Comb _ ("Prelude","[]") []) = []
showCurryStringConstant (Comb _ ("Prelude",":") [e1,e2]) =
showCharExpr e1 ++ showCurryStringConstant e2
showCharExpr :: Expr -> String
showCharExpr (Lit (Charc c))
| c=='"' = "\\\""
| c=='\'' = "\\\'"
| c=='\n' = "\\n"
| o < 32 || o > 126 =
['\\',chr(o `div` 100 + 48), chr(((o `mod` 100) `div` 10 + 48)),chr(o `mod` 10 + 48)]
['\\', chr (o `div` 100 + 48), chr (((o `mod` 100) `div` 10 + 48)),
chr(o `mod` 10 + 48)]
| otherwise = [c]
where
o = ord c
showCurryElems :: (a->String) -> [a] -> String
showCurryElems format elems =
concat (intersperse " " (map format elems))
showCurryElems :: (a -> String) -> [a] -> String
showCurryElems format elems = intercalate " " (map format elems)
showBracketsIf :: Bool -> String -> String
showBracketsIf nested s = if nested then '(' : s ++ ")" else s
sceBlanks :: Int -> String
sceBlanks b = take b (repeat ' ')
-- Is the expression a finite list (with an empty list at the end)?
......@@ -342,6 +364,7 @@ isFiniteList (Let _ _) = False
isFiniteList (Free _ _) = False
isFiniteList (Or _ _) = False
isFiniteList (Case _ _ _) = False
isFiniteList (Typed e _) = isFiniteList e
-- Is the expression a string constant?
isStringConstant :: Expr -> Bool
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiParamTypeClasses, CPP #-}
import Control.Concurrent
import Control.Monad (when)
import System.IO
#if __GLASGOW_HASKELL__ < 780
import Network
#endif
import Network.Socket hiding (sClose)
type C_Socket = PrimData Socket
-------------------------------------------------
#if __GLASGOW_HASKELL__ < 780
acceptOld :: Socket -> IO (Handle, HostName, PortNumber)
acceptOld = Network.accept
instance ConvertCurryHaskell Curry_Prelude.C_Int PortID where
toCurry (PortNumber i) = toCurry (toInteger i)
fromCurry i = PortNumber (fromInteger (fromCurry i))
external_d_C_prim_listenOn :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Socket
external_d_C_prim_listenOn i _ _ = toCurry listenOn i
external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket)
external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort
where
listenOnFreshPort :: IO (PortID,Socket)
listenOnFreshPort = do
s <- listenOn (PortNumber aNY_PORT)
p <- Network.socketPort s
p <- socketPort s
return (p,s)
-------------------------------------------------
#else
-------------------------------------------------
acceptOld :: Socket -> IO (Handle, HostName, PortNumber)
acceptOld sock = do (s, addr) <- Network.Socket.accept sock
h <- socketToHandle s ReadWriteMode
p <- socketPort s
n <- getSocketName s
(Just hn, _) <- getNameInfo [] True False n
return (h, hn, p)
listenOn :: PortNumber -> IO Socket
listenOn pn = do
let hints = defaultHints { addrFlags = [AI_PASSIVE], addrSocketType = Stream }
addr:_ <- getAddrInfo (Just hints) Nothing (Just (show pn))
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
setSocketOption sock ReuseAddr 1
fd <- fdSocket sock
setCloseOnExecIfNeeded fd
Network.Socket.bind sock (addrAddress addr)
listen sock maxListenQueue
return sock
sClose :: Socket -> IO ()
sClose = close
connectTo :: HostName -> PortNumber -> IO Handle
connectTo s a = do
let hints = defaultHints { addrSocketType = Stream }
addr:_ <- getAddrInfo (Just hints) (Just s) (Just (show a))
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
connect sock (addrAddress addr)
socketToHandle sock ReadWriteMode
instance ConvertCurryHaskell Curry_Prelude.C_Int PortNumber where
toCurry i = toCurry (toInteger i)
fromCurry i = fromInteger (fromCurry i)
external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket)
external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort
where
listenOnFreshPort :: IO (PortNumber,Socket)
listenOnFreshPort = do
s <- listenOn defaultPort
p <- socketPort s
return (p,s)
#endif
-------------------------------------------------
external_d_C_prim_listenOn :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Socket
external_d_C_prim_listenOn i _ _ = toCurry listenOn i
external_d_C_prim_socketAccept :: C_Socket
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_String Curry_IO.C_Handle)
external_d_C_prim_socketAccept socket _ _ =
toCurry (\s -> Network.accept s >>= \ (h,s,_) -> return (s,OneHandle h)) socket
toCurry (\s -> acceptOld s >>= \ (h,s,_) -> return (s,OneHandle h)) socket
external_d_C_prim_waitForSocketAccept :: C_Socket -> Curry_Prelude.C_Int
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.OP_Tuple2 (Curry_Prelude.OP_List Curry_Prelude.C_Char) Curry_IO.C_Handle))
......@@ -35,10 +94,10 @@ external_d_C_prim_waitForSocketAccept s i _ _ = toCurry wait s i
wait :: Socket -> Int -> IO (Maybe (String, CurryHandle))
wait s t =
if t < 0
then Network.accept s >>= \ (h, s, _) -> return (Just (s, OneHandle h))
then acceptOld s >>= \ (h, s, _) -> return (Just (s, OneHandle h))
else do
mv <- newEmptyMVar
tacc <- forkIO (Network.accept s >>= \ (h, s, _) ->
tacc <- forkIO (acceptOld s >>= \ (h, s, _) ->
putMVar mv (Just (s, OneHandle h)))
ttim <- forkIO (delay ((fromIntegral t :: Integer) * 1000)
>> putMVar mv Nothing)
......
......@@ -11,9 +11,11 @@
--- Curry syntax (`showCurryType`, `showCurryExpr`,...).
---
--- @author Michael Hanus
--- @version September 2016
--- @version March 2019
------------------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module FlatCurry.Show(showFlatProg,showFlatType,showFlatFunc,
showCurryType,isClassContext,
showCurryExpr,showCurryId,showCurryVar)
......@@ -35,13 +37,16 @@ showFlatProg (Prog modname imports types funcs ops) =
++ "\n " ++ showFlatList showFlatOp ops
++ "\n )\n"
showFlatVisibility :: Visibility -> String
showFlatVisibility Public = " Public "
showFlatVisibility Private = " Private "
showFlatFixity :: Fixity -> String
showFlatFixity InfixOp = " InfixOp "
showFlatFixity InfixlOp = " InfixlOp "
showFlatFixity InfixrOp = " InfixrOp "
showFlatOp :: OpDecl -> String
showFlatOp (Op name fix prec) =
"(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")"
......@@ -55,6 +60,7 @@ showFlatType (TypeSyn name vis tpars texp) =
++ showFlatList show tpars
++ showFlatTypeExpr texp ++ ")"
showFlatCons :: ConsDecl -> String
showFlatCons (Cons cname arity vis types) =
"(Cons " ++ show cname ++ " " ++ show arity
++ showFlatVisibility vis
......@@ -67,6 +73,7 @@ showFlatFunc (Func name arity vis ftype rl) =
"\n " ++ showFlatTypeExpr ftype ++
"\n " ++ showFlatRule rl ++ ")"
showFlatRule :: Rule -> String
showFlatRule (Rule params expr) =
" (Rule " ++ showFlatList show params
++ showFlatExpr expr ++ ")"
......@@ -109,13 +116,16 @@ showFlatExpr (Case Flex e bs) =
showFlatExpr (Typed e ty) =
"(Typed " ++ showFlatExpr e ++ ' ' : showFlatTypeExpr ty ++ ")"
showFlatLit :: Literal -> String
showFlatLit (Intc i) = "(Intc " ++ show i ++ ")"
showFlatLit (Floatc f) = "(Floatc " ++ show f ++ ")"
showFlatLit (Charc c) = "(Charc " ++ show c ++ ")"
showFlatBranch :: BranchExpr -> String
showFlatBranch (Branch p e) = "(Branch " ++ showFlatPattern p
++ showFlatExpr e ++ ")"
showFlatPattern :: Pattern -> String
showFlatPattern (Pattern qn xs) =
"(Pattern " ++ show qn
++ showFlatList show xs ++ ")"
......@@ -127,7 +137,7 @@ showFlatList :: (a->String) -> [a] -> String
showFlatList format elems = " [" ++ showFlatListElems format elems ++ "] "
showFlatListElems :: (a->String) -> [a] -> String
showFlatListElems format elems = concat (intersperse "," (map format elems))
showFlatListElems format elems = intercalate "," (map format elems)
------------------------------------------------------------------------------
......@@ -139,7 +149,7 @@ showFlatListElems format elems = concat (intersperse "," (map format elems))
--- @param texpr - the FlatCurry type expression to be formatted
--- @return the String representation of the formatted type expression
showCurryType :: ((String,String) -> String) -> Bool -> TypeExpr -> String
showCurryType :: (QName -> String) -> Bool -> TypeExpr -> String
showCurryType tf nested texp = case texp of
FuncType t1 t2 -> maybe (showCurryType_ tf nested texp)
(\ (cn,cv) -> showBracketsIf nested $
......@@ -198,7 +208,7 @@ isFuncType (ForallType _ te) = isFuncType te
--- @param expr - the FlatCurry expression to be formatted
--- @return the String representation of the formatted expression
showCurryExpr :: ((String,String) -> String) -> Bool -> Int -> Expr -> String
showCurryExpr :: (QName -> String) -> Bool -> Int -> Expr -> String
showCurryExpr _ _ _ (Var n) = showCurryVar n
......@@ -219,7 +229,7 @@ showCurryExpr tf nested b (Comb ct cf [e1,e2])
= if isStringConstant (Comb ct cf [e1,e2])
then "\"" ++ showCurryStringConstant (Comb ct cf [e1,e2]) ++ "\""
else "[" ++
concat (intersperse "," (showCurryFiniteList tf b (Comb ct cf [e1,e2])))
intercalate "," (showCurryFiniteList tf b (Comb ct cf [e1,e2]))
++ "]"
| snd cf == "(,)" -- pair constructor?
= "(" ++ showCurryExpr tf False b e1 ++ "," ++
......@@ -237,7 +247,7 @@ showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es))
sceBlanks b ++ " else " ++ showCurryExpr tf False (b+2) e3)
| take 2 (snd cf) == "(," -- tuple constructor?
= "(" ++
concat (intersperse "," (map (showCurryExpr tf False b) (e1:e2:e3:es)))
intercalate "," (map (showCurryExpr tf False b) (e1:e2:e3:es))
++ ")"
| otherwise
= showBracketsIf nested
......@@ -246,15 +256,17 @@ showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es))
showCurryExpr tf nested b (Let bindings exp) =
showBracketsIf nested
("\n"++sceBlanks b++"let " ++ concat (intersperse ("\n "++sceBlanks b)
(map (\ (x,e)->showCurryVar x ++" = "++showCurryExpr tf False (b+4) e) bindings)) ++
("\n"++sceBlanks b++" in ") ++ showCurryExpr tf False (b+4) exp)
("\n" ++ sceBlanks b ++ "let " ++
intercalate ("\n " ++ sceBlanks b)
(map (\ (x,e) -> showCurryVar x ++ " = " ++
showCurryExpr tf False (b+4) e) bindings) ++
("\n" ++ sceBlanks b ++ " in ") ++ showCurryExpr tf False (b+4) exp)
showCurryExpr tf nested b (Free [] e) = showCurryExpr tf nested b e
showCurryExpr tf nested b (Free (x:xs) e) =
showBracketsIf nested
("let " ++ concat (intersperse "," (map showCurryVar (x:xs))) ++
("let " ++ intercalate "," (map showCurryVar (x:xs)) ++
" free in " ++ showCurryExpr tf False b e)
showCurryExpr tf nested b (Or e1 e2) =
......@@ -269,19 +281,24 @@ showCurryExpr tf nested b (Case ctype e cs) =
showCurryElems (showCurryCase tf (b+2)) cs ++ sceBlanks b)
showCurryExpr tf nested b (Typed e ty) =
showBracketsIf nested (showCurryExpr tf True b e ++ " :: " ++ showCurryType tf False ty)
showBracketsIf nested
(showCurryExpr tf True b e ++ " :: " ++ showCurryType tf False ty)
showCurryVar :: Show a => a -> String
showCurryVar i = "v" ++ show i
--- Shows an identifier in Curry form. Thus, operators are enclosed in brackets.
showCurryId :: String -> String
showCurryId name | isAlpha (head name) = name
| name == "[]" = name
| otherwise = ('(':name)++")"
showCurryLit :: Literal -> String
showCurryLit (Intc i) = show i
showCurryLit (Floatc f) = show f
showCurryLit (Charc c) = show c
showCurryCase :: (QName -> String) -> Int -> BranchExpr -> String
showCurryCase tf b (Branch (Pattern l vs) e) =
sceBlanks b ++ showPattern (tf l) vs
++ " -> " ++ showCurryExpr tf False b e ++ "\n"
......@@ -296,38 +313,43 @@ showCurryCase tf b (Branch (Pattern l vs) e) =
else showCurryVar x1 ++ " " ++ c ++ " " ++ showCurryVar x2
showPattern c (x1:x2:x3:xs) =
if take 2 c == "(," -- tuple constructor?
then "("++ concat (intersperse "," (map showCurryVar (x1:x2:x3:xs))) ++")"
then "(" ++ intercalate "," (map showCurryVar (x1:x2:x3:xs)) ++ ")"
else c ++ " " ++ showCurryElems showCurryVar (x1:x2:x3:xs)
showCurryCase tf b (Branch (LPattern l) e) =
sceBlanks b ++ showCurryLit l ++ " "
++ " -> " ++ showCurryExpr tf False b e ++ "\n"
showCurryFiniteList _ _ (Comb _ ("Prelude","[]") []) = []
showCurryFiniteList :: (QName -> String) -> Int -> Expr -> [String]
showCurryFiniteList _ _ (Comb _ ("Prelude","[]") []) = []
showCurryFiniteList tf b (Comb _ ("Prelude",":") [e1,e2]) =
showCurryExpr tf False b e1 : showCurryFiniteList tf b e2
-- show a string constant
showCurryStringConstant :: Expr -> String
showCurryStringConstant (Comb _ ("Prelude","[]") []) = []
showCurryStringConstant (Comb _ ("Prelude",":") [e1,e2]) =
showCharExpr e1 ++ showCurryStringConstant e2
showCharExpr :: Expr -> String
showCharExpr (Lit (Charc c))
| c=='"' = "\\\""
| c=='\'' = "\\\'"
| c=='\n' = "\\n"
| o < 32 || o > 126 =
['\\',chr(o `div` 100 + 48), chr(((o `mod` 100) `div` 10 + 48)),chr(o `mod` 10 + 48)]
['\\', chr (o `div` 100 + 48), chr (((o `mod` 100) `div` 10 + 48)),
chr(o `mod` 10 + 48)]
| otherwise = [c]
where
o = ord c
showCurryElems :: (a->String) -> [a] -> String
showCurryElems format elems =
concat (intersperse " " (map format elems))
showCurryElems :: (a -> String) -> [a] -> String
showCurryElems format elems = intercalate " " (map format elems)
showBracketsIf :: Bool -> String -> String
showBracketsIf nested s = if nested then '(' : s ++ ")" else s
sceBlanks :: Int -> String
sceBlanks b = take b (repeat ' ')
-- Is the expression a finite list (with an empty list at the end)?
......@@ -342,6 +364,7 @@ isFiniteList (Let _ _) = False
isFiniteList (Free _ _) = False
isFiniteList (Or _ _) = False
isFiniteList (Case _ _ _) = False
isFiniteList (Typed e _) = isFiniteList e
-- Is the expression a string constant?
isStringConstant :: Expr -> Bool
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiParamTypeClasses, CPP #-}
import Control.Concurrent
import Control.Monad (when)
import System.IO
#if __GLASGOW_HASKELL__ < 780
import Network
#endif
import Network.Socket hiding (sClose)
type C_Socket = PrimData Socket
-------------------------------------------------
#if __GLASGOW_HASKELL__ < 780
acceptOld :: Socket -> IO (Handle, HostName, PortNumber)
acceptOld = Network.accept
instance ConvertCurryHaskell Curry_Prelude.C_Int PortID where
toCurry (PortNumber i) = toCurry (toInteger i)
fromCurry i = PortNumber (fromInteger (fromCurry i))
external_d_C_prim_listenOn :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Socket
external_d_C_prim_listenOn i _ _ = toCurry listenOn i
external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket)
external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort
where
listenOnFreshPort :: IO (PortID,Socket)
listenOnFreshPort = do
s <- listenOn (PortNumber aNY_PORT)
p <- Network.socketPort s
p <- socketPort s
return (p,s)
-------------------------------------------------
#else
-------------------------------------------------
acceptOld :: Socket -> IO (Handle, HostName, PortNumber)
acceptOld sock = do (s, addr) <- Network.Socket.accept sock
h <- socketToHandle s ReadWriteMode
p <- socketPort s
n <- getSocketName s
(Just hn, _) <- getNameInfo [] True False n
return (h, hn, p)
listenOn :: PortNumber -> IO Socket
listenOn pn = do
let hints = defaultHints { addrFlags = [AI_PASSIVE], addrSocketType = Stream }
addr:_ <- getAddrInfo (Just hints) Nothing (Just (show pn))
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
setSocketOption sock ReuseAddr 1
fd <- fdSocket sock
setCloseOnExecIfNeeded fd
Network.Socket.bind sock (addrAddress addr)
listen sock maxListenQueue
return sock
sClose :: Socket -> IO ()
sClose = close
connectTo :: HostName -> PortNumber -> IO Handle
connectTo s a = do
let hints = defaultHints { addrSocketType = Stream }
addr:_ <- getAddrInfo (Just hints) (Just s) (Just (show a))
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
connect sock (addrAddress addr)
socketToHandle sock ReadWriteMode
instance ConvertCurryHaskell Curry_Prelude.C_Int PortNumber where
toCurry i = toCurry (toInteger i)
fromCurry i = fromInteger (fromCurry i)
external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket)
external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort
where
listenOnFreshPort :: IO (PortNumber,Socket)
listenOnFreshPort = do
s <- listenOn defaultPort
p <- socketPort s
return (p,s)
#endif
-------------------------------------------------
external_d_C_prim_listenOn :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Socket
external_d_C_prim_listenOn i _ _ = toCurry listenOn i
external_d_C_prim_socketAccept :: C_Socket
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_String Curry_IO.C_Handle)
external_d_C_prim_socketAccept socket _ _ =
toCurry (\s -> Network.accept s >>= \ (h,s,_) -> return (s,OneHandle h)) socket
toCurry (\s -> acceptOld s >>= \ (h,s,_) -> return (s,OneHandle h)) socket
external_d_C_prim_waitForSocketAccept :: C_Socket -> Curry_Prelude.C_Int
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.OP_Tuple2 (Curry_Prelude.OP_List Curry_Prelude.C_Char) Curry_IO.C_Handle))
......@@ -35,10 +94,10 @@ external_d_C_prim_waitForSocketAccept s i _ _ = toCurry wait s i
wait :: Socket -> Int -> IO (Maybe (String, CurryHandle))
wait s t =
if t < 0
then Network.accept s >>= \ (h, s, _) -> return (Just (s, OneHandle h))
then acceptOld s >>= \ (h, s, _) -> return (Just (s, OneHandle h))
else do
mv <- newEmptyMVar
tacc <- forkIO (Network.accept s >>= \ (h, s, _) ->
tacc <- forkIO (acceptOld s >>= \ (h, s, _) ->
putMVar mv (Just (s, OneHandle h)))
ttim <- forkIO (delay ((fromIntegral t :: Integer) * 1000)
>> putMVar mv Nothing)
......
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