ghc/interpreter/prelude/PreludeText.hs

   1 #ifdef HEAD
   2 module PreludeText (
   3     ReadS, ShowS,
   4     Read(readsPrec, readList),
   5     Show(showsPrec, showList),
   6     reads, shows, show, read, lex,
   7     showChar, showString, readParen, showParen ) where
   8
   9 -- The omitted instances can be implemented in standard Haskell but
  10 -- they have been omitted for the sake of brevity
  11
  12 #if STD_PRELUDE
  13 import Char(isSpace, isAlpha, isDigit, isAlphanum, isHexDigit,
  14             showLitChar, readLitChar, lexLitChar)
  15
  16 import Numeric(showSigned, showInt, readSigned, readDec, showFloat,
  17                readFloat, lexDigits)
  18 #endif
  19
  20 import PreludeBuiltin
  21 #endif /* HEAD */
  22 #ifdef BODY
  23
  24 type  ReadS a  = String -> [(a,String)]
  25 type  ShowS    = String -> String
  26
  27 class  Read a  where
  28     readsPrec        :: Int -> ReadS a
  29     readList         :: ReadS [a]
  30
  31     readList         = readParen False (\r -> [pr | ("[",s)  <- lex r,
  32                                                     pr       <- readl s])
  33                        where readl  s = [([],t)   | ("]",t)  <- lex s] ++
  34                                         [(x:xs,u) | (x,t)    <- reads s,
  35                                                     (xs,u)   <- readl' t]
  36                              readl' s = [([],t)   | ("]",t)  <- lex s] ++
  37                                         [(x:xs,v) | (",",t)  <- lex s,
  38                                                     (x,u)    <- reads t,
  39                                                     (xs,v)   <- readl' u]
  40
  41 class  Show a  where
  42     showsPrec        :: Int -> a -> ShowS
  43     showList         :: [a] -> ShowS
  44
  45     showList []       = showString "[]"
  46     showList (x:xs)   = showChar '[' . shows x . showl xs
  47                         where showl []     = showChar ']'
  48                               showl (x:xs) = showChar ',' . shows x .
  49                                              showl xs
  50
  51 reads            :: (Read a) => ReadS a
  52 reads            =  readsPrec 0
  53
  54 shows            :: (Show a) => a -> ShowS
  55 shows            =  showsPrec 0
  56
  57 read             :: (Read a) => String -> a
  58 read s           =  case [x | (x,t) <- reads s, ("","") <- lex t] of
  59                          [x] -> x
  60                          []  -> error "PreludeText.read: no parse"
  61                          _   -> error "PreludeText.read: ambiguous parse"
  62
  63 show             :: (Show a) => a -> String
  64 show x           =  shows x ""
  65
  66 showChar         :: Char -> ShowS
  67 showChar         =  (:)
  68
  69 showString       :: String -> ShowS
  70 showString       =  (++)
  71
  72 showParen        :: Bool -> ShowS -> ShowS
  73 showParen b p    =  if b then showChar '(' . p . showChar ')' else p
  74
  75 readParen        :: Bool -> ReadS a -> ReadS a
  76 readParen b g    =  if b then mandatory else optional
  77                     where optional r  = g r ++ mandatory r
  78                           mandatory r = [(x,u) | ("(",s) <- lex r,
  79                                                  (x,t)   <- optional s,
  80                                                  (")",u) <- lex t    ]
  81
  82 -- This lexer is not completely faithful to the Haskell lexical syntax.
  83 -- Current limitations:
  84 --    Qualified names are not handled properly
  85 --    A `--' does not terminate a symbol
  86 --    Octal and hexidecimal numerics are not recognized as a single token
  87
  88 lex              :: ReadS String
  89 lex ""           =  [("","")]
  90 lex (c:s)
  91    | isSpace c   =  lex (dropWhile isSpace s)
  92 lex ('\'':s)     =  [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
  93                                          ch /= "'" ]
  94 lex ('"':s)      =  [('"':str, t)      | (str,t) <- lexString s]
  95                     where
  96                     lexString ('"':s) = [("\"",s)]
  97                     lexString s = [(ch++str, u)
  98                                          | (ch,t)  <- lexStrItem s,
  99                                            (str,u) <- lexString t  ]
 100
 101                     lexStrItem ('\\':'&':s) =  [("\\&",s)]
 102                     lexStrItem ('\\':c:s) | isSpace c
 103                                            =  [("\\&",t) |
 104                                                '\\':t <-
 105                                                    [dropWhile isSpace s]]
 106                     lexStrItem s           =  lexLitChar s
 107
 108 lex (c:s) | isSingle c = [([c],s)]
 109           | isSym c    = [(c:sym,t)       | (sym,t) <- [span isSym s]]
 110           | isAlpha c  = [(c:nam,t)       | (nam,t) <- [span isIdChar s]]
 111           | isDigit c  = [(c:ds++fe,t)    | (ds,s)  <- [span isDigit s],
 112                                             (fe,t)  <- lexFracExp s     ]
 113           | otherwise  = []    -- bad character
 114              where
 115               isSingle c =  c `elem` ",;()[]{}_`"
 116               isSym c    =  isPrint c && not (isAlphaNum c) &&
 117                             not (isSingle c) && not (c `elem` "_'")
 118                             && not (isSpace c)
 119               isIdChar c =  isAlphaNum c || c `elem` "_'"
 120
 121               lexFracExp ('.':c:cs) | isDigit c
 122                             = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),
 123                                                (e,u)  <- lexExp t]
 124               lexFracExp s          = [("",s)]
 125
 126               lexExp (e:s) | e `elem` "eE"
 127                        = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
 128                                                  (ds,u) <- lexDigits t] ++
 129                          [(e:ds,t)   | (ds,t) <- lexDigits s]
 130               lexExp s = [("",s)]
 131
 132 #if 1
 133 instance  Show Int  where
 134     showsPrec p n
 135       | n == minBound = showSigned showInt p (toInteger n)
 136       | otherwise     = showSigned showInt p n
 137 #else /* This version only goes slightly faster */
 138 instance  Show Int  where
 139     showsPrec p n
 140       | n == minBound = showSigned showInt p (toInteger n)
 141       | otherwise     = showSigned primShowInt p n
 142
 143 primShowInt n r = unsafeUnpackCString (primShowInt' n) ++ r
 144
 145 foreign import stdcall "" "prim_showInt" primShowInt' :: Int -> Addr
 146 #endif
 147
 148 instance  Read Int  where
 149     readsPrec p         = readSigned readDec
 150
 151 #ifdef PROVIDE_INTEGER
 152 instance  Show Integer  where
 153     showsPrec           = showSigned showInt
 154
 155 instance  Read Integer  where
 156     readsPrec p         = readSigned readDec
 157 #endif
 158
 159 #ifdef PROVIDE_INT64
 160 instance  Show Int64  where
 161     showsPrec           = showSigned showInt
 162
 163 instance  Read Int64  where
 164     readsPrec p         = readSigned readDec
 165 #endif
 166
 167 instance  Show Float  where
 168     showsPrec p         = showFloat
 169
 170 instance  Read Float  where
 171     readsPrec p         = readSigned readFloat
 172
 173 instance  Show Double  where
 174     showsPrec p         = showFloat
 175
 176 instance  Read Double  where
 177     readsPrec p         = readSigned readFloat
 178
 179 instance  Show ()  where
 180     showsPrec p () = showString "()"
 181
 182 instance Read () where
 183     readsPrec p    = readParen False
 184                             (\r -> [((),t) | ("(",s) <- lex r,
 185                                              (")",t) <- lex s ] )
 186 instance  Show Char  where
 187     showsPrec p '\'' = showString "'\\''"
 188     showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''
 189
 190     showList cs = showChar '"' . showl cs
 191                  where showl ""       = showChar '"'
 192                        showl ('"':cs) = showString "\\\"" . showl cs
 193                        showl (c:cs)   = showLitChar c . showl cs
 194
 195 instance  Read Char  where
 196     readsPrec p      = readParen False
 197                             (\r -> [(c,t) | ('\'':s,t)<- lex r,
 198                                             (c,"\'")  <- readLitChar s])
 199
 200     readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
 201                                                (l,_)      <- readl s ])
 202         where readl ('"':s)      = [("",s)]
 203               readl ('\\':'&':s) = readl s
 204               readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,
 205                                                (cs,u) <- readl t       ]
 206
 207 instance  (Show a) => Show [a]  where
 208     showsPrec p      = showList
 209
 210 instance  (Read a) => Read [a]  where
 211     readsPrec p      = readList
 212
 213 -- Tuples
 214
 215 #if STD_PRELUDE
 216 instance  (Show a, Show b) => Show (a,b)  where
 217     showsPrec p (x,y) = showChar '(' . shows x . showString ", " .
 218                                        shows y . showChar ')'
 219
 220 instance  (Read a, Read b) => Read (a,b)  where
 221     readsPrec p       = readParen False
 222                             (\r -> [((x,y), w) | ("(",s) <- lex r,
 223                                                  (x,t)   <- reads s,
 224                                                  (",",u) <- lex t,
 225                                                  (y,v)   <- reads u,
 226                                                  (")",w) <- lex v ] )
 227
 228 -- Other tuples have similar Read and Show instances
 229 #endif
 230
 231 -- Functions
 232
 233 instance  Show (a->b)  where
 234     showsPrec p f    =  showString "<<function>>"
 235
 236
 237 instance  Show (IO a)  where
 238     showsPrec p f    =  showString "<<IO action>>"
 239
 240 #endif /* BODY */