content: module Lex where
  import Data.List as List
  import Data.Char as Char
  import Tokens
  import Text.Parsec
  import Text.Parsec.Prim
  import Text.Parsec.Combinator
  import Text.Parsec.Char
  
  single_char_symbol = oneOf "()[]{},;"
  
  -- TODO: symbol_char seems too permissive
  symbol_char = oneOf "!%&$#+-/:<=>?@\\~`^|*"
  
  string_char =
    (try (string "\\\\") >> return '\\')
    <|>
    (try (string "\\\"") >> return '"')
    <|>
    (try (string "\\n") >> return '\n')
    <|>
    (try (string "\\t") >> return '\t')
    <|>
    noneOf ['\\', '\n', '"', '\t']
  
  skip_comment d =
    (try (string "(*") >> skip_comment (d + 1))
    <|>
    (try (string "*)") >> (if d == 0 then return () else skip_comment (d - 1)))
    <|>
    (anyChar >> skip_comment d)
  
  alpha_ident =
    do c <- letter;
       s <- many (alphaNum <|> oneOf "'_");
       return (c:s)
  
  ident = alpha_ident <|> many1 symbol_char
  
  next_token =
    (space >> next_token) 
    <|>
    do digits <- many1 digit;
       return (IntT (read digits))
    <|>
    try (do (char '~');
            digits <- many1 digit;
            return (IntT (0-read digits)))
    <|>
    do id1 <- alpha_ident;
       option (get_token_alpha id1) (char '.' >> do id2 <- ident; return (LongidT id1 id2))
    <|>
    do char '\'';
       tvar <- many (alphaNum <|> oneOf "'_");
       return (TyvarT ('\'':tvar))
    <|>
    fmap StringT (between (char '"') (char '"') (many string_char))
    <|>
    (try (string "*)") >> fail "stray \"*)\"")
    <|>
    (try (string "(*") >> skip_comment 0 >> next_token)
    <|>
    fmap (\c -> get_token_sym [c]) single_char_symbol
    <|>
    do id1 <- many1 symbol_char ;
       option (get_token_sym id1) (char '.' >> do id2 <- ident; return (LongidT id1 id2))
    <|>
    do char '_' ;
       return UnderbarT
    <|>
    do eof;
       return NoneT
    <?>
    "space, digit, letter, number, symbol, or ;"
  
  get_token_sym s =
    if s == "#" then HashT else
    if s == "(" then LparT else
    if s == ")" then RparT else
    if s == "*" then StarT else
    if s == "," then CommaT else
    if s == "->" then ArrowT else
    if s == "..." then DotsT else -- TODO, can't ever get this because . is not a symbol_char
    if s == ":" then ColonT else
    if s == ":>" then SealT else
    if s == ";" then SemicolonT else
    if s == "=" then EqualsT else
    if s == "=>" then DarrowT else
    if s == "[" then LbrackT else
    if s == "]" then RbrackT else
    if s == "_" then UnderbarT else
    if s == "{" then LbraceT else
    if s == "}" then RbraceT else
    if s == "|" then BarT else
    SymbolT s
  
  get_token_alpha s =
    if s == "and" then AndT else
    if s == "andalso" then AndalsoT else
    if s == "as" then AsT else
    if s == "case" then CaseT else
    if s == "datatype" then DatatypeT else
    if s == "else" then ElseT else
    if s == "end" then EndT else
    if s == "eqtype" then EqtypeT else
    if s == "exception" then ExceptionT else
    if s == "fn" then FnT else
    if s == "fun" then FunT else
    if s == "handle" then HandleT else
    if s == "if" then IfT else
    if s == "in" then InT else
    if s == "include" then IncludeT else
    if s == "let" then LetT else
    if s == "local" then LocalT else
    if s == "of" then OfT else
    if s == "op" then OpT else
    if s == "open" then OpenT else
    if s == "orelse" then OrelseT else
    if s == "raise" then RaiseT else
    if s == "rec" then RecT else
    if s == "sharing" then SharingT else
    if s == "sig" then SigT else
    if s == "signature" then SignatureT else
    if s == "struct" then StructT else
    if s == "structure" then StructureT else
    if s == "then" then ThenT else
    if s == "type" then TypeT else
    if s == "val" then ValT else
    if s == "where" then WhereT else
    if s == "with" then WithT else
    if s == "withtype" then WithtypeT else
    AlphaT s
  
  data Semihider = SH_END | SH_PAR
  
  lex_aux acc stk =
    do pos <- getPosition;
       token <- next_token;
       if token == SemicolonT && List.null stk then 
          return (List.reverse ((token,pos):acc))
       else if token == NoneT then
          return (List.reverse acc)
       else
         let new_acc = (token,pos):acc in
           if token == LetT then lex_aux new_acc (SH_END:stk)
           else if token == StructT then lex_aux new_acc (SH_END:stk)
           else if token == SigT then lex_aux new_acc (SH_END:stk)
           else if token == LparT then lex_aux new_acc (SH_PAR:stk)
           else if token == EndT then
             case stk of
               SH_END : stk' -> lex_aux new_acc stk'
               _ -> fail "stray \"end\"" 
           else if token == RparT then
             case stk of
               SH_PAR : stk' -> lex_aux new_acc stk'
               _ -> fail "stray \")\""
           else lex_aux new_acc stk
  
  lex_until_toplevel_semicolon :: String -> SourcePos -> Either ParseError ([(Token, SourcePos)], String, SourcePos)
  lex_until_toplevel_semicolon input pos = 
    parse (do setPosition pos;
              toks <- lex_aux [] [];
              pos <- getPosition;
              rest <- getInput;
              return (toks, rest, pos))
           (sourceName pos)
           input
  