F# Dependencies

core.fs

namespace FsDepedencies

module Core =
  open FSharp.Linq.RuntimeHelpers
  open FSharp.Quotations
  open FSharp.Quotations.Patterns

  open System
  open System.Collections.Generic

  type [<Sealed>] VariableAttribute() = inherit Attribute()

  type [<AbstractClass>] MetaVariableEvaluator () =
    class
    end

  type [<AbstractClass>] MetaVariableEvaluator<'VT> () =
    class
      inherit MetaVariableEvaluator ()
      abstract Eval : unit -> 'VT
    end

  type [<AbstractClass>] MetaVariable (domainType : Type, valueType : Type, name : String) =
    class
      member x.DomainType = domainType
      member x.ValueType  = valueType
      member x.Name       = name

      abstract UntypedEvaluator : unit -> MetaVariableEvaluator

      override x.ToString () = sprintf "{MetaVariable %s %s '%s'}" domainType.Name valueType.Name name
    end

  type [<AbstractClass>] MetaVariableEvaluator<'DT, 'VT> (mv : MetaVariable<'DT, 'VT>) =
    class
      inherit MetaVariableEvaluator<'VT> ()
    end

  and [<AbstractClass>] MetaVariable<'DT, 'VT> (name : String) =
    class
      inherit MetaVariable (typeof<'DT>, typeof<'VT>, name)

      abstract Evaluator : unit -> MetaVariableEvaluator<'DT, 'VT>

      override x.UntypedEvaluator () = upcast x.Evaluator ()
    end

  type [<Sealed>] ConstMetaVariable<'DT, 'VT> (name : String, v: 'VT) =
    class
      inherit MetaVariable<'DT, 'VT> (name)

      override x.Evaluator () =
        { new MetaVariableEvaluator<'DT, 'VT> (x) with
            override x.Eval () = v
        }
    end
  let constVariable<'DT, 'VT> name (v : 'VT) = ConstMetaVariable<'DT, 'VT> (name, v)

  type DomainTypes = IDictionary<Type, MetaVariable>

  let findDependencies (domainTypes : DomainTypes) (q : Expr<'T>) : MetaVariable array =
    match q with
    | Call (x, mi, args) ->
      let ps = mi.GetParameters ()
      if ps.Length > 0 then
        if mi.IsGenericMethod then
          let gmi   = mi.GetGenericMethodDefinition ()
          let gas   = gmi.GetGenericArguments ()
          let ga    = gas.[0]
          let gpcs  = ga.GetGenericParameterConstraints ()
          gpcs |> Array.map (fun gpc -> domainTypes.[gpc])
        else
          let p  = ps.[0]
          let mv = domainTypes.[p.ParameterType]
          [|mv|]
      else
        failwithf "Method '%s' is expected to have at least one parameter but had 0" mi.Name
    | _ ->
      failwithf "printDependencies invoked with the wrong shape. Expected shape like this: <@f env args@>"
    
  let invoke (domainTypes : DomainTypes) cenv (q : Expr<'T>) : 'T =
    let mvs = findDependencies domainTypes q
    let env = 
      mvs
      |> Array.map (fun mv -> mv.DomainType, mv.UntypedEvaluator ())
      |> dict
      |> cenv

    let nq = 
      match q with
      | Call (x, mi, args) ->
        let (_::t) = args
        let a = (Expr.Value env)::t
        match x with
        | Some x  -> Expr.Call (x, mi, a)
        | None    -> Expr.Call (mi, a)
        
      | _ ->
        failwithf "printDependencies invoked with the wrong shape. Expected shape like this: <@f env args@>"

    LeafExpressionConverter.EvaluateQuotation nq :?> 'T

  let printDependencies (domainTypes : DomainTypes) (q : Expr<'T>) =
    let mvs = findDependencies domainTypes q
    printfn "Method %d dependencies" mvs.Length
    for mv in mvs do
      printfn "  MetaVariable: %A" mv

fsdeps.fs

open System
open System.Collections.Generic
open FSharp.Quotations
open FSharp.Linq.RuntimeHelpers

module FsCollectVariable =
  type [<Sealed>] VariableAttribute() = inherit Attribute()

  type [<AbstractClass>] MetaVariableEvaluator () =
    class
    end

  type [<AbstractClass>] MetaVariableEvaluator<'VT> () =
    class
      inherit MetaVariableEvaluator ()
      abstract Eval : unit -> 'VT
    end

  type [<AbstractClass>] MetaVariable (domainType : Type, valueType : Type, name : String) =
    class
      member x.DomainType = domainType
      member x.ValueType  = valueType
      member x.Name       = name

      abstract UntypedEvaluator : unit -> MetaVariableEvaluator

      override x.ToString () = sprintf "{MetaVariable %s %s '%s'}" domainType.Name valueType.Name name
    end

  type [<AbstractClass>] MetaVariableEvaluator<'DT, 'VT> (mv : MetaVariable<'DT, 'VT>) =
    class
      inherit MetaVariableEvaluator<'VT> ()
    end

  and [<AbstractClass>] MetaVariable<'DT, 'VT> (name : String) =
    class
      inherit MetaVariable (typeof<'DT>, typeof<'VT>, name)

      abstract Evaluator : unit -> MetaVariableEvaluator<'DT, 'VT>

      override x.UntypedEvaluator () = upcast x.Evaluator ()
    end

  type [<Sealed>] ConstMetaVariable<'DT, 'VT> (name : String, v: 'VT) =
    class
      inherit MetaVariable<'DT, 'VT> (name)

      override x.Evaluator () =
        { new MetaVariableEvaluator<'DT, 'VT> (x) with
            override x.Eval () = v
        }
    end

  let constVariable<'DT, 'VT> name (v : 'VT) = ConstMetaVariable<'DT, 'VT> (name, v)

  type [<Interface; Variable>] IAmountVariable = abstract Amount : decimal
  let metaAmount = constVariable<IAmountVariable, decimal> "Amount" 0.0M
  let getAmount (env : #IAmountVariable) = env.Amount

  type [<Interface; Variable>] ICreditAVariable = abstract CreditA : decimal
  let metaCreditA = constVariable<ICreditAVariable, decimal> "CreditA" 0.0M
  let getCreditA (env : #ICreditAVariable) = env.CreditA

  type [<Interface; Variable>] ICreditBVariable = abstract CreditB : decimal
  let metaCreditB = constVariable<ICreditBVariable, decimal> "CreditB" 0.0M
  let getCreditB (env : #ICreditBVariable) = env.CreditB

  let metaVariables : MetaVariable array =
    [|
      metaAmount
      metaCreditA
      metaCreditB
    |]

  let domainTypes =
    metaVariables
    |> Array.map (fun mv -> mv.DomainType, mv)
    |> dict

  type Env (evaluators : IDictionary<Type, MetaVariableEvaluator>) =
    class
      let lookup (mv : MetaVariable<'DT, 'VT>) : 'VT =
        let name  = mv.Name
        let dt    = mv.DomainType
        let b, ue = evaluators.TryGetValue dt
        if b then
          match ue with
          | (:? MetaVariableEvaluator<'DT, 'VT> as e) -> e.Eval ()
          | v                                         ->
            let lt = v.GetType()
            let et = typeof<'VT>
            failwithf "Variable '%s' loaded but type mismatch. Loaded: %s, requested: %s" name lt.Name et.Name
        else
          failwithf "Variable '%s' not loaded" name
      interface IAmountVariable with
        member x.Amount   = lookup metaAmount
      end
      interface ICreditAVariable with
        member x.CreditA  = lookup metaCreditA
      end
      interface ICreditBVariable with
        member x.CreditB  = lookup metaCreditB
      end
    end
  let env = Env (dict [||])

  open FSharp.Quotations.Patterns

  let findDependencies (q : Expr<'T>) : MetaVariable array =
    match q with
    | Call (x, mi, args) ->
      let ps = mi.GetParameters ()
      if ps.Length > 0 then
        if mi.IsGenericMethod then
          let gmi   = mi.GetGenericMethodDefinition ()
          let gas   = gmi.GetGenericArguments ()
          let ga    = gas.[0]
          let gpcs  = ga.GetGenericParameterConstraints ()
          gpcs |> Array.map (fun gpc -> domainTypes.[gpc])
        else
          let p  = ps.[0]
          let mv = domainTypes.[p.ParameterType]
          [|mv|]
      else
        failwithf "Method '%s' is expected to have at least one parameter but had 0" mi.Name
    | _ ->
      failwithf "printDependencies invoked with the wrong shape. Expected shape like this: <@f env args@>"
    
  let invoke (q : Expr<'T>) : 'T =
    let mvs = findDependencies q
    let env = 
      mvs
      |> Array.map (fun mv -> mv.DomainType, mv.UntypedEvaluator ())
      |> dict
      |> Env

    let nq = 
      match q with
      | Call (x, mi, args) ->
        let (_::t) = args
        let a = (Expr.Value env)::t
        match x with
        | Some x  -> Expr.Call (x, mi, a)
        | None    -> Expr.Call (mi, a)
        
      | _ ->
        failwithf "printDependencies invoked with the wrong shape. Expected shape like this: <@f env args@>"

    LeafExpressionConverter.EvaluateQuotation nq :?> 'T

  let printDependencies (q : Expr<'T>) =
    let mvs = findDependencies q
    printfn "Method %d dependencies" mvs.Length
    for mv in mvs do
      printfn "  MetaVariable: %A" mv

open FsCollectVariable

module Test =
  let absoluteMaxAmount env amountLimit =
    let amount  = env |> getAmount

    min amount amountLimit

  let maxTotalDebt env debtLimit =
    let amount      = env |> getAmount
    let creditA     = env |> getCreditA
    let creditB     = env |> getCreditB
    let totalCredit = creditA + creditB

    if totalCredit > debtLimit then 0.0M else amount

[<EntryPoint>]
let main argv =
  let amountLimit = 100.0M
  let debtLimit   = 200.0M

  printDependencies <@ Test.absoluteMaxAmount env amountLimit @>
  printDependencies <@ Test.maxTotalDebt      env debtLimit   @>

  let r = invoke <@ Test.absoluteMaxAmount env amountLimit @>
  printfn "Result: %A" r

  0

fsdeps.tt

<#@ output extension=".fs" #>
namespace FsDepedencies

<#
  var model = new Variable[] 
    {
        constVariable("Amount"  , "decimal", "0.0M")
      , constVariable("CreditA" , "decimal", "0.0M")
      , constVariable("CreditB" , "decimal", "0.0M")
      , constVariable("CreditC" , "decimal", "0.0M")
    };
#>

module Model =
<#
  foreach (var variable in model)
  {
#>
  type [<Interface; Variable>] I<#=variable.Name#>Variable = abstract <#=variable.Name#> : <#=variable.Type#>
  let meta<#=variable.Name#> = constVariable<I<#=variable.Name#>Variable, <#=variable.Type#>> "<#=variable.Name#>" <#=variable.DefaultValue#>
  let get<#=variable.Name#> (env : #I<#=variable.Name#>Variable) = env.<#=variable.Name#>
<#
  }
#>

  let metaVariables : MetaVariable array =
    [|
<#
  foreach (var variable in model)
  {
#>
      meta<#=variable.Name#>
<#
  }
#>
    |]

  let domainTypes =
    metaVariables
    |> Array.map (fun mv -> mv.DomainType, mv)
    |> dict

  type Env (evaluators : IDictionary<Type, MetaVariableEvaluator>) =
    class
      let lookup (mv : MetaVariable<'DT, 'VT>) : 'VT =
        let name  = mv.Name
        let dt    = mv.DomainType
        let b, ue = evaluators.TryGetValue dt
        if b then
          match ue with
          | (:? MetaVariableEvaluator<'DT, 'VT> as e) -> e.Eval ()
          | v                                         ->
            let lt = v.GetType()
            let et = typeof<'VT>
            failwithf "Variable '%s' loaded but type mismatch. Loaded: %s, requested: %s" name lt.Name et.Name
        else
          failwithf "Variable '%s' not loaded" name
<#
  foreach (var variable in model)
  {
#>
      interface I<#=variable.Name#>Variable with
        member x.<#=variable.Name#> = lookup meta<#=variable.Name#>
      end
<#
  }
#>
    end
  let env = Env (dict [||])
<#+
  class Variable
  {
    public readonly string Name         ;
    public readonly string Type         ;
    public readonly string DefaultValue ;
    public Variable(string name, string type, string defaultValue)
    {
      Name          = name          ?? "";
      Type          = type          ?? "";
      DefaultValue  = defaultValue  ?? "";
    }
  }

  Variable constVariable(string name, string type, string defaultValue)
  {
    return new Variable(name, type, defaultValue);
  }
#>