planck / ocaml / token.ml

open Spotlib.Spot
open Planck
open Sexplib.Conv

type t =
  | AMPERAMPER
  | AMPERSAND
  | AND
  | AS
  | ASSERT
  | BACKQUOTE
  | BANG
  | BAR
  | BARBAR
  | BARRBRACKET
  | BEGIN
  | CHAR of (char)
  | CLASS
  | COLON
  | COLONCOLON
  | COLONEQUAL
  | COLONGREATER
  | COMMA
  | CONSTRAINT
  | DO
  | DONE
  | DOT
  | DOTDOT
  | DOWNTO
  | ELSE
  | END
  | EOF
  | EQUAL
  | EXCEPTION
  | EXTERNAL
  | FALSE
  | FLOAT of (string)
  | FOR
  | FUN
  | FUNCTION
  | FUNCTOR
  | GREATER
  | GREATERRBRACE
  | GREATERRBRACKET
  | IF
  | IN
  | INCLUDE
  | INFIXOP0 of (string)
  | INFIXOP1 of (string)
  | INFIXOP2 of (string)
  | INFIXOP3 of (string)
  | INFIXOP4 of (string)
  | INHERIT
  | INITIALIZER
  | INT of (int)
  | INT32 of (int32)
  | INT64 of (int64)
  | LABEL of (string)
  | LAZY
  | LBRACE
  | LBRACELESS
  | LBRACKET
  | LBRACKETBAR
  | LBRACKETLESS
  | LBRACKETGREATER
  | LESS
  | LESSMINUS
  | LET
  | LIDENT of (string)
  | LPAREN
  | MATCH
  | METHOD
  | MINUS
  | MINUSDOT
  | MINUSGREATER
  | MODULE
  | MUTABLE
  | NATIVEINT of (nativeint)
  | NEW
  | OBJECT
  | OF
  | OPEN
  | OPTLABEL of (string)
  | OR
  | PLUS
  | PLUSDOT
  | PREFIXOP of (string)
  | PRIVATE
  | QUESTION
  | QUESTIONQUESTION
  | QUOTE
  | RBRACE
  | RBRACKET
  | REC
  | RPAREN
  | SEMI
  | SEMISEMI
  | SHARP
  | SIG
  | STAR
  | STRING of (string)
  | STRUCT
  | THEN
  | TILDE
  | TO
  | TRUE
  | TRY
  | TYPE
  | UIDENT of (string)
  | UNDERSCORE
  | VAL
  | VIRTUAL
  | WHEN
  | WHILE
  | WITH
with sexp

type _token = t

let equal a b = 
  let a_int = Obj.is_int (Obj.repr a) in
  let b_int = Obj.is_int (Obj.repr b) in
  if a_int && b_int then (Obj.magic a : int) = (Obj.magic b : int)
  else if not a_int && not b_int then
    match a, b with
    | CHAR a, CHAR b -> a = b
    | FLOAT a, FLOAT b -> a = b
    | INFIXOP0 a, INFIXOP0 b -> a = b
    | INFIXOP1 a, INFIXOP1 b -> a = b
    | INFIXOP2 a, INFIXOP2 b -> a = b
    | INFIXOP3 a, INFIXOP3 b -> a = b
    | INFIXOP4 a, INFIXOP4 b -> a = b
    | INT a, INT b -> a = b
    | INT32 a, INT32 b -> a = b
    | INT64 a, INT64 b -> a = b
    | LABEL a, LABEL b -> a = b
    | LIDENT a, LIDENT b -> a = b
    | NATIVEINT a, NATIVEINT b -> a = b
    | OPTLABEL a, OPTLABEL b -> a = b
    | PREFIXOP a, PREFIXOP b -> a = b
    | STRING a, STRING b -> a = b
    | UIDENT a, UIDENT b -> a = b
    | _ -> false
  else false

let show t = Sexplib.Sexp.to_string_hum (sexp_of_t t)

module Stream = struct

  module Base = struct
    module Elem = struct
      type t = _token
      let show = show
      let format ppf = Format.pp_print_string ppf ** show 
      include Mtypes.Make_comparable(struct
        type t = _token
        let compare = compare
      end)
    end
    module Pos = Position.Region
    module Attr = struct
      type t = Pos.t option (* last consumed token position *) * Pos.t * Smemo.memo
      let position (_,pos,_) = pos
      let last_position (last_pos,_,_) = last_pos 
      let default = None, Pos.none, Smemo.create ()
      let memo (_,_,memo) = memo
      let buf (_,buf(*,_*)) = buf
    end
  end

  module Str = Pstream.Make(Base)

  include Str

  include Smemo.Extend(struct
    include Str
    let memo = Base.Attr.memo
  end)

  (* CR jfuruse: generalize it and port back to Planck.Core *)
  let create (m : ('a option * Position.Region.t) Input.Parser.t) = fun st ->
    let rec f last_pos st = lazy begin
      match Input.Parser.run m st with
      | `Ok ((None, pos), _st') -> null_desc (last_pos, pos, Smemo.create ()) (* EOS case *)
      | `Ok ((Some v, pos), st') -> cons_desc v (last_pos, pos, Smemo.create ()) (f (Some pos) st')
      | `Error (pos, s) -> raise (Input.Parser.Critical_error (pos, s))
    end
    in
    f None st
  ;;

  let last_position st : Position.Region.t option = Base.Attr.last_position (attr st)
end

module Parser = struct
  include Pbase.Make(Stream)

  open Position

  let last_position : Region.t t = perform
    st <-- stream;
    return & match Stream.last_position st with
             | Some reg -> reg
             | None -> Region.none

  (** Efficient version of with_region *)
  let with_region (t : 'a t) : ('a * Region.t) t = perform
    last_bot_pos <-- last_position;
    last_top_pos <-- position;
    res <-- t;
    top_pos <-- position;
    bot_pos <-- last_position;
    let pos = 
      if last_top_pos = top_pos then 
        (* No advancement. OCaml's behaviour is: return the end of the last consumed position *)
        { last_bot_pos with Region.start = last_bot_pos.Region.end_ }
      else
        { Region.start = last_top_pos.Region.start; 
          end_ = bot_pos.Region.end_ }
    in
    (* \ assert (Region.is_valid pos); *)
    return (res, pos)
end
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.