pax_global_header00006660000000000000000000000064135560236220014516gustar00rootroot0000000000000052 comment=967e8359f51456f8a15fca659e9aadf3e8d2ea94 curry-libs-v2.2.0/000077500000000000000000000000001355602362200140005ustar00rootroot00000000000000curry-libs-v2.2.0/.gitignore000066400000000000000000000001531355602362200157670ustar00rootroot00000000000000# intermediate files *~ .curry Curry_Main_Goal.curry dist *.cabal AllLibraries.curry # documentation CDOC curry-libs-v2.2.0/Char.curry000066400000000000000000000067201355602362200157500ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful functions on characters. --- --- @author Michael Hanus, Bjoern Peemoeller --- @version January 2015 --- @category general ------------------------------------------------------------------------------ module Char ( isAscii, isLatin1, isAsciiUpper, isAsciiLower, isControl , isUpper, isLower, isAlpha, isDigit, isAlphaNum , isBinDigit, isOctDigit, isHexDigit, isSpace , toUpper, toLower, digitToInt, intToDigit ) where --- Returns true if the argument is an ASCII character. isAscii :: Char -> Bool isAscii c = c < '\x80' --- Returns true if the argument is an Latin-1 character. isLatin1 :: Char -> Bool isLatin1 c = c < '\xff' --- Returns true if the argument is an ASCII lowercase letter. isAsciiLower :: Char -> Bool isAsciiLower c = c >= 'a' && c <= 'z' --- Returns true if the argument is an ASCII uppercase letter. isAsciiUpper :: Char -> Bool isAsciiUpper c = c >= 'A' && c <= 'Z' --- Returns true if the argument is a control character. 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') | otherwise = c --- Converts uppercase into lowercase letters. toLower :: Char -> Char toLower c | isUpper c = chr (ord c - ord 'A' + ord 'a') | otherwise = c --- Converts a (hexadecimal) digit character into an integer. digitToInt :: Char -> Int digitToInt c | isDigit c = ord c - ord '0' | ord c >= ord 'A' && ord c <= ord 'F' = ord c - ord 'A' + 10 | ord c >= ord 'a' && ord c <= ord 'f' = ord c - ord 'a' + 10 | otherwise = error "Char.digitToInt: argument is not a digit" --- Converts an integer into a (hexadecimal) digit character. intToDigit :: Int -> Char intToDigit i | i >= 0 && i <= 9 = chr (ord '0' + i) | i >= 10 && i <= 15 = chr (ord 'A' + i - 10) | otherwise = error "Char.intToDigit: argument not a digit value" curry-libs-v2.2.0/Debug.curry000066400000000000000000000031571355602362200161220ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains some useful operation for debugging programs. --- --- @author Bjoern Peemoeller --- @version September 2014 --- @category general ------------------------------------------------------------------------------ module Debug ( trace, traceId, traceShow, traceShowId, traceIO , assert, assertIO ) where import IO (hPutStrLn, stderr) import Unsafe (unsafePerformIO) --- Prints the first argument as a side effect and behaves as identity on the --- second argument. trace :: String -> a -> a trace s x = unsafePerformIO (traceIO s >> return x) --- Prints the first argument as a side effect and returns it afterwards. traceId :: String -> String traceId a = trace a a --- Prints the first argument using `show` and returns the second argument --- afterwards. traceShow :: Show a => a -> b -> b traceShow a b = trace (show a) b --- Prints the first argument using `show` and returns it afterwards. traceShowId :: Show a => a -> a traceShowId a = trace (show a) a --- Output a trace message from the `IO` monad. traceIO :: String -> IO () traceIO m = hPutStrLn stderr m --- Assert a condition w.r.t. an error message. --- If the condition is not met it fails with the given error message, --- otherwise the third argument is returned. assert :: Bool -> String -> a -> a assert cond s x = if cond then x else error s --- Assert a condition w.r.t. an error message from the `IO` monad. --- If the condition is not met it fails with the given error message. assertIO :: Bool -> String -> IO () assertIO cond s = unless cond $ error s curry-libs-v2.2.0/Directory.curry000066400000000000000000000114171355602362200170360ustar00rootroot00000000000000--- 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 () prim_renameFile external --- Copy the contents from one file to another file copyFile :: FilePath -> FilePath -> IO () copyFile src dest = readFile src >>= writeFile dest curry-libs-v2.2.0/Directory.kics2000066400000000000000000000056421355602362200167100ustar00rootroot00000000000000import System.Directory import System.IO import System.Time external_d_C_prim_doesFileExist :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_doesFileExist s _ _ = toCurry doesFileExist s external_d_C_prim_doesDirectoryExist :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_doesDirectoryExist s _ _ = toCurry doesDirectoryExist s external_d_C_prim_fileSize :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_fileSize s _ _ = toCurry (\f -> do h <- openFile f ReadMode i <- hFileSize h hClose h return i ) s external_d_C_prim_getModificationTime :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Time.C_ClockTime external_d_C_prim_getModificationTime s _ _ = toCurry getModificationTime s external_d_C_getCurrentDirectory :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_String) external_d_C_getCurrentDirectory _ _ = toCurry getCurrentDirectory external_d_C_prim_setCurrentDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_setCurrentDirectory s _ _ = toCurry setCurrentDirectory s external_d_C_prim_getDirectoryContents :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List (Curry_Prelude.C_String)) external_d_C_prim_getDirectoryContents s _ _ = toCurry getDirectoryContents s external_d_C_prim_createDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_createDirectory s _ _ = toCurry createDirectory s external_d_C_prim_removeFile :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_removeFile s _ _ = toCurry removeFile s external_d_C_prim_removeDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_removeDirectory s _ _ = toCurry removeDirectory s external_d_C_prim_renameFile :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_renameFile s1 s2 _ _ = toCurry renameFile s1 s2 external_d_C_prim_renameDirectory :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_renameDirectory s1 s2 _ _= toCurry renameDirectory s1 s2 curry-libs-v2.2.0/Directory.pakcs000066400000000000000000000034311355602362200167700ustar00rootroot00000000000000 prim_directory prim_doesFileExist prim_directory prim_doesDirectoryExist prim_directory prim_fileSize prim_directory prim_getModificationTime prim_directory prim_getDirectoryContents prim_directory prim_getCurrentDirectory prim_directory prim_setCurrentDirectory prim_directory prim_createDirectory prim_directory prim_removeFile prim_directory prim_removeDirectory prim_directory prim_renameFile prim_directory prim_renameDirectory curry-libs-v2.2.0/Distribution.curry000066400000000000000000000045201355602362200175460ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains definition of constants to obtain information --- concerning the current distribution of the Curry implementation, e.g., --- compiler version, run-time version, installation directory. --- --- @author Michael Hanus --- @version December 2018 --- @category general -------------------------------------------------------------------------------- module Distribution ( curryCompiler, curryCompilerMajorVersion, curryCompilerMinorVersion , curryCompilerRevisionVersion , curryRuntime, curryRuntimeMajorVersion, curryRuntimeMinorVersion , baseVersion, installDir, rcFileName ) where import Directory ( getHomeDirectory ) import FilePath ( FilePath, () ) ----------------------------------------------------------------- -- Compiler and run-time environment name and version ----------------------------------------------------------------- --- The name of the Curry compiler (e.g., "pakcs" or "kics2"). curryCompiler :: String curryCompiler external --- The major version number of the Curry compiler. curryCompilerMajorVersion :: Int curryCompilerMajorVersion external --- The minor version number of the Curry compiler. curryCompilerMinorVersion :: Int curryCompilerMinorVersion external --- The revision version number of the Curry compiler. curryCompilerRevisionVersion :: Int curryCompilerRevisionVersion external --- The name of the run-time environment (e.g., "sicstus", "swi", or "ghc") curryRuntime :: String curryRuntime external --- The major version number of the Curry run-time environment. curryRuntimeMajorVersion :: Int curryRuntimeMajorVersion external --- The minor version number of the Curry run-time environment. curryRuntimeMinorVersion :: Int curryRuntimeMinorVersion external --- The version number of the base libraries (e.g., "1.0.5"). baseVersion :: String baseVersion external --- Path of the main installation directory of the Curry compiler. installDir :: FilePath installDir external --- The name of the file specifying configuration parameters of the --- current distribution. --- This file must have the usual format of property files. rcFileName :: IO String rcFileName = getHomeDirectory >>= return . ( rcFile) where rcFile = '.' : curryCompiler ++ "rc" ----------------------------------------------------------- curry-libs-v2.2.0/Distribution.kics2000066400000000000000000000024621355602362200174200ustar00rootroot00000000000000import qualified Installation as I external_d_C_curryCompiler :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_curryCompiler _ _ = toCurry I.compilerName external_d_C_curryCompilerMajorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryCompilerMajorVersion _ _ = toCurry I.majorVersion external_d_C_curryCompilerMinorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryCompilerMinorVersion _ _ = toCurry I.minorVersion external_d_C_curryCompilerRevisionVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryCompilerRevisionVersion _ _ = toCurry I.revisionVersion external_d_C_curryRuntime :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_curryRuntime _ _ = toCurry I.runtime external_d_C_curryRuntimeMajorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryRuntimeMajorVersion _ _ = toCurry I.runtimeMajor external_d_C_curryRuntimeMinorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryRuntimeMinorVersion _ _ = toCurry I.runtimeMinor external_d_C_baseVersion :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_baseVersion _ _ = toCurry I.baseVersion external_d_C_installDir :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_installDir _ _ = toCurry I.installDir curry-libs-v2.2.0/Distribution.pakcs000066400000000000000000000026631355602362200175110ustar00rootroot00000000000000 prim_distribution prim_curryCompiler prim_distribution prim_curryCompilerMajorVersion prim_distribution prim_curryCompilerMinorVersion prim_distribution prim_curryCompilerRevisionVersion prim_distribution prim_curryRuntime prim_distribution prim_curryRuntimeMajorVersion prim_distribution prim_curryRuntimeMinorVersion prim_distribution prim_baseVersion prim_distribution prim_installDir curry-libs-v2.2.0/Either.curry000066400000000000000000000032231355602362200163060ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Library with some useful operations for the `Either` data type. --- --- @author Bjoern Peemoeller --- @version March 2015 --- @category general --- ---------------------------------------------------------------------------- {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Either ( Either (..) , either , lefts , rights , isLeft , isRight , fromLeft , fromRight , partitionEithers ) where --- Extracts from a list of `Either` all the `Left` elements in order. lefts :: [Either a b] -> [a] lefts x = [a | Left a <- x] --- Extracts from a list of `Either` all the `Right` elements in order. rights :: [Either a b] -> [b] rights x = [a | Right a <- x] --- Return `True` if the given value is a `Left`-value, `False` otherwise. isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft (Right _) = False --- Return `True` if the given value is a `Right`-value, `False` otherwise. isRight :: Either a b -> Bool isRight (Left _) = False isRight (Right _) = True --- Extract the value from a `Left` constructor. fromLeft :: Either a _ -> a fromLeft (Left x) = x --- Extract the value from a `Right` constructor. fromRight :: Either _ b -> b fromRight (Right x) = x --- Partitions a list of `Either` into two lists. --- All the `Left` elements are extracted, in order, to the first --- component of the output. Similarly the `Right` elements are extracted --- to the second component of the output. partitionEithers :: [Either a b] -> ([a],[b]) partitionEithers = foldr (either left right) ([],[]) where left a (l, r) = (a:l, r) right a (l, r) = (l, a:r) curry-libs-v2.2.0/ErrorState.curry000066400000000000000000000045101355602362200171600ustar00rootroot00000000000000--- --------------------------------------------------------------------------- --- A combination of Error and state monad like `ErrorT State` in Haskell. --- --- @author Bjoern Peemoeller --- @version September 2014 --- @category general --- ---------------------------------------------------------------------------- module ErrorState where infixl 1 >+, >+= infixl 4 <$>, <*> --- Error state monad. type ES e s a = s -> Either e (a, s) --- Evaluate an `ES` monad evalES :: ES e s a -> s -> Either e a evalES m s = case m s of Left e -> Left e Right (x, _) -> Right x --- Lift a value into the `ES` monad returnES :: a -> ES e s a returnES x s = Right (x, s) --- Failing computation in the `ES` monad failES :: e -> ES e s a failES e _ = Left e --- Bind of the `ES` monad (>+=) :: ES e s a -> (a -> ES e s b) -> ES e s b m >+= f = \s -> case m s of Left e -> Left e Right (x, s') -> f x s' --- Sequence operator of the `ES` monad (>+) :: ES e s a -> ES e s b -> ES e s b m >+ n = m >+= \_ -> n --- Apply a pure function onto a monadic value. (<$>) :: (a -> b) -> ES e s a -> ES e s b f <$> act = act >+= \x -> returnES (f x) --- Apply a function yielded by a monadic action to a monadic value. (<*>) :: ES e s (a -> b) -> ES e s a -> ES e s b sf <*> sx = sf >+= \f -> sx >+= \x -> returnES (f x) --- Retrieve the current state gets :: ES e s s gets s = Right (s, s) --- Replace the current state puts :: s -> ES e s () puts s _ = Right ((), s) --- Modify the current state modify :: (s -> s) -> ES e s () modify f s = Right ((), f s) --- Map a monadic function on all elements of a list by sequencing --- the effects. mapES :: (a -> ES e s b) -> [a] -> ES e s [b] mapES _ [] = returnES [] mapES f (x : xs) = f x >+= \y -> mapES f xs >+= \ys -> returnES (y:ys) --- Same as `concatMap`, but for a monadic function. concatMapES :: (a -> ES e s [b]) -> [a] -> ES e s [b] concatMapES f xs = concat <$> mapES f xs --- Same as `mapES` but with an additional accumulator threaded through. mapAccumES :: (a -> b -> ES e s (a, c)) -> a -> [b] -> ES e s (a, [c]) mapAccumES _ s [] = returnES (s, []) mapAccumES f s (x : xs) = f s x >+= \(s', y) -> mapAccumES f s' xs >+= \(s'', ys) -> returnES (s'', y:ys) curry-libs-v2.2.0/FileGoodies.curry000066400000000000000000000077751355602362200172770ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A collection of useful operations when dealing with files. --- --- @author Michael Hanus, Bernd Brassel --- @version June 2009 --- @category general ------------------------------------------------------------------------------ module FileGoodies ( separatorChar, pathSeparatorChar, suffixSeparatorChar , isAbsolute, dirName, baseName, splitDirectoryBaseName , stripSuffix, fileSuffix, splitBaseName, splitPath , lookupFileInPath, getFileInPath ) where import Directory ( doesFileExist ) import List ( intersperse ) --- The character for separating hierarchies in file names. --- On UNIX systems the value is '/'. separatorChar :: Char separatorChar = '/' --- The character for separating names in path expressions. --- On UNIX systems the value is ':'. pathSeparatorChar :: Char pathSeparatorChar = ':' --- The character for separating suffixes in file names. --- On UNIX systems the value is '.'. suffixSeparatorChar :: Char suffixSeparatorChar = '.' --- Is the argument an absolute name? isAbsolute :: String -> Bool isAbsolute (c:_) = c == separatorChar isAbsolute [] = False --- Extracts the directoy prefix of a given (Unix) file name. --- Returns "." if there is no prefix. dirName :: String -> String dirName name = fst (splitDirectoryBaseName name) --- Extracts the base name without directoy prefix of a given (Unix) file name. baseName :: String -> String baseName name = snd (splitDirectoryBaseName name) --- Splits a (Unix) file name into the directory prefix and the base name. --- The directory prefix is "." if there is no real prefix in the name. splitDirectoryBaseName :: String -> (String,String) splitDirectoryBaseName name = let (rbase,rdir) = break (==separatorChar) (reverse name) in if null rdir then (".",reverse rbase) else (reverse (tail rdir), reverse rbase) --- Strips a suffix (the last suffix starting with a dot) from a file name. stripSuffix :: String -> String stripSuffix = fst . splitBaseName --- Yields the suffix (the last suffix starting with a dot) --- from given file name. fileSuffix :: String -> String fileSuffix = snd . splitBaseName --- Splits a file name into prefix and suffix --- (the last suffix starting with a dot and the rest). splitBaseName :: String -> (String,String) splitBaseName name = let (rsuffix,rbase) = break (==suffixSeparatorChar) (reverse name) in if null rbase || elem separatorChar rsuffix then (name,"") else (reverse (tail rbase),reverse rsuffix) --- Splits a path string into list of directory names. splitPath :: String -> [String] splitPath [] = [] splitPath (x:xs) = let (ys,zs) = break (==pathSeparatorChar) (x:xs) in if null zs then [ys] else ys : splitPath (tail zs) --- Looks up the first file with a possible suffix in a list of directories. --- Returns Nothing if such a file does not exist. lookupFileInPath :: String -> [String] -> [String] -> IO (Maybe String) lookupFileInPath file suffixes path = if isAbsolute file then lookupFirstFileWithSuffix file suffixes else lookupFirstFile path where lookupFirstFile [] = return Nothing lookupFirstFile (dir:dirs) = do mbfile <- lookupFirstFileWithSuffix (dir++separatorChar:file) suffixes maybe (lookupFirstFile dirs) (return . Just) mbfile lookupFirstFileWithSuffix _ [] = return Nothing lookupFirstFileWithSuffix f (suf:sufs) = do let fsuf = f++suf exfile <- doesFileExist fsuf if exfile then return (Just fsuf) else lookupFirstFileWithSuffix f sufs --- Gets the first file with a possible suffix in a list of directories. --- An error message is delivered if there is no such file. getFileInPath :: String -> [String] -> [String] -> IO String getFileInPath file suffixes path = do mbfile <- lookupFileInPath file suffixes path maybe (error $ "File "++file++" not found in path "++ concat (intersperse [pathSeparatorChar] path)) return mbfile curry-libs-v2.2.0/FilePath.curry000066400000000000000000000733321355602362200165720ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library is a direct port of the Haskell library System.FilePath --- of Neil Mitchell. --- --- @author Bjoern Peemoeller --- @version November 2011 --- @category general ------------------------------------------------------------------------------ -- -- Some short examples: -- -- You are given a C file, you want to figure out the corresponding object (.o) file: -- -- @'replaceExtension' file \"o\"@ -- -- Haskell module Main imports Test, you have the file named main: -- -- @['replaceFileName' path_to_main \"Test\" '<.>' ext | ext <- [\"hs\",\"lhs\"] ]@ -- -- You want to download a file from the web and save it to disk: -- -- @do let file = 'makeValid' url -- System.IO.createDirectoryIfMissing True ('takeDirectory' file)@ -- -- You want to compile a Haskell file, but put the hi file under \"interface\" -- -- @'takeDirectory' file '' \"interface\" '' ('takeFileName' file \`replaceExtension\` \"hi\"@) -- -- The examples in code format descibed by each function are used to generate -- tests, and should give clear semantics for the functions. ----------------------------------------------------------------------------- module FilePath ( -- * Separator predicates FilePath, pathSeparator, pathSeparators, isPathSeparator, searchPathSeparator, isSearchPathSeparator, extSeparator, isExtSeparator, -- * Path methods (environment $PATH) splitSearchPath, getSearchPath, -- * Extension methods splitExtension, takeExtension, replaceExtension, dropExtension, addExtension, hasExtension, (<.>), splitExtensions, dropExtensions, takeExtensions, isExtensionOf, -- * Drive methods splitDrive, joinDrive, takeDrive, hasDrive, dropDrive, isDrive, -- * Operations on a FilePath, as a list of directories splitFileName, takeFileName, replaceFileName, dropFileName, takeBaseName, replaceBaseName, takeDirectory, replaceDirectory, combine, (), splitPath, joinPath, splitDirectories, -- * Low level FilePath operators hasTrailingPathSeparator, addTrailingPathSeparator, dropTrailingPathSeparator, -- * File name manipulators normalise, equalFilePath, makeRelative, isRelative, isAbsolute, isValid, makeValid ) where import Char (toLower, toUpper) import List (isPrefixOf, isSuffixOf, init, last) import Maybe (isJust, fromJust) import System (getEnviron, isPosix, isWindows) infixr 7 <.> infixr 5 type FilePath = String --------------------------------------------------------------------- -- The basic functions -- | The character that separates directories. In the case where more than -- one character is possible, 'pathSeparator' is the \'ideal\' one. -- -- > Windows: pathSeparator == '\\' -- > Posix: pathSeparator == '/' -- > isPathSeparator pathSeparator pathSeparator :: Char pathSeparator = if isWindows then '\\' else '/' -- | The list of all possible separators. -- -- > Windows: pathSeparators == ['\\', '/'] -- > Posix: pathSeparators == ['/'] -- > pathSeparator `elem` pathSeparators pathSeparators :: [Char] pathSeparators = if isWindows then "\\/" else "/" -- | Rather than using @(== 'pathSeparator')@, use this. Test if something -- is a path separator. -- -- > isPathSeparator a == (a `elem` pathSeparators) isPathSeparator :: Char -> Bool isPathSeparator = (`elem` pathSeparators) -- | The character that is used to separate the entries in the $PATH -- environment variable. -- -- > Windows: searchPathSeparator == ';' -- > Posix: searchPathSeparator == ':' searchPathSeparator :: Char searchPathSeparator = if isWindows then ';' else ':' -- | Is the character a file separator? -- -- > isSearchPathSeparator a == (a == searchPathSeparator) isSearchPathSeparator :: Char -> Bool isSearchPathSeparator = (== searchPathSeparator) -- | File extension character -- -- > extSeparator == '.' extSeparator :: Char extSeparator = '.' -- | Is the character an extension character? -- -- > isExtSeparator a == (a == extSeparator) isExtSeparator :: Char -> Bool isExtSeparator = (== extSeparator) --------------------------------------------------------------------- -- Path methods (environment $PATH) -- | Take a string, split it on the 'searchPathSeparator' character. -- -- Follows the recommendations in -- -- -- > Posix: splitSearchPath "File1:File2:File3" == ["File1","File2","File3"] -- > Posix: splitSearchPath "File1::File2:File3" == ["File1",".","File2","File3"] -- > Windows: splitSearchPath "File1;File2;File3" == ["File1","File2","File3"] -- > Windows: splitSearchPath "File1;;File2;File3" == ["File1","File2","File3"] splitSearchPath :: String -> [FilePath] splitSearchPath = f where f xs = case break isSearchPathSeparator xs of (pre, [] ) -> g pre (pre, _:post) -> g pre ++ f post g [] = ["." | isPosix] g x@(_:_) = [x] -- | Get a list of filepaths in the $PATH. getSearchPath :: IO [FilePath] getSearchPath = getEnviron "PATH" >>= return . splitSearchPath --------------------------------------------------------------------- -- Extension methods -- | Split on the extension. 'addExtension' is the inverse. -- -- > uncurry (++) (splitExtension x) == x -- > uncurry addExtension (splitExtension x) == x -- > splitExtension "file.txt" == ("file",".txt") -- > splitExtension "file" == ("file","") -- > splitExtension "file/file.txt" == ("file/file",".txt") -- > splitExtension "file.txt/boris" == ("file.txt/boris","") -- > splitExtension "file.txt/boris.ext" == ("file.txt/boris",".ext") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) splitExtension x = case d of [] -> (x,"") (y:ys) -> (a ++ reverse ys, y : reverse c) where (a,b) = splitFileName_ x (c,d) = break isExtSeparator $ reverse b -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- -- > takeExtension x == snd (splitExtension x) -- > Valid x => takeExtension (addExtension x "ext") == ".ext" -- > Valid x => takeExtension (replaceExtension x "ext") == ".ext" takeExtension :: FilePath -> String takeExtension = snd . splitExtension -- | Set the extension of a file, overwriting one if already present. -- -- > replaceExtension "file.txt" ".bob" == "file.bob" -- > replaceExtension "file.txt" "bob" == "file.bob" -- > replaceExtension "file" ".bob" == "file.bob" -- > replaceExtension "file.txt" "" == "file" -- > replaceExtension "file.fred.bob" "txt" == "file.fred.txt" replaceExtension :: FilePath -> String -> FilePath replaceExtension x y = dropExtension x <.> y -- | Alias to 'addExtension', for people who like that sort of thing. (<.>) :: FilePath -> String -> FilePath (<.>) = addExtension -- | Remove last extension, and the \".\" preceding it. -- -- > dropExtension x == fst (splitExtension x) dropExtension :: FilePath -> FilePath dropExtension = fst . splitExtension -- | Add an extension, even if there is already one there. -- E.g. @addExtension \"foo.txt\" \"bat\" -> \"foo.txt.bat\"@. -- -- > addExtension "file.txt" "bib" == "file.txt.bib" -- > addExtension "file." ".bib" == "file..bib" -- > addExtension "file" ".bib" == "file.bib" -- > addExtension "/" "x" == "/.x" -- > Valid x => takeFileName (addExtension (addTrailingPathSeparator x) "ext") == ".ext" -- > Windows: addExtension "\\\\share" ".txt" == "\\\\share\\.txt" addExtension :: FilePath -> String -> FilePath addExtension file [] = file addExtension file xs@(x:_) = joinDrive a res where res = if isExtSeparator x then b ++ xs else b ++ [extSeparator] ++ xs (a,b) = splitDrive file -- | Does the given filename have an extension? -- -- > null (takeExtension x) == not (hasExtension x) hasExtension :: FilePath -> Bool hasExtension = any isExtSeparator . takeFileName -- | Split on all extensions -- -- > uncurry (++) (splitExtensions x) == x -- > uncurry addExtension (splitExtensions x) == x -- > splitExtensions "file.tar.gz" == ("file",".tar.gz") splitExtensions :: FilePath -> (FilePath, String) splitExtensions x = (a ++ c, d) where (a,b) = splitFileName_ x (c,d) = break isExtSeparator b -- | Drop all extensions -- -- > not $ hasExtension (dropExtensions x) dropExtensions :: FilePath -> FilePath dropExtensions = fst . splitExtensions -- | Get all extensions -- -- > takeExtensions "file.tar.gz" == ".tar.gz" takeExtensions :: FilePath -> String takeExtensions = snd . splitExtensions -- | Does the given filename have the specified extension? -- -- > "png" `isExtensionOf` "/directory/file.png" == True -- > ".png" `isExtensionOf` "/directory/file.png" == True -- > ".tar.gz" `isExtensionOf` "bar/foo.tar.gz" == True -- > "ar.gz" `isExtensionOf` "bar/foo.tar.gz" == False -- > "png" `isExtensionOf` "/directory/file.png.jpg" == False -- > "csv/table.csv" `isExtensionOf` "/data/csv/table.csv" == False isExtensionOf :: String -> FilePath -> Bool isExtensionOf extension path = case extension of ext@('.':_) -> isSuffixOf ext $ takeExtensions path ext -> isSuffixOf ('.':ext) $ takeExtensions path --------------------------------------------------------------------- -- Drive methods -- | Is the given character a valid drive letter? -- only a-z and A-Z are letters, not isAlpha which is more unicodey isLetter :: Char -> Bool isLetter x = (x >= 'a' && x <= 'z') || (x >= 'A' && x <= 'Z') -- | Split a path into a drive and a path. -- On Unix, \/ is a Drive. -- -- > uncurry (++) (splitDrive x) == x -- > Windows: splitDrive "file" == ("","file") -- > Windows: splitDrive "c:/file" == ("c:/","file") -- > Windows: splitDrive "c:\\file" == ("c:\\","file") -- > Windows: splitDrive "\\\\shared\\test" == ("\\\\shared\\","test") -- > Windows: splitDrive "\\\\shared" == ("\\\\shared","") -- > Windows: splitDrive "\\\\?\\UNC\\shared\\file" == ("\\\\?\\UNC\\shared\\","file") -- > Windows: splitDrive "\\\\?\\UNCshared\\file" == ("\\\\?\\","UNCshared\\file") -- > Windows: splitDrive "\\\\?\\d:\\file" == ("\\\\?\\d:\\","file") -- > Windows: splitDrive "/d" == ("","/d") -- > Posix: splitDrive "/test" == ("/","test") -- > Posix: splitDrive "//test" == ("//","test") -- > Posix: splitDrive "test/file" == ("","test/file") -- > Posix: splitDrive "file" == ("","file") splitDrive :: FilePath -> (FilePath, FilePath) splitDrive x | isPosix = span (== '/') x | isJust dl = fromJust dl | isJust unc = fromJust unc | isJust shr = fromJust shr | otherwise = ("",x) where dl = readDriveLetter x unc = readDriveUNC x shr = readDriveShare x addSlash :: FilePath -> FilePath -> (FilePath, FilePath) addSlash a xs = (a++c,d) where (c,d) = span isPathSeparator xs -- http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp -- "\\?\D:\" or "\\?\UNC\\" -- a is "\\?\" readDriveUNC :: FilePath -> Maybe (FilePath, FilePath) readDriveUNC path = case path of (s1:s2:'?':s3:xs) -> if all isPathSeparator [s1,s2,s3] then let rdl = case readDriveLetter xs of Just (a,b) -> Just (s1:s2:'?':s3:a,b) Nothing -> Nothing in case map toUpper xs of ('U':'N':'C':s4:_) -> if isPathSeparator s4 then let (a,b) = readDriveShareName (drop 4 xs) in Just (s1:s2:'?':s3:take 4 xs ++ a, b) else rdl _ -> rdl else Nothing _ -> Nothing {- c:\ -} readDriveLetter :: String -> Maybe (FilePath, FilePath) readDriveLetter path = case path of (x:':':y:xs) -> if isLetter x && isPathSeparator y then Just $ addSlash [x,':'] (y:xs) else if isLetter x then Just ([x,':'], (y:xs)) else Nothing (x:':':xs) -> if isLetter x then Just ([x,':'], xs) else Nothing _ -> Nothing {- \\sharename\ -} readDriveShare :: String -> Maybe (FilePath, FilePath) readDriveShare path = case path of (s1:s2:xs) -> if isPathSeparator s1 && isPathSeparator s2 then let (a,b) = readDriveShareName xs in Just (s1:s2:a,b) else Nothing _ -> Nothing {- assume you have already seen \\ -} {- share\bob -> "share","\","bob" -} readDriveShareName :: String -> (FilePath, FilePath) readDriveShareName name = addSlash a b where (a,b) = break isPathSeparator name -- | Join a drive and the rest of the path. -- -- > uncurry joinDrive (splitDrive x) == x -- > Windows: joinDrive "C:" "foo" == "C:foo" -- > Windows: joinDrive "C:\\" "bar" == "C:\\bar" -- > Windows: joinDrive "\\\\share" "foo" == "\\\\share\\foo" -- > Windows: joinDrive "/:" "foo" == "/:\\foo" joinDrive :: FilePath -> FilePath -> FilePath joinDrive a b | isPosix = a ++ b | null a = b | null b = a | isPathSeparator (last a) = a ++ b | otherwise = case a of [a1,':'] -> if isLetter a1 then a ++ b else a ++ [pathSeparator] ++ b _ -> a ++ [pathSeparator] ++ b -- | Get the drive from a filepath. -- -- > takeDrive x == fst (splitDrive x) takeDrive :: FilePath -> FilePath takeDrive = fst . splitDrive -- | Delete the drive, if it exists. -- -- > dropDrive x == snd (splitDrive x) dropDrive :: FilePath -> FilePath dropDrive = snd . splitDrive -- | Does a path have a drive. -- -- > not (hasDrive x) == null (takeDrive x) hasDrive :: FilePath -> Bool hasDrive = not . null . takeDrive -- | Is an element a drive isDrive :: FilePath -> Bool isDrive = null . dropDrive --------------------------------------------------------------------- -- Operations on a filepath, as a list of directories -- | Split a filename into directory and file. 'combine' is the inverse. -- -- > Valid x => uncurry () (splitFileName x) == x || fst (splitFileName x) == "./" -- > Valid x => isValid (fst (splitFileName x)) -- > splitFileName "file/bob.txt" == ("file/", "bob.txt") -- > splitFileName "file/" == ("file/", "") -- > splitFileName "bob" == ("./", "bob") -- > Posix: splitFileName "/" == ("/","") -- > Windows: splitFileName "c:" == ("c:","") splitFileName :: FilePath -> (String, String) splitFileName x = (if null dir then "./" else dir, name) where (dir, name) = splitFileName_ x -- version of splitFileName where, if the FilePath has no directory -- component, the returned directory is "" rather than "./". This -- is used in cases where we are going to combine the returned -- directory to make a valid FilePath, and having a "./" appear would -- look strange and upset simple equality properties. See -- e.g. replaceFileName. splitFileName_ :: FilePath -> (String, String) splitFileName_ x = (c ++ reverse b, reverse a) where (a,b) = break isPathSeparator $ reverse d (c,d) = splitDrive x -- | Set the filename. -- -- > Valid x => replaceFileName x (takeFileName x) == x replaceFileName :: FilePath -> String -> FilePath replaceFileName x y = a y where (a,_) = splitFileName_ x -- | Drop the filename. -- -- > dropFileName x == fst (splitFileName x) dropFileName :: FilePath -> FilePath dropFileName = fst . splitFileName -- | Get the file name. -- -- > takeFileName "test/" == "" -- > takeFileName x `isSuffixOf` x -- > takeFileName x == snd (splitFileName x) -- > Valid x => takeFileName (replaceFileName x "fred") == "fred" -- > Valid x => takeFileName (x "fred") == "fred" -- > Valid x => isRelative (takeFileName x) takeFileName :: FilePath -> FilePath takeFileName = snd . splitFileName -- | Get the base name, without an extension or path. -- -- > takeBaseName "file/test.txt" == "test" -- > takeBaseName "dave.ext" == "dave" -- > takeBaseName "" == "" -- > takeBaseName "test" == "test" -- > takeBaseName (addTrailingPathSeparator x) == "" -- > takeBaseName "file/file.tar.gz" == "file.tar" takeBaseName :: FilePath -> String takeBaseName = dropExtension . takeFileName -- | Set the base name. -- -- > replaceBaseName "file/test.txt" "bob" == "file/bob.txt" -- > replaceBaseName "fred" "bill" == "bill" -- > replaceBaseName "/dave/fred/bob.gz.tar" "new" == "/dave/fred/new.tar" -- > Valid x => replaceBaseName x (takeBaseName x) == x replaceBaseName :: FilePath -> String -> FilePath replaceBaseName pth nam = combineAlways a (nam <.> ext) where (a,b) = splitFileName_ pth ext = takeExtension b -- | Is an item either a directory or the last character a path separator? -- -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool hasTrailingPathSeparator [] = False hasTrailingPathSeparator x@(_:_) = isPathSeparator (last x) -- | Add a trailing file path separator if one is not already present. -- -- > hasTrailingPathSeparator (addTrailingPathSeparator x) -- > hasTrailingPathSeparator x ==> addTrailingPathSeparator x == x -- > Posix: addTrailingPathSeparator "test/rest" == "test/rest/" addTrailingPathSeparator :: FilePath -> FilePath addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pathSeparator] -- | Remove any trailing path separators -- -- > dropTrailingPathSeparator "file/test/" == "file/test" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x -- > Posix: dropTrailingPathSeparator "/" == "/" -- > Windows: dropTrailingPathSeparator "\\" == "\\" dropTrailingPathSeparator :: FilePath -> FilePath dropTrailingPathSeparator x = if hasTrailingPathSeparator x && not (isDrive x) then let x' = reverse $ dropWhile isPathSeparator $ reverse x in if null x' then [pathSeparator] else x' else x -- | Get the directory name, move up one level. -- -- > takeDirectory x `isPrefixOf` x || takeDirectory x == "." -- > takeDirectory "foo" == "." -- > takeDirectory "/foo/bar/baz" == "/foo/bar" -- > takeDirectory "/foo/bar/baz/" == "/foo/bar/baz" -- > takeDirectory "foo/bar/baz" == "foo/bar" -- > Windows: takeDirectory "foo\\bar" == "foo" -- > Windows: takeDirectory "foo\\bar\\\\" == "foo\\bar" -- > Windows: takeDirectory "C:\\" == "C:\\" takeDirectory :: FilePath -> FilePath takeDirectory x = if isDrive file then file else if null res && not (null file) then file else res where res = reverse $ dropWhile isPathSeparator $ reverse file file = dropFileName x _ = isPrefixOf x -- warning suppression -- | Set the directory, keeping the filename the same. -- -- > Valid x => replaceDirectory x (takeDirectory x) `equalFilePath` x replaceDirectory :: FilePath -> String -> FilePath replaceDirectory x dir = combineAlways dir (takeFileName x) -- | Combine two paths, if the second path 'isAbsolute', then it returns the second. -- -- > Valid x => combine (takeDirectory x) (takeFileName x) `equalFilePath` x -- > Posix: combine "/" "test" == "/test" -- > Posix: combine "home" "bob" == "home/bob" -- > Windows: combine "home" "bob" == "home\\bob" -- > Windows: combine "home" "/bob" == "/bob" combine :: FilePath -> FilePath -> FilePath combine a b | hasDrive b || (not (null b) && isPathSeparator (head b)) = b | otherwise = combineAlways a b -- | Combine two paths, assuming rhs is NOT absolute. combineAlways :: FilePath -> FilePath -> FilePath combineAlways a b | null a = b | null b = a | isPathSeparator (last a) = a ++ b | isDrive a = joinDrive a b | otherwise = a ++ [pathSeparator] ++ b -- | A nice alias for 'combine'. () :: FilePath -> FilePath -> FilePath () = combine -- | Split a path by the directory separator. -- -- > concat (splitPath x) == x -- > splitPath "test//item/" == ["test//","item/"] -- > splitPath "test/item/file" == ["test/","item/","file"] -- > splitPath "" == [] -- > Windows: splitPath "c:\\test\\path" == ["c:\\","test\\","path"] -- > Posix: splitPath "/file/test" == ["/","file/","test"] splitPath :: FilePath -> [FilePath] splitPath x = [drive | drive /= ""] ++ f path where (drive,path) = splitDrive x f [] = [] f y@(_:_) = (a ++ c) : f d where (a,b) = break isPathSeparator y (c,d) = break (not . isPathSeparator) b -- | Just as 'splitPath', but don't add the trailing slashes to each element. -- -- > splitDirectories "test/file" == ["test","file"] -- > splitDirectories "/test/file" == ["/","test","file"] -- > Valid x => joinPath (splitDirectories x) `equalFilePath` x -- > splitDirectories "" == [] splitDirectories :: FilePath -> [FilePath] splitDirectories path = if hasDrive path then head pathComponents : f (tail pathComponents) else f pathComponents where pathComponents = splitPath path f xs = map g xs g x = if null res then x else res where res = takeWhile (not . isPathSeparator) x -- | Join path elements back together. -- -- > Valid x => joinPath (splitPath x) == x -- > joinPath [] == "" -- > Posix: joinPath ["test","file","path"] == "test/file/path" -- Note that this definition on c:\\c:\\, join then split will give c:\\. joinPath :: [FilePath] -> FilePath joinPath x = foldr combine "" x --------------------------------------------------------------------- -- File name manipulators -- | Equality of two 'FilePath's. -- If you call @System.Directory.canonicalizePath@ -- first this has a much better chance of working. -- Note that this doesn't follow symlinks or DOSNAM~1s. -- -- > x == y ==> equalFilePath x y -- > normalise x == normalise y ==> equalFilePath x y -- > Posix: equalFilePath "foo" "foo/" -- > Posix: not (equalFilePath "foo" "/foo") -- > Posix: not (equalFilePath "foo" "FOO") -- > Windows: equalFilePath "foo" "FOO" equalFilePath :: FilePath -> FilePath -> Bool equalFilePath a b = f a == f b where f x | isWindows = dropTrailSlash $ map toLower $ normalise x | otherwise = dropTrailSlash $ normalise x dropTrailSlash x | length x >= 2 && isPathSeparator (last x) = init x | otherwise = x -- | Contract a filename, based on a relative path. -- -- There is no corresponding @makeAbsolute@ function, instead use -- @System.Directory.canonicalizePath@ which has the same effect. -- -- > Valid y => equalFilePath x y || (isRelative x && makeRelative y x == x) || equalFilePath (y makeRelative y x) x -- > makeRelative x x == "." -- > null y || equalFilePath (makeRelative x (x y)) y || null (takeFileName x) -- > Windows: makeRelative "C:\\Home" "c:\\home\\bob" == "bob" -- > Windows: makeRelative "C:\\Home" "c:/home/bob" == "bob" -- > Windows: makeRelative "C:\\Home" "D:\\Home\\Bob" == "D:\\Home\\Bob" -- > Windows: makeRelative "C:\\Home" "C:Home\\Bob" == "C:Home\\Bob" -- > Windows: makeRelative "/Home" "/home/bob" == "bob" -- > Posix: makeRelative "/Home" "/home/bob" == "/home/bob" -- > Posix: makeRelative "/home/" "/home/bob/foo/bar" == "bob/foo/bar" -- > Posix: makeRelative "/fred" "bob" == "bob" -- > Posix: makeRelative "/file/test" "/file/test/fred" == "fred" -- > Posix: makeRelative "/file/test" "/file/test/fred/" == "fred/" -- > Posix: makeRelative "some/path" "some/path/a/b/c" == "a/b/c" makeRelative :: FilePath -> FilePath -> FilePath makeRelative root path | equalFilePath root path = "." | takeAbs root /= takeAbs path = path | otherwise = f (dropAbs root) (dropAbs path) where f [] y = dropWhile isPathSeparator y f x@(_:_) y = let (x1,x2) = g x (y1,y2) = g y in if equalFilePath x1 y1 then f x2 y2 else path g x = (dropWhile isPathSeparator a, dropWhile isPathSeparator b) where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x -- on windows, need to drop '/' which is kind of absolute, but not a drive dropAbs [] = dropDrive [] dropAbs (x:xs) | isPathSeparator x = xs | otherwise = dropDrive (x:xs) takeAbs [] = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive [] takeAbs xs@(x:_) | isPathSeparator x = [pathSeparator] | otherwise = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive xs -- | Normalise a file -- -- * \/\/ outside of the drive can be made blank -- -- * \/ -> 'pathSeparator' -- -- * .\/ -> \"\" -- -- > Posix: normalise "/file/\\test////" == "/file/\\test/" -- > Posix: normalise "/file/./test" == "/file/test" -- > Posix: normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/" -- > Posix: normalise "../bob/fred/" == "../bob/fred/" -- > Posix: normalise "./bob/fred/" == "bob/fred/" -- > Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\" -- > Windows: normalise "c:\\" == "C:\\" -- > Windows: normalise "\\\\server\\test" == "\\\\server\\test" -- > Windows: normalise "c:/file" == "C:\\file" -- > normalise "." == "." -- > Posix: normalise "./" == "./" -- > Posix: normalise "./." == "./" -- > Posix: normalise "bob/fred/." == "bob/fred/" normalise :: FilePath -> FilePath normalise path = joinDrive (normaliseDrive drv) (f pth) ++ [pathSeparator | isDirPath pth] where (drv,pth) = splitDrive path isDirPath xs = lastSep xs || not (null xs) && last xs == '.' && lastSep (init xs) lastSep xs = not (null xs) && isPathSeparator (last xs) f = joinPath . dropDots . splitDirectories . propSep propSep [] = [] propSep xs@[x] | isPathSeparator x = [pathSeparator] | otherwise = xs propSep (x:y:xs) | isPathSeparator x && isPathSeparator y = propSep (x:xs) | isPathSeparator x = pathSeparator : propSep (y:xs) | otherwise = x : propSep (y:xs) dropDots xs | all (== ".") xs = ["."] | otherwise = dropDots' [] xs dropDots' acc [] = reverse acc dropDots' acc (x:xs) | x == "." = dropDots' acc xs | otherwise = dropDots' (x:acc) xs normaliseDrive :: FilePath -> FilePath normaliseDrive drive | isPosix = drive | otherwise = if isJust $ readDriveLetter x2 then map toUpper x2 else drive where x2 = map repSlash drive repSlash x = if isPathSeparator x then pathSeparator else x -- information for validity functions on Windows -- see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp badCharacters :: [Char] badCharacters = ":*?><|\"" badElements :: [FilePath] badElements = ["CON", "PRN", "AUX", "NUL", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9", "CLOCK$"] -- | Is a FilePath valid, i.e. could you create a file like it? -- -- > isValid "" == False -- > Posix: isValid "/random_ path:*" == True -- > Posix: isValid x == not (null x) -- > Windows: isValid "c:\\test" == True -- > Windows: isValid "c:\\test:of_test" == False -- > Windows: isValid "test*" == False -- > Windows: isValid "c:\\test\\nul" == False -- > Windows: isValid "c:\\test\\prn.txt" == False -- > Windows: isValid "c:\\nul\\file" == False -- > Windows: isValid "\\\\" == False isValid :: FilePath -> Bool isValid [] = False isValid path@(_:_) | isPosix = True | otherwise = not (any (`elem` badCharacters) x2) && not (any f $ splitDirectories x2) && not (length path >= 2 && all isPathSeparator path) where x2 = dropDrive path f x = map toUpper (dropExtensions x) `elem` badElements -- | Take a FilePath and make it valid; does not change already valid FilePaths. -- -- > isValid (makeValid x) -- > isValid x ==> makeValid x == x -- > makeValid "" == "_" -- > Windows: makeValid "c:\\test:of_test" == "c:\\test_of_test" -- > Windows: makeValid "test*" == "test_" -- > Windows: makeValid "c:\\test\\nul" == "c:\\test\\nul_" -- > Windows: makeValid "c:\\test\\prn.txt" == "c:\\test\\prn_.txt" -- > Windows: makeValid "c:\\test/prn.txt" == "c:\\test/prn_.txt" -- > Windows: makeValid "c:\\nul\\file" == "c:\\nul_\\file" makeValid :: FilePath -> FilePath makeValid [] = "_" makeValid path@(_:_) | isPosix = path | length path >= 2 && all isPathSeparator path = take 2 path ++ "drive" | otherwise = joinDrive drv $ validElements $ validChars pth where (drv,pth) = splitDrive path validChars x = map f x f x | x `elem` badCharacters = '_' | otherwise = x validElements x = joinPath $ map g $ splitPath x g x = h (reverse b) ++ reverse a where (a,b) = span isPathSeparator $ reverse x h x = if map toUpper a `elem` badElements then a ++ "_" <.> b else x where (a,b) = splitExtensions x -- | Is a path relative, or is it fixed to the root? -- -- > Windows: isRelative "path\\test" == True -- > Windows: isRelative "c:\\test" == False -- > Windows: isRelative "c:test" == True -- > Windows: isRelative "c:" == True -- > Windows: isRelative "\\\\foo" == False -- > Windows: isRelative "/foo" == True -- > Posix: isRelative "test/path" == True -- > Posix: isRelative "/test" == False isRelative :: FilePath -> Bool isRelative = isRelativeDrive . takeDrive -- > isRelativeDrive "" == True -- > Windows: isRelativeDrive "c:\\" == False -- > Windows: isRelativeDrive "c:/" == False -- > Windows: isRelativeDrive "c:" == True -- > Windows: isRelativeDrive "\\\\foo" == False -- > Posix: isRelativeDrive "/" == False isRelativeDrive :: String -> Bool isRelativeDrive x = null x || maybe False (not . isPathSeparator . last . fst) (readDriveLetter x) -- | @not . 'isRelative'@ -- -- > isAbsolute x == not (isRelative x) isAbsolute :: FilePath -> Bool isAbsolute = not . isRelative curry-libs-v2.2.0/Float.curry000066400000000000000000000104231355602362200161330ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A collection of operations on floating point numbers. --- --- @category general ------------------------------------------------------------------------------ module Float ( pi, (+.), (-.), (*.), (/.), (^.), i2f, truncate, round, recip, sqrt, log , logBase, exp, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh , asinh, acosh, atanh) where -- The operator declarations are similar to the standard arithmetic operators. infixr 8 ^. infixl 7 *., /. infixl 6 +., -. --- The number pi. pi :: Float pi = 3.141592653589793238 --- Addition on floats. (+.) :: Float -> Float -> Float x +. y = (prim_Float_plus $# y) $# x prim_Float_plus :: Float -> Float -> Float prim_Float_plus external --- Subtraction on floats. (-.) :: Float -> Float -> Float x -. y = (prim_Float_minus $# y) $# x prim_Float_minus :: Float -> Float -> Float prim_Float_minus external --- Multiplication on floats. (*.) :: Float -> Float -> Float x *. y = (prim_Float_times $# y) $# x prim_Float_times :: Float -> Float -> Float prim_Float_times external --- Division on floats. (/.) :: Float -> Float -> Float x /. y = (prim_Float_div $# y) $# x prim_Float_div :: Float -> Float -> Float prim_Float_div external --- The value of `a ^. b` is `a` raised to the power of `b`. --- Executes in `O(log b)` steps. --- --- @param a - The base. --- @param b - The exponent. --- @return `a` raised to the power of `b`. (^.) :: Float -> Int -> Float a ^. b | b < 0 = 1 /. a ^. (b * (-1)) | otherwise = powaux 1.0 a b where powaux n x y = if y == 0 then n else powaux (n *. if (y `mod` 2 == 1) then x else 1.0) (x *. x) (y `div` 2) --- Conversion function from integers to floats. i2f :: Int -> Float i2f x = prim_i2f $# x prim_i2f :: Int -> Float prim_i2f external --- Conversion function from floats to integers. --- The result is the closest integer between the argument and 0. truncate :: Float -> Int truncate x = prim_truncate $# x prim_truncate :: Float -> Int prim_truncate external --- Conversion function from floats to integers. --- The result is the nearest integer to the argument. --- If the argument is equidistant between two integers, --- it is rounded to the closest even integer value. round :: Float -> Int round x = prim_round $# x prim_round :: Float -> Int prim_round external --- Reciprocal recip :: Float -> Float recip x = 1.0 /. x --- Square root. sqrt :: Float -> Float sqrt x = prim_sqrt $# x prim_sqrt :: Float -> Float prim_sqrt external --- Natural logarithm. log :: Float -> Float log x = prim_log $# x prim_log :: Float -> Float prim_log external --- Logarithm to arbitrary Base. logBase :: Float -> Float -> Float logBase x y = log y /. log x --- Natural exponent. exp :: Float -> Float exp x = prim_exp $# x prim_exp :: Float -> Float prim_exp external --- Sine. sin :: Float -> Float sin x = prim_sin $# x prim_sin :: Float -> Float prim_sin external --- Cosine. cos :: Float -> Float cos x = prim_cos $# x prim_cos :: Float -> Float prim_cos external --- Tangent. tan :: Float -> Float tan x = prim_tan $# x prim_tan :: Float -> Float prim_tan external --- Arc sine. asin :: Float -> Float asin x = prim_asin $# x prim_asin :: Float -> Float prim_asin external -- Arc cosine. acos :: Float -> Float acos x = prim_acos $# x prim_acos :: Float -> Float prim_acos external --- Arc tangent. atan :: Float -> Float atan x = prim_atan $# x prim_atan :: Float -> Float prim_atan external --- Hyperbolic sine. sinh :: Float -> Float sinh x = prim_sinh $# x prim_sinh :: Float -> Float prim_sinh external -- Hyperbolic cosine. cosh :: Float -> Float cosh x = prim_cosh $# x prim_cosh :: Float -> Float prim_cosh external --- Hyperbolic tangent. tanh :: Float -> Float tanh x = prim_tanh $# x prim_tanh :: Float -> Float prim_tanh external --- Hyperbolic Arc sine. asinh :: Float -> Float asinh x = prim_asinh $# x prim_asinh :: Float -> Float prim_asinh external -- Hyperbolic Arc cosine. acosh :: Float -> Float acosh x = prim_acosh $# x prim_acosh :: Float -> Float prim_acosh external --- Hyperbolic Arc tangent. atanh :: Float -> Float atanh x = prim_atanh $# x prim_atanh :: Float -> Float prim_atanh external curry-libs-v2.2.0/Float.kics2000066400000000000000000000074711355602362200160130ustar00rootroot00000000000000external_d_C_prim_Float_plus :: Curry_Prelude.C_Float -> Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_Float_plus y x _ _ = toCurry ((fromCurry x + fromCurry y) :: Double) external_d_C_prim_Float_minus :: Curry_Prelude.C_Float -> Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_Float_minus y x _ _ = toCurry ((fromCurry x - fromCurry y) :: Double) external_d_C_prim_Float_times :: Curry_Prelude.C_Float -> Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_Float_times y x _ _ = toCurry ((fromCurry x * fromCurry y) :: Double) external_d_C_prim_Float_div :: Curry_Prelude.C_Float -> Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_Float_div y x _ _ = toCurry ((fromCurry x / fromCurry y) :: Double) external_d_C_prim_i2f :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_i2f x _ _ = toCurry (fromInteger (fromCurry x) :: Double) external_d_C_prim_truncate :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_prim_truncate x _ _ = toCurry (truncate (fromCurry x :: Double) :: Int) external_d_C_prim_round :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_prim_round x _ _ = toCurry (round (fromCurry x :: Double) :: Int) external_d_C_prim_sqrt :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_sqrt x _ _ = toCurry (sqrt (fromCurry x :: Double)) external_d_C_prim_log :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_log x _ _ = toCurry (log (fromCurry x :: Double)) external_d_C_prim_exp :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_exp x _ _ = toCurry (exp (fromCurry x :: Double)) external_d_C_prim_sin :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_sin x _ _ = toCurry (sin (fromCurry x :: Double)) external_d_C_prim_asin :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_asin x _ _ = toCurry (asin (fromCurry x :: Double)) external_d_C_prim_sinh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_sinh x _ _ = toCurry (sinh (fromCurry x :: Double)) external_d_C_prim_asinh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_asinh x _ _ = toCurry (asinh (fromCurry x :: Double)) external_d_C_prim_cos :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_cos x _ _ = toCurry (cos (fromCurry x :: Double)) external_d_C_prim_acos :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_acos x _ _ = toCurry (acos (fromCurry x :: Double)) external_d_C_prim_cosh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_cosh x _ _ = toCurry (cosh (fromCurry x :: Double)) external_d_C_prim_acosh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_acosh x _ _ = toCurry (acosh (fromCurry x :: Double)) external_d_C_prim_tan :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_tan x _ _ = toCurry (tan (fromCurry x :: Double)) external_d_C_prim_atan :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_atan x _ _ = toCurry (atan (fromCurry x :: Double)) external_d_C_prim_tanh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_tanh x _ _ = toCurry (tanh (fromCurry x :: Double)) external_d_C_prim_atanh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_atanh x _ _ = toCurry (atanh (fromCurry x :: Double)) curry-libs-v2.2.0/Float.pakcs000066400000000000000000000052041355602362200160710ustar00rootroot00000000000000 prim_float prim_Float_plus prim_float prim_Float_minus prim_float prim_Float_times prim_float prim_Float_div prim_float prim_i2f prim_float prim_round prim_float prim_truncate prim_float prim_sqrt prim_float prim_log prim_float prim_exp prim_float prim_sin prim_float prim_cos prim_float prim_tan prim_float prim_asin prim_float prim_acos prim_float prim_atan prim_float prim_sinh prim_float prim_cosh prim_float prim_tanh prim_float prim_asinh prim_float prim_acosh prim_float prim_atanh curry-libs-v2.2.0/Function.curry000066400000000000000000000024341355602362200166560ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This module provides some utility functions for function application. --- --- @author Bjoern Peemoeller --- @version July 2013 --- @category general --- ---------------------------------------------------------------------------- module Function where --- `fix f` is the least fixed point of the function `f`, --- i.e. the least defined `x` such that `f x = x`. fix :: (a -> a) -> a fix f = let x = f x in x --- `(*) \`on\` f = \\x y -> f x * f y`. --- 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) curry-libs-v2.2.0/FunctionInversion.curry000066400000000000000000000020401355602362200205440ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This module provides some utility functions for inverting functions. --- --- @author Michael Hanus --- @version February 2015 --- @category general --- ---------------------------------------------------------------------------- module FunctionInversion where --- Inverts a unary function. invf1 :: (a -> b) -> (b -> a) invf1 f y | f x =:<= y = x where x free --- Inverts a binary function. invf2 :: (a -> b -> c) -> (c -> (a,b)) invf2 f y | f x1 x2 =:<= y = (x1,x2) where x1,x2 free --- Inverts a ternary function. invf3 :: (a -> b -> c -> d) -> (d -> (a,b,c)) invf3 f y | f x1 x2 x3 =:<= y = (x1,x2,x3) where x1,x2,x3 free --- Inverts a function of arity 4. invf4 :: (a -> b -> c -> d -> e) -> (e -> (a,b,c,d)) invf4 f y | f x1 x2 x3 x4 =:<= y = (x1,x2,x3,x4) where x1,x2,x3,x4 free --- Inverts a function of arity 5. invf5 :: (a -> b -> c -> d -> e -> f) -> (f -> (a,b,c,d,e)) invf5 f y | f x1 x2 x3 x4 x5 =:<= y = (x1,x2,x3,x4,x5) where x1,x2,x3,x4,x5 free curry-libs-v2.2.0/GetOpt.curry000066400000000000000000000415061355602362200162760ustar00rootroot00000000000000--- ----------------------------------------------------------------- --- This Module is a modified version of the Module --- System.Console.GetOpt by Sven Panne from the ghc-base package --- it has been adapted for Curry by Bjoern Peemoeller --- --- (c) Sven Panne 2002-2005 --- The Glasgow Haskell Compiler License --- --- Copyright 2004, The University Court of the University of Glasgow. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- - Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright notice, --- this list of conditions and the following disclaimer in the documentation --- and/or other materials provided with the distribution. --- --- - Neither name of the University nor the names of its contributors may be --- used to endorse or promote products derived from this software without --- specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF --- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, --- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND --- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE --- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT --- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY --- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH --- DAMAGE. --- --- @category general --- --------------------------------------------------------------------------- {- Two rather obscure features are missing: The Bash 2.0 non-option hack (if you don't already know it, you probably don't want to hear about it...) and the recognition of long options with a single dash (e.g. '-help' is recognised as '--help', as long as there is no short option 'h'). Other differences between GNU's getopt and this implementation: * To enforce a coherent description of options and arguments, there are explanation fields in the option/argument descriptor. * Error messages are now more informative, but no longer POSIX compliant... :-( -} module GetOpt -- * GetOpt ( getOpt, getOpt', usageInfo, ArgOrder (..), OptDescr (..), ArgDescr (..) -- * Examples -- |To hopefully illuminate the role of the different data structures, -- here are the command-line options for a (very simple) compiler, -- done in two different ways. -- The difference arises because the type of 'getOpt' is -- parameterized by the type of values derived from flags. -- ** Interpreting flags as concrete values -- $example1 -- ** Interpreting flags as transformations of an options record -- $example2 ) where import Prelude -- necessary to get dependencies right import List (isPrefixOf, find) -- |What to do with options following non-options data ArgOrder a = RequireOrder -- ^ no option processing after first non-option | Permute -- ^ freely intersperse options and non-options | ReturnInOrder (String -> a) -- ^ wrap non-options into options {-| Each 'OptDescr' describes a single option. The arguments to 'Option' are: * list of short option characters * list of long option strings (without \"--\") * argument descriptor * explanation of option for user -} data OptDescr a = -- description of a single options: Option [Char] -- list of short option characters [String] -- list of long option strings (without "--") (ArgDescr a) -- argument descriptor String -- explanation of option for user -- |Describes whether an option takes an argument or not, and if so -- how the argument is injected into a value of type @a@. data ArgDescr a = NoArg a -- ^no argument expected | ReqArg (String -> a) String -- ^option requires argument | OptArg (Maybe String -> a) String -- ^optional argument data OptKind a -- kind of cmd line arg (internal use only): = Opt a -- an option | UnreqOpt String -- an un-recognized option | NonOpt String -- a non-option | EndOfOpts -- end-of-options marker (i.e. "--") | OptErr String -- something went wrong... -- | Return a string describing the usage of a command, derived from -- the header (first argument) and the options described by the -- second argument. usageInfo :: String -- header -> [OptDescr a] -- option descriptors -> String -- nicely formatted decription of options usageInfo header optDescr = unlines (header:table) where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr table = zipWith3 paste (sameLen ss) (sameLen ls) ds paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z sameLen xs = flushLeft ((maximum . map length) xs) xs flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] maximum :: Ord a => [a] -> a maximum [] = error "maximum with empty list" maximum xs@(_:_) = foldl1 max xs fmtOpt :: OptDescr a -> [(String,String,String)] fmtOpt (Option sos los ad descr) = case lines descr of [] -> [(sosFmt,losFmt,"")] (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ] where sepBy _ [] = "" sepBy _ [x] = x sepBy ch (x:y:xs) = x ++ ch : ' ' : sepBy ch (y:xs) sosFmt = sepBy ',' (map (fmtShort ad) sos) losFmt = sepBy ',' (map (fmtLong ad) los) fmtShort :: ArgDescr a -> Char -> String fmtShort (NoArg _ ) so = "-" ++ [so] fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg _ ) lo = "--" ++ lo fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" {-| Process the command-line, and return the list of values that matched (and those that didn\'t). The arguments are: * The order requirements (see 'ArgOrder') * The option descriptions (see 'OptDescr') * The actual command line arguments (presumably got from 'System.Environment.getArgs'). 'getOpt' returns a triple consisting of the option arguments, a list of non-options, and a list of error messages. -} getOpt :: ArgOrder a -- non-option handling -> [OptDescr a] -- option descriptors -> [String] -- the command-line arguments -> ([a],[String],[String]) -- (options,non-options,error messages) getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) where (os,xs,us,es) = getOpt' ordering optDescr args {-| This is almost the same as 'getOpt', but returns a quadruple consisting of the option arguments, a list of non-options, a list of unrecognized options, and a list of error messages. -} getOpt' :: ArgOrder a -- non-option handling -> [OptDescr a] -- option descriptors -> [String] -- the command-line arguments -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) getOpt' _ _ [] = ([],[],[],[]) getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering where procNextOpt (Opt o) _ = (o:os,xs,us,es) procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) procNextOpt EndOfOpts Permute = ([],rest,[],[]) procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) procNextOpt (OptErr e) _ = (os,xs,us,e:es) (opt,rest) = getNext arg args optDescr (os,xs,us,es) = getOpt' ordering optDescr rest -- take a look at the next cmd line arg and decide what to do with it getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) getNext s rest optDescr = case s of '-':'-':[] -> (EndOfOpts, rest) '-':'-':xs -> longOpt xs rest optDescr '-': x :xs -> shortOpt x xs rest optDescr _ -> (NonOpt s,rest) -- handle long option longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) longOpt ls rs optDescr = long ads arg rs where (opt,arg) = break (=='=') ls getWith p = [ o | o@(Option _ xs _ _) <- optDescr , find (p opt) xs /= Nothing ] exact = getWith (==) options = if null exact then getWith isPrefixOf else exact ads = [ ad | Option _ _ ad _ <- options ] optStr = ("--"++opt) long ads0 arg0 rs0 = case (ads0, arg0, rs0) of ((_:_:_) , _ , rest ) -> (errAmbig options optStr,rest) ([NoArg a ], [] , rest ) -> (Opt a ,rest) ([NoArg _ ], ('=':_) , rest ) -> (errNoArg optStr ,rest) ([ReqArg _ d], [] , [] ) -> (errReq d optStr ,[] ) ([ReqArg f _], [] , (r:rest)) -> (Opt (f r) ,rest) ([ReqArg f _], ('=':xs), rest ) -> (Opt (f xs) ,rest) ([OptArg f _], [] , rest ) -> (Opt (f Nothing) ,rest) ([OptArg f _], ('=':xs), rest ) -> (Opt (f (Just xs)) ,rest) (_ , _ , rest ) -> (UnreqOpt ("--" ++ ls) ,rest) -- handle short option shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) shortOpt y ys rs optDescr = short ads ys rs where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] ads = [ ad | Option _ _ ad _ <- options ] optStr = '-':[y] short [] [] rest = (UnreqOpt optStr,rest) short [] xs@(_:_) rest = (UnreqOpt optStr,('-':xs):rest) short [NoArg a ] [] rest = (Opt a,rest) short [NoArg a ] xs@(_:_) rest = (Opt a,('-':xs):rest) short [ReqArg _ d] [] [] = (errReq d optStr,[]) short [ReqArg f _] [] (r:rest) = (Opt (f r),rest) short [ReqArg f _] xs@(_:_) rest = (Opt (f xs),rest) short [OptArg f _] [] rest = (Opt (f Nothing),rest) short [OptArg f _] xs@(_:_) rest = (Opt (f (Just xs)),rest) short (_:_:_) _ rest = (errAmbig options optStr,rest) -- miscellaneous error formatting errAmbig :: [OptDescr a] -> String -> OptKind a errAmbig ods optStr = OptErr (usageInfo header ods) where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" errReq :: String -> String -> OptKind a errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") errUnrec :: String -> String errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" errNoArg :: String -> OptKind a errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") {- ----------------------------------------------------------------------------------------- -- and here a small and hopefully enlightening example: data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show options :: [OptDescr Flag] options = [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", Option ['V','?'] ["version","release"] (NoArg Version) "show version info", Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] out :: Maybe String -> Flag out Nothing = Output "stdout" out (Just o) = Output o test :: ArgOrder Flag -> [String] -> String test order cmdline = case getOpt order options cmdline of (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" (_,_,errs) -> concat errs ++ usageInfo header options where header = "Usage: foobar [OPTION...] files..." -- example runs: -- putStr (test RequireOrder ["foo","-v"]) -- ==> options=[] args=["foo", "-v"] -- putStr (test Permute ["foo","-v"]) -- ==> options=[Verbose] args=["foo"] -- putStr (test (ReturnInOrder Arg) ["foo","-v"]) -- ==> options=[Arg "foo", Verbose] args=[] -- putStr (test Permute ["foo","--","-v"]) -- ==> options=[] args=["foo", "-v"] -- putStr (test Permute ["-?o","--name","bar","--na=baz"]) -- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] -- putStr (test Permute ["--ver","foo"]) -- ==> option `--ver' is ambiguous; could be one of: -- -v --verbose verbosely list files -- -V, -? --version, --release show version info -- Usage: foobar [OPTION...] files... -- -v --verbose verbosely list files -- -V, -? --version, --release show version info -- -o[FILE] --output[=FILE] use FILE for dump -- -n USER --name=USER only dump USER's files ----------------------------------------------------------------------------------------- -} {- $example1 A simple choice for the type associated with flags is to define a type @Flag@ as an algebraic type representing the possible flags and their arguments: > module Opts1 where > > import System.Console.GetOpt > import Data.Maybe ( fromMaybe ) > > data Flag > = Verbose | Version > | Input String | Output String | LibDir String > deriving Show > > options :: [OptDescr Flag] > options = > [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" > , Option ['V','?'] ["version"] (NoArg Version) "show version number" > , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" > , Option ['c'] [] (OptArg inp "FILE") "input FILE" > , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" > ] > > inp,outp :: Maybe String -> Flag > outp = Output . fromMaybe "stdout" > inp = Input . fromMaybe "stdin" > > compilerOpts :: [String] -> IO ([Flag], [String]) > compilerOpts argv = > case getOpt Permute options argv of > (o,n,[] ) -> return (o,n) > (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) > where header = "Usage: ic [OPTION...] files..." Then the rest of the program will use the constructed list of flags to determine it\'s behaviour. -} {- $example2 A different approach is to group the option values in a record of type @Options@, and have each flag yield a function of type @Options -> Options@ transforming this record. > module Opts2 where > > import System.Console.GetOpt > import Data.Maybe ( fromMaybe ) > > data Options = Options > { optVerbose :: Bool > , optShowVersion :: Bool > , optOutput :: Maybe FilePath > , optInput :: Maybe FilePath > , optLibDirs :: [FilePath] > } deriving Show > > defaultOptions = Options > { optVerbose = False > , optShowVersion = False > , optOutput = Nothing > , optInput = Nothing > , optLibDirs = [] > } > > options :: [OptDescr (Options -> Options)] > options = > [ Option ['v'] ["verbose"] > (NoArg (\ opts -> opts { optVerbose = True })) > "chatty output on stderr" > , Option ['V','?'] ["version"] > (NoArg (\ opts -> opts { optShowVersion = True })) > "show version number" > , Option ['o'] ["output"] > (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output") > "FILE") > "output FILE" > , Option ['c'] [] > (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input") > "FILE") > "input FILE" > , Option ['L'] ["libdir"] > (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR") > "library directory" > ] > > compilerOpts :: [String] -> IO (Options, [String]) > compilerOpts argv = > case getOpt Permute options argv of > (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) > (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) > where header = "Usage: ic [OPTION...] files..." Similarly, each flag could yield a monadic function transforming a record, of type @Options -> IO Options@ (or any other monad), allowing option processing to perform actions of the chosen monad, e.g. printing help or version messages, checking that file arguments exist, etc. -} curry-libs-v2.2.0/Global.curry000066400000000000000000000053011355602362200162650ustar00rootroot00000000000000------------------------------------------------------------------------------ --- 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 ------------------------------------------------------------------------ curry-libs-v2.2.0/Global.kics2000066400000000000000000000147001355602362200161370ustar00rootroot00000000000000import 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 do writeFile name (show val ++ "\n") system ("chmod 600 " ++ name) return () 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:\n" ++ s) 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 curry-libs-v2.2.0/Global.pakcs000066400000000000000000000006261355602362200162270ustar00rootroot00000000000000 prim_global prim_readGlobal prim_global prim_writeGlobal curry-libs-v2.2.0/IO.curry000066400000000000000000000204451355602362200154020ustar00rootroot00000000000000----------------------------------------------------------------------------- --- Library for IO operations like reading and writing files --- that are not already contained in the prelude. --- --- @author Michael Hanus, Bernd Brassel --- @version March 2015 --- @category general ----------------------------------------------------------------------------- module IO ( Handle, IOMode(..), SeekMode(..), stdin, stdout, stderr , openFile, hClose, hFlush, hIsEOF, isEOF , hSeek, hWaitForInput, hWaitForInputs , hWaitForInputOrMsg, hWaitForInputsOrMsg, hReady , hGetChar, hGetLine, hGetContents, getContents , hPutChar, hPutStr, hPutStrLn, hPrint , hIsReadable, hIsWritable, hIsTerminalDevice ) where --- The abstract type of a handle for a stream. external data Handle -- internally defined instance Eq Handle where h1 == h2 = (handle_eq $# h2) $# h1 handle_eq :: Handle -> Handle -> Bool handle_eq external --- The modes for opening a file. data IOMode = ReadMode | WriteMode | AppendMode --- The modes for positioning with hSeek in a file. data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd --- Standard input stream. stdin :: Handle stdin external --- Standard output stream. stdout :: Handle stdout external --- Standard error stream. stderr :: Handle stderr external --- Opens a file in specified mode and returns a handle to it. openFile :: String -> IOMode -> IO Handle openFile filename mode = (prim_openFile $## filename) $# mode prim_openFile :: String -> IOMode -> IO Handle prim_openFile external --- Closes a file handle and flushes the buffer in case of output file. hClose :: Handle -> IO () hClose h = prim_hClose $# h prim_hClose :: Handle -> IO () prim_hClose external --- Flushes the buffer associated to handle in case of output file. hFlush :: Handle -> IO () hFlush h = prim_hFlush $# h prim_hFlush :: Handle -> IO () prim_hFlush external --- Is handle at end of file? hIsEOF :: Handle -> IO Bool hIsEOF h = prim_hIsEOF $# h prim_hIsEOF :: Handle -> IO Bool prim_hIsEOF external --- Is standard input at end of file? isEOF :: IO Bool isEOF = hIsEOF stdin --- Set the position of a handle to a seekable stream (e.g., a file). --- If the second argument is AbsoluteSeek, --- SeekFromEnd, or RelativeSeek, --- 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 prim_hSeek :: Handle -> SeekMode -> Int -> IO () prim_hSeek external --- Waits until input is available on the given handle. --- If no input is available within t milliseconds, it returns False, --- otherwise it returns True. --- @param handle - a handle for an input stream --- @param timeout - milliseconds to wait for input (< 0 : no time out) hWaitForInput :: Handle -> Int -> IO Bool hWaitForInput handle timeout = (prim_hWaitForInput $# handle) $## timeout prim_hWaitForInput :: Handle -> Int -> IO Bool prim_hWaitForInput external --- Waits until input is available on some of the given handles. --- If no input is available within t milliseconds, it returns -1, --- otherwise it returns the index of the corresponding handle -- with the available data. --- @param handles - a list of handles for input streams --- @param timeout - milliseconds to wait for input (< 0 : no time out) --- @return -1 if no input is available within the time out, otherwise i --- if (handles!!i) has data available hWaitForInputs :: [Handle] -> Int -> IO Int hWaitForInputs handles timeout = (prim_hWaitForInputs $## handles) $## timeout prim_hWaitForInputs :: [Handle] -> Int -> IO Int prim_hWaitForInputs external --- Waits until input is available on a given handles or a message --- in the message stream. --- Usually, the message stream comes from an external port. --- Thus, this operation implements a committed choice over receiving input --- from an IO handle or an external port. --- --- Note that the implementation of this operation works only with --- Sicstus-Prolog 3.8.5 or higher (due to a bug in previous versions --- of Sicstus-Prolog). --- --- @param handle - a handle for an input stream --- @param msgs - a stream of messages received via an external port --- (see Ports) --- @return (Left handle) if the handle has some data available --- (Right msgs) if the stream msgs is instantiated --- with at least one new message at the head hWaitForInputOrMsg :: Handle -> [msg] -> IO (Either Handle [msg]) hWaitForInputOrMsg handle msgs = do input <- hWaitForInputsOrMsg [handle] msgs return $ either (\_ -> Left handle) Right input --- Waits until input is available on some of the given handles or a message --- in the message stream. --- Usually, the message stream comes from an external port. --- Thus, this operation implements a committed choice over receiving input --- from IO handles or an external port. --- --- Note that the implementation of this operation works only with --- Sicstus-Prolog 3.8.5 or higher (due to a bug in previous versions --- of Sicstus-Prolog). --- --- @param handles - a list of handles for input streams --- @param msgs - a stream of messages received via an external port --- (see Ports) --- @return (Left i) if (handles!!i) has some data available --- (Right msgs) if the stream msgs is instantiated --- with at least one new message at the head hWaitForInputsOrMsg :: [Handle] -> [msg] -> IO (Either Int [msg]) hWaitForInputsOrMsg handles msgs = seq (normalForm (map ensureNotFree (ensureSpine handles))) (prim_hWaitForInputsOrMsg handles msgs) prim_hWaitForInputsOrMsg :: [Handle] -> [msg] -> IO (Either Int [msg]) prim_hWaitForInputsOrMsg external --- Checks whether an input is available on a given handle. hReady :: Handle -> IO Bool hReady h = hWaitForInput h 0 --- Reads a character from an input handle and returns it. --- Throws an error if the end of file has been reached. hGetChar :: Handle -> IO Char hGetChar h = prim_hGetChar $# h prim_hGetChar :: Handle -> IO Char prim_hGetChar external --- Reads a line from an input handle and returns it. --- Throws an error if the end of file has been reached while reading --- the *first* character. If the end of file is reached later in the line, --- it ist treated as a line terminator and the (partial) line is returned. hGetLine :: Handle -> IO String hGetLine h = do c <- hGetChar h if c == '\n' then return [] else do eof <- hIsEOF h if eof then return [c] else do cs <- hGetLine h return (c:cs) --- Reads the complete contents from an input handle and closes the input handle --- before returning the contents. hGetContents :: Handle -> IO String hGetContents h = do eof <- hIsEOF h if eof then hClose h >> return "" else do c <- hGetChar h cs <- hGetContents h return (c:cs) --- Reads the complete contents from the standard input stream until EOF. getContents :: IO String getContents = hGetContents stdin --- Puts a character to an output handle. hPutChar :: Handle -> Char -> IO () hPutChar h c = (prim_hPutChar $# h) $## c prim_hPutChar :: Handle -> Char -> IO () prim_hPutChar external --- Puts a string to an output handle. hPutStr :: Handle -> String -> IO () hPutStr _ [] = done hPutStr h (c:cs) = hPutChar h c >> hPutStr h cs --- Puts a string with a newline to an output handle. hPutStrLn :: Handle -> String -> IO () hPutStrLn h s = hPutStr h s >> hPutChar h '\n' --- Converts a term into a string and puts it to an output handle. hPrint :: Show a => Handle -> a -> IO () hPrint h = hPutStrLn h . show --- Is the handle readable? hIsReadable :: Handle -> IO Bool hIsReadable h = prim_hIsReadable $# h prim_hIsReadable :: Handle -> IO Bool prim_hIsReadable external --- Is the handle writable? hIsWritable :: Handle -> IO Bool hIsWritable h = prim_hIsWritable $# h prim_hIsWritable :: Handle -> IO Bool prim_hIsWritable external --- Is the handle connected to a terminal? hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice h = prim_hIsTerminalDevice $# h prim_hIsTerminalDevice :: Handle -> IO Bool prim_hIsTerminalDevice external curry-libs-v2.2.0/IO.kics2000066400000000000000000000126751355602362200152570ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import Control.Concurrent import qualified Control.Exception as C (IOException, catch, throw) import Control.Monad (zipWithM) import System.IO import System.IO.Error (isEOFError) type C_Handle = PrimData CurryHandle instance ConvertCurryHaskell C_IOMode IOMode where toCurry ReadMode = C_ReadMode toCurry WriteMode = C_WriteMode toCurry AppendMode = C_AppendMode fromCurry C_ReadMode = ReadMode fromCurry C_WriteMode = WriteMode fromCurry C_AppendMode = AppendMode fromCurry _ = error "IOMode data with no ground term occurred" instance ConvertCurryHaskell C_SeekMode SeekMode where toCurry AbsoluteSeek = C_AbsoluteSeek toCurry RelativeSeek = C_RelativeSeek toCurry SeekFromEnd = C_SeekFromEnd fromCurry C_AbsoluteSeek = AbsoluteSeek fromCurry C_RelativeSeek = RelativeSeek fromCurry C_SeekFromEnd = SeekFromEnd fromCurry _ = error "SeekMode data with no ground term occurred" external_d_C_handle_eq :: C_Handle -> C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_Bool external_d_C_handle_eq (PrimData h1) (PrimData h2) _ _ = toCurry (h1 == h2) external_d_C_stdin :: Cover -> ConstStore -> C_Handle external_d_C_stdin _ _ = PrimData (OneHandle stdin) external_d_C_stdout :: Cover -> ConstStore -> C_Handle external_d_C_stdout _ _ = PrimData (OneHandle stdout) external_d_C_stderr :: Cover -> ConstStore -> C_Handle external_d_C_stderr _ _ = PrimData (OneHandle stderr) external_d_C_prim_openFile :: Curry_Prelude.OP_List Curry_Prelude.C_Char -> C_IOMode -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Handle external_d_C_prim_openFile fn mode _ _ = toCurry (\s m -> openFile s m >>= return . OneHandle) fn mode external_d_C_prim_hClose :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_hClose handle _ _ = toCurry (\ch -> case ch of OneHandle h -> hClose h InOutHandle h1 h2 -> hClose h1 >> hClose h2) handle external_d_C_prim_hFlush :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_hFlush h _ _ = toCurry (hFlush . outputHandle) h external_d_C_prim_hIsEOF :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hIsEOF h _ _ = toCurry (hIsEOF . inputHandle) h external_d_C_prim_hSeek :: C_Handle -> C_SeekMode -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_hSeek handle mode i _ _ = toCurry (hSeek . inputHandle) handle mode i external_d_C_prim_hWaitForInput :: C_Handle -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hWaitForInput handle timeout _ _ = toCurry (myhWaitForInput . inputHandle) handle timeout myhWaitForInput :: Handle -> Int -> IO Bool myhWaitForInput h timeout = C.catch (hWaitForInput h timeout) handler where handler :: C.IOException -> IO Bool handler e = if isEOFError e then return False else C.throw e external_d_C_prim_hWaitForInputs :: Curry_Prelude.OP_List C_Handle -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_hWaitForInputs hs i _ _ = toCurry selectHandle hs i selectHandle :: [CurryHandle] -> Int -> IO Int selectHandle handles timeout = do mvar <- newEmptyMVar threads <- zipWithM (\ i h -> forkIO (waitOnHandle (inputHandle h) i timeout mvar)) [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 <- takeMVar mvar case res of Nothing -> inspectRes (n - 1) mvar threads Just v -> mapM_ killThread threads >> return v waitOnHandle :: Handle -> Int -> Int -> MVar (Maybe Int) -> IO () waitOnHandle h v timeout mvar = do ready <- myhWaitForInput h timeout putMVar mvar (if ready then Just v else Nothing) external_d_C_prim_hWaitForInputsOrMsg :: Curry_Prelude.Curry a => Curry_Prelude.OP_List C_Handle -> Curry_Prelude.OP_List a -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Either Curry_Prelude.C_Int (Curry_Prelude.OP_List a)) external_d_C_prim_hWaitForInputsOrMsg = error "hWaitForInputsOrMsg undefined" external_d_C_prim_hGetChar :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Char external_d_C_prim_hGetChar h _ _ = toCurry (hGetChar . inputHandle) h external_d_C_prim_hPutChar :: C_Handle -> Curry_Prelude.C_Char -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_hPutChar h c _ _ = toCurry (hPutChar . outputHandle) h c external_d_C_prim_hIsReadable :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hIsReadable h _ _ = toCurry (hIsReadable . inputHandle) h external_d_C_prim_hIsWritable :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hIsWritable h _ _ = toCurry (hIsWritable . outputHandle) h external_d_C_prim_hIsTerminalDevice :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hIsTerminalDevice h _ _ = toCurry (hIsTerminalDevice . outputHandle) h curry-libs-v2.2.0/IO.pakcs000066400000000000000000000042201355602362200153300ustar00rootroot00000000000000 prim_io handle_eq prim_io prim_stdin prim_io prim_stdout prim_io prim_stderr prim_io prim_openFile prim_io prim_hClose prim_io prim_hFlush prim_io prim_hIsEOF prim_io prim_hSeek prim_io prim_hWaitForInput[raw] prim_io prim_hWaitForInputs[raw] prim_io prim_hWaitForInputsOrMsg[raw] prim_io prim_hGetChar prim_io prim_hPutChar prim_io prim_hIsReadable prim_io prim_hIsWritable prim_io prim_hIsTerminalDevice curry-libs-v2.2.0/IOExts.curry000066400000000000000000000154141355602362200162460ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful extensions to the IO monad. --- --- @author Michael Hanus --- @version January 2017 --- @category general ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module IOExts ( -- execution of shell commands execCmd, evalCmd, connectToCommand -- file access , readCompleteFile,updateFile, exclusiveIO -- associations , setAssoc,getAssoc -- IORef , IORef, newIORef, readIORef, writeIORef, modifyIORef ) where #ifdef __PAKCS__ import Char (isAlphaNum) import Directory (removeFile) import Read (readNat) #endif import IO ( Handle, hClose, hGetChar, hIsEOF, hPutStrLn ) import System ( getPID, system ) --- Executes a command with a new default shell process. --- The standard I/O streams of the new process (stdin,stdout,stderr) --- are returned as handles so that they can be explicitly manipulated. --- They should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handles of the input/output/error streams of the new process execCmd :: String -> IO (Handle, Handle, Handle) execCmd cmd = prim_execCmd $## cmd prim_execCmd :: String -> IO (Handle, Handle, Handle) prim_execCmd external --- Executes a command with the given arguments as a new default shell process --- and provides the input via the process' stdin input stream. --- The exit code of the process and the contents written to the standard --- I/O streams stdout and stderr are returned. --- @param cmd - the shell command to be executed --- @param args - the command's arguments --- @param input - the input to be written to the command's stdin --- @return the exit code and the contents written to stdout and stderr evalCmd :: String -> [String] -> String -> IO (Int, String, String) #ifdef __PAKCS__ evalCmd cmd args input = do pid <- getPID let tmpfile = "/tmp/PAKCS_evalCMD"++show pid (hi,ho,he) <- execCmd (unwords (map wrapArg (cmd:args)) ++ " ; (echo $? > "++tmpfile++")") unless (null input) (hPutStrLn hi input) hClose hi outs <- hGetEOF ho errs <- hGetEOF he ecodes <- readCompleteFile tmpfile removeFile tmpfile return (readNat ecodes, outs, errs) where wrapArg str | null str = "''" -- goodChar is a pessimistic predicate, such that if an argument is -- non-empty and only contains goodChars, then there is no need to -- do any quoting or escaping | all goodChar str = str | otherwise = '\'' : foldr escape "'" str where escape c s | c == '\'' = "'\\''" ++ s | otherwise = c : s goodChar c = isAlphaNum c || c `elem` "-_.,/" --- Reads from an input handle until EOF and returns the input. hGetEOF :: Handle -> IO String hGetEOF h = do eof <- hIsEOF h if eof then hClose h >> return "" else do c <- hGetChar h cs <- hGetEOF h return (c:cs) #else evalCmd cmd args input = ((prim_evalCmd $## cmd) $## args) $## input prim_evalCmd :: String -> [String] -> String -> IO (Int, String, String) prim_evalCmd external #endif --- Executes a command with a new default shell process. --- The input and output streams of the new process is returned --- as one handle which is both readable and writable. --- Thus, writing to the handle produces input to the process and --- output from the process can be retrieved by reading from this handle. --- The handle should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handle connected to the input/output streams --- of the new process connectToCommand :: String -> IO Handle connectToCommand cmd = prim_connectToCmd $## cmd prim_connectToCmd :: String -> IO Handle prim_connectToCmd external --- An action that reads the complete contents of a file and returns it. --- This action can be used instead of the (lazy) readFile --- action if the contents of the file might be changed. --- @param file - the name of the file --- @return the complete contents of the file readCompleteFile :: String -> IO String readCompleteFile file = do s <- readFile file f s (return s) where f [] r = r f (_:cs) r = f cs r --- An action that updates the contents of a file. --- @param f - the function to transform the contents --- @param file - the name of the file updateFile :: (String -> String) -> String -> IO () updateFile f file = do s <- readCompleteFile file writeFile file (f s) --- Forces the exclusive execution of an action via a lock file. --- For instance, (exclusiveIO "myaction.lock" act) ensures that --- the action "act" is not executed by two processes on the same --- system at the same time. --- @param lockfile - the name of a global lock file --- @param action - the action to be exclusively executed --- @return the result of the execution of the action exclusiveIO :: String -> IO a -> IO a exclusiveIO lockfile action = do system ("lockfile-create --lock-name "++lockfile) catch (do actionResult <- action deleteLockFile return actionResult ) (\e -> deleteLockFile >> ioError e) where deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile --- Defines a global association between two strings. --- Both arguments must be evaluable to ground terms before applying --- this operation. setAssoc :: String -> String -> IO () setAssoc key val = (prim_setAssoc $## key) $## val prim_setAssoc :: String -> String -> IO () prim_setAssoc external --- Gets the value associated to a string. --- Nothing is returned if there does not exist an associated value. getAssoc :: String -> IO (Maybe String) getAssoc key = prim_getAssoc $## key prim_getAssoc :: String -> IO (Maybe String) prim_getAssoc external --- 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 curry-libs-v2.2.0/IOExts.kics2000066400000000000000000000152111355602362200161100ustar00rootroot00000000000000{-# 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 -- (and not the corresponding Haskell values) in the Haskell IORefs data C_IORef a = Choice_C_IORef Cover ID (C_IORef a) (C_IORef a) | Choices_C_IORef Cover ID ([C_IORef a]) | Fail_C_IORef Cover FailInfo | Guard_C_IORef Cover Constraints (C_IORef a) | C_IORef (IORef a) instance Show (C_IORef a) where show = error "ERROR: no show for IORef" instance Read (C_IORef a) where readsPrec = error "ERROR: no read for IORef" instance NonDet (C_IORef a) where choiceCons = Choice_C_IORef choicesCons = Choices_C_IORef failCons = Fail_C_IORef guardCons = Guard_C_IORef try (Choice_C_IORef cd i x y) = tryChoice cd i x y try (Choices_C_IORef cd s xs) = tryChoices cd s xs try (Fail_C_IORef cd info) = Fail cd info try (Guard_C_IORef cd c e) = Guard cd c e try x = Val x match f _ _ _ _ _ (Choice_C_IORef cd i x y) = f cd i x y match _ f _ _ _ _ (Choices_C_IORef cd i@(NarrowedID _ _) xs) = f cd i xs match _ _ f _ _ _ (Choices_C_IORef cd i@(FreeID _ _) xs) = f cd i xs match _ _ _ _ _ _ (Choices_C_IORef _ i _) = error ("IOExts.IORef.match: Choices with ChoiceID " ++ show i) match _ _ _ f _ _ (Fail_C_IORef cd info) = f cd info match _ _ _ _ f _ (Guard_C_IORef cd cs e) = f cd cs e match _ _ _ _ _ f x = f x instance Generable (C_IORef a) where generate _ _ = error "ERROR: no generator for IORef" instance NormalForm (C_IORef a) where ($!!) cont ioref@(C_IORef _) cd cs = cont ioref cd cs ($!!) cont (Choice_C_IORef d i io1 io2) cd cs = nfChoice cont d i io1 io2 cd cs ($!!) cont (Choices_C_IORef d i ios) cd cs = nfChoices cont d i ios cd cs ($!!) cont (Guard_C_IORef d c io) cd cs = guardCons d c ((cont $!! io) cd $! (addCs c cs)) ($!!) _ (Fail_C_IORef d info) _ _ = failCons d info ($##) cont io@(C_IORef _) cd cs = cont io cd cs ($##) cont (Choice_C_IORef d i io1 io2) cd cs = gnfChoice cont d i io1 io2 cd cs ($##) cont (Choices_C_IORef d i ios) cd cs = gnfChoices cont d i ios cd cs ($##) cont (Guard_C_IORef d c io) cd cs = guardCons d c ((cont $## io) cd $! (addCs c cs)) ($##) _ (Fail_C_IORef d info) cd cs = failCons d info searchNF _ cont ioref@(C_IORef _) = cont ioref instance Unifiable (C_IORef a) where (=.=) _ _ = error "(=.=) for C_IORef" (=.<=) _ _ = error "(=.<=) for C_IORef" bind cd i (Choice_C_IORef d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_IORef d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_IORef d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ (Fail_C_IORef cd info) = [Unsolvable info] bind cd i (Guard_C_IORef _ cs e) = (getConstrList cs) ++ (bind cd i e) lazyBind cd i (Choice_C_IORef d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_IORef d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_IORef d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ (Fail_C_IORef cd info) = [Unsolvable info] lazyBind cd i (Guard_C_IORef _ cs e) = (getConstrList cs) ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry_Prelude.Curry a => Curry_Prelude.Curry (C_IORef a) instance ConvertCurryHaskell (C_IORef a) (IORef a) where fromCurry (C_IORef r) = r fromCurry _ = error "IORef with no ground term occurred" toCurry r = C_IORef r external_d_C_newIORef :: Curry_Prelude.Curry a => a -> Cover -> ConstStore -> Curry_Prelude.C_IO (C_IORef a) external_d_C_newIORef cv _ _ = toCurry (newIORef cv) external_d_C_prim_readIORef :: Curry_Prelude.Curry a => C_IORef a -> Cover -> ConstStore -> Curry_Prelude.C_IO a external_d_C_prim_readIORef ref _ _ = fromIO (readIORef (fromCurry ref)) external_d_C_prim_writeIORef :: Curry_Prelude.Curry a => C_IORef a -> a -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_writeIORef ref cv _ _ = toCurry (writeIORef (fromCurry ref) cv) curry-libs-v2.2.0/IOExts.pakcs000066400000000000000000000020041355602362200161720ustar00rootroot00000000000000 prim_ioexts prim_execCmd prim_ioexts prim_connectToCmd prim_ioexts prim_setAssoc prim_ioexts prim_getAssoc prim_ioexts prim_newIORef[raw] prim_ioexts prim_readIORef[raw] prim_ioexts prim_writeIORef[raw] curry-libs-v2.2.0/Integer.curry000066400000000000000000000143021355602362200164630ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A collection of common operations on integer numbers. --- Most operations make no assumption on the precision of integers. --- Operation `bitNot` is necessarily an exception. --- --- @author Sergio Antoy --- @version October 2016 --- @category general ------------------------------------------------------------------------------ module Integer ( (^), pow, ilog, isqrt, factorial, binomial , max3, min3, maxlist, minlist , bitTrunc, bitAnd, bitOr, bitNot, bitXor , even, odd ) where infixr 8 ^ ------------------------------------------------------------------ -- Public Operations ------------------------------------------------------------------ --- The value of `a ^ b` is `a` raised to the power of `b`. --- Fails if `b < 0`. --- Executes in `O(log b)` steps. --- --- @param a - The base. --- @param b - The exponent. --- @return `a` raised to the power of `b`. (^) :: Int -> Int -> Int a ^ b = pow a b --- The value of `pow a b` is `a` --- raised to the power of `b`. --- Fails if `b < 0`. --- Executes in `O(log b)` steps. --- --- @param a - The base. --- @param b - The exponent. --- @return `a` raised to the power of `b`. pow :: Int -> Int -> Int pow a b | b>= 0 = powaux 1 a b where powaux n x y = if y == 0 then n else powaux (n * if (y `mod` 2 == 1) then x else 1) (x * x) (y `div` 2) --- The value of `ilog n` is the floor of the logarithm --- in the base 10 of `n`. --- Fails if `n <= 0`. --- For positive integers, the returned value is --- 1 less the number of digits in the decimal representation of `n`. --- --- @param n - The argument. --- @return the floor of the logarithm in the base 10 of `n`. ilog :: Int -> Int ilog n | n>0 = if n<10 then 0 else 1 + ilog (n `div` 10) --- The value of `isqrt n` is the floor --- of the square root of `n`. --- Fails if `n < 0`. --- Executes in `O(log n)` steps, but there must be a better way. --- --- @param n - The argument. --- @return the floor of the square root of `n`. isqrt :: Int -> Int isqrt n | n >= 0 = if n == 0 then 0 else if n < 4 then 1 else aux 2 n where aux low past = -- invariant low <= result < past if past == low+1 then low else let cand = (past + low) `div` 2 in if cand*cand > n then aux low cand else aux cand past --- The value of `factorial n` is the factorial of `n`. --- Fails if `n < 0`. --- --- @param n - The argument. --- @return the factorial of `n`. factorial :: Int -> Int factorial n | n >= 0 = if n == 0 then 1 else n * factorial (n-1) --- The value of `binomial n m` is `n*(n-1)*...*(n-m+1)/m*(m-1)*...1`. --- Fails if `m <= 0` or `n < m`. --- --- @param n - Argument. --- @param m - Argument. --- @return the binomial coefficient of `n` over `m`. binomial :: Int -> Int -> Int binomial n m | m > 0 && n >= m = aux m n `div` factorial m where aux x y = if x == 0 then 1 else y * aux (x-1) (y-1) --- Returns the maximum of the three arguments. --- --- @param n - Argument. --- @param m - Argument. --- @param p - Argument. --- @return the maximum among `n`, `m` and `p`. max3 :: Ord a => a -> a -> a -> a max3 n m p = max n (max m p) --- Returns the minimum of the three arguments. --- --- @param n - Argument. --- @param m - Argument. --- @param p - Argument. --- @return the minimum among `n`, `m` and `p`. min3 :: Ord a => a -> a -> a -> a min3 n m p = min n (min m p) --- Returns the maximum of a list of integer values. --- Fails if the list is empty. --- --- @param l - The list of values. --- @return the maximum element of `l`. maxlist :: Ord a => [a] -> a maxlist [n] = n maxlist (n:m:ns) = max n (maxlist (m:ns)) --- Returns the minimum of a list of integer values. --- Fails if the list is empty. --- --- @param l - The list of values. --- @return the minimum element of `l`. minlist :: Ord a => [a] -> a minlist [n] = n minlist (n:m:ns) = min n (minlist (m:ns)) --- The value of `bitTrunc n m` is the value of the `n` --- least significant bits of `m`. --- --- @param n - Argument. --- @param m - Argument. --- @return `m` truncated to the `n` least significant bits. bitTrunc :: Int -> Int -> Int bitTrunc n m = bitAnd (pow 2 n - 1) m --- Returns the bitwise AND of the two arguments. --- --- @param n - Argument. --- @param m - Argument. --- @return the bitwise and of `n` and `m`. bitAnd :: Int -> Int -> Int bitAnd n m = if m == 0 then 0 else let p = 2 * bitAnd (n `div` 2) (m `div` 2) q = if m `mod` 2 == 0 then 0 else n `mod` 2 in p + q --- Returns the bitwise inclusive OR of the two arguments. --- --- @param n - Argument. --- @param m - Argument. --- @return the bitwise inclusive or of `n` and `m`. bitOr :: Int -> Int -> Int bitOr n m = if m == 0 then n else let p = 2 * bitOr (n `div` 2) (m `div` 2) q = if m `mod` 2 == 1 then 1 else n `mod` 2 in p + q --- Returns the bitwise NOT of the argument. --- Since integers have unlimited precision, --- only the 32 least significant bits are computed. --- --- @param n - Argument. --- @return the bitwise negation of `n` truncated to 32 bits. bitNot :: Int -> Int bitNot n = aux 32 n where aux c m = if c==0 then 0 else let p = 2 * aux (c-1) (m `div` 2) q = 1 - m `mod` 2 in p + q --- Returns the bitwise exclusive OR of the two arguments. --- --- @param n - Argument. --- @param m - Argument. --- @return the bitwise exclusive of `n` and `m`. bitXor :: Int -> Int -> Int bitXor n m = if m == 0 then n else let p = 2 * bitXor (n `div` 2) (m `div` 2) q = if m `mod` 2 == n `mod` 2 then 0 else 1 in p + q --- Returns whether an integer is even --- --- @param n - Argument. --- @return whether `n` is even. even :: Int -> Bool even n = n `mod` 2 == 0 --- Returns whether an integer is odd --- --- @param n - Argument. --- @return whether `n` is odd. odd :: Int -> Bool odd n = n `mod` 2 /= 0 curry-libs-v2.2.0/LICENSE000066400000000000000000000027101355602362200150050ustar00rootroot00000000000000Copyright (c) 2011-2016, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - None of the names of the copyright holders and contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. curry-libs-v2.2.0/List.curry000066400000000000000000000327111355602362200160050ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful operations on lists. --- --- @author Michael Hanus, Bjoern Peemoeller --- @version Februar 2016 --- @category general ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module 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 , unionBy, intersectBy , last, init , sum, product, maximum, minimum, maximumBy, minimumBy , scanl, scanl1, scanr, scanr1 , mapAccumL, mapAccumR , cycle, unfoldr ) where import Maybe (listToMaybe) infix 5 \\ --- Returns the index `i` of the first occurrence of an element in a list --- as `(Just i)`, otherwise `Nothing` is returned. elemIndex :: Eq a => a -> [a] -> Maybe Int elemIndex x = findIndex (x ==) --- Returns the list of indices of occurrences of an element in a list. elemIndices :: Eq a => a -> [a] -> [Int] elemIndices x = findIndices (x ==) --- Returns the first element `e` of a list satisfying a predicate --- as `(Just e)`, --- otherwise `Nothing` is returned. find :: (a -> Bool) -> [a] -> Maybe a find p = listToMaybe . filter p --- Returns the index `i` of the first occurrences of a list element --- satisfying a predicate as `(Just i)`, otherwise `Nothing` is returned. findIndex :: (a -> Bool) -> [a] -> Maybe Int findIndex p = listToMaybe . findIndices p --- Returns the list of indices of list elements satisfying a predicate. findIndices :: (a -> Bool) -> [a] -> [Int] findIndices p xs = [ i | (x,i) <- zip xs [0..], p x ] --- Removes all duplicates in the argument list. nub :: Eq a => [a] -> [a] nub xs = nubBy (==) xs --- Removes all duplicates in the argument list according to an --- equivalence relation. nubBy :: (a -> a -> Bool) -> [a] -> [a] nubBy _ [] = [] nubBy eq (x:xs) = x : nubBy eq (filter (\y -> not (eq x y)) xs) --- Deletes the first occurrence of an element in a list. delete :: Eq a => a -> [a] -> [a] delete = deleteBy (==) --- Deletes the first occurrence of an element in a list --- according to an equivalence relation. deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] deleteBy _ _ [] = [] deleteBy eq x (y:ys) = if eq x y then ys else y : deleteBy eq x ys --- Computes the difference of two lists. --- @param xs - a list --- @param ys - a list --- @return the list where the first occurrence of each element of --- `ys` has been removed from `xs` (\\) :: Eq a => [a] -> [a] -> [a] xs \\ ys = foldl (flip delete) xs ys --- Computes the union of two lists. union :: Eq a => [a] -> [a] -> [a] union [] ys = ys union (x:xs) ys = if x `elem` ys then union xs ys else x : union xs ys --- Computes the union of two lists according to the given equivalence relation unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs --- Computes the intersection of two lists. intersect :: Eq a => [a] -> [a] -> [a] intersect [] _ = [] intersect (x:xs) ys = if x `elem` ys then x : intersect xs ys else intersect xs ys --- Computes the intersection of two lists --- according to the given equivalence relation intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] intersectBy _ [] _ = [] intersectBy _ (_:_) [] = [] intersectBy eq xs@(_:_) ys@(_:_) = [x | x <- xs, any (eq x) ys] --- Puts a separator element between all elements in a list. --- --- Example: `(intersperse 9 [1,2,3,4]) = [1,9,2,9,3,9,4]` intersperse :: a -> [a] -> [a] intersperse _ [] = [] intersperse _ [x] = [x] intersperse sep (x:xs@(_:_)) = x : sep : intersperse sep xs --- `intercalate xs xss` is equivalent to `(concat (intersperse xs xss))`. --- It inserts the list `xs` in between the lists in `xss` and --- concatenates the result. intercalate :: [a] -> [[a]] -> [a] intercalate xs xss = concat (intersperse xs xss) --- Transposes the rows and columns of the argument. --- --- Example: `(transpose [[1,2,3],[4,5,6]]) = [[1,4],[2,5],[3,6]]` transpose :: [[a]] -> [[a]] transpose [] = [] transpose ([] : xss) = transpose xss transpose ((x:xs) : xss) = (x : map head xss) : transpose (xs : map tail xss) --- Diagonalization of a list of lists. --- Fairly merges (possibly infinite) list of (possibly infinite) lists. --- --- @param xss - lists of lists --- @return fair enumeration of all elements of inner lists of given lists --- diagonal :: [[a]] -> [a] diagonal = concat . foldr diags [] where diags [] ys = 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 --- Returns the list of all permutations of the argument. permutations :: [a] -> [[a]] permutations xs0 = xs0 : perms xs0 [] where perms [] _ = [] perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is) where interleave xs r = let (_, zs) = interleave' id xs r in zs interleave' _ [] r = (ts, r) interleave' f (y:ys) r = let (us, zs) = interleave' (f . (y:)) ys r in (y:us, f (t:y:us) : zs) --- Partitions a list into a pair of lists where the first list --- contains those elements that satisfy the predicate argument --- and the second list contains the remaining arguments. --- --- Example: `(partition (<4) [8,1,5,2,4,3]) = ([1,2,3],[8,5,4])` partition :: (a -> Bool) -> [a] -> ([a],[a]) partition p xs = foldr select ([],[]) xs where select x (ts,fs) = if p x then (x:ts,fs) else (ts,x:fs) --- Splits the list argument into a list of lists of equal adjacent --- elements. --- --- Example: `(group [1,2,2,3,3,3,4]) = [[1],[2,2],[3,3,3],[4]]` group :: Eq a => [a] -> [[a]] group = groupBy (==) --- Splits the list argument into a list of lists of related adjacent --- elements. --- @param eq - the relation to classify adjacent elements --- @param xs - the list of elements --- @return the list of lists of related adjacent elements groupBy :: (a -> a -> Bool) -> [a] -> [[a]] groupBy _ [] = [] groupBy eq (x:xs) = (x:ys) : groupBy eq zs where (ys,zs) = span (eq x) xs --- Breaks the second list argument into pieces separated by the first --- list argument, consuming the delimiter. An empty delimiter is --- invalid, and will cause an error to be raised. splitOn :: Eq a => [a] -> [a] -> [[a]] splitOn [] _ = error "splitOn called with an empty pattern" splitOn [x] xs = split (x ==) xs splitOn sep@(_:_:_) xs = go xs where go [] = [[]] go l@(y:ys) | sep `isPrefixOf` l = [] : go (drop len l) | otherwise = let (zs:zss) = go ys in (y:zs):zss len = length sep --- Splits a list into components delimited by separators, --- where the predicate returns True for a separator element. --- The resulting components do not contain the separators. --- Two adjacent separators result in an empty component in the output. --- --- > split (=='a') "aabbaca" == ["","","bb","c",""] --- > split (=='a') "" == [""] split :: (a -> Bool) -> [a] -> [[a]] split _ [] = [[]] split p (x:xs) | p x = [] : split p xs | otherwise = let (ys:yss) = split p xs in (x:ys):yss --- Returns all initial segments of a list, starting with the shortest. --- Example: `inits [1,2,3] == [[],[1],[1,2],[1,2,3]]` --- @param xs - the list of elements --- @return the list of initial segments of the argument list inits :: [a] -> [[a]] inits [] = [[]] inits (x:xs) = [] : map (x:) (inits xs) --- Returns all final segments of a list, starting with the longest. --- Example: `tails [1,2,3] == [[1,2,3],[2,3],[3],[]]` tails :: [a] -> [[a]] tails [] = [[]] tails xxs@(_:xs) = xxs : tails xs --- Replaces an element in a list. --- @param x - the new element --- @param p - the position of the new element (head = 0) --- @param ys - the old list --- @return the new list where the `p`. element is replaced by `x` replace :: a -> Int -> [a] -> [a] replace _ _ [] = [] replace x p (y:ys) | p==0 = x:ys | otherwise = y:(replace x (p-1) ys) --- Checks whether a list is a prefix of another. --- @param xs - a list --- @param ys - a list --- @return `True` if `xs` is a prefix of `ys` isPrefixOf :: Eq a => [a] -> [a] -> Bool isPrefixOf [] _ = True isPrefixOf (_:_) [] = False isPrefixOf (x:xs) (y:ys) = x==y && (isPrefixOf xs ys) --- Checks whether a list is a suffix of another. --- @param xs - a list --- @param ys - a list --- @return `True` if `xs` is a suffix of `ys` isSuffixOf :: Eq a => [a] -> [a] -> Bool isSuffixOf xs ys = isPrefixOf (reverse xs) (reverse ys) --- Checks whether a list is contained in another. --- @param xs - a list --- @param ys - a list --- @return True if xs is contained in ys isInfixOf :: Eq a => [a] -> [a] -> Bool isInfixOf xs ys = any (isPrefixOf xs) (tails ys) --- Sorts a list w.r.t. an ordering relation by the insertion method. sortBy :: (a -> a -> Bool) -> [a] -> [a] sortBy le = foldr (insertBy le) [] --- Inserts an object into a list according to an ordering relation. --- @param le - an ordering relation (e.g., less-or-equal) --- @param x - an element --- @param xs - a list --- @return a list where the element has been inserted insertBy :: (a -> a -> Bool) -> a -> [a] -> [a] insertBy _ x [] = [x] insertBy le x (y:ys) = if le x y then x : y : ys else y : insertBy le x ys --- Returns the last element of a non-empty list. last :: [a] -> a last [x] = x last (_ : xs@(_:_)) = last xs --- Returns the input list with the last element removed. init :: [a] -> [a] init [_] = [] init (x:xs@(_:_)) = x : init xs --- Returns the sum of a list of integers. sum :: Num a => [a] -> a sum ns = foldl (+) 0 ns --- Returns the product of a list of integers. product :: Num a => [a] -> a product ns = foldl (*) 1 ns --- Returns the maximum of a non-empty list. maximum :: Ord a => [a] -> a maximum xs@(_:_) = foldl1 max xs --- Returns the maximum of a non-empty list --- according to the given comparison function maximumBy :: (a -> a -> Ordering) -> [a] -> a maximumBy cmp xs@(_:_) = foldl1 maxBy xs where maxBy x y = case cmp x y of GT -> x _ -> y --- Returns the minimum of a non-empty list. minimum :: Ord a => [a] -> a minimum xs@(_:_) = foldl1 min xs --- Returns the minimum of a non-empty list --- according to the given comparison function minimumBy :: (a -> a -> Ordering) -> [a] -> a minimumBy cmp xs@(_:_) = foldl1 minBy xs where minBy x y = case cmp x y of GT -> y _ -> x --- `scanl` is similar to `foldl`, but returns a list of successive --- reduced values from the left: --- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] scanl :: (a -> b -> a) -> a -> [b] -> [a] scanl f q ls = q : (case ls of [] -> [] x:xs -> scanl f (f q x) xs) --- `scanl1` is a variant of `scanl` that has no starting value argument: --- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] scanl1 :: (a -> a -> a) -> [a] -> [a] scanl1 _ [] = [] scanl1 f (x:xs) = scanl f x xs --- `scanr` is the right-to-left dual of `scanl`. scanr :: (a -> b -> b) -> b -> [a] -> [b] scanr _ q0 [] = [q0] scanr f q0 (x:xs) = f x q : qs where qs@(q:_) = scanr f q0 xs --- `scanr1` is a variant of `scanr` that has no starting value argument. scanr1 :: (a -> a -> a) -> [a] -> [a] scanr1 _ [] = [] scanr1 _ [x] = [x] scanr1 f (x:xs@(_:_)) = f x q : qs where qs@(q:_) = scanr1 f xs --- The `mapAccumL` function behaves like a combination of `map` and --- `foldl`; it applies a function to each element of a list, passing --- an accumulating parameter from left to right, and returning a final --- value of this accumulator together with the new list. mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) mapAccumL _ s [] = (s, []) mapAccumL f s (x:xs) = (s'',y:ys) where (s', y ) = f s x (s'',ys) = mapAccumL f s' xs --- The `mapAccumR` function behaves like a combination of `map` and --- `foldr`; it applies a function to each element of a list, passing --- an accumulating parameter from right to left, and returning a final --- value of this accumulator together with the new list. mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) mapAccumR _ s [] = (s, []) mapAccumR f s (x:xs) = (s'', y:ys) where (s'',y ) = f s' x (s', ys) = mapAccumR f s xs --- Builds an infinite list from a finite one. cycle :: [a] -> [a] cycle xs@(_:_) = ys where ys = xs ++ ys --- Builds a list from a seed value. unfoldr :: (b -> Maybe (a, b)) -> b -> [a] unfoldr f b = case f b of Just (a, new_b) -> a : unfoldr f new_b Nothing -> [] curry-libs-v2.2.0/Makefile_kics2000066400000000000000000000217761355602362200165500ustar00rootroot00000000000000# Makefile for various compilations of the system libraries, # in particular, to generate the documentation CYMAKEPARAMS = --extended -Wnone -i. KICS2=$(ROOT)/bin/kics2 # directory for HTML documentation files # LIBDOCDIR = $(DOCDIR)/html LIBDOCDIR := CDOC # directory for LaTeX documentation files TEXDOCDIR := $(DOCDIR)/src/lib # replacement stuff comma := , empty := space := $(empty) $(empty) # prefix "pre" "dir/file.ext" = "dir/prefile.ext" prefix = $(patsubst ./%,%,$(dir $(2))$(1)$(notdir $(2))) # comma_sep "a b c" = "a, b, c" comma_sep = $(subst $(space),$(comma)$(space),$(1)) MODULE_FOLDERS:=$(shell find * -type d) TRACE_FOLDERS =$(addprefix .curry/kics2/,$(MODULE_FOLDERS)) CURRY_FILES :=$(shell find * -name "*.curry") # Curry library files LIB_CURRY = $(filter-out $(EXCLUDES), $(CURRY_FILES)) # lib names without directory prefix LIB_NAMES = $(subst /,., $(basename $(LIB_CURRY))) # lib names included in library documentation page (without directory prefix) LIB_DOCNAMES = $(filter-out $(DOCEXCLUDES), $(LIB_NAMES)) # Generated files LIB_TFCY = $(foreach lib, $(LIB_CURRY:%.curry=.curry/%.tfcy), $(lib)) LIB_ACY = $(foreach lib, $(LIB_CURRY:%.curry=.curry/%.acy), $(lib)) LIB_HS = $(foreach lib, $(LIB_CURRY:.curry=.hs), .curry/kics2/$(call prefix,Curry_,$(lib))) LIB_HS_TRACE = $(foreach lib, $(LIB_CURRY:.curry=.hs), .curry/kics2/$(call prefix,Curry_Trace_,$(lib))) LIB_HTML = $(foreach lib, $(LIB_CURRY:.curry=.html), $(LIBDOCDIR)/$(subst /,.,$(lib))) LIB_TEX = $(foreach lib, $(LIB_CURRY:.curry=.tex), $(TEXDOCDIR)/$(subst /,.,$(lib))) HS_LIB_NAMES = $(call comma_sep,$(foreach lib,$(LIB_NAMES),$(if $(findstring .,$(lib)),$(basename $(lib)).Curry_$(subst .,,$(suffix $(lib))),Curry_$(lib)))) HS_LIB_TRACE_NAMES = $(call comma_sep,$(foreach lib,$(LIB_NAMES),$(if $(findstring .,$(lib)),$(basename $(lib)).Curry_Trace_$(subst .,,$(suffix $(lib))),Curry_Trace_$(lib)))) ALLLIBS = AllLibraries MAINGOAL = Curry_Main_Goal.curry # Modules not included as regular libraries: EXCLUDES = $(ALLLIBS).curry $(MAINGOAL) # Modules not included in library documentation index page: DOCEXCLUDES = CPNS ValueSequence PACKAGE = kics2-libraries PACKAGE_TRACE = kics2-libraries-trace CABAL_FILE = $(PACKAGE).cabal CABAL_TRACE_FILE = $(PACKAGE_TRACE).cabal CABAL_LIBDEPS = $(call comma_sep,$(LIBDEPS)) # Executable of CurryDoc: CURRYDOC := $(shell which curry-doc) ######################################################################## # support for installation ######################################################################## .PHONY: install install: tfcy acy hs hstrace $(ALLLIBS).curry $(MAKE) $(CABAL_FILE) $(CABAL_INSTALL) $(CABAL_PROFILE) rm -f $(CABAL_FILE) $(MAKE) $(CABAL_TRACE_FILE) $(CABAL_INSTALL) $(CABAL_PROFILE) rm -f $(CABAL_TRACE_FILE) # create a program importing all libraries in order to re-compile them # so that all auxiliary files (.nda, .hs, ...) are up-to-date $(ALLLIBS).curry: $(LIB_CURRY) Makefile rm -f $@ for i in $(filter-out Prelude, $(LIB_NAMES)) ; do echo "import $$i" >> $@ ; done .PHONY: allsources allsources: @echo $(LIB_CURRY) .PHONY: unregister unregister: -$(GHC_UNREGISTER) $(PACKAGE)-$(VERSION) -$(GHC_UNREGISTER) $(PACKAGE_TRACE)-$(VERSION) # clean Haskell intermediate files .PHONY: clean: -cd .curry/kics2 && rm -f *.hi *.o # clean all generated files .PHONY: cleanall cleanall: rm -fr "$(LIBDOCDIR)"/bt3 rm -rf "$(LIBDOCDIR)" rm -rf "$(TEXDOCDIR)" rm -rf dist rm -f $(CABAL_FILE) rm -f $(CABAL_TRACE_FILE) rm -fr .curry $(CABAL_FILE): ../Makefile Makefile echo "Name: $(PACKAGE)" > $@ echo "Version: $(VERSION)" >> $@ echo "Description: The standard libraries for KiCS2" >> $@ echo "License: OtherLicense" >> $@ echo "Author: The KiCS2 Team" >> $@ echo "Maintainer: kics2@curry-lang.org" >> $@ echo "Build-Type: Simple" >> $@ echo "Cabal-Version: >= 1.9.2" >> $@ echo "" >> $@ echo "Library" >> $@ echo " Build-Depends:" >> $@ echo " kics2-runtime == $(VERSION)" >> $@ echo " , $(CABAL_LIBDEPS)" >> $@ echo " if os(windows)" >> $@ echo " Build-Depends: Win32" >> $@ echo " else" >> $@ echo " Build-Depends: unix" >> $@ echo " Exposed-modules: $(HS_LIB_NAMES)" >> $@ echo " hs-source-dirs: ./.curry/kics2" >> $@ $(CABAL_TRACE_FILE): ../Makefile Makefile echo "Name: $(PACKAGE_TRACE)" > $@ echo "Version: $(VERSION)" >> $@ echo "Description: The tracing standard libraries for KiCS2" >> $@ echo "License: OtherLicense" >> $@ echo "Author: The KiCS2 Team" >> $@ echo "Maintainer: kics2@curry-lang.org" >> $@ echo "Build-Type: Simple" >> $@ echo "Cabal-Version: >= 1.9.2" >> $@ echo "" >> $@ echo "Library" >> $@ echo " Build-Depends:" >> $@ echo " kics2-runtime == $(VERSION)" >> $@ echo " , $(CABAL_LIBDEPS)" >> $@ echo " if os(windows)" >> $@ echo " Build-Depends: Win32" >> $@ echo " else" >> $@ echo " Build-Depends: unix" >> $@ echo " Exposed-modules: $(HS_LIB_TRACE_NAMES)" >> $@ echo " hs-source-dirs: ./.curry/kics2" >> $@ # generate the compiled Haskell target files of all libraries: .NOTPARALLEL: hs .PHONY: hs hs: $(LIB_HS) # .curry/kics2/Curry_$(ALLLIBS).hs # generate the compiled Haskell target files with tracing of all libraries: .NOTPARALLEL: hstrace .PHONY: hstrace hstrace: $(LIB_HS_TRACE) define TRACERULE $(dir .curry/kics2/$1)Curry_$(notdir $1).hs: $1.curry $$(COMP) -v0 -i. $$(subst /,.,$$<) $(dir .curry/kics2/$1)Curry_Trace_$(notdir $1).hs: $1.curry $$(COMP) -v0 -i. --trace-failure $$(subst /,.,$$<) endef $(foreach module, $(basename $(LIB_CURRY)),$(eval $(call TRACERULE,$(module)))) # generate the typed FlatCurry files of all libraries: .NOTPARALLEL: tfcy .PHONY: tfcy tfcy: $(LIB_TFCY) # generate FlatCurry file in subdirectory .curry: .curry/%.tfcy: %.curry "$(CYMAKE)" --typed-flat $(CYMAKEPARAMS) $(subst /,.,$*) # generate the AbstractCurry files of all libraries: .PHONY: acy acy: $(LIB_ACY) # generate AbstractCurry file in subdirectory .curry: .curry/%.acy: %.curry "$(CYMAKE)" --acy $(CYMAKEPARAMS) $(subst /,.,$*) ############################################################################## # create HTML documentation files for system libraries ############################################################################## # Check whether CurryDoc is installed .PHONY: checkcurrydoc checkcurrydoc: @if [ ! -x "$(CURRYDOC)" ] ; then \ echo "ERROR: Executable 'curry-doc' is not installed!" && echo "Install it by > cpm installapp currydoc" && exit 1 ; \ fi INDEXHTML = $(LIBDOCDIR)/index.html HTMLEXCLUDES = $(INDEXHTML) $(foreach file, findex.html cindex.html KiCS2_libs.html, $(LIBDOCDIR)/$(file)) .PHONY: htmldoc htmldoc: checkcurrydoc $(LIB_CURRY) @mkdir -p "$(LIBDOCDIR)" @$(MAKE) $(LIB_HTML) @$(MAKE) $(INDEXHTML) $(INDEXHTML): $(filter-out $(HTMLEXCLUDES), $(wildcard $(LIBDOCDIR)/*.html)) @echo "Generating index pages for Curry libraries:" @echo $(LIB_DOCNAMES) $(CURRYDOC) --libsindexhtml "$(LIBDOCDIR)" $(LIB_DOCNAMES) # generate individual documentations for libraries define HTMLRULE $(LIBDOCDIR)/$1.html: $(subst .,/,$1).curry $$(CURRYDOC) --noindexhtml "$(LIBDOCDIR)" $$(subst /,.,$$<) endef $(foreach module, $(LIB_NAMES),$(eval $(call HTMLRULE,$(module)))) # uncomment for rule debugging # $(foreach module, $(LIB_NAMES),$(info $(call HTMLRULE,$(module)))) ############################################################################## # create LaTeX documentation files for system libraries ############################################################################## .PHONY: texdoc texdoc: checkcurrydoc $(LIB_CURRY) @mkdir -p "$(TEXDOCDIR)" $(MAKE) $(LIB_TEX) # generate individual LaTeX documentations for libraries define TEXRULE $(TEXDOCDIR)/$1.tex: $(subst .,/,$1).curry $$(CURRYDOC) --tex "$(TEXDOCDIR)" $$(subst /,.,$$<) endef $(foreach module, $(LIB_NAMES),$(eval $(call TEXRULE,$(module)))) curry-libs-v2.2.0/Makefile_kics2_install000066400000000000000000000030061355602362200202600ustar00rootroot00000000000000# directory containing the repository library files: ifndef CURRYLIBSDIR CURRYLIBSDIR=$(ROOT)/lib-trunk endif MODULE_FOLDERS :=$(shell cd $(CURRYLIBSDIR) && find * -type d) CURRY_FILES :=$(shell cd $(CURRYLIBSDIR) && find * -name "*.curry") GHC_FILES :=$(shell cd $(CURRYLIBSDIR) && find * -name "*.kics2") GHC_CURRY_FILES:=$(addsuffix .curry, $(basename $(GHC_FILES))) CURRYONLY_FILES =$(filter-out $(GHC_CURRY_FILES), $(CURRY_FILES)) # get all library files from standard makefile: LIB_CURRY = `cd $(CURRYLIBSDIR) && $(MAKE) --no-print-directory --quiet -f Makefile.$(CURRYSYSTEM) allsources` # name of this makefile: CURRENT_MAKEFILE = $(CURRYLIBSDIR)/Makefile_$(CURRYSYSTEM)_install ########################################################################## # Install the library sources into the Curry system library directory: .PHONY: install install: mkdir -p $(LIBDIR) cd $(LIBDIR) && $(MAKE) -f $(CURRENT_MAKEFILE) $(MODULE_FOLDERS) $(CURRYONLY_FILES) $(GHC_CURRY_FILES) $(LIBDIR)/Makefile $(LIBDIR)/VERSION $(LIBDIR)/test.sh $(MODULE_FOLDERS): %: $(CURRYLIBSDIR)/% mkdir -p $@ $(CURRYONLY_FILES): %.curry: $(CURRYLIBSDIR)/%.curry cp $< $@ $(GHC_FILES): %.kics2: $(CURRYLIBSDIR)/%.kics2 cp $< $@ $(GHC_CURRY_FILES): %.curry: $(CURRYLIBSDIR)/%.curry %.kics2 cp $< $@ $(LIBDIR)/Makefile: $(CURRYLIBSDIR)/Makefile_$(CURRYSYSTEM) cp $< $@ $(LIBDIR)/VERSION: $(CURRYLIBSDIR)/VERSION cp $< $@ $(LIBDIR)/test.sh: $(CURRYLIBSDIR)/test.sh cp $< $@ index.html: $(CURRYLIBSDIR)/index.html.$(CURRYSYSTEM) cp $< $@ curry-libs-v2.2.0/Makefile_pakcs000066400000000000000000000122561355602362200166270ustar00rootroot00000000000000# Makefile for various compilations of the system libraries, # in particular, to generate the documentation CYMAKEPARAMS = --extended -Wnone -i. PAKCS=$(ROOT)/bin/pakcs CURRY_FILES:=$(shell find * -name "*.curry") # directory for HTML documentation files: LIBDOCDIR=CDOC # directory for LaTeX documentation files: TEXDOCDIR := $(DOCDIR)/src/lib # Curry library files LIB_CURRY = $(filter-out $(EXCLUDES), $(CURRY_FILES)) # lib names without directory prefix LIB_NAMES = $(subst /,., $(basename $(LIB_CURRY))) # lib names included in library documentation page (without directory prefix) LIB_DOCNAMES = $(filter-out $(DOCEXCLUDES), $(LIB_NAMES)) # Generated files: LIB_FCY = $(foreach lib, $(LIB_CURRY:%.curry=.curry/%.fcy), $(lib)) LIB_TFCY = $(foreach lib, $(LIB_CURRY:%.curry=.curry/%.tfcy),$(lib)) LIB_ACY = $(foreach lib, $(LIB_CURRY:%.curry=.curry/%.acy), $(lib)) LIB_PL = $(foreach lib, $(LIB_CURRY:%.curry=.curry/pakcs/%.pl), $(lib)) LIB_HTML = $(foreach lib, $(LIB_CURRY:.curry=.html), $(LIBDOCDIR)/$(subst /,.,$(lib))) LIB_TEX = $(foreach lib, $(LIB_CURRY:.curry=.tex), $(TEXDOCDIR)/$(subst /,.,$(lib))) ALLLIBS = AllLibraries # Modules not included as regular libraries: EXCLUDES = $(ALLLIBS).curry # Modules not included in library documentation index page: DOCEXCLUDES = CHRcompiled CPNS # Executable of CurryDoc: CURRYDOC := $(shell which curry-doc) .PHONY: all all: $(ALLLIBS).curry fcy acy # create a program importing all libraries in order to re-compile them # so that all auxiliary files are up-to-date $(ALLLIBS).curry: $(LIB_CURRY) Makefile rm -f $@ for i in $(filter-out Prelude, $(LIB_NAMES)) ; do echo "import $$i" >> $@ ; done .PHONY: allsources allsources: @echo $(LIB_CURRY) # clean all generated files .PHONY: clean clean: rm -fr "$(LIBDOCDIR)"/bt3 rm -f "$(LIBDOCDIR)"/* rm -f "$(TEXDOCDIR)"/* rm -fr .curry # clean all generated Prolog files .PHONY: cleanpl cleanpl: rm -f .curry/pakcs/*.pl .curry/pakcs/*.po ########################################################################## # generate the FlatCurry files of all libraries: .NOTPARALLEL: fcy .PHONY: fcy fcy: $(LIB_FCY) # generate the type-annotated FlatCurry files of all libraries: .PHONY: tfcy tfcy: $(LIB_TFCY) # generate the AbstractCurry files of all libraries: .PHONY: acy acy: $(LIB_ACY) # generate the compiled Prolog target files of all libraries: .NOTPARALLEL: pl .PHONY: pl pl: .curry/pakcs/$(ALLLIBS).pl $(LIB_PL) # generate FlatCurry file in subdirectory .curry: .curry/%.fcy: %.curry "$(CYMAKE)" --flat $(CYMAKEPARAMS) $(subst /,.,$*) -D__PAKCS__=$(shell printf '%d%02d' $(MAJORVERSION) $(MINORVERSION)) # generate type-annotated FlatCurry file in subdirectory .curry: .curry/%.tfcy: %.curry "$(CYMAKE)" --typed-flat $(CYMAKEPARAMS) $(subst /,.,$*) -D__PAKCS__=$(shell printf '%d%02d' $(MAJORVERSION) $(MINORVERSION)) # generate all AbstractCurry files in subdirectory .curry: .curry/%.acy: %.curry "$(CYMAKE)" --acy $(CYMAKEPARAMS) $(subst /,.,$*) -D__PAKCS__=$(shell printf '%d%02d' $(MAJORVERSION) $(MINORVERSION)) # generate all Prolog translation (without binding optimization): .curry/pakcs/%.pl: .curry/%.fcy rm -f $@ && "$(PAKCS)" -Dbindingoptimization=no --nocypm --quiet :compile $(subst /,.,$*) :quit ############################################################################## # create HTML documentation files for system libraries ############################################################################## # Check whether CurryDoc is installed .PHONY: checkcurrydoc checkcurrydoc: @if [ ! -x "$(CURRYDOC)" ] ; then \ echo "ERROR: Executable 'curry-doc' is not installed!" && echo "Install it by > cpm installapp currydoc" && exit 1 ; \ fi INDEXHTML = $(LIBDOCDIR)/index.html HTMLEXCLUDES = $(INDEXHTML) $(foreach file, findex.html cindex.html PAKCS_libs.html, $(LIBDOCDIR)/$(file)) .PHONY: htmldoc htmldoc: checkcurrydoc $(LIB_CURRY) @mkdir -p "$(LIBDOCDIR)" @$(MAKE) $(LIB_HTML) @$(MAKE) $(INDEXHTML) $(INDEXHTML): $(filter-out $(HTMLEXCLUDES), $(wildcard $(LIBDOCDIR)/*.html)) @echo "Generating index pages for Curry libraries:" @echo $(LIB_DOCNAMES) $(CURRYDOC) --libsindexhtml "$(LIBDOCDIR)" $(LIB_DOCNAMES) # generate individual documentations for libraries define HTMLRULE $(LIBDOCDIR)/$1.html: $(subst .,/,$1).curry $$(CURRYDOC) --noindexhtml "$(LIBDOCDIR)" $$(subst /,.,$$<) endef $(foreach module, $(LIB_NAMES),$(eval $(call HTMLRULE,$(module)))) # uncomment for rule debugging # $(foreach module, $(LIB_NAMES),$(info $(call HTMLRULE,$(module)))) ############################################################################## # create LaTeX documentation files for system libraries ############################################################################## .PHONY: texdoc texdoc: checkcurrydoc $(LIB_CURRY) @mkdir -p "$(TEXDOCDIR)" $(MAKE) $(LIB_TEX) # Generate individual LaTeX documentations for libraries. # In case of failures (which might occur due to memory problems in SWI-Prolog) # an empty LaTeX file is generated so that the make process does not die. define TEXRULE $(TEXDOCDIR)/$1.tex: $(subst .,/,$1).curry $$(CURRYDOC) --tex "$(TEXDOCDIR)" $$(subst /,.,$$<) || (rm -f $$@ && touch $$@) endef $(foreach module, $(LIB_NAMES),$(eval $(call TEXRULE,$(module)))) curry-libs-v2.2.0/Makefile_pakcs_install000066400000000000000000000032431355602362200203510ustar00rootroot00000000000000# directory containing the repository library files: ifndef CURRYLIBSDIR CURRYLIBSDIR=$(ROOT)/lib-trunk endif MODULE_FOLDERS :=$(shell cd $(CURRYLIBSDIR) && find * -type d) CURRY_FILES :=$(shell cd $(CURRYLIBSDIR) && find * -name "*.curry") PAKCS_CURRY_FILES :=$(basename $(shell cd $(CURRYLIBSDIR) && find * -name "*.curry.pakcs")) C2P_FILES :=$(shell cd $(CURRYLIBSDIR) && find * -name "*.pakcs") C2P_CURRY_FILES :=$(addsuffix .curry, $(basename $(C2P_FILES))) NON_PAKCS_BASENAMES=$(basename $(filter-out $(CURRY_PAKCS_FILES), $(CURRY_FILES))) CURRYONLY_FILES =$(addsuffix .curry, $(filter-out $(basename $(C2P_FILES)), $(NON_PAKCS_BASENAMES))) # name of this makefile: CURRENT_MAKEFILE = $(CURRYLIBSDIR)/Makefile_$(CURRYSYSTEM)_install ########################################################################## # Install the library sources into the Curry system library directory: .PHONY: install install: mkdir -p $(LIBDIR) cd $(LIBDIR) && $(MAKE) -f $(CURRENT_MAKEFILE) $(MODULE_FOLDERS) $(CURRYONLY_FILES) $(PAKCS_CURRY_FILES) $(C2P_CURRY_FILES) $(LIBDIR)/Makefile $(LIBDIR)/VERSION $(LIBDIR)/test.sh $(MODULE_FOLDERS): %: $(CURRYLIBSDIR)/% mkdir -p $@ $(CURRYONLY_FILES): %.curry: $(CURRYLIBSDIR)/%.curry cp $< $@ $(PAKCS_CURRY_FILES): %.curry: $(CURRYLIBSDIR)/%.curry.pakcs cp $< $@ $(C2P_FILES): %.pakcs: $(CURRYLIBSDIR)/%.pakcs cp $< $@ $(C2P_CURRY_FILES): %.curry: $(CURRYLIBSDIR)/%.curry %.pakcs cp $< $@ $(LIBDIR)/Makefile: $(CURRYLIBSDIR)/Makefile_$(CURRYSYSTEM) cp $< $@ $(LIBDIR)/VERSION: $(CURRYLIBSDIR)/VERSION cp $< $@ $(LIBDIR)/test.sh: $(CURRYLIBSDIR)/test.sh cp $< $@ index.html: $(CURRYLIBSDIR)/index.html.$(CURRYSYSTEM) cp $< $@ curry-libs-v2.2.0/Maybe.curry000066400000000000000000000052301355602362200161230ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Library with some useful functions on the `Maybe` datatype. --- --- @author Frank Huch, Bernd Brassel, Bjoern Peemoeller --- @version October 2014 --- @category general --- ---------------------------------------------------------------------------- module 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 isJust Nothing = False --- Return `True` iff the argument is of the form `Nothing`. isNothing :: Maybe _ -> Bool isNothing Nothing = True isNothing (Just _) = False --- Extract the argument from the `Just` constructor and throw an error --- if the argument is `Nothing`. fromJust :: Maybe a -> a fromJust (Just a) = a fromJust Nothing = error "Maybe.fromJust: Nothing" --- Extract the argument from the `Just` constructor or return the provided --- default value if the argument is `Nothing`. fromMaybe :: a -> Maybe a -> a fromMaybe d Nothing = d fromMaybe _ (Just a) = a --- Return `Nothing` on an empty list or `Just x` where `x` is the first --- list element. listToMaybe :: [a] -> Maybe a listToMaybe [] = Nothing listToMaybe (a : _) = Just a --- Return an empty list for `Nothing` or a singleton list for `Just x`. maybeToList :: Maybe a -> [a] maybeToList Nothing = [] maybeToList (Just a) = [a] --- Return the list of all `Just` values. catMaybes :: [Maybe a] -> [a] catMaybes ms = [ m | (Just m) <- ms ] --- Apply a function which may throw out elements using the `Nothing` --- 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 curry-libs-v2.2.0/Prelude.curry000066400000000000000000001614211355602362200164730ustar00rootroot00000000000000---------------------------------------------------------------------------- --- The standard prelude of Curry (with type classes). --- All exported functions, data types, classes, and methods defined --- in this module are always available in any Curry program. ---------------------------------------------------------------------------- {-# LANGUAGE CPP #-} {-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-overlapping #-} module Prelude ( -- classes and overloaded functions Eq(..) , elem, notElem, lookup , Ord(..) , Show(..), ShowS, print, shows, showChar, showString, showParen , Read (..), ReadS, lex, read, reads, readParen , Bounded (..), Enum (..), boundedEnumFrom, boundedEnumFromThen , asTypeOf , Num(..), Fractional(..), Real(..), Integral(..) -- data types , Bool (..) , Char (..) , Int (..) , Float (..), String , Ordering (..) , Success, Maybe (..), Either (..), IO (..), IOError (..) , DET -- functions , (.), id, const, curry, uncurry, flip, until , seq, ensureNotFree, ensureSpine, ($), ($!), ($!!), ($#), ($##) , error, failed , (&&), (||), not, otherwise, if_then_else, solve , fst, snd, head, tail, null, (++), length, (!!), map, foldl, foldl1 , foldr, foldr1, filter, zip, zip3, zipWith, zipWith3, unzip, unzip3 , concat, concatMap, iterate, repeat, replicate, take, drop, splitAt , takeWhile, dropWhile, span, break, lines, unlines, words, unwords , reverse, and, or, any, all , ord, chr, (=:=), success, (&), (&>), maybe , either, (>>=), return, (>>), done, putChar, getChar, readFile , writeFile, appendFile , putStr, putStrLn, getLine, userError, ioError, showError , catch, doSolve, sequenceIO, sequenceIO_, mapIO , mapIO_, (?), anyOf, unknown , when, unless, forIO, forIO_, liftIO, foldIO , normalForm, groundNormalForm, apply, cond, (=:<=) , enumFrom_, enumFromTo_, enumFromThen_, enumFromThenTo_, negate_, negateFloat , PEVAL , Monad(..) , Functor(..) , sequence, sequence_, mapM, mapM_, foldM, liftM, liftM2, forM, forM_ , unlessM, whenM , letrec #ifdef __PAKCS__ , (=:<<=) #endif ) where -- Lines beginning with "--++" are part of the prelude -- but cannot parsed by the compiler -- Infix operator declarations: infixl 9 !! infixr 9 . infixl 7 *, `div`, `mod`, `quot`, `rem`, / infixl 6 +, - -- infixr 5 : -- declared together with list infixr 5 ++ infix 4 =:=, ==, /=, <, >, <=, >=, =:<= #ifdef __PAKCS__ infix 4 =:<<= #endif infix 4 `elem`, `notElem` infixr 3 && infixr 2 || infixl 1 >>, >>= infixr 0 $, $!, $!!, $#, $##, `seq`, &, &>, ? -- externally defined types for numbers and characters external data Int external data Float external data Char type String = [Char] -- Some standard combinators: --- Function composition. (.) :: (b -> c) -> (a -> b) -> (a -> c) f . g = \x -> f (g x) --- Identity function. id :: a -> a id x = x --- Constant function. const :: a -> _ -> a const x _ = x --- Converts an uncurried function to a curried function. curry :: ((a,b) -> c) -> a -> b -> c curry f a b = f (a,b) --- Converts an curried function to a function on pairs. uncurry :: (a -> b -> c) -> (a,b) -> c uncurry f (a,b) = f a b --- (flip f) is identical to f but with the order of arguments reversed. flip :: (a -> b -> c) -> b -> a -> c flip f x y = f y x --- Repeats application of a function until a predicate holds. until :: (a -> Bool) -> (a -> a) -> a -> a until p f x = if p x then x else until p f (f x) --- Evaluates the first argument to head normal form (which could also --- be a free variable) and returns the second argument. seq :: _ -> a -> a x `seq` y = const y $! x --- Evaluates the argument to head normal form and returns it. --- Suspends until the result is bound to a non-variable term. ensureNotFree :: a -> a ensureNotFree external --- Evaluates the argument to spine form and returns it. --- Suspends until the result is bound to a non-variable spine. ensureSpine :: [a] -> [a] ensureSpine l = ensureList (ensureNotFree l) where ensureList [] = [] ensureList (x:xs) = x : ensureSpine xs --- Right-associative application. ($) :: (a -> b) -> a -> b f $ x = f x --- Right-associative application with strict evaluation of its argument --- to head normal form. ($!) :: (a -> b) -> a -> b ($!) external --- Right-associative application with strict evaluation of its argument --- to normal form. ($!!) :: (a -> b) -> a -> b ($!!) external --- Right-associative application with strict evaluation of its argument --- to a non-variable term. ($#) :: (a -> b) -> a -> b f $# x = f $! (ensureNotFree x) --- Right-associative application with strict evaluation of its argument --- to ground normal form. ($##) :: (a -> b) -> a -> b ($##) external --- Aborts the execution with an error message. error :: String -> _ error x = prim_error $## x prim_error :: String -> _ prim_error external --- A non-reducible polymorphic function. --- It is useful to express a failure in a search branch of the execution. --- It could be defined by: `failed = head []` failed :: _ failed external -- Boolean values -- already defined as builtin, since it is required for if-then-else data Bool = False | True deriving (Eq, Ord, Show, Read) --- Sequential conjunction on Booleans. (&&) :: Bool -> Bool -> Bool True && x = x False && _ = False --- Sequential disjunction on Booleans. (||) :: Bool -> Bool -> Bool True || _ = True False || x = x --- Negation on Booleans. not :: Bool -> Bool not True = False not False = True --- Useful name for the last condition in a sequence of conditional equations. otherwise :: Bool otherwise = True --- The standard conditional. It suspends if the condition is a free variable. if_then_else :: Bool -> a -> a -> a if_then_else b t f = case b of True -> t False -> f --- Enforce a Boolean condition to be true. --- The computation fails if the argument evaluates to `False`. solve :: Bool -> Bool solve True = True --- Conditional expression. --- An expression like `(c &> e)` is evaluated by evaluating the first --- argument to `True` and then evaluating `e`. --- The expression has no value if the condition does not evaluate to `True`. (&>) :: Bool -> a -> a True &> x = x --- The equational constraint. --- `(e1 =:= e2)` is satisfiable if both sides `e1` and `e2` can be --- reduced to a unifiable data term (i.e., a term without defined --- function symbols). (=:=) :: a -> a -> Bool (=:=) external --- Concurrent conjunction. --- An expression like `(c1 & c2)` is evaluated by evaluating --- the `c1` and `c2` in a concurrent manner. (&) :: Bool -> Bool -> Bool (&) external -- used for comparison of standard types like Int, Float and Char eqChar :: Char -> Char -> Bool #ifdef __PAKCS__ eqChar x y = (prim_eqChar $# y) $# x prim_eqChar :: Char -> Char -> Bool prim_eqChar external #else eqChar external #endif eqInt :: Int -> Int -> Bool #ifdef __PAKCS__ eqInt x y = (prim_eqInt $# y) $# x prim_eqInt :: Int -> Int -> Bool prim_eqInt external #else eqInt external #endif eqFloat :: Float -> Float -> Bool #ifdef __PAKCS__ eqFloat x y = (prim_eqFloat $# y) $# x prim_eqFloat :: Float -> Float -> Bool prim_eqFloat external #else eqFloat external #endif --- Ordering type. Useful as a result of comparison functions. data Ordering = LT | EQ | GT deriving (Eq, Ord, Show, Read) -- used for comparison of standard types like Int, Float and Char ltEqChar :: Char -> Char -> Bool #ifdef __PAKCS__ ltEqChar x y = (prim_ltEqChar $# y) $# x prim_ltEqChar :: Char -> Char -> Bool prim_ltEqChar external #else ltEqChar external #endif ltEqInt :: Int -> Int -> Bool #ifdef __PAKCS__ ltEqInt x y = (prim_ltEqInt $# y) $# x prim_ltEqInt :: Int -> Int -> Bool prim_ltEqInt external #else ltEqInt external #endif ltEqFloat :: Float -> Float -> Bool #ifdef __PAKCS__ ltEqFloat x y = (prim_ltEqFloat $# y) $# x prim_ltEqFloat :: Float -> Float -> Bool prim_ltEqFloat external #else ltEqFloat external #endif -- Pairs --++ data (a,b) = (a,b) --- Selects the first component of a pair. fst :: (a,_) -> a fst (x,_) = x --- Selects the second component of a pair. snd :: (_,b) -> b snd (_,y) = y -- Unit type --++ data () = () -- Lists --++ data [a] = [] | a : [a] --- Computes the first element of a list. head :: [a] -> a head (x:_) = x --- Computes the remaining elements of a list. tail :: [a] -> [a] tail (_:xs) = xs --- Is a list empty? null :: [_] -> Bool null [] = True null (_:_) = False --- Concatenates two lists. --- Since it is flexible, it could be also used to split a list --- into two sublists etc. (++) :: [a] -> [a] -> [a] [] ++ ys = ys (x:xs) ++ ys = x : xs++ys --- Computes the length of a list. length :: [_] -> Int length [] = 0 length (_:xs) = 1 + length xs {- -- This version is more efficient but less usable for verification: length :: [_] -> Int length xs = len xs 0 where len [] n = n len (_:ys) n = let np1 = n + 1 in len ys $!! np1 -} --- List index (subscript) operator, head has index 0. (!!) :: [a] -> Int -> a (x:xs) !! n | n==0 = x | n>0 = xs !! (n-1) --- Map a function on all elements of a list. map :: (a->b) -> [a] -> [b] map _ [] = [] map f (x:xs) = f x : map f xs --- Accumulates all list elements by applying a binary operator from --- left to right. Thus, --- --- foldl f z [x1,x2,...,xn] = (...((z `f` x1) `f` x2) ...) `f` xn foldl :: (a -> b -> a) -> a -> [b] -> a foldl _ z [] = z foldl f z (x:xs) = foldl f (f z x) xs --- Accumulates a non-empty list from left to right. foldl1 :: (a -> a -> a) -> [a] -> a foldl1 f (x:xs) = foldl f x xs --- Accumulates all list elements by applying a binary operator from --- right to left. Thus, --- --- foldr f z [x1,x2,...,xn] = (x1 `f` (x2 `f` ... (xn `f` z)...)) foldr :: (a->b->b) -> b -> [a] -> b foldr _ z [] = z foldr f z (x:xs) = f x (foldr f z xs) --- Accumulates a non-empty list from right to left: foldr1 :: (a -> a -> a) -> [a] -> a foldr1 _ [x] = x foldr1 f (x:xs@(_:_)) = f x (foldr1 f xs) --- Filters all elements satisfying a given predicate in a list. filter :: (a -> Bool) -> [a] -> [a] filter _ [] = [] filter p (x:xs) = if p x then x : filter p xs else filter p xs --- Joins two lists into one list of pairs. If one input list is shorter than --- the other, the additional elements of the longer list are discarded. zip :: [a] -> [b] -> [(a,b)] zip [] _ = [] zip (_:_) [] = [] zip (x:xs) (y:ys) = (x,y) : zip xs ys --- Joins three lists into one list of triples. If one input list is shorter --- than the other, the additional elements of the longer lists are discarded. zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] zip3 [] _ _ = [] zip3 (_:_) [] _ = [] zip3 (_:_) (_:_) [] = [] zip3 (x:xs) (y:ys) (z:zs) = (x,y,z) : zip3 xs ys zs --- Joins two lists into one list by applying a combination function to --- corresponding pairs of elements. Thus `zip = zipWith (,)` zipWith :: (a->b->c) -> [a] -> [b] -> [c] zipWith _ [] _ = [] zipWith _ (_:_) [] = [] zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys --- Joins three lists into one list by applying a combination function to --- corresponding triples of elements. Thus `zip3 = zipWith3 (,,)` zipWith3 :: (a->b->c->d) -> [a] -> [b] -> [c] -> [d] zipWith3 _ [] _ _ = [] zipWith3 _ (_:_) [] _ = [] zipWith3 _ (_:_) (_:_) [] = [] zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs --- Transforms a list of pairs into a pair of lists. unzip :: [(a,b)] -> ([a],[b]) unzip [] = ([],[]) unzip ((x,y):ps) = (x:xs,y:ys) where (xs,ys) = unzip ps --- Transforms a list of triples into a triple of lists. unzip3 :: [(a,b,c)] -> ([a],[b],[c]) unzip3 [] = ([],[],[]) unzip3 ((x,y,z):ts) = (x:xs,y:ys,z:zs) where (xs,ys,zs) = unzip3 ts --- Concatenates a list of lists into one list. concat :: [[a]] -> [a] concat l = foldr (++) [] l --- Maps a function from elements to lists and merges the result into one list. concatMap :: (a -> [b]) -> [a] -> [b] concatMap f = concat . map f --- Infinite list of repeated applications of a function f to an element x. --- Thus, `iterate f x = [x, f x, f (f x),...]` iterate :: (a -> a) -> a -> [a] iterate f x = x : iterate f (f x) --- Infinite list where all elements have the same value. --- Thus, `repeat x = [x, x, x,...]` repeat :: a -> [a] repeat x = x : repeat x --- List of length n where all elements have the same value. replicate :: Int -> a -> [a] replicate n x = take n (repeat x) --- Returns prefix of length n. take :: Int -> [a] -> [a] take n l = if n<=0 then [] else takep n l where takep _ [] = [] takep m (x:xs) = x : take (m-1) xs --- Returns suffix without first n elements. drop :: Int -> [a] -> [a] drop n xs = if n<=0 then xs else case xs of [] -> [] (_:ys) -> drop (n-1) ys --- (splitAt n xs) is equivalent to (take n xs, drop n xs) splitAt :: Int -> [a] -> ([a],[a]) splitAt n l = if n<=0 then ([],l) else splitAtp n l where splitAtp _ [] = ([],[]) splitAtp m (x:xs) = let (ys,zs) = splitAt (m-1) xs in (x:ys,zs) --- Returns longest prefix with elements satisfying a predicate. takeWhile :: (a -> Bool) -> [a] -> [a] takeWhile _ [] = [] takeWhile p (x:xs) = if p x then x : takeWhile p xs else [] --- Returns suffix without takeWhile prefix. dropWhile :: (a -> Bool) -> [a] -> [a] dropWhile _ [] = [] dropWhile p (x:xs) = if p x then dropWhile p xs else x:xs --- (span p xs) is equivalent to (takeWhile p xs, dropWhile p xs) span :: (a -> Bool) -> [a] -> ([a],[a]) span _ [] = ([],[]) span p (x:xs) | p x = let (ys,zs) = span p xs in (x:ys, zs) | otherwise = ([],x:xs) --- (break p xs) is equivalent to (takeWhile (not.p) xs, dropWhile (not.p) xs). --- Thus, it breaks a list at the first occurrence of an element satisfying p. break :: (a -> Bool) -> [a] -> ([a],[a]) break p = span (not . p) --- Breaks a string into a list of lines where a line is terminated at a --- newline character. The resulting lines do not contain newline characters. lines :: String -> [String] lines [] = [] lines (x:xs) = let (l,xs_l) = splitline (x:xs) in l : lines xs_l where splitline [] = ([],[]) splitline (c:cs) = if c=='\n' then ([],cs) else let (ds,es) = splitline cs in (c:ds,es) --- Concatenates a list of strings with terminating newlines. unlines :: [String] -> String unlines ls = concatMap (++"\n") ls --- Breaks a string into a list of words where the words are delimited by --- white spaces. words :: String -> [String] words s = let s1 = dropWhile isSpace s in if s1=="" then [] else let (w,s2) = break isSpace s1 in w : words s2 --- Concatenates a list of strings with a blank between two strings. unwords :: [String] -> String unwords ws = if null ws then [] else foldr1 (\w s -> w ++ ' ':s) ws --- Reverses the order of all elements in a list. reverse :: [a] -> [a] reverse = foldl (flip (:)) [] --- Computes the conjunction of a Boolean list. and :: [Bool] -> Bool and = foldr (&&) True --- Computes the disjunction of a Boolean list. or :: [Bool] -> Bool or = foldr (||) False --- Is there an element in a list satisfying a given predicate? any :: (a -> Bool) -> [a] -> Bool any p = or . map p --- Is a given predicate satisfied by all elements in a list? all :: (a -> Bool) -> [a] -> Bool all p = and . map p --- Element of a list? elem :: Eq a => a -> [a] -> Bool elem x = any (x ==) --- Not element of a list? notElem :: Eq a => a -> [a] -> Bool notElem x = all (x /=) --- Looks up a key in an association list. lookup :: Eq a => a -> [(a, b)] -> Maybe b lookup _ [] = Nothing lookup k ((x,y):xys) | k==x = Just y | otherwise = lookup k xys --- Generates an infinite sequence of ascending integers. enumFrom_ :: Int -> [Int] -- [n..] enumFrom_ n = n : enumFrom_ (n+1) --- Generates an infinite sequence of integers with a particular in/decrement. enumFromThen_ :: Int -> Int -> [Int] -- [n1,n2..] enumFromThen_ n1 n2 = iterate ((n2-n1)+) n1 --- Generates a sequence of ascending integers. enumFromTo_ :: Int -> Int -> [Int] -- [n..m] enumFromTo_ n m = if n>m then [] else n : enumFromTo_ (n+1) m --- Generates a sequence of integers with a particular in/decrement. enumFromThenTo_ :: Int -> Int -> Int -> [Int] -- [n1,n2..m] enumFromThenTo_ n1 n2 m = takeWhile p (enumFromThen_ n1 n2) where p x | n2 >= n1 = (x <= m) | otherwise = (x >= m) --- Converts a character into its ASCII value. ord :: Char -> Int ord c = prim_ord $# c prim_ord :: Char -> Int prim_ord external --- Converts a Unicode value into a character. --- The conversion is total, i.e., for out-of-bound values, the smallest --- or largest character is generated. chr :: Int -> Char chr n | n < 0 = prim_chr 0 | n > 1114111 = prim_chr 1114111 | otherwise = prim_chr $# n prim_chr :: Int -> Char prim_chr external -- Types of primitive arithmetic functions and predicates --- Adds two integers. (+$) :: Int -> Int -> Int #ifdef __PAKCS__ x +$ y = (prim_Int_plus $# y) $# x prim_Int_plus :: Int -> Int -> Int prim_Int_plus external #else (+$) external #endif --- Subtracts two integers. (-$) :: Int -> Int -> Int #ifdef __PAKCS__ x -$ y = (prim_Int_minus $# y) $# x prim_Int_minus :: Int -> Int -> Int prim_Int_minus external #else (-$) external #endif --- Multiplies two integers. (*$) :: Int -> Int -> Int #ifdef __PAKCS__ x *$ y = (prim_Int_times $# y) $# x prim_Int_times :: Int -> Int -> Int prim_Int_times external #else (*$) external #endif --- Integer division. The value is the integer quotient of its arguments --- and always truncated towards negative infinity. --- Thus, the value of 13 `div` 5 is 2, --- and the value of -15 `div` 4 is -3. div_ :: Int -> Int -> Int #ifdef __PAKCS__ x `div_` y = (prim_Int_div $# y) $# x prim_Int_div :: Int -> Int -> Int prim_Int_div external #else div_ external #endif --- Integer remainder. The value is the remainder of the integer division and --- it obeys the rule x `mod` y = x - y * (x `div` y). --- Thus, the value of 13 `mod` 5 is 3, --- and the value of -15 `mod` 4 is -3. mod_ :: Int -> Int -> Int #ifdef __PAKCS__ x `mod_` y = (prim_Int_mod $# y) $# x prim_Int_mod :: Int -> Int -> Int prim_Int_mod external #else mod_ external #endif --- Returns an integer (quotient,remainder) pair. --- The value is the integer quotient of its arguments --- and always truncated towards negative infinity. divMod_ :: Int -> Int -> (Int, Int) #ifdef __PAKCS__ divMod_ x y = (x `div` y, x `mod` y) #else divMod_ external #endif --- Integer division. The value is the integer quotient of its arguments --- and always truncated towards zero. --- Thus, the value of 13 `quot` 5 is 2, --- and the value of -15 `quot` 4 is -3. quot_ :: Int -> Int -> Int #ifdef __PAKCS__ x `quot_` y = (prim_Int_quot $# y) $# x prim_Int_quot :: Int -> Int -> Int prim_Int_quot external #else quot_ external #endif --- Integer remainder. The value is the remainder of the integer division and --- it obeys the rule x `rem` y = x - y * (x `quot` y). --- Thus, the value of 13 `rem` 5 is 3, --- and the value of -15 `rem` 4 is -3. rem_ :: Int -> Int -> Int #ifdef __PAKCS__ x `rem_` y = (prim_Int_rem $# y) $# x prim_Int_rem :: Int -> Int -> Int prim_Int_rem external #else rem_ external #endif --- Returns an integer (quotient,remainder) pair. --- The value is the integer quotient of its arguments --- and always truncated towards zero. quotRem_ :: Int -> Int -> (Int, Int) #ifdef __PAKCS__ quotRem_ x y = (x `quot` y, x `rem` y) #else quotRem_ external #endif --- Unary minus. Usually written as "- e". negate_ :: Int -> Int negate_ x = 0 - x --- Unary minus on Floats. Usually written as "-e". negateFloat :: Float -> Float #ifdef __PAKCS__ negateFloat x = prim_negateFloat $# x prim_negateFloat :: Float -> Float prim_negateFloat external #else negateFloat external #endif -- Constraints (included for backward compatibility) type Success = Bool --- The always satisfiable constraint. success :: Success success = True -- Maybe type data Maybe a = Nothing | Just a deriving (Eq, Ord, Show, Read) maybe :: b -> (a -> b) -> Maybe a -> b maybe n _ Nothing = n maybe _ f (Just x) = f x -- Either type data Either a b = Left a | Right b deriving (Eq, Ord, Show, Read) either :: (a -> c) -> (b -> c) -> Either a b -> c either f _ (Left x) = f x either _ g (Right x) = g x -- Monadic IO external data IO _ -- conceptually: World -> (a,World) --- Sequential composition of IO actions. --- @param a - An action --- @param fa - A function from a value into an action --- @return An action that first performs a (yielding result r) --- and then performs (fa r) (>>=$) :: IO a -> (a -> IO b) -> IO b (>>=$) external --- The empty IO action that directly returns its argument. returnIO :: a -> IO a returnIO external --- Sequential composition of IO actions. --- @param a1 - An IO action --- @param a2 - An IO action --- @return An IO action that first performs a1 and then a2 (>>$) :: IO _ -> IO b -> IO b a >>$ b = a >>=$ (\_ -> b) --- The empty IO action that returns nothing. done :: IO () done = return () --- An action that puts its character argument on standard output. putChar :: Char -> IO () putChar c = prim_putChar $# c prim_putChar :: Char -> IO () prim_putChar external --- An action that reads a character from standard output and returns it. getChar :: IO Char getChar external --- An action that (lazily) reads a file and returns its contents. readFile :: String -> IO String readFile f = prim_readFile $## f prim_readFile :: String -> IO String prim_readFile external #ifdef __PAKCS__ -- for internal implementation of readFile: prim_readFileContents :: String -> String prim_readFileContents external #endif --- An action that writes a file. --- @param filename - The name of the file to be written. --- @param contents - The contents to be written to the file. writeFile :: String -> String -> IO () #ifdef __PAKCS__ writeFile f s = (prim_writeFile $## f) s #else writeFile f s = (prim_writeFile $## f) $## s #endif prim_writeFile :: String -> String -> IO () prim_writeFile external --- An action that appends a string to a file. --- It behaves like writeFile if the file does not exist. --- @param filename - The name of the file to be written. --- @param contents - The contents to be appended to the file. appendFile :: String -> String -> IO () #ifdef __PAKCS__ appendFile f s = (prim_appendFile $## f) s #else appendFile f s = (prim_appendFile $## f) $## s #endif prim_appendFile :: String -> String -> IO () prim_appendFile external --- Action to print a string on stdout. putStr :: String -> IO () putStr [] = done putStr (c:cs) = putChar c >> putStr cs --- Action to print a string with a newline on stdout. putStrLn :: String -> IO () putStrLn cs = putStr cs >> putChar '\n' --- Action to read a line from stdin. getLine :: IO String getLine = do c <- getChar if c=='\n' then return [] else do cs <- getLine return (c:cs) ---------------------------------------------------------------------------- -- Error handling in the I/O monad: --- The (abstract) type of error values. --- Currently, it distinguishes between general IO errors, --- user-generated errors (see 'userError'), failures and non-determinism --- errors during IO computations. These errors can be caught by 'catch' --- and shown by 'showError'. --- Each error contains a string shortly explaining the error. --- This type might be extended in the future to distinguish --- further error situations. data IOError = IOError String -- normal IO error | UserError String -- user-specified error | FailError String -- failing computation | NondetError String -- non-deterministic computation deriving (Eq,Show,Read) --- A user error value is created by providing a description of the --- error situation as a string. userError :: String -> IOError userError s = UserError s --- Raises an I/O exception with a given error value. ioError :: IOError -> IO _ #ifdef __PAKCS__ ioError err = error (showError err) #else ioError err = prim_ioError $## err prim_ioError :: IOError -> IO _ prim_ioError external #endif --- Shows an error values as a string. showError :: IOError -> String showError (IOError s) = "i/o error: " ++ s showError (UserError s) = "user error: " ++ s showError (FailError s) = "fail error: " ++ s showError (NondetError s) = "nondet error: " ++ s --- Catches a possible error or failure during the execution of an --- I/O action. `(catch act errfun)` executes the I/O action --- `act`. If an exception or failure occurs --- during this I/O action, the function `errfun` is applied --- to the error value. catch :: IO a -> (IOError -> IO a) -> IO a catch external ---------------------------------------------------------------------------- --- Converts an arbitrary term into an external string representation. show_ :: _ -> String show_ x = prim_show $## x prim_show :: _ -> String prim_show external --- Converts a term into a string and prints it. print :: Show a => a -> IO () print t = putStrLn (show t) --- Solves a constraint as an I/O action. --- Note: the constraint should be always solvable in a deterministic way doSolve :: Bool -> IO () doSolve b | b = done -- IO monad auxiliary functions: --- Executes a sequence of I/O actions and collects all results in a list. sequenceIO :: [IO a] -> IO [a] sequenceIO [] = return [] sequenceIO (c:cs) = do x <- c xs <- sequenceIO cs return (x:xs) --- Executes a sequence of I/O actions and ignores the results. sequenceIO_ :: [IO _] -> IO () sequenceIO_ = foldr (>>) done --- Maps an I/O action function on a list of elements. --- The results of all I/O actions are collected in a list. mapIO :: (a -> IO b) -> [a] -> IO [b] mapIO f = sequenceIO . map f --- Maps an I/O action function on a list of elements. --- The results of all I/O actions are ignored. mapIO_ :: (a -> IO _) -> [a] -> IO () mapIO_ f = sequenceIO_ . map f --- Folds a list of elements using an binary I/O action and a value --- for the empty list. foldIO :: (a -> b -> IO a) -> a -> [b] -> IO a foldIO _ a [] = return a foldIO f a (x:xs) = f a x >>= \fax -> foldIO f fax xs --- Apply a pure function to the result of an I/O action. liftIO :: (a -> b) -> IO a -> IO b liftIO f m = m >>= return . f --- Like `mapIO`, but with flipped arguments. --- --- This can be useful if the definition of the function is longer --- than those of the list, like in --- --- forIO [1..10] $ \n -> do --- ... forIO :: [a] -> (a -> IO b) -> IO [b] forIO xs f = mapIO f xs --- Like `mapIO_`, but with flipped arguments. --- --- This can be useful if the definition of the function is longer --- than those of the list, like in --- --- forIO_ [1..10] $ \n -> do --- ... forIO_ :: [a] -> (a -> IO b) -> IO () forIO_ xs f = mapIO_ f xs --- Performs an `IO` action unless the condition is met. unless :: Bool -> IO () -> IO () unless p act = if p then done else act --- Performs an `IO` action when the condition is met. when :: Bool -> IO () -> IO () when p act = if p then act else done ---------------------------------------------------------------- -- Non-determinism and free variables: --- Non-deterministic choice _par excellence_. --- The value of `x ? y` is either `x` or `y`. --- @param x - The right argument. --- @param y - The left argument. --- @return either `x` or `y` non-deterministically. (?) :: a -> a -> a x ? _ = x _ ? y = y -- Returns non-deterministically any element of a list. anyOf :: [a] -> a anyOf = foldr1 (?) --- Evaluates to a fresh free variable. unknown :: _ unknown = let x free in x ---------------------------------------------------------------- --- Identity type synonym used to mark deterministic operations. type DET a = a --- Identity function used by the partial evaluator --- to mark expressions to be partially evaluated. PEVAL :: a -> a PEVAL x = x --- Evaluates the argument to normal form and returns it. normalForm :: a -> a normalForm x = id $!! x --- Evaluates the argument to ground normal form and returns it. --- Suspends as long as the normal form of the argument is not ground. groundNormalForm :: a -> a groundNormalForm x = id $## x -- Only for internal use: -- Representation of higher-order applications in FlatCurry. apply :: (a -> b) -> a -> b apply external -- Only for internal use: -- Representation of conditional rules in FlatCurry. cond :: Bool -> a -> a cond external --- This operation is internally used by PAKCS to implement recursive --- `let`s by using cyclic term structures. Basically, the effect of --- --- letrec ones (1:ones) --- --- (where `ones` is a logic variable) is the binding of `ones` to `(1:ones)`. letrec :: a -> a -> Bool #ifdef __PAKCS__ letrec external #else letrec x y = let x = y in True -- not a real implementation #endif --- Non-strict equational constraint. Used to implement functional patterns. (=:<=) :: a -> a -> Bool (=:<=) external #ifdef __PAKCS__ --- Non-strict equational constraint for linear functional patterns. --- Thus, it must be ensured that the first argument is always --- (after evalutation by narrowing) a linear pattern. Experimental. (=:<<=) :: a -> a -> Bool (=:<<=) external --- internal function to implement =:<= ifVar :: _ -> a -> a -> a ifVar external --- internal operation to implement failure reporting failure :: _ -> _ -> _ failure external #endif -- ------------------------------------------------------------------------- -- Eq class and related instances and functions -- ------------------------------------------------------------------------- class Eq a where (==), (/=) :: a -> a -> Bool x == y = not (x /= y) x /= y = not (x == y) instance Eq Char where c == c' = c `eqChar` c' instance Eq Int where i == i' = i `eqInt` i' instance Eq Float where f == f' = f `eqFloat` f' instance Eq a => Eq [a] where [] == [] = True [] == (_:_) = False (_:_) == [] = False (x:xs) == (y:ys) = x == y && xs == ys instance Eq () where () == () = True instance (Eq a, Eq b) => Eq (a, b) where (a, b) == (a', b') = a == a' && b == b' instance (Eq a, Eq b, Eq c) => Eq (a, b, c) where (a, b, c) == (a', b', c') = a == a' && b == b' && c == c' instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) where (a, b, c, d) == (a', b', c', d') = a == a' && b == b' && c == c' && d == d' instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e) where (a, b, c, d, e) == (a', b', c', d', e') = a == a' && b == b' && c == c' && d == d' && e == e' instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => Eq (a, b, c, d, e, f) where (a, b, c, d, e, f) == (a', b', c', d', e', f') = a == a' && b == b' && c == c' && d == d' && e == e' && f == f' instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a, b, c, d, e, f, g) where (a, b, c, d, e, f, g) == (a', b', c', d', e', f', g') = a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g' -- ------------------------------------------------------------------------- -- Ord class and related instances and functions -- ------------------------------------------------------------------------- --- minimal complete definition: compare or <= class Eq a => Ord a where compare :: a -> a -> Ordering (<=) :: a -> a -> Bool (>=) :: a -> a -> Bool (<) :: a -> a -> Bool (>) :: a -> a -> Bool min :: a -> a -> a max :: a -> a -> a x < y = x <= y && x /= y x > y = not (x <= y) x >= y = y <= x x <= y = compare x y == EQ || compare x y == LT compare x y | x == y = EQ | x <= y = LT | otherwise = GT min x y | x <= y = x | otherwise = y max x y | x >= y = x | otherwise = y instance Ord Char where c1 <= c2 = c1 `ltEqChar` c2 instance Ord Int where i1 <= i2 = i1 `ltEqInt` i2 instance Ord Float where f1 <= f2 = f1 `ltEqFloat` f2 instance Ord a => Ord [a] where [] <= [] = True (_:_) <= [] = False [] <= (_:_) = True (x:xs) <= (y:ys) | x == y = xs <= ys | otherwise = x < y instance Ord () where () <= () = True instance (Ord a, Ord b) => Ord (a, b) where (a, b) <= (a', b') = a < a' || (a == a' && b <= b') instance (Ord a, Ord b, Ord c) => Ord (a, b, c) where (a, b, c) <= (a', b', c') = a < a' || (a == a' && b < b') || (a == a' && b == b' && c <= c') instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) where (a, b, c, d) <= (a', b', c', d') = a < a' || (a == a' && b < b') || (a == a' && b == b' && c < c') || (a == a' && b == b' && c == c' && d <= d') instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e) where (a, b, c, d, e) <= (a', b', c', d', e') = a < a' || (a == a' && b < b') || (a == a' && b == b' && c < c') || (a == a' && b == b' && c == c' && d < d') || (a == a' && b == b' && c == c' && d == d' && e <= e') -- ------------------------------------------------------------------------- -- Show class and related instances and functions -- ------------------------------------------------------------------------- type ShowS = String -> String class Show a where show :: a -> String showsPrec :: Int -> a -> ShowS showList :: [a] -> ShowS showsPrec _ x s = show x ++ s show x = shows x "" showList ls s = showList' shows ls s showList' :: (a -> ShowS) -> [a] -> ShowS showList' _ [] s = "[]" ++ s showList' showx (x:xs) s = '[' : showx x (showl xs) where showl [] = ']' : s showl (y:ys) = ',' : showx y (showl ys) shows :: Show a => a -> ShowS shows = showsPrec 0 showChar :: Char -> ShowS showChar c s = c:s showString :: String -> ShowS showString str s = foldr showChar s str showParen :: Bool -> ShowS -> ShowS showParen b s = if b then showChar '(' . s . showChar ')' else s -- ------------------------------------------------------------------------- instance Show () where showsPrec _ () = showString "()" instance (Show a, Show b) => Show (a, b) where showsPrec _ (a, b) = showTuple [shows a, shows b] instance (Show a, Show b, Show c) => Show (a, b, c) where showsPrec _ (a, b, c) = showTuple [shows a, shows b, shows c] instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where showsPrec _ (a, b, c, d) = showTuple [shows a, shows b, shows c, shows d] instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where showsPrec _ (a, b, c, d, e) = showTuple [shows a, shows b, shows c, shows d, shows e] instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a, b, c, d, e, f) where showsPrec _ (a, b, c, d, e, f) = showTuple [shows a, shows b, shows c, shows d, shows e, shows f] instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g) => Show (a, b, c, d, e, f, g) where showsPrec _ (a, b, c, d, e, f, g) = showTuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h) => Show (a, b, c, d, e, f, g, h) where showsPrec _ (a, b, c, d, e, f, g, h) = showTuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g ,shows h] instance Show a => Show [a] where showsPrec _ = showList instance Show Char where -- TODO: own implementation instead of passing to original Prelude functions? showsPrec _ c = showString (show_ c) showList cs | null cs = showString "\"\"" | otherwise = showString (show_ cs) instance Show Int where showsPrec = showSigned (showString . show_) instance Show Float where showsPrec = showSigned (showString . show_) showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS showSigned showPos p x | x < 0 = showParen (p > 6) (showChar '-' . showPos (-x)) | otherwise = showPos x showTuple :: [ShowS] -> ShowS showTuple ss = showChar '(' . foldr1 (\s r -> s . showChar ',' . r) ss . showChar ')' appPrec :: Int appPrec = 10 appPrec1 :: Int appPrec1 = 11 -- ------------------------------------------------------------------------- -- Read class and related instances and functions -- ------------------------------------------------------------------------- type ReadS a = String -> [(a, String)] class Read a where readsPrec :: Int -> ReadS a readList :: ReadS [a] readList = readListDefault readListDefault :: Read a => ReadS [a] readListDefault = readParen False (\r -> [pr | ("[",s) <- lex r , pr <- readl s]) where readl s = [([], t) | ("]", t) <- lex s] ++ [(x : xs, u) | (x, t) <- reads s, (xs, u) <- readl' t] readl' s = [([], t) | ("]", t) <- lex s] ++ [(x : xs, v) | (",", t) <- lex s, (x, u) <- reads t , (xs,v) <- readl' u] reads :: Read a => ReadS a reads = readsPrec 0 readParen :: Bool -> ReadS a -> ReadS a readParen b g = if b then mandatory else optional where optional r = g r ++ mandatory r mandatory r = [(x, u) | ("(", s) <- lex r, (x, t) <- optional s, (")", u) <- lex t] read :: (Read a) => String -> a read s = case [x | (x, t) <- reads s, ("", "") <- lex t] of [x] -> x [] -> error "Prelude.read: no parse" _ -> error "Prelude.read: ambiguous parse" instance Read () where readsPrec _ = readParen False (\r -> [ ((), t) | ("(", s) <- lex r , (")", t) <- lex s ]) instance Read Int where readsPrec _ = readSigned (\s -> [(i,t) | (x,t) <- lexDigits s , (i,[]) <- readNatLiteral x]) instance Read Float where readsPrec _ = readSigned (\s -> [ (f,t) | (x,t) <- lex s, not (null x) , isDigit (head x), (f,[]) <- readFloat x ]) where readFloat x = if all isDigit x then [ (i2f i, t) | (i,t) <- readNatLiteral x ] else readFloatLiteral x readSigned :: Real a => ReadS a -> ReadS a readSigned p = readParen False read' where read' r = read'' r ++ [(-x, t) | ("-", s) <- lex r, (x, t) <- read'' s] read'' r = [(n, s) | (str, s) <- lex r, (n, "") <- p str] instance Read Char where readsPrec _ = readParen False (\s -> [ (c, t) | (x, t) <- lex s, not (null x), head x == '\'' , (c, []) <- readCharLiteral x ]) readList xs = readParen False (\s -> [ (cs, t) | (x, t) <- lex s, not (null x), head x == '"' , (cs, []) <- readStringLiteral x ]) xs ++ readListDefault xs -- Primitive operations to read specific literals. readNatLiteral :: ReadS Int readNatLiteral s = prim_readNatLiteral $## s prim_readNatLiteral :: String -> [(Int,String)] prim_readNatLiteral external readFloatLiteral :: ReadS Float readFloatLiteral s = prim_readFloatLiteral $## s prim_readFloatLiteral :: String -> [(Float,String)] prim_readFloatLiteral external readCharLiteral :: ReadS Char readCharLiteral s = prim_readCharLiteral $## s prim_readCharLiteral :: String -> [(Char,String)] prim_readCharLiteral external readStringLiteral :: ReadS String readStringLiteral s = prim_readStringLiteral $## s prim_readStringLiteral :: String -> [(String,String)] prim_readStringLiteral external instance Read a => Read [a] where readsPrec _ = readList instance (Read a, Read b) => Read (a, b) where readsPrec _ = readParen False (\r -> [ ((a, b), w) | ("(", s) <- lex r , (a, t) <- reads s , (",", u) <- lex t , (b, v) <- reads u , (")", w) <- lex v ]) instance (Read a, Read b, Read c) => Read (a, b, c) where readsPrec _ = readParen False (\r -> [ ((a, b, c), y) | ("(", s) <- lex r , (a, t) <- reads s , (",", u) <- lex t , (b, v) <- reads u , (",", w) <- lex v , (c, x) <- reads w , (")", y) <- lex x ]) instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where readsPrec _ = readParen False (\q -> [ ((a, b, c, d), z) | ("(", r) <- lex q , (a, s) <- reads r , (",", t) <- lex s , (b, u) <- reads t , (",", v) <- lex u , (c, w) <- reads v , (",", x) <- lex w , (d, y) <- reads x , (")", z) <- lex y ]) instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where readsPrec _ = readParen False (\o -> [ ((a, b, c, d, e), z) | ("(", p) <- lex o , (a, q) <- reads p , (",", r) <- lex q , (b, s) <- reads r , (",", t) <- lex s , (c, u) <- reads t , (",", v) <- lex u , (d, w) <- reads v , (",", x) <- lex w , (e, y) <- reads x , (")", z) <- lex y ]) -- The following definitions are necessary to implement instances of Read. lex :: ReadS String lex xs = case xs of "" -> [("","")] ('\'':s) -> [('\'' : ch ++ "'", t) | (ch, '\'' : t) <- lexLitChar s, ch /= "'"] ('"':s) -> [('"' : str, t) | (str, t) <- lexString s] (c:cs) | isSpace c -> lex $ dropWhile isSpace cs | isSingle c -> [([c], cs)] | isSym c -> [(c : sym, t) | (sym, t) <- [span isSym cs]] | isAlpha c -> [(c : nam, t) | (nam, t) <- [span isIdChar cs]] | isDigit c -> [(c : ds ++ fe, t) | (ds, s) <- [span isDigit cs] , (fe, t) <- lexFracExp s] | otherwise -> [] where isSingle c = c `elem` ",;()[]{}_`" isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" isIdChar c = isAlphaNum c || c `elem` "_'" lexFracExp s = case s of ('.':c:cs) | isDigit c -> [('.' : ds ++ e, u) | (ds, t) <- lexDigits (c : cs), (e, u) <- lexExp t] _ -> lexExp s lexExp s = case s of (e:cs) | e `elem` "eE" -> [(e : c : ds, u) | (c:t) <- [cs], c `elem` "+-" , (ds, u) <- lexDigits t] ++ [(e : ds, t) | (ds, t) <- lexDigits cs] _ -> [("", s)] lexString s = case s of ('"':cs) -> [("\"", cs)] _ -> [(ch ++ str, u) | (ch, t) <- lexStrItem s, (str, u) <- lexString t] lexStrItem s = case s of ('\\':'&':cs) -> [("\\&", cs)] ('\\':c:cs) | isSpace c -> [("\\&", t) | '\\':t <- [dropWhile isSpace cs]] _ -> lexLitChar s lexLitChar :: ReadS String lexLitChar xs = case xs of "" -> [] ('\\':cs) -> map (prefix '\\') (lexEsc cs) (c:cs) -> [([c], cs)] where lexEsc s = case s of (c:cs) | c `elem` "abfnrtv\\\"'" -> [([c], cs)] ('^':c:cs) | c >= '@' && c <= '_' -> [(['^',c], cs)] ('b':cs) -> [prefix 'b' (span isBinDigit cs)] ('o':cs) -> [prefix 'o' (span isOctDigit cs)] ('x':cs) -> [prefix 'x' (span isHexDigit cs)] cs@(d:_) | isDigit d -> [span isDigit cs] cs@(c:_) | isUpper c -> [span isCharName cs] _ -> [] isCharName c = isUpper c || isDigit c prefix c (t, cs) = (c : t, cs) lexDigits :: ReadS String lexDigits = nonNull isDigit nonNull :: (Char -> Bool) -> ReadS String nonNull p s = [(cs, t) | (cs@(_:_), t) <- [span p s]] --- 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] -- ------------------------------------------------------------------------- -- Bounded and Enum classes and instances -- ------------------------------------------------------------------------- class Bounded a where minBound, maxBound :: a class Enum a where succ :: a -> a pred :: a -> a toEnum :: Int -> a fromEnum :: a -> Int enumFrom :: a -> [a] enumFromThen :: a -> a -> [a] enumFromTo :: a -> a -> [a] enumFromThenTo :: a -> a -> a -> [a] succ = toEnum . (+ 1) . fromEnum pred = toEnum . (\x -> x -1) . fromEnum enumFrom x = map toEnum [fromEnum x ..] enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..] enumFromTo x y = map toEnum [fromEnum x .. fromEnum y] enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] instance Bounded () where minBound = () maxBound = () instance Enum () where succ _ = error "Prelude.Enum.().succ: bad argument" pred _ = error "Prelude.Enum.().pred: bad argument" toEnum x | x == 0 = () | otherwise = error "Prelude.Enum.().toEnum: bad argument" fromEnum () = 0 enumFrom () = [()] enumFromThen () () = let many = ():many in many enumFromTo () () = [()] enumFromThenTo () () () = let many = ():many in many instance Bounded Bool where minBound = False maxBound = True instance Enum Bool where succ False = True succ True = error "Prelude.Enum.Bool.succ: bad argument" pred False = error "Prelude.Enum.Bool.pred: bad argument" pred True = False toEnum n | n == 0 = False | n == 1 = True | otherwise = error "Prelude.Enum.Bool.toEnum: bad argument" fromEnum False = 0 fromEnum True = 1 enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen instance (Bounded a, Bounded b) => Bounded (a, b) where minBound = (minBound, minBound) maxBound = (maxBound, maxBound) instance (Bounded a, Bounded b, Bounded c) => Bounded (a, b, c) where minBound = (minBound, minBound, minBound) maxBound = (maxBound, maxBound, maxBound) instance (Bounded a, Bounded b, Bounded c, Bounded d) => Bounded (a, b, c, d) where minBound = (minBound, minBound, minBound, minBound) maxBound = (maxBound, maxBound, maxBound, maxBound) instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e) => Bounded (a, b, c, d, e) where minBound = (minBound, minBound, minBound, minBound, minBound) maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound) instance Bounded Ordering where minBound = LT maxBound = GT instance Enum Ordering where succ LT = EQ succ EQ = GT succ GT = error "Prelude.Enum.Ordering.succ: bad argument" pred LT = error "Prelude.Enum.Ordering.pred: bad argument" pred EQ = LT pred GT = EQ toEnum n | n == 0 = LT | n == 1 = EQ | n == 2 = GT | otherwise = error "Prelude.Enum.Ordering.toEnum: bad argument" fromEnum LT = 0 fromEnum EQ = 1 fromEnum GT = 2 enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen uppermostCharacter :: Int uppermostCharacter = 0x10FFFF instance Bounded Char where minBound = chr 0 maxBound = chr uppermostCharacter instance Enum Char where succ c | ord c < uppermostCharacter = chr $ ord c + 1 | otherwise = error "Prelude.Enum.Char.succ: no successor" pred c | ord c > 0 = chr $ ord c - 1 | otherwise = error "Prelude.Enum.Char.succ: no predecessor" toEnum = chr fromEnum = ord enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen -- TODO: -- instance Enum Float where -- TODO (?): -- instance Bounded Int where instance Enum Int where -- TODO: is Int unbounded? succ x = x + 1 pred x = x - 1 -- TODO: correct semantic? toEnum n = n fromEnum n = n -- TODO: provide own implementations? enumFrom = enumFrom_ enumFromTo = enumFromTo_ enumFromThen = enumFromThen_ enumFromThenTo = enumFromThenTo_ boundedEnumFrom :: (Enum a, Bounded a) => a -> [a] boundedEnumFrom n = map toEnum [fromEnum n .. fromEnum (maxBound `asTypeOf` n)] boundedEnumFromThen :: (Enum a, Bounded a) => a -> a -> [a] boundedEnumFromThen n1 n2 | i_n2 >= i_n1 = map toEnum [i_n1, i_n2 .. fromEnum (maxBound `asTypeOf` n1)] | otherwise = map toEnum [i_n1, i_n2 .. fromEnum (minBound `asTypeOf` n1)] where i_n1 = fromEnum n1 i_n2 = fromEnum n2 -- ------------------------------------------------------------------------- -- Numeric classes and instances -- ------------------------------------------------------------------------- -- minimal definition: all (except negate or (-)) class Num a where (+), (-), (*) :: a -> a -> a negate :: a -> a abs :: a -> a signum :: a -> a fromInt :: Int -> a x - y = x + negate y negate x = 0 - x instance Num Int where x + y = x +$ y x - y = x -$ y x * y = x *$ y negate x = 0 - x abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 | x == 0 = 0 | otherwise = -1 fromInt x = x instance Num Float where x + y = x +. y x - y = x -. y x * y = x *. y negate x = negateFloat x abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 | x == 0 = 0 | otherwise = -1 fromInt x = i2f x -- minimal definition: fromFloat and (recip or (/)) class Num a => Fractional a where (/) :: a -> a -> a recip :: a -> a recip x = 1/x x / y = x * recip y fromFloat :: Float -> a -- since we have no type Rational instance Fractional Float where x / y = x /. y recip x = 1.0/x fromFloat x = x class (Num a, Ord a) => Real a where -- toFloat :: a -> Float class Real a => Integral a where div :: a -> a -> a mod :: a -> a -> a quot :: a -> a -> a rem :: a -> a -> a divMod :: a -> a -> (a, a) quotRem :: a -> a -> (a, a) n `div` d = q where (q, _) = divMod n d n `mod` d = r where (_, r) = divMod n d n `quot` d = q where (q, _) = n `quotRem` d n `rem` d = r where (_, r) = n `quotRem` d instance Real Int where -- no class methods to implement instance Real Float where -- no class methods to implement instance Integral Int where divMod n d = (n `div_` d, n `mod_` d) quotRem n d = (n `quot_` d, n `rem_` d) -- ------------------------------------------------------------------------- -- Helper functions -- ------------------------------------------------------------------------- asTypeOf :: a -> a -> a asTypeOf = const -- ------------------------------------------------------------------------- -- Floating point operations -- ------------------------------------------------------------------------- --- Addition on floats. (+.) :: Float -> Float -> Float x +. y = (prim_Float_plus $# y) $# x prim_Float_plus :: Float -> Float -> Float prim_Float_plus external --- Subtraction on floats. (-.) :: Float -> Float -> Float x -. y = (prim_Float_minus $# y) $# x prim_Float_minus :: Float -> Float -> Float prim_Float_minus external --- Multiplication on floats. (*.) :: Float -> Float -> Float x *. y = (prim_Float_times $# y) $# x prim_Float_times :: Float -> Float -> Float prim_Float_times external --- Division on floats. (/.) :: Float -> Float -> Float x /. y = (prim_Float_div $# y) $# x prim_Float_div :: Float -> Float -> Float prim_Float_div external --- Conversion function from integers to floats. i2f :: Int -> Float i2f x = prim_i2f $# x prim_i2f :: Int -> Float prim_i2f external -- the end of the standard prelude class Functor f where fmap :: (a -> b) -> f a -> f b instance Functor [] where fmap = map class Monad m where (>>=) :: m a -> (a -> m b) -> m b (>>) :: m a -> m b -> m b m >> k = m >>= \_ -> k return :: a -> m a fail :: String -> m a fail s = error s instance Monad IO where a1 >>= a2 = a1 >>=$ a2 a1 >> a2 = a1 >>$ a2 return x = returnIO x instance Monad Maybe where Nothing >>= _ = Nothing (Just x) >>= f = f x return = Just fail _ = Nothing 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 () ---------------------------------------------------------------------------- curry-libs-v2.2.0/Prelude.kics2000066400000000000000000002661431355602362200163510ustar00rootroot00000000000000{-# LANGUAGE BangPatterns, CPP, MagicHash #-} {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} import qualified Control.Exception as C -- ATTENTION: Do not introduce line breaks in import declarations as these -- are not recognized! import Data.Char (chr, ord) import GHC.Exts (Double (D#), Double#, (==##), (<=##), negateDouble#) import GHC.Exts (Char (C#), Char#, eqChar#, leChar#) import System.IO import CurryException import KiCS2Debug (internalError) import FailInfo (customFail) import PrimTypes #if __GLASGOW_HASKELL__ > 706 import GHC.Exts (isTrue#) #endif -- #endimport - do not remove this line! #if !(__GLASGOW_HASKELL__ > 706) isTrue# :: Bool -> Bool {-# INLINE isTrue# #-} isTrue# x = x #endif -- ----------------------------------------------------------------------------- -- Int representation -- ----------------------------------------------------------------------------- -- BEGIN GENERATED FROM PrimTypes.curry data C_Int = C_Int Integer | C_CurryInt BinInt | Choice_C_Int Cover ID C_Int C_Int | Choices_C_Int Cover ID ([C_Int]) | Fail_C_Int Cover FailInfo | Guard_C_Int Cover Constraints C_Int instance Show C_Int where showsPrec d (Choice_C_Int cd i x y) = showsChoice d cd i x y showsPrec d (Choices_C_Int cd i xs) = showsChoices d cd i xs showsPrec d (Guard_C_Int cd c e) = showsGuard d cd c e showsPrec _ (Fail_C_Int _ _) = showChar '!' showsPrec d (C_Int x1) = shows x1 showsPrec d (C_CurryInt x1) = case ((\x _ _ -> x) $## x1) (error "Show C_Int: nesting depth used") emptyCs of Choice_BinInt _ _ _ _ -> shows x1 Choices_BinInt _ _ _ -> shows x1 Fail_BinInt _ _ -> shows x1 Guard_BinInt _ _ _ -> shows x1 gnfBinInt -> shows (curryint2primint gnfBinInt) instance Read C_Int where readsPrec d s = map readInt (readsPrec d s) where readInt (i, s) = (C_Int i, s) instance NonDet C_Int where choiceCons = Choice_C_Int choicesCons = Choices_C_Int failCons = Fail_C_Int guardCons = Guard_C_Int try (Choice_C_Int cd i x y) = tryChoice cd i x y try (Choices_C_Int cd i xs) = tryChoices cd i xs try (Fail_C_Int cd info) = Fail cd info try (Guard_C_Int cd c e) = Guard cd c e try x = Val x match f _ _ _ _ _ (Choice_C_Int cd i x y) = f cd i x y match _ f _ _ _ _ (Choices_C_Int cd i@(NarrowedID _ _) xs) = f cd i xs match _ _ f _ _ _ (Choices_C_Int cd i@(FreeID _ _) xs) = f cd i xs match _ _ _ _ _ _ (Choices_C_Int _ i _) = error ("Prelude.Int.match: Choices with ChoiceID " ++ (show i)) match _ _ _ f _ _ (Fail_C_Int cd info) = f cd info match _ _ _ _ f _ (Guard_C_Int cd cs e) = f cd cs e match _ _ _ _ _ f x = f x instance Generable C_Int where generate s cd = Choices_C_Int cd (freeID [1] s) [C_CurryInt (generate (leftSupply s) cd)] instance NormalForm C_Int where ($!!) cont x@(C_Int _) cd cs = cont x cd cs ($!!) cont (C_CurryInt x1) cd cs = ((\y1 -> cont (C_CurryInt y1)) $!! x1) cd cs ($!!) cont (Choice_C_Int d i x y) cd cs = nfChoice cont d i x y cd cs ($!!) cont (Choices_C_Int d i xs) cd cs = nfChoices cont d i xs cd cs ($!!) cont (Guard_C_Int d c x) cd cs = guardCons d c ((cont $!! x) cd $! (addCs c cs)) ($!!) _ (Fail_C_Int cd info) _ _ = failCons cd info ($##) cont x@(C_Int _) cd cs = cont x cd cs ($##) cont (C_CurryInt x1) cd cs = ((\y1 -> cont (C_CurryInt y1)) $## x1) cd cs ($##) cont (Choice_C_Int d i x y) cd cs = gnfChoice cont d i x y cd cs ($##) cont (Choices_C_Int d i xs) cd cs = gnfChoices cont d i xs cd cs ($##) cont (Guard_C_Int d c x) cd cs = guardCons d c ((cont $## x) cd $! (addCs c cs)) ($##) _ (Fail_C_Int d info) _ _ = failCons d info searchNF search cont x@(C_Int _) = cont x searchNF search cont (C_CurryInt x1) = search (\y1 -> cont (C_CurryInt y1)) x1 searchNF _ _ x = error ("Prelude.Int.searchNF: no constructor: " ++ (show x)) instance Unifiable C_Int where (=.=) (C_Int x1) (C_Int y1) cd _ = if x1 == y1 then C_True else Fail_C_Bool cd defFailInfo (=.=) (C_Int x1) (C_CurryInt y1) cd cs = ((primint2curryint x1) =:= y1) cd cs (=.=) (C_CurryInt x1) (C_Int y1) cd cs = (x1 =:= (primint2curryint y1)) cd cs (=.=) (C_CurryInt x1) (C_CurryInt y1) cd cs = (x1 =:= y1) cd cs (=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo (=.<=) (C_Int x1) (C_Int y1) cd _ = if x1 == y1 then C_True else Fail_C_Bool cd defFailInfo (=.<=) (C_Int x1) (C_CurryInt y1) cd cs = ((primint2curryint x1) =:<= y1) cd cs (=.<=) (C_CurryInt x1) (C_Int y1) cd cs = (x1 =:<= (primint2curryint y1)) cd cs (=.<=) (C_CurryInt x1) (C_CurryInt y1) cd cs = (x1 =:<= y1) cd cs (=.<=) _ _ cd _= Fail_C_Bool cd defFailInfo bind cd i (C_Int x2) = (i :=: ChooseN 0 1) : bind cd (leftID i) (primint2curryint x2) bind cd i (C_CurryInt x2) = (i :=: ChooseN 0 1) : bind cd (leftID i) x2 bind cd i (Choice_C_Int d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_Int d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_Int d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ c@(Choices_C_Int _ i@(ChoiceID _) _) = error ("Prelude.Int.bind: Choices with ChoiceID: " ++ (show c)) bind _ _ (Fail_C_Int _ info) = [Unsolvable info] bind cd i (Guard_C_Int _ cs e) = getConstrList cs ++ (bind cd i e) lazyBind cd i (C_Int x2) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) (primint2curryint x2))] lazyBind cd i (C_CurryInt x2) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) x2)] lazyBind cd i (Choice_C_Int d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_Int d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_Int d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ c@(Choices_C_Int _ i@(ChoiceID _) _) = error ("Prelude.Int.lazyBind: Choices with ChoiceID: " ++ (show c)) lazyBind _ _ (Fail_C_Int _ info) = [Unsolvable info] lazyBind cd i (Guard_C_Int _ cs e) = getConstrList cs ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry C_Int -- END GENERATED FROM PrimTypes.curry d_C_prim_eqInt :: C_Int -> C_Int -> Cover -> ConstStore -> C_Bool d_C_prim_eqInt (Choice_C_Int d i x y) z cd cs = narrow d i ((x `d_C_prim_eqInt` z) cd cs) ((y `d_C_prim_eqInt` z) cd cs) d_C_prim_eqInt (Choices_C_Int d i xs) y cd cs = narrows cs d i (\x -> (x `d_C_prim_eqInt` y) cd cs) xs d_C_prim_eqInt (Guard_C_Int d c x) y cd cs = guardCons d c ((x `d_C_prim_eqInt` y) cd $! (addCs c cs)) d_C_prim_eqInt (Fail_C_Int d info) _ _ _ = failCons d info d_C_prim_eqInt z (Choice_C_Int d i x y) cd cs = narrow d i ((z `d_C_prim_eqInt` x) cd cs) ((z `d_C_prim_eqInt` y) cd cs) d_C_prim_eqInt y (Choices_C_Int d i xs) cd cs = narrows cs d i (\x -> (y `d_C_prim_eqInt` x) cd cs) xs d_C_prim_eqInt y (Guard_C_Int d c x) cd cs = guardCons d c ((y `d_C_prim_eqInt` x) cd $! (addCs c cs)) d_C_prim_eqInt _ (Fail_C_Int d info) _ _ = failCons d info d_C_prim_eqInt (C_Int x1) (C_Int y1) _ _ = toCurry (x1 == y1) d_C_prim_eqInt (C_Int x1) (C_CurryInt y1) cd cs = ((primint2curryint x1) `d_C_prim_eqBinInt` y1) cd cs d_C_prim_eqInt (C_CurryInt x1) (C_Int y1) cd cs = (x1 `d_C_prim_eqBinInt` (primint2curryint y1)) cd cs d_C_prim_eqInt (C_CurryInt x1) (C_CurryInt y1) cd cs = (x1 `d_C_prim_eqBinInt` y1) cd cs d_C_prim_ltEqInt :: C_Int -> C_Int -> Cover -> ConstStore -> C_Bool d_C_prim_ltEqInt (Choice_C_Int d i x y) z cd cs = narrow d i ((x `d_C_prim_ltEqInt` z) cd cs) ((y `d_C_prim_ltEqInt` z) cd cs) d_C_prim_ltEqInt (Choices_C_Int d i xs) y cd cs = narrows cs d i (\x -> (x `d_C_prim_ltEqInt` y) cd cs) xs d_C_prim_ltEqInt (Guard_C_Int d c x) y cd cs = guardCons d c ((x `d_C_prim_ltEqInt` y) cd $! (addCs c cs)) d_C_prim_ltEqInt (Fail_C_Int d info) _ _ _ = failCons d info d_C_prim_ltEqInt z (Choice_C_Int d i x y) cd cs = narrow d i ((z `d_C_prim_ltEqInt` x) cd cs) ((z `d_C_prim_ltEqInt` y) cd cs) d_C_prim_ltEqInt y (Choices_C_Int d i xs) cd cs = narrows cs d i (\x -> (y `d_C_prim_ltEqInt` x) cd cs) xs d_C_prim_ltEqInt y (Guard_C_Int d c x) cd cs = guardCons d c ((y `d_C_prim_ltEqInt` x) cd $! (addCs c cs)) d_C_prim_ltEqInt _ (Fail_C_Int d info) _ _ = failCons d info d_C_prim_ltEqInt (C_Int x1) (C_Int y1) _ _ = toCurry (x1 <= y1) d_C_prim_ltEqInt (C_Int x1) (C_CurryInt y1) cd cs = ((primint2curryint x1) `d_C_lteqInteger` y1) cd cs d_C_prim_ltEqInt (C_CurryInt x1) (C_Int y1) cd cs = (x1 `d_C_lteqInteger` (primint2curryint y1)) cd cs d_C_prim_ltEqInt (C_CurryInt x1) (C_CurryInt y1) cd cs = (x1 `d_C_lteqInteger` y1) cd cs external_d_C_eqInt :: C_Int -> C_Int -> Cover -> ConstStore -> C_Bool external_d_C_eqInt = d_C_prim_eqInt external_d_C_ltEqInt :: C_Int -> C_Int -> Cover -> ConstStore -> C_Bool external_d_C_ltEqInt = d_C_prim_ltEqInt primint2curryint :: Integer -> BinInt primint2curryint n | n < 0 = Neg (primint2currynat (negate n)) | n == 0 = Zero | otherwise = Pos (primint2currynat n) primint2currynat :: Integer -> Nat primint2currynat n | n == 1 = IHi | (n `rem` 2) == 0 = O (primint2currynat (n `quot` 2)) | otherwise = I (primint2currynat (n `quot` 2)) curryint2primint :: BinInt -> Integer curryint2primint Zero = 0 curryint2primint (Pos n) = currynat2primint n curryint2primint (Neg n) = negate (currynat2primint n) curryint2primint int = error ("KiCS2 error: Prelude.curryint2primint: no ground term, but " ++ show int) currynat2primint :: Nat -> Integer currynat2primint IHi = 1 currynat2primint (O n) = 2 * currynat2primint n currynat2primint (I n) = 2 * currynat2primint n + 1 currynat2primint nat = error ("KiCS2 error: Prelude.currynat2primint: no ground term, but " ++ show nat) -- ----------------------------------------------------------------------------- -- Float representation -- ----------------------------------------------------------------------------- -- BEGIN GENERATED FROM PrimTypes.curry data C_Float = C_Float Double# | Choice_C_Float Cover ID C_Float C_Float | Choices_C_Float Cover ID ([C_Float]) | Fail_C_Float Cover FailInfo | Guard_C_Float Cover (Constraints) C_Float instance Show C_Float where showsPrec d (Choice_C_Float cd i x y) = showsChoice d cd i x y showsPrec d (Choices_C_Float cd i xs) = showsChoices d cd i xs showsPrec d (Guard_C_Float cd c e) = showsGuard d cd c e showsPrec d (Fail_C_Float _ _) = showChar '!' showsPrec d (C_Float x1) = shows (D# x1) instance Read C_Float where readsPrec d s = map readFloat (readsPrec d s) where readFloat (D# d, s) = (C_Float d, s) instance NonDet C_Float where choiceCons = Choice_C_Float choicesCons = Choices_C_Float failCons = Fail_C_Float guardCons = Guard_C_Float try (Choice_C_Float cd i x y) = tryChoice cd i x y try (Choices_C_Float cd i xs) = tryChoices cd i xs try (Fail_C_Float cd info) = Fail cd info try (Guard_C_Float cd c e) = Guard cd c e try x = Val x match f _ _ _ _ _ (Choice_C_Float cd i x y) = f cd i x y match _ f _ _ _ _ (Choices_C_Float cd i@(NarrowedID _ _) xs) = f cd i xs match _ _ f _ _ _ (Choices_C_Float cd i@(FreeID _ _) xs) = f cd i xs match _ _ _ _ _ _ (Choices_C_Float cd i@(ChoiceID _) _) = error ("Prelude.Float.match: Choices with ChoiceID " ++ (show i)) match _ _ _ f _ _ (Fail_C_Float cd info) = f cd info match _ _ _ _ f _ (Guard_C_Float cd cs e) = f cd cs e match _ _ _ _ _ f x = f x instance Generable C_Float where generate = error "No generator for C_Float" instance NormalForm C_Float where ($!!) cont x@(C_Float _) cd cs = cont x cd cs ($!!) cont (Choice_C_Float d i x y) cd cs = nfChoice cont d i x y cd cs ($!!) cont (Choices_C_Float d i xs) cd cs = nfChoices cont d i xs cd cs ($!!) cont (Guard_C_Float d c x) cd cs = guardCons d c ((cont $!! x) cd $! (addCs c cs)) ($!!) _ (Fail_C_Float d info) _ _ = failCons d info ($##) cont x@(C_Float _) cd cs = cont x cd cs ($##) cont (Choice_C_Float d i x y) cd cs = gnfChoice cont d i x y cd cs ($##) cont (Choices_C_Float d i xs) cd cs = gnfChoices cont d i xs cd cs ($##) cont (Guard_C_Float d c x) cd cs = guardCons d c ((cont $## x) cd $! (addCs c cs)) ($##) _ (Fail_C_Float d info) _ _ = failCons d info searchNF search cont x@(C_Float _) = cont x searchNF _ _ x = error ("Prelude.Float.searchNF: no constructor: " ++ (show x)) instance Unifiable C_Float where (=.=) (C_Float x1) (C_Float y1) cd _ = if isTrue# (x1 ==## y1) then C_True else Fail_C_Bool cd defFailInfo (=.<=) (C_Float x1) (C_Float y1) cd _ = if isTrue# (x1 ==## y1) then C_True else Fail_C_Bool cd defFailInfo bind cd i (Choice_C_Float d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_Float d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_Float d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ c@(Choices_C_Float _ i _) = error ("Prelude.Float.bind: Choices with ChoiceID: " ++ (show c)) bind _ _ (Fail_C_Float _ info) = [Unsolvable info] bind cd i (Guard_C_Float _ cs e) = getConstrList cs ++ (bind cd i e) lazyBind cd i (Choice_C_Float d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_Float d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_Float d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ c@(Choices_C_Float _ i _) = error ("Prelude.Float.lazyBind: Choices with ChoiceID: " ++ (show c)) lazyBind _ _ (Fail_C_Float _ info) = [Unsolvable info] lazyBind cd i (Guard_C_Float _ cs e) = getConstrList cs ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry C_Float -- END GENERATED FROM PrimTypes.curry d_C_prim_eqFloat :: C_Float -> C_Float -> Cover -> ConstStore -> C_Bool d_C_prim_eqFloat (Choice_C_Float d i x y) z cd cs = narrow d i ((x `d_C_prim_eqFloat` z) cd cs) ((y `d_C_prim_eqFloat` z) cd cs) d_C_prim_eqFloat (Choices_C_Float d i xs) y cd cs = narrows cs d i (\x -> (x `d_C_prim_eqFloat` y) cd cs) xs d_C_prim_eqFloat (Guard_C_Float d c x) y cd cs = guardCons d c ((x `d_C_prim_eqFloat` y) cd $! (addCs c cs)) d_C_prim_eqFloat (Fail_C_Float d info) _ _ _= failCons d info d_C_prim_eqFloat z (Choice_C_Float d i x y) cd cs = narrow d i ((z `d_C_prim_eqFloat` x) cd cs) ((z `d_C_prim_eqFloat` y) cd cs) d_C_prim_eqFloat y (Choices_C_Float d i xs) cd cs = narrows cs d i (\x -> (y `d_C_prim_eqFloat` x) cd cs) xs d_C_prim_eqFloat y (Guard_C_Float d c x) cd cs = guardCons d c ((y `d_C_prim_eqFloat` x) cd $! (addCs c cs)) d_C_prim_eqFloat _ (Fail_C_Float d info) _ _ = failCons d info d_C_prim_eqFloat (C_Float x1) (C_Float y1) _ _ = toCurry (isTrue# (x1 ==## y1)) d_C_prim_ltEqFloat :: C_Float -> C_Float -> Cover -> ConstStore -> C_Bool d_C_prim_ltEqFloat (Choice_C_Float d i x y) z cd cs = narrow d i ((x `d_C_prim_ltEqFloat` z) cd cs) ((y `d_C_prim_ltEqFloat` z) cd cs) d_C_prim_ltEqFloat (Choices_C_Float d i xs) y cd cs = narrows cs d i (\x -> (x `d_C_prim_ltEqFloat` y) cd cs) xs d_C_prim_ltEqFloat (Guard_C_Float d c x) y cd cs = guardCons d c ((x `d_C_prim_ltEqFloat` y) cd $! (addCs c cs)) d_C_prim_ltEqFloat (Fail_C_Float d info) _ _ _ = failCons d info d_C_prim_ltEqFloat z (Choice_C_Float d i x y) cd cs = narrow d i ((z `d_C_prim_ltEqFloat` x) cd cs) ((z `d_C_prim_ltEqFloat` y) cd cs) d_C_prim_ltEqFloat y (Choices_C_Float d i xs) cd cs = narrows cs d i (\x -> (y `d_C_prim_ltEqFloat` x) cd cs) xs d_C_prim_ltEqFloat y (Guard_C_Float d c x) cd cs = guardCons d c ((y `d_C_prim_ltEqFloat` x) cd $! (addCs c cs)) d_C_prim_ltEqFloat _ (Fail_C_Float d info) _ _ = failCons d info d_C_prim_ltEqFloat (C_Float x1) (C_Float y1) _ _ = toCurry (isTrue# (x1 <=## y1)) external_d_C_eqFloat :: C_Float -> C_Float -> Cover -> ConstStore -> C_Bool external_d_C_eqFloat = d_C_prim_eqFloat external_d_C_ltEqFloat :: C_Float -> C_Float -> Cover -> ConstStore -> C_Bool external_d_C_ltEqFloat = d_C_prim_ltEqFloat -- --------------------------------------------------------------------------- -- Char -- --------------------------------------------------------------------------- -- BEGIN GENERATED FROM PrimTypes.curry data C_Char = C_Char Char# | CurryChar BinInt | Choice_C_Char Cover ID C_Char C_Char | Choices_C_Char Cover ID ([C_Char]) | Fail_C_Char Cover FailInfo | Guard_C_Char Cover (Constraints) C_Char instance Show C_Char where showsPrec d (Choice_C_Char cd i x y) = showsChoice d cd i x y showsPrec d (Choices_C_Char cd i xs) = showsChoices d cd i xs showsPrec d (Guard_C_Char cd c e) = showsGuard d d c e showsPrec d (Fail_C_Char _ _) = showChar '!' showsPrec d (C_Char x1) = showString (show (C# x1)) showsPrec d (CurryChar x1) = case ((\x _ _ -> x) $## x1) (error "Show C_Char: nesting depth used") emptyCs of Choice_BinInt _ _ _ _ -> showString "chr " . shows x1 Choices_BinInt _ _ _ -> showString "chr " . shows x1 Fail_BinInt _ _ -> shows x1 Guard_BinInt _ _ _ -> shows x1 gnfBinInt -> shows (C# (curryChar2primChar gnfBinInt)) showList cs | all isPrimChar cs' = showList (map convert cs') | otherwise = showCharList cs' where cs' = map gnfCurryChar cs gnfCurryChar :: C_Char -> C_Char gnfCurryChar (CurryChar x1) = case ((\x _ _ -> x) $## x1) (error "gnfCurryChar: nesting depth used") emptyCs of Choice_BinInt _ _ _ _ -> CurryChar x1 Choices_BinInt _ _ _ -> CurryChar x1 Fail_BinInt _ _ -> CurryChar x1 Guard_BinInt _ _ _ -> CurryChar x1 gnfBinInt -> C_Char (curryChar2primChar gnfBinInt) gnfCurryChar c = c isPrimChar (C_Char _) = True isPrimChar _ = False convert (C_Char c) = C# c showCharList [] = showString "[]" showCharList (x:xs) = showChar '[' . shows x . showRest xs where showRest [] = showChar ']' showRest (y:ys) = showChar ',' . shows y . showRest ys instance Read C_Char where readsPrec d s = map readChar (readsPrec d s) where readChar (C# c, s) = (C_Char c, s) readList s = map readString (readList s) where readString (cs, s) = (map (\(C# c) -> C_Char c) cs, s) instance NonDet C_Char where choiceCons = Choice_C_Char choicesCons = Choices_C_Char failCons = Fail_C_Char guardCons = Guard_C_Char try (Choice_C_Char cd i x y) = tryChoice cd i x y try (Choices_C_Char cd i xs) = tryChoices cd i xs try (Fail_C_Char cd info) = Fail cd info try (Guard_C_Char cd c e) = Guard cd c e try x = Val x match f _ _ _ _ _ (Choice_C_Char cd i x y) = f cd i x y match _ f _ _ _ _ (Choices_C_Char cd i@(NarrowedID _ _) xs) = f cd i xs match _ _ f _ _ _ (Choices_C_Char cd i@(FreeID _ _) xs) = f cd i xs match _ _ _ _ _ _ (Choices_C_Char cd i _) = error ("Prelude.Char.match: Choices with ChoiceID " ++ (show i)) match _ _ _ f _ _ (Fail_C_Char cd info) = f cd info match _ _ _ _ f _ (Guard_C_Char cd cs e) = f cd cs e match _ _ _ _ _ f x = f x instance Generable C_Char where generate s cd = Choices_C_Char cd (freeID [1] s) [CurryChar (generateNNBinInt (leftSupply s) cd)] where -- generate only non-negative ord values for characters: generateNNBinInt s c = Choices_BinInt c (freeID [1, 0, 1] s) [Fail_BinInt c (customFail "no negative ord values for characters"), Zero, Pos (generate (leftSupply s) c)] instance NormalForm C_Char where ($!!) cont x@(C_Char _) cd cs = cont x cd cs ($!!) cont (CurryChar x) cd cs = ((cont . CurryChar) $!! x) cd cs ($!!) cont (Choice_C_Char d i x y) cd cs = nfChoice cont d i x y cd cs ($!!) cont (Choices_C_Char d i xs) cd cs = nfChoices cont d i xs cd cs ($!!) cont (Guard_C_Char d c x) cd cs = guardCons d c ((cont $!! x) cd $! (addCs c cs)) ($!!) _ (Fail_C_Char d info) _ _ = failCons d info ($##) cont x@(C_Char _) cd cs = cont x cd cs ($##) cont (CurryChar x) cd cs = ((cont . CurryChar) $## x) cd cs ($##) cont (Choice_C_Char d i x y) cd cs = gnfChoice cont d i x y cd cs ($##) cont (Choices_C_Char d i xs) cd cs = gnfChoices cont d i xs cd cs ($##) cont (Guard_C_Char d c x) cd cs = guardCons d c ((cont $## x) cd $! (addCs c cs)) ($##) _ (Fail_C_Char d info) _ _ = failCons d info searchNF search cont c@(C_Char _) = cont c searchNF search cont (CurryChar x) = search (cont . CurryChar) x searchNF _ _ x = error ("Prelude.Char.searchNF: no constructor: " ++ (show x)) instance Unifiable C_Char where (=.=) (C_Char x1) (C_Char x2) cd _ | isTrue# (x1 `eqChar#` x2) = C_True | otherwise = Fail_C_Bool cd defFailInfo (=.=) (C_Char x1) (CurryChar x2) cd cs = (primChar2CurryChar x1 =:= x2) cd cs (=.=) (CurryChar x1) (C_Char x2) cd cs = (x1 =:= primChar2CurryChar x2) cd cs (=.=) (CurryChar x1) (CurryChar x2) cd cs = (x1 =:= x2) cd cs (=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo (=.<=) (C_Char x1) (C_Char x2) cd _ | isTrue# (x1 `eqChar#` x2) = C_True | otherwise = Fail_C_Bool cd defFailInfo (=.<=) (C_Char x1) (CurryChar x2) cd cs = (primChar2CurryChar x1 =:<= x2) cd cs (=.<=) (CurryChar x1) (C_Char x2) cd cs = (x1 =:<= primChar2CurryChar x2) cd cs (=.<=) (CurryChar x1) (CurryChar x2) cd cs = (x1 =:<= x2) cd cs (=.<=) _ _ cd _ = Fail_C_Bool cd defFailInfo bind cd i (C_Char x) = (i :=: ChooseN 0 1) : bind cd (leftID i) (primChar2CurryChar x) bind cd i (CurryChar x) = (i :=: ChooseN 0 1) : bind cd (leftID i) x bind cd i (Choice_C_Char d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_Char d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_Char d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ c@(Choices_C_Char _ i _) = error ("Prelude.Char.bind: Choices with ChoiceID: " ++ (show c)) bind _ _ (Fail_C_Char _ info) = [Unsolvable info] bind cd i (Guard_C_Char _ cs e) = getConstrList cs ++ (bind cd i e) lazyBind cd i (C_Char x) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) (primChar2CurryChar x))] lazyBind cd i (CurryChar x) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) x)] lazyBind cd i (Choice_C_Char d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_Char d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_Char d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ c@(Choices_C_Char _ i _) = error ("Prelude.Char.lazyBind: Choices with ChoiceID: " ++ (show c)) lazyBind _ _ (Fail_C_Char _ info) = [Unsolvable info] lazyBind cd i (Guard_C_Char _ cs e) = getConstrList cs ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry C_Char -- END GENERATED FROM PrimTypes.curry d_C_prim_eqChar :: C_Char -> C_Char -> Cover -> ConstStore -> C_Bool d_C_prim_eqChar (Choice_C_Char d i x y) z cd cs = narrow d i ((x `d_C_prim_eqChar` z) cd cs) ((y `d_C_prim_eqChar` z) cd cs) d_C_prim_eqChar (Choices_C_Char d i xs) y cd cs = narrows cs d i (\x -> (x `d_C_prim_eqChar` y) cd cs) xs d_C_prim_eqChar (Guard_C_Char d c x) y cd cs = guardCons d c ((x `d_C_prim_eqChar` y) cd $! (addCs c cs)) d_C_prim_eqChar (Fail_C_Char d info) _ _ _ = failCons d info d_C_prim_eqChar z (Choice_C_Char d i x y) cd cs = narrow d i ((z `d_C_prim_eqChar` x) cd cs) ((z `d_C_prim_eqChar` y) cd cs) d_C_prim_eqChar y (Choices_C_Char d i xs) cd cs = narrows cs d i (\x -> (y `d_C_prim_eqChar` x) cd cs) xs d_C_prim_eqChar y (Guard_C_Char d c x) cd cs = guardCons d c ((y `d_C_prim_eqChar` x) cd $! (addCs c cs)) d_C_prim_eqChar _ (Fail_C_Char d info) _ _ = failCons d info d_C_prim_eqChar (C_Char x1) (C_Char y1) _ _ = toCurry (isTrue# (x1 `eqChar#` y1)) d_C_prim_eqChar (C_Char x1) (CurryChar y1) cd cs = ((primChar2CurryChar x1) `d_C_prim_eqBinInt` y1) cd cs d_C_prim_eqChar (CurryChar x1) (C_Char y1) cd cs = (x1 `d_C_prim_eqBinInt` (primChar2CurryChar y1)) cd cs d_C_prim_eqChar (CurryChar x1) (CurryChar y1) cd cs = (x1 `d_C_prim_eqBinInt` y1) cd cs d_C_prim_ltEqChar :: C_Char -> C_Char -> Cover -> ConstStore -> C_Bool d_C_prim_ltEqChar (Choice_C_Char d i x y) z cd cs = narrow d i ((x `d_C_prim_ltEqChar` z) cd cs) ((y `d_C_prim_ltEqChar` z) cd cs) d_C_prim_ltEqChar (Choices_C_Char d i xs) y cd cs = narrows cs d i (\x -> (x `d_C_prim_ltEqChar` y) cd cs) xs d_C_prim_ltEqChar (Guard_C_Char d c x) y cd cs = guardCons d c ((x `d_C_prim_ltEqChar` y) cd $! (addCs c cs)) d_C_prim_ltEqChar (Fail_C_Char d info) _ _ _ = failCons d info d_C_prim_ltEqChar z (Choice_C_Char d i x y) cd cs = narrow d i ((z `d_C_prim_ltEqChar` x) cd cs) ((z `d_C_prim_ltEqChar` y) cd cs) d_C_prim_ltEqChar y (Choices_C_Char d i xs) cd cs = narrows cs d i (\x -> (y `d_C_prim_ltEqChar` x) cd cs) xs d_C_prim_ltEqChar y (Guard_C_Char d c x) cd cs = guardCons d c ((y `d_C_prim_ltEqChar` x) cd $! (addCs c cs)) d_C_prim_ltEqChar _ (Fail_C_Char d info) _ _ = failCons d info d_C_prim_ltEqChar (C_Char x1) (C_Char y1) _ _ = toCurry (isTrue# (x1 `leChar#` y1)) d_C_prim_ltEqChar (C_Char x1) (CurryChar y1) cd cs = ((primChar2CurryChar x1) `d_C_lteqInteger` y1) cd cs d_C_prim_ltEqChar (CurryChar x1) (C_Char y1) cd cs = (x1 `d_C_lteqInteger` (primChar2CurryChar y1)) cd cs d_C_prim_ltEqChar (CurryChar x1) (CurryChar y1) cd cs = (x1 `d_C_lteqInteger` y1) cd cs external_d_C_eqChar :: C_Char -> C_Char -> Cover -> ConstStore -> C_Bool external_d_C_eqChar = d_C_prim_eqChar external_d_C_ltEqChar :: C_Char -> C_Char -> Cover -> ConstStore -> C_Bool external_d_C_ltEqChar = d_C_prim_ltEqChar primChar2primint :: Char# -> Integer primChar2primint c = toInteger (ord (C# c)) primint2primChar :: Integer -> Char# primint2primChar c = char2primChar (chr (fromInteger c)) where char2primChar (C# c) = c primChar2CurryChar :: Char# -> BinInt primChar2CurryChar c = primint2curryint (primChar2primint c) curryChar2primChar :: BinInt -> Char# curryChar2primChar c = primint2primChar (curryint2primint c) -- --------------------------------------------------------------------------- -- Conversion from and to primitive Haskell types -- --------------------------------------------------------------------------- instance ConvertCurryHaskell C_Int Integer where toCurry i = C_Int i fromCurry (C_Int i) = i fromCurry (C_CurryInt i) = curryint2primint i fromCurry _ = error "KiCS2 error: Int data with no ground term" instance ConvertCurryHaskell C_Int Int where toCurry i = toCurry (toInteger i) fromCurry i = fromInteger (fromCurry i) instance ConvertCurryHaskell C_Float Double where toCurry (D# d) = C_Float d fromCurry (C_Float d) = D# d fromCurry _ = error "KiCS2 error: Float data with no ground term" instance ConvertCurryHaskell C_Char Char where toCurry (C# c) = C_Char c fromCurry (C_Char c) = C# c fromCurry (CurryChar c) = C# (curryChar2primChar c) fromCurry _ = error "KiCS2 error: Char data with no ground term" instance (ConvertCurryHaskell ct ht) => ConvertCurryHaskell (OP_List ct) [ht] where toCurry [] = OP_List toCurry (c:cs) = OP_Cons (toCurry c) (toCurry cs) fromCurry OP_List = [] fromCurry (OP_Cons c cs) = fromCurry c : fromCurry cs fromCurry _ = error "KiCS2 error: List data with no ground term" instance ConvertCurryHaskell C_Bool Bool where toCurry True = C_True toCurry False = C_False fromCurry C_True = True fromCurry C_False = False fromCurry _ = error "KiCS2 error: Bool data with no ground term" instance ConvertCurryHaskell OP_Unit () where toCurry () = OP_Unit fromCurry OP_Unit = () fromCurry _ = error "KiCS2 error: Unit data with no ground term" instance (ConvertCurryHaskell ct1 ht1, ConvertCurryHaskell ct2 ht2) => ConvertCurryHaskell (OP_Tuple2 ct1 ct2) (ht1,ht2) where toCurry (x1,x2) = OP_Tuple2 (toCurry x1) (toCurry x2) fromCurry (OP_Tuple2 x1 x2) = (fromCurry x1, fromCurry x2) fromCurry _ = error "KiCS2 error: Pair data with no ground term" instance (ConvertCurryHaskell ct1 ht1, ConvertCurryHaskell ct2 ht2, ConvertCurryHaskell ct3 ht3) => ConvertCurryHaskell (OP_Tuple3 ct1 ct2 ct3) (ht1,ht2,ht3) where toCurry (x1,x2,x3) = OP_Tuple3 (toCurry x1) (toCurry x2) (toCurry x3) fromCurry (OP_Tuple3 x1 x2 x3) = (fromCurry x1, fromCurry x2, fromCurry x3) fromCurry _ = error "KiCS2 error: Tuple3 data with no ground term occurred" instance ConvertCurryHaskell ct ht => ConvertCurryHaskell (C_Maybe ct) (Maybe ht) where toCurry Nothing = C_Nothing toCurry (Just x) = C_Just (toCurry x) fromCurry C_Nothing = Nothing fromCurry (C_Just x) = Just (fromCurry x) fromCurry _ = error "KiCS2 error: Maybe data with no ground term occurred" toCurryString :: String -> OP_List C_Char toCurryString = toCurry -- ----------------------------------------------------------------------------- -- Auxiliary operations for showing lists -- ----------------------------------------------------------------------------- showsPrec4CurryList :: Show a => Int -> OP_List a -> ShowS showsPrec4CurryList d cl = if isStandardCurryList cl then showsPrec d (clist2hlist cl) else showChar '(' . showsPrecRaw d cl . showChar ')' where isStandardCurryList OP_List = True isStandardCurryList (OP_Cons _ xs) = isStandardCurryList xs isStandardCurryList _ = False clist2hlist OP_List = [] clist2hlist (OP_Cons x xs) = x : clist2hlist xs showsPrecRaw d (Choice_OP_List cd i x y) = showsChoice d cd i x y showsPrecRaw d (Choices_OP_List cd i xs) = showsChoices d cd i xs showsPrecRaw d (Guard_OP_List cd c e) = showsGuard d cd c e showsPrecRaw d (Fail_OP_List _ _) = showChar '!' showsPrecRaw d OP_List = showString "[]" showsPrecRaw d (OP_Cons x xs) = showParen (d > 5) (showsPrec 6 x . showChar ':' . showsPrecRaw 5 xs) -- ----------------------------------------------------------------------------- -- Primitive operations: General -- ----------------------------------------------------------------------------- external_d_C_prim_show :: Show a => a -> Cover -> ConstStore -> C_String external_d_C_prim_show a _ _ = toCurry (show a) external_d_C_prim_readNatLiteral :: C_String -> Cover -> ConstStore -> OP_List (OP_Tuple2 C_Int C_String) external_d_C_prim_readNatLiteral s _ _ = toCurry (reads (fromCurry s) :: [(Integer, String)]) external_d_C_prim_readFloatLiteral :: C_String -> Cover -> ConstStore -> OP_List (OP_Tuple2 C_Float C_String) external_d_C_prim_readFloatLiteral s _ _ = toCurry (reads (fromCurry s) :: [(Double, String)]) external_d_C_prim_readCharLiteral :: C_String -> Cover -> ConstStore -> OP_List (OP_Tuple2 C_Char C_String) external_d_C_prim_readCharLiteral s _ _ = toCurry (reads (fromCurry s) :: [(Char, String)]) external_d_C_prim_readStringLiteral :: C_String -> Cover -> ConstStore -> OP_List (OP_Tuple2 C_String C_String) external_d_C_prim_readStringLiteral s _ _ = toCurry (reads (fromCurry s) :: [(String, String)]) external_d_OP_eq_colon_eq :: Unifiable a => a -> a -> Cover -> ConstStore -> C_Bool external_d_OP_eq_colon_eq = (=:=) external_d_OP_eq_colon_lt_eq :: Curry a => a -> a -> Cover -> ConstStore -> C_Bool external_d_OP_eq_colon_lt_eq = (=:<=) external_d_C_failed :: NonDet a => Cover -> ConstStore -> a external_d_C_failed cd _ = failCons cd (customFail "Call to function `failed'") external_d_C_cond :: Curry a => C_Bool -> a -> Cover -> ConstStore -> a external_d_C_cond succ a cd cs = ((\_ _ _ -> a) `d_OP_dollar_hash` succ) cd cs external_d_OP_amp :: C_Bool -> C_Bool -> Cover -> ConstStore -> C_Bool external_d_OP_amp = (&) external_d_C_ensureNotFree :: Curry a => a -> Cover -> ConstStore -> a external_d_C_ensureNotFree x cd cs = case try x of Choice d i a b -> choiceCons d i (external_d_C_ensureNotFree a cd cs) (external_d_C_ensureNotFree b cd cs) Narrowed d i xs -> choicesCons d i (map (\x -> external_d_C_ensureNotFree x cd cs) xs) Free d i xs -> narrows cs d i (\x -> external_d_C_ensureNotFree x cd cs) xs Guard d c e -> guardCons d c (external_d_C_ensureNotFree e cd $! (addCs c cs)) _ -> x external_d_OP_dollar_bang :: (NonDet a, NonDet b) => (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b external_d_OP_dollar_bang = d_dollar_bang external_nd_OP_dollar_bang :: (NonDet a, NonDet b) => (Func a b) -> a -> IDSupply -> Cover -> ConstStore -> b external_nd_OP_dollar_bang = nd_dollar_bang external_d_OP_dollar_bang_bang :: (NormalForm a, NonDet b) => (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b external_d_OP_dollar_bang_bang = ($!!) external_nd_OP_dollar_bang_bang :: (NormalForm a, NonDet b) => Func a b -> a -> IDSupply -> Cover -> ConstStore -> b external_nd_OP_dollar_bang_bang f x s cd cs = ((\y cd1 cs1-> nd_apply f y s cd1 cs1) $!! x) cd cs external_d_OP_dollar_hash_hash :: (NormalForm a, NonDet b) => (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b external_d_OP_dollar_hash_hash = ($##) external_nd_OP_dollar_hash_hash :: (NormalForm a, NonDet b) => Func a b -> a -> IDSupply -> Cover -> ConstStore -> b external_nd_OP_dollar_hash_hash f x s cd cs = ((\y cd1 cs1 -> nd_apply f y s cd1 cs1) $## x) cd cs external_d_C_apply :: (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b external_d_C_apply = d_apply external_nd_C_apply :: NonDet b => Func a b -> a -> IDSupply -> Cover -> ConstStore -> b external_nd_C_apply = nd_apply -- ----------------------------------------------------------------------------- -- Primitive operations: Characters -- ----------------------------------------------------------------------------- external_d_C_prim_ord :: C_Char -> Cover -> ConstStore -> C_Int external_d_C_prim_ord (C_Char c) _ _ = C_Int (primChar2primint c) external_d_C_prim_ord (CurryChar c) _ _ = C_CurryInt c external_d_C_prim_chr :: C_Int -> Cover -> ConstStore -> C_Char external_d_C_prim_chr (C_Int i) _ _ = C_Char (primint2primChar i) external_d_C_prim_chr (C_CurryInt i) _ _ = CurryChar i -- ----------------------------------------------------------------------------- -- Primitive operations: Arithmetics -- ----------------------------------------------------------------------------- external_d_OP_plus_dollar :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_OP_plus_dollar (C_Int x) (C_Int y) _ _ = C_Int (x + y) external_d_OP_plus_dollar (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_OP_plus_hash` y) cd cs) external_d_OP_plus_dollar (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_OP_plus_hash` (primint2curryint y)) cd cs) external_d_OP_plus_dollar (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_OP_plus_hash` y) cd cs) external_d_OP_plus_dollar x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_OP_plus_dollar` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_OP_minus_dollar :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_OP_minus_dollar (C_Int x) (C_Int y) _ _ = C_Int (x - y) external_d_OP_minus_dollar (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_OP_minus_hash` y) cd cs) external_d_OP_minus_dollar (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_OP_minus_hash` (primint2curryint y)) cd cs) external_d_OP_minus_dollar (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_OP_minus_hash` y) cd cs) external_d_OP_minus_dollar x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_OP_minus_dollar` b) cd2 cs2 )) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_OP_star_dollar :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_OP_star_dollar (C_Int x) (C_Int y) _ _ = C_Int (x * y) external_d_OP_star_dollar (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_OP_star_hash` y) cd cs) external_d_OP_star_dollar (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_OP_star_hash` (primint2curryint y)) cd cs) external_d_OP_star_dollar (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_OP_star_hash` y) cd cs) external_d_OP_star_dollar x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_OP_star_dollar` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_quot_ :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_C_quot_ (C_Int x) (C_Int y) cd _ | y == 0 = Fail_C_Int cd (customFail "Division by Zero") | otherwise = C_Int (x `quot` y) external_d_C_quot_ (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_C_quotInteger` y) cd cs) external_d_C_quot_ (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_C_quotInteger` (primint2curryint y)) cd cs) external_d_C_quot_ (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_C_quotInteger` y) cd cs) external_d_C_quot_ x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_quot_` b) cd2 cs2 )) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_rem_ :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_C_rem_ (C_Int x) (C_Int y) cd _ | y == 0 = Fail_C_Int cd (customFail "Division by Zero") | otherwise = C_Int (x `rem` y) external_d_C_rem_ (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_C_remInteger` y) cd cs) external_d_C_rem_ (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_C_remInteger` (primint2curryint y)) cd cs) external_d_C_rem_ (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_C_remInteger` y) cd cs) external_d_C_rem_ x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_rem_` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_quotRem_ :: C_Int -> C_Int -> Cover -> ConstStore -> OP_Tuple2 C_Int C_Int external_d_C_quotRem_ (C_Int x) (C_Int y) cd _ | y == 0 = Fail_OP_Tuple2 cd (customFail "Division by Zero") | otherwise = OP_Tuple2 (C_Int (x `quot` y)) (C_Int (x `rem` y)) external_d_C_quotRem_ (C_Int x) (C_CurryInt y) cd cs = (mkIntTuple `d_dollar_bang` (((primint2curryint x) `d_C_quotRemInteger` y) cd cs)) cd cs external_d_C_quotRem_ (C_CurryInt x) (C_Int y) cd cs = (mkIntTuple `d_dollar_bang` ((x `d_C_quotRemInteger` (primint2curryint y)) cd cs)) cd cs external_d_C_quotRem_ (C_CurryInt x) (C_CurryInt y) cd cs = (mkIntTuple `d_dollar_bang` ((x `d_C_quotRemInteger` y) cd cs)) cd cs external_d_C_quotRem_ x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_quotRem_` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_div_ :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_C_div_ (C_Int x) (C_Int y) cd _ | y == 0 = Fail_C_Int cd (customFail "Division by Zero") | otherwise = C_Int (x `div` y) external_d_C_div_ (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_C_divInteger` y) cd cs) external_d_C_div_ (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_C_divInteger` (primint2curryint y)) cd cs) external_d_C_div_ (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_C_divInteger` y) cd cs) external_d_C_div_ x y cd cs = ((\a cd1 cs1-> ((\b cd2 cs2-> ((a `external_d_C_div_` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_mod_ :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_C_mod_ (C_Int x) (C_Int y) cd _ | y == 0 = Fail_C_Int cd (customFail "Division by Zero") | otherwise = C_Int (x `mod` y) external_d_C_mod_ (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_C_modInteger` y) cd cs) external_d_C_mod_ (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_C_modInteger` (primint2curryint y)) cd cs) external_d_C_mod_ (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_C_modInteger` y) cd cs) external_d_C_mod_ x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_mod_` b)) cd2 cs2) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_divMod_ :: C_Int -> C_Int -> Cover -> ConstStore -> OP_Tuple2 C_Int C_Int external_d_C_divMod_ (C_Int x) (C_Int y) cd _ | y == 0 = Fail_OP_Tuple2 cd (customFail "Division by Zero") | otherwise = OP_Tuple2 (C_Int (x `div` y)) (C_Int (x `mod` y)) external_d_C_divMod_ (C_Int x) (C_CurryInt y) cd cs = (mkIntTuple `d_OP_dollar_hash` (((primint2curryint x) `d_C_divModInteger` y) cd cs)) cd cs external_d_C_divMod_ (C_CurryInt x) (C_Int y) cd cs = (mkIntTuple `d_OP_dollar_hash` ((x `d_C_divModInteger` (primint2curryint y)) cd cs)) cd cs external_d_C_divMod_ (C_CurryInt x) (C_CurryInt y) cd cs = (mkIntTuple `d_OP_dollar_hash` ((x `d_C_divModInteger` y) cd cs)) cd cs external_d_C_divMod_ x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_divMod_` b) cd2 cs2 )) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs mkIntTuple :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> OP_Tuple2 C_Int C_Int mkIntTuple (OP_Tuple2 d m) _ _ = OP_Tuple2 (C_CurryInt d) (C_CurryInt m) external_d_C_negateFloat :: C_Float -> Cover -> ConstStore -> C_Float external_d_C_negateFloat (C_Float x) _ _ = C_Float (negateDouble# x) external_d_C_negateFloat x cd cs = (external_d_C_negateFloat `d_OP_dollar_hash` x) cd cs external_d_C_prim_Float_plus :: C_Float -> C_Float -> Cover -> ConstStore -> C_Float external_d_C_prim_Float_plus y x _ _ = toCurry ((fromCurry x + fromCurry y) :: Double) external_d_C_prim_Float_minus :: C_Float -> C_Float -> Cover -> ConstStore -> C_Float external_d_C_prim_Float_minus y x _ _ = toCurry ((fromCurry x - fromCurry y) :: Double) external_d_C_prim_Float_times :: C_Float -> C_Float -> Cover -> ConstStore -> C_Float external_d_C_prim_Float_times y x _ _ = toCurry ((fromCurry x * fromCurry y) :: Double) external_d_C_prim_Float_div :: C_Float -> C_Float -> Cover -> ConstStore -> C_Float external_d_C_prim_Float_div y x _ _ = toCurry ((fromCurry x / fromCurry y) :: Double) external_d_C_prim_i2f :: C_Int -> Cover -> ConstStore -> C_Float external_d_C_prim_i2f x _ _ = toCurry (fromInteger (fromCurry x) :: Double) -- ----------------------------------------------------------------------------- -- Primitive operations: IO stuff -- ----------------------------------------------------------------------------- external_d_C_returnIO :: a -> Cover -> ConstStore -> C_IO a external_d_C_returnIO a _ _ = fromIO (return a) external_d_C_prim_putChar :: C_Char -> Cover -> ConstStore -> C_IO OP_Unit external_d_C_prim_putChar c _ _ = toCurry putChar c external_d_C_getChar :: Cover -> ConstStore -> C_IO C_Char external_d_C_getChar _ _ = toCurry getChar external_d_C_prim_readFile :: C_String -> Cover -> ConstStore -> C_IO C_String external_d_C_prim_readFile s _ _ = toCurry readFile s -- TODO: Problem: s is not evaluated to enable lazy IO and therefore could -- be non-deterministic external_d_C_prim_writeFile :: C_String -> C_String -> Cover -> ConstStore -> C_IO OP_Unit external_d_C_prim_writeFile s1 s2 _ _ = toCurry writeFile s1 s2 -- TODO: Problem: s is not evaluated to enable lazy IO and therefore could -- be non-deterministic external_d_C_prim_appendFile :: C_String -> C_String -> Cover -> ConstStore -> C_IO OP_Unit external_d_C_prim_appendFile s1 s2 _ _ = toCurry appendFile s1 s2 external_d_OP_gt_gt_eq_dollar :: (Curry t0, Curry t1) => C_IO t0 -> (t0 -> Cover -> ConstStore -> C_IO t1) -> Cover -> ConstStore -> C_IO t1 external_d_OP_gt_gt_eq_dollar m f cd cs = C_IO $ do res <- searchIO errSupply cd cs m case res of Left err -> return (Left (traceFail ("Prelude.>>=") [show m, show f] err)) Right x -> do cs1 <- lookupGlobalCs let cs2 = combineCs cs cs1 searchIO errSupply cd cs2 (f x cd cs2) where errSupply = internalError "Prelude.(>>=): ID supply used" -- TODO: Investigate if `cs` and `cs'` are in a subset relation -- in either direction. external_nd_OP_gt_gt_eq_dollar :: (Curry t0, Curry t1) => C_IO t0 -> Func t0 (C_IO t1) -> IDSupply -> Cover -> ConstStore -> C_IO t1 external_nd_OP_gt_gt_eq_dollar m f _ _ cs = HO_C_IO $ \s cd cs' -> do let cs1 = combineCs cs' cs res <- searchIO (leftSupply s) cd cs1 m case res of Left err -> return (Left (traceFail ("Prelude.>>=") [show m, show f] err)) Right x -> do cs2 <- lookupGlobalCs let cs3 = combineCs cs1 cs2 s' = rightSupply s searchIO (leftSupply s') cd cs3 (nd_apply f x (rightSupply s') cd cs3) -- ----------------------------------------------------------------------------- -- Primitive operations: Exception handling -- ----------------------------------------------------------------------------- instance ConvertCurryHaskell C_IOError CurryException where toCurry (IOException s) = C_IOError (toCurry s) toCurry (UserException s) = C_UserError (toCurry s) toCurry (FailException s) = C_FailError (toCurry s) toCurry (NondetException s) = C_NondetError (toCurry s) fromCurry (C_IOError s) = IOException $ fromCurry s fromCurry (C_UserError s) = UserException $ fromCurry s fromCurry (C_FailError s) = FailException $ fromCurry s fromCurry (C_NondetError s) = NondetException $ fromCurry s fromCurry _ = internalError "non-deterministic IOError" external_d_C_prim_error :: C_String -> Cover -> ConstStore -> a external_d_C_prim_error s _ _ = C.throw $ UserException (fromCurry s) external_d_C_prim_ioError :: C_IOError -> Cover -> ConstStore -> C_IO a external_d_C_prim_ioError e _ _ = C.throw $ (fromCurry e :: CurryException) external_d_C_catch :: C_IO a -> (C_IOError -> Cover -> ConstStore -> C_IO a) -> Cover -> ConstStore -> C_IO a external_d_C_catch act hndl cd cs = fromIO $ C.catches (toIO errSupply1 cd cs act) (exceptionHandlers errSupply2 cd cs (nd hndl)) where errSupply1 = internalError "Prelude.catch: ID supply 1 used" errSupply2 = internalError "Prelude.catch: ID supply 2 used" external_nd_C_catch :: C_IO a -> Func C_IOError (C_IO a) -> IDSupply -> Cover -> ConstStore -> C_IO a external_nd_C_catch act hndl _ _ cs = HO_C_IO $ \s cd cs' -> do let cs1 = combineCs cs' cs res <- C.catches (toIO (leftSupply s) cd cs1 act) (exceptionHandlers (rightSupply s) cd cs1 (nd_apply hndl)) return (Right res) exceptionHandlers :: IDSupply -> Cover -> ConstStore -> (C_IOError -> IDSupply -> Cover -> ConstStore -> C_IO a) -> [C.Handler a] exceptionHandlers s cd cs hndl = [ C.Handler (\ (e :: CurryException) -> toIO (leftSupply s) cd cs (hndl (toCurry e) (rightSupply s) cd cs)) , C.Handler (\ (e :: C.IOException) -> toIO (leftSupply s) cd cs (hndl (fromIOException e) (rightSupply s) cd cs)) ] where fromIOException = toCurry . IOException . show -- ----------------------------------------------------------------------------- -- Functions on Integer and Nat added from PrimTypes -- ----------------------------------------------------------------------------- d_C_cmpNat :: Nat -> Nat -> Cover -> ConstStore -> C_Ordering d_C_cmpNat x1 x2 cd cs = case x1 of IHi -> d_C__casept_33 x2 cd cs O x5 -> d_C__casept_32 x5 x2 cd cs I x9 -> d_C__casept_30 x9 x2 cd cs Choice_Nat d i l r -> narrow d i (d_C_cmpNat l x2 cd cs) (d_C_cmpNat r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_cmpNat z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_cmpNat e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.cmpNat" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.cmpNat" (showCons x1)) d_C_succNat :: Nat -> Cover -> ConstStore -> Nat d_C_succNat x1 cd cs = case x1 of IHi -> O IHi O x2 -> I x2 I x3 -> O (d_C_succNat x3 cd cs) Choice_Nat d i l r -> narrow d i (d_C_succNat l cd cs) (d_C_succNat r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_succNat z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_succNat e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.succ" [show x1] info) _ -> failCons cd (consFail "Prelude.succ" (showCons x1)) d_C_predNat :: Nat -> Cover -> ConstStore -> Nat d_C_predNat x1 cd cs = case x1 of IHi -> d_C_failed cd cs O x2 -> d_C__casept_28 x2 cd cs I x5 -> O x5 Choice_Nat d i l r -> narrow d i (d_C_predNat l cd cs) (d_C_predNat r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_predNat z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_predNat e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.pred" [show x1] info) _ -> failCons cd (consFail "Prelude.pred" (showCons x1)) d_OP_plus_caret :: Nat -> Nat -> Cover -> ConstStore -> Nat d_OP_plus_caret x1 x2 cd cs = case x1 of IHi -> d_C_succNat x2 cd cs O x3 -> d_C__casept_27 x3 x2 cd cs I x6 -> d_C__casept_26 x6 x2 cd cs Choice_Nat d i l r -> narrow d i (d_OP_plus_caret l x2 cd cs) (d_OP_plus_caret r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_plus_caret z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_OP_plus_caret e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.+^" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.+^" (showCons x1)) d_OP_minus_caret :: Nat -> Nat -> Cover -> ConstStore -> BinInt d_OP_minus_caret x1 x2 cd cs = case x1 of IHi -> d_C_inc (Neg x2) cd cs O x3 -> d_C__casept_25 x3 x1 x2 cd cs I x6 -> d_C__casept_24 x6 x2 cd cs Choice_Nat d i l r -> narrow d i (d_OP_minus_caret l x2 cd cs) (d_OP_minus_caret r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_minus_caret z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_OP_minus_caret e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.-^" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.-^" (showCons x1)) d_C_mult2 :: BinInt -> Cover -> ConstStore -> BinInt d_C_mult2 x1 cd cs = case x1 of Pos x2 -> Pos (O x2) Zero -> Zero Neg x3 -> Neg (O x3) Choice_BinInt d i l r -> narrow d i (d_C_mult2 l cd cs) (d_C_mult2 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_mult2 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_mult2 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.mult2" [show x1] info) _ -> failCons cd (consFail "Prelude.mult2" (showCons x1)) d_OP_star_caret :: Nat -> Nat -> Cover -> ConstStore -> Nat d_OP_star_caret x1 x2 cd cs = case x1 of IHi -> x2 O x3 -> O (d_OP_star_caret x3 x2 cd cs) I x4 -> d_OP_plus_caret x2 (O (d_OP_star_caret x4 x2 cd cs)) cd cs Choice_Nat d i l r -> narrow d i (d_OP_star_caret l x2 cd cs) (d_OP_star_caret r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_star_caret z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_OP_star_caret e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.*^" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.*^" (showCons x1)) d_C_div2 :: Nat -> Cover -> ConstStore -> Nat d_C_div2 x1 cd cs = case x1 of IHi -> d_C_failed cd cs O x2 -> x2 I x3 -> x3 Choice_Nat d i l r -> narrow d i (d_C_div2 l cd cs) (d_C_div2 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_div2 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_div2 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.div2" [show x1] info) _ -> failCons cd (consFail "Prelude.div2" (showCons x1)) d_C_mod2 :: Nat -> Cover -> ConstStore -> BinInt d_C_mod2 x1 cd cs = case x1 of IHi -> Pos IHi O x2 -> Zero I x3 -> Pos IHi Choice_Nat d i l r -> narrow d i (d_C_mod2 l cd cs) (d_C_mod2 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_mod2 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_mod2 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.mod2" [show x1] info) _ -> failCons cd (consFail "Prelude.mod2" (showCons x1)) d_C_quotRemNat :: Nat -> Nat -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C_quotRemNat x1 x2 cd cs = d_C__casept_23 x2 x1 (d_C_prim_eqNat x2 IHi cd cs) cd cs d_OP_quotRemNat_dot_shift_dot_104 :: Nat -> Nat -> Cover -> ConstStore -> Nat d_OP_quotRemNat_dot_shift_dot_104 x1 x2 cd cs = case x1 of IHi -> d_C_error (toCurryString "quotRemNat.shift: IHi") cd cs O x3 -> O x2 I x4 -> I x2 Choice_Nat d i l r -> narrow d i (d_OP_quotRemNat_dot_shift_dot_104 l x2 cd cs) (d_OP_quotRemNat_dot_shift_dot_104 r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_quotRemNat_dot_shift_dot_104 z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_OP_quotRemNat_dot_shift_dot_104 e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.quotRemNat.shift.104" [show x1 , show x2] info) _ -> failCons cd (consFail "Prelude.quotRemNat.shift.104" (showCons x1)) d_C_lteqInteger :: BinInt -> BinInt -> Cover -> ConstStore -> C_Bool d_C_lteqInteger x1 x2 cd cs = d_C_not (d_OP_eq_eq (d_OP_uscore_inst_hash_Prelude_dot_Eq_hash_Prelude_dot_Ordering cd cs) cd cs (d_C_cmpInteger x1 x2 cd cs) cd cs C_GT cd cs) cd cs d_C_cmpInteger :: BinInt -> BinInt -> Cover -> ConstStore -> C_Ordering d_C_cmpInteger x1 x2 cd cs = case x1 of Zero -> d_C__casept_14 x2 cd cs Pos x5 -> d_C__casept_13 x5 x2 cd cs Neg x8 -> d_C__casept_12 x8 x2 cd cs Choice_BinInt d i l r -> narrow d i (d_C_cmpInteger l x2 cd cs) (d_C_cmpInteger r x2 cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_cmpInteger z x2 cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_cmpInteger e x2 cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.cmpInteger" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.cmpInteger" (showCons x1)) d_C_neg :: BinInt -> Cover -> ConstStore -> BinInt d_C_neg x1 cd cs = case x1 of Zero -> Zero Pos x2 -> Neg x2 Neg x3 -> Pos x3 Choice_BinInt d i l r -> narrow d i (d_C_neg l cd cs) (d_C_neg r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_neg z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_neg e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.neg" [show x1] info) _ -> failCons cd (consFail "Prelude.neg" (showCons x1)) d_C_inc :: BinInt -> Cover -> ConstStore -> BinInt d_C_inc x1 cd cs = case x1 of Zero -> Pos IHi Pos x2 -> Pos (d_C_succNat x2 cd cs) Neg x3 -> d_C__casept_11 x3 cd cs Choice_BinInt d i l r -> narrow d i (d_C_inc l cd cs) (d_C_inc r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_inc z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_inc e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.inc" [show x1] info) _ -> failCons cd (consFail "Prelude.inc" (showCons x1)) d_C_dec :: BinInt -> Cover -> ConstStore -> BinInt d_C_dec x1 cd cs = case x1 of Zero -> Neg IHi Pos x2 -> d_C__casept_10 x2 cd cs Neg x5 -> Neg (d_C_succNat x5 cd cs) Choice_BinInt d i l r -> narrow d i (d_C_dec l cd cs) (d_C_dec r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_dec z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_dec e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.dec" [show x1] info) _ -> failCons cd (consFail "Prelude.dec" (showCons x1)) d_OP_plus_hash :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_OP_plus_hash x1 x2 cd cs = case x1 of Zero -> x2 Pos x3 -> d_C__casept_9 x3 x1 x2 cd cs Neg x6 -> d_C__casept_8 x6 x1 x2 cd cs Choice_BinInt d i l r -> narrow d i (d_OP_plus_hash l x2 cd cs) (d_OP_plus_hash r x2 cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_OP_plus_hash z x2 cd cs) xs Guard_BinInt d c e -> guardCons d c (d_OP_plus_hash e x2 cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.+#" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.+#" (showCons x1)) d_OP_minus_hash :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_OP_minus_hash x1 x2 cd cs = case x2 of Zero -> x1 Pos x3 -> d_OP_plus_hash x1 (Neg x3) cd cs Neg x4 -> d_OP_plus_hash x1 (Pos x4) cd cs Choice_BinInt d i l r -> narrow d i (d_OP_minus_hash x1 l cd cs) (d_OP_minus_hash x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_OP_minus_hash x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_OP_minus_hash x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.-#" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.-#" (showCons x2)) d_OP_star_hash :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_OP_star_hash x1 x2 cd cs = case x1 of Zero -> Zero Pos x3 -> d_C__casept_7 x3 x2 cd cs Neg x6 -> d_C__casept_6 x6 x2 cd cs Choice_BinInt d i l r -> narrow d i (d_OP_star_hash l x2 cd cs) (d_OP_star_hash r x2 cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_OP_star_hash z x2 cd cs) xs Guard_BinInt d c e -> guardCons d c (d_OP_star_hash e x2 cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.*#" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.*#" (showCons x1)) d_C_quotRemInteger :: BinInt -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C_quotRemInteger x1 x2 cd cs = case x2 of Zero -> d_C_failed cd cs Pos x3 -> d_C__casept_5 x3 x1 cd cs Neg x9 -> d_C__casept_4 x9 x1 cd cs Choice_BinInt d i l r -> narrow d i (d_C_quotRemInteger x1 l cd cs) (d_C_quotRemInteger x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_quotRemInteger x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_quotRemInteger x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.quotRemInteger" [show x1 , show x2] info) _ -> failCons cd (consFail "Prelude.quotRemInteger" (showCons x2)) d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP2#d" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP2#d" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP3#m" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP3#m" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP5#d" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP5#d" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP6#m" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP6#m" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP8#d" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP8#d" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP9#m" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP9#m" (showCons x1)) d_C_divModInteger :: BinInt -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C_divModInteger x1 x2 cd cs = case x2 of Zero -> d_C_failed cd cs Pos x3 -> d_C__casept_3 x3 x1 cd cs Neg x12 -> d_C__casept_1 x12 x1 cd cs Choice_BinInt d i l r -> narrow d i (d_C_divModInteger x1 l cd cs) (d_C_divModInteger x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_divModInteger x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_divModInteger x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.divModInteger" [show x1 , show x2] info) _ -> failCons cd (consFail "Prelude.divModInteger" (showCons x2)) d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP11#d" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP11#d" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP12#m" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP12#m" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP14#d" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP14#d" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP15#m" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP15#m" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP17#d" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP17#d" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP18#m" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP18#m" (showCons x1)) d_C_divInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C_divInteger x1 x2 cd cs = d_C_fst (d_C_divModInteger x1 x2 cd cs) cd cs d_C_modInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C_modInteger x1 x2 cd cs = d_C_snd (d_C_divModInteger x1 x2 cd cs) cd cs d_C_quotInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C_quotInteger x1 x2 cd cs = d_C_fst (d_C_quotRemInteger x1 x2 cd cs) cd cs d_C_remInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C_remInteger x1 x2 cd cs = d_C_snd (d_C_quotRemInteger x1 x2 cd cs) cd cs d_C__casept_1 :: Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_1 x12 x1 cd cs = case x1 of Zero -> OP_Tuple2 Zero Zero Pos x13 -> let x14 = d_C_quotRemNat x13 x12 cd cs x15 = d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d x14 cd cs x16 = d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m x14 cd cs x17 = OP_Tuple2 (d_C_neg (d_C_inc x15 cd cs) cd cs) (d_OP_minus_hash x16 (Pos x12) cd cs) in d_C__casept_0 x17 x15 x16 cd cs Neg x20 -> let x21 = d_C_quotRemNat x20 x12 cd cs x22 = d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d x21 cd cs x23 = d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m x21 cd cs in OP_Tuple2 x22 (d_C_neg x23 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_1 x12 l cd cs) (d_C__casept_1 x12 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_1 x12 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_1 x12 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_1" [show x12, show x1] info) _ -> failCons cd (consFail "Prelude._casept_1" (showCons x1)) d_C__casept_0 :: OP_Tuple2 BinInt BinInt -> BinInt -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_0 x17 x15 x16 cd cs = case x16 of Zero -> OP_Tuple2 (d_C_neg x15 cd cs) x16 Neg x18 -> x17 Pos x19 -> x17 Choice_BinInt d i l r -> narrow d i (d_C__casept_0 x17 x15 l cd cs) (d_C__casept_0 x17 x15 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_0 x17 x15 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_0 x17 x15 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_0" [show x17, show x15, show x16] info) _ -> failCons cd (consFail "Prelude._casept_0" (showCons x16)) d_C__casept_3 :: Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_3 x3 x1 cd cs = case x1 of Zero -> OP_Tuple2 Zero Zero Pos x4 -> d_C_quotRemNat x4 x3 cd cs Neg x5 -> let x6 = d_C_quotRemNat x5 x3 cd cs x7 = d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d x6 cd cs x8 = d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m x6 cd cs x9 = OP_Tuple2 (d_C_neg (d_C_inc x7 cd cs) cd cs) (d_OP_minus_hash (Pos x3) x8 cd cs) in d_C__casept_2 x9 x7 x8 cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_3 x3 l cd cs) (d_C__casept_3 x3 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_3 x3 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_3 x3 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_3" [show x3, show x1] info) _ -> failCons cd (consFail "Prelude._casept_3" (showCons x1)) d_C__casept_2 :: OP_Tuple2 BinInt BinInt -> BinInt -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_2 x9 x7 x8 cd cs = case x8 of Zero -> OP_Tuple2 (d_C_neg x7 cd cs) x8 Neg x10 -> x9 Pos x11 -> x9 Choice_BinInt d i l r -> narrow d i (d_C__casept_2 x9 x7 l cd cs) (d_C__casept_2 x9 x7 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_2 x9 x7 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_2 x9 x7 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_2" [show x9, show x7 , show x8] info) _ -> failCons cd (consFail "Prelude._casept_2" (showCons x8)) d_C__casept_4 :: Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_4 x9 x1 cd cs = case x1 of Zero -> OP_Tuple2 Zero Zero Pos x10 -> let x11 = d_C_quotRemNat x10 x9 cd cs x12 = d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d x11 cd cs x13 = d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m x11 cd cs in OP_Tuple2 (d_C_neg x12 cd cs) x13 Neg x14 -> let x15 = d_C_quotRemNat x14 x9 cd cs x16 = d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d x15 cd cs x17 = d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m x15 cd cs in OP_Tuple2 x16 (d_C_neg x17 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_4 x9 l cd cs) (d_C__casept_4 x9 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_4 x9 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_4 x9 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_4" [show x9, show x1] info) _ -> failCons cd (consFail "Prelude._casept_4" (showCons x1)) d_C__casept_5 :: Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_5 x3 x1 cd cs = case x1 of Zero -> OP_Tuple2 Zero Zero Pos x4 -> d_C_quotRemNat x4 x3 cd cs Neg x5 -> let x6 = d_C_quotRemNat x5 x3 cd cs x7 = d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d x6 cd cs x8 = d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m x6 cd cs in OP_Tuple2 (d_C_neg x7 cd cs) (d_C_neg x8 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_5 x3 l cd cs) (d_C__casept_5 x3 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_5 x3 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_5 x3 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_5" [show x3, show x1] info) _ -> failCons cd (consFail "Prelude._casept_5" (showCons x1)) d_C__casept_6 :: Nat -> BinInt -> Cover -> ConstStore -> BinInt d_C__casept_6 x6 x2 cd cs = case x2 of Zero -> Zero Pos x7 -> Neg (d_OP_star_caret x6 x7 cd cs) Neg x8 -> Pos (d_OP_star_caret x6 x8 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_6 x6 l cd cs) (d_C__casept_6 x6 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_6 x6 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_6 x6 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_6" [show x6, show x2] info) _ -> failCons cd (consFail "Prelude._casept_6" (showCons x2)) d_C__casept_7 :: Nat -> BinInt -> Cover -> ConstStore -> BinInt d_C__casept_7 x3 x2 cd cs = case x2 of Zero -> Zero Pos x4 -> Pos (d_OP_star_caret x3 x4 cd cs) Neg x5 -> Neg (d_OP_star_caret x3 x5 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_7 x3 l cd cs) (d_C__casept_7 x3 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_7 x3 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_7 x3 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_7" [show x3, show x2] info) _ -> failCons cd (consFail "Prelude._casept_7" (showCons x2)) d_C__casept_8 :: Nat -> BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C__casept_8 x6 x1 x2 cd cs = case x2 of Zero -> x1 Pos x7 -> d_OP_minus_caret x7 x6 cd cs Neg x8 -> Neg (d_OP_plus_caret x6 x8 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_8 x6 x1 l cd cs) (d_C__casept_8 x6 x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_8 x6 x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_8 x6 x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_8" [show x6, show x1 , show x2] info) _ -> failCons cd (consFail "Prelude._casept_8" (showCons x2)) d_C__casept_9 :: Nat -> BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C__casept_9 x3 x1 x2 cd cs = case x2 of Zero -> x1 Pos x4 -> Pos (d_OP_plus_caret x3 x4 cd cs) Neg x5 -> d_OP_minus_caret x3 x5 cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_9 x3 x1 l cd cs) (d_C__casept_9 x3 x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_9 x3 x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_9 x3 x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_9" [show x3, show x1 , show x2] info) _ -> failCons cd (consFail "Prelude._casept_9" (showCons x2)) d_C__casept_10 :: Nat -> Cover -> ConstStore -> BinInt d_C__casept_10 x2 cd cs = case x2 of IHi -> Zero O x3 -> Pos (d_C_predNat (O x3) cd cs) I x4 -> Pos (O x4) Choice_Nat d i l r -> narrow d i (d_C__casept_10 l cd cs) (d_C__casept_10 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_10 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_10 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_10" [show x2] info) _ -> failCons cd (consFail "Prelude._casept_10" (showCons x2)) d_C__casept_11 :: Nat -> Cover -> ConstStore -> BinInt d_C__casept_11 x3 cd cs = case x3 of IHi -> Zero O x4 -> Neg (d_C_predNat (O x4) cd cs) I x5 -> Neg (O x5) Choice_Nat d i l r -> narrow d i (d_C__casept_11 l cd cs) (d_C__casept_11 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_11 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_11 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_11" [show x3] info) _ -> failCons cd (consFail "Prelude._casept_11" (showCons x3)) d_C__casept_12 :: Nat -> BinInt -> Cover -> ConstStore -> C_Ordering d_C__casept_12 x8 x2 cd cs = case x2 of Zero -> C_LT Pos x9 -> C_LT Neg x10 -> d_C_cmpNat x10 x8 cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_12 x8 l cd cs) (d_C__casept_12 x8 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_12 x8 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_12 x8 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_12" [show x8, show x2] info) _ -> failCons cd (consFail "Prelude._casept_12" (showCons x2)) d_C__casept_13 :: Nat -> BinInt -> Cover -> ConstStore -> C_Ordering d_C__casept_13 x5 x2 cd cs = case x2 of Zero -> C_GT Pos x6 -> d_C_cmpNat x5 x6 cd cs Neg x7 -> C_GT Choice_BinInt d i l r -> narrow d i (d_C__casept_13 x5 l cd cs) (d_C__casept_13 x5 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_13 x5 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_13 x5 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_13" [show x5, show x2] info) _ -> failCons cd (consFail "Prelude._casept_13" (showCons x2)) d_C__casept_14 :: BinInt -> Cover -> ConstStore -> C_Ordering d_C__casept_14 x2 cd cs = case x2 of Zero -> C_EQ Pos x3 -> C_LT Neg x4 -> C_GT Choice_BinInt d i l r -> narrow d i (d_C__casept_14 l cd cs) (d_C__casept_14 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_14 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_14 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_14" [show x2] info) _ -> failCons cd (consFail "Prelude._casept_14" (showCons x2)) d_C__casept_23 :: Nat -> Nat -> C_Bool -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_23 x2 x1 x3 cd cs = case x3 of C_True -> OP_Tuple2 (Pos x1) Zero C_False -> d_C__casept_22 x1 x2 (d_C_prim_eqNat x1 IHi cd cs) cd cs Choice_C_Bool d i l r -> narrow d i (d_C__casept_23 x2 x1 l cd cs) (d_C__casept_23 x2 x1 r cd cs) Choices_C_Bool d i xs -> narrows cs d i (\z -> d_C__casept_23 x2 x1 z cd cs) xs Guard_C_Bool d c e -> guardCons d c (d_C__casept_23 x2 x1 e cd $! addCs c cs) Fail_C_Bool d info -> failCons d (traceFail "Prelude._casept_23" [show x2, show x1, show x3] info) _ -> failCons cd (consFail "Prelude._casept_23" (showCons x3)) d_C__casept_22 :: Nat -> Nat -> C_Bool -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_22 x1 x2 x3 cd cs = case x3 of C_True -> OP_Tuple2 Zero (Pos IHi) C_False -> d_C__casept_21 x2 x1 (d_C_otherwise cd cs) cd cs Choice_C_Bool d i l r -> narrow d i (d_C__casept_22 x1 x2 l cd cs) (d_C__casept_22 x1 x2 r cd cs) Choices_C_Bool d i xs -> narrows cs d i (\z -> d_C__casept_22 x1 x2 z cd cs) xs Guard_C_Bool d c e -> guardCons d c (d_C__casept_22 x1 x2 e cd $! addCs c cs) Fail_C_Bool d info -> failCons d (traceFail "Prelude._casept_22" [show x1, show x2, show x3] info) _ -> failCons cd (consFail "Prelude._casept_22" (showCons x3)) d_C__casept_21 :: Nat -> Nat -> C_Bool -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_21 x2 x1 x3 cd cs = case x3 of C_True -> d_C__casept_20 x2 x1 (d_C_cmpNat x1 x2 cd cs) cd cs C_False -> d_C_failed cd cs Choice_C_Bool d i l r -> narrow d i (d_C__casept_21 x2 x1 l cd cs) (d_C__casept_21 x2 x1 r cd cs) Choices_C_Bool d i xs -> narrows cs d i (\z -> d_C__casept_21 x2 x1 z cd cs) xs Guard_C_Bool d c e -> guardCons d c (d_C__casept_21 x2 x1 e cd $! addCs c cs) Fail_C_Bool d info -> failCons d (traceFail "Prelude._casept_21" [show x2, show x1, show x3] info) _ -> failCons cd (consFail "Prelude._casept_21" (showCons x3)) d_C__casept_20 :: Nat -> Nat -> C_Ordering -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_20 x2 x1 x3 cd cs = case x3 of C_EQ -> OP_Tuple2 (Pos IHi) Zero C_LT -> OP_Tuple2 Zero (Pos x1) C_GT -> d_C__casept_19 x2 x1 (d_C_quotRemNat (d_C_div2 x1 cd cs) x2 cd cs) cd cs Choice_C_Ordering d i l r -> narrow d i (d_C__casept_20 x2 x1 l cd cs) (d_C__casept_20 x2 x1 r cd cs) Choices_C_Ordering d i xs -> narrows cs d i (\z -> d_C__casept_20 x2 x1 z cd cs) xs Guard_C_Ordering d c e -> guardCons d c (d_C__casept_20 x2 x1 e cd $! addCs c cs) Fail_C_Ordering d info -> failCons d (traceFail "Prelude._casept_20" [show x2, show x1, show x3] info) _ -> failCons cd (consFail "Prelude._casept_20" (showCons x3)) d_C__casept_19 :: Nat -> Nat -> OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_19 x2 x1 x5 cd cs = case x5 of OP_Tuple2 x3 x4 -> d_C__casept_18 x4 x2 x1 x3 cd cs Choice_OP_Tuple2 d i l r -> narrow d i (d_C__casept_19 x2 x1 l cd cs) (d_C__casept_19 x2 x1 r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_C__casept_19 x2 x1 z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_C__casept_19 x2 x1 e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude._casept_19" [show x2, show x1, show x5] info) _ -> failCons cd (consFail "Prelude._casept_19" (showCons x5)) d_C__casept_18 :: BinInt -> Nat -> Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_18 x4 x2 x1 x3 cd cs = case x3 of Neg x5 -> d_C_error (toCurryString "quotRemNat: negative quotient") cd cs Zero -> OP_Tuple2 (Pos IHi) (d_OP_minus_caret x1 x2 cd cs) Pos x6 -> d_C__casept_17 x2 x1 x6 x4 cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_18 x4 x2 x1 l cd cs) (d_C__casept_18 x4 x2 x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_18 x4 x2 x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_18 x4 x2 x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_18" [show x4, show x2 , show x1, show x3] info) _ -> failCons cd (consFail "Prelude._casept_18" (showCons x3)) d_C__casept_17 :: Nat -> Nat -> Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_17 x2 x1 x6 x4 cd cs = case x4 of Neg x7 -> d_C_error (toCurryString "quotRemNat: negative remainder") cd cs Zero -> OP_Tuple2 (Pos (O x6)) (d_C_mod2 x1 cd cs) Pos x8 -> d_C__casept_16 x2 x8 x1 x6 (d_C_quotRemNat (d_OP_quotRemNat_dot_shift_dot_104 x1 x8 cd cs) x2 cd cs) cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_17 x2 x1 x6 l cd cs) (d_C__casept_17 x2 x1 x6 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_17 x2 x1 x6 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_17 x2 x1 x6 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_17" [show x2, show x1 , show x6, show x4] info) _ -> failCons cd (consFail "Prelude._casept_17" (showCons x4)) d_C__casept_16 :: Nat -> Nat -> Nat -> Nat -> OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_16 x2 x8 x1 x6 x11 cd cs = case x11 of OP_Tuple2 x9 x10 -> d_C__casept_15 x10 x6 x9 cd cs Choice_OP_Tuple2 d i l r -> narrow d i (d_C__casept_16 x2 x8 x1 x6 l cd cs) (d_C__casept_16 x2 x8 x1 x6 r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_C__casept_16 x2 x8 x1 x6 z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_C__casept_16 x2 x8 x1 x6 e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude._casept_16" [show x2, show x8, show x1, show x6, show x11] info) _ -> failCons cd (consFail "Prelude._casept_16" (showCons x11)) d_C__casept_15 :: BinInt -> Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_15 x10 x6 x9 cd cs = case x9 of Neg x11 -> d_C_error (toCurryString "quotRemNat: negative quotient") cd cs Zero -> OP_Tuple2 (Pos (O x6)) x10 Pos x12 -> OP_Tuple2 (Pos (d_OP_plus_caret (O x6) x12 cd cs)) x10 Choice_BinInt d i l r -> narrow d i (d_C__casept_15 x10 x6 l cd cs) (d_C__casept_15 x10 x6 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_15 x10 x6 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_15 x10 x6 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_15" [show x10, show x6, show x9] info) _ -> failCons cd (consFail "Prelude._casept_15" (showCons x9)) d_C__casept_24 :: Nat -> Nat -> Cover -> ConstStore -> BinInt d_C__casept_24 x6 x2 cd cs = case x2 of IHi -> Pos (O x6) O x7 -> d_C_inc (d_C_mult2 (d_OP_minus_caret x6 x7 cd cs) cd cs) cd cs I x8 -> d_C_mult2 (d_OP_minus_caret x6 x8 cd cs) cd cs Choice_Nat d i l r -> narrow d i (d_C__casept_24 x6 l cd cs) (d_C__casept_24 x6 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_24 x6 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_24 x6 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_24" [show x6, show x2] info) _ -> failCons cd (consFail "Prelude._casept_24" (showCons x2)) d_C__casept_25 :: Nat -> Nat -> Nat -> Cover -> ConstStore -> BinInt d_C__casept_25 x3 x1 x2 cd cs = case x2 of IHi -> Pos (d_C_predNat x1 cd cs) O x4 -> d_C_mult2 (d_OP_minus_caret x3 x4 cd cs) cd cs I x5 -> d_C_dec (d_C_mult2 (d_OP_minus_caret x3 x5 cd cs) cd cs) cd cs Choice_Nat d i l r -> narrow d i (d_C__casept_25 x3 x1 l cd cs) (d_C__casept_25 x3 x1 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_25 x3 x1 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_25 x3 x1 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_25" [show x3, show x1 , show x2] info) _ -> failCons cd (consFail "Prelude._casept_25" (showCons x2)) d_C__casept_26 :: Nat -> Nat -> Cover -> ConstStore -> Nat d_C__casept_26 x6 x2 cd cs = case x2 of IHi -> O (d_C_succNat x6 cd cs) O x7 -> I (d_OP_plus_caret x6 x7 cd cs) I x8 -> O (d_OP_plus_caret (d_C_succNat x6 cd cs) x8 cd cs) Choice_Nat d i l r -> narrow d i (d_C__casept_26 x6 l cd cs) (d_C__casept_26 x6 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_26 x6 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_26 x6 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_26" [show x6, show x2] info) _ -> failCons cd (consFail "Prelude._casept_26" (showCons x2)) d_C__casept_27 :: Nat -> Nat -> Cover -> ConstStore -> Nat d_C__casept_27 x3 x2 cd cs = case x2 of IHi -> I x3 O x4 -> O (d_OP_plus_caret x3 x4 cd cs) I x5 -> I (d_OP_plus_caret x3 x5 cd cs) Choice_Nat d i l r -> narrow d i (d_C__casept_27 x3 l cd cs) (d_C__casept_27 x3 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_27 x3 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_27 x3 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_27" [show x3, show x2] info) _ -> failCons cd (consFail "Prelude._casept_27" (showCons x2)) d_C__casept_28 :: Nat -> Cover -> ConstStore -> Nat d_C__casept_28 x2 cd cs = case x2 of IHi -> IHi O x3 -> I (d_C_predNat x2 cd cs) I x4 -> I (O x4) Choice_Nat d i l r -> narrow d i (d_C__casept_28 l cd cs) (d_C__casept_28 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_28 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_28 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_28" [show x2] info) _ -> failCons cd (consFail "Prelude._casept_28" (showCons x2)) d_C__casept_30 :: Nat -> Nat -> Cover -> ConstStore -> C_Ordering d_C__casept_30 x9 x2 cd cs = case x2 of IHi -> C_GT O x10 -> let x11 = d_C_cmpNat x9 x10 cd cs in d_C__casept_29 x11 cd cs I x12 -> d_C_cmpNat x9 x12 cd cs Choice_Nat d i l r -> narrow d i (d_C__casept_30 x9 l cd cs) (d_C__casept_30 x9 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_30 x9 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_30 x9 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_30" [show x9, show x2] info) _ -> failCons cd (consFail "Prelude._casept_30" (showCons x2)) d_C__casept_29 :: C_Ordering -> Cover -> ConstStore -> C_Ordering d_C__casept_29 x11 cd cs = case x11 of C_EQ -> C_GT C_LT -> x11 C_GT -> x11 Choice_C_Ordering d i l r -> narrow d i (d_C__casept_29 l cd cs) (d_C__casept_29 r cd cs) Choices_C_Ordering d i xs -> narrows cs d i (\z -> d_C__casept_29 z cd cs) xs Guard_C_Ordering d c e -> guardCons d c (d_C__casept_29 e cd $! addCs c cs) Fail_C_Ordering d info -> failCons d (traceFail "Prelude._casept_29" [show x11] info) _ -> failCons cd (consFail "Prelude._casept_29" (showCons x11)) d_C__casept_32 :: Nat -> Nat -> Cover -> ConstStore -> C_Ordering d_C__casept_32 x5 x2 cd cs = case x2 of IHi -> C_GT O x6 -> d_C_cmpNat x5 x6 cd cs I x7 -> let x8 = d_C_cmpNat x5 x7 cd cs in d_C__casept_31 x8 cd cs Choice_Nat d i l r -> narrow d i (d_C__casept_32 x5 l cd cs) (d_C__casept_32 x5 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_32 x5 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_32 x5 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_32" [show x5, show x2] info) _ -> failCons cd (consFail "Prelude._casept_32" (showCons x2)) d_C__casept_31 :: C_Ordering -> Cover -> ConstStore -> C_Ordering d_C__casept_31 x8 cd cs = case x8 of C_EQ -> C_LT C_LT -> x8 C_GT -> x8 Choice_C_Ordering d i l r -> narrow d i (d_C__casept_31 l cd cs) (d_C__casept_31 r cd cs) Choices_C_Ordering d i xs -> narrows cs d i (\z -> d_C__casept_31 z cd cs) xs Guard_C_Ordering d c e -> guardCons d c (d_C__casept_31 e cd $! addCs c cs) Fail_C_Ordering d info -> failCons d (traceFail "Prelude._casept_31" [show x8] info) _ -> failCons cd (consFail "Prelude._casept_31" (showCons x8)) d_C__casept_33 :: Nat -> Cover -> ConstStore -> C_Ordering d_C__casept_33 x2 cd cs = case x2 of IHi -> C_EQ O x3 -> C_LT I x4 -> C_LT Choice_Nat d i l r -> narrow d i (d_C__casept_33 l cd cs) (d_C__casept_33 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_33 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_33 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_33" [show x2] info) _ -> failCons cd (consFail "Prelude._casept_33" (showCons x2)) curry-libs-v2.2.0/Prelude.pakcs000066400000000000000000000151361355602362200164310ustar00rootroot00000000000000 prim_standard prim_applySeq[raw] prim_standard prim_applyNormalForm[raw] prim_standard prim_applyNotFree[raw] prim_standard prim_applyGroundNormalForm[raw] prim_standard prim_Int_plus prim_standard prim_Int_minus prim_standard prim_Int_times prim_standard prim_Int_div prim_standard prim_Int_mod prim_standard prim_Int_quot prim_standard prim_Int_rem prim_standard prim_negateFloat prim_standard prim_seq[raw] prim_standard prim_ensureNotFree[raw] prim_standard prim_ord prim_standard prim_chr prim_readshowterm prim_showTerm prim_readshowterm prim_readNatLiteral prim_readshowterm prim_readFloatLiteral prim_readshowterm prim_readCharLiteral prim_readshowterm prim_readStringLiteral prim_standard prim_error prim_standard prim_failed[raw] prim_standard constrEq[raw] prim_standard unifEq[raw] prim_standard unifEqLinear[raw] prim_standard prim_ifVar[raw] prim_standard prim_concurrent_and[raw] prim_standard prim_apply[raw] prim_standard prim_cond[raw] prim_standard prim_letrec[raw] prim_standard prim_failure[raw] prim_standard prim_Monad_bind[raw] prim_standard prim_Monad_seq[raw] prim_standard prim_return[raw] prim_standard prim_putChar prim_standard prim_getChar prim_standard prim_readFile prim_standard prim_readFileContents[raw] prim_standard prim_writeFile[raw] prim_standard prim_appendFile[raw] prim_standard prim_catch[raw] prim_standard prim_eqBasic prim_standard prim_eqBasic prim_standard prim_eqBasic prim_standard prim_leqChar prim_standard prim_leqNumber prim_standard prim_leqNumber prim_float prim_Float_plus prim_float prim_Float_minus prim_float prim_Float_times prim_float prim_Float_div prim_float prim_i2f curry-libs-v2.2.0/README.md000066400000000000000000000010121355602362200152510ustar00rootroot00000000000000Curry Libraries =============== This repository contains the standard libraries of the Curry distributions PAKCS and KiCS2. Since there are slight differences in the implementation of some libraries that are available for both PAKCS and KiCS2, libraries specific to PAKCS are suffixed by `.pakcs`. During the make process of PAKCS, these libraries are copied into the default `lib` directory where the suffix is removed. The makefiles `Makefiles.*.install` are responsible for this system-specific installation process. curry-libs-v2.2.0/Read.curry000066400000000000000000000037231355602362200157460ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some functions for reading special tokens. --- --- This library is included for backward compatibility. --- You should use the library ReadNumeric which provides a better interface --- for these functions. --- --- @author Michael Hanus --- @version January 2000 --- @category general ------------------------------------------------------------------------------ module Read ( readNat, readInt, readHex ) where import Char ( isDigit ) --- Read a natural number in a string. --- The string might contain leadings blanks and the the number is read --- up to the first non-digit. readNat :: String -> Int -- result >= 0 readNat l = readNatPrefix (dropWhile (\c->c==' ') l) 0 where readNatPrefix [] n = n readNatPrefix (c:cs) n = let oc = ord c in if oc>=ord '0' && oc<=ord '9' then readNatPrefix cs (n*10+oc-(ord '0')) else n --- Read a (possibly negative) integer in a string. --- The string might contain leadings blanks and the the integer is read --- up to the first non-digit. readInt :: String -> Int -- result >= 0 readInt l = readIntPrefix (dropWhile (\c->c==' ') l) where readIntPrefix [] = 0 readIntPrefix (c:cs) = if c=='-' then - (readNat cs) else readNat (c:cs) --- Read a hexadecimal number in a string. --- The string might contain leadings blanks and the the integer is read --- up to the first non-heaxdecimal digit. readHex :: String -> Int -- result >= 0 readHex l = readHexPrefix (dropWhile (\c->c==' ') l) 0 where readHexPrefix [] n = n readHexPrefix (c:cs) n = let cv = hex2int c in if cv>=0 then readHexPrefix cs (n*16+cv) else n hex2int c = if isDigit c then ord c - ord '0' else if ord c >= ord 'A' && ord c <= ord 'F' then ord c - ord 'A' + 10 else -1 -- end of library Read curry-libs-v2.2.0/ReadNumeric.curry000066400000000000000000000076441355602362200172770ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some functions for reading and converting numeric tokens. -- --- @author Michael Hanus, Frank Huch, Bjoern Peemoeller --- @version November 2016 --- @category general ------------------------------------------------------------------------------ module ReadNumeric ( readInt, readNat, readHex, readOct, readBin ) where import Char (digitToInt, isBinDigit, isOctDigit, isDigit, isHexDigit, isSpace) --- 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. --- If the string does not start with an integer token, `Nothing` is returned, --- otherwise the result is `Just (v, s)`, where `v` is the value of the integer --- and `s` is the remaing string without the integer token. readInt :: String -> Maybe (Int, String) readInt str = case dropWhile isSpace str of [] -> Nothing '-':str1 -> maybe Nothing (\ (val,rstr) -> Just (-val,rstr)) (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. --- If the string does not start with a natural number token, --- `Nothing` is returned, --- otherwise the result is `Just (v, s)` where `v` is the value of the number --- and s is the remaing string without the number token. readNat :: String -> Maybe (Int, String) readNat str = 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. --- If the string does not start with a hexadecimal number token, --- `Nothing` is returned, --- otherwise the result is `Just (v, s)` where `v` is the value of the number --- and s is the remaing string without the number token. readHex :: String -> Maybe (Int, String) readHex l = 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. --- If the string does not start with an octal number token, --- `Nothing` is returned, --- otherwise the result is `Just (v, s)` where `v` is the value of the number --- and s is the remaing string without the number token. readOct :: String -> Maybe (Int, String) readOct l = 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. --- If the string does not start with a binary number token, --- `Nothing` is returned, --- otherwise the result is `Just (v, s)` where `v` is the value of the number --- and s is the remaing string without the number token. readBin :: String -> Maybe (Int, String) readBin l = 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 curry-libs-v2.2.0/ReadShowTerm.curry000066400000000000000000000142251355602362200174360ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for converting ground terms to strings and vice versa. --- --- @author Michael Hanus --- @version April 2005 --- @category general ------------------------------------------------------------------------------ module ReadShowTerm(showTerm,showQTerm,readQTerm,readsQTerm, readsUnqualifiedTerm,readUnqualifiedTerm,readsTerm,readTerm, readQTermFile,readQTermListFile, writeQTermFile,writeQTermListFile) where import Char(isSpace) --- Transforms a ground(!) term into a string representation --- in standard prefix notation. --- Thus, showTerm suspends until its argument is ground. --- This function is similar to the prelude function show --- but can read the string back with readUnqualifiedTerm --- (provided that the constructor names are unique without the module --- qualifier). showTerm :: _ -> String showTerm x = prim_showTerm $## x prim_showTerm :: _ -> String prim_showTerm external --- Transforms a ground(!) term into a string representation --- in standard prefix notation. --- Thus, showTerm suspends until its argument is ground. --- Note that this function differs from the prelude function show --- since it prefixes constructors with their module name --- in order to read them back with readQTerm. showQTerm :: _ -> String showQTerm x = prim_showQTerm $## x prim_showQTerm :: _ -> String prim_showQTerm external --- Transform a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The first argument is a non-empty list of module qualifiers that are tried to --- prefix the constructor in the string in order to get the qualified constructors --- (that must be defined in the current program!). --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsUnqualifiedTerm :: [String] -> String -> [(_,String)] readsUnqualifiedTerm [] _ = error "ReadShowTerm.readsUnqualifiedTerm: list of module prefixes is empty" readsUnqualifiedTerm (prefix:prefixes) s = readsUnqualifiedTermWithPrefixes (prefix:prefixes) s readsUnqualifiedTermWithPrefixes :: [String] -> String -> [(_,String)] readsUnqualifiedTermWithPrefixes prefixes s = (prim_readsUnqualifiedTerm $## prefixes) $## s prim_readsUnqualifiedTerm :: [String] -> String -> [(_,String)] prim_readsUnqualifiedTerm external --- Transforms a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The first argument is a non-empty list of module qualifiers that are tried to --- prefix the constructor in the string in order to get the qualified constructors --- (that must be defined in the current program!). --- --- Example: readUnqualifiedTerm ["Prelude"] "Just 3" --- evaluates to (Just 3) readUnqualifiedTerm :: [String] -> String -> _ readUnqualifiedTerm prefixes s = case result of [(term,tail)] -> if all isSpace tail then term else error ("ReadShowTerm.readUnqualifiedTerm: no parse, unmatched string after term: "++tail) [] -> error "ReadShowTerm.readUnqualifiedTerm: no parse" _ -> error "ReadShowTerm.readUnqualifiedTerm: ambiguous parse" where result = readsUnqualifiedTerm prefixes s --- For backward compatibility. Should not be used since their use can be problematic --- in case of constructors with identical names in different modules. readsTerm :: String -> [(_,String)] readsTerm s = prim_readsUnqualifiedTerm [] $## s --- For backward compatibility. Should not be used since their use can be problematic --- in case of constructors with identical names in different modules. readTerm :: String -> _ readTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error ("ReadShowTerm.readTerm: no parse, unmatched string after term: "++tail) [] -> error "ReadShowTerm.readTerm: no parse" _ -> error "ReadShowTerm.readTerm: ambiguous parse" where result = prim_readsUnqualifiedTerm [] $## s --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsQTerm :: String -> [(_,String)] readsQTerm s = prim_readsQTerm $## s prim_readsQTerm :: String -> [(_,String)] prim_readsQTerm external --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. readQTerm :: String -> _ readQTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error "ReadShowTerm.readQTerm: no parse" [] -> error "ReadShowTerm.readQTerm: no parse" _ -> error "ReadShowTerm.readQTerm: ambiguous parse" where result = readsQTerm s --- Reads a file containing a string representation of a term --- in standard prefix notation and returns the corresponding data term. readQTermFile :: String -> IO _ readQTermFile file = readFile file >>= return . readQTerm --- Reads a file containing lines with string representations of terms --- of the same type and returns the corresponding list of data terms. readQTermListFile :: String -> IO [_] readQTermListFile file = readFile file >>= return . map readQTerm . lines --- Writes a ground term into a file in standard prefix notation. --- @param filename - The name of the file to be written. --- @param term - The term to be written to the file as a string. writeQTermFile :: String -> _ -> IO () writeQTermFile filename term = writeFile filename (showQTerm term) --- Writes a list of ground terms into a file. --- Each term is written into a separate line which might be useful --- to modify the file with a standard text editor. --- @param filename - The name of the file to be written. --- @param terms - The list of terms to be written to the file. writeQTermListFile :: String -> [_] -> IO () writeQTermListFile filename terms = writeFile filename (unlines (map showQTerm terms)) curry-libs-v2.2.0/ReadShowTerm.kics2000066400000000000000000000020151355602362200172770ustar00rootroot00000000000000external_d_C_prim_showTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_prim_showTerm t _ _ = toCurry (show t) external_d_C_prim_showQTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_prim_showQTerm t _ _ = toCurry (show t) external_d_C_prim_readsUnqualifiedTerm :: Read a => Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String) external_d_C_prim_readsUnqualifiedTerm _ = external_d_C_prim_readsQTerm external_d_C_prim_readsQTerm :: Read a => Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String) external_d_C_prim_readsQTerm s _ _ = toCurryPairs (reads (fromCurry s)) where toCurryPairs [] = Curry_Prelude.OP_List toCurryPairs ((v,s):xs) = Curry_Prelude.OP_Cons (Curry_Prelude.OP_Tuple2 v (toCurry s)) (toCurryPairs xs) curry-libs-v2.2.0/ReadShowTerm.pakcs000066400000000000000000000012661355602362200173740ustar00rootroot00000000000000 prim_readshowterm prim_showQTerm prim_readshowterm prim_showTerm prim_readshowterm prim_readsQTerm prim_readshowterm prim_readsUnqualifiedTerm curry-libs-v2.2.0/Setup.hs000066400000000000000000000000551355602362200154340ustar00rootroot00000000000000import Distribution.Simple main = defaultMaincurry-libs-v2.2.0/ShowS.curry000066400000000000000000000034661355602362200161420ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This library provides a type and combinators for show functions using --- functional lists. --- --- @author Bjoern Peemoeller --- @version April 2016 --- @category general -------------------------------------------------------------------------------- module ShowS ( ShowS , showString, showChar, showParen, shows , space, nl, sep, replicateS, concatS ) where import Test.Prop type ShowS = String -> String --- Prepend a string showString :: String -> ShowS showString s = (s ++) showStringIsString s = showString s [] -=- s showStringConcat s1 s2 = (showString s1 . showString s2) [] -=- s1++s2 --- Prepend a single character showChar :: Char -> ShowS showChar c = (c:) --- Surround the inner show function with parentheses if the first argument --- evaluates to `True`. showParen :: Bool -> ShowS -> ShowS showParen True s = showChar '(' . s . showChar ')' showParen False s = s --- Convert a value to `ShowS` using the standard show function. shows :: Show a => a -> ShowS shows = showString . show --- Prepend a space space :: ShowS space = showChar ' ' --- Prepend a newline nl :: ShowS nl = showChar '\n' --- Separate a list of `ShowS` sep :: ShowS -> [ShowS] -> ShowS sep _ [] = id sep s xs@(_:_) = foldr1 (\ f g -> f . s . g) xs --- Replicate a `ShowS` a given number of times replicateS :: Int -> ShowS -> ShowS replicateS n funcS | n <= 0 = id | otherwise = funcS . replicateS (n - 1) funcS replicateSIsConRep n s = n>=0 ==> replicateS n (showString s) [] -=- concat (replicate n s) --- Concatenate a list of `ShowS` concatS :: [ShowS] -> ShowS concatS [] = id concatS xs@(_:_) = foldr1 (\ f g -> f . g) xs concatSIsConcat xs = concatS (map showString xs) [] -=- concat xs curry-libs-v2.2.0/Sort.curry000066400000000000000000000202351355602362200160170ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A collection of useful functions for sorting and comparing --- characters, strings, and lists. --- --- @author Michael Hanus --- @version April 2016 --- @category algorithm ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-overlapping #-} module Sort ( sort, sortBy, sorted, sortedBy , permSort, permSortBy, insertionSort, insertionSortBy , quickSort, quickSortBy, mergeSort, mergeSortBy , cmpChar, cmpList, cmpString , leqChar, leqCharIgnoreCase, leqList , leqString, leqStringIgnoreCase, leqLexGerman ) where import Char ( toLower, toUpper ) --- The default sorting operation, mergeSort, with standard ordering `<=`. sort :: Ord a => [a] -> [a] sort = sortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. sort'post :: Ord a => [a] -> [a] -> Bool sort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: sort'spec :: Ord a => [a] -> [a] sort'spec xs = permSort xs --- The default sorting operation: mergeSort sortBy :: (a -> a -> Bool) -> [a] -> [a] sortBy = mergeSortBy --- `sorted xs` is satisfied if the elements `xs` are in ascending order. sorted :: Ord a => [a] -> Bool sorted = sortedBy (<=) --- `sortedBy leq xs` is satisfied if all adjacent elements of the list `xs` --- satisfy the ordering predicate `leq`. sortedBy :: (a -> a -> Bool) -> [a] -> Bool sortedBy _ [] = True sortedBy _ [_] = True sortedBy leq (x:y:ys) = leq x y && sortedBy leq (y:ys) ------------------------------------------------------------------------------ --- Permutation sort with standard ordering `<=`. --- Sorts a list by finding a sorted permutation --- of the input. This is not a usable way to sort a list but it can be used --- as a specification of other sorting algorithms. permSort :: Ord a => [a] -> [a] permSort = permSortBy (<=) --- Permutation sort with ordering as first parameter. --- Sorts a list by finding a sorted permutation --- of the input. This is not a usable way to sort a list but it can be used --- as a specification of other sorting algorithms. permSortBy :: Eq a => (a -> a -> Bool) -> [a] -> [a] permSortBy leq xs | sortedBy leq ys = ys where ys = perm xs --- Computes a permutation of a list. perm :: [a] -> [a] perm [] = [] perm (x:xs) = insert (perm xs) where insert ys = x : ys insert (y:ys) = y : insert ys ------------------------------------------------------------------------------ --- Insertion sort with standard ordering `<=`. --- The list is sorted by repeated sorted insertion of the elements --- into the already sorted part of the list. insertionSort :: Ord a => [a] -> [a] insertionSort = insertionSortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. insertionSort'post :: Ord a => [a] -> [a] -> Bool insertionSort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: insertionSort'spec :: Ord a => [a] -> [a] insertionSort'spec = permSort --- Insertion sort with ordering as first parameter. --- The list is sorted by repeated sorted insertion of the elements --- into the already sorted part of the list. insertionSortBy :: (a -> a -> Bool) -> [a] -> [a] insertionSortBy _ [] = [] insertionSortBy leq (x:xs) = insert (insertionSortBy leq xs) where insert [] = [x] insert zs@(y:ys) | leq x y = x : zs | otherwise = y : insert ys ------------------------------------------------------------------------------ --- Quicksort with standard ordering `<=`. --- The classical quicksort algorithm on lists. quickSort :: Ord a => [a] -> [a] quickSort = quickSortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. quickSort'post :: Ord a => [a] -> [a] -> Bool quickSort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: quickSort'spec :: Ord a => [a] -> [a] quickSort'spec = permSort --- Quicksort with ordering as first parameter. --- The classical quicksort algorithm on lists. quickSortBy :: (a -> a -> Bool) -> [a] -> [a] quickSortBy _ [] = [] quickSortBy leq (x:xs) = let (l,r) = split x xs in quickSortBy leq l ++ (x : quickSortBy leq r) where split _ [] = ([],[]) split e (y:ys) | leq y e = (y:l,r) | otherwise = (l,y:r) where (l,r) = split e ys ------------------------------------------------------------------------------ --- Bottom-up mergesort with standard ordering `<=`. mergeSort :: Ord a => [a] -> [a] mergeSort = mergeSortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. mergeSort'post :: Ord a => [a] -> [a] -> Bool mergeSort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: mergeSort'spec :: Ord a => [a] -> [a] mergeSort'spec = permSort --- 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 ------------------------------------------------------------------------------ -- Comparing lists, characters and strings --- Less-or-equal on lists. leqList :: Eq a => (a -> a -> Bool) -> [a] -> [a] -> Bool leqList _ [] _ = True leqList _ (_:_) [] = False leqList leq (x:xs) (y:ys) | x == y = leqList leq xs ys | otherwise = leq x y --- Comparison of lists. cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering cmpList _ [] [] = EQ cmpList _ [] (_:_) = LT cmpList _ (_:_) [] = GT cmpList cmp (x:xs) (y:ys) | cmp x y == EQ = cmpList cmp xs ys | otherwise = cmp x y --- Less-or-equal on characters (deprecated, use 'Prelude.<='). leqChar :: Char -> Char -> Bool leqChar = (<=) --- Comparison of characters (deprecated, use 'Prelude.compare'). cmpChar :: Char -> Char -> Ordering cmpChar = compare --- Less-or-equal on characters ignoring case considerations. leqCharIgnoreCase :: Char -> Char -> Bool leqCharIgnoreCase c1 c2 = (toUpper c1) <= (toUpper c2) --- Less-or-equal on strings (deprecated, use 'Prelude.<='). leqString :: String -> String -> Bool leqString = (<=) --- Comparison of strings (deprecated, use 'Prelude.compare'). cmpString :: String -> String -> Ordering cmpString = compare --- Less-or-equal on strings ignoring case considerations. leqStringIgnoreCase :: String -> String -> Bool leqStringIgnoreCase = leqList leqCharIgnoreCase --- Lexicographical ordering on German strings. --- Thus, upper/lowercase are not distinguished and Umlauts are sorted --- as vocals. leqLexGerman :: String -> String -> Bool leqLexGerman [] _ = True leqLexGerman (_:_) [] = False leqLexGerman (x:xs) (y:ys) | x' == y' = leqLexGerman xs ys | otherwise = x' < y' where x' = glex (ord x) y' = glex (ord y) -- map umlauts to vocals and make everything lowercase: glex o | o >= ord 'A' && o <= ord 'Z' = o + (ord 'a' - ord 'A') | o == 228 = ord 'a' | o == 246 = ord 'o' | o == 252 = ord 'u' | o == 196 = ord 'a' | o == 214 = ord 'o' | o == 220 = ord 'u' | o == 223 = ord 's' | otherwise = o -- end module Sort curry-libs-v2.2.0/State.curry000066400000000000000000000034431355602362200161520ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library provides an implementation of the state monad. --- --- @author Jan-Hendrik Matthes, Bjoern Peemoeller, Fabian Skrlac --- @version August 2016 --- @category general ------------------------------------------------------------------------------ module State ( State , bindS, bindS_, returnS, getS, putS, modifyS, sequenceS, sequenceS_, mapS , mapS_, runState, evalState, execState, liftS, liftS2 ) where infixl 1 `bindS`, `bindS_` type State s a = s -> (a, s) bindS :: State s a -> (a -> State s b) -> State s b bindS state f s = case state s of (x, newS) -> newS `seq` (f x newS) bindS_ :: State s a -> State s b -> State s b bindS_ a b = a `bindS` (\_ -> b) returnS :: a -> State s a returnS x s = (x, s) getS :: State s s getS s = (s, s) putS :: s -> State s () putS newS _ = ((), newS) modifyS :: (s -> s) -> State s () modifyS f s = ((), f s) sequenceS :: [State s a] -> State s [a] sequenceS = foldr (\s newS -> s `bindS` (\a -> newS `bindS` (\as -> returnS (a:as)))) (returnS []) sequenceS_ :: [State s a] -> State s () sequenceS_ = foldr bindS_ (returnS ()) mapS :: (a -> State s b) -> [a] -> State s [b] mapS f = sequenceS . (map f) mapS_ :: (a -> State s b) -> [a] -> State s () mapS_ f = sequenceS_ . (map f) runState :: State s a -> s -> (a, s) runState state s = state s evalState :: State s a -> s -> a evalState state s = fst (runState state s) execState :: State s a -> s -> s execState state s = snd (runState state s) liftS :: (a -> b) -> State s a -> State s b liftS f act = act `bindS` (returnS . f) liftS2 :: (a -> b -> c) -> State s a -> State s b -> State s c liftS2 f a b = a `bindS` (\x -> b `bindS` (\y -> returnS (f x y)))curry-libs-v2.2.0/System.curry000066400000000000000000000102311355602362200163470ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to access parts of the system environment. --- --- @author Michael Hanus, Bernd Brassel, Bjoern Peemoeller --- @version July 2012 --- @category general ------------------------------------------------------------------------------ module System ( getCPUTime,getElapsedTime , getArgs, getEnviron, setEnviron, unsetEnviron, getProgName , getHostname, getPID, system, exitWith, sleep , isPosix, isWindows ) where import Global ( Global, GlobalSpec(..), global, readGlobal, writeGlobal ) --- Returns the current cpu time of the process in milliseconds. getCPUTime :: IO Int getCPUTime external --- Returns the current elapsed time of the process in milliseconds. --- This operation is not supported in KiCS2 (there it always returns 0), --- but only included for compatibility reasons. getElapsedTime :: IO Int getElapsedTime external --- 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. getEnviron :: String -> IO String getEnviron evar = do envs <- readGlobal environ maybe (prim_getEnviron $## evar) return (lookup evar envs) prim_getEnviron :: String -> IO String prim_getEnviron external --- 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 system) and visible to subsequent calls to --- getEnviron (but it is not visible in the environment --- of the process that started the program execution). setEnviron :: String -> String -> IO () setEnviron evar val = do envs <- readGlobal environ writeGlobal environ ((evar,val) : filter ((/=evar) . fst) envs) --- Removes an environment variable that has been set by --- setEnviron. unsetEnviron :: String -> IO () unsetEnviron evar = do envs <- readGlobal environ writeGlobal environ (filter ((/=evar) . fst) envs) --- Returns the hostname of the machine running this process. getHostname :: IO String getHostname external --- Returns the process identifier of the current Curry process. getPID :: IO Int getPID external --- Returns the name of the current program, i.e., the name of the --- main module currently executed. getProgName :: IO String getProgName external --- Executes a shell command and return with the exit code of the command. --- An exit status of zero means successful execution. system :: String -> IO Int system cmd = do envs <- readGlobal environ prim_system $## (concatMap envToExport envs ++ escapedCmd) where win = isWindows -- This is a work around for GHC ticket #5376 -- (http://hackage.haskell.org/trac/ghc/ticket/5376) escapedCmd = if win then '\"' : cmd ++ "\"" else cmd envToExport (var, val) = if win then "set " ++ var ++ "=" ++ concatMap escapeWinSpecials val ++ " && " else var ++ "='" ++ concatMap encodeShellSpecials val ++ "' ; export " ++ var ++ " ; " escapeWinSpecials c = if c `elem` "<>|&^" then ['^', c] else [c] encodeShellSpecials c = if c == '\'' then map chr [39,34,39,34,39] else [c] prim_system :: String -> IO Int prim_system external --- Terminates the execution of the current Curry program --- and returns the exit code given by the argument. --- An exit code of zero means successful execution. exitWith :: Int -> IO _ exitWith exitcode = prim_exitWith $# exitcode prim_exitWith :: Int -> IO _ prim_exitWith external --- The evaluation of the action (sleep n) puts the Curry process --- asleep for n seconds. sleep :: Int -> IO () sleep n = prim_sleep $# n prim_sleep :: Int -> IO () prim_sleep 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 curry-libs-v2.2.0/System.kics2000066400000000000000000000060631355602362200162260ustar00rootroot00000000000000{-# LANGUAGE CPP, ForeignFunctionInterface, MultiParamTypeClasses #-} import Control.Exception as C (IOException, handle) import Network.BSD (getHostName) import System.CPUTime (getCPUTime) import System.Environment (getArgs, getEnv, getProgName) import System.Exit (ExitCode (..), exitWith) import System.Process (system) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) import System.Win32.Process #else import System.Posix.Process (getProcessID) #endif -- #endimport - do not remove this line! #if defined(mingw32_HOST_OS) || defined(__MINGW32__) foreign import stdcall unsafe "windows.h GetCurrentProcessId" getProcessID :: IO ProcessId #endif external_d_C_getCPUTime :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_getCPUTime _ _ = toCurry (getCPUTime >>= return . (`div` (10 ^ 9))) external_d_C_getElapsedTime :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_getElapsedTime _ _ = toCurry (return 0 :: IO Int) 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_getPID :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_getPID _ _ = toCurry $ do pid <- getProcessID return (fromIntegral pid :: Int) external_d_C_getProgName :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String external_d_C_getProgName _ _ = toCurry getProgName external_d_C_prim_system :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_system str _ _ = toCurry system str instance ConvertCurryHaskell Curry_Prelude.C_Int ExitCode where toCurry ExitSuccess = toCurry (0 :: Int) toCurry (ExitFailure i) = toCurry i fromCurry j = let i = fromCurry j :: Int in if i == 0 then ExitSuccess else ExitFailure i external_d_C_prim_exitWith :: Curry_Prelude.Curry a => Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO a external_d_C_prim_exitWith c _ _ = fromIO (exitWith (fromCurry c)) external_d_C_prim_sleep :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_sleep x _ _ = toCurry (\i -> system ("sleep " ++ show (i :: Int)) >> return ()) x -- TODO 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 curry-libs-v2.2.0/System.pakcs000066400000000000000000000027001355602362200163060ustar00rootroot00000000000000 prim_system prim_getCPUTime prim_system prim_getElapsedTime prim_system prim_getArgs prim_system prim_getEnviron prim_system prim_getHostname prim_system prim_getPID prim_system prim_getProgName prim_system prim_system prim_system prim_exitWith prim_system prim_sleep prim_system isWindows curry-libs-v2.2.0/Test/000077500000000000000000000000001355602362200147175ustar00rootroot00000000000000curry-libs-v2.2.0/Test/Prop.curry000066400000000000000000000204561355602362200167340ustar00rootroot00000000000000------------------------------------------------------------------------- --- This module defines the interface of properties that can be checked --- with the CurryCheck tool, an automatic property-based test tool --- based on the EasyCheck library. --- The ideas behind EasyCheck are described in --- [this paper](http://www-ps.informatik.uni-kiel.de/~sebf/pub/flops08.html). --- CurryCheck automatically tests properties defined with this library. --- CurryCheck supports the definition of unit tests --- (also for I/O operations) and property tests parameterized --- over some arguments. CurryCheck is described in more detail in --- [this paper](http://www.informatik.uni-kiel.de/~mh/papers/LOPSTR16.html). --- --- Basically, this module is a stub clone of the EasyCheck library --- which contains only the interface of the operations used to specify --- properties. Hence, this library does not import any other library. --- This supports the definition of properties in any other module --- (execept for the prelude). --- --- @author Sebastian Fischer (with extensions by Michael Hanus) --- @version January 2019 ------------------------------------------------------------------------- module Test.Prop ( -- test specification: PropIO, returns, sameReturns, toError, toIOError, Prop, (==>), for, forAll, is, isAlways, isEventually, uniquely, always, eventually, failing, successful, deterministic, (-=-), (<~>), (~>), (<~), (<~~>), (#), (#<), (#>), (<=>), solutionOf, -- test annotations label, trivial, classify, collect, collectAs, -- enumerating values valuesOf ) where import Test.Prop.Types infix 1 `is`, `isAlways`, `isEventually` infix 1 -=-, <~>, ~>, <~, <~~>, `trivial`, #, #<, #>, <=> infix 1 `returns`, `sameReturns` infixr 0 ==> ------------------------------------------------------------------------- -- Properties involving I/O actions: --- The property `returns a x` is satisfied if the execution of the --- I/O action `a` returns the value `x`. returns :: (Eq a, Show a) => IO a -> a -> PropIO returns _ _ = propUndefinedError "returns" --- The property `sameReturns a1 a2` is satisfied if the execution of the --- I/O actions `a1` and `a2` return identical values. sameReturns :: (Eq a, Show a) => IO a -> IO a -> PropIO sameReturns _ _ = propUndefinedError "sameReturns" --- The property `toError a` is satisfied if the evaluation of the argument --- to normal form yields an exception. toError :: a -> PropIO toError _ = propUndefinedError "toError" --- The property `toIOError a` is satisfied if the execution of the --- I/O action `a` causes an exception. toIOError :: IO a -> PropIO toIOError _ = propUndefinedError "toIOError" ------------------------------------------------------------------------- -- Standard properties to be checked: --- The property `x -=- y` is satisfied if `x` and `y` have deterministic --- values that are equal. (-=-) ::(Eq a, Show a) => a -> a -> Prop _ -=- _ = propUndefinedError "-=-" --- The property `x <~> y` is satisfied if the sets of the values of --- `x` and `y` are equal. (<~>) :: (Eq a, Show a) => a -> a -> Prop _ <~> _ = propUndefinedError "<~>" --- The property `x ~> y` is satisfied if `x` evaluates to every value of `y`. --- Thus, the set of values of `y` must be a subset of the set of values of `x`. (~>) :: (Eq a, Show a) => a -> a -> Prop _ ~> _ = propUndefinedError "~>" --- The property `x <~ y` is satisfied if `y` evaluates to every value of `x`. --- Thus, the set of values of `x` must be a subset of the set of values of `y`. (<~) :: (Eq a, Show a) => a -> a -> Prop _ <~ _ = propUndefinedError "<~" --- The property `x <~~> y` is satisfied if the multisets of the values of --- `x` and `y` are equal. (<~~>) :: (Eq a, Show a) => a -> a -> Prop _ <~~> _ = propUndefinedError "<~~>" --- A conditional property is tested if the condition evaluates to `True`. (==>) :: Bool -> Prop -> Prop _ ==> _ = propUndefinedError "==>" --- `solutionOf p` returns (non-deterministically) a solution --- of predicate `p`. This operation is useful to test solutions --- of predicates. solutionOf :: (a -> Bool) -> a solutionOf pred = pred x &> x where x free --- The property `is x p` is satisfied if `x` has a deterministic value --- which satisfies `p`. is :: Show a => a -> (a -> Bool) -> Prop is _ _ = propUndefinedError "is" --- The property `isAlways x p` is satisfied if all values of `x` satisfy `p`. isAlways :: Show a => a -> (a -> Bool) -> Prop isAlways _ = propUndefinedError "isAlways" --- The property `isEventually x p` is satisfied if some value of `x` --- satisfies `p`. isEventually :: Show a => a -> (a -> Bool) -> Prop isEventually _ = propUndefinedError "isEventually" --- The property `uniquely x` is satisfied if `x` has a deterministic value --- which is true. uniquely :: Bool -> Prop uniquely _ = propUndefinedError "uniquely" --- The property `always x` is satisfied if all values of `x` are true. always :: Bool -> Prop always _ = propUndefinedError "always" --- The property `eventually x` is satisfied if some value of `x` is true. eventually :: Bool -> Prop eventually _ = propUndefinedError "eventually" --- The property `failing x` is satisfied if `x` has no value. failing :: Show a => a -> Prop failing _ = propUndefinedError "failing" --- The property `successful x` is satisfied if `x` has at least one value. successful :: Show a => a -> Prop successful _ = propUndefinedError "successful" --- The property `deterministic x` is satisfied if `x` has exactly one value. deterministic :: Show a => a -> Prop deterministic _ = propUndefinedError "deterministic" --- The property `x # n` is satisfied if `x` has `n` values. (#) :: (Eq a, Show a) => a -> Int -> Prop _ # _ = propUndefinedError "#" --- The property `x #< n` is satisfied if `x` has less than `n` values. (#<) :: (Eq a, Show a) => a -> Int -> Prop _ #< _ = propUndefinedError "#<" --- The property `x #> n` is satisfied if `x` has more than `n` values. (#>) :: (Eq a, Show a) => a -> Int -> Prop _ #> _ = propUndefinedError "#>" --- The property `for x p` is satisfied if all values `y` of `x` --- satisfy property `p y`. for :: Show a => a -> (a -> Prop) -> Prop for _ _ = propUndefinedError "for" --- The property `forAll xs p` is satisfied if all values `x` of the list `xs` --- satisfy property `p x`. forAll :: Show a => [a] -> (a -> Prop) -> Prop forAll _ _ = propUndefinedError "forAll" --- The property `f <=> g` is satisfied if `f` and `g` are equivalent --- operations, i.e., they can be replaced in any context without changing --- the computed results. (<=>) :: a -> a -> Prop _ <=> _ = propUndefinedError "#" ------------------------------------------------------------------------- -- Test Annotations --- Assign a label to a property. --- All labeled tests are counted and shown at the end. label :: String -> Prop -> Prop label _ _ = propUndefinedError "label" --- Assign a label to a property if the first argument is `True`. --- All labeled tests are counted and shown at the end. --- Hence, this combinator can be used to classify tests: --- --- multIsComm x y = classify (x<0 || y<0) "Negative" $ x*y -=- y*x --- classify :: Bool -> String -> Prop -> Prop classify _ _ _ = propUndefinedError "classify" --- Assign the label "trivial" to a property if the first argument is `True`. --- All labeled tests are counted and shown at the end. trivial :: Bool -> Prop -> Prop trivial _ _ = propUndefinedError "trivial" --- Assign a label showing the given argument to a property. --- All labeled tests are counted and shown at the end. collect :: Show a => a -> Prop -> Prop collect _ _ = propUndefinedError "collect" --- Assign a label showing a given name and the given argument to a property. --- All labeled tests are counted and shown at the end. collectAs :: Show a => String -> a -> Prop -> Prop collectAs _ _ _ = propUndefinedError "collectAs" ------------------------------------------------------------------------- -- Value generation --- Computes the list of all values of the given argument --- according to a given strategy (here: --- randomized diagonalization of levels with flattening). valuesOf :: a -> [a] valuesOf = error "Test.Prop.valuesOf undefined. Use Test.EasyCheck to actually run it!" propUndefinedError :: String -> _ propUndefinedError op = error $ "Test.Prop." ++ op ++ " undefined. Use Test.EasyCheck to actually run it!" ------------------------------------------------------------------------- curry-libs-v2.2.0/Test/Prop/000077500000000000000000000000001355602362200156375ustar00rootroot00000000000000curry-libs-v2.2.0/Test/Prop/Types.curry000066400000000000000000000022551355602362200200350ustar00rootroot00000000000000------------------------------------------------------------------------- --- This module defines some types used by the EasyCheck libraries. --- --- @author Michael Hanus --- @version January 2019 ------------------------------------------------------------------------- module Test.Prop.Types where -- The types of properties: --- Abstract type to represent properties involving IO actions. data PropIO = PropIO (Bool -> String -> IO (Maybe String)) --- Abstract type to represent standard properties to be checked. --- Basically, it contains all tests to be executed to check the property. data Prop = Prop [Test] ------------------------------------------------------------------------- --- Abstract type to represent a single test for a property to be checked. --- A test consists of the result computed for this test, --- the arguments used for this test, and the labels possibly assigned --- to this test by annotating properties. data Test = Test Result [String] [String] --- Data type to represent the result of checking a property. data Result = Undef | Ok | Falsified [String] | Ambigious [Bool] [String] ------------------------------------------------------------------------- curry-libs-v2.2.0/Time.curry000066400000000000000000000144641355602362200157750ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for handling date and time information. --- --- @author Michael Hanus --- @version January 2018 ------------------------------------------------------------------------------ module Time ( ClockTime , CalendarTime(..), ctYear, ctMonth, ctDay, ctHour, ctMin, ctSec, ctTZ , getClockTime, getLocalTime, toUTCTime, toClockTime, toCalendarTime , clockTimeToInt, calendarTimeToString, toDayString, toTimeString , addSeconds, addMinutes, addHours, addDays, addMonths, addYears , daysOfMonth, validDate, compareCalendarTime, compareClockTime , compareDate) where --- ClockTime represents a clock time in some internal representation. data ClockTime = CTime Int 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, Read) --- The year of a calendar time. ctYear :: CalendarTime -> Int ctYear (CalendarTime y _ _ _ _ _ _) = y --- The month of a calendar time. ctMonth :: CalendarTime -> Int ctMonth (CalendarTime _ m _ _ _ _ _) = m --- The day of a calendar time. ctDay :: CalendarTime -> Int ctDay (CalendarTime _ _ d _ _ _ _) = d --- The hour of a calendar time. ctHour :: CalendarTime -> Int ctHour (CalendarTime _ _ _ h _ _ _) = h --- The minute of a calendar time. ctMin :: CalendarTime -> Int ctMin (CalendarTime _ _ _ _ m _ _) = m --- The second of a calendar time. ctSec :: CalendarTime -> Int ctSec (CalendarTime _ _ _ _ _ s _) = s --- The time zone of a calendar time. The value of the --- time zone is the difference to UTC time in seconds. ctTZ :: CalendarTime -> Int ctTZ (CalendarTime _ _ _ _ _ _ tz) = tz --- Returns the current clock time. getClockTime :: IO ClockTime getClockTime external --- Returns the local calendar time. getLocalTime :: IO CalendarTime getLocalTime = do ctime <- getClockTime toCalendarTime ctime --- Transforms a clock time into a unique integer. --- It is ensured that clock times that differs in at least one second --- are mapped into different integers. clockTimeToInt :: ClockTime -> Int clockTimeToInt (CTime i) = i --- Transforms a clock time into a calendar time according to the local time --- (if possible). Since the result depends on the local environment, --- it is an I/O operation. toCalendarTime :: ClockTime -> IO CalendarTime toCalendarTime ctime = prim_toCalendarTime $## ctime prim_toCalendarTime :: ClockTime -> IO CalendarTime prim_toCalendarTime external --- Transforms a clock time into a standard UTC calendar time. --- Thus, this operation is independent on the local time. toUTCTime :: ClockTime -> CalendarTime toUTCTime ctime = prim_toUTCTime $## ctime prim_toUTCTime :: ClockTime -> CalendarTime prim_toUTCTime external --- Transforms a calendar time (interpreted as UTC time) into a clock time. toClockTime :: CalendarTime -> ClockTime toClockTime d = prim_toClockTime $## d prim_toClockTime :: CalendarTime -> ClockTime prim_toClockTime external --- Transforms a calendar time into a readable form. calendarTimeToString :: CalendarTime -> String calendarTimeToString ctime@(CalendarTime y mo d _ _ _ _) = shortMonths!!(mo-1) ++ " " ++ show d ++ " " ++ toTimeString ctime ++ " " ++ show y where shortMonths = [ "Jan","Feb","Mar","Apr","May","Jun", "Jul","Aug","Sep","Oct","Nov","Dec"] --- Transforms a calendar time into a string containing the day, e.g., --- "September 23, 2006". toDayString :: CalendarTime -> String toDayString (CalendarTime y mo d _ _ _ _) = longMonths!!(mo-1) ++ " " ++ show d ++ ", " ++ show y where longMonths = [ "January" , "February" , "March" , "April" , "May" , "June" , "July" , "August" , "September" , "October" , "November" , "December" ] --- Transforms a calendar time into a string containing the time. toTimeString :: CalendarTime -> String toTimeString (CalendarTime _ _ _ h mi s _) = digit2 h ++":"++ digit2 mi ++":"++ digit2 s where digit2 n = if n<10 then ['0',chr(ord '0' + n)] else show n --- Adds seconds to a given time. addSeconds :: Int -> ClockTime -> ClockTime addSeconds n (CTime ctime) = CTime (ctime + n) --- Adds minutes to a given time. addMinutes :: Int -> ClockTime -> ClockTime addMinutes n (CTime ctime) = CTime (ctime + (n*60)) --- Adds hours to a given time. addHours :: Int -> ClockTime -> ClockTime addHours n (CTime ctime) = CTime (ctime + (n*3600)) --- Adds days to a given time. addDays :: Int -> ClockTime -> ClockTime addDays n (CTime ctime) = CTime (ctime + (n*86400)) --- Adds months to a given time. addMonths :: Int -> ClockTime -> ClockTime addMonths n ctime = let CalendarTime y mo d h mi s tz = toUTCTime ctime nmo = (mo-1+n) `mod` 12 + 1 in if nmo>0 then addYears ((mo-1+n) `div` 12) (toClockTime (CalendarTime y nmo d h mi s tz)) else addYears ((mo-1+n) `div` 12 - 1) (toClockTime (CalendarTime y (nmo+12) d h mi s tz)) --- Adds years to a given time. addYears :: Int -> ClockTime -> ClockTime addYears n ctime = if n==0 then ctime else let CalendarTime y mo d h mi s tz = toUTCTime ctime in toClockTime (CalendarTime (y+n) mo d h mi s tz) --- Gets the days of a month in a year. daysOfMonth :: Int -> Int -> Int daysOfMonth mo yr = if mo/=2 then [31,28,31,30,31,30,31,31,30,31,30,31] !! (mo-1) else if yr `mod` 4 == 0 && (yr `mod` 100 /= 0 || yr `mod` 400 == 0) then 29 else 28 --- Is a date consisting of year/month/day valid? validDate :: Int -> Int -> Int -> Bool validDate y m d = m > 0 && m < 13 && d > 0 && d <= daysOfMonth m y --- Compares two dates (don't use it, just for backward compatibility!). compareDate :: CalendarTime -> CalendarTime -> Ordering compareDate = compareCalendarTime --- Compares two calendar times. compareCalendarTime :: CalendarTime -> CalendarTime -> Ordering compareCalendarTime ct1 ct2 = compareClockTime (toClockTime ct1) (toClockTime ct2) --- Compares two clock times. compareClockTime :: ClockTime -> ClockTime -> Ordering compareClockTime (CTime time1) (CTime time2) | time1time2 = GT | otherwise = EQ curry-libs-v2.2.0/Time.kics2000066400000000000000000000050431355602362200156350ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import qualified System.Time as T import qualified Data.Time.Clock as Clock import qualified Data.Time.Calendar as Cal instance ConvertCurryHaskell C_ClockTime T.ClockTime where fromCurry (C_CTime i) = T.TOD (fromCurry i) 0 toCurry (T.TOD i _) = C_CTime (toCurry i) instance ConvertCurryHaskell C_CalendarTime T.CalendarTime where fromCurry (C_CalendarTime y m d h min s tz) = T.CalendarTime (fromCurry y) (toEnum (fromCurry m - 1)) (fromCurry d) (fromCurry h) (fromCurry min) (fromCurry s) 0 undefined undefined undefined (fromCurry tz) undefined toCurry (T.CalendarTime y m d h min s _ _ _ _ tz _) = C_CalendarTime (toCurry y) (toCurry (fromEnum m + 1)) (toCurry d) (toCurry h) (toCurry min) (toCurry s) (toCurry tz) instance ConvertCurryHaskell C_ClockTime Clock.UTCTime where fromCurry ct = let (T.CalendarTime y m d h min s _ _ _ _ tz _) = T.toUTCTime (fromCurry ct) in fromIntegral tz `Clock.addUTCTime` Clock.UTCTime (Cal.fromGregorian (toInteger y) (fromEnum m + 1) d) (Clock.secondsToDiffTime (toInteger ((h * 60 + min) * 60 + s))) toCurry (Clock.UTCTime day diff) = let (y,m,d) = Cal.toGregorian day in toCurry (T.addToClockTime (T.TimeDiff 0 0 0 0 0 (round (toRational diff)) 0) (T.toClockTime (T.CalendarTime (fromIntegral y) (toEnum (m - 1)) d 0 0 0 0 undefined undefined undefined 0 undefined))) external_d_C_getClockTime :: Cover -> ConstStore -> Curry_Prelude.C_IO C_ClockTime external_d_C_getClockTime _ _ = toCurry T.getClockTime external_d_C_prim_toCalendarTime :: C_ClockTime -> Cover -> ConstStore -> Curry_Prelude.C_IO C_CalendarTime external_d_C_prim_toCalendarTime ct _ _ = toCurry T.toCalendarTime ct external_d_C_prim_toUTCTime :: C_ClockTime -> Cover -> ConstStore -> C_CalendarTime external_d_C_prim_toUTCTime ct _ _ = toCurry T.toUTCTime ct external_d_C_prim_toClockTime :: C_CalendarTime -> Cover -> ConstStore -> C_ClockTime external_d_C_prim_toClockTime ct _ _ = toCurry T.toClockTime ct curry-libs-v2.2.0/Time.pakcs000066400000000000000000000012171355602362200157220ustar00rootroot00000000000000 prim_time prim_getClockTime prim_time prim_toCalendarTime prim_time prim_toUTCTime prim_time prim_toClockTime curry-libs-v2.2.0/Unsafe.curry000066400000000000000000000215011355602362200163060ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library containing unsafe operations. --- These operations should be carefully used (e.g., for testing or debugging). --- These operations should not be used in application programs! --- --- @author Michael Hanus, Bjoern Peemoeller --- @version September 2013 --- @category general ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module Unsafe ( unsafePerformIO, trace #ifdef __PAKCS__ , spawnConstraint, isVar, identicalVar, isGround, compareAnyTerm , showAnyTerm, showAnyQTerm, showAnyExpression, showAnyQExpression , readsAnyUnqualifiedTerm, readAnyUnqualifiedTerm , readsAnyQTerm, readAnyQTerm , readsAnyQExpression, readAnyQExpression #endif ) where import Char (isSpace) import IO (hPutStrLn, stderr) --- Performs and hides an I/O action in a computation (use with care!). unsafePerformIO :: IO a -> a unsafePerformIO external --- Prints the first argument as a side effect and behaves as identity on the --- second argument. trace :: String -> a -> a trace s x = unsafePerformIO (hPutStrLn stderr s >> return x) #ifdef __PAKCS__ --- Spawns a constraint and returns the second argument. --- This function can be considered as defined by --- `spawnConstraint c x | c = x`. --- However, the evaluation of the constraint and the right-hand side --- are performed concurrently, i.e., a suspension of the constraint --- does not imply a blocking of the right-hand side and the --- right-hand side might be evaluated before the constraint is successfully --- solved. --- Thus, a computation might return a result even if some of the --- spawned constraints are suspended (use the PAKCS option --- `+suspend` to show such suspended goals). spawnConstraint :: Bool -> a -> a spawnConstraint external --- Tests whether the first argument evaluates to a currently unbound --- variable (use with care!). isVar :: _ -> Bool isVar v = prim_isVar $! v prim_isVar :: _ -> Bool prim_isVar external --- Tests whether both arguments evaluate to the identical currently unbound --- variable (use with care!). --- For instance, identicalVar (id x) (fst (x,1)) evaluates to --- True whereas identicalVar x y and --- let x=1 in identicalVar x x evaluate to False identicalVar :: a -> a -> Bool identicalVar x y = (prim_identicalVar $! y) $! x --- let x=1 in identicalVar x x evaluate to False prim_identicalVar :: a -> a -> Bool prim_identicalVar external --- Tests whether the argument evaluates to a ground value --- (use with care!). isGround :: _ -> Bool isGround v = prim_isGround $!! v prim_isGround :: _ -> Bool prim_isGround external --- Comparison of any data terms, possibly containing variables. --- Data constructors are compared in the order of their definition --- in the datatype declarations and recursively in the arguments. --- Variables are compared in some internal order. compareAnyTerm :: a -> a -> Ordering compareAnyTerm external --- Transforms the normal form of a term into a string representation --- in standard prefix notation. --- Thus, showAnyTerm evaluates its argument to normal form. --- This function is similar to the function ReadShowTerm.showTerm --- but it also transforms logic variables into a string representation --- that can be read back by Unsafe.read(s)AnyUnqualifiedTerm. --- Thus, the result depends on the evaluation and binding status of --- logic variables so that it should be used with care! showAnyTerm :: _ -> String showAnyTerm x = prim_showAnyTerm $!! x prim_showAnyTerm :: _ -> String prim_showAnyTerm external --- Transforms the normal form of a term into a string representation --- in standard prefix notation. --- Thus, showAnyQTerm evaluates its argument to normal form. --- This function is similar to the function ReadShowTerm.showQTerm --- but it also transforms logic variables into a string representation --- that can be read back by Unsafe.read(s)AnyQTerm. --- Thus, the result depends on the evaluation and binding status of --- logic variables so that it should be used with care! showAnyQTerm :: _ -> String showAnyQTerm x = prim_showAnyQTerm $!! x prim_showAnyQTerm :: _ -> String prim_showAnyQTerm external --- Transform a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The string might contain logical variable encodings produced by showAnyTerm. --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsAnyUnqualifiedTerm :: [String] -> String -> [(_,String)] readsAnyUnqualifiedTerm [] _ = error "ReadShowTerm.readsAnyUnqualifiedTerm: list of module prefixes is empty" readsAnyUnqualifiedTerm (prefix:prefixes) s = readsAnyUnqualifiedTermWithPrefixes (prefix:prefixes) s readsAnyUnqualifiedTermWithPrefixes :: [String] -> String -> [(_,String)] readsAnyUnqualifiedTermWithPrefixes prefixes s = (prim_readsAnyUnqualifiedTerm $## prefixes) $## s prim_readsAnyUnqualifiedTerm :: [String] -> String -> [(_,String)] prim_readsAnyUnqualifiedTerm external --- Transforms a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The string might contain logical variable encodings produced by --- `showAnyTerm`. readAnyUnqualifiedTerm :: [String] -> String -> _ readAnyUnqualifiedTerm prefixes s = case result of [(term,tail)] -> if all isSpace tail then term else error ("Unsafe.readAnyUnqualifiedTerm: no parse, " ++ "unmatched string after term: " ++ tail) [] -> error "Unsafe.readAnyUnqualifiedTerm: no parse" _ -> error "Unsafe.readAnyUnqualifiedTerm: ambiguous parse" where result = readsAnyUnqualifiedTerm prefixes s --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. --- The string might contain logical variable encodings produced by --- `showAnyQTerm`. --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsAnyQTerm :: String -> [(_,String)] readsAnyQTerm s = prim_readsAnyQTerm $## s prim_readsAnyQTerm :: String -> [(_,String)] prim_readsAnyQTerm external --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. --- The string might contain logical variable encodings produced by --- `showAnyQTerm`. readAnyQTerm :: String -> _ readAnyQTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error "Unsafe.readAnyQTerm: no parse" [] -> error "Unsafe.readAnyQTerm: no parse" _ -> error "Unsafe.readAnyQTerm: ambiguous parse" where result = readsAnyQTerm s --- Transforms any expression (even not in normal form) --- into a string representation --- in standard prefix notation without module qualifiers. --- The result depends on the evaluation and binding status of --- logic variables so that it should be used with care! showAnyExpression :: _ -> String showAnyExpression external --- Transforms any expression (even not in normal form) --- into a string representation --- in standard prefix notation with module qualifiers. --- The result depends on the evaluation and binding status of --- logic variables so that it should be used with care! showAnyQExpression :: _ -> String showAnyQExpression external --- Transforms a string containing an expression in standard prefix notation --- with qualified constructor names into the corresponding expression. --- The string might contain logical variable and defined function --- encodings produced by showAnyQExpression. --- In case of a successful parse, the result is a one element list --- containing a pair of the expression and the remaining unparsed string. readsAnyQExpression :: String -> [(_,String)] readsAnyQExpression s = prim_readsAnyQExpression $## s prim_readsAnyQExpression :: String -> [(_,String)] prim_readsAnyQExpression external --- Transforms a string containing an expression in standard prefix notation --- with qualified constructor names into the corresponding expression. --- The string might contain logical variable and defined function --- encodings produced by showAnyQExpression. readAnyQExpression :: String -> _ readAnyQExpression s = case result of [(term,tail)] -> if all isSpace tail then term else error "Unsafe.readAnyQExpression: no parse" [] -> error "Unsafe.readAnyQExpression: no parse" _ -> error "Unsafe.readAnyQExpression: ambiguous parse" where result = readsAnyQExpression s #endif curry-libs-v2.2.0/Unsafe.kics2000066400000000000000000000007501355602362200161600ustar00rootroot00000000000000import System.IO.Unsafe (unsafePerformIO) import KiCS2Debug (internalError) external_d_C_unsafePerformIO :: Curry_Prelude.C_IO a -> Cover -> ConstStore -> a external_d_C_unsafePerformIO io cd cs = unsafePerformIO (toIO errSupply cd cs io) where errSupply = internalError "Unsafe.unsafePerformIO: ID supply used" external_nd_C_unsafePerformIO :: Curry_Prelude.C_IO a -> IDSupply -> Cover -> ConstStore -> a external_nd_C_unsafePerformIO io s cd cs = unsafePerformIO (toIO s cd cs io) curry-libs-v2.2.0/Unsafe.pakcs000066400000000000000000000035461355602362200162540ustar00rootroot00000000000000 prim_unsafe prim_unsafePerformIO[raw] prim_unsafe prim_spawnConstraint[raw] prim_unsafe prim_isVar prim_unsafe prim_identicalVar prim_unsafe prim_isGround prim_unsafe prim_compareAnyTerm[raw] prim_unsafe prim_showAnyTerm prim_unsafe prim_showAnyQTerm prim_unsafe prim_readsAnyUnqualifiedTerm prim_unsafe prim_readsAnyQTerm prim_unsafe prim_showAnyExpression[raw] prim_unsafe prim_showAnyQExpression[raw] prim_unsafe prim_readsAnyQExpression curry-libs-v2.2.0/VERSION000066400000000000000000000000061355602362200150440ustar00rootroot000000000000001.0.0 curry-libs-v2.2.0/test.sh000077500000000000000000000012751355602362200153230ustar00rootroot00000000000000#!/bin/sh # Shell script to test modules having some properties defined CURRYBIN="../bin" ALLTESTS="ShowS Sort" VERBOSE=no if [ "$1" = "-v" ] ; then VERBOSE=yes fi # use the right Curry system for the tests: PATH=$CURRYBIN:$PATH export PATH # clean up before $CURRYBIN/cleancurry CCOPTS="-m100 -dInt" LOGFILE=xxx$$ if [ $VERBOSE = yes ] ; then $CURRYBIN/curry check $CCOPTS $ALLTESTS if [ $? -gt 0 ] ; then exit 1 fi else $CURRYBIN/curry check $CCOPTS $ALLTESTS > $LOGFILE 2>&1 if [ $? -gt 0 ] ; then echo "ERROR in curry check:" cat $LOGFILE exit 1 fi fi ################ end of tests #################### # Clean: /bin/rm -f $LOGFILE *_PUBLIC.curry TEST*.curry