FSharpApiSearchのプロトタイプ

prototype.fsx

(*
Prefixを導入した理由は、同じ'aでもqueryとtargetの'aは別物としたい。
例)
query: string -> 'a -> 'a
target: 'a -> int -> int
この場合マッチして欲しい。
'aを同じとしてしまうと、string = 'a = intとなってマッチしない。
*)
type Prefix = Target | Query
type Type =
  | Type of string
  | Variable of Prefix * string
  | Arrow of Type list

let rec typeToString = function
  | Type n -> n
  | Variable (_, n) -> "'" + n
  | Arrow ts ->
    ts
    |> List.map (function Arrow _  as arrow -> sprintf "(%s)" (typeToString arrow) | t -> typeToString t)
    |> String.concat " -> "

type Equations = Map<Type, Type>
let rec match' (left: Type) (right: Type) (eq: Equations): (bool * Equations) =
  match left, right with
  | Type leftName, Type rightName ->
    (leftName = rightName, eq)
  | (Variable _), (Variable _) ->
    let newEq =
      let existsReverseEntry = Map.exists (fun k v -> k = right && v = left) eq
      if existsReverseEntry = false then
        Map.add left right eq
      else
        eq
    (true, newEq)
  | (Variable _ as left), right
  | right, (Variable _ as left) ->
    match Map.tryFind left eq with // Variableを左辺にする
    | Some left -> match' left right eq
    | None -> (true, Map.add left right eq)
  | Arrow leftTypes, Arrow rightTypes ->
    if leftTypes.Length <> rightTypes.Length then
      (false, eq)
    else
      List.zip leftTypes rightTypes
      |> List.fold (fun (result, eq) (left, right) -> if result then match' left right eq else (false, eq)) (true, eq)
  | _ ->
    (false, eq)

let assertMatch target query =
  let success, eq = match' query target Map.empty
  try
    if success then
      printfn "success: %A should match %A" (typeToString query) (typeToString target)
    else
      printfn "failure: %A should match %A" (typeToString query) (typeToString target)
  with ex ->
    printfn "error: %A should match %A" (typeToString query) (typeToString target)
    printfn "%A" ex

let assertNotMatch target query =
  let success, eq = match' query target Map.empty
  try
    if not success then
      printfn "success: %A shouldn't matche %A" (typeToString query) (typeToString target)
    else
      printfn "failure: %A shouldn't matche %A" (typeToString query) (typeToString target)
  with ex ->
    printfn "error: %A shouldn't match %A" (typeToString query) (typeToString target)
    printfn "%A" ex

assertMatch
  (Type "string")
  (Type "string")
assertNotMatch
  (Type "int")
  (Type "string")
assertMatch
  (Variable (Query, "a"))
  (Type "string")
assertMatch
  (Variable (Query, "a"))
  (Variable (Target, "a"))
assertMatch
  (Arrow [ Type "string"; Type "string" ])
  (Arrow [ Type "string"; Type "string" ])
assertNotMatch
  (Arrow [ Type "int"; Type "string" ])
  (Arrow [ Type "string"; Type "string" ])
assertNotMatch
  (Arrow [ Type "string"; Type "string"; Type "string" ])
  (Arrow [ Type "string"; Type "string" ])
assertMatch
  (Arrow [ Variable (Query, "a"); Variable (Query, "a") ])
  (Arrow [ Variable (Target, "a"); Variable (Target, "a") ])
assertMatch
  (Arrow [ Variable (Query, "a"); Variable (Query, "a") ])
  (Arrow [ Variable (Target, "a"); Variable (Target, "b") ])
assertMatch
  (Arrow [ Variable (Query, "a"); Type "int" ])
  (Arrow [ Type "string"; Type "int" ])
assertMatch
  (Arrow [ Variable (Query, "a"); Variable (Query, "b") ])
  (Arrow [ Type "string"; Type "string" ])
assertNotMatch
  (Arrow [ Variable (Query, "a"); Variable (Query, "a") ])
  (Arrow [ Type "int"; Type "string" ])
assertMatch
  (Arrow [ Type "string"; Variable (Query, "a"); Variable (Query, "a") ])
  (Arrow [ Variable (Target, "a"); Type "int"; Type "int" ])