ahc-old/lexer.ml

include import "./lib/parsers.ml"
open import "prelude.ml"

let lex = run_parser

let line_comment () =
  let! _ = symbol "--"
  let rec go =
    let! x = map (const "\n") eof <|> char
    if x == "\n" then
      pure ()
    else
      go
  go

let whitepiece : forall 'm. monad 'm => parser_t 'm () =
  (try (void @@ one_of " \n\v\t\r") <|> try (line_comment ()))
    <?> "white space"

let whitespace : forall 'm. monad 'm => parser_t 'm () =
  void (many whitepiece)

let lexeme p =
  let! _ = whitespace
  p

let oparen  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "(")
let cparen  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol ")")
let comma   : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol ",")
let semi    : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol ";")
let osquare : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "[")
let csquare : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "]")
let obrace  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "{")
let cbrace  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "}")
let back    : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "\\")
let arrow   : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "->")
let darrow  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "=>")
let equals  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "=")
let pipe    : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "|")
let dcolon  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "::")

let small : forall 'm. monad 'm => parser_t 'm string =
  try (satisfy (fun c -> "a" <= c && c <= "z") <|> symbol "_") <?> "small letter"

let big : forall 'm. monad 'm => parser_t 'm string =
  try (satisfy (fun c -> "A" <= c && c <= "Z")) <?> "big letter"

let iskw = function
  | "case"
  | "class"
  | "data"
  | "default"
  | "deriving"
  | "do"
  | "else"
  | "if"
  | "import"
  | "in"
  | "infix"
  | "infixl"
  | "infixr"
  | "instance"
  | "let"
  | "module"
  | "newtype"
  | "of"
  | "foreign"
  | "then"
  | "type"
  | "where"
  | "_" -> true
  | _ -> false

let isreserved = function
  | "=" | "=>" | "->" | "|" -> true
  | _ -> false

let varid : forall 'm. monad 'm => parser_t 'm string =
  flip (<?>) "variable name" # lexeme @@
    let! c = small
    let! cs =
      many_fold (^) "" (small <|> big <|> try (symbol "'"))
        <|> pure ""
    let id = c ^ cs
    if iskw id then
      unexpected id
    else
      pure id

let conid : forall 'm. monad 'm => parser_t 'm string =
  flip (<?>) "constructor name" # lexeme @@
    let! c = big
    let! cs =
      many_fold (^) "" (small <|> big <|> try (symbol "'"))
        <|> pure ""
    pure (c ^ cs)

let tyvar = varid
let tycon = conid
let tycls = conid

let keyword c = lexeme (symbol c) <?> "``" ^ c ^ "''"

let operator : forall 'm. monad 'm => parser_t 'm string =
  flip (<?>) "operator" # lexeme @@
    let! c = one_of "!#$%&*+./<=>?@\\^|-~"
    let! cs = many_fold (^) "" (one_of ":!#$%&*+./<=>?@\\^|-~")
    let op = c ^ cs
    if isreserved op then
      unexpected op
    else
      pure op

let digit : forall 'm. monad 'm => parser_t 'm string =
  satisfy (fun c -> "0" <= c && c <= "9") <?> "digit"

let hexit : forall 'm. monad 'm => parser_t 'm string =
  digit
    <|> satisfy (fun c -> "a" <= c && c <= "f")
    <|> satisfy (fun c -> "A" <= c && c <= "F")

let integer : forall 'm. monad 'm => parser_t 'm int =
  let decimal =
    let! c = digit
    let! cs = many_fold (^) "" digit
    pure (c ^ cs)
  let hexadecimal =
    let! _ = symbol "0x"
    let! c = hexit
    let! cs = many_fold (^) "" hexit
    pure ("0x" ^ c ^ cs)
  let! c = (lexeme (try hexadecimal <|> decimal)) <?> "hex or decimal integer"
  match parse_int c with
  | None -> error "no parse"
  | Some x -> pure x

let string : forall 'm. monad 'm => parser_t 'm string =
  flip (<?>) "string literal" # lexeme @@
    let parse_escape = function
      | "n" -> pure "\n"
      | "t" -> pure "\t"
      | "\"" -> pure "\""
      | a -> unexpected ("escape sequence " ^ a)
    let str_ent =
      satisfy (fun p -> p <> "\"" && p <> "\\")
        <|> ( let! _ = try (symbol "\\")
              let! e = char
              parse_escape e)
    symbol "\"" *> many_fold (^) "" str_ent <* symbol "\""