# Copyright 2011  Petter Urkedal
#
# This file is part of the Viz Standard Library <http://www.vizlang.org/>.
#
# The Viz Standard Library (VSL) is free software: you can redistribute it
# and/or modify it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation, either version 3 of the License,
# or (at your option) any later version.
#
# The VSL is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public License for
# more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with the VSL.  If not, see <http://www.gnu.org/licenses/>.

#?ffoc include compat.ocaml_prereq
#?ffoc include compat.ocaml_unicode.pervasive
#?ffoc include compat.ocaml_pervasives.pervasive

include signatures

in combinators
    let ident x be x
    let konst x y be x
    let ∘ (f : α → β) be f
    let (g ∘ f) x be g (f x)
    let f @ x be f x

include combinators

in basics
    type line_location := string * int
    inj failure : line_location → string → exception

    let curry f x y be f (x, y)
    let uncurry f (x, y) be f x y

    let fst (x, _) be x
    let snd (_, y) be y
    let swp (x, y) be (y, x)

    type α + β
     inj inl : α → α + β
     inj inr : β → α + β

    let inll x be inl (inl x)
    let inlr x be inl (inr x)

    sig a_total_order
	type t
	val cmp : t → t → torder

    in total_order_ops.(Ord : a_total_order)
	let x = y be (tcoin% ↦ true; _ ↦ false) (Ord.cmp x y)
	let x ≠ y be (tcoin% ↦ false; _ ↦ true) (Ord.cmp x y)
	let x ≤ y be (tsucc% ↦ false; _ ↦ true) (Ord.cmp x y)
	let x ≥ y be (tprec% ↦ false; _ ↦ true) (Ord.cmp x y)
	let x < y be (tprec% ↦ true; _ ↦ false) (Ord.cmp x y)
	let x > y be (tsucc% ↦ true; _ ↦ false) (Ord.cmp x y)

    let min_of_cmp cmp x y
	taken cmp x y at tprec% be x
		      at _ be y

    let max_of_cmp cmp x y
	taken cmp x y at tsucc% be x
		      at _ be y

    type cold inj _cold
    type hot ψ inj _hot

    type rational
     inj frac : int → int → rational

include basics

in bool_ops
    #?ffoc include compat.ocaml_pervasives.bool_ops
    let (¬* f)   x0 be ¬ f x0
    let (f ∧* g) x0 be f x0 ∧ g x0
    let (f ∨* g) x0 be f x0 ∨ g x0
    let (¬** f)   x0 x1 be ¬ f x0 x1
    let (f ∧** g) x0 x1 be f x0 x1 ∧ g x0 x1
    let (f ∨** g) x0 x1 be f x0 x1 ∨ g x0 x1

include bool_ops

in nat_ops.(Nat : a_basic_nat)
    let 1'+ (x : Nat.t) be x
    let 2'+ be Nat.add
    let 2'− be Nat.sub
    let 2'× be Nat.mul
    let 2'div be Nat.div
    let 2'mod be Nat.mod
    let 2'quo be Nat.quo
    let 2'rem be Nat.rem

in int_ops.(Int : a_basic_int)
    include nat_ops.(Int)
    let 1'− be Int.neg

in int include compat.ocaml_miscints.int
       in ops include int_ops.(compat.ocaml_miscints.int)
include int.ops
include compat.ocaml_miscints.pervasive

in effect
    type ψ /~ α := effect ψ α
    val return : α → effect ψ α
    val 2'>>= : effect ψ α → (α → effect ψ β) → effect ψ β
    val 2'>> : effect ψ unit → effect ψ α → effect ψ α
    val observe : (∀ψ. effect ψ α) → α
    val unsafe_observe : effect ψ α → α
    val repeat : int → effect ψ unit → effect ψ unit

    type pocket_tag ψ  inj pocket_tag : pocket_tag ψ

    let return be __builtin_effect_return
    let 2'>>= m k be __builtin_effect_bind k m
    let 2'>> m n be __builtin_effect_bind (() +> n) m
    let observe (m : ∀ψ. effect ψ α) be __builtin_effect_run m
    let unsafe_observe be __builtin_effect_run
    let! repeat n m when n > 0 do m >> repeat (n - 1) m

# Preliminary.
let __builtin_toplevel_run be __builtin_effect_run