--- /dev/null
+module PreludeText (
+ ReadS(..), ShowS(..),
+
+ lex,
+ showString,
+ readParen,
+ showParen,
+ read,
+ readDec,
+ readFloat,
+ readLitChar,
+ readSigned,
+ _readRational,
+ reads,
+ show,
+ showChar,
+ showFloat,
+ showInt,
+ showLitChar,
+ showSigned,
+ shows,
+
+ _showHex, _showRadix, _showDigit, -- non-std
+
+ showSpace__, -- non-std
+-- lexToss__, -- non-std
+ readOct, readHex
+ ) where
+
+import Cls
+import Core
+import IChar -- instances
+import IDouble
+import IFloat
+import IInt
+import IInteger
+import IList
+import IRatio
+import ITup2
+import List
+import Prel
+import PS ( _PackedString, _unpackPS )
+import TyComplex -- for pragmas
+
+-- import Prelude hiding ( readParen )
+
+type ReadS a = String -> [(a,String)]
+type ShowS = String -> String
+
+-- *** instances omitted ***
+
+
+{-# SPECIALIZE reads :: ReadS Int,
+ ReadS Integer,
+ ReadS Float,
+ ReadS Double #-}
+{-# SPECIALIZE shows :: Int -> String -> String = shows_Int,
+ Integer -> String -> String = shows_Integer,
+ Float -> String -> String,
+ Double -> String -> String #-}
+{-# SPECIALIZE show :: Char -> String,
+ Int -> String = itos,
+ Integer -> String = jtos,
+ Float -> String,
+ Double -> String,
+ _PackedString -> String,
+ String -> String,
+ (Int,Int) -> String,
+ (Integer,Integer) -> String #-}
+{-# SPECIALIZE read :: String -> Int,
+ String -> Integer,
+ String -> Float,
+ String -> Double #-}
+
+--{-# GENERATE_SPECS reads a #-}
+reads :: (Text a) => ReadS a
+reads = readsPrec 0
+
+--{-# GENERATE_SPECS read a #-}
+read :: (Text a) => String -> a
+read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> x
+ [] -> error ("read{PreludeText}: no parse:"++s++"\n")
+ _ -> error ("read{PreludeText}: ambiguous parse:"++s++"\n")
+
+--{-# GENERATE_SPECS shows a{+,Int} #-}
+shows :: (Text a) => a -> ShowS
+shows = showsPrec 0
+
+shows_Int :: Int -> ShowS
+shows_Int n r = itos n ++ r -- showsPrec 0 n r
+
+shows_Integer :: Integer -> ShowS
+shows_Integer n r = jtos n ++ r -- showsPrec 0 n r
+
+--{-# GENERATE_SPECS show a{+,Int} #-}
+show :: (Text a) => a -> String
+show x = shows x ""
+
+showChar :: Char -> ShowS
+showChar = (:)
+
+showSpace__ :: ShowS -- partain: this one is non-std
+showSpace__ = {-showChar ' '-} \ xs -> ' ' : xs
+
+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 ]
+
+--------------------------------------------
+lex :: ReadS String
+lex "" = [("","")]
+lex (c:s) | isSpace c = lex (dropWhile isSpace s)
+lex ('-':'-':s) = case dropWhile (/= '\n') s of
+ '\n':t -> lex t
+ _ -> [] -- unterminated end-of-line
+ -- comment
+
+lex ('{':'-':s) = lexNest lex s
+ where
+ lexNest f ('-':'}':s) = f s
+ lexNest f ('{':'-':s) = lexNest (lexNest f) s
+ lexNest f (c:s) = lexNest f s
+ lexNest _ "" = [] -- unterminated
+ -- nested comment
+
+lex ('<':'-':s) = [("<-",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)]
+ | isSym1 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` ",;()[]{}_`"
+ isSym1 c = c `elem` "-~" || isSym c
+ isSym c = c `elem` "!@#$%&*+./<=>?\\^|:"
+ isIdChar c = isAlphanum c || c `elem` "_'"
+
+ lexFracExp ('.':d:s) | isDigit d
+ = [('.':d:ds++e,u) | (ds,t) <- [span isDigit s],
+ (e,u) <- lexExp t ]
+ lexFracExp s = [("",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)]
+
+lexDigits :: ReadS String
+lexDigits = nonnull isDigit
+
+nonnull :: (Char -> Bool) -> ReadS String
+nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
+
+lexLitChar :: ReadS String
+
+lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
+ where
+ lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
+ lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
+ lexEsc s@(d:_) | isDigit d = lexDigits s
+ lexEsc ('o':s) = [('o':os, t) | (os,t) <- nonnull isOctDigit s]
+ lexEsc ('x':s) = [('x':xs, t) | (xs,t) <- nonnull isHexDigit s]
+ lexEsc s@(c:_) | isUpper c
+ = case [(mne,s') | mne <- "DEL" : asciiTab,
+ ([],s') <- [match mne s] ]
+ of (pr:_) -> [pr]
+ [] -> []
+ lexEsc _ = []
+lexLitChar (c:s) = [([c],s)]
+lexLitChar "" = []
+
+isOctDigit c = c >= '0' && c <= '7'
+isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
+ || c >= 'a' && c <= 'f'
+
+match :: (Eq a) => [a] -> [a] -> ([a],[a])
+match (x:xs) (y:ys) | x == y = match xs ys
+match xs ys = (xs,ys)
+
+asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ')
+ ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
+ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
+ "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
+ "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
+ "SP"]
+
+readLitChar :: ReadS Char
+
+readLitChar ('\\':s) = readEsc s
+ where
+ readEsc ('a':s) = [('\a',s)]
+ readEsc ('b':s) = [('\b',s)]
+ readEsc ('f':s) = [('\f',s)]
+ readEsc ('n':s) = [('\n',s)]
+ readEsc ('r':s) = [('\r',s)]
+ readEsc ('t':s) = [('\t',s)]
+ readEsc ('v':s) = [('\v',s)]
+ readEsc ('\\':s) = [('\\',s)]
+ readEsc ('"':s) = [('"',s)]
+ readEsc ('\'':s) = [('\'',s)]
+ readEsc ('^':c:s) | c >= '@' && c <= '_'
+ = [(chr (ord c - ord '@'), s)]
+ readEsc s@(d:_) | isDigit d
+ = [(chr n, t) | (n,t) <- readDec s]
+ readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s]
+ readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s]
+ readEsc s@(c:_) | isUpper c
+ = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
+ in case [(c,s') | (c, mne) <- table,
+ ([],s') <- [match mne s]]
+ of (pr:_) -> [pr]
+ [] -> []
+ readEsc _ = []
+readLitChar (c:s) = [(c,s)]
+
+showLitChar :: Char -> ShowS
+showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c))
+showLitChar '\DEL' = showString "\\DEL"
+showLitChar '\\' = showString "\\\\"
+showLitChar c | c >= ' ' = showChar c
+showLitChar '\a' = showString "\\a"
+showLitChar '\b' = showString "\\b"
+showLitChar '\f' = showString "\\f"
+showLitChar '\n' = showString "\\n"
+showLitChar '\r' = showString "\\r"
+showLitChar '\t' = showString "\\t"
+showLitChar '\v' = showString "\\v"
+showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO")
+showLitChar c = showString ('\\' : asciiTab!!ord c)
+
+protectEsc p f = f . cont
+ where cont s@(c:_) | p c = "\\&" ++ s
+ cont s = s
+
+{-# SPECIALIZE readDec :: ReadS Int, ReadS Integer #-}
+-- specialisations of readInt should happen automagically
+{-# SPECIALIZE showInt :: Int -> ShowS, Integer -> ShowS #-}
+
+readDec, readOct, readHex :: (Integral a) => ReadS a
+readDec = readInt 10 isDigit (\d -> ord d - i_ord_0)
+readOct = readInt 8 isOctDigit (\d -> ord d - i_ord_0)
+readHex = readInt 16 isHexDigit hex
+ where hex d = ord d - (if isDigit d then i_ord_0
+ else ord (if isUpper d then 'A' else 'a')
+ - 10)
+
+readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
+readInt radix isDig digToInt s =
+ [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
+ | (ds,r) <- nonnull isDig s ]
+
+showInt :: (Integral a) => a -> ShowS
+{- USE_REPORT_PRELUDE
+showInt n r = let (n',d) = quotRem n 10
+ r' = chr (i_ord_0 + fromIntegral d) : r
+ in if n' == 0 then r' else showInt n' r'
+-}
+
+showInt n r
+ = case quotRem n 10 of { (n', d) ->
+ case (chr (i_ord_0 + fromIntegral d)) of { C# c# -> -- stricter than necessary
+ let
+ r' = C# c# : r
+ in
+ if n' == 0 then r' else showInt n' r'
+ }}
+
+-- #endif /* ! USE_REPORT_PRELUDE */
+
+{-# SPECIALIZE readSigned :: ReadS Int -> ReadS Int,
+ ReadS Integer -> ReadS Integer,
+ ReadS Double -> ReadS Double #-}
+{-# SPECIALIZE showSigned :: (Int -> ShowS) -> Int -> Int -> ShowS = showSigned_Int,
+ (Integer -> ShowS) -> Int -> Integer -> ShowS = showSigned_Integer,
+ (Double -> ShowS) -> Int -> Double -> ShowS #-}
+{-# SPECIALIZE readFloat :: ReadS Float,
+ ReadS Double #-}
+{-# SPECIALIZE showFloat :: Float -> ShowS, Double -> ShowS #-}
+
+readSigned:: (Real a) => ReadS a -> ReadS a
+readSigned readPos = readParen False read'
+ where read' r = read'' r ++
+ [(-x,t) | ("-",s) <- lex r,
+ (x,t) <- read'' s]
+ read'' r = [(n,s) | (str,s) <- lex r,
+ (n,"") <- readPos str]
+
+-- ******************************************************************
+
+showSigned:: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
+showSigned showPos p x = if x < 0 then showParen (p > 6)
+ (showChar '-' . showPos (-x))
+ else showPos x
+
+showSigned_Int :: (Int -> ShowS) -> Int -> Int -> ShowS
+showSigned_Int _ p n r
+ = -- from HBC version; support code follows
+ if n < 0 && p > 6 then '(':itos n++(')':r) else itos n ++ r
+
+showSigned_Integer :: (Integer -> ShowS) -> Int -> Integer -> ShowS
+showSigned_Integer _ p n r
+ = -- from HBC version; support code follows
+ if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r
+
+itos :: Int -> String
+itos n =
+ if n < 0 then
+ if -n < 0 then
+ -- n is minInt, a difficult number
+ itos (n `quot` 10) ++ itos' (-(n `rem` 10)) []
+ else
+ '-':itos' (-n) []
+ else
+ itos' n []
+ where
+ itos' :: Int -> String -> String
+ itos' n cs =
+ if n < 10 then
+ chr (n + i_ord_0) : cs
+ else
+ itos' (n `quot` 10) (chr (n `rem` 10+i_ord_0) : cs)
+
+i_ord_0 :: Int
+j_ord_0 :: Integer
+i_ord_0 = ord '0'
+j_ord_0 = toInteger (ord '0')
+
+jtos :: Integer -> String
+jtos n =
+ if n < 0 then
+ if -n < 0 then
+ -- n is minInt, a difficult number
+ jtos (n `quot` 10) ++ jtos' (-(n `rem` 10)) []
+ else
+ '-':jtos' (-n) []
+ else
+ jtos' n []
+ where
+ jtos' :: Integer -> String -> String
+ jtos' n cs =
+ if n < 10 then
+ chr (fromInteger (n + j_ord_0)) : cs
+ else
+ jtos' (n `quot` 10) (chr (fromInteger (n `rem` 10+j_ord_0)) : cs)
+
+-- ******************************************************************
+
+-- The functions readFloat and showFloat below use rational arithmetic
+-- to insure correct conversion between the floating-point radix and
+-- decimal. It is often possible to use a higher-precision floating-
+-- point type to obtain the same results.
+
+readFloat :: (RealFloat a) => ReadS a
+readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
+
+readRational :: ReadS Rational -- NB: doesn't handle leading "-"
+
+readRational r
+ = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
+ (k,t) <- readExp s]
+ where readFix r = [(read (ds++ds'), length ds', t)
+ | (ds,'.':s) <- lexDigits r,
+ (ds',t) <- lexDigits s ]
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = [(0,s)]
+
+ readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
+ readExp' ('+':s) = readDec s
+ readExp' s = readDec s
+
+_readRational :: String -> Rational -- we export this one (non-std)
+ -- NB: *does* handle a leading "-"
+_readRational top_s
+ = case top_s of
+ '-' : xs -> - (read_me xs)
+ xs -> read_me xs
+ where
+ read_me s
+ = case [x | (x,t) <- readRational s, ("","") <- lex t] of
+ [x] -> x
+ [] -> error ("_readRational: no parse:" ++ top_s)
+ _ -> error ("_readRational: ambiguous parse:" ++ top_s)
+
+-- The number of decimal digits m below is chosen to guarantee
+-- read (show x) == x. See
+-- Matula, D. W. A formalization of floating-point numeric base
+-- conversion. IEEE Transactions on Computers C-19, 8 (1970 August),
+-- 681-692.
+
+zeros = repeat '0'
+
+showFloat:: (RealFloat a) => a -> ShowS
+showFloat x =
+ if x == 0 then showString ("0." ++ take (m-1) zeros)
+ else if e >= m-1 || e < 0 then showSci else showFix
+ where
+ showFix = showString whole . showChar '.' . showString frac
+ where (whole,frac) = splitAt (e+1) (show sig)
+ showSci = showChar d . showChar '.' . showString frac
+ . showChar 'e' . shows e
+ where (d:frac) = show sig
+ (m, sig, e) = if b == 10 then (w, s, n+w-1)
+ else (m', sig', e' )
+ m' = _ceiling
+ ((fromIntegral w * log (fromInteger b)) / log 10 :: Double)
+ + 1
+ (sig', e') = if sig1 >= 10^m' then (_round (t/10), e1+1)
+ else if sig1 < 10^(m'-1) then (_round (t*10), e1-1)
+ else (sig1, e1 )
+ sig1 = _round t
+ t = s%1 * (b%1)^^n * 10^^(m'-e1-1)
+ e1 = _floor (logBase 10 x)
+ (s, n) = decodeFloat x
+ b = floatRadix x
+ w = floatDigits x
+
+
+-- With all the guff the Prelude defines, you'd have thought they'd
+-- include a few of the basics! ADR
+-- (I guess this could be put in a utilities module instead...)
+
+_showHex :: Int -> ShowS
+_showHex = _showRadix 16
+
+_showRadix :: Int -> Int -> ShowS
+_showRadix radix n r =
+ let (n',d) = quotRem n radix
+ r' = _showDigit d : r
+ in
+ if n' == 0 then r' else _showRadix radix n' r'
+
+_showDigit :: Int -> Char
+_showDigit d | d < 10 = chr (i_ord_0 + d)
+ | otherwise = chr (ord 'a' + (d - 10))
projects / ghc-hetmet.git / blobdiff