Rec Active Pattern Parser

patternParser.fsx

let (|TakeUntil|_|) x xs =
    match List.takeWhile ((<>) x) xs with
    | y when y = xs -> None
    | y -> Some(y, List.skipWhile ((<>) x) xs)

let (|Split|_|) split xs =
    match xs with
    | TakeUntil split (x1, (_ :: x2)) -> Some(x1, x2)
    | _ -> None

let (|Eq|_|) x y =
    if x = y then Some()
    else None

// detect list surrounded by before and after items, allow inner surrounds, count pairs
let (|Surround|_|) before after xs =
    let rec f d acc xs =
        match xs with
        | _ when d < 0 -> None // wrong pairing
        | Eq after :: [] when d = 1 -> List.rev acc |> Some // closing pair on end -> success
        | Eq before :: rest -> f (d + 1) (before :: acc) rest // inner "before" char -> increase depth
        | Eq after :: rest -> f (d - 1) (after :: acc) rest // inner "after" char -> decrease depth
        | x :: rest -> f d (x :: acc) rest // other char copy to output
        | _ -> None
    match xs with
    | Eq before :: rest -> f 1 [] rest
    | _ -> None

let (|SplitsPick|_|) split f xs =
    let rec loop prev xs =
        seq {
            match xs with
            | TakeUntil split (x1, (_ :: x2)) ->
                yield (prev @ x1, x2)
                yield! loop (prev @ x1 @ [ split ]) x2
            | _ -> ()
        }
    loop [] xs |> Seq.tryPick f    
let (|Int|_|) str =
    match System.Int32.TryParse(str: string) with
    | (true, x) -> 
            Some(x)
    | _ -> 
            None

type Op =
    | Plus
    | Minus
    | Multiply
    | Divide

[<RequireQualifiedAccess>]
type Ast =
    | Number of int
    | Op of Op * Ast * Ast

// split into chunks, where chunk is where function f returns true to adjacent elements
let chunkBy f xs =
    let rec loop prev acc xs =
        match xs, acc with
        | [], _ -> List.rev acc
        | x :: rest, g :: accRest ->
            if f prev x then loop x ((x :: g) :: accRest) rest
            else loop x ([x] :: List.rev g :: accRest) rest
        | _, [] -> loop prev [[]] xs
    
    match Seq.toList xs with
    | [] -> []
    | [x] -> [[x]]
    | x :: xs ->
        loop x [[x]] xs

let tokens (s: string) =
    s |> chunkBy (fun x y -> System.Char.IsDigit x && System.Char.IsDigit y) 
    |> List.map (Seq.filter (System.Char.IsWhiteSpace >> not) >> Seq.map string >> String.concat "")
    |> List.filter ((<>) "")

let rec (|BinaryOp|_|) s =
    let twoExprs = function | (Expr e1, Expr e2) -> Some (e1, e2) | _ -> None
    match s with
    | SplitsPick "+" twoExprs (e1, e2) -> Ast.Op (Plus, e1, e2) |> Some
    | SplitsPick "-" twoExprs (e1, e2) -> Ast.Op (Minus, e1, e2) |> Some
    | SplitsPick "*" twoExprs (e1, e2) -> Ast.Op (Multiply, e1, e2) |> Some
    | SplitsPick "/" twoExprs (e1, e2) -> Ast.Op (Divide, e1, e2) |> Some
    | _ -> None

and (|Expr|_|) s =
    match s with
    | [ Int x ] -> (Ast.Number x) |> Some
    | Surround "(" ")" (Expr e) -> Some e
    | BinaryOp e -> Some e
    | e -> 
        printfn "not Expr: %A" e
        None

let parse s =
    match tokens s with
    | Expr e -> printfn "%A" e
    | _ -> failwith s

parse "1+2"
parse "12/(1+2)"
parse "(1+2) * (3+4)"
parse "(10 * 4) / ((30/10) + 1)"