module PreludeText (
-- * As specified in Haskell 98
ReadS, ShowS,
Read(readsPrec, readList),
Show(showsPrec, showList),
reads, shows, show, read, lex,
showChar, showString, readParen, showParen,
-- * Extra combinators used in derived Show & Read instances
showArgument,showParenArg,
readAp,readToken,readSkip,readSep,readChoice,
readArgument,readParenArg,readsField
) where
-- The instances of Read and Show for
-- Bool, Char, Maybe, Either, Ordering
-- are done via "deriving" clauses in Prelude.hs
import PreludeBuiltin(primDoubleShow)
import Char(isSpace, isAlpha, isDigit, isHexDigit, isOctDigit, isAlphaNum,
showLitChar, readLitChar, lexLitChar, chr, ord)
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 = \ xs ->
case xs of
[] -> showChar ']'
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 parses of
[x] -> x
[] -> error $ "Prelude.read: no parse: "++s
_ -> error $ "Prelude.read: ambiguous parse: "++s
where parses = [x | (x,t) <- reads s, ("","") <- lex t]
showChar :: Char -> ShowS
showChar = (:)
showString :: String -> ShowS
showString = (++)
showParen :: Bool -> ShowS -> ShowS
showParen b p = if b then showChar '(' . p . showChar ')' else p
-- Basic printing combinators (nonstd, for use in derived Show instances):
showParenArg :: Int -> ShowS -> ShowS
showParenArg d = showParen (10<=d)
showArgument x = showChar ' ' . showsPrec 10 x
-- Basic parsing combinators (nonstd, for use in derived Read instances):
readToken x t s = [(x,r)|(t',r)<-lex s,t'==t]
readSep t = readToken () t
readParenArg :: Int -> ReadS a -> ReadS a
readParenArg d = readParen (10<=d)
readArgument s = readsPrec 10 s
readsField sep f s = [(x,r) | (_,r0) <- readSep sep s,
(_,r1) <- readSep f r0,
(_,r2) <- readSep "=" r1,
(x,r ) <- reads r2]
-- | '<*>' for 'ReadS'
rf `readAp` rx = \ s0 -> [(f x,s2) | (f,s1)<-rf s0,(x,s2)<-rx s1]
rf `readSkip` rx = \ s0 -> [(f, s2) | (f,s1)<-rf s0,(x,s2)<-rx s1]
-- ^ '<*' for 'ReadS'
-- | '<|>' for 'ReadS'
readChoice rd1 rd2 s = rd1 s ++ rd2 s
---
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 ('0':'x':c:s)|isHexDigit c=[('0':'x':c:ds,r)] where (ds,r)=span isHexDigit s
lex ('0':'X':c:s)|isOctDigit c=[('0':'x':c:ds,r)] where (ds,r)=span isHexDigit s
lex ('0':'o':c:s)|isOctDigit c=[('0':'o':c:ds,r)] where (ds,r)=span isOctDigit s
lex ('0':'O':c:s)|isOctDigit c=[('0':'o':c:ds,r)] where (ds,r)=span isOctDigit 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 p = showSigned showInt p -- . toInteger
-- Converting to Integer avoids difficulty with (minBound::Int)
-- The problem is that -minBound == minBound, so Numeric.showInt will fail
-- because the number is negative.
where
-- To avoid the conversion to Integer, here is a variant of showInt that
-- can handle negative numbers
showInt n r = if n'==0 then r' else showInt n' r'
where
n' = n `quot` 10
d = toDigit (abs (n `rem` 10))
r' = d : r
toDigit i = chr (ord '0' + i)
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 Show Float where showsPrec p (Float x) = showsPrec p x
instance Read Float where
readsPrec p = readFloat
{-
instance Show Double where
showsPrec p = showFloat
-}
instance Show Double where showsPrec p x s = primDoubleShow x++s
instance Read Double where
readsPrec p = 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 (Show a, Show b, Show c) => Show (a,b,c) where
showsPrec p (x,y,z) = showChar '(' . shows x . showChar ',' .
shows y . showChar ',' .
shows z . showChar ')'
instance (Show a, Show b, Show c,Show d) => Show (a,b,c,d) where
showsPrec p (w,x,y,z) = showChar '(' . shows w . showChar ',' .
shows x . showChar ',' .
shows y . showChar ',' .
shows z . 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 ] )
instance (Read a, Read b, Read c) => Read (a,b,c) where
readsPrec p s = [((x,y,z), r) | ("(",r1) <- lex s,
(x,r2) <- reads r1,
(",",r3) <- lex r2,
(y,r4) <- reads r3,
(",",r5) <- lex r4,
(z,r6) <- reads r5,
(")",r) <- lex r6 ]
instance (Read a, Read b, Read c,Read d) => Read (a,b,c,d) where
readsPrec p s = [((w,x,y,z), r) | ("(",r1) <- lex s,
(w,r2) <- reads r1,
(",",r3) <- lex r2,
(x,r4) <- reads r3,
(",",r5) <- lex r4,
(y,r6) <- reads r5,
(",",r7) <- lex r6,
(z,r8) <- reads r7,
(")",r) <- lex r8 ]
-- Other tuples have similar Read and Show instances