Source file types.ml

(** A value identifier*)
type ide = string
[@@deriving show, eq, ord]

(** The type representing Abstract Syntax Tree expressions *)
type expr =
  | Unit
  | Integer of int
  | Boolean of bool
  | String of string
  | Symbol of ide
  | List of expr list
  | Cons of expr * expr
  | Dict of (expr * expr) list
  (* Numerical Operations *)
  | Plus of expr * expr
  | Sub of expr * expr
  | Mult of expr * expr
  | Eq of expr * expr
  | Gt of expr * expr
  | Lt of expr * expr
  | Ge of expr * expr
  | Le of expr * expr
  (* Boolean operations *)
  | And of expr * expr
  | Or of expr * expr
  | Not of expr
  (* Control flow and functions *)
  | IfThenElse of expr * expr * expr
  | Let of (ide * expr) list * expr
  | Letlazy of (ide * expr) list * expr
  | Letrec of ide * expr * expr
  | Letreclazy of ide * expr * expr
  | Lambda of ide list * expr
  | Apply of expr * expr list
  | Sequence of expr list
  | Pipe of expr * expr
  [@@deriving show { with_path = false }, eq, ord]

(** A type useful for evaluating files, stating if a command is
an expression or simply a "global" declaration (appended to environment) *)
type command =
  | Expr of expr
  | Def of (ide * expr) list
  | Defrec of (ide * expr) list
  [@@deriving show { with_path = false }, eq, ord]

(** A purely functional environment type, parametrized *)
type 'a env_t = (string * 'a) list [@@deriving show { with_path = false }, eq, ord]

(** A type that represents an evaluated (reduced) value *)
type evt =
  | EvtUnit
  | EvtInt of int         [@compare compare]
  | EvtBool of bool       [@equal (=)] [@compare compare]
  | EvtString of string   [@equal (=)] [@compare compare]
  | EvtList of evt list   [@equal (=)]
  | EvtDict of (evt * evt) list [@equal (=)]
  | Closure of ide list * expr * (type_wrapper env_t) [@equal (=)]
  (** RecClosure keeps the function name in the constructor for recursion *)
  | RecClosure of ide * ide list * expr * (type_wrapper env_t) [@equal (=)]
  (** Abstraction that permits treating primitives as closures *)
  | PrimitiveAbstraction of (ide * int * (type_wrapper env_t))
  [@@deriving show { with_path = false }, eq, ord]
and type_wrapper =
  | LazyExpression of expr
  | AlreadyEvaluated of evt
  [@@deriving show { with_path = false }]
(* Wrapper type that allows both AST expressions and
evaluated expression for lazy evaluation *)

(* Generate a list of parameter names to use in the primitive abstraction *)
let generate_prim_params n = 
  Array.to_list(Array.make n 'a' |> Array.mapi (fun i c -> int_of_char c + i |> char_of_int |> Printf.sprintf "%c"))


let rec show_unpacked_evt e = match e with
  | EvtInt v -> string_of_int v
  | EvtBool v -> string_of_bool v
  | EvtString v -> "\"" ^ (String.escaped v) ^ "\""
  | EvtList l -> "[" ^ (String.concat "; " (List.map show_unpacked_evt l)) ^ "]"
  | EvtDict d -> "{" ^ 
    (String.concat ", " 
      (List.map (fun (x,y) -> show_unpacked_evt x ^ ":" ^ show_unpacked_evt y) d)) 
      ^ "}"
  | Closure (params, _, _) -> "(fun " ^ (String.concat " " params) ^ " -> ... )"
  | RecClosure (name, params, _, _) -> name ^ " = (rec fun " ^ (String.concat " " params) ^ " -> ... )"
  | PrimitiveAbstraction (name, numargs, _ ) -> name ^ " = " ^ "(fun " ^ (generate_prim_params numargs |> String.concat " ") ^ " -> ... )"
  | _ -> show_evt e

(** An environment of already evaluated values  *)
type env_type = type_wrapper env_t

(** A recursive type representing a stacktrace frame *)
type stackframe =
  | StackValue of int * expr * stackframe
  | EmptyStack
  [@@deriving show { with_path = false }]

(** Push an AST expression into a stack
  @param s The stack where to push the expression
  @param e The expression to push
*)
let push_stack (s: stackframe) (e: expr) = match s with
  | StackValue(d, ee, ss) -> StackValue(d+1, e, StackValue(d, ee, ss))
  | EmptyStack -> StackValue(1, e, EmptyStack)

(** Pop an AST expression from a stack *)
let pop_stack (s: stackframe) = match s with
  | StackValue(_, _, ss) -> ss
  | EmptyStack -> failwith "Stack underflow"

exception UnboundVariable of string
exception TooManyArgs of string
exception WrongBindList
exception WrongPrimitiveArgs
exception TypeError of string
exception ListError of string
exception DictError of string
exception SyntaxError of string