compiler/parser/LexCore.hs

   1
   2 module LexCore where
   3
   4 import ParserCoreUtils
   5 import Panic
   6 import Data.Char
   7 import Numeric
   8
   9 isNameChar :: Char -> Bool
  10 isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'')
  11                || (c == '$') || (c == '-') || (c == '.')
  12
  13 isKeywordChar :: Char -> Bool
  14 isKeywordChar c = isAlpha c || (c == '_')
  15
  16 lexer :: (Token -> P a) -> P a
  17 lexer cont []           = cont TKEOF []
  18 lexer cont ('\n':cs)    = \line -> lexer cont cs (line+1)
  19 lexer cont ('-':'>':cs) = cont TKrarrow cs
  20
  21 lexer cont (c:cs)
  22       | isSpace c               = lexer cont cs
  23       | isLower c || (c == '_') = lexName cont TKname (c:cs)
  24       | isUpper c               = lexName cont TKcname (c:cs)
  25       | isDigit c || (c == '-') = lexNum cont (c:cs)
  26
  27 lexer cont ('%':cs)     = lexKeyword cont cs
  28 lexer cont ('\'':cs)    = lexChar cont cs
  29 lexer cont ('\"':cs)    = lexString [] cont cs
  30 lexer cont ('#':cs)     = cont TKhash cs
  31 lexer cont ('(':cs)     = cont TKoparen cs
  32 lexer cont (')':cs)     = cont TKcparen cs
  33 lexer cont ('{':cs)     = cont TKobrace cs
  34 lexer cont ('}':cs)     = cont TKcbrace cs
  35 lexer cont ('=':cs)     = cont TKeq cs
  36 lexer cont (':':'=':':':cs) = cont TKcoloneqcolon cs
  37 lexer cont (':':':':cs) = cont TKcoloncolon cs
  38 lexer cont ('*':cs)     = cont TKstar cs
  39 lexer cont ('.':cs)     = cont TKdot cs
  40 lexer cont ('\\':cs)    = cont TKlambda cs
  41 lexer cont ('@':cs)     = cont TKat cs
  42 lexer cont ('?':cs)     = cont TKquestion cs
  43 lexer cont (';':cs)     = cont TKsemicolon cs
  44 -- 20060420 GHC spits out constructors with colon in them nowadays. jds
  45 -- 20061103 but it's easier to parse if we split on the colon, and treat them
  46 -- as several tokens
  47 lexer cont (':':cs)     = cont TKcolon cs
  48 -- 20060420 Likewise does it create identifiers starting with dollar. jds
  49 lexer cont ('$':cs)     = lexName cont TKname ('$':cs)
  50 lexer _    (c:_)        = failP "invalid character" [c]
  51
  52 lexChar :: (Token -> String -> Int -> ParseResult a) -> String -> Int
  53         -> ParseResult a
  54 lexChar cont ('\\':'x':h1:h0:'\'':cs)
  55     | isHexEscape [h1,h0] = cont (TKchar (hexToChar h1 h0)) cs
  56 lexChar _    ('\\':cs)    = failP "invalid char character" ('\\':(take 10 cs))
  57 lexChar _    ('\'':_)     = failP "invalid char character" ['\'']
  58 lexChar _    ('\"':_)     = failP "invalid char character" ['\"']
  59 lexChar cont (c:'\'':cs)  = cont (TKchar c) cs
  60 lexChar _    cs           = panic ("lexChar: " ++ show cs)
  61
  62 lexString :: String -> (Token -> [Char] -> Int -> ParseResult a)
  63           -> String -> Int -> ParseResult a
  64 lexString s cont ('\\':'x':h1:h0:cs)
  65     | isHexEscape [h1,h0]  = lexString (s++[hexToChar h1 h0]) cont cs
  66 lexString _ _    ('\\':_)  = failP "invalid string character" ['\\']
  67 lexString _ _    ('\'':_)  = failP "invalid string character" ['\'']
  68 lexString s cont ('\"':cs) = cont (TKstring s) cs
  69 lexString s cont (c:cs)    = lexString (s++[c]) cont cs
  70 lexString _ _    []        = panic "lexString []"
  71
  72 isHexEscape :: String -> Bool
  73 isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
  74
  75 hexToChar :: Char -> Char -> Char
  76 hexToChar h1 h0 = chr (digitToInt h1 * 16 + digitToInt h0)
  77
  78 lexNum :: (Token -> String -> a) -> String -> a
  79 lexNum cont cs =
  80   case cs of
  81      ('-':cs) -> f (-1) cs
  82      _        -> f 1 cs
  83  where f sgn cs =
  84          case span isDigit cs of
  85           (digits,'.':c:rest)
  86                 | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest'
  87                 where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest))
  88                 -- When reading a floating-point number, which is
  89                 -- a bit complicated, use the Haskell 98 library function
  90           (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
  91
  92 lexName :: (a -> String -> b) -> (String -> a) -> String -> b
  93 lexName cont cstr cs = cont (cstr name) rest
  94    where (name,rest) = span isNameChar cs
  95
  96 lexKeyword :: (Token -> [Char] -> Int -> ParseResult a) -> String -> Int
  97            -> ParseResult a
  98 lexKeyword cont cs =
  99    case span isKeywordChar cs of
 100       ("module",rest) -> cont TKmodule rest
 101       ("data",rest)  -> cont TKdata rest
 102       ("newtype",rest) -> cont TKnewtype rest
 103       ("forall",rest) -> cont TKforall rest
 104       ("rec",rest) -> cont TKrec rest
 105       ("let",rest) -> cont TKlet rest
 106       ("in",rest) -> cont TKin rest
 107       ("case",rest) -> cont TKcase rest
 108       ("of",rest) -> cont TKof rest
 109       ("cast",rest) -> cont TKcast rest
 110       ("note",rest) -> cont TKnote rest
 111       ("external",rest) -> cont TKexternal rest
 112       ("local",rest) -> cont TKlocal rest
 113       ("_",rest) -> cont TKwild rest
 114       _ -> failP "invalid keyword" ('%':cs)
 115