pervasives.eff

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

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

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

effect Print : string -> unit
effect Read : unit -> string

(*********** files effects *********)
effect Open_in : string -> in_channel
effect Open_out : string -> out_channel

effect Close_in : in_channel -> unit
effect Close_out : out_channel -> unit

effect Write_file : (out_channel * string) -> unit
effect Read_file : string -> string

effect Read_line : in_channel -> string
(***********************************)

effect Raise : string -> empty
effect Random_int : int -> int
effect Random_float: float -> float

let absurd void = match void with;;

effect DivisionByZero : unit -> empty

effect InvalidArgument : string -> empty

effect Failure : string -> empty

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

effect AssertionFault : unit -> empty

let assert b = if b then () else absurd (#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 (#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 (#DivisionByZero ())
  | n -> (/) m n

external float_of_int : int -> float = "float_of_int"

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

external string_length : string -> int = "string_length"

external trim : string -> string = "trim"

external split_on_char : char -> string -> string list = "split_on_char"

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

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 option_catch exc = handler
  | exc#raise _ _ -> None
  | val x -> Some x

let default_catch exc default = handler
  | exc#raise _ _ -> default
 *)
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)


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

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

let ignore _ = ()

let hd (x :: _) = x

let tl (_ :: lst) = lst

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 (#InvalidArgument "zip: length mismatch")

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

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

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

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

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

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 fst (x, _) = x

let snd (_, y) = y

let print v =
  let s = to_string v in
    #Print s

let print_string str =
  #Print str

let print_endline v =
  let s = to_string v in
    #Print s;
    #Print "\n"

effect Lookup: unit -> int
effect Update: int -> unit

let state r x = handler
  | val y -> (fun _ -> y)
  | #Lookup () k -> (fun s -> k s s)
  | #Update s' k -> (fun _ -> k () s')
  | finally f -> f x;;

(* let ref x =
  new ref @ x with
    operation lookup _ @ x -> (x, x)
    operation update y @ _ -> ((), y)
  end

let (!) r = r#lookup ()
let (:=) r v = r#update v
let incr r = r#update (r#lookup () + 1)
let decr r = r#update (r#lookup () - 1)
 *)
(* type random =
effect
  operation int : int -> int
  operation float : float -> float
end

external rnd : random = "rnd";;

This forces the evaluation of x before calling the check, allowing us
   to write [check !l] and similar to get the result instead of an
   operation
let check_val x = check x
 *)