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 : string

effect Raise : string -> empty

effect RandomInt : int -> int

effect RandomFloat: float -> float

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

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

external infinity : float = "infinity"

external neg_infinity : float = "neg_infinity"

external nan : float = "nan"

let absurd void = match void with;;

effect DivisionByZero : empty

effect InvalidArgument : string -> empty

effect Failure : string -> empty

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

effect AssertionFault : 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

external exp : float -> float = "exp"

external expm1 : float -> float = "expm1"

external log : float -> float = "log"

external log1p : float -> float = "log1p"

external cos : float -> float = "cos"

external sin : float -> float = "sin"

external tan : float -> float = "tan"

external acos : float -> float = "acos"

external asin : float -> float = "asin"

external atan : float -> float = "atan"

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

external int_of_float : float -> int = "int_of_float"

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

external string_length : string -> int = "string_length"

external string_of_float : float -> string  = "string_of_float"

external string_of_int : int -> string  = "string_of_int"

external to_string : 'a -> string  = "to_string"  (*Unsafe for compilation*)

(* 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
  | (key, v) :: lst -> if x = key then Some v else assoc x lst

let rec range m n =
  if m > n then
    []
  else
    m :: range (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 acc = function
  | [] -> acc
  | y :: ys ->
    let acc' = f acc y in
    fold_left f acc' ys

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

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 unzip = function
  | [] -> ([], [])
  | (x, y) :: xys ->
    let xs, ys = unzip xys in
    (x :: xs, y :: ys)

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 (|>) x f = f 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 str =
  perform (Print (str ^ "\n"))

(* Basic Handlers *)
(*
effect Lookup: 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;;
*)