pervasives.eff

(* This is the equivalent of Haskell prelude or Ocaml pervasives,
   with some list handling functions thrown in. *)

let continue x = x

(* Top level effects. *)
effect Print : string -> unit

effect Read : unit -> string

effect Raise : string -> empty

effect Random_int : int -> int

effect Random_float: float -> float

effect System_time : unit -> float

(* Integers and Floats *)
external ( = ) : 'a -> 'a -> bool = "="

external ( < ) : 'a -> 'a -> bool = "<"

let absurd void = match void with;;

effect DivisionByZero : unit -> empty

effect InvalidArgument : string -> empty

effect Failure : string -> empty

let failwith msg = absurd (perform (Failure msg)) ;;

effect AssertionFault : unit -> empty

let assert b = if b then () else absurd (perform (AssertionFault ())) ;;

external ( ~- ) : int -> int = "~-"

external ( + ) : int -> int -> int = "+"

external ( * ) : int -> int -> int = "*"

external ( - ) : int -> int -> int = "-"

external ( mod ) : int -> int -> int = "mod"
let (mod) m n = match n with
  | 0 -> absurd (perform (DivisionByZero ()))
  | n -> m mod n

external ( ~-. ) : float -> float = "~-."

external ( +. ) : float -> float -> float = "+."

external ( *. ) : float -> float -> float = "*."

external ( -. ) : float -> float -> float = "-."

external ( /. ) : float -> float -> float = "/."
external ( / ) : int -> int -> int = "/"

external ( ** ) : int -> int -> int = "**"

let ( / ) m n = match n with
  | 0 -> absurd (perform (DivisionByZero ()))
  | n -> (/) m n

(* Strings *)
external float_of_int : int -> float = "float_of_int"

external ( ^ ) : string -> string -> string = "^"

external string_length : string -> int = "string_length"

external to_string : 'a -> string  = "to_string"

external int_of_string : string -> int = "int_of_string"

(* Booleans *)
let not x = if x then false else true

let (>) x y = y < x

let (<=) x y =
  let lt = x < y in
  let eq = x = y in
  lt || eq

let (>=) x y = (y <= x)

let (<>) x y = not (x = y)

let (!=) x y = not (x = y)

(* Lists *)
type 'a option = None | Some of 'a

let rec assoc x = function
  | [] -> None
  | (y,z)::lst -> if x = y then Some z else assoc x lst

let rec range m n =
  if m > n
  then []
  else
    let r = range in
    m :: r (m + 1) n

let reverse lst =
  let rec reverse_acc acc = function
    | [] -> acc
    | x :: xs -> reverse_acc (x :: acc) xs
  in
  reverse_acc [] lst

let rec map f = function
  | [] -> []
  | x :: xs ->
    let y = f x in
    let ys = map f xs in
      y :: ys;;

let hd = function
  | [] ->  absurd (perform (InvalidArgument "head: empty list"))
  | x :: _ -> x

let tl = function
  | [] ->  absurd (perform (InvalidArgument "tail: empty list"))
  | x :: xs -> xs

let take f k =
  let r = range 0 k in map f r

let rec fold_left f a = function
  | [] -> a
  | y :: ys ->
    let a = f a y in
    fold_left f a ys

let rec fold_right f xs a =
  match xs with
    | [] -> a
    | x :: xs ->
      let a = fold_right f xs a in
      f x a

let rec iter f = function
  | [] -> ()
  | x :: xs -> f x; iter f xs

let rec forall p = function
  | [] -> true
  | x :: xs -> if p x then forall p xs else false

let rec exists p = function
  | [] -> false
  | x :: xs -> if p x then true else exists p xs

let mem x = exists (fun x' -> x = x')

let rec filter p = function
  | [] -> []
  | x :: xs ->
    if p x then (x :: filter p xs) else filter p xs

let complement xs ys = filter (fun x -> not (mem x ys)) xs

let intersection xs ys = filter (fun x -> mem x ys) xs

let rec zip xs ys =
  match (xs, ys) with
  | ([], []) -> []
  | (x :: xs, y :: ys) -> (x, y) :: (zip xs ys)
  | (_, _) -> absurd (perform (InvalidArgument "zip: length mismatch"))

let rec (@) xs ys =
  match xs with
  | [] -> ys
  | x :: xs -> x :: (xs @ ys)

let rec length = function
  | [] -> 0
  | x :: xs -> length xs + 1

(* Basic functions *)
let abs x = if x < 0 then -x else x

let min x y = if x < y then x else y

let max x y = if x < y then y else x

let rec gcd m n =
  match n with
  | 0 -> m
  | _ ->
    let g = gcd n in g (m mod n)

let rec lcm m n =
  let d = gcd m n in (m * n) / d

let odd x = (x mod 2 = 1)

let even x = (x mod 2 = 0)

let id x = x

let compose f g x = f (g x)

let ignore _ = ()

let fst (x, _) = x

let snd (_, y) = y

let print v =
  let s = to_string v in
  perform (Print s)

let print_string str =
  perform (Print str)

let print_endline v =
  let s = to_string v in
    perform (Print s);
    perform (Print "\n")

(* Basic Handlers *)
(*
effect Lookup: unit -> int
effect Update: int -> unit

let state initial = handler
  | y -> (fun _ -> y)
  | effect (Lookup ()) k -> (fun s -> continue k s s)
  | effect (Update s') k -> (fun _ -> continue k () s')
  | finally f -> f initial;;
*)