#!/usr/bin/env runhaskell
#if __GLASGOW_HASKELL__
{-# LANGUAGE ... #-}
#endif
-- | ...
module A.B.C (a, {- ... -} B(..), c, -- ...
--(),
--(,),
--[],
--(->),
d, -- ...
e) {- ... -} where -- ...
{- ... -}
import qualified A.B.C as A.B hiding (a, {- ... -} B(..), c) --
import Data.Vector.Storable as V -- ...
import Data.Vector.Storable.Mutable as MV -- ...
instance Storable Foo where -- ...
-- instance Storable Foo -- ...
data family A = A { {- ... -} _a :: {-# UNPACK #-} !Int -- ...
#if __Q__
, _a :: C -- ...
#endif
} deriving (Foo) -- ...
data Foo = Foo {-# UNPACK #-} !Atype
{-# UNPACK #-} !BType
{-# UNPACK #-} !CType
newtype A = A (B ()) {- ... -}
deriving (Foo) {-
type A a b = B (C a b) -}
class family (B a) => {- ... -} A a where -- ...
class instance Bar {- ... -} where -- ...
a :: forall a. a -- ...
{-# INLINE a #-}
a = not >> mdo print 1 >> rec 1 '2' '\'' '\n' ':':' ':msg >> proc 1 2 3 >> " -- ..."
+ importA 1
+ moduleA 1
+ classA 1
+ instanceA 1
+ dataA 1
+ newtypeA 1
+ typeA 1
+ defaultA 1
+ infixA 1
+ foreignA 1
+ whereA 1
+ doA 1
default Num {- ... -} ( Int ) -- ...
infix {- ... -} + 1 -- ...
foreign import ccall {- ... -} "a" a :: A (B ()) -- ...
module Prelude (
module PreludeList, module PreludeText, module PreludeIO,
Bool(False, True),
Maybe(Nothing, Just),
Either(Left, Right),
Ordering(LT, EQ, GT),
Char, String, Int, Integer, Float, Double, Rational, IO,
-- These built-in types are defined in the Prelude, but
-- are denoted by built-in syntax, and cannot legally
-- appear in an export list.
-- List type: []((:), [])
-- Tuple types: (,)((,)), (,,)((,,)), etc.
-- Trivial type: ()(())
-- Functions: (->)
Eq((==), (/=)),
Ord(compare, (<), (<=), (>=), (>), max, min),
Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
enumFromTo, enumFromThenTo),
Bounded(minBound, maxBound),
Num((+), (-), (*), negate, abs, signum, fromInteger),
Real(toRational),
Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
Fractional((/), recip, fromRational),
Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
RealFrac(properFraction, truncate, round, ceiling, floor),
RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
encodeFloat, exponent, significand, scaleFloat, isNaN,
isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),
Monad((>>=), (>>), return, fail),
Functor(fmap),
mapM, mapM_, sequence, sequence_, (=<<),
maybe, either,
(&&), (||), not, otherwise,
subtract, even, odd, gcd, lcm, (^), (^^),
fromIntegral, realToFrac,
fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
asTypeOf, error, undefined,
seq, ($!)
) where
import PreludeBuiltin -- Contains all `prim' values
import UnicodePrims( primUnicodeMaxChar ) -- Unicode primitives
import PreludeList
import PreludeText
import PreludeIO
import Ratio( Rational )
infixr 9 .
infixr 8 ^, ^^, **
infixl 7 *, /, `quot`, `rem`, `div`, `mod`
infixl 6 +, -
-- The (:) operator is built-in syntax, and cannot legally be given
-- a fixity declaration; but its fixity is given by:
-- infixr 5 :
infix 4 ==, /=, <, <=, >=, >
infixr 3 &&
infixr 2 ||
infixl 1 >>, >>=
infixr 1 =<<
infixr 0 $, $!, `seq`
-- Standard types, classes, instances and related functions
-- Equality and Ordered classes
class Eq a where
(==), (/=) :: a -> a -> Bool
-- Minimal complete definition:
-- (==) or (/=)
x /= y = not (x == y)
x == y = not (x /= y)
class (Eq a) => Ord a where
compare :: a -> a -> Ordering
(<), (<=), (>=), (>) :: a -> a -> Bool
max, min :: a -> a -> a
-- Minimal complete definition:
-- (<=) or compare
-- Using compare can be more efficient for complex types.
compare x y
| x == y = EQ
| x <= y = LT
| otherwise = GT
x <= y = compare x y /= GT
x < y = compare x y == LT
x >= y = compare x y /= LT
x > y = compare x y == GT
-- note that (min x y, max x y) = (x,y) or (y,x)
max x y
| x <= y = y
| otherwise = x
min x y
| x <= y = x
| otherwise = y
-- Enumeration and Bounded classes
class Enum a where
succ, pred :: a -> a
toEnum :: Int -> a
fromEnum :: a -> Int
enumFrom :: a -> [a] -- [n..]
enumFromThen :: a -> a -> [a] -- [n,n'..]
enumFromTo :: a -> a -> [a] -- [n..m]
enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
-- Minimal complete definition:
-- toEnum, fromEnum
--
-- NOTE: these default methods only make sense for types
-- that map injectively into Int using fromEnum
-- and toEnum.
succ = toEnum . (+1) . fromEnum
pred = toEnum . (subtract 1) . fromEnum
enumFrom x = map toEnum [fromEnum x ..]
enumFromTo x y = map toEnum [fromEnum x .. fromEnum y]
enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..]
enumFromThenTo x y z =
map toEnum [fromEnum x, fromEnum y .. fromEnum z]
class Bounded a where
minBound :: a
maxBound :: a
-- Numeric classes
class (Eq a, Show a) => Num a where
(+), (-), (*) :: a -> a -> a
negate :: a -> a
abs, signum :: a -> a
fromInteger :: Integer -> a
-- Minimal complete definition:
-- All, except negate or (-)
x - y = x + negate y
negate x = 0 - x
class (Num a, Ord a) => Real a where
toRational :: a -> Rational
class (Real a, Enum a) => Integral a where
quot, rem :: a -> a -> a
div, mod :: a -> a -> a
quotRem, divMod :: a -> a -> (a,a)
toInteger :: a -> Integer
-- Minimal complete definition:
-- quotRem, toInteger
n `quot` d = q where (q,r) = quotRem n d
n `rem` d = r where (q,r) = quotRem n d
n `div` d = q where (q,r) = divMod n d
n `mod` d = r where (q,r) = divMod n d
divMod n d = if signum r == - signum d then (q-1, r+d) else qr
where qr@(q,r) = quotRem n d
class (Num a) => Fractional a where
(/) :: a -> a -> a
recip :: a -> a
fromRational :: Rational -> a
-- Minimal complete definition:
-- fromRational and (recip or (/))
recip x = 1 / x
x / y = x * recip y
class (Fractional a) => Floating a where
pi :: a
exp, log, sqrt :: a -> a
(**), logBase :: a -> a -> a
sin, cos, tan :: a -> a
asin, acos, atan :: a -> a
sinh, cosh, tanh :: a -> a
asinh, acosh, atanh :: a -> a
-- Minimal complete definition:
-- pi, exp, log, sin, cos, sinh, cosh
-- asin, acos, atan
-- asinh, acosh, atanh
x ** y = exp (log x * y)
logBase x y = log y / log x
sqrt x = x ** 0.5
tan x = sin x / cos x
tanh x = sinh x / cosh x
class (Real a, Fractional a) => RealFrac a where
properFraction :: (Integral b) => a -> (b,a)
truncate, round :: (Integral b) => a -> b
ceiling, floor :: (Integral b) => a -> b
-- Minimal complete definition:
-- properFraction
truncate x = m where (m,_) = properFraction x
round x = let (n,r) = properFraction x
m = if r < 0 then n - 1 else n + 1
in case signum (abs r - 0.5) of
-1 -> n
0 -> if even n then n else m
1 -> m
ceiling x = if r > 0 then n + 1 else n
where (n,r) = properFraction x
floor x = if r < 0 then n - 1 else n
where (n,r) = properFraction x
class (RealFrac a, Floating a) => RealFloat a where
floatRadix :: a -> Integer
floatDigits :: a -> Int
floatRange :: a -> (Int,Int)
decodeFloat :: a -> (Integer,Int)
encodeFloat :: Integer -> Int -> a
exponent :: a -> Int
significand :: a -> a
scaleFloat :: Int -> a -> a
isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
:: a -> Bool
atan2 :: a -> a -> a
-- Minimal complete definition:
-- All except exponent, significand,
-- scaleFloat, atan2
exponent x = if m == 0 then 0 else n + floatDigits x
where (m,n) = decodeFloat x
significand x = encodeFloat m (- floatDigits x)
where (m,_) = decodeFloat x
scaleFloat k x = encodeFloat m (n+k)
where (m,n) = decodeFloat x
atan2 y x
| x>0 = atan (y/x)
| x==0 && y>0 = pi/2
| x<0 && y>0 = pi + atan (y/x)
|(x<=0 && y<0) ||
(x<0 && isNegativeZero y) ||
(isNegativeZero x && isNegativeZero y)
= -atan2 (-y) x
| y==0 && (x<0 || isNegativeZero x)
= pi -- must be after the previous test on zero y
| x==0 && y==0 = y -- must be after the other double zero tests
| otherwise = x + y -- x or y is a NaN, return a NaN (via +)
-- Numeric functions
subtract :: (Num a) => a -> a -> a
subtract = flip (-)
even, odd :: (Integral a) => a -> Bool
even n = n `rem` 2 == 0
odd = not . even
gcd :: (Integral a) => a -> a -> a
gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
gcd x y = gcd' (abs x) (abs y)
where gcd' x 0 = x
gcd' x y = gcd' y (x `rem` y)
lcm :: (Integral a) => a -> a -> a
lcm _ 0 = 0
lcm 0 _ = 0
lcm x y = abs ((x `quot` (gcd x y)) * y)
(^) :: (Num a, Integral b) => a -> b -> a
x ^ 0 = 1
x ^ n | n > 0 = f x (n-1) x
where f _ 0 y = y
f x n y = g x n where
g x n | even n = g (x*x) (n `quot` 2)
| otherwise = f x (n-1) (x*y)
_ ^ _ = error "Prelude.^: negative exponent"
(^^) :: (Fractional a, Integral b) => a -> b -> a
x ^^ n = if n >= 0 then x^n else recip (x^(-n))
fromIntegral :: (Integral a, Num b) => a -> b
fromIntegral = fromInteger . toInteger
realToFrac :: (Real a, Fractional b) => a -> b
realToFrac = fromRational . toRational
-- Monadic classes
class Functor f where
fmap :: (a -> b) -> f a -> f b
class Monad m where
(>>=) :: m a -> (a -> m b) -> m b
(>>) :: m a -> m b -> m b
return :: a -> m a
fail :: String -> m a
-- Minimal complete definition:
-- (>>=), return
m >> k = m >>= \_ -> k
fail s = error s
sequence :: Monad m => [m a] -> m [a]
sequence = foldr mcons (return [])
where mcons p q = p >>= \x -> q >>= \y -> return (x:y)
sequence_ :: Monad m => [m a] -> m ()
sequence_ = foldr (>>) (return ())
-- The xxxM functions take list arguments, but lift the function or
-- list element to a monad type
mapM :: Monad m => (a -> m b) -> [a] -> m [b]
mapM f as = sequence (map f as)
mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
mapM_ f as = sequence_ (map f as)
(=<<) :: Monad m => (a -> m b) -> m a -> m b
f =<< x = x >>= f
-- Trivial type
data () = () deriving (Eq, Ord, Enum, Bounded)
-- Not legal Haskell; for illustration only
-- Function type
-- identity function
id :: a -> a
id x = x
-- constant function
const :: a -> b -> a
const x _ = x
-- function composition
(.) :: (b -> c) -> (a -> b) -> a -> c
f . g = \ x -> f (g x)
-- flip f takes its (first) two arguments in the reverse order of f.
flip :: (a -> b -> c) -> b -> a -> c
flip f x y = f y x
seq :: a -> b -> b
seq = ... -- Primitive
-- right-associating infix application operators
-- (useful in continuation-passing style)
($), ($!) :: (a -> b) -> a -> b
f $ x = f x
f $! x = x `seq` f x
-- Boolean type
data Bool = False | True deriving (Eq, Ord, Enum, Read, Show, Bounded)
-- Boolean functions
(&&), (||) :: Bool -> Bool -> Bool
True && x = x
False && _ = False
True || _ = True
False || x = x
not :: Bool -> Bool
not True = False
not False = True
otherwise :: Bool
otherwise = True
-- Character type
data Char = ... 'a' | 'b' ... -- Unicode values
instance Eq Char where
c == c' = fromEnum c == fromEnum c'
instance Ord Char where
c <= c' = fromEnum c <= fromEnum c'
instance Enum Char where
toEnum = primIntToChar
fromEnum = primCharToInt
enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
enumFromThen c c' = map toEnum [fromEnum c, fromEnum c' .. fromEnum lastChar]
where lastChar :: Char
lastChar | c' < c = minBound
| otherwise = maxBound
instance Bounded Char where
minBound = '\0'
maxBound = primUnicodeMaxChar
type String = [Char]
-- Maybe type
data Maybe a = Nothing | Just a deriving (Eq, Ord, Read, Show)
maybe :: b -> (a -> b) -> Maybe a -> b
maybe n f Nothing = n
maybe n f (Just x) = f x
instance Functor Maybe where
fmap f Nothing = Nothing
fmap f (Just x) = Just (f x)
instance Monad Maybe where
(Just x) >>= k = k x
Nothing >>= k = Nothing
return = Just
fail s = Nothing
-- Either type
data Either a b = Left a | Right b deriving (Eq, Ord, Read, Show)
either :: (a -> c) -> (b -> c) -> Either a b -> c
either f g (Left x) = f x
either f g (Right y) = g y
-- IO type
data IO a = ... -- abstract
instance Functor IO where
fmap f x = x >>= (return . f)
instance Monad IO where
(>>=) = ...
return = ...
fail s = ioError (userError s)
-- Ordering type
data Ordering = LT | EQ | GT
deriving (Eq, Ord, Enum, Read, Show, Bounded)
-- Standard numeric types. The data declarations for these types cannot
-- be expressed directly in Haskell since the constructor lists would be
-- far too large.
data Int = minBound ... -1 | 0 | 1 ... maxBound
instance Eq Int where ...
instance Ord Int where ...
instance Num Int where ...
instance Real Int where ...
instance Integral Int where ...
instance Enum Int where ...
instance Bounded Int where ...
data Integer = ... -1 | 0 | 1 ...
instance Eq Integer where ...
instance Ord Integer where ...
instance Num Integer where ...
instance Real Integer where ...
instance Integral Integer where ...
instance Enum Integer where ...
data Float
instance Eq Float where ...
instance Ord Float where ...
instance Num Float where ...
instance Real Float where ...
instance Fractional Float where ...
instance Floating Float where ...
instance RealFrac Float where ...
instance RealFloat Float where ...
data Double
instance Eq Double where ...
instance Ord Double where ...
instance Num Double where ...
instance Real Double where ...
instance Fractional Double where ...
instance Floating Double where ...
instance RealFrac Double where ...
instance RealFloat Double where ...
-- The Enum instances for Floats and Doubles are slightly unusual.
-- The `toEnum' function truncates numbers to Int. The definitions
-- of enumFrom and enumFromThen allow floats to be used in arithmetic
-- series: [0,0.1 .. 0.95]. However, roundoff errors make these somewhat
-- dubious. This example may have either 10 or 11 elements, depending on
-- how 0.1 is represented.
instance Enum Float where
succ x = x+1
pred x = x-1
toEnum = fromIntegral
fromEnum = fromInteger . truncate -- may overflow
enumFrom = numericEnumFrom
enumFromThen = numericEnumFromThen
enumFromTo = numericEnumFromTo
enumFromThenTo = numericEnumFromThenTo
instance Enum Double where
succ x = x+1
pred x = x-1
toEnum = fromIntegral
fromEnum = fromInteger . truncate -- may overflow
enumFrom = numericEnumFrom
enumFromThen = numericEnumFromThen
enumFromTo = numericEnumFromTo
enumFromThenTo = numericEnumFromThenTo
numericEnumFrom :: (Fractional a) => a -> [a]
numericEnumFromThen :: (Fractional a) => a -> a -> [a]
numericEnumFromTo :: (Fractional a, Ord a) => a -> a -> [a]
numericEnumFromThenTo :: (Fractional a, Ord a) => a -> a -> a -> [a]
numericEnumFrom = iterate (+1)
numericEnumFromThen n m = iterate (+(m-n)) n
numericEnumFromTo n m = takeWhile (<= m+1/2) (numericEnumFrom n)
numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
where
p | n' >= n = (<= m + (n'-n)/2)
| otherwise = (>= m + (n'-n)/2)
-- Lists
data [a] = [] | a : [a] deriving (Eq, Ord)
-- Not legal Haskell; for illustration only
instance Functor [] where
fmap = map
instance Monad [] where
m >>= k = concat (map k m)
return x = [x]
fail s = []
-- Tuples
data (a,b) = (a,b) deriving (Eq, Ord, Bounded)
data (a,b,c) = (a,b,c) deriving (Eq, Ord, Bounded)
-- Not legal Haskell; for illustration only
-- component projections for pairs:
-- (NB: not provided for triples, quadruples, etc.)
fst :: (a,b) -> a
fst (x,y) = x
snd :: (a,b) -> b
snd (x,y) = y
-- curry converts an uncurried function to a curried function;
-- uncurry converts a curried function to a function on pairs.
curry :: ((a, b) -> c) -> a -> b -> c
curry f x y = f (x, y)
uncurry :: (a -> b -> c) -> ((a, b) -> c)
uncurry f p = f (fst p) (snd p)
-- Misc functions
-- until p f yields the result of applying f until p holds.
until :: (a -> Bool) -> (a -> a) -> a -> a
until p f x
| p x = x
| otherwise = until p f (f x)
-- asTypeOf is a type-restricted version of const. It is usually used
-- as an infix operator, and its typing forces its first argument
-- (which is usually overloaded) to have the same type as the second.
asTypeOf :: a -> a -> a
asTypeOf = const
-- error stops execution and displays an error message
error :: String -> a
error = primError
-- It is expected that compilers will recognize this and insert error
-- messages that are more appropriate to the context in which undefined
-- appears.
undefined :: a
undefined = error "Prelude.undefined"
-- Standard list functions
module PreludeList (
map, (++), filter, concat, concatMap,
head, last, tail, init, null, length, (!!),
foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
iterate, repeat, replicate, cycle,
take, drop, splitAt, takeWhile, dropWhile, span, break,
lines, words, unlines, unwords, reverse, and, or,
any, all, elem, notElem, lookup,
sum, product, maximum, minimum,
zip, zip3, zipWith, zipWith3, unzip, unzip3)
where
import qualified Char(isSpace)
infixl 9 !!
infixr 5 ++
infix 4 `elem`, `notElem`
-- Map and append
map :: (a -> b) -> [a] -> [b]
map f [] = []
map f (x:xs) = f x : map f xs
(++) :: [a] -> [a] -> [a]
[] ++ ys = ys
(x:xs) ++ ys = x : (xs ++ ys)
filter :: (a -> Bool) -> [a] -> [a]
filter p [] = []
filter p (x:xs) | p x = x : filter p xs
| otherwise = filter p xs
concat :: [[a]] -> [a]
concat xss = foldr (++) [] xss
concatMap :: (a -> [b]) -> [a] -> [b]
concatMap f = concat . map f
-- head and tail extract the first element and remaining elements,
-- respectively, of a list, which must be non-empty. last and init
-- are the dual functions working from the end of a finite list,
-- rather than the beginning.
head :: [a] -> a
head (x:_) = x
head [] = error "Prelude.head: empty list"
tail :: [a] -> [a]
tail (_:xs) = xs
tail [] = error "Prelude.tail: empty list"
last :: [a] -> a
last [x] = x
last (_:xs) = last xs
last [] = error "Prelude.last: empty list"
init :: [a] -> [a]
init [x] = []
init (x:xs) = x : init xs
init [] = error "Prelude.init: empty list"
null :: [a] -> Bool
null [] = True
null (_:_) = False
-- length returns the length of a finite list as an Int.
length :: [a] -> Int
length [] = 0
length (_:l) = 1 + length l
-- List index (subscript) operator, 0-origin
(!!) :: [a] -> Int -> a
xs !! n | n < 0 = error "Prelude.!!: negative index"
[] !! _ = error "Prelude.!!: index too large"
(x:_) !! 0 = x
(_:xs) !! n = xs !! (n-1)
-- foldl, applied to a binary operator, a starting value (typically the
-- left-identity of the operator), and a list, reduces the list using
-- the binary operator, from left to right:
-- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
-- foldl1 is a variant that has no starting value argument, and thus must
-- be applied to non-empty lists. scanl is similar to foldl, but returns
-- a list of successive reduced values from the left:
-- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
-- Note that last (scanl f z xs) == foldl f z xs.
-- scanl1 is similar, again without the starting element:
-- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
foldl :: (a -> b -> a) -> a -> [b] -> a
foldl f z [] = z
foldl f z (x:xs) = foldl f (f z x) xs
foldl1 :: (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs
foldl1 _ [] = error "Prelude.foldl1: empty list"
scanl :: (a -> b -> a) -> a -> [b] -> [a]
scanl f q xs = q : (case xs of
[] -> []
x:xs -> scanl f (f q x) xs)
scanl1 :: (a -> a -> a) -> [a] -> [a]
scanl1 f (x:xs) = scanl f x xs
scanl1 _ [] = []
-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
-- above functions.
foldr :: (a -> b -> b) -> b -> [a] -> b
foldr f z [] = z
foldr f z (x:xs) = f x (foldr f z xs)
foldr1 :: (a -> a -> a) -> [a] -> a
foldr1 f [x] = x
foldr1 f (x:xs) = f x (foldr1 f xs)
foldr1 _ [] = error "Prelude.foldr1: empty list"
scanr :: (a -> b -> b) -> b -> [a] -> [b]
scanr f q0 [] = [q0]
scanr f q0 (x:xs) = f x q : qs
where qs@(q:_) = scanr f q0 xs
scanr1 :: (a -> a -> a) -> [a] -> [a]
scanr1 f [] = []
scanr1 f [x] = [x]
scanr1 f (x:xs) = f x q : qs
where qs@(q:_) = scanr1 f xs
-- iterate f x returns an infinite list of repeated applications of f to x:
-- iterate f x == [x, f x, f (f x), ...]
iterate :: (a -> a) -> a -> [a]
iterate f x = x : iterate f (f x)
-- repeat x is an infinite list, with x the value of every element.
repeat :: a -> [a]
repeat x = xs where xs = x:xs
-- replicate n x is a list of length n with x the value of every element
replicate :: Int -> a -> [a]
replicate n x = take n (repeat x)
-- cycle ties a finite list into a circular one, or equivalently,
-- the infinite repetition of the original list. It is the identity
-- on infinite lists.
cycle :: [a] -> [a]
cycle [] = error "Prelude.cycle: empty list"
cycle xs = xs' where xs' = xs ++ xs'
-- take n, applied to a list xs, returns the prefix of xs of length n,
-- or xs itself if n > length xs. drop n xs returns the suffix of xs
-- after the first n elements, or [] if n > length xs. splitAt n xs
-- is equivalent to (take n xs, drop n xs).
take :: Int -> [a] -> [a]
take n _ | n <= 0 = []
take _ [] = []
take n (x:xs) = x : take (n-1) xs
drop :: Int -> [a] -> [a]
drop n xs | n <= 0 = xs
drop _ [] = []
drop n (_:xs) = drop (n-1) xs
splitAt :: Int -> [a] -> ([a],[a])
splitAt n xs = (take n xs, drop n xs)
-- takeWhile, applied to a predicate p and a list xs, returns the longest
-- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs
-- returns the remaining suffix. span p xs is equivalent to
-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.
takeWhile :: (a -> Bool) -> [a] -> [a]
takeWhile p [] = []
takeWhile p (x:xs)
| p x = x : takeWhile p xs
| otherwise = []
dropWhile :: (a -> Bool) -> [a] -> [a]
dropWhile p [] = []
dropWhile p xs@(x:xs')
| p x = dropWhile p xs'
| otherwise = xs
span, break :: (a -> Bool) -> [a] -> ([a],[a])
span p [] = ([],[])
span p xs@(x:xs')
| p x = (x:ys,zs)
| otherwise = ([],xs)
where (ys,zs) = span p xs'
break p = span (not . p)
-- lines breaks a string up into a list of strings at newline characters.
-- The resulting strings do not contain newlines. Similary, words
-- breaks a string up into a list of words, which were delimited by
-- white space. unlines and unwords are the inverse operations.
-- unlines joins lines with terminating newlines, and unwords joins
-- words with separating spaces.
lines :: String -> [String]
lines "" = []
lines s = let (l, s') = break (== '\n') s
in l : case s' of
[] -> []
(_:s'') -> lines s''
words :: String -> [String]
words s = case dropWhile Char.isSpace s of
"" -> []
s' -> w : words s''
where (w, s'') = break Char.isSpace s'
unlines :: [String] -> String
unlines = concatMap (++ "\n")
unwords :: [String] -> String
unwords [] = ""
unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
-- reverse xs returns the elements of xs in reverse order. xs must be finite.
reverse :: [a] -> [a]
reverse = foldl (flip (:)) []
-- and returns the conjunction of a Boolean list. For the result to be
-- True, the list must be finite; False, however, results from a False
-- value at a finite index of a finite or infinite list. or is the
-- disjunctive dual of and.
and, or :: [Bool] -> Bool
and = foldr (&&) True
or = foldr (||) False
-- Applied to a predicate and a list, any determines if any element
-- of the list satisfies the predicate. Similarly, for all.
any, all :: (a -> Bool) -> [a] -> Bool
any p = or . map p
all p = and . map p
-- elem is the list membership predicate, usually written in infix form,
-- e.g., x `elem` xs. notElem is the negation.
elem, notElem :: (Eq a) => a -> [a] -> Bool
elem x = any (== x)
notElem x = all (/= x)
-- lookup key assocs looks up a key in an association list.
lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
lookup key [] = Nothing
lookup key ((x,y):xys)
| key == x = Just y
| otherwise = lookup key xys
-- sum and product compute the sum or product of a finite list of numbers.
sum, product :: (Num a) => [a] -> a
sum = foldl (+) 0
product = foldl (*) 1
-- maximum and minimum return the maximum or minimum value from a list,
-- which must be non-empty, finite, and of an ordered type.
maximum, minimum :: (Ord a) => [a] -> a
maximum [] = error "Prelude.maximum: empty list"
maximum xs = foldl1 max xs
minimum [] = error "Prelude.minimum: empty list"
minimum xs = foldl1 min xs
-- zip takes two lists and returns a list of corresponding pairs. If one
-- input list is short, excess elements of the longer list are discarded.
-- zip3 takes three lists and returns a list of triples. Zips for larger
-- tuples are in the List library
zip :: [a] -> [b] -> [(a,b)]
zip = zipWith (,)
zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
zip3 = zipWith3 (,,)
-- The zipWith family generalises the zip family by zipping with the
-- function given as the first argument, instead of a tupling function.
-- For example, zipWith (+) is applied to two lists to produce the list
-- of corresponding sums.
zipWith :: (a->b->c) -> [a]->[b]->[c]
zipWith z (a:as) (b:bs)
= z a b : zipWith z as bs
zipWith _ _ _ = []
zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
zipWith3 z (a:as) (b:bs) (c:cs)
= z a b c : zipWith3 z as bs cs
zipWith3 _ _ _ _ = []
-- unzip transforms a list of pairs into a pair of lists.
unzip :: [(a,b)] -> ([a],[b])
unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
unzip3 :: [(a,b,c)] -> ([a],[b],[c])
unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
([],[],[])
module PreludeText (
ReadS, ShowS,
Read(readsPrec, readList),
Show(showsPrec, show, showList),
reads, shows, read, lex,
showChar, showString, readParen, showParen ) where
-- The instances of Read and Show for
-- Bool, Maybe, Either, Ordering
-- are done via "deriving" clauses in Prelude.hs
import Char(isSpace, isAlpha, isDigit, isAlphaNum,
showLitChar, readLitChar, lexLitChar)
import Numeric(showSigned, showInt, readSigned, readDec, showFloat,
readFloat, lexDigits)
type ReadS a = String -> [(a,String)]
type ShowS = String -> String
class Read a where
readsPrec :: Int -> ReadS a
readList :: ReadS [a]
-- Minimal complete definition:
-- readsPrec
readList = 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]
class Show a where
showsPrec :: Int -> a -> ShowS
show :: a -> String
showList :: [a] -> ShowS
-- Mimimal complete definition:
-- show or showsPrec
showsPrec _ x s = show x ++ s
show x = showsPrec 0 x ""
showList [] = showString "[]"
showList (x:xs) = showChar '[' . shows x . showl xs
where showl [] = showChar ']'
showl (x:xs) = showChar ',' . shows x .
showl xs
reads :: (Read a) => ReadS a
reads = readsPrec 0
shows :: (Show a) => a -> ShowS
shows = showsPrec 0
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"
showChar :: Char -> ShowS
showChar = (:)
showString :: String -> ShowS
showString = (++)
showParen :: Bool -> ShowS -> ShowS
showParen b p = if b then showChar '(' . p . showChar ')' else p
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 ]
-- This lexer is not completely faithful to the Haskell lexical syntax.
-- Current limitations:
-- Qualified names are not handled properly
-- Octal and hexidecimal numerics are not recognized as a single token
-- Comments are not treated properly
lex :: ReadS String
lex "" = [("","")]
lex (c:s)
| isSpace c = lex (dropWhile isSpace s)
lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
ch /= "'" ]
lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
where
lexString ('"':s) = [("\"",s)]
lexString s = [(ch++str, u)
| (ch,t) <- lexStrItem s,
(str,u) <- lexString t ]
lexStrItem ('\\':'&':s) = [("\\&",s)]
lexStrItem ('\\':c:s) | isSpace c
= [("\\&",t) |
'\\':t <-
[dropWhile isSpace s]]
lexStrItem s = lexLitChar s
lex (c:s) | isSingle c = [([c],s)]
| isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
| isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
| isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
(fe,t) <- lexFracExp s ]
| otherwise = [] -- bad character
where
isSingle c = c `elem` ",;()[]{}_`"
isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
isIdChar c = isAlphaNum c || c `elem` "_'"
lexFracExp ('.':c:cs) | isDigit c
= [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),
(e,u) <- lexExp t]
lexFracExp s = lexExp s
lexExp (e:s) | e `elem` "eE"
= [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
(ds,u) <- lexDigits t] ++
[(e:ds,t) | (ds,t) <- lexDigits s]
lexExp s = [("",s)]
instance Show Int where
showsPrec n = showsPrec n . toInteger
-- Converting to Integer avoids
-- possible difficulty with minInt
instance Read Int where
readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]
-- Reading at the Integer type avoids
-- possible difficulty with minInt
instance Show Integer where
showsPrec = showSigned showInt
instance Read Integer where
readsPrec p = readSigned readDec
instance Show Float where
showsPrec p = showFloat
instance Read Float where
readsPrec p = readSigned readFloat
instance Show Double where
showsPrec p = showFloat
instance Read Double where
readsPrec p = readSigned readFloat
instance Show () where
showsPrec p () = showString "()"
instance Read () where
readsPrec p = readParen False
(\r -> [((),t) | ("(",s) <- lex r,
(")",t) <- lex s ] )
instance Show Char where
showsPrec p '\'' = showString "'\\''"
showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
showList cs = showChar '"' . showl cs
where showl "" = showChar '"'
showl ('"':cs) = showString "\\\"" . showl cs
showl (c:cs) = showLitChar c . showl cs
instance Read Char where
readsPrec p = readParen False
(\r -> [(c,t) | ('\'':s,t)<- lex r,
(c,"\'") <- readLitChar s])
readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
(l,_) <- readl s ])
where readl ('"':s) = [("",s)]
readl ('\\':'&':s) = readl s
readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
(cs,u) <- readl t ]
instance (Show a) => Show [a] where
showsPrec p = showList
instance (Read a) => Read [a] where
readsPrec p = readList
-- Tuples
instance (Show a, Show b) => Show (a,b) where
showsPrec p (x,y) = showChar '(' . shows x . showChar ',' .
shows y . showChar ')'
instance (Read a, Read b) => Read (a,b) where
readsPrec p = readParen False
(\r -> [((x,y), w) | ("(",s) <- lex r,
(x,t) <- reads s,
(",",u) <- lex t,
(y,v) <- reads u,
(")",w) <- lex v ] )
-- Other tuples have similar Read and Show instances
module PreludeIO (
FilePath, IOError, ioError, userError, catch,
putChar, putStr, putStrLn, print,
getChar, getLine, getContents, interact,
readFile, writeFile, appendFile, readIO, readLn
) where
import PreludeBuiltin
type FilePath = String
data IOError -- The internals of this type are system dependent
instance Show IOError where ...
instance Eq IOError where ...
ioError :: IOError -> IO a
ioError = primIOError
userError :: String -> IOError
userError = primUserError
catch :: IO a -> (IOError -> IO a) -> IO a
catch = primCatch
putChar :: Char -> IO ()
putChar = primPutChar
putStr :: String -> IO ()
putStr s = mapM_ putChar s
putStrLn :: String -> IO ()
putStrLn s = do putStr s
putStr "\n"
print :: Show a => a -> IO ()
print x = putStrLn (show x)
getChar :: IO Char
getChar = primGetChar
getLine :: IO String
getLine = do c <- getChar
if c == '\n' then return "" else
do s <- getLine
return (c:s)
getContents :: IO String
getContents = primGetContents
interact :: (String -> String) -> IO ()
-- The hSetBuffering ensures the expected interactive behaviour
interact f = do hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
s <- getContents
putStr (f s)
readFile :: FilePath -> IO String
readFile = primReadFile
writeFile :: FilePath -> String -> IO ()
writeFile = primWriteFile
appendFile :: FilePath -> String -> IO ()
appendFile = primAppendFile
-- raises an exception instead of an error
readIO :: Read a => String -> IO a
readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> return x
[] -> ioError (userError "Prelude.readIO: no parse")
_ -> ioError (userError "Prelude.readIO: ambiguous parse")
readLn :: Read a => IO a
readLn = do l <- getLine
r <- readIO l
return r
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__
{-# LANGUAGE MagicHash, UnboxedTuples,
NamedFieldPuns, BangPatterns, RecordWildCards #-}
#endif
{-# OPTIONS_HADDOCK prune #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
-- |
-- Module : Data.ByteString
-- Copyright : (c) The University of Glasgow 2001,
-- (c) David Roundy 2003-2005,
-- (c) Simon Marlow 2005,
-- (c) Bjorn Bringert 2006,
-- (c) Don Stewart 2005-2008,
-- (c) Duncan Coutts 2006-2011
-- License : BSD-style
--
-- Maintainer : dons00@gmail.com, duncan@community.haskell.org
-- Stability : stable
-- Portability : portable
--
-- A time and space-efficient implementation of byte vectors using
-- packed Word8 arrays, suitable for high performance use, both in terms
-- of large data quantities, or high speed requirements. Byte vectors
-- are encoded as strict 'Word8' arrays of bytes, held in a 'ForeignPtr',
-- and can be passed between C and Haskell with little effort.
--
-- This module is intended to be imported @qualified@, to avoid name
-- clashes with "Prelude" functions. eg.
--
-- > import qualified Data.ByteString as B
--
-- Original GHC implementation by Bryan O\'Sullivan.
-- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow.
-- Rewritten to support slices and use 'ForeignPtr' by David Roundy.
-- Rewritten again and extended by Don Stewart and Duncan Coutts.
--
module Data.ByteString (
-- * The @ByteString@ type
ByteString, -- abstract, instances: Eq, Ord, Show, Read, Data, Typeable, Monoid
-- * Introducing and eliminating 'ByteString's
empty, -- :: ByteString
singleton, -- :: Word8 -> ByteString
pack, -- :: [Word8] -> ByteString
unpack, -- :: ByteString -> [Word8]
-- * Basic interface
cons, -- :: Word8 -> ByteString -> ByteString
snoc, -- :: ByteString -> Word8 -> ByteString
append, -- :: ByteString -> ByteString -> ByteString
head, -- :: ByteString -> Word8
uncons, -- :: ByteString -> Maybe (Word8, ByteString)
last, -- :: ByteString -> Word8
tail, -- :: ByteString -> ByteString
init, -- :: ByteString -> ByteString
null, -- :: ByteString -> Bool
length, -- :: ByteString -> Int
-- * Transforming ByteStrings
map, -- :: (Word8 -> Word8) -> ByteString -> ByteString
reverse, -- :: ByteString -> ByteString
intersperse, -- :: Word8 -> ByteString -> ByteString
intercalate, -- :: ByteString -> [ByteString] -> ByteString
transpose, -- :: [ByteString] -> [ByteString]
-- * Reducing 'ByteString's (folds)
foldl, -- :: (a -> Word8 -> a) -> a -> ByteString -> a
foldl', -- :: (a -> Word8 -> a) -> a -> ByteString -> a
foldl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
foldl1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
foldr, -- :: (Word8 -> a -> a) -> a -> ByteString -> a
foldr', -- :: (Word8 -> a -> a) -> a -> ByteString -> a
foldr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
foldr1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
-- ** Special folds
concat, -- :: [ByteString] -> ByteString
concatMap, -- :: (Word8 -> ByteString) -> ByteString -> ByteString
any, -- :: (Word8 -> Bool) -> ByteString -> Bool
all, -- :: (Word8 -> Bool) -> ByteString -> Bool
maximum, -- :: ByteString -> Word8
minimum, -- :: ByteString -> Word8
-- * Building ByteStrings
-- ** Scans
scanl, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
scanl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
scanr, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
scanr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
-- ** Accumulating maps
mapAccumL, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
mapAccumR, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
-- ** Generating and unfolding ByteStrings
replicate, -- :: Int -> Word8 -> ByteString
unfoldr, -- :: (a -> Maybe (Word8, a)) -> a -> ByteString
unfoldrN, -- :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a)
-- * Substrings
-- ** Breaking strings
take, -- :: Int -> ByteString -> ByteString
drop, -- :: Int -> ByteString -> ByteString
splitAt, -- :: Int -> ByteString -> (ByteString, ByteString)
takeWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString
dropWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString
span, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
spanEnd, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
break, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
breakEnd, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
group, -- :: ByteString -> [ByteString]
groupBy, -- :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString]
inits, -- :: ByteString -> [ByteString]
tails, -- :: ByteString -> [ByteString]
-- ** Breaking into many substrings
split, -- :: Word8 -> ByteString -> [ByteString]
splitWith, -- :: (Word8 -> Bool) -> ByteString -> [ByteString]
-- * Predicates
isPrefixOf, -- :: ByteString -> ByteString -> Bool
isSuffixOf, -- :: ByteString -> ByteString -> Bool
isInfixOf, -- :: ByteString -> ByteString -> Bool
-- ** Search for arbitrary substrings
breakSubstring, -- :: ByteString -> ByteString -> (ByteString,ByteString)
findSubstring, -- :: ByteString -> ByteString -> Maybe Int
findSubstrings, -- :: ByteString -> ByteString -> [Int]
-- * Searching ByteStrings
-- ** Searching by equality
elem, -- :: Word8 -> ByteString -> Bool
notElem, -- :: Word8 -> ByteString -> Bool
-- ** Searching with a predicate
find, -- :: (Word8 -> Bool) -> ByteString -> Maybe Word8
filter, -- :: (Word8 -> Bool) -> ByteString -> ByteString
partition, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
-- * Indexing ByteStrings
index, -- :: ByteString -> Int -> Word8
elemIndex, -- :: Word8 -> ByteString -> Maybe Int
elemIndices, -- :: Word8 -> ByteString -> [Int]
elemIndexEnd, -- :: Word8 -> ByteString -> Maybe Int
findIndex, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int
findIndices, -- :: (Word8 -> Bool) -> ByteString -> [Int]
count, -- :: Word8 -> ByteString -> Int
-- * Zipping and unzipping ByteStrings
zip, -- :: ByteString -> ByteString -> [(Word8,Word8)]
zipWith, -- :: (Word8 -> Word8 -> c) -> ByteString -> ByteString -> [c]
unzip, -- :: [(Word8,Word8)] -> (ByteString,ByteString)
-- * Ordered ByteStrings
sort, -- :: ByteString -> ByteString
-- * Low level conversions
-- ** Copying ByteStrings
copy, -- :: ByteString -> ByteString
-- ** Packing 'CString's and pointers
packCString, -- :: CString -> IO ByteString
packCStringLen, -- :: CStringLen -> IO ByteString
-- ** Using ByteStrings as 'CString's
useAsCString, -- :: ByteString -> (CString -> IO a) -> IO a
useAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a
-- * I\/O with 'ByteString's
-- ** Standard input and output
getLine, -- :: IO ByteString
getContents, -- :: IO ByteString
putStr, -- :: ByteString -> IO ()
putStrLn, -- :: ByteString -> IO ()
interact, -- :: (ByteString -> ByteString) -> IO ()
-- ** Files
readFile, -- :: FilePath -> IO ByteString
writeFile, -- :: FilePath -> ByteString -> IO ()
appendFile, -- :: FilePath -> ByteString -> IO ()
-- ** I\/O with Handles
hGetLine, -- :: Handle -> IO ByteString
hGetContents, -- :: Handle -> IO ByteString
hGet, -- :: Handle -> Int -> IO ByteString
hGetSome, -- :: Handle -> Int -> IO ByteString
hGetNonBlocking, -- :: Handle -> Int -> IO ByteString
hPut, -- :: Handle -> ByteString -> IO ()
hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString
hPutStr, -- :: Handle -> ByteString -> IO ()
hPutStrLn, -- :: Handle -> ByteString -> IO ()
breakByte
) where
import qualified Prelude as P
import Prelude hiding (reverse,head,tail,last,init,null
,length,map,lines,foldl,foldr,unlines
,concat,any,take,drop,splitAt,takeWhile
,dropWhile,span,break,elem,filter,maximum
,minimum,all,concatMap,foldl1,foldr1
,scanl,scanl1,scanr,scanr1
,readFile,writeFile,appendFile,replicate
,getContents,getLine,putStr,putStrLn,interact
,zip,zipWith,unzip,notElem)
import Data.ByteString.Internal
import Data.ByteString.Unsafe
import qualified Data.List as List
import Data.Word (Word8)
import Data.Maybe (isJust, listToMaybe)
-- Control.Exception.assert not available in yhc or nhc
#ifndef __NHC__
import Control.Exception (finally, bracket, assert, throwIO)
#else
import Control.Exception (bracket, finally)
#endif
import Control.Monad (when)
import Foreign.C.String (CString, CStringLen)
import Foreign.C.Types (CSize)
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc (allocaBytes, mallocBytes, reallocBytes, finalizerFree)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Ptr
import Foreign.Storable (Storable(..))
-- hGetBuf and hPutBuf not available in yhc or nhc
import System.IO (stdin,stdout,hClose,hFileSize
,hGetBuf,hPutBuf,openBinaryFile
,IOMode(..))
import System.IO.Error (mkIOError, illegalOperationErrorType)
import Data.Monoid (Monoid(..))
#if !defined(__GLASGOW_HASKELL__)
import System.IO.Unsafe
import qualified System.Environment
import qualified System.IO (hGetLine)
import System.IO (hIsEOF)
#endif
#if defined(__GLASGOW_HASKELL__)
import System.IO (hGetBufNonBlocking, hPutBufNonBlocking)
#if MIN_VERSION_base(4,3,0)
import System.IO (hGetBufSome)
#else
import System.IO (hWaitForInput, hIsEOF)
#endif
#if __GLASGOW_HASKELL__ >= 611
import Data.IORef
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types
import GHC.IO.Buffer
import GHC.IO.BufferedIO as Buffered
import GHC.IO (unsafePerformIO, unsafeDupablePerformIO)
import Data.Char (ord)
import Foreign.Marshal.Utils (copyBytes)
#else
import System.IO.Error (isEOFError)
import GHC.IOBase
import GHC.Handle
#endif
import GHC.Prim (Word#)
import GHC.Base (build)
import GHC.Word hiding (Word8)
#endif
-- An alternative to Control.Exception (assert) for nhc98
#ifdef __NHC__
import System.IO (Handle)
#define assert assertS "__FILE__ : __LINE__"
assertS :: String -> Bool -> a -> a
assertS _ True = id
assertS s False = error ("assertion failed at "++s)
-- An alternative to hWaitForInput
hWaitForInput :: Handle -> Int -> IO ()
hWaitForInput _ _ = return ()
#endif
#ifndef __GLASGOW_HASKELL__
unsafeDupablePerformIO = unsafePerformIO
#endif
-- -----------------------------------------------------------------------------
--
-- Useful macros, until we have bang patterns
--
#define STRICT1(f) f a | a `seq` False = undefined
#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
-- -----------------------------------------------------------------------------
-- Introducing and eliminating 'ByteString's
-- | /O(1)/ The empty 'ByteString'
empty :: ByteString
empty = PS nullForeignPtr 0 0
-- | /O(1)/ Convert a 'Word8' into a 'ByteString'
singleton :: Word8 -> ByteString
singleton c = unsafeCreate 1 $ \p -> poke p c
{-# INLINE [1] singleton #-}
-- Inline [1] for intercalate rule
--
-- XXX The use of unsafePerformIO in allocating functions (unsafeCreate) is critical!
--
-- Otherwise:
--
-- singleton 255 `compare` singleton 127
--
-- is compiled to:
--
-- case mallocByteString 2 of
-- ForeignPtr f internals ->
-- case writeWord8OffAddr# f 0 255 of _ ->
-- case writeWord8OffAddr# f 0 127 of _ ->
-- case eqAddr# f f of
-- False -> case compare (GHC.Prim.plusAddr# f 0)
-- (GHC.Prim.plusAddr# f 0)
--
--
-- | /O(n)/ Convert a '[Word8]' into a 'ByteString'.
--
-- For applications with large numbers of string literals, pack can be a
-- bottleneck. In such cases, consider using packAddress (GHC only).
pack :: [Word8] -> ByteString
pack = packBytes
-- | /O(n)/ Converts a 'ByteString' to a '[Word8]'.
unpack :: ByteString -> [Word8]
#if !defined(__GLASGOW_HASKELL__)
unpack = unpackBytes
#else
unpack ps = build (unpackFoldr ps)
{-# INLINE unpack #-}
--
-- Have unpack fuse with good list consumers
--
-- critical this isn't strict in the acc
-- as it will break in the presence of list fusion. this is a known
-- issue with seq and build/foldr rewrite rules, which rely on lazy
-- demanding to avoid bottoms in the list.
--
unpackFoldr :: ByteString -> (Word8 -> a -> a) -> a -> a
unpackFoldr (PS fp off len) f ch = withPtr fp $ \p -> do
let loop q n _ | q `seq` n `seq` False = undefined -- n.b.
loop _ (-1) acc = return acc
loop q n acc = do
a <- peekByteOff q n
loop q (n-1) (a `f` acc)
loop (p `plusPtr` off) (len-1) ch
{-# INLINE [0] unpackFoldr #-}
{-# RULES
"ByteString unpack-list" [1] forall p .
unpackFoldr p (:) [] = unpackBytes p
#-}
#endif
-- ---------------------------------------------------------------------
-- Basic interface
-- | /O(1)/ Test whether a ByteString is empty.
null :: ByteString -> Bool
null (PS _ _ l) = assert (l >= 0) $ l <= 0
{-# INLINE null #-}
-- ---------------------------------------------------------------------
-- | /O(1)/ 'length' returns the length of a ByteString as an 'Int'.
length :: ByteString -> Int
length (PS _ _ l) = assert (l >= 0) $ l
{-# INLINE length #-}
------------------------------------------------------------------------
infixr 5 `cons` --same as list (:)
infixl 5 `snoc`
-- | /O(n)/ 'cons' is analogous to (:) for lists, but of different
-- complexity, as it requires a memcpy.
cons :: Word8 -> ByteString -> ByteString
cons c (PS x s l) = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do
poke p c
memcpy (p `plusPtr` 1) (f `plusPtr` s) (fromIntegral l)
{-# INLINE cons #-}
-- | /O(n)/ Append a byte to the end of a 'ByteString'
snoc :: ByteString -> Word8 -> ByteString
snoc (PS x s l) c = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do
memcpy p (f `plusPtr` s) (fromIntegral l)
poke (p `plusPtr` l) c
{-# INLINE snoc #-}
-- todo fuse
-- | /O(1)/ Extract the first element of a ByteString, which must be non-empty.
-- An exception will be thrown in the case of an empty ByteString.
head :: ByteString -> Word8
head (PS x s l)
| l <= 0 = errorEmptyList "head"
| otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p s
{-# INLINE head #-}
-- | /O(1)/ Extract the elements after the head of a ByteString, which must be non-empty.
-- An exception will be thrown in the case of an empty ByteString.
tail :: ByteString -> ByteString
tail (PS p s l)
| l <= 0 = errorEmptyList "tail"
| otherwise = PS p (s+1) (l-1)
{-# INLINE tail #-}
-- | /O(1)/ Extract the head and tail of a ByteString, returning Nothing
-- if it is empty.
uncons :: ByteString -> Maybe (Word8, ByteString)
uncons (PS x s l)
| l <= 0 = Nothing
| otherwise = Just (inlinePerformIO $ withForeignPtr x
$ \p -> peekByteOff p s,
PS x (s+1) (l-1))
{-# INLINE uncons #-}
-- | /O(1)/ Extract the last element of a ByteString, which must be finite and non-empty.
-- An exception will be thrown in the case of an empty ByteString.
last :: ByteString -> Word8
last ps@(PS x s l)
| null ps = errorEmptyList "last"
| otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p (s+l-1)
{-# INLINE last #-}
-- | /O(1)/ Return all the elements of a 'ByteString' except the last one.
-- An exception will be thrown in the case of an empty ByteString.
init :: ByteString -> ByteString
init ps@(PS p s l)
| null ps = errorEmptyList "init"
| otherwise = PS p s (l-1)
{-# INLINE init #-}
-- | /O(n)/ Append two ByteStrings
append :: ByteString -> ByteString -> ByteString
append = mappend
{-# INLINE append #-}
-- ---------------------------------------------------------------------
-- Transformations
-- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each
-- element of @xs@.
map :: (Word8 -> Word8) -> ByteString -> ByteString
map f (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a ->
create len $ map_ 0 (a `plusPtr` s)
where
map_ :: Int -> Ptr Word8 -> Ptr Word8 -> IO ()
STRICT3(map_)
map_ n p1 p2
| n >= len = return ()
| otherwise = do
x <- peekByteOff p1 n
pokeByteOff p2 n (f x)
map_ (n+1) p1 p2
{-# INLINE map #-}
-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order.
reverse :: ByteString -> ByteString
reverse (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f ->
c_reverse p (f `plusPtr` s) (fromIntegral l)
-- | /O(n)/ The 'intersperse' function takes a 'Word8' and a
-- 'ByteString' and \`intersperses\' that byte between the elements of
-- the 'ByteString'. It is analogous to the intersperse function on
-- Lists.
intersperse :: Word8 -> ByteString -> ByteString
intersperse c ps@(PS x s l)
| length ps < 2 = ps
| otherwise = unsafeCreate (2*l-1) $ \p -> withForeignPtr x $ \f ->
c_intersperse p (f `plusPtr` s) (fromIntegral l) c
-- | The 'transpose' function transposes the rows and columns of its
-- 'ByteString' argument.
transpose :: [ByteString] -> [ByteString]
transpose ps = P.map pack (List.transpose (P.map unpack ps))
-- ---------------------------------------------------------------------
-- Reducing 'ByteString's
-- | 'foldl', applied to a binary operator, a starting value (typically
-- the left-identity of the operator), and a ByteString, reduces the
-- ByteString using the binary operator, from left to right.
--
foldl :: (a -> Word8 -> a) -> a -> ByteString -> a
foldl f v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->
lgo v (ptr `plusPtr` s) (ptr `plusPtr` (s+l))
where
STRICT3(lgo)
lgo z p q | p == q = return z
| otherwise = do c <- peek p
lgo (f z c) (p `plusPtr` 1) q
{-# INLINE foldl #-}
-- | 'foldl\'' is like 'foldl', but strict in the accumulator.
-- However, for ByteStrings, all left folds are strict in the accumulator.
--
foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a
foldl' = foldl
{-# INLINE foldl' #-}
-- | 'foldr', applied to a binary operator, a starting value
-- (typically the right-identity of the operator), and a ByteString,
-- reduces the ByteString using the binary operator, from right to left.
foldr :: (Word8 -> a -> a) -> a -> ByteString -> a
foldr k v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->
go v (ptr `plusPtr` (s+l-1)) (ptr `plusPtr` (s-1))
where
STRICT3(go)
go z p q | p == q = return z
| otherwise = do c <- peek p
go (c `k` z) (p `plusPtr` (-1)) q -- tail recursive
{-# INLINE foldr #-}
-- | 'foldr\'' is like 'foldr', but strict in the accumulator.
foldr' :: (Word8 -> a -> a) -> a -> ByteString -> a
foldr' k v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->
go v (ptr `plusPtr` (s+l-1)) (ptr `plusPtr` (s-1))
where
STRICT3(go)
go z p q | p == q = return z
| otherwise = do c <- peek p
go (c `k` z) (p `plusPtr` (-1)) q -- tail recursive
{-# INLINE foldr' #-}
-- | 'foldl1' is a variant of 'foldl' that has no starting value
-- argument, and thus must be applied to non-empty 'ByteStrings'.
-- An exception will be thrown in the case of an empty ByteString.
foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
foldl1 f ps
| null ps = errorEmptyList "foldl1"
| otherwise = foldl f (unsafeHead ps) (unsafeTail ps)
{-# INLINE foldl1 #-}
-- | 'foldl1\'' is like 'foldl1', but strict in the accumulator.
-- An exception will be thrown in the case of an empty ByteString.
foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
foldl1' f ps
| null ps = errorEmptyList "foldl1'"
| otherwise = foldl' f (unsafeHead ps) (unsafeTail ps)
{-# INLINE foldl1' #-}
-- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
-- and thus must be applied to non-empty 'ByteString's
-- An exception will be thrown in the case of an empty ByteString.
foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
foldr1 f ps
| null ps = errorEmptyList "foldr1"
| otherwise = foldr f (last ps) (init ps)
{-# INLINE foldr1 #-}
-- | 'foldr1\'' is a variant of 'foldr1', but is strict in the
-- accumulator.
foldr1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8
foldr1' f ps
| null ps = errorEmptyList "foldr1"
| otherwise = foldr' f (last ps) (init ps)
{-# INLINE foldr1' #-}
-- ---------------------------------------------------------------------
-- Special folds
-- | /O(n)/ Concatenate a list of ByteStrings.
concat :: [ByteString] -> ByteString
concat = mconcat
-- | Map a function over a 'ByteString' and concatenate the results
concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString
concatMap f = concat . foldr ((:) . f) []
-- foldr (append . f) empty
-- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if
-- any element of the 'ByteString' satisfies the predicate.
any :: (Word8 -> Bool) -> ByteString -> Bool
any _ (PS _ _ 0) = False
any f (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->
go (ptr `plusPtr` s) (ptr `plusPtr` (s+l))
where
STRICT2(go)
go p q | p == q = return False
| otherwise = do c <- peek p
if f c then return True
else go (p `plusPtr` 1) q
{-# INLINE any #-}
-- todo fuse
-- | /O(n)/ Applied to a predicate and a 'ByteString', 'all' determines
-- if all elements of the 'ByteString' satisfy the predicate.
all :: (Word8 -> Bool) -> ByteString -> Bool
all _ (PS _ _ 0) = True
all f (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->
go (ptr `plusPtr` s) (ptr `plusPtr` (s+l))
where
STRICT2(go)
go p q | p == q = return True -- end of list
| otherwise = do c <- peek p
if f c
then go (p `plusPtr` 1) q
else return False
{-# INLINE all #-}
------------------------------------------------------------------------
-- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString'
-- This function will fuse.
-- An exception will be thrown in the case of an empty ByteString.
maximum :: ByteString -> Word8
maximum xs@(PS x s l)
| null xs = errorEmptyList "maximum"
| otherwise = inlinePerformIO $ withForeignPtr x $ \p ->
c_maximum (p `plusPtr` s) (fromIntegral l)
{-# INLINE maximum #-}
-- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString'
-- This function will fuse.
-- An exception will be thrown in the case of an empty ByteString.
minimum :: ByteString -> Word8
minimum xs@(PS x s l)
| null xs = errorEmptyList "minimum"
| otherwise = inlinePerformIO $ withForeignPtr x $ \p ->
c_minimum (p `plusPtr` s) (fromIntegral l)
{-# INLINE minimum #-}
------------------------------------------------------------------------
-- | The 'mapAccumL' function behaves like a combination of 'map' and
-- 'foldl'; it applies a function to each element of a ByteString,
-- passing an accumulating parameter from left to right, and returning a
-- final value of this accumulator together with the new list.
mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
mapAccumL f acc (PS fp o len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> do
gp <- mallocByteString len
acc' <- withForeignPtr gp $ \p -> mapAccumL_ acc 0 (a `plusPtr` o) p
return $! (acc', PS gp 0 len)
where
STRICT4(mapAccumL_)
mapAccumL_ s n p1 p2
| n >= len = return s
| otherwise = do
x <- peekByteOff p1 n
let (s', y) = f s x
pokeByteOff p2 n y
mapAccumL_ s' (n+1) p1 p2
{-# INLINE mapAccumL #-}
-- | The 'mapAccumR' function behaves like a combination of 'map' and
-- 'foldr'; it applies a function to each element of a ByteString,
-- passing an accumulating parameter from right to left, and returning a
-- final value of this accumulator together with the new ByteString.
mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)
mapAccumR f acc (PS fp o len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> do
gp <- mallocByteString len
acc' <- withForeignPtr gp $ \p -> mapAccumR_ acc (len-1) (a `plusPtr` o) p
return $! (acc', PS gp 0 len)
where
STRICT4(mapAccumR_)
mapAccumR_ s n p q
| n < 0 = return s
| otherwise = do
x <- peekByteOff p n
let (s', y) = f s x
pokeByteOff q n y
mapAccumR_ s' (n-1) p q
{-# INLINE mapAccumR #-}
-- ---------------------------------------------------------------------
-- Building ByteStrings
-- | 'scanl' is similar to 'foldl', but returns a list of successive
-- reduced values from the left. This function will fuse.
--
-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
--
-- Note that
--
-- > last (scanl f z xs) == foldl f z xs.
--
scanl :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
scanl f v (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a ->
create (len+1) $ \q -> do
poke q v
scanl_ v 0 (a `plusPtr` s) (q `plusPtr` 1)
where
STRICT4(scanl_)
scanl_ z n p q
| n >= len = return ()
| otherwise = do
x <- peekByteOff p n
let z' = f z x
pokeByteOff q n z'
scanl_ z' (n+1) p q
{-# INLINE scanl #-}
-- n.b. haskell's List scan returns a list one bigger than the
-- input, so we need to snoc here to get some extra space, however,
-- it breaks map/up fusion (i.e. scanl . map no longer fuses)
-- | 'scanl1' is a variant of 'scanl' that has no starting value argument.
-- This function will fuse.
--
-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
scanl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
scanl1 f ps
| null ps = empty
| otherwise = scanl f (unsafeHead ps) (unsafeTail ps)
{-# INLINE scanl1 #-}
-- | scanr is the right-to-left dual of scanl.
scanr :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString
scanr f v (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a ->
create (len+1) $ \q -> do
poke (q `plusPtr` len) v
scanr_ v (len-1) (a `plusPtr` s) q
where
STRICT4(scanr_)
scanr_ z n p q
| n < 0 = return ()
| otherwise = do
x <- peekByteOff p n
let z' = f x z
pokeByteOff q n z'
scanr_ z' (n-1) p q
{-# INLINE scanr #-}
-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
scanr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString
scanr1 f ps
| null ps = empty
| otherwise = scanr f (last ps) (init ps) -- todo, unsafe versions
{-# INLINE scanr1 #-}
-- ---------------------------------------------------------------------
-- Unfolds and replicates
-- | /O(n)/ 'replicate' @n x@ is a ByteString of length @n@ with @x@
-- the value of every element. The following holds:
--
-- > replicate w c = unfoldr w (\u -> Just (u,u)) c
--
-- This implemenation uses @memset(3)@
replicate :: Int -> Word8 -> ByteString
replicate w c
| w <= 0 = empty
| otherwise = unsafeCreate w $ \ptr ->
memset ptr c (fromIntegral w) >> return ()
-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr'
-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a
-- ByteString from a seed value. The function takes the element and
-- returns 'Nothing' if it is done producing the ByteString or returns
-- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string,
-- and @b@ is the seed value for further production.
--
-- Examples:
--
-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0
-- > == pack [0, 1, 2, 3, 4, 5]
--
unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString
unfoldr f = concat . unfoldChunk 32 64
where unfoldChunk n n' x =
case unfoldrN n f x of
(s, Nothing) -> s : []
(s, Just x') -> s : unfoldChunk n' (n+n') x'
{-# INLINE unfoldr #-}
-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ByteString from a seed
-- value. However, the length of the result is limited by the first
-- argument to 'unfoldrN'. This function is more efficient than 'unfoldr'
-- when the maximum length of the result is known.
--
-- The following equation relates 'unfoldrN' and 'unfoldr':
--
-- > fst (unfoldrN n f s) == take n (unfoldr f s)
--
unfoldrN :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a)
unfoldrN i f x0
| i < 0 = (empty, Just x0)
| otherwise = unsafePerformIO $ createAndTrim' i $ \p -> go p x0 0
where STRICT3(go)
go p x n =
case f x of
Nothing -> return (0, n, Nothing)
Just (w,x')
| n == i -> return (0, n, Just x)
| otherwise -> do poke p w
go (p `plusPtr` 1) x' (n+1)
{-# INLINE unfoldrN #-}
-- ---------------------------------------------------------------------
-- Substrings
-- | /O(1)/ 'take' @n@, applied to a ByteString @xs@, returns the prefix
-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@.
take :: Int -> ByteString -> ByteString
take n ps@(PS x s l)
| n <= 0 = empty
| n >= l = ps
| otherwise = PS x s n
{-# INLINE take #-}
-- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@
-- elements, or @[]@ if @n > 'length' xs@.
drop :: Int -> ByteString -> ByteString
drop n ps@(PS x s l)
| n <= 0 = ps
| n >= l = empty
| otherwise = PS x (s+n) (l-n)
{-# INLINE drop #-}
-- | /O(1)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@.
splitAt :: Int -> ByteString -> (ByteString, ByteString)
splitAt n ps@(PS x s l)
| n <= 0 = (empty, ps)
| n >= l = (ps, empty)
| otherwise = (PS x s n, PS x (s+n) (l-n))
{-# INLINE splitAt #-}
-- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@,
-- returns the longest prefix (possibly empty) of @xs@ of elements that
-- satisfy @p@.
takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString
takeWhile f ps = unsafeTake (findIndexOrEnd (not . f) ps) ps
{-# INLINE takeWhile #-}
-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.
dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString
dropWhile f ps = unsafeDrop (findIndexOrEnd (not . f) ps) ps
{-# INLINE dropWhile #-}
-- instead of findIndexOrEnd, we could use memchr here.
-- | 'break' @p@ is equivalent to @'span' ('not' . p)@.
--
-- Under GHC, a rewrite rule will transform break (==) into a
-- call to the specialised breakByte:
--
-- > break ((==) x) = breakByte x
-- > break (==x) = breakByte x
--
break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
break p ps = case findIndexOrEnd p ps of n -> (unsafeTake n ps, unsafeDrop n ps)
#if __GLASGOW_HASKELL__
{-# INLINE [1] break #-}
#endif
{-# RULES
"ByteString specialise break (x==)" forall x.
break ((==) x) = breakByte x
"ByteString specialise break (==x)" forall x.
break (==x) = breakByte x
#-}
-- INTERNAL:
-- | 'breakByte' breaks its ByteString argument at the first occurence
-- of the specified byte. It is more efficient than 'break' as it is
-- implemented with @memchr(3)@. I.e.
--
-- > break (=='c') "abcd" == breakByte 'c' "abcd"
--
breakByte :: Word8 -> ByteString -> (ByteString, ByteString)
breakByte c p = case elemIndex c p of
Nothing -> (p,empty)
Just n -> (unsafeTake n p, unsafeDrop n p)
{-# INLINE breakByte #-}
-- | 'breakEnd' behaves like 'break' but from the end of the 'ByteString'
--
-- breakEnd p == spanEnd (not.p)
breakEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
breakEnd p ps = splitAt (findFromEndUntil p ps) ps
-- | 'span' @p xs@ breaks the ByteString into two segments. It is
-- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@
span :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
span p ps = break (not . p) ps
#if __GLASGOW_HASKELL__
{-# INLINE [1] span #-}
#endif
-- | 'spanByte' breaks its ByteString argument at the first
-- occurence of a byte other than its argument. It is more efficient
-- than 'span (==)'
--
-- > span (=='c') "abcd" == spanByte 'c' "abcd"
--
spanByte :: Word8 -> ByteString -> (ByteString, ByteString)
spanByte c ps@(PS x s l) = inlinePerformIO $ withForeignPtr x $ \p ->
go (p `plusPtr` s) 0
where
STRICT2(go)
go p i | i >= l = return (ps, empty)
| otherwise = do c' <- peekByteOff p i
if c /= c'
then return (unsafeTake i ps, unsafeDrop i ps)
else go p (i+1)
{-# INLINE spanByte #-}
{-# RULES
"ByteString specialise span (x==)" forall x.
span ((==) x) = spanByte x
"ByteString specialise span (==x)" forall x.
span (==x) = spanByte x
#-}
-- | 'spanEnd' behaves like 'span' but from the end of the 'ByteString'.
-- We have
--
-- > spanEnd (not.isSpace) "x y z" == ("x y ","z")
--
-- and
--
-- > spanEnd (not . isSpace) ps
-- > ==
-- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x)
--
spanEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
spanEnd p ps = splitAt (findFromEndUntil (not.p) ps) ps
-- | /O(n)/ Splits a 'ByteString' into components delimited by
-- separators, where the predicate returns True for a separator element.
-- The resulting components do not contain the separators. Two adjacent
-- separators result in an empty component in the output. eg.
--
-- > splitWith (=='a') "aabbaca" == ["","","bb","c",""]
-- > splitWith (=='a') [] == []
--
splitWith :: (Word8 -> Bool) -> ByteString -> [ByteString]
#if defined(__GLASGOW_HASKELL__)
splitWith _pred (PS _ _ 0) = []
splitWith pred_ (PS fp off len) = splitWith0 pred# off len fp
where pred# c# = pred_ (W8# c#)
STRICT4(splitWith0)
splitWith0 pred' off' len' fp' = withPtr fp $ \p ->
splitLoop pred' p 0 off' len' fp'
splitLoop :: (Word# -> Bool)
-> Ptr Word8
-> Int -> Int -> Int
-> ForeignPtr Word8
-> IO [ByteString]
splitLoop pred' p idx' off' len' fp'
| idx' >= len' = return [PS fp' off' idx']
| otherwise = do
w <- peekElemOff p (off'+idx')
if pred' (case w of W8# w# -> w#)
then return (PS fp' off' idx' :
splitWith0 pred' (off'+idx'+1) (len'-idx'-1) fp')
else splitLoop pred' p (idx'+1) off' len' fp'
{-# INLINE splitWith #-}
#else
splitWith _ (PS _ _ 0) = []
splitWith p ps = loop p ps
where
STRICT2(loop)
loop q qs = if null rest then [chunk]
else chunk : loop q (unsafeTail rest)
where (chunk,rest) = break q qs
#endif
-- | /O(n)/ Break a 'ByteString' into pieces separated by the byte
-- argument, consuming the delimiter. I.e.
--
-- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"]
-- > split 'a' "aXaXaXa" == ["","X","X","X",""]
-- > split 'x' "x" == ["",""]
--
-- and
--
-- > intercalate [c] . split c == id
-- > split == splitWith . (==)
--
-- As for all splitting functions in this library, this function does
-- not copy the substrings, it just constructs new 'ByteStrings' that
-- are slices of the original.
--
split :: Word8 -> ByteString -> [ByteString]
split _ (PS _ _ 0) = []
split w (PS x s l) = loop 0
where
STRICT1(loop)
loop n =
let q = inlinePerformIO $ withForeignPtr x $ \p ->
memchr (p `plusPtr` (s+n))
w (fromIntegral (l-n))
in if q == nullPtr
then [PS x (s+n) (l-n)]
else let i = inlinePerformIO $ withForeignPtr x $ \p ->
return (q `minusPtr` (p `plusPtr` s))
in PS x (s+n) (i-n) : loop (i+1)
{-# INLINE split #-}
{-
-- slower. but stays inside Haskell.
split _ (PS _ _ 0) = []
split (W8# w#) (PS fp off len) = splitWith' off len fp
where
splitWith' off' len' fp' = withPtr fp $ \p ->
splitLoop p 0 off' len' fp'
splitLoop :: Ptr Word8
-> Int -> Int -> Int
-> ForeignPtr Word8
-> IO [ByteString]
STRICT5(splitLoop)
splitLoop p idx' off' len' fp'
| idx' >= len' = return [PS fp' off' idx']
| otherwise = do
(W8# x#) <- peekElemOff p (off'+idx')
if word2Int# w# ==# word2Int# x#
then return (PS fp' off' idx' :
splitWith' (off'+idx'+1) (len'-idx'-1) fp')
else splitLoop p (idx'+1) off' len' fp'
-}
{-
-- | Like 'splitWith', except that sequences of adjacent separators are
-- treated as a single separator. eg.
--
-- > tokens (=='a') "aabbaca" == ["bb","c"]
--
tokens :: (Word8 -> Bool) -> ByteString -> [ByteString]
tokens f = P.filter (not.null) . splitWith f
{-# INLINE tokens #-}
-}
-- | The 'group' function takes a ByteString and returns a list of
-- ByteStrings such that the concatenation of the result is equal to the
-- argument. Moreover, each sublist in the result contains only equal
-- elements. For example,
--
-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]
--
-- It is a special case of 'groupBy', which allows the programmer to
-- supply their own equality test. It is about 40% faster than
-- /groupBy (==)/
group :: ByteString -> [ByteString]
group xs
| null xs = []
| otherwise = ys : group zs
where
(ys, zs) = spanByte (unsafeHead xs) xs
-- | The 'groupBy' function is the non-overloaded version of 'group'.
groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString]
groupBy k xs
| null xs = []
| otherwise = unsafeTake n xs : groupBy k (unsafeDrop n xs)
where
n = 1 + findIndexOrEnd (not . k (unsafeHead xs)) (unsafeTail xs)
-- | /O(n)/ The 'intercalate' function takes a 'ByteString' and a list of
-- 'ByteString's and concatenates the list after interspersing the first
-- argument between each element of the list.
intercalate :: ByteString -> [ByteString] -> ByteString
intercalate s = concat . (List.intersperse s)
{-# INLINE [1] intercalate #-}
{-# RULES
"ByteString specialise intercalate c -> intercalateByte" forall c s1 s2 .
intercalate (singleton c) (s1 : s2 : []) = intercalateWithByte c s1 s2
#-}
-- | /O(n)/ intercalateWithByte. An efficient way to join to two ByteStrings
-- with a char. Around 4 times faster than the generalised join.
--
intercalateWithByte :: Word8 -> ByteString -> ByteString -> ByteString
intercalateWithByte c f@(PS ffp s l) g@(PS fgp t m) = unsafeCreate len $ \ptr ->
withForeignPtr ffp $ \fp ->
withForeignPtr fgp $ \gp -> do
memcpy ptr (fp `plusPtr` s) (fromIntegral l)
poke (ptr `plusPtr` l) c
memcpy (ptr `plusPtr` (l + 1)) (gp `plusPtr` t) (fromIntegral m)
where
len = length f + length g + 1
{-# INLINE intercalateWithByte #-}
-- ---------------------------------------------------------------------
-- Indexing ByteStrings
-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0.
index :: ByteString -> Int -> Word8
index ps n
| n < 0 = moduleError "index" ("negative index: " ++ show n)
| n >= length ps = moduleError "index" ("index too large: " ++ show n
++ ", length = " ++ show (length ps))
| otherwise = ps `unsafeIndex` n
{-# INLINE index #-}
-- | /O(n)/ The 'elemIndex' function returns the index of the first
-- element in the given 'ByteString' which is equal to the query
-- element, or 'Nothing' if there is no such element.
-- This implementation uses memchr(3).
elemIndex :: Word8 -> ByteString -> Maybe Int
elemIndex c (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do
let p' = p `plusPtr` s
q <- memchr p' c (fromIntegral l)
return $! if q == nullPtr then Nothing else Just $! q `minusPtr` p'
{-# INLINE elemIndex #-}
-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the
-- element in the given 'ByteString' which is equal to the query
-- element, or 'Nothing' if there is no such element. The following
-- holds:
--
-- > elemIndexEnd c xs ==
-- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs)
--
elemIndexEnd :: Word8 -> ByteString -> Maybe Int
elemIndexEnd ch (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p ->
go (p `plusPtr` s) (l-1)
where
STRICT2(go)
go p i | i < 0 = return Nothing
| otherwise = do ch' <- peekByteOff p i
if ch == ch'
then return $ Just i
else go p (i-1)
{-# INLINE elemIndexEnd #-}
-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning
-- the indices of all elements equal to the query element, in ascending order.
-- This implementation uses memchr(3).
elemIndices :: Word8 -> ByteString -> [Int]
elemIndices w (PS x s l) = loop 0
where
STRICT1(loop)
loop n = let q = inlinePerformIO $ withForeignPtr x $ \p ->
memchr (p `plusPtr` (n+s))
w (fromIntegral (l - n))
in if q == nullPtr
then []
else let i = inlinePerformIO $ withForeignPtr x $ \p ->
return (q `minusPtr` (p `plusPtr` s))
in i : loop (i+1)
{-# INLINE elemIndices #-}
{-
-- much slower
elemIndices :: Word8 -> ByteString -> [Int]
elemIndices c ps = loop 0 ps
where STRICT2(loop)
loop _ ps' | null ps' = []
loop n ps' | c == unsafeHead ps' = n : loop (n+1) (unsafeTail ps')
| otherwise = loop (n+1) (unsafeTail ps')
-}
-- | count returns the number of times its argument appears in the ByteString
--
-- > count = length . elemIndices
--
-- But more efficiently than using length on the intermediate list.
count :: Word8 -> ByteString -> Int
count w (PS x s m) = inlinePerformIO $ withForeignPtr x $ \p ->
fmap fromIntegral $ c_count (p `plusPtr` s) (fromIntegral m) w
{-# INLINE count #-}
{-
--
-- around 30% slower
--
count w (PS x s m) = inlinePerformIO $ withForeignPtr x $ \p ->
go (p `plusPtr` s) (fromIntegral m) 0
where
go :: Ptr Word8 -> CSize -> Int -> IO Int
STRICT3(go)
go p l i = do
q <- memchr p w l
if q == nullPtr
then return i
else do let k = fromIntegral $ q `minusPtr` p
go (q `plusPtr` 1) (l-k-1) (i+1)
-}
-- | The 'findIndex' function takes a predicate and a 'ByteString' and
-- returns the index of the first element in the ByteString
-- satisfying the predicate.
findIndex :: (Word8 -> Bool) -> ByteString -> Maybe Int
findIndex k (PS x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0
where
STRICT2(go)
go ptr n | n >= l = return Nothing
| otherwise = do w <- peek ptr
if k w
then return (Just n)
else go (ptr `plusPtr` 1) (n+1)
{-# INLINE findIndex #-}
-- | The 'findIndices' function extends 'findIndex', by returning the
-- indices of all elements satisfying the predicate, in ascending order.
findIndices :: (Word8 -> Bool) -> ByteString -> [Int]
findIndices p ps = loop 0 ps
where
STRICT2(loop)
loop n qs | null qs = []
| p (unsafeHead qs) = n : loop (n+1) (unsafeTail qs)
| otherwise = loop (n+1) (unsafeTail qs)
-- ---------------------------------------------------------------------
-- Searching ByteStrings
-- | /O(n)/ 'elem' is the 'ByteString' membership predicate.
elem :: Word8 -> ByteString -> Bool
elem c ps = case elemIndex c ps of Nothing -> False ; _ -> True
{-# INLINE elem #-}
-- | /O(n)/ 'notElem' is the inverse of 'elem'
notElem :: Word8 -> ByteString -> Bool
notElem c ps = not (elem c ps)
{-# INLINE notElem #-}
-- | /O(n)/ 'filter', applied to a predicate and a ByteString,
-- returns a ByteString containing those characters that satisfy the
-- predicate.
filter :: (Word8 -> Bool) -> ByteString -> ByteString
filter k ps@(PS x s l)
| null ps = ps
| otherwise = unsafePerformIO $ createAndTrim l $ \p -> withForeignPtr x $ \f -> do
t <- go (f `plusPtr` s) p (f `plusPtr` (s + l))
return $! t `minusPtr` p -- actual length
where
STRICT3(go)
go f t end | f == end = return t
| otherwise = do
w <- peek f
if k w
then poke t w >> go (f `plusPtr` 1) (t `plusPtr` 1) end
else go (f `plusPtr` 1) t end
{-# INLINE filter #-}
{-
--
-- | /O(n)/ A first order equivalent of /filter . (==)/, for the common
-- case of filtering a single byte. It is more efficient to use
-- /filterByte/ in this case.
--
-- > filterByte == filter . (==)
--
-- filterByte is around 10x faster, and uses much less space, than its
-- filter equivalent
--
filterByte :: Word8 -> ByteString -> ByteString
filterByte w ps = replicate (count w ps) w
{-# INLINE filterByte #-}
{-# RULES
"ByteString specialise filter (== x)" forall x.
filter ((==) x) = filterByte x
"ByteString specialise filter (== x)" forall x.
filter (== x) = filterByte x
#-}
-}
-- | /O(n)/ The 'find' function takes a predicate and a ByteString,
-- and returns the first element in matching the predicate, or 'Nothing'
-- if there is no such element.
--
-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing
--
find :: (Word8 -> Bool) -> ByteString -> Maybe Word8
find f p = case findIndex f p of
Just n -> Just (p `unsafeIndex` n)
_ -> Nothing
{-# INLINE find #-}
{-
--
-- fuseable, but we don't want to walk the whole array.
--
find k = foldl findEFL Nothing
where findEFL a@(Just _) _ = a
findEFL _ c | k c = Just c
| otherwise = Nothing
-}
-- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns
-- the pair of ByteStrings with elements which do and do not satisfy the
-- predicate, respectively; i.e.,
--
-- > partition p bs == (filter p xs, filter (not . p) xs)
--
partition :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
partition p bs = (filter p bs, filter (not . p) bs)
--TODO: use a better implementation
-- ---------------------------------------------------------------------
-- Searching for substrings
-- | /O(n)/ The 'isPrefixOf' function takes two ByteStrings and returns 'True'
-- iff the first is a prefix of the second.
isPrefixOf :: ByteString -> ByteString -> Bool
isPrefixOf (PS x1 s1 l1) (PS x2 s2 l2)
| l1 == 0 = True
| l2 < l1 = False
| otherwise = inlinePerformIO $ withForeignPtr x1 $ \p1 ->
withForeignPtr x2 $ \p2 -> do
i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2) (fromIntegral l1)
return $! i == 0
-- | /O(n)/ The 'isSuffixOf' function takes two ByteStrings and returns 'True'
-- iff the first is a suffix of the second.
--
-- The following holds:
--
-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y
--
-- However, the real implemenation uses memcmp to compare the end of the
-- string only, with no reverse required..
isSuffixOf :: ByteString -> ByteString -> Bool
isSuffixOf (PS x1 s1 l1) (PS x2 s2 l2)
| l1 == 0 = True
| l2 < l1 = False
| otherwise = inlinePerformIO $ withForeignPtr x1 $ \p1 ->
withForeignPtr x2 $ \p2 -> do
i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2 `plusPtr` (l2 - l1)) (fromIntegral l1)
return $! i == 0
-- | Check whether one string is a substring of another. @isInfixOf
-- p s@ is equivalent to @not (null (findSubstrings p s))@.
isInfixOf :: ByteString -> ByteString -> Bool
isInfixOf p s = isJust (findSubstring p s)
-- | Break a string on a substring, returning a pair of the part of the
-- string prior to the match, and the rest of the string.
--
-- The following relationships hold:
--
-- > break (== c) l == breakSubstring (singleton c) l
--
-- and:
--
-- > findSubstring s l ==
-- > if null s then Just 0
-- > else case breakSubstring s l of
-- > (x,y) | null y -> Nothing
-- > | otherwise -> Just (length x)
--
-- For example, to tokenise a string, dropping delimiters:
--
-- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t)
-- > where (h,t) = breakSubstring x y
--
-- To skip to the first occurence of a string:
--
-- > snd (breakSubstring x y)
--
-- To take the parts of a string before a delimiter:
--
-- > fst (breakSubstring x y)
--
breakSubstring :: ByteString -- ^ String to search for
-> ByteString -- ^ String to search in
-> (ByteString,ByteString) -- ^ Head and tail of string broken at substring
breakSubstring pat src = search 0 src
where
STRICT2(search)
search n s
| null s = (src,empty) -- not found
| pat `isPrefixOf` s = (take n src,s)
| otherwise = search (n+1) (unsafeTail s)
-- | Get the first index of a substring in another string,
-- or 'Nothing' if the string is not found.
-- @findSubstring p s@ is equivalent to @listToMaybe (findSubstrings p s)@.
findSubstring :: ByteString -- ^ String to search for.
-> ByteString -- ^ String to seach in.
-> Maybe Int
findSubstring f i = listToMaybe (findSubstrings f i)
{-# DEPRECATED findSubstring "findSubstring is deprecated in favour of breakSubstring." #-}
{-
findSubstring pat str = search 0 str
where
STRICT2(search)
search n s
= let x = pat `isPrefixOf` s
in
if null s
then if x then Just n else Nothing
else if x then Just n
else search (n+1) (unsafeTail s)
-}
-- | Find the indexes of all (possibly overlapping) occurances of a
-- substring in a string.
--
findSubstrings :: ByteString -- ^ String to search for.
-> ByteString -- ^ String to seach in.
-> [Int]
findSubstrings pat str
| null pat = [0 .. length str]
| otherwise = search 0 str
where
STRICT2(search)
search n s
| null s = []
| pat `isPrefixOf` s = n : search (n+1) (unsafeTail s)
| otherwise = search (n+1) (unsafeTail s)
{-# DEPRECATED findSubstrings "findSubstrings is deprecated in favour of breakSubstring." #-}
{-
{- This function uses the Knuth-Morris-Pratt string matching algorithm. -}
findSubstrings pat@(PS _ _ m) str@(PS _ _ n) = search 0 0
where
patc x = pat `unsafeIndex` x
strc x = str `unsafeIndex` x
-- maybe we should make kmpNext a UArray before using it in search?
kmpNext = listArray (0,m) (-1:kmpNextL pat (-1))
kmpNextL p _ | null p = []
kmpNextL p j = let j' = next (unsafeHead p) j + 1
ps = unsafeTail p
x = if not (null ps) && unsafeHead ps == patc j'
then kmpNext Array.! j' else j'
in x:kmpNextL ps j'
search i j = match ++ rest -- i: position in string, j: position in pattern
where match = if j == m then [(i - j)] else []
rest = if i == n then [] else search (i+1) (next (strc i) j + 1)
next c j | j >= 0 && (j == m || c /= patc j) = next c (kmpNext Array.! j)
| otherwise = j
-}
-- ---------------------------------------------------------------------
-- Zipping
-- | /O(n)/ 'zip' takes two ByteStrings and returns a list of
-- corresponding pairs of bytes. If one input ByteString is short,
-- excess elements of the longer ByteString are discarded. This is
-- equivalent to a pair of 'unpack' operations.
zip :: ByteString -> ByteString -> [(Word8,Word8)]
zip ps qs
| null ps || null qs = []
| otherwise = (unsafeHead ps, unsafeHead qs) : zip (unsafeTail ps) (unsafeTail qs)
-- | 'zipWith' generalises 'zip' by zipping with the function given as
-- the first argument, instead of a tupling function. For example,
-- @'zipWith' (+)@ is applied to two ByteStrings to produce the list of
-- corresponding sums.
zipWith :: (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a]
zipWith f ps qs
| null ps || null qs = []
| otherwise = f (unsafeHead ps) (unsafeHead qs) : zipWith f (unsafeTail ps) (unsafeTail qs)
{-# NOINLINE [1] zipWith #-}
--
-- | A specialised version of zipWith for the common case of a
-- simultaneous map over two bytestrings, to build a 3rd. Rewrite rules
-- are used to automatically covert zipWith into zipWith' when a pack is
-- performed on the result of zipWith.
--
zipWith' :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString
zipWith' f (PS fp s l) (PS fq t m) = unsafeDupablePerformIO $
withForeignPtr fp $ \a ->
withForeignPtr fq $ \b ->
create len $ zipWith_ 0 (a `plusPtr` s) (b `plusPtr` t)
where
zipWith_ :: Int -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO ()
STRICT4(zipWith_)
zipWith_ n p1 p2 r
| n >= len = return ()
| otherwise = do
x <- peekByteOff p1 n
y <- peekByteOff p2 n
pokeByteOff r n (f x y)
zipWith_ (n+1) p1 p2 r
len = min l m
{-# INLINE zipWith' #-}
{-# RULES
"ByteString specialise zipWith" forall (f :: Word8 -> Word8 -> Word8) p q .
zipWith f p q = unpack (zipWith' f p q)
#-}
-- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of
-- ByteStrings. Note that this performs two 'pack' operations.
unzip :: [(Word8,Word8)] -> (ByteString,ByteString)
unzip ls = (pack (P.map fst ls), pack (P.map snd ls))
{-# INLINE unzip #-}
-- ---------------------------------------------------------------------
-- Special lists
-- | /O(n)/ Return all initial segments of the given 'ByteString', shortest first.
inits :: ByteString -> [ByteString]
inits (PS x s l) = [PS x s n | n <- [0..l]]
-- | /O(n)/ Return all final segments of the given 'ByteString', longest first.
tails :: ByteString -> [ByteString]
tails p | null p = [empty]
| otherwise = p : tails (unsafeTail p)
-- less efficent spacewise: tails (PS x s l) = [PS x (s+n) (l-n) | n <- [0..l]]
-- ---------------------------------------------------------------------
-- ** Ordered 'ByteString's
-- | /O(n)/ Sort a ByteString efficiently, using counting sort.
sort :: ByteString -> ByteString
sort (PS input s l) = unsafeCreate l $ \p -> allocaArray 256 $ \arr -> do
_ <- memset (castPtr arr) 0 (256 * fromIntegral (sizeOf (undefined :: CSize)))
withForeignPtr input (\x -> countOccurrences arr (x `plusPtr` s) l)
let STRICT2(go)
go 256 _ = return ()
go i ptr = do n <- peekElemOff arr i
when (n /= 0) $ memset ptr (fromIntegral i) n >> return ()
go (i + 1) (ptr `plusPtr` (fromIntegral n))
go 0 p
where
-- | Count the number of occurrences of each byte.
-- Used by 'sort'
--
countOccurrences :: Ptr CSize -> Ptr Word8 -> Int -> IO ()
STRICT3(countOccurrences)
countOccurrences counts str len = go 0
where
STRICT1(go)
go i | i == len = return ()
| otherwise = do k <- fromIntegral `fmap` peekElemOff str i
x <- peekElemOff counts k
pokeElemOff counts k (x + 1)
go (i + 1)
{-
sort :: ByteString -> ByteString
sort (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> do
memcpy p (f `plusPtr` s) l
c_qsort p l -- inplace
-}
-- The 'sortBy' function is the non-overloaded version of 'sort'.
--
-- Try some linear sorts: radix, counting
-- Or mergesort.
--
-- sortBy :: (Word8 -> Word8 -> Ordering) -> ByteString -> ByteString
-- sortBy f ps = undefined
-- ---------------------------------------------------------------------
-- Low level constructors
-- | /O(n) construction/ Use a @ByteString@ with a function requiring a
-- null-terminated @CString@. The @CString@ will be freed
-- automatically. This is a memcpy(3).
useAsCString :: ByteString -> (CString -> IO a) -> IO a
useAsCString (PS fp o l) action = do
allocaBytes (l+1) $ \buf ->
withForeignPtr fp $ \p -> do
memcpy buf (p `plusPtr` o) (fromIntegral l)
pokeByteOff buf l (0::Word8)
action (castPtr buf)
-- | /O(n) construction/ Use a @ByteString@ with a function requiring a @CStringLen@.
-- As for @useAsCString@ this function makes a copy of the original @ByteString@.
useAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a
useAsCStringLen p@(PS _ _ l) f = useAsCString p $ \cstr -> f (cstr,l)
------------------------------------------------------------------------
-- | /O(n)./ Construct a new @ByteString@ from a @CString@. The
-- resulting @ByteString@ is an immutable copy of the original
-- @CString@, and is managed on the Haskell heap. The original
-- @CString@ must be null terminated.
packCString :: CString -> IO ByteString
packCString cstr = do
len <- c_strlen cstr
packCStringLen (cstr, fromIntegral len)
-- | /O(n)./ Construct a new @ByteString@ from a @CStringLen@. The
-- resulting @ByteString@ is an immutable copy of the original @CStringLen@.
-- The @ByteString@ is a normal Haskell value and will be managed on the
-- Haskell heap.
packCStringLen :: CStringLen -> IO ByteString
packCStringLen (cstr, len) | len >= 0 = create len $ \p ->
memcpy p (castPtr cstr) (fromIntegral len)
packCStringLen (_, len) =
moduleErrorIO "packCStringLen" ("negative length: " ++ show len)
------------------------------------------------------------------------
-- | /O(n)/ Make a copy of the 'ByteString' with its own storage.
-- This is mainly useful to allow the rest of the data pointed
-- to by the 'ByteString' to be garbage collected, for example
-- if a large string has been read in, and only a small part of it
-- is needed in the rest of the program.
--
copy :: ByteString -> ByteString
copy (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f ->
memcpy p (f `plusPtr` s) (fromIntegral l)
-- ---------------------------------------------------------------------
-- Line IO
-- | Read a line from stdin.
getLine :: IO ByteString
getLine = hGetLine stdin
-- | Read a line from a handle
hGetLine :: Handle -> IO ByteString
#if !defined(__GLASGOW_HASKELL__)
hGetLine h = System.IO.hGetLine h >>= return . pack . P.map c2w
#elif __GLASGOW_HASKELL__ >= 611
hGetLine h =
wantReadableHandle_ "Data.ByteString.hGetLine" h $
\ h_@Handle__{haByteBuffer} -> do
flushCharReadBuffer h_
buf <- readIORef haByteBuffer
if isEmptyBuffer buf
then fill h_ buf 0 []
else haveBuf h_ buf 0 []
where
fill h_@Handle__{haByteBuffer,haDevice} buf len xss =
len `seq` do
(r,buf') <- Buffered.fillReadBuffer haDevice buf
if r == 0
then do writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
if len > 0
then mkBigPS len xss
else ioe_EOF
else haveBuf h_ buf' len xss
haveBuf h_@Handle__{haByteBuffer}
buf@Buffer{ bufRaw=raw, bufR=w, bufL=r }
len xss =
do
off <- findEOL r w raw
let new_len = len + off - r
xs <- mkPS raw r off
-- if eol == True, then off is the offset of the '\n'
-- otherwise off == w and the buffer is now empty.
if off /= w
then do if (w == off + 1)
then writeIORef haByteBuffer buf{ bufL=0, bufR=0 }
else writeIORef haByteBuffer buf{ bufL = off + 1 }
mkBigPS new_len (xs:xss)
else do
fill h_ buf{ bufL=0, bufR=0 } new_len (xs:xss)
-- find the end-of-line character, if there is one
findEOL r w raw
| r == w = return w
| otherwise = do
c <- readWord8Buf raw r
if c == fromIntegral (ord '\n')
then return r -- NB. not r+1: don't include the '\n'
else findEOL (r+1) w raw
mkPS :: RawBuffer Word8 -> Int -> Int -> IO ByteString
mkPS buf start end =
create len $ \p ->
withRawBuffer buf $ \pbuf -> do
copyBytes p (pbuf `plusPtr` start) len
where
len = end - start
#else
-- GHC 6.10 and older, pre-Unicode IO library
hGetLine h = wantReadableHandle "Data.ByteString.hGetLine" h $ \ handle_ -> do
case haBufferMode handle_ of
NoBuffering -> error "no buffering"
_other -> hGetLineBuffered handle_
where
hGetLineBuffered handle_ = do
let ref = haBuffer handle_
buf <- readIORef ref
hGetLineBufferedLoop handle_ ref buf 0 []
hGetLineBufferedLoop handle_ ref
buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } len xss =
len `seq` do
off <- findEOL r w raw
let new_len = len + off - r
xs <- mkPS raw r off
-- if eol == True, then off is the offset of the '\n'
-- otherwise off == w and the buffer is now empty.
if off /= w
then do if (w == off + 1)
then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
else writeIORef ref buf{ bufRPtr = off + 1 }
mkBigPS new_len (xs:xss)
else do
maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
buf{ bufWPtr=0, bufRPtr=0 }
case maybe_buf of
-- Nothing indicates we caught an EOF, and we may have a
-- partial line to return.
Nothing -> do
writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
if new_len > 0
then mkBigPS new_len (xs:xss)
else ioe_EOF
Just new_buf ->
hGetLineBufferedLoop handle_ ref new_buf new_len (xs:xss)
-- find the end-of-line character, if there is one
findEOL r w raw
| r == w = return w
| otherwise = do
(c,r') <- readCharFromBuffer raw r
if c == '\n'
then return r -- NB. not r': don't include the '\n'
else findEOL r' w raw
maybeFillReadBuffer fd is_line is_stream buf = catch
(do buf' <- fillReadBuffer fd is_line is_stream buf
return (Just buf'))
(\e -> if isEOFError e then return Nothing else ioError e)
-- TODO, rewrite to use normal memcpy
mkPS :: RawBuffer -> Int -> Int -> IO ByteString
mkPS buf start end =
let len = end - start
in create len $ \p -> do
memcpy_ptr_baoff p buf (fromIntegral start) (fromIntegral len)
return ()
memcpy_ptr_baoff dst src src_off sz = memcpy dst (src+src_off) sz
#endif
mkBigPS :: Int -> [ByteString] -> IO ByteString
mkBigPS _ [ps] = return ps
mkBigPS _ pss = return $! concat (P.reverse pss)
-- ---------------------------------------------------------------------
-- Block IO
-- | Outputs a 'ByteString' to the specified 'Handle'.
hPut :: Handle -> ByteString -> IO ()
hPut _ (PS _ _ 0) = return ()
hPut h (PS ps s l) = withForeignPtr ps $ \p-> hPutBuf h (p `plusPtr` s) l
-- | Similar to 'hPut' except that it will never block. Instead it returns
-- any tail that did not get written. This tail may be 'empty' in the case that
-- the whole string was written, or the whole original string if nothing was
-- written. Partial writes are also possible.
--
-- Note: on Windows and with Haskell implementation other than GHC, this
-- function does not work correctly; it behaves identically to 'hPut'.
--
hPutNonBlocking :: Handle -> ByteString -> IO ByteString
#if defined(__GLASGOW_HASKELL__)
hPutNonBlocking h bs@(PS ps s l) = do
bytesWritten <- withForeignPtr ps $ \p-> hPutBufNonBlocking h (p `plusPtr` s) l
return $! drop bytesWritten bs
#else
hPutNonBlocking h bs = hPut h bs >> return empty
#endif
-- | A synonym for @hPut@, for compatibility
hPutStr :: Handle -> ByteString -> IO ()
hPutStr = hPut
-- | Write a ByteString to a handle, appending a newline byte
hPutStrLn :: Handle -> ByteString -> IO ()
hPutStrLn h ps
| length ps < 1024 = hPut h (ps `snoc` 0x0a)
| otherwise = hPut h ps >> hPut h (singleton (0x0a)) -- don't copy
-- | Write a ByteString to stdout
putStr :: ByteString -> IO ()
putStr = hPut stdout
-- | Write a ByteString to stdout, appending a newline byte
putStrLn :: ByteString -> IO ()
putStrLn = hPutStrLn stdout
{-# DEPRECATED hPutStrLn
"Use Data.ByteString.Char8.hPutStrLn instead. (Functions that rely on ASCII encodings belong in Data.ByteString.Char8)"
#-}
{-# DEPRECATED putStrLn
"Use Data.ByteString.Char8.putStrLn instead. (Functions that rely on ASCII encodings belong in Data.ByteString.Char8)"
#-}
------------------------------------------------------------------------
-- Low level IO
-- | Read a 'ByteString' directly from the specified 'Handle'. This
-- is far more efficient than reading the characters into a 'String'
-- and then using 'pack'. First argument is the Handle to read from,
-- and the second is the number of bytes to read. It returns the bytes
-- read, up to n, or 'null' if EOF has been reached.
--
-- 'hGet' is implemented in terms of 'hGetBuf'.
--
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGet' will behave as if EOF was reached.
--
hGet :: Handle -> Int -> IO ByteString
hGet h i
| i > 0 = createAndTrim i $ \p -> hGetBuf h p i
| i == 0 = return empty
| otherwise = illegalBufferSize h "hGet" i
-- | hGetNonBlocking is similar to 'hGet', except that it will never block
-- waiting for data to become available, instead it returns only whatever data
-- is available. If there is no data available to be read, 'hGetNonBlocking'
-- returns 'empty'.
--
-- Note: on Windows and with Haskell implementation other than GHC, this
-- function does not work correctly; it behaves identically to 'hGet'.
--
hGetNonBlocking :: Handle -> Int -> IO ByteString
#if defined(__GLASGOW_HASKELL__)
hGetNonBlocking h i
| i > 0 = createAndTrim i $ \p -> hGetBufNonBlocking h p i
| i == 0 = return empty
| otherwise = illegalBufferSize h "hGetNonBlocking" i
#else
hGetNonBlocking = hGet
#endif
-- | Like 'hGet', except that a shorter 'ByteString' may be returned
-- if there are not enough bytes immediately available to satisfy the
-- whole request. 'hGetSome' only blocks if there is no data
-- available, and EOF has not yet been reached.
--
hGetSome :: Handle -> Int -> IO ByteString
hGetSome hh i
#if MIN_VERSION_base(4,3,0)
| i > 0 = createAndTrim i $ \p -> hGetBufSome hh p i
#else
| i > 0 = let
loop = do
s <- hGetNonBlocking hh i
if not (null s)
then return s
else do eof <- hIsEOF hh
if eof then return s
else hWaitForInput hh (-1) >> loop
-- for this to work correctly, the
-- Handle should be in binary mode
-- (see GHC ticket #3808)
in loop
#endif
| i == 0 = return empty
| otherwise = illegalBufferSize hh "hGetSome" i
illegalBufferSize :: Handle -> String -> Int -> IO a
illegalBufferSize handle fn sz =
ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)
--TODO: System.IO uses InvalidArgument here, but it's not exported :-(
where
msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []
-- | Read entire handle contents strictly into a 'ByteString'.
--
-- This function reads chunks at a time, doubling the chunksize on each
-- read. The final buffer is then realloced to the appropriate size. For
-- files > half of available memory, this may lead to memory exhaustion.
-- Consider using 'readFile' in this case.
--
-- As with 'hGet', the string representation in the file is assumed to
-- be ISO-8859-1.
--
-- The Handle is closed once the contents have been read,
-- or if an exception is thrown.
--
hGetContents :: Handle -> IO ByteString
hGetContents h = always (hClose h) $ do -- strict, so hClose
let start_size = 1024
p <- mallocBytes start_size
i <- hGetBuf h p start_size
if i < start_size
then do p' <- reallocBytes p i
fp <- newForeignPtr finalizerFree p'
return $! PS fp 0 i
else f p start_size
where
always = flip finally
f p s = do
let s' = 2 * s
p' <- reallocBytes p s'
i <- hGetBuf h (p' `plusPtr` s) s
if i < s
then do let i' = s + i
p'' <- reallocBytes p' i'
fp <- newForeignPtr finalizerFree p''
return $! PS fp 0 i'
else f p' s'
-- | getContents. Read stdin strictly. Equivalent to hGetContents stdin
-- The 'Handle' is closed after the contents have been read.
--
getContents :: IO ByteString
getContents = hGetContents stdin
-- | The interact function takes a function of type @ByteString -> ByteString@
-- as its argument. The entire input from the standard input device is passed
-- to this function as its argument, and the resulting string is output on the
-- standard output device.
--
interact :: (ByteString -> ByteString) -> IO ()
interact transformer = putStr . transformer =<< getContents
-- | Read an entire file strictly into a 'ByteString'. This is far more
-- efficient than reading the characters into a 'String' and then using
-- 'pack'. It also may be more efficient than opening the file and
-- reading it using 'hGet'.
--
readFile :: FilePath -> IO ByteString
readFile f = bracket (openBinaryFile f ReadMode) hClose
(\h -> hFileSize h >>= hGet h . fromIntegral)
-- | Write a 'ByteString' to a file.
writeFile :: FilePath -> ByteString -> IO ()
writeFile f txt = bracket (openBinaryFile f WriteMode) hClose
(\h -> hPut h txt)
-- | Append a 'ByteString' to a file.
appendFile :: FilePath -> ByteString -> IO ()
appendFile f txt = bracket (openBinaryFile f AppendMode) hClose
(\h -> hPut h txt)
-- ---------------------------------------------------------------------
-- Internal utilities
-- | 'findIndexOrEnd' is a variant of findIndex, that returns the length
-- of the string if no element is found, rather than Nothing.
findIndexOrEnd :: (Word8 -> Bool) -> ByteString -> Int
findIndexOrEnd k (PS x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0
where
STRICT2(go)
go ptr n | n >= l = return l
| otherwise = do w <- peek ptr
if k w
then return n
else go (ptr `plusPtr` 1) (n+1)
{-# INLINE findIndexOrEnd #-}
-- | Perform an operation with a temporary ByteString
withPtr :: ForeignPtr a -> (Ptr a -> IO b) -> b
withPtr fp io = inlinePerformIO (withForeignPtr fp io)
{-# INLINE withPtr #-}
-- Common up near identical calls to `error' to reduce the number
-- constant strings created when compiled:
errorEmptyList :: String -> a
errorEmptyList fun = moduleError fun "empty ByteString"
{-# NOINLINE errorEmptyList #-}
moduleError :: String -> String -> a
moduleError fun msg = error (moduleErrorMsg fun msg)
{-# NOINLINE moduleError #-}
moduleErrorIO :: String -> String -> IO a
moduleErrorIO fun msg =
#if MIN_VERSION_base(4,0,0)
throwIO . userError $ moduleErrorMsg fun msg
#else
throwIO . IOException . userError $ moduleErrorMsg fun msg
#endif
{-# NOINLINE moduleErrorIO #-}
moduleErrorMsg :: String -> String -> String
moduleErrorMsg fun msg = "Data.ByteString." ++ fun ++ ':':' ':msg
-- Find from the end of the string using predicate
findFromEndUntil :: (Word8 -> Bool) -> ByteString -> Int
STRICT2(findFromEndUntil)
findFromEndUntil f ps@(PS x s l) =
if null ps then 0
else if f (last ps) then l
else findFromEndUntil f (PS x s (l-1))
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.List
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : stable
-- Portability : portable
--
-- Operations on lists.
--
-----------------------------------------------------------------------------
module Data.List
(
#ifdef __NHC__
[](..),
#endif
-- * Basic functions
(++) -- :: [a] -> [a] -> [a]
, head -- :: [a] -> a
, last -- :: [a] -> a
, tail -- :: [a] -> [a]
, init -- :: [a] -> [a]
, null -- :: [a] -> Bool
, length -- :: [a] -> Int
-- * List transformations
, map -- :: (a -> b) -> [a] -> [b]
, reverse -- :: [a] -> [a]
, intersperse -- :: a -> [a] -> [a]
, intercalate -- :: [a] -> [[a]] -> [a]
, transpose -- :: [[a]] -> [[a]]
, subsequences -- :: [a] -> [[a]]
, permutations -- :: [a] -> [[a]]
-- * Reducing lists (folds)
, foldl -- :: (a -> b -> a) -> a -> [b] -> a
, foldl' -- :: (a -> b -> a) -> a -> [b] -> a
, foldl1 -- :: (a -> a -> a) -> [a] -> a
, foldl1' -- :: (a -> a -> a) -> [a] -> a
, foldr -- :: (a -> b -> b) -> b -> [a] -> b
, foldr1 -- :: (a -> a -> a) -> [a] -> a
-- ** Special folds
, concat -- :: [[a]] -> [a]
, concatMap -- :: (a -> [b]) -> [a] -> [b]
, and -- :: [Bool] -> Bool
, or -- :: [Bool] -> Bool
, any -- :: (a -> Bool) -> [a] -> Bool
, all -- :: (a -> Bool) -> [a] -> Bool
, sum -- :: (Num a) => [a] -> a
, product -- :: (Num a) => [a] -> a
, maximum -- :: (Ord a) => [a] -> a
, minimum -- :: (Ord a) => [a] -> a
-- * Building lists
-- ** Scans
, scanl -- :: (a -> b -> a) -> a -> [b] -> [a]
, scanl1 -- :: (a -> a -> a) -> [a] -> [a]
, scanr -- :: (a -> b -> b) -> b -> [a] -> [b]
, scanr1 -- :: (a -> a -> a) -> [a] -> [a]
-- ** Accumulating maps
, mapAccumL -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
, mapAccumR -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
-- ** Infinite lists
, iterate -- :: (a -> a) -> a -> [a]
, repeat -- :: a -> [a]
, replicate -- :: Int -> a -> [a]
, cycle -- :: [a] -> [a]
-- ** Unfolding
, unfoldr -- :: (b -> Maybe (a, b)) -> b -> [a]
-- * Sublists
-- ** Extracting sublists
, take -- :: Int -> [a] -> [a]
, drop -- :: Int -> [a] -> [a]
, splitAt -- :: Int -> [a] -> ([a], [a])
, takeWhile -- :: (a -> Bool) -> [a] -> [a]
, dropWhile -- :: (a -> Bool) -> [a] -> [a]
, dropWhileEnd -- :: (a -> Bool) -> [a] -> [a]
, span -- :: (a -> Bool) -> [a] -> ([a], [a])
, break -- :: (a -> Bool) -> [a] -> ([a], [a])
, stripPrefix -- :: Eq a => [a] -> [a] -> Maybe [a]
, group -- :: Eq a => [a] -> [[a]]
, inits -- :: [a] -> [[a]]
, tails -- :: [a] -> [[a]]
-- ** Predicates
, isPrefixOf -- :: (Eq a) => [a] -> [a] -> Bool
, isSuffixOf -- :: (Eq a) => [a] -> [a] -> Bool
, isInfixOf -- :: (Eq a) => [a] -> [a] -> Bool
-- * Searching lists
-- ** Searching by equality
, elem -- :: a -> [a] -> Bool
, notElem -- :: a -> [a] -> Bool
, lookup -- :: (Eq a) => a -> [(a,b)] -> Maybe b
-- ** Searching with a predicate
, find -- :: (a -> Bool) -> [a] -> Maybe a
, filter -- :: (a -> Bool) -> [a] -> [a]
, partition -- :: (a -> Bool) -> [a] -> ([a], [a])
-- * Indexing lists
-- | These functions treat a list @xs@ as a indexed collection,
-- with indices ranging from 0 to @'length' xs - 1@.
, (!!) -- :: [a] -> Int -> a
, elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int
, elemIndices -- :: (Eq a) => a -> [a] -> [Int]
, findIndex -- :: (a -> Bool) -> [a] -> Maybe Int
, findIndices -- :: (a -> Bool) -> [a] -> [Int]
-- * Zipping and unzipping lists
, zip -- :: [a] -> [b] -> [(a,b)]
, zip3
, zip4, zip5, zip6, zip7
, zipWith -- :: (a -> b -> c) -> [a] -> [b] -> [c]
, zipWith3
, zipWith4, zipWith5, zipWith6, zipWith7
, unzip -- :: [(a,b)] -> ([a],[b])
, unzip3
, unzip4, unzip5, unzip6, unzip7
-- * Special lists
-- ** Functions on strings
, lines -- :: String -> [String]
, words -- :: String -> [String]
, unlines -- :: [String] -> String
, unwords -- :: [String] -> String
-- ** \"Set\" operations
, nub -- :: (Eq a) => [a] -> [a]
, delete -- :: (Eq a) => a -> [a] -> [a]
, (\\) -- :: (Eq a) => [a] -> [a] -> [a]
, union -- :: (Eq a) => [a] -> [a] -> [a]
, intersect -- :: (Eq a) => [a] -> [a] -> [a]
-- ** Ordered lists
, sort -- :: (Ord a) => [a] -> [a]
, insert -- :: (Ord a) => a -> [a] -> [a]
-- * Generalized functions
-- ** The \"@By@\" operations
-- | By convention, overloaded functions have a non-overloaded
-- counterpart whose name is suffixed with \`@By@\'.
--
-- It is often convenient to use these functions together with
-- 'Data.Function.on', for instance @'sortBy' ('compare'
-- \`on\` 'fst')@.
-- *** User-supplied equality (replacing an @Eq@ context)
-- | The predicate is assumed to define an equivalence.
, nubBy -- :: (a -> a -> Bool) -> [a] -> [a]
, deleteBy -- :: (a -> a -> Bool) -> a -> [a] -> [a]
, deleteFirstsBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
, unionBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
, intersectBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
, groupBy -- :: (a -> a -> Bool) -> [a] -> [[a]]
-- *** User-supplied comparison (replacing an @Ord@ context)
-- | The function is assumed to define a total ordering.
, sortBy -- :: (a -> a -> Ordering) -> [a] -> [a]
, insertBy -- :: (a -> a -> Ordering) -> a -> [a] -> [a]
, maximumBy -- :: (a -> a -> Ordering) -> [a] -> a
, minimumBy -- :: (a -> a -> Ordering) -> [a] -> a
-- ** The \"@generic@\" operations
-- | The prefix \`@generic@\' indicates an overloaded function that
-- is a generalized version of a "Prelude" function.
, genericLength -- :: (Integral a) => [b] -> a
, genericTake -- :: (Integral a) => a -> [b] -> [b]
, genericDrop -- :: (Integral a) => a -> [b] -> [b]
, genericSplitAt -- :: (Integral a) => a -> [b] -> ([b], [b])
, genericIndex -- :: (Integral a) => [b] -> a -> b
, genericReplicate -- :: (Integral a) => a -> b -> [b]
) where
#ifdef __NHC__
import Prelude
#endif
import Data.Maybe
import Data.Char ( isSpace )
#ifdef __GLASGOW_HASKELL__
import GHC.Num
import GHC.Real
import GHC.List
import GHC.Base
#endif
infix 5 \\ -- comment to fool cpp
-- -----------------------------------------------------------------------------
-- List functions
-- | The 'dropWhileEnd' function drops the largest suffix of a list
-- in which the given predicate holds for all elements. For example:
--
-- > dropWhileEnd isSpace "foo\n" == "foo"
-- > dropWhileEnd isSpace "foo bar" == "foo bar"
-- > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
-- | The 'stripPrefix' function drops the given prefix from a list.
-- It returns 'Nothing' if the list did not start with the prefix
-- given, or 'Just' the list after the prefix, if it does.
--
-- > stripPrefix "foo" "foobar" == Just "bar"
-- > stripPrefix "foo" "foo" == Just ""
-- > stripPrefix "foo" "barfoo" == Nothing
-- > stripPrefix "foo" "barfoobaz" == Nothing
stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [] ys = Just ys
stripPrefix (x:xs) (y:ys)
| x == y = stripPrefix xs ys
stripPrefix _ _ = Nothing
-- | The 'elemIndex' function returns the index of the first element
-- in the given list which is equal (by '==') to the query element,
-- or 'Nothing' if there is no such element.
elemIndex :: Eq a => a -> [a] -> Maybe Int
elemIndex x = findIndex (x==)
-- | The 'elemIndices' function extends 'elemIndex', by returning the
-- indices of all elements equal to the query element, in ascending order.
elemIndices :: Eq a => a -> [a] -> [Int]
elemIndices x = findIndices (x==)
-- | The 'find' function takes a predicate and a list and returns the
-- first element in the list matching the predicate, or 'Nothing' if
-- there is no such element.
find :: (a -> Bool) -> [a] -> Maybe a
find p = listToMaybe . filter p
-- | The 'findIndex' function takes a predicate and a list and returns
-- the index of the first element in the list satisfying the predicate,
-- or 'Nothing' if there is no such element.
findIndex :: (a -> Bool) -> [a] -> Maybe Int
findIndex p = listToMaybe . findIndices p
-- | The 'findIndices' function extends 'findIndex', by returning the
-- indices of all elements satisfying the predicate, in ascending order.
findIndices :: (a -> Bool) -> [a] -> [Int]
#if defined(USE_REPORT_PRELUDE) || !defined(__GLASGOW_HASKELL__)
findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]
#else
-- Efficient definition
findIndices p ls = loop 0# ls
where
loop _ [] = []
loop n (x:xs) | p x = I# n : loop (n +# 1#) xs
| otherwise = loop (n +# 1#) xs
#endif /* USE_REPORT_PRELUDE */
-- | The 'isPrefixOf' function takes two lists and returns 'True'
-- iff the first list is a prefix of the second.
isPrefixOf :: (Eq a) => [a] -> [a] -> Bool
isPrefixOf [] _ = True
isPrefixOf _ [] = False
isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys
-- | The 'isSuffixOf' function takes two lists and returns 'True'
-- iff the first list is a suffix of the second.
-- Both lists must be finite.
isSuffixOf :: (Eq a) => [a] -> [a] -> Bool
isSuffixOf x y = reverse x `isPrefixOf` reverse y
-- | The 'isInfixOf' function takes two lists and returns 'True'
-- iff the first list is contained, wholly and intact,
-- anywhere within the second.
--
-- Example:
--
-- >isInfixOf "Haskell" "I really like Haskell." == True
-- >isInfixOf "Ial" "I really like Haskell." == False
isInfixOf :: (Eq a) => [a] -> [a] -> Bool
isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
-- | /O(n^2)/. The 'nub' function removes duplicate elements from a list.
-- In particular, it keeps only the first occurrence of each element.
-- (The name 'nub' means \`essence\'.)
-- It is a special case of 'nubBy', which allows the programmer to supply
-- their own equality test.
nub :: (Eq a) => [a] -> [a]
#ifdef USE_REPORT_PRELUDE
nub = nubBy (==)
#else
-- stolen from HBC
nub l = nub' l [] -- '
where
nub' [] _ = [] -- '
nub' (x:xs) ls -- '
| x `elem` ls = nub' xs ls -- '
| otherwise = x : nub' xs (x:ls) -- '
#endif
-- | The 'nubBy' function behaves just like 'nub', except it uses a
-- user-supplied equality predicate instead of the overloaded '=='
-- function.
nubBy :: (a -> a -> Bool) -> [a] -> [a]
#ifdef USE_REPORT_PRELUDE
nubBy eq [] = []
nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs)
#else
nubBy eq l = nubBy' l []
where
nubBy' [] _ = []
nubBy' (y:ys) xs
| elem_by eq y xs = nubBy' ys xs
| otherwise = y : nubBy' ys (y:xs)
-- Not exported:
-- Note that we keep the call to `eq` with arguments in the
-- same order as in the reference implementation
-- 'xs' is the list of things we've seen so far,
-- 'y' is the potential new element
elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool
elem_by _ _ [] = False
elem_by eq y (x:xs) = y `eq` x || elem_by eq y xs
#endif
-- | 'delete' @x@ removes the first occurrence of @x@ from its list argument.
-- For example,
--
-- > delete 'a' "banana" == "bnana"
--
-- It is a special case of 'deleteBy', which allows the programmer to
-- supply their own equality test.
delete :: (Eq a) => a -> [a] -> [a]
delete = deleteBy (==)
-- | The 'deleteBy' function behaves like 'delete', but takes a
-- user-supplied equality predicate.
deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy _ _ [] = []
deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys
-- | The '\\' function is list difference (non-associative).
-- In the result of @xs@ '\\' @ys@, the first occurrence of each element of
-- @ys@ in turn (if any) has been removed from @xs@. Thus
--
-- > (xs ++ ys) \\ xs == ys.
--
-- It is a special case of 'deleteFirstsBy', which allows the programmer
-- to supply their own equality test.
(\\) :: (Eq a) => [a] -> [a] -> [a]
(\\) = foldl (flip delete)
-- | The 'union' function returns the list union of the two lists.
-- For example,
--
-- > "dog" `union` "cow" == "dogcw"
--
-- Duplicates, and elements of the first list, are removed from the
-- the second list, but if the first list contains duplicates, so will
-- the result.
-- It is a special case of 'unionBy', which allows the programmer to supply
-- their own equality test.
union :: (Eq a) => [a] -> [a] -> [a]
union = unionBy (==)
-- | The 'unionBy' function is the non-overloaded version of 'union'.
unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
-- | The 'intersect' function takes the list intersection of two lists.
-- For example,
--
-- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4]
--
-- If the first list contains duplicates, so will the result.
--
-- > [1,2,2,3,4] `intersect` [6,4,4,2] == [2,2,4]
--
-- It is a special case of 'intersectBy', which allows the programmer to
-- supply their own equality test. If the element is found in both the first
-- and the second list, the element from the first list will be used.
intersect :: (Eq a) => [a] -> [a] -> [a]
intersect = intersectBy (==)
-- | The 'intersectBy' function is the non-overloaded version of 'intersect'.
intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
intersectBy _ [] _ = []
intersectBy _ _ [] = []
intersectBy eq xs ys = [x | x <- xs, any (eq x) ys]
-- | The 'intersperse' function takes an element and a list and
-- \`intersperses\' that element between the elements of the list.
-- For example,
--
-- > intersperse ',' "abcde" == "a,b,c,d,e"
intersperse :: a -> [a] -> [a]
intersperse _ [] = []
intersperse sep (x:xs) = x : prependToAll sep xs
-- Not exported:
-- We want to make every element in the 'intersperse'd list available
-- as soon as possible to avoid space leaks. Experiments suggested that
-- a separate top-level helper is more efficient than a local worker.
prependToAll :: a -> [a] -> [a]
prependToAll _ [] = []
prependToAll sep (x:xs) = sep : x : prependToAll sep xs
-- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@.
-- It inserts the list @xs@ in between the lists in @xss@ and concatenates the
-- result.
intercalate :: [a] -> [[a]] -> [a]
intercalate xs xss = concat (intersperse xs xss)
-- | The 'transpose' function transposes the rows and columns of its argument.
-- For example,
--
-- > transpose [[1,2,3],[4,5,6]] == [[1,4],[2,5],[3,6]]
transpose :: [[a]] -> [[a]]
transpose [] = []
transpose ([] : xss) = transpose xss
transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss])
-- | The 'partition' function takes a predicate a list and returns
-- the pair of lists of elements which do and do not satisfy the
-- predicate, respectively; i.e.,
--
-- > partition p xs == (filter p xs, filter (not . p) xs)
partition :: (a -> Bool) -> [a] -> ([a],[a])
{-# INLINE partition #-}
partition p xs = foldr (select p) ([],[]) xs
select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])
select p x ~(ts,fs) | p x = (x:ts,fs)
| otherwise = (ts, x:fs)
-- | The 'mapAccumL' function behaves like a combination of 'map' and
-- 'foldl'; it applies a function to each element of a list, passing
-- an accumulating parameter from left to right, and returning a final
-- value of this accumulator together with the new list.
mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
-- and accumulator, returning new
-- accumulator and elt of result list
-> acc -- Initial accumulator
-> [x] -- Input list
-> (acc, [y]) -- Final accumulator and result list
mapAccumL _ s [] = (s, [])
mapAccumL f s (x:xs) = (s'',y:ys)
where (s', y ) = f s x
(s'',ys) = mapAccumL f s' xs
-- | The 'mapAccumR' function behaves like a combination of 'map' and
-- 'foldr'; it applies a function to each element of a list, passing
-- an accumulating parameter from right to left, and returning a final
-- value of this accumulator together with the new list.
mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
-- and accumulator, returning new
-- accumulator and elt of result list
-> acc -- Initial accumulator
-> [x] -- Input list
-> (acc, [y]) -- Final accumulator and result list
mapAccumR _ s [] = (s, [])
mapAccumR f s (x:xs) = (s'', y:ys)
where (s'',y ) = f s' x
(s', ys) = mapAccumR f s xs
-- | The 'insert' function takes an element and a list and inserts the
-- element into the list at the first position where it is less
-- than or equal to the next element. In particular, if the list
-- is sorted before the call, the result will also be sorted.
-- It is a special case of 'insertBy', which allows the programmer to
-- supply their own comparison function.
insert :: Ord a => a -> [a] -> [a]
insert e ls = insertBy (compare) e ls
-- | The non-overloaded version of 'insert'.
insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
insertBy _ x [] = [x]
insertBy cmp x ys@(y:ys')
= case cmp x y of
GT -> y : insertBy cmp x ys'
_ -> x : ys
#ifdef __GLASGOW_HASKELL__
-- | 'maximum' returns the maximum value from a list,
-- which must be non-empty, finite, and of an ordered type.
-- It is a special case of 'Data.List.maximumBy', which allows the
-- programmer to supply their own comparison function.
maximum :: (Ord a) => [a] -> a
maximum [] = errorEmptyList "maximum"
maximum xs = foldl1 max xs
{-# RULES
"maximumInt" maximum = (strictMaximum :: [Int] -> Int);
"maximumInteger" maximum = (strictMaximum :: [Integer] -> Integer)
#-}
-- We can't make the overloaded version of maximum strict without
-- changing its semantics (max might not be strict), but we can for
-- the version specialised to 'Int'.
strictMaximum :: (Ord a) => [a] -> a
strictMaximum [] = errorEmptyList "maximum"
strictMaximum xs = foldl1' max xs
-- | 'minimum' returns the minimum value from a list,
-- which must be non-empty, finite, and of an ordered type.
-- It is a special case of 'Data.List.minimumBy', which allows the
-- programmer to supply their own comparison function.
minimum :: (Ord a) => [a] -> a
minimum [] = errorEmptyList "minimum"
minimum xs = foldl1 min xs
{-# RULES
"minimumInt" minimum = (strictMinimum :: [Int] -> Int);
"minimumInteger" minimum = (strictMinimum :: [Integer] -> Integer)
#-}
strictMinimum :: (Ord a) => [a] -> a
strictMinimum [] = errorEmptyList "minimum"
strictMinimum xs = foldl1' min xs
#endif /* __GLASGOW_HASKELL__ */
-- | The 'maximumBy' function takes a comparison function and a list
-- and returns the greatest element of the list by the comparison function.
-- The list must be finite and non-empty.
maximumBy :: (a -> a -> Ordering) -> [a] -> a
maximumBy _ [] = error "List.maximumBy: empty list"
maximumBy cmp xs = foldl1 maxBy xs
where
maxBy x y = case cmp x y of
GT -> x
_ -> y
-- | The 'minimumBy' function takes a comparison function and a list
-- and returns the least element of the list by the comparison function.
-- The list must be finite and non-empty.
minimumBy :: (a -> a -> Ordering) -> [a] -> a
minimumBy _ [] = error "List.minimumBy: empty list"
minimumBy cmp xs = foldl1 minBy xs
where
minBy x y = case cmp x y of
GT -> y
_ -> x
-- | The 'genericLength' function is an overloaded version of 'length'. In
-- particular, instead of returning an 'Int', it returns any type which is
-- an instance of 'Num'. It is, however, less efficient than 'length'.
genericLength :: (Num i) => [b] -> i
genericLength [] = 0
genericLength (_:l) = 1 + genericLength l
{-# RULES
"genericLengthInt" genericLength = (strictGenericLength :: [a] -> Int);
"genericLengthInteger" genericLength = (strictGenericLength :: [a] -> Integer);
#-}
strictGenericLength :: (Num i) => [b] -> i
strictGenericLength l = gl l 0
where
gl [] a = a
gl (_:xs) a = let a' = a + 1 in a' `seq` gl xs a'
-- | The 'genericTake' function is an overloaded version of 'take', which
-- accepts any 'Integral' value as the number of elements to take.
genericTake :: (Integral i) => i -> [a] -> [a]
genericTake n _ | n <= 0 = []
genericTake _ [] = []
genericTake n (x:xs) = x : genericTake (n-1) xs
-- | The 'genericDrop' function is an overloaded version of 'drop', which
-- accepts any 'Integral' value as the number of elements to drop.
genericDrop :: (Integral i) => i -> [a] -> [a]
genericDrop n xs | n <= 0 = xs
genericDrop _ [] = []
genericDrop n (_:xs) = genericDrop (n-1) xs
-- | The 'genericSplitAt' function is an overloaded version of 'splitAt', which
-- accepts any 'Integral' value as the position at which to split.
genericSplitAt :: (Integral i) => i -> [b] -> ([b],[b])
genericSplitAt n xs | n <= 0 = ([],xs)
genericSplitAt _ [] = ([],[])
genericSplitAt n (x:xs) = (x:xs',xs'') where
(xs',xs'') = genericSplitAt (n-1) xs
-- | The 'genericIndex' function is an overloaded version of '!!', which
-- accepts any 'Integral' value as the index.
genericIndex :: (Integral a) => [b] -> a -> b
genericIndex (x:_) 0 = x
genericIndex (_:xs) n
| n > 0 = genericIndex xs (n-1)
| otherwise = error "List.genericIndex: negative argument."
genericIndex _ _ = error "List.genericIndex: index too large."
-- | The 'genericReplicate' function is an overloaded version of 'replicate',
-- which accepts any 'Integral' value as the number of repetitions to make.
genericReplicate :: (Integral i) => i -> a -> [a]
genericReplicate n x = genericTake n (repeat x)
-- | The 'zip4' function takes four lists and returns a list of
-- quadruples, analogous to 'zip'.
zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
zip4 = zipWith4 (,,,)
-- | The 'zip5' function takes five lists and returns a list of
-- five-tuples, analogous to 'zip'.
zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
zip5 = zipWith5 (,,,,)
-- | The 'zip6' function takes six lists and returns a list of six-tuples,
-- analogous to 'zip'.
zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
[(a,b,c,d,e,f)]
zip6 = zipWith6 (,,,,,)
-- | The 'zip7' function takes seven lists and returns a list of
-- seven-tuples, analogous to 'zip'.
zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
[g] -> [(a,b,c,d,e,f,g)]
zip7 = zipWith7 (,,,,,,)
-- | The 'zipWith4' function takes a function which combines four
-- elements, as well as four lists and returns a list of their point-wise
-- combination, analogous to 'zipWith'.
zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
= z a b c d : zipWith4 z as bs cs ds
zipWith4 _ _ _ _ _ = []
-- | The 'zipWith5' function takes a function which combines five
-- elements, as well as five lists and returns a list of their point-wise
-- combination, analogous to 'zipWith'.
zipWith5 :: (a->b->c->d->e->f) ->
[a]->[b]->[c]->[d]->[e]->[f]
zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
= z a b c d e : zipWith5 z as bs cs ds es
zipWith5 _ _ _ _ _ _ = []
-- | The 'zipWith6' function takes a function which combines six
-- elements, as well as six lists and returns a list of their point-wise
-- combination, analogous to 'zipWith'.
zipWith6 :: (a->b->c->d->e->f->g) ->
[a]->[b]->[c]->[d]->[e]->[f]->[g]
zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
= z a b c d e f : zipWith6 z as bs cs ds es fs
zipWith6 _ _ _ _ _ _ _ = []
-- | The 'zipWith7' function takes a function which combines seven
-- elements, as well as seven lists and returns a list of their point-wise
-- combination, analogous to 'zipWith'.
zipWith7 :: (a->b->c->d->e->f->g->h) ->
[a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
= z a b c d e f g : zipWith7 z as bs cs ds es fs gs
zipWith7 _ _ _ _ _ _ _ _ = []
-- | The 'unzip4' function takes a list of quadruples and returns four
-- lists, analogous to 'unzip'.
unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d])
unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
(a:as,b:bs,c:cs,d:ds))
([],[],[],[])
-- | The 'unzip5' function takes a list of five-tuples and returns five
-- lists, analogous to 'unzip'.
unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
(a:as,b:bs,c:cs,d:ds,e:es))
([],[],[],[],[])
-- | The 'unzip6' function takes a list of six-tuples and returns six
-- lists, analogous to 'unzip'.
unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
(a:as,b:bs,c:cs,d:ds,e:es,f:fs))
([],[],[],[],[],[])
-- | The 'unzip7' function takes a list of seven-tuples and returns
-- seven lists, analogous to 'unzip'.
unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
(a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
([],[],[],[],[],[],[])
-- | The 'deleteFirstsBy' function takes a predicate and two lists and
-- returns the first list with the first occurrence of each element of
-- the second list removed.
deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy eq = foldl (flip (deleteBy eq))
-- | The 'group' function takes a list and returns a list of lists such
-- that the concatenation of the result is equal to the argument. Moreover,
-- each sublist in the result contains only equal elements. For example,
--
-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]
--
-- It is a special case of 'groupBy', which allows the programmer to supply
-- their own equality test.
group :: Eq a => [a] -> [[a]]
group = groupBy (==)
-- | The 'groupBy' function is the non-overloaded version of 'group'.
groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
groupBy _ [] = []
groupBy eq (x:xs) = (x:ys) : groupBy eq zs
where (ys,zs) = span (eq x) xs
-- | The 'inits' function returns all initial segments of the argument,
-- shortest first. For example,
--
-- > inits "abc" == ["","a","ab","abc"]
--
-- Note that 'inits' has the following strictness property:
-- @inits _|_ = [] : _|_@
inits :: [a] -> [[a]]
inits xs = [] : case xs of
[] -> []
x : xs' -> map (x :) (inits xs')
-- | The 'tails' function returns all final segments of the argument,
-- longest first. For example,
--
-- > tails "abc" == ["abc", "bc", "c",""]
--
-- Note that 'tails' has the following strictness property:
-- @tails _|_ = _|_ : _|_@
tails :: [a] -> [[a]]
tails xs = xs : case xs of
[] -> []
_ : xs' -> tails xs'
-- | The 'subsequences' function returns the list of all subsequences of the argument.
--
-- > subsequences "abc" == ["","a","b","ab","c","ac","bc","abc"]
subsequences :: [a] -> [[a]]
subsequences xs = [] : nonEmptySubsequences xs
-- | The 'nonEmptySubsequences' function returns the list of all subsequences of the argument,
-- except for the empty list.
--
-- > nonEmptySubsequences "abc" == ["a","b","ab","c","ac","bc","abc"]
nonEmptySubsequences :: [a] -> [[a]]
nonEmptySubsequences [] = []
nonEmptySubsequences (x:xs) = [x] : foldr f [] (nonEmptySubsequences xs)
where f ys r = ys : (x : ys) : r
-- | The 'permutations' function returns the list of all permutations of the argument.
--
-- > permutations "abc" == ["abc","bac","cba","bca","cab","acb"]
permutations :: [a] -> [[a]]
permutations xs0 = xs0 : perms xs0 []
where
perms [] _ = []
perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is)
where interleave xs r = let (_,zs) = interleave' id xs r in zs
interleave' _ [] r = (ts, r)
interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r
in (y:us, f (t:y:us) : zs)
------------------------------------------------------------------------------
-- Quick Sort algorithm taken from HBC's QSort library.
-- | The 'sort' function implements a stable sorting algorithm.
-- It is a special case of 'sortBy', which allows the programmer to supply
-- their own comparison function.
sort :: (Ord a) => [a] -> [a]
-- | The 'sortBy' function is the non-overloaded version of 'sort'.
sortBy :: (a -> a -> Ordering) -> [a] -> [a]
#ifdef USE_REPORT_PRELUDE
sort = sortBy compare
sortBy cmp = foldr (insertBy cmp) []
#else
{-
GHC's mergesort replaced by a better implementation, 24/12/2009.
This code originally contributed to the nhc12 compiler by Thomas Nordin
in 2002. Rumoured to have been based on code by Lennart Augustsson, e.g.
http://www.mail-archive.com/haskell@haskell.org/msg01822.html
and possibly to bear similarities to a 1982 paper by Richard O'Keefe:
"A smooth applicative merge sort".
Benchmarks show it to be often 2x the speed of the previous implementation.
Fixes ticket http://hackage.haskell.org/trac/ghc/ticket/2143
-}
sort = sortBy compare
sortBy cmp = mergeAll . sequences
where
sequences (a:b:xs)
| a `cmp` b == GT = descending b [a] xs
| otherwise = ascending b (a:) xs
sequences xs = [xs]
descending a as (b:bs)
| a `cmp` b == GT = descending b (a:as) bs
descending a as bs = (a:as): sequences bs
ascending a as (b:bs)
| a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs
ascending a as bs = as [a]: sequences bs
mergeAll [x] = x
mergeAll xs = mergeAll (mergePairs xs)
mergePairs (a:b:xs) = merge a b: mergePairs xs
mergePairs xs = xs
merge as@(a:as') bs@(b:bs')
| a `cmp` b == GT = b:merge as bs'
| otherwise = a:merge as' bs
merge [] bs = bs
merge as [] = as
{-
sortBy cmp l = mergesort cmp l
sort l = mergesort compare l
Quicksort replaced by mergesort, 14/5/2002.
From: Ian Lynagh
I am curious as to why the List.sort implementation in GHC is a
quicksort algorithm rather than an algorithm that guarantees n log n
time in the worst case? I have attached a mergesort implementation along
with a few scripts to time it's performance, the results of which are
shown below (* means it didn't finish successfully - in all cases this
was due to a stack overflow).
If I heap profile the random_list case with only 10000 then I see
random_list peaks at using about 2.5M of memory, whereas in the same
program using List.sort it uses only 100k.
Input style Input length Sort data Sort alg User time
stdin 10000 random_list sort 2.82
stdin 10000 random_list mergesort 2.96
stdin 10000 sorted sort 31.37
stdin 10000 sorted mergesort 1.90
stdin 10000 revsorted sort 31.21
stdin 10000 revsorted mergesort 1.88
stdin 100000 random_list sort *
stdin 100000 random_list mergesort *
stdin 100000 sorted sort *
stdin 100000 sorted mergesort *
stdin 100000 revsorted sort *
stdin 100000 revsorted mergesort *
func 10000 random_list sort 0.31
func 10000 random_list mergesort 0.91
func 10000 sorted sort 19.09
func 10000 sorted mergesort 0.15
func 10000 revsorted sort 19.17
func 10000 revsorted mergesort 0.16
func 100000 random_list sort 3.85
func 100000 random_list mergesort *
func 100000 sorted sort 5831.47
func 100000 sorted mergesort 2.23
func 100000 revsorted sort 5872.34
func 100000 revsorted mergesort 2.24
mergesort :: (a -> a -> Ordering) -> [a] -> [a]
mergesort cmp = mergesort' cmp . map wrap
mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]
mergesort' _ [] = []
mergesort' _ [xs] = xs
mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)
merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]
merge_pairs _ [] = []
merge_pairs _ [xs] = [xs]
merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss
merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
merge _ [] ys = ys
merge _ xs [] = xs
merge cmp (x:xs) (y:ys)
= case x `cmp` y of
GT -> y : merge cmp (x:xs) ys
_ -> x : merge cmp xs (y:ys)
wrap :: a -> [a]
wrap x = [x]
OLDER: qsort version
-- qsort is stable and does not concatenate.
qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
qsort _ [] r = r
qsort _ [x] r = x:r
qsort cmp (x:xs) r = qpart cmp x xs [] [] r
-- qpart partitions and sorts the sublists
qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
qpart cmp x [] rlt rge r =
-- rlt and rge are in reverse order and must be sorted with an
-- anti-stable sorting
rqsort cmp rlt (x:rqsort cmp rge r)
qpart cmp x (y:ys) rlt rge r =
case cmp x y of
GT -> qpart cmp x ys (y:rlt) rge r
_ -> qpart cmp x ys rlt (y:rge) r
-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
rqsort _ [] r = r
rqsort _ [x] r = x:r
rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r
rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
rqpart cmp x [] rle rgt r =
qsort cmp rle (x:qsort cmp rgt r)
rqpart cmp x (y:ys) rle rgt r =
case cmp y x of
GT -> rqpart cmp x ys rle (y:rgt) r
_ -> rqpart cmp x ys (y:rle) rgt r
-}
#endif /* USE_REPORT_PRELUDE */
-- | The 'unfoldr' function is a \`dual\' to 'foldr': while 'foldr'
-- reduces a list to a summary value, 'unfoldr' builds a list from
-- a seed value. The function takes the element and returns 'Nothing'
-- if it is done producing the list or returns 'Just' @(a,b)@, in which
-- case, @a@ is a prepended to the list and @b@ is used as the next
-- element in a recursive call. For example,
--
-- > iterate f == unfoldr (\x -> Just (x, f x))
--
-- In some cases, 'unfoldr' can undo a 'foldr' operation:
--
-- > unfoldr f' (foldr f z xs) == xs
--
-- if the following holds:
--
-- > f' (f x y) = Just (x,y)
-- > f' z = Nothing
--
-- A simple use of unfoldr:
--
-- > unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10
-- > [10,9,8,7,6,5,4,3,2,1]
--
unfoldr :: (b -> Maybe (a, b)) -> b -> [a]
unfoldr f b =
case f b of
Just (a,new_b) -> a : unfoldr f new_b
Nothing -> []
-- -----------------------------------------------------------------------------
-- | A strict version of 'foldl'.
foldl' :: (a -> b -> a) -> a -> [b] -> a
#ifdef __GLASGOW_HASKELL__
foldl' f z0 xs0 = lgo z0 xs0
where lgo z [] = z
lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs
#else
foldl' f a [] = a
foldl' f a (x:xs) = let a' = f a x in a' `seq` foldl' f a' xs
#endif
#ifdef __GLASGOW_HASKELL__
-- | 'foldl1' is a variant of 'foldl' that has no starting value argument,
-- and thus must be applied to non-empty lists.
foldl1 :: (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs
foldl1 _ [] = errorEmptyList "foldl1"
#endif /* __GLASGOW_HASKELL__ */
-- | A strict version of 'foldl1'
foldl1' :: (a -> a -> a) -> [a] -> a
foldl1' f (x:xs) = foldl' f x xs
foldl1' _ [] = errorEmptyList "foldl1'"
#ifdef __GLASGOW_HASKELL__
-- -----------------------------------------------------------------------------
-- List sum and product
{-# SPECIALISE sum :: [Int] -> Int #-}
{-# SPECIALISE sum :: [Integer] -> Integer #-}
{-# SPECIALISE product :: [Int] -> Int #-}
{-# SPECIALISE product :: [Integer] -> Integer #-}
-- | The 'sum' function computes the sum of a finite list of numbers.
sum :: (Num a) => [a] -> a
-- | The 'product' function computes the product of a finite list of numbers.
product :: (Num a) => [a] -> a
#ifdef USE_REPORT_PRELUDE
sum = foldl (+) 0
product = foldl (*) 1
#else
sum l = sum' l 0
where
sum' [] a = a
sum' (x:xs) a = sum' xs (a+x)
product l = prod l 1
where
prod [] a = a
prod (x:xs) a = prod xs (a*x)
#endif
-- -----------------------------------------------------------------------------
-- Functions on strings
-- | 'lines' breaks a string up into a list of strings at newline
-- characters. The resulting strings do not contain newlines.
lines :: String -> [String]
lines "" = []
#ifdef __GLASGOW_HASKELL__
-- Somehow GHC doesn't detect the selector thunks in the below code,
-- so s' keeps a reference to the first line via the pair and we have
-- a space leak (cf. #4334).
-- So we need to make GHC see the selector thunks with a trick.
lines s = cons (case break (== '\n') s of
(l, s') -> (l, case s' of
[] -> []
_:s'' -> lines s''))
where
cons ~(h, t) = h : t
#else
lines s = let (l, s') = break (== '\n') s
in l : case s' of
[] -> []
(_:s'') -> lines s''
#endif
-- | 'unlines' is an inverse operation to 'lines'.
-- It joins lines, after appending a terminating newline to each.
unlines :: [String] -> String
#ifdef USE_REPORT_PRELUDE
unlines = concatMap (++ "\n")
#else
-- HBC version (stolen)
-- here's a more efficient version
unlines [] = []
unlines (l:ls) = l ++ '\n' : unlines ls
#endif
-- | 'words' breaks a string up into a list of words, which were delimited
-- by white space.
words :: String -> [String]
words s = case dropWhile {-partain:Char.-}isSpace s of
"" -> []
s' -> w : words s''
where (w, s'') =
break {-partain:Char.-}isSpace s'
-- | 'unwords' is an inverse operation to 'words'.
-- It joins words with separating spaces.
unwords :: [String] -> String
#ifdef USE_REPORT_PRELUDE
unwords [] = ""
unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
#else
-- HBC version (stolen)
-- here's a more efficient version
unwords [] = ""
unwords [w] = w
unwords (w:ws) = w ++ ' ' : unwords ws
#endif
#else /* !__GLASGOW_HASKELL__ */
errorEmptyList :: String -> a
errorEmptyList fun =
error ("Prelude." ++ fun ++ ": empty list")
#endif /* !__GLASGOW_HASKELL__ */
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Applicative
-- Copyright : Conor McBride and Ross Paterson 2005
-- License : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- This module describes a structure intermediate between a functor and
-- a monad (technically, a strong lax monoidal functor). Compared with
-- monads, this interface lacks the full power of the binding operation
-- '>>=', but
--
-- * it has more instances.
--
-- * it is sufficient for many uses, e.g. context-free parsing, or the
-- 'Data.Traversable.Traversable' class.
--
-- * instances can perform analysis of computations before they are
-- executed, and thus produce shared optimizations.
--
-- This interface was introduced for parsers by Niklas Röjemo, because
-- it admits more sharing than the monadic interface. The names here are
-- mostly based on parsing work by Doaitse Swierstra.
--
-- For more details, see /Applicative Programming with Effects/,
-- by Conor McBride and Ross Paterson, online at
-- .
module Control.Applicative (
-- * Applicative functors
Applicative(..),
-- * Alternatives
Alternative(..),
-- * Instances
Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),
-- * Utility functions
(<$>), (<$), (<**>),
liftA, liftA2, liftA3,
optional,
) where
import Prelude hiding (id,(.))
import Control.Category
import Control.Arrow
import Control.Monad (liftM, ap, MonadPlus(..))
#ifndef __NHC__
import Control.Monad.ST.Safe (ST)
import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST)
#endif
import Data.Functor ((<$>), (<$))
import Data.Monoid (Monoid(..))
import Text.ParserCombinators.ReadP
#ifndef __NHC__
(ReadP)
#else
(ReadPN)
#define ReadP (ReadPN b)
#endif
import Text.ParserCombinators.ReadPrec (ReadPrec)
#ifdef __GLASGOW_HASKELL__
import GHC.Conc (STM, retry, orElse)
#endif
infixl 3 <|>
infixl 4 <*>, <*, *>, <**>
-- | A functor with application, providing operations to
--
-- * embed pure expressions ('pure'), and
--
-- * sequence computations and combine their results ('<*>').
--
-- A minimal complete definition must include implementations of these
-- functions satisfying the following laws:
--
-- [/identity/]
-- @'pure' 'id' '<*>' v = v@
--
-- [/composition/]
-- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
--
-- [/homomorphism/]
-- @'pure' f '<*>' 'pure' x = 'pure' (f x)@
--
-- [/interchange/]
-- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
--
-- The other methods have the following default definitions, which may
-- be overridden with equivalent specialized implementations:
--
-- @
-- u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v
-- u '<*' v = 'pure' 'const' '<*>' u '<*>' v
-- @
--
-- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
--
-- @
-- 'fmap' f x = 'pure' f '<*>' x
-- @
--
-- If @f@ is also a 'Monad', it should satisfy @'pure' = 'return'@ and
-- @('<*>') = 'ap'@ (which implies that 'pure' and '<*>' satisfy the
-- applicative functor laws).
class Functor f => Applicative f where
-- | Lift a value.
pure :: a -> f a
-- | Sequential application.
(<*>) :: f (a -> b) -> f a -> f b
-- | Sequence actions, discarding the value of the first argument.
(*>) :: f a -> f b -> f b
(*>) = liftA2 (const id)
-- | Sequence actions, discarding the value of the second argument.
(<*) :: f a -> f b -> f a
(<*) = liftA2 const
-- | A monoid on applicative functors.
--
-- Minimal complete definition: 'empty' and '<|>'.
--
-- If defined, 'some' and 'many' should be the least solutions
-- of the equations:
--
-- * @some v = (:) '<$>' v '<*>' many v@
--
-- * @many v = some v '<|>' 'pure' []@
class Applicative f => Alternative f where
-- | The identity of '<|>'
empty :: f a
-- | An associative binary operation
(<|>) :: f a -> f a -> f a
-- | One or more.
some :: f a -> f [a]
some v = some_v
where
many_v = some_v <|> pure []
some_v = (:) <$> v <*> many_v
-- | Zero or more.
many :: f a -> f [a]
many v = many_v
where
many_v = some_v <|> pure []
some_v = (:) <$> v <*> many_v
-- instances for Prelude types
instance Applicative Maybe where
pure = return
(<*>) = ap
instance Alternative Maybe where
empty = Nothing
Nothing <|> r = r
l <|> _ = l
instance Applicative [] where
pure = return
(<*>) = ap
instance Alternative [] where
empty = []
(<|>) = (++)
instance Applicative IO where
pure = return
(<*>) = ap
#ifndef __NHC__
instance Applicative (ST s) where
pure = return
(<*>) = ap
instance Applicative (Lazy.ST s) where
pure = return
(<*>) = ap
#endif
#ifdef __GLASGOW_HASKELL__
instance Applicative STM where
pure = return
(<*>) = ap
instance Alternative STM where
empty = retry
(<|>) = orElse
#endif
instance Applicative ((->) a) where
pure = const
(<*>) f g x = f x (g x)
instance Monoid a => Applicative ((,) a) where
pure x = (mempty, x)
(u, f) <*> (v, x) = (u `mappend` v, f x)
instance Applicative (Either e) where
pure = Right
Left e <*> _ = Left e
Right f <*> r = fmap f r
instance Applicative ReadP where
pure = return
(<*>) = ap
instance Alternative ReadP where
empty = mzero
(<|>) = mplus
instance Applicative ReadPrec where
pure = return
(<*>) = ap
instance Alternative ReadPrec where
empty = mzero
(<|>) = mplus
instance Arrow a => Applicative (ArrowMonad a) where
pure x = ArrowMonad (arr (const x))
ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))
instance ArrowPlus a => Alternative (ArrowMonad a) where
empty = ArrowMonad zeroArrow
ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
-- new instances
newtype Const a b = Const { getConst :: a }
instance Functor (Const m) where
fmap _ (Const v) = Const v
instance Monoid m => Applicative (Const m) where
pure _ = Const mempty
Const f <*> Const v = Const (f `mappend` v)
newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }
instance Monad m => Functor (WrappedMonad m) where
fmap f (WrapMonad v) = WrapMonad (liftM f v)
instance Monad m => Applicative (WrappedMonad m) where
pure = WrapMonad . return
WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
instance MonadPlus m => Alternative (WrappedMonad m) where
empty = WrapMonad mzero
WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)
newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }
instance Arrow a => Functor (WrappedArrow a b) where
fmap f (WrapArrow a) = WrapArrow (a >>> arr f)
instance Arrow a => Applicative (WrappedArrow a b) where
pure x = WrapArrow (arr (const x))
WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id))
instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
empty = WrapArrow zeroArrow
WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)
-- | Lists, but with an 'Applicative' functor based on zipping, so that
--
-- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@
--
newtype ZipList a = ZipList { getZipList :: [a] }
instance Functor ZipList where
fmap f (ZipList xs) = ZipList (map f xs)
instance Applicative ZipList where
pure x = ZipList (repeat x)
ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)
-- extra functions
-- | A variant of '<*>' with the arguments reversed.
(<**>) :: Applicative f => f a -> f (a -> b) -> f b
(<**>) = liftA2 (flip ($))
-- | Lift a function to actions.
-- This function may be used as a value for `fmap` in a `Functor` instance.
liftA :: Applicative f => (a -> b) -> f a -> f b
liftA f a = pure f <*> a
-- | Lift a binary function to actions.
liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
liftA2 f a b = f <$> a <*> b
-- | Lift a ternary function to actions.
liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 f a b c = f <$> a <*> b <*> c
-- | One or none.
optional :: Alternative f => f a -> f (Maybe a)
optional v = Just <$> v <|> pure Nothing
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.Trans.State.Lazy
-- Copyright : (c) Andy Gill 2001,
-- (c) Oregon Graduate Institute of Science and Technology, 2001
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : ross@soi.city.ac.uk
-- Stability : experimental
-- Portability : portable
--
-- Lazy state monads, passing an updatable state through a computation.
-- See below for examples.
--
-- In this version, sequencing of computations is lazy.
-- For a strict version, see "Control.Monad.Trans.State.Strict", which
-- has the same interface.
--
-- Some computations may not require the full power of state transformers:
--
-- * For a read-only state, see "Control.Monad.Trans.Reader".
--
-- * To accumulate a value without using it on the way, see
-- "Control.Monad.Trans.Writer".
-----------------------------------------------------------------------------
module Control.Monad.Trans.State.Lazy (
-- * The State monad
State,
state,
runState,
evalState,
execState,
mapState,
withState,
-- * The StateT monad transformer
StateT(..),
evalStateT,
execStateT,
mapStateT,
withStateT,
-- * State operations
get,
put,
modify,
gets,
-- * Lifting other operations
liftCallCC,
liftCallCC',
liftCatch,
liftListen,
liftPass,
-- * Examples
-- ** State monads
-- $examples
-- ** Counting
-- $counting
-- ** Labelling trees
-- $labelling
) where
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.Functor.Identity
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
-- ---------------------------------------------------------------------------
-- | A state monad parameterized by the type @s@ of the state to carry.
--
-- The 'return' function leaves the state unchanged, while @>>=@ uses
-- the final state of the first computation as the initial state of
-- the second.
type State s = StateT s Identity
-- | Construct a state monad computation from a function.
-- (The inverse of 'runState'.)
state :: Monad m
=> (s -> (a, s)) -- ^pure state transformer
-> StateT s m a -- ^equivalent state-passing computation
state f = StateT (return . f)
-- | Unwrap a state monad computation as a function.
-- (The inverse of 'state'.)
runState :: State s a -- ^state-passing computation to execute
-> s -- ^initial state
-> (a, s) -- ^return value and final state
runState m = runIdentity . runStateT m
-- | Evaluate a state computation with the given initial state
-- and return the final value, discarding the final state.
--
-- * @'evalState' m s = 'fst' ('runState' m s)@
evalState :: State s a -- ^state-passing computation to execute
-> s -- ^initial value
-> a -- ^return value of the state computation
evalState m s = fst (runState m s)
-- | Evaluate a state computation with the given initial state
-- and return the final state, discarding the final value.
--
-- * @'execState' m s = 'snd' ('runState' m s)@
execState :: State s a -- ^state-passing computation to execute
-> s -- ^initial value
-> s -- ^final state
execState m s = snd (runState m s)
-- | Map both the return value and final state of a computation using
-- the given function.
--
-- * @'runState' ('mapState' f m) = f . 'runState' m@
mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
mapState f = mapStateT (Identity . f . runIdentity)
-- | @'withState' f m@ executes action @m@ on a state modified by
-- applying @f@.
--
-- * @'withState' f m = 'modify' f >> m@
withState :: (s -> s) -> State s a -> State s a
withState = withStateT
-- ---------------------------------------------------------------------------
-- | A state transformer monad parameterized by:
--
-- * @s@ - The state.
--
-- * @m@ - The inner monad.
--
-- The 'return' function leaves the state unchanged, while @>>=@ uses
-- the final state of the first computation as the initial state of
-- the second.
newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
-- | Evaluate a state computation with the given initial state
-- and return the final value, discarding the final state.
--
-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@
evalStateT :: (Monad m) => StateT s m a -> s -> m a
evalStateT m s = do
~(a, _) <- runStateT m s
return a
-- | Evaluate a state computation with the given initial state
-- and return the final state, discarding the final value.
--
-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@
execStateT :: (Monad m) => StateT s m a -> s -> m s
execStateT m s = do
~(_, s') <- runStateT m s
return s'
-- | Map both the return value and final state of a computation using
-- the given function.
--
-- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@
mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT f m = StateT $ f . runStateT m
-- | @'withStateT' f m@ executes action @m@ on a state modified by
-- applying @f@.
--
-- * @'withStateT' f m = 'modify' f >> m@
withStateT :: (s -> s) -> StateT s m a -> StateT s m a
withStateT f m = StateT $ runStateT m . f
instance (Functor m) => Functor (StateT s m) where
fmap f m = StateT $ \ s ->
fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s
instance (Functor m, Monad m) => Applicative (StateT s m) where
pure = return
(<*>) = ap
instance (Functor m, MonadPlus m) => Alternative (StateT s m) where
empty = mzero
(<|>) = mplus
instance (Monad m) => Monad (StateT s m) where
return a = state $ \s -> (a, s)
m >>= k = StateT $ \s -> do
~(a, s') <- runStateT m s
runStateT (k a) s'
fail str = StateT $ \_ -> fail str
instance (MonadPlus m) => MonadPlus (StateT s m) where
mzero = StateT $ \_ -> mzero
m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s
instance (MonadFix m) => MonadFix (StateT s m) where
mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s
instance MonadTrans (StateT s) where
lift m = StateT $ \s -> do
a <- m
return (a, s)
instance (MonadIO m) => MonadIO (StateT s m) where
liftIO = lift . liftIO
-- | Fetch the current value of the state within the monad.
get :: (Monad m) => StateT s m s
get = state $ \s -> (s, s)
-- | @'put' s@ sets the state within the monad to @s@.
put :: (Monad m) => s -> StateT s m ()
put s = state $ \_ -> ((), s)
-- | @'modify' f@ is an action that updates the state to the result of
-- applying @f@ to the current state.
--
-- * @'modify' f = 'get' >>= ('put' . f)@
modify :: (Monad m) => (s -> s) -> StateT s m ()
modify f = state $ \s -> ((), f s)
-- | Get a specific component of the state, using a projection function
-- supplied.
--
-- * @'gets' f = 'liftM' f 'get'@
gets :: (Monad m) => (s -> a) -> StateT s m a
gets f = state $ \s -> (f s, s)
-- | Uniform lifting of a @callCC@ operation to the new monad.
-- This version rolls back to the original state on entering the
-- continuation.
liftCallCC :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->
((a -> StateT s m b) -> StateT s m a) -> StateT s m a
liftCallCC callCC f = StateT $ \s ->
callCC $ \c ->
runStateT (f (\a -> StateT $ \ _ -> c (a, s))) s
-- | In-situ lifting of a @callCC@ operation to the new monad.
-- This version uses the current state on entering the continuation.
-- It does not satisfy the laws of a monad transformer.
liftCallCC' :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) ->
((a -> StateT s m b) -> StateT s m a) -> StateT s m a
liftCallCC' callCC f = StateT $ \s ->
callCC $ \c ->
runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s
-- | Lift a @catchError@ operation to the new monad.
liftCatch :: (m (a,s) -> (e -> m (a,s)) -> m (a,s)) ->
StateT s m a -> (e -> StateT s m a) -> StateT s m a
liftCatch catchError m h =
StateT $ \s -> runStateT m s `catchError` \e -> runStateT (h e) s
-- | Lift a @listen@ operation to the new monad.
liftListen :: Monad m =>
(m (a,s) -> m ((a,s),w)) -> StateT s m a -> StateT s m (a,w)
liftListen listen m = StateT $ \s -> do
~((a, s'), w) <- listen (runStateT m s)
return ((a, w), s')
-- | Lift a @pass@ operation to the new monad.
liftPass :: Monad m =>
(m ((a,s),b) -> m (a,s)) -> StateT s m (a,b) -> StateT s m a
liftPass pass m = StateT $ \s -> pass $ do
~((a, f), s') <- runStateT m s
return ((a, s'), f)
{- $examples
Parser from ParseLib with Hugs:
> type Parser a = StateT String [] a
> ==> StateT (String -> [(a,String)])
For example, item can be written as:
> item = do (x:xs) <- get
> put xs
> return x
>
> type BoringState s a = StateT s Identity a
> ==> StateT (s -> Identity (a,s))
>
> type StateWithIO s a = StateT s IO a
> ==> StateT (s -> IO (a,s))
>
> type StateWithErr s a = StateT s Maybe a
> ==> StateT (s -> Maybe (a,s))
-}
{- $counting
A function to increment a counter.
Taken from the paper \"Generalising Monads to Arrows\",
John Hughes (), November 1998:
> tick :: State Int Int
> tick = do n <- get
> put (n+1)
> return n
Add one to the given number using the state monad:
> plusOne :: Int -> Int
> plusOne n = execState tick n
A contrived addition example. Works only with positive numbers:
> plus :: Int -> Int -> Int
> plus n x = execState (sequence $ replicate n tick) x
-}
{- $labelling
An example from /The Craft of Functional Programming/, Simon
Thompson (),
Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a
tree of integers in which the original elements are replaced by
natural numbers, starting from 0. The same element has to be
replaced by the same number at every occurrence, and when we meet
an as-yet-unvisited element we have to find a \'new\' number to match
it with:\"
> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)
> type Table a = [a]
> numberTree :: Eq a => Tree a -> State (Table a) (Tree Int)
> numberTree Nil = return Nil
> numberTree (Node x t1 t2)
> = do num <- numberNode x
> nt1 <- numberTree t1
> nt2 <- numberTree t2
> return (Node num nt1 nt2)
> where
> numberNode :: Eq a => a -> State (Table a) Int
> numberNode x
> = do table <- get
> (newTable, newPos) <- return (nNode x table)
> put newTable
> return newPos
> nNode:: (Eq a) => a -> Table a -> (Table a, Int)
> nNode x table
> = case (findIndexInList (== x) table) of
> Nothing -> (table ++ [x], length table)
> Just i -> (table, i)
> findIndexInList :: (a -> Bool) -> [a] -> Maybe Int
> findIndexInList = findIndexInListHelp 0
> findIndexInListHelp _ _ [] = Nothing
> findIndexInListHelp count f (h:t)
> = if (f h)
> then Just count
> else findIndexInListHelp (count+1) f t
numTree applies numberTree with an initial state:
> numTree :: (Eq a) => Tree a -> Tree Int
> numTree t = evalState (numberTree t) []
> testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil
> numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil
sumTree is a little helper function that does not use the State monad:
> sumTree :: (Num a) => Tree a -> a
> sumTree Nil = 0
> sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)
-}
{-# LANGUAGE CPP, ExistentialQuantification, FlexibleContexts, Rank2Types,
TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances,
UndecidableInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving,
DeriveFunctor, DeriveFoldable, DeriveTraversable
#-}
module Agda.TypeChecking.Monad.Base where
import Control.Arrow
import qualified Control.Concurrent as C
import Control.DeepSeq
import Control.Exception as E
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Reader
import Control.Applicative
import Data.Function
import Data.Int
import Data.Map as Map
import Data.Set as Set
import Data.Sequence as Seq
import Data.Typeable (Typeable)
import Data.Foldable
import Data.Traversable
import Data.IORef
import Data.Hashable
import Agda.Syntax.Common
import qualified Agda.Syntax.Concrete as C
import qualified Agda.Syntax.Concrete.Definitions as D
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Internal
import Agda.Syntax.Position
import Agda.Syntax.Scope.Base
import Agda.Utils.HashMap as HMap
import Agda.TypeChecking.CompiledClause
import Agda.Interaction.Exceptions
import {-# SOURCE #-} Agda.Interaction.FindFile
import Agda.Interaction.Options
import qualified Agda.Interaction.Highlighting.Range as R
import {-# SOURCE #-} Agda.Interaction.Response
(InteractionOutputCallback, defaultInteractionOutputCallback)
import Agda.Interaction.Highlighting.Precise
(CompressedFile, HighlightingInfo)
import Data.Monoid
import qualified Agda.Compiler.JS.Syntax as JS
import Agda.Utils.FileName
import Agda.Utils.Fresh
import Agda.Utils.Monad
import Agda.Utils.Permutation
import Agda.Utils.Pretty
import Agda.Utils.Time
#include "../../undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
-- * Type checking state
---------------------------------------------------------------------------
data TCState =
TCSt { stFreshThings :: FreshThings
, stSyntaxInfo :: CompressedFile
-- ^ Highlighting info.
, stTokens :: CompressedFile
-- ^ Highlighting info for tokens (but not those tokens for
-- which highlighting exists in 'stSyntaxInfo').
, stTermErrs :: Seq TerminationError
, stMetaStore :: MetaStore
, stInteractionPoints :: InteractionPoints
, stAwakeConstraints :: Constraints
, stSleepingConstraints :: Constraints
, stDirty :: Bool
, stOccursCheckDefs :: Set QName
-- ^ Definitions to be considered during occurs check.
-- Initialized to the current mutual block before the check.
, stSignature :: Signature
, stImports :: Signature
, stImportedModules :: Set ModuleName
, stModuleToSource :: ModuleToSource
, stVisitedModules :: VisitedModules
, stCurrentModule :: Maybe ModuleName
-- ^ The current module is available after it has been type
-- checked.
, stScope :: ScopeInfo
, stPatternSyns :: A.PatternSynDefns
, stPatternSynImports :: A.PatternSynDefns
, stPragmaOptions :: PragmaOptions
-- ^ Options applying to the current file. @OPTIONS@
-- pragmas only affect this field.
, stStatistics :: Statistics
, stExtLambdaTele :: Map QName (Int , Int)
, stMutualBlocks :: Map MutualId (Set QName)
, stLocalBuiltins :: BuiltinThings PrimFun
, stImportedBuiltins :: BuiltinThings PrimFun
, stHaskellImports :: Set String
-- ^ Imports that should be generated by the compiler (this
-- includes imports from imported modules).
, stPersistent :: PersistentTCState
, stInteractionOutputCallback :: InteractionOutputCallback
-- ^ Callback fuction to call when there is a response
-- to give to the interactive frontend.
-- See the documentation of 'InteractionOutputCallback'.
}
-- | A part of the state which is not reverted when an error is thrown
-- or the state is reset.
data PersistentTCState = PersistentTCSt
{ stDecodedModules :: DecodedModules
, stPersistentOptions :: CommandLineOptions
-- ^ Options which apply to all files, unless overridden.
}
data FreshThings =
Fresh { fMeta :: MetaId
, fInteraction :: InteractionId
, fMutual :: MutualId
, fName :: NameId
, fCtx :: CtxId
, fProblem :: ProblemId
, fInt :: Int
-- ^ Can be used for various things.
}
deriving (Show)
initState :: TCState
initState =
TCSt { stFreshThings = (Fresh 0 0 0 (NameId 0 0) 0 0 0) { fProblem = 1 }
, stMetaStore = Map.empty
, stSyntaxInfo = mempty
, stTokens = mempty
, stTermErrs = Seq.empty
, stInteractionPoints = Map.empty
, stAwakeConstraints = []
, stSleepingConstraints = []
, stDirty = False
, stOccursCheckDefs = Set.empty
, stSignature = emptySignature
, stImports = emptySignature
, stImportedModules = Set.empty
, stModuleToSource = Map.empty
, stVisitedModules = Map.empty
, stCurrentModule = Nothing
, stScope = emptyScopeInfo
, stPatternSyns = Map.empty
, stPatternSynImports = Map.empty
, stPragmaOptions = defaultInteractionOptions
, stStatistics = Map.empty
, stExtLambdaTele = Map.empty
, stMutualBlocks = Map.empty
, stLocalBuiltins = Map.empty
, stImportedBuiltins = Map.empty
, stHaskellImports = Set.empty
, stPersistent = PersistentTCSt
{ stPersistentOptions = defaultOptions
, stDecodedModules = Map.empty
}
, stInteractionOutputCallback = defaultInteractionOutputCallback
}
stBuiltinThings :: TCState -> BuiltinThings PrimFun
stBuiltinThings s = stLocalBuiltins s `Map.union` stImportedBuiltins s
instance HasFresh MetaId FreshThings where
nextFresh s = (i, s { fMeta = i + 1 })
where
i = fMeta s
instance HasFresh MutualId FreshThings where
nextFresh s = (i, s { fMutual = i + 1 })
where
i = fMutual s
instance HasFresh InteractionId FreshThings where
nextFresh s = (i, s { fInteraction = i + 1 })
where
i = fInteraction s
instance HasFresh NameId FreshThings where
nextFresh s = (i, s { fName = succ i })
where
i = fName s
instance HasFresh CtxId FreshThings where
nextFresh s = (i, s { fCtx = succ i })
where
i = fCtx s
instance HasFresh Int FreshThings where
nextFresh s = (i, s { fInt = succ i })
where
i = fInt s
newtype ProblemId = ProblemId Nat
deriving (Typeable, Eq, Ord, Enum, Real, Integral, Num)
instance Show ProblemId where
show (ProblemId n) = show n
instance HasFresh ProblemId FreshThings where
nextFresh s = (i, s { fProblem = succ i })
where i = fProblem s
instance HasFresh i FreshThings => HasFresh i TCState where
nextFresh s = ((,) $! i) $! s { stFreshThings = f }
where
(i, f) = nextFresh $ stFreshThings s
---------------------------------------------------------------------------
-- ** Interface
---------------------------------------------------------------------------
data ModuleInfo = ModuleInfo
{ miInterface :: Interface
, miWarnings :: Bool
-- ^ 'True' if warnings were encountered when the module was type
-- checked.
, miTimeStamp :: ClockTime
-- ^ The modification time stamp of the interface file when the
-- interface was read or written. Alternatively, if warnings were
-- encountered (in which case there may not be any up-to-date
-- interface file), the time at which the interface was produced
-- (approximately).
}
-- Note that the use of 'C.TopLevelModuleName' here is a potential
-- performance problem, because these names do not contain unique
-- identifiers.
type VisitedModules = Map C.TopLevelModuleName ModuleInfo
type DecodedModules = Map C.TopLevelModuleName (Interface, ClockTime)
data Interface = Interface
{ iImportedModules :: [ModuleName]
, iModuleName :: ModuleName
, iScope :: Map ModuleName Scope
, iInsideScope :: ScopeInfo
, iSignature :: Signature
, iBuiltin :: BuiltinThings (String, QName)
, iHaskellImports :: Set String
-- ^ Haskell imports listed in
-- (transitively) imported modules are
-- not included here.
, iHighlighting :: HighlightingInfo
, iPragmaOptions :: [OptionsPragma]
-- ^ Pragma options set in the file.
, iPatternSyns :: A.PatternSynDefns
}
deriving (Typeable, Show)
---------------------------------------------------------------------------
-- ** Closure
---------------------------------------------------------------------------
data Closure a = Closure { clSignature :: Signature
, clEnv :: TCEnv
, clScope :: ScopeInfo
, clValue :: a
}
deriving (Typeable)
instance Show a => Show (Closure a) where
show cl = "Closure " ++ show (clValue cl)
instance HasRange a => HasRange (Closure a) where
getRange = getRange . clValue
buildClosure :: a -> TCM (Closure a)
buildClosure x = do
env <- ask
sig <- gets stSignature
scope <- gets stScope
return $ Closure sig env scope x
---------------------------------------------------------------------------
-- ** Constraints
---------------------------------------------------------------------------
type Constraints = [ProblemConstraint]
data ProblemConstraint = PConstr
{ constraintProblem :: ProblemId
, theConstraint :: Closure Constraint
}
deriving (Typeable, Show)
data Constraint
= ValueCmp Comparison Type Term Term
| ElimCmp [Polarity] Type Term [Elim] [Elim]
| TypeCmp Comparison Type Type
| TelCmp Type Type Comparison Telescope Telescope -- ^ the two types are for the error message only
| SortCmp Comparison Sort Sort
| LevelCmp Comparison Level Level
-- | ShortCut MetaId Term Type
-- -- ^ A delayed instantiation. Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'.
| UnBlock MetaId
| Guarded Constraint ProblemId
| IsEmpty Range Type
-- ^ the range is the one of the absurd pattern
| FindInScope MetaId [(Term, Type)]
deriving (Typeable, Show)
data Comparison = CmpEq | CmpLeq
deriving (Eq, Typeable)
instance Show Comparison where
show CmpEq = "="
show CmpLeq = "=<"
---------------------------------------------------------------------------
-- * Open things
---------------------------------------------------------------------------
-- | A thing tagged with the context it came from.
data Open a = OpenThing [CtxId] a
deriving (Typeable, Show, Functor)
---------------------------------------------------------------------------
-- * Judgements
--
-- Used exclusively for typing of meta variables.
---------------------------------------------------------------------------
data Judgement t a
= HasType { jMetaId :: a, jMetaType :: t }
| IsSort { jMetaId :: a, jMetaType :: t } -- Andreas, 2011-04-26: type needed for higher-order sort metas
deriving (Typeable, Functor, Foldable, Traversable)
instance (Show t, Show a) => Show (Judgement t a) where
show (HasType a t) = show a ++ " : " ++ show t
show (IsSort a t) = show a ++ " :sort " ++ show t
---------------------------------------------------------------------------
-- ** Meta variables
---------------------------------------------------------------------------
data MetaVariable =
MetaVar { mvInfo :: MetaInfo
, mvPriority :: MetaPriority -- ^ some metavariables are more eager to be instantiated
, mvPermutation :: Permutation
-- ^ a metavariable doesn't have to depend on all variables
-- in the context, this "permutation" will throw away the
-- ones it does not depend on
, mvJudgement :: Judgement Type MetaId
, mvInstantiation :: MetaInstantiation
, mvListeners :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one
, mvFrozen :: Frozen -- ^ are we past the point where we can instantiate this meta variable?
}
deriving (Typeable)
data Listener = EtaExpand MetaId
| CheckConstraint Nat ProblemConstraint
deriving (Typeable)
instance Eq Listener where
EtaExpand x == EtaExpand y = x == y
CheckConstraint x _ == CheckConstraint y _ = x == y
_ == _ = False
instance Ord Listener where
EtaExpand x `compare` EtaExpand y = x `compare` y
CheckConstraint x _ `compare` CheckConstraint y _ = x `compare` y
EtaExpand{} `compare` CheckConstraint{} = LT
CheckConstraint{} `compare` EtaExpand{} = Prelude.GT
-- | Frozen meta variable cannot be instantiated by unification.
-- This serves to prevent the completion of a definition by its use
-- outside of the current block.
-- (See issues 118, 288, 399).
data Frozen
= Frozen -- ^ Do not instantiate.
| Instantiable
deriving (Eq, Show)
data MetaInstantiation
= InstV Term -- ^ solved by term
| InstS Term -- ^ solved by @Lam .. Sort s@
| Open -- ^ unsolved
| OpenIFS -- ^ open, to be instantiated as "implicit from scope"
| BlockedConst Term -- ^ solution blocked by unsolved constraints
| PostponedTypeCheckingProblem (Closure (A.Expr, Type, TCM Bool))
deriving (Typeable)
instance Show MetaInstantiation where
show (InstV t) = "InstV (" ++ show t ++ ")"
show (InstS s) = "InstS (" ++ show s ++ ")"
show Open = "Open"
show OpenIFS = "OpenIFS"
show (BlockedConst t) = "BlockedConst (" ++ show t ++ ")"
show (PostponedTypeCheckingProblem{}) = "PostponedTypeCheckingProblem (...)"
newtype MetaPriority = MetaPriority Int
deriving (Eq, Ord, Show)
data RunMetaOccursCheck
= RunMetaOccursCheck
| DontRunMetaOccursCheck
deriving (Eq, Ord, Show)
-- | @MetaInfo@ is cloned from one meta to the next during pruning.
data MetaInfo = MetaInfo
{ miClosRange :: Closure Range -- TODO: Not so nice. But we want both to have the environment of the meta (Closure) and its range.
-- , miRelevance :: Relevance -- ^ Created in irrelevant position?
, miMetaOccursCheck :: RunMetaOccursCheck -- ^ Run the extended occurs check that goes in definitions?
, miNameSuggestion :: MetaNameSuggestion
-- ^ Used for printing.
-- @Just x@ if meta-variable comes from omitted argument with name @x@.
}
-- | Name suggestion for meta variable. Empty string means no suggestion.
type MetaNameSuggestion = String
-- | For printing, we couple a meta with its name suggestion.
data NamedMeta = NamedMeta
{ nmSuggestion :: MetaNameSuggestion
, nmid :: MetaId
}
instance Show NamedMeta where
show (NamedMeta "" x) = show x
show (NamedMeta s x) = "_" ++ s ++ show x
type MetaStore = Map MetaId MetaVariable
instance HasRange MetaVariable where
getRange m = getRange $ getMetaInfo m
instance SetRange MetaVariable where
setRange r m = m { mvInfo = (mvInfo m)
{ miClosRange = (miClosRange (mvInfo m))
{ clValue = r }}}
normalMetaPriority :: MetaPriority
normalMetaPriority = MetaPriority 0
lowMetaPriority :: MetaPriority
lowMetaPriority = MetaPriority (-10)
highMetaPriority :: MetaPriority
highMetaPriority = MetaPriority 10
getMetaInfo :: MetaVariable -> Closure Range
getMetaInfo = miClosRange . mvInfo
getMetaScope :: MetaVariable -> ScopeInfo
getMetaScope m = clScope $ getMetaInfo m
getMetaEnv :: MetaVariable -> TCEnv
getMetaEnv m = clEnv $ getMetaInfo m
getMetaSig :: MetaVariable -> Signature
getMetaSig m = clSignature $ getMetaInfo m
getMetaRelevance :: MetaVariable -> Relevance
getMetaRelevance = envRelevance . getMetaEnv
---------------------------------------------------------------------------
-- ** Interaction meta variables
---------------------------------------------------------------------------
type InteractionPoints = Map InteractionId MetaId
newtype InteractionId = InteractionId Nat
deriving (Eq,Ord,Num,Integral,Real,Enum)
instance Show InteractionId where
show (InteractionId x) = "?" ++ show x
---------------------------------------------------------------------------
-- ** Signature
---------------------------------------------------------------------------
data Signature = Sig
{ sigSections :: Sections
, sigDefinitions :: Definitions
}
deriving (Typeable, Show)
type Sections = Map ModuleName Section
type Definitions = HashMap QName Definition
data Section = Section
{ secTelescope :: Telescope
, secFreeVars :: Nat -- ^ This is the number of parameters when
-- we're inside the section and 0
-- outside. It's used to know how much of
-- the context to apply function from the
-- section to when translating from
-- abstract to internal syntax.
}
deriving (Typeable, Show)
emptySignature :: Signature
emptySignature = Sig Map.empty HMap.empty
data DisplayForm = Display Nat [Term] DisplayTerm
-- ^ The three arguments are:
--
-- * @n@: number of free variables;
--
-- * Patterns for arguments, one extra free var which
-- represents pattern vars. There should @n@ of them.
--
-- * Display form. @n@ free variables.
deriving (Typeable, Show)
data DisplayTerm = DWithApp [DisplayTerm] Args
| DCon QName [Arg DisplayTerm]
| DDef QName [Arg DisplayTerm]
| DDot Term
| DTerm Term
deriving (Typeable, Show)
defaultDisplayForm :: QName -> [Open DisplayForm]
defaultDisplayForm c = []
data Definition = Defn
{ defRelevance :: Relevance -- ^ Some defs can be irrelevant (but not hidden).
, defName :: QName
, defType :: Type -- ^ Type of the lifted definition.
, defPolarity :: [Polarity]
, defArgOccurrences :: [Occurrence]
, defDisplay :: [Open DisplayForm]
, defMutual :: MutualId
, defCompiledRep :: CompiledRepresentation
, theDef :: Defn
}
deriving (Typeable, Show)
type HaskellCode = String
type HaskellType = String
type EpicCode = String
type JSCode = JS.Exp
data HaskellRepresentation
= HsDefn HaskellType HaskellCode
| HsType HaskellType
deriving (Typeable, Show)
-- | Polarity for equality and subtype checking.
data Polarity
= Covariant -- ^ monotone
| Contravariant -- ^ antitone
| Invariant -- ^ no information (mixed variance)
| Nonvariant -- ^ constant
deriving (Typeable, Show, Eq)
data CompiledRepresentation = CompiledRep
{ compiledHaskell :: Maybe HaskellRepresentation
, compiledEpic :: Maybe EpicCode
, compiledJS :: Maybe JSCode
}
deriving (Typeable, Show)
noCompiledRep :: CompiledRepresentation
noCompiledRep = CompiledRep Nothing Nothing Nothing
-- | Subterm occurrences for positivity checking.
-- The constructors are listed in increasing information they provide:
-- @Mixed <= JustPos <= StrictPos <= GuardPos <= Unused@
-- @Mixed <= JustNeg <= Unused@.
data Occurrence
= Mixed -- ^ Arbitrary occurrence (positive and negative).
| JustNeg -- ^ Negative occurrence.
| JustPos -- ^ Positive occurrence, but not strictly positive.
| StrictPos -- ^ Strictly positive occurrence.
| GuardPos -- ^ Guarded strictly positive occurrence (i.e., under ∞). For checking recursive records.
| Unused -- ^ No occurrence.
deriving (Typeable, Show, Eq, Ord)
instance NFData Occurrence
data Defn = Axiom
| Function
{ funClauses :: [Clause]
, funCompiled :: CompiledClauses
, funInv :: FunctionInverse
{- MOVED to Definition
, funPolarity :: [Polarity]
, funArgOccurrences :: [Occurrence]
-}
, funMutual :: [QName]
-- ^ Mutually recursive functions, @data@s and @record@s.
, funAbstr :: IsAbstract
, funDelayed :: Delayed
-- ^ Are the clauses of this definition delayed?
, funProjection :: Maybe (QName, Int)
-- ^ Is it a record projection?
-- If yes, then return the name of the record type and index of
-- the record argument. Start counting with 1, because 0 means that
-- it is already applied to the record. (Can happen in module
-- instantiation.) This information is used in the termination
-- checker.
, funStatic :: Bool
-- ^ Should calls to this function be normalised at compile-time?
, funCopy :: Bool
-- ^ Has this function been created by a module
-- instantiation?
, funTerminates :: Maybe Bool
-- ^ Has this function been termination checked? Did it pass?
}
| Datatype
{ dataPars :: Nat -- nof parameters
, dataIxs :: Nat -- nof indices
, dataInduction :: Induction -- data or codata?
, dataClause :: (Maybe Clause) -- this might be in an instantiated module
, dataCons :: [QName] -- constructor names
, dataSort :: Sort
{- MOVED
, dataPolarity :: [Polarity]
, dataArgOccurrences :: [Occurrence]
-}
, dataMutual :: [QName] -- ^ Mutually recursive functions, @data@s and @record@s.
, dataAbstr :: IsAbstract
}
| Record
{ recPars :: Nat -- ^ Number of parameters.
, recClause :: Maybe Clause
, recCon :: QName -- ^ Constructor name.
, recNamedCon :: Bool
, recConType :: Type -- ^ The record constructor's type.
, recFields :: [Arg A.QName]
, recTel :: Telescope -- ^ The record field telescope
{- MOVED
, recPolarity :: [Polarity]
, recArgOccurrences :: [Occurrence]
-}
, recMutual :: [QName] -- ^ Mutually recursive functions, @data@s and @record@s.
, recEtaEquality :: Bool -- ^ Eta-expand at this record type. @False@ for unguarded recursive records.
, recInduction :: Induction -- ^ 'Inductive' or 'Coinductive'? Matters only for recursive records.
, recRecursive :: Bool -- ^ Recursive record. Implies @recEtaEquality = False@. Projections are not size-preserving.
, recAbstr :: IsAbstract
}
| Constructor
{ conPars :: Nat -- nof parameters
, conSrcCon :: QName -- original constructor (this might be in a module instance)
, conData :: QName -- name of datatype or record type
, conAbstr :: IsAbstract
, conInd :: Induction -- ^ Inductive or coinductive?
}
| Primitive
{ primAbstr :: IsAbstract
, primName :: String
, primClauses :: Maybe [Clause]
-- ^ 'Nothing' for primitive functions, @'Just'
-- something@ for builtin functions.
, primCompiled :: Maybe CompiledClauses
-- ^ 'Nothing' for primitive functions, @'Just'
-- something@ for builtin functions.
}
-- ^ Primitive or builtin functions.
deriving (Typeable, Show)
defIsRecord :: Defn -> Bool
defIsRecord Record{} = True
defIsRecord _ = False
defIsDataOrRecord :: Defn -> Bool
defIsDataOrRecord Record{} = True
defIsDataOrRecord Datatype{} = True
defIsDataOrRecord _ = False
newtype Fields = Fields [(C.Name, Type)]
deriving (Typeable)
data Reduced no yes = NoReduction no | YesReduction yes
deriving (Typeable, Functor)
data IsReduced = NotReduced | Reduced (Blocked ())
data MaybeReduced a = MaybeRed
{ isReduced :: IsReduced
, ignoreReduced :: a
}
deriving (Functor)
type MaybeReducedArgs = [MaybeReduced (Arg Term)]
notReduced :: a -> MaybeReduced a
notReduced x = MaybeRed NotReduced x
reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced b = case fmap ignoreSharing <$> b of
NotBlocked (Arg _ _ (MetaV x _)) -> MaybeRed (Reduced $ Blocked x ()) v
_ -> MaybeRed (Reduced $ () <$ b) v
where
v = ignoreBlocking b
data PrimFun = PrimFun
{ primFunName :: QName
, primFunArity :: Arity
, primFunImplementation :: [Arg Term] -> TCM (Reduced MaybeReducedArgs Term)
}
deriving (Typeable)
defClauses :: Definition -> [Clause]
defClauses Defn{theDef = Function{funClauses = cs}} = cs
defClauses Defn{theDef = Primitive{primClauses = Just cs}} = cs
defClauses Defn{theDef = Datatype{dataClause = Just c}} = [c]
defClauses Defn{theDef = Record{recClause = Just c}} = [c]
defClauses _ = []
defCompiled :: Definition -> Maybe CompiledClauses
defCompiled Defn{theDef = Function{funCompiled = cc}} = Just cc
defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc
defCompiled _ = Nothing
defJSDef :: Definition -> Maybe JSCode
defJSDef = compiledJS . defCompiledRep
defEpicDef :: Definition -> Maybe EpicCode
defEpicDef = compiledEpic . defCompiledRep
-- | Are the clauses of this definition delayed?
defDelayed :: Definition -> Delayed
defDelayed Defn{theDef = Function{funDelayed = d}} = d
defDelayed _ = NotDelayed
-- | Is the definition just a copy created by a module instantiation?
defCopy :: Definition -> Bool
defCopy Defn{theDef = Function{funCopy = b}} = b
defCopy _ = False
defAbstract :: Definition -> IsAbstract
defAbstract d = case theDef d of
Axiom{} -> ConcreteDef
Function{funAbstr = a} -> a
Datatype{dataAbstr = a} -> a
Record{recAbstr = a} -> a
Constructor{conAbstr = a} -> a
Primitive{primAbstr = a} -> a
---------------------------------------------------------------------------
-- ** Injectivity
---------------------------------------------------------------------------
type FunctionInverse = FunctionInverse' Clause
data FunctionInverse' c
= NotInjective
| Inverse (Map TermHead c)
deriving (Typeable, Show, Functor)
data TermHead = SortHead
| PiHead
| ConHead QName
deriving (Typeable, Eq, Ord, Show)
---------------------------------------------------------------------------
-- ** Mutual blocks
---------------------------------------------------------------------------
newtype MutualId = MutId Int32
deriving (Typeable, Eq, Ord, Show, Num)
---------------------------------------------------------------------------
-- ** Statistics
---------------------------------------------------------------------------
type Statistics = Map String Integer
---------------------------------------------------------------------------
-- ** Trace
---------------------------------------------------------------------------
data Call = CheckClause Type A.Clause (Maybe Clause)
| forall a. CheckPattern A.Pattern Telescope Type (Maybe a)
| CheckLetBinding A.LetBinding (Maybe ())
| InferExpr A.Expr (Maybe (Term, Type))
| CheckExpr A.Expr Type (Maybe Term)
| CheckDotPattern A.Expr Term (Maybe Constraints)
| CheckPatternShadowing A.Clause (Maybe ())
| IsTypeCall A.Expr Sort (Maybe Type)
| IsType_ A.Expr (Maybe Type)
| InferVar Name (Maybe (Term, Type))
| InferDef Range QName (Maybe (Term, Type))
| CheckArguments Range [NamedArg A.Expr] Type Type (Maybe (Args, Type))
| CheckDataDef Range Name [A.LamBinding] [A.Constructor] (Maybe ())
| CheckRecDef Range Name [A.LamBinding] [A.Constructor] (Maybe ())
| CheckConstructor QName Telescope Sort A.Constructor (Maybe ())
| CheckFunDef Range Name [A.Clause] (Maybe ())
| CheckPragma Range A.Pragma (Maybe ())
| CheckPrimitive Range Name A.Expr (Maybe ())
| CheckIsEmpty Range Type (Maybe ())
| CheckWithFunctionType A.Expr (Maybe ())
| CheckSectionApplication Range ModuleName A.ModuleApplication (Maybe ())
| ScopeCheckExpr C.Expr (Maybe A.Expr)
| ScopeCheckDeclaration D.NiceDeclaration (Maybe [A.Declaration])
| ScopeCheckLHS C.Name C.Pattern (Maybe A.LHS)
| forall a. NoHighlighting (Maybe a)
| forall a. SetRange Range (Maybe a) -- ^ used by 'setCurrentRange'
deriving (Typeable)
instance HasRange Call where
getRange (CheckClause _ c _) = getRange c
getRange (CheckPattern p _ _ _) = getRange p
getRange (InferExpr e _) = getRange e
getRange (CheckExpr e _ _) = getRange e
getRange (CheckLetBinding b _) = getRange b
getRange (IsTypeCall e s _) = getRange e
getRange (IsType_ e _) = getRange e
getRange (InferVar x _) = getRange x
getRange (InferDef _ f _) = getRange f
getRange (CheckArguments r _ _ _ _) = r
getRange (CheckDataDef i _ _ _ _) = getRange i
getRange (CheckRecDef i _ _ _ _) = getRange i
getRange (CheckConstructor _ _ _ c _) = getRange c
getRange (CheckFunDef i _ _ _) = getRange i
getRange (CheckPragma r _ _) = r
getRange (CheckPrimitive i _ _ _) = getRange i
getRange CheckWithFunctionType{} = noRange
getRange (ScopeCheckExpr e _) = getRange e
getRange (ScopeCheckDeclaration d _) = getRange d
getRange (ScopeCheckLHS _ p _) = getRange p
getRange (CheckDotPattern e _ _) = getRange e
getRange (CheckPatternShadowing c _) = getRange c
getRange (SetRange r _) = r
getRange (CheckSectionApplication r _ _ _) = r
getRange (CheckIsEmpty r _ _) = r
getRange (NoHighlighting _) = noRange
---------------------------------------------------------------------------
-- ** Builtin things
---------------------------------------------------------------------------
data BuiltinDescriptor = BuiltinData (TCM Type) [String]
| BuiltinDataCons (TCM Type)
| BuiltinPrim String (Term -> TCM ())
| BuiltinPostulate Relevance (TCM Type)
| BuiltinUnknown (Maybe (TCM Type)) (Term -> TCM ())
data BuiltinInfo =
BuiltinInfo { builtinName :: String
, builtinDesc :: BuiltinDescriptor }
type BuiltinThings pf = Map String (Builtin pf)
data Builtin pf
= Builtin Term
| Prim pf
deriving (Typeable, Show, Functor, Foldable, Traversable)
---------------------------------------------------------------------------
-- * Highlighting levels
---------------------------------------------------------------------------
-- | How much highlighting should be sent to the user interface?
data HighlightingLevel
= None
| NonInteractive
| Interactive
-- ^ This includes both non-interactive highlighting and
-- interactive highlighting of the expression that is currently
-- being type-checked.
deriving (Eq, Ord, Show, Read)
-- | How should highlighting be sent to the user interface?
data HighlightingMethod
= Direct
-- ^ Via stdout.
| Indirect
-- ^ Both via files and via stdout.
deriving (Eq, Show, Read)
-- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're
-- type-checking the top-level module and the highlighting level is
-- /at least/ @l@.
ifTopLevelAndHighlightingLevelIs ::
MonadTCM tcm => HighlightingLevel -> tcm () -> tcm ()
ifTopLevelAndHighlightingLevelIs l m = do
e <- ask
when (envModuleNestingLevel e == 0 &&
envHighlightingLevel e >= l)
m
---------------------------------------------------------------------------
-- * Type checking environment
---------------------------------------------------------------------------
data TCEnv =
TCEnv { envContext :: Context
, envLetBindings :: LetBindings
, envCurrentModule :: ModuleName
, envCurrentPath :: AbsolutePath
-- ^ The path to the file that is currently being
-- type-checked.
, envAnonymousModules :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables
, envImportPath :: [C.TopLevelModuleName] -- ^ to detect import cycles
, envMutualBlock :: Maybe MutualId -- ^ the current (if any) mutual block
, envSolvingConstraints :: Bool
-- ^ Are we currently in the process of solving active constraints?
, envAssignMetas :: Bool
-- ^ Are we allowed to assign metas?
, envActiveProblems :: [ProblemId]
, envAbstractMode :: AbstractMode
-- ^ When checking the typesignature of a public definition
-- or the body of a non-abstract definition this is true.
-- To prevent information about abstract things leaking
-- outside the module.
, envRelevance :: Relevance
-- ^ Are we checking an irrelevant argument? (=@Irrelevant@)
-- Then top-level irrelevant declarations are enabled.
-- Other value: @Relevant@, then only relevant decls. are avail.
, envDisplayFormsEnabled :: Bool
-- ^ Sometimes we want to disable display forms.
, envReifyInteractionPoints :: Bool
-- ^ should we try to recover interaction points when reifying?
-- disabled when generating types for with functions
, envEtaContractImplicit :: Bool
-- ^ it's safe to eta contract implicit lambdas as long as we're
-- not going to reify and retypecheck (like when doing with
-- abstraction)
, envRange :: Range
, envHighlightingRange :: Range
-- ^ Interactive highlighting uses this range rather
-- than 'envRange'.
, envCall :: Maybe (Closure Call)
-- ^ what we're doing at the moment
, envEmacs :: Bool
-- ^ True when called from the Emacs mode.
, envHighlightingLevel :: HighlightingLevel
-- ^ Set to 'None' when imported modules are
-- type-checked.
, envHighlightingMethod :: HighlightingMethod
, envModuleNestingLevel :: Integer
-- ^ This number indicates how far away from the
-- top-level module Agda has come when chasing
-- modules. The level of a given module is not
-- necessarily the same as the length, in the module
-- dependency graph, of the shortest path from the
-- top-level module; it depends on in which order
-- Agda chooses to chase dependencies.
, envAllowDestructiveUpdate :: Bool
-- ^ When True, allows destructively shared updating terms
-- during evaluation or unification. This is disabled when
-- doing speculative checking, like solve instance metas, or
-- when updating might break abstraction, as is the case when
-- checking abstract definitions.
}
deriving (Typeable)
initEnv :: TCEnv
initEnv = TCEnv { envContext = []
, envLetBindings = Map.empty
, envCurrentModule = noModuleName
, envCurrentPath = __IMPOSSIBLE__
, envAnonymousModules = []
, envImportPath = []
, envMutualBlock = Nothing
, envSolvingConstraints = False
, envActiveProblems = [0]
, envAssignMetas = True
, envAbstractMode = AbstractMode
, envRelevance = Relevant
, envDisplayFormsEnabled = True
, envReifyInteractionPoints = True
, envEtaContractImplicit = True
, envRange = noRange
, envHighlightingRange = noRange
, envCall = Nothing
, envEmacs = False
, envHighlightingLevel = None
, envHighlightingMethod = Indirect
, envModuleNestingLevel = -1
, envAllowDestructiveUpdate = True
}
---------------------------------------------------------------------------
-- ** Context
---------------------------------------------------------------------------
-- | The @Context@ is a stack of 'ContextEntry's.
type Context = [ContextEntry]
data ContextEntry = Ctx { ctxId :: CtxId
, ctxEntry :: Dom (Name, Type)
}
deriving (Typeable)
newtype CtxId = CtxId Nat
deriving (Typeable, Eq, Ord, Show, Enum, Real, Integral, Num)
---------------------------------------------------------------------------
-- ** Let bindings
---------------------------------------------------------------------------
type LetBindings = Map Name (Open (Term, Dom Type))
---------------------------------------------------------------------------
-- ** Abstract mode
---------------------------------------------------------------------------
data AbstractMode = AbstractMode -- ^ abstract things in the current module can be accessed
| ConcreteMode -- ^ no abstract things can be accessed
| IgnoreAbstractMode -- ^ all abstract things can be accessed
deriving (Typeable)
---------------------------------------------------------------------------
-- ** Insertion of implicit arguments
---------------------------------------------------------------------------
data ExpandHidden
= ExpandLast -- ^ Add implicit arguments in the end until type is no longer hidden 'Pi'.
| DontExpandLast -- ^ Do not append implicit arguments.
data ExpandInstances
= ExpandInstanceArguments
| DontExpandInstanceArguments
deriving (Eq)
---------------------------------------------------------------------------
-- * Type checking errors
---------------------------------------------------------------------------
-- Occurence of a name in a datatype definition
data Occ = OccCon { occDatatype :: QName
, occConstructor :: QName
, occPosition :: OccPos
}
| OccClause { occFunction :: QName
, occClause :: Int
, occPosition :: OccPos
}
deriving (Show)
data OccPos = NonPositively | ArgumentTo Nat QName
deriving (Show)
-- | Information about a call.
data CallInfo = CallInfo
{ callInfoRange :: Range
-- ^ Range of the head identifier.
, callInfoCall :: String
-- ^ Formatted representation of the call.
--
-- ('Doc' would perhaps be better here, but 'Doc' doesn't come
-- with an 'Ord' instance.)
} deriving (Eq, Ord, Typeable, Show)
-- | Information about a mutual block which did not pass the
-- termination checker.
data TerminationError = TerminationError
{ termErrFunctions :: [QName]
-- ^ The functions which failed to check. (May not include
-- automatically generated functions.)
, termErrCalls :: [CallInfo]
-- ^ The problematic call sites.
} deriving (Typeable, Show, Eq)
{-
-- | We consider two 'TerminationError's equal if they report the same
-- invalid calls.
instance Eq TerminationError where
(==) = (==) `on` termErrCalls
-}
data TypeError
= InternalError String
| NotImplemented String
| NotSupported String
| CompilationError String
| TerminationCheckFailed [TerminationError]
| PropMustBeSingleton
| DataMustEndInSort Term
{- UNUSED
| DataTooManyParameters
-- ^ In @data D xs where@ the number of parameters @xs@ does not fit the
-- the parameters given in the forward declaraion @data D Gamma : T@.
-}
| ShouldEndInApplicationOfTheDatatype Type
-- ^ The target of a constructor isn't an application of its
-- datatype. The 'Type' records what it does target.
| ShouldBeAppliedToTheDatatypeParameters Term Term
-- ^ The target of a constructor isn't its datatype applied to
-- something that isn't the parameters. First term is the correct
-- target and the second term is the actual target.
| ShouldBeApplicationOf Type QName
-- ^ Expected a type to be an application of a particular datatype.
| ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype
| IndicesNotConstructorApplications [Arg Term] -- ^ Indices.
| IndexVariablesNotDistinct [Nat] [Arg Term] -- ^ Variables, indices.
| IndicesFreeInParameters [Nat] [Arg Term] [Arg Term]
-- ^ Indices (variables), index expressions (with
-- constructors applied to reconstructed parameters),
-- parameters.
| DoesNotConstructAnElementOf QName Term -- ^ constructor, type
| DifferentArities
-- ^ Varying number of arguments for a function.
| WrongHidingInLHS Type
-- ^ The left hand side of a function definition has a hidden argument
-- where a non-hidden was expected.
| WrongHidingInLambda Type
-- ^ Expected a non-hidden function and found a hidden lambda.
| WrongHidingInApplication Type
-- ^ A function is applied to a hidden argument where a non-hidden was expected.
| WrongIrrelevanceInLambda Type
-- ^ Expected a relevant function and found an irrelevant lambda.
| NotInductive Term
-- ^ The term does not correspond to an inductive data type.
| UninstantiatedDotPattern A.Expr
| IlltypedPattern A.Pattern Type
| TooManyArgumentsInLHS Type
| WrongNumberOfConstructorArguments QName Nat Nat
| ShouldBeEmpty Type [Pattern]
| ShouldBeASort Type
-- ^ The given type should have been a sort.
| ShouldBePi Type
-- ^ The given type should have been a pi.
| ShouldBeRecordType Type
| ShouldBeRecordPattern Pattern
| NotAProperTerm
| SetOmegaNotValidType
| SplitOnIrrelevant A.Pattern (Dom Type)
| DefinitionIsIrrelevant QName
| VariableIsIrrelevant Name
| UnequalLevel Comparison Term Term
| UnequalTerms Comparison Term Term Type
| UnequalTypes Comparison Type Type
| UnequalTelescopes Comparison Telescope Telescope
| UnequalRelevance Comparison Term Term
-- ^ The two function types have different relevance.
| UnequalHiding Term Term
-- ^ The two function types have different hiding.
| UnequalSorts Sort Sort
| UnequalBecauseOfUniverseConflict Comparison Term Term
| HeterogeneousEquality Term Type Term Type
-- ^ We ended up with an equality constraint where the terms
-- have different types. This is not supported.
| NotLeqSort Sort Sort
| MetaCannotDependOn MetaId [Nat] Nat
-- ^ The arguments are the meta variable, the parameters it can
-- depend on and the paratemeter that it wants to depend on.
| MetaOccursInItself MetaId
| GenericError String
| GenericDocError Doc
| BuiltinMustBeConstructor String A.Expr
| NoSuchBuiltinName String
| DuplicateBuiltinBinding String Term Term
| NoBindingForBuiltin String
| NoSuchPrimitiveFunction String
| ShadowedModule C.Name [A.ModuleName]
| BuiltinInParameterisedModule String
| NoRHSRequiresAbsurdPattern [NamedArg A.Pattern]
| AbsurdPatternRequiresNoRHS [NamedArg A.Pattern]
| TooFewFields QName [C.Name]
| TooManyFields QName [C.Name]
| DuplicateFields [C.Name]
| DuplicateConstructors [C.Name]
| UnexpectedWithPatterns [A.Pattern]
| WithClausePatternMismatch A.Pattern Pattern
| FieldOutsideRecord
| ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr]
-- Coverage errors
| IncompletePatternMatching Term Args -- can only happen if coverage checking is switched off
| CoverageFailure QName [[Arg Pattern]]
| UnreachableClauses QName [[Arg Pattern]]
| CoverageCantSplitOn QName Telescope Args Args
| CoverageCantSplitIrrelevantType Type
| CoverageCantSplitType Type
-- Positivity errors
| NotStrictlyPositive QName [Occ]
-- Import errors
| LocalVsImportedModuleClash ModuleName
| UnsolvedMetas [Range]
| UnsolvedConstraints Constraints
| CyclicModuleDependency [C.TopLevelModuleName]
| FileNotFound C.TopLevelModuleName [AbsolutePath]
| OverlappingProjects AbsolutePath C.TopLevelModuleName C.TopLevelModuleName
| AmbiguousTopLevelModuleName C.TopLevelModuleName [AbsolutePath]
| ModuleNameDoesntMatchFileName C.TopLevelModuleName [AbsolutePath]
| ClashingFileNamesFor ModuleName [AbsolutePath]
| ModuleDefinedInOtherFile C.TopLevelModuleName AbsolutePath AbsolutePath
-- ^ Module name, file from which it was loaded, file which
-- the include path says contains the module.
-- Scope errors
| BothWithAndRHS
| NotInScope [C.QName]
| NoSuchModule C.QName
| AmbiguousName C.QName [A.QName]
| AmbiguousModule C.QName [A.ModuleName]
| UninstantiatedModule C.QName
| ClashingDefinition C.QName A.QName
| ClashingModule A.ModuleName A.ModuleName
| ClashingImport C.Name A.QName
| ClashingModuleImport C.Name A.ModuleName
| PatternShadowsConstructor A.Name A.QName
| ModuleDoesntExport C.QName [C.ImportedName]
| DuplicateImports C.QName [C.ImportedName]
| InvalidPattern C.Pattern
| RepeatedVariablesInPattern [C.Name]
-- Concrete to Abstract errors
| NotAModuleExpr C.Expr
-- ^ The expr was used in the right hand side of an implicit module
-- definition, but it wasn't of the form @m Delta@.
| NotAnExpression C.Expr
| NotAValidLetBinding D.NiceDeclaration
| NothingAppliedToHiddenArg C.Expr
| NothingAppliedToInstanceArg C.Expr
| UnusedVariableInPatternSynonym
| PatternSynonymArityMismatch A.QName
-- Operator errors
| NoParseForApplication [C.Expr]
| AmbiguousParseForApplication [C.Expr] [C.Expr]
| NoParseForLHS LHSOrPatSyn C.Pattern
| AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern]
{- UNUSED
| NoParseForPatternSynonym C.Pattern
| AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]
-}
-- Usage errors
-- Implicit From Scope errors
| IFSNoCandidateInScope Type
-- Safe flag errors
| SafeFlagPostulate C.Name
| SafeFlagPragma [String]
| SafeFlagNoTerminationCheck
| SafeFlagPrimTrustMe
-- Language option errors
| NeedOptionCopatterns
deriving (Typeable, Show)
-- | Distinguish error message when parsing lhs or pattern synonym, resp.
data LHSOrPatSyn = IsLHS | IsPatSyn deriving (Eq, Show)
-- instance Show TypeError where
-- show _ = "" -- TODO: more info?
instance Error TypeError where
noMsg = strMsg ""
strMsg = GenericError
-- | Type-checking errors.
data TCErr = TypeError TCState (Closure TypeError)
| Exception Range String
| IOException Range E.IOException
| PatternErr TCState -- ^ for pattern violations
{- AbortAssign TCState -- ^ used to abort assignment to meta when there are instantiations -- UNUSED -}
deriving (Typeable)
instance Error TCErr where
noMsg = strMsg ""
strMsg = Exception noRange . strMsg
instance Show TCErr where
show (TypeError _ e) = show (envRange $ clEnv e) ++ ": " ++ show (clValue e)
show (Exception r s) = show r ++ ": " ++ s
show (IOException r e) = show r ++ ": " ++ show e
show (PatternErr _) = "Pattern violation (you shouldn't see this)"
{- show (AbortAssign _) = "Abort assignment (you shouldn't see this)" -- UNUSED -}
instance HasRange TCErr where
getRange (TypeError _ cl) = envRange $ clEnv cl
getRange (Exception r _) = r
getRange (IOException r _) = r
getRange (PatternErr s) = noRange
{- getRange (AbortAssign s) = noRange -- UNUSED -}
instance Exception TCErr
---------------------------------------------------------------------------
-- * Type checking monad transformer
---------------------------------------------------------------------------
newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }
instance MonadIO m => MonadReader TCEnv (TCMT m) where
ask = TCM $ \s e -> return e
local f (TCM m) = TCM $ \s e -> m s (f e)
instance MonadIO m => MonadState TCState (TCMT m) where
get = TCM $ \s _ -> liftIO (readIORef s)
put s = TCM $ \r _ -> liftIO (writeIORef r s)
type TCM = TCMT IO
class ( Applicative tcm, MonadIO tcm
, MonadReader TCEnv tcm
, MonadState TCState tcm
) => MonadTCM tcm where
liftTCM :: TCM a -> tcm a
instance MonadError TCErr (TCMT IO) where
throwError = liftIO . throwIO
catchError m h = TCM $ \r e -> do
oldState <- liftIO (readIORef r)
unTCM m r e `E.catch` \err -> do
-- Reset the state, but do not forget changes to the persistent
-- component.
liftIO $ do
newState <- readIORef r
writeIORef r $ oldState { stPersistent = stPersistent newState }
unTCM (h err) r e
-- | Preserve the state of the failing computation.
catchError_ :: TCM a -> (TCErr -> TCM a) -> TCM a
catchError_ m h = TCM $ \r e ->
unTCM m r e
`E.catch` \err -> unTCM (h err) r e
{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-}
mapTCMT :: (forall a. m a -> n a) -> TCMT m a -> TCMT n a
mapTCMT f (TCM m) = TCM $ \s e -> f (m s e)
pureTCM :: MonadIO m => (TCState -> TCEnv -> a) -> TCMT m a
pureTCM f = TCM $ \r e -> do
s <- liftIO $ readIORef r
return (f s e)
{-# RULES "liftTCM/id" liftTCM = id #-}
instance MonadIO m => MonadTCM (TCMT m) where
liftTCM = mapTCMT liftIO
instance (Error err, MonadTCM tcm) => MonadTCM (ErrorT err tcm) where
liftTCM = lift . liftTCM
instance MonadTrans TCMT where
lift m = TCM $ \_ _ -> m
-- We want a special monad implementation of fail.
instance MonadIO m => Monad (TCMT m) where
return = returnTCMT
(>>=) = bindTCMT
(>>) = thenTCMT
fail = internalError
-- One goal of the definitions and pragmas below is to inline the
-- monad operations as much as possible. This doesn't seem to have a
-- large effect on the performance of the normal executable, but (at
-- least on one machine/configuration) it has a massive effect on the
-- performance of the profiling executable [1], and reduces the time
-- attributed to bind from over 90% to about 25%.
--
-- [1] When compiled with -auto-all and run with -p: roughly 750%
-- faster for one example.
returnTCMT :: MonadIO m => a -> TCMT m a
returnTCMT = \x -> TCM $ \_ _ -> return x
{-# RULES "returnTCMT"
returnTCMT = \x -> TCM $ \_ _ -> return x
#-}
{-# INLINE returnTCMT #-}
{-# SPECIALIZE INLINE returnTCMT :: a -> TCM a #-}
bindTCMT :: MonadIO m => TCMT m a -> (a -> TCMT m b) -> TCMT m b
bindTCMT = \(TCM m) k -> TCM $ \r e -> m r e >>= \x -> unTCM (k x) r e
{-# RULES "bindTCMT"
bindTCMT = \(TCM m) k -> TCM $ \r e ->
m r e >>= \x -> unTCM (k x) r e
#-}
{-# INLINE bindTCMT #-}
{-# SPECIALIZE INLINE bindTCMT :: TCM a -> (a -> TCM b) -> TCM b #-}
thenTCMT :: MonadIO m => TCMT m a -> TCMT m b -> TCMT m b
thenTCMT = \(TCM m1) (TCM m2) -> TCM $ \r e -> m1 r e >> m2 r e
{-# RULES "thenTCMT"
thenTCMT = \(TCM m1) (TCM m2) -> TCM $ \r e -> m1 r e >> m2 r e
#-}
{-# INLINE thenTCMT #-}
{-# SPECIALIZE INLINE thenTCMT :: TCM a -> TCM b -> TCM b #-}
instance MonadIO m => Functor (TCMT m) where
fmap = fmapTCMT
fmapTCMT :: MonadIO m => (a -> b) -> TCMT m a -> TCMT m b
fmapTCMT = \f (TCM m) -> TCM $ \r e -> liftM f (m r e)
{-# RULES "fmapTCMT"
fmapTCMT = \f (TCM m) -> TCM $ \r e -> liftM f (m r e)
#-}
{-# INLINE fmapTCMT #-}
{-# SPECIALIZE INLINE fmapTCMT :: (a -> b) -> TCM a -> TCM b #-}
instance MonadIO m => Applicative (TCMT m) where
pure = returnTCMT
(<*>) = apTCMT
apTCMT :: MonadIO m => TCMT m (a -> b) -> TCMT m a -> TCMT m b
apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> ap (mf r e) (m r e)
{-# RULES "apTCMT"
apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> ap (mf r e) (m r e)
#-}
{-# INLINE apTCMT #-}
{-# SPECIALIZE INLINE apTCMT :: TCM (a -> b) -> TCM a -> TCM b #-}
instance MonadIO m => MonadIO (TCMT m) where
liftIO m = TCM $ \s e ->
do let r = envRange e
liftIO $ wrap r $ do
x <- m
x `seq` return x
where
wrap r m = failOnException handleException
$ E.catch m (handleIOException r)
handleIOException r e = throwIO $ IOException r e
handleException r s = throwIO $ Exception r s
patternViolation :: TCM a
patternViolation = do
s <- get
throwError $ PatternErr s
internalError :: MonadTCM tcm => String -> tcm a
internalError s = typeError $ InternalError s
typeError :: MonadTCM tcm => TypeError -> tcm a
typeError err = liftTCM $ do
cl <- buildClosure err
s <- get
throwError $ TypeError s cl
-- | Running the type checking monad
runTCM :: TCMT IO a -> IO (Either TCErr a)
runTCM m = (Right <$> runTCM' m) `E.catch` (return . Left)
runTCM' :: MonadIO m => TCMT m a -> m a
runTCM' m = do
r <- liftIO $ newIORef initState
unTCM m r initEnv
-- | Runs the given computation in a separate thread, with /a copy/ of
-- the current state and environment.
--
-- Note that Agda sometimes uses actual, mutable state. If the
-- computation given to @forkTCM@ tries to /modify/ this state, then
-- bad things can happen, because accesses are not mutually exclusive.
-- The @forkTCM@ function has been added mainly to allow the thread to
-- /read/ (a snapshot of) the current state in a convenient way.
--
-- Note also that exceptions which are raised in the thread are not
-- propagated to the parent, so the thread should not do anything
-- important.
forkTCM :: TCM a -> TCM ()
forkTCM m = do
s <- get
e <- ask
liftIO $ C.forkIO $ do
runTCM $ local (\_ -> e) $ do
put s
m
return ()
return ()
-- | Base name for extended lambda patterns
extendlambdaname = ".extendedlambda"
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
#ifndef MIN_VERSION_bytestring
#define MIN_VERSION_bytestring(x,y,z) 1
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Control.Lens.Iso
-- Copyright : (C) 2012-13 Edward Kmett
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Edward Kmett
-- Stability : provisional
-- Portability : Rank2Types
--
----------------------------------------------------------------------------
module Control.Lens.Iso
(
-- * Isomorphism Lenses
Iso, Iso'
, AnIso, AnIso'
-- * Isomorphism Construction
, iso
-- * Consuming Isomorphisms
, from
, cloneIso
, withIso
-- * Working with isomorphisms
, au
, auf
, under
, mapping
-- ** Common Isomorphisms
, simple
, non
, anon
, enum
, curried, uncurried
, flipped
, Swapped(..)
, Strict(..)
, Reversing(..), reversed
, involuted
-- ** Uncommon Isomorphisms
, magma
, imagma
, Magma
-- ** Contravariant functors
, contramapping
-- * Profunctors
, Profunctor(dimap,rmap,lmap)
, dimapping
, lmapping
, rmapping
) where
import Control.Lens.Internal.Context
import Control.Lens.Internal.Indexed
import Control.Lens.Internal.Iso as Iso
import Control.Lens.Internal.Magma
import Control.Lens.Internal.Setter
import Control.Lens.Type
import Control.Monad.State.Lazy as Lazy
import Control.Monad.State.Strict as Strict
import Control.Monad.Writer.Lazy as Lazy
import Control.Monad.Writer.Strict as Strict
import Control.Monad.RWS.Lazy as Lazy
import Control.Monad.RWS.Strict as Strict
import Data.Bifunctor
import Data.ByteString as StrictB hiding (reverse)
import Data.ByteString.Lazy as LazyB hiding (reverse)
import Data.Functor.Contravariant
import Data.Text as StrictT hiding (reverse)
import Data.Text.Lazy as LazyT hiding (reverse)
import Data.Tuple (swap)
import Data.Maybe
import Data.Profunctor
import Data.Profunctor.Unsafe
{-# ANN module "HLint: ignore Use on" #-}
-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
-- >>> import Data.Map as Map
-- >>> import Data.Foldable
-- >>> import Data.Monoid
----------------------------------------------------------------------------
-- Isomorphisms
-----------------------------------------------------------------------------
-- | When you see this as an argument to a function, it expects an 'Iso'.
type AnIso s t a b = Exchange a b a (Mutator b) -> Exchange a b s (Mutator t)
-- | A 'Simple' 'AnIso'.
type AnIso' s a = AnIso s s a a
-- | Build a simple isomorphism from a pair of inverse functions.
--
-- @
-- 'Control.Lens.Getter.view' ('iso' f g) ≡ f
-- 'Control.Lens.Getter.view' ('Control.Lens.Iso.from' ('iso' f g)) ≡ g
-- 'Control.Lens.Setter.set' ('iso' f g) h ≡ g '.' h '.' f
-- 'Control.Lens.Setter.set' ('Control.Lens.Iso.from' ('iso' f g)) h ≡ f '.' h '.' g
-- @
iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso sa bt = dimap sa (fmap bt)
{-# INLINE iso #-}
----------------------------------------------------------------------------
-- Consuming Isomorphisms
-----------------------------------------------------------------------------
-- | Invert an isomorphism.
--
-- @
-- 'from' ('from' l) ≡ l
-- @
from :: AnIso s t a b -> Iso b a t s
from l = withIso l $ \ sa bt -> iso bt sa
{-# INLINE from #-}
-- | Extract the two functions, one from @s -> a@ and
-- one from @b -> t@ that characterize an 'Iso'.
withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso ai k = case ai (Exchange id Mutator) of
Exchange sa bt -> k sa (runMutator #. bt)
{-# INLINE withIso #-}
-- | Convert from 'AnIso' back to any 'Iso'.
--
-- This is useful when you need to store an isomorphism as a data type inside a container
-- and later reconstitute it as an overloaded function.
--
-- See 'Control.Lens.Lens.cloneLens' or 'Control.Lens.Traversal.cloneTraversal' for more information on why you might want to do this.
cloneIso :: AnIso s t a b -> Iso s t a b
cloneIso k = withIso k $ \ sa bt -> iso sa bt
{-# INLINE cloneIso #-}
-----------------------------------------------------------------------------
-- Isomorphisms families as Lenses
-----------------------------------------------------------------------------
-- | Based on 'Control.Lens.Wrapped.ala' from Conor McBride's work on Epigram.
--
-- This version is generalized to accept any 'Iso', not just a @newtype@.
--
-- >>> au (wrapping Sum) foldMap [1,2,3,4]
-- 10
au :: AnIso s t a b -> ((s -> a) -> e -> b) -> e -> t
au k = withIso k $ \ sa bt f e -> bt (f sa e)
{-# INLINE au #-}
-- | Based on @ala'@ from Conor McBride's work on Epigram.
--
-- This version is generalized to accept any 'Iso', not just a @newtype@.
--
-- For a version you pass the name of the @newtype@ constructor to, see 'Control.Lens.Wrapped.alaf'.
--
-- Mnemonically, the German /auf/ plays a similar role to /à la/, and the combinator
-- is 'au' with an extra function argument.
--
-- >>> auf (wrapping Sum) (foldMapOf both) Prelude.length ("hello","world")
-- 10
auf :: AnIso s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t
auf k = withIso k $ \ sa bt f g e -> bt (f (sa . g) e)
{-# INLINE auf #-}
-- | The opposite of working 'Control.Lens.Setter.over' a 'Setter' is working 'under' an isomorphism.
--
-- @
-- 'under' ≡ 'Control.Lens.Setter.over' '.' 'from'
-- @
--
-- @
-- 'under' :: 'Iso' s t a b -> (t -> s) -> b -> a
-- @
under :: AnIso s t a b -> (t -> s) -> b -> a
under k = withIso k $ \ sa bt ts -> sa . ts . bt
{-# INLINE under #-}
-----------------------------------------------------------------------------
-- Isomorphisms
-----------------------------------------------------------------------------
-- | This isomorphism can be used to convert to or from an instance of 'Enum'.
--
-- >>> LT^.from enum
-- 0
--
-- >>> 97^.enum :: Char
-- 'a'
--
-- Note: this is only an isomorphism from the numeric range actually used
-- and it is a bit of a pleasant fiction, since there are questionable
-- 'Enum' instances for 'Double', and 'Float' that exist solely for
-- @[1.0 .. 4.0]@ sugar and the instances for those and 'Integer' don't
-- cover all values in their range.
enum :: Enum a => Iso' Int a
enum = iso toEnum fromEnum
{-# INLINE enum #-}
-- | This can be used to lift any 'Iso' into an arbitrary 'Functor'.
mapping :: Functor f => AnIso s t a b -> Iso (f s) (f t) (f a) (f b)
mapping k = withIso k $ \ sa bt -> iso (fmap sa) (fmap bt)
{-# INLINE mapping #-}
-- | Composition with this isomorphism is occasionally useful when your 'Lens',
-- 'Control.Lens.Traversal.Traversal' or 'Iso' has a constraint on an unused
-- argument to force that argument to agree with the
-- type of a used argument and avoid @ScopedTypeVariables@ or other ugliness.
simple :: Iso' a a
simple = id
{-# INLINE simple #-}
-- | If @v@ is an element of a type @a@, and @a'@ is @a@ sans the element @v@, then @'non' v@ is an isomorphism from
-- @'Maybe' a'@ to @a@.
--
-- Keep in mind this is only a real isomorphism if you treat the domain as being @'Maybe' (a sans v)@.
--
-- This is practically quite useful when you want to have a 'Data.Map.Map' where all the entries should have non-zero values.
--
-- >>> Map.fromList [("hello",1)] & at "hello" . non 0 +~ 2
-- fromList [("hello",3)]
--
-- >>> Map.fromList [("hello",1)] & at "hello" . non 0 -~ 1
-- fromList []
--
-- >>> Map.fromList [("hello",1)] ^. at "hello" . non 0
-- 1
--
-- >>> Map.fromList [] ^. at "hello" . non 0
-- 0
--
-- This combinator is also particularly useful when working with nested maps.
--
-- /e.g./ When you want to create the nested 'Data.Map.Map' when it is missing:
--
-- >>> Map.empty & at "hello" . non Map.empty . at "world" ?~ "!!!"
-- fromList [("hello",fromList [("world","!!!")])]
--
-- and when have deleting the last entry from the nested 'Data.Map.Map' mean that we
-- should delete its entry from the surrounding one:
--
-- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non Map.empty . at "world" .~ Nothing
-- fromList []
non :: Eq a => a -> Iso' (Maybe a) a
non a = anon a (a==)
{-# INLINE non #-}
-- | @'anon' a p@ generalizes @'non' a@ to take any value and a predicate.
--
-- This function assumes that @p a@ holds @'True'@ and generates an isomorphism between @'Maybe' (a | 'not' (p a))@ and @a@.
--
-- >>> Map.empty & at "hello" . anon Map.empty Map.null . at "world" ?~ "!!!"
-- fromList [("hello",fromList [("world","!!!")])]
--
-- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing
-- fromList []
anon :: a -> (a -> Bool) -> Iso' (Maybe a) a
anon a p = iso (fromMaybe a) go where
go b | p b = Nothing
| otherwise = Just b
{-# INLINE anon #-}
-- | The canonical isomorphism for currying and uncurrying a function.
--
-- @
-- 'curried' = 'iso' 'curry' 'uncurry'
-- @
--
-- >>> (fst^.curried) 3 4
-- 3
--
-- >>> view curried fst 3 4
-- 3
curried :: Iso ((a,b) -> c) ((d,e) -> f) (a -> b -> c) (d -> e -> f)
curried = iso curry uncurry
{-# INLINE curried #-}
-- | The canonical isomorphism for uncurrying and currying a function.
--
-- @
-- 'uncurried' = 'iso' 'uncurry' 'curry'
-- @
--
-- @
-- 'uncurried' = 'from' 'curried'
-- @
--
-- >>> ((+)^.uncurried) (1,2)
-- 3
uncurried :: Iso (a -> b -> c) (d -> e -> f) ((a,b) -> c) ((d,e) -> f)
uncurried = iso uncurry curry
{-# INLINE uncurried #-}
-- | The isomorphism for flipping a function.
--
-- >>>((,)^.flipped) 1 2
-- (2,1)
flipped :: Iso (a -> b -> c) (a' -> b' -> c') (b -> a -> c) (b' -> a' -> c')
flipped = iso flip flip
{-# INLINE flipped #-}
-- | This class provides for symmetric bifunctors.
class Bifunctor p => Swapped p where
-- |
-- @
-- 'swapped' '.' 'swapped' ≡ 'id'
-- 'first' f '.' 'swapped' = 'swapped' '.' 'second' f
-- 'second' g '.' 'swapped' = 'swapped' '.' 'first' g
-- 'bimap' f g '.' 'swapped' = 'swapped' '.' 'bimap' g f
-- @
--
-- >>> (1,2)^.swapped
-- (2,1)
swapped :: Iso (p a b) (p c d) (p b a) (p d c)
instance Swapped (,) where
swapped = iso swap swap
instance Swapped Either where
swapped = iso (either Right Left) (either Right Left)
-- | Ad hoc conversion between \"strict\" and \"lazy\" versions of a structure,
-- such as 'StrictT.Text' or 'StrictB.ByteString'.
class Strict s a | s -> a, a -> s where
strict :: Iso' s a
instance Strict LazyB.ByteString StrictB.ByteString where
#if MIN_VERSION_bytestring(0,10,0)
strict = iso LazyB.toStrict LazyB.fromStrict
#else
strict = iso (StrictB.concat . LazyB.toChunks) (LazyB.fromChunks . return)
#endif
{-# INLINE strict #-}
instance Strict LazyT.Text StrictT.Text where
strict = iso LazyT.toStrict LazyT.fromStrict
{-# INLINE strict #-}
instance Strict (Lazy.StateT s m a) (Strict.StateT s m a) where
strict = iso (Strict.StateT . Lazy.runStateT) (Lazy.StateT . Strict.runStateT)
{-# INLINE strict #-}
instance Strict (Lazy.WriterT w m a) (Strict.WriterT w m a) where
strict = iso (Strict.WriterT . Lazy.runWriterT) (Lazy.WriterT . Strict.runWriterT)
{-# INLINE strict #-}
instance Strict (Lazy.RWST r w s m a) (Strict.RWST r w s m a) where
strict = iso (Strict.RWST . Lazy.runRWST) (Lazy.RWST . Strict.runRWST)
{-# INLINE strict #-}
-- | An 'Iso' between a list, 'ByteString', 'Text' fragment, etc. and its reversal.
--
-- >>> "live" ^. reversed
-- "evil"
--
-- >>> "live" & reversed %~ ('d':)
-- "lived"
reversed :: Reversing a => Iso' a a
reversed = involuted Iso.reversing
-- | Given a function that is its own inverse, this gives you an 'Iso' using it in both directions.
--
-- @
-- 'involuted' ≡ 'Control.Monad.join' 'iso'
-- @
--
-- >>> "live" ^. involuted reverse
-- "evil"
--
-- >>> "live" & involuted reverse %~ ('d':)
-- "lived"
involuted :: (a -> a) -> Iso' a a
involuted a = iso a a
{-# INLINE involuted #-}
------------------------------------------------------------------------------
-- Magma
------------------------------------------------------------------------------
-- | This isomorphism can be used to inspect a 'Traversal' to see how it associates
-- the structure and it can also be used to bake the 'Traversal' into a 'Magma' so
-- that you can traverse over it multiple times.
magma :: LensLike (Mafic a b) s t a b -> Iso s u (Magma Int t b a) (Magma j u c c)
magma l = iso (runMafic `rmap` l sell) runMagma
{-# INLINE magma #-}
-- | This isomorphism can be used to inspect an 'IndexedTraversal' to see how it associates
-- the structure and it can also be used to bake the 'IndexedTraversal' into a 'Magma' so
-- that you can traverse over it multiple times with access to the original indices.
imagma :: Overloading (Indexed i) (->) (Molten i a b) s t a b -> Iso s t' (Magma i t b a) (Magma j t' c c)
imagma l = iso (runMolten #. l sell) (iextract .# Molten)
{-# INLINE imagma #-}
------------------------------------------------------------------------------
-- Contravariant
------------------------------------------------------------------------------
-- | Lift an 'Iso' into a 'Contravariant' functor.
--
-- @
-- contramapping :: 'Contravariant' f => 'Iso' s t a b -> 'Iso' (f a) (f b) (f s) (f t)
-- contramapping :: 'Contravariant' f => 'Iso'' s a -> 'Iso'' (f a) (f s)
-- @
contramapping :: Contravariant f => AnIso s t a b -> Iso (f a) (f b) (f s) (f t)
contramapping f = withIso f $ \ sa bt -> iso (contramap sa) (contramap bt)
{-# INLINE contramapping #-}
------------------------------------------------------------------------------
-- Profunctor
------------------------------------------------------------------------------
-- | Lift two 'Iso's into both arguments of a 'Profunctor' simultaneously.
--
-- @
-- dimapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' s' t' a' b' -> 'Iso' (p a s') (p b t') (p s a') (p t b')
-- dimapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' s' a' -> 'Iso'' (p a s') (p s a')
-- @
dimapping :: Profunctor p => AnIso s t a b -> AnIso s' t' a' b' -> Iso (p a s') (p b t') (p s a') (p t b')
dimapping f g = withIso f $ \ s'a' b't' -> withIso g $ \ sa bt ->
iso (dimap s'a' sa) (dimap b't' bt)
{-# INLINE dimapping #-}
-- | Lift an 'Iso' contravariantly into the left argument of a 'Profunctor'.
--
-- @
-- lmapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' (p a x) (p b y) (p s x) (p t y)
-- lmapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' (p a x) (p s x)
-- @
lmapping :: Profunctor p => AnIso s t a b -> Iso (p a x) (p b y) (p s x) (p t y)
lmapping f = withIso f $ \ sa bt -> iso (lmap sa) (lmap bt)
{-# INLINE lmapping #-}
-- | Lift an 'Iso' covariantly into the right argument of a 'Profunctor'.
--
-- @
-- rmapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' (p x s) (p y t) (p x a) (p y b)
-- rmapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' (p x s) (p x a)
-- @
rmapping :: Profunctor p => AnIso s t a b -> Iso (p x s) (p y t) (p x a) (p y b)
rmapping g = withIso g $ \ sa bt -> iso (rmap sa) (rmap bt)
{-# INLINE rmapping #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
, ForeignFunctionInterface
, MagicHash
, UnboxedTuples
, ScopedTypeVariables
#-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
-- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN
-- and Control.Concurrent.SampleVar imports.
-----------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (concurrency)
--
-- A common interface to a collection of useful concurrency
-- abstractions.
--
-----------------------------------------------------------------------------
module Control.Concurrent (
-- * Concurrent Haskell
-- $conc_intro
-- * Basic concurrency operations
ThreadId,
#ifdef __GLASGOW_HASKELL__
myThreadId,
#endif
forkIO,
#ifdef __GLASGOW_HASKELL__
forkFinally,
forkIOWithUnmask,
killThread,
throwTo,
#endif
-- ** Threads with affinity
forkOn,
forkOnWithUnmask,
getNumCapabilities,
setNumCapabilities,
threadCapability,
-- * Scheduling
-- $conc_scheduling
yield, -- :: IO ()
-- ** Blocking
-- $blocking
#ifdef __GLASGOW_HASKELL__
-- ** Waiting
threadDelay, -- :: Int -> IO ()
threadWaitRead, -- :: Int -> IO ()
threadWaitWrite, -- :: Int -> IO ()
#endif
-- * Communication abstractions
module Control.Concurrent.MVar,
module Control.Concurrent.Chan,
module Control.Concurrent.QSem,
module Control.Concurrent.QSemN,
module Control.Concurrent.SampleVar,
-- * Merging of streams
#ifndef __HUGS__
mergeIO, -- :: [a] -> [a] -> IO [a]
nmergeIO, -- :: [[a]] -> IO [a]
#endif
-- $merge
#ifdef __GLASGOW_HASKELL__
-- * Bound Threads
-- $boundthreads
rtsSupportsBoundThreads,
forkOS,
isCurrentThreadBound,
runInBoundThread,
runInUnboundThread,
#endif
-- * Weak references to ThreadIds
mkWeakThreadId,
-- * GHC's implementation of concurrency
-- |This section describes features specific to GHC's
-- implementation of Concurrent Haskell.
-- ** Haskell threads and Operating System threads
-- $osthreads
-- ** Terminating the program
-- $termination
-- ** Pre-emption
-- $preemption
-- * Deprecated functions
forkIOUnmasked
) where
import Prelude
import Control.Exception.Base as Exception
#ifdef __GLASGOW_HASKELL__
import GHC.Exception
import GHC.Conc hiding (threadWaitRead, threadWaitWrite)
import qualified GHC.Conc
import GHC.IO ( IO(..), unsafeInterleaveIO, unsafeUnmask )
import GHC.IORef ( newIORef, readIORef, writeIORef )
import GHC.Base
import System.Posix.Types ( Fd )
import Foreign.StablePtr
import Foreign.C.Types
import Control.Monad ( when )
#ifdef mingw32_HOST_OS
import Foreign.C
import System.IO
#endif
#endif
#ifdef __HUGS__
import Hugs.ConcBase
#endif
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Control.Concurrent.QSem
import Control.Concurrent.QSemN
import Control.Concurrent.SampleVar
#ifdef __HUGS__
type ThreadId = ()
#endif
{- $conc_intro
The concurrency extension for Haskell is described in the paper
/Concurrent Haskell/
.
Concurrency is \"lightweight\", which means that both thread creation
and context switching overheads are extremely low. Scheduling of
Haskell threads is done internally in the Haskell runtime system, and
doesn't make use of any operating system-supplied thread packages.
However, if you want to interact with a foreign library that expects your
program to use the operating system-supplied thread package, you can do so
by using 'forkOS' instead of 'forkIO'.
Haskell threads can communicate via 'MVar's, a kind of synchronised
mutable variable (see "Control.Concurrent.MVar"). Several common
concurrency abstractions can be built from 'MVar's, and these are
provided by the "Control.Concurrent" library.
In GHC, threads may also communicate via exceptions.
-}
{- $conc_scheduling
Scheduling may be either pre-emptive or co-operative,
depending on the implementation of Concurrent Haskell (see below
for information related to specific compilers). In a co-operative
system, context switches only occur when you use one of the
primitives defined in this module. This means that programs such
as:
> main = forkIO (write 'a') >> write 'b'
> where write c = putChar c >> write c
will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@,
instead of some random interleaving of @a@s and @b@s. In
practice, cooperative multitasking is sufficient for writing
simple graphical user interfaces.
-}
{- $blocking
Different Haskell implementations have different characteristics with
regard to which operations block /all/ threads.
Using GHC without the @-threaded@ option, all foreign calls will block
all other Haskell threads in the system, although I\/O operations will
not. With the @-threaded@ option, only foreign calls with the @unsafe@
attribute will block all other threads.
Using Hugs, all I\/O operations and foreign calls will block all other
Haskell threads.
-}
-- | fork a thread and call the supplied function when the thread is about
-- to terminate, with an exception or a returned value. The function is
-- called with asynchronous exceptions masked.
--
-- > forkFinally action and_then =
-- > mask $ \restore ->
-- > forkIO $ try (restore action) >>= and_then
--
-- This function is useful for informing the parent when a child
-- terminates, for example.
--
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally action and_then =
mask $ \restore ->
forkIO $ try (restore action) >>= and_then
-- -----------------------------------------------------------------------------
-- Merging streams
#ifndef __HUGS__
max_buff_size :: Int
max_buff_size = 1
{-# DEPRECATED mergeIO "Control.Concurrent.mergeIO will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}
{-# DEPRECATED nmergeIO "Control.Concurrent.nmergeIO will be removed in GHC 7.8. Please use an alternative, e.g. the SafeSemaphore package, instead." #-}
mergeIO :: [a] -> [a] -> IO [a]
nmergeIO :: [[a]] -> IO [a]
-- $merge
-- The 'mergeIO' and 'nmergeIO' functions fork one thread for each
-- input list that concurrently evaluates that list; the results are
-- merged into a single output list.
--
-- Note: Hugs does not provide these functions, since they require
-- preemptive multitasking.
mergeIO ls rs
= newEmptyMVar >>= \ tail_node ->
newMVar tail_node >>= \ tail_list ->
newQSem max_buff_size >>= \ e ->
newMVar 2 >>= \ branches_running ->
let
buff = (tail_list,e)
in
forkIO (suckIO branches_running buff ls) >>
forkIO (suckIO branches_running buff rs) >>
takeMVar tail_node >>= \ val ->
signalQSem e >>
return val
type Buffer a
= (MVar (MVar [a]), QSem)
suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
suckIO branches_running buff@(tail_list,e) vs
= case vs of
[] -> takeMVar branches_running >>= \ val ->
if val == 1 then
takeMVar tail_list >>= \ node ->
putMVar node [] >>
putMVar tail_list node
else
putMVar branches_running (val-1)
(x:xs) ->
waitQSem e >>
takeMVar tail_list >>= \ node ->
newEmptyMVar >>= \ next_node ->
unsafeInterleaveIO (
takeMVar next_node >>= \ y ->
signalQSem e >>
return y) >>= \ next_node_val ->
putMVar node (x:next_node_val) >>
putMVar tail_list next_node >>
suckIO branches_running buff xs
nmergeIO lss
= let
len = length lss
in
newEmptyMVar >>= \ tail_node ->
newMVar tail_node >>= \ tail_list ->
newQSem max_buff_size >>= \ e ->
newMVar len >>= \ branches_running ->
let
buff = (tail_list,e)
in
mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
takeMVar tail_node >>= \ val ->
signalQSem e >>
return val
where
mapIO f xs = sequence (map f xs)
#endif /* __HUGS__ */
#ifdef __GLASGOW_HASKELL__
-- ---------------------------------------------------------------------------
-- Bound Threads
{- $boundthreads
#boundthreads#
Support for multiple operating system threads and bound threads as described
below is currently only available in the GHC runtime system if you use the
/-threaded/ option when linking.
Other Haskell systems do not currently support multiple operating system threads.
A bound thread is a haskell thread that is /bound/ to an operating system
thread. While the bound thread is still scheduled by the Haskell run-time
system, the operating system thread takes care of all the foreign calls made
by the bound thread.
To a foreign library, the bound thread will look exactly like an ordinary
operating system thread created using OS functions like @pthread_create@
or @CreateThread@.
Bound threads can be created using the 'forkOS' function below. All foreign
exported functions are run in a bound thread (bound to the OS thread that
called the function). Also, the @main@ action of every Haskell program is
run in a bound thread.
Why do we need this? Because if a foreign library is called from a thread
created using 'forkIO', it won't have access to any /thread-local state/ -
state variables that have specific values for each OS thread
(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some
libraries (OpenGL, for example) will not work from a thread created using
'forkIO'. They work fine in threads created using 'forkOS' or when called
from @main@ or from a @foreign export@.
In terms of performance, 'forkOS' (aka bound) threads are much more
expensive than 'forkIO' (aka unbound) threads, because a 'forkOS'
thread is tied to a particular OS thread, whereas a 'forkIO' thread
can be run by any OS thread. Context-switching between a 'forkOS'
thread and a 'forkIO' thread is many times more expensive than between
two 'forkIO' threads.
Note in particular that the main program thread (the thread running
@Main.main@) is always a bound thread, so for good concurrency
performance you should ensure that the main thread is not doing
repeated communication with other threads in the system. Typically
this means forking subthreads to do the work using 'forkIO', and
waiting for the results in the main thread.
-}
-- | 'True' if bound threads are supported.
-- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'
-- will always return 'False' and both 'forkOS' and 'runInBoundThread' will
-- fail.
foreign import ccall rtsSupportsBoundThreads :: Bool
{- |
Like 'forkIO', this sparks off a new thread to run the 'IO'
computation passed as the first argument, and returns the 'ThreadId'
of the newly created thread.
However, 'forkOS' creates a /bound/ thread, which is necessary if you
need to call foreign (non-Haskell) libraries that make use of
thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads").
Using 'forkOS' instead of 'forkIO' makes no difference at all to the
scheduling behaviour of the Haskell runtime system. It is a common
misconception that you need to use 'forkOS' instead of 'forkIO' to
avoid blocking all the Haskell threads when making a foreign call;
this isn't the case. To allow foreign calls to be made without
blocking all the Haskell threads (with GHC), it is only necessary to
use the @-threaded@ option when linking your program, and to make sure
the foreign import is not marked @unsafe@.
-}
forkOS :: IO () -> IO ThreadId
foreign export ccall forkOS_entry
:: StablePtr (IO ()) -> IO ()
foreign import ccall "forkOS_entry" forkOS_entry_reimported
:: StablePtr (IO ()) -> IO ()
forkOS_entry :: StablePtr (IO ()) -> IO ()
forkOS_entry stableAction = do
action <- deRefStablePtr stableAction
action
foreign import ccall forkOS_createThread
:: StablePtr (IO ()) -> IO CInt
failNonThreaded :: IO a
failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
++"(use ghc -threaded when linking)"
forkOS action0
| rtsSupportsBoundThreads = do
mv <- newEmptyMVar
b <- Exception.getMaskingState
let
-- async exceptions are masked in the child if they are masked
-- in the parent, as for forkIO (see #1048). forkOS_createThread
-- creates a thread with exceptions masked by default.
action1 = case b of
Unmasked -> unsafeUnmask action0
MaskedInterruptible -> action0
MaskedUninterruptible -> uninterruptibleMask_ action0
action_plus = Exception.catch action1 childHandler
entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
err <- forkOS_createThread entry
when (err /= 0) $ fail "Cannot create OS thread."
tid <- takeMVar mv
freeStablePtr entry
return tid
| otherwise = failNonThreaded
-- | Returns 'True' if the calling thread is /bound/, that is, if it is
-- safe to use foreign libraries that rely on thread-local state from the
-- calling thread.
isCurrentThreadBound :: IO Bool
isCurrentThreadBound = IO $ \ s# ->
case isCurrentThreadBound# s# of
(# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
{- |
Run the 'IO' computation passed as the first argument. If the calling thread
is not /bound/, a bound thread is created temporarily. @runInBoundThread@
doesn't finish until the 'IO' computation finishes.
You can wrap a series of foreign function calls that rely on thread-local state
with @runInBoundThread@ so that you can use them without knowing whether the
current thread is /bound/.
-}
runInBoundThread :: IO a -> IO a
runInBoundThread action
| rtsSupportsBoundThreads = do
bound <- isCurrentThreadBound
if bound
then action
else do
ref <- newIORef undefined
let action_plus = Exception.try action >>= writeIORef ref
bracket (newStablePtr action_plus)
freeStablePtr
(\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) >>=
unsafeResult
| otherwise = failNonThreaded
{- |
Run the 'IO' computation passed as the first argument. If the calling thread
is /bound/, an unbound thread is created temporarily using 'forkIO'.
@runInBoundThread@ doesn't finish until the 'IO' computation finishes.
Use this function /only/ in the rare case that you have actually observed a
performance loss due to the use of bound threads. A program that
doesn't need it's main thread to be bound and makes /heavy/ use of concurrency
(e.g. a web server), might want to wrap it's @main@ action in
@runInUnboundThread@.
Note that exceptions which are thrown to the current thread are thrown in turn
to the thread that is executing the given computation. This ensures there's
always a way of killing the forked thread.
-}
runInUnboundThread :: IO a -> IO a
runInUnboundThread action = do
bound <- isCurrentThreadBound
if bound
then do
mv <- newEmptyMVar
mask $ \restore -> do
tid <- forkIO $ Exception.try (restore action) >>= putMVar mv
let wait = takeMVar mv `Exception.catch` \(e :: SomeException) ->
Exception.throwTo tid e >> wait
wait >>= unsafeResult
else action
unsafeResult :: Either SomeException a -> IO a
unsafeResult = either Exception.throwIO return
#endif /* __GLASGOW_HASKELL__ */
#ifdef __GLASGOW_HASKELL__
-- ---------------------------------------------------------------------------
-- threadWaitRead/threadWaitWrite
-- | Block the current thread until data is available to read on the
-- given file descriptor (GHC only).
--
-- This will throw an 'IOError' if the file descriptor was closed
-- while this thread was blocked. To safely close a file descriptor
-- that has been used with 'threadWaitRead', use
-- 'GHC.Conc.closeFdWith'.
threadWaitRead :: Fd -> IO ()
threadWaitRead fd
#ifdef mingw32_HOST_OS
-- we have no IO manager implementing threadWaitRead on Windows.
-- fdReady does the right thing, but we have to call it in a
-- separate thread, otherwise threadWaitRead won't be interruptible,
-- and this only works with -threaded.
| threaded = withThread (waitFd fd 0)
| otherwise = case fd of
0 -> do _ <- hWaitForInput stdin (-1)
return ()
-- hWaitForInput does work properly, but we can only
-- do this for stdin since we know its FD.
_ -> error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput"
#else
= GHC.Conc.threadWaitRead fd
#endif
-- | Block the current thread until data can be written to the
-- given file descriptor (GHC only).
--
-- This will throw an 'IOError' if the file descriptor was closed
-- while this thread was blocked. To safely close a file descriptor
-- that has been used with 'threadWaitWrite', use
-- 'GHC.Conc.closeFdWith'.
threadWaitWrite :: Fd -> IO ()
threadWaitWrite fd
#ifdef mingw32_HOST_OS
| threaded = withThread (waitFd fd 1)
| otherwise = error "threadWaitWrite requires -threaded on Windows"
#else
= GHC.Conc.threadWaitWrite fd
#endif
#ifdef mingw32_HOST_OS
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
withThread :: IO a -> IO a
withThread io = do
m <- newEmptyMVar
_ <- mask_ $ forkIO $ try io >>= putMVar m
x <- takeMVar m
case x of
Right a -> return a
Left e -> throwIO (e :: IOException)
waitFd :: Fd -> CInt -> IO ()
waitFd fd write = do
throwErrnoIfMinus1_ "fdReady" $
fdReady (fromIntegral fd) write iNFINITE 0
iNFINITE :: CInt
iNFINITE = 0xFFFFFFFF -- urgh
foreign import ccall safe "fdReady"
fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
#endif
-- ---------------------------------------------------------------------------
-- More docs
{- $osthreads
#osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and
are managed entirely by the GHC runtime. Typically Haskell
threads are an order of magnitude or two more efficient (in
terms of both time and space) than operating system threads.
The downside of having lightweight threads is that only one can
run at a time, so if one thread blocks in a foreign call, for
example, the other threads cannot continue. The GHC runtime
works around this by making use of full OS threads where
necessary. When the program is built with the @-threaded@
option (to link against the multithreaded version of the
runtime), a thread making a @safe@ foreign call will not block
the other threads in the system; another OS thread will take
over running Haskell threads until the original call returns.
The runtime maintains a pool of these /worker/ threads so that
multiple Haskell threads can be involved in external calls
simultaneously.
The "System.IO" library manages multiplexing in its own way. On
Windows systems it uses @safe@ foreign calls to ensure that
threads doing I\/O operations don't block the whole runtime,
whereas on Unix systems all the currently blocked I\/O requests
are managed by a single thread (the /IO manager thread/) using
a mechanism such as @epoll@ or @kqueue@, depending on what is
provided by the host operating system.
The runtime will run a Haskell thread using any of the available
worker OS threads. If you need control over which particular OS
thread is used to run a given Haskell thread, perhaps because
you need to call a foreign library that uses OS-thread-local
state, then you need bound threads (see "Control.Concurrent#boundthreads").
If you don't use the @-threaded@ option, then the runtime does
not make use of multiple OS threads. Foreign calls will block
all other running Haskell threads until the call returns. The
"System.IO" library still does multiplexing, so there can be multiple
threads doing I\/O, and this is handled internally by the runtime using
@select@.
-}
{- $termination
In a standalone GHC program, only the main thread is
required to terminate in order for the process to terminate.
Thus all other forked threads will simply terminate at the same
time as the main thread (the terminology for this kind of
behaviour is \"daemonic threads\").
If you want the program to wait for child threads to
finish before exiting, you need to program this yourself. A
simple mechanism is to have each child thread write to an
'MVar' when it completes, and have the main
thread wait on all the 'MVar's before
exiting:
> myForkIO :: IO () -> IO (MVar ())
> myForkIO io = do
> mvar <- newEmptyMVar
> forkFinally io (\_ -> putMVar mvar ())
> return mvar
Note that we use 'forkFinally' to make sure that the
'MVar' is written to even if the thread dies or
is killed for some reason.
A better method is to keep a global list of all child
threads which we should wait for at the end of the program:
> children :: MVar [MVar ()]
> children = unsafePerformIO (newMVar [])
>
> waitForChildren :: IO ()
> waitForChildren = do
> cs <- takeMVar children
> case cs of
> [] -> return ()
> m:ms -> do
> putMVar children ms
> takeMVar m
> waitForChildren
>
> forkChild :: IO () -> IO ThreadId
> forkChild io = do
> mvar <- newEmptyMVar
> childs <- takeMVar children
> putMVar children (mvar:childs)
> forkFinally io (\_ -> putMVar mvar ())
>
> main =
> later waitForChildren $
> ...
The main thread principle also applies to calls to Haskell from
outside, using @foreign export@. When the @foreign export@ed
function is invoked, it starts a new main thread, and it returns
when this main thread terminates. If the call causes new
threads to be forked, they may remain in the system after the
@foreign export@ed function has returned.
-}
{- $preemption
GHC implements pre-emptive multitasking: the execution of
threads are interleaved in a random fashion. More specifically,
a thread may be pre-empted whenever it allocates some memory,
which unfortunately means that tight loops which do no
allocation tend to lock out other threads (this only seems to
happen with pathological benchmark-style code, however).
The rescheduling timer runs on a 20ms granularity by
default, but this may be altered using the
@-i\@ RTS option. After a rescheduling
\"tick\" the running thread is pre-empted as soon as
possible.
One final note: the
@aaaa@ @bbbb@ example may not
work too well on GHC (see Scheduling, above), due
to the locking on a 'System.IO.Handle'. Only one thread
may hold the lock on a 'System.IO.Handle' at any one
time, so if a reschedule happens while a thread is holding the
lock, the other thread won't be able to run. The upshot is that
the switch from @aaaa@ to
@bbbbb@ happens infrequently. It can be
improved by lowering the reschedule tick period. We also have a
patch that causes a reschedule whenever a thread waiting on a
lock is woken up, but haven't found it to be useful for anything
other than this example :-)
-}
#endif /* __GLASGOW_HASKELL__ */
{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.Printf
-- Copyright : (c) Lennart Augustsson, 2004-2008
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : lennart@augustsson.net
-- Stability : provisional
-- Portability : portable
--
-- A C printf like formatter.
--
-----------------------------------------------------------------------------
{-# Language CPP #-}
module Text.Printf(
printf, hPrintf,
PrintfType, HPrintfType, PrintfArg, IsChar
) where
import Prelude
import Data.Char
import Data.Int
import Data.Word
import Numeric(showEFloat, showFFloat, showGFloat)
import System.IO
-------------------
-- | Format a variable number of arguments with the C-style formatting string.
-- The return value is either 'String' or @('IO' a)@.
--
-- The format string consists of ordinary characters and /conversion
-- specifications/, which specify how to format one of the arguments
-- to printf in the output string. A conversion specification begins with the
-- character @%@, followed by one or more of the following flags:
--
-- > - left adjust (default is right adjust)
-- > + always use a sign (+ or -) for signed conversions
-- > 0 pad with zeroes rather than spaces
--
-- followed optionally by a field width:
--
-- > num field width
-- > * as num, but taken from argument list
--
-- followed optionally by a precision:
--
-- > .num precision (number of decimal places)
--
-- and finally, a format character:
--
-- > c character Char, Int, Integer, ...
-- > d decimal Char, Int, Integer, ...
-- > o octal Char, Int, Integer, ...
-- > x hexadecimal Char, Int, Integer, ...
-- > X hexadecimal Char, Int, Integer, ...
-- > u unsigned decimal Char, Int, Integer, ...
-- > f floating point Float, Double
-- > g general format float Float, Double
-- > G general format float Float, Double
-- > e exponent format float Float, Double
-- > E exponent format float Float, Double
-- > s string String
--
-- Mismatch between the argument types and the format string will cause
-- an exception to be thrown at runtime.
--
-- Examples:
--
-- > > printf "%d\n" (23::Int)
-- > 23
-- > > printf "%s %s\n" "Hello" "World"
-- > Hello World
-- > > printf "%.2f\n" pi
-- > 3.14
--
printf :: (PrintfType r) => String -> r
printf fmts = spr fmts []
-- | Similar to 'printf', except that output is via the specified
-- 'Handle'. The return type is restricted to @('IO' a)@.
hPrintf :: (HPrintfType r) => Handle -> String -> r
hPrintf hdl fmts = hspr hdl fmts []
-- |The 'PrintfType' class provides the variable argument magic for
-- 'printf'. Its implementation is intentionally not visible from
-- this module. If you attempt to pass an argument of a type which
-- is not an instance of this class to 'printf' or 'hPrintf', then
-- the compiler will report it as a missing instance of 'PrintfArg'.
class PrintfType t where
spr :: String -> [UPrintf] -> t
-- | The 'HPrintfType' class provides the variable argument magic for
-- 'hPrintf'. Its implementation is intentionally not visible from
-- this module.
class HPrintfType t where
hspr :: Handle -> String -> [UPrintf] -> t
{- not allowed in Haskell 98
instance PrintfType String where
spr fmt args = uprintf fmt (reverse args)
-}
instance (IsChar c) => PrintfType [c] where
spr fmts args = map fromChar (uprintf fmts (reverse args))
instance PrintfType (IO a) where
spr fmts args = do
putStr (uprintf fmts (reverse args))
return (error "PrintfType (IO a): result should not be used.")
instance HPrintfType (IO a) where
hspr hdl fmts args = do
hPutStr hdl (uprintf fmts (reverse args))
return (error "HPrintfType (IO a): result should not be used.")
instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
spr fmts args = \ a -> spr fmts (toUPrintf a : args)
instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
hspr hdl fmts args = \ a -> hspr hdl fmts (toUPrintf a : args)
class PrintfArg a where
toUPrintf :: a -> UPrintf
instance PrintfArg Char where
toUPrintf c = UChar c
{- not allowed in Haskell 98
instance PrintfArg String where
toUPrintf s = UString s
-}
instance (IsChar c) => PrintfArg [c] where
toUPrintf = UString . map toChar
instance PrintfArg Int where
toUPrintf = uInteger
instance PrintfArg Int8 where
toUPrintf = uInteger
instance PrintfArg Int16 where
toUPrintf = uInteger
instance PrintfArg Int32 where
toUPrintf = uInteger
instance PrintfArg Int64 where
toUPrintf = uInteger
#ifndef __NHC__
instance PrintfArg Word where
toUPrintf = uInteger
#endif
instance PrintfArg Word8 where
toUPrintf = uInteger
instance PrintfArg Word16 where
toUPrintf = uInteger
instance PrintfArg Word32 where
toUPrintf = uInteger
instance PrintfArg Word64 where
toUPrintf = uInteger
instance PrintfArg Integer where
toUPrintf = UInteger 0
instance PrintfArg Float where
toUPrintf = UFloat
instance PrintfArg Double where
toUPrintf = UDouble
uInteger :: (Integral a, Bounded a) => a -> UPrintf
uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x)
class IsChar c where
toChar :: c -> Char
fromChar :: Char -> c
instance IsChar Char where
toChar c = c
fromChar c = c
-------------------
data UPrintf = UChar Char | UString String | UInteger Integer Integer | UFloat Float | UDouble Double
uprintf :: String -> [UPrintf] -> String
uprintf "" [] = ""
uprintf "" (_:_) = fmterr
uprintf ('%':'%':cs) us = '%':uprintf cs us
uprintf ('%':_) [] = argerr
uprintf ('%':cs) us@(_:_) = fmt cs us
uprintf (c:cs) us = c:uprintf cs us
fmt :: String -> [UPrintf] -> String
fmt cs us =
let (width, prec, ladj, zero, plus, cs', us') = getSpecs False False False cs us
adjust (pre, str) =
let lstr = length str
lpre = length pre
fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
in if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
adjust' ("", str) | plus = adjust ("+", str)
adjust' ps = adjust ps
in
case cs' of
[] -> fmterr
c:cs'' ->
case us' of
[] -> argerr
u:us'' ->
(case c of
'c' -> adjust ("", [toEnum (toint u)])
'd' -> adjust' (fmti prec u)
'i' -> adjust' (fmti prec u)
'x' -> adjust ("", fmtu 16 prec u)
'X' -> adjust ("", map toUpper $ fmtu 16 prec u)
'o' -> adjust ("", fmtu 8 prec u)
'u' -> adjust ("", fmtu 10 prec u)
'e' -> adjust' (dfmt' c prec u)
'E' -> adjust' (dfmt' c prec u)
'f' -> adjust' (dfmt' c prec u)
'g' -> adjust' (dfmt' c prec u)
'G' -> adjust' (dfmt' c prec u)
's' -> adjust ("", tostr prec u)
_ -> perror ("bad formatting char " ++ [c])
) ++ uprintf cs'' us''
fmti :: Int -> UPrintf -> (String, String)
fmti prec (UInteger _ i) = if i < 0 then ("-", integral_prec prec (show (-i))) else ("", integral_prec prec (show i))
fmti _ (UChar c) = fmti 0 (uInteger (fromEnum c))
fmti _ _ = baderr
fmtu :: Integer -> Int -> UPrintf -> String
fmtu b prec (UInteger l i) = integral_prec prec (itosb b (if i < 0 then -2*l + i else i))
fmtu b _ (UChar c) = itosb b (toInteger (fromEnum c))
fmtu _ _ _ = baderr
integral_prec :: Int -> String -> String
integral_prec prec integral = (replicate (prec - (length integral)) '0') ++ integral
toint :: UPrintf -> Int
toint (UInteger _ i) = fromInteger i
toint (UChar c) = fromEnum c
toint _ = baderr
tostr :: Int -> UPrintf -> String
tostr n (UString s) = if n >= 0 then take n s else s
tostr _ _ = baderr
itosb :: Integer -> Integer -> String
itosb b n =
if n < b then
[intToDigit $ fromInteger n]
else
let (q, r) = quotRem n b in
itosb b q ++ [intToDigit $ fromInteger r]
stoi :: Int -> String -> (Int, String)
stoi a (c:cs) | isDigit c = stoi (a*10 + digitToInt c) cs
stoi a cs = (a, cs)
getSpecs :: Bool -> Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, Bool, String, [UPrintf])
getSpecs _ z s ('-':cs) us = getSpecs True z s cs us
getSpecs l z _ ('+':cs) us = getSpecs l z True cs us
getSpecs l _ s ('0':cs) us = getSpecs l True s cs us
getSpecs l z s ('*':cs) us =
let (us', n) = getStar us
((p, cs''), us'') =
case cs of
'.':'*':r -> let (us''', p') = getStar us'
in ((p', r), us''')
'.':r -> (stoi 0 r, us')
_ -> ((-1, cs), us')
in (n, p, l, z, s, cs'', us'')
getSpecs l z s ('.':cs) us =
let ((p, cs'), us') =
case cs of
'*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')
_ -> (stoi 0 cs, us)
in (0, p, l, z, s, cs', us')
getSpecs l z s cs@(c:_) us | isDigit c =
let (n, cs') = stoi 0 cs
((p, cs''), us') = case cs' of
'.':'*':r -> let (us'', p') = getStar us in ((p', r), us'')
'.':r -> (stoi 0 r, us)
_ -> ((-1, cs'), us)
in (n, p, l, z, s, cs'', us')
getSpecs l z s cs us = (0, -1, l, z, s, cs, us)
getStar :: [UPrintf] -> ([UPrintf], Int)
getStar us =
case us of
[] -> argerr
nu : us' -> (us', toint nu)
dfmt' :: Char -> Int -> UPrintf -> (String, String)
dfmt' c p (UDouble d) = dfmt c p d
dfmt' c p (UFloat f) = dfmt c p f
dfmt' _ _ _ = baderr
dfmt :: (RealFloat a) => Char -> Int -> a -> (String, String)
dfmt c p d =
case (if isUpper c then map toUpper else id) $
(case toLower c of
'e' -> showEFloat
'f' -> showFFloat
'g' -> showGFloat
_ -> error "Printf.dfmt: impossible"
)
(if p < 0 then Nothing else Just p) d "" of
'-':cs -> ("-", cs)
cs -> ("" , cs)
perror :: String -> a
perror s = error ("Printf.printf: "++s)
fmterr, argerr, baderr :: a
fmterr = perror "formatting string ended prematurely"
argerr = perror "argument list ended prematurely"
baderr = perror "bad argument"