Стандартное начало (Prelude)

- Числовые функции

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 не определен"
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.^: отрицательный показатель степени"


(^^)             :: (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

- Монадические классы

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

- Минимальное полное определение:

-      (>>=), 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 ())

- Функции вида xxxM работают со списком аргументов, но повышают тип функции или - элемента списка до монадического типа

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

- Тривиальный тип

data  ()  =  ()  deriving (Eq, Ord, Enum, Bounded)

- Недопустимо в Haskell; только для примера

id               :: a -> a
id x             =  x

- константная функция

const            :: a -> b -> a
const x _        =  x

- композиция функций

(.)              :: (b -> c) -> (a -> b) -> a -> c
f . g            =  \ x -> f (g x)

- flip f принимает свои (первые) два аргумента в обратном порядке для f.

flip             :: (a -> b -> c) -> b -> a -> c
flip f x y       =  f y x


seq :: a -> b -> b
seq = ...

- Примитив - правоассоциативное инфиксное применение операторов - (полезно в стиле с возобновляющейся передачей)

($), ($!) :: (a -> b) -> a -> b
f $  x    =  f x
f $! x    =  x `seq` f x

- Булевский тип

data  Bool  =  False | True     deriving (Eq, Ord, Enum, Read, Show, Bounded)

- Булевы функции

(), (||)       :: 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

- Символьный тип

data Char = ... 'a' | 'b' ... - значения Unicode


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)

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)

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

- Тип ввода - вывода

data IO a = ...  - абстрактный


instance  Functor IO where
   fmap f x           =  x >>= (return . f)


instance Monad IO where
   (>>=)  = ...
   return = ...
   fail s = ioError (userError s)

- Тип упорядочивания

data  Ordering  =  LT | EQ | GT
          deriving (Eq, Ord, Enum, Read, Show, Bounded)

- Стандартные числовые типы. Объявления данных для этих типов нельзя - выразить непосредственно на Haskell, т.к. конструируемые списки были бы - слишком длинными.

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 ...

- Экземпляры Enum для Float и Double слегка необычны. - Функция 'toEnum' выполняет усечение числа до Int. Определения - enumFrom и enumFromThen позволяют использовать числа с плавающей точкой в арифметических - последовательностях: [0,0.1 .. 0.95]. Тем не менее, ошибки roundoff делают это несколько - сомнительным. В этом примере может быть 10 или 11 элементов, в зависимости от того, - как представлено 0.1.

instance  Enum Float  where
    succ x           =  x+1
    pred x           =  x-1
    toEnum           =  fromIntegral
    fromEnum         =  fromInteger . truncate   -

может вызвать переполнение

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   -

может вызвать переполнение

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)

- Списки

data  [a]  =  [] | a : [a]  deriving (Eq, Ord)

- Недопустимо в Haskell; только для примера

instance Functor [] where
    fmap = map


instance  Monad []  where
    m >>= k          = concat (map k m)
    return x         = [x]
    fail s           = []

- Кортежи

data  (a,b)   =  (a,b)    deriving (Eq, Ord, Bounded)

data  (a,b,c) =  (a,b,c)  deriving (Eq, Ord, Bounded)

- Недопустимо в Haskell; только для примера - проекции компонент для пары: - (NB: не предусмотрено для кортежей размера 3, 4 и т.д.)

fst              :: (a,b) -> a
fst (x,y)        =  x


snd              :: (a,b) -> b
snd (x,y)        =  y

- curry преобразует развернутую функцию (функцию двух аргументов) в свернутую функцию (функцию над парой аргументов) - uncurry преобразует свернутую функцию в развернутую функцию

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)

- Разные функции

- until p f получает результат применения f до тех пор, пока p выполняется.


until            :: (a -> Bool) -> (a -> a) -> a -> a
until p f x 
     | p x       =  x
     | otherwise =  until p f (f x)

- asTypeOf является версией const с ограниченным набором типов. Она обычно используется - в качестве инфиксного оператора, и ее типизация приводит к тому, что ее первый аргумент - (который обычно является перегруженным) должен иметь тот же тип, что второй аргумент.

asTypeOf         :: a -> a -> a
asTypeOf         =  const

- error останавливает вычисление и выводит на экран сообщение об ошибке

error            :: String -> a
error            =  primError

- Ожидается, что компиляторы распознают это и вставят - более подходящие сообщения об ошибках для контекста, в котором возник undefined.

undefined        :: a
undefined        =  error "Prelude.undefined"

8.1. Prelude PreludeList

- Стандартные функции над списками

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) и добавление в конец (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 и tail извлекают соответственно первый и последний элементы - конечного списка. last и init являются - двойственными функциями, которые выполняются с конца конечного списка, - а не с начала.

head             :: [a] -> a
head (x:_)       =  x
head []          =  error "Prelude.head: пустой список"


tail             :: [a] -> [a]
tail (_:xs)      =  xs
tail []          =  error "Prelude.tail: пустой список"


last             :: [a] -> a
last [x]         =  x
last (_:xs)      =  last xs
last []          =  error "Prelude.last: пустой список"


init             :: [a] -> [a]
init [x]         =  []
init (x:xs)      =  x : init xs
init []          =  error "Prelude.init: пустой список"


null             :: [a] -> Bool
null []          =  True
null (_:_)       =  False

- length возвращает длину конечного списка в виде Int.

length           :: [a] -> Int
length []        =  0
length (_:l)     =  1 + length l

- Оператор доступа к элементам списка по индексу, начало - в 0.

(!!)                :: [a] -> Int -> a
xs     !! n | n < 0 =  error "Prelude.!!: отрицательный индекс"
[]     !! _         =  error "Prelude.!!: слишком большой индекс"
(x:_)  !! 0         =  x
(_:xs) !! n         =  xs !! (n-1)

foldl, будучи примененной к своим аргументам: бинарному оператору, начальному значению (обычно - левому аргументу из тождества оператора) и списку, сокращает список, используя - бинарный оператор слева направо:

-  foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn

foldl1 является вариантом предыдущей функции, она не имеет аргумента с начальным значением, и поэтому должна - применяться к непустым спискам. scanl похожа на foldl, но возвращает - список успешно сокращенных значений слева:

-      scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]

- Обратите внимание, что last (scanl f z xs) == foldl f z xs. - scanl1 похожа на предыдущую функцию, но без начального элемента:

-      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: пустой список"


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 и scanr1 являются двойственными дополнениями описанных выше функций; - они действуют справа налево.

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: пустой список"


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 возвращает бесконечный список повторных применений f к 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 представляет собой бесконечный список, где каждый элемент равен x.

repeat           :: a -> [a]
repeat x         =  xs where xs = x:xs

- replicate n x представляет собой список длины n, где каждый элемент равен x.

replicate        :: Int -> a -> [a]
replicate n x    =  take n (repeat x)

- cycle связывает конечный список в круговой или, что то же самое, - бесконечно повторяет исходный список. Он идентичен - бесконечным спискам.

cycle            :: [a] -> [a]
cycle []         =  error "Prelude.cycle: пустой список"
cycle xs         =  xs' where xs' = xs ++ xs'

- take n, будучи примененной к списку xs, возвращает префикс xs длины n, - или сам xs, если n > length xs. drop n xs возвращает суффикс xs - после первых n элементов, или [], если n > length xs. splitAt n xs - эквивалентна (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)

- akeWhile, будучи примененной к предикату p и списку xs, возвращает самый длинный - префикс (возможно пустой) xs, элементы которого удовлетворяют p. dropWhile p xs - возвращает оставшийся суффикс. span p xs эквивалентна - (takeWhile p xs, dropWhile p xs), тогда как break p использует отрицание 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 разбивает строку в местах символов новой строки на список строк. - Полученные строки не содержат символов новой строки. Аналогично, words - разбивает строку на список строк в местах пробельных символов. - unlines и unwords являются обратными операциями. - unlines соединяет строки, добавляя в конец каждой символ новой строки, а unwords соединяет - слова, отделяя их друг от друга пробелами.

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 возвращает элементы списка xs в обратном порядке. Список xs должен быть конечным.

reverse          :: [a] -> [a]
reverse          =  foldl (flip (:)) []

- and возвращает конъюнкцию списка булевых значений. Для того чтобы результат - был истиной, список должен быть конечным; False является результатом наличия значения False - в элементе с конечным индексом конечного или бесконечного списка. or является двойственной к and функцией, - в ней используется дизъюнкция.

and, or          :: [Bool] -> Bool
and              =  foldr () True
or               =  foldr (||) False

- Будучи примененной к предикату и списку, any определяет, есть ли хотя бы один элемент - списка, который удовлетворяет предикату. Аналогично all определяет, все ли элементы списка удовлетворяет предикату.

any, all         :: (a -> Bool) -> [a] -> Bool
any p            =  or . map p
all p            =  and . map p

- elem является предикатом, который определяет, является ли аргумент элементом списка; обычно он записывается в инфиксной форме, - например, x 'elem' xs. notElem является отрицанием предыдущей функции.

elem, notElem    :: (Eq a) => a -> [a] -> Bool
elem x           =  any (== x)
notElem x        =  all (/= x)

- lookup key assoc ищет ключ в ассоциативном списке.

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 и product вычисляют соответственно сумму и произведение чисел из конечного списка.

sum, product     :: (Num a) => [a] -> a
sum              =  foldl (+) 0  
product          =  foldl (*) 1

- maximum и minimum возвращают соответственно максимальное и минимальное значение из списка, - который должен быть непуст, конечен и содержать элементы, которые можно упорядочить.

maximum, minimum :: (Ord a) => [a] -> a
maximum []       =  error "Prelude.maximum: пустой список"
maximum xs       =  foldl1 max xs

minimum []       =  error "Prelude.minimum: пустой список"
minimum xs       =  foldl1 min xs

- zip принимает в качестве аргументов два списка и возвращает список соответствующих пар. Если один из - входных списков короче, дополнительные элементы более длинного списка игнорируются. - zip3 принимает в качестве аргументов три списка и возвращает список кортежей размера 3. Функции zip для более длинных кортежей - находятся в библиотеке List.

zip              :: [a] -> [b] -> [(a,b)]
zip              =  zipWith (,)


zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]
zip3             =  zipWith3 (,,)

- Семейство функций zipWith является обобщением семейства функций zip; они упаковывают элементы списков с помощью - функции, заданной в качестве первого аргумента, вместо функции создания кортежей. - Например, zipWith (+), будучи примененной к двум спискам, порождает список - соответствующих сумм.

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 преобразует список пар в пару списков.

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))
                          ([],[],[])

8.2. Prelude PreludeText

module PreludeText (
    ReadS, ShowS,
    Read(readsPrec, readList),
    Show(showsPrec, show, showList),
    reads, shows, read, lex,
    showChar, showString, readParen, showParen ) where

- Экземпляры классов Read и Show для - Bool, Maybe, Either, Ordering - созданы посредством инструкций "deriving" в 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]

- Минимальное полное определение: - readsPrec

readList         = readParen False (\r -> [pr | ("[",s)  <- lex r,
                                                    pr       7gt;- 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

- Минимальное полное определение: - show или 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: нет разбора"
                         _   -> error "Prelude.read: неоднозначный разбор"


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    ]

- Этот лексический анализатор не полностью соответствует лексическому синтаксису Haskell.

- Текущие ограничения:

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) =  [("\\amp;",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  = []    - плохой символ
             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

- Преобразование к Integer позволяет избежать - возможного противоречия с minInt

instance  Read Int  where
  readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]

- Считывание в тип Integer позволяет избежать - возможного противоречия с 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

- Кортежи

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 ] )

- Другие кортежи имеют сходные экземпляры классов Read и Show

8.3. Prelude PreludeIO

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 - Внутреннее представление этого типа зависит от системы

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 ()

- hSetBuffering гарантирует ожидаемое интерактивное поведение

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

- вместо ошибки вызывает исключение

readIO   :: Read a => String -> IO a
readIO s =  case [x | (x,t) <- reads s, ("","") <- lex t] of
              [x] -> return x
              []  -> ioError (userError "Prelude.readIO: нет разбора")
              _   -> ioError (userError "Prelude.readIO: неоднозначный разбор")


readLn :: Read a => IO a
readLn =  do l <- getLine
             r <- readIO l
             return r