Source file ocaml.ml

(*********************************************************************************)
(*                Higlo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2014-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU Lesser General Public           *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*                                                                               *)
(*********************************************************************************)

open Lang

let lexeme lb = Sedlexing.(Utf8.lexeme lb, lexeme_length lb);;
let sedlexeme = Sedlexing.Utf8.lexeme;;

let digit = [%sedlex.regexp? '0'..'9'|'_']
let hex = [%sedlex.regexp? digit | 'A'..'F' | 'a'..'f']
let integer = [%sedlex.regexp? Plus(digit)]
let decimal = [%sedlex.regexp? Star('0'..'9'), '.', Plus('0'..'9')]
let exponent = [%sedlex.regexp? ('e'|'E'), Opt('+'|'-'), Plus('0'..'9')]
let double = [%sedlex.regexp? (Plus('0'..'9'), '.', Star('0'..'9'), exponent) | ('.', Plus('0'..'9'), exponent) | (Plus('0'..'9'), exponent)]
let integer_positive = [%sedlex.regexp? '+',integer]
let decimal_positive = [%sedlex.regexp? '+',decimal]
let double_positive = [%sedlex.regexp? '+',double]
let integer_negative = [%sedlex.regexp? '-',integer]
let decimal_negative = [%sedlex.regexp? '-',decimal]
let double_negative = [%sedlex.regexp? '-',double]

let binary = [%sedlex.regexp? "0b",Plus('0'|'1')]
let octal = [%sedlex.regexp? "0o",Plus('0'..'7')]
let hexa = [%sedlex.regexp? "0x",Plus(hex)]

let numeric = [%sedlex.regexp? integer_positive | decimal_positive | double_positive | integer_negative | decimal_negative | double_negative | integer | decimal | double | binary | octal | hexa]

let boolean = [%sedlex.regexp? "true" | "false"]
let echar = [%sedlex.regexp? 't' | 'b' | 'n' | 'r' | 'f' | '\\' | '"' | '\'']

let escaped_char = [%sedlex.regexp? '\\', echar]
let string = [%sedlex.regexp? '"', Star(Compl(0x22)| escaped_char),'"']
let char = [%sedlex.regexp? "'", (Compl(0x27)| escaped_char), "'"]

let space = [%sedlex.regexp? Plus(' ' | '\n' | '\t' | '\r') ]

let capchar = [%sedlex.regexp? 'A'..'Z']
let lowchar = [%sedlex.regexp? 'a'..'z']
let idchar = [%sedlex.regexp? lowchar | capchar | '_' | digit]

let modname = [%sedlex.regexp? capchar, Star(idchar)]

let start_comment = [%sedlex.regexp? "(*"]
let end_comment = [%sedlex.regexp? "*)"]

(* 28 is left parenthesis, 29 is right parenthesis;
   do not eat char and string delimiter, as they
   are handled in lexer, or else the the comment char would
   eat the string or char start chararacter.
 *)
let comment_char = [%sedlex.regexp? (Compl(0x28|0x29|'"'|'\''|'*') | (0x28,Compl('\''|'"'|'*')) | ('*',Compl('\''|'"'|0x29))) ]

let id = [%sedlex.regexp? ('_'|lowchar), Star(idchar)]
let cap_id = [%sedlex.regexp? capchar, id]
let attr_id = [%sedlex.regexp? (id | cap_id), Star('.', Plus(id | cap_id))]

let percent_id = [%sedlex.regexp? '%', attr_id]

let decl_kw = [%sedlex.regexp? "and" |"class" |"constraint" |"exception" |"external" |"let" |"fun" |"function" |"functor" |"in" |"include" |"inherit" |"initializer" |"method" |"module" |"mutable" | "nonrec" | "of" |"open" |"private" |"rec" |"type" |"val" |"virtual"]

(* split keyword list because of sedlex bug:
  https://github.com/ocaml-community/sedlex/issues/97 *)
let expr_kw = [%sedlex.regexp? "asr" |"do" |"else" |"for" |"if" |"while" |"as" |"assert" |"begin" |"do" |"done" |"downto"]
let expr_kw2 = [%sedlex.regexp? "else" |"end" |"for" |"if" |"land" |"lazy" |"lor" |"lsl" |"lsr" |"lxor" |"match" |"mod"]
let expr_kw3 = [%sedlex.regexp? "new" |"object" |"or" | "ref" |"sig" |"struct" |"then" |"to"|"try" |"when" |"while" |"with" |"#" ]

let type_kw = [%sedlex.regexp? "bool" | "int" |"string" |"list" |"array" |"float" |"char" |"unit"]

let lwt_kw = [%sedlex.regexp? "lwt" | "raise_lwt" | ">>=" | ">>" | "=<<" | "for_lwt" | "assert_lwt" | "match_lwt" | "while_lwt"]
let label = [%sedlex.regexp? '~', id]

let directive = [%sedlex.regexp? Opt('\n',Opt('\r')), '#', lowchar, Star(idchar)]

let rec main lexbuf =
  match%sedlex lexbuf with
| eof -> []
| space -> [Text (lexeme lexbuf)]
| numeric -> [Numeric (lexeme lexbuf)]
| boolean -> [Constant (lexeme lexbuf)]
| directive ->
    begin
      let (s,len) = lexeme lexbuf in
      match String.get s 0 with
        '\n' -> [Directive (s, len)]
      | _ ->
         match Sedlexing.lexeme_start lexbuf with
         | 0 -> [Directive (s, len)]
         | _ ->
           [Keyword (1, ("#", 1)) ; Id (String.sub s 1 (String.length s - 1), len - 1)]
    end
| decl_kw -> [Keyword (0, lexeme lexbuf)]
| expr_kw -> [Keyword (1, lexeme lexbuf)]
| expr_kw2 -> [Keyword (1, lexeme lexbuf)]
| expr_kw3 -> [Keyword (1, lexeme lexbuf)]
| modname -> [Keyword (2, lexeme lexbuf)]
| type_kw -> [Keyword (3, lexeme lexbuf)]
| percent_id ->
    begin
      let lexeme = lexeme lexbuf in
      [ Keyword (5, lexeme) ]
    end
| lwt_kw -> [Keyword (10, lexeme lexbuf)]
| label -> [Keyword (4, lexeme lexbuf)]
| id -> [Id (lexeme lexbuf)]
| string -> [String (lexeme lexbuf)]
| char -> [String (lexeme lexbuf)]
| start_comment ->
      let b = Buffer.create 256 in
      let (s,len) = lexeme lexbuf in
      Buffer.add_string b s ;
      let len = bcomment (b,len) 1 lexbuf in
      [Bcomment (Buffer.contents b, len)]
| any -> [Text (lexeme lexbuf)]
| _ -> failwith "Invalid state"

and bcomment (b,len) level lexbuf =
  match%sedlex lexbuf with
| eof -> len
| start_comment ->
      let (s,n) = lexeme lexbuf in
      Buffer.add_string b s;
      bcomment (b,len+n) (level+1) lexbuf
| Opt('*'),end_comment ->
      let (s,n) = lexeme lexbuf in
      Buffer.add_string b s ;
      let level = level - 1 in
      if level <= 0 then
        (len+n)
      else
        bcomment (b,len+n) level lexbuf
| string
| char
| comment_char ->
      let (s,n) = lexeme lexbuf in
      Buffer.add_string b s;
      bcomment (b,len+n) level lexbuf
| any ->
      let (s,n) = lexeme lexbuf in
      Buffer.add_string b s;
      bcomment (b,len+n) level lexbuf
| _ -> len


let () = Lang.register_lang "ocaml" main;;