#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 702
#define DEFAULT_SIGNATURES
#endif
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 701
#endif
#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
module Prelude.Extras
(
Eq1(..), (/=#)
, Ord1(..), (<#), (<=#), (>=#), (>#), max1, min1
, Show1(..), show1, shows1
, Read1(..), read1, reads1
#ifdef __GLASGOW_HASKELL__
, readPrec1
, readListPrec1
, readList1Default
, readListPrec1Default
#endif
, Lift1(..)
, Eq2(..), (/=##)
, Ord2(..), (<##), (<=##), (>=##), (>##), max2, min2
, Show2(..), show2, shows2
, Read2(..), read2, reads2
#ifdef __GLASGOW_HASKELL__
, readPrec2
, readListPrec2
, readList2Default
, readListPrec2Default
#endif
, Lift2(..)
) where
import Control.Applicative
import Control.Arrow (first)
import Control.Concurrent (Chan, MVar)
import Data.Complex (Complex)
import Data.Fixed
import Data.IORef (IORef)
import Data.Monoid
import Data.Ratio (Ratio)
import Foreign.ForeignPtr (ForeignPtr)
import Foreign.Ptr (Ptr, FunPtr)
import Foreign.StablePtr (StablePtr)
import GHC.Conc (TVar)
import Text.Read
import qualified Text.ParserCombinators.ReadP as P
import qualified Text.Read.Lex as L
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity
#else
import Data.Foldable
import Data.Traversable
#endif
#if MIN_VERSION_base(4,7,0)
import Data.Proxy
#endif
#if MIN_VERSION_base(4,6,0)
import Data.Ord (Down(..))
#endif
infixr 4 ==#, /=#, <#, <=#, >=#, >#
infixr 4 ==##, /=##, <##, <=##, >=##, >##
class Eq1 f where
(==#) :: Eq a => f a -> f a -> Bool
#ifdef DEFAULT_SIGNATURES
default (==#) :: (Eq (f a), Eq a) => f a -> f a -> Bool
(==#) = (==)
#endif
(/=#) :: (Eq1 f, Eq a) => f a -> f a -> Bool
a /=# b = not (a ==# b)
instance Eq1 Maybe where
Just a ==# Just b = a == b
Nothing ==# Nothing = True
_ ==# _ = False
instance Eq a => Eq1 (Either a) where
(==#) = (==)
instance Eq1 [] where
(==#) = (==)
#if MIN_VERSION_base(4,8,0)
instance Eq1 Identity where (==#) = (==)
instance Eq1 f => Eq1 (Alt f) where Alt x ==# Alt y = x ==# y
#endif
#if MIN_VERSION_base(4,7,0)
instance Eq1 Proxy where (==#) = (==)
instance Eq1 ZipList where (==#) = (==)
#else
instance Eq1 ZipList where ZipList xs ==# ZipList ys = xs == ys
#endif
#if MIN_VERSION_base(4,6,0)
instance Eq1 Down where (==#) = (==)
#endif
instance Eq1 Dual where (==#) = (==)
instance Eq1 Sum where (==#) = (==)
instance Eq1 Product where (==#) = (==)
instance Eq1 First where (==#) = (==)
instance Eq1 Last where (==#) = (==)
instance Eq1 Ptr where (==#) = (==)
instance Eq1 FunPtr where (==#) = (==)
instance Eq1 MVar where (==#) = (==)
instance Eq1 IORef where (==#) = (==)
instance Eq1 ForeignPtr where (==#) = (==)
instance Eq1 TVar where (==#) = (==)
instance Eq1 Fixed where (==#) = (==)
instance Eq1 StablePtr where (==#) = (==)
#if MIN_VERSION_base(4,4,0)
instance Eq1 Ratio where (==#) = (==)
instance Eq1 Complex where (==#) = (==)
instance Eq1 Chan where (==#) = (==)
#endif
class Eq2 f where
(==##) :: (Eq a, Eq b) => f a b -> f a b -> Bool
#ifdef DEFAULT_SIGNATURES
default (==##) :: (Eq (f a b), Eq a, Eq b) => f a b -> f a b -> Bool
(==##) = (==)
#endif
(/=##) :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool
a /=## b = not (a ==## b)
instance Eq2 Either where
(==##) = (==)
class Eq1 f => Ord1 f where
compare1 :: Ord a => f a -> f a -> Ordering
#ifdef DEFAULT_SIGNATURES
default compare1 :: (Ord (f a), Ord a) => f a -> f a -> Ordering
compare1 = compare
#endif
(<#), (<=#), (>=#), (>#) :: (Ord1 f, Ord a) => f a -> f a -> Bool
max1, min1 :: (Ord1 f, Ord a) => f a -> f a -> f a
x <=# y = compare1 x y /= GT
x <# y = compare1 x y == LT
x >=# y = compare1 x y /= LT
x ># y = compare1 x y == GT
max1 x y
| x >=# y = x
| otherwise = y
min1 x y
| x <# y = x
| otherwise = y
instance Ord1 Maybe where compare1 = compare
instance Ord a => Ord1 (Either a) where compare1 = compare
instance Ord1 [] where compare1 = compare
#if MIN_VERSION_base(4,8,0)
instance Ord1 Identity where compare1 = compare
instance Ord1 f => Ord1 (Alt f) where compare1 (Alt x) (Alt y) = compare1 x y
#endif
#if MIN_VERSION_base(4,7,0)
instance Ord1 Proxy where compare1 = compare
instance Ord1 ZipList where compare1 = compare
#else
instance Ord1 ZipList where compare1 (ZipList xs) (ZipList ys) = compare xs ys
#endif
#if MIN_VERSION_base(4,6,0)
instance Ord1 Down where compare1 = compare
#endif
instance Ord1 Dual where compare1 = compare
instance Ord1 Sum where compare1 = compare
instance Ord1 Product where compare1 = compare
instance Ord1 First where compare1 = compare
instance Ord1 Last where compare1 = compare
instance Ord1 Ptr where compare1 = compare
instance Ord1 FunPtr where compare1 = compare
instance Ord1 ForeignPtr where compare1 = compare
instance Ord1 Fixed where compare1 = compare
class Eq2 f => Ord2 f where
compare2 :: (Ord a, Ord b) => f a b -> f a b -> Ordering
#ifdef DEFAULT_SIGNATURES
default compare2 :: (Ord (f a b), Ord a, Ord b) => f a b -> f a b -> Ordering
compare2 = compare
#endif
(<##) :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Bool
x <=## y = compare2 x y /= GT
(<=##) :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Bool
x <## y = compare2 x y == LT
(>=##) :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Bool
x >=## y = compare2 x y /= LT
(>##) :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Bool
x >## y = compare2 x y == GT
max2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> f a b
max2 x y
| x >=## y = x
| otherwise = y
min2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> f a b
min2 x y
| x <## y = x
| otherwise = y
instance Ord2 Either where compare2 = compare
class Show1 f where
showsPrec1 :: Show a => Int -> f a -> ShowS
#ifdef DEFAULT_SIGNATURES
default showsPrec1 :: (Show (f a), Show a) => Int -> f a -> ShowS
showsPrec1 = showsPrec
#endif
showList1 :: (Show a) => [f a] -> ShowS
showList1 ls s = showList__ shows1 ls s
show1 :: (Show1 f, Show a) => f a -> String
show1 x = shows1 x ""
shows1 :: (Show1 f, Show a) => f a -> ShowS
shows1 = showsPrec1 0
instance Show1 Maybe where showsPrec1 = showsPrec
instance Show1 [] where showsPrec1 = showsPrec
instance Show a => Show1 (Either a) where showsPrec1 = showsPrec
instance Show a => Show1 ((,) a) where showsPrec1 = showsPrec
#if MIN_VERSION_base(4,8,0)
instance Show1 Identity where showsPrec1 = showsPrec
#endif
#if MIN_VERSION_base(4,7,0)
instance Show1 Proxy where showsPrec1 = showsPrec
instance Show1 ZipList where showsPrec1 = showsPrec
#else
instance Show1 ZipList where
showsPrec1 p (ZipList xs)
= showString "ZipList {getZipList = "
. showList xs
. showString "}"
#endif
#if MIN_VERSION_base(4,8,0)
instance Show1 Down where showsPrec1 = showsPrec
instance Show1 f => Show1 (Alt f) where
showsPrec1 p (Alt x)
= showParen (p > 10)
$ showString "Alt "
. showsPrec1 11 x
#endif
instance Show1 Dual where showsPrec1 = showsPrec
instance Show1 Sum where showsPrec1 = showsPrec
instance Show1 Product where showsPrec1 = showsPrec
instance Show1 First where showsPrec1 = showsPrec
instance Show1 Last where showsPrec1 = showsPrec
instance Show1 Ptr where showsPrec1 = showsPrec
instance Show1 FunPtr where showsPrec1 = showsPrec
instance Show1 ForeignPtr where showsPrec1 = showsPrec
#if MIN_VERSION_base(4,4,0)
instance Show1 Complex where showsPrec1 = showsPrec
#endif
class Show2 f where
showsPrec2 :: (Show a, Show b) => Int -> f a b -> ShowS
#ifdef DEFAULT_SIGNATURES
default showsPrec2 :: (Show (f a b), Show a, Show b) => Int -> f a b -> ShowS
showsPrec2 = showsPrec
#endif
showList2 :: (Show a, Show b) => [f a b] -> ShowS
showList2 ls s = showList__ shows2 ls s
show2 :: (Show2 f, Show a, Show b) => f a b -> String
show2 x = shows2 x ""
shows2 :: (Show2 f, Show a, Show b) => f a b -> ShowS
shows2 = showsPrec2 0
instance Show2 (,) where showsPrec2 = showsPrec
instance Show2 Either where showsPrec2 = showsPrec
showList__ :: (a -> ShowS) -> [a] -> ShowS
showList__ _ [] s = "[]" ++ s
showList__ showx (x:xs) s = '[' : showx x (showl xs)
where
showl [] = ']' : s
showl (y:ys) = ',' : showx y (showl ys)
class Read1 f where
readsPrec1 :: Read a => Int -> ReadS (f a)
#ifdef DEFAULT_SIGNATURES
default readsPrec1 :: (Read (f a), Read a) => Int -> ReadS (f a)
readsPrec1 = readsPrec
#endif
readList1 :: (Read a) => ReadS [f a]
readList1 = readPrec_to_S (list readPrec1) 0
#ifdef __GLASGOW_HASKELL__
readPrec1 :: (Read1 f, Read a) => ReadPrec (f a)
readPrec1 = readS_to_Prec readsPrec1
readListPrec1 :: (Read1 f, Read a) => ReadPrec [f a]
readListPrec1 = readS_to_Prec (\_ -> readList1)
#endif
read1 :: (Read1 f, Read a) => String -> f a
read1 s = either error id (readEither1 s)
reads1 :: (Read1 f, Read a) => ReadS (f a)
reads1 = readsPrec1 minPrec
readEither1 :: (Read1 f, Read a) => String -> Either String (f a)
readEither1 s =
case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
[x] -> Right x
[] -> Left "Prelude.read: no parse"
_ -> Left "Prelude.read: ambiguous parse"
where
read' =
do x <- readPrec1
lift P.skipSpaces
return x
#ifdef __GLASGOW_HASKELL__
readList1Default :: (Read1 f, Read a) => ReadS [f a]
readList1Default = readPrec_to_S readListPrec1 0
readListPrec1Default :: (Read1 f, Read a) => ReadPrec [f a]
readListPrec1Default = list readPrec1
#endif
instance Read1 [] where
readsPrec1 = readsPrec
readList1 = readList
instance Read1 Maybe where
readsPrec1 = readsPrec
readList1 = readList
instance Read a => Read1 (Either a) where
readsPrec1 = readsPrec
readList1 = readList
instance Read a => Read1 ((,) a) where
readsPrec1 = readsPrec
readList1 = readList
#if MIN_VERSION_base(4,8,0)
instance Read1 Identity where
readsPrec1 = readsPrec
readList1 = readList
instance Read1 f => Read1 (Alt f) where
readsPrec1 p
= readParen (p > 10) $ \s ->
do ("Alt",s1) <- lex s
(x,s2) <- readsPrec1 11 s1
return (Alt x, s2)
#endif
#if MIN_VERSION_base(4,7,0)
instance Read1 Proxy where
readsPrec1 = readsPrec
readList1 = readList
instance Read1 ZipList where
readsPrec1 = readsPrec
readList1 = readList
#else
instance Read1 ZipList where
readList1 = readList1Default
readsPrec1 _
= readParen False $ \s ->
do ("ZipList" , s1) <- lex s
("{" , s2) <- lex s1
("getZipList", s3) <- lex s2
("=" , s4) <- lex s3
(xs , s5) <- readList s4
("}" , s6) <- lex s5
return (ZipList xs, s6)
#endif
#if MIN_VERSION_base(4,7,0)
instance Read1 Down where
readsPrec1 = readsPrec
readList1 = readList
#elif MIN_VERSION_base(4,6,0)
instance Read1 Down where
readList1 = readList1Default
readsPrec1 p = readParen (p > 10) $ \s ->
do ("Down",s1) <- lex s
(x ,s2) <- readsPrec 11 s1
return (Down x, s2)
#endif
instance Read1 Dual where
readsPrec1 = readsPrec
readList1 = readList
instance Read1 Sum where
readsPrec1 = readsPrec
readList1 = readList
instance Read1 Product where
readsPrec1 = readsPrec
readList1 = readList
instance Read1 First where
readsPrec1 = readsPrec
readList1 = readList
instance Read1 Last where
readsPrec1 = readsPrec
readList1 = readList
#if MIN_VERSION_base(4,4,0)
instance Read1 Complex where
readsPrec1 = readsPrec
readList1 = readList
#endif
class Read2 f where
readsPrec2 :: (Read a, Read b) => Int -> ReadS (f a b)
#ifdef DEFAULT_SIGNATURES
default readsPrec2 :: (Read (f a b), Read a, Read b) => Int -> ReadS (f a b)
readsPrec2 = readsPrec
#endif
readList2 :: (Read a, Read b) => ReadS [f a b]
readList2 = readPrec_to_S (list readPrec2) 0
#ifdef __GLASGOW_HASKELL__
readPrec2 :: (Read2 f, Read a, Read b) => ReadPrec (f a b)
readPrec2 = readS_to_Prec readsPrec2
readListPrec2 :: (Read2 f, Read a, Read b) => ReadPrec [f a b]
readListPrec2 = readS_to_Prec (\_ -> readList2)
#endif
instance Read2 (,) where
readsPrec2 = readsPrec
readList2 = readList
instance Read2 Either where
readsPrec2 = readsPrec
readList2 = readList
read2 :: (Read2 f, Read a, Read b) => String -> f a b
read2 s = either error id (readEither2 s)
reads2 :: (Read2 f, Read a, Read b) => ReadS (f a b)
reads2 = readsPrec2 minPrec
readEither2 :: (Read2 f, Read a, Read b) => String -> Either String (f a b)
readEither2 s =
case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
[x] -> Right x
[] -> Left "Prelude.read: no parse"
_ -> Left "Prelude.read: ambiguous parse"
where
read' =
do x <- readPrec2
lift P.skipSpaces
return x
#ifdef __GLASGOW_HASKELL__
readList2Default :: (Read2 f, Read a, Read b) => ReadS [f a b]
readList2Default = readPrec_to_S readListPrec2 0
readListPrec2Default :: (Read2 f, Read a, Read b) => ReadPrec [f a b]
readListPrec2Default = list readPrec2
#endif
list :: ReadPrec a -> ReadPrec [a]
list readx =
parens
( do L.Punc "[" <- lexP
(listRest False +++ listNext)
)
where
listRest started =
do L.Punc c <- lexP
case c of
"]" -> return []
"," | started -> listNext
_ -> pfail
listNext =
do x <- reset readx
xs <- listRest True
return (x:xs)
newtype Lift1 f a = Lift1 { lower1 :: f a }
deriving (Functor, Foldable, Traversable)
instance Eq1 f => Eq1 (Lift1 f) where Lift1 a ==# Lift1 b = a ==# b
instance Ord1 f => Ord1 (Lift1 f) where Lift1 a `compare1` Lift1 b = compare1 a b
instance Show1 f => Show1 (Lift1 f) where showsPrec1 d (Lift1 a) = showsPrec1 d a
instance Read1 f => Read1 (Lift1 f) where
readsPrec1 d = map (first Lift1) . readsPrec1 d
instance (Eq1 f, Eq a) => Eq (Lift1 f a) where Lift1 a == Lift1 b = a ==# b
instance (Ord1 f, Ord a) => Ord (Lift1 f a) where Lift1 a `compare` Lift1 b = compare1 a b
instance (Show1 f, Show a) => Show (Lift1 f a) where showsPrec d (Lift1 a) = showsPrec1 d a
instance (Read1 f, Read a) => Read (Lift1 f a) where
readsPrec d = map (first Lift1) . readsPrec1 d
newtype Lift2 f a b = Lift2 { lower2 :: f a b }
deriving (Functor, Foldable, Traversable)
instance Eq2 f => Eq2 (Lift2 f) where Lift2 a ==## Lift2 b = a ==## b
instance Ord2 f => Ord2 (Lift2 f) where Lift2 a `compare2` Lift2 b = compare2 a b
instance Show2 f => Show2 (Lift2 f) where showsPrec2 d (Lift2 a) = showsPrec2 d a
instance Read2 f => Read2 (Lift2 f) where
readsPrec2 d = map (first Lift2) . readsPrec2 d
instance (Eq2 f, Eq a) => Eq1 (Lift2 f a) where Lift2 a ==# Lift2 b = a ==## b
instance (Ord2 f, Ord a) => Ord1 (Lift2 f a) where Lift2 a `compare1` Lift2 b = compare2 a b
instance (Show2 f, Show a) => Show1 (Lift2 f a) where showsPrec1 d (Lift2 a) = showsPrec2 d a
instance (Read2 f, Read a) => Read1 (Lift2 f a) where
readsPrec1 d = map (first Lift2) . readsPrec2 d
instance (Eq2 f, Eq a, Eq b) => Eq (Lift2 f a b) where Lift2 a == Lift2 b = a ==## b
instance (Ord2 f, Ord a, Ord b) => Ord (Lift2 f a b) where Lift2 a `compare` Lift2 b = compare2 a b
instance (Show2 f, Show a, Show b) => Show (Lift2 f a b) where showsPrec d (Lift2 a) = showsPrec2 d a
instance (Read2 f, Read a, Read b) => Read (Lift2 f a b) where
readsPrec d = map (first Lift2) . readsPrec2 d