ChaosBuilder

ChaosBuilder.fsx

#r "packages/Unquote/lib/net45/Unquote.dll"

open FSharp.Quotations
open Swensen.Unquote

type IMutationSitePicker =
    abstract member PickNextSite: bool
    abstract member NotifyIgnoredSite: unit -> unit
    abstract member NotifyMutation: unit -> unit

type IExpressionReplacer =
    abstract member ReplaceSignedConstant: Expr -> Expr
    abstract member ReplaceUnsignedConstant: Expr -> Expr
    abstract member ReplaceBinaryArithmeticOperator: Expr * Expr * Expr -> Expr

let rec mutate (mutationSitePicker:IMutationSitePicker) (expressionReplacer:IExpressionReplacer) (expr:Expr) =
    match expr with
    | DerivedPatterns.Byte _
    | DerivedPatterns.SByte _
    | DerivedPatterns.Single _
    | DerivedPatterns.Double _
    | DerivedPatterns.Decimal _
    | DerivedPatterns.Int16 _
    | DerivedPatterns.UInt16 _
    | DerivedPatterns.Int32 _
    | DerivedPatterns.UInt32 _
    | DerivedPatterns.Int64 _
    | DerivedPatterns.UInt64 _ when not mutationSitePicker.PickNextSite ->
        mutationSitePicker.NotifyIgnoredSite()
        expr

    | DerivedPatterns.SpecificCall <@@ (+) @@> _
    | DerivedPatterns.SpecificCall <@@ (-) @@> _
    | DerivedPatterns.SpecificCall <@@ (*) @@> _
    | DerivedPatterns.SpecificCall <@@ (/) @@> _ when not mutationSitePicker.PickNextSite ->
        mutationSitePicker.NotifyIgnoredSite()
        expr

    | DerivedPatterns.SByte _
    | DerivedPatterns.Single _
    | DerivedPatterns.Double _
    | DerivedPatterns.Decimal _
    | DerivedPatterns.Int16 _
    | DerivedPatterns.Int32 _
    | DerivedPatterns.Int64 _ ->
        mutationSitePicker.NotifyMutation()
        expressionReplacer.ReplaceSignedConstant(expr)

    | DerivedPatterns.Byte _
    | DerivedPatterns.UInt16 _
    | DerivedPatterns.UInt32 _
    | DerivedPatterns.UInt64 _ ->
        mutationSitePicker.NotifyMutation()
        expressionReplacer.ReplaceUnsignedConstant(expr)

    | DerivedPatterns.SpecificCall <@@ (+) @@> (_, _, [e1; e2])
    | DerivedPatterns.SpecificCall <@@ (-) @@> (_, _, [e1; e2])
    | DerivedPatterns.SpecificCall <@@ (*) @@> (_, _, [e1; e2])
    | DerivedPatterns.SpecificCall <@@ (/) @@> (_, _, [e1; e2]) ->
        mutationSitePicker.NotifyMutation()
        let e1' = mutate mutationSitePicker expressionReplacer e1
        let e2' = mutate mutationSitePicker expressionReplacer e2
        expressionReplacer.ReplaceBinaryArithmeticOperator(expr, e1', e2')

    | ExprShape.ShapeVar _ -> expr
    | ExprShape.ShapeLambda (var, expression) ->
        let expression' = mutate mutationSitePicker expressionReplacer expression
        Expr.Lambda(var, expression')
    | ExprShape.ShapeCombination(shape, expressions) ->
        let expressions' = expressions |> List.map (mutate mutationSitePicker expressionReplacer)
        ExprShape.RebuildShapeCombination(shape, expressions')

type ChaosBuilder (mutationSitePicker:IMutationSitePicker, expressionReplacer:IExpressionReplacer) =
    member this.Return(x) = x
    member this.Quote (expr) = expr
    member this.Run (expr:Expr<'T>) =
        let choaticExpr = mutate mutationSitePicker expressionReplacer expr
        choaticExpr.Eval<'T>()

type MutateOnceEvery(interval) =
    let mutable nextMutation = interval
    interface IMutationSitePicker with
         member this.PickNextSite = nextMutation <= 0
         member this.NotifyIgnoredSite() = nextMutation <- nextMutation - 1
         member this.NotifyMutation() = nextMutation <- nextMutation + interval

type MutateWithProbability(proportion) =
    let r = new System.Random()
    let mutable lastRandom = r.NextDouble()
    interface IMutationSitePicker with
         member this.PickNextSite = lastRandom < proportion
         member this.NotifyIgnoredSite() = lastRandom <- r.NextDouble()
         member this.NotifyMutation() = lastRandom <- r.NextDouble()

[<RequireQualifiedAccess>]
type SignedConstantMutation =
    | AbsoluteZero
    | AbsolutePlusOne
    | RelativePlusOne
    | AbsoluteMinusOne
    | RelativeMinusOne

[<RequireQualifiedAccess>]
type UnsignedConstantMutation =
    | AbsoluteZero
    | AbsolutePlusOne
    | RelativePlusOne
    | RelativeMinusOne

[<RequireQualifiedAccess>]
type BinaryArithmeticOperator =
    | Plus
    | Minus
    | MultipliedBy
    | DividedBy

let inline mutateSignedConstant (mutation:SignedConstantMutation) (value:'T) =
    match mutation with
    | SignedConstantMutation.AbsoluteZero -> LanguagePrimitives.GenericZero<'T>
    | SignedConstantMutation.AbsolutePlusOne -> LanguagePrimitives.GenericOne<'T>
    | SignedConstantMutation.RelativePlusOne -> value + LanguagePrimitives.GenericOne<'T>
    | SignedConstantMutation.AbsoluteMinusOne -> - LanguagePrimitives.GenericOne<'T>
    | SignedConstantMutation.RelativeMinusOne -> value - LanguagePrimitives.GenericOne<'T>

let inline mutateUnsignedConstant (mutation:UnsignedConstantMutation) (value:'T) =
    match mutation with
    | UnsignedConstantMutation.AbsolutePlusOne -> LanguagePrimitives.GenericOne<'T>
    | UnsignedConstantMutation.RelativePlusOne -> value + LanguagePrimitives.GenericOne<'T>
    | UnsignedConstantMutation.RelativeMinusOne when value > LanguagePrimitives.GenericOne<'T> -> value - LanguagePrimitives.GenericOne<'T>
    | _ -> LanguagePrimitives.GenericZero<'T>

let mutateBinaryArithmeticOperatorInInt32Expr (newOperator:BinaryArithmeticOperator) (e1:Expr, e2:Expr) =
    match newOperator with
    | BinaryArithmeticOperator.Plus -> <@@ (%%e1:int) + (%%e2:int) @@>
    | BinaryArithmeticOperator.Minus -> <@@ (%%e1:int) - (%%e2:int) @@>
    | BinaryArithmeticOperator.MultipliedBy -> <@@ (%%e1:int) * (%%e2:int) @@>
    | BinaryArithmeticOperator.DividedBy -> <@@ (%%e1:int) / (%%e2:int) @@>
let mutateBinaryArithmeticOperatorInDoubleExpr (newOperator:BinaryArithmeticOperator) (e1:Expr, e2:Expr) =
    match newOperator with
    | BinaryArithmeticOperator.Plus -> <@@ (%%e1:double) + (%%e2:double) @@>
    | BinaryArithmeticOperator.Minus -> <@@ (%%e1:double) - (%%e2:double) @@>
    | BinaryArithmeticOperator.MultipliedBy -> <@@ (%%e1:double) * (%%e2:double) @@>
    | BinaryArithmeticOperator.DividedBy -> <@@ (%%e1:double) / (%%e2:double) @@>

type RandomExpressionReplacer() =
    let r = new System.Random()
    let getRandomSignedMutation() =
        let cases = FSharp.Reflection.FSharpType.GetUnionCases(typeof<SignedConstantMutation>)
        let index = r.Next(cases.Length)
        FSharp.Reflection.FSharpValue.MakeUnion(cases.[index], [||]) :?> SignedConstantMutation
    let getRandomUnsignedMutation() =
        let cases = FSharp.Reflection.FSharpType.GetUnionCases(typeof<UnsignedConstantMutation>)
        let index = r.Next(cases.Length)
        FSharp.Reflection.FSharpValue.MakeUnion(cases.[index], [||]) :?> UnsignedConstantMutation
    let getRandomBinaryArithmeticOperatorDifferentFrom operatorToExclude =
        let cases =
            FSharp.Reflection.FSharpType.GetUnionCases(typeof<BinaryArithmeticOperator>)
            |> Array.map (fun uc -> FSharp.Reflection.FSharpValue.MakeUnion(uc, [||]) :?> BinaryArithmeticOperator)
            |> Array.filter (fun op -> op <> operatorToExclude)
        let index = r.Next(cases.Length)
        cases.[index]

    interface IExpressionReplacer with
        member this.ReplaceSignedConstant expr =
            match expr with
            | DerivedPatterns.SByte i ->
                Expr.Value(mutateSignedConstant (getRandomSignedMutation()) i)
            | DerivedPatterns.Single i ->
                Expr.Value(mutateSignedConstant (getRandomSignedMutation()) i)
            | DerivedPatterns.Double i ->
                Expr.Value(mutateSignedConstant (getRandomSignedMutation()) i)
            | DerivedPatterns.Decimal i ->
                Expr.Value(mutateSignedConstant (getRandomSignedMutation()) i)
            | DerivedPatterns.Int16 i ->
                Expr.Value(mutateSignedConstant (getRandomSignedMutation()) i)
            | DerivedPatterns.Int32 i ->
                Expr.Value(mutateSignedConstant (getRandomSignedMutation()) i)
            | DerivedPatterns.Int64 i ->
                Expr.Value(mutateSignedConstant (getRandomSignedMutation()) i)
            | _ ->
                invalidArg "expr" "This expression shape is not supported"

        member this.ReplaceUnsignedConstant expr =
            match expr with
            | DerivedPatterns.UInt16 i ->
                Expr.Value(mutateUnsignedConstant (getRandomUnsignedMutation()) i)
            | DerivedPatterns.UInt32 i ->
                Expr.Value(mutateUnsignedConstant (getRandomUnsignedMutation()) i)
            | DerivedPatterns.UInt64 i ->
                Expr.Value(mutateUnsignedConstant (getRandomUnsignedMutation()) i)
            | DerivedPatterns.Byte i ->
                Expr.Value(mutateUnsignedConstant (getRandomUnsignedMutation()) i)
            | _ ->
                invalidArg "expr" "This expression shape is not supported"

        member this.ReplaceBinaryArithmeticOperator(expr, e1, e2) =
            match expr with
            | DerivedPatterns.SpecificCall <@ (+) @> _ when expr.Type = typeof<int> ->
                mutateBinaryArithmeticOperatorInInt32Expr (getRandomBinaryArithmeticOperatorDifferentFrom BinaryArithmeticOperator.Plus) (e1, e2)
            | DerivedPatterns.SpecificCall <@ (-) @> _ when expr.Type = typeof<int> ->
                mutateBinaryArithmeticOperatorInInt32Expr (getRandomBinaryArithmeticOperatorDifferentFrom BinaryArithmeticOperator.Minus) (e1, e2)
            | DerivedPatterns.SpecificCall <@ (*) @> _ when expr.Type = typeof<int> ->
                mutateBinaryArithmeticOperatorInInt32Expr (getRandomBinaryArithmeticOperatorDifferentFrom BinaryArithmeticOperator.MultipliedBy) (e1, e2)
            | DerivedPatterns.SpecificCall <@ (/) @> _ when expr.Type = typeof<int> ->
                mutateBinaryArithmeticOperatorInInt32Expr (getRandomBinaryArithmeticOperatorDifferentFrom BinaryArithmeticOperator.DividedBy) (e1, e2)

            | DerivedPatterns.SpecificCall <@ (+) @> _ when expr.Type = typeof<double> ->
                mutateBinaryArithmeticOperatorInDoubleExpr (getRandomBinaryArithmeticOperatorDifferentFrom BinaryArithmeticOperator.Plus) (e1, e2)
            | DerivedPatterns.SpecificCall <@ (-) @> _ when expr.Type = typeof<double> ->
                mutateBinaryArithmeticOperatorInDoubleExpr (getRandomBinaryArithmeticOperatorDifferentFrom BinaryArithmeticOperator.Minus) (e1, e2)
            | DerivedPatterns.SpecificCall <@ (*) @> _ when expr.Type = typeof<double> ->
                mutateBinaryArithmeticOperatorInDoubleExpr (getRandomBinaryArithmeticOperatorDifferentFrom BinaryArithmeticOperator.MultipliedBy) (e1, e2)
            | DerivedPatterns.SpecificCall <@ (/) @> _ when expr.Type = typeof<double> ->
                mutateBinaryArithmeticOperatorInDoubleExpr (getRandomBinaryArithmeticOperatorDifferentFrom BinaryArithmeticOperator.DividedBy) (e1, e2)

            | _ ->
                invalidArg "expr" "This expression shape is not supported"
        
let never = new ChaosBuilder (MutateOnceEvery 0, new RandomExpressionReplacer())
let usually = new ChaosBuilder (MutateOnceEvery 10, new RandomExpressionReplacer())
let always = new ChaosBuilder (MutateOnceEvery System.Int32.MaxValue, new RandomExpressionReplacer())

let mostProbably = new ChaosBuilder (MutateWithProbability 0.05, new RandomExpressionReplacer())

let theAnswer = usually { return 42 }
let basicArithmetic = mostProbably { return 6 * 7 }

let test = mostProbably {
    let x = 2
    let y = 3
    let alpha = System.Math.PI
    let w = 4M
    return System.Convert.ToDouble(x + y) + sin alpha * System.Convert.ToDouble(w)
}