F#: Active Patterns

Introduction

Pattern matching is an extremely powerful feature supported by F#. Ability to decompose composite data structure into constituent parts (recursively by support of nested patterns) makes analysis of complex objects a piece of cake. As a sample we can take insertion operation for AVL tree and implement tree rotation with pattern matching. Entire process is nicely demonstrated on the picture below.

type Tree<'T> = 
    | Nil
    | Node of Tree<'T> * 'T * Tree<'T>

let rec height = function
    | Nil -> 0
    | Node(l, _, r) -> 1 + max (height l) (height r)

// balance factor - difference between heights    
let balance l r = height l - height r

// extracts value contained in tree
let valueOf = function
    | Nil -> failwith "Nil has no value"
    | Node(_, v, _) -> v

///Tree is valid if both left and right subtree are valid and balance factor of tree is lesser than 2 
let rec validate = function
    | Nil -> true
    | Node(l, _, r) ->
        validate l && validate r && (abs (balance l r) < 2)

// Rotate functions
let rotateLL = function
    | Node(Node(ll, lv, lr), v, r) -> Node(ll, lv, Node(lr, v, r))
    | x -> failwithf "Unexpected %O" x
let rotateRR = function
    | Node(l, v, Node(rl, rv, rr)) -> Node(Node(l, v, rl), rv, rr)
    | x -> failwithf "Unexpected %O" x
let rotateLR = function
    | Node(Node(ll, lv, Node(lrl, lrv, lrr)), v, r) -> Node(Node(ll, lv, lrl), lrv, Node(lrr, v, r))
    | x -> failwithf "Unexpected %O" x
let rotateRL = function
    | Node(l, v, Node(Node(rll, rlv, rlr), rv, rr)) -> Node(Node(l, v, rll), rlv, Node(rlr, rv, rr))
    | x -> failwithf "Unexpected %O" x

// the hero of blogpost: multi-case active pattern
let (|Lesser|Greater|Equals|) (a, b) = 
    if a < b then Lesser
    else if a = b then Equals
    else Greater

let rec insert v = function
    | Nil -> Node(Nil, v, Nil)
    | Node(l, c, r) as self->
        // common part
        // if balance factor of newly inserted node and its sibling is equal to threshold value (2) 
        // we should rebalance tree
        let doInsert inserted newNode sibling previous rotateL rotateR = 
            if balance inserted sibling = 2 then
                if v < valueOf previous then rotateL newNode
                else rotateR newNode
            else newNode
        match (v,c) with
        | Equals -> self
        | Lesser -> 
            let inserted = insert v l
            let newNode = Node(inserted, c, r)
            doInsert inserted newNode r l rotateLL rotateLR
        | Greater -> 
            let inserted = insert v r
            let newNode = Node(l, c, inserted)
            doInsert inserted newNode l r rotateRL rotateRR             

let flip f x y = f y x
let random = seq {
    let rnd = new System.Random()
    while true do
        yield rnd.Next()
    }
let tree = (Nil, Seq.take 1000 random) ||> Seq.fold (flip insert)
     
printfn "%O" (validate tree) // True

Code of rotation routines is almost verbatim translation of the picture. As you see description of each case takes three source lines, IMO very good result. Without pattern matching analysis of nested elements will be much more cumbersome.

F# spec defines large number of pattern forms that are already built in language. However sometimes it is not enough to express intentions of the developer, you may need to desconstuct the F# structure in application-dependent way (split list of numbers into two parts with odd in first and evens in second) or the object is opaque to F# (interoperabiliy issue). Luckily F# allows writing custom recognizers that can participate in pattern matching as first class citizens (as opposed to functions that can appear only in guards), this language feature is called Active Patterns.

Single Case Active Recognizer.

The first and the simpliest kind of Active Patterns is Single Case pattern – it just converts one value to another without putting restrictions on type of result.

open System.Drawing

let (|ARGB|) (c : Color) = c.A, c.R, c.G, c.B
let (ARGB (a, r, g, b)) = Color.Aquamarine
(*
val r : byte = 127uy
val g : byte = 255uy
val b : byte = 212uy
val a : byte = 255uy
*)

Single Case pattern can also be used with additional parameters. F# specification puts Parameterized Single Case Patterns into separate group but for the sake of simplicity (IMO) basic Single Case patterns can be imagined as parameterized ones with no arguments.

//Value to match comes as a last mandatory argument.
(|SingleCase|) [arg0…argn] input

This type of Active Patterns doesn’t perform filtering of incoming values; it is converter and nothing more. However you can always mix it with other patterns (i.e. constant pattern).

type Object(id : int) = 
    member this.Id = id

let (|Id|) (o : Object) = o.Id

// initially active recognizer extracts value of Id from the object, then Id is matched with simple constant pattern
let selectObjectWithSpecificIds o = 
    match o with
    | Id 10 -> printfn "Object with id=10 found"
    | Id 20 -> printfn "Object with id=20 found"
    | _ -> printfn "Required object not found"

selectObjectWithSpecificIds (Object(100))
(*
Required object not found
*)
selectObjectWithSpecificId (Object(10))
(*
Object with id=10 found
*)

Sometimes it is enough, but ofter you need to pick objects based on more complex criteria and in this case the guy you need – partial active recognizer.

Partial Active Recognizer.

This type of recognizers combines abilities of the Single Case patterns with a possibility to reject input value; that’s why they return not just ‘T but option<’T>.

// tests if specified string value can be parsed as int value
let (|Int|_|) v = 
    match Int32.TryParse(v) with
    | (true, v) -> Some(v)
    | false, _ -> None

let (Int x) = "100" // x = 100
match "a" with
| Int v -> printfn "this is int value %d" v
| _ -> printfn "something else"
(*
something else
*) 

By the way of application this recognizer is close to function passed into List.choose, you can simultaneously perform filtering and conversion. In fact you can directly use recognizer as a function in choose

let lst = ["1"; "a"; "2"; "b"; "3"]
let res = lst |> List.choose (|Int|_|)
printfn "%O" res
(*
[1; 2; 3]
*)

Similarly to Single Case patterns Partial Active recognizers can accept parameters, everything that was previously said regarding Single Case patterns is also applicable to partial ones. Declaration syntax is slightly different

// last argument is mandatory
(|Partial|_|) [arg0…argn] input 

// tests if specified string value can be parsed as int value
let (|Int|_|) v = 
    match Int32.TryParse(v) with
    | (true, v) -> Some(v)
    | false, _ -> None

// tests if specified string value can be parsed as double value
let (|Double|_|) v = 
    match Double.TryParse(v) with
    | true, v -> Some(v)
    | false, _ -> None

// tests if specified string value starts with given prefix
let (|Prefix|_|) prefix (s : string) = 
    if s.StartsWith(prefix) then Some(s.Substring(prefix.Length))
    else None

let classifyString s = 
    match s with
    | Int v -> printfn "Int: %d" v
    | Double v -> printfn "Double: %f" v
    | Prefix "http://" v -> printfn "String that starts with http://: %s" v

You can notice that if we try to compile code from above, the compiler will issue warning FS0025: Incomplete pattern matches on this expression. because it cannot verify that match cases are exhaustive. If you have fixed number of categories and want to put matched value into one of them  then you definitely should use third kind of active recognizers: multi case active recognizer.

Multi-Case Active Recognizer

This type of recognizers makes input value fall into one of existing categories. Recognizers of this kind differ from the ones we’ve already seen: first of all they do not accept any arguments except input value, second: they return Choice<…>.Declaration syntax is following:

// Сase1..СaseN is disguised Choice
(|Case1|Case2|..|CaseN|) input

We can rewrite slightly modified sample with multicase recognizers and make sure that warning dissapears.

// ( |Int|Double|Other| ) : string -> Choice<int,float,string>
let (|Int|Double|Other|) s = 
    match Int32.TryParse(s) with
    | (true, v) -> Int(v)
    | false, _ ->     
        match Double.TryParse(s) with
        | true, v -> Double(v)
        | false, _ -> Other(s)

let classifyString s = 
    match s with
    | Int v -> printfn "Int: %d" v
    | Double v -> printfn "Double: %f" v
    | Other s -> printfn "Other string %s" s

Practical application

Everything is limited by the imagination :). Adam Granicz‘ve posted amazing article about creating parsers based on active patterns. Nice example is interoperability with another .Net languages, you can easily enhance existing object with pattern matching capabilities without converting them to F# friendly structures.

using System.Collections.Generic;
using System.Linq;

namespace CSharp
{
    public class DataObject
    {
        public int Id { get; set; }
        public string Name { get; set; }
        public string Value { get; set; }

        public static List<DataObject> Create(int n)
        {
            return Enumerable
                .Range(1, n)
                .Select(i => new DataObject {Id = i, Name = "Name:" + i, Value = "Value:" + i}).
                ToList();
        }
    }
}

open CSharp
module CSInterop = 
    // single case patterns
    let (|Id|) (o : DataObject) = o.Id
    let (|Name|) (o : DataObject) = o.Name
    let (|Value|) (o : DataObject) = o.Value

    // partial patterns (why I cannot use ? in identifiers like I can in Schema)
    // my dream
    //let (|Id?|_|) id (o : DataObject) = if o.Id = id then Some(o) else None
    let (|Id_|_|) id (o : DataObject) = if o.Id = id then Some(o) else None
    let (|Name_|_|) name (o : DataObject) = if o.Name = name then Some(o) else None
    let (|Value_|_|) value (o : DataObject) = if o.Value = value then Some(o) else None

open CSInterop
 
let namesValues = DataObject.Create(5) |> Seq.map(function | Name name & Value value -> name + " " + value)
let findObject n = DataObject.Create(5) |> Seq.tryPick(function | Id_ n _ & Name name -> Some(name) | _ -> None)

Ability to decompose structure in arbitrary way is extremly powerful. With Active Patterns can perform pattern matching over any object model created in any .NET language. Processing XML, traversing LINQ expression trees, various file system based operations, decomposing text with regular expressions and binding matched group to the list elements or tuple components…You are the master of the Universe!

As a close-to-life sample we’ll examine transformation of expression trees. Often it is useful to describe structure of the objects with simple and straightforward expressions and later mechanically transform them into more complex ones. Expression can be used both for deducing type of field for the UI components and as a source for creating accessor delegates.

public class DataObject
{
    public int Id { get; set; }
    public string Name { get; set; }
}

Expression<Func<DataObject, string[]>> Expr = obj => obj.Name.Split(',');

Expression Expr describes what actions need to be performed to obtain result and provides complete type-related information. Unfortunatly we cannot use this compiled version of this expression directly because it is error-prone: NullReferenceException will be thrown in case of null argument or null Name property. Sad, but not fatal: we can easily detect all possible null references in this expression and transform it so all dangerous calls will be routed through special function.

type Methods private() = 
    static member ClassBindMethod = typeof<Methods>.GetMethod("ClassBind")
    static member ClassBind<'T when 'T : null and 'T : equality>(t : 'T, f : Func<'T, obj>) = 
        if t <> null then f.Invoke(t)
        else box null

Transformed version will look like this:

ClassBind(obj, p0 => ClassBind(p0.Name, p1 -> p1.Split(',')))

Disclaimer: implementation below is made just for demonstration and supports only reference types as possible null candidates.

open System
open System.Collections.Generic
open System.Linq.Expressions

type Methods private() = 
    static member ClassBindMethod = typeof<Methods>.GetMethod("ClassBind")
    static member ClassBind<'T when 'T : null and 'T : equality>(t : 'T, f : Func<'T, obj>) = 
        if t <> null then f.Invoke(t)
        else box null


let isNullable(t : Type) = t.IsClass || t.IsInterface

// Multi-Case pattern for expression
let (|MemberAccess|MethodCall|Lambda|Other|) (expr : Expression) =
    match expr.NodeType with
    | ExpressionType.Lambda ->
        let lambda = expr :?> LambdaExpression
        Lambda(lambda.Type, lambda.Parameters, lambda.ReturnType, lambda.Body)
    | ExpressionType.MemberAccess ->  
        let memberAccess = expr :?> MemberExpression
        MemberAccess(memberAccess.Expression, memberAccess.Member)
    | ExpressionType.Call ->
        let call = expr :?> MethodCallExpression
        MethodCall(call.Object, call.Method, call.Arguments |> Seq.toList)
    | _ -> Other(expr)

// gathers nullable candidates from given expression
// checks instance argument in member accesses and method calls
let rec collectNullableExpressions e = 
    match e with
    | Lambda(_, _, _, body) -> collectNullableExpressions body
    | MemberAccess(instance, _) when instance <> null ->
        let l1 = collectNullableExpressions instance
        if isNullable instance.Type then instance::l1 else l1
    | MethodCall(instance, _, args) ->
        let l1 = 
            if instance <> null 
            then if isNullable instance.Type then instance::(collectNullableExpressions instance) else collectNullableExpressions instance
            else []
        (List.collect collectNullableExpressions args) @ l1
    | _ -> []

// replaces all nullable references in expressions to the corrected values
let rec fixNullableRefs (map : Dictionary<_, _>) e = 
    match e with
    | MemberAccess(instance, memberInfo) when instance <> null && map.ContainsKey instance ->
        Expression.MakeMemberAccess(snd map.[instance], memberInfo) :> Expression, true   
    | MethodCall(instance, methodInfo, args) when instance <> null && map.ContainsKey instance ->
        Expression.Call(snd map.[instance],  methodInfo, args |> List.map (fixNullableRefs map >> fst) |> List.toArray) :> Expression, true
    | MethodCall(instance, methodInfo, args) ->
        let (fixedArgs, changes) = List.map (fixNullableRefs map) args |> List.unzip
        if (List.exists id changes) then
            Expression.Call(instance,  methodInfo, fixedArgs |> List.toArray) :> Expression, true
        else
            e, false
    | x -> x, false
                
let fix<'T when 'T :> LambdaExpression> (e :'T) =
    let nullables = 
        collectNullableExpressions e
        |> List.rev
        |> Seq.distinct
        |> List.ofSeq
    let counter = ref 0
    let map = new Dictionary<_, _>()
    for nullable in nullables do
        let (patchedExpr, hasChanges) = fixNullableRefs map nullable
        let param = Expression.Parameter(nullable.Type, sprintf "p%d" !counter)
        map.[nullable] <- ((if hasChanges then patchedExpr else nullable), param)
        incr counter
    let fixedBody,_ = fixNullableRefs map e.Body
    let newBody = 
        (nullables, fixedBody)
            ||> List.foldBack(fun n body ->
                let (patchedExpr, param) = map.[n]
                let bind = Methods.ClassBindMethod.MakeGenericMethod(n.Type)
                let funcType = typedefof<Func<_,_>>.MakeGenericType(n.Type, typeof<obj>)
                let lambda = Expression.Lambda(funcType, body, [|param|])
                Expression.Call(bind, patchedExpr, lambda) :> Expression
            )
    Expression.Lambda(e.Type, Expression.Convert(newBody, e.Body.Type), e.Parameters) :?> 'T

let source = DataObject.Expr
let patched = fix source    
printfn "%O" patched         
(*
obj => Convert(ClassBind(obj, p0 => ClassBind(p0.Name, p1 => p1.Split(new [] {,}))))
*)