path: root/ghc/lib/prelude/Text.hs

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