hSeek in a file.
data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
--- Standard input stream.
stdin :: Handle
stdin external
--- Standard output stream.
stdout :: Handle
stdout external
--- Standard error stream.
stderr :: Handle
stderr external
--- Opens a file in specified mode and returns a handle to it.
openFile :: String -> IOMode -> IO Handle
openFile filename mode = (prim_openFile $## filename) $# mode
prim_openFile :: String -> IOMode -> IO Handle
prim_openFile external
--- Closes a file handle and flushes the buffer in case of output file.
hClose :: Handle -> IO ()
hClose h = prim_hClose $# h
prim_hClose :: Handle -> IO ()
prim_hClose external
--- Flushes the buffer associated to handle in case of output file.
hFlush :: Handle -> IO ()
hFlush h = prim_hFlush $# h
prim_hFlush :: Handle -> IO ()
prim_hFlush external
--- Is handle at end of file?
hIsEOF :: Handle -> IO Bool
hIsEOF h = prim_hIsEOF $# h
prim_hIsEOF :: Handle -> IO Bool
prim_hIsEOF external
--- Is standard input at end of file?
isEOF :: IO Bool
isEOF = hIsEOF stdin
--- Set the position of a handle to a seekable stream (e.g., a file).
--- If the second argument is AbsoluteSeek,
--- SeekFromEnd, or RelativeSeek,
--- the position is set relative to the beginning of the file,
--- to the end of the file, or to the current position, respectively.
hSeek :: Handle -> SeekMode -> Int -> IO ()
hSeek h sm pos = ((prim_hSeek $# h) $# sm) $# pos
prim_hSeek :: Handle -> SeekMode -> Int -> IO ()
prim_hSeek external
--- Waits until input is available on the given handle.
--- If no input is available within t milliseconds, it returns False,
--- otherwise it returns True.
--- @param handle - a handle for an input stream
--- @param timeout - milliseconds to wait for input (< 0 : no time out)
hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput handle timeout = (prim_hWaitForInput $# handle) $## timeout
prim_hWaitForInput :: Handle -> Int -> IO Bool
prim_hWaitForInput external
--- Waits until input is available on some of the given handles.
--- If no input is available within t milliseconds, it returns -1,
--- otherwise it returns the index of the corresponding handle with the available
--- data.
--- @param handles - a list of handles for input streams
--- @param timeout - milliseconds to wait for input (< 0 : no time out)
--- @return -1 if no input is available within the time out, otherwise i
--- if (handles!!i) has data available
hWaitForInputs :: [Handle] -> Int -> IO Int
hWaitForInputs handles timeout = (prim_hWaitForInputs $## handles) $## timeout
prim_hWaitForInputs :: [Handle] -> Int -> IO Int
prim_hWaitForInputs external
--- Waits until input is available on a given handles or a message
--- in the message stream. Usually, the message stream comes from an external port.
--- Thus, this operation implements a committed choice over receiving input
--- from an IO handle or an external port.
---
--- Note that the implementation of this operation works only with
--- Sicstus-Prolog 3.8.5 or higher (due to a bug in previous versions
--- of Sicstus-Prolog).
---
--- @param handle - a handle for an input stream
--- @param msgs - a stream of messages received via an external port (see Ports)
--- @return (Left handle) if the handle has some data available
--- (Right msgs) if the stream msgs is instantiated
--- with at least one new message at the head
hWaitForInputOrMsg :: Handle -> [msg] -> IO (Either Handle [msg])
hWaitForInputOrMsg handle msgs = do
input <- hWaitForInputsOrMsg [handle] msgs
return $ either (\_ -> Left handle) Right input
--- Waits until input is available on some of the given handles or a message
--- in the message stream. Usually, the message stream comes from an external port.
--- Thus, this operation implements a committed choice over receiving input
--- from IO handles or an external port.
---
--- Note that the implementation of this operation works only with
--- Sicstus-Prolog 3.8.5 or higher (due to a bug in previous versions
--- of Sicstus-Prolog).
---
--- @param handles - a list of handles for input streams
--- @param msgs - a stream of messages received via an external port (see Ports)
--- @return (Left i) if (handles!!i) has some data available
--- (Right msgs) if the stream msgs is instantiated
--- with at least one new message at the head
hWaitForInputsOrMsg :: [Handle] -> [msg] -> IO (Either Int [msg])
hWaitForInputsOrMsg handles msgs =
seq (normalForm (map ensureNotFree (ensureSpine handles)))
(prim_hWaitForInputsOrMsg handles msgs)
prim_hWaitForInputsOrMsg :: [Handle] -> [msg] -> IO (Either Int [msg])
prim_hWaitForInputsOrMsg external
--- Checks whether an input is available on a given handle.
hReady :: Handle -> IO Bool
hReady h = hWaitForInput h 0
--- Reads a character from an input handle and returns it.
--- Throws an error if the end of file has been reached.
hGetChar :: Handle -> IO Char
hGetChar h = prim_hGetChar $# h
prim_hGetChar :: Handle -> IO Char
prim_hGetChar external
--- Reads a line from an input handle and returns it.
--- Throws an error if the end of file has been reached while reading
--- the *first* character. If the end of file is reached later in the line,
--- it ist treated as a line terminator and the (partial) line is returned.
hGetLine :: Handle -> IO String
hGetLine h = do c <- hGetChar h
if c == '\n'
then return []
else do eof <- hIsEOF h
if eof then return [c]
else do cs <- hGetLine h
return (c:cs)
--- Reads the complete contents from an input handle and closes the input handle
--- before returning the contents.
hGetContents :: Handle -> IO String
hGetContents h = do
eof <- hIsEOF h
if eof then hClose h >> return ""
else do c <- hGetChar h
cs <- hGetContents h
return (c:cs)
--- Reads the complete contents from the standard input stream until EOF.
getContents :: IO String
getContents = hGetContents stdin
--- Puts a character to an output handle.
hPutChar :: Handle -> Char -> IO ()
hPutChar h c = (prim_hPutChar $# h) $## c
prim_hPutChar :: Handle -> Char -> IO ()
prim_hPutChar external
--- Puts a string to an output handle.
hPutStr :: Handle -> String -> IO ()
hPutStr _ [] = done
hPutStr h (c:cs) = hPutChar h c >> hPutStr h cs
--- Puts a string with a newline to an output handle.
hPutStrLn :: Handle -> String -> IO ()
hPutStrLn h s = hPutStr h s >> hPutChar h '\n'
--- Converts a term into a string and puts it to an output handle.
hPrint :: Show a => Handle -> a -> IO ()
hPrint h = hPutStrLn h . show
--- Is the handle readable?
hIsReadable :: Handle -> IO Bool
hIsReadable h = prim_hIsReadable $# h
prim_hIsReadable :: Handle -> IO Bool
prim_hIsReadable external
--- Is the handle writable?
hIsWritable :: Handle -> IO Bool
hIsWritable h = prim_hIsWritable $# h
prim_hIsWritable :: Handle -> IO Bool
prim_hIsWritable external
--- Is the handle connected to a terminal?
hIsTerminalDevice :: Handle -> IO Bool
hIsTerminalDevice h = prim_hIsTerminalDevice $# h
prim_hIsTerminalDevice :: Handle -> IO Bool
prim_hIsTerminalDevice external
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/IO.kics2 0000664 0000000 0000000 00000012675 13231616147 0022742 0 ustar 00root root 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses #-}
import Control.Concurrent
import qualified Control.Exception as C (IOException, catch, throw)
import Control.Monad (zipWithM)
import System.IO
import System.IO.Error (isEOFError)
type C_Handle = PrimData CurryHandle
instance ConvertCurryHaskell C_IOMode IOMode where
toCurry ReadMode = C_ReadMode
toCurry WriteMode = C_WriteMode
toCurry AppendMode = C_AppendMode
fromCurry C_ReadMode = ReadMode
fromCurry C_WriteMode = WriteMode
fromCurry C_AppendMode = AppendMode
fromCurry _ = error "IOMode data with no ground term occurred"
instance ConvertCurryHaskell C_SeekMode SeekMode where
toCurry AbsoluteSeek = C_AbsoluteSeek
toCurry RelativeSeek = C_RelativeSeek
toCurry SeekFromEnd = C_SeekFromEnd
fromCurry C_AbsoluteSeek = AbsoluteSeek
fromCurry C_RelativeSeek = RelativeSeek
fromCurry C_SeekFromEnd = SeekFromEnd
fromCurry _ = error "SeekMode data with no ground term occurred"
external_d_C_handle_eq :: C_Handle -> C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_Bool
external_d_C_handle_eq (PrimData h1) (PrimData h2) _ _ = toCurry (h1 == h2)
external_d_C_stdin :: Cover -> ConstStore -> C_Handle
external_d_C_stdin _ _ = PrimData (OneHandle stdin)
external_d_C_stdout :: Cover -> ConstStore -> C_Handle
external_d_C_stdout _ _ = PrimData (OneHandle stdout)
external_d_C_stderr :: Cover -> ConstStore -> C_Handle
external_d_C_stderr _ _ = PrimData (OneHandle stderr)
external_d_C_prim_openFile :: Curry_Prelude.OP_List Curry_Prelude.C_Char -> C_IOMode
-> Cover -> ConstStore -> Curry_Prelude.C_IO C_Handle
external_d_C_prim_openFile fn mode _ _ =
toCurry (\s m -> openFile s m >>= return . OneHandle) fn mode
external_d_C_prim_hClose :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_hClose handle _ _ = toCurry
(\ch -> case ch of OneHandle h -> hClose h
InOutHandle h1 h2 -> hClose h1 >> hClose h2) handle
external_d_C_prim_hFlush :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_hFlush h _ _ = toCurry (hFlush . outputHandle) h
external_d_C_prim_hIsEOF :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool
external_d_C_prim_hIsEOF h _ _ = toCurry (hIsEOF . inputHandle) h
external_d_C_prim_hSeek :: C_Handle -> C_SeekMode -> Curry_Prelude.C_Int
-> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_hSeek handle mode i _ _
= toCurry (hSeek . inputHandle) handle mode i
external_d_C_prim_hWaitForInput :: C_Handle -> Curry_Prelude.C_Int -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_Bool
external_d_C_prim_hWaitForInput handle timeout _ _
= toCurry (myhWaitForInput . inputHandle) handle timeout
myhWaitForInput :: Handle -> Int -> IO Bool
myhWaitForInput h timeout = C.catch (hWaitForInput h timeout) handler
where
handler :: C.IOException -> IO Bool
handler e = if isEOFError e then return False else C.throw e
external_d_C_prim_hWaitForInputs :: Curry_Prelude.OP_List C_Handle -> Curry_Prelude.C_Int
-> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int
external_d_C_prim_hWaitForInputs hs i _ _ = toCurry selectHandle hs i
selectHandle :: [CurryHandle] -> Int -> IO Int
selectHandle handles timeout = do
mvar <- newEmptyMVar
threads <- zipWithM
(\ i h -> forkIO (waitOnHandle (inputHandle h) i timeout mvar))
[0 ..] handles
inspectRes (length handles) mvar threads
inspectRes :: Int -> MVar (Maybe Int) -> [ThreadId] -> IO Int
inspectRes 0 _ _ = return (-1)
inspectRes n mvar threads = do
res <- takeMVar mvar
case res of
Nothing -> inspectRes (n - 1) mvar threads
Just v -> mapM_ killThread threads >> return v
waitOnHandle :: Handle -> Int -> Int -> MVar (Maybe Int) -> IO ()
waitOnHandle h v timeout mvar = do
ready <- myhWaitForInput h timeout
putMVar mvar (if ready then Just v else Nothing)
external_d_C_prim_hWaitForInputsOrMsg ::
Curry_Prelude.Curry a => Curry_Prelude.OP_List C_Handle -> Curry_Prelude.OP_List a -> Cover -> ConstStore
-> Curry_Prelude.C_IO (Curry_Prelude.C_Either Curry_Prelude.C_Int (Curry_Prelude.OP_List a))
external_d_C_prim_hWaitForInputsOrMsg = error "hWaitForInputsOrMsg undefined"
external_d_C_prim_hGetChar :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Char
external_d_C_prim_hGetChar h _ _ = toCurry (hGetChar . inputHandle) h
external_d_C_prim_hPutChar :: C_Handle -> Curry_Prelude.C_Char -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_hPutChar h c _ _ = toCurry (hPutChar . outputHandle) h c
external_d_C_prim_hIsReadable :: C_Handle -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_Bool
external_d_C_prim_hIsReadable h _ _ = toCurry (hIsReadable . inputHandle) h
external_d_C_prim_hIsWritable :: C_Handle -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_Bool
external_d_C_prim_hIsWritable h _ _ = toCurry (hIsWritable . outputHandle) h
external_d_C_prim_hIsTerminalDevice :: C_Handle -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_Bool
external_d_C_prim_hIsTerminalDevice h _ _ =
toCurry (hIsTerminalDevice . outputHandle) h
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/IO.pakcs 0000664 0000000 0000000 00000004220 13231616147 0023013 0 ustar 00root root 0000000 0000000
IO.hClose since they are not
--- closed automatically when the process terminates.
--- @param cmd - the shell command to be executed
--- @return the handles of the input/output/error streams of the new process
execCmd :: String -> IO (Handle, Handle, Handle)
execCmd cmd = prim_execCmd $## cmd
prim_execCmd :: String -> IO (Handle, Handle, Handle)
prim_execCmd external
--- Executes a command with the given arguments as a new default shell process
--- and provides the input via the process' stdin input stream.
--- The exit code of the process and the contents written to the standard
--- I/O streams stdout and stderr are returned.
--- @param cmd - the shell command to be executed
--- @param args - the command's arguments
--- @param input - the input to be written to the command's stdin
--- @return the exit code and the contents written to stdout and stderr
evalCmd :: String -> [String] -> String -> IO (Int, String, String)
#ifdef __PAKCS__
evalCmd cmd args input = do
pid <- getPID
let tmpfile = "/tmp/PAKCS_evalCMD"++show pid
(hi,ho,he) <- execCmd (unwords (map wrapArg (cmd:args)) ++
" ; (echo $? > "++tmpfile++")")
unless (null input) (hPutStrLn hi input)
hClose hi
outs <- hGetEOF ho
errs <- hGetEOF he
ecodes <- readCompleteFile tmpfile
removeFile tmpfile
return (readNat ecodes, outs, errs)
where
wrapArg str
| null str = "''"
-- goodChar is a pessimistic predicate, such that if an argument is
-- non-empty and only contains goodChars, then there is no need to
-- do any quoting or escaping
| all goodChar str = str
| otherwise = '\'' : foldr escape "'" str
where escape c s
| c == '\'' = "'\\''" ++ s
| otherwise = c : s
goodChar c = isAlphaNum c || c `elem` "-_.,/"
--- Reads from an input handle until EOF and returns the input.
hGetEOF :: Handle -> IO String
hGetEOF h = do
eof <- hIsEOF h
if eof
then hClose h >> return ""
else do c <- hGetChar h
cs <- hGetEOF h
return (c:cs)
#else
evalCmd cmd args input = ((prim_evalCmd $## cmd) $## args) $## input
prim_evalCmd :: String -> [String] -> String -> IO (Int, String, String)
prim_evalCmd external
#endif
--- Executes a command with a new default shell process.
--- The input and output streams of the new process is returned
--- as one handle which is both readable and writable.
--- Thus, writing to the handle produces input to the process and
--- output from the process can be retrieved by reading from this handle.
--- The handle should be closed with IO.hClose since they are not
--- closed automatically when the process terminates.
--- @param cmd - the shell command to be executed
--- @return the handle connected to the input/output streams
--- of the new process
connectToCommand :: String -> IO Handle
connectToCommand cmd = prim_connectToCmd $## cmd
prim_connectToCmd :: String -> IO Handle
prim_connectToCmd external
--- An action that reads the complete contents of a file and returns it.
--- This action can be used instead of the (lazy) readFile
--- action if the contents of the file might be changed.
--- @param file - the name of the file
--- @return the complete contents of the file
readCompleteFile :: String -> IO String
readCompleteFile file = do
s <- readFile file
f s (return s)
where
f [] r = r
f (_:cs) r = f cs r
--- An action that updates the contents of a file.
--- @param f - the function to transform the contents
--- @param file - the name of the file
updateFile :: (String -> String) -> String -> IO ()
updateFile f file = do
s <- readCompleteFile file
writeFile file (f s)
--- Forces the exclusive execution of an action via a lock file.
--- For instance, (exclusiveIO "myaction.lock" act) ensures that
--- the action "act" is not executed by two processes on the same
--- system at the same time.
--- @param lockfile - the name of a global lock file
--- @param action - the action to be exclusively executed
--- @return the result of the execution of the action
exclusiveIO :: String -> IO a -> IO a
exclusiveIO lockfile action = do
system ("lockfile-create --lock-name "++lockfile)
catch (do actionResult <- action
deleteLockFile
return actionResult )
(\e -> deleteLockFile >> ioError e)
where
deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile
--- Defines a global association between two strings.
--- Both arguments must be evaluable to ground terms before applying
--- this operation.
setAssoc :: String -> String -> IO ()
setAssoc key val = (prim_setAssoc $## key) $## val
prim_setAssoc :: String -> String -> IO ()
prim_setAssoc external
--- Gets the value associated to a string.
--- Nothing is returned if there does not exist an associated value.
getAssoc :: String -> IO (Maybe String)
getAssoc key = prim_getAssoc $## key
prim_getAssoc :: String -> IO (Maybe String)
prim_getAssoc external
--- Mutable variables containing values of some type.
--- The values are not evaluated when they are assigned to an IORef.
#ifdef __PAKCS__
data IORef a = IORef a -- precise structure internally defined
#else
external data IORef _ -- precise structure internally defined
#endif
--- Creates a new IORef with an initial value.
newIORef :: a -> IO (IORef a)
newIORef external
--- Reads the current value of an IORef.
readIORef :: IORef a -> IO a
readIORef ref = prim_readIORef $# ref
prim_readIORef :: IORef a -> IO a
prim_readIORef external
--- Updates the value of an IORef.
writeIORef :: IORef a -> a -> IO ()
writeIORef ref val = (prim_writeIORef $# ref) val
prim_writeIORef :: IORef a -> a -> IO ()
prim_writeIORef external
--- Modify the value of an IORef.
modifyIORef :: IORef a -> (a -> a) -> IO ()
modifyIORef ref f = readIORef ref >>= writeIORef ref . f
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/IOExts.kics2 0000664 0000000 0000000 00000015211 13231616147 0023573 0 ustar 00root root 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses #-}
import Data.IORef
import System.IO.Unsafe (unsafePerformIO) -- for global associations
import System.Process (readProcessWithExitCode, runInteractiveCommand)
import Control.Concurrent (forkIO)
import System.IO
external_d_C_prim_execCmd :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_IO.C_Handle Curry_IO.C_Handle Curry_IO.C_Handle)
external_d_C_prim_execCmd str _ _ = toCurry
(\s -> do (h1,h2,h3,_) <- runInteractiveCommand s
return (OneHandle h1, OneHandle h2, OneHandle h3)) str
external_d_C_prim_evalCmd :: Curry_Prelude.C_String -> Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_Prelude.C_Int Curry_Prelude.C_String Curry_Prelude.C_String)
external_d_C_prim_evalCmd cmd args input _ _
= toCurry readProcessWithExitCode cmd args input
external_d_C_prim_connectToCmd :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_IO.C_Handle
external_d_C_prim_connectToCmd str _ _ = toCurry
(\s -> do (hin,hout,herr,_) <- runInteractiveCommand s
forkIO (forwardError herr)
return (InOutHandle hout hin)) str
forwardError :: Handle -> IO ()
forwardError h = do
eof <- hIsEOF h
if eof then return ()
else hGetLine h >>= hPutStrLn stderr >> forwardError h
-----------------------------------------------------------------------
-- Implementation of global associations as simple association lists
-- (could be later improved by a more efficient implementation, e.g., maps)
type Assocs = [(String,String)]
assocs :: IORef Assocs
assocs = unsafePerformIO (newIORef [])
external_d_C_prim_setAssoc :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_setAssoc str1 str2 _ _ = toCurry
(\key val -> do as <- readIORef assocs
writeIORef assocs ((key,val):as)) str1 str2
external_d_C_prim_getAssoc :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.C_String))
external_d_C_prim_getAssoc str _ _ = toCurry
(\key -> do as <- readIORef assocs
return (lookup key as)) str
-----------------------------------------------------------------------
-- Implementation of IORefs in Curry. Note that we store Curry values
-- (and not the corresponding Haskell values) in the Haskell IORefs
data C_IORef a
= Choice_C_IORef Cover ID (C_IORef a) (C_IORef a)
| Choices_C_IORef Cover ID ([C_IORef a])
| Fail_C_IORef Cover FailInfo
| Guard_C_IORef Cover Constraints (C_IORef a)
| C_IORef (IORef a)
instance Show (C_IORef a) where
show = error "ERROR: no show for IORef"
instance Read (C_IORef a) where
readsPrec = error "ERROR: no read for IORef"
instance NonDet (C_IORef a) where
choiceCons = Choice_C_IORef
choicesCons = Choices_C_IORef
failCons = Fail_C_IORef
guardCons = Guard_C_IORef
try (Choice_C_IORef cd i x y) = tryChoice cd i x y
try (Choices_C_IORef cd s xs) = tryChoices cd s xs
try (Fail_C_IORef cd info) = Fail cd info
try (Guard_C_IORef cd c e) = Guard cd c e
try x = Val x
match f _ _ _ _ _ (Choice_C_IORef cd i x y) = f cd i x y
match _ f _ _ _ _ (Choices_C_IORef cd i@(NarrowedID _ _) xs) = f cd i xs
match _ _ f _ _ _ (Choices_C_IORef cd i@(FreeID _ _) xs) = f cd i xs
match _ _ _ _ _ _ (Choices_C_IORef _ i _) =
error ("IOExts.IORef.match: Choices with ChoiceID " ++ show i)
match _ _ _ f _ _ (Fail_C_IORef cd info) = f cd info
match _ _ _ _ f _ (Guard_C_IORef cd cs e) = f cd cs e
match _ _ _ _ _ f x = f x
instance Generable (C_IORef a) where
generate _ _ = error "ERROR: no generator for IORef"
instance NormalForm (C_IORef a) where
($!!) cont ioref@(C_IORef _) cd cs = cont ioref cd cs
($!!) cont (Choice_C_IORef d i io1 io2) cd cs = nfChoice cont d i io1 io2 cd cs
($!!) cont (Choices_C_IORef d i ios) cd cs = nfChoices cont d i ios cd cs
($!!) cont (Guard_C_IORef d c io) cd cs
= guardCons d c ((cont $!! io) cd $! (addCs c cs))
($!!) _ (Fail_C_IORef d info) _ _ = failCons d info
($##) cont io@(C_IORef _) cd cs = cont io cd cs
($##) cont (Choice_C_IORef d i io1 io2) cd cs = gnfChoice cont d i io1 io2 cd cs
($##) cont (Choices_C_IORef d i ios) cd cs = gnfChoices cont d i ios cd cs
($##) cont (Guard_C_IORef d c io) cd cs
= guardCons d c ((cont $## io) cd $! (addCs c cs))
($##) _ (Fail_C_IORef d info) cd cs = failCons d info
searchNF _ cont ioref@(C_IORef _) = cont ioref
instance Unifiable (C_IORef a) where
(=.=) _ _ = error "(=.=) for C_IORef"
(=.<=) _ _ = error "(=.<=) for C_IORef"
bind cd i (Choice_C_IORef d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))]
bind cd i (Choices_C_IORef d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs
bind cd i (Choices_C_IORef d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))]
bind _ _ (Fail_C_IORef cd info) = [Unsolvable info]
bind cd i (Guard_C_IORef _ cs e) = (getConstrList cs) ++ (bind cd i e)
lazyBind cd i (Choice_C_IORef d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))]
lazyBind cd i (Choices_C_IORef d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs
lazyBind cd i (Choices_C_IORef d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))]
lazyBind _ _ (Fail_C_IORef cd info) = [Unsolvable info]
lazyBind cd i (Guard_C_IORef _ cs e) = (getConstrList cs) ++ [(i :=: (LazyBind (lazyBind cd i e)))]
instance Curry_Prelude.Curry a => Curry_Prelude.Curry (C_IORef a)
instance ConvertCurryHaskell (C_IORef a) (IORef a) where
fromCurry (C_IORef r) = r
fromCurry _ = error "IORef with no ground term occurred"
toCurry r = C_IORef r
external_d_C_newIORef :: Curry_Prelude.Curry a => a -> Cover -> ConstStore
-> Curry_Prelude.C_IO (C_IORef a)
external_d_C_newIORef cv _ _ = toCurry (newIORef cv)
external_d_C_prim_readIORef :: Curry_Prelude.Curry a => C_IORef a -> Cover -> ConstStore
-> Curry_Prelude.C_IO a
external_d_C_prim_readIORef ref _ _ = fromIO (readIORef (fromCurry ref))
external_d_C_prim_writeIORef :: Curry_Prelude.Curry a => C_IORef a -> a
-> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_writeIORef ref cv _ _ = toCurry (writeIORef (fromCurry ref) cv)
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/IOExts.pakcs 0000664 0000000 0000000 00000002004 13231616147 0023655 0 ustar 00root root 0000000 0000000
Socket), this library uses the Curry Port Name Server
--- to provide sockets that are addressed by symbolic names
--- rather than numbers.
---
--- In standard applications, the server side uses the operations
--- listenOn and socketAccept to provide some service
--- on a named socket, and the client side uses the operation
--- connectToSocket to request a service.
---
--- @author Michael Hanus
--- @version February 2008
--- @category general
------------------------------------------------------------------------------
module NamedSocket(Socket,
listenOn, socketAccept, waitForSocketAccept,
connectToSocketRepeat, connectToSocketWait,
sClose, socketName, connectToSocket)
where
import System
import IO(Handle)
import qualified Socket
import CPNS
---------------------------------------------------------------------
-- Server side operations:
--- Abstract type for named sockets.
data Socket = NamedSocket String Socket.Socket
--- Creates a server side socket with a symbolic name.
listenOn :: String -> IO Socket
listenOn socketname = do
(port,socket) <- Socket.listenOnFresh
registerPort socketname port 0
return (NamedSocket socketname socket)
--- Returns a connection of a client to a socket.
--- The connection is returned as a pair consisting of a string identifying
--- the client (the format of this string is implementation-dependent)
--- and a handle to a stream communication with the client.
--- The handle is both readable and writable.
socketAccept :: Socket -> IO (String,Handle)
socketAccept (NamedSocket _ socket) = Socket.socketAccept socket
--- Waits until a connection of a client to a socket is available.
--- If no connection is available within the time limit, it returns Nothing,
--- otherwise the connection is returned as a pair consisting
--- of a string identifying the client
--- (the format of this string is implementation-dependent)
--- and a handle to a stream communication with the client.
--- @param socket - a socket
--- @param timeout - milliseconds to wait for input (< 0 : no time out)
waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle))
waitForSocketAccept (NamedSocket _ socket) = Socket.waitForSocketAccept socket
--- Closes a server socket.
sClose :: Socket -> IO ()
sClose (NamedSocket socketname socket) = do
Socket.sClose socket
unregisterPort socketname
--- Returns a the symbolic name of a named socket.
socketName :: Socket -> String
socketName (NamedSocket socketname _) = socketname
---------------------------------------------------------------------
-- Client side operations:
--- Waits for connection to a Unix socket with a symbolic name.
--- In contrast to connectToSocket, this action waits until
--- the socket has been registered with its symbolic name.
--- @param waittime - the time to wait before retrying (in milliseconds)
--- @param action - I/O action to be executed before each wait cycle
--- @param retries - number of retries before giving up (-1 = retry forever)
--- @param nameAtHost - the symbolic name of the socket
--- (must be either of the form "name@host" or "name"
--- where the latter is a shorthand for "name@localhost")
--- @return Nothing (if connection is not possible within the given limits)
--- or (Just h) where h is the handle of the connection
connectToSocketRepeat :: Int -> IO _ -> Int -> String -> IO (Maybe Handle)
connectToSocketRepeat waittime action retries nameAtHost = do
let (name,atHost) = break (=='@') nameAtHost
host = if atHost=="" then "localhost" else tail atHost
-- check whether remote CPNS demon is alive:
alive <- cpnsAlive waittime host
if not alive
then tryAgain
else do -- get remote socket/port numbers:
(snr,_) <- getPortInfo name host
if snr==0
then tryAgain
else Socket.connectToSocket host snr >>= return . Just
where
tryAgain = if retries==0 then return Nothing else do
action
sleep (ms2s waittime)
connectToSocketRepeat waittime action (decr retries) nameAtHost
ms2s n = let mn = n `div` 1000 in if mn==0 then 1 else mn
decr n = if n<0 then n else n-1
--- Waits for connection to a Unix socket with a symbolic name and
--- return the handle of the connection.
--- This action waits (possibly forever) until the socket with the symbolic
--- name is registered.
--- @param nameAtHost - the symbolic name of the socket
--- (must be either of the form "name@host" or "name"
--- where the latter is a shorthand for "name@localhost")
--- @return the handle of the connection (connected to the socket nameAtHost)
--- which is both readable and writable
connectToSocketWait :: String -> IO Handle
connectToSocketWait nameAtHost = do
Just hdl <- connectToSocketRepeat 1000 done (-1) nameAtHost
return hdl
--- Creates a new connection to an existing(!) Unix socket with a symbolic
--- name. If the symbolic name is not registered, an error is reported.
--- @param nameAtHost - the symbolic name of the socket
--- (must be either of the form "name@host" or "name"
--- where the latter is a shorthand for "name@localhost")
--- @return the handle of the stream (connected to the socket nameAtHost)
--- which is both readable and writable
connectToSocket :: String -> IO Handle
connectToSocket nameAtHost = do
let (name,atHost) = break (=='@') nameAtHost
host = if atHost=="" then "localhost" else tail atHost
-- get remote port number:
(snr,_) <- getPortInfo name host
if snr==0
then error ("connectToSocket: Socket \""++name++"@"++host++
"\" is not registered!")
else done
Socket.connectToSocket host snr
---------------------------------------------------------------------
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Nat.curry 0000664 0000000 0000000 00000005464 13231616147 0023304 0 ustar 00root root 0000000 0000000 ------------------------------------------------------------------------------
--- Library defining natural numbers in Peano representation and
--- some operations on this representation.
---
--- @author Michael Hanus
--- @version May 2017
--- @category general
------------------------------------------------------------------------------
module Nat
( Nat(..), fromNat, toNat, add, sub, mul, leq
) where
import Test.Prop
--- Natural numbers defined in Peano representation.
data Nat = Z | S Nat
deriving (Eq,Show)
--- Transforms a natural number into a standard integer.
fromNat :: Nat -> Int
fromNat Z = 0
fromNat (S n) = 1 + fromNat n
-- Postcondition: the result of `fromNat` is not negative
fromNat'post :: Nat -> Int -> Bool
fromNat'post _ n = n >= 0
--- Transforms a standard integer into a natural number.
toNat :: Int -> Nat
toNat n | n == 0 = Z
| n > 0 = S (toNat (n-1))
-- Precondition: `toNat` must be called with non-negative numbers
toNat'pre :: Int -> Bool
toNat'pre n = n >= 0
-- Property: transforming natural numbers into integers and back is the identity
fromToNat :: Nat -> Prop
fromToNat n = toNat (fromNat n) -=- n
toFromNat :: Int -> Prop
toFromNat n = n>=0 ==> fromNat (toNat n) -=- n
--- Addition on natural numbers.
add :: Nat -> Nat -> Nat
add Z n = n
add (S m) n = S(add m n)
-- Property: addition is commutative
addIsCommutative :: Nat -> Nat -> Prop
addIsCommutative x y = add x y -=- add y x
-- Property: addition is associative
addIsAssociative :: Nat -> Nat -> Nat -> Prop
addIsAssociative x y z = add (add x y) z -=- add x (add y z)
--- Subtraction defined by reversing addition.
sub :: Nat -> Nat -> Nat
sub x y | add y z == x = z where z free
-- Properties: subtracting a value which was added yields the same value
subAddL :: Nat -> Nat -> Prop
subAddL x y = sub (add x y) x -=- y
subAddR :: Nat -> Nat -> Prop
subAddR x y = sub (add x y) y -=- x
--- Multiplication on natural numbers.
mul :: Nat -> Nat -> Nat
mul Z _ = Z
mul (S m) n = add n (mul m n)
-- Property: multiplication is commutative
mulIsCommutative :: Nat -> Nat -> Prop
mulIsCommutative x y = mul x y -=- mul y x
-- Property: multiplication is associative
mulIsAssociative :: Nat -> Nat -> Nat -> Prop
mulIsAssociative x y z = mul (mul x y) z -=- mul x (mul y z)
-- Properties: multiplication is distributive over addition
distMulAddL :: Nat -> Nat -> Nat -> Prop
distMulAddL x y z = mul x (add y z) -=- add (mul x y) (mul x z)
distMulAddR :: Nat -> Nat -> Nat -> Prop
distMulAddR x y z = mul (add y z) x -=- add (mul y x) (mul z x)
-- less-or-equal predicated on natural numbers:
leq :: Nat -> Nat -> Bool
leq Z _ = True
leq (S _) Z = False
leq (S x) (S y) = leq x y
-- Property: adding a number yields always a greater-or-equal number
leqAdd :: Nat -> Nat -> Prop
leqAdd x y = always $ leq x (add x y)
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Prelude.curry 0000664 0000000 0000000 00000157061 13231616147 0024163 0 ustar 00root root 0000000 0000000 ----------------------------------------------------------------------------
--- The standard prelude of Curry (with type classes).
--- All top-level functions, data types, classes and methods defined
--- in this module are always available in any Curry program.
---
--- @category general
----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-overlapping #-}
module Prelude
(
-- classes and overloaded functions
Eq(..)
, elem, notElem, lookup
, Ord(..)
, Show(..), ShowS, print, shows, showChar, showString, showParen
, Read (..), ReadS, lex, read, reads, readParen
, Bounded (..), Enum (..), boundedEnumFrom, boundedEnumFromThen
, asTypeOf
, Num(..), Fractional(..), Real(..), Integral(..)
-- data types
, Bool (..) , Char (..) , Int (..) , Float (..), String , Ordering (..)
, Success, Maybe (..), Either (..), IO (..), IOError (..)
, DET
-- functions
, (.), id, const, curry, uncurry, flip, until, seq, ensureNotFree
, ensureSpine, ($), ($!), ($!!), ($#), ($##), error
, failed, (&&), (||), not, otherwise, if_then_else, solve
, fst, snd, head, tail, null, (++), length, (!!), map, foldl, foldl1
, foldr, foldr1, filter, zip, zip3, zipWith, zipWith3, unzip, unzip3
, concat, concatMap, iterate, repeat, replicate, take, drop, splitAt
, takeWhile, dropWhile, span, break, lines, unlines, words, unwords
, reverse, and, or, any, all
, ord, chr, (=:=), success, (&), (&>), maybe
, either, (>>=), return, (>>), done, putChar, getChar, readFile
, writeFile, appendFile
, putStr, putStrLn, getLine, userError, ioError, showError
, catch, doSolve, sequenceIO, sequenceIO_, mapIO
, mapIO_, (?), anyOf, unknown
, when, unless, forIO, forIO_, liftIO, foldIO
, normalForm, groundNormalForm, apply, cond, (=:<=)
, enumFrom_, enumFromTo_, enumFromThen_, enumFromThenTo_, negate_, negateFloat
, PEVAL
, Monad(..)
, Functor(..)
, sequence, sequence_, mapM, mapM_, foldM, liftM, liftM2, forM, forM_
, unlessM, whenM
#ifdef __PAKCS__
, (=:<<=), letrec
#endif
) where
-- Lines beginning with "--++" are part of the prelude
-- but cannot parsed by the compiler
-- Infix operator declarations:
infixl 9 !!
infixr 9 .
infixl 7 *, `div`, `mod`, `quot`, `rem`, /
infixl 6 +, -
-- infixr 5 : -- declared together with list
infixr 5 ++
infix 4 =:=, ==, /=, <, >, <=, >=, =:<=
#ifdef __PAKCS__
infix 4 =:<<=
#endif
infix 4 `elem`, `notElem`
infixr 3 &&
infixr 2 ||
infixl 1 >>, >>=
infixr 0 $, $!, $!!, $#, $##, `seq`, &, &>, ?
-- externally defined types for numbers and characters
external data Int
external data Float
external data Char
type String = [Char]
-- Some standard combinators:
--- Function composition.
(.) :: (b -> c) -> (a -> b) -> (a -> c)
f . g = \x -> f (g x)
--- Identity function.
id :: a -> a
id x = x
--- Constant function.
const :: a -> _ -> a
const x _ = x
--- Converts an uncurried function to a curried function.
curry :: ((a,b) -> c) -> a -> b -> c
curry f a b = f (a,b)
--- Converts an curried function to a function on pairs.
uncurry :: (a -> b -> c) -> (a,b) -> c
uncurry f (a,b) = f a b
--- (flip f) is identical to f but with the order of arguments reversed.
flip :: (a -> b -> c) -> b -> a -> c
flip f x y = f y x
--- Repeats application of a function until a predicate holds.
until :: (a -> Bool) -> (a -> a) -> a -> a
until p f x = if p x then x else until p f (f x)
--- Evaluates the first argument to head normal form (which could also
--- be a free variable) and returns the second argument.
seq :: _ -> a -> a
x `seq` y = const y $! x
--- Evaluates the argument to head normal form and returns it.
--- Suspends until the result is bound to a non-variable term.
ensureNotFree :: a -> a
ensureNotFree external
--- Evaluates the argument to spine form and returns it.
--- Suspends until the result is bound to a non-variable spine.
ensureSpine :: [a] -> [a]
ensureSpine l = ensureList (ensureNotFree l)
where ensureList [] = []
ensureList (x:xs) = x : ensureSpine xs
--- Right-associative application.
($) :: (a -> b) -> a -> b
f $ x = f x
--- Right-associative application with strict evaluation of its argument
--- to head normal form.
($!) :: (a -> b) -> a -> b
($!) external
--- Right-associative application with strict evaluation of its argument
--- to normal form.
($!!) :: (a -> b) -> a -> b
($!!) external
--- Right-associative application with strict evaluation of its argument
--- to a non-variable term.
($#) :: (a -> b) -> a -> b
f $# x = f $! (ensureNotFree x)
--- Right-associative application with strict evaluation of its argument
--- to ground normal form.
($##) :: (a -> b) -> a -> b
($##) external
--- Aborts the execution with an error message.
error :: String -> _
error x = prim_error $## x
prim_error :: String -> _
prim_error external
--- A non-reducible polymorphic function.
--- It is useful to express a failure in a search branch of the execution.
--- It could be defined by: `failed = head []`
failed :: _
failed external
-- Boolean values
-- already defined as builtin, since it is required for if-then-else
data Bool = False | True
deriving (Eq, Ord, Show, Read)
--- Sequential conjunction on Booleans.
(&&) :: Bool -> Bool -> Bool
True && x = x
False && _ = False
--- Sequential disjunction on Booleans.
(||) :: Bool -> Bool -> Bool
True || _ = True
False || x = x
--- Negation on Booleans.
not :: Bool -> Bool
not True = False
not False = True
--- Useful name for the last condition in a sequence of conditional equations.
otherwise :: Bool
otherwise = True
--- The standard conditional. It suspends if the condition is a free variable.
if_then_else :: Bool -> a -> a -> a
if_then_else b t f = case b of True -> t
False -> f
--- Enforce a Boolean condition to be true.
--- The computation fails if the argument evaluates to `False`.
solve :: Bool -> Bool
solve True = True
--- Conditional expression.
--- An expression like `(c &> e)` is evaluated by evaluating the first
--- argument to `True` and then evaluating `e`.
--- The expression has no value if the condition does not evaluate to `True`.
(&>) :: Bool -> a -> a
True &> x = x
--- The equational constraint.
--- `(e1 =:= e2)` is satisfiable if both sides `e1` and `e2` can be
--- reduced to a unifiable data term (i.e., a term without defined
--- function symbols).
(=:=) :: a -> a -> Bool
(=:=) external
--- Concurrent conjunction.
--- An expression like `(c1 & c2)` is evaluated by evaluating
--- the `c1` and `c2` in a concurrent manner.
(&) :: Bool -> Bool -> Bool
(&) external
-- used for comparison of standard types like Int, Float and Char
eqChar :: Char -> Char -> Bool
#ifdef __PAKCS__
eqChar x y = (prim_eqChar $# y) $# x
prim_eqChar :: Char -> Char -> Bool
prim_eqChar external
#else
eqChar external
#endif
eqInt :: Int -> Int -> Bool
#ifdef __PAKCS__
eqInt x y = (prim_eqInt $# y) $# x
prim_eqInt :: Int -> Int -> Bool
prim_eqInt external
#else
eqInt external
#endif
eqFloat :: Float -> Float -> Bool
#ifdef __PAKCS__
eqFloat x y = (prim_eqFloat $# y) $# x
prim_eqFloat :: Float -> Float -> Bool
prim_eqFloat external
#else
eqFloat external
#endif
--- Ordering type. Useful as a result of comparison functions.
data Ordering = LT | EQ | GT
deriving (Eq, Ord, Show, Read)
-- used for comparison of standard types like Int, Float and Char
ltEqChar :: Char -> Char -> Bool
#ifdef __PAKCS__
ltEqChar x y = (prim_ltEqChar $# y) $# x
prim_ltEqChar :: Char -> Char -> Bool
prim_ltEqChar external
#else
ltEqChar external
#endif
ltEqInt :: Int -> Int -> Bool
#ifdef __PAKCS__
ltEqInt x y = (prim_ltEqInt $# y) $# x
prim_ltEqInt :: Int -> Int -> Bool
prim_ltEqInt external
#else
ltEqInt external
#endif
ltEqFloat :: Float -> Float -> Bool
#ifdef __PAKCS__
ltEqFloat x y = (prim_ltEqFloat $# y) $# x
prim_ltEqFloat :: Float -> Float -> Bool
prim_ltEqFloat external
#else
ltEqFloat external
#endif
-- Pairs
--++ data (a,b) = (a,b)
--- Selects the first component of a pair.
fst :: (a,_) -> a
fst (x,_) = x
--- Selects the second component of a pair.
snd :: (_,b) -> b
snd (_,y) = y
-- Unit type
--++ data () = ()
-- Lists
--++ data [a] = [] | a : [a]
--- Computes the first element of a list.
head :: [a] -> a
head (x:_) = x
--- Computes the remaining elements of a list.
tail :: [a] -> [a]
tail (_:xs) = xs
--- Is a list empty?
null :: [_] -> Bool
null [] = True
null (_:_) = False
--- Concatenates two lists.
--- Since it is flexible, it could be also used to split a list
--- into two sublists etc.
(++) :: [a] -> [a] -> [a]
[] ++ ys = ys
(x:xs) ++ ys = x : xs++ys
--- Computes the length of a list.
--length :: [_] -> Int
--length [] = 0
--length (_:xs) = 1 + length xs
length :: [_] -> Int
length xs = len xs 0
where
len [] n = n
len (_:ys) n = let np1 = n + 1 in len ys $!! np1
--- List index (subscript) operator, head has index 0.
(!!) :: [a] -> Int -> a
(x:xs) !! n | n==0 = x
| n>0 = xs !! (n-1)
--- Map a function on all elements of a list.
map :: (a->b) -> [a] -> [b]
map _ [] = []
map f (x:xs) = f x : map f xs
--- Accumulates all list elements by applying a binary operator from
--- left to right. Thus,
---
--- foldl f z [x1,x2,...,xn] = (...((z `f` x1) `f` x2) ...) `f` xn
foldl :: (a -> b -> a) -> a -> [b] -> a
foldl _ z [] = z
foldl f z (x:xs) = foldl f (f z x) xs
--- Accumulates a non-empty list from left to right.
foldl1 :: (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs
--- Accumulates all list elements by applying a binary operator from
--- right to left. Thus,
---
--- foldr f z [x1,x2,...,xn] = (x1 `f` (x2 `f` ... (xn `f` z)...))
foldr :: (a->b->b) -> b -> [a] -> b
foldr _ z [] = z
foldr f z (x:xs) = f x (foldr f z xs)
--- Accumulates a non-empty list from right to left:
foldr1 :: (a -> a -> a) -> [a] -> a
foldr1 _ [x] = x
foldr1 f (x:xs@(_:_)) = f x (foldr1 f xs)
--- Filters all elements satisfying a given predicate in a list.
filter :: (a -> Bool) -> [a] -> [a]
filter _ [] = []
filter p (x:xs) = if p x then x : filter p xs
else filter p xs
--- Joins two lists into one list of pairs. If one input list is shorter than
--- the other, the additional elements of the longer list are discarded.
zip :: [a] -> [b] -> [(a,b)]
zip [] _ = []
zip (_:_) [] = []
zip (x:xs) (y:ys) = (x,y) : zip xs ys
--- Joins three lists into one list of triples. If one input list is shorter
--- than the other, the additional elements of the longer lists are discarded.
zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
zip3 [] _ _ = []
zip3 (_:_) [] _ = []
zip3 (_:_) (_:_) [] = []
zip3 (x:xs) (y:ys) (z:zs) = (x,y,z) : zip3 xs ys zs
--- Joins two lists into one list by applying a combination function to
--- corresponding pairs of elements. Thus `zip = zipWith (,)`
zipWith :: (a->b->c) -> [a] -> [b] -> [c]
zipWith _ [] _ = []
zipWith _ (_:_) [] = []
zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys
--- Joins three lists into one list by applying a combination function to
--- corresponding triples of elements. Thus `zip3 = zipWith3 (,,)`
zipWith3 :: (a->b->c->d) -> [a] -> [b] -> [c] -> [d]
zipWith3 _ [] _ _ = []
zipWith3 _ (_:_) [] _ = []
zipWith3 _ (_:_) (_:_) [] = []
zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs
--- Transforms a list of pairs into a pair of lists.
unzip :: [(a,b)] -> ([a],[b])
unzip [] = ([],[])
unzip ((x,y):ps) = (x:xs,y:ys) where (xs,ys) = unzip ps
--- Transforms a list of triples into a triple of lists.
unzip3 :: [(a,b,c)] -> ([a],[b],[c])
unzip3 [] = ([],[],[])
unzip3 ((x,y,z):ts) = (x:xs,y:ys,z:zs) where (xs,ys,zs) = unzip3 ts
--- Concatenates a list of lists into one list.
concat :: [[a]] -> [a]
concat l = foldr (++) [] l
--- Maps a function from elements to lists and merges the result into one list.
concatMap :: (a -> [b]) -> [a] -> [b]
concatMap f = concat . map f
--- Infinite list of repeated applications of a function f to an element x.
--- Thus, `iterate f x = [x, f x, f (f x),...]`
iterate :: (a -> a) -> a -> [a]
iterate f x = x : iterate f (f x)
--- Infinite list where all elements have the same value.
--- Thus, `repeat x = [x, x, x,...]`
repeat :: a -> [a]
repeat x = x : repeat x
--- List of length n where all elements have the same value.
replicate :: Int -> a -> [a]
replicate n x = take n (repeat x)
--- Returns prefix of length n.
take :: Int -> [a] -> [a]
take n l = if n<=0 then [] else takep n l
where takep _ [] = []
takep m (x:xs) = x : take (m-1) xs
--- Returns suffix without first n elements.
drop :: Int -> [a] -> [a]
drop n xs = if n<=0 then xs
else case xs of [] -> []
(_:ys) -> drop (n-1) ys
--- (splitAt n xs) is equivalent to (take n xs, drop n xs)
splitAt :: Int -> [a] -> ([a],[a])
splitAt n l = if n<=0 then ([],l) else splitAtp n l
where splitAtp _ [] = ([],[])
splitAtp m (x:xs) = let (ys,zs) = splitAt (m-1) xs in (x:ys,zs)
--- Returns longest prefix with elements satisfying a predicate.
takeWhile :: (a -> Bool) -> [a] -> [a]
takeWhile _ [] = []
takeWhile p (x:xs) = if p x then x : takeWhile p xs else []
--- Returns suffix without takeWhile prefix.
dropWhile :: (a -> Bool) -> [a] -> [a]
dropWhile _ [] = []
dropWhile p (x:xs) = if p x then dropWhile p xs else x:xs
--- (span p xs) is equivalent to (takeWhile p xs, dropWhile p xs)
span :: (a -> Bool) -> [a] -> ([a],[a])
span _ [] = ([],[])
span p (x:xs)
| p x = let (ys,zs) = span p xs in (x:ys, zs)
| otherwise = ([],x:xs)
--- (break p xs) is equivalent to (takeWhile (not.p) xs, dropWhile (not.p) xs).
--- Thus, it breaks a list at the first occurrence of an element satisfying p.
break :: (a -> Bool) -> [a] -> ([a],[a])
break p = span (not . p)
--- Breaks a string into a list of lines where a line is terminated at a
--- newline character. The resulting lines do not contain newline characters.
lines :: String -> [String]
lines [] = []
lines (x:xs) = let (l,xs_l) = splitline (x:xs) in l : lines xs_l
where splitline [] = ([],[])
splitline (c:cs) = if c=='\n'
then ([],cs)
else let (ds,es) = splitline cs in (c:ds,es)
--- Concatenates a list of strings with terminating newlines.
unlines :: [String] -> String
unlines ls = concatMap (++"\n") ls
--- Breaks a string into a list of words where the words are delimited by
--- white spaces.
words :: String -> [String]
words s = let s1 = dropWhile isSpace s
in if s1=="" then []
else let (w,s2) = break isSpace s1
in w : words s2
--- Concatenates a list of strings with a blank between two strings.
unwords :: [String] -> String
unwords ws = if ws==[] then []
else foldr1 (\w s -> w ++ ' ':s) ws
--- Reverses the order of all elements in a list.
reverse :: [a] -> [a]
reverse = foldl (flip (:)) []
--- Computes the conjunction of a Boolean list.
and :: [Bool] -> Bool
and = foldr (&&) True
--- Computes the disjunction of a Boolean list.
or :: [Bool] -> Bool
or = foldr (||) False
--- Is there an element in a list satisfying a given predicate?
any :: (a -> Bool) -> [a] -> Bool
any p = or . map p
--- Is a given predicate satisfied by all elements in a list?
all :: (a -> Bool) -> [a] -> Bool
all p = and . map p
--- Element of a list?
elem :: Eq a => a -> [a] -> Bool
elem x = any (x ==)
--- Not element of a list?
notElem :: Eq a => a -> [a] -> Bool
notElem x = all (x /=)
--- Looks up a key in an association list.
lookup :: Eq a => a -> [(a, b)] -> Maybe b
lookup _ [] = Nothing
lookup k ((x,y):xys)
| k==x = Just y
| otherwise = lookup k xys
--- Generates an infinite sequence of ascending integers.
enumFrom_ :: Int -> [Int] -- [n..]
enumFrom_ n = n : enumFrom_ (n+1)
--- Generates an infinite sequence of integers with a particular in/decrement.
enumFromThen_ :: Int -> Int -> [Int] -- [n1,n2..]
enumFromThen_ n1 n2 = iterate ((n2-n1)+) n1
--- Generates a sequence of ascending integers.
enumFromTo_ :: Int -> Int -> [Int] -- [n..m]
enumFromTo_ n m = if n>m then [] else n : enumFromTo_ (n+1) m
--- Generates a sequence of integers with a particular in/decrement.
enumFromThenTo_ :: Int -> Int -> Int -> [Int] -- [n1,n2..m]
enumFromThenTo_ n1 n2 m = takeWhile p (enumFromThen_ n1 n2)
where
p x | n2 >= n1 = (x <= m)
| otherwise = (x >= m)
--- Converts a character into its ASCII value.
ord :: Char -> Int
ord c = prim_ord $# c
prim_ord :: Char -> Int
prim_ord external
--- Converts a Unicode value into a character, fails iff the value is out of bounds
chr :: Int -> Char
chr n | n >= 0 = prim_chr $# n
-- chr n | n < 0 || n > 1114111 = failed
-- | otherwise = prim_chr $# n
prim_chr :: Int -> Char
prim_chr external
-- Types of primitive arithmetic functions and predicates
--- Adds two integers.
(+$) :: Int -> Int -> Int
#ifdef __PAKCS__
x +$ y = (prim_Int_plus $# y) $# x
prim_Int_plus :: Int -> Int -> Int
prim_Int_plus external
#else
(+$) external
#endif
--- Subtracts two integers.
(-$) :: Int -> Int -> Int
#ifdef __PAKCS__
x -$ y = (prim_Int_minus $# y) $# x
prim_Int_minus :: Int -> Int -> Int
prim_Int_minus external
#else
(-$) external
#endif
--- Multiplies two integers.
(*$) :: Int -> Int -> Int
#ifdef __PAKCS__
x *$ y = (prim_Int_times $# y) $# x
prim_Int_times :: Int -> Int -> Int
prim_Int_times external
#else
(*$) external
#endif
--- Integer division. The value is the integer quotient of its arguments
--- and always truncated towards negative infinity.
--- Thus, the value of 13 `div` 5 is 2,
--- and the value of -15 `div` 4 is -3.
div_ :: Int -> Int -> Int
#ifdef __PAKCS__
x `div_` y = (prim_Int_div $# y) $# x
prim_Int_div :: Int -> Int -> Int
prim_Int_div external
#else
div_ external
#endif
--- Integer remainder. The value is the remainder of the integer division and
--- it obeys the rule x `mod` y = x - y * (x `div` y).
--- Thus, the value of 13 `mod` 5 is 3,
--- and the value of -15 `mod` 4 is -3.
mod_ :: Int -> Int -> Int
#ifdef __PAKCS__
x `mod_` y = (prim_Int_mod $# y) $# x
prim_Int_mod :: Int -> Int -> Int
prim_Int_mod external
#else
mod_ external
#endif
--- Returns an integer (quotient,remainder) pair.
--- The value is the integer quotient of its arguments
--- and always truncated towards negative infinity.
divMod_ :: Int -> Int -> (Int, Int)
#ifdef __PAKCS__
divMod_ x y = (x `div` y, x `mod` y)
#else
divMod_ external
#endif
--- Integer division. The value is the integer quotient of its arguments
--- and always truncated towards zero.
--- Thus, the value of 13 `quot` 5 is 2,
--- and the value of -15 `quot` 4 is -3.
quot_ :: Int -> Int -> Int
#ifdef __PAKCS__
x `quot_` y = (prim_Int_quot $# y) $# x
prim_Int_quot :: Int -> Int -> Int
prim_Int_quot external
#else
quot_ external
#endif
--- Integer remainder. The value is the remainder of the integer division and
--- it obeys the rule x `rem` y = x - y * (x `quot` y).
--- Thus, the value of 13 `rem` 5 is 3,
--- and the value of -15 `rem` 4 is -3.
rem_ :: Int -> Int -> Int
#ifdef __PAKCS__
x `rem_` y = (prim_Int_rem $# y) $# x
prim_Int_rem :: Int -> Int -> Int
prim_Int_rem external
#else
rem_ external
#endif
--- Returns an integer (quotient,remainder) pair.
--- The value is the integer quotient of its arguments
--- and always truncated towards zero.
quotRem_ :: Int -> Int -> (Int, Int)
#ifdef __PAKCS__
quotRem_ x y = (x `quot` y, x `rem` y)
#else
quotRem_ external
#endif
--- Unary minus. Usually written as "- e".
negate_ :: Int -> Int
negate_ x = 0 - x
--- Unary minus on Floats. Usually written as "-e".
negateFloat :: Float -> Float
#ifdef __PAKCS__
negateFloat x = prim_negateFloat $# x
prim_negateFloat :: Float -> Float
prim_negateFloat external
#else
negateFloat external
#endif
-- Constraints (included for backward compatibility)
type Success = Bool
--- The always satisfiable constraint.
success :: Success
success = True
-- Maybe type
data Maybe a = Nothing | Just a
deriving (Eq, Ord, Show, Read)
maybe :: b -> (a -> b) -> Maybe a -> b
maybe n _ Nothing = n
maybe _ f (Just x) = f x
-- Either type
data Either a b = Left a | Right b
deriving (Eq, Ord, Show, Read)
either :: (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left x) = f x
either _ g (Right x) = g x
-- Monadic IO
external data IO _ -- conceptually: World -> (a,World)
--- Sequential composition of IO actions.
--- @param a - An action
--- @param fa - A function from a value into an action
--- @return An action that first performs a (yielding result r)
--- and then performs (fa r)
(>>=$) :: IO a -> (a -> IO b) -> IO b
(>>=$) external
--- The empty IO action that directly returns its argument.
returnIO :: a -> IO a
returnIO external
--- Sequential composition of IO actions.
--- @param a1 - An IO action
--- @param a2 - An IO action
--- @return An IO action that first performs a1 and then a2
(>>$) :: IO _ -> IO b -> IO b
a >>$ b = a >>=$ (\_ -> b)
--- The empty IO action that returns nothing.
done :: IO ()
done = return ()
--- An action that puts its character argument on standard output.
putChar :: Char -> IO ()
putChar c = prim_putChar $# c
prim_putChar :: Char -> IO ()
prim_putChar external
--- An action that reads a character from standard output and returns it.
getChar :: IO Char
getChar external
--- An action that (lazily) reads a file and returns its contents.
readFile :: String -> IO String
readFile f = prim_readFile $## f
prim_readFile :: String -> IO String
prim_readFile external
#ifdef __PAKCS__
-- for internal implementation of readFile:
prim_readFileContents :: String -> String
prim_readFileContents external
#endif
--- An action that writes a file.
--- @param filename - The name of the file to be written.
--- @param contents - The contents to be written to the file.
writeFile :: String -> String -> IO ()
#ifdef __PAKCS__
writeFile f s = (prim_writeFile $## f) s
#else
writeFile f s = (prim_writeFile $## f) $## s
#endif
prim_writeFile :: String -> String -> IO ()
prim_writeFile external
--- An action that appends a string to a file.
--- It behaves like writeFile if the file does not exist.
--- @param filename - The name of the file to be written.
--- @param contents - The contents to be appended to the file.
appendFile :: String -> String -> IO ()
#ifdef __PAKCS__
appendFile f s = (prim_appendFile $## f) s
#else
appendFile f s = (prim_appendFile $## f) $## s
#endif
prim_appendFile :: String -> String -> IO ()
prim_appendFile external
--- Action to print a string on stdout.
putStr :: String -> IO ()
putStr [] = done
putStr (c:cs) = putChar c >> putStr cs
--- Action to print a string with a newline on stdout.
putStrLn :: String -> IO ()
putStrLn cs = putStr cs >> putChar '\n'
--- Action to read a line from stdin.
getLine :: IO String
getLine = do c <- getChar
if c=='\n' then return []
else do cs <- getLine
return (c:cs)
----------------------------------------------------------------------------
-- Error handling in the I/O monad:
--- The (abstract) type of error values.
--- Currently, it distinguishes between general IO errors,
--- user-generated errors (see 'userError'), failures and non-determinism
--- errors during IO computations. These errors can be caught by 'catch'
--- and shown by 'showError'.
--- Each error contains a string shortly explaining the error.
--- This type might be extended in the future to distinguish
--- further error situations.
data IOError
= IOError String -- normal IO error
| UserError String -- user-specified error
| FailError String -- failing computation
| NondetError String -- non-deterministic computation
deriving (Eq,Show,Read)
--- A user error value is created by providing a description of the
--- error situation as a string.
userError :: String -> IOError
userError s = UserError s
--- Raises an I/O exception with a given error value.
ioError :: IOError -> IO _
#ifdef __PAKCS__
ioError err = error (showError err)
#else
ioError err = prim_ioError $## err
prim_ioError :: IOError -> IO _
prim_ioError external
#endif
--- Shows an error values as a string.
showError :: IOError -> String
showError (IOError s) = "i/o error: " ++ s
showError (UserError s) = "user error: " ++ s
showError (FailError s) = "fail error: " ++ s
showError (NondetError s) = "nondet error: " ++ s
--- Catches a possible error or failure during the execution of an
--- I/O action. `(catch act errfun)` executes the I/O action
--- `act`. If an exception or failure occurs
--- during this I/O action, the function `errfun` is applied
--- to the error value.
catch :: IO a -> (IOError -> IO a) -> IO a
catch external
----------------------------------------------------------------------------
--- Converts an arbitrary term into an external string representation.
show_ :: _ -> String
show_ x = prim_show $## x
prim_show :: _ -> String
prim_show external
--- Converts a term into a string and prints it.
print :: Show a => a -> IO ()
print t = putStrLn (show t)
--- Solves a constraint as an I/O action.
--- Note: the constraint should be always solvable in a deterministic way
doSolve :: Bool -> IO ()
doSolve b | b = done
-- IO monad auxiliary functions:
--- Executes a sequence of I/O actions and collects all results in a list.
sequenceIO :: [IO a] -> IO [a]
sequenceIO [] = return []
sequenceIO (c:cs) = do x <- c
xs <- sequenceIO cs
return (x:xs)
--- Executes a sequence of I/O actions and ignores the results.
sequenceIO_ :: [IO _] -> IO ()
sequenceIO_ = foldr (>>) done
--- Maps an I/O action function on a list of elements.
--- The results of all I/O actions are collected in a list.
mapIO :: (a -> IO b) -> [a] -> IO [b]
mapIO f = sequenceIO . map f
--- Maps an I/O action function on a list of elements.
--- The results of all I/O actions are ignored.
mapIO_ :: (a -> IO _) -> [a] -> IO ()
mapIO_ f = sequenceIO_ . map f
--- Folds a list of elements using an binary I/O action and a value
--- for the empty list.
foldIO :: (a -> b -> IO a) -> a -> [b] -> IO a
foldIO _ a [] = return a
foldIO f a (x:xs) = f a x >>= \fax -> foldIO f fax xs
--- Apply a pure function to the result of an I/O action.
liftIO :: (a -> b) -> IO a -> IO b
liftIO f m = m >>= return . f
--- Like `mapIO`, but with flipped arguments.
---
--- This can be useful if the definition of the function is longer
--- than those of the list, like in
---
--- forIO [1..10] $ \n -> do
--- ...
forIO :: [a] -> (a -> IO b) -> IO [b]
forIO xs f = mapIO f xs
--- Like `mapIO_`, but with flipped arguments.
---
--- This can be useful if the definition of the function is longer
--- than those of the list, like in
---
--- forIO_ [1..10] $ \n -> do
--- ...
forIO_ :: [a] -> (a -> IO b) -> IO ()
forIO_ xs f = mapIO_ f xs
--- Performs an `IO` action unless the condition is met.
unless :: Bool -> IO () -> IO ()
unless p act = if p then done else act
--- Performs an `IO` action when the condition is met.
when :: Bool -> IO () -> IO ()
when p act = if p then act else done
----------------------------------------------------------------
-- Non-determinism and free variables:
--- Non-deterministic choice _par excellence_.
--- The value of `x ? y` is either `x` or `y`.
--- @param x - The right argument.
--- @param y - The left argument.
--- @return either `x` or `y` non-deterministically.
(?) :: a -> a -> a
x ? _ = x
_ ? y = y
-- Returns non-deterministically any element of a list.
anyOf :: [a] -> a
anyOf = foldr1 (?)
--- Evaluates to a fresh free variable.
unknown :: _
unknown = let x free in x
----------------------------------------------------------------
--- Identity type synonym used to mark deterministic operations.
type DET a = a
--- Identity function used by the partial evaluator
--- to mark expressions to be partially evaluated.
PEVAL :: a -> a
PEVAL x = x
--- Evaluates the argument to normal form and returns it.
normalForm :: a -> a
normalForm x = id $!! x
--- Evaluates the argument to ground normal form and returns it.
--- Suspends as long as the normal form of the argument is not ground.
groundNormalForm :: a -> a
groundNormalForm x = id $## x
-- Only for internal use:
-- Representation of higher-order applications in FlatCurry.
apply :: (a -> b) -> a -> b
apply external
-- Only for internal use:
-- Representation of conditional rules in FlatCurry.
cond :: Bool -> a -> a
cond external
#ifdef __PAKCS__
-- Only for internal use:
-- letrec ones (1:ones) -> bind ones to (1:ones)
letrec :: a -> a -> Bool
letrec external
#endif
--- Non-strict equational constraint. Used to implement functional patterns.
(=:<=) :: a -> a -> Bool
(=:<=) external
#ifdef __PAKCS__
--- Non-strict equational constraint for linear functional patterns.
--- Thus, it must be ensured that the first argument is always (after evalutation
--- by narrowing) a linear pattern. Experimental.
(=:<<=) :: a -> a -> Bool
(=:<<=) external
--- internal function to implement =:<=
ifVar :: _ -> a -> a -> a
ifVar external
--- internal operation to implement failure reporting
failure :: _ -> _ -> _
failure external
#endif
-- -------------------------------------------------------------------------
-- Eq class and related instances and functions
-- -------------------------------------------------------------------------
class Eq a where
(==), (/=) :: a -> a -> Bool
x == y = not (x /= y)
x /= y = not (x == y)
instance Eq Char where
c == c' = c `eqChar` c'
instance Eq Int where
i == i' = i `eqInt` i'
instance Eq Float where
f == f' = f `eqFloat` f'
instance Eq a => Eq [a] where
[] == [] = True
[] == (_:_) = False
(_:_) == [] = False
(x:xs) == (y:ys) = x == y && xs == ys
instance Eq () where
() == () = True
instance (Eq a, Eq b) => Eq (a, b) where
(a, b) == (a', b') = a == a' && b == b'
instance (Eq a, Eq b, Eq c) => Eq (a, b, c) where
(a, b, c) == (a', b', c') = a == a' && b == b' && c == c'
instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) where
(a, b, c, d) == (a', b', c', d') = a == a' && b == b' && c == c' && d == d'
instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e) where
(a, b, c, d, e) == (a', b', c', d', e') = a == a' && b == b' && c == c' && d == d' && e == e'
instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => Eq (a, b, c, d, e, f) where
(a, b, c, d, e, f) == (a', b', c', d', e', f') = a == a' && b == b' && c == c' && d == d' && e == e' && f == f'
instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a, b, c, d, e, f, g) where
(a, b, c, d, e, f, g) == (a', b', c', d', e', f', g') = a == a' && b == b' && c == c' && d == d' && e == e' && f == f' && g == g'
-- -------------------------------------------------------------------------
-- Ord class and related instances and functions
-- -------------------------------------------------------------------------
--- minimal complete definition: compare or <=
class Eq a => Ord a where
compare :: a -> a -> Ordering
(<=) :: a -> a -> Bool
(>=) :: a -> a -> Bool
(<) :: a -> a -> Bool
(>) :: a -> a -> Bool
min :: a -> a -> a
max :: a -> a -> a
x < y = x <= y && x /= y
x > y = not (x <= y)
x >= y = y <= x
x <= y = compare x y == EQ || compare x y == LT
compare x y | x == y = EQ
| x <= y = LT
| otherwise = GT
min x y | x <= y = x
| otherwise = y
max x y | x >= y = x
| otherwise = y
instance Ord Char where
c1 <= c2 = c1 `ltEqChar` c2
instance Ord Int where
i1 <= i2 = i1 `ltEqInt` i2
instance Ord Float where
f1 <= f2 = f1 `ltEqFloat` f2
instance Ord a => Ord [a] where
[] <= [] = True
(_:_) <= [] = False
[] <= (_:_) = True
(x:xs) <= (y:ys) | x == y = xs <= ys
| otherwise = x < y
instance Ord () where
() <= () = True
instance (Ord a, Ord b) => Ord (a, b) where
(a, b) <= (a', b') = a < a' || (a == a' && b <= b')
instance (Ord a, Ord b, Ord c) => Ord (a, b, c) where
(a, b, c) <= (a', b', c') = a < a'
|| (a == a' && b < b')
|| (a == a' && b == b' && c <= c')
instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) where
(a, b, c, d) <= (a', b', c', d') = a < a'
|| (a == a' && b < b')
|| (a == a' && b == b' && c < c')
|| (a == a' && b == b' && c == c' && d <= d')
instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e) where
(a, b, c, d, e) <= (a', b', c', d', e') = a < a'
|| (a == a' && b < b')
|| (a == a' && b == b' && c < c')
|| (a == a' && b == b' && c == c' && d < d')
|| (a == a' && b == b' && c == c' && d == d' && e <= e')
-- -------------------------------------------------------------------------
-- Show class and related instances and functions
-- -------------------------------------------------------------------------
type ShowS = String -> String
class Show a where
show :: a -> String
showsPrec :: Int -> a -> ShowS
showList :: [a] -> ShowS
showsPrec _ x s = show x ++ s
show x = shows x ""
showList ls s = showList' shows ls s
showList' :: (a -> ShowS) -> [a] -> ShowS
showList' _ [] s = "[]" ++ s
showList' showx (x:xs) s = '[' : showx x (showl xs)
where
showl [] = ']' : s
showl (y:ys) = ',' : showx y (showl ys)
shows :: Show a => a -> ShowS
shows = showsPrec 0
showChar :: Char -> ShowS
showChar c s = c:s
showString :: String -> ShowS
showString str s = foldr showChar s str
showParen :: Bool -> ShowS -> ShowS
showParen b s = if b then showChar '(' . s . showChar ')' else s
-- -------------------------------------------------------------------------
instance Show () where
showsPrec _ () = showString "()"
instance (Show a, Show b) => Show (a, b) where
showsPrec _ (a, b) = showTuple [shows a, shows b]
instance (Show a, Show b, Show c) => Show (a, b, c) where
showsPrec _ (a, b, c) = showTuple [shows a, shows b, shows c]
instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
showsPrec _ (a, b, c, d) = showTuple [shows a, shows b, shows c, shows d]
instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
showsPrec _ (a, b, c, d, e) = showTuple [shows a, shows b, shows c, shows d, shows e]
instance Show a => Show [a] where
showsPrec _ = showList
instance Show Char where
-- TODO: own implementation instead of passing to original Prelude functions?
showsPrec _ c = showString (show_ c)
showList cs | null cs = showString "\"\""
| otherwise = showString (show_ cs)
instance Show Int where
showsPrec = showSigned (showString . show_)
instance Show Float where
showsPrec = showSigned (showString . show_)
showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
showSigned showPos p x
| x < 0 = showParen (p > 6) (showChar '-' . showPos (-x))
| otherwise = showPos x
showTuple :: [ShowS] -> ShowS
showTuple ss = showChar '('
. foldr1 (\s r -> s . showChar ',' . r) ss
. showChar ')'
appPrec :: Int
appPrec = 10
appPrec1 :: Int
appPrec1 = 11
-- -------------------------------------------------------------------------
-- Read class and related instances and functions
-- -------------------------------------------------------------------------
type ReadS a = String -> [(a, String)]
class Read a where
readsPrec :: Int -> ReadS a
readList :: ReadS [a]
readList = readListDefault
readListDefault :: Read a => ReadS [a]
readListDefault = readParen False (\r -> [pr | ("[",s) <- lex r
, pr <- readl s])
where readl s = [([], t) | ("]", t) <- lex s] ++
[(x : xs, u) | (x, t) <- reads s, (xs, u) <- readl' t]
readl' s = [([], t) | ("]", t) <- lex s] ++
[(x : xs, v) | (",", t) <- lex s, (x, u) <- reads t
, (xs,v) <- readl' u]
reads :: Read a => ReadS a
reads = readsPrec 0
readParen :: Bool -> ReadS a -> ReadS a
readParen b g = if b then mandatory else optional
where optional r = g r ++ mandatory r
mandatory r =
[(x, u) | ("(", s) <- lex r, (x, t) <- optional s, (")", u) <- lex t]
read :: (Read a) => String -> a
read s = case [x | (x, t) <- reads s, ("", "") <- lex t] of
[x] -> x
[] -> error "Prelude.read: no parse"
_ -> error "Prelude.read: ambiguous parse"
instance Read () where
readsPrec _ = readParen False (\r -> [ ((), t) | ("(", s) <- lex r
, (")", t) <- lex s ])
instance Read Int where
readsPrec _ = readSigned (\s -> [(i,t) | (x,t) <- lexDigits s
, (i,[]) <- readNatLiteral x])
instance Read Float where
readsPrec _ = readSigned
(\s -> [ (f,t) | (x,t) <- lex s, not (null x)
, isDigit (head x), (f,[]) <- readFloat x ])
where
readFloat x = if all isDigit x
then [ (i2f i, t) | (i,t) <- readNatLiteral x ]
else readFloatLiteral x
readSigned :: Real a => ReadS a -> ReadS a
readSigned p = readParen False read'
where read' r = read'' r ++ [(-x, t) | ("-", s) <- lex r, (x, t) <- read'' s]
read'' r = [(n, s) | (str, s) <- lex r, (n, "") <- p str]
instance Read Char where
readsPrec _ = readParen False
(\s -> [ (c, t) | (x, t) <- lex s, not (null x), head x == '\''
, (c, []) <- readCharLiteral x ])
readList xs = readParen False
(\s -> [ (cs, t) | (x, t) <- lex s, not (null x), head x == '"'
, (cs, []) <- readStringLiteral x ]) xs
++ readListDefault xs
-- Primitive operations to read specific literals.
readNatLiteral :: ReadS Int
readNatLiteral s = prim_readNatLiteral $## s
prim_readNatLiteral :: String -> [(Int,String)]
prim_readNatLiteral external
readFloatLiteral :: ReadS Float
readFloatLiteral s = prim_readFloatLiteral $## s
prim_readFloatLiteral :: String -> [(Float,String)]
prim_readFloatLiteral external
readCharLiteral :: ReadS Char
readCharLiteral s = prim_readCharLiteral $## s
prim_readCharLiteral :: String -> [(Char,String)]
prim_readCharLiteral external
readStringLiteral :: ReadS String
readStringLiteral s = prim_readStringLiteral $## s
prim_readStringLiteral :: String -> [(String,String)]
prim_readStringLiteral external
instance Read a => Read [a] where
readsPrec _ = readList
instance (Read a, Read b) => Read (a, b) where
readsPrec _ = readParen False (\r -> [ ((a, b), w) | ("(", s) <- lex r
, (a, t) <- reads s
, (",", u) <- lex t
, (b, v) <- reads u
, (")", w) <- lex v ])
instance (Read a, Read b, Read c) => Read (a, b, c) where
readsPrec _ = readParen False (\r -> [ ((a, b, c), y) | ("(", s) <- lex r
, (a, t) <- reads s
, (",", u) <- lex t
, (b, v) <- reads u
, (",", w) <- lex v
, (c, x) <- reads w
, (")", y) <- lex x ])
instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
readsPrec _ = readParen False
(\q -> [ ((a, b, c, d), z) | ("(", r) <- lex q
, (a, s) <- reads r
, (",", t) <- lex s
, (b, u) <- reads t
, (",", v) <- lex u
, (c, w) <- reads v
, (",", x) <- lex w
, (d, y) <- reads x
, (")", z) <- lex y ])
instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
readsPrec _ = readParen False
(\o -> [ ((a, b, c, d, e), z) | ("(", p) <- lex o
, (a, q) <- reads p
, (",", r) <- lex q
, (b, s) <- reads r
, (",", t) <- lex s
, (c, u) <- reads t
, (",", v) <- lex u
, (d, w) <- reads v
, (",", x) <- lex w
, (e, y) <- reads x
, (")", z) <- lex y ])
-- The following definitions are necessary to implement instances of Read.
lex :: ReadS String
lex xs = case xs of
"" -> [("","")]
(c:cs)
| isSpace c -> lex $ dropWhile isSpace cs
('\'':s) ->
[('\'' : ch ++ "'", t) | (ch, '\'' : t) <- lexLitChar s, ch /= "'"]
('"':s) -> [('"' : str, t) | (str, t) <- lexString s]
(c:cs)
| isSingle c -> [([c], cs)]
| isSym c -> [(c : sym, t) | (sym, t) <- [span isSym cs]]
| isAlpha c -> [(c : nam, t) | (nam, t) <- [span isIdChar cs]]
| isDigit c -> [(c : ds ++ fe, t) | (ds, s) <- [span isDigit cs]
, (fe, t) <- lexFracExp s]
| otherwise -> []
where
isSingle c = c `elem` ",;()[]{}_`"
isSym c = c `elem` "!@#$%&⋆+./<=>?\\^|:-~"
isIdChar c = isAlphaNum c || c `elem` "_'"
lexFracExp s = case s of
('.':c:cs)
| isDigit c ->
[('.' : ds ++ e, u) | (ds, t) <- lexDigits (c : cs), (e, u) <- lexExp t]
_ -> lexExp s
lexExp s = case s of
(e:cs) | e `elem` "eE" ->
[(e : c : ds, u) | (c:t) <- [cs], c `elem` "+-"
, (ds, u) <- lexDigits t] ++
[(e : ds, t) | (ds, t) <- lexDigits cs]
_ -> [("", s)]
lexString s = case s of
('"':cs) -> [("\"", cs)]
_ -> [(ch ++ str, u) | (ch, t) <- lexStrItem s, (str, u) <- lexString t]
lexStrItem s = case s of
('\\':'&':cs) -> [("\\&", cs)]
('\\':c:cs)
| isSpace c -> [("\\&", t) | '\\':t <- [dropWhile isSpace cs]]
_ -> lexLitChar s
lexLitChar :: ReadS String
lexLitChar xs = case xs of
"" -> []
('\\':cs) -> map (prefix '\\') (lexEsc cs)
(c:cs) -> [([c], cs)]
where
lexEsc s = case s of
(c:cs)
| c `elem` "abfnrtv\\\"'" -> [([c], cs)]
('^':c:cs)
| c >= '@' && c <= '_' -> [(['^',c], cs)]
('b':cs) -> [prefix 'b' (span isBinDigit cs)]
('o':cs) -> [prefix 'o' (span isOctDigit cs)]
('x':cs) -> [prefix 'x' (span isHexDigit cs)]
cs@(d:_)
| isDigit d -> [span isDigit cs]
cs@(c:_)
| isUpper c -> [span isCharName cs]
_ -> []
isCharName c = isUpper c || isDigit c
prefix c (t, cs) = (c : t, cs)
lexDigits :: ReadS String
lexDigits = nonNull isDigit
nonNull :: (Char -> Bool) -> ReadS String
nonNull p s = [(cs, t) | (cs@(_:_), t) <- [span p s]]
--- Returns true if the argument is an uppercase letter.
isUpper :: Char -> Bool
isUpper c = c >= 'A' && c <= 'Z'
--- Returns true if the argument is an lowercase letter.
isLower :: Char -> Bool
isLower c = c >= 'a' && c <= 'z'
--- Returns true if the argument is a letter.
isAlpha :: Char -> Bool
isAlpha c = isUpper c || isLower c
--- Returns true if the argument is a decimal digit.
isDigit :: Char -> Bool
isDigit c = c >= '0' && c <= '9'
--- Returns true if the argument is a letter or digit.
isAlphaNum :: Char -> Bool
isAlphaNum c = isAlpha c || isDigit c
--- Returns true if the argument is a binary digit.
isBinDigit :: Char -> Bool
isBinDigit c = c >= '0' || c <= '1'
--- Returns true if the argument is an octal digit.
isOctDigit :: Char -> Bool
isOctDigit c = c >= '0' && c <= '7'
--- Returns true if the argument is a hexadecimal digit.
isHexDigit :: Char -> Bool
isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
|| c >= 'a' && c <= 'f'
--- Returns true if the argument is a white space.
isSpace :: Char -> Bool
isSpace c = c == ' ' || c == '\t' || c == '\n' ||
c == '\r' || c == '\f' || c == '\v' ||
c == '\xa0' || ord c `elem` [5760,6158,8192,8239,8287,12288]
-- -------------------------------------------------------------------------
-- Bounded and Enum classes and instances
-- -------------------------------------------------------------------------
class Bounded a where
minBound, maxBound :: a
class Enum a where
succ :: a -> a
pred :: a -> a
toEnum :: Int -> a
fromEnum :: a -> Int
enumFrom :: a -> [a]
enumFromThen :: a -> a -> [a]
enumFromTo :: a -> a -> [a]
enumFromThenTo :: a -> a -> a -> [a]
succ = toEnum . (+ 1) . fromEnum
pred = toEnum . (\x -> x -1) . fromEnum
enumFrom x = map toEnum [fromEnum x ..]
enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..]
enumFromTo x y = map toEnum [fromEnum x .. fromEnum y]
enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y]
instance Bounded () where
minBound = ()
maxBound = ()
instance Enum () where
succ _ = error "Prelude.Enum.().succ: bad argument"
pred _ = error "Prelude.Enum.().pred: bad argument"
toEnum x | x == 0 = ()
| otherwise = error "Prelude.Enum.().toEnum: bad argument"
fromEnum () = 0
enumFrom () = [()]
enumFromThen () () = let many = ():many in many
enumFromTo () () = [()]
enumFromThenTo () () () = let many = ():many in many
instance Bounded Bool where
minBound = False
maxBound = True
instance Enum Bool where
succ False = True
succ True = error "Prelude.Enum.Bool.succ: bad argument"
pred False = error "Prelude.Enum.Bool.pred: bad argument"
pred True = False
toEnum n | n == 0 = False
| n == 1 = True
| otherwise = error "Prelude.Enum.Bool.toEnum: bad argument"
fromEnum False = 0
fromEnum True = 1
enumFrom = boundedEnumFrom
enumFromThen = boundedEnumFromThen
instance (Bounded a, Bounded b) => Bounded (a, b) where
minBound = (minBound, minBound)
maxBound = (maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c) => Bounded (a, b, c) where
minBound = (minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d) => Bounded (a, b, c, d) where
minBound = (minBound, minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e) => Bounded (a, b, c, d, e) where
minBound = (minBound, minBound, minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound)
instance Bounded Ordering where
minBound = LT
maxBound = GT
instance Enum Ordering where
succ LT = EQ
succ EQ = GT
succ GT = error "Prelude.Enum.Ordering.succ: bad argument"
pred LT = error "Prelude.Enum.Ordering.pred: bad argument"
pred EQ = LT
pred GT = EQ
toEnum n | n == 0 = LT
| n == 1 = EQ
| n == 2 = GT
| otherwise = error "Prelude.Enum.Ordering.toEnum: bad argument"
fromEnum LT = 0
fromEnum EQ = 1
fromEnum GT = 2
enumFrom = boundedEnumFrom
enumFromThen = boundedEnumFromThen
uppermostCharacter :: Int
uppermostCharacter = 0x10FFFF
instance Bounded Char where
minBound = chr 0
maxBound = chr uppermostCharacter
instance Enum Char where
succ c | ord c < uppermostCharacter = chr $ ord c + 1
| otherwise = error "Prelude.Enum.Char.succ: no successor"
pred c | ord c > 0 = chr $ ord c - 1
| otherwise = error "Prelude.Enum.Char.succ: no predecessor"
toEnum = chr
fromEnum = ord
enumFrom = boundedEnumFrom
enumFromThen = boundedEnumFromThen
-- TODO:
-- instance Enum Float where
-- TODO (?):
-- instance Bounded Int where
instance Enum Int where
-- TODO: is Int unbounded?
succ x = x + 1
pred x = x - 1
-- TODO: correct semantic?
toEnum n = n
fromEnum n = n
-- TODO: provide own implementations?
enumFrom = enumFrom_
enumFromTo = enumFromTo_
enumFromThen = enumFromThen_
enumFromThenTo = enumFromThenTo_
boundedEnumFrom :: (Enum a, Bounded a) => a -> [a]
boundedEnumFrom n = map toEnum [fromEnum n .. fromEnum (maxBound `asTypeOf` n)]
boundedEnumFromThen :: (Enum a, Bounded a) => a -> a -> [a]
boundedEnumFromThen n1 n2
| i_n2 >= i_n1 = map toEnum [i_n1, i_n2 .. fromEnum (maxBound `asTypeOf` n1)]
| otherwise = map toEnum [i_n1, i_n2 .. fromEnum (minBound `asTypeOf` n1)]
where
i_n1 = fromEnum n1
i_n2 = fromEnum n2
-- -------------------------------------------------------------------------
-- Numeric classes and instances
-- -------------------------------------------------------------------------
-- minimal definition: all (except negate or (-))
class Num a where
(+), (-), (*) :: a -> a -> a
negate :: a -> a
abs :: a -> a
signum :: a -> a
fromInt :: Int -> a
x - y = x + negate y
negate x = 0 - x
instance Num Int where
x + y = x +$ y
x - y = x -$ y
x * y = x *$ y
negate x = 0 - x
abs x | x >= 0 = x
| otherwise = negate x
signum x | x > 0 = 1
| x == 0 = 0
| otherwise = -1
fromInt x = x
instance Num Float where
x + y = x +. y
x - y = x -. y
x * y = x *. y
negate x = negateFloat x
abs x | x >= 0 = x
| otherwise = negate x
signum x | x > 0 = 1
| x == 0 = 0
| otherwise = -1
fromInt x = i2f x
-- minimal definition: fromFloat and (recip or (/))
class Num a => Fractional a where
(/) :: a -> a -> a
recip :: a -> a
recip x = 1/x
x / y = x * recip y
fromFloat :: Float -> a -- since we have no type Rational
instance Fractional Float where
x / y = x /. y
recip x = 1.0/x
fromFloat x = x
class (Num a, Ord a) => Real a where
-- toFloat :: a -> Float
class Real a => Integral a where
div :: a -> a -> a
mod :: a -> a -> a
quot :: a -> a -> a
rem :: a -> a -> a
divMod :: a -> a -> (a, a)
quotRem :: a -> a -> (a, a)
n `div` d = q where (q, _) = divMod n d
n `mod` d = r where (_, r) = divMod n d
n `quot` d = q where (q, _) = n `quotRem` d
n `rem` d = r where (_, r) = n `quotRem` d
instance Real Int where
-- no class methods to implement
instance Real Float where
-- no class methods to implement
instance Integral Int where
divMod n d = (n `div_` d, n `mod_` d)
quotRem n d = (n `quot_` d, n `rem_` d)
-- -------------------------------------------------------------------------
-- Helper functions
-- -------------------------------------------------------------------------
asTypeOf :: a -> a -> a
asTypeOf = const
-- -------------------------------------------------------------------------
-- Floating point operations
-- -------------------------------------------------------------------------
--- Addition on floats.
(+.) :: Float -> Float -> Float
x +. y = (prim_Float_plus $# y) $# x
prim_Float_plus :: Float -> Float -> Float
prim_Float_plus external
--- Subtraction on floats.
(-.) :: Float -> Float -> Float
x -. y = (prim_Float_minus $# y) $# x
prim_Float_minus :: Float -> Float -> Float
prim_Float_minus external
--- Multiplication on floats.
(*.) :: Float -> Float -> Float
x *. y = (prim_Float_times $# y) $# x
prim_Float_times :: Float -> Float -> Float
prim_Float_times external
--- Division on floats.
(/.) :: Float -> Float -> Float
x /. y = (prim_Float_div $# y) $# x
prim_Float_div :: Float -> Float -> Float
prim_Float_div external
--- Conversion function from integers to floats.
i2f :: Int -> Float
i2f x = prim_i2f $# x
prim_i2f :: Int -> Float
prim_i2f external
-- the end of the standard prelude
class Functor f where
fmap :: (a -> b) -> f a -> f b
instance Functor [] where
fmap = map
class Monad m where
(>>=) :: m a -> (a -> m b) -> m b
(>>) :: m a -> m b -> m b
m >> k = m >>= \_ -> k
return :: a -> m a
fail :: String -> m a
fail s = error s
instance Monad IO where
a1 >>= a2 = a1 >>=$ a2
a1 >> a2 = a1 >>$ a2
return x = returnIO x
instance Monad Maybe where
Nothing >>= _ = Nothing
(Just x) >>= f = f x
return = Just
fail _ = Nothing
instance Monad [] where
xs >>= f = [y | x <- xs, y <- f x]
return x = [x]
fail _ = []
----------------------------------------------------------------------------
-- Some useful monad operations which might be later generalized
-- or moved into some other base module.
--- Evaluates a sequence of monadic actions and collects all results in a list.
sequence :: Monad m => [m a] -> m [a]
sequence = foldr (\m n -> m >>= \x -> n >>= \xs -> return (x:xs)) (return [])
--- Evaluates a sequence of monadic actions and ignores the results.
sequence_ :: Monad m => [m _] -> m ()
sequence_ = foldr (>>) (return ())
--- Maps a monadic action function on a list of elements.
--- The results of all monadic actions are collected in a list.
mapM :: Monad m => (a -> m b) -> [a] -> m [b]
mapM f = sequence . map f
--- Maps a monadic action function on a list of elements.
--- The results of all monadic actions are ignored.
mapM_ :: Monad m => (a -> m _) -> [a] -> m ()
mapM_ f = sequence_ . map f
--- Folds a list of elements using a binary monadic action and a value
--- for the empty list.
foldM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
foldM _ z [] = return z
foldM f z (x:xs) = f z x >>= \z' -> foldM f z' xs
--- Apply a pure function to the result of a monadic action.
liftM :: Monad m => (a -> b) -> m a -> m b
liftM f m = m >>= return . f
--- Apply a pure binary function to the result of two monadic actions.
liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 f m1 m2 = do x1 <- m1
x2 <- m2
return (f x1 x2)
--- Like `mapM`, but with flipped arguments.
---
--- This can be useful if the definition of the function is longer
--- than those of the list, like in
---
--- forM [1..10] $ \n -> do
--- ...
forM :: Monad m => [a] -> (a -> m b) -> m [b]
forM xs f = mapM f xs
--- Like `mapM_`, but with flipped arguments.
---
--- This can be useful if the definition of the function is longer
--- than those of the list, like in
---
--- forM_ [1..10] $ \n -> do
--- ...
forM_ :: Monad m => [a] -> (a -> m b) -> m ()
forM_ xs f = mapM_ f xs
--- Performs a monadic action unless the condition is met.
unlessM :: Monad m => Bool -> m () -> m ()
unlessM p act = if p then return () else act
--- Performs a monadic action when the condition is met.
whenM :: Monad m => Bool -> m () -> m ()
whenM p act = if p then act else return ()
----------------------------------------------------------------------------
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Prelude.kics2 0000664 0000000 0000000 00000266143 13231616147 0024034 0 ustar 00root root 0000000 0000000 {-# LANGUAGE BangPatterns, CPP, MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
import qualified Control.Exception as C
-- ATTENTION: Do not introduce line breaks in import declarations as these
-- are not recognized!
import Data.Char (chr, ord)
import GHC.Exts (Double (D#), Double#, (==##), (<=##), negateDouble#)
import GHC.Exts (Char (C#), Char#, eqChar#, leChar#)
import System.IO
import CurryException
import KiCS2Debug (internalError)
import FailInfo (customFail)
import PrimTypes
#if __GLASGOW_HASKELL__ > 706
import GHC.Exts (isTrue#)
#endif
-- #endimport - do not remove this line!
#if !(__GLASGOW_HASKELL__ > 706)
isTrue# :: Bool -> Bool
{-# INLINE isTrue# #-}
isTrue# x = x
#endif
-- -----------------------------------------------------------------------------
-- Int representation
-- -----------------------------------------------------------------------------
-- BEGIN GENERATED FROM PrimTypes.curry
data C_Int
= C_Int Integer
| C_CurryInt BinInt
| Choice_C_Int Cover ID C_Int C_Int
| Choices_C_Int Cover ID ([C_Int])
| Fail_C_Int Cover FailInfo
| Guard_C_Int Cover Constraints C_Int
instance Show C_Int where
showsPrec d (Choice_C_Int cd i x y) = showsChoice d cd i x y
showsPrec d (Choices_C_Int cd i xs) = showsChoices d cd i xs
showsPrec d (Guard_C_Int cd c e) = showsGuard d cd c e
showsPrec _ (Fail_C_Int _ _) = showChar '!'
showsPrec d (C_Int x1) = shows x1
showsPrec d (C_CurryInt x1) = case ((\x _ _ -> x) $## x1) (error "Show C_Int: nesting depth used") emptyCs of
Choice_BinInt _ _ _ _ -> shows x1
Choices_BinInt _ _ _ -> shows x1
Fail_BinInt _ _ -> shows x1
Guard_BinInt _ _ _ -> shows x1
gnfBinInt -> shows (curryint2primint gnfBinInt)
instance Read C_Int where
readsPrec d s = map readInt (readsPrec d s) where readInt (i, s) = (C_Int i, s)
instance NonDet C_Int where
choiceCons = Choice_C_Int
choicesCons = Choices_C_Int
failCons = Fail_C_Int
guardCons = Guard_C_Int
try (Choice_C_Int cd i x y) = tryChoice cd i x y
try (Choices_C_Int cd i xs) = tryChoices cd i xs
try (Fail_C_Int cd info) = Fail cd info
try (Guard_C_Int cd c e) = Guard cd c e
try x = Val x
match f _ _ _ _ _ (Choice_C_Int cd i x y) = f cd i x y
match _ f _ _ _ _ (Choices_C_Int cd i@(NarrowedID _ _) xs) = f cd i xs
match _ _ f _ _ _ (Choices_C_Int cd i@(FreeID _ _) xs) = f cd i xs
match _ _ _ _ _ _ (Choices_C_Int _ i _) = error ("Prelude.Int.match: Choices with ChoiceID " ++ (show i))
match _ _ _ f _ _ (Fail_C_Int cd info) = f cd info
match _ _ _ _ f _ (Guard_C_Int cd cs e) = f cd cs e
match _ _ _ _ _ f x = f x
instance Generable C_Int where
generate s cd = Choices_C_Int cd (freeID [1] s) [C_CurryInt (generate (leftSupply s) cd)]
instance NormalForm C_Int where
($!!) cont x@(C_Int _) cd cs = cont x cd cs
($!!) cont (C_CurryInt x1) cd cs = ((\y1 -> cont (C_CurryInt y1)) $!! x1) cd cs
($!!) cont (Choice_C_Int d i x y) cd cs = nfChoice cont d i x y cd cs
($!!) cont (Choices_C_Int d i xs) cd cs = nfChoices cont d i xs cd cs
($!!) cont (Guard_C_Int d c x) cd cs = guardCons d c ((cont $!! x) cd $! (addCs c cs))
($!!) _ (Fail_C_Int cd info) _ _ = failCons cd info
($##) cont x@(C_Int _) cd cs = cont x cd cs
($##) cont (C_CurryInt x1) cd cs = ((\y1 -> cont (C_CurryInt y1)) $## x1) cd cs
($##) cont (Choice_C_Int d i x y) cd cs = gnfChoice cont d i x y cd cs
($##) cont (Choices_C_Int d i xs) cd cs = gnfChoices cont d i xs cd cs
($##) cont (Guard_C_Int d c x) cd cs = guardCons d c ((cont $## x) cd $! (addCs c cs))
($##) _ (Fail_C_Int d info) _ _ = failCons d info
searchNF search cont x@(C_Int _) = cont x
searchNF search cont (C_CurryInt x1) = search (\y1 -> cont (C_CurryInt y1)) x1
searchNF _ _ x = error ("Prelude.Int.searchNF: no constructor: " ++ (show x))
instance Unifiable C_Int where
(=.=) (C_Int x1) (C_Int y1) cd _ = if x1 == y1 then C_True else Fail_C_Bool cd defFailInfo
(=.=) (C_Int x1) (C_CurryInt y1) cd cs = ((primint2curryint x1) =:= y1) cd cs
(=.=) (C_CurryInt x1) (C_Int y1) cd cs = (x1 =:= (primint2curryint y1)) cd cs
(=.=) (C_CurryInt x1) (C_CurryInt y1) cd cs = (x1 =:= y1) cd cs
(=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo
(=.<=) (C_Int x1) (C_Int y1) cd _ = if x1 == y1 then C_True else Fail_C_Bool cd defFailInfo
(=.<=) (C_Int x1) (C_CurryInt y1) cd cs = ((primint2curryint x1) =:<= y1) cd cs
(=.<=) (C_CurryInt x1) (C_Int y1) cd cs = (x1 =:<= (primint2curryint y1)) cd cs
(=.<=) (C_CurryInt x1) (C_CurryInt y1) cd cs = (x1 =:<= y1) cd cs
(=.<=) _ _ cd _= Fail_C_Bool cd defFailInfo
bind cd i (C_Int x2) = (i :=: ChooseN 0 1) : bind cd (leftID i) (primint2curryint x2)
bind cd i (C_CurryInt x2) = (i :=: ChooseN 0 1) : bind cd (leftID i) x2
bind cd i (Choice_C_Int d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))]
bind cd i (Choices_C_Int d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs
bind cd i (Choices_C_Int d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))]
bind _ _ c@(Choices_C_Int _ i@(ChoiceID _) _) = error ("Prelude.Int.bind: Choices with ChoiceID: " ++ (show c))
bind _ _ (Fail_C_Int _ info) = [Unsolvable info]
bind cd i (Guard_C_Int _ cs e) = getConstrList cs ++ (bind cd i e)
lazyBind cd i (C_Int x2) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) (primint2curryint x2))]
lazyBind cd i (C_CurryInt x2) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) x2)]
lazyBind cd i (Choice_C_Int d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))]
lazyBind cd i (Choices_C_Int d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs
lazyBind cd i (Choices_C_Int d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))]
lazyBind _ _ c@(Choices_C_Int _ i@(ChoiceID _) _) = error ("Prelude.Int.lazyBind: Choices with ChoiceID: " ++ (show c))
lazyBind _ _ (Fail_C_Int _ info) = [Unsolvable info]
lazyBind cd i (Guard_C_Int _ cs e) = getConstrList cs ++ [(i :=: (LazyBind (lazyBind cd i e)))]
instance Curry C_Int
-- END GENERATED FROM PrimTypes.curry
d_C_prim_eqInt :: C_Int -> C_Int -> Cover -> ConstStore -> C_Bool
d_C_prim_eqInt (Choice_C_Int d i x y) z cd cs =
narrow d i ((x `d_C_prim_eqInt` z) cd cs) ((y `d_C_prim_eqInt` z) cd cs)
d_C_prim_eqInt (Choices_C_Int d i xs) y cd cs =
narrows cs d i (\x -> (x `d_C_prim_eqInt` y) cd cs) xs
d_C_prim_eqInt (Guard_C_Int d c x) y cd cs =
guardCons d c ((x `d_C_prim_eqInt` y) cd $! (addCs c cs))
d_C_prim_eqInt (Fail_C_Int d info) _ _ _ = failCons d info
d_C_prim_eqInt z (Choice_C_Int d i x y) cd cs =
narrow d i ((z `d_C_prim_eqInt` x) cd cs) ((z `d_C_prim_eqInt` y) cd cs)
d_C_prim_eqInt y (Choices_C_Int d i xs) cd cs =
narrows cs d i (\x -> (y `d_C_prim_eqInt` x) cd cs) xs
d_C_prim_eqInt y (Guard_C_Int d c x) cd cs =
guardCons d c ((y `d_C_prim_eqInt` x) cd $! (addCs c cs))
d_C_prim_eqInt _ (Fail_C_Int d info) _ _ = failCons d info
d_C_prim_eqInt (C_Int x1) (C_Int y1) _ _ = toCurry (x1 == y1)
d_C_prim_eqInt (C_Int x1) (C_CurryInt y1) cd cs =
((primint2curryint x1) `d_C_prim_eqBinInt` y1) cd cs
d_C_prim_eqInt (C_CurryInt x1) (C_Int y1) cd cs =
(x1 `d_C_prim_eqBinInt` (primint2curryint y1)) cd cs
d_C_prim_eqInt (C_CurryInt x1) (C_CurryInt y1) cd cs =
(x1 `d_C_prim_eqBinInt` y1) cd cs
d_C_prim_ltEqInt :: C_Int -> C_Int -> Cover -> ConstStore -> C_Bool
d_C_prim_ltEqInt (Choice_C_Int d i x y) z cd cs =
narrow d i ((x `d_C_prim_ltEqInt` z) cd cs) ((y `d_C_prim_ltEqInt` z) cd cs)
d_C_prim_ltEqInt (Choices_C_Int d i xs) y cd cs =
narrows cs d i (\x -> (x `d_C_prim_ltEqInt` y) cd cs) xs
d_C_prim_ltEqInt (Guard_C_Int d c x) y cd cs =
guardCons d c ((x `d_C_prim_ltEqInt` y) cd $! (addCs c cs))
d_C_prim_ltEqInt (Fail_C_Int d info) _ _ _ = failCons d info
d_C_prim_ltEqInt z (Choice_C_Int d i x y) cd cs =
narrow d i ((z `d_C_prim_ltEqInt` x) cd cs) ((z `d_C_prim_ltEqInt` y) cd cs)
d_C_prim_ltEqInt y (Choices_C_Int d i xs) cd cs =
narrows cs d i (\x -> (y `d_C_prim_ltEqInt` x) cd cs) xs
d_C_prim_ltEqInt y (Guard_C_Int d c x) cd cs =
guardCons d c ((y `d_C_prim_ltEqInt` x) cd $! (addCs c cs))
d_C_prim_ltEqInt _ (Fail_C_Int d info) _ _ = failCons d info
d_C_prim_ltEqInt (C_Int x1) (C_Int y1) _ _ = toCurry (x1 <= y1)
d_C_prim_ltEqInt (C_Int x1) (C_CurryInt y1) cd cs =
((primint2curryint x1) `d_C_lteqInteger` y1) cd cs
d_C_prim_ltEqInt (C_CurryInt x1) (C_Int y1) cd cs =
(x1 `d_C_lteqInteger` (primint2curryint y1)) cd cs
d_C_prim_ltEqInt (C_CurryInt x1) (C_CurryInt y1) cd cs =
(x1 `d_C_lteqInteger` y1) cd cs
external_d_C_eqInt :: C_Int -> C_Int -> Cover -> ConstStore -> C_Bool
external_d_C_eqInt = d_C_prim_eqInt
external_d_C_ltEqInt :: C_Int -> C_Int -> Cover -> ConstStore -> C_Bool
external_d_C_ltEqInt = d_C_prim_ltEqInt
primint2curryint :: Integer -> BinInt
primint2curryint n
| n < 0 = Neg (primint2currynat (negate n))
| n == 0 = Zero
| otherwise = Pos (primint2currynat n)
primint2currynat :: Integer -> Nat
primint2currynat n
| n == 1 = IHi
| (n `rem` 2) == 0 = O (primint2currynat (n `quot` 2))
| otherwise = I (primint2currynat (n `quot` 2))
curryint2primint :: BinInt -> Integer
curryint2primint Zero = 0
curryint2primint (Pos n) = currynat2primint n
curryint2primint (Neg n) = negate (currynat2primint n)
curryint2primint int = error ("KiCS2 error: Prelude.curryint2primint: no ground term, but " ++ show int)
currynat2primint :: Nat -> Integer
currynat2primint IHi = 1
currynat2primint (O n) = 2 * currynat2primint n
currynat2primint (I n) = 2 * currynat2primint n + 1
currynat2primint nat = error ("KiCS2 error: Prelude.currynat2primint: no ground term, but " ++ show nat)
-- -----------------------------------------------------------------------------
-- Float representation
-- -----------------------------------------------------------------------------
-- BEGIN GENERATED FROM PrimTypes.curry
data C_Float
= C_Float Double#
| Choice_C_Float Cover ID C_Float C_Float
| Choices_C_Float Cover ID ([C_Float])
| Fail_C_Float Cover FailInfo
| Guard_C_Float Cover (Constraints) C_Float
instance Show C_Float where
showsPrec d (Choice_C_Float cd i x y) = showsChoice d cd i x y
showsPrec d (Choices_C_Float cd i xs) = showsChoices d cd i xs
showsPrec d (Guard_C_Float cd c e) = showsGuard d cd c e
showsPrec d (Fail_C_Float _ _) = showChar '!'
showsPrec d (C_Float x1) = shows (D# x1)
instance Read C_Float where
readsPrec d s = map readFloat (readsPrec d s) where readFloat (D# d, s) = (C_Float d, s)
instance NonDet C_Float where
choiceCons = Choice_C_Float
choicesCons = Choices_C_Float
failCons = Fail_C_Float
guardCons = Guard_C_Float
try (Choice_C_Float cd i x y) = tryChoice cd i x y
try (Choices_C_Float cd i xs) = tryChoices cd i xs
try (Fail_C_Float cd info) = Fail cd info
try (Guard_C_Float cd c e) = Guard cd c e
try x = Val x
match f _ _ _ _ _ (Choice_C_Float cd i x y) = f cd i x y
match _ f _ _ _ _ (Choices_C_Float cd i@(NarrowedID _ _) xs) = f cd i xs
match _ _ f _ _ _ (Choices_C_Float cd i@(FreeID _ _) xs) = f cd i xs
match _ _ _ _ _ _ (Choices_C_Float cd i@(ChoiceID _) _) = error ("Prelude.Float.match: Choices with ChoiceID " ++ (show i))
match _ _ _ f _ _ (Fail_C_Float cd info) = f cd info
match _ _ _ _ f _ (Guard_C_Float cd cs e) = f cd cs e
match _ _ _ _ _ f x = f x
instance Generable C_Float where
generate = error "No generator for C_Float"
instance NormalForm C_Float where
($!!) cont x@(C_Float _) cd cs = cont x cd cs
($!!) cont (Choice_C_Float d i x y) cd cs = nfChoice cont d i x y cd cs
($!!) cont (Choices_C_Float d i xs) cd cs = nfChoices cont d i xs cd cs
($!!) cont (Guard_C_Float d c x) cd cs = guardCons d c ((cont $!! x) cd $! (addCs c cs))
($!!) _ (Fail_C_Float d info) _ _ = failCons d info
($##) cont x@(C_Float _) cd cs = cont x cd cs
($##) cont (Choice_C_Float d i x y) cd cs = gnfChoice cont d i x y cd cs
($##) cont (Choices_C_Float d i xs) cd cs = gnfChoices cont d i xs cd cs
($##) cont (Guard_C_Float d c x) cd cs = guardCons d c ((cont $## x) cd $! (addCs c cs))
($##) _ (Fail_C_Float d info) _ _ = failCons d info
searchNF search cont x@(C_Float _) = cont x
searchNF _ _ x = error ("Prelude.Float.searchNF: no constructor: " ++ (show x))
instance Unifiable C_Float where
(=.=) (C_Float x1) (C_Float y1) cd _ = if isTrue# (x1 ==## y1) then C_True else Fail_C_Bool cd defFailInfo
(=.<=) (C_Float x1) (C_Float y1) cd _ = if isTrue# (x1 ==## y1) then C_True else Fail_C_Bool cd defFailInfo
bind cd i (Choice_C_Float d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))]
bind cd i (Choices_C_Float d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs
bind cd i (Choices_C_Float d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))]
bind _ _ c@(Choices_C_Float _ i _) = error ("Prelude.Float.bind: Choices with ChoiceID: " ++ (show c))
bind _ _ (Fail_C_Float _ info) = [Unsolvable info]
bind cd i (Guard_C_Float _ cs e) = getConstrList cs ++ (bind cd i e)
lazyBind cd i (Choice_C_Float d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))]
lazyBind cd i (Choices_C_Float d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs
lazyBind cd i (Choices_C_Float d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))]
lazyBind _ _ c@(Choices_C_Float _ i _) = error ("Prelude.Float.lazyBind: Choices with ChoiceID: " ++ (show c))
lazyBind _ _ (Fail_C_Float _ info) = [Unsolvable info]
lazyBind cd i (Guard_C_Float _ cs e) = getConstrList cs ++ [(i :=: (LazyBind (lazyBind cd i e)))]
instance Curry C_Float
-- END GENERATED FROM PrimTypes.curry
d_C_prim_eqFloat :: C_Float -> C_Float -> Cover -> ConstStore -> C_Bool
d_C_prim_eqFloat (Choice_C_Float d i x y) z cd cs =
narrow d i ((x `d_C_prim_eqFloat` z) cd cs) ((y `d_C_prim_eqFloat` z) cd cs)
d_C_prim_eqFloat (Choices_C_Float d i xs) y cd cs =
narrows cs d i (\x -> (x `d_C_prim_eqFloat` y) cd cs) xs
d_C_prim_eqFloat (Guard_C_Float d c x) y cd cs =
guardCons d c ((x `d_C_prim_eqFloat` y) cd $! (addCs c cs))
d_C_prim_eqFloat (Fail_C_Float d info) _ _ _= failCons d info
d_C_prim_eqFloat z (Choice_C_Float d i x y) cd cs =
narrow d i ((z `d_C_prim_eqFloat` x) cd cs) ((z `d_C_prim_eqFloat` y) cd cs)
d_C_prim_eqFloat y (Choices_C_Float d i xs) cd cs =
narrows cs d i (\x -> (y `d_C_prim_eqFloat` x) cd cs) xs
d_C_prim_eqFloat y (Guard_C_Float d c x) cd cs =
guardCons d c ((y `d_C_prim_eqFloat` x) cd $! (addCs c cs))
d_C_prim_eqFloat _ (Fail_C_Float d info) _ _ = failCons d info
d_C_prim_eqFloat (C_Float x1) (C_Float y1) _ _ = toCurry (isTrue# (x1 ==## y1))
d_C_prim_ltEqFloat :: C_Float -> C_Float -> Cover -> ConstStore -> C_Bool
d_C_prim_ltEqFloat (Choice_C_Float d i x y) z cd cs =
narrow d i ((x `d_C_prim_ltEqFloat` z) cd cs) ((y `d_C_prim_ltEqFloat` z) cd cs)
d_C_prim_ltEqFloat (Choices_C_Float d i xs) y cd cs =
narrows cs d i (\x -> (x `d_C_prim_ltEqFloat` y) cd cs) xs
d_C_prim_ltEqFloat (Guard_C_Float d c x) y cd cs =
guardCons d c ((x `d_C_prim_ltEqFloat` y) cd $! (addCs c cs))
d_C_prim_ltEqFloat (Fail_C_Float d info) _ _ _ = failCons d info
d_C_prim_ltEqFloat z (Choice_C_Float d i x y) cd cs =
narrow d i ((z `d_C_prim_ltEqFloat` x) cd cs) ((z `d_C_prim_ltEqFloat` y) cd cs)
d_C_prim_ltEqFloat y (Choices_C_Float d i xs) cd cs =
narrows cs d i (\x -> (y `d_C_prim_ltEqFloat` x) cd cs) xs
d_C_prim_ltEqFloat y (Guard_C_Float d c x) cd cs =
guardCons d c ((y `d_C_prim_ltEqFloat` x) cd $! (addCs c cs))
d_C_prim_ltEqFloat _ (Fail_C_Float d info) _ _ = failCons d info
d_C_prim_ltEqFloat (C_Float x1) (C_Float y1) _ _ = toCurry (isTrue# (x1 <=## y1))
external_d_C_eqFloat :: C_Float -> C_Float -> Cover -> ConstStore -> C_Bool
external_d_C_eqFloat = d_C_prim_eqFloat
external_d_C_ltEqFloat :: C_Float -> C_Float -> Cover -> ConstStore -> C_Bool
external_d_C_ltEqFloat = d_C_prim_ltEqFloat
-- ---------------------------------------------------------------------------
-- Char
-- ---------------------------------------------------------------------------
-- BEGIN GENERATED FROM PrimTypes.curry
data C_Char
= C_Char Char#
| CurryChar BinInt
| Choice_C_Char Cover ID C_Char C_Char
| Choices_C_Char Cover ID ([C_Char])
| Fail_C_Char Cover FailInfo
| Guard_C_Char Cover (Constraints) C_Char
instance Show C_Char where
showsPrec d (Choice_C_Char cd i x y) = showsChoice d cd i x y
showsPrec d (Choices_C_Char cd i xs) = showsChoices d cd i xs
showsPrec d (Guard_C_Char cd c e) = showsGuard d d c e
showsPrec d (Fail_C_Char _ _) = showChar '!'
showsPrec d (C_Char x1) = showString (show (C# x1))
showsPrec d (CurryChar x1) = case ((\x _ _ -> x) $## x1) (error "Show C_Char: nesting depth used") emptyCs of
Choice_BinInt _ _ _ _ -> showString "chr " . shows x1
Choices_BinInt _ _ _ -> showString "chr " . shows x1
Fail_BinInt _ _ -> shows x1
Guard_BinInt _ _ _ -> shows x1
gnfBinInt -> shows (C# (curryChar2primChar gnfBinInt))
showList cs | all isPrimChar cs' = showList (map convert cs')
| otherwise = showCharList cs'
where
cs' = map gnfCurryChar cs
gnfCurryChar :: C_Char -> C_Char
gnfCurryChar (CurryChar x1) = case ((\x _ _ -> x) $## x1) (error "gnfCurryChar: nesting depth used") emptyCs of
Choice_BinInt _ _ _ _ -> CurryChar x1
Choices_BinInt _ _ _ -> CurryChar x1
Fail_BinInt _ _ -> CurryChar x1
Guard_BinInt _ _ _ -> CurryChar x1
gnfBinInt -> C_Char (curryChar2primChar gnfBinInt)
gnfCurryChar c = c
isPrimChar (C_Char _) = True
isPrimChar _ = False
convert (C_Char c) = C# c
showCharList [] = showString "[]"
showCharList (x:xs) = showChar '[' . shows x . showRest xs
where
showRest [] = showChar ']'
showRest (y:ys) = showChar ',' . shows y . showRest ys
instance Read C_Char where
readsPrec d s = map readChar (readsPrec d s) where readChar (C# c, s) = (C_Char c, s)
readList s = map readString (readList s) where readString (cs, s) = (map (\(C# c) -> C_Char c) cs, s)
instance NonDet C_Char where
choiceCons = Choice_C_Char
choicesCons = Choices_C_Char
failCons = Fail_C_Char
guardCons = Guard_C_Char
try (Choice_C_Char cd i x y) = tryChoice cd i x y
try (Choices_C_Char cd i xs) = tryChoices cd i xs
try (Fail_C_Char cd info) = Fail cd info
try (Guard_C_Char cd c e) = Guard cd c e
try x = Val x
match f _ _ _ _ _ (Choice_C_Char cd i x y) = f cd i x y
match _ f _ _ _ _ (Choices_C_Char cd i@(NarrowedID _ _) xs) = f cd i xs
match _ _ f _ _ _ (Choices_C_Char cd i@(FreeID _ _) xs) = f cd i xs
match _ _ _ _ _ _ (Choices_C_Char cd i _) = error ("Prelude.Char.match: Choices with ChoiceID " ++ (show i))
match _ _ _ f _ _ (Fail_C_Char cd info) = f cd info
match _ _ _ _ f _ (Guard_C_Char cd cs e) = f cd cs e
match _ _ _ _ _ f x = f x
instance Generable C_Char where
generate s cd = Choices_C_Char cd (freeID [1] s)
[CurryChar (generateNNBinInt (leftSupply s) cd)]
where
-- generate only non-negative ord values for characters:
generateNNBinInt s c =
Choices_BinInt c (freeID [1, 0, 1] s)
[Fail_BinInt c (customFail "no negative ord values for characters"),
Zero, Pos (generate (leftSupply s) c)]
instance NormalForm C_Char where
($!!) cont x@(C_Char _) cd cs = cont x cd cs
($!!) cont (CurryChar x) cd cs = ((cont . CurryChar) $!! x) cd cs
($!!) cont (Choice_C_Char d i x y) cd cs = nfChoice cont d i x y cd cs
($!!) cont (Choices_C_Char d i xs) cd cs = nfChoices cont d i xs cd cs
($!!) cont (Guard_C_Char d c x) cd cs = guardCons d c ((cont $!! x) cd $! (addCs c cs))
($!!) _ (Fail_C_Char d info) _ _ = failCons d info
($##) cont x@(C_Char _) cd cs = cont x cd cs
($##) cont (CurryChar x) cd cs = ((cont . CurryChar) $## x) cd cs
($##) cont (Choice_C_Char d i x y) cd cs = gnfChoice cont d i x y cd cs
($##) cont (Choices_C_Char d i xs) cd cs = gnfChoices cont d i xs cd cs
($##) cont (Guard_C_Char d c x) cd cs = guardCons d c ((cont $## x) cd $! (addCs c cs))
($##) _ (Fail_C_Char d info) _ _ = failCons d info
searchNF search cont c@(C_Char _) = cont c
searchNF search cont (CurryChar x) = search (cont . CurryChar) x
searchNF _ _ x = error ("Prelude.Char.searchNF: no constructor: " ++ (show x))
instance Unifiable C_Char where
(=.=) (C_Char x1) (C_Char x2) cd _ | isTrue# (x1 `eqChar#` x2) = C_True
| otherwise = Fail_C_Bool cd defFailInfo
(=.=) (C_Char x1) (CurryChar x2) cd cs = (primChar2CurryChar x1 =:= x2) cd cs
(=.=) (CurryChar x1) (C_Char x2) cd cs = (x1 =:= primChar2CurryChar x2) cd cs
(=.=) (CurryChar x1) (CurryChar x2) cd cs = (x1 =:= x2) cd cs
(=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo
(=.<=) (C_Char x1) (C_Char x2) cd _ | isTrue# (x1 `eqChar#` x2) = C_True
| otherwise = Fail_C_Bool cd defFailInfo
(=.<=) (C_Char x1) (CurryChar x2) cd cs = (primChar2CurryChar x1 =:<= x2) cd cs
(=.<=) (CurryChar x1) (C_Char x2) cd cs = (x1 =:<= primChar2CurryChar x2) cd cs
(=.<=) (CurryChar x1) (CurryChar x2) cd cs = (x1 =:<= x2) cd cs
(=.<=) _ _ cd _ = Fail_C_Bool cd defFailInfo
bind cd i (C_Char x) = (i :=: ChooseN 0 1) : bind cd (leftID i) (primChar2CurryChar x)
bind cd i (CurryChar x) = (i :=: ChooseN 0 1) : bind cd (leftID i) x
bind cd i (Choice_C_Char d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))]
bind cd i (Choices_C_Char d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs
bind cd i (Choices_C_Char d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))]
bind _ _ c@(Choices_C_Char _ i _) = error ("Prelude.Char.bind: Choices with ChoiceID: " ++ (show c))
bind _ _ (Fail_C_Char _ info) = [Unsolvable info]
bind cd i (Guard_C_Char _ cs e) = getConstrList cs ++ (bind cd i e)
lazyBind cd i (C_Char x) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) (primChar2CurryChar x))]
lazyBind cd i (CurryChar x) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) x)]
lazyBind cd i (Choice_C_Char d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))]
lazyBind cd i (Choices_C_Char d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs
lazyBind cd i (Choices_C_Char d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))]
lazyBind _ _ c@(Choices_C_Char _ i _) = error ("Prelude.Char.lazyBind: Choices with ChoiceID: " ++ (show c))
lazyBind _ _ (Fail_C_Char _ info) = [Unsolvable info]
lazyBind cd i (Guard_C_Char _ cs e) = getConstrList cs ++ [(i :=: (LazyBind (lazyBind cd i e)))]
instance Curry C_Char
-- END GENERATED FROM PrimTypes.curry
d_C_prim_eqChar :: C_Char -> C_Char -> Cover -> ConstStore -> C_Bool
d_C_prim_eqChar (Choice_C_Char d i x y) z cd cs =
narrow d i ((x `d_C_prim_eqChar` z) cd cs) ((y `d_C_prim_eqChar` z) cd cs)
d_C_prim_eqChar (Choices_C_Char d i xs) y cd cs =
narrows cs d i (\x -> (x `d_C_prim_eqChar` y) cd cs) xs
d_C_prim_eqChar (Guard_C_Char d c x) y cd cs =
guardCons d c ((x `d_C_prim_eqChar` y) cd $! (addCs c cs))
d_C_prim_eqChar (Fail_C_Char d info) _ _ _ = failCons d info
d_C_prim_eqChar z (Choice_C_Char d i x y) cd cs =
narrow d i ((z `d_C_prim_eqChar` x) cd cs) ((z `d_C_prim_eqChar` y) cd cs)
d_C_prim_eqChar y (Choices_C_Char d i xs) cd cs =
narrows cs d i (\x -> (y `d_C_prim_eqChar` x) cd cs) xs
d_C_prim_eqChar y (Guard_C_Char d c x) cd cs =
guardCons d c ((y `d_C_prim_eqChar` x) cd $! (addCs c cs))
d_C_prim_eqChar _ (Fail_C_Char d info) _ _ = failCons d info
d_C_prim_eqChar (C_Char x1) (C_Char y1) _ _ = toCurry (isTrue# (x1 `eqChar#` y1))
d_C_prim_eqChar (C_Char x1) (CurryChar y1) cd cs =
((primChar2CurryChar x1) `d_C_prim_eqBinInt` y1) cd cs
d_C_prim_eqChar (CurryChar x1) (C_Char y1) cd cs =
(x1 `d_C_prim_eqBinInt` (primChar2CurryChar y1)) cd cs
d_C_prim_eqChar (CurryChar x1) (CurryChar y1) cd cs =
(x1 `d_C_prim_eqBinInt` y1) cd cs
d_C_prim_ltEqChar :: C_Char -> C_Char -> Cover -> ConstStore -> C_Bool
d_C_prim_ltEqChar (Choice_C_Char d i x y) z cd cs =
narrow d i ((x `d_C_prim_ltEqChar` z) cd cs) ((y `d_C_prim_ltEqChar` z) cd cs)
d_C_prim_ltEqChar (Choices_C_Char d i xs) y cd cs =
narrows cs d i (\x -> (x `d_C_prim_ltEqChar` y) cd cs) xs
d_C_prim_ltEqChar (Guard_C_Char d c x) y cd cs =
guardCons d c ((x `d_C_prim_ltEqChar` y) cd $! (addCs c cs))
d_C_prim_ltEqChar (Fail_C_Char d info) _ _ _ = failCons d info
d_C_prim_ltEqChar z (Choice_C_Char d i x y) cd cs =
narrow d i ((z `d_C_prim_ltEqChar` x) cd cs) ((z `d_C_prim_ltEqChar` y) cd cs)
d_C_prim_ltEqChar y (Choices_C_Char d i xs) cd cs =
narrows cs d i (\x -> (y `d_C_prim_ltEqChar` x) cd cs) xs
d_C_prim_ltEqChar y (Guard_C_Char d c x) cd cs =
guardCons d c ((y `d_C_prim_ltEqChar` x) cd $! (addCs c cs))
d_C_prim_ltEqChar _ (Fail_C_Char d info) _ _ = failCons d info
d_C_prim_ltEqChar (C_Char x1) (C_Char y1) _ _ = toCurry (isTrue# (x1 `leChar#` y1))
d_C_prim_ltEqChar (C_Char x1) (CurryChar y1) cd cs = ((primChar2CurryChar x1) `d_C_lteqInteger` y1) cd cs
d_C_prim_ltEqChar (CurryChar x1) (C_Char y1) cd cs = (x1 `d_C_lteqInteger` (primChar2CurryChar y1)) cd cs
d_C_prim_ltEqChar (CurryChar x1) (CurryChar y1) cd cs = (x1 `d_C_lteqInteger` y1) cd cs
external_d_C_eqChar :: C_Char -> C_Char -> Cover -> ConstStore -> C_Bool
external_d_C_eqChar = d_C_prim_eqChar
external_d_C_ltEqChar :: C_Char -> C_Char -> Cover -> ConstStore -> C_Bool
external_d_C_ltEqChar = d_C_prim_ltEqChar
primChar2primint :: Char# -> Integer
primChar2primint c = toInteger (ord (C# c))
primint2primChar :: Integer -> Char#
primint2primChar c = char2primChar (chr (fromInteger c))
where char2primChar (C# c) = c
primChar2CurryChar :: Char# -> BinInt
primChar2CurryChar c = primint2curryint (primChar2primint c)
curryChar2primChar :: BinInt -> Char#
curryChar2primChar c = primint2primChar (curryint2primint c)
-- ---------------------------------------------------------------------------
-- Conversion from and to primitive Haskell types
-- ---------------------------------------------------------------------------
instance ConvertCurryHaskell C_Int Integer where
toCurry i = C_Int i
fromCurry (C_Int i) = i
fromCurry (C_CurryInt i) = curryint2primint i
fromCurry _ = error "KiCS2 error: Int data with no ground term"
instance ConvertCurryHaskell C_Int Int where
toCurry i = toCurry (toInteger i)
fromCurry i = fromInteger (fromCurry i)
instance ConvertCurryHaskell C_Float Double where
toCurry (D# d) = C_Float d
fromCurry (C_Float d) = D# d
fromCurry _ = error "KiCS2 error: Float data with no ground term"
instance ConvertCurryHaskell C_Char Char where
toCurry (C# c) = C_Char c
fromCurry (C_Char c) = C# c
fromCurry (CurryChar c) = C# (curryChar2primChar c)
fromCurry _ = error "KiCS2 error: Char data with no ground term"
instance (ConvertCurryHaskell ct ht) =>
ConvertCurryHaskell (OP_List ct) [ht] where
toCurry [] = OP_List
toCurry (c:cs) = OP_Cons (toCurry c) (toCurry cs)
fromCurry OP_List = []
fromCurry (OP_Cons c cs) = fromCurry c : fromCurry cs
fromCurry _ = error "KiCS2 error: List data with no ground term"
instance ConvertCurryHaskell C_Bool Bool where
toCurry True = C_True
toCurry False = C_False
fromCurry C_True = True
fromCurry C_False = False
fromCurry _ = error "KiCS2 error: Bool data with no ground term"
instance ConvertCurryHaskell OP_Unit () where
toCurry () = OP_Unit
fromCurry OP_Unit = ()
fromCurry _ = error "KiCS2 error: Unit data with no ground term"
instance (ConvertCurryHaskell ct1 ht1, ConvertCurryHaskell ct2 ht2) =>
ConvertCurryHaskell (OP_Tuple2 ct1 ct2) (ht1,ht2) where
toCurry (x1,x2) = OP_Tuple2 (toCurry x1) (toCurry x2)
fromCurry (OP_Tuple2 x1 x2) = (fromCurry x1, fromCurry x2)
fromCurry _ = error "KiCS2 error: Pair data with no ground term"
instance (ConvertCurryHaskell ct1 ht1, ConvertCurryHaskell ct2 ht2,
ConvertCurryHaskell ct3 ht3) =>
ConvertCurryHaskell (OP_Tuple3 ct1 ct2 ct3) (ht1,ht2,ht3) where
toCurry (x1,x2,x3) = OP_Tuple3 (toCurry x1) (toCurry x2) (toCurry x3)
fromCurry (OP_Tuple3 x1 x2 x3) = (fromCurry x1, fromCurry x2, fromCurry x3)
fromCurry _ = error "KiCS2 error: Tuple3 data with no ground term occurred"
instance ConvertCurryHaskell ct ht =>
ConvertCurryHaskell (C_Maybe ct) (Maybe ht) where
toCurry Nothing = C_Nothing
toCurry (Just x) = C_Just (toCurry x)
fromCurry C_Nothing = Nothing
fromCurry (C_Just x) = Just (fromCurry x)
fromCurry _ = error "KiCS2 error: Maybe data with no ground term occurred"
toCurryString :: String -> OP_List C_Char
toCurryString = toCurry
-- -----------------------------------------------------------------------------
-- Auxiliary operations for showing lists
-- -----------------------------------------------------------------------------
showsPrec4CurryList :: Show a => Int -> OP_List a -> ShowS
showsPrec4CurryList d cl =
if isStandardCurryList cl
then showsPrec d (clist2hlist cl)
else showChar '(' . showsPrecRaw d cl . showChar ')'
where
isStandardCurryList OP_List = True
isStandardCurryList (OP_Cons _ xs) = isStandardCurryList xs
isStandardCurryList _ = False
clist2hlist OP_List = []
clist2hlist (OP_Cons x xs) = x : clist2hlist xs
showsPrecRaw d (Choice_OP_List cd i x y) = showsChoice d cd i x y
showsPrecRaw d (Choices_OP_List cd i xs) = showsChoices d cd i xs
showsPrecRaw d (Guard_OP_List cd c e) = showsGuard d cd c e
showsPrecRaw d (Fail_OP_List _ _) = showChar '!'
showsPrecRaw d OP_List = showString "[]"
showsPrecRaw d (OP_Cons x xs) = showParen (d > 5)
(showsPrec 6 x . showChar ':' . showsPrecRaw 5 xs)
-- -----------------------------------------------------------------------------
-- Primitive operations: General
-- -----------------------------------------------------------------------------
external_d_C_prim_show :: Show a => a -> Cover -> ConstStore -> C_String
external_d_C_prim_show a _ _ = toCurry (show a)
external_d_C_prim_readNatLiteral :: C_String -> Cover -> ConstStore -> OP_List (OP_Tuple2 C_Int C_String)
external_d_C_prim_readNatLiteral s _ _ = toCurry (reads (fromCurry s) :: [(Integer, String)])
external_d_C_prim_readFloatLiteral :: C_String -> Cover -> ConstStore -> OP_List (OP_Tuple2 C_Float C_String)
external_d_C_prim_readFloatLiteral s _ _ = toCurry (reads (fromCurry s) :: [(Double, String)])
external_d_C_prim_readCharLiteral :: C_String -> Cover -> ConstStore -> OP_List (OP_Tuple2 C_Char C_String)
external_d_C_prim_readCharLiteral s _ _ = toCurry (reads (fromCurry s) :: [(Char, String)])
external_d_C_prim_readStringLiteral :: C_String -> Cover -> ConstStore -> OP_List (OP_Tuple2 C_String C_String)
external_d_C_prim_readStringLiteral s _ _ = toCurry (reads (fromCurry s) :: [(String, String)])
external_d_OP_eq_colon_eq :: Unifiable a => a -> a -> Cover -> ConstStore -> C_Bool
external_d_OP_eq_colon_eq = (=:=)
external_d_OP_eq_colon_lt_eq :: Curry a => a -> a -> Cover -> ConstStore -> C_Bool
external_d_OP_eq_colon_lt_eq = (=:<=)
external_d_C_failed :: NonDet a => Cover -> ConstStore -> a
external_d_C_failed cd _ = failCons cd (customFail "Call to function `failed'")
external_d_C_cond :: Curry a => C_Bool -> a -> Cover -> ConstStore -> a
external_d_C_cond succ a cd cs = ((\_ _ _ -> a) `d_OP_dollar_hash` succ) cd cs
external_d_OP_amp :: C_Bool -> C_Bool -> Cover -> ConstStore -> C_Bool
external_d_OP_amp = (&)
external_d_C_ensureNotFree :: Curry a => a -> Cover -> ConstStore -> a
external_d_C_ensureNotFree x cd cs = case try x of
Choice d i a b -> choiceCons d i (external_d_C_ensureNotFree a cd cs)
(external_d_C_ensureNotFree b cd cs)
Narrowed d i xs -> choicesCons d i
(map (\x -> external_d_C_ensureNotFree x cd cs) xs)
Free d i xs -> narrows cs d i
(\x -> external_d_C_ensureNotFree x cd cs) xs
Guard d c e -> guardCons d c
(external_d_C_ensureNotFree e cd $! (addCs c cs))
_ -> x
external_d_OP_dollar_bang :: (NonDet a, NonDet b)
=> (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b
external_d_OP_dollar_bang = d_dollar_bang
external_nd_OP_dollar_bang :: (NonDet a, NonDet b)
=> (Func a b) -> a -> IDSupply -> Cover -> ConstStore -> b
external_nd_OP_dollar_bang = nd_dollar_bang
external_d_OP_dollar_bang_bang :: (NormalForm a, NonDet b)
=> (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b
external_d_OP_dollar_bang_bang = ($!!)
external_nd_OP_dollar_bang_bang :: (NormalForm a, NonDet b)
=> Func a b -> a -> IDSupply -> Cover -> ConstStore -> b
external_nd_OP_dollar_bang_bang f x s cd cs
= ((\y cd1 cs1-> nd_apply f y s cd1 cs1) $!! x) cd cs
external_d_OP_dollar_hash_hash :: (NormalForm a, NonDet b)
=> (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b
external_d_OP_dollar_hash_hash = ($##)
external_nd_OP_dollar_hash_hash :: (NormalForm a, NonDet b)
=> Func a b -> a -> IDSupply -> Cover -> ConstStore -> b
external_nd_OP_dollar_hash_hash f x s cd cs
= ((\y cd1 cs1 -> nd_apply f y s cd1 cs1) $## x) cd cs
external_d_C_apply :: (a -> Cover -> ConstStore -> b) -> a
-> Cover -> ConstStore -> b
external_d_C_apply = d_apply
external_nd_C_apply :: NonDet b => Func a b -> a
-> IDSupply -> Cover -> ConstStore -> b
external_nd_C_apply = nd_apply
-- -----------------------------------------------------------------------------
-- Primitive operations: Characters
-- -----------------------------------------------------------------------------
external_d_C_prim_ord :: C_Char -> Cover -> ConstStore -> C_Int
external_d_C_prim_ord (C_Char c) _ _ = C_Int (primChar2primint c)
external_d_C_prim_ord (CurryChar c) _ _ = C_CurryInt c
external_d_C_prim_chr :: C_Int -> Cover -> ConstStore -> C_Char
external_d_C_prim_chr (C_Int i) _ _ = C_Char (primint2primChar i)
external_d_C_prim_chr (C_CurryInt i) _ _ = CurryChar i
-- -----------------------------------------------------------------------------
-- Primitive operations: Arithmetics
-- -----------------------------------------------------------------------------
external_d_OP_plus_dollar :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int
external_d_OP_plus_dollar (C_Int x) (C_Int y) _ _ = C_Int (x + y)
external_d_OP_plus_dollar (C_Int x) (C_CurryInt y) cd cs
= C_CurryInt (((primint2curryint x) `d_OP_plus_hash` y) cd cs)
external_d_OP_plus_dollar (C_CurryInt x) (C_Int y) cd cs
= C_CurryInt ((x `d_OP_plus_hash` (primint2curryint y)) cd cs)
external_d_OP_plus_dollar (C_CurryInt x) (C_CurryInt y) cd cs
= C_CurryInt ((x `d_OP_plus_hash` y) cd cs)
external_d_OP_plus_dollar x y cd cs
= ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_OP_plus_dollar` b) cd2 cs2))
`d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs
external_d_OP_minus_dollar :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int
external_d_OP_minus_dollar (C_Int x) (C_Int y) _ _ = C_Int (x - y)
external_d_OP_minus_dollar (C_Int x) (C_CurryInt y) cd cs
= C_CurryInt (((primint2curryint x) `d_OP_minus_hash` y) cd cs)
external_d_OP_minus_dollar (C_CurryInt x) (C_Int y) cd cs
= C_CurryInt ((x `d_OP_minus_hash` (primint2curryint y)) cd cs)
external_d_OP_minus_dollar (C_CurryInt x) (C_CurryInt y) cd cs
= C_CurryInt ((x `d_OP_minus_hash` y) cd cs)
external_d_OP_minus_dollar x y cd cs
= ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_OP_minus_dollar` b) cd2 cs2 ))
`d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs
external_d_OP_star_dollar :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int
external_d_OP_star_dollar (C_Int x) (C_Int y) _ _ = C_Int (x * y)
external_d_OP_star_dollar (C_Int x) (C_CurryInt y) cd cs
= C_CurryInt (((primint2curryint x) `d_OP_star_hash` y) cd cs)
external_d_OP_star_dollar (C_CurryInt x) (C_Int y) cd cs
= C_CurryInt ((x `d_OP_star_hash` (primint2curryint y)) cd cs)
external_d_OP_star_dollar (C_CurryInt x) (C_CurryInt y) cd cs
= C_CurryInt ((x `d_OP_star_hash` y) cd cs)
external_d_OP_star_dollar x y cd cs
= ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_OP_star_dollar` b) cd2 cs2))
`d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs
external_d_C_quot_ :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int
external_d_C_quot_ (C_Int x) (C_Int y) cd _
| y == 0 = Fail_C_Int cd (customFail "Division by Zero")
| otherwise = C_Int (x `quot` y)
external_d_C_quot_ (C_Int x) (C_CurryInt y) cd cs
= C_CurryInt (((primint2curryint x) `d_C_quotInteger` y) cd cs)
external_d_C_quot_ (C_CurryInt x) (C_Int y) cd cs
= C_CurryInt ((x `d_C_quotInteger` (primint2curryint y)) cd cs)
external_d_C_quot_ (C_CurryInt x) (C_CurryInt y) cd cs
= C_CurryInt ((x `d_C_quotInteger` y) cd cs)
external_d_C_quot_ x y cd cs
= ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_quot_` b) cd2 cs2 ))
`d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs
external_d_C_rem_ :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int
external_d_C_rem_ (C_Int x) (C_Int y) cd _
| y == 0 = Fail_C_Int cd (customFail "Division by Zero")
| otherwise = C_Int (x `rem` y)
external_d_C_rem_ (C_Int x) (C_CurryInt y) cd cs
= C_CurryInt (((primint2curryint x) `d_C_remInteger` y) cd cs)
external_d_C_rem_ (C_CurryInt x) (C_Int y) cd cs
= C_CurryInt ((x `d_C_remInteger` (primint2curryint y)) cd cs)
external_d_C_rem_ (C_CurryInt x) (C_CurryInt y) cd cs
= C_CurryInt ((x `d_C_remInteger` y) cd cs)
external_d_C_rem_ x y cd cs
= ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_rem_` b) cd2 cs2))
`d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs
external_d_C_quotRem_ :: C_Int -> C_Int
-> Cover -> ConstStore -> OP_Tuple2 C_Int C_Int
external_d_C_quotRem_ (C_Int x) (C_Int y) cd _
| y == 0 = Fail_OP_Tuple2 cd (customFail "Division by Zero")
| otherwise = OP_Tuple2 (C_Int (x `quot` y)) (C_Int (x `rem` y))
external_d_C_quotRem_ (C_Int x) (C_CurryInt y) cd cs
= (mkIntTuple `d_dollar_bang` (((primint2curryint x) `d_C_quotRemInteger` y) cd cs)) cd cs
external_d_C_quotRem_ (C_CurryInt x) (C_Int y) cd cs
= (mkIntTuple `d_dollar_bang` ((x `d_C_quotRemInteger` (primint2curryint y)) cd cs)) cd cs
external_d_C_quotRem_ (C_CurryInt x) (C_CurryInt y) cd cs
= (mkIntTuple `d_dollar_bang` ((x `d_C_quotRemInteger` y) cd cs)) cd cs
external_d_C_quotRem_ x y cd cs
= ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_quotRem_` b) cd2 cs2))
`d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs
external_d_C_div_ :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int
external_d_C_div_ (C_Int x) (C_Int y) cd _
| y == 0 = Fail_C_Int cd (customFail "Division by Zero")
| otherwise = C_Int (x `div` y)
external_d_C_div_ (C_Int x) (C_CurryInt y) cd cs
= C_CurryInt (((primint2curryint x) `d_C_divInteger` y) cd cs)
external_d_C_div_ (C_CurryInt x) (C_Int y) cd cs
= C_CurryInt ((x `d_C_divInteger` (primint2curryint y)) cd cs)
external_d_C_div_ (C_CurryInt x) (C_CurryInt y) cd cs
= C_CurryInt ((x `d_C_divInteger` y) cd cs)
external_d_C_div_ x y cd cs
= ((\a cd1 cs1-> ((\b cd2 cs2-> ((a `external_d_C_div_` b) cd2 cs2))
`d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs
external_d_C_mod_ :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int
external_d_C_mod_ (C_Int x) (C_Int y) cd _
| y == 0 = Fail_C_Int cd (customFail "Division by Zero")
| otherwise = C_Int (x `mod` y)
external_d_C_mod_ (C_Int x) (C_CurryInt y) cd cs
= C_CurryInt (((primint2curryint x) `d_C_modInteger` y) cd cs)
external_d_C_mod_ (C_CurryInt x) (C_Int y) cd cs
= C_CurryInt ((x `d_C_modInteger` (primint2curryint y)) cd cs)
external_d_C_mod_ (C_CurryInt x) (C_CurryInt y) cd cs
= C_CurryInt ((x `d_C_modInteger` y) cd cs)
external_d_C_mod_ x y cd cs
= ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_mod_` b)) cd2 cs2)
`d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs
external_d_C_divMod_ :: C_Int -> C_Int -> Cover -> ConstStore -> OP_Tuple2 C_Int C_Int
external_d_C_divMod_ (C_Int x) (C_Int y) cd _
| y == 0 = Fail_OP_Tuple2 cd (customFail "Division by Zero")
| otherwise = OP_Tuple2 (C_Int (x `div` y)) (C_Int (x `mod` y))
external_d_C_divMod_ (C_Int x) (C_CurryInt y) cd cs
= (mkIntTuple `d_OP_dollar_hash` (((primint2curryint x) `d_C_divModInteger` y) cd cs)) cd cs
external_d_C_divMod_ (C_CurryInt x) (C_Int y) cd cs
= (mkIntTuple `d_OP_dollar_hash` ((x `d_C_divModInteger` (primint2curryint y)) cd cs)) cd cs
external_d_C_divMod_ (C_CurryInt x) (C_CurryInt y) cd cs
= (mkIntTuple `d_OP_dollar_hash` ((x `d_C_divModInteger` y) cd cs)) cd cs
external_d_C_divMod_ x y cd cs
= ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_divMod_` b) cd2 cs2 ))
`d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs
mkIntTuple :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> OP_Tuple2 C_Int C_Int
mkIntTuple (OP_Tuple2 d m) _ _ = OP_Tuple2 (C_CurryInt d) (C_CurryInt m)
external_d_C_negateFloat :: C_Float -> Cover -> ConstStore -> C_Float
external_d_C_negateFloat (C_Float x) _ _ = C_Float (negateDouble# x)
external_d_C_negateFloat x cd cs
= (external_d_C_negateFloat `d_OP_dollar_hash` x) cd cs
external_d_C_prim_Float_plus :: C_Float -> C_Float -> Cover -> ConstStore -> C_Float
external_d_C_prim_Float_plus y x _ _ =
toCurry ((fromCurry x + fromCurry y) :: Double)
external_d_C_prim_Float_minus :: C_Float -> C_Float -> Cover -> ConstStore -> C_Float
external_d_C_prim_Float_minus y x _ _ =
toCurry ((fromCurry x - fromCurry y) :: Double)
external_d_C_prim_Float_times :: C_Float -> C_Float -> Cover -> ConstStore -> C_Float
external_d_C_prim_Float_times y x _ _ =
toCurry ((fromCurry x * fromCurry y) :: Double)
external_d_C_prim_Float_div :: C_Float -> C_Float -> Cover -> ConstStore -> C_Float
external_d_C_prim_Float_div y x _ _ =
toCurry ((fromCurry x / fromCurry y) :: Double)
external_d_C_prim_i2f :: C_Int -> Cover -> ConstStore -> C_Float
external_d_C_prim_i2f x _ _ = toCurry (fromInteger (fromCurry x) :: Double)
-- -----------------------------------------------------------------------------
-- Primitive operations: IO stuff
-- -----------------------------------------------------------------------------
external_d_C_returnIO :: a -> Cover -> ConstStore -> C_IO a
external_d_C_returnIO a _ _ = fromIO (return a)
external_d_C_prim_putChar :: C_Char -> Cover -> ConstStore -> C_IO OP_Unit
external_d_C_prim_putChar c _ _ = toCurry putChar c
external_d_C_getChar :: Cover -> ConstStore -> C_IO C_Char
external_d_C_getChar _ _ = toCurry getChar
external_d_C_prim_readFile :: C_String -> Cover -> ConstStore -> C_IO C_String
external_d_C_prim_readFile s _ _ = toCurry readFile s
-- TODO: Problem: s is not evaluated to enable lazy IO and therefore could
-- be non-deterministic
external_d_C_prim_writeFile :: C_String -> C_String
-> Cover -> ConstStore -> C_IO OP_Unit
external_d_C_prim_writeFile s1 s2 _ _ = toCurry writeFile s1 s2
-- TODO: Problem: s is not evaluated to enable lazy IO and therefore could
-- be non-deterministic
external_d_C_prim_appendFile :: C_String -> C_String
-> Cover -> ConstStore -> C_IO OP_Unit
external_d_C_prim_appendFile s1 s2 _ _ = toCurry appendFile s1 s2
external_d_OP_gt_gt_eq_dollar :: (Curry t0, Curry t1)
=> C_IO t0 -> (t0 -> Cover -> ConstStore -> C_IO t1)
-> Cover -> ConstStore -> C_IO t1
external_d_OP_gt_gt_eq_dollar m f cd cs = C_IO $ do
res <- searchIO errSupply cd cs m
case res of
Left err -> return (Left (traceFail ("Prelude.>>=") [show m, show f] err))
Right x -> do
cs1 <- lookupGlobalCs
let cs2 = combineCs cs cs1
searchIO errSupply cd cs2 (f x cd cs2)
where errSupply = internalError "Prelude.(>>=): ID supply used"
-- TODO: Investigate if `cs` and `cs'` are in a subset relation
-- in either direction.
external_nd_OP_gt_gt_eq_dollar :: (Curry t0, Curry t1)
=> C_IO t0 -> Func t0 (C_IO t1)
-> IDSupply -> Cover -> ConstStore -> C_IO t1
external_nd_OP_gt_gt_eq_dollar m f _ _ cs = HO_C_IO $ \s cd cs' -> do
let cs1 = combineCs cs' cs
res <- searchIO (leftSupply s) cd cs1 m
case res of
Left err -> return (Left (traceFail ("Prelude.>>=") [show m, show f] err))
Right x -> do
cs2 <- lookupGlobalCs
let cs3 = combineCs cs1 cs2
s' = rightSupply s
searchIO (leftSupply s') cd cs3 (nd_apply f x (rightSupply s') cd cs3)
-- -----------------------------------------------------------------------------
-- Primitive operations: Exception handling
-- -----------------------------------------------------------------------------
instance ConvertCurryHaskell C_IOError CurryException where
toCurry (IOException s) = C_IOError (toCurry s)
toCurry (UserException s) = C_UserError (toCurry s)
toCurry (FailException s) = C_FailError (toCurry s)
toCurry (NondetException s) = C_NondetError (toCurry s)
fromCurry (C_IOError s) = IOException $ fromCurry s
fromCurry (C_UserError s) = UserException $ fromCurry s
fromCurry (C_FailError s) = FailException $ fromCurry s
fromCurry (C_NondetError s) = NondetException $ fromCurry s
fromCurry _ = internalError "non-deterministic IOError"
external_d_C_prim_error :: C_String -> Cover -> ConstStore -> a
external_d_C_prim_error s _ _ = C.throw $ UserException (fromCurry s)
external_d_C_prim_ioError :: C_IOError -> Cover -> ConstStore -> C_IO a
external_d_C_prim_ioError e _ _ = C.throw $ (fromCurry e :: CurryException)
external_d_C_catch :: C_IO a -> (C_IOError -> Cover -> ConstStore -> C_IO a)
-> Cover -> ConstStore -> C_IO a
external_d_C_catch act hndl cd cs =
fromIO $ C.catches (toIO errSupply1 cd cs act)
(exceptionHandlers errSupply2 cd cs (nd hndl))
where
errSupply1 = internalError "Prelude.catch: ID supply 1 used"
errSupply2 = internalError "Prelude.catch: ID supply 2 used"
external_nd_C_catch :: C_IO a -> Func C_IOError (C_IO a)
-> IDSupply -> Cover -> ConstStore -> C_IO a
external_nd_C_catch act hndl _ _ cs = HO_C_IO $ \s cd cs' -> do
let cs1 = combineCs cs' cs
res <- C.catches (toIO (leftSupply s) cd cs1 act)
(exceptionHandlers (rightSupply s) cd cs1 (nd_apply hndl))
return (Right res)
exceptionHandlers :: IDSupply -> Cover -> ConstStore -> (C_IOError -> IDSupply -> Cover -> ConstStore -> C_IO a) -> [C.Handler a]
exceptionHandlers s cd cs hndl =
[ C.Handler (\ (e :: CurryException) -> toIO (leftSupply s) cd cs (hndl (toCurry e) (rightSupply s) cd cs))
, C.Handler (\ (e :: C.IOException) -> toIO (leftSupply s) cd cs (hndl (fromIOException e) (rightSupply s) cd cs))
] where fromIOException = toCurry . IOException . show
-- -----------------------------------------------------------------------------
-- Functions on Integer and Nat added from PrimTypes
-- -----------------------------------------------------------------------------
d_C_cmpNat :: Nat -> Nat -> Cover -> ConstStore -> C_Ordering
d_C_cmpNat x1 x2 cd cs = case x1 of
IHi -> d_C__casept_33 x2 cd cs
O x5 -> d_C__casept_32 x5 x2 cd cs
I x9 -> d_C__casept_30 x9 x2 cd cs
Choice_Nat d i l r -> narrow d i (d_C_cmpNat l x2 cd cs) (d_C_cmpNat r x2 cd
cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C_cmpNat z x2 cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C_cmpNat e x2 cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude.cmpNat" [show x1, show x2]
info)
_ -> failCons cd (consFail "Prelude.cmpNat" (showCons x1))
d_C_succNat :: Nat -> Cover -> ConstStore -> Nat
d_C_succNat x1 cd cs = case x1 of
IHi -> O IHi
O x2 -> I x2
I x3 -> O (d_C_succNat x3 cd cs)
Choice_Nat d i l r -> narrow d i (d_C_succNat l cd cs) (d_C_succNat r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C_succNat z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C_succNat e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude.succ" [show x1] info)
_ -> failCons cd (consFail "Prelude.succ" (showCons x1))
d_C_predNat :: Nat -> Cover -> ConstStore -> Nat
d_C_predNat x1 cd cs = case x1 of
IHi -> d_C_failed cd cs
O x2 -> d_C__casept_28 x2 cd cs
I x5 -> O x5
Choice_Nat d i l r -> narrow d i (d_C_predNat l cd cs) (d_C_predNat r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C_predNat z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C_predNat e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude.pred" [show x1] info)
_ -> failCons cd (consFail "Prelude.pred" (showCons x1))
d_OP_plus_caret :: Nat -> Nat -> Cover -> ConstStore -> Nat
d_OP_plus_caret x1 x2 cd cs = case x1 of
IHi -> d_C_succNat x2 cd cs
O x3 -> d_C__casept_27 x3 x2 cd cs
I x6 -> d_C__casept_26 x6 x2 cd cs
Choice_Nat d i l r -> narrow d i (d_OP_plus_caret l x2 cd cs)
(d_OP_plus_caret r x2 cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_plus_caret z x2 cd cs) xs
Guard_Nat d c e -> guardCons d c (d_OP_plus_caret e x2 cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude.+^" [show x1, show x2] info)
_ -> failCons cd (consFail "Prelude.+^" (showCons x1))
d_OP_minus_caret :: Nat -> Nat -> Cover -> ConstStore -> BinInt
d_OP_minus_caret x1 x2 cd cs = case x1 of
IHi -> d_C_inc (Neg x2) cd cs
O x3 -> d_C__casept_25 x3 x1 x2 cd cs
I x6 -> d_C__casept_24 x6 x2 cd cs
Choice_Nat d i l r -> narrow d i (d_OP_minus_caret l x2 cd cs)
(d_OP_minus_caret r x2 cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_minus_caret z x2 cd cs) xs
Guard_Nat d c e -> guardCons d c (d_OP_minus_caret e x2 cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude.-^" [show x1, show x2] info)
_ -> failCons cd (consFail "Prelude.-^" (showCons x1))
d_C_mult2 :: BinInt -> Cover -> ConstStore -> BinInt
d_C_mult2 x1 cd cs = case x1 of
Pos x2 -> Pos (O x2)
Zero -> Zero
Neg x3 -> Neg (O x3)
Choice_BinInt d i l r -> narrow d i (d_C_mult2 l cd cs) (d_C_mult2 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_mult2 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C_mult2 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.mult2" [show x1] info)
_ -> failCons cd (consFail "Prelude.mult2" (showCons x1))
d_OP_star_caret :: Nat -> Nat -> Cover -> ConstStore -> Nat
d_OP_star_caret x1 x2 cd cs = case x1 of
IHi -> x2
O x3 -> O (d_OP_star_caret x3 x2 cd cs)
I x4 -> d_OP_plus_caret x2 (O (d_OP_star_caret x4 x2 cd cs)) cd cs
Choice_Nat d i l r -> narrow d i (d_OP_star_caret l x2 cd cs)
(d_OP_star_caret r x2 cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_star_caret z x2 cd cs) xs
Guard_Nat d c e -> guardCons d c (d_OP_star_caret e x2 cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude.*^" [show x1, show x2] info)
_ -> failCons cd (consFail "Prelude.*^" (showCons x1))
d_C_div2 :: Nat -> Cover -> ConstStore -> Nat
d_C_div2 x1 cd cs = case x1 of
IHi -> d_C_failed cd cs
O x2 -> x2
I x3 -> x3
Choice_Nat d i l r -> narrow d i (d_C_div2 l cd cs) (d_C_div2 r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C_div2 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C_div2 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude.div2" [show x1] info)
_ -> failCons cd (consFail "Prelude.div2" (showCons x1))
d_C_mod2 :: Nat -> Cover -> ConstStore -> BinInt
d_C_mod2 x1 cd cs = case x1 of
IHi -> Pos IHi
O x2 -> Zero
I x3 -> Pos IHi
Choice_Nat d i l r -> narrow d i (d_C_mod2 l cd cs) (d_C_mod2 r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C_mod2 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C_mod2 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude.mod2" [show x1] info)
_ -> failCons cd (consFail "Prelude.mod2" (showCons x1))
d_C_quotRemNat :: Nat -> Nat -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt
d_C_quotRemNat x1 x2 cd cs = d_C__casept_23 x2 x1 (d_C_prim_eqNat x2
IHi cd cs) cd cs
d_OP_quotRemNat_dot_shift_dot_104 :: Nat -> Nat -> Cover -> ConstStore -> Nat
d_OP_quotRemNat_dot_shift_dot_104 x1 x2 cd cs = case x1 of
IHi -> d_C_error (toCurryString
"quotRemNat.shift: IHi") cd cs
O x3 -> O x2
I x4 -> I x2
Choice_Nat d i l r -> narrow d i (d_OP_quotRemNat_dot_shift_dot_104 l x2 cd
cs) (d_OP_quotRemNat_dot_shift_dot_104 r x2 cd cs)
Choices_Nat d i xs -> narrows cs d i (\z ->
d_OP_quotRemNat_dot_shift_dot_104 z x2 cd cs) xs
Guard_Nat d c e -> guardCons d c (d_OP_quotRemNat_dot_shift_dot_104 e x2
cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude.quotRemNat.shift.104" [show x1
, show x2] info)
_ -> failCons cd (consFail "Prelude.quotRemNat.shift.104" (showCons x1))
d_C_lteqInteger :: BinInt -> BinInt -> Cover -> ConstStore
-> C_Bool
d_C_lteqInteger x1 x2 cd cs =
d_C_not (d_OP_eq_eq (d_OP_uscore_inst_hash_Prelude_dot_Eq_hash_Prelude_dot_Ordering cd cs)
cd cs (d_C_cmpInteger x1 x2 cd cs) cd cs C_GT cd cs) cd cs
d_C_cmpInteger :: BinInt -> BinInt -> Cover -> ConstStore -> C_Ordering
d_C_cmpInteger x1 x2 cd cs = case x1 of
Zero -> d_C__casept_14 x2 cd cs
Pos x5 -> d_C__casept_13 x5 x2 cd cs
Neg x8 -> d_C__casept_12 x8 x2 cd cs
Choice_BinInt d i l r -> narrow d i (d_C_cmpInteger l x2 cd cs)
(d_C_cmpInteger r x2 cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_cmpInteger z x2 cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C_cmpInteger e x2 cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.cmpInteger" [show x1, show
x2] info)
_ -> failCons cd (consFail "Prelude.cmpInteger" (showCons x1))
d_C_neg :: BinInt -> Cover -> ConstStore -> BinInt
d_C_neg x1 cd cs = case x1 of
Zero -> Zero
Pos x2 -> Neg x2
Neg x3 -> Pos x3
Choice_BinInt d i l r -> narrow d i (d_C_neg l cd cs) (d_C_neg r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_neg z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C_neg e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.neg" [show x1] info)
_ -> failCons cd (consFail "Prelude.neg" (showCons x1))
d_C_inc :: BinInt -> Cover -> ConstStore -> BinInt
d_C_inc x1 cd cs = case x1 of
Zero -> Pos IHi
Pos x2 -> Pos (d_C_succNat x2 cd cs)
Neg x3 -> d_C__casept_11 x3 cd cs
Choice_BinInt d i l r -> narrow d i (d_C_inc l cd cs) (d_C_inc r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_inc z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C_inc e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.inc" [show x1] info)
_ -> failCons cd (consFail "Prelude.inc" (showCons x1))
d_C_dec :: BinInt -> Cover -> ConstStore -> BinInt
d_C_dec x1 cd cs = case x1 of
Zero -> Neg IHi
Pos x2 -> d_C__casept_10 x2 cd cs
Neg x5 -> Neg (d_C_succNat x5 cd cs)
Choice_BinInt d i l r -> narrow d i (d_C_dec l cd cs) (d_C_dec r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_dec z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C_dec e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.dec" [show x1] info)
_ -> failCons cd (consFail "Prelude.dec" (showCons x1))
d_OP_plus_hash :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt
d_OP_plus_hash x1 x2 cd cs = case x1 of
Zero -> x2
Pos x3 -> d_C__casept_9 x3 x1 x2 cd cs
Neg x6 -> d_C__casept_8 x6 x1 x2 cd cs
Choice_BinInt d i l r -> narrow d i (d_OP_plus_hash l x2 cd cs)
(d_OP_plus_hash r x2 cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_OP_plus_hash z x2 cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_OP_plus_hash e x2 cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.+#" [show x1, show x2]
info)
_ -> failCons cd (consFail "Prelude.+#" (showCons x1))
d_OP_minus_hash :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt
d_OP_minus_hash x1 x2 cd cs = case x2 of
Zero -> x1
Pos x3 -> d_OP_plus_hash x1 (Neg x3) cd cs
Neg x4 -> d_OP_plus_hash x1 (Pos x4) cd cs
Choice_BinInt d i l r -> narrow d i (d_OP_minus_hash x1 l cd cs)
(d_OP_minus_hash x1 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_OP_minus_hash x1 z cd cs)
xs
Guard_BinInt d c e -> guardCons d c (d_OP_minus_hash x1 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.-#" [show x1, show x2]
info)
_ -> failCons cd (consFail "Prelude.-#" (showCons x2))
d_OP_star_hash :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt
d_OP_star_hash x1 x2 cd cs = case x1 of
Zero -> Zero
Pos x3 -> d_C__casept_7 x3 x2 cd cs
Neg x6 -> d_C__casept_6 x6 x2 cd cs
Choice_BinInt d i l r -> narrow d i (d_OP_star_hash l x2 cd cs)
(d_OP_star_hash r x2 cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_OP_star_hash z x2 cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_OP_star_hash e x2 cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.*#" [show x1, show x2]
info)
_ -> failCons cd (consFail "Prelude.*#" (showCons x1))
d_C_quotRemInteger :: BinInt -> BinInt -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C_quotRemInteger x1 x2 cd cs = case x2 of
Zero -> d_C_failed cd cs
Pos x3 -> d_C__casept_5 x3 x1 cd cs
Neg x9 -> d_C__casept_4 x9 x1 cd cs
Choice_BinInt d i l r -> narrow d i (d_C_quotRemInteger x1 l cd cs)
(d_C_quotRemInteger x1 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_quotRemInteger x1 z cd
cs) xs
Guard_BinInt d c e -> guardCons d c (d_C_quotRemInteger x1 e cd $! addCs c
cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.quotRemInteger" [show x1
, show x2] info)
_ -> failCons cd (consFail "Prelude.quotRemInteger" (showCons x2))
d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x2
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d l cd cs)
(d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.quotRemInteger._#selFP2#d" [show x1] info)
_ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP2#d" (showCons x1))
d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x3
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m l cd cs)
(d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.quotRemInteger._#selFP3#m" [show x1] info)
_ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP3#m" (showCons x1))
d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x2
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d l cd cs)
(d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.quotRemInteger._#selFP5#d" [show x1] info)
_ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP5#d" (showCons x1))
d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x3
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m l cd cs)
(d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.quotRemInteger._#selFP6#m" [show x1] info)
_ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP6#m" (showCons x1))
d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x2
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d l cd cs)
(d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.quotRemInteger._#selFP8#d" [show x1] info)
_ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP8#d" (showCons x1))
d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x3
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m l cd cs)
(d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.quotRemInteger._#selFP9#m" [show x1] info)
_ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP9#m" (showCons x1))
d_C_divModInteger :: BinInt -> BinInt -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C_divModInteger x1 x2 cd cs = case x2 of
Zero -> d_C_failed cd cs
Pos x3 -> d_C__casept_3 x3 x1 cd cs
Neg x12 -> d_C__casept_1 x12 x1 cd cs
Choice_BinInt d i l r -> narrow d i (d_C_divModInteger x1 l cd cs)
(d_C_divModInteger x1 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_divModInteger x1 z cd cs)
xs
Guard_BinInt d c e -> guardCons d c (d_C_divModInteger x1 e cd $! addCs c
cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude.divModInteger" [show x1
, show x2] info)
_ -> failCons cd (consFail "Prelude.divModInteger" (showCons x2))
d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x2
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d l cd cs)
(d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.divModInteger._#selFP11#d" [show x1] info)
_ -> failCons cd (consFail "Prelude.divModInteger._#selFP11#d" (showCons x1))
d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x3
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m l cd cs)
(d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.divModInteger._#selFP12#m" [show x1] info)
_ -> failCons cd (consFail "Prelude.divModInteger._#selFP12#m" (showCons x1))
d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x2
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d l cd cs)
(d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.divModInteger._#selFP14#d" [show x1] info)
_ -> failCons cd (consFail "Prelude.divModInteger._#selFP14#d" (showCons x1))
d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x3
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m l cd cs)
(d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.divModInteger._#selFP15#m" [show x1] info)
_ -> failCons cd (consFail "Prelude.divModInteger._#selFP15#m" (showCons x1))
d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x2
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d l cd cs)
(d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.divModInteger._#selFP17#d" [show x1] info)
_ -> failCons cd (consFail "Prelude.divModInteger._#selFP17#d" (showCons x1))
d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m :: OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> BinInt
d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m x1 cd cs = case x1 of
OP_Tuple2 x2 x3 -> x3
Choice_OP_Tuple2 d i l r -> narrow d i
(d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m l cd cs)
(d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z ->
d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c
(d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail
"Prelude.divModInteger._#selFP18#m" [show x1] info)
_ -> failCons cd (consFail "Prelude.divModInteger._#selFP18#m" (showCons x1))
d_C_divInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt
d_C_divInteger x1 x2 cd cs = d_C_fst (d_C_divModInteger x1 x2 cd
cs) cd cs
d_C_modInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt
d_C_modInteger x1 x2 cd cs = d_C_snd (d_C_divModInteger x1 x2 cd
cs) cd cs
d_C_quotInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt
d_C_quotInteger x1 x2 cd cs = d_C_fst (d_C_quotRemInteger x1 x2 cd
cs) cd cs
d_C_remInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt
d_C_remInteger x1 x2 cd cs = d_C_snd (d_C_quotRemInteger x1 x2 cd
cs) cd cs
d_C__casept_1 :: Nat -> BinInt -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_1 x12 x1 cd cs = case x1 of
Zero -> OP_Tuple2 Zero Zero
Pos x13 -> let x14 = d_C_quotRemNat x13 x12 cd cs
x15 = d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d x14
cd cs
x16 = d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m x14
cd cs
x17 = OP_Tuple2 (d_C_neg (d_C_inc x15 cd cs) cd
cs) (d_OP_minus_hash x16 (Pos x12) cd cs)
in d_C__casept_0 x17 x15 x16 cd cs
Neg x20 -> let x21 = d_C_quotRemNat x20 x12 cd cs
x22 = d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d x21
cd cs
x23 = d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m x21
cd cs
in OP_Tuple2 x22 (d_C_neg x23 cd cs)
Choice_BinInt d i l r -> narrow d i (d_C__casept_1 x12 l cd cs) (d_C__casept_1
x12 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_1 x12 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_1 x12 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_1" [show x12, show
x1] info)
_ -> failCons cd (consFail "Prelude._casept_1" (showCons x1))
d_C__casept_0 :: OP_Tuple2 BinInt BinInt -> BinInt -> BinInt
-> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt
d_C__casept_0 x17 x15 x16 cd cs = case x16 of
Zero -> OP_Tuple2 (d_C_neg x15 cd cs) x16
Neg x18 -> x17
Pos x19 -> x17
Choice_BinInt d i l r -> narrow d i (d_C__casept_0 x17 x15 l cd cs)
(d_C__casept_0 x17 x15 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_0 x17 x15 z cd cs)
xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_0 x17 x15 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_0" [show x17, show
x15, show x16] info)
_ -> failCons cd (consFail "Prelude._casept_0" (showCons x16))
d_C__casept_3 :: Nat -> BinInt -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_3 x3 x1 cd cs = case x1 of
Zero -> OP_Tuple2 Zero Zero
Pos x4 -> d_C_quotRemNat x4 x3 cd cs
Neg x5 -> let x6 = d_C_quotRemNat x5 x3 cd cs
x7 = d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d x6 cd
cs
x8 = d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m x6 cd
cs
x9 = OP_Tuple2 (d_C_neg (d_C_inc x7 cd cs) cd
cs) (d_OP_minus_hash (Pos x3) x8 cd cs)
in d_C__casept_2 x9 x7 x8 cd cs
Choice_BinInt d i l r -> narrow d i (d_C__casept_3 x3 l cd cs) (d_C__casept_3 x3
r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_3 x3 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_3 x3 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_3" [show x3, show x1]
info)
_ -> failCons cd (consFail "Prelude._casept_3" (showCons x1))
d_C__casept_2 :: OP_Tuple2 BinInt BinInt -> BinInt -> BinInt
-> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt
d_C__casept_2 x9 x7 x8 cd cs = case x8 of
Zero -> OP_Tuple2 (d_C_neg x7 cd cs) x8
Neg x10 -> x9
Pos x11 -> x9
Choice_BinInt d i l r -> narrow d i (d_C__casept_2 x9 x7 l cd cs) (d_C__casept_2
x9 x7 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_2 x9 x7 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_2 x9 x7 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_2" [show x9, show x7
, show x8] info)
_ -> failCons cd (consFail "Prelude._casept_2" (showCons x8))
d_C__casept_4 :: Nat -> BinInt -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_4 x9 x1 cd cs = case x1 of
Zero -> OP_Tuple2 Zero Zero
Pos x10 -> let x11 = d_C_quotRemNat x10 x9 cd cs
x12 = d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d x11
cd cs
x13 = d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m x11
cd cs
in OP_Tuple2 (d_C_neg x12 cd cs) x13
Neg x14 -> let x15 = d_C_quotRemNat x14 x9 cd cs
x16 = d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d x15
cd cs
x17 = d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m x15
cd cs
in OP_Tuple2 x16 (d_C_neg x17 cd cs)
Choice_BinInt d i l r -> narrow d i (d_C__casept_4 x9 l cd cs) (d_C__casept_4 x9
r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_4 x9 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_4 x9 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_4" [show x9, show x1]
info)
_ -> failCons cd (consFail "Prelude._casept_4" (showCons x1))
d_C__casept_5 :: Nat -> BinInt -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_5 x3 x1 cd cs = case x1 of
Zero -> OP_Tuple2 Zero Zero
Pos x4 -> d_C_quotRemNat x4 x3 cd cs
Neg x5 -> let x6 = d_C_quotRemNat x5 x3 cd cs
x7 = d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d x6 cd
cs
x8 = d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m x6 cd
cs
in OP_Tuple2 (d_C_neg x7 cd cs) (d_C_neg x8 cd cs)
Choice_BinInt d i l r -> narrow d i (d_C__casept_5 x3 l cd cs) (d_C__casept_5 x3
r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_5 x3 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_5 x3 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_5" [show x3, show x1]
info)
_ -> failCons cd (consFail "Prelude._casept_5" (showCons x1))
d_C__casept_6 :: Nat -> BinInt -> Cover -> ConstStore -> BinInt
d_C__casept_6 x6 x2 cd cs = case x2 of
Zero -> Zero
Pos x7 -> Neg (d_OP_star_caret x6 x7 cd cs)
Neg x8 -> Pos (d_OP_star_caret x6 x8 cd cs)
Choice_BinInt d i l r -> narrow d i (d_C__casept_6 x6 l cd cs) (d_C__casept_6 x6
r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_6 x6 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_6 x6 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_6" [show x6, show x2]
info)
_ -> failCons cd (consFail "Prelude._casept_6" (showCons x2))
d_C__casept_7 :: Nat -> BinInt -> Cover -> ConstStore -> BinInt
d_C__casept_7 x3 x2 cd cs = case x2 of
Zero -> Zero
Pos x4 -> Pos (d_OP_star_caret x3 x4 cd cs)
Neg x5 -> Neg (d_OP_star_caret x3 x5 cd cs)
Choice_BinInt d i l r -> narrow d i (d_C__casept_7 x3 l cd cs) (d_C__casept_7 x3
r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_7 x3 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_7 x3 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_7" [show x3, show x2]
info)
_ -> failCons cd (consFail "Prelude._casept_7" (showCons x2))
d_C__casept_8 :: Nat -> BinInt -> BinInt -> Cover -> ConstStore -> BinInt
d_C__casept_8 x6 x1 x2 cd cs = case x2 of
Zero -> x1
Pos x7 -> d_OP_minus_caret x7 x6 cd cs
Neg x8 -> Neg (d_OP_plus_caret x6 x8 cd cs)
Choice_BinInt d i l r -> narrow d i (d_C__casept_8 x6 x1 l cd cs) (d_C__casept_8
x6 x1 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_8 x6 x1 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_8 x6 x1 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_8" [show x6, show x1
, show x2] info)
_ -> failCons cd (consFail "Prelude._casept_8" (showCons x2))
d_C__casept_9 :: Nat -> BinInt -> BinInt -> Cover -> ConstStore -> BinInt
d_C__casept_9 x3 x1 x2 cd cs = case x2 of
Zero -> x1
Pos x4 -> Pos (d_OP_plus_caret x3 x4 cd cs)
Neg x5 -> d_OP_minus_caret x3 x5 cd cs
Choice_BinInt d i l r -> narrow d i (d_C__casept_9 x3 x1 l cd cs) (d_C__casept_9
x3 x1 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_9 x3 x1 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_9 x3 x1 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_9" [show x3, show x1
, show x2] info)
_ -> failCons cd (consFail "Prelude._casept_9" (showCons x2))
d_C__casept_10 :: Nat -> Cover -> ConstStore -> BinInt
d_C__casept_10 x2 cd cs = case x2 of
IHi -> Zero
O x3 -> Pos (d_C_predNat (O x3) cd cs)
I x4 -> Pos (O x4)
Choice_Nat d i l r -> narrow d i (d_C__casept_10 l cd cs) (d_C__casept_10 r cd
cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_10 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_10 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_10" [show x2] info)
_ -> failCons cd (consFail "Prelude._casept_10" (showCons x2))
d_C__casept_11 :: Nat -> Cover -> ConstStore -> BinInt
d_C__casept_11 x3 cd cs = case x3 of
IHi -> Zero
O x4 -> Neg (d_C_predNat (O x4) cd cs)
I x5 -> Neg (O x5)
Choice_Nat d i l r -> narrow d i (d_C__casept_11 l cd cs) (d_C__casept_11 r cd
cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_11 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_11 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_11" [show x3] info)
_ -> failCons cd (consFail "Prelude._casept_11" (showCons x3))
d_C__casept_12 :: Nat -> BinInt -> Cover -> ConstStore -> C_Ordering
d_C__casept_12 x8 x2 cd cs = case x2 of
Zero -> C_LT
Pos x9 -> C_LT
Neg x10 -> d_C_cmpNat x10 x8 cd cs
Choice_BinInt d i l r -> narrow d i (d_C__casept_12 x8 l cd cs) (d_C__casept_12
x8 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_12 x8 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_12 x8 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_12" [show x8, show
x2] info)
_ -> failCons cd (consFail "Prelude._casept_12" (showCons x2))
d_C__casept_13 :: Nat -> BinInt -> Cover -> ConstStore -> C_Ordering
d_C__casept_13 x5 x2 cd cs = case x2 of
Zero -> C_GT
Pos x6 -> d_C_cmpNat x5 x6 cd cs
Neg x7 -> C_GT
Choice_BinInt d i l r -> narrow d i (d_C__casept_13 x5 l cd cs) (d_C__casept_13
x5 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_13 x5 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_13 x5 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_13" [show x5, show
x2] info)
_ -> failCons cd (consFail "Prelude._casept_13" (showCons x2))
d_C__casept_14 :: BinInt -> Cover -> ConstStore -> C_Ordering
d_C__casept_14 x2 cd cs = case x2 of
Zero -> C_EQ
Pos x3 -> C_LT
Neg x4 -> C_GT
Choice_BinInt d i l r -> narrow d i (d_C__casept_14 l cd cs) (d_C__casept_14 r
cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_14 z cd cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_14 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_14" [show x2] info)
_ -> failCons cd (consFail "Prelude._casept_14" (showCons x2))
d_C__casept_23 :: Nat -> Nat -> C_Bool -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_23 x2 x1 x3 cd cs = case x3 of
C_True -> OP_Tuple2 (Pos x1) Zero
C_False -> d_C__casept_22 x1 x2 (d_C_prim_eqNat x1 IHi
cd cs) cd cs
Choice_C_Bool d i l r -> narrow d i (d_C__casept_23 x2 x1 l cd cs)
(d_C__casept_23 x2 x1 r cd cs)
Choices_C_Bool d i xs -> narrows cs d i (\z -> d_C__casept_23 x2
x1 z cd cs) xs
Guard_C_Bool d c e -> guardCons d c (d_C__casept_23 x2 x1 e cd $!
addCs c cs)
Fail_C_Bool d info -> failCons d (traceFail "Prelude._casept_23" [show
x2, show x1, show x3] info)
_ -> failCons cd (consFail "Prelude._casept_23" (showCons x3))
d_C__casept_22 :: Nat -> Nat -> C_Bool -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_22 x1 x2 x3 cd cs = case x3 of
C_True -> OP_Tuple2 Zero (Pos IHi)
C_False -> d_C__casept_21 x2 x1 (d_C_otherwise cd
cs) cd cs
Choice_C_Bool d i l r -> narrow d i (d_C__casept_22 x1 x2 l cd cs)
(d_C__casept_22 x1 x2 r cd cs)
Choices_C_Bool d i xs -> narrows cs d i (\z -> d_C__casept_22 x1
x2 z cd cs) xs
Guard_C_Bool d c e -> guardCons d c (d_C__casept_22 x1 x2 e cd $!
addCs c cs)
Fail_C_Bool d info -> failCons d (traceFail "Prelude._casept_22" [show
x1, show x2, show x3] info)
_ -> failCons cd (consFail "Prelude._casept_22" (showCons x3))
d_C__casept_21 :: Nat -> Nat -> C_Bool -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_21 x2 x1 x3 cd cs = case x3 of
C_True -> d_C__casept_20 x2 x1 (d_C_cmpNat x1 x2 cd cs) cd cs
C_False -> d_C_failed cd cs
Choice_C_Bool d i l r -> narrow d i (d_C__casept_21 x2 x1 l cd cs)
(d_C__casept_21 x2 x1 r cd cs)
Choices_C_Bool d i xs -> narrows cs d i (\z -> d_C__casept_21 x2
x1 z cd cs) xs
Guard_C_Bool d c e -> guardCons d c (d_C__casept_21 x2 x1 e cd $!
addCs c cs)
Fail_C_Bool d info -> failCons d (traceFail "Prelude._casept_21" [show
x2, show x1, show x3] info)
_ -> failCons cd (consFail "Prelude._casept_21" (showCons x3))
d_C__casept_20 :: Nat -> Nat -> C_Ordering -> Cover
-> ConstStore -> OP_Tuple2 BinInt BinInt
d_C__casept_20 x2 x1 x3 cd cs = case x3 of
C_EQ -> OP_Tuple2 (Pos IHi) Zero
C_LT -> OP_Tuple2 Zero (Pos x1)
C_GT -> d_C__casept_19 x2 x1 (d_C_quotRemNat (d_C_div2 x1 cd cs)
x2 cd cs) cd cs
Choice_C_Ordering d i l r -> narrow d i (d_C__casept_20 x2 x1 l cd
cs) (d_C__casept_20 x2 x1 r cd cs)
Choices_C_Ordering d i xs -> narrows cs d i (\z -> d_C__casept_20
x2 x1 z cd cs) xs
Guard_C_Ordering d c e -> guardCons d c (d_C__casept_20 x2 x1 e
cd $! addCs c cs)
Fail_C_Ordering d info -> failCons d (traceFail "Prelude._casept_20"
[show x2, show x1, show x3] info)
_ -> failCons cd (consFail "Prelude._casept_20" (showCons x3))
d_C__casept_19 :: Nat -> Nat -> OP_Tuple2 BinInt BinInt
-> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt
d_C__casept_19 x2 x1 x5 cd cs = case x5 of
OP_Tuple2 x3 x4 -> d_C__casept_18 x4 x2 x1 x3 cd cs
Choice_OP_Tuple2 d i l r -> narrow d i (d_C__casept_19 x2 x1 l cd
cs) (d_C__casept_19 x2 x1 r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_C__casept_19
x2 x1 z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c (d_C__casept_19 x2 x1 e
cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude._casept_19"
[show x2, show x1, show x5] info)
_ -> failCons cd (consFail "Prelude._casept_19" (showCons x5))
d_C__casept_18 :: BinInt -> Nat -> Nat -> BinInt -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_18 x4 x2 x1 x3 cd cs = case x3 of
Neg x5 -> d_C_error (toCurryString
"quotRemNat: negative quotient") cd cs
Zero -> OP_Tuple2 (Pos IHi) (d_OP_minus_caret x1 x2 cd cs)
Pos x6 -> d_C__casept_17 x2 x1 x6 x4 cd cs
Choice_BinInt d i l r -> narrow d i (d_C__casept_18 x4 x2 x1 l cd cs)
(d_C__casept_18 x4 x2 x1 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_18 x4 x2 x1 z cd
cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_18 x4 x2 x1 e cd $! addCs c
cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_18" [show x4, show x2
, show x1, show x3] info)
_ -> failCons cd (consFail "Prelude._casept_18" (showCons x3))
d_C__casept_17 :: Nat -> Nat -> Nat -> BinInt -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_17 x2 x1 x6 x4 cd cs = case x4 of
Neg x7 -> d_C_error (toCurryString
"quotRemNat: negative remainder") cd cs
Zero -> OP_Tuple2 (Pos (O x6)) (d_C_mod2 x1 cd cs)
Pos x8 -> d_C__casept_16 x2 x8 x1 x6 (d_C_quotRemNat
(d_OP_quotRemNat_dot_shift_dot_104 x1 x8 cd cs) x2 cd cs) cd cs
Choice_BinInt d i l r -> narrow d i (d_C__casept_17 x2 x1 x6 l cd cs)
(d_C__casept_17 x2 x1 x6 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_17 x2 x1 x6 z cd
cs) xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_17 x2 x1 x6 e cd $! addCs c
cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_17" [show x2, show x1
, show x6, show x4] info)
_ -> failCons cd (consFail "Prelude._casept_17" (showCons x4))
d_C__casept_16 :: Nat -> Nat -> Nat -> Nat -> OP_Tuple2
BinInt BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt
BinInt
d_C__casept_16 x2 x8 x1 x6 x11 cd cs = case x11 of
OP_Tuple2 x9 x10 -> d_C__casept_15 x10 x6 x9 cd cs
Choice_OP_Tuple2 d i l r -> narrow d i (d_C__casept_16 x2 x8 x1 x6
l cd cs) (d_C__casept_16 x2 x8 x1 x6 r cd cs)
Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_C__casept_16
x2 x8 x1 x6 z cd cs) xs
Guard_OP_Tuple2 d c e -> guardCons d c (d_C__casept_16 x2 x8 x1 x6
e cd $! addCs c cs)
Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude._casept_16"
[show x2, show x8, show x1, show x6, show x11] info)
_ -> failCons cd (consFail "Prelude._casept_16" (showCons x11))
d_C__casept_15 :: BinInt -> Nat -> BinInt -> Cover -> ConstStore
-> OP_Tuple2 BinInt BinInt
d_C__casept_15 x10 x6 x9 cd cs = case x9 of
Neg x11 -> d_C_error (toCurryString
"quotRemNat: negative quotient") cd cs
Zero -> OP_Tuple2 (Pos (O x6)) x10
Pos x12 -> OP_Tuple2 (Pos (d_OP_plus_caret (O x6) x12 cd
cs)) x10
Choice_BinInt d i l r -> narrow d i (d_C__casept_15 x10 x6 l cd cs)
(d_C__casept_15 x10 x6 r cd cs)
Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_15 x10 x6 z cd cs)
xs
Guard_BinInt d c e -> guardCons d c (d_C__casept_15 x10 x6 e cd $! addCs c cs)
Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_15" [show x10, show
x6, show x9] info)
_ -> failCons cd (consFail "Prelude._casept_15" (showCons x9))
d_C__casept_24 :: Nat -> Nat -> Cover -> ConstStore -> BinInt
d_C__casept_24 x6 x2 cd cs = case x2 of
IHi -> Pos (O x6)
O x7 -> d_C_inc (d_C_mult2 (d_OP_minus_caret x6 x7 cd cs) cd cs) cd cs
I x8 -> d_C_mult2 (d_OP_minus_caret x6 x8 cd cs) cd cs
Choice_Nat d i l r -> narrow d i (d_C__casept_24 x6 l cd cs) (d_C__casept_24 x6
r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_24 x6 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_24 x6 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_24" [show x6, show x2]
info)
_ -> failCons cd (consFail "Prelude._casept_24" (showCons x2))
d_C__casept_25 :: Nat -> Nat -> Nat -> Cover -> ConstStore -> BinInt
d_C__casept_25 x3 x1 x2 cd cs = case x2 of
IHi -> Pos (d_C_predNat x1 cd cs)
O x4 -> d_C_mult2 (d_OP_minus_caret x3 x4 cd cs) cd cs
I x5 -> d_C_dec (d_C_mult2 (d_OP_minus_caret x3 x5 cd cs) cd cs) cd cs
Choice_Nat d i l r -> narrow d i (d_C__casept_25 x3 x1 l cd cs) (d_C__casept_25
x3 x1 r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_25 x3 x1 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_25 x3 x1 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_25" [show x3, show x1
, show x2] info)
_ -> failCons cd (consFail "Prelude._casept_25" (showCons x2))
d_C__casept_26 :: Nat -> Nat -> Cover -> ConstStore -> Nat
d_C__casept_26 x6 x2 cd cs = case x2 of
IHi -> O (d_C_succNat x6 cd cs)
O x7 -> I (d_OP_plus_caret x6 x7 cd cs)
I x8 -> O (d_OP_plus_caret (d_C_succNat x6 cd cs) x8 cd cs)
Choice_Nat d i l r -> narrow d i (d_C__casept_26 x6 l cd cs) (d_C__casept_26 x6
r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_26 x6 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_26 x6 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_26" [show x6, show x2]
info)
_ -> failCons cd (consFail "Prelude._casept_26" (showCons x2))
d_C__casept_27 :: Nat -> Nat -> Cover -> ConstStore -> Nat
d_C__casept_27 x3 x2 cd cs = case x2 of
IHi -> I x3
O x4 -> O (d_OP_plus_caret x3 x4 cd cs)
I x5 -> I (d_OP_plus_caret x3 x5 cd cs)
Choice_Nat d i l r -> narrow d i (d_C__casept_27 x3 l cd cs) (d_C__casept_27 x3
r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_27 x3 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_27 x3 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_27" [show x3, show x2]
info)
_ -> failCons cd (consFail "Prelude._casept_27" (showCons x2))
d_C__casept_28 :: Nat -> Cover -> ConstStore -> Nat
d_C__casept_28 x2 cd cs = case x2 of
IHi -> IHi
O x3 -> I (d_C_predNat x2 cd cs)
I x4 -> I (O x4)
Choice_Nat d i l r -> narrow d i (d_C__casept_28 l cd cs) (d_C__casept_28 r cd
cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_28 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_28 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_28" [show x2] info)
_ -> failCons cd (consFail "Prelude._casept_28" (showCons x2))
d_C__casept_30 :: Nat -> Nat -> Cover -> ConstStore -> C_Ordering
d_C__casept_30 x9 x2 cd cs = case x2 of
IHi -> C_GT
O x10 -> let x11 = d_C_cmpNat x9 x10 cd cs in d_C__casept_29 x11 cd cs
I x12 -> d_C_cmpNat x9 x12 cd cs
Choice_Nat d i l r -> narrow d i (d_C__casept_30 x9 l cd cs) (d_C__casept_30 x9
r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_30 x9 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_30 x9 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_30" [show x9, show x2]
info)
_ -> failCons cd (consFail "Prelude._casept_30" (showCons x2))
d_C__casept_29 :: C_Ordering -> Cover -> ConstStore -> C_Ordering
d_C__casept_29 x11 cd cs = case x11 of
C_EQ -> C_GT
C_LT -> x11
C_GT -> x11
Choice_C_Ordering d i l r -> narrow d i (d_C__casept_29 l cd cs)
(d_C__casept_29 r cd cs)
Choices_C_Ordering d i xs -> narrows cs d i (\z -> d_C__casept_29
z cd cs) xs
Guard_C_Ordering d c e -> guardCons d c (d_C__casept_29 e cd $!
addCs c cs)
Fail_C_Ordering d info -> failCons d (traceFail "Prelude._casept_29"
[show x11] info)
_ -> failCons cd (consFail "Prelude._casept_29" (showCons x11))
d_C__casept_32 :: Nat -> Nat -> Cover -> ConstStore -> C_Ordering
d_C__casept_32 x5 x2 cd cs = case x2 of
IHi -> C_GT
O x6 -> d_C_cmpNat x5 x6 cd cs
I x7 -> let x8 = d_C_cmpNat x5 x7 cd cs in d_C__casept_31 x8 cd cs
Choice_Nat d i l r -> narrow d i (d_C__casept_32 x5 l cd cs) (d_C__casept_32 x5
r cd cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_32 x5 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_32 x5 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_32" [show x5, show x2]
info)
_ -> failCons cd (consFail "Prelude._casept_32" (showCons x2))
d_C__casept_31 :: C_Ordering -> Cover -> ConstStore -> C_Ordering
d_C__casept_31 x8 cd cs = case x8 of
C_EQ -> C_LT
C_LT -> x8
C_GT -> x8
Choice_C_Ordering d i l r -> narrow d i (d_C__casept_31 l cd cs)
(d_C__casept_31 r cd cs)
Choices_C_Ordering d i xs -> narrows cs d i (\z -> d_C__casept_31
z cd cs) xs
Guard_C_Ordering d c e -> guardCons d c (d_C__casept_31 e cd $!
addCs c cs)
Fail_C_Ordering d info -> failCons d (traceFail "Prelude._casept_31"
[show x8] info)
_ -> failCons cd (consFail "Prelude._casept_31" (showCons x8))
d_C__casept_33 :: Nat -> Cover -> ConstStore -> C_Ordering
d_C__casept_33 x2 cd cs = case x2 of
IHi -> C_EQ
O x3 -> C_LT
I x4 -> C_LT
Choice_Nat d i l r -> narrow d i (d_C__casept_33 l cd cs) (d_C__casept_33 r cd
cs)
Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_33 z cd cs) xs
Guard_Nat d c e -> guardCons d c (d_C__casept_33 e cd $! addCs c cs)
Fail_Nat d info -> failCons d (traceFail "Prelude._casept_33" [show x2] info)
_ -> failCons cd (consFail "Prelude._casept_33" (showCons x2))
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Prelude.pakcs 0000664 0000000 0000000 00000015136 13231616147 0024114 0 ustar 00root root 0000000 0000000
show
--- but can read the string back with readUnqualifiedTerm
--- (provided that the constructor names are unique without the module
--- qualifier).
showTerm :: _ -> String
showTerm x = prim_showTerm $## x
prim_showTerm :: _ -> String
prim_showTerm external
--- Transforms a ground(!) term into a string representation
--- in standard prefix notation.
--- Thus, showTerm suspends until its argument is ground.
--- Note that this function differs from the prelude function show
--- since it prefixes constructors with their module name
--- in order to read them back with readQTerm.
showQTerm :: _ -> String
showQTerm x = prim_showQTerm $## x
prim_showQTerm :: _ -> String
prim_showQTerm external
--- Transform a string containing a term in standard prefix notation
--- without module qualifiers into the corresponding data term.
--- The first argument is a non-empty list of module qualifiers that are tried to
--- prefix the constructor in the string in order to get the qualified constructors
--- (that must be defined in the current program!).
--- In case of a successful parse, the result is a one element list
--- containing a pair of the data term and the remaining unparsed string.
readsUnqualifiedTerm :: [String] -> String -> [(_,String)]
readsUnqualifiedTerm [] _ =
error "ReadShowTerm.readsUnqualifiedTerm: list of module prefixes is empty"
readsUnqualifiedTerm (prefix:prefixes) s =
readsUnqualifiedTermWithPrefixes (prefix:prefixes) s
readsUnqualifiedTermWithPrefixes :: [String] -> String -> [(_,String)]
readsUnqualifiedTermWithPrefixes prefixes s =
(prim_readsUnqualifiedTerm $## prefixes) $## s
prim_readsUnqualifiedTerm :: [String] -> String -> [(_,String)]
prim_readsUnqualifiedTerm external
--- Transforms a string containing a term in standard prefix notation
--- without module qualifiers into the corresponding data term.
--- The first argument is a non-empty list of module qualifiers that are tried to
--- prefix the constructor in the string in order to get the qualified constructors
--- (that must be defined in the current program!).
---
--- Example: readUnqualifiedTerm ["Prelude"] "Just 3"
--- evaluates to (Just 3)
readUnqualifiedTerm :: [String] -> String -> _
readUnqualifiedTerm prefixes s = case result of
[(term,tail)]
-> if all isSpace tail then term
else error ("ReadShowTerm.readUnqualifiedTerm: no parse, unmatched string after term: "++tail)
[] -> error "ReadShowTerm.readUnqualifiedTerm: no parse"
_ -> error "ReadShowTerm.readUnqualifiedTerm: ambiguous parse"
where result = readsUnqualifiedTerm prefixes s
--- For backward compatibility. Should not be used since their use can be problematic
--- in case of constructors with identical names in different modules.
readsTerm :: String -> [(_,String)]
readsTerm s = prim_readsUnqualifiedTerm [] $## s
--- For backward compatibility. Should not be used since their use can be problematic
--- in case of constructors with identical names in different modules.
readTerm :: String -> _
readTerm s = case result of
[(term,tail)]
-> if all isSpace tail then term
else error ("ReadShowTerm.readTerm: no parse, unmatched string after term: "++tail)
[] -> error "ReadShowTerm.readTerm: no parse"
_ -> error "ReadShowTerm.readTerm: ambiguous parse"
where result = prim_readsUnqualifiedTerm [] $## s
--- Transforms a string containing a term in standard prefix notation
--- with qualified constructor names into the corresponding data term.
--- In case of a successful parse, the result is a one element list
--- containing a pair of the data term and the remaining unparsed string.
readsQTerm :: String -> [(_,String)]
readsQTerm s = prim_readsQTerm $## s
prim_readsQTerm :: String -> [(_,String)]
prim_readsQTerm external
--- Transforms a string containing a term in standard prefix notation
--- with qualified constructor names into the corresponding data term.
readQTerm :: String -> _
readQTerm s = case result of
[(term,tail)] -> if all isSpace tail then term
else error "ReadShowTerm.readQTerm: no parse"
[] -> error "ReadShowTerm.readQTerm: no parse"
_ -> error "ReadShowTerm.readQTerm: ambiguous parse"
where result = readsQTerm s
--- Reads a file containing a string representation of a term
--- in standard prefix notation and returns the corresponding data term.
readQTermFile :: String -> IO _
readQTermFile file = readFile file >>= return . readQTerm
--- Reads a file containing lines with string representations of terms
--- of the same type and returns the corresponding list of data terms.
readQTermListFile :: String -> IO [_]
readQTermListFile file = readFile file >>= return . map readQTerm . lines
--- Writes a ground term into a file in standard prefix notation.
--- @param filename - The name of the file to be written.
--- @param term - The term to be written to the file as a string.
writeQTermFile :: String -> _ -> IO ()
writeQTermFile filename term = writeFile filename (showQTerm term)
--- Writes a list of ground terms into a file.
--- Each term is written into a separate line which might be useful
--- to modify the file with a standard text editor.
--- @param filename - The name of the file to be written.
--- @param terms - The list of terms to be written to the file.
writeQTermListFile :: String -> [_] -> IO ()
writeQTermListFile filename terms =
writeFile filename (unlines (map showQTerm terms))
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/ReadShowTerm.kics2 0000664 0000000 0000000 00000002015 13231616147 0024762 0 ustar 00root root 0000000 0000000 external_d_C_prim_showTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String
external_d_C_prim_showTerm t _ _ = toCurry (show t)
external_d_C_prim_showQTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String
external_d_C_prim_showQTerm t _ _ = toCurry (show t)
external_d_C_prim_readsUnqualifiedTerm ::
Read a => Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String ->
Cover -> ConstStore -> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String)
external_d_C_prim_readsUnqualifiedTerm _ = external_d_C_prim_readsQTerm
external_d_C_prim_readsQTerm
:: Read a => Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String)
external_d_C_prim_readsQTerm s _ _ = toCurryPairs (reads (fromCurry s))
where
toCurryPairs [] = Curry_Prelude.OP_List
toCurryPairs ((v,s):xs) = Curry_Prelude.OP_Cons (Curry_Prelude.OP_Tuple2 v (toCurry s))
(toCurryPairs xs)
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/ReadShowTerm.pakcs 0000664 0000000 0000000 00000001266 13231616147 0025057 0 ustar 00root root 0000000 0000000
--- Serves as the base for both TableRBT and SetRBT
--- All the operations on trees are generic, i.e., one has to provide
--- two explicit order predicates ("
--- A table is a finite mapping from keys to values.
--- All the operations on tables are generic, i.e., one has to provide
--- an explicit order predicate ("lessThan" and "eq"below)
--- on elements.
---
--- @author Johannes Koj, Michael Hanus, Bernd Brassel
--- @version March 2005
--- @category algorithm
----------------------------------------------------------------------------
module RedBlackTree
( RedBlackTree, empty, isEmpty, lookup, update
, tree2list, sortBy, newTreeLike, setInsertEquivalence, delete
) where
----------------------------------------------------------------------------
-- the main interface:
--- A red-black tree consists of a tree structure and three order predicates.
--- These predicates generalize the red black tree. They define
--- 1) equality when inserting into the tree
--- eg for a set eqInsert is (==),
--- for a multiset it is (\ _ _ -> False)
--- for a lookUp-table it is ((==) . fst)
--- 2) equality for looking up values
--- eg for a set eqLookUp is (==),
--- for a multiset it is (==)
--- for a lookUp-table it is ((==) . fst)
--- 3) the (less than) relation for the binary search tree
data RedBlackTree a
= RedBlackTree
(a -> a -> Bool) -- equality for insertion
(a -> a -> Bool) -- equality for lookup
(a -> a -> Bool) -- lessThan for search
(Tree a) -- contents
--- The three relations are inserted into the structure by function empty.
--- Returns an empty tree, i.e., an empty red-black tree
--- augmented with the order predicates.
empty :: (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool)
-> RedBlackTree a
empty eqInsert eqLookUp lessThan = RedBlackTree eqInsert eqLookUp lessThan Empty
--- Test on emptyness
isEmpty :: RedBlackTree _ -> Bool
isEmpty (RedBlackTree _ _ _ Empty) = True
isEmpty (RedBlackTree _ _ _ (Tree _ _ _ _)) = False
--- Creates a new empty red black tree from with the same ordering as a give one.
newTreeLike :: RedBlackTree a -> RedBlackTree a
newTreeLike (RedBlackTree eqIns eqLk lt _) = RedBlackTree eqIns eqLk lt Empty
--- Returns an element if it is contained in a red-black tree.
--- @param p - a pattern for an element to look up in the tree
--- @param t - a red-black tree
--- @return the contained True if p matches in t
lookup :: a -> RedBlackTree a -> Maybe a
lookup p (RedBlackTree _ eqLk lt t) = lookupTree eqLk lt p t
lookupTree :: (a -> a -> Bool) -> (a -> a -> Bool) -> a -> Tree a -> Maybe a
lookupTree _ _ _ Empty = Nothing
lookupTree eq lt p (Tree _ e l r)
| eq p e = Just e
| lt p e = lookupTree eq lt p l
| otherwise = lookupTree eq lt p r
--- Updates/inserts an element into a RedBlackTree.
update :: a -> RedBlackTree a -> RedBlackTree a
update e (RedBlackTree eqIns eqLk lt t) =
RedBlackTree eqIns eqLk lt (updateTree eqIns lt e t)
updateTree :: (a -> a -> Bool) -> (a -> a -> Bool) -> a -> Tree a -> Tree a
updateTree eq lt e t = let (Tree _ e2 l r) = upd t
in Tree Black e2 l r
where
upd Empty = Tree Red e Empty Empty
upd (Tree c e2 l r) | eq e e2 = Tree c e l r
| lt e e2 = balanceL (Tree c e2 (upd l) r)
| otherwise = balanceR (Tree c e2 l (upd r))
--- Deletes entry from red black tree.
delete :: a -> RedBlackTree a -> RedBlackTree a
delete e (RedBlackTree eqIns eqLk lt t) =
RedBlackTree eqIns eqLk lt (blackenRoot (deleteTree eqLk lt e t))
where
blackenRoot Empty = Empty
blackenRoot (Tree _ x l r) = Tree Black x l r
deleteTree :: (a -> a -> Prelude.Bool)
-> (a -> a -> Prelude.Bool) -> a -> Tree a -> Tree a
deleteTree _ _ _ Empty = Empty -- no error for non existence
deleteTree eq lt e (Tree c e2 l r)
| eq e e2 = if isEmptyTree l then addColor c r else
if isEmptyTree r
then addColor c l
else let el = rightMost l
in delBalanceL (Tree c el (deleteTree eq lt el l) r)
| lt e e2 = delBalanceL (Tree c e2 (deleteTree eq lt e l) r)
| otherwise = delBalanceR (Tree c e2 l (deleteTree eq lt e r))
where
addColor DoublyBlack tree = tree -- should not occur
addColor Red tree = tree
addColor Black Empty = Empty
addColor Black (Tree Red x lx rx) = Tree Black x lx rx
addColor Black (Tree Black x lx rx) = Tree DoublyBlack x lx rx
addColor Black (Tree DoublyBlack x lx rx) = Tree DoublyBlack x lx rx
rightMost Empty = error "RedBlackTree.rightMost"
rightMost (Tree _ x _ rx) = if isEmptyTree rx then x else rightMost rx
--- Transforms a red-black tree into an ordered list of its elements.
tree2list :: RedBlackTree a -> [a]
tree2list (RedBlackTree _ _ _ t) = tree2listTree t
tree2listTree :: Tree a -> [a]
tree2listTree tree = t2l tree []
where
t2l Empty es = es
t2l (Tree _ e l r) es = t2l l (e : t2l r es)
--- Generic sort based on insertion into red-black trees.
--- The first argument is the order for the elements.
sortBy :: Eq a => (a -> a -> Bool) -> [a] -> [a]
sortBy cmp xs = tree2list (foldr update (empty (\_ _->False) (==) cmp) xs)
--- For compatibility with old version only
setInsertEquivalence :: (a -> a -> Bool) -> RedBlackTree a -> RedBlackTree a
setInsertEquivalence eqIns (RedBlackTree _ eqLk lt t) = RedBlackTree eqIns eqLk lt t
----------------------------------------------------------------------------
-- implementation of red-black trees:
rbt :: RedBlackTree a -> Tree a
rbt (RedBlackTree _ _ _ t) = t
--- The colors of a node in a red-black tree.
data Color = Red | Black | DoublyBlack
deriving Eq
--- The structure of red-black trees.
data Tree a = Tree Color a (Tree a) (Tree a)
| Empty
isEmptyTree :: Tree _ -> Bool
isEmptyTree Empty = True
isEmptyTree (Tree _ _ _ _) = False
isBlack :: Tree _ -> Bool
isBlack Empty = True
isBlack (Tree c _ _ _) = c == Black
isRed :: Tree _ -> Bool
isRed Empty = False
isRed (Tree c _ _ _) = c == Red
isDoublyBlack :: Tree _ -> Bool
isDoublyBlack Empty = True
isDoublyBlack (Tree c _ _ _) = c == DoublyBlack
left :: Tree a -> Tree a
left Empty = error "RedBlackTree.left"
left (Tree _ _ l _) = l
right :: Tree a -> Tree a
right Empty = error "RedBlackTree.right"
right (Tree _ _ _ r) = r
singleBlack :: Tree a -> Tree a
singleBlack Empty = Empty
singleBlack (Tree Red x l r) = Tree Red x l r
singleBlack (Tree Black x l r) = Tree Black x l r
singleBlack (Tree DoublyBlack x l r) = Tree Black x l r
--- for the implementation of balanceL and balanceR refer to picture 3.5, page 27,
--- Okasaki "Purely Functional Data Structures"
balanceL :: Tree a -> Tree a
balanceL tree
| isRed leftTree && isRed (left leftTree)
= let Tree _ z (Tree _ y (Tree _ x a b) c) d = tree
in Tree Red y (Tree Black x a b) (Tree Black z c d)
| isRed leftTree && isRed (right leftTree)
= let Tree _ z (Tree _ x a (Tree _ y b c)) d = tree
in Tree Red y (Tree Black x a b) (Tree Black z c d)
| otherwise = tree
where
leftTree = left tree
balanceR :: Tree a -> Tree a
balanceR tree
| isRed rightTree && isRed (right rightTree)
= let Tree _ x a (Tree _ y b (Tree _ z c d)) = tree
in Tree Red y (Tree Black x a b) (Tree Black z c d)
| isRed rightTree && isRed (left rightTree)
= let Tree _ x a (Tree _ z (Tree _ y b c) d) = tree
in Tree Red y (Tree Black x a b) (Tree Black z c d)
| otherwise = tree
where
rightTree = right tree
--- balancing after deletion
delBalanceL :: Tree a -> Tree a
delBalanceL tree = if isDoublyBlack (left tree) then reviseLeft tree else tree
reviseLeft :: Tree a -> Tree a
reviseLeft tree
| isEmptyTree r = tree
| blackr && isRed (left r)
= let Tree col x a (Tree _ z (Tree _ y b c) d) = tree
in Tree col y (Tree Black x (singleBlack a) b) (Tree Black z c d)
| blackr && isRed (right r)
= let Tree col x a (Tree _ y b (Tree _ z c d)) = tree
in Tree col y (Tree Black x (singleBlack a) b) (Tree Black z c d)
| blackr
= let Tree col x a (Tree _ y b c) = tree
in Tree (if col==Red then Black else DoublyBlack) x (singleBlack a)
(Tree Red y b c)
| otherwise
= let Tree _ x a (Tree _ y b c) = tree
in Tree Black y (reviseLeft (Tree Red x a b)) c
where
r = right tree
blackr = isBlack r
delBalanceR :: Tree a -> Tree a
delBalanceR tree = if isDoublyBlack (right tree) then reviseRight tree
else tree
reviseRight :: Tree a -> Tree a
reviseRight tree
| isEmptyTree l = tree
| blackl && isRed (left l)
= let Tree col x (Tree _ y (Tree _ z d c) b) a = tree
in Tree col y (Tree Black z d c) (Tree Black x b (singleBlack a))
| blackl && isRed (right l)
= let Tree col x (Tree _ z d (Tree _ y c b)) a = tree
in Tree col y (Tree Black z d c) (Tree Black x b (singleBlack a))
| blackl
= let Tree col x (Tree _ y c b) a = tree
in Tree (if col==Red then Black
else DoublyBlack) x (Tree Red y c b) (singleBlack a)
| otherwise
= let Tree _ x (Tree _ y c b) a = tree
in Tree Black y c (reviseRight (Tree Red x b a))
where
l = left tree
blackl = isBlack l
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/SCC.curry 0000664 0000000 0000000 00000006036 13231616147 0023166 0 ustar 00root root 0000000 0000000 --- ----------------------------------------------------------------------------
--- Computing strongly connected components
---
--- Copyright (c) 2000 - 2003, Wolfgang Lux
--- See LICENSE for the full license.
---
--- The function `scc` computes the strongly connected components of a list
--- of entities in two steps. First, the list is topologically sorted
--- "downwards" using the *defines* relation.
--- Then the resulting list is sorted "upwards" using the *uses* relation
--- and partitioned into the connected components. Both relations
--- are computed within this module using the bound and free names of each
--- declaration.
---
--- In order to avoid useless recomputations, the code in the module first
--- decorates the declarations with their bound and free names and a
--- unique number. The latter is only used to provide a trivial ordering
--- so that the declarations can be used as set elements.
---
--- @author Wolfgang Lux
--- @category algorithm
--- ----------------------------------------------------------------------------
module SCC (scc) where
import SetRBT (emptySetRBT, elemRBT, insertRBT)
data Node a b = Node Int [b] [b] a
deriving Eq
cmpNode :: Node a b -> Node a b -> Bool
cmpNode n1 n2 = key n1 < key n2
key :: Node a b -> Int
key (Node k _ _ _) = k
bvs :: Node a b -> [b]
bvs (Node _ bs _ _) = bs
fvs :: Node a b -> [b]
fvs (Node _ _ fs _) = fs
node :: Node a b -> a
node (Node _ _ _ n) = n
--- Computes the strongly connected components of a list
--- of entities. To be flexible, we distinguish the nodes and
--- the entities defined in this node.
---
--- @param defines - maps each node to the entities defined in this node
--- @param uses - maps each node to the entities used in this node
--- @param nodes - the list of nodes which should be sorted into
--- strongly connected components
--- @return the strongly connected components of the list of nodes
scc :: (Eq a, Eq b) =>
(a -> [b]) -- ^ entities defined by node
-> (a -> [b]) -- ^ entities used by node
-> [a] -- ^ list of nodes
-> [[a]] -- ^ strongly connected components
scc bvs' fvs' = map (map node) . tsort' . tsort . zipWith wrap [0 ..]
where wrap i n = Node i (bvs' n) (fvs' n) n
tsort :: (Eq a, Eq b) => [Node a b] -> [Node a b]
tsort xs = snd (dfs xs (emptySetRBT cmpNode) [])
where
dfs [] marks stack = (marks, stack)
dfs (x : xs') marks stack
| x `elemRBT` marks = dfs xs' marks stack
| otherwise = dfs xs' marks' (x : stack')
where
(marks', stack') = dfs (defs x) (x `insertRBT` marks) stack
defs x1 = filter (any (`elem` fvs x1) . bvs) xs
tsort' :: (Eq a, Eq b) => [Node a b] -> [[Node a b]]
tsort' xs = snd (dfs xs (emptySetRBT cmpNode) [])
where
dfs [] marks stack = (marks, stack)
dfs (x : xs') marks stack
| x `elemRBT` marks = dfs xs' marks stack
| otherwise = dfs xs' marks' ((x : concat stack') : stack)
where
(marks', stack') = dfs (uses x) (x `insertRBT` marks) []
uses x1 = filter (any (`elem` bvs x1) . fvs) xs
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/SearchTree.curry 0000664 0000000 0000000 00000031061 13231616147 0024577 0 ustar 00root root 0000000 0000000 ------------------------------------------------------------------------------
--- This library defines a representation of a search space as
--- a tree and various search strategies on this tree.
--- This module implements **strong encapsulation** as discussed in
--- [the JFLP'04 paper](http://www.informatik.uni-kiel.de/~mh/papers/JFLP04_findall.html).
---
--- @author Michael Hanus, Bjoern Peemoeller, Fabian Reck
--- @version February 2016
--- @category algorithm
------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module SearchTree
( SearchTree (..), someSearchTree, getSearchTree
, isDefined, showSearchTree, searchTreeSize, limitSearchTree
, Strategy
, dfsStrategy, bfsStrategy, idsStrategy, idsStrategyWith, diagStrategy
, allValuesWith
, allValuesDFS, allValuesBFS, allValuesIDS, allValuesIDSwith, allValuesDiag
, ValueSequence, vsToList
, getAllValuesWith, printAllValuesWith, printValuesWith
, someValue, someValueWith
) where
#ifdef __PAKCS__
import Findall (allValues)
#endif
import IO (hFlush,stdout)
import List (diagonal)
import ValueSequence
--- A search tree is a value, a failure, or a choice between two search trees.
data SearchTree a = Value a
| Fail Int
| Or (SearchTree a) (SearchTree a)
--- A search strategy maps a search tree into some sequence of values.
--- Using the abtract type of sequence of values (rather than list of values)
--- enables the use of search strategies for encapsulated search
--- with search trees (strong encapsulation) as well as
--- with set functions (weak encapsulation).
type Strategy a = SearchTree a -> ValueSequence a
--- Returns the search tree for some expression.
getSearchTree :: a -> IO (SearchTree a)
getSearchTree x = return (someSearchTree x)
--- Internal operation to return the search tree for some expression.
--- Note that this operation is not purely declarative since
--- the ordering in the resulting search tree depends on the
--- ordering of the program rules.
---
--- Note that in PAKCS the search tree is just a degenerated tree
--- representing all values of the argument expression
--- and it is computed at once (i.e., not lazily!).
someSearchTree :: a -> SearchTree a
#ifdef __PAKCS__
someSearchTree = list2st . allValues
where list2st [] = Fail 0
list2st [x] = Value x
list2st (x:y:ys) = Or (Value x) (list2st (y:ys))
#else
someSearchTree external
#endif
--- Returns True iff the argument is defined, i.e., has a value.
isDefined :: a -> Bool
isDefined x = hasValue (someSearchTree x)
where hasValue y = case y of Value _ -> True
Fail _ -> False
Or t1 t2 -> hasValue t1 || hasValue t2
--- Shows the search tree as an intended line structure
showSearchTree :: Show a => SearchTree a -> String
showSearchTree st = showsST [] st ""
where
-- `showsST ctxt listenOn and socketAccept to provide some service
--- on a socket, and the client side uses the operation
--- connectToSocket to request a service.
---
--- @author Michael Hanus
--- @version February 2008
--- @category general
------------------------------------------------------------------------------
module Socket(Socket, listenOn, listenOnFresh,
socketAccept, waitForSocketAccept, sClose, connectToSocket)
where
import System
import IO(Handle)
--- The abstract type of sockets.
external data Socket
---------------------------------------------------------------------
-- Server side operations:
--- Creates a server side socket bound to a given port number.
listenOn :: Int -> IO Socket
listenOn port = prim_listenOn $# port
prim_listenOn :: Int -> IO Socket
prim_listenOn external
--- Creates a server side socket bound to a free port.
--- The port number and the socket is returned.
listenOnFresh :: IO (Int,Socket)
listenOnFresh external
--- Returns a connection of a client to a socket.
--- The connection is returned as a pair consisting of a string identifying
--- the client (the format of this string is implementation-dependent)
--- and a handle to a stream communication with the client.
--- The handle is both readable and writable.
socketAccept :: Socket -> IO (String,Handle)
socketAccept s = prim_socketAccept $## s
prim_socketAccept :: Socket -> IO (String,Handle)
prim_socketAccept external
--- Waits until a connection of a client to a socket is available.
--- If no connection is available within the time limit, it returns Nothing,
--- otherwise the connection is returned as a pair consisting
--- of a string identifying the client
--- (the format of this string is implementation-dependent)
--- and a handle to a stream communication with the client.
--- @param socket - a socket
--- @param timeout - milliseconds to wait for input (< 0 : no time out)
waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle))
waitForSocketAccept s timeout = (prim_waitForSocketAccept $## s) $# timeout
prim_waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle))
prim_waitForSocketAccept external
--- Closes a server socket.
sClose :: Socket -> IO ()
sClose s = prim_sClose $## s
prim_sClose :: Socket -> IO ()
prim_sClose external
---------------------------------------------------------------------
-- Client side operations:
--- Creates a new connection to a Unix socket.
--- @param host - the host name of the connection
--- @param port - the port number of the connection
--- @return the handle of the stream (connected to the port port@host)
--- which is both readable and writable
connectToSocket :: String -> Int -> IO Handle
connectToSocket host port = (prim_connectToSocket $## host) $# port
prim_connectToSocket :: String -> Int -> IO Handle
prim_connectToSocket external
---------------------------------------------------------------------
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Socket.kics2 0000664 0000000 0000000 00000005071 13231616147 0023653 0 ustar 00root root 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses #-}
import Control.Concurrent
import Control.Monad (when)
import Network
import Network.Socket hiding (sClose)
type C_Socket = PrimData Socket
instance ConvertCurryHaskell Curry_Prelude.C_Int PortID where
toCurry (PortNumber i) = toCurry (toInteger i)
fromCurry i = PortNumber (fromInteger (fromCurry i))
external_d_C_prim_listenOn :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Socket
external_d_C_prim_listenOn i _ _ = toCurry listenOn i
external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket)
external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort
where
listenOnFreshPort :: IO (PortID,Socket)
listenOnFreshPort = do
s <- listenOn (PortNumber aNY_PORT)
p <- Network.socketPort s
return (p,s)
external_d_C_prim_socketAccept :: C_Socket
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_String Curry_IO.C_Handle)
external_d_C_prim_socketAccept socket _ _ =
toCurry (\s -> Network.accept s >>= \ (h,s,_) -> return (s,OneHandle h)) socket
external_d_C_prim_waitForSocketAccept :: C_Socket -> Curry_Prelude.C_Int
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.OP_Tuple2 (Curry_Prelude.OP_List Curry_Prelude.C_Char) Curry_IO.C_Handle))
external_d_C_prim_waitForSocketAccept s i _ _ = toCurry wait s i
wait :: Socket -> Int -> IO (Maybe (String, CurryHandle))
wait s t =
if t < 0
then Network.accept s >>= \ (h, s, _) -> return (Just (s, OneHandle h))
else do
mv <- newEmptyMVar
tacc <- forkIO (Network.accept s >>= \ (h, s, _) ->
putMVar mv (Just (s, OneHandle h)))
ttim <- forkIO (delay ((fromIntegral t :: Integer) * 1000)
>> putMVar mv Nothing)
res <- takeMVar mv
maybe (killThread tacc) (\_ -> killThread ttim) res
return res
-- Like 'threadDelay', but not bounded by an 'Int'
delay :: Integer -> IO ()
delay time = do
let maxWait = min time $ toInteger (maxBound :: Int)
threadDelay $ fromInteger maxWait
when (maxWait /= time) $ delay (time - maxWait)
external_d_C_prim_sClose :: C_Socket -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_sClose s _ _ = toCurry sClose s
external_d_C_prim_connectToSocket :: Curry_Prelude.C_String -> Curry_Prelude.C_Int
-> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_IO.C_Handle
external_d_C_prim_connectToSocket str i _ _ =
toCurry (\ s i -> connectTo s i >>= return . OneHandle) str i
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Socket.pakcs 0000664 0000000 0000000 00000001641 13231616147 0023740 0 ustar 00root root 0000000 0000000
system) and visible to subsequent calls to
--- getEnviron (but it is not visible in the environment
--- of the process that started the program execution).
setEnviron :: String -> String -> IO ()
setEnviron evar val = do
envs <- readGlobal environ
writeGlobal environ ((evar,val) : filter ((/=evar) . fst) envs)
--- Removes an environment variable that has been set by
--- setEnviron.
unsetEnviron :: String -> IO ()
unsetEnviron evar = do
envs <- readGlobal environ
writeGlobal environ (filter ((/=evar) . fst) envs)
--- Returns the hostname of the machine running this process.
getHostname :: IO String
getHostname external
--- Returns the process identifier of the current Curry process.
getPID :: IO Int
getPID external
--- Returns the name of the current program, i.e., the name of the
--- main module currently executed.
getProgName :: IO String
getProgName external
--- Executes a shell command and return with the exit code of the command.
--- An exit status of zero means successful execution.
system :: String -> IO Int
system cmd = do
envs <- readGlobal environ
prim_system $## (concatMap envToExport envs ++ escapedCmd)
where
win = isWindows
-- This is a work around for GHC ticket #5376
-- (http://hackage.haskell.org/trac/ghc/ticket/5376)
escapedCmd = if win then '\"' : cmd ++ "\""
else cmd
envToExport (var, val) =
if win
then "set " ++ var ++ "=" ++ concatMap escapeWinSpecials val ++ " && "
else var ++ "='" ++ concatMap encodeShellSpecials val
++ "' ; export " ++ var ++ " ; "
escapeWinSpecials c = if c `elem` "<>|&^" then ['^', c]
else [c]
encodeShellSpecials c = if c == '\'' then map chr [39,34,39,34,39]
else [c]
prim_system :: String -> IO Int
prim_system external
--- Terminates the execution of the current Curry program
--- and returns the exit code given by the argument.
--- An exit code of zero means successful execution.
exitWith :: Int -> IO _
exitWith exitcode = prim_exitWith $# exitcode
prim_exitWith :: Int -> IO _
prim_exitWith external
--- The evaluation of the action (sleep n) puts the Curry process
--- asleep for n seconds.
sleep :: Int -> IO ()
sleep n = prim_sleep $# n
prim_sleep :: Int -> IO ()
prim_sleep external
--- Is the underlying operating system a POSIX system (unix, MacOS)?
isPosix :: Bool
isPosix = not isWindows
--- Is the underlying operating system a Windows system?
isWindows :: Bool
isWindows external
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/System.kics2 0000664 0000000 0000000 00000006063 13231616147 0023711 0 ustar 00root root 0000000 0000000 {-# LANGUAGE CPP, ForeignFunctionInterface, MultiParamTypeClasses #-}
import Control.Exception as C (IOException, handle)
import Network.BSD (getHostName)
import System.CPUTime (getCPUTime)
import System.Environment (getArgs, getEnv, getProgName)
import System.Exit (ExitCode (..), exitWith)
import System.Process (system)
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
import System.Win32.Process
#else
import System.Posix.Process (getProcessID)
#endif
-- #endimport - do not remove this line!
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
foreign import stdcall unsafe "windows.h GetCurrentProcessId"
getProcessID :: IO ProcessId
#endif
external_d_C_getCPUTime :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int
external_d_C_getCPUTime _ _ = toCurry (getCPUTime >>= return . (`div` (10 ^ 9)))
external_d_C_getElapsedTime :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int
external_d_C_getElapsedTime _ _ = toCurry (return 0 :: IO Int)
external_d_C_getArgs :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List Curry_Prelude.C_String)
external_d_C_getArgs _ _ = toCurry getArgs
external_d_C_prim_getEnviron :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_prim_getEnviron str _ _ =
toCurry (handle handleIOException . getEnv) str
where
handleIOException :: IOException -> IO String
handleIOException _ = return ""
external_d_C_getHostname :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_getHostname _ _ = toCurry getHostName
external_d_C_getPID :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int
external_d_C_getPID _ _ = toCurry $ do
pid <- getProcessID
return (fromIntegral pid :: Int)
external_d_C_getProgName :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String
external_d_C_getProgName _ _ = toCurry getProgName
external_d_C_prim_system :: Curry_Prelude.C_String -> Cover -> ConstStore
-> Curry_Prelude.C_IO Curry_Prelude.C_Int
external_d_C_prim_system str _ _ = toCurry system str
instance ConvertCurryHaskell Curry_Prelude.C_Int ExitCode where
toCurry ExitSuccess = toCurry (0 :: Int)
toCurry (ExitFailure i) = toCurry i
fromCurry j = let i = fromCurry j :: Int
in if i == 0 then ExitSuccess else ExitFailure i
external_d_C_prim_exitWith :: Curry_Prelude.Curry a
=> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO a
external_d_C_prim_exitWith c _ _ = fromIO (exitWith (fromCurry c))
external_d_C_prim_sleep :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_sleep x _ _ =
toCurry (\i -> system ("sleep " ++ show (i :: Int)) >> return ()) x -- TODO
external_d_C_isWindows :: Cover -> ConstStore -> Curry_Prelude.C_Bool
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
external_d_C_isWindows _ _ = Curry_Prelude.C_True
#else
external_d_C_isWindows _ _ = Curry_Prelude.C_False
#endif
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/System.pakcs 0000664 0000000 0000000 00000002700 13231616147 0023771 0 ustar 00root root 0000000 0000000
cmp" below) on elements.
--- Each inner node in the red-black tree contains a key-value association.
---
--- @author Johannes Koj, Michael Hanus, Bernd Brassel
--- @version March 2005
--- @category algorithm
----------------------------------------------------------------------------
module TableRBT where
import qualified RedBlackTree as RBT
--import RedBlackTree (RedBlackTree) -- uncomment for old (buggy) Java front end
----------------------------------------------------------------------------
-- the main interface:
type TableRBT key a = RBT.RedBlackTree (key,a)
--- Returns an empty table, i.e., an empty red-black tree.
emptyTableRBT :: Eq a => (a -> a -> Bool) -> TableRBT a _
emptyTableRBT lt = RBT.empty (\ x y -> fst x==fst y)
(\ x y -> fst x==fst y)
(\ x y -> lt (fst x) (fst y))
--- tests whether a given table is empty
isEmptyTable :: TableRBT _ _ -> Bool
isEmptyTable = RBT.isEmpty
--- Looks up an entry in a table.
--- @param k - a key under which a value is stored
--- @param t - a table (represented as a red-black tree)
--- @return (Just v) if v is the value stored with key k,
--- otherwise Nothing is returned.
lookupRBT :: key -> TableRBT key a -> Maybe a
lookupRBT k = maybe Nothing (Just . snd) . RBT.lookup (k,failed)
--- Inserts or updates an element in a table.
updateRBT :: key -> a -> TableRBT key a -> TableRBT key a
updateRBT k e = RBT.update (k,e)
--- Transforms the nodes of red-black tree into a list.
tableRBT2list :: TableRBT key a -> [(key,a)]
tableRBT2list = RBT.tree2list
deleteRBT :: key -> TableRBT key a -> TableRBT key a
deleteRBT key = RBT.delete (key,failed)
-- end of TableRBT
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Test/ 0000775 0000000 0000000 00000000000 13231616147 0022402 5 ustar 00root root 0000000 0000000 curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Test/Contract.curry 0000664 0000000 0000000 00000017156 13231616147 0025257 0 ustar 00root root 0000000 0000000 ------------------------------------------------------------------------
--- This library defines some auxiliaries to check contracts
--- based on specifications or pre- and postconditions provided
--- in a Curry module.
--- The interface might probably change with the further
--- development of the contract implementation.
---
--- @author Michael Hanus
--- @version May 2016
--- @category general
------------------------------------------------------------------------
module Test.Contract
( withContract1, withContract2
, withContract1ND, withContract2ND
, withPreContract1, withPreContract2
, withPostContract0, withPostContract1, withPostContract2
, withPostContract0ND, withPostContract1ND, withPostContract2ND
) where
import SetFunctions
import Unsafe(trace)
---------------------------------------------------------------------------
-- Report the result of checking the pre/postconditions.
-- The first argument is a tag (the name of the operation).
-- The second argument is unified with () (used by enforceable constraints).
-- The third argument is a Boolean result that must not be False for
-- a satisfied condition.
-- The fourth argument is a string describing the context (arguments,result).
checkPre :: String -> Bool -> String -> Bool
checkPre fname result arg = case result of
True -> True
False -> traceLines
["Precondition of "++fname++" violated for:",arg]
(error "Execution aborted due to contract violation!")
checkPreND :: String -> Values Bool -> String -> Bool
checkPreND fname result arg = case False `valueOf` result of
True -> traceLines
["Precondition of "++fname++" violated for:",arg]
(error "Execution aborted due to contract violation!")
False -> True
checkPost :: String -> Bool -> String -> Bool
checkPost fname result arg = case result of
True -> True
False -> traceLines
["Postcondition of "++fname++" violated "++
"for:", arg]
(error "Execution aborted due to contract violation!")
checkPostND :: String -> Values Bool -> String -> Bool
checkPostND fname result arg = case False `valueOf` result of
True -> traceLines
["Postcondition of "++fname++" violated "++
"for:", arg]
(error "Execution aborted due to contract violation!")
False -> True
-- print some lines of output on stderr with flushing after each line
traceLines :: [String] -> a -> a
traceLines ls x = trace (unlines ls) x
-- show operation used to show argument or result terms to the user:
-- Currently, we use Prelude.show but this has the risk that it suspends
-- or loops.
showATerm :: Show a => a -> String
showATerm = show -- or Unsafe.showAnyTerm --
---------------------------------------------------------------------------
-- Combinators for checking of contracts having pre- and postconditions
withContract1 :: (Show a, Show b) => String
-> (a -> Bool) -> (a -> b -> Bool) -> (b -> b)
-> (a -> b) -> a -> b
withContract1 fname precond postcond postobserve fun arg
| checkPre fname (precond arg) (showATerm arg)
&> checkPost fname (postcond arg result)
(unwords [showATerm arg, "->", showATerm (postobserve result)])
= result
where result = fun arg
withContract1ND :: (Show a, Show b) => String
-> (a -> Values Bool) -> (a -> b -> Values Bool) -> (b -> b)
-> (a -> b) -> a -> b
withContract1ND fname precond postcond postobserve fun arg
| checkPreND fname (precond arg) (showATerm arg)
&> checkPostND fname (postcond arg result)
(unwords [showATerm arg, "->", showATerm (postobserve result)])
= result
where result = fun arg
withContract2 :: (Show a, Show b, Show c) => String
-> (a -> b -> Bool) -> (a -> b -> c -> Bool)
-> (c -> c) -> (a -> b -> c) -> a -> b -> c
withContract2 fname precond postcond postobserve fun arg1 arg2
| checkPre fname (precond arg1 arg2)
(unwords [showATerm arg1,showATerm arg2])
&> checkPost fname (postcond arg1 arg2 result)
(unwords [showATerm arg1, showATerm arg2, "->",
showATerm (postobserve result)])
= result
where result = fun arg1 arg2
withContract2ND :: (Show a, Show b, Show c) => String
-> (a -> b -> Values Bool) -> (a -> b -> c -> Values Bool)
-> (c -> c) -> (a -> b -> c) -> a -> b -> c
withContract2ND fname precond postcond postobserve fun arg1 arg2
| checkPreND fname (precond arg1 arg2)
(unwords [showATerm arg1,showATerm arg2])
&> checkPostND fname (postcond arg1 arg2 result)
(unwords [showATerm arg1, showATerm arg2, "->",
showATerm (postobserve result)])
= result
where result = fun arg1 arg2
---------------------------------------------------------------------------
-- Combinators for checking contracts without postconditions:
withPreContract1 :: Show a => String -> (a -> Bool) -> (a -> b) -> a -> b
withPreContract1 fname precond fun arg
| checkPre fname (precond arg) (showATerm arg)
= fun arg
withPreContract2 :: (Show a, Show b) => String -> (a -> b -> Bool)
-> (a -> b -> c) -> a -> b -> c
withPreContract2 fname precond fun arg1 arg2
| checkPre fname (precond arg1 arg2)
(unwords [showATerm arg1,showATerm arg2])
= fun arg1 arg2
---------------------------------------------------------------------------
-- Combinators for checking contracts without preconditions:
-- Add postcondition contract to 0-ary operation:
withPostContract0 :: Show a => String -> (a -> Bool) -> (a -> a) -> a -> a
withPostContract0 fname postcond postobserve val
| checkPost fname (postcond val) (unwords [showATerm (postobserve val)])
= val
-- Add postcondition contract to 0-ary operation:
withPostContract0ND :: Show a => String -> (a -> Values Bool) -> (a -> a) -> a -> a
withPostContract0ND fname postcond postobserve val
| checkPostND fname (postcond val) (unwords [showATerm (postobserve val)])
= val
withPostContract1 :: (Show a, Show b) => String -> (a -> b -> Bool) -> (b -> b)
-> (a -> b) -> a -> b
withPostContract1 fname postcond postobserve fun arg
| checkPost fname (postcond arg result)
(unwords [showATerm arg, "->", showATerm (postobserve result)])
= result
where result = fun arg
withPostContract1ND :: (Show a, Show b) => String
-> (a -> b -> Values Bool) -> (b -> b)
-> (a -> b) -> a -> b
withPostContract1ND fname postcond postobserve fun arg
| checkPostND fname (postcond arg result)
(unwords [showATerm arg, "->", showATerm (postobserve result)])
= result
where result = fun arg
withPostContract2 :: (Show a, Show b, Show c) =>
String -> (a -> b -> c -> Bool) -> (c -> c)
-> (a -> b -> c) -> a -> b -> c
withPostContract2 fname postcond postobserve fun arg1 arg2
| checkPost fname (postcond arg1 arg2 result)
(unwords [showATerm arg1, showATerm arg2, "->",
showATerm (postobserve result)])
= result
where result = fun arg1 arg2
withPostContract2ND :: (Show a, Show b, Show c) =>
String -> (a -> b -> c -> Values Bool) -> (c -> c)
-> (a -> b -> c) -> a -> b -> c
withPostContract2ND fname postcond postobserve fun arg1 arg2
| checkPostND fname (postcond arg1 arg2 result)
(unwords [showATerm arg1, showATerm arg2, "->",
showATerm (postobserve result)])
= result
where result = fun arg1 arg2
---------------------------------------------------------------------------
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Test/EasyCheck.curry 0000664 0000000 0000000 00000030500 13231616147 0025325 0 ustar 00root root 0000000 0000000 -------------------------------------------------------------------------
--- EasyCheck is a library for automated, property-based testing of
--- Curry programs. The ideas behind EasyCheck are described in
--- [this paper](http://www-ps.informatik.uni-kiel.de/~sebf/pub/flops08.html).
--- The CurryCheck tool automatically executes tests 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).
---
--- Note that this module defines the interface of EasyCheck to
--- define properties. The operations to actually execute the tests
--- are contained in the accompanying library `Test.EasyCheckExec`.
---
--- @author Sebastian Fischer (with extensions by Michael Hanus)
--- @version June 2016
--- @category general
-------------------------------------------------------------------------
module Test.EasyCheck (
-- test specification:
PropIO, returns, sameReturns, toError, toIOError,
Test, Prop, (==>), for, forAll,
test, is, isAlways, isEventually, uniquely, always, eventually,
failing, successful, deterministic, (-=-), (<~>), (~>), (<~), (<~~>),
(#), (#<), (#>), (<=>),
solutionOf,
-- test annotations
label, trivial, classify, collect, collectAs,
-- enumerating values
valuesOfSearchTree, valuesOf,
-- for EasyCheckExec
Result(..), result, args, updArgs, stamp, testsOf, ioTestOf, forAllValues
) where
import Findall (getAllValues)
import List ( (\\), delete, diagonal, nub )
import SearchTree ( SearchTree, someSearchTree )
import SearchTreeTraversal
infix 1 `is`, `isAlways`, `isEventually`
infix 1 -=-, <~>, ~>, <~, <~~>, `trivial`, #, #<, #>, <=>
infix 1 `returns`, `sameReturns`
infixr 0 ==>
-------------------------------------------------------------------------
--- Abstract type to represent properties involving IO actions.
data PropIO = PropIO (Bool -> String -> IO (Maybe String))
--- 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 act r = PropIO (testIO act (return r))
--- 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 a1 a2 = PropIO (testIO a1 a2)
--- The property `toError a` is satisfied if the evaluation of the argument
--- to normal form yields an exception.
toError :: a -> PropIO
toError x = toIOError (getAllValues x >>= \rs -> (id $!! rs) `seq` done)
--- The property `toIOError a` is satisfied if the execution of the
--- I/O action `a` causes an exception.
toIOError :: IO a -> PropIO
toIOError act = PropIO (hasIOError act)
--- Extracts the tests of an I/O property (used by the test runner).
ioTestOf :: PropIO -> (Bool -> String -> IO (Maybe String))
ioTestOf (PropIO t) = t
-- Test an IO property, i.e., compare the results of two IO actions.
testIO :: (Eq a, Show a) => IO a -> IO a -> Bool -> String -> IO (Maybe String)
testIO act1 act2 quiet msg =
catch (do r1 <- act1
r2 <- act2
if r1 == r2
then unless quiet (putStr (msg++": OK\n")) >> return Nothing
else do putStrLn $ msg++": FAILED!\nResults: " ++ show (r1,r2)
return (Just msg)
)
(\err -> do putStrLn $ msg++": EXECUTION FAILURE:\n" ++ showError err
return (Just msg)
)
-- Test whether an IO action produces an error.
hasIOError :: IO a -> Bool -> String -> IO (Maybe String)
hasIOError act quiet msg =
catch (act >> return (Just msg))
(\_ -> unless quiet (putStr (msg++": OK\n")) >> return Nothing)
-------------------------------------------------------------------------
--- 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]
--- Abstract type to represent properties to be checked.
--- Basically, it contains all tests to be executed to check the property.
data Prop = Prop [Test]
--- Extracts the tests of a property (used by the test runner).
testsOf :: Prop -> [Test]
testsOf (Prop ts) = ts
--- An empty test.
notest :: Test
notest = Test Undef [] []
--- Extracts the result of a test.
result :: Test -> Result
result (Test r _ _) = r
--- Set the result of a test.
setResult :: Result -> Test -> Test
setResult res (Test _ s a) = Test res a s
--- Extracts the arguments of a test.
args :: Test -> [String]
args (Test _ a _) = a
--- Extracts the labels of a test.
stamp :: Test -> [String]
stamp (Test _ _ s) = s
--- Updates the arguments of a test.
updArgs :: ([String] -> [String]) -> Test -> Test
updArgs upd (Test r a s) = Test r (upd a) s
--- Updates the labels of a test.
updStamp :: ([String] -> [String]) -> Test -> Test
updStamp upd (Test r a s) = Test r a (upd s)
-- Test Specification
--- Constructs a property to be tested from an arbitrary expression
--- (first argument) and a predicate that is applied to the list of
--- non-deterministic values. The given predicate determines whether
--- the constructed property is satisfied or falsified for the given
--- expression.
test :: Show a => a -> ([a] -> Bool) -> Prop
test x f = Prop [setResult res notest]
where
xs = valuesOf x
res = case valuesOf (f xs) of
[True] -> Ok
[False] -> Falsified (map show xs)
bs -> Ambigious bs (map show xs)
--- The property `x -=- y` is satisfied if `x` and `y` have deterministic
--- values that are equal.
(-=-) :: (Eq a, Show a) => a -> a -> Prop
x -=- y = (x,y) `is` uncurry (==)
--- 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
x <~> y = test x (isSameSet (valuesOf y))
--- 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
x ~> y = test x (isSubsetOf (valuesOf y))
--- 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
x <~ y = test x (`isSubsetOf` (valuesOf y))
--- 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
x <~~> y = test x (isSameMSet (valuesOf y))
isSameSet :: Eq a => [a] -> [a] -> Bool
isSameSet xs ys = xs' `subset` ys' && ys' `subset` xs'
where xs' = nub xs
ys' = nub ys
isSubsetOf :: Eq a => [a] -> [a] -> Bool
xs `isSubsetOf` ys = nub xs `subset` ys
subset :: Eq a => [a] -> [a] -> Bool
xs `subset` ys = null (xs\\ys)
-- compare to lists if they represent the same multi-set
isSameMSet :: Eq a => [a] -> [a] -> Bool
isSameMSet [] ys = ys == []
isSameMSet (x:xs) ys
| x `elem` ys = isSameMSet xs (delete x ys)
| otherwise = False
--- A conditional property is tested if the condition evaluates to `True`.
(==>) :: Bool -> Prop -> Prop
cond ==> p =
if True `elem` valuesOf cond
then p
else Prop [notest]
--- `solutionOf p` returns (non-deterministically) a solution
--- of predicate `p`. This operation is useful to test solutions
--- of predicates.
solutionOf :: (a -> Bool) -> a
solutionOf pred = pred x &> x where x free
--- The property `is x p` is satisfied if `x` has a deterministic value
--- which satisfies `p`.
is :: Show a => a -> (a -> Bool) -> Prop
is x f = test x (\xs -> case xs of [y] -> f y
_ -> False)
--- The property `isAlways x p` is satisfied if all values of `x` satisfy `p`.
isAlways :: Show a => a -> (a -> Bool) -> Prop
isAlways x = test x . all
--- The property `isEventually x p` is satisfied if some value of `x`
--- satisfies `p`.
isEventually :: Show a => a -> (a -> Bool) -> Prop
isEventually x = test x . any
--- The property `uniquely x` is satisfied if `x` has a deterministic value
--- which is true.
uniquely :: Bool -> Prop
uniquely = (`is` id)
--- The property `always x` is satisfied if all values of `x` are true.
always :: Bool -> Prop
always = (`isAlways` id)
--- The property `eventually x` is satisfied if some value of `x` is true.
eventually :: Bool -> Prop
eventually = (`isEventually` id)
--- The property `failing x` is satisfied if `x` has no value.
failing :: Show a => a -> Prop
failing x = test x null
--- The property `successful x` is satisfied if `x` has at least one value.
successful :: Show a => a -> Prop
successful x = test x (not . null)
--- The property `deterministic x` is satisfied if `x` has exactly one value.
deterministic :: Show a => a -> Prop
deterministic x = x `is` const True
--- The property `x # n` is satisfied if `x` has `n` values.
(#) :: (Eq a, Show a) => a -> Int -> Prop
x # n = test x ((n==) . length . nub)
--- The property `x #< n` is satisfied if `x` has less than `n` values.
(#<) :: (Eq a, Show a) => a -> Int -> Prop
x #< n = test x ((Traversable if it defines a function
--- that can decompose a value into a list of children of the same type
--- and recombine new children to a new value of the original type.
---
type Traversable a b = a -> ([b], [b] -> a)
--- Traversal function for constructors without children.
---
noChildren :: Traversable _ _
noChildren x = ([], const x)
--- Yields the children of a value.
---
children :: Traversable a b -> a -> [b]
children tr = fst . tr
--- Replaces the children of a value.
---
replaceChildren :: Traversable a b -> a -> [b] -> a
replaceChildren tr = snd . tr
--- Applies the given function to each child of a value.
---
mapChildren :: Traversable a b -> (b -> b) -> a -> a
mapChildren tr f x = replaceChildren tr x (map f (children tr x))
--- Computes a list of the given value, its children, those children, etc.
---
family :: Traversable a a -> a -> [a]
family tr x = familyFL tr x []
--- Computes a list of family members of the children of a value.
--- The value and its children can have different types.
---
childFamilies :: Traversable a b -> Traversable b b -> a -> [b]
childFamilies tra trb x = childFamiliesFL tra trb x []
--- Applies the given function to each member of the family of a value.
--- Proceeds bottom-up.
---
mapFamily :: Traversable a a -> (a -> a) -> a -> a
mapFamily tr f = f . mapChildFamilies tr tr f
--- Applies the given function to each member of the families of the children
--- of a value. The value and its children can have different types.
--- Proceeds bottom-up.
---
mapChildFamilies :: Traversable a b -> Traversable b b -> (b -> b) -> a -> a
mapChildFamilies tra trb = mapChildren tra . mapFamily trb
--- Applies the given function to each member of the family of a value
--- as long as possible. On each member of the family of the result the given
--- function will yield Nothing.
--- Proceeds bottom-up.
---
evalFamily :: Traversable a a -> (a -> Maybe a) -> a -> a
evalFamily tr f = mapFamily tr g
where g x = maybe x (mapFamily tr g) (f x)
--- Applies the given function to each member of the families of the children
--- of a value as long as possible.
--- Similar to 'evalFamily'.
---
evalChildFamilies :: Traversable a b -> Traversable b b
-> (b -> Maybe b) -> a -> a
evalChildFamilies tra trb = mapChildren tra . evalFamily trb
--- Implements a traversal similar to a fold with possible default cases.
---
fold :: Traversable a a -> (a -> [r] -> r) -> a -> r
fold tr f = foldChildren tr tr f f
--- Fold the children and combine the results.
---
foldChildren :: Traversable a b -> Traversable b b
-> (a -> [rb] -> ra) -> (b -> [rb] -> rb) -> a -> ra
foldChildren tra trb f g a = f a (map (fold trb g) (children tra a))
--- IO version of replaceChildren
---
replaceChildrenIO :: Traversable a b -> a -> IO [b] -> IO a
replaceChildrenIO tr = liftIO . replaceChildren tr
--- IO version of mapChildren
---
mapChildrenIO :: Traversable a b -> (b -> IO b) -> a -> IO a
mapChildrenIO tr f a = replaceChildrenIO tr a (mapIO f (children tr a))
--- IO version of mapFamily
---
mapFamilyIO :: Traversable a a -> (a -> IO a) -> a -> IO a
mapFamilyIO tr f a = mapChildFamiliesIO tr tr f a >>= f
--- IO version of mapChildFamilies
---
mapChildFamiliesIO :: Traversable a b -> Traversable b b
-> (b -> IO b) -> a -> IO a
mapChildFamiliesIO tra trb = mapChildrenIO tra . mapFamilyIO trb
--- IO version of evalFamily
---
evalFamilyIO :: Traversable a a -> (a -> IO (Maybe a)) -> a -> IO a
evalFamilyIO tr f = mapFamilyIO tr g
where g a = f a >>= maybe (return a) (mapFamilyIO tr g)
--- IO version of evalChildFamilies
---
evalChildFamiliesIO :: Traversable a b -> Traversable b b
-> (b -> IO (Maybe b)) -> a -> IO a
evalChildFamiliesIO tra trb = mapChildrenIO tra . evalFamilyIO trb
-- implementation of 'family' with functional lists for efficiency reasons
type FunList a = [a] -> [a]
concatFL :: [FunList a] -> FunList a
concatFL [] ys = ys
concatFL (x:xs) ys = x (concatFL xs ys)
familyFL :: Traversable a a -> a -> FunList a
familyFL tr x xs = x : childFamiliesFL tr tr x xs
childFamiliesFL :: Traversable a b -> Traversable b b -> a -> FunList b
childFamiliesFL tra trb x xs = concatFL (map (familyFL trb) (children tra x)) xs
liftIO :: (a -> b) -> IO a -> IO b
liftIO f ioa = ioa >>= return . f
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Unsafe.curry 0000664 0000000 0000000 00000021224 13231616147 0023773 0 ustar 00root root 0000000 0000000 ------------------------------------------------------------------------------
--- Library containing unsafe operations.
--- These operations should be carefully used (e.g., for testing or debugging).
--- These operations should not be used in application programs!
---
--- @author Michael Hanus, Bjoern Peemoeller
--- @version September 2013
--- @category general
------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module Unsafe
( unsafePerformIO, trace
#ifdef __PAKCS__
, spawnConstraint, isVar, identicalVar, isGround, compareAnyTerm
, showAnyTerm, showAnyQTerm, showAnyExpression, showAnyQExpression
, readsAnyUnqualifiedTerm, readAnyUnqualifiedTerm
, readsAnyQTerm, readAnyQTerm
, readsAnyQExpression, readAnyQExpression
#endif
) where
import Char (isSpace)
import IO (hPutStrLn, stderr)
--- Performs and hides an I/O action in a computation (use with care!).
unsafePerformIO :: IO a -> a
unsafePerformIO external
--- Prints the first argument as a side effect and behaves as identity on the
--- second argument.
trace :: String -> a -> a
trace s x = unsafePerformIO (hPutStrLn stderr s >> return x)
#ifdef __PAKCS__
--- Spawns a constraint and returns the second argument.
--- This function can be considered as defined by
--- `spawnConstraint c x | c = x`.
--- However, the evaluation of the constraint and the right-hand side
--- are performed concurrently, i.e., a suspension of the constraint
--- does not imply a blocking of the right-hand side and the
--- right-hand side might be evaluated before the constraint is successfully
--- solved.
--- Thus, a computation might return a result even if some of the
--- spawned constraints are suspended (use the PAKCS option
--- `+suspend` to show such suspended goals).
spawnConstraint :: Bool -> a -> a
spawnConstraint external
--- Tests whether the first argument evaluates to a currently unbound
--- variable (use with care!).
isVar :: _ -> Bool
isVar v = prim_isVar $! v
prim_isVar :: _ -> Bool
prim_isVar external
--- Tests whether both arguments evaluate to the identical currently unbound
--- variable (use with care!).
--- For instance, identicalVar (id x) (fst (x,1)) evaluates to
--- True whereas identicalVar x y and
--- let x=1 in identicalVar x x evaluate to False
identicalVar :: a -> a -> Bool
identicalVar x y = (prim_identicalVar $! y) $! x
--- let x=1 in identicalVar x x evaluate to False
prim_identicalVar :: a -> a -> Bool
prim_identicalVar external
--- Tests whether the argument evaluates to a ground value
--- (use with care!).
isGround :: _ -> Bool
isGround v = prim_isGround $!! v
prim_isGround :: _ -> Bool
prim_isGround external
--- Comparison of any data terms, possibly containing variables.
--- Data constructors are compared in the order of their definition
--- in the datatype declarations and recursively in the arguments.
--- Variables are compared in some internal order.
compareAnyTerm :: a -> a -> Ordering
compareAnyTerm external
--- Transforms the normal form of a term into a string representation
--- in standard prefix notation.
--- Thus, showAnyTerm evaluates its argument to normal form.
--- This function is similar to the function ReadShowTerm.showTerm
--- but it also transforms logic variables into a string representation
--- that can be read back by Unsafe.read(s)AnyUnqualifiedTerm.
--- Thus, the result depends on the evaluation and binding status of
--- logic variables so that it should be used with care!
showAnyTerm :: _ -> String
showAnyTerm x = prim_showAnyTerm $!! x
prim_showAnyTerm :: _ -> String
prim_showAnyTerm external
--- Transforms the normal form of a term into a string representation
--- in standard prefix notation.
--- Thus, showAnyQTerm evaluates its argument to normal form.
--- This function is similar to the function ReadShowTerm.showQTerm
--- but it also transforms logic variables into a string representation
--- that can be read back by Unsafe.read(s)AnyQTerm.
--- Thus, the result depends on the evaluation and binding status of
--- logic variables so that it should be used with care!
showAnyQTerm :: _ -> String
showAnyQTerm x = prim_showAnyQTerm $!! x
prim_showAnyQTerm :: _ -> String
prim_showAnyQTerm external
--- Transform a string containing a term in standard prefix notation
--- without module qualifiers into the corresponding data term.
--- The string might contain logical variable encodings produced by showAnyTerm.
--- In case of a successful parse, the result is a one element list
--- containing a pair of the data term and the remaining unparsed string.
readsAnyUnqualifiedTerm :: [String] -> String -> [(_,String)]
readsAnyUnqualifiedTerm [] _ =
error "ReadShowTerm.readsAnyUnqualifiedTerm: list of module prefixes is empty"
readsAnyUnqualifiedTerm (prefix:prefixes) s =
readsAnyUnqualifiedTermWithPrefixes (prefix:prefixes) s
readsAnyUnqualifiedTermWithPrefixes :: [String] -> String -> [(_,String)]
readsAnyUnqualifiedTermWithPrefixes prefixes s =
(prim_readsAnyUnqualifiedTerm $## prefixes) $## s
prim_readsAnyUnqualifiedTerm :: [String] -> String -> [(_,String)]
prim_readsAnyUnqualifiedTerm external
--- Transforms a string containing a term in standard prefix notation
--- without module qualifiers into the corresponding data term.
--- The string might contain logical variable encodings produced by showAnyTerm.
readAnyUnqualifiedTerm :: [String] -> String -> _
readAnyUnqualifiedTerm prefixes s = case result of
[(term,tail)]
-> if all isSpace tail then term
else error ("Unsafe.readAnyUnqualifiedTerm: no parse, unmatched string after term: "++tail)
[] -> error "Unsafe.readAnyUnqualifiedTerm: no parse"
_ -> error "Unsafe.readAnyUnqualifiedTerm: ambiguous parse"
where result = readsAnyUnqualifiedTerm prefixes s
--- Transforms a string containing a term in standard prefix notation
--- with qualified constructor names into the corresponding data term.
--- The string might contain logical variable encodings produced by showAnyQTerm.
--- In case of a successful parse, the result is a one element list
--- containing a pair of the data term and the remaining unparsed string.
readsAnyQTerm :: String -> [(_,String)]
readsAnyQTerm s = prim_readsAnyQTerm $## s
prim_readsAnyQTerm :: String -> [(_,String)]
prim_readsAnyQTerm external
--- Transforms a string containing a term in standard prefix notation
--- with qualified constructor names into the corresponding data term.
--- The string might contain logical variable encodings produced by showAnyQTerm.
readAnyQTerm :: String -> _
readAnyQTerm s = case result of
[(term,tail)] -> if all isSpace tail then term
else error "Unsafe.readAnyQTerm: no parse"
[] -> error "Unsafe.readAnyQTerm: no parse"
_ -> error "Unsafe.readAnyQTerm: ambiguous parse"
where result = readsAnyQTerm s
--- Transforms any expression (even not in normal form) into a string representation
--- in standard prefix notation without module qualifiers.
--- The result depends on the evaluation and binding status of
--- logic variables so that it should be used with care!
showAnyExpression :: _ -> String
showAnyExpression external
--- Transforms any expression (even not in normal form) into a string representation
--- in standard prefix notation with module qualifiers.
--- The result depends on the evaluation and binding status of
--- logic variables so that it should be used with care!
showAnyQExpression :: _ -> String
showAnyQExpression external
--- Transforms a string containing an expression in standard prefix notation
--- with qualified constructor names into the corresponding expression.
--- The string might contain logical variable and defined function
--- encodings produced by showAnyQExpression.
--- In case of a successful parse, the result is a one element list
--- containing a pair of the expression and the remaining unparsed string.
readsAnyQExpression :: String -> [(_,String)]
readsAnyQExpression s = prim_readsAnyQExpression $## s
prim_readsAnyQExpression :: String -> [(_,String)]
prim_readsAnyQExpression external
--- Transforms a string containing an expression in standard prefix notation
--- with qualified constructor names into the corresponding expression.
--- The string might contain logical variable and defined function
--- encodings produced by showAnyQExpression.
readAnyQExpression :: String -> _
readAnyQExpression s = case result of
[(term,tail)] -> if all isSpace tail then term
else error "Unsafe.readAnyQExpression: no parse"
[] -> error "Unsafe.readAnyQExpression: no parse"
_ -> error "Unsafe.readAnyQExpression: ambiguous parse"
where result = readsAnyQExpression s
#endif
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Unsafe.kics2 0000664 0000000 0000000 00000000750 13231616147 0023643 0 ustar 00root root 0000000 0000000 import System.IO.Unsafe (unsafePerformIO)
import KiCS2Debug (internalError)
external_d_C_unsafePerformIO :: Curry_Prelude.C_IO a -> Cover -> ConstStore -> a
external_d_C_unsafePerformIO io cd cs = unsafePerformIO (toIO errSupply cd cs io)
where errSupply = internalError "Unsafe.unsafePerformIO: ID supply used"
external_nd_C_unsafePerformIO :: Curry_Prelude.C_IO a -> IDSupply -> Cover -> ConstStore -> a
external_nd_C_unsafePerformIO io s cd cs = unsafePerformIO (toIO s cd cs io)
curry-libs-v2.0.1-33a3ab5b66da00f76d4e503790eb142dacb71b53/Unsafe.pakcs 0000664 0000000 0000000 00000003546 13231616147 0023737 0 ustar 00root root 0000000 0000000