utils/ext-core/Lex.hs

   1 module Lex where
   2
   3 import ParseGlue
   4 import Ratio
   5 import Char
   6
   7 isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'')
   8 isKeywordChar c = isAlpha c || (c == '_')
   9
  10 lexer :: (Token -> P a) -> P a
  11 lexer cont [] = cont TKEOF []
  12 lexer cont ('\n':cs) = \line -> lexer cont cs (line+1)
  13 lexer cont ('-':'>':cs) = cont TKrarrow cs
  14 lexer cont (c:cs)
  15       | isSpace c = lexer cont cs
  16       | isLower c || (c == '_') = lexName cont TKname (c:cs)
  17       | isUpper c = lexName cont TKcname (c:cs)
  18       | isDigit c || (c == '-') = lexNum cont (c:cs)
  19 lexer cont ('%':cs) = lexKeyword cont cs
  20 lexer cont ('\'':cs) = lexChar cont cs
  21 lexer cont ('\"':cs) = lexString [] cont cs
  22 lexer cont ('#':cs) = cont TKhash cs
  23 lexer cont ('(':cs) = cont TKoparen cs
  24 lexer cont (')':cs) = cont TKcparen cs
  25 lexer cont ('{':cs) = cont TKobrace cs
  26 lexer cont ('}':cs) = cont TKcbrace cs
  27 lexer cont ('=':cs) = cont TKeq cs
  28 lexer cont (':':':':cs) = cont TKcoloncolon cs
  29 lexer cont ('*':cs) = cont TKstar cs
  30 lexer cont ('.':cs) = cont TKdot cs
  31 lexer cont ('\\':cs) = cont TKlambda cs
  32 lexer cont ('/':'\\':cs) = cont TKbiglambda cs
  33 lexer cont ('@':cs) = cont TKat cs
  34 lexer cont ('?':cs) = cont TKquestion cs
  35 lexer cont (';':cs) = cont TKsemicolon cs
  36 lexer cont (':':cs) = cont TKcolon cs
  37 lexer cont (c:cs) = failP "invalid character" [c]
  38
  39 lexChar cont ('\\':'x':h1:h0:'\'':cs)
  40         | isHexEscape [h1,h0] =  cont (TKchar (hexToChar h1 h0)) cs
  41 lexChar cont ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs))
  42 lexChar cont ('\'':cs) = failP "invalid char character" ['\'']
  43 lexChar cont ('\"':cs) = failP "invalid char character" ['\"']
  44 lexChar cont (c:'\'':cs) = cont (TKchar c) cs
  45
  46 lexString s cont ('\\':'x':h1:h0:cs)
  47         | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs
  48 lexString s cont ('\\':cs) = failP "invalid string character" ['\\']
  49 lexString s cont ('\'':cs) = failP "invalid string character" ['\'']
  50 lexString s cont ('\"':cs) = cont (TKstring s) cs
  51 lexString s cont (c:cs) = lexString (s++[c]) cont cs
  52
  53 isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
  54
  55 hexToChar h1 h0 =
  56         chr(
  57         (digitToInt h1) * 16 +
  58         (digitToInt h0))
  59
  60
  61 lexNum cont cs =
  62   case cs of
  63      ('-':cs) ->  f (-1) cs
  64      _ -> f 1 cs
  65  where f sgn cs =
  66          case span isDigit cs of
  67           (digits,'.':c:rest) | isDigit c ->
  68              cont (TKrational (numer % denom)) rest'
  69                where (fpart,rest') = span isDigit (c:rest)
  70                      denom = 10^(length fpart)
  71                      numer = sgn * ((read digits) * denom + (read fpart))
  72           (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
  73
  74 lexName cont cstr cs = cont (cstr name) rest
  75    where (name,rest) = span isNameChar cs
  76
  77 lexKeyword cont cs =
  78    case span isKeywordChar cs of
  79       ("module",rest) -> cont TKmodule rest
  80       ("data",rest)  -> cont TKdata rest
  81       ("newtype",rest) -> cont TKnewtype rest
  82       ("forall",rest) -> cont TKforall rest
  83       ("rec",rest) -> cont TKrec rest
  84       ("let",rest) -> cont TKlet rest
  85       ("in",rest) -> cont TKin rest
  86       ("case",rest) -> cont TKcase rest
  87       ("of",rest) -> cont TKof rest
  88       ("cast",rest) -> cont TKcast rest
  89       ("note",rest) -> cont TKnote rest
  90       ("external",rest) -> cont TKexternal rest
  91       ("_",rest) -> cont TKwild rest
  92       _ -> failP "invalid keyword" ('%':cs)
  93