Source

oni / cf / cf_dyn.ml

Full commit
(*---------------------------------------------------------------------------*
  $Change$
  Copyright (C) 2011, james woodyatt
  All rights reserved.
  
  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:
  
    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.
    
    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution
  
  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

type ('i, 'o) t = ('i, 'o) s Lazy.t and ('i, 'o) s =
    | Z
    | P of 'o * ('i, 'o) t
    | Q of ('i -> ('i, 'o) s)

let fin = lazy Z

let nop =
    let rec get = lazy (Q put) and put x = P (x, get)
    in get

let select =
    let rec get = lazy (Q put)
    and put = function Some x -> P (x, get) | None -> Lazy.force get
    in get

let flat =
    let rec get = lazy (Q put)
    and put z =
        match Lazy.force z with
        | Cf_seq.Z -> Lazy.force get
        | Cf_seq.P (hd, tl) -> P (hd, lazy (put tl))
    in get

let filter f =
    let rec get = lazy (Q put)
    and put x = if f x then P (x, get) else Lazy.force get
    in get

let map f =
    let rec get = lazy (Q put) and put x = P (f x, get)
    in get

let fold =
    let rec loop p q m w =
        match Lazy.force w with
        | Z -> m
        | P (hd, tl) -> loop p q (p m hd) tl
        | Q f -> let x, m = q m in loop p q m (lazy (f x))
    in
    loop

let connect =
    let rec loop w1 w2 =
        match Lazy.force w2 with
        | Z -> Z
        | P (hd, tl) -> P (hd, lazy (loop w1 tl))
        | Q f ->
            match Lazy.force w1 with
            | Z -> Z
            | P (hd, tl) -> loop tl (lazy (f hd))
            | Q f -> Q (fun x -> loop (lazy (f x)) w2)
    in
    let enter w1 w2 = lazy (loop w1 w2) in
    enter

let zip =
    let rec loop a b =
        match Lazy.force a, Lazy.force b with
        | Q fx, Q fy -> Q (fun i -> loop (lazy (fx i)) (lazy (fy i)))
        | Q f, P _ -> Q (fun x -> loop (lazy (f x)) b)
        | P _, Q f -> Q (fun y -> loop a (lazy (f y)))
        | P (x, a), P (y, b) -> P ((x, y), lazy (loop a b))
        | (Z, _ | _, Z) -> Z
    in
    let enter a b = lazy (loop a b) in
    enter

let cyclical =
    let rec loop w0 w =
        match Lazy.force w with
        | Z -> loop w0 w0
        | P (hd, tl) -> P (hd, lazy (loop w0 tl))
        | Q f -> Q (fun x -> loop w0 (lazy (f x)))
    in
    let enter w = lazy (loop w w) in
    enter

let sequential =
    let rec loop z =
        match Lazy.force z with
        | Cf_seq.Z -> Z
        | Cf_seq.P (hd, tl) -> each hd tl
    and each w z =
        match Lazy.force w with
        | Z -> loop z
        | P (x, w) -> P (x, lazy (each w z))
        | Q f -> Q (get f z)
    and get f z x = each (lazy (f x)) z in
    let enter z = lazy (loop z) in
    enter

let concurrent =
    let get f q x = Cf_deque.A.push (lazy (f x)) q in
    let rec loop q =
        match Cf_deque.B.pop q with
        | None ->
            Z
        | Some (w, q) ->
            match Lazy.force w with
            | Z -> loop q
            | P (x, w) -> P (x, lazy (loop (Cf_deque.A.push w q)))
            | Q f -> Q (fun x -> loop (get f q x))
    in
    let rec start q z =
        match Lazy.force z with
        | Cf_seq.Z ->
            loop q
        | Cf_seq.P (hd, tl) ->
            match Lazy.force hd with
            | Z -> start q tl
            | P (x, w) -> P (x, lazy (start (Cf_deque.A.push w q) tl))
            | Q f -> Q (fun x -> start (get f q x) tl)
    in
    let enter z = lazy (start Cf_deque.nil z) in
    enter

module A = struct
    open Cf_either
    
    let tag =
        let rec get = lazy (Q put) and put x = P (A x, get)
        in get
    
    let strip =
        let rec get = lazy (Q put)
        and put = function
            | A x -> P (x, get)
            | B _ -> Lazy.force get
        in get
end

module B = struct
    open Cf_either
    
    let tag =
        let rec get = lazy (Q put) and put x = P (B x, get)
        in get
    
    let strip =
        let rec get = lazy (Q put)
        and put = function
            | A _ -> Lazy.force get
            | B x -> P (x, get)
        in get
end

let parallel =
    let ( -=- ) = connect in
    let enter a b =
        let a = A.strip -=- a -=- A.tag in
        let b = B.strip -=- b -=- B.tag in
        concurrent (Cf_seq.of_list [ a; b ])
    in
    enter

let commute =
    let rec start w s = lazy (loop w s)
    and loop w s =
        match Lazy.force w with
        | Z -> Cf_seq.Z
        | P (hd, tl) -> Cf_seq.P (hd, start tl s)
        | Q f ->
            match Lazy.force s with
            | Cf_seq.P (hd, tl) -> loop (lazy (f hd)) tl
            | Cf_seq.Z -> Cf_seq.Z
    in
    start

let drain =
    let rec loop w =
        match Lazy.force w with
        | P (hd, tl) -> Cf_seq.P (hd, lazy (loop tl))
        | (Z | Q _) -> Cf_seq.Z
    in
    let enter w = lazy (loop w) in
    enter

let flush =
    let rec loop w =
        match Lazy.force w with
        | P (_, tl) -> loop tl
        | (Z | Q _ as w0) -> w0
    in
    let enter w = lazy (loop w) in
    enter

let stringcommute w s = Cf_seq.to_string (commute w (Cf_seq.of_string s))

let upcase, dncase =
    let delta = (int_of_char 'a') - (int_of_char 'A') in
    let upcode = function
        | 'a'..'z' as c -> char_of_int ((int_of_char c) - delta)
        | c -> c
    and dncode = function
        | 'A'..'Z' as c -> char_of_int ((int_of_char c) + delta)
        | c -> c
    in
    map upcode, map dncode

let liftseq =
    let rec loop z =
        match Lazy.force z with
        | Cf_seq.P (hd, tl) -> P (hd, lazy (loop tl))
        | Cf_seq.Z -> Z
    in
    let enter z = lazy (loop z) in
    enter

let downseq =
    let rec loop w =
        match Lazy.force w with
        | Z -> Cf_seq.Z
        | P (hd, tl) -> Cf_seq.P (hd, lazy (loop tl))
        | Q f -> loop (lazy (f ()))
    in
    let enter w = lazy (loop w) in
    enter

module CM = struct
    let eval =
        let finish_ () = fin in
        let enter m = m finish_ in
        enter
    
    let read =
        let get f a = Lazy.force (f a) in
        let enter f = lazy (Q (get f)) in
        enter
    
    let write x f = lazy (P (x, f ()))
end

module SCM = struct
    let eval =
        let finish_ () _ = fin in
        let enter m s = m finish_ s in
        enter
    
    let read =
        let get f s a = Lazy.force (f a s) in
        let enter f s = lazy (Q (get f s)) in
        enter
    
    let write x f s = lazy (P (x, f () s))
end

module Op = struct
    let ( -=- ) = connect
    let ( -^- ) = zip
    let ( -%- ) = parallel
    let ( ~* ) s = concurrent (Cf_seq.of_list s)
    let ( ~& ) s = sequential (Cf_seq.of_list s)
end

(*--- $File$ ---*)