+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : Text.Read.Lex
--- Copyright : (c) The University of Glasgow 2002
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : non-portable (uses Text.ParserCombinators.ReadP)
---
--- The cut-down Haskell lexer, used by Text.Read
---
------------------------------------------------------------------------------
-
-module Text.Read.Lex
- -- lexing types
- ( Lexeme(..) -- :: *; Show, Eq
-
- -- lexer
- , lex -- :: ReadP Lexeme Skips leading spaces
- , hsLex -- :: ReadP String
- , lexChar -- :: ReadP Char Reads just one char, with H98 escapes
-
- , readIntP -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
- , readOctP -- :: Num a => ReadP a
- , readDecP -- :: Num a => ReadP a
- , readHexP -- :: Num a => ReadP a
- )
- where
-
-import Text.ParserCombinators.ReadP
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Num( Num(..), Integer )
-import GHC.Show( Show(..) )
-#ifndef __HADDOCK__
-import {-# SOURCE #-} GHC.Unicode ( isSpace, isAlpha, isAlphaNum )
-#endif
-import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral,
- toInteger, (^), (^^), infinity, notANumber )
-import GHC.List
-import GHC.Enum( maxBound )
-#else
-import Prelude hiding ( lex )
-import Data.Char( chr, ord, isSpace, isAlpha, isAlphaNum )
-import Data.Ratio( Ratio, (%) )
-#endif
-#ifdef __HUGS__
-import Hugs.Prelude( Ratio(..) )
-#endif
-import Data.Maybe
-import Control.Monad
-
--- -----------------------------------------------------------------------------
--- Lexing types
-
--- ^ Haskell lexemes.
-data Lexeme
- = Char Char -- ^ Character literal
- | String String -- ^ String literal, with escapes interpreted
- | Punc String -- ^ Punctuation or reserved symbol, e.g. @(@, @::@
- | Ident String -- ^ Haskell identifier, e.g. @foo@, @Baz@
- | Symbol String -- ^ Haskell symbol, e.g. @>>@, @:%@
- | Int Integer -- ^ Integer literal
- | Rat Rational -- ^ Floating point literal
- | EOF
- deriving (Eq, Show)
-
--- -----------------------------------------------------------------------------
--- Lexing
-
-lex :: ReadP Lexeme
-lex = skipSpaces >> lexToken
-
-hsLex :: ReadP String
--- ^ Haskell lexer: returns the lexed string, rather than the lexeme
-hsLex = do skipSpaces
- (s,_) <- gather lexToken
- return s
-
-lexToken :: ReadP Lexeme
-lexToken = lexEOF +++
- lexLitChar +++
- lexString +++
- lexPunc +++
- lexSymbol +++
- lexId +++
- lexNumber
-
-
--- ----------------------------------------------------------------------
--- End of file
-lexEOF :: ReadP Lexeme
-lexEOF = do s <- look
- guard (null s)
- return EOF
-
--- ---------------------------------------------------------------------------
--- Single character lexemes
-
-lexPunc :: ReadP Lexeme
-lexPunc =
- do c <- satisfy isPuncChar
- return (Punc [c])
- where
- isPuncChar c = c `elem` ",;()[]{}`"
-
--- ----------------------------------------------------------------------
--- Symbols
-
-lexSymbol :: ReadP Lexeme
-lexSymbol =
- do s <- munch1 isSymbolChar
- if s `elem` reserved_ops then
- return (Punc s) -- Reserved-ops count as punctuation
- else
- return (Symbol s)
- where
- isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
- reserved_ops = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]
-
--- ----------------------------------------------------------------------
--- identifiers
-
-lexId :: ReadP Lexeme
-lexId = lex_nan <++ lex_id
- where
- -- NaN and Infinity look like identifiers, so
- -- we parse them first.
- lex_nan = (string "NaN" >> return (Rat notANumber)) +++
- (string "Infinity" >> return (Rat infinity))
-
- lex_id = do c <- satisfy isIdsChar
- s <- munch isIdfChar
- return (Ident (c:s))
-
- -- Identifiers can start with a '_'
- isIdsChar c = isAlpha c || c == '_'
- isIdfChar c = isAlphaNum c || c `elem` "_'"
-
-#ifndef __GLASGOW_HASKELL__
-infinity, notANumber :: Rational
-infinity = 1 :% 0
-notANumber = 0 :% 0
-#endif
-
--- ---------------------------------------------------------------------------
--- Lexing character literals
-
-lexLitChar :: ReadP Lexeme
-lexLitChar =
- do char '\''
- (c,esc) <- lexCharE
- guard (esc || c /= '\'') -- Eliminate '' possibility
- char '\''
- return (Char c)
-
-lexChar :: ReadP Char
-lexChar = do { (c,_) <- lexCharE; return c }
-
-lexCharE :: ReadP (Char, Bool) -- "escaped or not"?
-lexCharE =
- do c <- get
- if c == '\\'
- then do c <- lexEsc; return (c, True)
- else do return (c, False)
- where
- lexEsc =
- lexEscChar
- +++ lexNumeric
- +++ lexCntrlChar
- +++ lexAscii
-
- lexEscChar =
- do c <- get
- case c of
- 'a' -> return '\a'
- 'b' -> return '\b'
- 'f' -> return '\f'
- 'n' -> return '\n'
- 'r' -> return '\r'
- 't' -> return '\t'
- 'v' -> return '\v'
- '\\' -> return '\\'
- '\"' -> return '\"'
- '\'' -> return '\''
- _ -> pfail
-
- lexNumeric =
- do base <- lexBaseChar <++ return 10
- n <- lexInteger base
- guard (n <= toInteger (ord maxBound))
- return (chr (fromInteger n))
-
- lexCntrlChar =
- do char '^'
- c <- get
- case c of
- '@' -> return '\^@'
- 'A' -> return '\^A'
- 'B' -> return '\^B'
- 'C' -> return '\^C'
- 'D' -> return '\^D'
- 'E' -> return '\^E'
- 'F' -> return '\^F'
- 'G' -> return '\^G'
- 'H' -> return '\^H'
- 'I' -> return '\^I'
- 'J' -> return '\^J'
- 'K' -> return '\^K'
- 'L' -> return '\^L'
- 'M' -> return '\^M'
- 'N' -> return '\^N'
- 'O' -> return '\^O'
- 'P' -> return '\^P'
- 'Q' -> return '\^Q'
- 'R' -> return '\^R'
- 'S' -> return '\^S'
- 'T' -> return '\^T'
- 'U' -> return '\^U'
- 'V' -> return '\^V'
- 'W' -> return '\^W'
- 'X' -> return '\^X'
- 'Y' -> return '\^Y'
- 'Z' -> return '\^Z'
- '[' -> return '\^['
- '\\' -> return '\^\'
- ']' -> return '\^]'
- '^' -> return '\^^'
- '_' -> return '\^_'
- _ -> pfail
-
- lexAscii =
- do choice
- [ (string "SOH" >> return '\SOH') <++
- (string "SO" >> return '\SO')
- -- \SO and \SOH need maximal-munch treatment
- -- See the Haskell report Sect 2.6
-
- , string "NUL" >> return '\NUL'
- , string "STX" >> return '\STX'
- , string "ETX" >> return '\ETX'
- , string "EOT" >> return '\EOT'
- , string "ENQ" >> return '\ENQ'
- , string "ACK" >> return '\ACK'
- , string "BEL" >> return '\BEL'
- , string "BS" >> return '\BS'
- , string "HT" >> return '\HT'
- , string "LF" >> return '\LF'
- , string "VT" >> return '\VT'
- , string "FF" >> return '\FF'
- , string "CR" >> return '\CR'
- , string "SI" >> return '\SI'
- , string "DLE" >> return '\DLE'
- , string "DC1" >> return '\DC1'
- , string "DC2" >> return '\DC2'
- , string "DC3" >> return '\DC3'
- , string "DC4" >> return '\DC4'
- , string "NAK" >> return '\NAK'
- , string "SYN" >> return '\SYN'
- , string "ETB" >> return '\ETB'
- , string "CAN" >> return '\CAN'
- , string "EM" >> return '\EM'
- , string "SUB" >> return '\SUB'
- , string "ESC" >> return '\ESC'
- , string "FS" >> return '\FS'
- , string "GS" >> return '\GS'
- , string "RS" >> return '\RS'
- , string "US" >> return '\US'
- , string "SP" >> return '\SP'
- , string "DEL" >> return '\DEL'
- ]
-
-
--- ---------------------------------------------------------------------------
--- string literal
-
-lexString :: ReadP Lexeme
-lexString =
- do char '"'
- body id
- where
- body f =
- do (c,esc) <- lexStrItem
- if c /= '"' || esc
- then body (f.(c:))
- else let s = f "" in
- return (String s)
-
- lexStrItem = (lexEmpty >> lexStrItem)
- +++ lexCharE
-
- lexEmpty =
- do char '\\'
- c <- get
- case c of
- '&' -> do return ()
- _ | isSpace c -> do skipSpaces; char '\\'; return ()
- _ -> do pfail
-
--- ---------------------------------------------------------------------------
--- Lexing numbers
-
-type Base = Int
-type Digits = [Int]
-
-lexNumber :: ReadP Lexeme
-lexNumber
- = lexHexOct <++ -- First try for hex or octal 0x, 0o etc
- -- If that fails, try for a decimal number
- lexDecNumber -- Start with ordinary digits
-
-lexHexOct :: ReadP Lexeme
-lexHexOct
- = do char '0'
- base <- lexBaseChar
- digits <- lexDigits base
- return (Int (val (fromIntegral base) 0 digits))
-
-lexBaseChar :: ReadP Int
--- Lex a single character indicating the base; fail if not there
-lexBaseChar = do { c <- get;
- case c of
- 'o' -> return 8
- 'O' -> return 8
- 'x' -> return 16
- 'X' -> return 16
- _ -> pfail }
-
-lexDecNumber :: ReadP Lexeme
-lexDecNumber =
- do xs <- lexDigits 10
- mFrac <- lexFrac <++ return Nothing
- mExp <- lexExp <++ return Nothing
- return (value xs mFrac mExp)
- where
- value xs mFrac mExp = valueFracExp (val 10 0 xs) mFrac mExp
-
- valueFracExp :: Integer -> Maybe Digits -> Maybe Integer
- -> Lexeme
- valueFracExp a Nothing Nothing
- = Int a -- 43
- valueFracExp a Nothing (Just exp)
- | exp >= 0 = Int (a * (10 ^ exp)) -- 43e7
- | otherwise = Rat (valExp (fromInteger a) exp) -- 43e-7
- valueFracExp a (Just fs) mExp
- = case mExp of
- Nothing -> Rat rat -- 4.3
- Just exp -> Rat (valExp rat exp) -- 4.3e-4
- where
- rat :: Rational
- rat = fromInteger a + frac 10 0 1 fs
-
- valExp :: Rational -> Integer -> Rational
- valExp rat exp = rat * (10 ^^ exp)
-
-lexFrac :: ReadP (Maybe Digits)
--- Read the fractional part; fail if it doesn't
--- start ".d" where d is a digit
-lexFrac = do char '.'
- frac <- lexDigits 10
- return (Just frac)
-
-lexExp :: ReadP (Maybe Integer)
-lexExp = do char 'e' +++ char 'E'
- exp <- signedExp +++ lexInteger 10
- return (Just exp)
- where
- signedExp
- = do c <- char '-' +++ char '+'
- n <- lexInteger 10
- return (if c == '-' then -n else n)
-
-lexDigits :: Int -> ReadP Digits
--- Lex a non-empty sequence of digits in specified base
-lexDigits base =
- do s <- look
- xs <- scan s id
- guard (not (null xs))
- return xs
- where
- scan (c:cs) f = case valDig base c of
- Just n -> do get; scan cs (f.(n:))
- Nothing -> do return (f [])
- scan [] f = do return (f [])
-
-lexInteger :: Base -> ReadP Integer
-lexInteger base =
- do xs <- lexDigits base
- return (val (fromIntegral base) 0 xs)
-
-val :: Num a => a -> a -> Digits -> a
--- val base y [d1,..,dn] = y ++ [d1,..,dn], as it were
-val base y [] = y
-val base y (x:xs) = y' `seq` val base y' xs
- where
- y' = y * base + fromIntegral x
-
-frac :: Integral a => a -> a -> a -> Digits -> Ratio a
-frac base a b [] = a % b
-frac base a b (x:xs) = a' `seq` b' `seq` frac base a' b' xs
- where
- a' = a * base + fromIntegral x
- b' = b * base
-
-valDig :: Num a => a -> Char -> Maybe Int
-valDig 8 c
- | '0' <= c && c <= '7' = Just (ord c - ord '0')
- | otherwise = Nothing
-
-valDig 10 c = valDecDig c
-
-valDig 16 c
- | '0' <= c && c <= '9' = Just (ord c - ord '0')
- | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)
- | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)
- | otherwise = Nothing
-
-valDecDig c
- | '0' <= c && c <= '9' = Just (ord c - ord '0')
- | otherwise = Nothing
-
--- ----------------------------------------------------------------------
--- other numeric lexing functions
-
-readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
-readIntP base isDigit valDigit =
- do s <- munch1 isDigit
- return (val base 0 (map valDigit s))
-
-readIntP' :: Num a => a -> ReadP a
-readIntP' base = readIntP base isDigit valDigit
- where
- isDigit c = maybe False (const True) (valDig base c)
- valDigit c = maybe 0 id (valDig base c)
-
-readOctP, readDecP, readHexP :: Num a => ReadP a
-readOctP = readIntP' 8
-readDecP = readIntP' 10
-readHexP = readIntP' 16
projects / haskell-directory.git / blobdiff