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

Merge branch 'version3'

parents 967e8359 f5b6dd94
module Control.Applicative
( Applicative(..), liftA, liftA3, when
, sequenceA, sequenceA_
) where
--- Lift a function to actions.
--- This function may be used as a value for `fmap` in a `Functor` instance.
liftA :: Applicative f => (a -> b) -> f a -> f b
liftA f a = pure f <*> a
--- Lift a ternary function to actions.
liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 f a b c = liftA2 f a b <*> c
-- | Conditional execution of 'Applicative' expressions.
when :: (Applicative f) => Bool -> f () -> f ()
when p s = if p then s else pure ()
--- Evaluate each action in the list from left to right, and
--- collect the results. For a version that ignores the results
--- see 'sequenceA_'.
sequenceA :: (Applicative f) => [f a] -> f [a]
sequenceA [] = pure []
sequenceA (x:xs) = (:) <$> x <*> sequenceA xs
--- Evaluate each action in the structure from left to right, and
--- ignore the results. For a version that doesn't ignore the results
--- see 'sequenceA'.
sequenceA_ :: (Applicative f) => [f a] -> f ()
sequenceA_ = foldr (*>) (pure ())
module Control.Monad
( Functor(..), Applicative(..), Monad(..)
, filterM, (>=>), (<=<), forever, mapAndUnzipM, zipWithM
, zipWithM_, foldM, foldM_, replicateM, replicateM_
, when, unless, liftM3
) where
import Control.Applicative
--- This generalizes the list-based 'filter' function.
filterM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a]
filterM p = foldr (\ x -> liftA2 (\ flg -> if flg
then (x:)
else id)
(p x))
(pure [])
infixr 1 <=<, >=>
--- Left-to-right composition of Kleisli arrows.
(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
f >=> g = \x -> f x >>= g
--- Right-to-left composition of Kleisli arrows. @('>=>')@, with the arguments
--- flipped.
(<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
(<=<) = flip (>=>)
--- Repeat an action indefinitely.
forever :: (Applicative f) => f a -> f b
forever a = let a' = a *> a' in a'
-- -----------------------------------------------------------------------------
-- Other monad functions
--- The 'mapAndUnzipM' function maps its first argument over a list, returning
--- the result as a pair of lists. This function is mainly used with complicated
--- data structures or a state-transforming monad.
mapAndUnzipM :: (Applicative m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
mapAndUnzipM f xs = unzip <$> sequenceA (map f xs)
--- The 'zipWithM' function generalizes 'zipWith' to
--- arbitrary applicative functors.
zipWithM :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM f xs ys = sequenceA (zipWith f xs ys)
--- 'zipWithM_' is the extension of 'zipWithM' which ignores the final result.
zipWithM_ :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ f xs ys = sequenceA_ (zipWith f xs ys)
--- The 'foldM' function is analogous to 'foldl', except that its result is
--- encapsulated in a monad.
foldM :: (Monad m) => (b -> a -> m b) -> b -> [a] -> m b
foldM f z0 xs = foldr f' return xs z0
where f' x k z = f z x >>= k
--- Like 'foldM', but discards the result.
foldM_ :: (Monad m) => (b -> a -> m b) -> b -> [a] -> m ()
foldM_ f a xs = foldM f a xs >> return ()
--- @'replicateM' n act@ performs the action @n@ times,
--- gathering the results.
replicateM :: (Applicative m) => Int -> m a -> m [a]
replicateM cnt0 f =
loop cnt0
where
loop cnt
| cnt <= 0 = pure []
| otherwise = liftA2 (:) f (loop (cnt - 1))
--- Like 'replicateM', but discards the result.
replicateM_ :: (Applicative m) => Int -> m a -> m ()
replicateM_ cnt0 f =
loop cnt0
where
loop cnt
| cnt <= 0 = pure ()
| otherwise = f *> loop (cnt - 1)
--- The reverse of 'when'.
unless :: (Applicative f) => Bool -> f () -> f ()
unless p s = if p then pure () else s
liftM3 :: Monad m => (a -> b -> c -> d) -> m a -> m b -> m c -> m d
liftM3 f ma mb mc = do
a <- ma
b <- mb
c <- mc
return (f a b c)
......@@ -6,11 +6,12 @@
--- @category general
------------------------------------------------------------------------------
module Char
module Data.Char
( isAscii, isLatin1, isAsciiUpper, isAsciiLower, isControl
, isUpper, isLower, isAlpha, isDigit, isAlphaNum
, isBinDigit, isOctDigit, isHexDigit, isSpace
, toUpper, toLower, digitToInt, intToDigit
, ord, chr
) where
--- Returns true if the argument is an ASCII character.
......@@ -33,45 +34,6 @@ isAsciiUpper c = c >= 'A' && c <= 'Z'
isControl :: Char -> Bool
isControl c = c < '\x20' || c >= '\x7f' && c <= '\x9f'
--- Returns true if the argument is an uppercase letter.
isUpper :: Char -> Bool
isUpper c = c >= 'A' && c <= 'Z'
--- Returns true if the argument is an lowercase letter.
isLower :: Char -> Bool
isLower c = c >= 'a' && c <= 'z'
--- Returns true if the argument is a letter.
isAlpha :: Char -> Bool
isAlpha c = isUpper c || isLower c
--- Returns true if the argument is a decimal digit.
isDigit :: Char -> Bool
isDigit c = c >= '0' && c <= '9'
--- Returns true if the argument is a letter or digit.
isAlphaNum :: Char -> Bool
isAlphaNum c = isAlpha c || isDigit c
--- Returns true if the argument is a binary digit.
isBinDigit :: Char -> Bool
isBinDigit c = c >= '0' || c <= '1'
--- Returns true if the argument is an octal digit.
isOctDigit :: Char -> Bool
isOctDigit c = c >= '0' && c <= '7'
--- Returns true if the argument is a hexadecimal digit.
isHexDigit :: Char -> Bool
isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
|| c >= 'a' && c <= 'f'
--- Returns true if the argument is a white space.
isSpace :: Char -> Bool
isSpace c = c == ' ' || c == '\t' || c == '\n' ||
c == '\r' || c == '\f' || c == '\v' ||
c == '\xa0' || ord c `elem` [5760,6158,8192,8239,8287,12288]
--- Converts lowercase into uppercase letters.
toUpper :: Char -> Char
toUpper c | isLower c = chr (ord c - ord 'a' + ord 'A')
......
......@@ -6,7 +6,7 @@
--- @category general
--- ----------------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module Either
module Data.Either
( Either (..)
, either
, lefts
......
......@@ -5,7 +5,7 @@
--- @version July 2013
--- @category general
--- ----------------------------------------------------------------------------
module Function where
module Data.Function (fix, on) where
--- `fix f` is the least fixed point of the function `f`,
--- i.e. the least defined `x` such that `f x = x`.
......@@ -16,23 +16,3 @@ fix f = let x = f x in x
--- Typical usage: `sortBy (compare \`on\` fst)`.
on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
on op f x y = f x `op` f y
--- Apply a function to the first component of a tuple.
first :: (a -> b) -> (a, c) -> (b, c)
first f (x, y) = (f x, y)
--- Apply a function to the second component of a tuple.
second :: (a -> b) -> (c, a) -> (c, b)
second f (x, y) = (x, f y)
--- Apply two functions to the two components of a tuple.
(***) :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
f *** g = \ (x, y) -> (f x, g y)
--- Apply two functions to a value and returns a tuple of the results.
(&&&) :: (a -> b) -> (a -> c) -> a -> (b, c)
f &&& g = \x -> (f x, g x)
--- Apply a function to both components of a tuple.
both :: (a -> b) -> (a, a) -> (b, b)
both f (x, y) = (f x, f y)
module Data.Functor.Identity where
newtype Identity a = Identity { runIdentity :: a }
deriving (Eq, Ord, Read, Show)
instance Functor Identity where
fmap f (Identity a) = Identity $ f a
instance Applicative Identity where
pure = Identity
Identity f <*> Identity a = Identity (f a)
instance Monad Identity where
m >>= k = k (runIdentity m)
return a = Identity a
------------------------------------------------------------------------------
--- Library with some useful extensions to the IO monad.
---
--- @author Michael Hanus
--- @version January 2017
--- @category general
------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module Data.IORef
(
IORef, newIORef, readIORef, writeIORef, modifyIORef
) where
--- Mutable variables containing values of some type.
--- The values are not evaluated when they are assigned to an IORef.
#ifdef __PAKCS__
data IORef a = IORef a -- precise structure internally defined
#else
external data IORef _ -- precise structure internally defined
#endif
--- Creates a new IORef with an initial value.
newIORef :: a -> IO (IORef a)
newIORef external
--- Reads the current value of an IORef.
readIORef :: IORef a -> IO a
readIORef ref = prim_readIORef $# ref
prim_readIORef :: IORef a -> IO a
prim_readIORef external
--- Updates the value of an IORef.
writeIORef :: IORef a -> a -> IO ()
writeIORef ref val = (prim_writeIORef $# ref) val
prim_writeIORef :: IORef a -> a -> IO ()
prim_writeIORef external
--- Modify the value of an IORef.
modifyIORef :: IORef a -> (a -> a) -> IO ()
modifyIORef ref f = readIORef ref >>= writeIORef ref . f
{-# LANGUAGE MultiParamTypeClasses #-}
import Data.IORef
import System.IO.Unsafe (unsafePerformIO) -- for global associations
import System.Process (readProcessWithExitCode, runInteractiveCommand)
import Control.Concurrent (forkIO)
import System.IO
external_d_C_prim_execCmd :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_IO.C_Handle Curry_IO.C_Handle Curry_IO.C_Handle)
external_d_C_prim_execCmd str _ _ = toCurry
(\s -> do (h1,h2,h3,_) <- runInteractiveCommand s
return (OneHandle h1, OneHandle h2, OneHandle h3)) str
external_d_C_prim_evalCmd :: Curry_Prelude.C_String -> Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_Prelude.C_Int Curry_Prelude.C_String Curry_Prelude.C_String)
external_d_C_prim_evalCmd cmd args input _ _
= toCurry readProcessWithExitCode cmd args input
external_d_C_prim_connectToCmd :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_IO.C_Handle
external_d_C_prim_connectToCmd str _ _ = toCurry
(\s -> do (hin,hout,herr,_) <- runInteractiveCommand s
forkIO (forwardError herr)
return (InOutHandle hout hin)) str
forwardError :: Handle -> IO ()
forwardError h = do
eof <- hIsEOF h
if eof then return ()
else hGetLine h >>= hPutStrLn stderr >> forwardError h
-----------------------------------------------------------------------
-- Implementation of global associations as simple association lists
-- (could be later improved by a more efficient implementation, e.g., maps)
type Assocs = [(String,String)]
assocs :: IORef Assocs
assocs = unsafePerformIO (newIORef [])
external_d_C_prim_setAssoc :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_setAssoc str1 str2 _ _ = toCurry
(\key val -> do as <- readIORef assocs
writeIORef assocs ((key,val):as)) str1 str2
external_d_C_prim_getAssoc :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.C_String))
external_d_C_prim_getAssoc str _ _ = toCurry
(\key -> do as <- readIORef assocs
return (lookup key as)) str
-----------------------------------------------------------------------
-- Implementation of IORefs in Curry. Note that we store Curry values
......
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="prim_execCmd" arity="1">
<library>prim_ioexts</library>
<entry>prim_execCmd</entry>
</primitive>
<primitive name="prim_connectToCmd" arity="1">
<library>prim_ioexts</library>
<entry>prim_connectToCmd</entry>
</primitive>
<primitive name="prim_setAssoc" arity="2">
<library>prim_ioexts</library>
<entry>prim_setAssoc</entry>
</primitive>
<primitive name="prim_getAssoc" arity="1">
<library>prim_ioexts</library>
<entry>prim_getAssoc</entry>
</primitive>
<primitive name="newIORef" arity="1">
<library>prim_ioexts</library>
<entry>prim_newIORef[raw]</entry>
......
......@@ -6,15 +6,15 @@
--- @category general
------------------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
--{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module List
module Data.List
( elemIndex, elemIndices, find, findIndex, findIndices
, nub, nubBy, delete, deleteBy, (\\), union, intersect
, 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
......@@ -23,7 +23,7 @@ module List
, cycle, unfoldr
) where
import Maybe (listToMaybe)
import Data.Maybe (listToMaybe)
infix 5 \\
......@@ -134,11 +134,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]]
......@@ -251,9 +251,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)
......
......@@ -6,18 +6,15 @@
--- @category general
--- ----------------------------------------------------------------------------
module Maybe
module Data.Maybe
( Maybe (..)
, maybe
, isJust, isNothing
, fromJust, fromMaybe
, listToMaybe, maybeToList
, catMaybes, mapMaybe
, (>>-), sequenceMaybe, mapMMaybe, mplus
) where
infixl 1 >>-
--- Return `True` iff the argument is of the form `Just _`.
isJust :: Maybe _ -> Bool
isJust (Just _) = True
......@@ -59,27 +56,3 @@ catMaybes ms = [ m | (Just m) <- ms ]
--- constructor to a list of elements.
mapMaybe :: (a -> Maybe b) -> [a] -> [b]
mapMaybe f = catMaybes . map f
--- Monadic bind for Maybe.
--- Maybe can be interpreted as a monad where Nothing is interpreted
--- as the error case by this monadic binding.
--- @param maybeValue - Nothing or Just x
--- @param f - function to be applied to x
--- @return Nothing if maybeValue is Nothing, otherwise f is applied to x
(>>-) :: Maybe a -> (a -> Maybe b) -> Maybe b
Nothing >>- _ = Nothing
Just x >>- f = f x
--- Monadic `sequence` for `Maybe`.
sequenceMaybe :: [Maybe a] -> Maybe [a]
sequenceMaybe [] = Just []
sequenceMaybe (c:cs) = c >>- \x -> sequenceMaybe cs >>- \xs -> Just (x:xs)
--- Monadic `map` for `Maybe`.
mapMMaybe :: (a -> Maybe b) -> [a] -> Maybe [b]
mapMMaybe f = sequenceMaybe . map f
--- Combine two `Maybe`s, returning the first `Just` value, if any.
mplus :: Maybe a -> Maybe a -> Maybe a
Nothing `mplus` y = y
x@(Just _) `mplus` _ = x
......@@ -6,13 +6,14 @@
--- @category general
------------------------------------------------------------------------------
module Debug
module Debug.Trace
( trace, traceId, traceShow, traceShowId, traceIO
, assert, assertIO
) where
import IO (hPutStrLn, stderr)
import Unsafe (unsafePerformIO)
import Control.Monad (unless)
import System.IO (hPutStrLn, stderr)
import System.IO.Unsafe (unsafePerformIO)
--- Prints the first argument as a side effect and behaves as identity on the
--- second argument.
......
--- Library for accessing the directory structure of the
--- underlying operating system.
---
--- @author Michael Hanus
--- @version January 2013
--- @category general
module Directory
( doesFileExist, doesDirectoryExist, fileSize, getModificationTime
, getCurrentDirectory, setCurrentDirectory
, getDirectoryContents, createDirectory, createDirectoryIfMissing
, removeDirectory, renameDirectory
, getHomeDirectory, getTemporaryDirectory
, getAbsolutePath
, removeFile, renameFile, copyFile
) where
import FilePath (FilePath, (</>), splitDirectories, isAbsolute, normalise)
import List (isPrefixOf, scanl1, last)
import System (getEnviron, isWindows)
import Time (ClockTime)
--- Returns true if the argument is the name of an existing file.
doesFileExist :: FilePath -> IO Bool
doesFileExist fname = prim_doesFileExist $## fname
prim_doesFileExist :: FilePath -> IO Bool
prim_doesFileExist external
--- Returns true if the argument is the name of an existing directory.
doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist dir = prim_doesDirectoryExist $## dir
prim_doesDirectoryExist :: FilePath -> IO Bool
prim_doesDirectoryExist external
--- Returns the size of the file.
fileSize :: FilePath -> IO Int
fileSize fname = prim_fileSize $## fname
prim_fileSize :: FilePath -> IO Int
prim_fileSize external
--- Returns the modification time of the file.
getModificationTime :: FilePath -> IO ClockTime
getModificationTime fname = prim_getModificationTime $## fname
prim_getModificationTime :: FilePath -> IO ClockTime
prim_getModificationTime external
--- Returns the current working directory.
getCurrentDirectory :: IO FilePath
getCurrentDirectory external
--- Sets the current working directory.
setCurrentDirectory :: FilePath -> IO ()
setCurrentDirectory dir = prim_setCurrentDirectory $## dir
prim_setCurrentDirectory :: FilePath -> IO ()
prim_setCurrentDirectory external
--- Returns the list of all entries in a directory.
getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents dir = prim_getDirectoryContents $## dir
prim_getDirectoryContents :: FilePath -> IO [FilePath]
prim_getDirectoryContents external
--- Creates a new directory with the given name.
createDirectory :: FilePath -> IO ()
createDirectory dir = prim_createDirectory $## dir
prim_createDirectory :: FilePath -> IO ()
prim_createDirectory external
--- Creates a new directory with the given name if it does not already exist.
--- If the first parameter is `True` it will also create all missing
--- parent directories.
createDirectoryIfMissing :: Bool -> FilePath -> IO ()
createDirectoryIfMissing createParents path
= if createParents then createDirs parents
else createDirs [last parents]
where
parents = scanl1 (</>) $ splitDirectories $ path
createDirs [] = done
createDirs (d:ds) = do
exists <- doesDirectoryExist d
if exists then done else createDirectory d
createDirs ds
--- Deletes a directory from the file system.
removeDirectory :: FilePath -> IO ()
removeDirectory dir = prim_removeDirectory $## dir
prim_removeDirectory :: FilePath -> IO ()
prim_removeDirectory external
--- Renames a directory.
renameDirectory :: FilePath -> FilePath -> IO ()
renameDirectory dir1 dir2 = (prim_renameDirectory $## dir1) $## dir2
prim_renameDirectory :: FilePath -> FilePath -> IO ()
prim_renameDirectory external
--- Returns the home directory of the current user.
getHomeDirectory :: IO FilePath
getHomeDirectory = if isWindows
then getEnviron "USERPROFILE"
else getEnviron "HOME"
--- Returns the temporary directory of the operating system.
getTemporaryDirectory :: IO FilePath
getTemporaryDirectory = if isWindows then getEnviron "TMP" else return "/tmp"
--- Convert a path name into an absolute one.
--- For instance, a leading `~` is replaced by the current home directory.
getAbsolutePath :: FilePath -> IO FilePath
getAbsolutePath path
| isAbsolute path = return (normalise path)
| path == "~" = getHomeDirectory
| "~/" `isPrefixOf` path = do homedir <- getHomeDirectory
return (normalise (homedir </> drop 2 path))
| otherwise = do curdir <- getCurrentDirectory
return (normalise (curdir </> path))
--- Deletes a file from the file system.
removeFile :: FilePath -> IO ()
removeFile file = prim_removeFile $## file
prim_removeFile :: FilePath -> IO ()
prim_removeFile external
--- Renames a file.
renameFile :: FilePath -> FilePath -> IO ()
renameFile file1 file2 = (prim_renameFile $## file1) $## file2
prim_renameFile :: FilePath -> FilePath -> IO ()