gdritter repos shift-resolve / master parse.ml
master

Tree @master (Download .tar.gz)

parse.ml @master — raw · history · blame 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
(* A given rule in a grammar is a list of either terminals or
 * nonterminals... *)
type element =
  | Nonterm of string
  | Term    of char
type rule = element list

(* and a grammar itself is a set---er, list, for us---that maps
 * nonterminal names to one or more rules. *)
type grammar = (string * rule) list

(* We'll work with the same grammar that's described in the paper:
 *   S' ::= S
 *   S  ::= ACa | BDd
 *   A  ::= AD | a
 *   B  ::= BC | b
 *   C  ::= c
 *   D  ::= d
 *)

let test_grammar =
  [ "S'", [ Nonterm "S" ]
  ; "S",  [ Nonterm "A"; Nonterm "C"; Term 'a' ]
  ; "S",  [ Nonterm "B"; Nonterm "D"; Term 'd' ]
  ; "A",  [ Nonterm "A"; Nonterm "D" ]
  ; "A",  [ Term 'a' ]
  ; "B",  [ Nonterm "B"; Nonterm "C" ]
  ; "B",  [ Term 'b' ]
  ; "C",  [ Term 'c' ]
  ; "D",  [ Term 'd' ]
  ]

(* Every action in our generated table is going to be either a
 * Shift, which will give us the new state as well, or a Resolve,
 * which will produce a non-terminal and optionally pop some
 * things from the stack.
 *)
type state = int
type action =
  | Shift of state
  | Resolve of element * int

(* This is not the best data structure to put a table in. *)
type table = (int * element) -> action option
let empty : table = fun _ -> None
let lookup (t : table) (k : int * element) = t k
let insert (k : int * element) (v : action) (t : table) =
  fun k' -> if k = k' then Some v else lookup t k'

let sample : table = (empty
  |> insert (0, Term 'a')     (Shift 4)
  |> insert (0, Term 'b')     (Shift 5)
  |> insert (0, Nonterm "S")  (Shift 1)
  |> insert (0, Nonterm "A")  (Shift 2)
  |> insert (0, Nonterm "B")  (Shift 3)
  |> insert (1, Term '$')     (Resolve (Nonterm "S'", 0))
  |> insert (2, Term 'c')     (Shift 8)
  |> insert (2, Nonterm "C")  (Shift 6)
  |> insert (2, Nonterm "D")  (Shift 7)
  |> insert (3, Term 'c')     (Shift 8)
  |> insert (3, Nonterm "C")  (Shift 9)
  |> insert (3, Nonterm "D")  (Shift 10)
  |> insert (4, Term 'c')     (Shift 8)
  |> insert (4, Nonterm "C")  (Resolve (Nonterm "A", 0))
  |> insert (4, Nonterm "D")  (Resolve (Nonterm "A", 0))
  |> insert (5, Term 'c')     (Shift 8)
  |> insert (5, Nonterm "C")  (Resolve (Nonterm "B", 0))
  |> insert (5, Nonterm "D")  (Resolve (Nonterm "B", 0))
  |> insert (6, Term 'a')     (Shift 11)
  |> insert (6, Term 'c')     (Shift 8)
  |> insert (7, Term 'c')     (Shift 8)
  |> insert (7, Nonterm "C")  (Resolve (Nonterm "A", 0))
  |> insert (7, Nonterm "D")  (Resolve (Nonterm "A", 0))
  |> insert (8, Term 'a')     (Resolve (Nonterm "C", 0))
  |> insert (8, Term 'b')     (Resolve (Nonterm "D", 0))
  |> insert (8, Term 'c')     (Shift 8)
  |> insert (8, Nonterm "C")  (Shift 12)
  |> insert (8, Nonterm "D")  (Shift 13)
  |> insert (9, Term 'c')     (Shift 8)
  |> insert (9, Nonterm "C")  (Resolve (Nonterm "B", 0))
  |> insert (9, Nonterm "D")  (Resolve (Nonterm "B", 0))
  |> insert (10, Term 'b')    (Shift 14)
  |> insert (10, Term 'c')    (Shift 8)
  |> insert (11, Term '$')    (Resolve (Nonterm "S", 0))
  |> insert (12, Term 'a')    (Resolve (Nonterm "D", 1))
  |> insert (12, Term 'c')    (Shift 8)
  |> insert (12, Nonterm "C") (Resolve (Nonterm "C", 1))
  |> insert (12, Nonterm "D") (Resolve (Nonterm "C", 1))
  |> insert (13, Term 'b')    (Resolve (Nonterm "C", 1))
  |> insert (13, Term 'c')    (Shift 8)
  |> insert (13, Nonterm "C") (Resolve (Nonterm "D", 1))
  |> insert (13, Nonterm "D") (Resolve (Nonterm "D", 1))
  |> insert (14, Term '$')    (Resolve (Nonterm "S", 0)))

let rec take n ls =
  if n = 0 then [] else (List.hd ls :: take (n-1) (List.tl ls))

let rec drop n ls =
  if n = 0 then ls else drop (n-1) (List.tl ls)

let runParser (t : table) (inp : char list) =
  let rec helper (inS : element list) (stS : state list) (st : state) =
    match inS with
      | [] -> stS
      | (i::is) -> match lookup t (st, i) with
                     | None -> raise (Failure "Unable to find rule")
                     | Some (Shift n) ->
                         helper is (n::stS) n
                     | Some (Resolve (s, i)) -> raise (Failure "..")
  in helper (List.map (fun x -> Term x) inp) [] 0