pax_global_header00006660000000000000000000000064140012765270014516gustar00rootroot0000000000000052 comment=24848f37cd700e35271da515ae5ab0d89a3f97b7 curry-libs-v3.0.0/000077500000000000000000000000001400127652700137775ustar00rootroot00000000000000curry-libs-v3.0.0/.gitignore000066400000000000000000000001601400127652700157640ustar00rootroot00000000000000# intermediate files *~ .cpm .curry Curry_Main_Goal.curry dist *.cabal AllLibraries.curry # documentation CDOC curry-libs-v3.0.0/LICENSE000066400000000000000000000027421400127652700150110ustar00rootroot00000000000000Copyright (c) 2011-2020, 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: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 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 HOLDER 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-v3.0.0/MigrationGuide.md000066400000000000000000000317261400127652700172410ustar00rootroot00000000000000# Curry 2 -> 3 Migration Guide Between version 2 and 3 the standard library has undergone some notable changes, like aligning module and function names more closely with their Haskell equivalents and moving more specialized functionality into separate packages. This migration guide aims to provide a comprehensive outline of the changes to make the transition of existing packages more seamless. In order to find the modules and packages containing a given operation, one should try the [Currygle](https://www-ps.informatik.uni-kiel.de/kics2/currygle/) search tool. ## Standard Library ### Renamed Modules | Old | New | Notes | | ------------- | ----------------------------- | --------------------------- | | `Char` | `Data.Char` | | | `Debug` | `Debug.Trace` | | | `Distribution`| `Curry.Compiler.Distribution` | `rcFileName` in `currypath` | | `Either` | `Data.Either` | | | `Function` | `Data.Function` | | | `GetOpt` | `System.Console.GetOpt` | | | `IO` | `System.IO` | | | `IOExts` | `Data.IORef` | Only includes the `IORef` | | `List` | `Data.List` | | | `Maybe` | `Data.Maybe` | Now using `Monad` instance. | | `ReadNumeric` | `Numeric` | Types changed. | | `ShowS` | `Text.Show` | | ### Moved and Renamed Modules | Old | New | New Package | | ---------------------- | ------------------------------- | --------------- | | `AllSolutions` | `Control.AllSolutions` | `searchtree` | | `AnsiCodes` | `System.Console.ANSI.Codes` | `ansi-terminal` | | `Array` | `Data.Array` | `array` | | `CPNS` | `Network.CPNS` | `cpns` | | `Dequeue` | `Data.Queue` | `queue` | | `Directory` | `System.Directory` | `directory` | | `ErrorState` | `Control.Monad.Trans.Error` | `transformers` | | `FilePath` | `System.FilePath` | `filepath` | | `FiniteMap` | `Data.Map` | `containers` | | `Findall` | `Control.Findall` | `searchtree` | | `FunctionInversion` | `Data.Function.Inversion` | `inversion` | | `Nat` | `Data.Nat` | `peano` | | `NamedSocket` | `Network.NamedSocket` | `cpns` | | `Profile` | `Debug.Profile` | `profiling` | | `Random` | `System.Random` | `random` | | `RedBlackTree` | `Data.RedBlackTree` | `redblacktree` | | `SearchTree` | `Control.SearchTree` | `searchtree` | | `SearchTreeGenerators` | `Control.SearchTree.Generators` | `searchtree` | | `SearchTreeTraversal` | `Control.SearchTree.Traversal` | `searchtree` | | `SCC` | `Data.SCC` | `scc` | | `SetRBT` | `Data.Set.RBTree` | `redblacktree` | | `Socket` | `Network.Socket` | `socket` | | `State` | `Control.Monad.Trans.State` | `transformers` | | `TableRBT` | `Data.Table.RBTree` | `redblacktree` | | `Traversal` | `Data.Traversal` | `traversal` | | `Time` | `Data.Time` | `time` | | `ValueSequence` | `Control.ValueSequence` | `searchtree` | ### Moved Modules | Old | New Package | | ----------------------- | --------------- | | `Combinatorial` | `combinatorial` | | `Control.Monad.Extra` | `extra` | | `Control.Monad.Trans.*` | `transformers` | | `Data.Tuple.Extra` | `extra` | | `Global` | `global` | | `System.Process` | `process` | | `ReadShowTerm` | `read-legacy` | | `Test.*` | `easycheck` | ### Deleted Modules | Old | Notes | | ------------------------- | ---------------------------------------------------- | | `Sort` | | | `FileGoodies` | Migrated to `System.FilePath` and `System.Directory` | | `System` | Split into `System.CPUTime` and `System.Environment` | | `Integer` | Removed, important functions moved to `Prelude`. | | `Float` | Removed, important functions moved to `Prelude`. | | `Read` | Use `Read` instance | ### Renamed Functions #### Prelude | Old | New | | ------------ | -------------- | | `liftIO` | `fmap` | | `mapIO` | `mapM` | | `mapIO_` | `mapM_` | | `showError` | `show` | #### System (previously) | Old | New | Notes | | -------------- | -------------- | -------------------------------------------------------- | | `setEnviron` | `setEnv` | | | `unsetEnviron` | `unsetEnv` | | | `getEnviron` | `getEnv` | `getEnvironment` was added, but has a different purpose. | | `setEnviron` | `setEnv` | | ### Moved and Renamed Functions #### Prelude | Old | New | | ------------ | ---------------------- | | `when` | `Control.Monad.when` | | `unless` | `Control.Monad.unless` | #### Float (previously) | Old | New | | ------------ | ----------------- | | `i2f` | `Prelude.fromInt` | #### FileGoodies (previously) | Old | New | Notes | | ------------------------ | ------------------------------------- | ----------| | `separatorChar` | | removed | | `pathSeparatorChar` | `System.FilePath.pathSeparator` | | | `suffixSeparatorChar` | `System.FilePath.extSeparator` | | | `dirName` | `System.FilePath.takeDirectory` | | | `baseName` | `System.FilePath.takeBaseName` | | | `splitDirectoryBaseName` | `System.FilePath.splitFileName` | | | `stripSuffix` | `System.FilePath.dropExtension` | | | `fileSuffix` | `System.FilePath.takeExtension` | | | `splitBaseName` | `System.FilePath.splitExtension` | | | `splitPath` | `System.FilePath.splitPath` | | | `lookupFileInPath` | `System.Directory.findFileWithSuffix` | | | `getFileInPath` | `System.FilePath.getFileWithSuffix` | | ### Added Functions #### Prelude | New | | -------------- | | `pi` | | `(^)` | | `(<$>)` | | `(<$)` | ## Finite Map Package Note that the explicit ordering function is not necessary anymore. Instead, an `Ord` context is needed. ### Renamed Types and Functions #### Map | Old | New | Notes | | --------------------- | ----------------------- | ----------------------- | | `FM` | `Map` | | | `emptyFM` | `empty` | | | `unitFM` | `singleton` | | | `listToFM` | `fromList` | | | `addToFM` | `insert` | argument order changed! | | `addToFM_C` | `insertWith` | argument order changed! | | `addListToFM` | `insertList` | argument order changed! | | `addListToFM_C` | `insertListWith` | argument order changed! | | `delFromFM` | `delete` | argument order changed! | | `delListFromFM` | `deleteAll` | argument order changed! | | `updFM` | `adjust` | argument order changed! | | `splitFM` | | removed, can be user-defined (split lookup is different) | | `plusFM` | `union` | first two arguments are swapped! | | `plusFM_C` | `unionWith` | | | `minusFM` | `difference` | | | `intersectFM` | `intersection` | | | `intersectFM_C` | `intersectionWith` | | | `foldFM` | `foldrWithKey` | | | `mapFM` | `mapWithKey` | | | `filterFM` | `filterWithKey` | | | `sizeFM` | `size` | | | `eqFM` | | Map has "Eq" context instead | | `isEmptyFM` | `null` | | | `elemFM` | `member` | argument order changed! | | `lookupFM` | `lookup` | argument order changed! | | `lookupWithDefaultFM` | `findWithDefault` | argument order changed! | | `keyOrder` | | removed, because "Ord" context is used now | | `fmToList` | `toList` | | | `keysFM` | `keys` | | | `eltsFM` | `elems` | | | `fmSortBy` | `sortWithMap` | Will sort given by "<" of "Ord" context | | `minFM` | `lookupMin` | | | `maxFM` | `lookupMax` | | | `fmToListPreOrder` | `toPreOrderList` | | #### Set | Old | New | | ------------ | -------------- | | `FiniteSet` | `Set` | | `emptySet` | `empty` | | `mkSet` | `fromList` | | `isEmptySet` | `null` | | `elementOf` | `member` | | `minusSet` | `difference` | | `setToList` | `toList` | | `union` | `union` | ## Directory Package ### Renamed Functions | Old | New | | ------------ | -------------- | | `fileSize` | `getFileSize` | ## Transformers Package ### Renamed Functions #### State | Old | New | | -------------- | -------------------------- | | `bindS` | Monad instance, `(>>=)` | | `bindS_` | Monad instance, `(>>)` | | `returnS` | Monad instance, `return` | | `getS` | `get` | | `putS` | `put` | | `modifyS` | `modify` | | `sequenceS` | `sequence` | | `sequenceS_` | `sequence_` | | `mapS` | `mapM` | | `mapS_` | `mapM_` | | `liftS` | `fmap` | | `liftM` | `fmap` | | `liftS2` | `liftM2` | #### ErrorState | Old | New | | -------------- | -------------------------------- | | `returnES` | Monad instance, `return` | | `>+=` | Monad instance, `(>>=)` | | `>+` | `(>>)` | | `getS` | `lift . get` | | `putS` | `lift . put` | | `modifyS` | `lift . modify` | | `mapS` | `mapM` | | `<*>,<*,` | `Applicative instance` | ### Moved and Renamed Functions #### ErrorState | Old | New | New Package | | -------------- | -------------------------------- | ----------- | | `concatMapES` | `Control.Monad.Extra.concatMapM` | `extra` | | `mapAccumES` | `Control.Monad.Extra.mapAccumM` | `extra` | ## Socket Package ### Renamed Functions | Old | New | | -------------- | -------- | | `sClose` | `close` | | `socketAccept` | `accept` | ## RedBlackTree Package ### Renamed Functions | Old | New | | -------------- | -------- | | `tree2list` | `toList` | curry-libs-v3.0.0/README.md000066400000000000000000000015251400127652700152610ustar00rootroot00000000000000Curry Base Libraries ==================== This repository contains the standard libraries of Curry distributions like [PAKCS](https://www.informatik.uni-kiel.de/~pakcs/) or [KiCS2](https://www-ps.informatik.uni-kiel.de/kics2/). The libraries in this package can be used in these Curry systems without the use of the Curry Package Manager. Since the structure of this base repository is similar to other Curry packages, the dependency on this package can be specified in other Curry packages. This is reasonable to specify the dependency on base libraries in a Curry package. *Technical note:* The file `VERSION` must contain the version number of this package as specified in the `version` field of `package.json`. This file is used during the build process of Curry systems, like PAKCS or KICS2, in order to avoid reading and parsing the JSON file. curry-libs-v3.0.0/VERSION000066400000000000000000000000061400127652700150430ustar00rootroot000000000000003.0.0 curry-libs-v3.0.0/package.json000066400000000000000000000015601400127652700162670ustar00rootroot00000000000000{ "name": "base", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Base libraries for Curry systems", "description": "This package contains the base libraries which are directly distributed with Curry systems like PAKCS or KiCS2.", "category": [ "Programming" ], "compilerCompatibility": { "kics2": ">= 3.0.0, < 4.0.0", "pakcs": ">= 3.0.0, < 4.0.0" }, "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { }, "testsuite": { "src-dir": "test", "modules": [ "TestPrelude", "TestDataChar", "TestList", "TestIORefs", "TestFunction", "TestEnvironment", "TestTextShow" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry/curry-libs.git", "tag": "$version" } } curry-libs-v3.0.0/src/000077500000000000000000000000001400127652700145665ustar00rootroot00000000000000curry-libs-v3.0.0/src/Control/000077500000000000000000000000001400127652700162065ustar00rootroot00000000000000curry-libs-v3.0.0/src/Control/Applicative.curry000066400000000000000000000021011400127652700215270ustar00rootroot00000000000000module Control.Applicative ( Applicative(..), liftA, liftA3, when , sequenceA, sequenceA_ ) where --- Lift a function to actions. --- This function may be used as a value for `fmap` in a `Functor` instance. liftA :: Applicative f => (a -> b) -> f a -> f b liftA f a = pure f <*> a --- Lift a ternary function to actions. liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d liftA3 f a b c = liftA2 f a b <*> c -- | Conditional execution of 'Applicative' expressions. when :: (Applicative f) => Bool -> f () -> f () when p s = if p then s else pure () --- Evaluate each action in the list from left to right, and --- collect the results. For a version that ignores the results --- see 'sequenceA_'. sequenceA :: (Applicative f) => [f a] -> f [a] sequenceA [] = pure [] sequenceA (x:xs) = (:) <$> x <*> sequenceA xs --- Evaluate each action in the structure from left to right, and --- ignore the results. For a version that doesn't ignore the results --- see 'sequenceA'. sequenceA_ :: (Applicative f) => [f a] -> f () sequenceA_ = foldr (*>) (pure ()) curry-libs-v3.0.0/src/Control/Monad.curry000066400000000000000000000062741400127652700203430ustar00rootroot00000000000000module Control.Monad ( Functor(..), Applicative(..), Monad(..) , filterM, (>=>), (<=<), forever, mapAndUnzipM, zipWithM , zipWithM_, foldM, foldM_, replicateM, replicateM_ , when, unless, liftM3, join, void ) where import Control.Applicative --- This generalizes the list-based 'filter' function. filterM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] filterM p = foldr (\ x -> liftA2 (\ flg -> if flg then (x:) else id) (p x)) (pure []) infixr 1 <=<, >=> --- Left-to-right composition of Kleisli arrows. (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) f >=> g = \x -> f x >>= g --- Right-to-left composition of Kleisli arrows. @('>=>')@, with the arguments --- flipped. (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) (<=<) = flip (>=>) --- Repeat an action indefinitely. forever :: (Applicative f) => f a -> f b forever a = let a' = a *> a' in a' -- ----------------------------------------------------------------------------- -- Other monad functions --- The 'mapAndUnzipM' function maps its first argument over a list, returning --- the result as a pair of lists. This function is mainly used with complicated --- data structures or a state-transforming monad. mapAndUnzipM :: (Applicative m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) mapAndUnzipM f xs = unzip <$> sequenceA (map f xs) --- The 'zipWithM' function generalizes 'zipWith' to --- arbitrary applicative functors. zipWithM :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c] zipWithM f xs ys = sequenceA (zipWith f xs ys) --- 'zipWithM_' is the extension of 'zipWithM' which ignores the final result. zipWithM_ :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m () zipWithM_ f xs ys = sequenceA_ (zipWith f xs ys) --- The 'foldM' function is analogous to 'foldl', except that its result is --- encapsulated in a monad. foldM :: (Monad m) => (b -> a -> m b) -> b -> [a] -> m b foldM f z0 xs = foldr f' return xs z0 where f' x k z = f z x >>= k --- Like 'foldM', but discards the result. foldM_ :: (Monad m) => (b -> a -> m b) -> b -> [a] -> m () foldM_ f a xs = foldM f a xs >> return () --- @'replicateM' n act@ performs the action @n@ times, --- gathering the results. replicateM :: (Applicative m) => Int -> m a -> m [a] replicateM cnt0 f = loop cnt0 where loop cnt | cnt <= 0 = pure [] | otherwise = liftA2 (:) f (loop (cnt - 1)) --- Like 'replicateM', but discards the result. replicateM_ :: (Applicative m) => Int -> m a -> m () replicateM_ cnt0 f = loop cnt0 where loop cnt | cnt <= 0 = pure () | otherwise = f *> loop (cnt - 1) --- The reverse of 'when'. unless :: (Applicative f) => Bool -> f () -> f () unless p s = if p then pure () else s liftM3 :: Monad m => (a -> b -> c -> d) -> m a -> m b -> m c -> m d liftM3 f ma mb mc = do a <- ma b <- mb c <- mc return (f a b c) --- Removes one level of monadic structure, i.e. 'flattens' the monad. join :: Monad m => m (m a) -> m a join = (>>= id) --- Ignores the result of the evaluation. void :: Functor f => f a -> f () void = fmap (const ()) curry-libs-v3.0.0/src/Curry/000077500000000000000000000000001400127652700156725ustar00rootroot00000000000000curry-libs-v3.0.0/src/Curry/Compiler/000077500000000000000000000000001400127652700174445ustar00rootroot00000000000000curry-libs-v3.0.0/src/Curry/Compiler/Distribution.curry000066400000000000000000000037271400127652700232220ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- 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 November 2020 -------------------------------------------------------------------------------- module Curry.Compiler.Distribution ( curryCompiler, curryCompilerMajorVersion, curryCompilerMinorVersion , curryCompilerRevisionVersion , curryRuntime, curryRuntimeMajorVersion, curryRuntimeMinorVersion , baseVersion, installDir ) where ----------------------------------------------------------------- -- 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 :: String installDir external ----------------------------------------------------------- curry-libs-v3.0.0/src/Curry/Compiler/Distribution.kics2000066400000000000000000000024621400127652700230640ustar00rootroot00000000000000import 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-v3.0.0/src/Curry/Compiler/Distribution.pakcs.pl000066400000000000000000000020761400127652700235650ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module Distribution % 'Curry.Compiler.Distribution.curryCompiler'(CS) :- atom2String(pakcs,CS). 'Curry.Compiler.Distribution.curryCompilerMajorVersion'(V) :- compilerMajorVersion(V). 'Curry.Compiler.Distribution.curryCompilerMinorVersion'(V) :- compilerMinorVersion(V). 'Curry.Compiler.Distribution.curryCompilerRevisionVersion'(V) :- compilerRevisionVersion(V). 'Curry.Compiler.Distribution.curryRuntime'(PrologS) :- prolog(Prolog), atom2String(Prolog,PrologS). 'Curry.Compiler.Distribution.curryRuntimeMajorVersion'(V) :- prologMajorVersion(V). 'Curry.Compiler.Distribution.curryRuntimeMinorVersion'(V) :- prologMinorVersion(V). 'Curry.Compiler.Distribution.baseVersion'(BVS) :- baseVersion(BVA), atom2String(BVA,BVS). 'Curry.Compiler.Distribution.installDir'(PHS) :- installDir(PH) -> atom2String(PH,PHS) ; raise_exception('Curry.Compiler.Distribution.installDir: cannot determine installation directory!'). curry-libs-v3.0.0/src/Data/000077500000000000000000000000001400127652700154375ustar00rootroot00000000000000curry-libs-v3.0.0/src/Data/Char.curry000066400000000000000000000042161400127652700174050ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful functions on characters. --- --- @author Michael Hanus, Bjoern Peemoeller --- @version January 2015 --- @category general ------------------------------------------------------------------------------ module Data.Char ( isAscii, isLatin1, isAsciiUpper, isAsciiLower, isControl , isUpper, isLower, isAlpha, isDigit, isAlphaNum , isBinDigit, isOctDigit, isHexDigit, isSpace , toUpper, toLower, digitToInt, intToDigit , ord, chr ) where --- Returns true if the argument is an ASCII character. 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' --- 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-v3.0.0/src/Data/Either.curry000066400000000000000000000032351400127652700177500ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Library with some useful operations for the `Either` data type. --- --- @author Bjoern Peemoeller --- @version November 2020 --- @category general --- ---------------------------------------------------------------------------- {-# OPTIONS_FRONTEND -Wno-incomplete-patterns #-} module Data.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-v3.0.0/src/Data/Function.curry000066400000000000000000000015531400127652700203160ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This module provides some utility functions for function application. --- --- @author Bjoern Peemoeller --- @version July 2013 --- ---------------------------------------------------------------------------- module Data.Function (fix, on) where --- `fix f` is the least fixed point of the function `f`, --- i.e. the least defined `x` such that `f x = x`. fix :: (a -> a) -> a fix f = let x = f x in x --- `on f g x y` applies the binary operation `f` to the results of --- applying operation `g` to two arguments `x` and `y`. --- Thus, it transforms two inputs and combines the outputs. --- --- (*) `on` f = \x y -> f x * f y --- --- A typical usage of this operation is: --- --- sortBy (compare `on` fst) on :: (b -> b -> c) -> (a -> b) -> a -> a -> c on op f x y = f x `op` f y curry-libs-v3.0.0/src/Data/Functor/000077500000000000000000000000001400127652700170575ustar00rootroot00000000000000curry-libs-v3.0.0/src/Data/Functor/Identity.curry000066400000000000000000000016701400127652700217420ustar00rootroot00000000000000----------------------------------------------------------------------------- --- This simple module defines the identify functor and monad and --- has been adapted from the same Haskell module (by Andy Gill). --- It defines a a trivial type constructor `Identity` which --- can be used with functions parameterized by functor or monad classes --- or as a simple base to specialize monad transformers. ----------------------------------------------------------------------------- module Data.Functor.Identity where --- The `Identity` type constructor with `Functor`, `Applicative`, --- and `Monad` instances. newtype Identity a = Identity { runIdentity :: a } deriving (Eq, Ord, Read, Show) instance Functor Identity where fmap f (Identity a) = Identity $ f a instance Applicative Identity where pure = Identity Identity f <*> Identity a = Identity (f a) instance Monad Identity where m >>= k = k (runIdentity m) return a = Identity a curry-libs-v3.0.0/src/Data/IORef.curry000066400000000000000000000023661400127652700175000ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful extensions to the IO monad. --- --- @author Michael Hanus --- @version January 2017 --- @category general ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) where --- Mutable variables containing values of some type. --- The values are not evaluated when they are assigned to an IORef. #ifdef __PAKCS__ data IORef a = IORef a -- precise structure internally defined #else external data IORef _ -- precise structure internally defined #endif --- Creates a new IORef with an initial value. newIORef :: a -> IO (IORef a) newIORef external --- Reads the current value of an IORef. readIORef :: IORef a -> IO a readIORef ref = prim_readIORef $# ref prim_readIORef :: IORef a -> IO a prim_readIORef external --- Updates the value of an IORef. writeIORef :: IORef a -> a -> IO () writeIORef ref val = (prim_writeIORef $# ref) val prim_writeIORef :: IORef a -> a -> IO () prim_writeIORef external --- Modify the value of an IORef. modifyIORef :: IORef a -> (a -> a) -> IO () modifyIORef ref f = readIORef ref >>= writeIORef ref . f curry-libs-v3.0.0/src/Data/IORef.kics2000066400000000000000000000105321400127652700173410ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import Data.IORef ----------------------------------------------------------------------- -- 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-v3.0.0/src/Data/IORef.pakcs000066400000000000000000000006631400127652700174330ustar00rootroot00000000000000 prim_newIORef[raw] prim_readIORef[raw] prim_writeIORef[raw] curry-libs-v3.0.0/src/Data/IORef.pakcs.pl000066400000000000000000000037501400127652700200450ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prolog implementation of builtins of module Data.IORef: % % New IORefs are represented as mutable values. The "share" constructor % is put around to be conform with the remaining implementation where % all mutables are "marked" by this constructor. ?- block prim_newIORef(?,?,-,?). prim_newIORef(V,partcall(1,exec_newIORef,[V]),E,E). ?- block exec_newIORef(?,?,?,-,?). exec_newIORef(Val,_,'$io'('IOExts.IORef'(share(MutVal))),E0,E) :- var(Val), !, create_mutable('$eval'(Val),MutVal), E0=E. exec_newIORef(Val,_,'$io'('IOExts.IORef'(share(MutVal))),E0,E) :- create_mutable(Val,MutVal), E0=E. % When an IORef is read and its value is not evaluated, the current value % is wrapped into a new mutable in order to implement sharing % of evaluations of IORefs. The current IORef is updated so that % it refers to the new mutable (without this indirection, there is % a risk of creating cyclic structures when the IORef itself is updated). ?- block prim_readIORef(?,?,-,?). prim_readIORef(R,partcall(1,exec_readIORef,[R]),E,E). ?- block exec_readIORef(?,?,?,-,?). exec_readIORef(RIORef,_,'$io'(V),E0,E) :- user:derefRoot(RIORef,'IOExts.IORef'(share(MutVal))), get_mutable(Val,MutVal), (Val='$eval'(V) -> true ; create_mutable(Val,MutV), update_mutable(share(MutV),MutVal), V=share(MutV)), E0=E. % Assign a new value to an IORef: ?- block prim_writeIORef(?,?,?,-,?). prim_writeIORef(R,V,partcall(1,exec_writeIORef,[V,R]),E,E). ?- block exec_writeIORef(?,?,?,?,-,?). exec_writeIORef(RIORef,Val,_,R,E0,E) :- user:derefRoot(RIORef,IORef), prim_writeIORef_exec(IORef,Val,R), E0=E. prim_writeIORef_exec('IOExts.IORef'(share(MutVal)),Val,'$io'('Prelude.()')) :- var(Val), !, update_mutable('$eval'(Val),MutVal). prim_writeIORef_exec('IOExts.IORef'(share(MutVal)),Val,'$io'('Prelude.()')) :- update_mutable(Val,MutVal). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-libs-v3.0.0/src/Data/List.curry000066400000000000000000000347711400127652700174540ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful operations on lists. --- --- @author Michael Hanus, Bjoern Peemoeller --- @version November 2020 --- @category general ------------------------------------------------------------------------------ {-# OPTIONS_FRONTEND -Wno-incomplete-patterns #-} module Data.List ( elemIndex, elemIndices, find, findIndex, findIndices , nub, nubBy, delete, deleteBy, (\\), union, intersect , intersperse, intercalate, transpose, diagonal, permutations, partition , group, groupBy, splitOn, split, inits, tails, replace , isPrefixOf, isSuffixOf, isInfixOf , sort, sortBy, insertBy , unionBy, intersectBy , last, init , sum, product, maximum, minimum, maximumBy, minimumBy , scanl, scanl1, scanr, scanr1 , mapAccumL, mapAccumR , cycle, unfoldr ) where import Data.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) --- The default sorting operation, mergeSort, with standard ordering `<=`. sort :: Ord a => [a] -> [a] sort = sortBy (<=) --- Sorts a list w.r.t. an ordering relation by the insertion method. sortBy :: (a -> a -> Bool) -> [a] -> [a] sortBy = mergeSortBy --- Bottom-up mergesort with ordering as first parameter. mergeSortBy :: (a -> a -> Bool) -> [a] -> [a] mergeSortBy leq zs = mergeLists (genRuns zs) where -- generate runs of length 2: genRuns [] = [] genRuns [x] = [[x]] genRuns (x1:x2:xs) | leq x1 x2 = [x1,x2] : genRuns xs | otherwise = [x2,x1] : genRuns xs -- merge the runs: mergeLists [] = [] mergeLists [x] = x mergeLists (x1:x2:xs) = mergeLists (merge leq x1 x2 : mergePairs xs) mergePairs [] = [] mergePairs [x] = [x] mergePairs (x1:x2:xs) = merge leq x1 x2 : mergePairs xs --- Merges two lists with respect to an ordering predicate. merge :: (a -> a -> Bool) -> [a] -> [a] -> [a] merge _ [] ys = ys merge _ (x:xs) [] = x : xs merge leq (x:xs) (y:ys) | leq x y = x : merge leq xs (y:ys) | otherwise = y : merge leq (x:xs) ys --- Inserts an object into a list according to an ordering relation. --- @param le - an ordering relation (e.g., less-or-equal) --- @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-v3.0.0/src/Data/Maybe.curry000066400000000000000000000034211400127652700175620ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Library with some useful functions on the `Maybe` datatype. --- --- @author Frank Huch, Bernd Brassel, Bjoern Peemoeller --- @version October 2014 --- @category general --- ---------------------------------------------------------------------------- module Data.Maybe ( Maybe (..) , maybe , isJust, isNothing , fromJust, fromMaybe , listToMaybe, maybeToList , catMaybes, mapMaybe ) where --- 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 curry-libs-v3.0.0/src/Debug/000077500000000000000000000000001400127652700156145ustar00rootroot00000000000000curry-libs-v3.0.0/src/Debug/Trace.curry000066400000000000000000000032521400127652700177420ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains some useful operation for debugging programs. --- --- @author Bjoern Peemoeller --- @version September 2014 --- @category general ------------------------------------------------------------------------------ module Debug.Trace ( trace, traceId, traceShow, traceShowId, traceIO , assert, assertIO ) where import Control.Monad (unless) import System.IO (hPutStrLn, stderr) import System.IO.Unsafe (unsafePerformIO) --- Prints the first argument as a side effect and behaves as identity on the --- second argument. 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-v3.0.0/src/Numeric.curry000066400000000000000000000066461400127652700172720ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some functions for reading and converting numeric tokens. -- --- @author Michael Hanus, Frank Huch, Bjoern Peemoeller --- @version November 2016 --- @category general ------------------------------------------------------------------------------ module Numeric ( readInt, readNat, readHex, readOct, readBin ) where import Data.Char ( digitToInt, isBinDigit, isOctDigit , isDigit, isHexDigit, isSpace) import Data.Maybe --- Read a (possibly negative) integer as a first token in a string. --- The string might contain leadings blanks and the integer is read --- up to the first non-digit. --- On success returns `[(v,s)]`, where `v` is the value of the integer --- and `s` is the remaing string without the integer token. readInt :: ReadS Int readInt str = case dropWhile isSpace str of [] -> [] '-':str1 -> map (\(n,s) -> (-n, s)) (readNat str1) str1 -> readNat str1 --- Read a natural number as a first token in a string. --- The string might contain leadings blanks and the number is read --- up to the first non-digit. --- On success returns `[(v,s)]`, where `v` is the value of the number --- and s is the remaing string without the number token. readNat :: ReadS Int readNat str = maybeToList $ readNumPrefix (dropWhile isSpace str) Nothing 10 isDigit digitToInt --- Read a hexadecimal number as a first token in a string. --- The string might contain leadings blanks and the number is read --- up to the first non-hexadecimal digit. --- On success returns `[(v,s)]`, where `v` is the value of the number --- and s is the remaing string without the number token. readHex :: ReadS Int readHex l = maybeToList $ readNumPrefix (dropWhile isSpace l) Nothing 16 isHexDigit digitToInt --- Read an octal number as a first token in a string. --- The string might contain leadings blanks and the number is read --- up to the first non-octal digit. --- On success returns `[(v,s)]`, where `v` is the value of the number --- and s is the remaing string without the number token. readOct :: ReadS Int readOct l = maybeToList $ readNumPrefix (dropWhile isSpace l) Nothing 8 isOctDigit digitToInt --- Read a binary number as a first token in a string. --- The string might contain leadings blanks and the number is read --- up to the first non-binary digit. --- On success returns `[(v,s)]`, where `v` is the value of the number --- and s is the remaing string without the number token. readBin :: ReadS Int readBin l = maybeToList $ readNumPrefix (dropWhile isSpace l) Nothing 2 isBinDigit digitToInt --- Read an integral number prefix where the value of an already read number --- prefix is provided as the second argument. --- The third argument is the base, the fourth argument --- is a predicate to distinguish valid digits, and the fifth argument converts --- valid digits into integer values. readNumPrefix :: String -> Maybe Int -> Int -> (Char -> Bool) -> (Char -> Int) -> Maybe (Int, String) readNumPrefix [] Nothing _ _ _ = Nothing readNumPrefix [] (Just n) _ _ _ = Just (n,"") readNumPrefix (c:cs) (Just n) base isdigit valueof | isdigit c = readNumPrefix cs (Just (base*n+valueof c)) base isdigit valueof | otherwise = Just (n,c:cs) readNumPrefix (c:cs) Nothing base isdigit valueof | isdigit c = readNumPrefix cs (Just (valueof c)) base isdigit valueof | otherwise = Nothing curry-libs-v3.0.0/src/Prelude.curry000066400000000000000000001672471400127652700172750ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- The standard prelude of Curry with type classes. --- All exported functions, data types, type classes --- and methods defined in this module are always --- available in any Curry program. -------------------------------------------------------------------------------- {-# LANGUAGE CPP #-} {-# OPTIONS_FRONTEND -Wno-incomplete-patterns -Wno-overlapping #-} module Prelude ( -- * Basic Datatypes Char (..), Int (..), Float (..) --++ , () (..), (,) (..), (,,) (..), (,,,) (..), (,,,,) (..) --++ , [] (..), (->) (..) , Bool (..), Ordering (..), Maybe (..), Either (..) -- * Type Classes , Data(..), (/==), Eq (..) , Ord (..) , Show (..), ShowS, shows, showChar, showString, showParen , Read (..), ReadS, reads, readParen, read, lex , Bounded (..), Enum (..) -- ** Numerical Typeclasses , Num (..), Fractional (..), Real (..) , Integral (..), even, odd, fromIntegral, realToFrac, (^) , RealFrac (..), Floating (..), Monoid (..) -- Type Constructor Classes , Functor (..), Applicative (..), Alternative (..) , Monad (..), MonadFail(..) , liftM2, sequence, sequence_, mapM, mapM_ -- * Operations on Characters , isUpper, isLower, isAlpha, isDigit, isAlphaNum , isBinDigit, isOctDigit, isHexDigit, isSpace , ord, chr , String, lines, unlines, words, unwords -- * Operations on Lists , 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, reverse, and, or, any, all, elem, notElem, lookup, (<$>) -- * Evaluation , ($), ($!), ($!!), ($#), ($##), seq, ensureNotFree, ensureSpine , normalForm, groundNormalForm -- * Other Functions , (.), id, const, asTypeOf, curry, uncurry, flip, until , (&&), (||), not, otherwise, ifThenElse, maybe, either, fst, snd , failed, error -- * IO-Type and Operations , IO, getChar, getLine, putChar, putStr, putStrLn, print , FilePath, readFile, writeFile, appendFile , IOError (..), userError, ioError, catch -- * Constraint Programming , Success, success, solve, doSolve, (=:=), (=:<=), constrEq #ifdef __PAKCS__ , (=:<<=) #endif , (&), (&>) -- * Non-determinism , (?), anyOf, unknown -- * Internal Functions , apply, cond #ifdef __PAKCS__ , letrec, failure #endif , DET, PEVAL ) where infixr 9 . infixl 9 !! infixl 7 *, /, `div`, `mod`, `quot`, `rem` infixl 6 +, - infixr 5 ++ --++ The (:) operator is built-in syntax with the following fixity: --++ infixr 5 : infix 4 ==, /=, <, >, <=, >= infix 4 =:=, =:<=, ===, /== #ifdef __PAKCS__ infix 4 =:<<= #endif infix 4 `elem`, `notElem` infixl 4 <$, <$>, <*>, <*, *> infixl 3 <|> infixr 3 && infixr 2 || infixl 1 >>, >>= infixr 0 ?, $, $!, $!!, $#, $##, `seq`, &, &> external data Char external data Int external data Float data Bool = False | True data Ordering = LT | EQ | GT ------------------------------------------------------------------------------ --++ data () = () --++ data (a, b) = (a, b) --++ data (a, b, c) = (a, b, c) --++ data (a, b, c, d) = (a, b, c, d) --++ data (a, b, c, d, e) = (a, b, c, d, e) --++ ... --++ data [a] = [] | a : [a] --++ data (->) a b class Data a where (===) :: a -> a -> Bool aValue :: a --- The negation of strict equality. (/==) :: Data a => a -> a -> Bool x /== y = not (x ===y) instance Data Char where (===) = (==) aValue = aValueChar instance Data Int where (===) = (==) aValue = aValueInt instance Data Float where (===) = (==) aValue = aValueFloat instance Data a => Data [a] where [] === [] = True [] === (_:_) = False (_:_) === [] = False (x:xs) === (y:ys) = x === y && xs === ys aValue = [] ? (aValue:aValue) instance Data () where () === () = True aValue = () instance (Data a, Data b) => Data (a, b) where (a1, b1) === (a2, b2) = a1 === a2 && b1 === b2 aValue = (aValue, aValue) instance (Data a, Data b, Data c) => Data (a, b, c) where (a1, b1, c1) === (a2, b2, c2) = a1 === a2 && b1 === b2 && c1 === c2 aValue = (aValue, aValue, aValue) instance (Data a, Data b, Data c, Data d) => Data (a, b, c, d) where (a1, b1, c1, d1) === (a2, b2, c2, d2) = a1 === a2 && b1 === b2 && c1 === c2 && d1 === d2 aValue = (aValue, aValue, aValue, aValue) instance (Data a, Data b, Data c, Data d, Data e) => Data (a, b, c, d, e) where (a1, b1, c1, d1, e1) === (a2, b2, c2, d2, e2) = a1 === a2 && b1 === b2 && c1 === c2 && d1 === d2 && e1 === e2 aValue = (aValue, aValue, aValue, aValue, aValue) instance (Data a, Data b, Data c, Data d, Data e, Data f) => Data (a, b, c, d, e, f) where (a1, b1, c1, d1, e1, f1) === (a2, b2, c2, d2, e2, f2) = a1 === a2 && b1 === b2 && c1 === c2 && d1 === d2 && e1 === e2 && f1 === f2 aValue = (aValue, aValue, aValue, aValue, aValue, aValue) instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => Data (a, b, c, d, e, f, g) where (a1, b1, c1, d1, e1, f1, g1) === (a2, b2, c2, d2, e2, f2, g2) = a1 === a2 && b1 === b2 && c1 === c2 && d1 === d2 && e1 === e2 && f1 === f2 && g1 === g2 aValue = (aValue, aValue, aValue, aValue, aValue, aValue, aValue) -- Value generator for integers. aValueInt :: Int aValueInt = genPos 1 ? 0 ? 0 - genPos 1 where genPos n = n ? genPos (2 * n) ? genPos (2 * n + 1) -- Value generator for chars. aValueChar :: Char aValueChar = foldr1 (?) [minBound .. maxBound] -- Value generator for floats. -- Since there is no good way to enumerate floats, a free variable -- is returned. aValueFloat :: Float aValueFloat = x where x free ------------------------------------------------------------------------------ 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 () 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 [a] where [] == [] = True [] == (_:_) = False (_:_) == [] = False (x:xs) == (y:ys) = x == y && xs == ys instance Eq Bool where False == False = True False == True = False True == False = False True == True = True instance Eq Ordering where LT == LT = True LT == EQ = False LT == GT = False EQ == LT = False EQ == EQ = True EQ == GT = False GT == LT = False GT == EQ = False GT == GT = True -- Equality on characters. eqChar :: Char -> Char -> Bool #ifdef __KICS2__ eqChar external #elif defined(__PAKCS__) eqChar x y = (prim_eqChar $# y) $# x prim_eqChar :: Char -> Char -> Bool prim_eqChar external #endif -- Equality on integers. eqInt :: Int -> Int -> Bool #ifdef __KICS2__ eqInt external #elif defined(__PAKCS__) eqInt x y = (prim_eqInt $# y) $# x prim_eqInt :: Int -> Int -> Bool prim_eqInt external #endif -- Equality on floating point numbers. eqFloat :: Float -> Float -> Bool #ifdef __KICS2__ eqFloat external #elif defined(__PAKCS__) eqFloat x y = (prim_eqFloat $# y) $# x prim_eqFloat :: Float -> Float -> Bool prim_eqFloat external #endif class Eq a => Ord a where compare :: a -> a -> Ordering (<), (>), (<=), (>=) :: a -> a -> Bool min, max :: a -> a -> a compare x y | x == y = EQ | x <= y = LT | otherwise = GT x < y = x <= y && x /= y x > y = not (x <= y) x <= y = compare x y == EQ || compare x y == LT x >= y = y <= x 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 () 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') instance Ord a => Ord [a] where [] <= [] = True (_:_) <= [] = False [] <= (_:_) = True (x:xs) <= (y:ys) | x == y = xs <= ys | otherwise = x < y instance Ord Bool where False <= False = True False <= True = True True <= False = False True <= True = True instance Ord Ordering where LT <= LT = True LT <= EQ = True LT <= GT = True EQ <= LT = False EQ <= EQ = True EQ <= GT = True GT <= LT = False GT <= EQ = False GT <= GT = True -- Compares two characters. ltEqChar :: Char -> Char -> Bool #ifdef __KICS2__ ltEqChar external #elif defined(__PAKCS__) ltEqChar x y = (prim_ltEqChar $# y) $# x prim_ltEqChar :: Char -> Char -> Bool prim_ltEqChar external #endif -- Compares two integers. ltEqInt :: Int -> Int -> Bool #ifdef __KICS2__ ltEqInt external #elif defined(__PAKCS__) ltEqInt x y = (prim_ltEqInt $# y) $# x prim_ltEqInt :: Int -> Int -> Bool prim_ltEqInt external #endif -- Compares two floating point numbers. ltEqFloat :: Float -> Float -> Bool #ifdef __KICS2__ ltEqFloat external #elif defined(__PAKCS__) ltEqFloat x y = (prim_ltEqFloat $# y) $# x prim_ltEqFloat :: Float -> Float -> Bool prim_ltEqFloat external #endif type ShowS = String -> String class Show a where show :: a -> String showsPrec :: Int -> a -> ShowS showList :: [a] -> ShowS show x = shows x "" showsPrec _ x s = show x ++ s showList = showListDefault instance Show Char where showsPrec _ c = showString (showCharLiteral c) showList cs | null cs = showString "\"\"" | otherwise = showString (showStringLiteral cs) instance Show Int where showsPrec = showSigned (showString . showIntLiteral) instance Show Float where showsPrec = showSigned (showString . showFloatLiteral) 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 [a] where showsPrec _ = showList instance Show Bool where showsPrec _ False = showString "False" showsPrec _ True = showString "True" instance Show Ordering where showsPrec _ LT = showString "LT" showsPrec _ EQ = showString "EQ" showsPrec _ GT = showString "GT" shows :: Show a => a -> ShowS shows = showsPrec 0 showChar :: Char -> ShowS showChar = (:) showString :: String -> ShowS showString str s = foldr showChar s str showListDefault :: Show a => [a] -> ShowS showListDefault [] s = "[]" ++ s showListDefault (x:xs) s = '[' : shows x (showl xs) where showl [] = ']' : s showl (y:ys) = ',' : shows y (showl ys) showParen :: Bool -> ShowS -> ShowS showParen b s = if b then showChar '(' . s . showChar ')' else s 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 ')' -- Returns the string representation of a character. showCharLiteral :: Char -> String showCharLiteral x = prim_showCharLiteral $## x prim_showCharLiteral :: Char -> String prim_showCharLiteral external -- Returns the string representation of a string. showStringLiteral :: String -> String showStringLiteral x = prim_showStringLiteral $## x prim_showStringLiteral :: String -> String prim_showStringLiteral external -- Returns the string representation of an integer. showIntLiteral :: Int -> String showIntLiteral x = prim_showIntLiteral $## x prim_showIntLiteral :: Int -> String prim_showIntLiteral external -- Returns the string representation of a floating point number. showFloatLiteral :: Float -> String showFloatLiteral x = prim_showFloatLiteral $## x prim_showFloatLiteral :: Float -> String prim_showFloatLiteral external type ReadS a = String -> [(a, String)] class Read a where readsPrec :: Int -> ReadS a readList :: ReadS [a] readList = readListDefault 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 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 [(fromInt i, t) | (i, t) <- readNatLiteral x] else readFloatLiteral x instance Read () where readsPrec _ = readParen False (\r -> [ ((), t) | ("(", s) <- lex r , (")", t) <- lex s ]) 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 ]) instance Read a => Read [a] where readsPrec _ = readList instance Read Bool where readsPrec _ r = readParen False (\s -> [(False, t) | ("False", t) <- lex s]) r ++ readParen False (\s -> [(True, t) | ("True", t) <- lex s]) r instance Read Ordering where readsPrec _ r = readParen False (\s -> [(LT, t) | ("LT", t) <- lex s]) r ++ readParen False (\s -> [(EQ, t) | ("EQ", t) <- lex s]) r ++ readParen False (\s -> [(GT, t) | ("GT", t) <- lex s]) r reads :: Read a => ReadS a reads = readsPrec 0 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 ] 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] 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] read :: Read a => String -> a read s = case [x | (x, t) <- reads s, ("", "") <- lex t] of [x] -> x lex :: ReadS String lex xs = case xs of "" -> [("", "")] (c:cs) | isSpace c -> lex $ dropWhile isSpace cs ('\'':s) -> [('\'' : ch ++ "'", t) | (ch, '\'' : t) <- lexCharLiteral s, ch /= "'"] ('"':s) -> [('"' : str, t) | (str, t) <- lexString s] (c:cs) | isSingle c -> [([c], cs)] | isSymbol c -> [(c : sym, t) | (sym, t) <- [span isSymbol 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` ",;()[]{}_`" isSymbol 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) <- lexStringItem s , (str, u) <- lexString t ] lexStringItem s = case s of ('\\':'&':cs) -> [("\\&", cs)] ('\\':c:cs) | isSpace c -> [("\\&", t) | '\\':t <- [dropWhile isSpace cs]] _ -> lexCharLiteral s lexCharLiteral :: ReadS String lexCharLiteral 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 s = [(cs, t) | (cs@(_:_), t) <- [span isDigit s]] 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 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 class Bounded a where minBound, maxBound :: a instance Bounded Char where minBound = chr 0 maxBound = chr 0x10FFFF instance Bounded () where minBound = () maxBound = () 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 Bool where maxBound = False minBound = True instance Bounded Ordering where maxBound = LT minBound = GT 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 x y z = map toEnum [fromEnum x, fromEnum y .. fromEnum z] instance Enum Char where succ c | c < maxBound = chr $ ord c + 1 pred c | c > minBound = chr $ ord c - 1 toEnum = chr fromEnum = ord enumFrom x = [x .. maxBound] enumFromThen x y | y >= x = [x, y .. maxBound] | otherwise = [x, y .. minBound] instance Enum Int where succ x = x + 1 pred x = x - 1 toEnum n = n fromEnum n = n enumFrom x = x : enumFrom (x + 1) enumFromTo x y | x > y = [] | otherwise = x : enumFromTo (x + 1) y enumFromThen x y = iterate ((y - x) +) x enumFromThenTo x y z = takeWhile p (enumFromThen x y) where p x' | y >= x = x' <= z | otherwise = x' >= z instance Enum () where succ _ = failed pred _ = failed toEnum 0 = () fromEnum () = 0 enumFrom () = [()] enumFromThen () () = let units = () : units in units enumFromTo () () = [()] enumFromThenTo () () () = let units = () : units in units instance Enum Bool where succ False = True pred True = False toEnum 0 = False toEnum 1 = True fromEnum False = 0 fromEnum True = 1 enumFrom x = enumFromTo x True enumFromThen x y = enumFromThenTo x y (x <= y) instance Enum Ordering where succ LT = EQ succ EQ = GT pred EQ = LT pred GT = EQ toEnum 0 = LT toEnum 1 = EQ toEnum 2 = GT fromEnum LT = 0 fromEnum EQ = 1 fromEnum GT = 2 enumFrom x = enumFromTo x GT enumFromThen x y = enumFromThenTo x y (if x <= y then GT else LT) 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 `plusInt` y x - y = x `minusInt` y x * y = x `timesInt` 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 `plusFloat` y x - y = x `minusFloat` y x * y = x `timesFloat` 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 = intToFloat x -- Adds two integers. plusInt :: Int -> Int -> Int #ifdef __KICS2__ plusInt external #elif defined(__PAKCS__) x `plusInt` y = (prim_plusInt $# y) $# x prim_plusInt :: Int -> Int -> Int prim_plusInt external #endif -- Subtracts two integers. minusInt :: Int -> Int -> Int #ifdef __KICS2__ minusInt external #elif defined(__PAKCS__) x `minusInt` y = (prim_minusInt $# y) $# x prim_minusInt :: Int -> Int -> Int prim_minusInt external #endif -- Multiplies two integers. timesInt :: Int -> Int -> Int #ifdef __KICS2__ timesInt external #elif defined(__PAKCS__) x `timesInt` y = (prim_timesInt $# y) $# x prim_timesInt :: Int -> Int -> Int prim_timesInt external #endif -- Adds two floating point numbers. plusFloat :: Float -> Float -> Float x `plusFloat` y = (prim_plusFloat $# y) $# x prim_plusFloat :: Float -> Float -> Float prim_plusFloat external -- Subtracts two floating point numbers. minusFloat :: Float -> Float -> Float x `minusFloat` y = (prim_minusFloat $# y) $# x prim_minusFloat :: Float -> Float -> Float prim_minusFloat external -- Multiplies two floating point numbers. timesFloat :: Float -> Float -> Float x `timesFloat` y = (prim_timesFloat $# y) $# x prim_timesFloat :: Float -> Float -> Float prim_timesFloat external -- Negates a floating point number. negateFloat :: Float -> Float #ifdef __KICS2__ negateFloat external #elif defined(__PAKCS__) negateFloat x = prim_negateFloat $# x prim_negateFloat :: Float -> Float prim_negateFloat external #endif -- Converts from integers to floating point numbers. intToFloat :: Int -> Float intToFloat x = prim_intToFloat $# x prim_intToFloat :: Int -> Float prim_intToFloat external class Num a => Fractional a where (/) :: a -> a -> a recip :: a -> a fromFloat :: Float -> a recip x = 1.0 / x x / y = x * recip y instance Fractional Float where x / y = x `divFloat` y fromFloat x = x -- Division on floating point numbers. divFloat :: Float -> Float -> Float x `divFloat` y = (prim_divFloat $# y) $# x prim_divFloat :: Float -> Float -> Float prim_divFloat external class (Num a, Ord a) => Real a where toFloat :: a -> Float instance Real Int where toFloat x = fromInt x instance Real Float where toFloat x = x class (Real a, Enum a) => Integral a where div, mod :: a -> a -> a quot, rem :: a -> a -> a divMod :: a -> a -> (a, a) quotRem :: a -> a -> (a, a) toInt :: a -> Int n `div` d = q where (q, _) = divMod n d n `mod` d = r where (_, r) = divMod n d n `quot` d = q where (q, _) = quotRem n d n `rem` d = r where (_, r) = quotRem n d instance Integral Int where divMod n d = (n `divInt` d, n `modInt` d) quotRem n d = (n `quotInt` d, n `remInt` d) toInt x = x --- Returns whether an integer is even. even :: Integral a => a -> Bool even n = n `rem` 2 == 0 --- Returns whether an integer is odd. odd :: Integral a => a -> Bool odd = not . even --- General coercion from integral types. fromIntegral :: (Integral a, Num b) => a -> b fromIntegral = fromInt . toInt --- General coercion to fractional types. realToFrac :: (Real a, Fractional b) => a -> b realToFrac = fromFloat . toFloat -- Integer division. The value is the integer quotient of its arguments -- and always truncated towards negative infinity. divInt :: Int -> Int -> Int #ifdef __KICS2__ divInt external #elif defined(__PAKCS__) x `divInt` y = (prim_divInt $# y) $# x prim_divInt :: Int -> Int -> Int prim_divInt external #endif -- Integer remainder. The value is the remainder of the integer division -- and it obeys the rule `mod x y = x - y * (div x y)`. modInt :: Int -> Int -> Int #ifdef __KICS2__ modInt external #elif defined(__PAKCS__) x `modInt` y = (prim_modInt $# y) $# x prim_modInt :: Int -> Int -> Int prim_modInt external #endif -- Integer division. The value is the integer quotient of its arguments -- and always truncated towards zero. quotInt :: Int -> Int -> Int #ifdef __KICS2__ quotInt external #elif defined(__PAKCS__) x `quotInt` y = (prim_quotInt $# y) $# x prim_quotInt :: Int -> Int -> Int prim_quotInt external #endif -- Integer remainder. The value is the remainder of the integer division -- and it obeys the rule `rem x y = x - y * (quot x y)`. remInt :: Int -> Int -> Int #ifdef __KICS2__ remInt external #elif defined(__PAKCS__) x `remInt` y = (prim_remInt $# y) $# x prim_remInt :: Int -> Int -> Int prim_remInt external #endif class (Real a, Fractional a) => RealFrac a where properFraction :: Integral b => a -> (b, a) truncate :: Integral b => a -> b round :: Integral b => a -> b ceiling :: Integral b => a -> b floor :: Integral b => a -> b truncate x = m where (m, _) = properFraction x round x = let (n, r) = properFraction x m = if r < 0 then n - 1 else n + 1 in case compare (signum (abs r - 0.5)) 0 of LT -> n EQ -> if even n then n else m GT -> m ceiling x = if r > 0 then n + 1 else n where (n, r) = properFraction x floor x = if r < 0 then n - 1 else n where (n, r) = properFraction x instance RealFrac Float where properFraction x = (n, x - fromIntegral n) where n = truncate x truncate = fromInt . truncateFloat round = fromInt . roundFloat -- Conversion function from floating point numbers to integers. -- The result is the closest integer between the argument and 0. truncateFloat :: Float -> Int truncateFloat x = prim_truncateFloat $# x prim_truncateFloat :: Float -> Int prim_truncateFloat external -- Conversion function from floating point numbers 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. roundFloat :: Float -> Int roundFloat x = prim_roundFloat $# x prim_roundFloat :: Float -> Int prim_roundFloat external class Fractional a => Floating a where pi :: a exp, log, sqrt :: a -> a (**), logBase :: a -> a -> a sin, cos, tan :: a -> a asin, acos, atan :: a -> a sinh, cosh, tanh :: a -> a asinh, acosh, atanh :: a -> a sqrt x = x ** 0.5 x ** y = exp (log x * y) logBase x y = log y / log x tan x = sin x / cos x tanh x = sinh x / cosh x instance Floating Float where pi = 3.141592653589793238 exp = expFloat log = logFloat sqrt = sqrtFloat sin = sinFloat cos = cosFloat tan = tanFloat asin = asinFloat acos = acosFloat atan = atanFloat sinh = sinhFloat cosh = coshFloat tanh = tanhFloat asinh = asinhFloat acosh = acoshFloat atanh = atanhFloat -- Natural logarithm. logFloat :: Float -> Float logFloat x = prim_logFloat $# x prim_logFloat :: Float -> Float prim_logFloat external -- Natural exponent. expFloat :: Float -> Float expFloat x = prim_expFloat $# x prim_expFloat :: Float -> Float prim_expFloat external -- Square root. sqrtFloat :: Float -> Float sqrtFloat x = prim_sqrtFloat $# x prim_sqrtFloat :: Float -> Float prim_sqrtFloat external -- Sine. sinFloat :: Float -> Float sinFloat x = prim_sinFloat $# x prim_sinFloat :: Float -> Float prim_sinFloat external -- Cosine. cosFloat :: Float -> Float cosFloat x = prim_cosFloat $# x prim_cosFloat :: Float -> Float prim_cosFloat external -- Tangent. tanFloat :: Float -> Float tanFloat x = prim_tanFloat $# x prim_tanFloat :: Float -> Float prim_tanFloat external -- Arcus sine. asinFloat :: Float -> Float asinFloat x = prim_asinFloat $# x prim_asinFloat :: Float -> Float prim_asinFloat external -- Arcus cosine. acosFloat :: Float -> Float acosFloat x = prim_acosFloat $# x prim_acosFloat :: Float -> Float prim_acosFloat external -- Arcus tangent. atanFloat :: Float -> Float atanFloat x = prim_atanFloat $# x prim_atanFloat :: Float -> Float prim_atanFloat external -- Hyperbolic sine. sinhFloat :: Float -> Float sinhFloat x = prim_sinhFloat $# x prim_sinhFloat :: Float -> Float prim_sinhFloat external -- Hyperbolic cosine. coshFloat :: Float -> Float coshFloat x = prim_coshFloat $# x prim_coshFloat :: Float -> Float prim_coshFloat external -- Hyperbolic tangent. tanhFloat :: Float -> Float tanhFloat x = prim_tanhFloat $# x prim_tanhFloat :: Float -> Float prim_tanhFloat external -- Hyperbolic arcus sine. asinhFloat :: Float -> Float asinhFloat x = prim_asinhFloat $# x prim_asinhFloat :: Float -> Float prim_asinhFloat external -- Hyperbolic arcus cosine. acoshFloat :: Float -> Float acoshFloat x = prim_acoshFloat $# x prim_acoshFloat :: Float -> Float prim_acoshFloat external -- Hyperbolic arcus tangent. atanhFloat :: Float -> Float atanhFloat x = prim_atanhFloat $# x prim_atanhFloat :: Float -> Float prim_atanhFloat external (^) :: (Num a, Integral b) => a -> b -> a x0 ^ y0 | y0 < 0 = error "Negative exponent" | y0 == 0 = 1 | otherwise = f x0 y0 where -- f : x0 ^ y0 = x ^ y f x y | even y = f (x * x) (y `quot` 2) | y == 1 = x | otherwise = g (x * x) (y `quot` 2) x -- g : x0 ^ y0 = (x ^ y) * z g x y z | even y = g (x * x) (y `quot` 2) z | y == 1 = x * z | otherwise = g (x * x) (y `quot` 2) (x * z) class Monoid a where mempty :: a mappend :: a -> a -> a mconcat :: [a] -> a mconcat = foldr mappend mempty instance Monoid () where mempty = () _ `mappend` _ = () mconcat _ = () instance (Monoid a, Monoid b) => Monoid (a, b) where mempty = (mempty, mempty) (a1, b1) `mappend` (a2,b2) = (a1 `mappend` a2, b1 `mappend` b2) instance (Monoid a, Monoid b, Monoid c) => Monoid (a, b, c) where mempty = (mempty, mempty, mempty) (a1, b1, c1) `mappend` (a2, b2, c2) = (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2) instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a, b, c, d) where mempty = (mempty, mempty, mempty, mempty) (a1, b1, c1, d1) `mappend` (a2, b2, c2, d2) = (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2, d1 `mappend` d2) instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => Monoid (a, b, c, d, e) where mempty = (mempty, mempty, mempty, mempty, mempty) (a1, b1, c1, d1, e1) `mappend` (a2, b2, c2, d2, e2) = (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2, d1 `mappend` d2, e1 `mappend` e2) instance Monoid [a] where mempty = [] mappend = (++) mconcat xss = [x | xs <- xss, x <- xs] instance Monoid b => Monoid (a -> b) where mempty _ = mempty mappend f g x = f x `mappend` g x instance Monoid Ordering where mempty = EQ LT `mappend` _ = LT EQ `mappend` y = y GT `mappend` _ = GT class Functor f where fmap :: (a -> b) -> f a -> f b (<$) :: a -> f b -> f a (<$) = fmap . const instance Functor [] where fmap = map instance Functor ((->) r) where fmap = (.) (<$>) :: Functor f => (a -> b) -> f a -> f b (<$>) = fmap class Functor f => Applicative f where pure :: a -> f a (<*>) :: f (a -> b) -> f a -> f b (*>) :: f a -> f b -> f b (<*) :: f a -> f b -> f a liftA2 :: (a -> b -> c) -> f a -> f b -> f c (<*>) = liftA2 id a1 *> a2 = (id <$ a1) <*> a2 (<*) = liftA2 const liftA2 f x = (<*>) (fmap f x) instance Applicative [] where pure x = [x] fs <*> xs = [f x | f <- fs, x <- xs] xs *> ys = [y | _ <- xs, y <- ys] liftA2 f xs ys = [f x y | x <- xs, y <- ys] instance Applicative ((->) a) where pure = const (<*>) f g x = f x (g x) liftA2 q f g x = q (f x) (g x) -- | A monoid on applicative functors. -- -- If defined, 'some' and 'many' should be the least solutions -- of the equations: -- -- * @'some' v = (:) '<$>' v '<*>' 'many' v@ -- -- * @'many' v = 'some' v '<|>' 'pure' []@ class Applicative f => Alternative f where -- | The identity of '<|>' empty :: f a -- | An associative binary operation (<|>) :: f a -> f a -> f a -- | One or more. some :: f a -> f [a] some v = some_v where many_v = some_v <|> pure [] some_v = (:) <$> v <*> many_v -- | Zero or more. many :: f a -> f [a] many v = many_v where many_v = some_v <|> pure [] some_v = (:) <$> v <*> many_v instance Alternative [] where empty = [] (<|>) = (++) class Applicative m => Monad m where (>>=) :: m a -> (a -> m b) -> m b (>>) :: m a -> m b -> m b return :: a -> m a return = pure m >> k = m >>= \_ -> k instance Monad [] where xs >>= f = [y | x <- xs, y <- f x] (>>) = (*>) instance Monad ((->) r) where f >>= k = \ r -> k (f r) r class Monad m => MonadFail m where fail :: String -> m a instance MonadFail [] where fail _ = [] ap :: Monad m => m (a -> b) -> m a -> m b ap m1 m2 = do x1 <- m1 x2 <- m2 return (x1 x2) 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) --- Executes a sequence of monadic actions and collects all results in a list. sequence :: Monad m => [m a] -> m [a] sequence [] = return [] sequence (c:cs) = do x <- c xs <- sequence cs return (x : xs) --- Executes 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 an 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 --- 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 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 type String = [Char] --- 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 as@(_:_) = let (l, bs) = splitLine as in l : lines bs 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 = concatMap (++ "\n") --- 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 ws == [] then [] else foldr1 (\w s -> w ++ ' ' : s) ws --- 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 --- 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 --- 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 --- 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 --- `asTypeOf` is a type-restricted version of `const`. --- It is usually used as an infix operator, and its typing forces its first --- argument (which is usually overloaded) to have the same type as the second. asTypeOf :: a -> a -> a asTypeOf = const --- 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) --- 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. ifThenElse :: Bool -> a -> a -> a ifThenElse b t f = case b of True -> t False -> f --- 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 --- 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 --- List index (subscript) operator, head has index 0. (!!) :: [a] -> Int -> a (x:xs) !! n | n == 0 = x | n > 0 = xs !! (n - 1) --- Maps 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. 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. 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 = foldr (++) [] --- 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) --- 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 data Maybe a = Nothing | Just a deriving (Eq, Ord, Show, Read) instance Monoid a => Monoid (Maybe a) where mempty = Nothing Nothing `mappend` m = m Just m1 `mappend` Nothing = Just m1 Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) instance Functor Maybe where fmap _ Nothing = Nothing fmap f (Just x) = Just (f x) instance Applicative Maybe where pure = Just Just f <*> m = fmap f m Nothing <*> _ = Nothing Just _ *> m = m Nothing *> _ = Nothing liftA2 f (Just x) (Just y) = Just (f x y) liftA2 _ (Just _) Nothing = Nothing liftA2 _ Nothing _ = Nothing instance Alternative Maybe where empty = Nothing Nothing <|> r = r Just l <|> _ = Just l instance Monad Maybe where Nothing >>= _ = Nothing Just x >>= k = k x (>>) = (*>) instance MonadFail Maybe where fail _ = Nothing maybe :: b -> (a -> b) -> Maybe a -> b maybe n _ Nothing = n maybe _ f (Just x) = f x data Either a b = Left a | Right b deriving (Eq, Ord, Show, Read) instance Functor (Either a) where fmap _ (Left e) = Left e fmap f (Right x) = Right (f x) instance Applicative (Either a) where pure = Right (<*>) = ap instance Monad (Either a) where return = Right (Left e) >>= _ = Left e (Right x) >>= f = f x either :: (a -> c) -> (b -> c) -> Either a b -> c either left _ (Left a) = left a either _ right (Right b) = right b external data IO _ instance Monoid a => Monoid (IO a) where mempty = pure mempty mappend = liftA2 mappend instance Functor IO where fmap f x = x >>= (pure . f) instance Applicative IO where pure = returnIO #ifdef __PAKCS__ (*>) = seqIO #else m *> k = m >>= \_ -> k #endif (<*>) = ap liftA2 = liftM2 instance Alternative IO where empty = fail "mzero" m <|> n = m `catch` const n instance Monad IO where (>>=) = bindIO (>>) = (*>) instance MonadFail IO where fail s = ioError (userError s) bindIO :: IO a -> (a -> IO b) -> IO b bindIO external seqIO :: IO a -> IO b -> IO b seqIO external returnIO :: a -> IO a returnIO external --- An action that reads a character from standard output and returns it. getChar :: IO Char getChar external --- An action that reads a line from standard input and returns it. getLine :: IO String getLine = do c <- getChar case c of '\n' -> return [] _ -> do cs <- getLine return (c : cs) --- 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 --- Action to print a string on standard output. putStr :: String -> IO () putStr [] = return () putStr (c:cs) = putChar c >> putStr cs --- Action to print a string with a newline on standard output. putStrLn :: String -> IO () putStrLn cs = putStr cs >> putChar '\n' --- Converts a term into a string and prints it. print :: Show a => a -> IO () print = putStrLn . show type FilePath = String --- An action that (lazily) reads a file and returns its contents. readFile :: FilePath -> IO String readFile f = prim_readFile $## f prim_readFile :: FilePath -> IO String prim_readFile external #ifdef __PAKCS__ -- Needed for internal implementation of readFile. prim_readFileContents :: FilePath -> String prim_readFileContents external #endif --- An action that writes a file. writeFile :: FilePath -> String -> IO () writeFile f s = (prim_writeFile $## f) s prim_writeFile :: FilePath -> String -> IO () prim_writeFile external --- An action that appends a string to a file. --- It behaves like `writeFile` if the file does not exist. appendFile :: FilePath -> String -> IO () appendFile f s = (prim_appendFile $## f) s prim_appendFile :: FilePath -> String -> IO () prim_appendFile external --- The (abstract) type of error values. --- Currently, it distinguishes between general I/O errors, --- user-generated errors (see 'userError'), failures and non-determinism --- errors during I/O computations. These errors can be caught by 'catch'. --- 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 instance Show IOError where show (IOError s) = "i/o error: " ++ s show (UserError s) = "user error: " ++ s show (FailError s) = "fail error: " ++ s show (NondetError s) = "nondet error: " ++ s --- A user error value is created by providing a description of the --- error situation as a string. userError :: String -> IOError userError = UserError --- Raises an I/O exception with a given error value. ioError :: IOError -> IO _ #ifdef __PAKCS__ ioError err = error (show err) #else ioError err = prim_ioError $## err prim_ioError :: IOError -> IO _ prim_ioError external #endif --- 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 type Success = Bool --- The always satisfiable constraint. success :: Success success = True --- Enforce a Boolean condition to be true. --- The computation fails if the argument evaluates to `False`. solve :: Bool -> Bool solve True = True --- 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 = return () --- 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). (=:=) :: Data a => a -> a -> Bool x =:= y = constrEq x y --- Internal operation to implement equational constraints. --- It is used by the strict equality optimizer but should not be used --- in regular programs. constrEq :: a -> a -> Bool constrEq external --- Non-strict equational constraint. --- This operation is not intended to be used in source programs --- but it is used to implement --- [functional patterns](https://doi.org/10.1007/11680093_2). --- Conceptually, `(e1 =:<= e2)` is satisfiable if `e1` can be evaluated --- to some pattern (data term) that matches `e2`, i.e., `e2` is --- an instance of this pattern. --- The `Data` context is required since the resulting pattern might be --- non-linear so that it abbreviates some further equational constraints, --- see [Section 7](https://doi.org/10.1007/978-3-030-46714-2_15). (=:<=) :: Data a => a -> a -> Bool x =:<= y = nonstrictEq x y nonstrictEq :: a -> a -> Bool nonstrictEq 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. (=:<<=) :: Data a => a -> a -> Bool x =:<<= y = unifEqLinear x y unifEqLinear :: a -> a -> Bool unifEqLinear external --- internal function to implement =:<= ifVar :: _ -> a -> a -> a ifVar external #endif --- Concurrent conjunction. --- An expression like `(c1 & c2)` is evaluated by evaluating --- the `c1` and `c2` in a concurrent manner. (&) :: Bool -> Bool -> Bool (&) external --- 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 --- Non-deterministic choice _par excellence_. --- The value of `x ? y` is either `x` or `y`. (?) :: 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 :: Data a => a unknown = let x free in x --- A non-reducible polymorphic function. --- It is useful to express a failure in a search branch of the execution. failed :: _ failed external --- Aborts the execution with an error message. error :: String -> _ error x = prim_error $## x prim_error :: String -> _ prim_error external -- Representation of higher-order applications in FlatCurry. apply :: (a -> b) -> a -> b apply external -- Representation of conditional rules in FlatCurry. cond :: Bool -> a -> a cond external #ifdef __PAKCS__ -- `letrec ones (1 : ones)` binds `ones` to `1 : ones`. letrec :: a -> a -> Bool letrec external -- Internal operation to implement failure reporting. failure :: _ -> _ -> _ failure external #endif ---------------------------------------------------------------- -- Extras used by specific Curry tools. --- Identity type synonym used to mark deterministic operations. --- Used by the Curry preprocessor. type DET a = a --- Identity function used by the partial evaluator --- to mark expressions to be partially evaluated. PEVAL :: a -> a PEVAL x = x ---------------------------------------------------------------- curry-libs-v3.0.0/src/Prelude.kics2000066400000000000000000002661431400127652700171370ustar00rootroot00000000000000{-# 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-v3.0.0/src/Prelude.pakcs000066400000000000000000000042501400127652700172120ustar00rootroot00000000000000 prim_applySeq[raw] prim_applyNormalForm[raw] prim_applyNotFree[raw] prim_applyGroundNormalForm[raw] prim_seq[raw] prim_ensureNotFree[raw] prim_failed[raw] Prelude.constrEq[raw] Prelude.nonstrictEq[raw] unifEqLinear[raw] prim_ifVar[raw] prim_concurrent_and[raw] prim_apply[raw] prim_cond[raw] prim_letrec[raw] prim_failure[raw] prim_Monad_bind[raw] prim_Monad_seq[raw] prim_return[raw] prim_readFileContents[raw] prim_writeFile[raw] prim_appendFile[raw] prim_catch[raw] curry-libs-v3.0.0/src/Prelude.pakcs.pl000066400000000000000000000665541400127652700176430ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prolog implementation of external Prelude operations: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Definition of arithmetic functions: % 'Prelude.prim_plusInt'(Y,X,R) :- R is X+Y. 'Prelude.prim_minusInt'(Y,X,R) :- R is X-Y. 'Prelude.prim_timesInt'(Y,X,R) :- R is X*Y. 'Prelude.prim_divInt'(Y,X,R) :- R is div(X,Y). 'Prelude.prim_modInt'(Y,X,R) :- isMod(R,X,Y). 'Prelude.prim_quotInt'(Y,X,R) :- R is X // Y. 'Prelude.prim_remInt'(Y,X,R) :- isRem(R,X,Y). 'Prelude.prim_plusFloat'(Y,X,R) :- R is X+Y. 'Prelude.prim_minusFloat'(Y,X,R) :- R is X-Y. 'Prelude.prim_timesFloat'(Y,X,R) :- R is X*Y. 'Prelude.prim_divFloat'(Y,X,R) :- R is X/Y. 'Prelude.prim_negateFloat'(X,R) :- R is -X. % transform an integer into a float: 'Prelude.prim_intToFloat'(X,R) :- R is X*1.0. % transform a float to an integer: 'Prelude.prim_truncateFloat'(X,R) :- R is integer(X). % round a float to an integer: 'Prelude.prim_roundFloat'(X,R) :- R is integer(round(X)). 'Prelude.prim_sqrtFloat'(X,R) :- R is sqrt(X). 'Prelude.prim_logFloat'(X,R) :- R is log(X). 'Prelude.prim_expFloat'(X,R) :- R is exp(X). 'Prelude.prim_sinFloat'(X,R) :- R is sin(X). 'Prelude.prim_cosFloat'(X,R) :- R is cos(X). 'Prelude.prim_tanFloat'(X,R) :- R is tan(X). 'Prelude.prim_asinFloat'(X,R) :- R is asin(X). 'Prelude.prim_acosFloat'(X,R) :- R is acos(X). 'Prelude.prim_atanFloat'(X,R) :- R is atan(X). 'Prelude.prim_sinhFloat'(X,R) :- R is sinh(X). 'Prelude.prim_coshFloat'(X,R) :- R is cosh(X). 'Prelude.prim_tanhFloat'(X,R) :- R is tanh(X). 'Prelude.prim_asinhFloat'(X,R) :- R is asinh(X). 'Prelude.prim_acoshFloat'(X,R) :- R is acosh(X). 'Prelude.prim_atanhFloat'(X,R) :- R is atanh(X). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Definition of comparsion of primitive data: % 'Prelude.prim_eqInt'(Y,X,R) :- X==Y -> R='Prelude.True' ; R='Prelude.False'. 'Prelude.prim_eqFloat'(Y,X,R) :- X==Y -> R='Prelude.True' ; R='Prelude.False'. 'Prelude.prim_eqChar'(Y,X,R) :- X==Y -> R='Prelude.True' ; R='Prelude.False'. 'Prelude.prim_ltEqInt'(Y,X,R) :- X= R='Prelude.True' ; R='Prelude.False'. 'Prelude.prim_ltEqFloat'(Y,X,R) :- X= R='Prelude.True' ; R='Prelude.False'. 'Prelude.prim_ltEqChar'(Y,X,R) :- char_int(X,VX), char_int(Y,VY), VX= R='Prelude.True' ; R='Prelude.False'. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Definition of conversion functions for characters: % 'Prelude.prim_ord'(C,N) :- char_int(C,N). 'Prelude.prim_chr'(N,C) :- N>=0, N<1114112, !, char_int(C,N). 'Prelude.prim_chr'(_,_) :- raise_exception('chr: argument out of range'). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Show and read functions for primitive types: % 'Prelude.prim_showIntLiteral'(N,S) :- prim_showNumber(N,S). 'Prelude.prim_showFloatLiteral'(N,S) :- prim_showNumber(N,S). prim_showNumber(N,S) :- number_codes(N,SN), map2M(basics:char_int,String,SN), (N>=0 -> S = String ; % enclose negative number in parentheses: char_int(Op,40), char_int(Cl,41), append([Op|String],[Cl],S)). % conversion of string representations of nat literals into Curry terms: 'Prelude.prim_readNatLiteral'([CC|String],['Prelude.(,)'(Num,TailString)]) :- char_int(CC,C), C>47, C<58, natConst(NumStr,String,TailString), number_codes(Num,[C|NumStr]), !. 'Prelude.prim_readNatLiteral'(_,[]). % parse error % conversion of string representations of float literals into Curry terms: 'Prelude.prim_readFloatLiteral'([CC|String],['Prelude.(,)'(Num,TailString)]) :- char_int(CC,C), C>47, C<58, floatConst(NumStr,String,TailString), number_codes(Num,[C|NumStr]), !. 'Prelude.prim_readFloatLiteral'(_,[]). % parse error natConst([C|Cs]) --> [CC], { char_int(CC,C), C>47, C<58 }, !, natConst(Cs). natConst([]) --> skipblanks. floatConst([C|Cs]) --> [CC], { char_int(CC,C), C>47, C<58 }, !, floatConst(Cs). floatConst([46,C|Cs]) --> [PC], { char_int(PC,46) }, [CC], { char_int(CC,C), C>47, C<58 }, !, floatConstRest(Cs). floatConstRest([C|Cs]) --> [CC], { char_int(CC,C), C>47, C<58 }, !, floatConstRest(Cs). floatConstRest([C|Cs]) --> [CC], {char_int(CC,C), C=69 ; C=101}, !, % exponent intConst(Cs). floatConstRest([]) --> skipblanks. intConst(Cs) --> ( [CC], {char_int(CC,45)}, natConst(NCs), {Cs=[45|NCs]} ; natConst(Cs) ). % conversion of string representations of char literals into Curry terms: % TODO: avoid char_int conversion 'Prelude.prim_readCharLiteral'(String,['Prelude.(,)'(Char,TailString)]) :- map2M(basics:char_int,String,[C|PrologString]), C=39, readChar(PrologString,Tail,Char), map2M(basics:char_int,TailString,Tail), !. 'Prelude.prim_readCharLiteral'(_,[]). % parse error % conversion of string representations of string literals into Curry terms: % TODO: avoid char_int conversion 'Prelude.prim_readStringLiteral'(String,['Prelude.(,)'(Result,TailString)]) :- map2M(basics:char_int,String,[C|PrologString]), C=34, readString(PrologString,Tail,Result), map2M(basics:char_int,TailString,Tail), !. 'Prelude.prim_readStringLiteral'(_,[]). % parse error 'Prelude.prim_showCharLiteral'(C,[Apo|S]) :- char_int(Apo,39), % 39=''' char_int(C,N), (N=39 -> char_int(BS,92), S=[BS,C|SE] % ' ; (N=34 -> S=[C|SE] % " ; showTermChar(N,S,SE))), SE = [Apo]. 'Prelude.prim_showStringLiteral'(Str,[Quot|S]) :- char_int(Quot,34), % 34 = '"' showTermString(Str,S,[]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Definition of I/O actions: % 'Prelude.prim_putChar'(C,'Prelude.()') :- char_int(C,N), put_code(N), %flush_output. % this is problematic for Sicstus4 (substantial delay) (N=10 -> flush_output ; true). 'Prelude.getChar'(C) :- get_code(N), char_int(C,N). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % handling "FAIL" values % Checks whether a Prolog term is a "FAIL" value. isFail(T) :- nonvar(T), T='FAIL'(_). % Check whether a Prolog term is a "FAIL" value and, if yes, extend it % with one item: ?- block checkFailValue(?,?,?,-,?). checkFailValue(Ext,Val,Result,E0,E) :- (nonvar(Val), Val='FAIL'(Src)) -> Result='FAIL'([Ext|Src]), E0=E ; Result=Val, E0=E. % normalize a term and show "FAIL" errors, if necessary: ?- block normalizeAndCheck(?,?,-,?). normalizeAndCheck(Exp,Val,E0,E) :- user:nf(Exp,Val,E0,E1), normalizeAndCheckNF(Val,E1,E). ?- block normalizeAndCheckNF(?,-,?). normalizeAndCheckNF(Val,E0,E) :- isFail(Val) -> Val='FAIL'(S), evaluator:writeFailSource(S) ; E0=E. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % definition of concurrent conjunction: ?- block prim_concurrent_and(?,?,?,-,?). prim_concurrent_and(C1,C2,R,E0,E) :- user:hnf(C1,S1,E0,E1), user:hnf(C2,S2,E0,E2), waitConcurrentConjunction(S1,S2,R,E1,E2,E). % primitive for conditional rules: ?- block prim_cond(?,?,?,-,?). prim_cond(Cond,RHS,R,E0,E) :- user:hnf(Cond,S,E0,E1), prim_checkcond(S,Cond,RHS,R,E1,E). ?- block prim_checkcond(-,?,?,?,?,?), prim_checkcond(?,?,?,?,-,?). prim_checkcond('Prelude.True',_,RHS,R,E0,E) :- user:hnf(RHS,R,E0,E). prim_checkcond('FAIL'(Src),Cond,RHS,'FAIL'(['Prelude.cond'(Cond,RHS)|Src]),E,E). % primitive for implementing letrec: ?- block prim_letrec(?,?,?,-,?). prim_letrec(X,XE,'Prelude.True',E0,E) :- var(XE), !, X=XE, E0=E. prim_letrec(X,XE,'Prelude.True',E0,E) :- create_mutable(XE,MX), X=share(MX), E0=E. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Definition of I/O actions: % ?- block prim_Monad_bind(?,?,?,-,?). prim_Monad_bind(A1,FA2,partcall(1,prim_Monad_bindWorld,[FA2,A1]),E,E). ?- block prim_Monad_bindWorld(?,?,?,?,-,?). prim_Monad_bindWorld(Action1,FunAction2,W,R,E0,E) :- prim_apply(Action1,W,'$io'(R1),E0,E1), prim_apply(FunAction2,R1,HAction2,E1,E2), prim_apply(HAction2,W,R,E2,E). % although (>>) is a defined function, % we provide a slightly faster primitive implementation: ?- block prim_Monad_seq(?,?,?,-,?). prim_Monad_seq(A1,A2,partcall(1,prim_Monad_seqWorld,[A2,A1]),E,E). ?- block prim_Monad_seqWorld(?,?,?,?,-,?). prim_Monad_seqWorld(Action1,Action2,W,R,E0,E) :- prim_apply(Action1,W,_,E0,E1), prim_apply(Action2,W,R,E1,E). ?- block prim_return(?,?,-,?). prim_return(V,partcall(1,prim_returnWorld,[V]),E,E). ?- block prim_returnWorld(?,?,?,-,?). prim_returnWorld(A,_,'$io'(A),E,E). 'Prelude.prim_readFile'(A,Result) :- string2Atom(A,FName), fileOpenOptions(Options), open(FName,read,Stream,Options), (compileWithSharing(function) -> makeShare('Prelude.prim_readFileContents'(Stream),Result) ; Result = 'Prelude.prim_readFileContents'(Stream)). ?- block prim_readFileContents(?,?,-,?). prim_readFileContents(Stream,Result,E0,E) :- atEndOfStream(Stream), !, Result=[], close(Stream), E0=E. prim_readFileContents(Stream,Result,E0,E) :- get_code(Stream,NChar), char_int(Char,NChar), Result=[Char|RFC], (compileWithSharing(function) -> makeShare('Prelude.prim_readFileContents'(Stream),RFC) ; RFC = 'Prelude.prim_readFileContents'(Stream)), E0=E. ?- block prim_writeFile(?,?,?,-,?). prim_writeFile(F,S,partcall(1,prim_writeFileWorld,[S,F]),E,E). ?- block prim_writeFileWorld(?,?,?,?,-,?). prim_writeFileWorld(RA,S,W,H,E0,E) :- user:derefAll(RA,A), string2Atom(A,FName), fileOpenOptions(Options), open(FName,write,Stream,Options), prim_writeFileContents(Stream,S,W,H,E0,E). ?- block prim_appendFile(?,?,?,-,?). prim_appendFile(F,S,partcall(1,prim_appendFileWorld,[S,F]),E,E). ?- block prim_appendFileWorld(?,?,?,?,-,?). prim_appendFileWorld(RA,S,W,H,E0,E) :- user:derefAll(RA,A), string2Atom(A,FName), fileOpenOptions(Options), open(FName,append,Stream,Options), prim_writeFileContents(Stream,S,W,H,E0,E). ?- block prim_writeFileContents(?,?,?,?,-,?). prim_writeFileContents(Stream,Contents,W,R,E0,E) :- user:hnf(Contents,HContents,E0,E1), prim_writeFileContents1(HContents,Stream,W,R,E1,E). ?- block prim_writeFileContents1(-,?,?,?,?,?), prim_writeFileContents1(?,?,?,?,-,?). prim_writeFileContents1([],Stream,_,'$io'('Prelude.()'),E0,E) :- flush_output(Stream), close(Stream), E0=E. prim_writeFileContents1([C|Cs],Stream,W,R,E0,E) :- user:hnf(C,HC,E0,E1), put_writeFileContents(Stream,HC,Cs,W,R,E1,E). prim_writeFileContents1('FAIL'(Src),_,_,'FAIL'(Src),E,E). ?- block put_writeFileContents(?,-,?,?,?,?,?), put_writeFileContents(?,?,?,?,?,-,?). put_writeFileContents(_,'FAIL'(Src),_,_,'FAIL'(Src),E,E) :- !. put_writeFileContents(Stream,C,Cs,W,H,E0,E) :- char_int(C,N), put_code(Stream,N), prim_writeFileContents(Stream,Cs,W,H,E0,E). ?- block prim_catch(?,?,?,-,?). prim_catch(A1,A2,partcall(1,prim_catchWorld,[A2,A1]),E,E). ?- block prim_catchWorld(?,?,?,?,-,?). prim_catchWorld(Action,ErrFunction,W,R,E0,E) :- on_exception(ErrorMsg, (prim_apply(Action,W,R0,E0,E), (nonvar(E) -> R=R0 ; ErrAtom = 'Computation suspended', returnIOError(ErrAtom,ErrFunction,W,R,E0,E))), (prologError2Atom(ErrorMsg,ErrAtom), returnIOError(ErrAtom,ErrFunction,W,R,E0,E))), !. prim_catchWorld(_,ErrFunction,W,R,E0,E) :- atom2String('IO action failed',FailMsg), applyErrorFunction(ErrFunction,'Prelude.FailError'(FailMsg),W,R,E0,E). returnIOError(ErrAtom,ErrFunction,W,R,E0,E) :- atom2String(ErrAtom,ErrString), ErrValue = 'Prelude.IOError'(ErrString), applyErrorFunction(ErrFunction,ErrValue,W,R,E0,E). applyErrorFunction(ErrFunction,ErrValue,W,R,E0,E) :- prim_apply(ErrFunction,ErrValue,ErrAction,E0,E1), prim_apply(ErrAction,W,R,E1,E). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % definition of apply primitive: ?- block prim_apply(?,?,?,-,?). prim_apply(F,X,R,E0,E) :- user:hnf(F,HF,E0,E1), prim_hnf_apply(HF,X,R,E1,E). ?- block prim_hnf_apply(-,?,?,?,?), prim_hnf_apply(?,?,?,-,?). prim_hnf_apply('FAIL'(Src),_,'FAIL'(Src),E,E) :- !. prim_hnf_apply(partcall(N,F,Args),X,R,E0,E) :- !, (N=1 -> (X=='$world' % application of primitive IO operation -> rev([E,E0,R,X|Args],AllArgs), %(F=M:UF -> true ; F=UF, M=user), Term =.. [F|AllArgs], call(user:Term) ; prim_hnf_apply_call(Args,F,X,R,E0,E)) ; N1 is N-1, R=partcall(N1,F,[X|Args]), E0=E). prim_hnf_apply('Dynamic.Dynamic'(DP),X,'Dynamic.Dynamic'(DPX),E0,E) :- !, % special treatment of dynamic predicates: user:hnf(DP,DynPred,E0,E1), DynPred =.. [P|Args], append(Args,[X],ArgsX), % not constant time! (TODO: improve) DPX =.. [P|ArgsX], E1=E. prim_hnf_apply(CTerm,X,R,E0,E) :- % partial constructor applications CTerm =.. [C|Args], append(Args,[X],ArgsX), % not constant time, hopefully occurs not so often, R =.. [C|ArgsX], % otherwise one can represent them also as partcalls E0=E. prim_hnf_apply_call([],F,X,R,E0,E) :- !, Term =.. [F,X], user:hnf(Term,R,E0,E). prim_hnf_apply_call([A1],F,X,R,E0,E) :- !, Term =.. [F,A1,X], user:hnf(Term,R,E0,E). prim_hnf_apply_call([A1,A2],F,X,R,E0,E) :- !, Term =.. [F,A2,A1,X], user:hnf(Term,R,E0,E). prim_hnf_apply_call([A1,A2,A3],F,X,R,E0,E) :- !, Term =.. [F,A3,A2,A1,X], user:hnf(Term,R,E0,E). prim_hnf_apply_call(Args,F,X,R,E0,E) :- % the general case: rev([X|Args],AllArgs), Term =.. [F|AllArgs], user:hnf(Term,R,E0,E). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Implementation of $! ?- block prim_applySeq(?,?,?,-,?). prim_applySeq(F,X,R,E0,E) :- user:hnf(X,HX,E0,E1), prim_applySeqHNF(F,HX,R,E1,E). ?- block prim_applySeqHNF(?,?,?,-,?). prim_applySeqHNF(F,HX,R,E0,E) :- isFail(HX) -> R=HX, E0=E ; user:hnf(F,HF,E0,E1), prim_hnf_apply(HF,HX,R,E1,E). % Implementation of $!! ?- block prim_applyNormalForm(?,?,?,-,?). prim_applyNormalForm(F,X,R,E0,E) :- user:nf(X,NX,E0,E1), prim_applyNormalFormNF(F,NX,R,E1,E). ?- block prim_applyNormalFormNF(?,?,?,-,?). prim_applyNormalFormNF(F,NX,R,E0,E) :- isFail(NX) -> R=NX, E0=E ; user:hnf(F,HF,E0,E1), prim_hnf_apply(HF,NX,R,E1,E). % Implementation of $# ?- block prim_applyNotFree(?,?,?,-,?). prim_applyNotFree(F,X,R,E0,E) :- user:hnf('Prelude.ensureNotFree'(X),HX,E0,E1), prim_applyNotFreeHNF(F,HX,R,E1,E). ?- block prim_applyNotFreeHNF(?,?,?,-,?). prim_applyNotFreeHNF(F,HX,R,E0,E) :- isFail(HX) -> R=HX, E0=E ; user:hnf(F,HF,E0,E1), prim_hnf_apply(HF,HX,R,E1,E). % Implementation of $## ?- block prim_applyGroundNormalForm(?,?,?,-,?). prim_applyGroundNormalForm(F,X,R,E0,E) :- user:nf(X,NX,E0,E1), waitUntilGround(NX,E1,E2), prim_applyGroundNormalFormNF(F,NX,R,E2,E). ?- block prim_applyGroundNormalFormNF(?,?,?,-,?). prim_applyGroundNormalFormNF(F,NX,R,E0,E) :- isFail(NX) -> R=NX, E0=E ; user:hnf(F,HF,E0,E1), prim_hnf_apply(HF,NX,R,E1,E). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % definition of seq primitive: ?- block prim_seq(?,?,?,-,?). prim_seq(Arg,Val,Result,E0,E) :- user:hnf(Arg,H,E0,E1), prim_seqHNF(H,Val,Result,E1,E). ?- block prim_seqHNF(?,?,?,-,?). prim_seqHNF(H,Val,Result,E0,E) :- isFail(H) -> Result=H, E0=E ; user:hnf(Val,Result,E0,E). % definition of ensureNotFree primitive (rigid on first argument): ?- block prim_ensureNotFree(?,?,-,?). prim_ensureNotFree(Arg,Result,E0,E) :- user:hnf(Arg,Val,E0,E1), prim_ensureNotFreeHNF(Val,Result,E1,E). ?- block prim_ensureNotFreeHNF(?,?,-,?). prim_ensureNotFreeHNF(Val,Result,E0,E) :- isFail(Val) -> Result=Val, E0=E ; (var(Val) -> addSuspensionReason('Applying a primitive (rigid) operation to a free variable') ; true), prim_ensureHnfNotFree(Val,Result,E0,E). ?- block prim_ensureHnfNotFree(-,?,?,?), prim_ensureHnfNotFree(?,?,-,?). prim_ensureHnfNotFree(Val,Val,E,E). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % definition of run-time error and failure: 'Prelude.prim_error'(Msg,_) :- string2Atom(Msg,AMsg), raise_exception(AMsg). ?- block prim_failed(?,-,?). prim_failed(R,E0,E) :- prim_failure(partcall(0,'Prelude.failed',[]),[],R,E0,E). %prim_failed(_,E,E) :- fail. ?- block prim_failure(?,?,?,-,?). prim_failure(_,_,_,_,_) :- printConsFailure(no), !, fail. % no reporting required prim_failure(_,_,_,_,_) :- % no reporting in findall: hasPrintedFailure, !, fail. prim_failure(PartCall,ConsExp,Result,E0,E) :- % generate FAIL value Result = 'FAIL'([PartCall,ConsExp]), E0=E. %prim_failure(PartCall,ConsExp,_,E,E) :- evaluator:writeFailSource([PartCall,ConsExp]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TODO: implement prim_compare in main Prolog file similarly to hnf,nf,... % so that its computations are also covered by the profiler. ?- block prim_compare(?,?,?,-,?). prim_compare(X,Y,R,E0,E) :- user:hnf(X,HX,E0,E1), user:hnf(Y,HY,E1,E2), prim_compareHNF(HX,HY,R,E2,E). ?- block prim_compareHNF(?,?,?,-,?). prim_compareHNF(X,Y,R,E0,E) :- var(X), var(Y), !, addSuspensionReason('Comparing (with <, >,...) two free variables'), when((nonvar(X);nonvar(Y)), prim_compareHNF(X,Y,R,E0,E)). prim_compareHNF(X,Y,R,E0,E) :- var(X), !, prim_compareHNF(Y,X,R0,E0,E1), switchOrdering(R0,R), E1=E. prim_compareHNF('FAIL'(Src),_,'FAIL'(Src),E,E) :- !. prim_compareHNF(_,Y,R,E0,E) :- nonvar(Y), Y='FAIL'(_), !, R=Y, E0=E. prim_compareHNF(X,Y,R,E0,E) :- var(Y), (number(X); isCharCons(X)), !, addSuspensionReason('Comparing (with <, >,...) a free variable with a number or character'), when(nonvar(Y), prim_compareHNF(X,Y,R,E0,E)). prim_compareHNF(X,Y,R,E0,E) :- number(X), !, (X=Y -> R='Prelude.EQ' ; (X R='Prelude.LT' ; R='Prelude.GT')), E0=E. prim_compareHNF(X,Y,R,E0,E) :- isCharCons(X), !, char_int(X,VX), char_int(Y,VY), (VX=VY -> R='Prelude.EQ' ; (VX R='Prelude.LT' ; R='Prelude.GT')), E0=E. prim_compareHNF(X,Y,R,E0,E) :- var(Y), !, functor(X,FX,NX), ( functor(Y,FX,NX), prim_compareArgs(1,NX,X,Y,R,E0,E) ; user:constructortype(FX,_,NX,_,IX,_,OtherCons), member(FY/NY,OtherCons), user:constructortype(FY,_,NY,_,IY,_,_), functor(Y,FY,NY), (IX R='Prelude.LT', E0=E ; (IX>IY -> R='Prelude.GT', E0=E)) ). prim_compareHNF(X,Y,R,E0,E) :- functor(X,FX,NX), functor(Y,FY,NY), user:constructortype(FX,_,NX,_,IX,_,_), user:constructortype(FY,_,NY,_,IY,_,_), !, (IX R='Prelude.LT', E0=E ; (IX>IY -> R='Prelude.GT', E0=E ; prim_compareArgs(1,NX,X,Y,R,E0,E))). ?- block prim_compareArgs(?,?,?,?,?,-,?). prim_compareArgs(I,N,_,_,R,E0,E) :- I>N, !, R='Prelude.EQ', E0=E. prim_compareArgs(I,N,X,Y,R,E0,E) :- arg(I,X,ArgX), arg(I,Y,ArgY), prim_compare(ArgX,ArgY,ArgR,E0,E1), (ArgR='Prelude.EQ' -> I1 is I+1, prim_compareArgs(I1,N,X,Y,R,E1,E) ; R=ArgR, E1=E). switchOrdering('Prelude.LT','Prelude.GT') :- !. switchOrdering('Prelude.GT','Prelude.LT') :- !. switchOrdering(X,X). :- block waitUntilGround(-,?,?), waitUntilGround(?,-,?). waitUntilGround(share(M),E0,E) :- !, get_mutable(V,M), (V='$eval'(Exp) -> true ; Exp=V), waitUntilGround(Exp,E0,E). waitUntilGround(T,E0,E) :- functor(T,_,N), waitUntilGroundArgs(1,N,T,E0,E). :- block waitUntilGroundArgs(?,?,?,-,?). waitUntilGroundArgs(A,N,_,E0,E) :- A>N, !, E0=E. waitUntilGroundArgs(A,N,T,E0,E) :- arg(A,T,Arg), waitUntilGround(Arg,E0,E1), A1 is A+1, waitUntilGroundArgs(A1,N,T,E1,E). % compute head normal form and wait until it is ground: :- block hnfAndWaitUntilGround(?,?,-,?). hnfAndWaitUntilGround(X,HX,E0,E) :- user:hnf(X,HX,E0,E1), hnfAndWaitUntilGroundHNF(HX,E1,E). :- block hnfAndWaitUntilGroundHNF(?,-,?). hnfAndWaitUntilGroundHNF(X,E0,E) :- isFail(X) -> E0=E ; waitUntilGround(X,E0,E). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Directed non-strict equality for matching against functional patterns: % (first argument must be the functional pattern): :- block 'Prelude.nonstrictEq'(?,?,?,-,?). 'Prelude.nonstrictEq'(A,B,R,E0,E):- user:hnf(A,HA,E0,E1), unifEq1(HA,B,R,E1,E). :- block unifEq1(?,?,?,-,?). % In the following clause, we bind a functional pattern variable to the % actual argument. This binding of a logical variable against % a non-constructor term is not problematic since the functional pattern % variable is a logical variable that is not enclosed % by a sharing structure (compare definition of makeShare). unifEq1(FPat,ActArg,'Prelude.True',E0,E) :- var(FPat), !, user:occursNot(FPat,ActArg), %FPat=ActArg, % this would implement run-time choice % in order to implement call-time choice for pattern variables, % we wrap the pattern variable in a share structure % (this could be optimized by checking the number of further occurrences % of the pattern variable) makeShare(ActArg,FPat), %writeErr('BOUND TO: '), removeShares(ActArg,AA), writeErr(AA), nlErr, E0=E. unifEq1('FAIL'(Src),_,'FAIL'(Src),E,E):- !. unifEq1(A,B,R,E0,E) :- replaceMultipleVariables(A,LinA,LinConstraints), user:hnf(B,HB,E0,E1), unifEqHnf(LinA,HB,EqR,E1,E2), unifEq2(EqR,LinConstraints,R,E2,E). :- block unifEq2(?,?,?,-,?). unifEq2(EqR,LinConstraints,R,E0,E) :- isFail(EqR) -> R=EqR, E0=E ; %(LinConstraints='Prelude.True' -> true % ; writeErr('Linearity constraints: '), % writeErr(LinConstraints), nlErr), user:hnf(LinConstraints,R,E0,E). % replace multiple occurrences of a same logic variables by new ones combined % with strict equations: replaceMultipleVariables(T,LinT,LinConstraints) :- %writeErr('Term to linearize: '), writeErr(T), nlErr, T =.. [Cons|Args], replaceMultipleVariablesInArgs(Args,inConstructorCall,Vars,LinArgs), LinT =.. [Cons|LinArgs], getSEqConstraints(Vars,LinConstraints). %length(Vars,Len), writeErr('Length of variable list: '), writeErr(Len), nlErr. getControlVar(X,Below,L,NewX) :- var(L), !, L=[control(X,Below,NewX,_)|_]. getControlVar(X,Below,[control(Y,YBelow,NewVar,NewConstraint)|_],NewX) :- X==Y, !, % multiple occurrence of a variable X not inside function calls are replaced % a fresh variable Y and a strict equality constraint X=:=Y % that is later executed. ((Below=inConstructorCall, YBelow=inConstructorCall) -> (var(NewConstraint) -> NewConstraint = 'Prelude.constrEq'(X,NewVar), NewX=X ; NewX=NewVar) ; % multiple occurrence of a variable X, where one occurrence is in a % function call, are replaced by an expression that % forces the evaluation of a strict equality constraint if the variable % occurs multiple times in the finally evaluated pattern. % Therefore, each variable X is replaced by % (if isVar ShareX then ShareX=:=() else CtrlX=:=()) &> X % with a constraint % (if isVar CtrlX then success else X=:=X) that is later executed. NewX=NewVar, (var(NewConstraint) -> NewVar = 'Prelude.&>'('Prelude.ifVar'(ShareVar, 'Prelude.constrEq'(ShareVar,'Prelude.()'), 'Prelude.constrEq'(CtrlVar,'Prelude.()')),X), NewConstraint = 'Prelude.ifVar'(CtrlVar, 'Prelude.True', 'Prelude.constrEq'(X,X)) ; true)). getControlVar(X,Below,[_|L],NewVar) :- getControlVar(X,Below,L,NewVar). getSEqConstraints(L,'Prelude.True') :- var(L), !, L=[]. getSEqConstraints([control(X,_,NewVar,NewConstraint)|L],Constraints) :- var(NewConstraint), !, % occurred only once X=NewVar, getSEqConstraints(L,Constraints). getSEqConstraints([control(_,_,_,NewConstraints)|L], 'Prelude.&'(NewConstraints,Constraints)) :- getSEqConstraints(L,Constraints). replaceMultipleVariablesInArgs([],_,_,[]). replaceMultipleVariablesInArgs([X|Args],Below,Vars,[NewArg|LinArgs]) :- var(X), !, getControlVar(X,Below,Vars,NewArg), replaceMultipleVariablesInArgs(Args,Below,Vars,LinArgs). replaceMultipleVariablesInArgs([Arg|Args],Below,Vars,[Arg|LinArgs]) :- % avoid repeating replacing already replaced variables Arg = 'Prelude.&>'('Prelude.ifVar'(ShareVar, 'Prelude.constrEq'(ShareVar,'Prelude.()'), 'Prelude.constrEq'(_CtrlVar,'Prelude.()')),_), !, replaceMultipleVariablesInArgs(Args,Below,Vars,LinArgs). replaceMultipleVariablesInArgs([Arg|Args],Below,Vars,[LinArg|LinArgs]) :- Arg =.. [FC|Ts], (user:functiontype(FC,_,_,_,_,_) -> TsBelow= inFunctionCall ; TsBelow=Below), replaceMultipleVariablesInArgs(Ts,TsBelow,Vars,LinTs), LinArg =.. [FC|LinTs], replaceMultipleVariablesInArgs(Args,Below,Vars,LinArgs). :- block unifEqHnf(?,?,?,-,?). unifEqHnf(A,B,Success,E0,E) :- var(B),!, user:bind(B,A,Success,E0,E). % in order to evaluate function pattern unifEqHnf(_,'FAIL'(Src),'FAIL'(Src),E,E) :- !. unifEqHnf(A,B,R,E0,E) :- number(A), !, (A=B -> R='Prelude.True', E0=E ; prim_failure(partcall(2,'Prelude.=:<=',[]),[A,B],R,E0,E)). unifEqHnf(A,B,R,E0,E) :- functor(A,FuncA,ArA), functor(B,FuncB,ArB), FuncA==FuncB, ArA==ArB, !, genUnifEqHnfBody(1,ArA,A,B,Con), user:hnf(Con,R,E0,E). unifEqHnf(A,B,R,E0,E) :- prim_failure(partcall(2,'Prelude.=:<=',[]),[A,B],R,E0,E). genUnifEqHnfBody(N,Arity,_,_,'Prelude.True') :- N>Arity, !. genUnifEqHnfBody(N,Arity,A,B,'Prelude.nonstrictEq'(ArgA,ArgB)):- N=Arity, !, arg(N,A,ArgA), arg(N,B,ArgB). genUnifEqHnfBody(N,Arity,A,B,'Prelude.&'('Prelude.nonstrictEq'(ArgA,ArgB),G)):- arg(N,A,ArgA), arg(N,B,ArgB), N1 is N+1, genUnifEqHnfBody(N1,Arity,A,B,G). % Directed non-strict equality for matching against linear function patterns, % i.e., it must be ensured that the first argument is always (after evalutation % by narrowing) a linear pattern. % At call time, the first argument must be the function pattern. :- block unifEqLinear(?,?,?,-,?). unifEqLinear(A,B,R,E0,E):- user:hnf(A,HA,E0,E1), unifEqLinear1(HA,B,R,E1,E). :- block unifEqLinear1(?,?,?,-,?). % In the following clause, we bind a function pattern variable to the % actual argument. This binding of a logical variable against % a non-constructor term is not problematic since the functional pattern % variable is a logical variable that is not enclosed % by a sharing structure (compare definition of makeShare). unifEqLinear1(FPat,ActArg,'Prelude.True',E0,E):- var(FPat), !, %FPat=ActArg, % this would implement run-time choice % in order to implement call-time choice for pattern variables, % we wrap the pattern variable in a share structure % (this could be optimized by checking the number of further occurrences % of the pattern variable) makeShare(ActArg,FPat), %writeErr('BOUND TO: '), removeShares(ActArg,AA), writeErr(AA), nlErr, E0=E. unifEqLinear1('FAIL'(Src),_,'FAIL'(Src),E,E):- !. unifEqLinear1(A,B,R,E0,E):- user:hnf(B,HB,E0,E1), unifEqLinearHnf(A,HB,R,E1,E). :- block unifEqLinearHnf(?,?,?,-,?). unifEqLinearHnf(A,B,R,E0,E) :- var(B), !, user:nf(A,NA,E0,E1), freeze(E1,(isFail(NA) -> R=NA, E1=E ; B=NA, R='Prelude.True', E1=E)). unifEqLinearHnf(_,'FAIL'(Src),'FAIL'(Src),E,E) :- !. unifEqLinearHnf(A,B,R,E0,E) :- number(A), !, (A=B -> R='Prelude.True', E0=E ; prim_failure(partcall(2,'Prelude.=:<<=',[]),[A,B],R,E0,E)). unifEqLinearHnf(A,B,R,E0,E) :- functor(A,FuncA,ArA), functor(B,FuncB,ArB), FuncA==FuncB, ArA==ArB, !, genUnifEqLinearHnfBody(1,ArA,A,B,Con), user:hnf(Con,R,E0,E). unifEqLinearHnf(A,B,R,E0,E) :- prim_failure(partcall(2,'Prelude.=:<<=',[]),[A,B],R,E0,E). genUnifEqLinearHnfBody(N,Arity,_,_,'Prelude.True') :- N>Arity, !. genUnifEqLinearHnfBody(N,Arity,A,B,'Prelude.unifEqLinear'(ArgA,ArgB)):- N=Arity, !, arg(N,A,ArgA), arg(N,B,ArgB). genUnifEqLinearHnfBody(N,Arity,A,B, 'Prelude.&'('Prelude.unifEqLinear'(ArgA,ArgB),G)):- arg(N,A,ArgA), arg(N,B,ArgB), N1 is N+1, genUnifEqLinearHnfBody(N1,Arity,A,B,G). % ifVar x t f corresponds to if (Unsafe.isVar x) then t else f: ?- block prim_ifVar(?,?,?,?,-,?). prim_ifVar(RTerm,T,F,H,E0,E) :- user:derefRoot(RTerm,Term), (var(Term) -> user:hnf(T,H,E0,E) ; user:hnf(F,H,E0,E)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-libs-v3.0.0/src/System/000077500000000000000000000000001400127652700160525ustar00rootroot00000000000000curry-libs-v3.0.0/src/System/CPUTime.curry000066400000000000000000000005711400127652700204110ustar00rootroot00000000000000module System.CPUTime where --- 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 curry-libs-v3.0.0/src/System/CPUTime.kics2000066400000000000000000000005631400127652700202610ustar00rootroot00000000000000import System.CPUTime (getCPUTime) 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) curry-libs-v3.0.0/src/System/CPUTime.pakcs.pl000066400000000000000000000004731400127652700207610ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module System.CPUTime % 'System.CPUTime.getCPUTime'(MS) :- getRunTime(MS). 'System.CPUTime.getElapsedTime'(MS) :- getElapsedTime(MS). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-libs-v3.0.0/src/System/Console/000077500000000000000000000000001400127652700174545ustar00rootroot00000000000000curry-libs-v3.0.0/src/System/Console/GetOpt.curry000066400000000000000000000415351400127652700217540ustar00rootroot00000000000000--- ----------------------------------------------------------------- --- 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 System.Console.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 Data.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-v3.0.0/src/System/Environment.curry000066400000000000000000000037051400127652700214510ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to access parts of the system environment. --- --- @author Michael Hanus, Bernd Brassel, Bjoern Peemoeller --- @version November 2020 --- @category general ------------------------------------------------------------------------------ module System.Environment ( getArgs, getEnv, setEnv, unsetEnv, getProgName , getHostname, isPosix, isWindows ) where --- Returns the list of the program's command line arguments. --- The program name is not included. getArgs :: IO [String] getArgs external --- Returns the value of an environment variable. --- The empty string is returned for undefined environment variables. getEnv :: String -> IO String getEnv evar = prim_getEnviron $## evar prim_getEnviron :: String -> IO String prim_getEnviron external --- 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 --- getEnv (but it is not visible in the environment --- of the process that started the program execution). setEnv :: String -> String -> IO () setEnv evar val = (prim_setEnviron $## evar) $## val prim_setEnviron :: String -> String -> IO () prim_setEnviron external --- Removes an environment variable that has been set by --- setEnv. unsetEnv :: String -> IO () unsetEnv evar = prim_unsetEnviron $## evar prim_unsetEnviron :: String -> IO () prim_unsetEnviron external --- Returns the hostname of the machine running this process. getHostname :: IO String getHostname external --- Returns the name of the current program, i.e., the name of the --- main module currently executed. getProgName :: IO String getProgName external --- Is the underlying operating system a POSIX system (unix, MacOS)? isPosix :: Bool isPosix = not isWindows --- Is the underlying operating system a Windows system? isWindows :: Bool isWindows external curry-libs-v3.0.0/src/System/Environment.kics2000066400000000000000000000046701400127652700213220ustar00rootroot00000000000000{-# LANGUAGE CPP #-} import Control.Exception as C (IOException, handle) import Network.BSD (getHostName) #if __GLASGOW_HASKELL__ < 840 import System.Environment (getArgs, getEnv, setEnv, unsetEnv, getProgName) #else import System.Environment (getArgs, getProgName) import System.Environment.Blank (setEnv, getEnvDefault, unsetEnv) #endif external_d_C_getArgs :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List Curry_Prelude.C_String) external_d_C_getArgs _ _ = toCurry getArgs #if __GLASGOW_HASKELL__ < 840 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 "" #elif 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 (\v -> getEnvDefault v "") str #endif #if __GLASGOW_HASKELL__ < 840 external_d_C_prim_setEnviron :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String external_d_C_prim_setEnviron str val _ _ = toCurry setEnv str val #elif external_d_C_prim_setEnviron :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String external_d_C_prim_setEnviron str val _ _ = toCurry (\s v -> setEnv s v True) str val #endif external_d_C_prim_unsetEnviron :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String external_d_C_prim_getEnviron str _ _ = toCurry unsetEnv str external_d_C_getHostname :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String external_d_C_getHostname _ _ = toCurry getHostName external_d_C_getProgName :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String external_d_C_getProgName _ _ = toCurry getProgName external_d_C_isWindows :: Cover -> ConstStore -> Curry_Prelude.C_Bool #if defined(mingw32_HOST_OS) || defined(__MINGW32__) external_d_C_isWindows _ _ = Curry_Prelude.C_True #else external_d_C_isWindows _ _ = Curry_Prelude.C_False #endif curry-libs-v3.0.0/src/System/Environment.pakcs.pl000066400000000000000000000023131400127652700220120ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module System.Environment % 'System.Environment.getArgs'(StringArgs) :- (rtArgs(Args) -> true ; getProgramArgs(Args)), map2M(basics:atom2String,Args,StringArgs). 'System.Environment.prim_getEnviron'(Var,Value) :- string2Atom(Var,AtomVar), (getEnv(AtomVar,AtomValue) -> atom2String(AtomValue,Value) ; Value = []). % empty string if undefined 'System.Environment.prim_setEnviron'(Var,Value,'Prelude.()') :- string2Atom(Var,AtomVar), string2Atom(Value,AtomValue), setEnv(AtomVar,AtomValue). 'System.Environment.prim_unsetEnviron'(Var,'Prelude.()') :- string2Atom(Var,AtomVar), unsetEnv(AtomVar). 'System.Environment.getHostname'(String) :- getHostname(Name), atom2String(Name,String). 'System.Environment.getProgName'(String) :- user:currentModuleFile(Name,_), atom2String(Name,String). 'System.Environment.isWindows'(Flag) :- getEnv('COMSPEC', _) -> % Windows systems define this environment variable... Flag = 'Prelude.True' ; Flag = 'Prelude.False'. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-libs-v3.0.0/src/System/IO.curry000066400000000000000000000204311400127652700174470ustar00rootroot00000000000000----------------------------------------------------------------------------- --- 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 System.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 import Data.Either --- 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 _ [] = return () 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-v3.0.0/src/System/IO.kics2000066400000000000000000000126751400127652700173310ustar00rootroot00000000000000{-# 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-v3.0.0/src/System/IO.pakcs000066400000000000000000000007361400127652700174120ustar00rootroot00000000000000 prim_hWaitForInput[raw] prim_hWaitForInputs[raw] prim_hWaitForInputsOrMsg[raw] curry-libs-v3.0.0/src/System/IO.pakcs.pl000066400000000000000000000124301400127652700200160ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module System.IO % % Note: the Prolog term '$stream'('$inoutstream'(In,Out)) represents a handle % for a stream that is both readable (on In) and writable (on Out) % Otherwise, handles are represented by Prolog terms of the form '$stream'(N). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % equality of two handles: 'System.IO.handle_eq'(H1,H2,B) :- (H1=H2 -> B='Prelude.True' ; B='Prelude.False'). 'System.IO.stdin'(Stream) :- stdInputStream(Stream). 'System.IO.stdout'(Stream) :- stdOutputStream(Stream). 'System.IO.stderr'(Stream) :- stdErrorStream(Stream). 'System.IO.prim_openFile'(A,Mode,Stream) :- string2Atom(A,FName), curryFileMode2plmode(Mode,PMode), fileOpenOptions(Options), open(FName,PMode,Stream,Options). curryFileMode2plmode('System.IO.ReadMode',read). curryFileMode2plmode('System.IO.WriteMode',write). curryFileMode2plmode('System.IO.AppendMode',append). 'System.IO.prim_hClose'('$stream'('$inoutstream'(In,Out)),'Prelude.()') :- !, flush_output(Out), close(Out), (In==Out -> true ; close(In)). 'System.IO.prim_hClose'(Stream,'Prelude.()') :- (isOutputStream(Stream) -> flush_output(Stream) ; true), close(Stream). 'System.IO.prim_hFlush'('$stream'('$inoutstream'(_,Out)),'Prelude.()') :- !, flush_output(Out). 'System.IO.prim_hFlush'(Stream,'Prelude.()') :- (isOutputStream(Stream) -> flush_output(Stream) ; true). 'System.IO.prim_hIsEOF'('$stream'('$inoutstream'(In,_)),B) :- !, (atEndOfStream(In) -> B='Prelude.True' ; B='Prelude.False'). 'System.IO.prim_hIsEOF'(Stream,B) :- (atEndOfStream(Stream) -> B='Prelude.True' ; B='Prelude.False'). 'System.IO.prim_hSeek'(Handle,SeekMode,Pos,'Prelude.()') :- currySeekMode2plmode(SeekMode,PlSM), seek(Handle,Pos,PlSM,_). currySeekMode2plmode('System.IO.AbsoluteSeek',bof). currySeekMode2plmode('System.IO.RelativeSeek',current). currySeekMode2plmode('System.IO.SeekFromEnd',eof). ?- block prim_hWaitForInput(?,?,?,-,?). prim_hWaitForInput(Hdl,TO,partcall(1,exec_hWaitForInput,[TO,Hdl]),E,E). ?- block exec_hWaitForInput(?,?,?,?,-,?). exec_hWaitForInput(RStream,RTO,World,'$io'(B),E0,E) :- exec_hWaitForInputs([RStream],RTO,World,'$io'(N),E0,E1), (N=0 -> B='Prelude.True' ; B='Prelude.False'), !, E1=E. ?- block prim_hWaitForInputs(?,?,?,-,?). prim_hWaitForInputs(H,T,partcall(1,exec_hWaitForInputs,[T,H]),E,E). ?- block exec_hWaitForInputs(?,?,?,?,-,?). exec_hWaitForInputs(RStreams,RTO,_,'$io'(N),E0,E) :- user:derefAll(RStreams,Streams), selectInstreams(Streams,InStreams), user:derefRoot(RTO,TimeOut), waitForInputDataOnStreams(InStreams,TimeOut,N), !, E0=E. selectInstreams([],[]). selectInstreams(['$stream'('$inoutstream'(In,_))|Streams],[In|InStreams]) :- !, selectInstreams(Streams,InStreams). selectInstreams([Stream|Streams],[Stream|InStreams]) :- selectInstreams(Streams,InStreams). 'System.IO.prim_hGetChar'('$stream'('$inoutstream'(In,_)),C) :- !, get_code(In,N), char_int(C,N). 'System.IO.prim_hGetChar'(Stream,C) :- get_code(Stream,N), char_int(C,N). 'System.IO.prim_hPutChar'('$stream'('$inoutstream'(_,Out)),C,'Prelude.()') :- !, char_int(C,N), put_code(Out,N). 'System.IO.prim_hPutChar'(Stream,C,'Prelude.()') :- char_int(C,N), put_code(Stream,N). 'System.IO.prim_hIsReadable'('$stream'('$inoutstream'(_,_)),'Prelude.True') :- !. 'System.IO.prim_hIsReadable'(Stream,B) :- (isInputStream(Stream) -> B='Prelude.True' ; B='Prelude.False'). 'System.IO.prim_hIsWritable'('$stream'('$inoutstream'(_,_)),'Prelude.True') :- !. 'System.IO.prim_hIsWritable'(Stream,B) :- (isOutputStream(Stream) -> B='Prelude.True' ; B='Prelude.False'). 'System.IO.prim_hIsTerminalDevice'('$stream'('$inoutstream'(_,S)),R) :- !, prim_hIsTerminalDevice(S,R). 'System.IO.prim_hIsTerminalDevice'(Stream,B) :- (isTerminalDeviceStream(Stream) -> B='Prelude.True' ; B='Prelude.False'). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % choice on a stream and an external message stream: ?- block prim_hWaitForInputsOrMsg(?,?,?,-,?). prim_hWaitForInputsOrMsg(H,M,partcall(1,exec_hWaitForInputsOrMsg,[M,H]),E,E). ?- block exec_hWaitForInputsOrMsg(?,-,?,?,?,?), exec_hWaitForInputsOrMsg(?,?,?,?,-,?). exec_hWaitForInputsOrMsg(Handles,share(M),World,Result,E0,E) :- !, get_mutable(V,M), (V='$eval'(R) % external message stream has been already evaluated -> E0=E, Result='$io'('Prelude.Right'(R)) ; exec_hWaitForInputsOrMsg(Handles,V,World,CResult,E0,E), (CResult='$io'('Prelude.Left'(_)) -> Result=CResult ; CResult='$io'('Prelude.Right'(S)), (compileWithSharing(variable) -> user:propagateShare(S,TResult) ; S=TResult), Result='$io'('Prelude.Right'(TResult)), update_mutable('$eval'(TResult),M))). exec_hWaitForInputsOrMsg(_,[M|Ms],_,'$io'('Prelude.Right'([M|Ms])),E0,E) :- !, E0=E. % stream already evaluated exec_hWaitForInputsOrMsg(RHandles,[],_,'$io'('Prelude.Left'(N)),E0,E) :- !, % message stream is empty, so anything must be received from the handles. user:derefAll(RHandles,Handles), selectInstreams(Handles,InStreams), waitForInputDataOnStreams(InStreams,-1,N), !, E0=E. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-libs-v3.0.0/src/System/IO/000077500000000000000000000000001400127652700163615ustar00rootroot00000000000000curry-libs-v3.0.0/src/System/IO/Unsafe.curry000066400000000000000000000213341400127652700206730ustar00rootroot00000000000000------------------------------------------------------------------------------ --- 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 System.IO.Unsafe ( unsafePerformIO, trace #ifdef __PAKCS__ , spawnConstraint, isVar, identicalVar, isGround, compareAnyTerm , showAnyTerm, showAnyQTerm, showAnyExpression, showAnyQExpression , readsAnyUnqualifiedTerm, readAnyUnqualifiedTerm , readsAnyQTerm, readAnyQTerm , readsAnyQExpression, readAnyQExpression #endif ) where import Data.Char (isSpace) import System.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-v3.0.0/src/System/IO/Unsafe.kics2000066400000000000000000000007501400127652700205410ustar00rootroot00000000000000import 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-v3.0.0/src/System/IO/Unsafe.pakcs000066400000000000000000000012441400127652700206260ustar00rootroot00000000000000 prim_unsafePerformIO[raw] prim_spawnConstraint[raw] prim_compareAnyTerm[raw] prim_showAnyExpression[raw] prim_showAnyQExpression[raw] curry-libs-v3.0.0/src/System/IO/Unsafe.pakcs.pl000066400000000000000000000177101400127652700212450ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prolog implementation of builtins of module Unsafe: % ?- block 'prim_unsafePerformIO'(?,?,-,?). 'prim_unsafePerformIO'(Action,H,E0,E) :- worldToken(World), prim_apply(Action,World,'$io'(Result),E0,E1), user:hnf(Result,H,E1,E). ?- block 'prim_spawnConstraint'(?,?,?,-,?). 'prim_spawnConstraint'(Guard,Exp,H,E0,E) :- user:hnf(Guard,S,E0,_), % S='Prelude.True', user:hnf(Exp,H,E0,E). 'System.IO.Unsafe.prim_isVar'(Term,H) :- var(Term), !, H='Prelude.True'. 'System.IO.Unsafe.prim_isVar'('VAR'(_),H) :- !, H='Prelude.True'. % for ports 'System.IO.Unsafe.prim_isVar'(_,'Prelude.False'). 'System.IO.Unsafe.prim_identicalVar'(Y,X,H) :- var(X), var(Y), !, (X==Y -> H='Prelude.True' ; H='Prelude.False'). 'System.IO.Unsafe.prim_identicalVar'(_,X,H) :- var(X), !, H='Prelude.False'. 'System.IO.Unsafe.prim_identicalVar'(Y,_,H) :- var(Y), !, H='Prelude.False'. 'System.IO.Unsafe.prim_identicalVar'('VAR'(I),'VAR'(J),H) :- !, % for ports (I=J -> H='Prelude.True' ; H='Prelude.False'). 'System.IO.Unsafe.prim_identicalVar'(_,_,'Prelude.False'). 'System.IO.Unsafe.prim_isGround'(T,H) :- var(T), !, H='Prelude.False'. 'System.IO.Unsafe.prim_isGround'(T,H) :- functor(T,_,N), prim_isGroundArgs(1,N,T,H). prim_isGroundArgs(A,N,_,H) :- A>N, !, H='Prelude.True'. prim_isGroundArgs(A,N,T,H) :- arg(A,T,Arg), 'System.IO.Unsafe.prim_isGround'(Arg,GA), (GA='Prelude.False' -> H=GA ; A1 is A+1, prim_isGroundArgs(A1,N,T,H)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Comparison of any data term including free variables. ?- block prim_compareAnyTerm(?,?,?,-,?). prim_compareAnyTerm(X,Y,R,E0,E) :- user:hnf(X,HX,E0,E1), user:hnf(Y,HY,E1,E2), prim_compareAnyTermHNF(HX,HY,R,E2,E). ?- block prim_compareAnyTermHNF(?,?,?,-,?). prim_compareAnyTermHNF(X,Y,R,E0,E) :- (var(X) ; var(Y)), !, (X==Y -> R='Prelude.EQ' ; (X@ R='Prelude.LT' ; R='Prelude.GT')), E0=E. prim_compareAnyTermHNF('FAIL'(Src),_,'FAIL'(Src),E,E) :- !. prim_compareAnyTermHNF(_,'FAIL'(Src),'FAIL'(Src),E,E) :- !. prim_compareAnyTermHNF(X,Y,R,E0,E) :- number(X), !, (X=Y -> R='Prelude.EQ' ; (X R='Prelude.LT' ; R='Prelude.GT')), E0=E. prim_compareAnyTermHNF(X,Y,R,E0,E) :- isCharCons(X), !, char_int(X,VX), char_int(Y,VY), (VX=VY -> R='Prelude.EQ' ; (VX R='Prelude.LT' ; R='Prelude.GT')), E0=E. prim_compareAnyTermHNF(X,Y,R,E0,E) :- functor(X,FX,NX), functor(Y,FY,NY), user:constructortype(FX,_,NX,_,IX,_,_), user:constructortype(FY,_,NY,_,IY,_,_), !, (IX R='Prelude.LT', E0=E ; (IX>IY -> R='Prelude.GT', E0=E ; prim_compareAnyTermArgs(1,NX,X,Y,R,E0,E))). ?- block prim_compareAnyTermArgs(?,?,?,?,?,-,?). prim_compareAnyTermArgs(I,N,_,_,R,E0,E) :- I>N, !, R='Prelude.EQ', E0=E. prim_compareAnyTermArgs(I,N,X,Y,R,E0,E) :- arg(I,X,ArgX), arg(I,Y,ArgY), prim_compareAnyTerm(ArgX,ArgY,ArgR,E0,E1), (ArgR='Prelude.EQ' -> I1 is I+1, prim_compareAnyTermArgs(I1,N,X,Y,R,E1,E) ; R=ArgR, E1=E). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % conversion of Curry data terms (with variables) into string representation in % standard prefix notation 'System.IO.Unsafe.prim_showAnyTerm'(Term,String) :- copy_term(Term,CTerm), groundTermVars(CTerm,0,_), readShowTerm:show_term(CTerm,unqualified,String,[]). 'System.IO.Unsafe.prim_showAnyQTerm'(Term,String) :- copy_term(Term,CTerm), groundTermVars(CTerm,0,_), readShowTerm:show_term(CTerm,qualified,String,[]). ?- block prim_showAnyExpression(?,?,-,?). prim_showAnyExpression(Exp,String,E0,E) :- removeShares(Exp,UExp), copy_term(UExp,CExp), groundTermVars(CExp,0,_), readShowTerm:show_term(CExp,unqualified,String,[]), E0=E. ?- block prim_showAnyQExpression(?,?,-,?). prim_showAnyQExpression(Exp,String,E0,E) :- shares2let(Lets,Exp,UExp), bindSingleLets(Lets), copy_term(UExp,CExp), groundTermVars(CExp,0,_), readShowTerm:show_term(CExp,qualified,String,[]), E0=E. % replace all share structures in a term by let expressions: shares2let(_,T,T) :- var(T), !. shares2let(Lets,makeShare(T,_),UT) :- !, shares2let(Lets,T,UT), %???? writeErr('MAKESHARE OCCURRED'), nlErr. shares2let(Lets,share(M),LetVar) :- lookupMutable(Lets,M,LetVar), !. shares2let(Lets,share(M),ShareVar) :- !, get_mutable(V,M), (V='$eval'(Exp) -> true ; Exp=V), shares2let(Lets,Exp,UT), addOL(Lets,(M,_NewVar,UT,ShareVar)). shares2let(Lets,T,UT) :- T =.. [F|Args], shares2letL(Lets,Args,UArgs), UT =.. [F|UArgs]. shares2letL(_,[],[]). shares2letL(L,[X|Xs],[Y|Ys]) :- shares2let(L,X,Y), shares2letL(L,Xs,Ys). % lookup mutable with == in open-ended list: lookupMutable(Binds,_,_) :- var(Binds), !, fail. lookupMutable([(M,V,T,ShareVar)|_],Mut,LetVar) :- Mut==M, !, LetVar=V, ShareVar=let(LetVar,T). % insert let binding lookupMutable([_|Binds],Mut,LetVar) :- lookupMutable(Binds,Mut,LetVar). % add new last element to open-ended list: addOL(Xs,E) :- var(Xs), !, Xs=[E|_]. addOL([_|Xs],E) :- addOL(Xs,E). % bind remaining lets with single occurrences: bindSingleLets(Lets) :- var(Lets), !. bindSingleLets([(_,_,T,ShareVar)|Lets]) :- (var(ShareVar) -> ShareVar=T ; true), bindSingleLets(Lets). % bind free variables in a term to a printable ground representation: groundTermVars(X,I,I1) :- var(X), !, X='_'(I), I1 is I+1. groundTermVars(A,I,I) :- atom(A), !. groundTermVars(T,I,I1) :- T =.. [_|Args], groundTermsVars(Args,I,I1). groundTermsVars([],I,I). groundTermsVars([A|As],I,I2) :- groundTermVars(A,I,I1), groundTermsVars(As,I1,I2). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % conversion of standard prefix string representations of Curry terms % into Curry terms: % conversion of string representations of Curry terms into Curry terms: 'System.IO.Unsafe.prim_readsAnyQTerm'(String,['Prelude.(,)'(Term,TailString)]) :- map2M(basics:char_int,String,PrologString), readShowTerm:readTerm(PrologString,any_qualified,Tail,GTerm), ungroundTermVars(GTerm,Term,_), map2M(basics:char_int,TailString,Tail), !. 'System.IO.Unsafe.prim_readsAnyQTerm'(_,[]). % parse error 'System.IO.Unsafe.prim_readsAnyUnqualifiedTerm'(Prefixes,String, ['Prelude.(,)'(Term,TailString)]) :- (Prefixes=[] -> PrefixDots=any ; map2M(prim_readshowterm:prefix2prefixdot,Prefixes,PrefixDots)), map2M(basics:char_int,String,PrologString), readShowTerm:readTerm(PrologString,any_unqualified(PrefixDots),Tail,GTerm), ungroundTermVars(GTerm,Term,_), map2M(basics:char_int,TailString,Tail), !. 'System.IO.Unsafe.prim_readsAnyUnqualifiedTerm'(_,_,[]). % parse error % conversion of string representations into Curry expressions: 'System.IO.Unsafe.prim_readsAnyQExpression'(String,['Prelude.(,)'(Term,TailString)]) :- map2M(basics:char_int,String,PrologString), readShowTerm:readTerm(PrologString,any_expression,Tail,GTerm), ungroundTermVars(GTerm,LTerm,_), let2share(LTerm,Term), map2M(basics:char_int,TailString,Tail), !. 'System.IO.Unsafe.prim_readsAnyQExpression'(_,[]). % parse error % replace let contruct by share expressions: let2share(T,T) :- var(T), !. let2share(share(M),share(M)) :- !. % ignore if already transformed let2share(let(Var,T),Var) :- !, create_mutable(T,M), Var=share(M). % instantiate all other occurrences let2share(LT,T) :- LT =.. [F|LArgs], map2M(user:let2share,LArgs,Args), T =.. [F|Args]. % replace ground representations by free variables in a term: ungroundTermVars('_'(I),X,Binds) :- !, getVarIndex(Binds,I,X). ungroundTermVars(A,A,_) :- atom(A), !. ungroundTermVars(T,VT,Binds) :- T =.. [C|Args], ungroundTermsVars(Args,VArgs,Binds), VT =.. [C|VArgs]. ungroundTermsVars([],[],_). ungroundTermsVars([A|As],[VA|VAs],Binds) :- ungroundTermVars(A,VA,Binds), ungroundTermsVars(As,VAs,Binds). getVarIndex(Binds,Idx,Var) :- var(Binds), !, Binds=[(Idx=Var)|_]. getVarIndex([(Idx=V)|_],Idx,Var) :- !, V=Var. getVarIndex([_|Binds],Idx,Var) :- getVarIndex(Binds,Idx,Var). curry-libs-v3.0.0/src/Test/000077500000000000000000000000001400127652700155055ustar00rootroot00000000000000curry-libs-v3.0.0/src/Test/Prop.curry000066400000000000000000000204701400127652700175160ustar00rootroot00000000000000------------------------------------------------------------------------- --- 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 :: Data a => (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-v3.0.0/src/Test/Prop/000077500000000000000000000000001400127652700164255ustar00rootroot00000000000000curry-libs-v3.0.0/src/Test/Prop/Types.curry000066400000000000000000000022551400127652700206230ustar00rootroot00000000000000------------------------------------------------------------------------- --- 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-v3.0.0/src/Text/000077500000000000000000000000001400127652700155125ustar00rootroot00000000000000curry-libs-v3.0.0/src/Text/Show.curry000066400000000000000000000017031400127652700175210ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This library provides a type and combinators for show functions using --- functional lists. --- --- @author Bjoern Peemoeller --- @version April 2016 --- @category general -------------------------------------------------------------------------------- module Text.Show ( ShowS , showString, showChar, showParen, shows ) where type ShowS = String -> String --- Prepend a string showString :: String -> ShowS showString s = (s ++) --- 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 curry-libs-v3.0.0/test/000077500000000000000000000000001400127652700147565ustar00rootroot00000000000000curry-libs-v3.0.0/test/TestDataChar.curry000066400000000000000000000012651400127652700203570ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- Test operation for library `Data.Char` -------------------------------------------------------------------------------- import Data.Char import Test.Prop import Control.SearchTree import Control.SearchTree.Generators chrOrdId :: Char -> Prop chrOrdId c = chr (ord c) -=- c lowerUpper :: Char -> Prop lowerUpper c = toLower (toUpper c) -=- toLower c data Digit = Digit { digit :: Int } deriving (Eq,Show) genDigit :: SearchTree Digit genDigit = genCons1 Digit (foldr1 (|||) (map genCons0 [0 .. 15])) digitInt :: Digit -> Prop digitInt (Digit i) = (i >= 0 && i < 16) ==> digitToInt (intToDigit i) -=- i curry-libs-v3.0.0/test/TestEnvironment.curry000066400000000000000000000011401400127652700212040ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library System.Environment --- --- To run all tests automatically by CurryCheck, use the command: --- --- > curry-check TestEnvironment ------------------------------------------------------------------------------ import System.Environment import Test.Prop -- Testing environment variable handling: evar = "asd123" testGetUndefinedEnviron = (getEnv evar) `returns` "" testSetEnviron = (setEnv evar "SET" >> getEnv evar) `returns` "SET" testUnsetEnviron = (unsetEnv evar >> getEnv evar) `returns` "" curry-libs-v3.0.0/test/TestFunction.curry000066400000000000000000000012231400127652700204670ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library `Data.Function` --- --- To run all tests automatically by CurryCheck, use the command: --- --- > curry-check TestFunction ------------------------------------------------------------------------------ import Data.Function import Test.Prop testOnMult :: (a -> Int) -> a -> a -> Prop testOnMult f x y = ((*) `on` f) x y -=- f x * f y testOnAdd1 :: Ordering -> Ordering -> Prop testOnAdd1 x y = ((+) `on` f) x y -=- f x + f y where f = fromEnum testOnAdd2 :: Int -> Int -> Prop testOnAdd2 x y = ((+) `on` f) x y -=- f x + f y where f = \n -> n*n curry-libs-v3.0.0/test/TestIORefs.curry000066400000000000000000000011231400127652700200300ustar00rootroot00000000000000-- Testing operations from library IOExts: import Data.IORef import Data.List ( replace ) import Test.Prop ioref1 = do r <- newIORef (1,True) (n,_) <- readIORef r writeIORef r (n,False) readIORef r testIORef1 = ioref1 `returns` (1,False) ioref2 = do r <- newIORef [1,2..] l1 <- readIORef r writeIORef r (replace 42 2 l1) l2 <- readIORef r return (take 5 l2) testIORefInfinite = ioref2 `returns` [1,2,42,4,5] ioref3 = do r <- let x free in newIORef (x,x) (_,y) <- readIORef r doSolve (y=:=1) (z,_) <- readIORef r return z testIORefLogic = ioref3 `returns` 1 curry-libs-v3.0.0/test/TestList.curry000066400000000000000000000027461400127652700176300ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library `Data.List` --- --- To run all tests automatically by CurryCheck, use the command: --- --- > curry-check TestList ------------------------------------------------------------------------------ import Data.List import Test.Prop -- Now we can test properties of our program: testAppend = ([1,2]++[3,4]) -=- [1,2,3,4] testNub = (nub [1,3,1,2,3,2,4]) -=- [1,3,2,4] nubNub :: Eq a => [a] -> [a] nubNub = nub . nub propNub = nubNub <=> (nub :: [Int] -> [Int]) testAll = always (all (<5) [1,2,3,4]) -- Specification of `last`: lastSpec :: Data a => [a] -> a lastSpec (_ ++ [x]) = x lastCorrect :: Prop lastCorrect = last <=> (lastSpec :: [Int] -> Int) -- Specification of `init` (which is slightly more strict): initSpec :: Data a => [a] -> [a] initSpec (xs ++ [_]) = xs initGroundCorrect :: [Int] -> Prop initGroundCorrect xs = init xs <~> initSpec xs propDelete :: Int -> [Int] -> Prop propDelete x xs = x `notElem` xs ==> delete x xs -=- xs propUnion1 :: Int -> [Int] -> Prop propUnion1 x xs = always (x `elem` union xs [x]) propUnion2 :: Int -> [Int] -> [Int] -> Prop propUnion2 x xs ys = x `elem` union xs ys -=- x `elem` xs || x `elem` ys propIntersect :: Int -> [Int] -> [Int] -> Prop propIntersect x xs ys = x `elem` intersect xs ys -=- x `elem` xs && x `elem` ys propPermutations :: [Int] -> Prop propPermutations xs = length (permutations xs) -=- foldr (*) 1 [1 .. length xs] curry-libs-v3.0.0/test/TestPrelude.curry000066400000000000000000000022471400127652700203110ustar00rootroot00000000000000-- Testing Prelude operations: import Test.Prop -- Test simple arithmetic: testPlus = (2+3) -=- 5 testMinus = (1 - 5) -=- (-4) -- Testing compare: testCompare1 = (compare True False) -=- GT testCompare2 = (compare 3 4) -=- LT testCompare3 = (compare Nothing (Just (not unknown))) -=- LT testCompare4 = (compare (True,failed) (False,True)) -=- GT testCompare5 = failing (compare (True,failed) (True,True)) testCompare6 = (compare 'A' 'a') -=- LT testCompare7 = (compare "AAB" "AA") -=- GT -- Testing integer arithmetic: testDiv1 = (13 `div` 5) -=- 2 testDiv2 = (15 `div` (-4)) -=- (-4) testMod1 = (13 `mod` 5) -=- 3 testMod2 = ((-15) `mod` 4) -=- 1 testQuot1 = (13 `quot` 5) -=- 2 testQuot2 = (15 `quot` (-4)) -=- (-3) testRem1 = (13 `rem` 5) -=- 3 testRem2 = ((-15) `rem` 4) -=- (-3) testDivMod1 = (divMod 7 2) -=- (3,1) testDivMod2 = (divMod 7 (-2)) -=- (-4,-1) testQuotRem1 = (quotRem 7 2) -=- (3,1) testQuotRem2 = (quotRem 7 (-2)) -=- (-3,1) testModDivProperty x y = y/=0 ==> x `mod` y -=- x - y * (x `div` y) testRemQuotProperty x y = y/=0 ==> x `rem` y -=- x - y * (x `quot` y) curry-libs-v3.0.0/test/TestTextShow.curry000066400000000000000000000022101400127652700204640ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- Test operation for library Text.Show -------------------------------------------------------------------------------- import Prelude hiding ( ShowS, showString ) import Text.Show import Test.Prop showStringIsString :: String -> Prop showStringIsString s = showString s [] -=- s showStringConcat :: String -> String -> Prop showStringConcat s1 s2 = (showString s1 . showString s2) [] -=- s1++s2 --- 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 :: Int -> String -> Prop 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 :: [String] -> Prop concatSIsConcat xs = concatS (map showString xs) [] -=- concat xs