F# translation of a Haskell regex combinator exercise.

Regex.fs

(*

See the Haskell source: https://gist.github.com/1082416

There exist a few problems:

 (0) How correct is this? Non-termination, stack overflows? The kind
     of grammars that are recognized here are obviously not simply 
     regular expressions, because of the fixpoints. Try for instance:

     type S =
      | E
      | P of S * S
      | G of S

     let SG =
      let (<|>) a b = Choice (a, b)
      Fix <| fun self ->
          (Char 'a' >. Empty E)
          <|> (Char '`' >. Zip (fun a b -> P (a, b)) self self)
          <|> (Char '(' >. Map G self <. Char ')')

     let Test () =
      List.ofSeq "`a(`((a))(a))"
      |> Run (Compile SG)

     Using left-recursion currently gives a loop / stack overflow.
      
 (1) Fixpoint compilation is a compromise that gets it working but
     if you trace it you will see that compilation keeps happening over
     and over again at runtime. This is obviously a problem that needs to
     be fixed: compile/runtime separation is essential.

 (2) It would be nice to be able to memoize transition functions for
     efficiency. However, to take full advantage of that, the state machine
     type will have to be made non-generic in return type 'R. Otherwise a
     finite regex generates infinitely many SM states because of different 'R
     values, which defeats the purpose of memoization.

 (3) Kleene star probably deserves a rule for itself for efficiency.



*)
module My.Regex

type Regex<'T,'R> =
    | Empty of 'R
    | Fail
    (* Exists 'S. ('S -> 'R) -> Regex<'T,'S> -> Regex<'T,'R> *)
    | Map of (IMapVisitor<'T,'R> -> unit)
    (* Exists 'R1 'R2. ('R1 -> 'R2 -> 'R) ->
        Regex<'T,'R1> -> Regex<'T,'R2> -> Regex<'T,'R> *)
    | Zip of (IZipVisitor<'T,'R> -> unit)
    | Choice of Regex<'T,'R> * Regex<'T,'R>
    | Token of ('T -> option<'R>)
    (* This is necessary to be on par with Haskell implicit fixpoints. *)
    | Knot of ref<Regex<'T,'R>>

and IMapVisitor<'T,'R> =
    abstract member Visit<'S> :
        ('S -> 'R) -> Regex<'T,'S> -> unit

and IZipVisitor<'T,'R> =
    abstract member Visit<'R1,'R2> :
        ('R1 -> 'R2 -> 'R) -> Regex<'T,'R1> -> Regex<'T,'R2> -> unit

let Fix mk =
    let r = ref Fail
    r := mk (Knot r)
    !r

type SM<'T,'R> =
    | Accept of 'R
    | Reject
    | Expect of (option<'T> -> SM<'T,'R>)

let rec Conv f sm =
    match sm with
    | Accept r -> Accept (f r)
    | Reject   -> Reject
    | Expect e -> Expect (Conv f << e)

let rec Fork a b =
    match a, b with
    | Accept _, _ ->
        a
    | x, Reject | Reject, x ->
        x
    | Expect x, Expect y ->
        let e t = Fork (x t) (y t)
        Expect e
    | Expect x, (Accept _ as b) ->
        let e t = Fork (x t) b
        Expect e

let Push t sm =
    match sm with
    | Expect f -> f (Some t)
    | _ -> sm

let rec C<'T,'A,'R> (y: SM<'T,'A->'R>)
                    (n: SM<'T,'R>)
                    (rx: Regex<'T,'A>) : SM<'T,'R> =
    match rx with
    | Empty x   -> Conv (fun f -> f x) y
    | Fail      -> n
    | Map visit ->
        let result = ref Unchecked.defaultof<_>
        visit {
            new IMapVisitor<_,_> with
                member this.Visit f a =
                    result := C (Conv (fun r x -> r (f x)) y) n a
        }
        !result
    | Zip visit ->
        let result = ref Unchecked.defaultof<_>
        visit {
            new IZipVisitor<_,_> with
                member this.Visit f a b =
                    let k r x y = r (f y x)
                    result := C (C (Conv k y) (Conv (fun x _ -> x) n) b) n a
        }
        !result
    | Choice (a, b) ->
        Fork (C y n a) (C y n b)
    | Token f ->
        let parse t = function
            | Some x -> Conv (fun f -> f x) y
            | None   -> Push t n
        let e = function
            | None   -> n
            | Some t -> parse t (f t)
        Expect e
    | Knot r ->
        let cell = lazy C y n !r
        Expect <| function
            | Some t -> Push t cell.Value
            | None   -> cell.Value

let Compile regex =
    C (Accept (fun x -> x)) Reject regex

let Char c =
    Token (fun x -> if x = c then Some c else None)

let Map f a =
    Map (fun v -> v.Visit f a)

let Zip f a b =
    Zip (fun v -> v.Visit f a b)

let String (s: string) : Regex<char,string> =
    let rec str = function
        | []      -> Empty []
        | c :: cs -> Zip (fun x xs -> x :: xs) (Char c) (str cs)
    str (Seq.toList s)
    |> Map (fun xs -> System.String (Array.ofList xs))

let rec Run sm input =
    match sm, input with
    | Accept x, _     -> Some x
    | Reject, _       -> None
    | Expect f, []    -> Run (f None) []
    | Expect f, x::xs -> Run (f (Some x)) xs

let Many regex =
    Fix <| fun loop ->
        Choice (Zip (fun x xs -> x :: xs) regex loop, Empty [])

let ( <. ) a b = Zip (fun x _ -> x) a b
let ( >. ) a b = Zip (fun _ x -> x) a b

let Test () =
    List.ofSeq "abcabcabcDONE"
    |> Run (Compile (Many (String "abc") <. String "DONE"))

do (Test() |> printfn "%A")