Commit 5ce5beb2 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott
Browse files

Minor corrections

parent a40f2fc2
......@@ -14,7 +14,7 @@ module Data.List
, intersperse, intercalate, transpose, diagonal, permutations, partition
, group, groupBy, splitOn, split, inits, tails, replace
, isPrefixOf, isSuffixOf, isInfixOf
, sortBy, insertBy
, sort, sortBy, insertBy
, unionBy, intersectBy
, last, init
, sum, product, maximum, minimum, maximumBy, minimumBy
......@@ -133,11 +133,11 @@ diagonal :: [[a]] -> [a]
diagonal = concat . foldr diags []
where
diags [] ys = ys
diags (x:xs) ys = [x] : merge xs ys
diags (x:xs) ys = [x] : merge' xs ys
merge [] ys = ys
merge xs@(_:_) [] = map (:[]) xs
merge (x:xs) (y:ys) = (x:y) : merge xs ys
merge' [] ys = ys
merge' xs@(_:_) [] = map (:[]) xs
merge' (x:xs) (y:ys) = (x:y) : merge' xs ys
--- Returns the list of all permutations of the argument.
permutations :: [a] -> [[a]]
......@@ -248,9 +248,41 @@ isSuffixOf xs ys = isPrefixOf (reverse xs) (reverse ys)
isInfixOf :: Eq a => [a] -> [a] -> Bool
isInfixOf xs ys = any (isPrefixOf xs) (tails ys)
--- The default sorting operation, mergeSort, with standard ordering `<=`.
sort :: Ord a => [a] -> [a]
sort = sortBy (<=)
--- Sorts a list w.r.t. an ordering relation by the insertion method.
sortBy :: (a -> a -> Bool) -> [a] -> [a]
sortBy le = foldr (insertBy le) []
sortBy = mergeSortBy
--- Bottom-up mergesort with ordering as first parameter.
mergeSortBy :: (a -> a -> Bool) -> [a] -> [a]
mergeSortBy leq zs = mergeLists (genRuns zs)
where
-- generate runs of length 2:
genRuns [] = []
genRuns [x] = [[x]]
genRuns (x1:x2:xs) | leq x1 x2 = [x1,x2] : genRuns xs
| otherwise = [x2,x1] : genRuns xs
-- merge the runs:
mergeLists [] = []
mergeLists [x] = x
mergeLists (x1:x2:xs) = mergeLists (merge leq x1 x2 : mergePairs xs)
mergePairs [] = []
mergePairs [x] = [x]
mergePairs (x1:x2:xs) = merge leq x1 x2 : mergePairs xs
--- Merges two lists with respect to an ordering predicate.
merge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
merge _ [] ys = ys
merge _ (x:xs) [] = x : xs
merge leq (x:xs) (y:ys) | leq x y = x : merge leq xs (y:ys)
| otherwise = y : merge leq (x:xs) ys
--- Inserts an object into a list according to an ordering relation.
--- @param le - an ordering relation (e.g., less-or-equal)
......
------------------------------------------------------------------------------
--- Library for handling global entities.
--- A global entity has a name declared in the program.
--- Its value can be accessed and modified by IO actions.
--- Furthermore, global entities can be declared as persistent so that
--- their values are stored across different program executions.
---
--- Currently, it is still experimental so that its interface might
--- be slightly changed in the future.
---
--- A global entity `g` with an initial value `v`
--- of type `t` must be declared by:
---
--- g :: Global t
--- g = global v spec
---
--- Here, the type `t` must not contain type variables and
--- `spec` specifies the storage mechanism for the
--- global entity (see type `GlobalSpec`).
---
---
--- @author Michael Hanus
--- @version February 2017
--- @category general
------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module Global( Global, GlobalSpec(..), global
, readGlobal, safeReadGlobal, writeGlobal)
where
----------------------------------------------------------------------
--- The abstract type of a global entity.
#ifdef __PAKCS__
data Global a = GlobalDef a GlobalSpec
#else
external data Global _
#endif
--- `global` is only used for the declaration of a global value
--- and should not be used elsewhere. In the future, it might become a keyword.
global :: a -> GlobalSpec -> Global a
#ifdef __PAKCS__
global v s = GlobalDef v s
#else
global external
#endif
--- The storage mechanism for the global entity.
--- @cons Temporary - the global value exists only during a single execution
--- of a program
--- @cons Persistent f - the global value is stored persisently in file f
--- (which is created and initialized if it does not exists)
data GlobalSpec = Temporary | Persistent String
--- Reads the current value of a global.
readGlobal :: Global a -> IO a
readGlobal g = prim_readGlobal $# g
prim_readGlobal :: Global a -> IO a
prim_readGlobal external
--- Safely reads the current value of a global.
--- If `readGlobal` fails (e.g., due to a corrupted persistent storage),
--- the global is re-initialized with the default value given as
--- the second argument.
safeReadGlobal :: Global a -> a -> IO a
safeReadGlobal g dflt =
catch (readGlobal g) (\_ -> writeGlobal g dflt >> return dflt)
--- Updates the value of a global.
--- The value is evaluated to a ground constructor term before it is updated.
writeGlobal :: Global a -> a -> IO ()
writeGlobal g v = (prim_writeGlobal $# g) $## v
prim_writeGlobal :: Global a -> a -> IO ()
prim_writeGlobal external
------------------------------------------------------------------------
import CurryException
import Control.Exception as C
import Data.IORef
import System.IO
import System.Directory (doesFileExist)
import System.IO.Unsafe
import System.Process (system)
-- Implementation of Globals in Curry. We use Haskell's IORefs for temporary
-- globals where Curry values are stored in the IORefs
data C_Global a
= Choice_C_Global Cover ID (C_Global a) (C_Global a)
| Choices_C_Global Cover ID ([C_Global a])
| Fail_C_Global Cover FailInfo
| Guard_C_Global Cover Constraints (C_Global a)
| C_Global_Temp (IORef a) -- a temporary global
| C_Global_Pers String -- a persistent global with a given (file) name
instance Show (C_Global a) where
show = error "ERROR: no show for Global"
instance Read (C_Global a) where
readsPrec = error "ERROR: no read for Global"
instance NonDet (C_Global a) where
choiceCons = Choice_C_Global
choicesCons = Choices_C_Global
failCons = Fail_C_Global
guardCons = Guard_C_Global
try (Choice_C_Global cd i x y) = tryChoice cd i x y
try (Choices_C_Global cd i xs) = tryChoices cd i xs
try (Fail_C_Global cd info) = Fail cd info
try (Guard_C_Global cd c e) = Guard cd c e
try x = Val x
match choiceF _ _ _ _ _ (Choice_C_Global cd i x y) = choiceF cd i x y
match _ narrF _ _ _ _ (Choices_C_Global cd i@(NarrowedID _ _) xs)
= narrF cd i xs
match _ _ freeF _ _ _ (Choices_C_Global cd i@(FreeID _ _) xs)
= freeF cd i xs
match _ _ _ failF _ _ (Fail_C_Global cd info) = failF cd info
match _ _ _ _ guardF _ (Guard_C_Global cd c e) = guardF cd c e
match _ _ _ _ _ valF x = valF x
instance Generable (C_Global a) where
generate _ _ = error "ERROR: no generator for Global"
instance NormalForm (C_Global a) where
($!!) cont g@(C_Global_Temp _) cd cs = cont g cd cs
($!!) cont g@(C_Global_Pers _) cd cs = cont g cd cs
($!!) cont (Choice_C_Global d i g1 g2) cd cs = nfChoice cont d i g1 g2 cd cs
($!!) cont (Choices_C_Global d i gs) cd cs = nfChoices cont d i gs cd cs
($!!) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $!! g) cd
$! (addCs c cs))
($!!) _ (Fail_C_Global d info) _ _ = failCons d info
($##) cont g@(C_Global_Temp _) cd cs = cont g cd cs
($##) cont g@(C_Global_Pers _) cd cs = cont g cd cs
($##) cont (Choice_C_Global d i g1 g2) cd cs = gnfChoice cont d i g1 g2 cd cs
($##) cont (Choices_C_Global d i gs) cd cs = gnfChoices cont d i gs cd cs
($##) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $## g) cd
$! (addCs c cs))
($##) _ (Fail_C_Global cd info) _ _ = failCons cd info
searchNF _ cont g@(C_Global_Temp _) = cont g
searchNF _ cont g@(C_Global_Pers _) = cont g
instance Unifiable (C_Global a) where
(=.=) (C_Global_Temp ref1) (C_Global_Temp ref2) _ _
| ref1 == ref2 = C_True
(=.=) (C_Global_Pers f1) (C_Global_Pers f2) _ _
| f1 == f2 = C_True
(=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo
(=.<=) = (=.=)
bind cd i (Choice_C_Global d j l r)
= [(ConstraintChoice d j (bind cd i l) (bind cd i r))]
bind cd i (Choices_C_Global d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs
bind cd i (Choices_C_Global d j@(NarrowedID _ _) xs)
= [(ConstraintChoices d j (map (bind cd i) xs))]
bind _ _ (Fail_C_Global _ info) = [Unsolvable info]
bind cd i (Guard_C_Global _ cs e) = (getConstrList cs) ++ (bind cd i e)
lazyBind cd i (Choice_C_Global d j l r)
= [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))]
lazyBind cd i (Choices_C_Global d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs
lazyBind cd i (Choices_C_Global d j@(NarrowedID _ _) xs)
= [(ConstraintChoices d j (map (lazyBind cd i) xs))]
lazyBind _ _ (Fail_C_Global cd info) = [Unsolvable info]
lazyBind cd i (Guard_C_Global _ cs e)
= (getConstrList cs) ++ [(i :=: (LazyBind (lazyBind cd i e)))]
instance Curry_Prelude.Curry a => Curry_Prelude.Curry (C_Global a)
external_d_C_global :: Curry_Prelude.Curry a => a -> C_GlobalSpec -> Cover -> ConstStore
-> C_Global a
external_d_C_global val C_Temporary _ _ = ref `seq` (C_Global_Temp ref)
where ref = unsafePerformIO (newIORef val)
external_d_C_global val (C_Persistent cname) _ _ =
let name = fromCurry cname :: String
in unsafePerformIO (initGlobalFile name >> return (C_Global_Pers name))
where initGlobalFile name = do
ex <- doesFileExist name
if ex then return ()
else writeFile name (show val++"\n")
external_d_C_prim_readGlobal :: Curry_Prelude.Curry a => C_Global a -> Cover -> ConstStore
-> Curry_Prelude.C_IO a
external_d_C_prim_readGlobal (C_Global_Temp ref) _ _ = fromIO (readIORef ref)
external_d_C_prim_readGlobal (C_Global_Pers name) _ _ = fromIO $
exclusiveOnFile name $ do
s <- catch (do h <- openFile name ReadMode
eof <- hIsEOF h
s <- if eof then return "" else hGetLine h
hClose h
return s)
(\e -> throw (IOException (show (e :: C.IOException))))
case reads s of
[(val,"")] -> return val
_ -> throw (IOException $ "Persistent file `" ++ name ++
"' contains malformed contents")
external_d_C_prim_writeGlobal :: Curry_Prelude.Curry a => C_Global a -> a
-> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_writeGlobal (C_Global_Temp ref) val _ _ =
toCurry (writeIORef ref val)
external_d_C_prim_writeGlobal (C_Global_Pers name) val _ _ =
toCurry (exclusiveOnFile name $ writeFile name (show val ++ "\n"))
--- Forces the exclusive execution of an action via a lock file.
exclusiveOnFile :: String -> IO a -> IO a
exclusiveOnFile file action = do
exlock <- doesFileExist lockfile
if exlock
then hPutStrLn stderr
(">>> Waiting for removing lock file `" ++ lockfile ++ "'...")
else return ()
system ("lockfile-create --lock-name "++lockfile)
C.catch (do actionResult <- action
deleteLockFile
return actionResult )
(\e -> deleteLockFile >> C.throw (e :: CurryException))
where
lockfile = file ++ ".LOCK"
deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="prim_readGlobal" arity="1">
<library>prim_global</library>
<entry>prim_readGlobal</entry>
</primitive>
<primitive name="prim_writeGlobal" arity="2">
<library>prim_global</library>
<entry>prim_writeGlobal</entry>
</primitive>
</primitives>
------------------------------------------------------------------------------
--- Library with some functions for reading and converting numeric tokens.
--
--- @author Michael Hanus, Frank Huch, Bjoern Peemoeller
--- @version November 2016
--- @category general
------------------------------------------------------------------------------
module Numeric
( readInt, readNat, readHex, readOct, readBin
) where
import Data.Char ( digitToInt, isBinDigit, isOctDigit
, isDigit, isHexDigit, isSpace)
import Data.Maybe
--- Read a (possibly negative) integer as a first token in a string.
--- The string might contain leadings blanks and the integer is read
--- up to the first non-digit.
--- On success returns `[(v,s)]`, where `v` is the value of the integer
--- and `s` is the remaing string without the integer token.
readInt :: ReadS Int
readInt str = case dropWhile isSpace str of
[] -> []
'-':str1 -> map (\(n,s) -> (-n, s)) (readNat str1)
str1 -> readNat str1
--- Read a natural number as a first token in a string.
--- The string might contain leadings blanks and the number is read
--- up to the first non-digit.
--- On success returns `[(v,s)]`, where `v` is the value of the number
--- and s is the remaing string without the number token.
readNat :: ReadS Int
readNat str = maybeToList $
readNumPrefix (dropWhile isSpace str) Nothing 10 isDigit digitToInt
--- Read a hexadecimal number as a first token in a string.
--- The string might contain leadings blanks and the number is read
--- up to the first non-hexadecimal digit.
--- On success returns `[(v,s)]`, where `v` is the value of the number
--- and s is the remaing string without the number token.
readHex :: ReadS Int
readHex l = maybeToList $
readNumPrefix (dropWhile isSpace l) Nothing 16 isHexDigit digitToInt
--- Read an octal number as a first token in a string.
--- The string might contain leadings blanks and the number is read
--- up to the first non-octal digit.
--- On success returns `[(v,s)]`, where `v` is the value of the number
--- and s is the remaing string without the number token.
readOct :: ReadS Int
readOct l = maybeToList $
readNumPrefix (dropWhile isSpace l) Nothing 8 isOctDigit digitToInt
--- Read a binary number as a first token in a string.
--- The string might contain leadings blanks and the number is read
--- up to the first non-binary digit.
--- On success returns `[(v,s)]`, where `v` is the value of the number
--- and s is the remaing string without the number token.
readBin :: ReadS Int
readBin l = maybeToList $
readNumPrefix (dropWhile isSpace l) Nothing 2 isBinDigit digitToInt
--- Read an integral number prefix where the value of an already read number
--- prefix is provided as the second argument.
--- The third argument is the base, the fourth argument
--- is a predicate to distinguish valid digits, and the fifth argument converts
--- valid digits into integer values.
readNumPrefix :: String -> Maybe Int -> Int -> (Char -> Bool) -> (Char -> Int)
-> Maybe (Int, String)
readNumPrefix [] Nothing _ _ _ = Nothing
readNumPrefix [] (Just n) _ _ _ = Just (n,"")
readNumPrefix (c:cs) (Just n) base isdigit valueof
| isdigit c = readNumPrefix cs (Just (base*n+valueof c)) base isdigit valueof
| otherwise = Just (n,c:cs)
readNumPrefix (c:cs) Nothing base isdigit valueof
| isdigit c = readNumPrefix cs (Just (valueof c)) base isdigit valueof
| otherwise = Nothing
......@@ -18,12 +18,13 @@ module Prelude
, Bool (..), Ordering (..), Maybe (..), Either (..)
-- * Type Classes
, Eq (..) , Ord (..) , Show (..), shows, showChar, showString, showParen
, Read (..), reads, readParen, read, lex
, Eq (..) , Ord (..)
, Show (..), ShowS, shows, showChar, showString, showParen
, Read (..), ReadS, reads, readParen, read, lex
, Bounded (..), Enum (..)
-- ** Numerical Typeclasses
, Num (..), Fractional (..), Real (..)
, Integral (..), even, odd, fromIntegral, realToFrac
, Integral (..), even, odd, fromIntegral, realToFrac, (^)
, RealFrac (..), Floating (..), Monoid (..)
-- Type Constructor Classes
, Functor (..), Applicative (..), Alternative (..)
......@@ -1108,6 +1109,20 @@ atanhFloat x = prim_atanhFloat $# x
prim_atanhFloat :: Float -> Float
prim_atanhFloat external
(^) :: (Num a, Integral b) => a -> b -> a
x0 ^ y0 | y0 < 0 = error "Negative exponent"
| y0 == 0 = 1
| otherwise = f x0 y0
where -- f : x0 ^ y0 = x ^ y
f x y | even y = f (x * x) (y `quot` 2)
| y == 1 = x
| otherwise = g (x * x) (y `quot` 2) x
-- g : x0 ^ y0 = (x ^ y) * z
g x y z | even y = g (x * x) (y `quot` 2) z
| y == 1 = x * z
| otherwise = g (x * x) (y `quot` 2) (x * z)
class Monoid a where
mempty :: a
mappend :: a -> a -> a
......
------------------------------------------------------------------------------
--- Library to access parts of the system environment.
---
--- @author Michael Hanus, Bernd Brassel, Bjoern Peemoeller
--- @version July 2012
--- @category general
------------------------------------------------------------------------------
module System.Environment
( getArgs, getEnv, getEnvironment, setEnv, unsetEnv, getProgName
, getHostname, isPosix, isWindows
) where
import Global
--- Returns the list of the program's command line arguments.
--- The program name is not included.
getArgs :: IO [String]
getArgs external
--- Returns the value of an environment variable.
--- The empty string is returned for undefined environment variables.
getEnv :: String -> IO String
getEnv evar = do
envs <- getEnvironment
maybe (prim_getEnviron $## evar) return (lookup evar envs)
prim_getEnviron :: String -> IO String
prim_getEnviron external
getEnvironment :: IO [(String, String)]
getEnvironment = readGlobal environ
--- internal state of environment variables set via setEnviron
environ :: Global [(String,String)]
environ = global [] Temporary
--- Set an environment variable to a value.
--- The new value will be passed to subsequent shell commands
--- (see <code>system</code>) and visible to subsequent calls to
--- <code>getEnv</code> (but it is not visible in the environment
--- of the process that started the program execution).
setEnv :: String -> String -> IO ()
setEnv evar val = do
envs <- getEnvironment
writeGlobal environ ((evar,val) : filter ((/=evar) . fst) envs)
--- Removes an environment variable that has been set by
--- <code>setEnv</code>.
unsetEnv :: String -> IO ()
unsetEnv evar = do
envs <- getEnvironment
writeGlobal environ (filter ((/=evar) . fst) envs)
--- Returns the hostname of the machine running this process.
getHostname :: IO String
getHostname external
--- Returns the name of the current program, i.e., the name of the
--- main module currently executed.
getProgName :: IO String
getProgName external
--- Is the underlying operating system a POSIX system (unix, MacOS)?
isPosix :: Bool
isPosix = not isWindows
--- Is the underlying operating system a Windows system?
isWindows :: Bool
isWindows external
{-# LANGUAGE CPP #-}
import Control.Exception as C (IOException, handle)
import Network.BSD (getHostName)
import System.Environment (getArgs, getEnv, getProgName)
external_d_C_getArgs :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List Curry_Prelude.C_String)
external_d_C_getArgs _ _ = toCurry getArgs
external_d_C_prim_getEnviron :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_prim_getEnviron str _ _ =
toCurry (handle handleIOException . getEnv) str
where
handleIOException :: IOException -> IO String
handleIOException _ = return ""
external_d_C_getHostname :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_getHostname _ _ = toCurry getHostName
external_d_C_getProgName :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_getProgName _ _ = toCurry getProgName
external_d_C_isWindows :: Cover -> ConstStore -> Curry_Prelude.C_Bool
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
external_d_C_isWindows _ _ = Curry_Prelude.C_True
#else
external_d_C_isWindows _ _ = Curry_Prelude.C_False
#endif
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="getArgs" arity="0">
<library>prim_system</library>
<entry>prim_getArgs</entry>
</primitive>
<primitive name="prim_getEnviron" arity="1">
<library>prim_system</library>
<entry>prim_getEnviron</entry>
</primitive>
<primitive name="getHostname" arity="0">
<library>prim_system</library>
<entry>prim_getHostname</entry>
</primitive>
<primitive name="getProgName" arity="0">
<library>prim_system</library>
<entry>prim_getProgName</entry>
</primitive>
<primitive name="isWindows" arity="0">
<library>prim_system</library>
<entry>isWindows</entry>
</primitive>
</primitives>
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