/Fing/Unify.fs

  1// Copyright (c) 2010, Nathan Sanders
  2// Licence: New BSD. See accompanying documentation.
  3
  4module Unify
  5open Types
  6open Parser
  7open Microsoft.FSharp.Metadata
  8// fancy unification stuff (not implemented yet)
  9// mainly: list<'a> |=> seq<'a> (interface)
 10//         list<'a> |=> 'a (most-general unification)
 11//         Stack<'a> |=> StretchList<'a> (subtype, I htink my example is wrong)
 12//           (also, with proper respect for co-variance and contra-variance)
 13//           (ugh)
 14
 15let check t = function // TODO: this is a no-op right now because I can't verify any of these
 16| Null var -> true // because Id should contain FSharpType or whatever instead of string
 17| Struct var -> true
 18| NotStruct var -> true
 19| DefaultConstructor var -> true
 20| Enum(var,t) -> true
 21| Delegate(var,domain,range) -> true
 22| Subtype(var,t) -> true
 23| Sig(var,id,t,prop) -> true
 24| TyparConstraint t -> true
 25
 26
 27let rec subst' v t = function
 28| Complex(tag,l) -> Complex(tag, l |> List.map (subst' v t))
 29| Param i when i = v -> t
 30| Param j -> Param j
 31(* substitute type t for variable v in the target type *)
 32let rec subst v t = function
 33| Var (Choice is) when is |> List.exists ((=) v) -> t
 34| Var i when i = v -> t
 35| Arrow types -> Arrow (List.map (subst v t) types)
 36| Tuple types -> Tuple (List.map (subst v t) types)
 37| NamedArg (name,typ,opt) -> NamedArg(name,subst v t typ,opt)
 38| Generic (typ,types) -> Generic (subst v t typ,List.map (subst v t) types)
 39| Array (n,typ) -> Array (n,subst v t typ)
 40| Constraint (quand,typ) when check t quand -> subst v t typ
 41| typ -> typ // Id and non-matching Var
 42
 43(* get type variables used in a type *)
 44let rec stringify = function // this function is cheesy because it's a hack and needs to disappear
 45| Anonymous -> Set.singleton "_"
 46| Structural a -> Set.singleton a
 47| Normal a -> Set.singleton a
 48| Choice vars -> Set.unionMany (List.map stringify vars)
 49
 50let rec usedVars = function // should be Typ -> Set<Typar> not Set<string>
 51| Var v -> Set.singleton v
 52| Arrow types -> Set.unionMany (List.map usedVars types)
 53| Tuple types -> Set.unionMany (List.map usedVars types)
 54| Id _ -> Set.empty
 55| NamedArg(_,t,_) -> usedVars t
 56| Generic(t,types) -> usedVars t |>Set.union<| Set.unionMany (List.map usedVars types)
 57| Array(_,t) -> usedVars t
 58| Constraint(var,t) -> usedConstraintVars var |>Set.union<| usedVars t
 59and usedConstraintVars = function
 60| Null var -> Set.singleton var
 61| Struct var -> Set.singleton var
 62| NotStruct var -> Set.singleton var
 63| DefaultConstructor var -> Set.singleton var
 64| Enum(var,t) -> var |>Set.add<| usedVars t
 65| Delegate(var,t,t') -> var |>Set.add<| usedVars t |>Set.union<| usedVars t'
 66| Subtype(var,t) -> var |>Set.add<| usedVars t
 67| Sig(var,t,t',_) -> var |>Set.add<| usedVars t |>Set.union<| usedVars t'
 68| TyparConstraint cons -> Set.unionMany (List.map usedConstraintVars cons)
 69let rec usedVars' = function
 70| Param i -> Set.singleton i;
 71| Complex(tag, l) -> Set.unionMany (List.map usedVars' l)
 72
 73type Env = list<Typar * Typ>
 74let both f (x,y) = (f x, f y)
 75let guard b f = if b then f () else None
 76(* Find most general unifier (if any) for two types 
 77for example, make sure that
 78list<'a> -> int <=> list<list<'a>> -> int
 79't <=> ('a -> 'b)
 80't <=> ('a * 'b)
 81but
 82not ('t `mgu`
 83*)
 84let (<=>) t1 t2 =
 85  let rec mgu subs = function
 86  | [] -> Some subs
 87  | (Complex(tag1,l1),Complex(tag2,l2))::rest ->
 88       if tag1 <> tag2 then
 89         None
 90       else
 91         let rec loop r = function
 92         | [],[] -> mgu subs r
 93         | [],_ | _,[] -> None
 94         | x::xs, y::ys -> loop ((x,y)::r) (xs,ys)
 95         loop rest (l1,l2)
 96  | (Param i, Param j)::rest when i = j -> mgu subs rest
 97  | ((Param i, x) | (x, Param i))::rest ->
 98       if (Set.contains i (usedVars' x)) then
 99         None (* type would be infinite when unifying *)
100       else
101         mgu ((i,x)::subs) (rest |> List.map (fun (t1,t2) -> (subst' i x t1, subst' i x t2)))
102  let rec mgu' (subs : Env) rest = function
103  // Note: subs is unneeded here because tyvar substitutions happen immediately
104  // MAYBE you only need subs with backtracking
105  // or MAYBE it would be more elegant to use it to look up substitutions each time
106  | (Arrow l1, Arrow l2) ->
107    // this version is less efficient than the previous version because it fully traverses
108    // both lists twice. But it's a lot easier to understand.
109    guard (List.length l1 = List.length l2)
110      (fun _ -> Some ([], List.zip l1 l2 @ rest))
111  | (Tuple l1, Tuple l2) ->
112    guard (List.length l1 <> List.length l2)
113      (fun _ -> Some ([], List.zip l1 l2 @ rest))
114  | (Var (Normal i), Var (Normal j)) when i = j -> Some([],rest)
115  | (Var (Structural i), Var (Structural j)) when i = j -> Some([],rest)
116  | ((Var Anonymous, Var _) | (Var _, Var Anonymous)) -> Some([],rest)
117  | ((Var i, t) | (t, (Var i))) ->
118    guard (usedVars t |>(Set.contains<| i)) // Infinite type if unified
119      (fun _ -> Some([(i,t)], (rest |> List.map (both (subst i t)))))
120  | (Id i, Id j) when i = j -> Some([],rest)
121  // optional args are treated same as others for now
122  | (NamedArg (i,t,opt), NamedArg (j,t',opt')) -> Some([],(t,t')::rest)
123  | (Generic(t,args),Generic(t',args')) when List.length args = List.length args' -> 
124    Some([], (t,t')::List.zip args args')
125  | (Array(n,t),Array(n',t')) when n = n' -> Some([],(t,t')::rest)
126  // still have to handle (w,w') somehow, probably need another function for that
127  | (Constraint(w,t),Constraint(w',t')) -> Some([],(t,t')::rest)
128  | _ -> None // avoid blue lines for now...
129  let rec mgu'' (subs : Env) = function
130  | [] -> Some subs
131  | (t::ts) -> 
132    match mgu' subs ts t with
133    | None -> None
134    | Some(subs',ts') -> mgu'' (subs' @ subs) ts'
135    
136  // TODO: Finish this!
137  mgu'' [] [(t1,t2)]
138
139(* finds entities in the F# library with the requested signature, modulo type parameter unification *)
140let find' s =
141  let ty = parse s
142  let vars = usedVars ty
143  seq {
144    for e in FSharpAssembly.FSharpLibrary.Entities do
145    for m in e.MembersOrValues do
146      (* need try/catch to avoid error on weird types like "[]`1" *)
147      match (try Some(FSharpTypes.cvt m.Type) with _ -> None) with
148      | Some ty2 ->
149        (* rename all type variables from the query to avoid incorrectly unifying with type variables in signatures *)
150        let used = usedVars ty2
151        let newVars = Seq.choose 
152                       (fun v -> 
153                         if Set.contains (Normal v) used || Set.contains (Structural v) used
154                         then Some(Var (Normal v))
155                         else None)
156                       Types.names
157        //let ty = Map.fold (fun t v p -> subst v p t) ty varMap
158        let ty = Map.foldBack subst (Map.ofSeq (Seq.zip vars newVars)) ty
159        match ty <=> ty2 with
160        | None -> ()
161        | Some _ -> yield sprintf "%s.%s.%s" e.Namespace e.DisplayName m.DisplayName 
162      | _ -> () }