Commit 0517c144 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott
Browse files

Merge branch 'master' into libs_refactor

SetFunctions.isEmpty: Eq context removed

SetFunctions: code refactored, minValueBy/maxValueBy added

Some type signatures added
parent a7714e31
......@@ -2,7 +2,7 @@
--- Library for handling date and time information.
---
--- @author Michael Hanus
--- @version April 2007
--- @version January 2018
--- @category general
------------------------------------------------------------------------------
......@@ -17,14 +17,14 @@ module Data.Time(ClockTime,
--- ClockTime represents a clock time in some internal representation.
data ClockTime = CTime Int
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Read)
--- A calendar time is presented in the following form:
--- (CalendarTime year month day hour minute second timezone)
--- where timezone is an integer representing the timezone as a difference
--- to UTC time in seconds.
data CalendarTime = CalendarTime Int Int Int Int Int Int Int
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Read)
--- The year of a calendar time.
ctYear :: CalendarTime -> Int
......
......@@ -77,6 +77,7 @@ showMemInfo infos = concat $ intersperse ", " $
--- Print a human readable version of the current memory situation
--- of the Curry process.
printMemInfo :: IO ()
printMemInfo = getProcessInfos >>= putStrLn . showMemInfo
--- Print the time needed to execute a given IO action.
......@@ -129,6 +130,8 @@ profileSpace action = do
profileSpaceNF :: a -> IO ()
profileSpaceNF exp = profileSpace (seq (id $!! exp) done)
showInfoDiff :: [(ProcessInfo, Int)] -> [(ProcessInfo, Int)] -> ProcessInfo
-> String
showInfoDiff infos1 infos2 item =
show (maybe 0 id (lookup item infos2) - maybe 0 id (lookup item infos1))
......
......@@ -37,8 +37,9 @@ import System.Directory ( doesFileExist, getHomeDirectory
, findFileWithSuffix, getFileWithSuffix)
import System.FilePath ( FilePath, (</>), (<.>), addTrailingPathSeparator
, dropFileName, joinPath, normalise, splitDirectories
, splitExtension, splitFileName, splitSearchPath
, takeFileName, takeExtension, dropExtension)
, takeDirectory, splitExtension, splitFileName
, splitSearchPath, takeFileName
, takeExtension, dropExtension)
import System.IO
import PropertyFile
import System.Process
......@@ -458,7 +459,9 @@ callFrontendWithParams target params modpath = do
else ioError (userError "Illegal source program")
where
callParseCurry = do
path <- maybe (getLoadPathForModule modpath) return (fullPath params)
path <- maybe (getLoadPathForModule modpath)
(\p -> return (nub (takeDirectory modpath : p)))
(fullPath params)
return (quote (installDir </> "bin" </> curryCompiler ++ "-frontend")
++ concatMap ((" -i" ++) . quote) path)
......
......@@ -84,7 +84,7 @@ pl: .curry/pakcs/$(ALLLIBS).pl $(LIB_PL)
# generate all Prolog translations:
.curry/pakcs/%.pl: .curry/%.fcy
rm -f $@ && "$(PAKCS)" --quiet :compile $(subst /,.,$*) :quit
rm -f $@ && "$(PAKCS)" --nocypm --quiet :compile $(subst /,.,$*) :quit
##############################################################################
# create HTML documentation files for system libraries
......
......@@ -32,10 +32,13 @@ import Data.Either
-- Distributed Curry! If this port is occupied by another process
-- on a host, you cannot run Distributed Curry on it.)
cpnsSocket = 8767 -- standard port number of CPNS demon
-- The standard port number of CPNS demon.
cpnsSocket :: Int
cpnsSocket = 8767
-- The time out before considering the server as unreachable:
cpnsTimeOut :: Int
cpnsTimeOut = 3000
--- Type of messages to be processed by the Curry Port Name Server.
......@@ -61,6 +64,7 @@ data CPNSMessage = Terminate
deriving (Read, Show)
-- The lock file to coordinate the startup of the CPNS demon:
cpnsStartupLockfile :: String
cpnsStartupLockfile = "/tmp/CurryPNSD.lock"
--- Starts the "Curry Port Name Server" (CPNS) running on the local machine.
......@@ -92,7 +96,7 @@ cpnsStart = catch startup
--- The main loop of the CPNS demon
cpnsServer :: [(String,Int,Int,Int)] -> Socket -> IO ()
cpnsServer regs socket = do
(chost,stream) <- socketAccept socket
(chost,stream) <- accept socket
--putStrLn $ "Connection from "++chost
serveRequest chost stream
where
......@@ -140,6 +144,8 @@ cpnsServer regs socket = do
cpnsServer newregs socket )
msg
tryRegisterPortName :: [(String,Int,Int,Int)] -> String -> Int -> Int -> Int
-> IO (Bool, [(String, Int, Int, Int)])
tryRegisterPortName regs name pid sn pn = do
let nameregs = filter (\(n,_,_,_)->name==n) regs
ack <- if null nameregs
......@@ -159,6 +165,8 @@ tryRegisterPortName regs name pid sn pn = do
return (ack, newregs)
-- Delete all registrations for a given port name:
unregisterPortName :: [(String,Int,Int,Int)] -> String
-> IO [(String,Int,Int,Int)]
unregisterPortName regs name = do
ctime <- getLocalTime
putStrLn $ "Unregister port \""++name++"\" at "++calendarTimeToString ctime
......@@ -239,9 +247,11 @@ sendToLocalCPNS msg = doIfAlive "localhost" $ do
hClose h
--- Shows all registered ports at the local CPNS demon (in its logfile).
cpnsShow :: IO ()
cpnsShow = sendToLocalCPNS ShowRegistry
--- Terminates the local CPNS demon
cpnsStop :: IO ()
cpnsStop = sendToLocalCPNS Terminate
--- Gets an answer from a Curry port name server on a host,
......@@ -302,6 +312,7 @@ startCPNSDIfNecessary = do
done
--- Main function for CPNS demon. Check arguments and execute command.
main :: IO ()
main = do
args <- getArgs
case args of
......
......@@ -45,7 +45,7 @@ listenOn socketname = do
--- and a handle to a stream communication with the client.
--- The handle is both readable and writable.
socketAccept :: Socket -> IO (String,Handle)
socketAccept (NamedSocket _ socket) = Socket.socketAccept socket
socketAccept (NamedSocket _ socket) = Socket.accept socket
--- Waits until a connection of a client to a socket is available.
--- If no connection is available within the time limit, it returns Nothing,
......@@ -61,7 +61,7 @@ waitForSocketAccept (NamedSocket _ socket) = Socket.waitForSocketAccept socket
--- Closes a server socket.
sClose :: Socket -> IO ()
sClose (NamedSocket socketname socket) = do
Socket.sClose socket
Socket.close socket
unregisterPort socketname
--- Returns a the symbolic name of a named socket.
......
......@@ -12,7 +12,7 @@
module Network.Socket
(Socket, listenOn, listenOnFresh,
socketAccept, waitForSocketAccept, close, connectToSocket)
accept, waitForSocketAccept, close, connectToSocket)
where
import System.IO (Handle)
......
......@@ -45,6 +45,8 @@ module Prelude
, PEVAL
, Monad(..)
, Functor(..)
, sequence, sequence_, mapM, mapM_, foldM, liftM, liftM2, forM, forM_
, unlessM, whenM
#ifdef __PAKCS__
, (=:<<=), letrec
#endif
......@@ -1650,7 +1652,7 @@ class Num a where
abs :: a -> a
signum :: a -> a
fromInteger :: Int -> a
fromInt :: Int -> a
x - y = x + negate y
negate x = 0 - x
......@@ -1669,7 +1671,7 @@ instance Num Int where
| x == 0 = 0
| otherwise = -1
fromInteger x = x
fromInt x = x
instance Num Float where
x + y = x +. y
......@@ -1686,9 +1688,9 @@ instance Num Float where
| x == 0 = 0
| otherwise = -1
fromInteger x = i2f x
fromInt x = i2f x
-- minimal definition: fromRational and (recip or (/))
-- minimal definition: fromFloat and (recip or (/))
class Num a => Fractional a where
(/) :: a -> a -> a
......@@ -1697,16 +1699,16 @@ class Num a => Fractional a where
recip x = 1/x
x / y = x * recip y
fromRational :: Float -> a -- since we have no type Rational
fromFloat :: Float -> a -- since we have no type Rational
instance Fractional Float where
x / y = x /. y
recip x = 1.0/x
fromRational x = x
fromFloat x = x
class (Num a, Ord a) => Real a where
-- toRational :: a -> Rational
-- toFloat :: a -> Float
class Real a => Integral a where
div :: a -> a -> a
......@@ -1809,3 +1811,71 @@ instance Monad [] where
xs >>= f = [y | x <- xs, y <- f x]
return x = [x]
fail _ = []
----------------------------------------------------------------------------
-- Some useful monad operations which might be later generalized
-- or moved into some other base module.
--- Evaluates a sequence of monadic actions and collects all results in a list.
sequence :: Monad m => [m a] -> m [a]
sequence = foldr (\m n -> m >>= \x -> n >>= \xs -> return (x:xs)) (return [])
--- Evaluates a sequence of monadic actions and ignores the results.
sequence_ :: Monad m => [m _] -> m ()
sequence_ = foldr (>>) (return ())
--- Maps a monadic action function on a list of elements.
--- The results of all monadic actions are collected in a list.
mapM :: Monad m => (a -> m b) -> [a] -> m [b]
mapM f = sequence . map f
--- Maps a monadic action function on a list of elements.
--- The results of all monadic actions are ignored.
mapM_ :: Monad m => (a -> m _) -> [a] -> m ()
mapM_ f = sequence_ . map f
--- Folds a list of elements using a binary monadic action and a value
--- for the empty list.
foldM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
foldM _ z [] = return z
foldM f z (x:xs) = f z x >>= \z' -> foldM f z' xs
--- Apply a pure function to the result of a monadic action.
liftM :: Monad m => (a -> b) -> m a -> m b
liftM f m = m >>= return . f
--- Apply a pure binary function to the result of two monadic actions.
liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 f m1 m2 = do x1 <- m1
x2 <- m2
return (f x1 x2)
--- Like `mapM`, but with flipped arguments.
---
--- This can be useful if the definition of the function is longer
--- than those of the list, like in
---
--- forM [1..10] $ \n -> do
--- ...
forM :: Monad m => [a] -> (a -> m b) -> m [b]
forM xs f = mapM f xs
--- Like `mapM_`, but with flipped arguments.
---
--- This can be useful if the definition of the function is longer
--- than those of the list, like in
---
--- forM_ [1..10] $ \n -> do
--- ...
forM_ :: Monad m => [a] -> (a -> m b) -> m ()
forM_ xs f = mapM_ f xs
--- Performs a monadic action unless the condition is met.
unlessM :: Monad m => Bool -> m () -> m ()
unlessM p act = if p then return () else act
--- Performs a monadic action when the condition is met.
whenM :: Monad m => Bool -> m () -> m ()
whenM p act = if p then act else return ()
----------------------------------------------------------------------------
......@@ -126,11 +126,11 @@ genPosFloat :: SearchTree Float
genPosFloat = valsTo (genPair genNat genNat) ii2f
where
-- Combine two naturals to a float value:
ii2f (x,y) = Value (fromInteger x + nat2float 0.1 y)
ii2f (x,y) = Value (fromInt x + nat2float 0.1 y)
-- Transform an natural to float<1, e.g., nat2float 0.1 135 = 0.531
nat2float m i =
if i == 0 then 0.0
else nat2float (m/10) (i `div` 10) + m * fromInteger (i `mod` 10)
else nat2float (m/10) (i `div` 10) + m * fromInt (i `mod` 10)
--- Generates a search tree for Boolean values.
genBool :: SearchTree Bool
......
......@@ -46,25 +46,27 @@
--- the set functions itself will be evaluated.
---
--- @author Michael Hanus, Fabian Reck
--- @version June 2017
--- @version January 2018
--- @category general
------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module SetFunctions
(set0,set1,set2,set3,set4,set5,set6,set7
(set0, set1, set2, set3, set4, set5, set6, set7
#ifdef __PAKCS__
#else
,set0With,set1With,set2With,set3With,set4With,set5With,set6With,set7With
, set0With, set1With, set2With, set3With, set4With, set5With, set6With
, set7With
#endif
,Values,isEmpty,notEmpty,valueOf
,choose,chooseValue,select,selectValue
,mapValues,foldValues,filterValues,minValue,maxValue
,values2list,printValues,sortValues,sortValuesBy
, Values, isEmpty, notEmpty, valueOf
, choose, chooseValue, select, selectValue
, mapValues, foldValues, filterValues
, minValue, minValueBy, maxValue, maxValueBy
, values2list, printValues, sortValues, sortValuesBy
) where
import Data.List(delete)
import Sort(mergeSortBy)
import List ( delete, minimum, minimumBy, maximum, maximumBy)
import Sort ( mergeSortBy )
#ifdef __PAKCS__
import Findall
#else
......@@ -259,31 +261,32 @@ data Values a = Values (Maybe a) [a]
data Values a = Values [a]
#endif
--- Internal operation to extract all elements of a multiset of values.
valuesOf :: Values a -> [a]
#ifdef __PAKCS__
--- Is a multiset of values empty?
isEmpty :: Eq a => Values a -> Bool
isEmpty (Values firstval _) = firstval == Nothing
valuesOf (Values _ s) = s
#else
valuesOf (Values s) = s
#endif
--- Is a multiset of values not empty?
notEmpty :: Eq a => Values a -> Bool
notEmpty vs = not (isEmpty vs)
----------------------------------------------------------------------
--- Is some value an element of a multiset of values?
valueOf :: Eq a => a -> Values a -> Bool
valueOf e (Values _ s) = e `elem` s
#else
--- Is a multiset of values empty?
isEmpty :: Values _ -> Bool
isEmpty :: Values a -> Bool
#ifdef __PAKCS__
isEmpty (Values firstval _) = case firstval of Nothing -> True
Just _ -> False
#else
isEmpty (Values vs) = null vs
#endif
--- Is a multiset of values not empty?
notEmpty :: Values _ -> Bool
notEmpty :: Values a -> Bool
notEmpty vs = not (isEmpty vs)
--- Is some value an element of a multiset of values?
valueOf :: Eq a => a -> Values a -> Bool
valueOf e (Values s) = e `elem` s
#endif
valueOf e s = e `elem` valuesOf s
--- Chooses (non-deterministically) some value in a multiset of values
--- and returns the chosen value and the remaining multiset of values.
......@@ -358,11 +361,7 @@ mapValues f (Values s) = Values (map f s)
--- must be <b>commutative</b> so that the result is independent of the order
--- of applying this operation to all elements in the multiset.
foldValues :: (a -> a -> a) -> a -> Values a -> a
#ifdef __PAKCS__
foldValues f z (Values _ s) = foldr f z s
#else
foldValues f z (Values s) = foldr f z s
#endif
foldValues f z s = foldr f z (valuesOf s)
--- Keeps all elements of a multiset of values that satisfy a predicate.
filterValues :: (a -> Bool) -> Values a -> Values a
......@@ -375,41 +374,31 @@ filterValues p (Values _ s) = Values val xs
filterValues p (Values s) = Values (filter p s)
#endif
--- Returns the minimal element of a non-empty multiset of values
--- with respect to a given total ordering on the elements.
minValue :: (a -> a -> Bool) -> Values a -> a
#ifdef __PAKCS__
minValue leq (Values _ s) = minOf s
#else
minValue leq (Values s) = minOf s
#endif
where
minOf [x] = x
minOf (x:y:ys) = let m1 = minOf (y:ys)
in if leq x m1 then x else m1
--- Returns the minimum of a non-empty multiset of values
--- according to the given comparison function on the elements.
minValue :: Ord a => Values a -> a
minValue s = minimum (valuesOf s)
--- Returns the maximal element of a non-empty multiset of value
--- with respect to a given total ordering on the elements.
maxValue :: (a -> a -> Bool) -> Values a -> a
#ifdef __PAKCS__
maxValue leq (Values _ s) = maxOf s
#else
maxValue leq (Values s) = maxOf s
#endif
where
maxOf [x] = x
maxOf (x:y:ys) = let m1 = maxOf (y:ys)
in if leq x m1 then m1 else x
--- Returns the minimum of a non-empty multiset of values
--- according to the given comparison function on the elements.
minValueBy :: (a -> a -> Ordering) -> Values a -> a
minValueBy cmp s = minimumBy cmp (valuesOf s)
--- Returns the maximum of a non-empty multiset of values
--- according to the given comparison function on the elements.
maxValue :: Ord a => Values a -> a
maxValue s = maximum (valuesOf s)
--- Returns the maximum of a non-empty multiset of values
--- according to the given comparison function on the elements.
maxValueBy :: (a -> a -> Ordering) -> Values a -> a
maxValueBy cmp s = maximumBy cmp (valuesOf s)
--- Puts all elements of a multiset of values in a list.
--- Since the order of the elements in the list might depend on
--- the time of the computation, this operation is an I/O action.
values2list :: Values a -> IO [a]
#ifdef __PAKCS__
values2list (Values _ s) = return s
#else
values2list (Values s) = return s
#endif
values2list s = return (valuesOf s)
--- Prints all elements of a multiset of values.
printValues :: Show a => Values a -> IO ()
......@@ -427,10 +416,6 @@ sortValues = sortValuesBy (<=)
--- In order to ensure that the result of this operation is independent of the
--- evaluation order, the given ordering must be a total order.
sortValuesBy :: (a -> a -> Bool) -> Values a -> [a]
#ifdef __PAKCS__
sortValuesBy leq (Values _ s) = mergeSortBy leq s
#else
sortValuesBy leq (Values s) = mergeSortBy leq s
#endif
sortValuesBy leq s = mergeSortBy leq (valuesOf s)
------------------------------------------------------------------------
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