`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 ()
writeFile f s = (prim_writeFile $## f) s
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 ()
appendFile f s = (prim_appendFile $## f) s
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
-- toRational :: a -> Rational
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 _ = []