Source

ocaml-lib / syndesc / iso.ml

open Monad

class type ['a,'b] t =
  object
    method apply : 'a -> 'b MOption.t
    method unapply : 'b -> 'a MOption.t
  end


(* isomorphisms algebra *)

class ['a,'b] inverse (f : ('a,'b) t) : ['b,'a] t =
  object
    method apply = f#unapply
    method unapply = f#apply
  end
let inverse f = new inverse f

let id : ('a,'a) t =
  object
    method apply x = MOption.some x
    method unapply x = MOption.some x
  end

class ['a,'b,'c] compose (g : ('b,'c) t) (f : ('a,'b) t) : ['a,'c] t =
  object
    method apply x = MOption.bind (f#apply x) g#apply
    method unapply z = MOption.bind (g#unapply z) f#unapply
  end
let compose g f = new compose g f
let seq f g = new compose g f

class ['a,'b,'c,'d] prod (f : ('a,'b) t) (g : ('c,'d) t) : ['a * 'c, 'b * 'd] t =
  object
    method apply (a,c) =
      MOption.bind (f#apply a) (fun b ->
	MOption.bind (g#apply c) (fun d ->
	  MOption.some (b,d)))
    method unapply (b,d) =
      MOption.bind (f#unapply b) (fun a ->
	MOption.bind (g#unapply d) (fun c ->
	  MOption.some (a,c)))
  end
let prod f g = new prod f g

let assoc : ('a * ('b * 'c), ('a * 'b) * 'c) t =
  object
    method apply (a,(b,c)) = MOption.some ((a,b),c)
    method unapply ((a,b),c) = MOption.some (a,(b,c))
  end

let comm : ('a * 'b, 'b * 'a) t =
  object
    method apply (a,b) = MOption.some (b,a)
    method unapply (b,a) = MOption.some (a,b)
  end

let unit : ('a, 'a * unit) t =
  object
    method apply x = MOption.some (x,())
    method unapply (x,()) = MOption.some x
  end

class ['a] elt (e : 'a) : [unit, 'a] t =
  object
    method apply _ = MOption.some e
    method unapply x =
      if x = e then MOption.some () else MOption.none
  end
let elt e = new elt e

class ['a] subset (p : 'a -> bool) : ['a,'a] t =
  object
    method apply x =
      if p x then MOption.some x else MOption.none
    method unapply x =
      if p x then MOption.some x else MOption.none
  end
let subset p = new subset p

(* isomorphisms for lists *)

let nil : (unit, 'a list) t =
  object
    method apply () = MOption.some []
    method unapply = function
      | [] -> MOption.some ()
      | _ -> MOption.none
  end

let cons : ('a * 'a list, 'a list) t =
  object
    method apply (x,xs) = MOption.some (x::xs)
    method unapply = function
      | [] -> MOption.none
      | x::xs -> MOption.some (x,xs)
  end

(* conversions *)

let string_of_list : (char list, string) t =
  object
    method apply lc =
      let n = List.length lc in
      let s = String.make n ' ' in
      ignore (List.fold_left (fun i c -> s.[i] <- c; i+1) 0 lc);
      MOption.some s
    method unapply s =
      let lc = ref [] in
      for i = String.length s - 1 downto 0 do
	lc := s.[i] :: !lc
      done;
      MOption.some !lc
  end

let int_of_string : (string, int) t =
  object
    method apply s =
      try MOption.some (int_of_string s)
      with _ -> MOption.none
    method unapply i =
      MOption.some (string_of_int i)
  end

(* isomorphisms for either *)

type ('a,'b) either = Left of 'a | Right of 'b

let left : ('a, ('a,'b) either) t =
  object
    method apply x = MOption.some (Left x)
    method unapply = function
      | Left x -> MOption.some x
      | _ -> MOption.none
  end

let right : ('b, ('a,'b) either) t =
  object
    method apply x = MOption.some (Right x)
    method unapply = function
      | Right x -> MOption.some x
      | _ -> MOption.none
  end

let list_cases : ((unit, 'a * 'a list) either, 'a list) t =
  object
    method apply = function
      | Left () -> MOption.some []
      | Right (x,xs) -> MOption.some (x::xs)
    method unapply = function
      | [] -> MOption.some (Left ())
      | x::xs -> MOption.some (Right (x,xs))
  end

(* small step abstract machine *)

let rec driver (f : 'a -> 'a MOption.t) (state : 'a) : 'a =
  match f state with
  | Some state' -> assert (state' <> state); driver f state'
  | None -> state

class ['a] iterate (step : ('a,'a) t) : ['a,'a] t =
  object
    method apply x = MOption.some (driver step#apply x)
    method unapply y = MOption.some (driver step#unapply y)
  end
let iterate step = new iterate step

let step (f : ('a * 'b, 'a) t) : ('a * 'b list, 'a * 'b list) t =
  compose
    (prod f id)
    (compose
       assoc
       (prod id (inverse cons)))

let fold_left (f : ('a * 'b, 'a) t) : ('a * 'b list, 'a) t =
  compose
    (inverse unit)
    (compose
       (prod id (inverse nil))
       (iterate (step f)))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.