diff --git a/Fixpoint.hs b/Fixpoint.hs --- a/Fixpoint.hs +++ b/Fixpoint.hs @@ -1,73 +1,11 @@ - -import Language.Fixpoint.Interface (solveFile) -import System.Environment (getArgs) --- import System.Console.GetOpt -import Language.Fixpoint.Config hiding (config) -import Data.Maybe (fromMaybe, listToMaybe) -import System.Console.CmdArgs +import Language.Fixpoint.Interface (solveFQ) +import Language.Fixpoint.Config (getOpts) +import System.Exit import System.Console.CmdArgs.Verbosity (whenLoud) -import Control.Applicative ((<$>)) -import Language.Fixpoint.Parse -import Language.Fixpoint.Types -import Text.PrettyPrint.HughesPJ - - - - - - - -main = do cfg <- getOpts +main :: IO ExitCode +main = do cfg <- getOpts whenLoud $ putStrLn $ "Options: " ++ show cfg - if (native cfg) - then solveNative (inFile cfg) - else solveFile cfg - - - -config = Config { - inFile = def &= typ "TARGET" &= args &= typFile - , outFile = "out" &= help "Output file" - , solver = def &= help "Name of SMT Solver" - , genSorts = def &= help "Generalize qualifier sorts" - , ueqAllSorts = def &= help "use UEq on all sorts" - , native = False &= help "Use (new, non-working) Haskell Solver" - , real = False &= help "Experimental support for the theory of real numbers" - } - &= verbosity - &= program "fixpoint" - &= help "Predicate Abstraction Based Horn-Clause Solver" - &= summary "fixpoint Copyright 2009-13 Regents of the University of California." - &= details [ "Predicate Abstraction Based Horn-Clause Solver" - , "" - , "To check a file foo.fq type:" - , " fixpoint foo.fq" - ] - -getOpts :: IO Config -getOpts = do md <- cmdArgs config - putStrLn $ banner md - return md - -banner args = "Liquid-Fixpoint Copyright 2009-13 Regents of the University of California.\n" - ++ "All Rights Reserved.\n" - ---------------------------------------------------------------------------------- --- Hook for Haskell Solver ------------------------------------------------------ ---------------------------------------------------------------------------------- - -solveNative file - = do str <- readFile file - let q = rr' file str :: FInfo () - res <- solveQuery q - putStrLn $ "Result: " ++ show res - error "TODO: enzo" - --------------------------------------------------------------- -solveQuery :: FInfo a -> IO (FixResult a) --------------------------------------------------------------- -solveQuery q - = do putStrLn $ "Query Was: " ++ (render $ toFixpoint q) - return Safe - -- error "TODO: Enzo" + e <- solveFQ cfg + putStrLn $ "EXIT: " ++ show e + exitWith e diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -40,7 +40,7 @@ setEnv "Z3MEM" (show z3mem) executeShellCommand "./configure" executeShellCommand "./build.sh" - executeShellCommand "chmod a+x external/fixpoint/fixpoint.native " + executeShellCommand "chmod a+x external/fixpoint/fixpoint.native" where allDirs = absoluteInstallDirs pkg lbi NoCopyDest binDir = bindir allDirs ++ "/" diff --git a/external/fixpoint/ast.ml b/external/fixpoint/ast.ml --- a/external/fixpoint/ast.ml +++ b/external/fixpoint/ast.ml @@ -238,6 +238,19 @@ let rec unifyt s = function | Num,_ | _, Num -> None +(* NIKI: Unifycation of two variables should always succeed, +but the bellow code crashes tests/zipper0.hs.fq +*) +(* + | (Var i), (Var j) -> + begin match lookup_var s i with + | Some ct -> Some {s with vars = (j,ct) :: s.vars} + | None -> begin match lookup_var s j with + | Some ct -> Some {s with vars = (i, ct) :: s.vars} + | None -> Some {s with vars = (i, Var j) :: s.vars} + end + end +*) | ct, (Var i) | (Var i), ct (* when ct != Bool *) -> @@ -318,9 +331,11 @@ let sub_args s = List.sort compare s.vars (* API *) - let check_arity n s = s.vars |>: fst |> Misc.sort_and_compact |> List.length |> (=) n - (* if ... then s else assertf "Type Inst. With Wrong Arity!" *) + let check_arity n s = + let n_vars = s.vars |>: fst |> Misc.sort_and_compact |> List.length in + n == n_vars + end module Symbol = @@ -1154,7 +1169,37 @@ end | None -> None +let checkArity f uf = function + | None -> None + | Some (s, t) -> begin match uf_arity f uf with + | Some n -> if Sort.check_arity n s then Some (s, t) else None + | _ -> None + end +let unifiable t1 t2 = + match Sort.unify [t1] [t2] with + | Some _ -> true + | _ -> false + + +(* added for sortcheck of Nothing([]) + it used to fail, as (su, Some (Just @0)) = sortcheck_expr (Nothing ([])) + but su.vars is empty + *) +let updateArity env f = function + | None -> None + | Some (su, t) -> begin match uf_arity f env with + | Some n -> + let rec go n + = if n < 0 + then [] + else match Sort.lookup_var su n with + | Some _ -> go (n-1) + | None -> (n, Sort.Var n) :: go (n-1) + in Some({su with Sort.vars = List.append su.Sort.vars (go n) }, t) + | None -> None + end + let rec sortcheck_expr g f e = match euw e with | Bot -> @@ -1172,10 +1217,14 @@ | Ite (p, e1, e2) -> if sortcheck_pred g f p then match Misc.map_pair (sortcheck_expr g f) (e1, e2) with - | (Some t1, Some t2) when t1 = t2 -> Some t1 + | (Some t1, Some t2) -> + begin + match Sort.unify [t1] [t2] with + | Some s -> Some (Sort.apply s t1) + | None -> None + end | _ -> None else None - | Cst (e1, t) -> begin match euw e1 with | App (uf, es) -> sortcheck_app g f (Some t) uf es @@ -1194,7 +1243,7 @@ and sortcheck_app_sub g f so_expected uf es = let yikes uf = F.printf "sortcheck_app_sub: unknown sym = %s \n" (Symbol.to_string uf) in sortcheck_sym f uf - |> function None -> (yikes uf; None) | Some t -> + |> function None -> (* yikes uf; *) None | Some t -> Sort.func_of_t t |> function None -> None | Some (tyArity, i_ts, o_t) -> let _ = asserts (List.length es = List.length i_ts) @@ -1214,17 +1263,19 @@ | None -> None | Some s' -> Some (s', Sort.apply s' t) -and sortcheck_app g f so_expected uf es = - sortcheck_app_sub g f so_expected uf es +and sortcheck_app g f tExp uf es = + + sortcheck_app_sub g f tExp uf es + |> updateArity uf f (* THIS CHECK IS NEW, but will it break a bunch of tests? *) |> Misc.maybe_map snd - (* >> begin function + (* + >> begin function | Some t -> Format.printf "sortcheck_app: e = %s , t = %s \n" (expr_to_string (eApp (uf, es))) (Sort.to_string t) | None -> Format.printf "sortcheck_app: e = %s FAILS\n" (expr_to_string (eApp (uf, es))) end - *) - + *) and sortcheck_op g f (e1, op, e2) = (* DEBUGGING @@ -1257,12 +1308,22 @@ when op = Minus && s = s' -> Some Sort.Int + | (Some (Sort.Var v), Some t) + | (Some t, Some (Sort.Var v)) + -> begin match Sort.unify [Sort.Var v] [t] with + | None -> None + | Some _ -> Some t (* PV: subst is lost here *) + end + | _ -> None and sortcheck_rel g f (e1, r, e2) = let t1o, t2o = (e1,e2) |> Misc.map_pair (sortcheck_expr g f) in match r, t1o, t2o with + | Ueq, Some (_), Some (_) + | Une, Some (_), Some (_) + -> true | _, Some (Sort.Ptr _) , Some (Sort.Ptr Sort.LFun) | _, Some (Sort.Ptr Sort.LFun), Some (Sort.Ptr _) -> true @@ -1274,21 +1335,18 @@ && (sortcheck_loc f l2 = Some Sort.Num)) || ((sortcheck_loc f l1 = Some Sort.Frac) && (sortcheck_loc f l2 = Some Sort.Frac)) - -> true + -> true | _ , Some Sort.Real, Some (Sort.Ptr l) | _ , Some (Sort.Ptr l), Some Sort.Real -> sortcheck_loc f l = Some Sort.Frac | Eq, Some t1, Some t2 | Ne, Some t1, Some t2 - -> t1 = t2 - | Ueq, Some (Sort.App (_,_)), Some (Sort.App (_,_)) - | Une, Some (Sort.App (_,_)), Some (Sort.App (_,_)) - -> true + -> unifiable t1 t2 | _ , Some (Sort.App (tc,_)), _ when (g tc) (* tc is an interpreted tycon *) -> false | _ , Some t1, Some t2 - -> t1 = t2 && t1 != Sort.Bool + -> unifiable t1 t2 && t1 != Sort.Bool | _ -> false and sortcheck_pred g f p = @@ -1296,8 +1354,8 @@ | True | False -> true - | Bexp e -> - sortcheck_expr g f e = Some Sort.Bool + | Bexp e -> + sortcheck_expr g f e = Some Sort.Bool | Not p -> sortcheck_pred g f p | Imp (p1, p2) | Iff (p1, p2) -> @@ -1305,7 +1363,6 @@ | And ps | Or ps -> List.for_all (sortcheck_pred g f) ps - | Atom (e1, Ueq, e2) when !Constants.ueq_all_sorts -> (not (None = sortcheck_expr g f e1)) && @@ -1316,9 +1373,9 @@ when not (!Constants.strictsortcheck) -> not (None = sortcheck_expr g f e) - | Atom (((Con _, _) as e) , Eq, (App (uf, es), _)) + | Atom (((Con _, _) as e), Eq, (App (uf, es), _)) | Atom ((App (uf, es), _), Eq, ((Con _, _) as e)) - | Atom (((Var _, _) as e) , Eq, (App (uf, es), _)) + | Atom (((Var _, _) as e), Eq, (App (uf, es), _)) | Atom ((App (uf, es), _), Eq, ((Var _, _) as e)) (* -> begin match sortcheck_sym f x with *) -> begin match sortcheck_expr g f e with @@ -1330,7 +1387,7 @@ -> let t1o = solved_app f uf1 <| sortcheck_app_sub g f None uf1 e1s in let t2o = solved_app f uf2 <| sortcheck_app_sub g f None uf2 e2s in begin match t1o, t2o with - | (Some t1, Some t2) -> t1 = t2 + | (Some t1, Some t2) -> unifiable t1 t2 | (None, None) -> false | (None, Some t2) -> not (None = sortcheck_app g f (Some t2) uf1 e1s) | (Some t1, None) -> not (None = sortcheck_app g f (Some t1) uf2 e2s) @@ -1356,6 +1413,10 @@ (* API *) let sortcheck_app g f tExp uf es = + sortcheck_app_sub g f tExp uf es + |> checkArity f uf + + (* match uf_arity f uf, sortcheck_app_sub g f tExp uf es with | (Some n, Some (s, t)) -> if Sort.check_arity n s then @@ -1371,15 +1432,14 @@ (opt_to_string Sort.to_string tExp) in assertf "%s" msg - *) + *) | _ -> None + *) -(* -let sortcheck_pred f p = - sortcheck_pred f p - >> (fun b -> ignore <| F.printf "sortcheck_pred: p = %a, res = %b\n" - Predicate.print p b) +let sortcheck_pred g f p = + sortcheck_pred g f p +(* >> (fun b -> ignore <| F.printf "DEBUG: sortcheck_pred: p = %a, res = %b\n" Predicate.print p b) *) (***************************************************************************) diff --git a/external/fixpoint/ast.mli b/external/fixpoint/ast.mli --- a/external/fixpoint/ast.mli +++ b/external/fixpoint/ast.mli @@ -1,27 +1,27 @@ (* - * Copyright © 2009 The Regents of the University of California. All rights reserved. + * Copyright © 2009 The Regents of the University of California. All rights reserved. * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS *) (** - * This module implements a DAG representation for expressions and + * This module implements a DAG representation for expressions and * predicates: each sub-predicate or sub-expression is paired with - * a unique int ID, which enables constant time hashing. + * a unique int ID, which enables constant time hashing. * However, one must take care when using DAGS: * (1) they can only be constructed using the appropriate functions * (2) when destructed via pattern-matching, one must discard the ID @@ -31,22 +31,22 @@ (********************** Base Logic ********************) (*******************************************************) -module Cone : sig +module Cone : sig type 'a t = Empty | Cone of ('a * 'a t) list val map : ('a -> 'b) -> 'a t -> 'b t end module Sort : sig - type loc = - | Loc of string + type loc = + | Loc of string | Lvar of int | LFun type tycon - type t + type t type sub - + val tycon : string -> tycon val tycon_string: tycon -> string @@ -63,19 +63,19 @@ val t_func : int -> t list -> t val t_app : tycon -> t list -> t (* val t_fptr : t *) - + val is_bool : t -> bool val is_int : t -> bool val is_real : t -> bool val is_func : t -> bool val is_kind : t -> bool - val app_of_t : t -> (tycon * t list) option + val app_of_t : t -> (tycon * t list) option val func_of_t : t -> (int * t list * t) option val ptr_of_t : t -> loc option - + val compat : t -> t -> bool val empty_sub : sub - val unifyWith : sub -> t list -> t list -> sub option + val unifyWith : sub -> t list -> t list -> sub option val unify : t list -> t list -> sub option val apply : sub -> t -> t val generalize : t list -> t list @@ -83,14 +83,14 @@ (* val check_arity : int -> sub -> bool *) end -module Symbol : - sig - type t +module Symbol : + sig + type t module SMap : FixMisc.EMapType with type key = t module SSet : FixMisc.ESetType with type elt = t - val mk_wild : unit -> t + val mk_wild : unit -> t val of_string : string -> t - val to_string : t -> string + val to_string : t -> string val is_wild_any : t -> bool val is_wild_fresh : t -> bool val is_wild : t -> bool @@ -116,20 +116,20 @@ type bop = Plus | Minus | Times | Div | Mod (* NOTE: For "Mod" 2nd expr should be a constant or a var *) -type expr = expr_int * tag +type expr = expr_int * tag and expr_int = | Con of Constant.t | Var of Symbol.t | App of Symbol.t * expr list - | Bin of expr * bop * expr + | Bin of expr * bop * expr | Ite of pred * expr * expr - | Fld of Symbol.t * expr (* NOTE: Fld (s, e) == App ("field"^s,[e]) *) - | Cst of expr * Sort.t + | Fld of Symbol.t * expr (* NOTE: Fld (s, e) == App ("field"^s,[e]) *) + | Cst of expr * Sort.t | Bot | MExp of expr list - | MBin of expr * bop list * expr - + | MBin of expr * bop list * expr + and pred = pred_int * tag and pred_int = @@ -141,7 +141,7 @@ | Imp of pred * pred | Iff of pred * pred | Bexp of expr - | Atom of expr * brel * expr + | Atom of expr * brel * expr | MAtom of expr * brel list * expr | Forall of ((Symbol.t * Sort.t) list) * pred @@ -154,8 +154,8 @@ val eModExp : expr * expr -> expr val eVar : Symbol.t -> expr val eApp : Symbol.t * expr list -> expr -val eBin : expr * bop * expr -> expr -val eMBin : expr * bop list * expr -> expr +val eBin : expr * bop * expr -> expr +val eMBin : expr * bop list * expr -> expr val eIte : pred * expr * expr -> expr val eFld : Symbol.t * expr -> expr val eCst : expr * Sort.t -> expr @@ -175,26 +175,26 @@ val pUequal : expr * expr -> pred val neg_brel : brel -> brel -module Expression : +module Expression : sig - module Hash : Hashtbl.S with type key = expr - + module Hash : Hashtbl.S with type key = expr + val print : Format.formatter -> expr -> unit val show : expr -> unit val to_string : expr -> string - + val unwrap : expr -> expr_int val support : expr -> Symbol.t list - val subst : expr -> Symbol.t -> expr -> expr - val map : (pred -> pred) -> (expr -> expr) -> expr -> expr - val iter : (pred -> unit) -> (expr -> unit) -> expr -> unit + val subst : expr -> Symbol.t -> expr -> expr + val map : (pred -> pred) -> (expr -> expr) -> expr -> expr + val iter : (pred -> unit) -> (expr -> unit) -> expr -> unit end - + module Predicate : sig - module Hash : Hashtbl.S with type key = pred - + module Hash : Hashtbl.S with type key = pred + val print : Format.formatter -> pred -> unit val show : pred -> unit val to_string : pred -> string @@ -202,13 +202,13 @@ val unwrap : pred -> pred_int val support : pred -> Symbol.t list val subst : pred -> Symbol.t -> expr -> pred - val map : (pred -> pred) -> (expr -> expr) -> pred -> pred - val iter : (pred -> unit) -> (expr -> unit) -> pred -> unit + val map : (pred -> pred) -> (expr -> expr) -> pred -> pred + val iter : (pred -> unit) -> (expr -> unit) -> pred -> unit val is_contra : pred -> bool val is_tauto : pred -> bool end -module Subst : +module Subst : sig type t val empty : t @@ -227,7 +227,7 @@ sig type pr = string * string list type gd = C of pred | K of pr - type t = pr * gd list + type t = pr * gd list val print: Format.formatter -> t -> unit val support: t -> string list end @@ -241,7 +241,7 @@ val symm_pred : pred -> pred val unify_pred : pred -> pred -> Subst.t option val substs_expr : expr -> Subst.t -> expr -val substs_pred : pred -> Subst.t -> pred +val substs_pred : pred -> Subst.t -> pred val simplify_pred : pred -> pred val conjuncts : pred -> pred list @@ -250,4 +250,3 @@ val sortcheck_app : (Sort.tycon -> bool) -> (Symbol.t -> Sort.t option) -> Sort.t option -> Symbol.t -> expr list -> (Sort.sub * Sort.t) option val into_of_expr : expr -> int option - diff --git a/external/fixpoint/fixConstraint.ml b/external/fixpoint/fixConstraint.ml --- a/external/fixpoint/fixConstraint.ml +++ b/external/fixpoint/fixConstraint.ml @@ -1,22 +1,22 @@ (* - * Copyright © 2009 The Regents of the University of California. All rights reserved. + * Copyright © 2009 The Regents of the University of California. All rights reserved. * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONSy. * *) @@ -33,7 +33,7 @@ module BS = BNstats module Su = Ast.Subst module Co = Constants -module Misc = FixMisc +module Misc = FixMisc module MSM = Misc.StringMap open Misc.Ops @@ -47,7 +47,7 @@ type envt = reft SM.t type senvt = So.t SM.t type wf = envt * reft * (id option) * (Qualifier.t -> bool) -type t = { full : envt; +type t = { full : envt; nontriv : envt; guard : A.pred; iguard : A.pred; @@ -67,8 +67,8 @@ ; kvars : Ast.Symbol.SSet.t } *) -let mydebug = false - +let mydebug = false + (***************************************************************) (*********************** Getter/Setter *************************) (***************************************************************) @@ -80,16 +80,16 @@ (* API *) -let env_of_t = fun t -> t.full -let grd_of_t = fun t -> t.guard -let lhs_of_t = fun t -> t.lhs +let env_of_t = fun t -> t.full +let grd_of_t = fun t -> t.guard +let lhs_of_t = fun t -> t.lhs let rhs_of_t = fun t -> t.rhs let tag_of_t = fun t -> t.tag let ido_of_t = fun t -> t.ido let id_of_t = fun t -> match t.ido with Some i -> i | _ -> assertf "C.id_of_t" let vv_of_t = fun t -> fst3 t.lhs let sort_of_t = fun t -> snd3 t.lhs -let senv_of_t = fun t -> SM.map snd3 t.full |> SM.add (vv_of_t t) (sort_of_t t) +let senv_of_t = fun t -> SM.map snd3 t.full |> SM.add (vv_of_t t) (sort_of_t t) (* let make_t = fun env p ((v,t,ras1) as r1) r2 io is -> @@ -97,11 +97,11 @@ let po, kras = split_ras ras1 in let ne, ps = non_trivial env in let gps = match po with Some p' -> p' :: p :: ps | _ -> p :: ps in - { full = env + { full = env ; nontriv = ne ; guard = p - ; iguard = A.pAnd gps - ; lhs = (v, t, kras) + ; iguard = A.pAnd gps + ; lhs = (v, t, kras) ; rhs = r2 ; ido = io ; tag = is } @@ -114,53 +114,53 @@ let reft_of_wf = snd4 let id_of_wf = function (_,_,Some i,_) -> i | _ -> assertf "C.id_of_wf" let filter_of_wf = fth4 - + (*************************************************************) (************************** Misc. ***************************) (*************************************************************) -let is_simple_refatom = function - | Kvar (s, _) -> Ast.Subst.is_empty s +let is_simple_refatom = function + | Kvar (s, _) -> Ast.Subst.is_empty s | _ -> false -let is_tauto_refatom = function - | Conc p -> P.is_tauto p +let is_tauto_refatom = function + | Conc p -> P.is_tauto p | _ -> false (* API *) let is_tauto = rhs_of_t <+> ras_of_reft <+> List.for_all is_tauto_refatom (* API *) -let fresh_kvar = +let fresh_kvar = let tick, _ = Misc.mk_int_factory () in tick <+> string_of_int <+> (^) "k_" <+> Sy.of_string (* API *) let kvars_of_reft (_, _, rs) = - Misc.map_partial begin function - | Kvar (subs, k) -> Some (subs,k) - | _ -> None + Misc.map_partial begin function + | Kvar (subs, k) -> Some (subs,k) + | _ -> None end rs -let meet x (v1, t1, ra1s) (v2, t2, ra2s) = - asserts (v1=v2 && t1=t2) "ERROR: FixConstraint.meet x=%s (v1=%s, t1=%s) (v2=%s, t2=%s)" +let meet x (v1, t1, ra1s) (v2, t2, ra2s) = + asserts (v1=v2 && t1=t2) "ERROR: FixConstraint.meet x=%s (v1=%s, t1=%s) (v2=%s, t2=%s)" (Sy.to_string x) (Sy.to_string v1) (A.Sort.to_string t1) (Sy.to_string v2) (A.Sort.to_string t2) ; (v1, t1, Misc.sort_and_compact (ra1s ++ ra2s)) let env_of_bindings_ meetb xrs = - List.fold_left begin fun env (x, r) -> + List.fold_left begin fun env (x, r) -> let r = if meetb && SM.mem x env then meet x r (SM.find x env) else r in SM.add x r env end SM.empty xrs (* API *) let env_of_bindings = env_of_bindings_ true -let env_of_ordered_bindings = env_of_bindings_ false +let env_of_ordered_bindings = env_of_bindings_ false -(* +(* let env_of_bindings xrs = - List.fold_left begin fun env (x, r) -> + List.fold_left begin fun env (x, r) -> let r = if SM.mem x env then meet x r (SM.find x env) else r in SM.add x r env end SM.empty xrs @@ -168,40 +168,40 @@ let bindings_of_env = SM.to_list -(* let bindings_of_env env = +(* let bindings_of_env env = SM.fold (fun x y bs -> (x,y)::bs) env [] *) -let split_ras ras = +let split_ras ras = let cras, kras = List.partition (function (Conc _) -> true | _ -> false) ras in - cras |> Misc.map_partial (function Conc p -> Some p | _ -> None) + cras |> Misc.map_partial (function Conc p -> Some p | _ -> None) |> (function [] -> (None, kras) | ps -> (Some (A.pAnd ps), kras)) -let kbindings_of_lhs {nontriv = ne; lhs = (v, t, ras)} = +let kbindings_of_lhs {nontriv = ne; lhs = (v, t, ras)} = let xkss = SM.to_list ne in let _, kras = split_ras ras in (v, (v,t,kras)) :: xkss let map_env = SM.mapi -let lookup_env = Misc.flip SM.maybe_find +let lookup_env = Misc.flip SM.maybe_find (* let lookup_env env x = try Some (SM.find x env) with Not_found -> None *) (* API *) -let is_simple {lhs = (_,_,ra1s); rhs = (_,_,ra2s)} = - List.for_all is_simple_refatom ra1s - && List.for_all is_simple_refatom ra2s +let is_simple {lhs = (_,_,ra1s); rhs = (_,_,ra2s)} = + List.for_all is_simple_refatom ra1s + && List.for_all is_simple_refatom ra2s && !Co.simple let is_conc_refa = function Conc p -> not (P.is_tauto p) | _ -> false (* API *) let kvars_of_t {nontriv = env; lhs = lhs; rhs = rhs} = - [lhs; rhs] + [lhs; rhs] |> SM.fold (fun _ r acc -> r :: acc) env - |> Misc.flap kvars_of_reft + |> Misc.flap kvars_of_reft @@ -210,37 +210,37 @@ (*********************** Logic Embedding *********************) (*************************************************************) -let canon_ras ras = +let canon_ras ras = match split_ras ras with | None, kras -> kras | Some p, kras -> Conc p :: kras -(* -let non_trivial env = - SM.fold begin fun x r sm -> match thd3 r with - | [] -> sm +(* +let non_trivial env = + SM.fold begin fun x r sm -> match thd3 r with + | [] -> sm | _::_ -> SM.add x r sm end env SM.empty *) -let non_trivial env = +let non_trivial env = SM.fold begin fun x (v,t,ras) ((ne, ps) as acc) -> match ras with - | [] -> acc - | _ -> let po, kras = split_ras ras in + | [] -> acc + | _ -> let po, kras = split_ras ras in let ne' = match kras with [] -> ne | _ -> SM.add x (v,t,kras) ne in let ps' = match po with None -> ps | Some p -> (P.subst p v (A.eVar x)) :: ps in ne', ps' - end env (SM.empty, []) + end env (SM.empty, []) (* API *) let make_t = fun env p r1 r2 io is -> let p = A.simplify_pred p in let ne, ps = non_trivial env in - { full = env + { full = env ; nontriv = ne ; guard = p - ; iguard = A.pAnd (p::ps) - ; lhs = r1 + ; iguard = A.pAnd (p::ps) + ; lhs = r1 ; rhs = r2 ; ido = io ; tag = is } @@ -259,34 +259,34 @@ | Kvar (su,k) -> soln_read s k |> List.map (Misc.flip A.substs_pred su) (* API *) -let preds_of_reft f (_,_,ras) = +let preds_of_reft f (_,_,ras) = Misc.flap (preds_of_refa f) ras (* API *) let meet_solution s1 s2 = fun k -> s1 k ++ s2 k (* SM.extendWith (fun _ -> (++)) *) let empty_solution = fun _ -> [] -let apply_solution_refa f ra = +let apply_solution_refa f ra = Conc (A.pAnd (preds_of_refa f ra)) (* API *) -let apply_solution f (v, t, ras) = +let apply_solution f (v, t, ras) = (v, t, List.map (apply_solution_refa f) ras) let preds_of_envt f env = SM.fold - (fun x ((vv, t, ras) as r) ps -> + (fun x ((vv, t, ras) as r) ps -> let vps = preds_of_reft f r in let xps = List.map (fun p -> P.subst p vv (A.eVar x)) vps in xps ++ ps) - env [] + env [] (* API *) -let wellformed_pred senv = +let wellformed_pred senv = A.sortcheck_pred Theories.is_interp (Misc.flip SM.maybe_find senv) (* API *) -let preds_of_lhs_nofilter f c = +let preds_of_lhs_nofilter f c = let envps = preds_of_envt f c.nontriv in let r1ps = preds_of_reft f c.lhs in (c.iguard :: envps) ++ r1ps @@ -294,27 +294,35 @@ (* let preds_of_lhs f c = let env = SM.add (fst3 c.lhs) c.lhs c.full in - let wfp p = wellformed_pred env p + let wfp p = wellformed_pred env p >> (fun b -> if not b then F.eprintf "WARNING: Malformed Lhs Pred (%a)\n" P.print p) in let ps = preds_of_lhs_nofilter f c in let ps' = List.filter wfp ps in - if !Co.strictsortcheck && List.length ps != List.length ps' + if !Co.strictsortcheck && List.length ps != List.length ps' then raise (BadConstraint (Misc.maybe c.ido, c.tag, "Malformed Lhs Pred")) else ps *) -let report_wellformed senv c p wf = +let pred_context senv p = + P.support p + |> List.filter (fun x -> SM.mem x senv) + |> List.map (fun x -> (x, SM.find x senv)) + + +let report_wellformed senv c p wf = if not wf then - let msg = F.sprintf "WARNING: Malformed Lhs Pred (%s)\n" (P.to_string p) in - let _ = F.eprintf "%s" msg in - let _ = SM.iter (fun s t -> F.eprintf "@[%a :: %a@]@." Sy.print s So.print t) senv in - let _ = F.eprintf "@[%a@]@.@." P.print p in + let msg = F.sprintf "WARNING: Malformed Lhs Pred (%s)\n" (P.to_string p) in + let _ = F.eprintf "%s" msg in + let _ = pred_context senv p + |> List.iter (fun (s,t) -> F.eprintf "@[%a :: %a@]@." Sy.print s So.print t) in + let _ = F.eprintf "@[%a@]@.@." P.print p in if !Co.strictsortcheck then raise (BadConstraint (Misc.maybe c.ido, c.tag, msg)) (* API *) -let preds_of_lhs f c = +let preds_of_lhs f c = let senv = senv_of_t c in (* SM.add (fst3 c.lhs) c.lhs c.full in *) - preds_of_lhs_nofilter f c + preds_of_lhs_nofilter f c + |> Misc.flap A.conjuncts |> List.filter (fun p -> wellformed_pred senv p >> report_wellformed senv c p) (* API *) @@ -332,24 +340,24 @@ (* (* API *) -let print_ras so ppf = function +let print_ras so ppf = function | [] -> F.fprintf ppf "true" - | ras -> begin match so with + | ras -> begin match so with | None -> - F.fprintf ppf "%a" (Misc.pprint_many_box false "" "; " "" print_refineatom) ras + F.fprintf ppf "%a" (Misc.pprint_many_box false "" "; " "" print_refineatom) ras | Some s -> let ps = Misc.flap (preds_of_refa s) ras in - (match ps with - | [] -> F.fprintf ppf "[]" + (match ps with + | [] -> F.fprintf ppf "[]" | _ -> F.fprintf ppf "%a" P.print (A.pAnd ps)) end *) (* API *) let print_ras so ppf ras = match so with - | None -> + | None -> Misc.pprint_many_box false "[" "; " "]" print_refineatom ppf ras - | Some s -> - begin match Misc.flap (preds_of_refa s) ras with + | Some s -> + begin match Misc.flap (preds_of_refa s) ras with | [] -> F.fprintf ppf "[]" | ps -> F.fprintf ppf "[%a]" P.print (A.pAnd ps) end @@ -358,7 +366,7 @@ (* API *) let print_reft_pred so ppf (v,t,ras) = F.fprintf ppf "@[{%a:%a | %a}@]" - Sy.print v + Sy.print v Ast.Sort.print t (print_ras so) ras @@ -370,18 +378,18 @@ (* API *) let print_reft so ppf (v, t, ras) = - F.fprintf ppf "@[{%a : %a | %a}@]" - Sy.print v + F.fprintf ppf "@[{%a : %a | %a}@]" + Sy.print v Ast.Sort.print t (print_ras so) ras (* API *) -let print_binding so ppf (x, r) = - F.fprintf ppf "@[%a:%a@]" Sy.print x (print_reft so) r +let print_binding so ppf (x, r) = + F.fprintf ppf "@[%a:%a@]" Sy.print x (print_reft so) r (* API *) -let print_env so ppf env = - bindings_of_env env +let print_env so ppf env = + bindings_of_env env |> F.fprintf ppf "@[%a@]" (Misc.pprint_many_brackets true (print_binding so)) @@ -395,17 +403,17 @@ (* API *) let print_tag ppf = function | [],_ -> F.fprintf ppf "" - | is,s -> F.fprintf ppf "tag [%s] //%s" (string_of_intlist is) s + | is,s -> F.fprintf ppf "tag [%s] //%s" (string_of_intlist is) s (* API *) let print_dep ppf = function - | Adp ((t,_), (t',_)) + | Adp ((t,_), (t',_)) -> F.fprintf ppf "add_dep: [%s] => [%s]" (string_of_intlist t) (string_of_intlist t') - | Ddp ((t,_), (t',_)) + | Ddp ((t,_), (t',_)) -> F.fprintf ppf "del_dep: [%s] => [%s]" (string_of_intlist t) (string_of_intlist t') - | Ddp_s (t,_) - -> F.fprintf ppf "del_dep: [%s] => *" (string_of_intlist t) - | Ddp_t (t',_) + | Ddp_s (t,_) + -> F.fprintf ppf "del_dep: [%s] => *" (string_of_intlist t) + | Ddp_t (t',_) -> F.fprintf ppf "del_dep: * => [%s]" (string_of_intlist t') (* API *) @@ -416,46 +424,46 @@ pprint_id io let print_t so ppf c = - let env, g = if !Co.print_nontriv then c.nontriv, c.iguard else c.full, c.guard in - F.fprintf ppf + let env, g = if !Co.print_nontriv then c.nontriv, c.iguard else c.full, c.guard in + F.fprintf ppf "constraint:@. env @[%a@] @\n grd @[%a@] @\n lhs @[%a@] @\n rhs @[%a@] @\n %a %a @\n" - (print_env so) env + (print_env so) env P.print g - (print_reft so) c.lhs + (print_reft so) c.lhs (print_reft so) c.rhs pprint_id c.ido - print_tag c.tag + print_tag c.tag (* API *) let to_string = Misc.fsprintf (print_t None) -let refa_to_string = Misc.fsprintf print_refineatom +let refa_to_string = Misc.fsprintf print_refineatom let reft_to_string = Misc.fsprintf (print_reft None) -let binding_to_string = Misc.fsprintf (print_binding None) +let binding_to_string = Misc.fsprintf (print_binding None) - + let intersect_maps m1 m2 = SM.filter begin fun k elt -> SM.mem k m2 && SM.find k m2 = elt end m1 - + let intersect_wfs (e1, r1, id1, qf1) (e2, r2, id2, qf2) = let _ = assert (r1 = r2) in let env = intersect_maps e1 e2 in (env, r1, id1, fun x -> (qf1 x && qf2 x)) - -let reduce_wfs wfs = - wfs - |> Misc.groupby reft_of_wf + +let reduce_wfs wfs = + wfs + |> Misc.groupby reft_of_wf |>: (fun wfs -> List.fold_left intersect_wfs (List.hd wfs) (List.tl wfs)) (* API *) -let matches_deps ds = +let matches_deps ds = let tt = H.create 37 in let s_tt = H.create 37 in let t_tt = H.create 37 in - List.iter begin function - | Adp (t, t') + List.iter begin function + | Adp (t, t') | Ddp (t, t') -> H.add tt (t,t') () | Ddp_s t -> H.add s_tt t () | Ddp_t t' -> H.add t_tt t' () @@ -466,8 +474,8 @@ let pol_of_dep = function Adp (_,_) -> true | _ -> false (* API *) -let tags_of_dep = function - | Adp (t, t') | Ddp (t, t') -> t,t' +let tags_of_dep = function + | Adp (t, t') | Ddp (t, t') -> t,t' | _ -> assertf "tags_of_dep" (* API *) @@ -481,9 +489,9 @@ (* API *) let preds_kvars_of_reft reft = - List.fold_left begin fun (ps, ks) -> function + List.fold_left begin fun (ps, ks) -> function | Conc p -> p :: ps, ks - | Kvar (xes, kvar) -> ps, (xes, kvar) :: ks + | Kvar (xes, kvar) -> ps, (xes, kvar) :: ks end ([], []) (ras_of_reft reft) (***************************************************************************************) @@ -492,7 +500,7 @@ let theta_ra (su': Su.t) = function | Conc p -> Conc (A.substs_pred p su') - | Kvar (su, k) -> Kvar (Su.compose su su', k) + | Kvar (su, k) -> Kvar (Su.compose su su', k) (* API *) let make_reft = fun v so ras -> (v, so, List.map (theta_ra Su.empty) (canon_ras ras)) @@ -518,23 +526,23 @@ (***************************************************************) let max_id n cs = - cs |> Misc.map_partial ido_of_t + cs |> Misc.map_partial ido_of_t >> (fun ids -> asserts (Misc.distinct ids) "Duplicate Ids") |> List.fold_left max n let max_wf_id n ws = - ws |> Misc.map_partial (fun (_,_,ido,_) -> ido) + ws |> Misc.map_partial (fun (_,_,ido,_) -> ido) >> (fun ids -> asserts (Misc.distinct ids) "Duplicate WF Ids") |> List.fold_left max n (* API *) -let add_wf_ids ws = +let add_wf_ids ws = Misc.mapfold begin fun j wf -> match wf with - | (x,y,None,z) -> j+1, (x, y, Some j, z) + | (x,y,None,z) -> j+1, (x, y, Some j, z) | _ -> j, wf end ((max_wf_id 0 ws) + 1) ws |> snd - + (* API *) let add_ids n cs = Misc.mapfold begin fun j c -> match c with @@ -549,6 +557,3 @@ let idn = match i with Some i -> i | None -> (-1) in List.exists is_conc_refa ras >> (fun rv -> if rv then (asserts (List.for_all is_conc_refa ras) "is_conc_rhs: id = %d" idn)) - - - diff --git a/external/fixpoint/fixLex.mll b/external/fixpoint/fixLex.mll --- a/external/fixpoint/fixLex.mll +++ b/external/fixpoint/fixLex.mll @@ -72,7 +72,7 @@ let digit = ['0'-'9' '-'] let letdig = ['0'-'9' 'a'-'z' 'A'-'Z' '_' '@' ''' '.' '#'] -let alphlet = ['A'-'Z' 'a'-'z' '~' '_' ''' '@' ] +let alphlet = ['A'-'Z' 'a'-'z' '~' '_' ''' '@'] let capital = ['A'-'Z'] let small = ['a'-'z' '$' '_'] let ws = [' ' '\009' '\012'] @@ -107,6 +107,7 @@ | '*' { TIMES } | '/' { DIV } | '?' { QM } + | '$' { DOL } | '.' { DOT } | "not" { NOTWORD } | "tag" { TAG } diff --git a/external/fixpoint/fixParse.mly b/external/fixpoint/fixParse.mly --- a/external/fixpoint/fixParse.mly +++ b/external/fixpoint/fixParse.mly @@ -70,7 +70,7 @@ %token MINUS %token TIMES %token DIV -%token QM DOT ASGN +%token DOL QM DOT ASGN %token OBJ REAL INT NUM PTR LFUN BOOL UNINT FUNC LIT FRAC %token SRT AXM CON CST WF SOL QUL KUT BIND ADP DDP %token ENV GRD LHS RHS REF @@ -132,7 +132,7 @@ | WF COLON wf { FixConfig.Wfc $3 } | sol { FixConfig.Sol $1 } | QUL qual { FixConfig.Qul $2 } - | KUT Id { FixConfig.Kut (Sy.of_string $2) } + | KUT kvid { FixConfig.Kut $2 } | dep { FixConfig.Dep $1 } | BIND Num Id COLON reft { let (i, x, r) = ($2, Sy.of_string $3, $5) >> set_ibind @@ -395,10 +395,15 @@ refa { [$1] } | refa SEMI refasne { $1 :: $3 } ; - + +kvid: + DOL Id { Sy.of_string $2 } + | Id { Sy.of_string $1 } + ; + refa: - Id subs { C.Kvar ($2, (Sy.of_string $1)) } - | pred { C.Conc $1 } + | kvid subs { C.Kvar ($2, $1) } + | pred { C.Conc $1 } ; subs: diff --git a/external/fixpoint/fixpoint.native-i386-linux b/external/fixpoint/fixpoint.native-i386-linux Binary files a/external/fixpoint/fixpoint.native-i386-linux and b/external/fixpoint/fixpoint.native-i386-linux differ diff --git a/external/fixpoint/fixpoint.native-i686-w64-mingw32 b/external/fixpoint/fixpoint.native-i686-w64-mingw32 # file too large to diff: external/fixpoint/fixpoint.native-i686-w64-mingw32 diff --git a/external/fixpoint/fixpoint.native-x86_64-darwin b/external/fixpoint/fixpoint.native-x86_64-darwin # file too large to diff: external/fixpoint/fixpoint.native-x86_64-darwin diff --git a/external/fixpoint/fixpoint.native-x86_64-linux b/external/fixpoint/fixpoint.native-x86_64-linux # file too large to diff: external/fixpoint/fixpoint.native-x86_64-linux diff --git a/external/fixpoint/predAbs.ml b/external/fixpoint/predAbs.ml --- a/external/fixpoint/predAbs.ml +++ b/external/fixpoint/predAbs.ml @@ -1,26 +1,26 @@ (* - * Copyright © 2009 The Regents of the University of California. All rights reserved. + * Copyright © 2009 The Regents of the University of California. All rights reserved. * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. *) - + (*************************************************************) (******************** Solution Management ********************) (*************************************************************) @@ -45,23 +45,23 @@ module PH = A.Predicate.Hash module CX = Counterexample -module Misc = FixMisc +module Misc = FixMisc module IM = Misc.IntMap module IS = Misc.IntSet open Misc.Ops -let mydebug = false +let mydebug = false module Q2S = Misc.ESet (struct type t = Sy.t * Sy.t - let compare x y = compare x y + let compare x y = compare x y end) module V : Graph.Sig.COMPARABLE with type t = Sy.t = struct type t = Sy.t let hash = Sy.to_string <+> H.hash let compare = compare - let equal = (=) + let equal = (=) end @@ -84,9 +84,9 @@ *) module Id : Graph.Sig.ORDERED_TYPE_DFT with type t = unit = struct - type t = unit + type t = unit let default = () - let compare = compare + let compare = compare end module G = Graph.Persistent.Digraph.ConcreteLabeled(V)(Id) @@ -101,79 +101,79 @@ | (_, Bot) -> b1 | (NonBot x, NonBot y) -> NonBot (x ++ y) -type t = +type t = { tpc : ProverArch.prover ; m : bind SM.t ; om : (Q.t list) SM.t ; wm : (Ast.Sort.t SM.t * Ast.Symbol.t * Ast.Sort.t) SM.t ; assm : FixConstraint.soln (* invariant assumption for K, must be a fixpoint wrt constraints *) (* ; qm : Q.t SM.t *) (* map from names to qualifiers *) - ; qs : Q.t list (* list of qualifiers *) + ; qs : Q.t list (* list of qualifiers *) ; qleqs : Q2S.t (* (q1,q2) \in qleqs implies q1 => q2 *) - ; seen : IS.t (* constraint (ids) that have been "refined" once *) + ; seen : IS.t (* constraint (ids) that have been "refined" once *) (* counterexamples *) ; step : CX.step (* which iteration *) - ; ctrace : CX.ctrace - ; lifespan : CX.lifespan - + ; ctrace : CX.ctrace + ; lifespan : CX.lifespan + (* stats *) - ; stat_simple_refines : int ref - ; stat_tp_refines : int ref - ; stat_imp_queries : int ref - ; stat_valid_queries : int ref - ; stat_matches : int ref - ; stat_umatches : int ref - ; stat_unsatLHS : int ref - ; stat_emptyRHS : int ref + ; stat_simple_refines : int ref + ; stat_tp_refines : int ref + ; stat_imp_queries : int ref + ; stat_valid_queries : int ref + ; stat_matches : int ref + ; stat_umatches : int ref + ; stat_unsatLHS : int ref + ; stat_emptyRHS : int ref } -let lookup_bind k m = SM.find_default Bot k m +let lookup_bind k m = SM.find_default Bot k m let pprint_ps = - Misc.pprint_many false ";" P.print - -let pprint_dep ppf q = + Misc.pprint_many false ";" P.print + +let pprint_dep ppf q = F.fprintf ppf "(%a, %a)" P.print (Q.pred_of_t q) Q.print_args q -let pprint_ds = +let pprint_ds = Misc.pprint_many false ";" pprint_dep -let pprint_bind ppf = function +let pprint_bind ppf = function | Bot -> F.fprintf ppf "(false, BOT())" | NonBot qs -> pprint_ds ppf qs -let pprint_qs ppf = +let pprint_qs ppf = F.fprintf ppf "[%a]" (Misc.pprint_many false ";" Q.print) -let pprint_qs' ppf = - List.map (fst <+> snd <+> snd <+> fst) <+> pprint_qs ppf +let pprint_qs' ppf = + List.map (fst <+> snd <+> snd <+> fst) <+> pprint_qs ppf (*************************************************************) (************* Breadcrumbs for Cex Generation ****************) (*************************************************************) -let cx_iter c me = - { me with step = me.step + 1 } +let cx_iter c me = + { me with step = me.step + 1 } -let cx_ctrace b c me = - let _ = if mydebug then F.printf "\nPredAbs.refine iter = %d cid = %d b = %b\n" +let cx_ctrace b c me = + let _ = if mydebug then F.printf "\nPredAbs.refine iter = %d cid = %d b = %b\n" me.step (C.id_of_t c) b in if b then { me with ctrace = IM.adds (C.id_of_t c) [me.step] me.ctrace } else me -let lookup_qualifiers k m = - lookup_bind k m +let lookup_qualifiers k m = + lookup_bind k m |> function | Bot -> [] | NonBot qs -> qs -let cx_update ks kqsm' me : t = - List.fold_left begin fun me k -> +let cx_update ks kqsm' me : t = + List.fold_left begin fun me k -> let qs = QS.of_list (lookup_qualifiers k me.m) in let qs' = QS.of_list (SM.finds k kqsm') in let kills = QS.elements (QS.diff qs qs') in - if Misc.nonnull kills + if Misc.nonnull kills then {me with lifespan = SM.adds k [(me.step, kills)] me.lifespan} else me end me ks @@ -191,21 +191,21 @@ | None -> assertf "ERROR: unify q=%s p=%s" (P.to_string qp) (P.to_string p) let map_of_bindings bs = - List.fold_left begin fun s (k, ds) -> - ds |> List.map Misc.single + List.fold_left begin fun s (k, ds) -> + ds |> List.map Misc.single |> Misc.flip (SM.add k) s - end SM.empty bs + end SM.empty bs *) let quals_of_bindings bm = - bm |> SM.range + bm |> SM.range |> Misc.flatten (* |> Misc.map (snd <+> fst) *) |> Misc.sort_and_compact >> (fun qs -> Co.bprintf mydebug "Quals of Bindings: \n%a" (Misc.pprint_many true "\n" Q.print) qs; flush stdout) (************************************************************************) -(*************************** Dumping to Dot *****************************) +(*************************** Dumping to Dot *****************************) (************************************************************************) module DotGraph = struct @@ -216,33 +216,33 @@ let iter_edges_e = G.iter_edges_e let graph_attributes = fun _ -> [`Size (11.0, 8.5); `Ratio (`Fill (* Float 1.29*))] let default_vertex_attributes = fun _ -> [`Shape `Box] - let vertex_name = Sy.to_string - let vertex_attributes = fun q -> [`Label (Sy.to_string q)] + let vertex_name = Sy.to_string + let vertex_attributes = fun q -> [`Label (Sy.to_string q)] let default_edge_attributes = fun _ -> [] - let edge_attributes = fun (_,(),_) -> [] + let edge_attributes = fun (_,(),_) -> [] let get_subgraph = fun _ -> None end -module Dot = Graph.Graphviz.Dot(DotGraph) +module Dot = Graph.Graphviz.Dot(DotGraph) -let dump_graph s g = - s |> open_out +let dump_graph s g = + s |> open_out >> (fun oc -> Dot.output_graph oc g) - |> close_out + |> close_out (* INV: qs' \subseteq qs *) let update m k ds' = - let n' = List.length ds' in - let n = match SM.find_default Bot k m with - | Bot -> 1 + n' + let n' = List.length ds' in + let n = match SM.find_default Bot k m with + | Bot -> 1 + n' | NonBot qs -> List.length qs in - let _ = asserts (n = 0 || n' <= n) "PredAbs.update: Non-monotone k = %s |ds| = %d |ds'| = %d \n" (Sy.to_string k) n n' in + let _ = asserts (n = 0 || n' <= n) "PredAbs.update: Non-monotone k = %s |ds| = %d |ds'| = %d \n" (Sy.to_string k) n n' in ((n != n'), SM.add k (NonBot ds') m) - (* >> begin fun _ -> - if n' > n && n > 0 then - Co.bprintflush mydebug <| Printf.sprintf "OMFG: update k = %s |ds| = %d |ds'| = %d \n" + (* >> begin fun _ -> + if n' > n && n > 0 then + Co.bprintflush mydebug <| Printf.sprintf "OMFG: update k = %s |ds| = %d |ds'| = %d \n" (Sy.to_string k) n n' end *) @@ -252,31 +252,31 @@ * a "k-q" binding is ONLY preserved IF #bindings = #copies-of-k * If there are NO duplicate KVars there SHOULD BE no duplicate k-q pairs. *) -let group_ks_kqs ks kqs = - if (Misc.cardinality ks = List.length ks) then - kqs (* no duplicate kvars *) - else +let group_ks_kqs ks kqs = + if (Misc.cardinality ks = List.length ks) then + kqs (* no duplicate kvars *) + else let km = SM.frequency ks in - kqs |> Misc.frequency + kqs |> Misc.frequency |> Misc.filter (fun ((k, _), n) -> n = SM.find_default 0 k km) - |> Misc.map fst + |> Misc.map fst -let p_update me ks kqs = +let p_update me ks kqs = (* let _ = Co.bprintflush mydebug (Printf.sprintf "p_update A: |kqs| = %d \n" (List.length kqs)) in *) let kqs = group_ks_kqs ks kqs in (* let _ = Co.bprintflush mydebug (Printf.sprintf "p_update B: |kqs| = %d \n" (List.length kqs)) in *) let kqsm = SM.of_alist kqs in - let me = me |> (!Co.cex BS.time "cx_update" (cx_update ks) kqsm) in + let me = me |> (!Co.cex BS.time "cx_update" (cx_update ks) kqsm) in List.fold_left begin fun (b, m) k -> - SM.finds k kqsm - |> update m k + SM.finds k kqsm + |> update m k |> Misc.app_fst ((||) b) end (false, me.m) ks - |> Misc.app_snd (fun m -> { me with m = m }) + |> Misc.app_snd (fun m -> { me with m = m }) (* API *) -let top s ks = +let top s ks = ks (* |> List.partition (fun k -> SM.mem k s.m) >> (fun (_, badks) -> Co.bprintf mydebug "WARNING: Trueing Unbound KVars = %s \n" (Misc.fsprintf (Misc.pprint_many false "," Sy.print) badks)) |> fst *) @@ -309,7 +309,7 @@ (* DEBUG ONLY *) let print_param ppf (x, t) = - F.fprintf ppf "%a:%a" Sy.print x Ast.Sort.print t + F.fprintf ppf "%a:%a" Sy.print x Ast.Sort.print t let print_params ppf args = F.fprintf ppf "%a" (Misc.pprint_many false ", " print_param) args let print_valid_binding ppf (x,y) = @@ -317,8 +317,8 @@ let print_valid_bindings ppf xys = F.printf "[%a]" (Misc.pprint_many false "" print_valid_binding) xys -(* -let dupfree_binding xys : bool = +(* +let dupfree_binding xys : bool = let ys = List.map snd xys in let ys' = Misc.sort_and_compact ys in List.length ys = List.length ys' @@ -326,7 +326,7 @@ let varmatch_ctr = ref 0 -let varmatch (x, y) = +let varmatch (x, y) = let _ = varmatch_ctr += 1 in let (x,y) = Misc.map_pair Sy.to_string (x,y) in if x.[0] = '@' then @@ -336,8 +336,8 @@ let sort_compat t1 t2 = A.Sort.unify [t1] [t2] <> None -let wellformed_qual f q = - Q.pred_of_t q +let wellformed_qual f q = + Q.pred_of_t q |> A.sortcheck_pred Theories.is_interp f (* >> (F.printf "\nwellformed: id = %d q = @[%a@] result %b\n" (C.id_of_wf wf) Q.print q) *) (* NEVER uncomment out the above. *) @@ -346,62 +346,62 @@ (**************** Lazy Instantiation: WF-Index *****************) (***************************************************************) -let kvars_of_wf wf = +let kvars_of_wf wf = let check_trivial su = asserts (Su.is_empty su) "non-trivial substitution in WF constraint!" in - wf |> C.reft_of_wf - |> C.kvars_of_reft + wf |> C.reft_of_wf + |> C.kvars_of_reft >> List.iter (fst <+> check_trivial) |> List.map snd -let meet_wf_index k = function - | (Some (env, v, t), (env', (v', t', _))) when (v=v' && t=t') -> +let meet_wf_index k = function + | (Some (env, v, t), (env', (v', t', _))) when (v=v' && t=t') -> env |> SM.filter (fun x _ -> SM.mem x env') |> (fun env' -> (env', v, t)) - | (None, (env, (v, t, _))) -> + | (None, (env, (v, t, _))) -> (env, v, t) - | _ -> + | _ -> assertf "Conflicting v,t for WF %s" (Sy.to_string k) -let upds_wf_index z wm ks = - List.fold_left begin fun wm k -> +let upds_wf_index z wm ks = + List.fold_left begin fun wm k -> SM.add k (meet_wf_index k (SM.maybe_find k wm, z)) wm end wm ks (* API *) let valid_after_substitution f su y = - Su.apply su y + Su.apply su y |> (function None -> [y] | Some ye -> E.support ye) - |> List.for_all f + |> List.for_all f -let kvars_of_bind (x, r) = +let kvars_of_bind (x, r) = let xv = (C.vv_of_reft r, A.eVar x) in C.kvars_of_reft r |>: (fun (su, k) -> (Su.extend su xv, k)) let kvars_of_c c = - (C.kvars_of_reft <| C.rhs_of_t c) ++ + (C.kvars_of_reft <| C.rhs_of_t c) ++ (Misc.flap kvars_of_bind <| C.kbindings_of_lhs c) (* MORE DEBUG NOISE -- NEVER DELETE! *) let pp_ikxts i k xts = F.printf "\n refine_wf_index removes at id = %d, k = %a, xs = %a\n" i Sy.print k - (Misc.pprint_many false ", " Sy.print) (List.map fst xts) - -let refine_wf_index wm c = + (Misc.pprint_many false ", " Sy.print) (List.map fst xts) + +let refine_wf_index wm c = let senv = C.senv_of_t c in let ok z = SM.mem z senv in let ksus = kvars_of_c c in (* [(su, k)] *) List.fold_left begin fun wm (su, k) -> let (xts, v, t) = SM.safeFind k wm "refine_wf_index" in let (xts', dts) = Misc.tr_partition begin fun (x,t) -> A.Sort.is_kind t || - valid_after_substitution ok su x - end xts + valid_after_substitution ok su x + end xts in SM.add k (xts', v, t) wm - (* let xts' = Misc.filter (fun (x,t) -> A.Sort.is_kind t || valid_after_substitution ok su x) xts in - let _ = pp k xts; pp k xts' in - let _ = pp_ikxts (C.id_of_t c) k dts in + (* let xts' = Misc.filter (fun (x,t) -> A.Sort.is_kind t || valid_after_substitution ok su x) xts in + let _ = pp k xts; pp k xts' in + let _ = pp_ikxts (C.id_of_t c) k dts in *) end wm ksus -let create_wf_index_basic ws = +let create_wf_index_basic ws = List.fold_left begin fun wm w -> let env = SM.map C.sort_of_reft <| C.env_of_wf w in let r = C.reft_of_wf w in @@ -424,7 +424,7 @@ type qual_binding = (Sy.t * Sy.t) list -let is_valid_binding (xys : qual_binding) : bool = +let is_valid_binding (xys : qual_binding) : bool = List.for_all varmatch xys let valid_bindings ys (x,_) = @@ -440,7 +440,7 @@ xts (* >> F.printf "\n\ninst_qual: params q = %a: %a" Q.print q print_params *) |> List.map (valid_bindings ys) (* candidate bindings *) - |> Misc.product (* generate combinations *) + |> Misc.product (* generate combinations *) (* >> (List.iter (F.printf "\ninst_qual: pre-binds = %a\n" print_valid_bindings)) *) |> List.filter is_valid_binding (* remove bogus bindings *) (* >> (List.iter (F.printf "\ninst_qual: post-binds = %a\n" print_valid_bindings)) *) @@ -448,17 +448,17 @@ |> List.rev_map (fun xes -> Q.inst q (vve::xes)) (* quals *) (* >> (F.printf "\n\ninst_qual: result q = %a:\n%a DONE\n" Q.print q (Misc.pprint_many true "" Q.print)) *) -let inst_binds env = - env |> SM.to_list +let inst_binds env = + env |> SM.to_list |> Misc.filter (not <.> A.Sort.is_func <.> snd) -let inst_ext env vv t qs = +let inst_ext env vv t qs = let _ = Misc.display_tick () in let ys = inst_binds env |>: fst in let env' = Misc.flip SM.maybe_find (SM.add vv t env) in qs |> List.filter (Q.sort_of_t <+> sort_compat t) |> Misc.flap (inst_qual env ys (A.eVar vv)) - |> Misc.filter (wellformed_qual env') + |> Misc.filter (wellformed_qual env') (********************************************************************************) (****** Sort Based Qualifier Instantiation **************************************) @@ -472,24 +472,24 @@ let ext_bindings yts wkl (x, tx) = let yts = List.filter (fun (y,_) -> varmatch (x, y)) yts in Misc.tr_rev_flap (fun (su, xys) -> - Misc.map_partial (fun (y, ty) -> + Misc.map_partial (fun (y, ty) -> match A.Sort.unifyWith su [tx] [ty] with | None -> None | Some su' -> Some (su', (x,y) :: xys) ) yts - ) wkl + ) wkl -let inst_qual_sorted yts vv t q = +let inst_qual_sorted yts vv t q = let (qvv0, t0) :: xts = Q.all_params_of_t q in - match A.Sort.unify [t0] [t] with - | Some su0 -> + match A.Sort.unify [t0] [t] with + | Some su0 -> xts |> List.fold_left (ext_bindings yts) [(su0, [(qvv0, vv)])] (* generate subs-bindings *) |> List.rev_map (List.rev <.> snd) (* extract sorted bindings *) |> List.rev_map (List.map (Misc.app_snd A.eVar)) (* instantiations *) |> List.rev_map (Q.inst q) (* quals *) - | None -> [] + | None -> [] -let inst_ext_sorted env vv t qs = +let inst_ext_sorted env vv t qs = let _ = Misc.display_tick () in let yts = inst_binds env in Misc.flap (inst_qual_sorted yts vv t) qs @@ -501,12 +501,12 @@ let inst_ext qs ckEnv env v t : Q.t list = let instf = if !Co.sorted_quals then inst_ext_sorted else inst_ext in let env' = Misc.flip SM.maybe_find (SM.add v t ckEnv) in - qs |> instf env v t - |> Misc.filter (wellformed_qual env') + qs |> instf env v t + |> Misc.filter (wellformed_qual env') - + (* -let is_non_trivial_var me lps su = +let is_non_trivial_var me lps su = let cxs = SS.of_list <| Misc.flap P.support lps in let ok z = SS.mem z cxs in fun y _ -> valid_after_substitution ok su y @@ -519,9 +519,9 @@ (* RJ: DO NOT DELETE EVER! *) -let ppBinding k zs = - F.printf "ppBind %a := %a \n" - Sy.print k +let ppBinding k zs = + F.printf "ppBind %a := %a \n" + Sy.print k (Misc.pprint_many false ", " Q.print) zs (* API *) @@ -532,17 +532,17 @@ (* >> ppBinding k *) |> ((++) (SM.find_default [] k me.om)) - + (***************************************************************) (**************** Refinement ***********************************) (***************************************************************) (*** {{{ KEEP AROUND FOR DEBUG PRINTING SIGH. let rhs_cands me = function - | C.Kvar (su, k) -> - k + | C.Kvar (su, k) -> + k (* >> (fun k -> Co.bprintflush mydebug ("rhs_cands: k = "^(Sy.to_string k)^"\n")) *) - |> p_read me + |> p_read me (* >> (fun xs -> Co.bprintflush mydebug ("rhs_cands: size="^(string_of_int (List.length xs))^" BEGIN \n")) *) |>: (Misc.app_snd (Misc.flip A.substs_pred su)) (* >> (fun xs -> Co.bprintflush mydebug ("rhs_cands: size="^(string_of_int (List.length xs))^" DONE\n")) *) @@ -557,10 +557,10 @@ List.exists begin function C.Conc _ -> false | C.Kvar (_,k) -> (bind_read me k = Bot) end ras - + let is_bot_lhs me c = - C.kbindings_of_lhs c - |>: snd + C.kbindings_of_lhs c + |>: snd |> List.exists (is_bot_reft me) let is_bot_rhs me c = @@ -572,40 +572,40 @@ ((k, q), qp') let quals_of_bind me c lhs k su = function - | NonBot qs -> + | NonBot qs -> (qs, me) - | Bot -> + | Bot -> let qs = lazy_instantiate_with me c lhs k su in let (_, me) = p_update me [k] (qs |>: (fun q -> (k,q))) in (qs, me) (* only called when ALL RHS k are NONBOT *) let rhs_cands_noinst me = function - | C.Kvar (su, k) -> begin match bind_read me k with - | Bot -> assertf "rhs_cands_noinst" + | C.Kvar (su, k) -> begin match bind_read me k with + | Bot -> assertf "rhs_cands_noinst" | NonBot qs -> qs |>: make_cand k su end | _ -> [] let rhs_cands_noinst me c = c |> C.rhs_of_t - |> thd3 + |> thd3 |> BS.time "rhs_cands" (Misc.flap (rhs_cands_noinst me)) (* only called when SOME RHS k is BOT *) let rhs_cands_inst c lhs me = function - | C.Conc _ -> + | C.Conc _ -> (me, []) - | C.Kvar (su, k) -> - let (qs, me) = SM.safeFind k me.m "rhs_cands" |> quals_of_bind me c lhs k su in + | C.Kvar (su, k) -> + let (qs, me) = SM.safeFind k me.m "rhs_cands" |> quals_of_bind me c lhs k su in (me, qs |>: make_cand k su) let rhs_cands_inst me c lps = let (_, _, ras) = C.rhs_of_t c in - let (me, zs) = Misc.mapfold (rhs_cands_inst c lps) me ras in + let (me, zs) = Misc.mapfold (rhs_cands_inst c lps) me ras in (Misc.flatten zs, me) -let lhs_preds me c = +let lhs_preds me c = let lps = BS.time "preds_of_lhs" (C.preds_of_lhs (read me)) c in (lps, me) @@ -615,39 +615,39 @@ let senv = C.senv_of_t c in let rcs = Misc.filter (fun (_,p) -> C.wellformed_pred senv p) rcs in (true, me, lps, rcs) - -let refine_sort_first_time me c = + +let refine_sort_first_time me c = let (lps, me) = lhs_preds me c in - let rcs = rhs_cands_noinst me c in + let rcs = rhs_cands_noinst me c in let senv = C.senv_of_t c in let rcs' = Misc.filter (fun (_,p) -> C.wellformed_pred senv p) rcs in (List.length rcs != List.length rcs', me, lps, rcs') -let refine_sort_default me c = - let (lps, me) = lhs_preds me c in - let rcs = rhs_cands_noinst me c in +let refine_sort_default me c = + let (lps, me) = lhs_preds me c in + let rcs = rhs_cands_noinst me c in (false, me, lps, rcs) -let refine_sort me c = - if is_bot_rhs me c then +let refine_sort me c = + if is_bot_rhs me c then refine_sort_bot_rhs me c else if not (IS.mem (C.id_of_t c) (me.seen)) then - refine_sort_first_time me c - else + refine_sort_first_time me c + else refine_sort_default me c -let is_trivial_rhs me c = - let is_trivial_refa me = function - | C.Conc _ -> true - | C.Kvar (_,k) -> bind_read me k = NonBot [] - in +let is_trivial_rhs me c = + let is_trivial_refa me = function + | C.Conc _ -> true + | C.Kvar (_,k) -> bind_read me k = NonBot [] + in C.rhs_of_t c - |> C.ras_of_reft - |> List.for_all (is_trivial_refa me) + |> C.ras_of_reft + |> List.for_all (is_trivial_refa me) let is_trivial_c me c = is_bot_lhs me c || is_trivial_rhs me c -let refine_match me lps rcs = +let refine_match me lps rcs = let lt = PH.create 17 in let _ = List.iter (fun p -> PH.add lt p ()) lps in let (x1,x2) = List.partition (fun (_,p) -> PH.mem lt p) rcs in @@ -658,7 +658,7 @@ me.tpc#set_filter env vv lps rcs >> (fun _ -> me.stat_tp_refines += 1) >> (fun _ -> me.stat_imp_queries += List.length rcs) - >> (fun rv -> me.stat_valid_queries += List.length rv) + >> (fun rv -> me.stat_valid_queries += List.length rv) let refine_tp me c lps x2 = if C.is_simple c then @@ -669,9 +669,9 @@ let t = C.sort_of_t c in BS.time "check tp" (check_tp me senv vv t lps) x2 -let refine me c = - if is_trivial_c me c then - (false, me) +let refine me c = + if is_trivial_c me c then + (false, me) else let (ch, me, lps, rcs) = refine_sort me c in if BS.time "lhs_contra" (List.exists P.is_contra) lps then @@ -690,7 +690,7 @@ let (ch, me) = refine me c in (ch, {me with seen = IS.add (C.id_of_t c) me.seen}) -let refine me c = +let refine me c = let me = me |> (!Co.cex cx_iter c) in let (b, me) = refine me c in let me = me |> (!Co.cex cx_ctrace b c) in @@ -702,7 +702,7 @@ (************************* Satisfaction ************************) (***************************************************************) -let unsat me c = +let unsat me c = let s = read me in let (vv,t,_) = C.lhs_of_t c in let lps = C.preds_of_lhs s c in @@ -716,7 +716,7 @@ (****************************************************************) (* -let canonize_subs = +let canonize_subs = Su.to_list <+> List.sort (fun (x,_) (y,_) -> compare x y) let subst_leq = @@ -724,40 +724,40 @@ *) let args_leq q1 q2 = - let qArgs = List.map snd <.> Q.args_of_t in + let qArgs = List.map snd <.> Q.args_of_t in try List.for_all2 (=) (qArgs q1) (qArgs q2) with _ -> false (* P(v,x,y,z) => Q(v,x) if P => Q held and _intersection_ of args match. *) -let def_leq s q1 q2 = +let def_leq s q1 q2 = Q2S.mem (Q.name_of_t q1, Q.name_of_t q2) s.qleqs && args_leq q1 q2 -let pred_of_bind_name q = +let pred_of_bind_name q = let name = q |> Q.name_of_t in let args = q |> Q.args_of_t |> List.map snd in - A.pBexp (A.eApp (name, args)) + A.pBexp (A.eApp (name, args)) -let pred_of_bind_raw = Q.pred_of_t +let pred_of_bind_raw = Q.pred_of_t -let pred_of_bind q = - if !Co.shortannots - then pred_of_bind_name q - else pred_of_bind_raw q +let pred_of_bind q = + if !Co.shortannots + then pred_of_bind_name q + else pred_of_bind_raw q -let min_binds_bot ds = +let min_binds_bot ds = match Misc.list_find_maybe (P.is_contra <.> pred_of_bind_raw) ds with | None -> ds - | Some d -> [d] + | Some d -> [d] (* API *) let min_binds s ds = ds |> min_binds_bot |> Misc.rootsBy (def_leq s) -let min_read s k = SM.find_default Bot k s.m |> function - | Bot -> [A.pFalse] +let min_read s k = SM.find_default Bot k s.m |> function + | Bot -> [A.pFalse] | NonBot qs -> qs |> min_binds s |>: pred_of_bind let min_read s k = if !Co.minquals then min_read s k else read s k let min_read s k = BS.time "min_read" (min_read s) k let close_env qs sm = - qs |> Misc.flap (Q.pred_of_t <+> P.support) + qs |> Misc.flap (Q.pred_of_t <+> P.support) |> Misc.filter (not <.> Misc.flip SM.mem sm) |> Misc.map (fun x -> (x, Ast.Sort.t_int)) |> SM.of_list @@ -771,13 +771,13 @@ |> A.substs_pred (Q.pred_of_t q') |> (fun p' -> (q', p')) -let sm_of_qual sm q = - q |> Q.all_params_of_t - |> SM.of_list +let sm_of_qual sm q = + q |> Q.all_params_of_t + |> SM.of_list |> SM.extend sm (* check_leq tp sm q qs = [q' | q' <- qs, Z3 |- q => q'] *) -let check_leq (tp : ProverArch.prover) sm (q : Q.t) (qs : Q.t list) : Q.t list = +let check_leq (tp : ProverArch.prover) sm (q : Q.t) (qs : Q.t list) : Q.t list = let vv = Q.vv_of_t q in let lps = [Q.pred_of_t q] in let sm = q |> sm_of_qual sm |> close_env qs in @@ -797,6 +797,8 @@ let wellformed_qual sm q = let sm = sm_of_qual sm q in A.sortcheck_pred Theories.is_interp (fun x -> SM.maybe_find x sm) (Q.pred_of_t q) +(* >> (fun res ->F.printf "wellformed_qual: q = %a, res = %b\n" Q.print q res) + *) let qleqs_of_qs ts sm cs ps qs = let tp = TpNull.create ts sm cs ps in @@ -804,7 +806,7 @@ |> Misc.groupby (List.map snd <.> Q.all_params_of_t) (* Q.sort_of_t *) |> Misc.flap (qimps_of_partition tp sm) |> Misc.flatten - |> Misc.map (Misc.map_pair Q.name_of_t) + |> Misc.map (Misc.map_pair Q.name_of_t) |> Q2S.of_list @@ -813,8 +815,8 @@ (*************************************************************************) let create_qleqs ts sm ps consts qs = - if !Co.minquals - then BS.time "Annots: make qleqs" (qleqs_of_qs ts sm consts ps) qs + if !Co.minquals + then BS.time "Annots: make qleqs" (qleqs_of_qs ts sm consts ps) qs else Q2S.empty let create obm cs ws ts sm ps consts assm qs bm = @@ -824,12 +826,12 @@ ; assm = assm (*; qm = qs |>: Misc.pad_fst Q.name_of_t |> SM.of_list *) ; qs = qs - ; qleqs = Misc.with_ref_at Constants.strictsortcheck false - (fun () -> create_qleqs ts sm consts ps qs) + ; qleqs = Misc.with_ref_at Constants.strictsortcheck false + (fun () -> create_qleqs ts sm consts ps qs) ; tpc = TpNull.create ts sm ps consts ; seen = IS.empty - (* Counterexamples *) + (* Counterexamples *) ; step = 0 ; ctrace = IM.empty ; lifespan = SM.empty @@ -840,7 +842,7 @@ ; stat_valid_queries = ref 0; stat_matches = ref 0 ; stat_umatches = ref 0; stat_unsatLHS = ref 0 ; stat_emptyRHS = ref 0 - } + } (***************************************************************) (****************** Sort Check Based Refinement ****************) @@ -849,15 +851,15 @@ let refts_of_c c = [ C.lhs_of_t c ; C.rhs_of_t c] ++ (C.env_of_t c |> C.bindings_of_env |>: snd) -let refine_sort_reft env me ((vv, so, ras) as r) = - let env' = SM.add vv r env in +let refine_sort_reft env me ((vv, so, ras) as r) = + let env' = SM.add vv r env in let ks = r |> C.kvars_of_reft |>: snd in (* let _ = let s = String.concat ", " (List.map Sy.to_string ks) in Co.bprintflush mydebug ("\n refine_sort_reft ks = "^s^"\n") in *) - ras + ras |> Misc.flap (rhs_cands me) (* OMFG blowup due to FLAP if kv appears multiple times...*) |> Misc.filter (fun (_, p) -> C.wellformed_pred env' p) |> List.rev_map fst -(* |> (fun xs -> Co.bprintflush mydebug (Printf.sprintf "refine_sort_reft map: size = %d\n" (List.length xs)); +(* |> (fun xs -> Co.bprintflush mydebug (Printf.sprintf "refine_sort_reft map: size = %d\n" (List.length xs)); List.rev_map fst xs) >> (fun _ -> Co.bprintflush mydebug "\n refine_sort_reft TICK 4 \n") *) @@ -868,7 +870,7 @@ let env = C.env_of_t c in c (* >> (fun _ -> Co.bprintflush mydebug ("\n refine_sort TICK 0 id = "^(string_of_int (C.id_of_t c))^"\n")) *) |> refts_of_c - |> List.fold_left (refine_sort_reft env) me + |> List.fold_left (refine_sort_reft env) me (* >> (fun _ -> Co.bprintflush mydebug "\n refine_sort TICK 2 \n") *) *) @@ -885,8 +887,8 @@ List.fold_left begin fun m k -> if not (SM.mem k fqm) then m else let false_qs = SM.safeFind k fqm "update_pruned 1" in - let qs = SM.safeFind k m "update_pruned 2" - |> List.filter (fun q -> (not (List.mem (k, q) false_qs))) + let qs = SM.safeFind k m "update_pruned 2" + |> List.filter (fun q -> (not (List.mem (k, q) false_qs))) in SM.add k qs m end me.m ks @@ -921,15 +923,15 @@ *) (* LAZYINST: map each KVAR to BOT *) -let initial_solution c = +let initial_solution c = c.Cg.ws - |> Misc.flap kvars_of_wf + |> Misc.flap kvars_of_wf |>: (fun k -> (k, Bot)) |> SM.of_list (* API *) let create c = function - | None -> + | None -> initial_solution c |> create c.Cg.bm c.Cg.cs c.Cg.ws c.Cg.ts c.Cg.uops c.Cg.ps c.Cg.cons c.Cg.assm c.Cg.qs (* LAZYINST: this is factored into the canonical env for each K @@ -937,35 +939,35 @@ |> ((!Constants.refine_sort) Misc.flip (List.fold_left refine_sort) c.Cg.cs) >> (fun _ -> Co.bprintflush mydebug "\nEND: refine_sort\n") *) - | _ -> assertf "PredAbs.create: does not support facts" + | _ -> assertf "PredAbs.create: does not support facts" (* API *) let empty () = create Cg.empty None (* API *) -let meet me you = {me with m = SM.extendWith (fun _ -> meet_bind) me.m you.m} +let meet me you = {me with m = SM.extendWith (fun _ -> meet_bind) me.m you.m} (****************************************************************) (************* Simplify Solution Using min_read *****************) (****************************************************************) -(* let minb s bs = min_binds s bs +(* let minb s bs = min_binds s bs >> Printf.printf "minBinds: [%a] \n\n" pprint_ds *) -let simplify s = { s with m = SM.map begin function - | Bot -> Bot +let simplify s = { s with m = SM.map begin function + | Bot -> Bot | NonBot qs -> NonBot (min_binds s qs) - end s.m - } + end s.m + } (************************************************************************) (****************** Counterexample Generation ***************************) (************************************************************************) - -let ctr_examples me cs ucs = - let cx = CX.create me.tpc (read me) cs me.ctrace me.lifespan in + +let ctr_examples me cs ucs = + let cx = CX.create me.tpc (read me) cs me.ctrace me.lifespan in List.map (CX.explain cx) ucs @@ -973,24 +975,24 @@ (******************************** Profile/Stats ********************************) (*******************************************************************************) -let print_m ppf s = +let print_m ppf s = SM.iter begin fun k -> function | Bot -> F.fprintf ppf "solution: %a := [%a] \n\n" Sy.print k pprint_bind Bot - | NonBot ds -> ds + | NonBot ds -> ds |> () (!Co.minquals) (min_binds s) - |> F.fprintf ppf "solution: %a := [%a] \n\n" Sy.print k pprint_ds - end s.m - -let print_qs ppf s = + |> F.fprintf ppf "solution: %a := [%a] \n\n" Sy.print k pprint_ds + end s.m + +let print_qs ppf s = s.qs >> (fun _ -> F.fprintf ppf "//QUALIFIERS \n\n") |> F.fprintf ppf "%a" (Misc.pprint_many true "\n" Q.print) -(* |> List.iter (F.fprintf ppf "%a" Q.print) *) +(* |> List.iter (F.fprintf ppf "%a" Q.print) *) |> ignore (* API *) let print ppf s = s >> print_m ppf >> print_qs ppf |> ignore - + let botInt = function | Bot -> 1 | NonBot qs -> if List.exists (Q.pred_of_t <+> P.is_contra) qs then 1 else 0 @@ -1001,19 +1003,19 @@ (* API *) let print_stats ppf me = - let (sum, max, min, bot) = + let (sum, max, min, bot) = (SM.fold (fun _ b x -> (+) x (bindSize b)) me.m 0, SM.fold (fun _ b x -> max x (bindSize b)) me.m min_int, SM.fold (fun _ b x -> min x (bindSize b)) me.m max_int, SM.fold (fun _ b x -> x + botInt b) me.m 0) in let n = SM.length me.m in let avg = (float_of_int sum) /. (float_of_int n) in - F.fprintf ppf "# Vars: (Total=%d, False=%d) Quals: (Total=%d, Avg=%f, Max=%d, Min=%d)\n" + F.fprintf ppf "# Vars: (Total=%d, False=%d) Quals: (Total=%d, Avg=%f, Max=%d, Min=%d)\n" n bot sum avg max min; F.fprintf ppf "#Iteration Profile = (si=%d tp=%d unsatLHS=%d emptyRHS=%d) \n" !(me.stat_simple_refines) !(me.stat_tp_refines) !(me.stat_unsatLHS) !(me.stat_emptyRHS); - F.fprintf ppf "#Queries: umatch=%d, match=%d, ask=%d, valid=%d\n" + F.fprintf ppf "#Queries: umatch=%d, match=%d, ask=%d, valid=%d\n" !(me.stat_umatches) !(me.stat_matches) !(me.stat_imp_queries) !(me.stat_valid_queries); me.tpc#print_stats ppf @@ -1025,8 +1027,8 @@ F.fprintf ppf "@[%a@] \n" print s; close_out oc -let key_of_quals qs = - qs |> List.map P.to_string +let key_of_quals qs = + qs |> List.map P.to_string |> List.sort compare |> String.concat "," @@ -1034,15 +1036,13 @@ let mkbind qs = assertf "PredAbs.mkBind not supported in lazyinst" (* NonBot qs *)(* Misc.flatten <+> Misc.sort_and_compact *) (* API *) -let dump s = - s.m - |> SM.to_list - |> List.map (snd <+> preds_of_bind) +let dump s = + s.m + |> SM.to_list + |> List.map (snd <+> preds_of_bind) |> Misc.groupby key_of_quals - |> List.map begin function - | [] -> assertf "impossible" + |> List.map begin function + | [] -> assertf "impossible" | (ps::_ as pss) -> Co.bprintf mydebug "SolnCluster: preds %d = size %d \n" (List.length ps) (List.length pss) end |> ignore - - diff --git a/external/fixpoint/qualifier.ml b/external/fixpoint/qualifier.ml --- a/external/fixpoint/qualifier.ml +++ b/external/fixpoint/qualifier.ml @@ -1,23 +1,23 @@ (* - * Copyright © 2009-11 The Regents of the University of California. - * All rights reserved. + * Copyright © 2009-11 The Regents of the University of California. + * All rights reserved. * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. * *) @@ -46,13 +46,13 @@ (**************************************************************************) (***************************** Qualifiers *********************************) (**************************************************************************) - -type q = { name : Sy.t + +type q = { name : Sy.t ; vvar : Sy.t ; vsort : So.t ; params : (Sy.t * So.t) list ; pred : pred - ; args : expr list option + ; args : expr list option (* when args = Some es, es = vv'::[e1;...;en] where vv' is the applied vv and e1...en are the args applied to ~A1,...,~An *) } @@ -60,7 +60,7 @@ type t = q (* to appease the functor gods. *) -let rename = fun n -> fun q -> {q with name = n} +let rename = fun n -> fun q -> {q with name = n} let name_of_t = fun q -> q.name let vv_of_t = fun q -> q.vvar let sort_of_t = fun q -> q.vsort @@ -76,23 +76,23 @@ in Misc.combine "Qualifier.args_of_t" xs es let print_param ppf (x, t) = - F.fprintf ppf "%a:%a" Sy.print x So.print t + F.fprintf ppf "%a:%a" Sy.print x So.print t let print_params ppf args = F.fprintf ppf "%a" (Misc.pprint_many false ", " print_param) args let print_args ppf q = - q |> args_of_t |> List.map snd - |> F.fprintf ppf "%a(%a)" Sy.print q.name (Misc.pprint_many false ", " E.print) - -(* API *) -let print ppf q = - F.fprintf ppf "qualif %a(%a):%a" + q |> args_of_t |> List.map snd + |> F.fprintf ppf "%a(%a)" Sy.print q.name (Misc.pprint_many false ", " E.print) + +(* API *) +let print ppf q = + F.fprintf ppf "qualif %a(%a):%a" Sy.print q.name - print_params (all_params_of_t q) + print_params (all_params_of_t q) P.print q.pred - + (**********************************************************************) (****************** Canonizing Wildcards (e.g. _ ---> ~A) *************) (**********************************************************************) @@ -103,18 +103,18 @@ let fresh = Misc.mk_string_factory "~AA" |> fst |> (fun f -> f <+> Sy.of_string <+> eVar) in let memo = Hashtbl.create 7 in function - | (Var x, _) when is_free params x && Hashtbl.mem memo x -> + | (Var x, _) when is_free params x && Hashtbl.mem memo x -> Hashtbl.find memo x | (Var x, _) when is_free params x && Sy.is_wild_fresh x -> - fresh () - | (Var x, _) when is_free params x && Sy.is_wild_any x -> - fresh () >> Hashtbl.replace memo x - | e -> e + fresh () + | (Var x, _) when is_free params x && Sy.is_wild_any x -> + fresh () >> Hashtbl.replace memo x + | e -> e (**************************************************************************) (*************** Expanding Away Sets of Ops and Rels **********************) (**************************************************************************) - + let expand_with_list f g = List.map f <+> Misc.cross_flatten <+> Misc.map g @@ -122,7 +122,7 @@ Misc.map_pair f <+> Misc.uncurry Misc.cross_product <+> Misc.map g let crunchExpr f e1s xs e2s = - List.map begin fun e1 -> + List.map begin fun e1 -> List.map begin fun e2 -> List.map begin fun x -> f (e1, x, e2) @@ -131,10 +131,10 @@ end e1s |> List.flatten |> List.flatten -let rec expand_p ((p,_) as pred) = match p with +let rec expand_p ((p,_) as pred) = match p with | And ps -> expand_ps pAnd ps | Or ps -> expand_ps pOr ps - | Not p -> expand_p p |> List.map pNot + | Not p -> expand_p p |> List.map pNot | Imp (p1,p2) -> expand_pp pImp (p1, p2) | Iff (p1,p2) -> expand_pp pIff (p1, p2) | Forall(qs, p) -> expand_p p |> List.map (fun p -> pForall (qs, p)) @@ -148,13 +148,13 @@ and expand_e ((e,_) as expr) = match e with | MExp es -> Misc.flap expand_e es | App (f, es) -> expand_es (fun es -> eApp (f, es)) es - | Bin (e1, op, e2) -> expand_ep (fun (e1,e2) -> eBin (e1, op, e2)) (e1, e2) + | Bin (e1, op, e2) -> expand_ep (fun (e1,e2) -> eBin (e1, op, e2)) (e1, e2) | MBin (e1, ops, e2) -> let e1s, e2s = Misc.map_pair expand_e (e1, e2) in crunchExpr eBin e1s ops e2s | Fld (s, e) -> expand_e e |> List.map (fun e -> eFld (s,e)) | Cst (e, t) -> expand_e e |> List.map (fun e -> eCst (e,t)) | Ite (p,e1,e2) -> let e1s, e2s = Misc.map_pair expand_e (e1, e2) in - let ps = expand_p p in + let ps = expand_p p in List.map begin fun e1 -> List.map begin fun e2 -> List.map begin fun p -> @@ -171,7 +171,7 @@ and expand_ep x = expand_with_pair expand_e x (* API *) -let expand_qual q = +let expand_qual q = expand_p q.pred |> List.map (fun p -> {q with pred = p}) @@ -179,51 +179,51 @@ (*************** Expanding Away Sets of Ops and Rels **********************) (**************************************************************************) -let make_def_deps qnames q = +let make_def_deps qnames q = let res = ref [] in - let p' : pred = P.map begin function - | Bexp (App (f, args),_), _ - when SS.mem f qnames -> res := (f, args) :: !res; pTrue - | p -> p - end id q.pred - in (q.name, !res) + let p' : pred = P.map begin function + | Bexp (App (f, args),_), _ + when SS.mem f qnames -> res := (f, args) :: !res; pTrue + | p -> p + end id q.pred + in (q.name, !res) (* >> (fun (n, xs) -> F.printf "qdep %a = %a \n" Sy.print n (Misc.pprint_many false ", " Sy.print) (List.map fst xs) ) *) -let check_def_deps qm = +let check_def_deps qm = List.iter begin fun (n, fargs) -> List.iter begin fun (f, args) -> match SM.finds f qm with - | [q] -> asserts (List.length args = 1 + List.length q.params) + | [q] -> asserts (List.length args = 1 + List.length q.params) "Malformed Qualifier: %s with incorrect application of %s" (Sy.to_string n) (Sy.to_string f) - | _::_::_ -> assertf "Malformed Qualifier: %s refers to multiply defined %s" + | _::_::_ -> assertf "Malformed Qualifier: %s refers to multiply defined %s" (Sy.to_string n) (Sy.to_string f) - | _ -> () -(* | [] -> assertf "Malformed Qualifier: %s refers to unknown %s" + | _ -> () +(* | [] -> assertf "Malformed Qualifier: %s refers to unknown %s" (Sy.to_string n) (Sy.to_string f) *) - + end fargs end -let order_by_defs qm qs = +let order_by_defs qm qs = let is = Misc.range 0 (List.length qs) in let qis = List.combine qs is in let i2q = qis |>: Misc.swap |> IM.of_list |> Misc.flip IM.find in - let i2s = i2q <+> name_of_t <+> Sy.to_string in - let n2i = qis |>: Misc.app_fst name_of_t |> SM.of_list + let i2s = i2q <+> name_of_t <+> Sy.to_string in + let n2i = qis |>: Misc.app_fst name_of_t |> SM.of_list |> (fun m n -> SM.safeFind n m "order_by_defs") in - + let qnams= qs |>: name_of_t |> SS.of_list in let deps = qs |>: make_def_deps qnams >> check_def_deps qm in - let ijs = deps |> Misc.flap (fun (n, fargs) -> fargs |>: (fun (f,_) -> (n, f))) + let ijs = deps |> Misc.flap (fun (n, fargs) -> fargs |>: (fun (f,_) -> (n, f))) |> List.map (Misc.map_pair n2i) in - let irs = Fcommon.scc_rank "qualifier-deps" i2s is ijs in - Misc.fsort snd irs + let irs = Fcommon.scc_rank "qualifier-deps" i2s is ijs in + Misc.fsort snd irs |>: (fst <+> i2q) (* >> (F.printf "ORDERED QUALS:\n%a\n" (Misc.pprint_many true "\n" print)) *) -let expand_def qm p = match p with +let expand_def qm p = match p with | Bexp (App (f, args),_), _ -> begin match SM.finds f qm with | _::_::_ -> assertf "Ambiguous Qualifier: %s" (Sy.to_string f) @@ -235,12 +235,12 @@ | [] -> p (* assertf "Unknown Qualifier: %s" (Sy.to_string f) *) end | _ -> p - + (* this MUST precede any renaming as renaming can screw up name resolution *) -let compile_definitions qs = +let compile_definitions qs = let qm = List.fold_left (fun qm q -> SM.adds q.name [q] qm) SM.empty qs in - let qs' = order_by_defs qm qs in - List.fold_left begin fun qm q -> + let qs' = order_by_defs qm qs in + List.fold_left begin fun qm q -> let q' = {q with pred = P.map (expand_def qm) id q.pred } in SM.adds q.name [q'] qm end SM.empty qs' @@ -250,11 +250,11 @@ (************************* Normalize Qualifier Sets ***********************) (**************************************************************************) -let remove_duplicates qs = +let remove_duplicates qs = qs |> Misc.kgroupby (all_params_of_t <*> pred_of_t) |> List.map (fun (_,x::_) -> x) -let rename_qual q i = +let rename_qual q i = {q with name = Sy.suffix q.name (string_of_int i)} let uniquely_rename qs = @@ -262,26 +262,26 @@ if SM.mem q.name m then let i = SM.safeFind q.name m "uniquelyRename" in (SM.add q.name (i+1) m, rename_qual q i) - else + else (SM.add q.name 0 m, q) - end SM.empty qs + end SM.empty qs |> snd -let check_dup t q = - try +let check_dup t q = + try let q' = Hashtbl.find t q.name in if (pred_of_t q' = pred_of_t q) then () else Format.printf "WARNING: duplicate qualifiers after normalization! (q = %a) (q' = %a)" - print q + print q print q' with Not_found -> () -let qualifMap_set, qualifMap_get = +let qualifMap_set, qualifMap_get = let t = Hashtbl.create 37 in ( (fun qs -> Hashtbl.clear t; List.iter (fun q -> check_dup t q; Hashtbl.replace t q.name q) qs) - , (fun n -> try Some (Hashtbl.find t n) - with Not_found -> (Format.printf "qualifMap_get fails on %a" Sy.print n; assert false) + , (fun n -> try Some (Hashtbl.find t n) + with Not_found -> (Format.printf "qualifMap_get fails on %a" Sy.print n; assert false) ) ) @@ -294,16 +294,16 @@ |> remove_duplicates |> uniquely_rename >> qualifMap_set -(* >> (fun qs -> ticker += 1; Co.logPrintf "normalize (%d):\n%a" (!ticker) +(* >> (fun qs -> ticker += 1; Co.logPrintf "normalize (%d):\n%a" (!ticker) (Misc.pprint_many true "\n" print) qs; flush stdout) *) (* API *) -let expandPred n es = +let expandPred n es = n |> qualifMap_get |> Misc.maybe_map begin fun q -> let xs = List.map fst <| args_of_t q in - Misc.combine "expandPred" xs es - |> Ast.Subst.of_list + Misc.combine "expandPred" xs es + |> Ast.Subst.of_list |> Ast.substs_pred (pred_of_t q) end @@ -311,7 +311,7 @@ (***************************** Create ********************************) (*********************************************************************) -let generalize_sorts vts = +let generalize_sorts vts = let vs, ts = List.split vts in let ts' = So.generalize ts in List.combine vs ts' @@ -320,7 +320,7 @@ let close_params vts p = p |> P.support - |> List.filter (Sy.is_wild <&&> is_free vts) + |> List.filter (Sy.is_wild <&&> is_free vts) |> List.map (fun x -> (x, So.t_int (* t_generic 0 causes blowup? *))) |> (@) vts (* Sy.SMap.of_list *) @@ -330,26 +330,26 @@ let vts = close_params vts p in let (v,t)::vts = generalize_sorts ((v,t)::vts) in let _ = asserts (Misc.distinct vts) "Error: Q.create duplicate params %s \n" (Sy.to_string n) - in { name = n + in { name = n ; vvar = v ; vsort = t ; pred = p - ; params = vts + ; params = vts ; args = None } (* DEBUG ONLY *) let printb ppf (x, e) = - F.fprintf ppf "%a:%a" Sy.print x E.print e + F.fprintf ppf "%a:%a" Sy.print x E.print e let printbs ppf args = F.fprintf ppf "%a" (Misc.pprint_many false ", " printb) args (* API *) let inst q args = - let _ = if mydebug then F.printf "\nQ.inst with <<%a>>\n" printbs args in - let xes = try q |> all_params_of_t |> List.map (fun (x,_) -> (x, List.assoc x args)) - with Not_found -> - let _ = F.printf "Error: Q.inst with bad args %a <<%a>>" print q printbs args - in assertf "Error: Q.inst with bad args \n" + let _ = if mydebug then F.printf "\nQ.inst with <<%a>>\n" printbs args in + let xes = try q |> all_params_of_t |> List.map (fun (x,_) -> (x, List.assoc x args)) + with Not_found -> + let _ = F.printf "Error: Q.inst with bad args %a <<%a>>" print q printbs args + in assertf "Error: Q.inst with bad args \n" in let v = match xes with (_, (Var v, _)) :: _ -> v | _ -> assertf "Error: Q.inst with non-vvar arg" in let p = xes |> Su.of_list |> Ast.substs_pred q.pred in @@ -358,9 +358,8 @@ module QSet = Misc.ESet (struct type t = q - let compare q1 q2 = - if (q1.name = q2.name) - then compare q1.args q2.args - else compare q1.name q2.name + let compare q1 q2 = + if (q1.name = q2.name) + then compare q1.args q2.args + else compare q1.name q2.name end) - diff --git a/external/fixpoint/smtLIB2.ml b/external/fixpoint/smtLIB2.ml --- a/external/fixpoint/smtLIB2.ml +++ b/external/fixpoint/smtLIB2.ml @@ -45,7 +45,7 @@ let spr = Printf.sprintf -let mydebug = false +let mydebug = false let nb_unsat = ref 0 let nb_pop = ref 0 @@ -57,8 +57,8 @@ type symbol = string (* Sy.t *) type sort = string (* So.t *) -type ast = string (* E of A.expr | P of A.pred *) -type fun_decl = symbol +type ast = string (* E of A.expr | P of A.pred *) +type fun_decl = symbol type cmd = Push | Pop @@ -67,13 +67,13 @@ | AssertCnstr of ast | Distinct of ast list (* {v: ast list | (len v) >= 2} *) -type resp = Ok - | Sat - | Unsat +type resp = Ok + | Sat + | Unsat | Unknown | Error of string -type solver = Z3 | Mathsat | Cvc4 +type solver = Z3 | Mathsat | Cvc4 type context = { cin : in_channel ; cout : out_channel @@ -110,7 +110,7 @@ let sel = "smt_map_sel" let sto = "smt_map_sto" -(* +(* (define-fun smt_set_emp () Set ((as const Set) false)) (define-fun smt_set_mem ((x Elt) (s Set)) Bool (select s x)) (define-fun smt_set_add ((s Set) (x Elt)) Set (store s x true)) @@ -124,19 +124,19 @@ let (++) = List.append (* array preamble *) -let array_preamble _ = +let array_preamble _ = if not !Co.map_theory then [] else - [ spr "(define-sort %s () (Array %s %s))" - map elt elt + [ spr "(define-sort %s () (Array %s %s))" + map elt elt ; spr "(define-fun %s ((m %s) (k %s)) %s (select m k))" - sel map elt elt + sel map elt elt ; spr "(define-fun %s ((m %s) (k %s) (v %s)) %s (store m k v))" sto map elt elt map ] (* z3 specific *) -let z3_preamble _ +let z3_preamble _ = [ "(set-option :auto-config false)" ; "(set-option :model true)" ; "(set-option :model.partial false)" @@ -144,10 +144,10 @@ ] ++ if not !Co.set_theory then [] else [ spr "(define-sort %s () Int)" elt - ; spr "(define-sort %s () (Array %s Bool))" + ; spr "(define-sort %s () (Array %s Bool))" set elt - ; spr "(define-fun %s () %s ((as const %s) false))" - emp set set + ; spr "(define-fun %s () %s ((as const %s) false))" + emp set set ; spr "(define-fun %s ((x %s) (s %s)) Bool (select s x))" mem elt set ; spr "(define-fun %s ((s %s) (x %s)) %s (store s x true))" @@ -161,17 +161,17 @@ ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s (%s s1 (%s s2)))" dif set set set cap com ; spr "(define-fun %s ((s1 %s) (s2 %s)) Bool (= %s (%s s1 s2)))" - sub set set emp dif + sub set set emp dif ] ++ array_preamble () (* cvc4 specific *) -let cvc4_preamble _ +let cvc4_preamble _ = if not !Co.set_theory then [] else [ spr "(set-logic QF_AUFNIRAFS)" ; spr "(define-sort %s () Int)" elt - ; spr "(define-sort %s () (Set %s))" + ; spr "(define-sort %s () (Set %s))" set elt ; spr "(define-fun %s () %s (as emptyset (Set %s)))" emp set elt @@ -191,54 +191,54 @@ sub set set ] ++ array_preamble () -let smtlib_preamble +let smtlib_preamble = [ spr "(set-logic QF_UFLIA)" ; spr "(define-sort %s () Int)" elt - ; spr "(define-sort %s () Int)" set + ; spr "(define-sort %s () Int)" set ; spr "(declare-fun %s () %s)" emp set ; spr "(declare-fun %s (%s %s) %s)" add set elt set ; spr "(declare-fun %s (%s %s) %s)" cup set set set ; spr "(declare-fun %s (%s %s) %s)" cap set set set ; spr "(declare-fun %s (%s %s) %s)" dif set set set - ; spr "(declare-fun %s (%s %s) Bool)" sub set set - ; spr "(declare-fun %s (%s %s) Bool)" mem elt set - ; spr "(declare-fun %s (%s %s) %s)" sel map elt elt - ; spr "(declare-fun %s (%s %s %s) %s)" sto map elt elt map - - (* HIDE? - ; spr "(assert (forall ((x %s)) (not (%s x %s))))" + ; spr "(declare-fun %s (%s %s) Bool)" sub set set + ; spr "(declare-fun %s (%s %s) Bool)" mem elt set + ; spr "(declare-fun %s (%s %s) %s)" sel map elt elt + ; spr "(declare-fun %s (%s %s %s) %s)" sto map elt elt map + + (* HIDE? + ; spr "(assert (forall ((x %s)) (not (%s x %s))))" elt mem emp - ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) + ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) (= (%s x (%s s1 s2)) (or (%s x s1) (%s x s2)))))" elt set set mem cup mem mem - ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) + ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) (= (%s x (%s s1 s2)) (and (%s x s1) (%s x s2)))))" elt set set mem cap mem mem - ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) + ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) (= (%s x (%s s1 s2)) (and (%s x s1) (not (%s x s2))))))" elt set set mem dif mem mem - ; spr "(assert (forall ((x %s) (s %s) (y %s)) + ; spr "(assert (forall ((x %s) (s %s) (y %s)) (= (%s x (%s s y)) (or (%s x s) (= x y)))))" - elt set elt mem add mem + elt set elt mem add mem *) - ] + ] let mkSetSort _ _ = set let mkEmptySet _ _ = emp let mkSetAdd _ s x = spr "(%s %s %s)" add s x -let mkSetMem _ x s = spr "(%s %s %s)" mem x s +let mkSetMem _ x s = spr "(%s %s %s)" mem x s let mkSetCup _ s t = spr "(%s %s %s)" cup s t let mkSetCap _ s t = spr "(%s %s %s)" cap s t let mkSetDif _ s t = spr "(%s %s %s)" dif s t let mkSetSub _ s t = spr "(%s %s %s)" sub s t -let mkMapSort c k v = map -let mkMapSelect c m k = spr "(%s %s %s)" sel m k +let mkMapSort c k v = map +let mkMapSelect c m k = spr "(%s %s %s)" sel m k let mkMapStore c m k v = spr "(%s %s %s %s)" sto m k v -let mkSizeSort _ n = spr "%d" n -let mkBitSort _ s = spr "(_ BitVec %s)" s +let mkSizeSort _ n = spr "%d" n +let mkBitSort _ s = spr "(_ BitVec %s)" s let mkBitAnd _ x y = spr "(bvand %s %s)" x y let mkBitOr _ x y = spr "(bvor %s %s)" x y @@ -247,7 +247,7 @@ (**************** SMT IO ******************************************) (** https://raw.github.com/ravichugh/djs/master/src/zzz.ml ********) (******************************************************************) - + (* "z3 -smt2 -in" *) (* "z3 -smtc SOFT_TIMEOUT=1000 -in" *) (* "z3 -smtc -in MBQI=false" *) @@ -260,11 +260,11 @@ let smt_preamble = function | Z3 -> z3_preamble () | Cvc4 -> cvc4_preamble () - | _ -> smtlib_preamble + | _ -> smtlib_preamble -let smt_write_raw me s = - output_now me.clog s; +let smt_write_raw me s = + output_now me.clog s; output_now me.cout s (* copied from String.trim in ocaml-4.0 since mingw-ocaml uses 3.x *) @@ -289,7 +289,7 @@ "" (* strip off trailing whitespace, e.g. \r on windows.. *) -let smt_read_raw me = +let smt_read_raw me = trim (input_line me.cin) let smt_write me ?nl:(nl=true) ?tab:(tab=false) s = @@ -301,61 +301,61 @@ = match smt_read_raw me with | "sat" -> Sat | "unsat" -> Unsat - | "success" -> smt_read me + | "success" -> smt_read me | "unknown" -> Unknown | s -> Error s (* val interact : context -> cmd -> resp *) -let interact me = function - | Declare (x, ts, t) -> +let interact me = function + | Declare (x, ts, t) -> let _ = smt_write me <| spr "(declare-fun %s (%s) %s)" x (String.concat " " ts) t in - Ok - | Push -> + Ok + | Push -> let _ = smt_write me <| "(push 1)" in Ok - | Pop -> + | Pop -> let _ = smt_write me <| "(pop 1)" in Ok - | CheckSat -> + | CheckSat -> let _ = smt_write me <| "(check-sat)" in - smt_read me - | AssertCnstr a -> + smt_read me + | AssertCnstr a -> let _ = smt_write me <| spr "(assert %s)" a in Ok - | Distinct az -> + | Distinct az -> let _ = smt_write me <| spr "(assert (distinct %s))" (String.concat " " az) in Ok (* API *) -let smt_decl me x ts t +let smt_decl me x ts t = match interact me (Declare (x, ts, t)) with | Ok -> () | _ -> assertf "crash: SMTLIB2 smt_decl" (* API *) -let smt_push me +let smt_push me = match interact me Push with - | Ok -> incr nb_push; () + | Ok -> incr nb_push; () | _ -> assertf "crash: SMTLIB2 smt_push" (* API *) -let smt_pop me +let smt_pop me = match interact me Pop with - | Ok -> incr nb_pop; () + | Ok -> incr nb_pop; () | _ -> assertf "crash: SMTLIB2 smt_pop" (* API *) -let smt_check_unsat me +let smt_check_unsat me = match interact me CheckSat with | Unsat -> true | Sat -> false - | Unknown -> false + | Unknown -> false | e -> assertf "crash: SMTLIB2 smt_check_unsat %s" (respString e) (* API *) -let smt_assert_cnstr me p +let smt_assert_cnstr me p = match interact me (AssertCnstr p) with | Ok -> () | _ -> assertf "crash: SMTLIB2 smt_assert_cnstr" @@ -388,22 +388,22 @@ (***********************************************************************) let stringSymbol _ s = s -let astString _ a = a -let sortString _ s = s +let astString _ a = a +let sortString _ s = s let isBool c a = failwith "TODO:SMTLib2.isBool" let boundVar me i t = failwith "TODO:SMTLib2.boundVar" let var me x t = - let _ = smt_decl me x [] t in - x + let _ = smt_decl me x [] t in + x let funcDecl me s ta t = let _ = smt_decl me s (Array.to_list ta) t in s -let mkIntSort _ = "Int" -let mkRealSort _ = "Real" -let mkBoolSort _ = "Bool" +let mkIntSort _ = "Int" +let mkRealSort _ = "Real" +let mkBoolSort _ = "Bool" let mkInt _ i _ = if i >= 0 then string_of_int i else spr "(- %d)" (abs i) @@ -411,27 +411,27 @@ else spr "(- %s)" (string_of_float (i *. -1.0) ^ "0") let mkLit _ l _ = l - + let mkTrue _ = "true" -let mkFalse _ = "false" +let mkFalse _ = "false" let mkAll _ _ _ _ = failwith "TODO:SMTLib2.mkAll" -let mkRel _ r a1 a2 - = match r with - | A.Eq - | A.Ueq -> spr "(= %s %s)" a1 a2 - | A.Ne - | A.Une -> spr "(not (= %s %s))" a1 a2 - | A.Gt -> spr "(> %s %s)" a1 a2 - | A.Ge -> spr "(>= %s %s)" a1 a2 - | A.Lt -> spr "(< %s %s)" a1 a2 - | A.Le -> spr "(<= %s %s)" a1 a2 +let mkRel _ r a1 a2 + = match r with + | A.Eq + | A.Ueq -> spr "(= %s %s)" a1 a2 + | A.Ne + | A.Une -> spr "(not (= %s %s))" a1 a2 + | A.Gt -> spr "(> %s %s)" a1 a2 + | A.Ge -> spr "(>= %s %s)" a1 a2 + | A.Lt -> spr "(< %s %s)" a1 a2 + | A.Le -> spr "(<= %s %s)" a1 a2 let mkApp _ f = function - | [] -> f + | [] -> f | az -> spr "(%s %s)" f (String.concat " " az) let opStr = function @@ -443,30 +443,30 @@ let mkOp op a1 a2 = spr "(%s %s %s)" (opStr op) a1 a2 - -let mkMul _ = mkOp A.Times + +let mkMul _ = mkOp A.Times let mkDiv _ = mkOp A.Div let mkAdd _ = mkOp A.Plus let mkSub _ = mkOp A.Minus let mkMod _ = mkOp A.Mod -let mkIte _ a1 a2 a3 +let mkIte _ a1 a2 a3 = spr "(ite %s %s %s)" a1 a2 a3 -let mkNot _ a - = spr "(not %s)" a +let mkNot _ a + = spr "(not %s)" a -let mkAnd _ az - = spr "(and %s)" (String.concat " " az) +let mkAnd _ az + = spr "(and %s)" (String.concat " " az) -let mkOr _ az - = spr "(or %s)" (String.concat " " az) +let mkOr _ az + = spr "(or %s)" (String.concat " " az) -let mkImp _ a1 a2 - = spr "(=> %s %s)" a1 a2 +let mkImp _ a1 a2 + = spr "(=> %s %s)" a1 a2 -let mkIff _ a1 a2 - = spr "(= %s %s)" a1 a2 +let mkIff _ a1 a2 + = spr "(= %s %s)" a1 a2 (*******************************************************************) (*********************** Queries ***********************************) @@ -475,15 +475,15 @@ let us_ref = ref 0 (* API *) -let unsat me = - let _ = if mydebug then begin +let unsat me = + let _ = if mydebug then begin Printf.printf "[%d] UNSAT 1 " (us_ref += 1); flush stdout - end + end in let rv = BS.time "SMT.check_unsat" smt_check_unsat me in let _ = if mydebug then (Printf.printf "UNSAT 2 \n"; flush stdout) in - let _ = if rv then ignore (nb_unsat += 1) in + let _ = if rv then ignore (nb_unsat += 1) in rv (* API *) @@ -493,21 +493,21 @@ asserts (not (unsat me)) "ERROR: Axiom makes background theory inconsistent!" (* API *) -let assertDistinct me = function +let assertDistinct me = function | ((x1::x2::_) as az) -> smt_assert_distinct me az | _ -> () (* API *) -let bracket me f +let bracket me f = Misc.bracket (fun _ -> smt_push me) (fun _ -> smt_pop me) f (* API *) -let assertPreds me ps +let assertPreds me ps = List.iter (fun p -> BS.time "assertPreds" (smt_assert_cnstr me) p) ps (* API *) let print_stats ppf () = - F.fprintf ppf "SMT stats: pushes=%d, pops=%d, unsats=%d \n" + F.fprintf ppf "SMT stats: pushes=%d, pops=%d, unsats=%d \n" !nb_push !nb_pop !nb_unsat end diff --git a/external/fixpoint/smtZ3.ml b/external/fixpoint/smtZ3.ml --- a/external/fixpoint/smtZ3.ml +++ b/external/fixpoint/smtZ3.ml @@ -30,12 +30,12 @@ module SMTZ3 : ProverArch.SMTSOLVER = struct type context = () -type symbol = () -type sort = () -type ast = () -type fun_decl = () +type symbol = () +type sort = () +type ast = () +type fun_decl = () -let var _ = failwith msg +let var _ = failwith msg let boundVar _ = failwith msg let stringSymbol _ = failwith msg let funcDecl _ = failwith msg @@ -43,22 +43,22 @@ let isInt _ = failwith msg let mkAll _ = failwith msg let mkRel _ = failwith msg -let mkApp _ = failwith msg +let mkApp _ = failwith msg let mkMul _ = failwith msg let mkDiv _ = failwith msg let mkAdd _ = failwith msg let mkSub _ = failwith msg let mkMod _ = failwith msg let mkIte _ = failwith msg -let mkInt _ = failwith msg -let mkLit _ = failwith msg -let mkReal _ = failwith msg +let mkInt _ = failwith msg +let mkLit _ = failwith msg +let mkReal _ = failwith msg let mkTrue _ = failwith msg let mkFalse _ = failwith msg let mkNot _ = failwith msg -let mkAnd _ = failwith msg -let mkOr _ = failwith msg -let mkImp _ = failwith msg +let mkAnd _ = failwith msg +let mkOr _ = failwith msg +let mkImp _ = failwith msg let mkIff _ = failwith msg let astString _ = failwith msg let sortString _ = failwith msg @@ -81,12 +81,12 @@ let mkBitAnd _ = failwith msg let mkBitOr _ = failwith msg let mkContext _ = failwith msg -let unsat _ = failwith msg +let unsat _ = failwith msg let assertAxiom _ = failwith msg let assertDistinct _ = failwith msg let bracket _ = failwith msg let assertPreds _ = failwith msg -let valid _ = failwith msg +let valid _ = failwith msg let contra _ = failwith msg let print_stats _ = failwith msg diff --git a/external/fixpoint/smtZ3.nomem.ml b/external/fixpoint/smtZ3.nomem.ml --- a/external/fixpoint/smtZ3.nomem.ml +++ b/external/fixpoint/smtZ3.nomem.ml @@ -30,12 +30,12 @@ module SMTZ3 : ProverArch.SMTSOLVER = struct type context = () -type symbol = () -type sort = () -type ast = () -type fun_decl = () +type symbol = () +type sort = () +type ast = () +type fun_decl = () -let var _ = failwith msg +let var _ = failwith msg let boundVar _ = failwith msg let stringSymbol _ = failwith msg let funcDecl _ = failwith msg @@ -43,22 +43,22 @@ let isInt _ = failwith msg let mkAll _ = failwith msg let mkRel _ = failwith msg -let mkApp _ = failwith msg +let mkApp _ = failwith msg let mkMul _ = failwith msg let mkDiv _ = failwith msg let mkAdd _ = failwith msg let mkSub _ = failwith msg let mkMod _ = failwith msg let mkIte _ = failwith msg -let mkInt _ = failwith msg -let mkLit _ = failwith msg -let mkReal _ = failwith msg +let mkInt _ = failwith msg +let mkLit _ = failwith msg +let mkReal _ = failwith msg let mkTrue _ = failwith msg let mkFalse _ = failwith msg let mkNot _ = failwith msg -let mkAnd _ = failwith msg -let mkOr _ = failwith msg -let mkImp _ = failwith msg +let mkAnd _ = failwith msg +let mkOr _ = failwith msg +let mkImp _ = failwith msg let mkIff _ = failwith msg let astString _ = failwith msg let sortString _ = failwith msg @@ -81,12 +81,12 @@ let mkBitAnd _ = failwith msg let mkBitOr _ = failwith msg let mkContext _ = failwith msg -let unsat _ = failwith msg +let unsat _ = failwith msg let assertAxiom _ = failwith msg let assertDistinct _ = failwith msg let bracket _ = failwith msg let assertPreds _ = failwith msg -let valid _ = failwith msg +let valid _ = failwith msg let contra _ = failwith msg let print_stats _ = failwith msg diff --git a/external/fixpoint/tpGen.ml b/external/fixpoint/tpGen.ml --- a/external/fixpoint/tpGen.ml +++ b/external/fixpoint/tpGen.ml @@ -32,18 +32,18 @@ module SM = Sy.SMap module P = A.Predicate module E = A.Expression -module Misc = FixMisc +module Misc = FixMisc module SSM = Misc.StringMap module SMT = SmtZ3.SMTZ3 open Misc.Ops open ProverArch -let mydebug = false +let mydebug = false module MakeProver(SMT : SMTSOLVER) : PROVER = struct - module Th = Theories.MakeTheory(SMT) + module Th = Theories.MakeTheory(SMT) (*************************************************************************) (*************************** Type Definitions ****************************) @@ -53,7 +53,7 @@ type var_ast = Const of SMT.ast | Bound of int * So.t -type t = { +type t = { c : SMT.context; tint : SMT.sort; treal : SMT.sort; @@ -72,12 +72,12 @@ (*************************************************************************) let pprint_decl ppf = function - | Vbl (x, t) -> F.fprintf ppf "%a:%a" Sy.print x So.print t - | Barrier -> F.fprintf ppf "----@." + | Vbl (x, t) -> F.fprintf ppf "%a:%a" Sy.print x So.print t + | Barrier -> F.fprintf ppf "----@." | Fun (s, i) -> F.fprintf ppf "%a[%i]" Sy.print s i let dump_decls me = - F.printf "Vars: %a" (Misc.pprint_many true "," pprint_decl) me.vars + F.printf "Vars: %a" (Misc.pprint_many true "," pprint_decl) me.vars (************************************************************************) (***************************** Stats Counters **************************) @@ -97,11 +97,11 @@ let axioms = [] (* TBD these are related to ML and should be in DSOLVE, not here *) -let builtins = - SM.empty +let builtins = + SM.empty |> SM.add tag_n (So.t_func 0 [So.t_obj; So.t_int]) - |> SM.add div_n (So.t_func 0 [So.t_int; So.t_int; So.t_int]) - |> SM.add mul_n (So.t_func 0 [So.t_int; So.t_int; So.t_int]) + |> SM.add div_n (So.t_func 0 [So.t_int; So.t_int; So.t_int]) + |> SM.add mul_n (So.t_func 0 [So.t_int; So.t_int; So.t_int]) let select_t = So.t_func 0 [So.t_int; So.t_int] @@ -110,7 +110,7 @@ (fun f -> Sy.to_string f |> (^) (ss ^ "_") |> Sy.of_string), (fun s -> Sy.to_string s |> Misc.is_prefix ss) -let fresh = +let fresh = let x = ref 0 in fun v -> incr x; (v^(string_of_int !x)) @@ -119,35 +119,35 @@ (*************************************************************************) let varSort env s = - try SM.find s env with Not_found -> - failure "ERROR: varSort cannot type %s in TPZ3 \n" (Sy.to_string s) + try SM.find s env with Not_found -> + failure "ERROR: varSort cannot type %s in TPZ3 \n" (Sy.to_string s) let funSort env s = - try SM.find s builtins with Not_found -> - try SM.find s env with Not_found -> - if is_select s then select_t else - failure "ERROR: could not type function %s in TPZ3 \n" (Sy.to_string s) + try SM.find s builtins with Not_found -> + try SM.find s env with Not_found -> + if is_select s then select_t else + failure "ERROR: could not type function %s in TPZ3 \n" (Sy.to_string s) let rec z3Type me t = - Misc.do_memo me.tydt begin fun t -> + Misc.do_memo me.tydt begin fun t -> if So.is_bool t then me.tbool else if So.is_int t then me.tint else if So.is_real t then me.treal else Misc.maybe_default (z3TypeThy me t) me.tint - (* match z3TypeThy me t with + (* match z3TypeThy me t with | Some t' -> t' - | None -> me.tint *) + | None -> me.tint *) end t t and z3TypeThy me t = match So.app_of_t t with - | Some (c, ts) when H.mem me.thy_sortm c -> + | Some (c, ts) when H.mem me.thy_sortm c -> let def = H.find me.thy_sortm c in let zts = List.map (z3Type me) ts in Some (Th.mk_thy_sort def me.c zts) | _ -> - None - + None + (***********************************************************************) (********************** Identifiers ************************************) (***********************************************************************) @@ -157,14 +157,14 @@ let z3Var_memo me env x = let vx = getVbl env x in Misc.do_memo me.vart - (fun () -> + (fun () -> let t = x |> varSort env |> z3Type me in - let sym = fresh "z3v" + let sym = fresh "z3v" (* >> F.printf "z3Var_memo: %a :-> %s\n" Sy.print x *) - |> SMT.stringSymbol me.c in + |> SMT.stringSymbol me.c in let rv = Const (SMT.var me.c sym t) in - let _ = me.vars <- vx :: me.vars in - rv) + let _ = me.vars <- vx :: me.vars in + rv) () vx let z3Var me env x = @@ -173,10 +173,10 @@ | Bound (b, t) -> SMT.boundVar me.c (me.bnd - b) (z3Type me t) -let z3Fun me env p t k = - Misc.do_memo me.funt begin fun _ -> +let z3Fun me env p t k = + Misc.do_memo me.funt begin fun _ -> match So.func_of_t t with - | None -> assertf "MATCH ERROR: z3ArgTypes" + | None -> assertf "MATCH ERROR: z3ArgTypes" | Some (_, ts, rt) -> let ts = List.map (z3Type me) ts in let rt = z3Type me rt in @@ -193,38 +193,46 @@ let opt_to_string p = function | None -> "none" | Some x -> p x - + exception Z3RelTypeError -let pred_sort env p = - A.sortcheck_pred Theories.is_interp (Misc.flip SM.maybe_find env) p +let pred_sort env p = + A.sortcheck_pred Theories.is_interp (Misc.flip SM.maybe_find env) p let app_sort env tyo f es = A.sortcheck_app Theories.is_interp (Misc.flip SM.maybe_find env) tyo f es +(* >> (fun so -> let _ = F.printf "app_sort [f = %a es = %a] = %a\n" + Sy.print f + (Misc.pprint_many false ", " E.print) es + (Misc.pprint_maybe So.print) (Misc.maybe_map snd so) + in + () + ) + *) let expr_sort env = function - | A.App (f, es), _ -> Misc.maybe_map snd <| app_sort env None f es + | A.App (f, es), _ -> Misc.maybe_map snd <| app_sort env None f es | e -> A.sortcheck_expr Theories.is_interp (Misc.flip SM.maybe_find env) e let z3Bind me env x t = let vx = Vbl (x, varSort env x) in - me.bnd <- me.bnd + 1; - H.replace me.vart vx (Bound (me.bnd, t)); + me.bnd <- me.bnd + 1; + H.replace me.vart vx (Bound (me.bnd, t)); me.vars <- vx :: me.vars; SMT.stringSymbol me.c (fresh "z3b") let rec z3Rel me env (e1, r, e2) = let p = A.pAtom (e1, r, e2) in - let ok = pred_sort env p in + let ok = pred_sort env p in (* let _ = F.printf "z3Rel: e = %a, res = %b \n" P.print p ok in let _ = F.print_flush () in *) - if ok then + if ok then z3Rel_cast me env (e1, r, e2) (* z3Rel_real me env (e1, r, e2) *) (* SMT.mkRel me.c r (z3Exp me env e1) (z3Exp me env e2) *) - else begin + else begin SM.iter (fun s t -> F.printf "@[%a :: %a@]@." Sy.print s So.print t) env; F.printf "@[%a@]@.@." P.print (A.pAtom (e1, r, e2)); F.print_flush (); @@ -236,17 +244,19 @@ and z3Rel_cast me env = function | (e1, A.Eq, e2) -> begin - let (t1o, t2o) = (expr_sort env e1, expr_sort env e2) in - (* let _ = F.printf "z3Rel_cast: t1o = %s, t2o = %s \n" - (opt_to_string So.to_string t1o) (opt_to_string So.to_string t2o) in + let (t1o, t2o) = (expr_sort env e1, expr_sort env e2) in + (* + let _ = F.printf "z3Rel_cast: t1o = %s, t2o = %s \n" + (opt_to_string So.to_string t1o) + (opt_to_string So.to_string t2o) in *) match (t1o, t2o) with - | (Some t , None ) -> z3Rel_real me env (e1, A.Eq, A.eCst (e2, t)) + | (Some t , None ) -> z3Rel_real me env (e1, A.Eq, A.eCst (e2, t)) | (None , Some t) -> z3Rel_real me env (A.eCst (e1, t), A.Eq, e2) - | (_ , _ ) -> z3Rel_real me env (e1, A.Eq, e2) + | (_ , _ ) -> z3Rel_real me env (e1, A.Eq, e2) end - | (e1, r, e2) -> - z3Rel_real me env (e1, r, e2) + | (e1, r, e2) -> + z3Rel_real me env (e1, r, e2) and z3Rel_real me env (e1, r, e2) = (* let _ = F.printf "z3Rel_real: e1 = %s, e2 = %s \n" @@ -260,9 +270,9 @@ let cf = z3Fun me env p t (List.length zes) in SMT.mkApp me.c cf zes -and z3AppThy me env def tyo f es = +and z3AppThy me env def tyo f es = (* match A.sortcheck_app Theories.is_interp (Misc.flip SM.maybe_find env) tyo f es with *) - match app_sort env tyo f es with + match app_sort env tyo f es with | Some (s, t) -> let zts = So.sub_args s |> List.map (snd <+> z3Type me) in let zes = es |> List.map (z3Exp me env) in @@ -273,38 +283,38 @@ |> assertf "z3AppThy: sort error %s" and z3Div me env = function - | (e1, e2) when !Co.uif_divide -> + | (e1, e2) when !Co.uif_divide -> z3App me env div_n (List.map (z3Exp me env) [e1; e2]) - | (e1, e2) -> + | (e1, e2) -> SMT.mkDiv me.c (z3Exp me env e1) (z3Exp me env e2) and z3Mul me env = function - | ((A.Con (A.Constant.Int i), _), e) + | ((A.Con (A.Constant.Int i), _), e) | (e, (A.Con (A.Constant.Int i), _)) -> - SMT.mkMul me.c (SMT.mkInt me.c i me.tint) (z3Exp me env e) - | (e1, e2) when !Co.uif_multiply -> + SMT.mkMul me.c (SMT.mkInt me.c i me.tint) (z3Exp me env e) + | (e1, e2) when !Co.uif_multiply -> z3App me env mul_n (List.map (z3Exp me env) [e1; e2]) - | (e1, e2) -> + | (e1, e2) -> SMT.mkMul me.c (z3Exp me env e1) (z3Exp me env e2) and z3Con me env = function - | A.Constant.Int i -> - SMT.mkInt me.c i me.tint - | A.Constant.Real i -> + | A.Constant.Int i -> + SMT.mkInt me.c i me.tint + | A.Constant.Real i -> SMT.mkReal me.c i me.treal | A.Constant.Lit (l, t) -> SMT.mkLit me.c l (z3Type me t) - + and z3Exp me env = function | A.Con c, _ -> z3Con me env c - | A.Var s, _ -> + | A.Var s, _ -> z3Var me env s - | A.Cst ((A.App (f, es), _), t), _ when (H.mem me.thy_symm f) -> + | A.Cst ((A.App (f, es), _), t), _ when (H.mem me.thy_symm f) -> z3AppThy me env (H.find me.thy_symm f) (Some t) f es - | A.App (f, es), _ when (H.mem me.thy_symm f) -> + | A.App (f, es), _ when (H.mem me.thy_symm f) -> z3AppThy me env (H.find me.thy_symm f) None f es - | A.App (f, es), _ -> + | A.App (f, es), _ -> z3App me env f (List.map (z3Exp me env) es) | A.Bin (e1, A.Plus, e2), _ -> SMT.mkAdd me.c (z3Exp me env e1) (z3Exp me env e2) @@ -320,86 +330,87 @@ SMT.mkMod me.c (z3Exp me env e) (SMT.mkInt me.c i me.tint) | A.Bin (e1, A.Mod, e2), _ -> SMT.mkMod me.c (z3Exp me env e1) (z3Exp me env e2) - | A.Ite (e1, e2, e3), _ -> + | A.Ite (e1, e2, e3), _ -> SMT.mkIte me.c (z3Pred me env e1) (z3Exp me env e2) (z3Exp me env e3) - | A.Fld (f, e), _ -> + | A.Fld (f, e), _ -> z3App me env (mk_select f) [z3Exp me env e] (** REQUIRES: disjoint field names *) - | A.Cst (e, _), _ -> + | A.Cst (e, _), _ -> z3Exp me env e - | e -> - assertf "z3Exp: Cannot Convert %s!" (E.to_string e) + | e -> + assertf "z3Exp: Cannot Convert %s!" (E.to_string e) and z3Pred me env = function - | A.True, _ -> + | A.True, _ -> SMT.mkTrue me.c | A.False, _ -> SMT.mkFalse me.c - | A.Not p, _ -> + | A.Not p, _ -> SMT.mkNot me.c (z3Pred me env p) - | A.And ps, _ -> + | A.And ps, _ -> SMT.mkAnd me.c (List.map (z3Pred me env) ps) - | A.Or ps, _ -> + | A.Or ps, _ -> SMT.mkOr me.c (List.map (z3Pred me env) ps) - | A.Imp (p1, p2), _ -> + | A.Imp (p1, p2), _ -> SMT.mkImp me.c (z3Pred me env p1) (z3Pred me env p2) | A.Iff (p1, p2), _ -> SMT.mkIff me.c (z3Pred me env p1) (z3Pred me env p2) | A.Atom (e1, r, e2), _ -> z3Rel me env (e1, r, e2) - | A.Bexp e, _ -> + | A.Bexp e, _ -> let a = z3Exp me env e in let s2 = E.to_string e in - let so = match expr_sort env e with Some so -> so - | _ -> F.printf "No type for %s" (E.to_string e); - assert false in + let so = match expr_sort env e with + | Some so -> so + | _ -> let _ = F.printf "No type for %s" (E.to_string e) in assert false + in let sos = So.to_string so in (* let s1 = SMT.astString me.c a in - let _ = asserts (SMT.isBool me.c a) - "Bexp is not bool (e = %s)! z3=%s, fix=%s, sort=%s" - (E.to_string e) s1 s2 sos - in *) + let _ = asserts (SMT.isBool me.c a) + "Bexp is not bool (e = %s)! z3=%s, fix=%s, sort=%s" + (E.to_string e) s1 s2 sos + in *) a - | A.Forall (xts, p), _ -> + | A.Forall (xts, p), _ -> let (xs, ts) = List.split xts in let zargs = Array.of_list (List.map2 (z3Bind me env) xs ts) in - let zts = Array.of_list (List.map (z3Type me) ts) in + let zts = Array.of_list (List.map (z3Type me) ts) in let rv = SMT.mkAll me.c zts zargs (z3Pred me env p) in let _ = me.bnd <- me.bnd - (List.length xs) in rv - | p -> - assertf "z3Pred: Cannot Convert %s!" (P.to_string p) + | p -> + assertf "z3Pred: Cannot Convert %s!" (P.to_string p) - -let z3Pred me env p = - try + +let z3Pred me env p = + try let p = p in (*BS.time "fixdiv" A.fixdiv p in *) BS.time "z3Pred" (z3Pred me env) p - with ex -> (F.printf "z3Pred: error converting %a\n" P.print p) ; raise ex + with ex -> (F.printf "z3Pred: error converting %a\n" P.print p) ; raise ex (***************************************************************************) (***************** Binder/Stack Management *********************************) (***************************************************************************) let rec vpop (cs,s) = - match s with + match s with | [] -> (cs,s) | Barrier :: t -> (cs,t) - | h :: t -> vpop (h::cs,t) + | h :: t -> vpop (h::cs,t) let clean_decls me = let cs, vars' = vpop ([],me.vars) in - let _ = me.vars <- vars' in - List.iter begin function - | Barrier -> failure "ERROR: TPZ3-cleanDecls" - | Vbl _ as d -> H.remove me.vart d + let _ = me.vars <- vars' in + List.iter begin function + | Barrier -> failure "ERROR: TPZ3-cleanDecls" + | Vbl _ as d -> H.remove me.vart d | Fun _ as d -> H.remove me.funt d end cs -let handle_vv me env vv = - H.remove me.vart (getVbl env vv) (* RJ: why are we removing this? *) +let handle_vv me env vv = + H.remove me.vart (getVbl env vv) (* RJ: why are we removing this? *) (************************************************************************) @@ -407,14 +418,14 @@ (************************************************************************) let create_theories () = - Th.theories () + Th.theories () |> (Misc.hashtbl_of_list_with Th.sort_name <**> Misc.hashtbl_of_list_with Th.sym_name) -let assert_distinct_constants me env = function [] -> () | cs -> - cs |> Misc.kgroupby (varSort env) +let assert_distinct_constants me env = function [] -> () | cs -> + cs |> Misc.kgroupby (varSort env) |> List.iter begin fun (_, xs) -> xs >> Co.bprintf mydebug "Distinct Constants: %a \n" (Misc.pprint_many false ", " Sy.print) - |> List.map (z3Var me env) + |> List.map (z3Var me env) |> SMT.assertDistinct me.c end @@ -423,10 +434,10 @@ let _ = me.vars <- Barrier :: me.vars in ps -let valid me p = +let valid me p = SMT.bracket me begin fun _ -> SMT.assertPreds me [SMT.mkNot me p]; - BS.time "unsat" SMT.unsat me + BS.time "unsat" SMT.unsat me end (* API *) @@ -438,7 +449,7 @@ let _ = SMT.assertPreds me.c zps in let tqs, fqs = List.partition (snd <+> P.is_tauto) qs in let fqs = fqs |> List.rev_map (Misc.app_snd (z3Pred me env)) - |> Misc.filter (snd <+> valid me.c) in + |> Misc.filter (snd <+> valid me.c) in let _ = clean_decls me in (List.map fst tqs) ++ (List.map fst fqs) end @@ -446,8 +457,8 @@ (* API *) let print_stats ppf me = SMT.print_stats ppf (); - F.fprintf ppf "TP stats: sets=%d, queries=%d, count=%d\n" - !nb_set !nb_query (List.length me.vars) + F.fprintf ppf "TP stats: sets=%d, queries=%d, count=%d\n" + !nb_set !nb_query (List.length me.vars) (*************************************************************************) (****************** Unsat Core for CEX generation ************************) @@ -456,30 +467,30 @@ let mk_prop_var me pfx i : SMT.ast = i |> string_of_int |> (^) pfx - |> SMT.stringSymbol me.c - |> Misc.flip (SMT.var me.c) me.tbool + |> SMT.stringSymbol me.c + |> Misc.flip (SMT.var me.c) me.tbool let mk_prop_var_idx me ipa : (SMT.ast array * (SMT.ast -> 'a option)) = let va = Array.mapi (fun i _ -> mk_prop_var me "uc_p_" i) ipa in - let vm = va + let vm = va |> Array.map (SMT.astString me.c) - |> Misc.array_to_index_list - |> List .map Misc.swap - |> SSM.of_list in + |> Misc.array_to_index_list + |> List .map Misc.swap + |> SSM.of_list in let f z = SSM.maybe_find (SMT.astString me.c z) vm |> Misc.maybe_map (fst <.> Array.get ipa) in (va, f) let mk_pa me p2z pfx ics = - ics |> List.map (Misc.app_snd p2z) - |> Array.of_list + ics |> List.map (Misc.app_snd p2z) + |> Array.of_list |> Array.mapi (fun i (x, p) -> (x, p, mk_prop_var me pfx i)) (* API *) let unsat_core me env bgp ips = - let _ = H.clear me.vart in + let _ = H.clear me.vart in let p2z = (*A.fixdiv <+>*) z3Pred me env in - let ipa = ips |> List.map (Misc.app_snd p2z) |> Array.of_list in + let ipa = ips |> List.map (Misc.app_snd p2z) |> Array.of_list in let va, f = mk_prop_var_idx me ipa in let zp = ipa |> Array.mapi (fun i (_, p) -> SMT.mkIff me.c va.(i) p) |> Array.to_list @@ -492,29 +503,29 @@ failwith "SMT-UNSAT-CORE-TODO" (************************************ match SMT.check_assumptions me.c va n va' with - | (Z3.L_FALSE, m,_, n, ucore) - -> Array.map f ucore |> Array.to_list |> Misc.map_partial id + | (Z3.L_FALSE, m,_, n, ucore) + -> Array.map f ucore |> Array.to_list |> Misc.map_partial id | _ -> [] ************************************) end -let contra me p = +let contra me p = SMT.bracket me begin fun _ -> SMT.assertPreds me [p]; - BS.time "unsat" SMT.unsat me + BS.time "unsat" SMT.unsat me end (* API *) -let is_contra me env = z3Pred me env <+> contra me.c +let is_contra me env = z3Pred me env <+> contra me.c (* API *) let unsat_suffix me env p ps = let _ = if SMT.unsat me.c then assertf "ERROR: unsat_suffix" in SMT.bracket me.c begin fun _ -> - let rec loop j = function [] -> None | zp' :: zps' -> - SMT.assertPreds me.c [zp']; + let rec loop j = function [] -> None | zp' :: zps' -> + SMT.assertPreds me.c [zp']; if SMT.unsat me.c then Some j else loop (j-1) zps' - in loop (List.length ps) (List.map (z3Pred me env) (p :: List.rev ps)) + in loop (List.length ps) (List.map (z3Pred me env) (p :: List.rev ps)) end (***********************************************************************) @@ -525,36 +536,36 @@ let create ts env ps consts = let _ = asserts (ts = []) "ERROR: TPGEN-create non-empty sorts!" in let c = SMT.mkContext [|("MODEL", "false"); ("MODEL_PARTIAL", "true")|] in - let som, sym = create_theories () in - let me = { c = c; - tint = SMT.mkIntSort c; - treal = SMT.mkRealSort c; - tbool = SMT.mkBoolSort c; - tydt = H.create 37; - vart = H.create 37; - funt = H.create 37; - vars = []; + let som, sym = create_theories () in + let me = { c = c; + tint = SMT.mkIntSort c; + treal = SMT.mkRealSort c; + tbool = SMT.mkBoolSort c; + tydt = H.create 37; + vart = H.create 37; + funt = H.create 37; + vars = []; bnd = 0; - thy_sortm = som; - thy_symm = sym - } + thy_sortm = som; + thy_symm = sym + } in let _ = List.iter (z3Pred me env <+> SMT.assertAxiom me.c) (axioms ++ ps) in let _ = assert_distinct_constants me env consts in me -class tprover ts env ps consts : prover = +class tprover ts env ps consts : prover = object (self) - val me = create ts env ps consts - method interp_syms = Theories.interp_syms - method set_filter : 'a. Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.Symbol.t - -> Ast.pred list - -> ('a * Ast.pred) list + val me = create ts env ps consts + method interp_syms = Theories.interp_syms + method set_filter : 'a. Ast.Sort.t Ast.Symbol.SMap.t + -> Ast.Symbol.t + -> Ast.pred list + -> ('a * Ast.pred) list -> 'a list - = set_filter me - method print_stats = fun ppf -> print_stats ppf me - method is_contra = is_contra me + = set_filter me + method print_stats = fun ppf -> print_stats ppf me + method is_contra = is_contra me method unsat_suffix = unsat_suffix me end diff --git a/external/ocamlgraph/src/version.ml b/external/ocamlgraph/src/version.ml --- a/external/ocamlgraph/src/version.ml +++ b/external/ocamlgraph/src/version.ml @@ -1,2 +1,2 @@ let version = "0.99b" -let date = "Fri Mar 27 20:20:48 UTC 2015" +let date = "Tue May 19 21:41:16 UTC 2015" diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -1,5 +1,5 @@ name: liquid-fixpoint -version: 0.2.3.2 +version: 0.3.0.0 Copyright: 2010-15 Ranjit Jhala, University of California, San Diego. synopsis: Predicate Abstraction-based Horn-Clause/Implication Constraint Solver homepage: https://github.com/ucsd-progsys/liquid-fixpoint @@ -102,7 +102,6 @@ , containers , deepseq , directory - -- , filemanip , filepath , mtl , parsec @@ -155,8 +154,15 @@ Language.Fixpoint.Parse, Language.Fixpoint.PrettyPrint, Language.Fixpoint.SmtLib2, - Language.Fixpoint.Misc - + Language.Fixpoint.Misc, + Language.Fixpoint.Solver.Solution, + Language.Fixpoint.Solver.Worklist, + Language.Fixpoint.Solver.Monad, + Language.Fixpoint.Solver.Deps, + Language.Fixpoint.Solver.Eliminate, + Language.Fixpoint.Solver.Validate, + Language.Fixpoint.Solver.Solve + Build-Depends: base >= 4.7 && < 5 , array , attoparsec @@ -183,21 +189,21 @@ , unordered-containers , text-format --- test-suite test --- default-language: Haskell98 --- type: exitcode-stdio-1.0 --- hs-source-dirs: tests --- ghc-options: -O2 -threaded --- main-is: test.hs --- build-depends: base, --- -- directory, --- -- filepath, --- -- process, --- -- tagged, --- liquid-fixpoint, --- -- optparse-applicative == 0.11.*, --- QuickCheck, --- tasty >= 0.10, --- tasty-quickcheck, --- tasty-rerun >= 1.1, --- text +test-suite test + default-language: Haskell98 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + ghc-options: -O2 -threaded + main-is: test.hs + build-depends: base, + directory, + filepath, + process, + -- tagged, + liquid-fixpoint, + -- optparse-applicative == 0.11.*, + tasty >= 0.10, + -- tasty-quickcheck, + tasty-hunit, + tasty-rerun >= 1.1, + text diff --git a/src/Language/Fixpoint/Config.hs b/src/Language/Fixpoint/Config.hs --- a/src/Language/Fixpoint/Config.hs +++ b/src/Language/Fixpoint/Config.hs @@ -7,6 +7,7 @@ module Language.Fixpoint.Config ( Config (..) + , getOpts , Command (..) , SMTSolver (..) , GenQualifierSort (..) @@ -15,6 +16,8 @@ , withUEqAllSorts ) where +import System.Console.CmdArgs +import System.Console.CmdArgs.Verbosity (whenLoud) import Data.Generics (Data) import Data.Typeable (Typeable) import Language.Fixpoint.Files @@ -34,18 +37,20 @@ data Config = Config { - inFile :: FilePath -- target fq-file - , outFile :: FilePath -- output file - , solver :: SMTSolver -- which SMT solver to use - , genSorts :: GenQualifierSort -- generalize qualifier sorts - , ueqAllSorts :: UeqAllSorts -- use UEq on all sorts - , native :: Bool -- use haskell solver - , real :: Bool -- interpret div and mul in SMT + inFile :: FilePath -- ^ target fq-file + , outFile :: FilePath -- ^ output file + , srcFile :: FilePath -- ^ src file (*.hs, *.ts, *.c) + , solver :: SMTSolver -- ^ which SMT solver to use + , genSorts :: GenQualifierSort -- ^ generalize qualifier sorts + , ueqAllSorts :: UeqAllSorts -- ^ use UEq on all sorts + , native :: Bool -- ^ use haskell solver + , real :: Bool -- ^ interpret div and mul in SMT + , eliminate :: Bool -- ^ eliminate non-cut KVars } deriving (Eq,Data,Typeable,Show) instance Default Config where - def = Config "" def def def def def def - + def = Config "" def def def def def def def def + instance Command Config where command c = command (genSorts c) ++ command (ueqAllSorts c) @@ -110,3 +115,34 @@ -- defaultSolver :: Maybe SMTSolver -> SMTSolver -- defaultSolver = fromMaybe Z3 + + +config = Config { + inFile = def &= typ "TARGET" &= args &= typFile + , outFile = "out" &= help "Output file" + , srcFile = def &= help "Source File from which FQ is generated" + , solver = def &= help "Name of SMT Solver" + , genSorts = def &= help "Generalize qualifier sorts" + , ueqAllSorts = def &= help "use UEq on all sorts" + , native = False &= help "(alpha) Haskell Solver" + , real = False &= help "(alpha) Theory of real numbers" + , eliminate = False &= help "(alpha) Eliminate non-cut KVars" + } + &= verbosity + &= program "fixpoint" + &= help "Predicate Abstraction Based Horn-Clause Solver" + &= summary "fixpoint Copyright 2009-13 Regents of the University of California." + &= details [ "Predicate Abstraction Based Horn-Clause Solver" + , "" + , "To check a file foo.fq type:" + , " fixpoint foo.fq" + ] + +getOpts :: IO Config +getOpts = do md <- cmdArgs config + putStrLn $ banner md + return md + +banner args = "Liquid-Fixpoint Copyright 2009-13 Regents of the University of California.\n" + ++ "All Rights Reserved.\n" + diff --git a/src/Language/Fixpoint/Errors.hs b/src/Language/Fixpoint/Errors.hs --- a/src/Language/Fixpoint/Errors.hs +++ b/src/Language/Fixpoint/Errors.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} - +{-# LANGUAGE ScopedTypeVariables #-} module Language.Fixpoint.Errors ( -- * Concrete Location Type SrcSpan (..) @@ -18,7 +18,6 @@ -- * Accessors , errLoc , errMsg - -- , errorInfo -- * Adding Insult to Injury , catMessage @@ -26,6 +25,7 @@ -- * Fatal Exit , die + , exit ) where @@ -41,6 +41,7 @@ import Text.Parsec.Pos import Text.PrettyPrint.HughesPJ import Text.Printf +import Control.Exception (catch) ----------------------------------------------------------------------- -- | A Reusable SrcSpan Type ------------------------------------------ @@ -111,15 +112,13 @@ --------------------------------------------------------------------- catMessage :: Error -> String -> Error --------------------------------------------------------------------- -catMessage err msg = err {errMsg = msg ++ errMsg err} +catMessage e msg = e {errMsg = msg ++ errMsg e} --------------------------------------------------------------------- catError :: Error -> Error -> Error --------------------------------------------------------------------- catError e1 e2 = catMessage e1 $ show e2 - - --------------------------------------------------------------------- err :: SrcSpan -> String -> Error --------------------------------------------------------------------- @@ -129,3 +128,10 @@ die :: Error -> a --------------------------------------------------------------------- die = throw + +--------------------------------------------------------------------- +exit :: a -> IO a -> IO a +--------------------------------------------------------------------- +exit def act = catch act $ \(e :: Error) -> do + putStrLn $ "Unexpected Error: " ++ showpp e + return def diff --git a/src/Language/Fixpoint/Files.hs b/src/Language/Fixpoint/Files.hs --- a/src/Language/Fixpoint/Files.hs +++ b/src/Language/Fixpoint/Files.hs @@ -19,12 +19,11 @@ , isExtFile -- * Hardwired paths - , getFixpointPath, getZ3LibPath + , getFixpointPath + , getZ3LibPath -- * Various generic utility functions for finding and removing files - -- , getHsTargets , getFileInDirs - -- , findFileInDirs , copyFiles ) where @@ -47,8 +46,11 @@ getFixpointPath = fromMaybe msg . msum <$> sequence [ findExecutable "fixpoint.native" , findExecutable "fixpoint.native.exe" + -- fallback for developing in-tree... + , findFile ["external/fixpoint"] "fixpoint.native" ] - where msg = errorstar "Cannot find fixpoint binary [fixpoint.native]" + where + msg = errorstar "Cannot find fixpoint binary [fixpoint.native]" getZ3LibPath = dropFileName <$> getFixpointPath diff --git a/src/Language/Fixpoint/Interface.hs b/src/Language/Fixpoint/Interface.hs --- a/src/Language/Fixpoint/Interface.hs +++ b/src/Language/Fixpoint/Interface.hs @@ -1,133 +1,199 @@ +-- | This module implements the top-level API for interfacing with Fixpoint +-- In particular it exports the functions that solve constraints supplied +-- either as .fq files or as FInfo. + module Language.Fixpoint.Interface ( -- * Containing Constraints FInfo (..) - -- * Invoke Solver on Set of Constraints + -- * Invoke Solver on an FInfo , solve - , solveFile + -- * Invoke Solver on a .fq file + , solveFQ + -- * Function to determine outcome , resultExit - -- * Validity Query - , checkValid - + -- * Parse Qualifiers from File + , parseFInfo ) where -{- Interfacing with Fixpoint Binary -} - import Data.Functor -import Data.Hashable +-- import Data.Hashable import qualified Data.HashMap.Strict as M import Data.List -import Data.Monoid -import System.Directory (getTemporaryDirectory) +import Data.Monoid (mconcat, mempty) +-- import System.Directory (getTemporaryDirectory) import System.Exit -import System.FilePath (()) +-- import System.FilePath (()) import System.IO (IOMode (..), hPutStr, withFile) import Text.Printf +import Language.Fixpoint.Solver.Eliminate (eliminateAll) +import qualified Language.Fixpoint.Solver.Solve as S import Language.Fixpoint.Config import Language.Fixpoint.Files import Language.Fixpoint.Misc -import Language.Fixpoint.Parse (rr) +import Language.Fixpoint.Parse (rr, rr') import Language.Fixpoint.Types hiding (kuts, lits) -import System.Console.CmdArgs.Default +import Language.Fixpoint.Errors (exit) +import Language.Fixpoint.PrettyPrint (showpp) +-- import System.Console.CmdArgs.Default import System.Console.CmdArgs.Verbosity import Text.PrettyPrint.HughesPJ + --------------------------------------------------------------------------- --- | One Shot validity query ---------------------------------------------- +-- | Solve FInfo system of horn-clause constraints ------------------------ --------------------------------------------------------------------------- +solve :: Config -> FInfo a -> IO (Result a) +solve cfg + | native cfg = S.solve cfg + | otherwise = solveExt cfg --------------------------------------------------------------------------- -checkValid :: (Hashable a) => a -> [(Symbol, Sort)] -> Pred -> IO (FixResult a) +-- | Solve .fq File ------------------------------------------------------- --------------------------------------------------------------------------- -checkValid n xts p - = do file <- ( show (hash n)) <$> getTemporaryDirectory - (r, _) <- solve def file [] $ validFInfo n xts p - return (sinfo <$> r) +solveFQ :: Config -> IO ExitCode +--------------------------------------------------------------------------- +solveFQ cfg + | native cfg = solveNative' cfg + | otherwise = solveFile cfg -validFInfo :: a -> [(Symbol, Sort)] -> Pred -> FInfo a -validFInfo l xts p = FI constrm [] benv emptySEnv [] ksEmpty [] - where - constrm = M.singleton 0 $ validSubc l ibenv p - binds = [(x, trueSortedReft t) | (x, t) <- xts] - ibenv = insertsIBindEnv bids emptyIBindEnv - (bids, benv) = foldlMap (\e (x,t) -> insertBindEnv x t e) emptyBindEnv binds -validSubc :: a -> IBindEnv -> Pred -> SubC a -validSubc l env p = safeHead "Interface.validSubC" $ subC env PTrue lhs rhs i t l - where - lhs = mempty - rhs = RR mempty (predReft p) - i = Just 0 - t = [] - -result :: a -> Bool -> FixResult a -result _ True = Safe -result x False = Unsafe [x] - +--------------------------------------------------------------------------- +-- | Fake Dependencies Harness Solver +--------------------------------------------------------------------------- +solveNative :: Config -> IO ExitCode +solveNative cfg + = do let file = inFile cfg + str <- readFile file + let fi = rr' file str :: FInfo () + let res = eliminateAll fi + putStrLn $ "Result: \n" ++ (render $ toFixpoint res) + error "TODO: solveNative" --------------------------------------------------------------------------- --- | Solve a system of horn-clause constraints ---------------------------- +-- | Native Haskell Solver --------------------------------------------------------------------------- +solveNative' :: Config -> IO ExitCode +solveNative' cfg = exit (ExitFailure 2) $ do + let file = inFile cfg + str <- readFile file + let fi = rr' file str :: FInfo () + let fi' = if eliminate cfg then eliminateAll fi else fi + (res, s) <- S.solve cfg fi' + let res' = sid <$> res + putStrLn $ "Solution:\n" ++ showpp s + putStrLn $ "Result: " ++ show res' + return $ resultExit res' --------------------------------------------------------------------------- -solve :: Config -> FilePath -> [FilePath] -> FInfo a - -> IO (FixResult (SubC a), M.HashMap Symbol Pred) +-- | External Ocaml Solver --------------------------------------------------------------------------- -solve cfg fn hqs fi - = {-# SCC "Solve" #-} execFq cfg fn hqs fi - >>= {-# SCC "exitFq" #-} exitFq fn (cm fi) +solveExt :: Config -> FInfo a -> IO (Result a) +solveExt cfg fi = {-# SCC "Solve" #-} execFq cfg fn fi + >>= {-# SCC "exitFq" #-} exitFq fn (cm fi) + where + fn = srcFile cfg -execFq cfg fn hqs fi - = do copyFiles hqs fq - appendFile fq qstr +execFq cfg fn fi + = do writeFile fq qstr withFile fq AppendMode (\h -> {-# SCC "HPrintDump" #-} hPutStr h (render d)) solveFile $ cfg `withTarget` fq where fq = extFileName Fq fn d = {-# SCC "FixPointify" #-} toFixpoint fi - qstr = render ((vcat $ toFix <$> (quals fi)) $$ text "\n") + qstr = render ((vcat $ toFix <$> quals fi) $$ text "\n") ---------------------------------------------------------------------------- solveFile :: Config -> IO ExitCode ---------------------------------------------------------------------------- solveFile cfg = do fp <- getFixpointPath z3 <- getZ3LibPath v <- (\b -> if b then "-v 1" else "") <$> isLoud - ec <- {-# SCC "sysCall:Fixpoint" #-} executeShellCommand "fixpoint" $ fixCommand cfg fp z3 v rf - return ec - where realFlags = "-no-uif-multiply " - ++ "-no-uif-divide " - rf = if (real cfg) then realFlags else "" + {-# SCC "sysCall:Fixpoint" #-} executeShellCommand "fixpoint" $ fixCommand cfg fp z3 v -fixCommand cfg fp z3 verbosity realFlags +fixCommand cfg fp z3 verbosity = printf "LD_LIBRARY_PATH=%s %s %s %s -notruekvars -refinesort -nosimple -strictsortcheck -sortedquals %s" - z3 fp verbosity realFlags (command cfg) + z3 fp verbosity rf (command cfg) + where + rf = if real cfg then realFlags else "" -exitFq _ _ (ExitFailure n) | (n /= 1) +realFlags = "-no-uif-multiply " + ++ "-no-uif-divide " + +exitFq _ _ (ExitFailure n) | n /= 1 = return (Crash [] "Unknown Error", M.empty) exitFq fn cm _ = do str <- {-# SCC "readOut" #-} readFile (extFileName Out fn) let (x, y) = parseFixpointOutput str -- {-# SCC "parseFixOut" #-} rr ({-# SCC "sanitizeFixpointOutput" #-} sanitizeFixpointOutput str) return $ (plugC cm x, y) + where + plugC = fmap . mlookup parseFixpointOutput :: String -> (FixResult Integer, FixSolution) parseFixpointOutput str = {-# SCC "parseFixOut" #-} rr ({-# SCC "sanitizeFixpointOutput" #-} sanitizeFixpointOutput str) -plugC = fmap . mlookup - sanitizeFixpointOutput = unlines . filter (not . ("//" `isPrefixOf`)) . chopAfter ("//QUALIFIERS" `isPrefixOf`) . lines +--------------------------------------------------------------------------- +resultExit :: FixResult a -> ExitCode +--------------------------------------------------------------------------- resultExit Safe = ExitSuccess resultExit (Unsafe _) = ExitFailure 1 resultExit _ = ExitFailure 2 + + +--------------------------------------------------------------------------- +-- | Parse External Qualifiers -------------------------------------------- +--------------------------------------------------------------------------- +parseFInfo :: [FilePath] -> IO (FInfo a) -- [Qualifier] +--------------------------------------------------------------------------- +parseFInfo fs = mconcat <$> mapM parseFI fs + +parseFI :: FilePath -> IO (FInfo a) --[Qualifier] +parseFI f = do + str <- readFile f + let fi = rr' f str :: FInfo () + return $ mempty { quals = quals fi + , gs = gs fi } + +-- OLD CUT USE NEW SMTLIB INTERFACE --------------------------------------------------------------------------- +-- OLD CUT USE NEW SMTLIB INTERFACE -- | One Shot validity query ---------------------------------------------- +-- OLD CUT USE NEW SMTLIB INTERFACE --------------------------------------------------------------------------- +-- OLD CUT USE NEW SMTLIB INTERFACE +-- OLD CUT USE NEW SMTLIB INTERFACE --------------------------------------------------------------------------- +-- OLD CUT USE NEW SMTLIB INTERFACE checkValid :: (Hashable a) => a -> [(Symbol, Sort)] -> Pred -> IO (FixResult a) +-- OLD CUT USE NEW SMTLIB INTERFACE --------------------------------------------------------------------------- +-- OLD CUT USE NEW SMTLIB INTERFACE checkValid n xts p +-- OLD CUT USE NEW SMTLIB INTERFACE = do file <- ( show (hash n)) <$> getTemporaryDirectory +-- OLD CUT USE NEW SMTLIB INTERFACE (r, _) <- solve def file [] $ validFInfo n xts p +-- OLD CUT USE NEW SMTLIB INTERFACE return (sinfo <$> r) +-- OLD CUT USE NEW SMTLIB INTERFACE +-- OLD CUT USE NEW SMTLIB INTERFACE validFInfo :: a -> [(Symbol, Sort)] -> Pred -> FInfo a +-- OLD CUT USE NEW SMTLIB INTERFACE validFInfo l xts p = FI constrm [] benv emptySEnv [] ksEmpty [] +-- OLD CUT USE NEW SMTLIB INTERFACE where +-- OLD CUT USE NEW SMTLIB INTERFACE constrm = M.singleton 0 $ validSubc l ibenv p +-- OLD CUT USE NEW SMTLIB INTERFACE binds = [(x, trueSortedReft t) | (x, t) <- xts] +-- OLD CUT USE NEW SMTLIB INTERFACE ibenv = insertsIBindEnv bids emptyIBindEnv +-- OLD CUT USE NEW SMTLIB INTERFACE (bids, benv) = foldlMap (\e (x,t) -> insertBindEnv x t e) emptyBindEnv binds +-- OLD CUT USE NEW SMTLIB INTERFACE +-- OLD CUT USE NEW SMTLIB INTERFACE validSubc :: a -> IBindEnv -> Pred -> SubC a +-- OLD CUT USE NEW SMTLIB INTERFACE validSubc l env p = safeHead "Interface.validSubC" $ subC env PTrue lhs rhs i t l +-- OLD CUT USE NEW SMTLIB INTERFACE where +-- OLD CUT USE NEW SMTLIB INTERFACE lhs = mempty +-- OLD CUT USE NEW SMTLIB INTERFACE rhs = RR mempty (predReft p) +-- OLD CUT USE NEW SMTLIB INTERFACE i = Just 0 +-- OLD CUT USE NEW SMTLIB INTERFACE t = [] +-- OLD CUT USE NEW SMTLIB INTERFACE +-- OLD CUT USE NEW SMTLIB INTERFACE result :: a -> Bool -> FixResult a +-- OLD CUT USE NEW SMTLIB INTERFACE result _ True = Safe +-- OLD CUT USE NEW SMTLIB INTERFACE result x False = Unsafe [x] +-- OLD CUT USE NEW SMTLIB INTERFACE diff --git a/src/Language/Fixpoint/Misc.hs b/src/Language/Fixpoint/Misc.hs --- a/src/Language/Fixpoint/Misc.hs +++ b/src/Language/Fixpoint/Misc.hs @@ -9,13 +9,14 @@ import qualified Control.Exception as Ex import Data.Hashable import Data.Traversable (traverse) --- import qualified Data.HashSet as S +import qualified Data.HashSet as S import Control.Applicative ((<$>)) import Control.Monad (forM_, (>=>)) import qualified Data.ByteString as B import Data.ByteString.Char8 (pack, unpack) import qualified Data.HashMap.Strict as M import qualified Data.List as L +import Data.Tuple (swap) import Data.Maybe (fromJust) import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T @@ -29,6 +30,7 @@ import Text.PrettyPrint.HughesPJ + ----------------------------------------------------------------------------------- ------------ Support for Colored Logging ------------------------------------------ ----------------------------------------------------------------------------------- @@ -132,6 +134,7 @@ Just v -> v Nothing -> errorstar $ "mlookup: unknown key " ++ show k +safeLookup msg k m = fromMaybe (errorstar msg) (M.lookup k m) mfromJust :: String -> Maybe a -> a mfromJust _ (Just x) = x @@ -158,10 +161,15 @@ concatMaps = fmap sortNub . L.foldl' (M.unionWith (++)) M.empty -- group :: Hashable k => [(k, v)] -> M.HashMap k [v] -group = L.foldl' (\m (k, v) -> inserts k v m) M.empty +group = groupBase M.empty +groupBase = L.foldl' (\m (k, v) -> inserts k v m) groupList = M.toList . group +mkGraph :: (Eq a, Eq b, Hashable a, Hashable b) => [(a, b)] -> M.HashMap a (S.HashSet b) +mkGraph = fmap S.fromList . group + + -- groupMap :: Hashable k => (a -> k) -> [a] -> M.HashMap k [a] groupMap f xs = L.foldl' (\m x -> inserts (f x) x m) M.empty xs @@ -174,17 +182,26 @@ sortDiff :: (Ord a) => [a] -> [a] -> [a] -sortDiff x1s x2s = go (sortNub x1s) (sortNub x2s) - where go xs@(x:xs') ys@(y:ys') - | x < y = x : go xs' ys - | x == y = go xs' ys' - | otherwise = go xs ys' - go xs [] = xs - go [] _ = [] +sortDiff x1s x2s = go (sortNub x1s) (sortNub x2s) + where + go xs@(x:xs') ys@(y:ys') + | x < y = x : go xs' ys + | x == y = go xs' ys' + | otherwise = go xs ys' + go xs [] = xs + go [] _ = [] +folds :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a) +folds f b = L.foldl' step ([], b) + where + step (cs, acc) x = (c:cs, x') + where + (c, x') = f acc x + + distinct :: Ord a => [a] -> Bool distinct xs = length xs == length (sortNub xs) @@ -236,14 +253,29 @@ Just k -> errorstar $ "safeUnion with common key = " ++ show k ++ " " ++ msg Nothing -> M.union m1 m2 +{-@ type ListNE a = {v:[a] | 0 < len v} @-} +type ListNE a = [a] + +safeHead :: String -> ListNE a -> a safeHead _ (x:_) = x safeHead msg _ = errorstar $ "safeHead with empty list " ++ msg +safeLast :: String -> ListNE a -> a safeLast _ xs@(_:_) = last xs safeLast msg _ = errorstar $ "safeLast with empty list " ++ msg + +safeInit :: String -> ListNE a -> [a] safeInit _ xs@(_:_) = init xs safeInit msg _ = errorstar $ "safeInit with empty list " ++ msg + +safeUncons :: String -> ListNE a -> (a, [a]) +safeUncons _ (x:xs) = (x, xs) +safeUncons msg _ = errorstar $ "safeUncons with empty list " ++ msg + +safeUnsnoc :: String -> ListNE a -> ([a], a) +safeUnsnoc msg = swap . mapSnd reverse . safeUncons msg . reverse + -- memoIndex :: (Hashable b) => (a -> Maybe b) -> [a] -> [Maybe Int] diff --git a/src/Language/Fixpoint/Names.hs b/src/Language/Fixpoint/Names.hs --- a/src/Language/Fixpoint/Names.hs +++ b/src/Language/Fixpoint/Names.hs @@ -18,17 +18,18 @@ -- * Symbols Symbol , Symbolic (..) - , anfPrefix, tempPrefix, vv, intKvar, isPrefixOfSym, isSuffixOfSym, stripParensSym + , anfPrefix, tempPrefix, vv, isPrefixOfSym, isSuffixOfSym, stripParensSym , consSym, unconsSym, dropSym, singletonSym, headSym, takeWhileSym, lengthSym , symChars, isNonSymbol, nonSymbol , isNontrivialVV , symbolText, symbolString , encode, vvCon , dropModuleNames + , dropModuleUnique , takeModuleNames -- * Creating Symbols - , dummySymbol, intSymbol, tempSymbol + , dummySymbol, intSymbol, tempSymbol, existSymbol , qualifySymbol , suffixSymbol @@ -42,6 +43,8 @@ , propConName , hpropConName , strConName + , nilName + , consName , vvName , symSepName , size32Name, size64Name, bitVecName, bvAndName, bvOrName @@ -200,22 +203,23 @@ dummySymbol = dummyName + +intSymbol :: (Show a) => Symbol -> a -> Symbol intSymbol x i = x `mappend` symbol (show i) -tempSymbol :: Symbol -> Integer -> Symbol -tempSymbol prefix n = intSymbol (tempPrefix `mappend` prefix) n +tempSymbol, existSymbol :: Symbol -> Integer -> Symbol +tempSymbol prefix n = intSymbol (tempPrefix `mappend` prefix) n +existSymbol prefix n = intSymbol (existPrefix `mappend` prefix) n -tempPrefix, anfPrefix :: Symbol +tempPrefix, anfPrefix, existPrefix :: Symbol tempPrefix = "lq_tmp_" anfPrefix = "lq_anf_" +existPrefix = "lq_ext_" nonSymbol :: Symbol nonSymbol = "" isNonSymbol = (== nonSymbol) -intKvar :: Integer -> Symbol -intKvar = intSymbol "k_" - -- | Values that can be viewed as Symbols class Symbolic a where @@ -251,6 +255,9 @@ vvName = "VV" symSepName = '#' +nilName = "nil" :: Symbol +consName = "cons" :: Symbol + size32Name = "Size32" :: Symbol size64Name = "Size64" :: Symbol bitVecName = "BitVec" :: Symbol @@ -281,6 +288,8 @@ , bvOrName , bvAndName , "FAppTy" + , nilName + , consName ] -- dropModuleNames [] = [] @@ -292,9 +301,18 @@ -- dotWhite '.' = ' ' -- dotWhite c = c -dropModuleNames = mungeModuleNames safeLast "dropModuleNames: " -takeModuleNames = mungeModuleNames safeInit "takeModuleNames: " +sepModNames = "." +sepUnique = "#" +dropModuleNames = mungeNames safeLast sepModNames "dropModuleNames: " +takeModuleNames = mungeNames safeInit sepModNames "takeModuleNames: " + +dropModuleUnique = mungeNames safeHead sepUnique "dropModuleUnique: " + +safeHead :: String -> [T.Text] -> Symbol +safeHead msg [] = errorstar $ "safeHead with empty list" ++ msg +safeHead _ (x:_) = symbol x + safeInit :: String -> [T.Text] -> Symbol safeInit _ xs@(_:_) = symbol $ T.intercalate "." $ init xs safeInit msg _ = errorstar $ "safeInit with empty list " ++ msg @@ -303,9 +321,9 @@ safeLast _ xs@(_:_) = symbol $ last xs safeLast msg _ = errorstar $ "safeLast with empty list " ++ msg -mungeModuleNames :: (String -> [T.Text] -> Symbol) -> String -> Symbol -> Symbol -mungeModuleNames _ _ "" = "" -mungeModuleNames f msg s'@(symbolText -> s) +mungeNames :: (String -> [T.Text] -> Symbol) -> T.Text -> String -> Symbol -> Symbol +mungeNames _ _ _ "" = "" +mungeNames f d msg s'@(symbolText -> s) | s' == tupConName = tupConName - | otherwise = f (msg ++ T.unpack s) $ T.splitOn "." $ stripParens s + | otherwise = f (msg ++ T.unpack s) $ T.splitOn d $ stripParens s diff --git a/src/Language/Fixpoint/Parse.hs b/src/Language/Fixpoint/Parse.hs --- a/src/Language/Fixpoint/Parse.hs +++ b/src/Language/Fixpoint/Parse.hs @@ -59,11 +59,11 @@ , remainderP ) where -import Control.Applicative ((<$>), (<*), (<*>)) -import Control.Monad +import Control.Applicative ((<$>), (<*), (*>), (<*>)) +-- import Control.Monad import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S -import Data.Text (Text) +-- import Data.Text (Text) import qualified Data.Text as T import Text.Parsec import Text.Parsec.Expr @@ -79,10 +79,12 @@ import Language.Fixpoint.Misc hiding (dcolon) import Language.Fixpoint.SmtLib2 import Language.Fixpoint.Types +import Language.Fixpoint.Names (vv, nilName, consName) +import Language.Fixpoint.Visitor (foldSort, mapSort) import Data.Maybe (fromJust, maybe) -import Data.Monoid (mempty) +import Data.Monoid (mempty,mconcat) type Parser = Parsec String Integer @@ -91,7 +93,7 @@ languageDef = emptyDef { Token.commentStart = "/* " , Token.commentEnd = " */" - , Token.commentLine = "--" + , Token.commentLine = "//" , Token.identStart = satisfy (\_ -> False) , Token.identLetter = satisfy (\_ -> False) , Token.reservedNames = [ "SAT" @@ -115,7 +117,7 @@ , "|" , "if", "then", "else" ] - , Token.reservedOpNames = [ "+", "-", "*", "/", "\\" + , Token.reservedOpNames = [ "+", "-", "*", "/", "\\", ":" , "<", ">", "<=", ">=", "=", "!=" , "/=" , "mod", "and", "or" --, "is" @@ -163,7 +165,10 @@ ---------------------------------------------------------------- locParserP :: Parser a -> Parser (Located a) -locParserP p = liftM2 Loc getPosition p +locParserP p = do l1 <- getPosition + x <- p + l2 <- getPosition + return $ Loc l1 l2 x -- FIXME: we (LH) rely on this parser being dumb and *not* consuming trailing -- whitespace, in order to avoid some parsers spanning multiple lines.. @@ -180,6 +185,9 @@ lowerIdP :: Parser Symbol lowerIdP = condIdP symChars (isLower . head) +symCharsP :: Parser Symbol +symCharsP = condIdP symChars (`notElem` keyWordSyms) + locLowerIdP = locParserP lowerIdP locUpperIdP = locParserP upperIdP @@ -187,14 +195,16 @@ symbolP = symbol <$> symCharsP constantP :: Parser Constant -constantP = try (liftM R double) <|> liftM I integer +constantP = try (R <$> double) + <|> I <$>integer symconstP :: Parser SymConst symconstP = SL . T.pack <$> stringLiteral expr0P :: Parser Expr expr0P - = (fastIfP EIte exprP) + = (brackets whiteSpace >> return eNil) + <|> (fastIfP EIte exprP) <|> (ESym <$> symconstP) <|> (ECon <$> constantP) <|> (reserved "_|_" >> return EBot) @@ -228,21 +238,17 @@ funAppP = (try litP) <|> (try exprFunSpacesP) <|> (try exprFunSemisP) <|> exprFunCommasP where - exprFunSpacesP = liftM2 EApp funSymbolP (sepBy1 expr0P blanks) - exprFunCommasP = liftM2 EApp funSymbolP (parens $ sepBy exprP comma) - exprFunSemisP = liftM2 EApp funSymbolP (parenBrackets $ sepBy exprP semi) + exprFunSpacesP = EApp <$> funSymbolP <*> sepBy1 expr0P blanks + exprFunCommasP = EApp <$> funSymbolP <*> parens (sepBy exprP comma) + exprFunSemisP = EApp <$> funSymbolP <*> parenBrackets (sepBy exprP semi) funSymbolP = locParserP symbolP -- | BitVector literal: lit "#x00000001" (BitVec (Size32 obj)) litP = do reserved "lit" l <- stringLiteral - s <- try (bvSortP "Size32" S32) <|> bvSortP "Size64" S64 - return $ ECon $ L (T.pack l) (mkSort s) - where - bvSortP ss s = do parens (reserved "BitVec" >> parens (reserved ss >> reserved "obj")) - return s - + t <- sortP + return $ ECon $ L (T.pack l) t -- ORIG exprP :: Parser Expr -- ORIG exprP = expr2P <|> lexprP @@ -278,10 +284,12 @@ , Infix (reservedOp "+" >> return (EBin Plus )) AssocLeft ] , [ Infix (reservedOp "mod" >> return (EBin Mod )) AssocLeft] + , [ Infix (reservedOp ":" >> return (eCons )) AssocLeft] ] -eMinus = EBin Minus (expr (0 :: Integer)) - +eMinus = EBin Minus (expr (0 :: Integer)) +eCons x xs = EApp (dummyLoc consName) [x,xs] +eNil = EVar nilName exprCastP = do e <- exprP @@ -291,41 +299,71 @@ dcolon = string "::" <* spaces +varSortP = FVar <$> parens intP +funcSortP = parens $ FFunc <$> intP <* comma <*> sortsP + +sortsP = brackets $ sepBy sortP semi + sortP - = try (string "Integer" >> return FInt) - <|> try (string "Int" >> return FInt) - <|> try (string "int" >> return FInt) - <|> try (FObj . symbol <$> lowerIdP) - <|> (fApp <$> (Left <$> fTyConP) <*> many sortP) + = try (parens $ sortP) + <|> try (string "@" >> varSortP) + <|> try (string "func" >> funcSortP) + <|> try (fApp (Left listFTyCon) . single <$> brackets sortP) + <|> try bvSortP + <|> try (fApp <$> (Left <$> fTyConP) <*> sepBy sortP blanks) + <|> (FObj . symbol <$> lowerIdP) -symCharsP = condIdP symChars (`notElem` keyWordSyms) +bvSortP + = mkSort <$> (bvSizeP "Size32" S32 <|> bvSizeP "Size64" S64) +bvSizeP ss s = do + parens (reserved "BitVec" >> parens (reserved ss >> reserved "obj")) + return s + + + keyWordSyms = ["if", "then", "else", "mod"] --------------------------------------------------------------------- -------------------------- Predicates ------------------------------- --------------------------------------------------------------------- -trueP = reserved "true" >> return PTrue -falseP = reserved "false" >> return PFalse pred0P :: Parser Pred pred0P = trueP <|> falseP + <|> try kvarPredP <|> try (fastIfP pIte predP) <|> try predrP <|> try (parens predP) - <|> try (liftM PBexp funAppP) - <|> try (reservedOp "&&" >> liftM PAnd predsP) - <|> try (reservedOp "||" >> liftM POr predsP) + <|> try (PBexp <$> (reserved "?" *> exprP)) + <|> try (PBexp <$> funAppP) + <|> try (reservedOp "&&" >> PAnd <$> predsP) + <|> try (reservedOp "||" >> POr <$> predsP) +-- qmP = reserved "?" <|> reserved "Bexp" + +trueP, falseP :: Parser Pred +trueP = reserved "true" >> return PTrue +falseP = reserved "false" >> return PFalse + +kvarPredP :: Parser Pred +kvarPredP = PKVar <$> kvarP <*> substP + +kvarP :: Parser KVar +kvarP = KV <$> (char '$' *> symbolP) + +substP :: Parser Subst +substP = mkSubst <$> many (brackets $ pairP symbolP aP exprP) + where + aP = reserved ":=" + predP :: Parser Pred predP = buildExpressionParser lops pred0P predsP = brackets $ sepBy predP semi -qmP = reserved "?" <|> reserved "Bexp" lops = [ [Prefix (reservedOp "~" >> return PNot)] , [Prefix (reservedOp "not " >> return PNot)] @@ -381,36 +419,38 @@ ---------------------------------------------------------------------------------- fTyConP - = (reserved "int" >> return intFTyCon) - <|> (reserved "bool" >> return boolFTyCon) - <|> (reserved "real" >> return realFTyCon) - <|> (symbolFTycon <$> locUpperIdP) + = (reserved "int" >> return intFTyCon) + <|> (reserved "Integer" >> return intFTyCon) + <|> (reserved "Int" >> return intFTyCon) + <|> (reserved "int" >> return intFTyCon) + <|> (reserved "real" >> return realFTyCon) + <|> (reserved "bool" >> return boolFTyCon) + <|> (symbolFTycon <$> locUpperIdP) -refasP :: Parser [Refa] -refasP = (try (brackets $ sepBy (RConc <$> predP) semi)) - <|> liftM ((:[]) . RConc) predP +refaP :: Parser Refa +refaP = try (refa <$> brackets (sepBy predP semi)) + <|> (Refa <$> predP) -refBindP :: Parser Symbol -> Parser [Refa] -> Parser (Reft -> a) -> Parser a +refBindP :: Parser Symbol -> Parser Refa -> Parser (Reft -> a) -> Parser a refBindP bp rp kindP = braces $ do - vv <- bp - t <- kindP + x <- bp + t <- kindP reserved "|" - ras <- rp <* spaces - return $ t (Reft (vv, ras)) + ra <- rp <* spaces + return $ t (Reft (x, ra)) -bindP = liftM symbol (lowerIdP <* colon) -optBindP vv = try bindP <|> return vv +-- bindP = symbol <$> (lowerIdP <* colon) +bindP = symbolP <* colon +optBindP x = try bindP <|> return x -refP = refBindP bindP refasP -refDefP vv = refBindP (optBindP vv) +refP = refBindP bindP refaP +refDefP x = refBindP (optBindP x) --------------------------------------------------------------------- -- | Parsing Qualifiers --------------------------------------------- --------------------------------------------------------------------- --- qualifierP = mkQual <$> upperIdP <*> parens $ sepBy1 sortBindP comma <*> predP - qualifierP = do pos <- getPosition n <- upperIdP params <- parens $ sepBy1 sortBindP comma @@ -418,14 +458,37 @@ body <- predP return $ mkQual n params body pos -sortBindP = (,) <$> symbolP <* colon <*> sortP +sortBindP = (,) <$> symbolP <* colon <*> sortP -mkQual n xts p pos = Q n ((vv, t) : yts) (subst su p) pos +pairP :: Parser a -> Parser z -> Parser b -> Parser (a, b) +pairP xP sepP yP = (,) <$> xP <* sepP <*> yP + + +mkQual n xts p = Q n ((vv, t) : yts) (subst su p) where - (vv,t):zts = xts - yts = mapFst mkParam <$> zts - su = mkSubst $ zipWith (\(z,_) (y,_) -> (z, eVar y)) zts yts + (vv,t):zts = gSorts xts + yts = mapFst mkParam <$> zts + su = mkSubst $ zipWith (\(z,_) (y,_) -> (z, eVar y)) zts yts +gSorts :: [(a, Sort)] -> [(a, Sort)] +gSorts xts = [(x, substVars su t) | (x, t) <- xts] + where + su = (`zip` [0..]) . sortNub . concatMap sortVars . map snd $ xts + +substVars :: [(Symbol, Int)] -> Sort -> Sort +substVars su = mapSort tx + where + tx (FObj x) + | Just i <- lookup x su = FVar i + tx t = t + +sortVars :: Sort -> [Symbol] +sortVars = foldSort go [] + where + go b (FObj x) = x : b + go b _ = b + + mkParam s = symbol ('~' `T.cons` toUpper c `T.cons` cs) where Just (c,cs)= T.uncons $ symbolText s @@ -438,14 +501,14 @@ fInfoP = defsFInfo <$> many defP defP :: Parser (Def ()) -defP = Srt <$> (reserved "sort" >> colon >> sortP) - <|> Axm <$> (reserved "axiom" >> colon >> predP) - <|> Cst <$> (reserved "constraint" >> colon >> subCP) - <|> Wfc <$> (reserved "wf" >> colon >> wfCP) - <|> Con <$> (reserved "constant" >> symbolP) <*> (colon >> sortP) - <|> Qul <$> (reserved "qualifier" >> qualifierP) - <|> Kut <$> (reserved "cut" >> symbolP) - <|> IBind <$> (reserved "bind" >> intP) <*> symbolP <*> (colon >> sortedReftP) +defP = Srt <$> (reserved "sort" >> colon >> sortP) + <|> Axm <$> (reserved "axiom" >> colon >> predP) + <|> Cst <$> (reserved "constraint" >> colon >> subCP) + <|> Wfc <$> (reserved "wf" >> colon >> wfCP) + <|> Con <$> (reserved "constant" >> symbolP) <*> (colon >> sortP) + <|> Qul <$> (reserved "qualif" >> qualifierP) + <|> Kut <$> (reserved "cut" >> kvarP) + <|> IBind <$> (reserved "bind" >> intP) <*> symbolP <*> (colon >> sortedReftP) sortedReftP :: Parser SortedReft sortedReftP = refP (RR <$> (sortP <* spaces)) @@ -467,10 +530,18 @@ reserved "rhs" rhs <- sortedReftP reserved "id" - i <- (integer <* spaces) + i <- integer <* spaces tag <- tagP return $ safeHead "subCP" $ subC env grd lhs rhs (Just i) tag () +-- idVV :: Integer -> SortedReft -> SortedReft +-- idVV i sr = sr {sr_reft = ri } +-- where +-- ri = shiftVV r vvi +-- r = sr_reft sr +-- vvi = vv $ Just i + + tagP :: Parser [Int] tagP = try (reserved "tag" >> spaces >> (brackets $ sepBy intP semi)) <|> (return []) @@ -487,7 +558,7 @@ where cm = M.fromList [(cid c, c) | Cst c <- defs] ws = [w | Wfc w <- defs] - bs = rawBindEnv [(n, x, r) | IBind n x r <- defs] + bs = bindEnvFromList [(n, x, r) | IBind n x r <- defs] gs = fromListSEnv [(x, RR t mempty) | Con x t <- defs] lts = [(x, t) | Con x t <- defs, notFun t] kts = KS $ S.fromList [k | Kut k <- defs] @@ -518,17 +589,19 @@ solution1P = do reserved "solution:" - k <- symbolP + k <- kvP reserved ":=" ps <- brackets $ sepBy predSolP semi return (k, simplify $ PAnd ps) - -solutionP :: Parser (M.HashMap Symbol Pred) + where + kvP = try kvarP <|> (KV <$> symbolP) + +solutionP :: Parser (M.HashMap KVar Pred) solutionP = M.fromList <$> sepBy solution1P whiteSpace solutionFileP - = liftM2 (,) (fixResultP integer) solutionP + = (,) <$> fixResultP integer <*> solutionP ------------------------------------------------------------------------ @@ -542,7 +615,8 @@ = case runParser (remainderP (whiteSpace >> parser)) 0 f s of Left e -> die $ err (errorSpan e) $ printf "parseError %s\n when parsing from %s\n" (show e) f Right (r, "", _) -> r - Right (_, rem, l) -> die $ err (SS l l) $ printf "doParse has leftover when parsing: %s\nfrom file %s\n" rem f + Right (_, rem, l) -> die $ err (SS l l) + $ printf "doParse has leftover when parsing: %s\nfrom file %s\n" rem f errorSpan e = SS l l where l = errorPos e @@ -581,8 +655,8 @@ class Inputable a where rr :: String -> a rr' :: String -> String -> a - rr' = \_ -> rr - rr = rr' "" + rr' _ = rr + rr = rr' "" instance Inputable Symbol where rr' = doParse' symbolP @@ -596,8 +670,8 @@ instance Inputable Expr where rr' = doParse' exprP -instance Inputable [Refa] where - rr' = doParse' refasP +instance Inputable Refa where + rr' = doParse' refaP instance Inputable (FixResult Integer) where rr' = doParse' $ fixResultP integer diff --git a/src/Language/Fixpoint/PrettyPrint.hs b/src/Language/Fixpoint/PrettyPrint.hs --- a/src/Language/Fixpoint/PrettyPrint.hs +++ b/src/Language/Fixpoint/PrettyPrint.hs @@ -4,12 +4,14 @@ module Language.Fixpoint.PrettyPrint where +import Debug.Trace (trace) import Control.Applicative ((<$>)) import qualified Data.Text as T import Language.Fixpoint.Misc import Language.Fixpoint.Types import Text.Parsec import Text.PrettyPrint.HughesPJ +import qualified Data.HashMap.Strict as M class PPrint a where pprint :: a -> Doc @@ -22,22 +24,34 @@ showpp :: (PPrint a) => a -> String showpp = render . pprint +tracepp :: (PPrint a) => String -> a -> a +tracepp s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showpp x) x + instance PPrint a => PPrint (Maybe a) where pprint = maybe (text "Nothing") ((text "Just" <+>) . pprint) instance PPrint a => PPrint [a] where pprint = brackets . intersperse comma . map pprint +instance (PPrint a, PPrint b) => PPrint (M.HashMap a b) where + pprint = vcat . punctuate (text "\n") . map pp1 . M.toList + where + pp1 (x, y) = pprint x <+> text ":=" <+> pprint y + + instance (PPrint a, PPrint b, PPrint c) => PPrint (a, b, c) where - pprint (x, y, z) = parens $ (pprint x) <> text "," <> (pprint y) <> text "," <> (pprint z) + pprint (x, y, z) = parens $ pprint x <> text "," <> pprint y <> text "," <> pprint z instance (PPrint a, PPrint b) => PPrint (a,b) where - pprint (x, y) = (pprint x) <+> text ":" <+> (pprint y) + pprint (x, y) = pprint x <+> text ":" <+> pprint y instance PPrint SourcePos where pprint = text . show +instance PPrint Bool where + pprint = text . show + instance PPrint () where pprint = text . show @@ -67,9 +81,11 @@ instance PPrint Symbol where pprint = text . symbolString -instance PPrint SymConst where - pprint (SL x) = doubleQuotes $ text $ T.unpack x +instance PPrint KVar where + pprint (KV x) = text "$" <> pprint x +instance PPrint SymConst where + pprint (SL x) = doubleQuotes $ text $ T.unpack x -- | Wrap the enclosed 'Doc' in parentheses only if the condition holds. parensIf True = parens @@ -111,7 +127,7 @@ where zn = 2 pprintPrec z (EApp f es) = parensIf (z > za) $ intersperse empty $ - (pprint f) : (pprintPrec (za+1) <$> es) + pprint f : (pprintPrec (za+1) <$> es) where za = 8 pprintPrec z (EBin o e1 e2) = parensIf (z > zo) $ pprintPrec (zo+1) e1 <+> @@ -155,6 +171,7 @@ pprintPrec (za+1) e2 where za = 4 pprintPrec _ (PAll xts p) = text "forall" <+> toFix xts <+> text "." <+> pprint p + pprintPrec _ p@(PKVar {}) = toFix p trueD = text "true" falseD = text "false" @@ -165,15 +182,15 @@ pprintBin z _ o xs = intersperse o $ pprintPrec z <$> xs instance PPrint Refa where - pprintPrec z (RConc p) = pprintPrec z p - pprintPrec _ k = toFix k + pprintPrec z (Refa p) = pprintPrec z p + pprintPrec _ k = toFix k instance PPrint Reft where - pprint r@(Reft (_,ras)) + pprint r@(Reft (_,ra)) | isTauto r = text "true" | otherwise = {- intersperse comma -} pprintBin z trueD andD flat where - flat = flattenRefas ras + flat = flattenRefas [ra] z = if length flat > 1 then 3 else 0 instance PPrint SortedReft where @@ -182,4 +199,4 @@ $ (pprint v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> pprint ras instance PPrint a => PPrint (Located a) where - pprint (Loc _ x) = pprint x + pprint (Loc _ _ x) = pprint x diff --git a/src/Language/Fixpoint/SmtLib2.hs b/src/Language/Fixpoint/SmtLib2.hs --- a/src/Language/Fixpoint/SmtLib2.hs +++ b/src/Language/Fixpoint/SmtLib2.hs @@ -1,6 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} @@ -37,10 +35,20 @@ , command , smtWrite + -- * Query API + , smtDecl + , smtAssert + , smtCheckUnsat + , smtBracket + , smtDistinct + + -- * Theory Symbols , smt_set_funs + ) where import Language.Fixpoint.Config (SMTSolver (..)) +import Language.Fixpoint.Errors import Language.Fixpoint.Files import Language.Fixpoint.Types @@ -55,13 +63,14 @@ import qualified Data.Text.IO as TIO import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.IO as LTIO +import Data.IORef import System.Directory -import System.Exit +import System.Exit hiding (die) import System.FilePath import System.IO (Handle, IOMode (..), hClose, hFlush, openFile) import System.Process - +import Debug.Trace (trace) import qualified Data.Attoparsec.Text as A {- Usage: @@ -91,7 +100,7 @@ | Declare Symbol [Sort] Sort | Define Sort | Assert (Maybe Int) Pred - | Distinct [Expr] -- {v:[Expr] | (len v) >= 2} + | Distinct [Expr] -- {v:[Expr] | 2 <= len v} | GetValue [Symbol] deriving (Eq, Show) @@ -133,8 +142,8 @@ -smtWrite :: Context -> LT.Text -> IO () -smtWrite me !s = smtWriteRaw me s +smtWrite :: Context -> LT.Text -> IO () +smtWrite me !s = smtWriteRaw me s smtRead :: Context -> IO Response smtRead me = {-# SCC "smtRead" #-} @@ -199,9 +208,9 @@ -------------------------------------------------------------------------- -------------------------------------------------------------------------- -makeContext :: SMTSolver -> IO Context +makeContext :: SMTSolver -> FilePath -> IO Context -------------------------------------------------------------------------- -makeContext s +makeContext s f = do me <- makeProcess s pre <- smtPreamble s me createDirectoryIfMissing True $ takeDirectory smtFile @@ -209,9 +218,12 @@ let me' = me { cLog = Just hLog } mapM_ (smtWrite me') pre return me' + where + smtFile = extFileName Smt2 f + makeContextNoLog s - = do me <- makeProcess s + = do me <- makeProcess s pre <- smtPreamble s me mapM_ (smtWrite me) pre return me @@ -245,29 +257,49 @@ r <- (!!1) . T.splitOn "\"" <$> smtReadRaw me case T.words r of "4.3.2" : _ -> return $ z3_432_options ++ z3Preamble - _ -> return $ z3_options ++ z3Preamble + _ -> return $ z3_options ++ z3Preamble smtPreamble _ _ = return smtlibPreamble -smtFile :: FilePath -smtFile = extFileName Smt2 "out" - ----------------------------------------------------------------------------- -- | SMT Commands ----------------------------------------------------------- ----------------------------------------------------------------------------- -smtDecl me x ts t = interact' me (Declare x ts t) -smtPush me = interact' me (Push) -smtPop me = interact' me (Pop) +smtPush, smtPop :: Context -> IO () +smtPush me = interact' me Push +smtPop me = interact' me Pop + + +smtDecl :: Context -> Symbol -> Sort -> IO () +smtDecl me x t = interact' me (Declare x ins out) + where + (ins, out) = deconSort t + +deconSort :: Sort -> ([Sort], Sort) +deconSort t = case functionSort t of + Just (_, ins, out) -> (ins, out) + Nothing -> ([] , t ) + +smtAssert :: Context -> Pred -> IO () smtAssert me p = interact' me (Assert Nothing p) + +smtDistinct :: Context -> [Expr] -> IO () smtDistinct me az = interact' me (Distinct az) + +smtCheckUnsat :: Context -> IO Bool smtCheckUnsat me = respSat <$> command me CheckSat -respSat Unsat = True -respSat Sat = False -respSat Unknown = False -respSat r = error "crash: SMTLIB2 respSat" +smtBracket :: Context -> IO a -> IO a +smtBracket me a = do smtPush me + r <- a + smtPop me + return r +respSat Unsat = True +respSat Sat = False +respSat Unknown = False +respSat r = die $ err dummySpan $ "crash: SMTLIB2 respSat = " ++ show r + interact' me cmd = command me cmd >> return () @@ -296,10 +328,20 @@ sel = "smt_map_sel" sto = "smt_map_sto" +setEmp = "Set_emp" :: Symbol +setCap = "Set_cap" :: Symbol +setSub = "Set_sub" :: Symbol +setAdd = "Set_add" :: Symbol +setMem = "Set_mem" :: Symbol +setCom = "Set_com" :: Symbol +setCup = "Set_cup" :: Symbol +setDif = "Set_dif" :: Symbol +setSng = "Set_sng" :: Symbol + smt_set_funs :: M.HashMap Symbol Raw -smt_set_funs = M.fromList [ ("Set_emp",emp),("Set_add",add),("Set_cup",cup) - , ("Set_cap",cap),("Set_mem",mem),("Set_dif",dif) - , ("Set_sub",sub),("Set_com",com)] +smt_set_funs = M.fromList [ (setEmp, emp), (setAdd, add), (setCup, cup) + , (setCap, cap), (setMem, mem), (setDif, dif) + , (setSub, sub), (setCom, com)] -- DON'T REMOVE THIS! z3 changed the names of options between 4.3.1 and 4.3.2... z3_432_options @@ -372,8 +414,8 @@ smt2 (FApp t []) | t == intFTyCon = "Int" smt2 (FApp t []) | t == boolFTyCon = "Bool" smt2 (FApp t [FApp ts _,_]) | t == appFTyCon && fTyconSymbol ts == "Set_Set" = "Set" - smt2 (FObj s) = smt2 s - smt2 (FFunc _ _) = error "smt2 FFunc" + -- smt2 (FObj s) = smt2 s + smt2 s@(FFunc _ _) = error $ "smt2 FFunc: " ++ show s smt2 _ = "Int" instance SMTLIB2 Symbol where @@ -419,21 +461,27 @@ smt2 (ECon c) = smt2 c smt2 (EVar x) = smt2 x smt2 (ELit x _) = smt2 x - smt2 (EApp f []) = smt2 f - smt2 (EApp f [e]) | val f == "Set_emp" - = format "(= {} {})" (emp, smt2 e) - smt2 (EApp f [e]) | val f == "Set_sng" - = format "({} {} {})" (add, emp, smt2 e) - smt2 (EApp f es) = format "({} {})" (smt2 f, smt2s es) + smt2 (EApp f es) = smt2App f es smt2 (ENeg e) = format "(- {})" (Only $ smt2 e) smt2 (EBin o e1 e2) = format "({} {} {})" (smt2 o, smt2 e1, smt2 e2) smt2 (EIte e1 e2 e3) = format "(ite {} {} {})" (smt2 e1, smt2 e2, smt2 e3) - smt2 _ = error "TODO: SMTLIB2 Expr" + smt2 (ECst e _) = smt2 e + smt2 e = error $ "TODO: SMTLIB2 Expr: " ++ show e +smt2App :: LocSymbol -> [Expr] -> LT.Text +smt2App f [] = smt2 f +smt2App f [e] + | val f == setEmp = format "(= {} {})" (emp, smt2 e) + | val f == setSng = format "({} {} {})" (add, emp, smt2 e) +smt2App f es = format "({} {})" (smt2 f, smt2s es) + + instance SMTLIB2 Pred where smt2 (PTrue) = "true" smt2 (PFalse) = "false" + smt2 (PAnd []) = "true" smt2 (PAnd ps) = format "(and {})" (Only $ smt2s ps) + smt2 (POr []) = "false" smt2 (POr ps) = format "(or {})" (Only $ smt2s ps) smt2 (PNot p) = format "(not {})" (Only $ smt2 p) smt2 (PImp p q) = format "(=> {} {})" (smt2 p, smt2 q) @@ -476,3 +524,6 @@ (check-sat) (pop 1) -} + +------------------------------------------------------------------- + diff --git a/src/Language/Fixpoint/Solver/Deps.hs b/src/Language/Fixpoint/Solver/Deps.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Deps.hs @@ -0,0 +1,96 @@ +module Language.Fixpoint.Solver.Deps + ( -- * Dummy Solver for Debugging Kuts + solve + + -- * KV-Dependencies + , deps + , Deps (..) + + -- * Reads and Writes of Constraints + , lhsKVars + , rhsKVars + ) where + +import Language.Fixpoint.Config +import Language.Fixpoint.Misc (groupList) +import Language.Fixpoint.Names (nonSymbol) +import qualified Language.Fixpoint.Types as F + +import qualified Language.Fixpoint.Visitor as V +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.Graph as G + +import Control.Monad.State + +data Deps = Deps { depCuts :: ![F.KVar] + , depNonCuts :: ![F.KVar] + } + deriving (Eq, Ord, Show) + + +-------------------------------------------------------------- +-- | Dummy just for debugging -------------------------------- +-------------------------------------------------------------- +solve :: Config -> F.FInfo a -> IO (F.FixResult a) +-------------------------------------------------------------- +solve _ fi = do + let d = deps fi + print "(begin cuts debug)" + print "Cuts:" + print (depCuts d) + print "Non-cuts:" + print (depNonCuts d) + print "(end cuts debug)" + return F.Safe + + +-------------------------------------------------------------- +-- | Compute Dependencies and Cuts --------------------------- +-------------------------------------------------------------- + +deps :: F.FInfo a -> Deps +deps finfo = sccsToDeps sccs (F.kuts finfo) + where + bs = F.bs finfo + subCs = M.elems (F.cm finfo) + edges = concatMap (subcEdges bs) subCs + graph = [(k,k,ks) | (k, ks) <- groupList edges] + sccs = G.stronglyConnCompR graph + +sccsToDeps :: [G.SCC (F.KVar, F.KVar,[F.KVar])] -> F.Kuts -> Deps +sccsToDeps xs ks = execState (mapM_ (bar ks) xs) (Deps [] []) + +bar :: F.Kuts -> G.SCC (F.KVar, F.KVar,[F.KVar]) -> State Deps () +bar _ (G.AcyclicSCC (v,_,_)) = do ds <- get + put ds {depNonCuts = v : depNonCuts ds} +bar ks (G.CyclicSCC vs) = do let (v,vs') = chooseCut vs ks + ds <- get + put ds {depCuts = v : depCuts ds} + mapM_ (bar ks) (G.stronglyConnCompR vs') + +chooseCut :: [(F.KVar, F.KVar, [F.KVar])] -> F.Kuts -> (F.KVar, [(F.KVar, F.KVar,[F.KVar])]) +chooseCut vs (F.KS ks) = (v, [x | x@(u,_,_) <- vs, u /= v]) + where + vs' = [x | (x,_,_) <- vs] + is = S.intersection (S.fromList vs') ks + v = head $ if S.null is then vs' else S.toList is + +subcEdges :: F.BindEnv -> F.SubC a -> [(F.KVar, F.KVar)] +subcEdges bs c = [(k1, k2) | k1 <- lhsKVars bs c + , k2 <- rhsKVars c ] + ++ [(k2, F.KV nonSymbol) | k2 <- rhsKVars c] +-- this nonSymbol hack is one way to prevent nodes with potential +-- outdegree 0 from getting pruned by stronglyConnCompR + +lhsKVars :: F.BindEnv -> F.SubC a -> [F.KVar] +lhsKVars bs c = envKVs ++ lhsKVs + where + envKVs = V.envKVars bs c + lhsKVs = V.kvars $ F.lhsCs c + +rhsKVars :: F.SubC a -> [F.KVar] +rhsKVars = V.kvars . F.rhsCs + + +--------------------------------------------------------------- diff --git a/src/Language/Fixpoint/Solver/Eliminate.hs b/src/Language/Fixpoint/Solver/Eliminate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Eliminate.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE FlexibleContexts #-} +module Language.Fixpoint.Solver.Eliminate + (eliminateAll) where + +import Language.Fixpoint.Types +import qualified Language.Fixpoint.Solver.Deps as D +import Language.Fixpoint.Visitor (kvars, mapKVars) +import Language.Fixpoint.Names (existSymbol) +import Language.Fixpoint.Misc (errorstar) + +import qualified Data.HashMap.Strict as M +import Data.List (partition, (\\)) +import Data.Foldable (foldlM) +import Control.Monad.State (get, put, runState, evalState, State) + + +-------------------------------------------------------------- +eliminateAll :: FInfo a -> FInfo a +eliminateAll fi = evalState (foldlM eliminate fi (D.depNonCuts ds)) 0 + where + ds = D.deps fi +-------------------------------------------------------------- + + +class Elimable a where + elimKVar :: KVar -> Pred -> a -> a + +instance Elimable (SubC a) where + -- we don't bother editing srhs since if kv is on the rhs then the entire constraint should get eliminated + elimKVar kv pr x = x { slhs = elimKVar kv pr (slhs x) } + +instance Elimable SortedReft where + elimKVar kv pr x = x { sr_reft = elimKVar kv pr (sr_reft x) } + +instance Elimable Reft where + elimKVar kv pr = mapKVars go + where + go k = if kv == k then Just pr else Nothing + +instance Elimable (FInfo a) where + elimKVar kv pr x = x { cm = M.map (elimKVar kv pr) (cm x) + , bs = elimKVar kv pr (bs x) + } + +instance Elimable BindEnv where + elimKVar kv pr = mapBindEnv (\(sym, sr) -> (sym, elimKVar kv pr sr)) + + +eliminate :: FInfo a -> KVar -> State Integer (FInfo a) +eliminate fInfo kv = do + n <- get + let relevantSubCs = M.filter ( elem kv . D.rhsKVars) (cm fInfo) + let remainingSubCs = M.filter (notElem kv . D.rhsKVars) (cm fInfo) + let (kvWfC, remainingWs) = findWfC kv (ws fInfo) + let (bindingsList, (n', orPred)) = runState (mapM (extractPred kvWfC (bs fInfo)) (M.elems relevantSubCs)) (n, POr []) + let bindings = concat bindingsList + + let be = bs fInfo + let (ids, be') = insertsBindEnv [(sym, trueSortedReft srt) | (sym, srt) <- bindings] be + let newSubCs = M.map (\s -> s { senv = insertsIBindEnv ids (senv s)}) remainingSubCs + put n' + return $ elimKVar kv orPred (fInfo { cm = newSubCs , ws = remainingWs , bs = be' }) + +insertsBindEnv :: [(Symbol, SortedReft)] -> BindEnv -> ([BindId], BindEnv) +insertsBindEnv bs = runState (mapM go bs) + where + go (sym, srft) = do be <- get + let (id, be') = insertBindEnv sym srft be + put be' + return id + +findWfC :: KVar -> [WfC a] -> (WfC a, [WfC a]) +findWfC kv ws = (w', ws') + where + (w, ws') = partition (elem kv . kvars . sr_reft . wrft) ws + w' | [x] <- w = x + | otherwise = errorstar $ (show kv) ++ " needs exactly one wf constraint" + +extractPred :: WfC a -> BindEnv -> SubC a -> State (Integer, Pred) [(Symbol, Sort)] +extractPred wfc be subC = do (n, (POr preds)) <- get + let (bs, (n', pr')) = runState (mapM renameVar vars) (n, PAnd $ pr : [(blah (kVarVV, slhs subC))] ++ suPreds') + put (n', POr $ pr' : preds) + return bs + where + wfcIBinds = elemsIBindEnv $ wenv wfc + subcIBinds = elemsIBindEnv $ senv subC + unmatchedIBinds | wfcIBinds `subset` subcIBinds = subcIBinds \\ wfcIBinds + | otherwise = errorstar $ "kVar is not well formed (missing bindings)" ++ "kVar: " ++ (showFix wfc) ++ "constraint: " ++ (showFix subC) + unmatchedIBindEnv = insertsIBindEnv unmatchedIBinds emptyIBindEnv + unmatchedBindings = envCs be unmatchedIBindEnv + + kvSreft = wrft wfc + kVarVV = reftBind $ sr_reft kvSreft + + (vars, pr) = baz unmatchedBindings + + reft = sr_reft $ srhs subC + suPreds = substPreds $ reftPred reft + sub = ((reftBind reft), (eVar kVarVV)) + suPreds' = [subst1 p sub | p <- suPreds] + +-- on rhs, k0[v:=z] -> [v = z] +substPreds :: Pred -> [Pred] +substPreds (PKVar _ (Su subs)) = map (\(sym, expr) -> PAtom Eq (eVar sym) expr) subs + +renameVar :: (Symbol, Sort) -> State (Integer, Pred) (Symbol, Sort) +renameVar (sym, srt) = do (n, pr) <- get + let sym' = existSymbol sym n + put ((n+1), subst1 pr (sym, eVar sym')) + return (sym', srt) + +subset :: (Eq a) => [a] -> [a] -> Bool +subset xs ys = (xs \\ ys) == [] + +-- [ x:{v:int|v=10} , y:{v:int|v=20} ] -> [x:int, y:int], (x=10) /\ (y=20) +baz :: [(Symbol, SortedReft)] -> ([(Symbol,Sort)],Pred) +baz bindings = (bs, PAnd $ map blah bindings) + where + bs = map (\(sym, sreft) -> (sym, sr_sort sreft)) bindings + +-- [ x:{v:int|v=10} ] -> (x=10) +blah :: (Symbol, SortedReft) -> Pred +blah (sym, sr) = subst1 (reftPred reft) sub + where + reft = sr_reft sr + sub = ((reftBind reft), (eVar sym)) diff --git a/src/Language/Fixpoint/Solver/Monad.hs b/src/Language/Fixpoint/Solver/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Monad.hs @@ -0,0 +1,103 @@ +-- | This is a wrapper around IO that permits SMT queries + +module Language.Fixpoint.Solver.Monad + ( -- * Type + SolveM + + -- * Execution + , runSolverM + + -- * Get Binds + , getBinds + + -- * SMT Query + , filterValid + + -- * Debug + , tickIter + + ) + where + +import Language.Fixpoint.Config (Config, inFile, solver) +import qualified Language.Fixpoint.Types as F +import qualified Language.Fixpoint.Errors as E +import Language.Fixpoint.SmtLib2 +import Language.Fixpoint.Solver.Validate +import Language.Fixpoint.Solver.Solution +import Data.Maybe (catMaybes) +import Control.Applicative ((<$>)) +import Control.Monad.State.Strict + +--------------------------------------------------------------------------- +-- | Solver Monadic API --------------------------------------------------- +--------------------------------------------------------------------------- + +type SolveM = StateT SolverState IO + +data SolverState = SS { ssCtx :: !Context + , ssBinds :: !F.BindEnv + , ssIter :: !Int + } + +--------------------------------------------------------------------------- +runSolverM :: Config -> F.FInfo b -> SolveM a -> IO a +--------------------------------------------------------------------------- +runSolverM cfg fi act = do + ctx <- makeContext (solver cfg) (inFile cfg) + fst <$> runStateT (declare fi >> act) (SS ctx be 0) + where + be = F.bs fi + +--------------------------------------------------------------------------- +getBinds :: SolveM F.BindEnv +--------------------------------------------------------------------------- +getBinds = ssBinds <$> get + +--------------------------------------------------------------------------- +getIter :: SolveM Int +--------------------------------------------------------------------------- +getIter = ssIter <$> get + +--------------------------------------------------------------------------- +incIter :: SolveM () +--------------------------------------------------------------------------- +incIter = modify $ \s -> s {ssIter = 1 + ssIter s} + +--------------------------------------------------------------------------- +tickIter :: SolveM Int +--------------------------------------------------------------------------- +tickIter = incIter >> getIter + +withContext :: (Context -> IO a) -> SolveM a +withContext k = (lift . k) =<< getContext + +getContext :: SolveM Context +getContext = ssCtx <$> get + + +--------------------------------------------------------------------------- +-- | SMT Interface -------------------------------------------------------- +--------------------------------------------------------------------------- +filterValid :: F.Pred -> Cand a -> SolveM [a] +--------------------------------------------------------------------------- +filterValid p qs = + withContext $ \me -> + smtBracket me $ + filterValid_ p qs me + +filterValid_ :: F.Pred -> Cand a -> Context -> IO [a] +filterValid_ p qs me = catMaybes <$> do + smtAssert me p + forM qs $ \(q, x) -> + smtBracket me $ do + smtAssert me (F.PNot q) + valid <- smtCheckUnsat me + return $ if valid then Just x else Nothing + +--------------------------------------------------------------------------- +declare :: F.FInfo a -> SolveM () +--------------------------------------------------------------------------- +declare fi = withContext $ \me -> do + xts <- either E.die return $ symbolSorts fi + forM_ xts $ uncurry $ smtDecl me diff --git a/src/Language/Fixpoint/Solver/Solution.hs b/src/Language/Fixpoint/Solver/Solution.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Solution.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} + +module Language.Fixpoint.Solver.Solution + ( -- * Solutions and Results + Solution, Cand, EQual (..) + + -- * Types with Template/KVars + , Solvable (..) + + -- * Initial Solution + , init + + -- * Update Solution + , update + + -- * Lookup Solution + , lookup + ) +where + +import Control.Applicative ((<$>)) +import qualified Data.HashMap.Strict as M +import qualified Data.List as L +import Data.Maybe (maybeToList, isNothing) -- , fromMaybe) +import Language.Fixpoint.PrettyPrint +import Language.Fixpoint.Config +import Language.Fixpoint.Visitor as V +import qualified Language.Fixpoint.Sort as So +import Language.Fixpoint.Misc +import qualified Language.Fixpoint.Types as F +import Prelude hiding (init, lookup) +-- import Text.Printf (printf) + +--------------------------------------------------------------------- +-- | Types ---------------------------------------------------------- +--------------------------------------------------------------------- + +type Solution = Sol KBind +type Sol a = M.HashMap F.KVar a +type KBind = [EQual] +type Cand a = [(F.Pred, a)] + +lookup :: Solution -> F.KVar -> KBind +lookup s k = M.lookupDefault [] k s + +--------------------------------------------------------------------- +-- | Expanded or Instantiated Qualifier ----------------------------- +--------------------------------------------------------------------- + +data EQual = EQL { eqQual :: !F.Qualifier + , eqPred :: !F.Pred + , eqArgs :: ![F.Expr] + } + deriving (Eq, Ord, Show) + +instance PPrint EQual where + pprint = pprint . eqPred + +{-@ EQL :: q:_ -> p:_ -> ListX F.Expr {q_params q} -> _ @-} + +eQual :: F.Qualifier -> [F.Symbol] -> EQual +eQual q xs = EQL q p es + where + p = F.subst su $ F.q_body q + su = F.mkSubst $ safeZip "eQual" qxs es + es = F.eVar <$> xs + qxs = fst <$> F.q_params q + +------------------------------------------------------------------------ +-- | Update Solution --------------------------------------------------- +------------------------------------------------------------------------ +update :: Solution -> [F.KVar] -> [(F.KVar, EQual)] -> (Bool, Solution) +------------------------------------------------------------------------- +update s ks kqs = {- tracepp msg -} (or bs, s') + where + kqss = groupKs ks kqs + (bs, s') = folds update1 s kqss + -- msg = printf "ks = %s, s = %s" (showpp ks) (showpp s) + + +groupKs :: [F.KVar] -> [(F.KVar, EQual)] -> [(F.KVar, [EQual])] +groupKs ks kqs = M.toList $ groupBase m0 kqs + where + m0 = M.fromList $ (,[]) <$> ks + +update1 :: Solution -> (F.KVar, KBind) -> (Bool, Solution) +update1 s (k, qs) = (change, M.insert k qs s) + where + oldQs = lookup s k + change = length oldQs /= length qs + + +-------------------------------------------------------------------- +-- | Initial Solution (from Qualifiers and WF constraints) --------- +-------------------------------------------------------------------- +init :: Config -> F.FInfo a -> Solution +-------------------------------------------------------------------- +init _ fi = {- tracepp "init solution" -} s + where + s = L.foldl' (refine fi qs) s0 ws + s0 = M.empty + qs = F.quals fi + ws = F.ws fi + +-------------------------------------------------------------------- +refine :: F.FInfo a + -> [F.Qualifier] + -> Solution + -> F.WfC a + -> Solution +-------------------------------------------------------------------- +refine fi qs s w = refineK env qs s (wfKvar w) + where + env = F.fromListSEnv $ F.envCs (F.bs fi) (F.wenv w) + + +refineK :: F.SEnv F.SortedReft + -> [F.Qualifier] + -> Solution + -> (F.Symbol, F.Sort, F.KVar) + -> Solution +refineK env qs s (v, t, k) = M.insert k eqs' s + where + eqs' = case M.lookup k s of + Nothing -> instK env v t qs + Just eqs -> [eq | eq <- eqs, okInst env v t eq] + +-------------------------------------------------------------------- +instK :: F.SEnv F.SortedReft + -> F.Symbol + -> F.Sort + -> [F.Qualifier] + -> [EQual] +-------------------------------------------------------------------- +instK env v t = unique . concatMap (instKQ env v t) + where + unique qs = M.elems $ M.fromList [(eqPred q, q) | q <- qs ] + +instKQ :: F.SEnv F.SortedReft + -> F.Symbol + -> F.Sort + -> F.Qualifier + -> [EQual] +instKQ env v t q + = do (su0, v0) <- candidates [(v, t)] qt + xs <- match xts [v0] (So.apply su0 <$> qts) + return $ eQual q (reverse xs) + where + qt : qts = snd <$> F.q_params q + xts = instCands env + +instCands :: F.SEnv F.SortedReft -> [(F.Symbol, F.Sort)] +instCands = filter isOk . F.toListSEnv . fmap F.sr_sort + where + isOk = isNothing . F.functionSort . snd + +match :: [(F.Symbol, F.Sort)] -> [F.Symbol] -> [F.Sort] -> [[F.Symbol]] +match xts xs (t : ts) + = do (su, x) <- candidates xts t + match xts (x : xs) (So.apply su <$> ts) +match _ xs [] + = return xs + + +----------------------------------------------------------------------- +candidates :: [(F.Symbol, F.Sort)] -> F.Sort -> [(So.TVSubst, F.Symbol)] +----------------------------------------------------------------------- +candidates xts t' + = [(su, x) | (x, t) <- xts, su <- maybeToList $ So.unify t' t] + +----------------------------------------------------------------------- +wfKvar :: F.WfC a -> (F.Symbol, F.Sort, F.KVar) +----------------------------------------------------------------------- +wfKvar w@(F.WfC {F.wrft = sr}) + | F.Reft (v, F.Refa (F.PKVar k su)) <- F.sr_reft sr + , F.isEmptySubst su = (v, F.sr_sort sr, k) + | otherwise = errorstar $ "wfKvar: malformed wfC " ++ show w + +----------------------------------------------------------------------- +okInst :: F.SEnv F.SortedReft -> F.Symbol -> F.Sort -> EQual -> Bool +----------------------------------------------------------------------- +okInst env v t eq = isNothing $ So.checkSortedReftFull env sr + where + sr = F.RR t (F.Reft (v, F.Refa (eqPred eq))) + +--------------------------------------------------------------------- +-- | Apply Solution ------------------------------------------------- +--------------------------------------------------------------------- + +class Solvable a where + apply :: Solution -> a -> F.Pred + +instance Solvable EQual where + apply _ = eqPred + +instance Solvable F.KVar where + apply s k = apply s $ safeLookup err k s + where + err = "apply: Unknown KVar " ++ show k + +instance Solvable (F.KVar, F.Subst) where + apply s (k, su) = F.subst su (apply s k) + +instance Solvable F.Pred where + apply s = V.trans (V.defaultVisitor {V.txPred = tx}) () () + where + tx _ (F.PKVar k su) = apply s (k, su) + tx _ p = p + +instance Solvable F.Refa where + apply s = apply s . F.raPred + +instance Solvable F.Reft where + apply s = apply s . F.reftPred + +instance Solvable F.SortedReft where + apply s = apply s . F.sr_reft + +instance Solvable (F.Symbol, F.SortedReft) where + apply s (x, sr) = p `F.subst1` (v, F.eVar x) + where + p = apply s r + F.Reft (v, r) = F.sr_reft sr + +instance Solvable a => Solvable [a] where + apply s = F.pAnd . fmap (apply s) + diff --git a/src/Language/Fixpoint/Solver/Solve.hs b/src/Language/Fixpoint/Solver/Solve.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Solve.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} + +-- | Solve a system of horn-clause constraints ---------------------------- + +module Language.Fixpoint.Solver.Solve (solve) where + +import Control.Monad (filterM) +import Control.Applicative ((<$>)) +import qualified Data.HashMap.Strict as M +import qualified Language.Fixpoint.Types as F +import Language.Fixpoint.Config +import Language.Fixpoint.PrettyPrint +import Language.Fixpoint.Solver.Validate +import qualified Language.Fixpoint.Solver.Solution as S +import qualified Language.Fixpoint.Solver.Worklist as W +import Language.Fixpoint.Solver.Monad +import qualified Data.List as L +import Debug.Trace (trace) +import Text.Printf (printf) +--------------------------------------------------------------------------- +solve :: Config -> F.FInfo a -> IO (F.Result a) +--------------------------------------------------------------------------- +solve cfg fi = runSolverM cfg fi' $ solve_ cfg fi' + where + Right fi' = validate cfg fi + +--------------------------------------------------------------------------- +solve_ :: Config -> F.FInfo a -> SolveM (F.Result a) +--------------------------------------------------------------------------- +solve_ cfg fi = refine s0 wkl >>= result fi + where + s0 = S.init cfg fi + wkl = W.init cfg fi + +--------------------------------------------------------------------------- +refine :: S.Solution -> W.Worklist a -> SolveM S.Solution +--------------------------------------------------------------------------- +refine s w + | Just (c, w') <- W.pop w = do i <- tickIter + (b, s') <- refineC i s c + let w'' = if b then W.push c w' else w' + refine s' w'' + -- $ trace (refineMsg i c b w'') w'' + | otherwise = return s + +-- DEBUG +-- refineMsg i c b w = printf "REFINE: iter = %d cid = %s change = %s wkl = %s" +-- i (show $ F.sid c) (show b) (showpp w) + +--------------------------------------------------------------------------- +-- | Single Step Refinement ----------------------------------------------- +--------------------------------------------------------------------------- +refineC :: Int -> S.Solution -> F.SubC a -> SolveM (Bool, S.Solution) +--------------------------------------------------------------------------- +refineC i s c + | null rhs = return (False, s) + | otherwise = do lhs <- lhsPred s c <$> getBinds + kqs <- filterValid lhs rhs + return $ S.update s ks {- $ tracepp (msg ks rhs kqs) -} kqs + where + (ks, rhs) = rhsCands s c + -- msg ks xs ys = printf "refineC: iter = %d, ks = %s, rhs = %d, rhs' = %d \n" i (showpp ks) (length xs) (length ys) + +lhsPred :: S.Solution -> F.SubC a -> F.BindEnv -> F.Pred +lhsPred s c be = F.pAnd $ pGrd : pLhs : pBinds + where + pGrd = F.sgrd c + pLhs = S.apply s $ F.lhsCs c + pBinds = S.apply s <$> xts + xts = F.envCs be $ F.senv c + +rhsCands :: S.Solution -> F.SubC a -> ([F.KVar], S.Cand (F.KVar, S.EQual)) +rhsCands s c = (fst <$> ks, kqs) + where + kqs = [ cnd k su q | (k, su) <- ks, q <- S.lookup s k] + ks = predKs . F.reftPred . F.rhsCs $ c + cnd k su q = (F.subst su (S.eqPred q), (k, q)) + +predKs :: F.Pred -> [(F.KVar, F.Subst)] +predKs (F.PAnd ps) = concatMap predKs ps +predKs (F.PKVar k su) = [(k, su)] +predKs _ = [] + +--------------------------------------------------------------------------- +-- | Convert Solution into Result ----------------------------------------- +--------------------------------------------------------------------------- +result :: F.FInfo a -> S.Solution -> SolveM (F.Result a) +--------------------------------------------------------------------------- +result fi s = (, sol) <$> result_ fi s + where + sol = M.map (F.pAnd . fmap S.eqPred) s + +result_ :: F.FInfo a -> S.Solution -> SolveM (F.FixResult (F.SubC a)) +result_ fi s = res <$> filterM (isUnsat s) cs + where + cs = M.elems $ F.cm fi + res [] = F.Safe + res cs' = F.Unsafe cs' + +--------------------------------------------------------------------------- +isUnsat :: S.Solution -> F.SubC a -> SolveM Bool +--------------------------------------------------------------------------- +isUnsat s c = do + lp <- lhsPred s c <$> getBinds + let rp = rhsPred s c + not <$> isValid lp rp + +isValid :: F.Pred -> F.Pred -> SolveM Bool +isValid p q = (not . null) <$> filterValid p [(q, ())] + +rhsPred :: S.Solution -> F.SubC a -> F.Pred +rhsPred s c = S.apply s $ F.rhsCs c + diff --git a/src/Language/Fixpoint/Solver/Validate.hs b/src/Language/Fixpoint/Solver/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Validate.hs @@ -0,0 +1,100 @@ +-- | Validate and Transform Constraints to Ensure various Invariants ------------------------- +-- 1. Each binder must be unique + +module Language.Fixpoint.Solver.Validate + ( -- * Validate and Transform FInfo to enforce invariants + validate + + -- * Sorts for each Symbol + , symbolSorts + ) + where + +import Language.Fixpoint.Config +import Language.Fixpoint.PrettyPrint +import qualified Language.Fixpoint.Misc as Misc +import qualified Language.Fixpoint.Types as F +import qualified Language.Fixpoint.Errors as E +import qualified Data.HashMap.Strict as M +import qualified Data.List as L +-- import Control.Monad (filterM) +-- import Control.Applicative ((<$>)) +-- import Debug.Trace (trace) +import Text.Printf + +--------------------------------------------------------------------------- +validate :: Config -> F.FInfo a -> Either E.Error (F.FInfo a) +--------------------------------------------------------------------------- +validate _ = Right . renameVV + +--------------------------------------------------------------------------- +-- | symbol |-> sort for EVERY variable in the FInfo +--------------------------------------------------------------------------- +symbolSorts :: F.FInfo a -> Either E.Error [(F.Symbol, F.Sort)] +--------------------------------------------------------------------------- +symbolSorts fi = compact . (\z -> lits ++ consts ++ z) =<< bindSorts fi + where + lits = F.lits fi + consts = [(x, t) | (x, F.RR t _) <- F.toListSEnv $ F.gs fi] + +compact :: [(F.Symbol, F.Sort)] -> Either E.Error [(F.Symbol, F.Sort)] +compact xts + | null bad = Right [(x, t) | (x, [t]) <- ok ] + | otherwise = Left $ dupBindErrors bad + where + (bad, ok) = L.partition multiSorted . binds $ xts + binds = M.toList . M.map Misc.sortNub . Misc.group + +--------------------------------------------------------------------------- +bindSorts :: F.FInfo a -> Either E.Error [(F.Symbol, F.Sort)] +--------------------------------------------------------------------------- +bindSorts fi + | null bad = Right [ (x, t) | (x, [(t, _)]) <- ok ] + | otherwise = Left $ dupBindErrors [ (x, map fst ts) | (x, ts) <- bad] + where + (bad, ok) = L.partition multiSorted . binds $ fi + binds = symBinds . F.bs + +multiSorted :: (x, [t]) -> Bool +multiSorted = (1 <) . length . snd + +dupBindErrors :: [(F.Symbol, [F.Sort])] -> E.Error +dupBindErrors = foldr1 E.catError . map dbe + where + dbe (x, y) = E.err E.dummySpan $ printf "Multiple sorts for %s : %s \n" (showpp x) (showpp y) + +--------------------------------------------------------------------------- +symBinds :: F.BindEnv -> [SymBinds] +--------------------------------------------------------------------------- +symBinds = M.toList + . M.map Misc.groupList + . Misc.group + . binders + +type SymBinds = (F.Symbol, [(F.Sort, [F.BindId])]) + +binders :: F.BindEnv -> [(F.Symbol, (F.Sort, F.BindId))] +binders be = [(x, (F.sr_sort t, i)) | (i, x, t) <- F.bindEnvToList be] + +--------------------------------------------------------------------------- +-- | Alpha Rename bindings to ensure each var appears in unique binder +--------------------------------------------------------------------------- +renameVV :: F.FInfo a -> F.FInfo a +--------------------------------------------------------------------------- +renameVV fi = fi {F.bs = be'} + where + vts = map subcVV $ M.elems $ F.cm fi + be' = L.foldl' addVV be vts + be = F.bs fi + +addVV :: F.BindEnv -> (F.Symbol, F.SortedReft) -> F.BindEnv +addVV b (x, t) = snd $ F.insertBindEnv x t b + +subcVV :: F.SubC a -> (F.Symbol, F.SortedReft) +subcVV c = (x, sr) + where + sr = F.slhs c + x = F.reftBind $ F.sr_reft sr + + + diff --git a/src/Language/Fixpoint/Solver/Worklist.hs b/src/Language/Fixpoint/Solver/Worklist.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Worklist.hs @@ -0,0 +1,128 @@ +module Language.Fixpoint.Solver.Worklist + ( -- * Worklist type is opaque + Worklist + + -- * Initialize + , init + + -- * Pop off a constraint + , pop + + -- * Add a constraint and all its dependencies + , push + + ) + where + +import Prelude hiding (init) +import Language.Fixpoint.Solver.Deps +import Language.Fixpoint.PrettyPrint +import Language.Fixpoint.Misc +import Language.Fixpoint.Config +import qualified Language.Fixpoint.Types as F +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S +import qualified Data.List as L +import Data.Maybe (fromMaybe) + +--------------------------------------------------------------------------- +-- | Worklist ------------------------------------------------------------- +--------------------------------------------------------------------------- + +--------------------------------------------------------------------------- +init :: Config -> F.FInfo a -> Worklist a +--------------------------------------------------------------------------- +init _ fi = WL roots (cSucc cd) (F.cm fi) + where + cd = cDeps fi + roots = S.fromList $ cRoots cd + +--------------------------------------------------------------------------- +pop :: Worklist a -> Maybe (F.SubC a, Worklist a) +--------------------------------------------------------------------------- +pop w = do + (i, is) <- sPop $ wCs w + Just (getC (wCm w) i, w {wCs = is}) + +getC :: M.HashMap CId a -> CId -> a +getC cm i = fromMaybe err $ M.lookup i cm + where + err = errorstar "getC: bad CId i" + +--------------------------------------------------------------------------- +push :: F.SubC a -> Worklist a -> Worklist a +--------------------------------------------------------------------------- +push c w = w {wCs = sAdds (wCs w) js} + where + i = sid' c + js = {- tracepp ("PUSH: id = " ++ show i) $ -} wDeps w i + +sid' :: F.SubC a -> Integer +sid' c = fromMaybe err $ F.sid c + where + err = errorstar "sid': SubC without id" + +--------------------------------------------------------------------------- +-- | Worklist ------------------------------------------------------------- +--------------------------------------------------------------------------- + +type CId = Integer +type CSucc = CId -> [CId] +type KVRead = M.HashMap F.KVar [CId] + +data Worklist a = WL { wCs :: S.Set CId + , wDeps :: CSucc + , wCm :: M.HashMap CId (F.SubC a) + } + +instance PPrint (Worklist a) where + pprint = pprint . S.toList . wCs + +--------------------------------------------------------------------------- +-- | Constraint Dependencies ---------------------------------------------- +--------------------------------------------------------------------------- + +data CDeps = CDs { cRoots :: ![CId] + , cSucc :: CId -> [CId] + } + +cDeps :: F.FInfo a -> CDeps +cDeps fi = CDs rs next + where + next = kvSucc fi + is = M.keys $ F.cm fi + is' = concatMap next is + rs = sortDiff is is' + +kvSucc :: F.FInfo a -> CSucc +kvSucc fi = succs cm rdBy + where + rdBy = kvReadBy fi + cm = F.cm fi + +succs :: M.HashMap CId (F.SubC a) -> KVRead -> CSucc +succs cm rdBy i = sortNub $ concatMap kvReads iKs + where + ci = getC cm i + iKs = rhsKVars ci + kvReads k = M.lookupDefault [] k rdBy + +kvReadBy :: F.FInfo a -> KVRead +kvReadBy fi = group [ (k, i) | (i, ci) <- M.toList cm + , k <- {- tracepp ("lhsKVS: " ++ show i) $ -} + lhsKVars bs ci] + where + cm = F.cm fi + bs = F.bs fi + + +--------------------------------------------------------------------------- +-- | Set API -------------------------------------------------------------- +--------------------------------------------------------------------------- + +sAdds :: (Ord a) => S.Set a -> [a] -> S.Set a +sAdds = L.foldl' (flip S.insert) + +sPop :: S.Set a -> Maybe (a, S.Set a) +sPop = S.minView + diff --git a/src/Language/Fixpoint/Sort.hs b/src/Language/Fixpoint/Sort.hs --- a/src/Language/Fixpoint/Sort.hs +++ b/src/Language/Fixpoint/Sort.hs @@ -4,16 +4,24 @@ -- operations on Fixpoint expressions and predicates. module Language.Fixpoint.Sort ( + -- * Sort Substitutions + TVSubst + -- * Checking Well-Formedness - checkSorted + , checkSorted , checkSortedReft , checkSortedReftFull , checkSortFull , pruneUnsortedReft - ) where + -- * Unify + , unify + -- * Apply Substitution + , apply + ) where + import Control.Applicative import Control.Monad import Control.Monad.Error (catchError, throwError) @@ -30,9 +38,10 @@ type CheckM a = Either String a type Env = Symbol -> SESearch Sort -fProp = FApp boolFTyCon [] --- fProp = FApp propFTyCon [] +fProp :: Sort +fProp = FApp boolFTyCon [] + ------------------------------------------------------------------------- -- | Checking Refinements ----------------------------------------------- ------------------------------------------------------------------------- @@ -41,7 +50,7 @@ checkSortedReft env xs sr = applyNonNull Nothing error unknowns where error = Just . (text "Unknown symbols:" <+>) . toFix - unknowns = [ x | x <- syms sr, not (x `elem` v : xs), not (x `memberSEnv` env)] + unknowns = [ x | x <- syms sr, x `notElem` v : xs, not (x `memberSEnv` env)] Reft (v,_) = sr_reft sr checkSortedReftFull :: Checkable a => SEnv SortedReft -> a -> Maybe Doc @@ -50,7 +59,7 @@ Left err -> Just (text err) Right _ -> Nothing where - γ' = mapSEnv sr_sort γ + γ' = sr_sort <$> γ checkSortFull :: Checkable a => SEnv SortedReft -> Sort -> a -> Maybe Doc checkSortFull γ s t @@ -58,7 +67,7 @@ Left err -> Just (text err) Right _ -> Nothing where - γ' = mapSEnv sr_sort γ + γ' = sr_sort <$> γ checkSorted :: Checkable a => SEnv Sort -> a -> Maybe Doc checkSorted γ t @@ -67,21 +76,19 @@ Right _ -> Nothing pruneUnsortedReft :: SEnv Sort -> SortedReft -> SortedReft -pruneUnsortedReft γ (RR s (Reft (v, ras))) - = RR s (Reft (v, catMaybes (go <$> ras))) +pruneUnsortedReft γ (RR s (Reft (v, Refa p))) = RR s (Reft (v, tx p)) where - go r = case checkRefa f r of - Left war -> trace (wmsg war r) $ Nothing - Right _ -> Just r - γ' = insertSEnv v s γ - f = (`lookupSEnvWithDistance` γ') - - wmsg t r = "WARNING: prune unsorted reft:\n" ++ showFix r ++ "\n" ++ t - -checkRefa f (RConc p) = checkPred f p -checkRefa f _ = return () - + tx = refa . catMaybes . map (checkPred' f) . conjuncts + f = (`lookupSEnvWithDistance` γ') + γ' = insertSEnv v s γ + -- wmsg t r = "WARNING: prune unsorted reft:\n" ++ showFix r ++ "\n" ++ t +checkPred' f p = res -- traceFix ("checkPred: p = " ++ showFix p) $ res + where + res = case checkPred f p of + Left war -> {- trace (wmsg war p) -} Nothing + Right _ -> Just p + class Checkable a where check :: SEnv Sort -> a -> CheckM () checkSort :: SEnv Sort -> Sort -> a -> CheckM () @@ -91,18 +98,16 @@ instance Checkable Refa where check γ = checkRefa (`lookupSEnvWithDistance` γ) +checkRefa f (Refa p) = checkPred f p + instance Checkable Expr where check γ e = do {checkExpr f e; return ()} where f = (`lookupSEnvWithDistance` γ) - checkSort γ s e = checkExpr f (ECst e s) >> return () + checkSort γ s e = void $ checkExpr f (ECst e s) where f = (`lookupSEnvWithDistance` γ) - -- ORIG checkSort γ s e = do {t <- checkExpr f e; checkEqSort s t} - -- ORIG where f = (`lookupSEnvWithDistance` γ) - - checkEqSort s t | s == t = return () | otherwise = throwError $ "Couldn't match expected type '" @@ -115,8 +120,9 @@ where f = (`lookupSEnvWithDistance` γ) instance Checkable SortedReft where - check γ (RR s (Reft (v, ras))) = mapM_ (check γ') ras - where γ' = insertSEnv v s γ + check γ (RR s (Reft (v, ra))) = check γ' ra + where + γ' = insertSEnv v s γ ------------------------------------------------------------------------- -- | Checking Expressions ----------------------------------------------- @@ -125,8 +131,10 @@ checkExpr :: Env -> Expr -> CheckM Sort checkExpr _ EBot = throwError "Type Error: Bot" -checkExpr _ (ECon (I _)) = return FInt -checkExpr _ (ECon (R _)) = return FReal +checkExpr _ (ESym _) = return strSort +checkExpr _ (ECon (I _)) = return FInt +checkExpr _ (ECon (R _)) = return FReal +checkExpr _ (ECon (L _ s)) = return s checkExpr f (EVar x) = checkSym f x checkExpr f (ENeg e) = checkNeg f e checkExpr f (EBin o e1 e2) = checkOp f e1 o e2 @@ -151,7 +159,7 @@ = do tp <- checkPred f p t1 <- checkExpr f e1 t2 <- checkExpr f e2 - ((`apply` t1) <$> unify [t1] [t2]) `catchError` (\_ -> throwError $ errIte e1 e2 t1 t2) + ((`apply` t1) <$> unifys [t1] [t2]) `catchError` (\_ -> throwError $ errIte e1 e2 t1 t2) -- | Helper for checking cast expressions @@ -159,7 +167,7 @@ = checkApp f (Just t) g es checkCst f t e = do t' <- checkExpr f e - ((`apply` t) <$> unify [t] [t']) `catchError` (\_ -> throwError $ errCast e t' t) + ((`apply` t) <$> unifys [t] [t']) `catchError` (\_ -> throwError $ errCast e t' t) checkApp f to g es = snd <$> checkApp' f to g es @@ -170,7 +178,7 @@ (n, its, ot) <- sortFunction gt unless (length its == length es) $ throwError (errArgArity g its es) ets <- mapM (checkExpr f) es - θ <- unify its ets + θ <- unifys its ets let t = apply θ ot case to of Nothing -> return (θ, t) @@ -222,9 +230,8 @@ ------------------------------------------------------------------------- checkPred :: Env -> Pred -> CheckM () - -checkPred f PTrue = return () -checkPred f PFalse = return () +checkPred _ PTrue = return () +checkPred _ PFalse = return () checkPred f (PBexp e) = checkPredBExp f e checkPred f (PNot p) = checkPred f p checkPred f (PImp p p') = mapM_ (checkPred f) [p, p'] @@ -232,15 +239,17 @@ checkPred f (PAnd ps) = mapM_ (checkPred f) ps checkPred f (POr ps) = mapM_ (checkPred f) ps checkPred f (PAtom r e e') = checkRel f r e e' -checkPred f p = throwError $ errUnexpectedPred p +checkPred _ (PKVar {}) = return () +checkPred _ p = throwError $ errUnexpectedPred p +checkPredBExp :: Env -> Expr -> CheckM () checkPredBExp f e = do t <- checkExpr f e unless (t == fProp) (throwError $ errBExp e t) return () -- | Checking Relations - +checkRel :: (Symbol -> SESearch Sort) -> Brel -> Expr -> Expr -> CheckM () checkRel f Eq (EVar x) (EApp g es) = checkRelEqVar f x g es checkRel f Eq (EApp g es) (EVar x) = checkRelEqVar f x g es checkRel f r e1 e2 = do t1 <- checkExpr f e1 @@ -250,26 +259,21 @@ checkRelTy :: (Fixpoint a) => Env -> a -> Brel -> Sort -> Sort -> CheckM () checkRelTy f _ _ (FObj l) (FObj l') | l /= l' = (checkNumeric f l >> checkNumeric f l') `catchError` (\_ -> throwError $ errNonNumerics l l') -checkRelTy f _ _ FInt (FObj l) = (checkNumeric f l) `catchError` (\_ -> throwError $ errNonNumeric l) -checkRelTy f _ _ (FObj l) FInt = (checkNumeric f l) `catchError` (\_ -> throwError $ errNonNumeric l) -checkRelTy f _ _ FReal FReal = return () -checkRelTy f _ _ FReal (FObj l) = (checkFractional f l) `catchError` (\_ -> throwError $ errNonFractional l) -checkRelTy f _ _ (FObj l) FReal = (checkFractional f l) `catchError` (\_ -> throwError $ errNonFractional l) +checkRelTy f _ _ FInt (FObj l) = checkNumeric f l `catchError` (\_ -> throwError $ errNonNumeric l) +checkRelTy f _ _ (FObj l) FInt = checkNumeric f l `catchError` (\_ -> throwError $ errNonNumeric l) +checkRelTy _ _ _ FReal FReal = return () +checkRelTy f _ _ FReal (FObj l) = checkFractional f l `catchError` (\_ -> throwError $ errNonFractional l) +checkRelTy f _ _ (FObj l) FReal = checkFractional f l `catchError` (\_ -> throwError $ errNonFractional l) checkRelTy _ e Eq t1 t2 | t1 == fProp || t2 == fProp = throwError $ errRel e t1 t2 checkRelTy _ e Ne t1 t2 | t1 == fProp || t2 == fProp = throwError $ errRel e t1 t2 -checkRelTy _ e Eq t1 t2 = unify [t1] [t2] >> return () -checkRelTy _ e Ne t1 t2 = unify [t1] [t2] >> return () - --- ORIG checkRelTy _ e Eq t1 t2 = unless (t1 == t2 && t1 /= fProp) (throwError $ errRel e t1 t2) --- ORIG checkRelTy _ e Ne t1 t2 = unless (t1 == t2 && t1 /= fProp) (throwError $ errRel e t1 t2) - - +checkRelTy _ e Eq t1 t2 = unifys [t1] [t2] >> return () +checkRelTy _ e Ne t1 t2 = unifys [t1] [t2] >> return () -checkRelTy _ e Ueq t1 t2 = unless (isAppTy t1 && isAppTy t2) (throwError $ errRel e t1 t2) -checkRelTy _ e Une t1 t2 = unless (isAppTy t1 && isAppTy t2) (throwError $ errRel e t1 t2) +checkRelTy _ e Ueq t1 t2 = return () +checkRelTy _ e Une t1 t2 = return () checkRelTy _ e _ t1 t2 = unless (t1 == t2) (throwError $ errRel e t1 t2) @@ -285,8 +289,8 @@ isAppTy _ = False -isPoly :: Sort -> Bool -isPoly = not . null . fVars +-- isPoly :: Sort -> Bool +-- isPoly = not . null . fVars fVars (FVar i) = [i] fVars (FFunc _ ts) = concatMap fVars ts @@ -295,90 +299,58 @@ ------------------------------------------------------------------------- --- | Error messages ----------------------------------------------------- +-- | Unification of Sorts ------------------------------------------------------------------------- - -errUnify t1 t2 = printf "Cannot unify %s with %s" (showFix t1) (showFix t2) - -errUnifyMany ts ts' = printf "Cannot unify types with different cardinalities %s and %s" - (showFix ts) (showFix ts') - -errRel e t1 t2 = printf "Invalid Relation %s with operand types %s and %s" - (showFix e) (showFix t1) (showFix t2) - -errBExp e t = printf "BExp %s with non-propositional type %s" (showFix e) (showFix t) - -errOp e t t' - | t == t' = printf "Operands have non-numeric types %s in %s" - (showFix t) (showFix e) - | otherwise = printf "Operands have different types %s and %s in %s" - (showFix t) (showFix t') (showFix e) - -errArgArity g its es = printf "Measure %s expects %d args but gets %d in %s" - (showFix g) (length its) (length es) (showFix (EApp g es)) - -errIte e1 e2 t1 t2 = printf "Mismatched branches in Ite: then %s : %s, else %s : %s" - (showFix e1) (showFix t1) (showFix e2) (showFix t2) - -errCast e t' t = printf "Cannot cast %s of sort %s to incompatible sort %s" - (showFix e) (showFix t') (showFix t) - -errUnbound x = printf "Unbound Symbol %s" (showFix x) -errUnboundAlts x xs = printf "Unbound Symbol %s\n Perhaps you meant: %s" - (showFix x) - (foldr1 (\w s -> w ++ ", " ++ s) (showFix <$> xs)) - -errNonFunction t = printf "Sort %s is not a function" (showFix t) - -errNonNumeric l = printf "FObj sort %s is not numeric" (showFix l) -errNonNumerics l l' = printf "FObj sort %s and %s are different and not numeric" (showFix l) (showFix l') - -errNonFractional l = printf "FObj sort %s is not fractional" (showFix l) - -errUnexpectedPred p = printf "Sort Checking: Unexpected Predicate %s" (showFix p) +unify :: Sort -> Sort -> Maybe TVSubst +------------------------------------------------------------------------- +unify t1 t2 = case unify1 emptySubst t1 t2 of + Left _ -> Nothing + Right su -> Just su ------------------------------------------------------------------------- --- | Utilities for working with sorts ----------------------------------- +unifys :: [Sort] -> [Sort] -> CheckM TVSubst ------------------------------------------------------------------------- - --- | Unification of Sorts - -unify = unifyMany (Th M.empty) +unifys = unifyMany emptySubst +unifyMany :: TVSubst -> [Sort] -> [Sort] -> CheckM TVSubst unifyMany θ ts ts' - | length ts == length ts' = foldM (uncurry . unify1) θ $ zip ts ts' - | otherwise = throwError $ errUnifyMany ts ts' + | length ts == length ts' = foldM (uncurry . unify1) θ $ zip ts ts' + | otherwise = throwError $ errUnifyMany ts ts' --- unify1 _ FNum _ = Nothing -unify1 θ (FVar i) t = unifyVar θ i t -unify1 θ t (FVar i) = unifyVar θ i t +unify1 :: TVSubst -> Sort -> Sort -> CheckM TVSubst +unify1 θ (FVar i) t = unifyVar θ i t +unify1 θ t (FVar i) = unifyVar θ i t unify1 θ (FApp c ts) (FApp c' ts') - | c == c' = unifyMany θ ts ts' + | c == c' = unifyMany θ ts ts' unify1 θ t1 t2 - | t1 == t2 = return θ - | otherwise = throwError $ errUnify t1 t2 + | t1 == t2 = return θ + | otherwise = throwError $ errUnify t1 t2 +-- unify1 _ FNum _ = Nothing -unifyVar θ i t +unifyVar :: TVSubst -> Int -> Sort -> CheckM TVSubst +unifyVar θ i t@(FVar j) = case lookupVar i θ of - Just t' -> if t == t' then return θ else throwError (errUnify t t') - Nothing -> return $ updateVar i t θ - --- | Sort Substitutions -newtype TVSubst = Th (M.HashMap Int Sort) + Just t' -> if t == t' then return θ else return $ updateVar j t' θ + Nothing -> return $ updateVar i t θ --- | API for manipulating substitutions -lookupVar i (Th m) = M.lookup i m -updateVar i t (Th m) = Th (M.insert i t m) +unifyVar θ i t + = case lookupVar i θ of + Just t' -> if t == t' then return θ else throwError (errUnify t t') + Nothing -> return $ updateVar i t θ ------------------------------------------------------------------------- -- | Applying a Type Substitution --------------------------------------- ------------------------------------------------------------------------- - +apply :: TVSubst -> Sort -> Sort +------------------------------------------------------------------------- apply θ = sortMap f where f t@(FVar i) = fromMaybe t (lookupVar i θ) f t = t +------------------------------------------------------------------------- +sortMap :: (Sort -> Sort) -> Sort -> Sort +------------------------------------------------------------------------- sortMap f (FFunc n ts) = FFunc n (sortMap f <$> ts) sortMap f (FApp c ts) = FApp c (sortMap f <$> ts) sortMap f t = f t @@ -387,6 +359,7 @@ -- | Deconstruct a function-sort --------------------------------------- ------------------------------------------------------------------------ +sortFunction :: Sort -> CheckM (Int, [Sort], Sort) sortFunction (FFunc n ts') = return (n, ts, t) where ts = take numArgs ts' @@ -394,3 +367,52 @@ numArgs = length ts' - 1 sortFunction t = throwError $ errNonFunction t + + +------------------------------------------------------------------------ +-- | API for manipulating Sort Substitutions --------------------------- +------------------------------------------------------------------------ + +newtype TVSubst = Th (M.HashMap Int Sort) + +lookupVar :: Int -> TVSubst -> Maybe Sort +lookupVar i (Th m) = M.lookup i m + +updateVar :: Int -> Sort -> TVSubst -> TVSubst +updateVar i t (Th m) = Th (M.insert i t m) + +emptySubst :: TVSubst +emptySubst = Th M.empty + +------------------------------------------------------------------------- +-- | Error messages ----------------------------------------------------- +------------------------------------------------------------------------- + +errUnify t1 t2 = printf "Cannot unify %s with %s" (showFix t1) (showFix t2) + +errUnifyMany ts ts' = printf "Cannot unify types with different cardinalities %s and %s" + (showFix ts) (showFix ts') +errRel e t1 t2 = printf "Invalid Relation %s with operand types %s and %s" + (showFix e) (showFix t1) (showFix t2) +errBExp e t = printf "BExp %s with non-propositional type %s" (showFix e) (showFix t) +errOp e t t' + | t == t' = printf "Operands have non-numeric types %s in %s" + (showFix t) (showFix e) + | otherwise = printf "Operands have different types %s and %s in %s" + (showFix t) (showFix t') (showFix e) +errArgArity g its es = printf "Measure %s expects %d args but gets %d in %s" + (showFix g) (length its) (length es) (showFix (EApp g es)) +errIte e1 e2 t1 t2 = printf "Mismatched branches in Ite: then %s : %s, else %s : %s" + (showFix e1) (showFix t1) (showFix e2) (showFix t2) +errCast e t' t = printf "Cannot cast %s of sort %s to incompatible sort %s" + (showFix e) (showFix t') (showFix t) +errUnbound x = printf "Unbound Symbol %s" (showFix x) +errUnboundAlts x xs = printf "Unbound Symbol %s\n Perhaps you meant: %s" + (showFix x) + (foldr1 (\w s -> w ++ ", " ++ s) (showFix <$> xs)) +errNonFunction t = printf "Sort %s is not a function" (showFix t) +errNonNumeric l = printf "FObj sort %s is not numeric" (showFix l) +errNonNumerics l l' = printf "FObj sort %s and %s are different and not numeric" (showFix l) (showFix l') +errNonFractional l = printf "FObj sort %s is not fractional" (showFix l) +errUnexpectedPred p = printf "Sort Checking: Unexpected Predicate %s" (showFix p) + diff --git a/src/Language/Fixpoint/Types.hs b/src/Language/Fixpoint/Types.hs --- a/src/Language/Fixpoint/Types.hs +++ b/src/Language/Fixpoint/Types.hs @@ -7,14 +7,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} - --- | This module contains the data types, operations and serialization functions --- for representing Fixpoint's implication (i.e. subtyping) and well-formedness --- constraints in Haskell. The actual constraint solving is done by the --- `fixpoint.native` which is written in Ocaml. +-- | This module contains the data types, operations and +-- serialization functions for representing Fixpoint's +-- implication (i.e. subtyping) and well-formedness +-- constraints in Haskell. The actual constraint +-- solving is done by the `fixpoint.native` which +-- is written in Ocaml. module Language.Fixpoint.Types ( @@ -29,8 +29,9 @@ , resultDoc -- * Symbols - , Symbol(..) - , anfPrefix, tempPrefix, vv, intKvar + , Symbol + , KVar (..) + , anfPrefix, tempPrefix, vv, vv_, intKvar , symChars, isNonSymbol, nonSymbol , isNontrivialVV , symbolText, symbolString @@ -49,11 +50,16 @@ , realFTyCon , strFTyCon , propFTyCon + , listFTyCon , appFTyCon , fTyconSymbol , symbolFTycon + + , strSort , fApp , fObj + , isListTC + , isFAppTyTC -- * Expressions and Predicates , SymConst (..) @@ -65,44 +71,53 @@ , pAnd, pOr, pIte , isTautoPred , symConstLits - , zero -- * Generalizing Embedding with Typeclasses , Symbolic (..) , Expression (..) , Predicate (..) - -- * Constraints and Solutions - , SubC --(..) - , WfC --(..) - , sid - , subC, lhsCs, rhsCs, wfC + -- * Constraints + , WfC (..) + , SubC, sid, sgrd, senv, slhs, srhs, subC, lhsCs, rhsCs, wfC , Tag - , FixResult (..) - , FixSolution + + -- * Accessing Constraints + , envCs , addIds, sinfo , trueSubCKvar , removeLhsKvars + -- * Solutions + , Result + , FixResult (..) + , FixSolution + -- * Environments , SEnv, SESearch(..) , emptySEnv, toListSEnv, fromListSEnv - , mapSEnv, mapSEnvWithKey + -- , mapSEnv + , mapSEnvWithKey , insertSEnv, deleteSEnv, memberSEnv, lookupSEnv , intersectWithSEnv , filterSEnv , lookupSEnvWithDistance , FEnv, insertFEnv - , IBindEnv, BindId - , emptyIBindEnv, insertsIBindEnv, deleteIBindEnv + , IBindEnv, BindId, BindMap + , emptyIBindEnv, insertsIBindEnv, deleteIBindEnv, elemsIBindEnv + , BindEnv - , rawBindEnv, insertBindEnv, emptyBindEnv, mapBindEnv + , insertBindEnv, emptyBindEnv, lookupBindEnv, mapBindEnv + , bindEnvFromList, bindEnvToList + , unionIBindEnv -- * Refinements , Refa (..), SortedReft (..), Reft(..), Reftable(..) -- * Constructing Refinements + , refa + , reft -- "smart , trueSortedReft -- trivial reft , trueRefa -- trivial reft , trueReft -- trivial reft @@ -113,19 +128,21 @@ , usymbolReft -- singleton: v ~~ x , propReft -- singleton: Prop(v) <=> p , predReft -- any pred : p - , isFunctionSortedReft - , isNonTrivialSortedReft - , isTautoReft + , reftPred, reftBind + , isFunctionSortedReft, functionSort + , isNonTrivial , isSingletonReft , isEVar , isFalse - , flattenRefas, squishRefas + , flattenRefas, squishRefas, conjuncts , shiftVV + , mapPredReft -- * Substitutions - , Subst + , Subst (..) , Subable (..) , mkSubst + , isEmptySubst -- , emptySubst -- , catSubst , substExcept @@ -134,9 +151,6 @@ , sortSubst , targetSubstSyms - -- * Visitors - , reftKVars - -- * Functions on @Result@ , colorResult @@ -163,23 +177,20 @@ import Data.Typeable (Typeable) import GHC.Generics (Generic) -import Data.Char (chr, isAlpha, isUpper, ord, toLower) +import Data.Char (toLower) import qualified Data.Foldable as F import Data.Functor import Data.Hashable -import Data.Interned -import Data.List (foldl', intersect, nub, sort, - stripPrefix) +-- import Data.Interned +import Data.List (foldl', intersect, nub, sort) import Data.Monoid hiding ((<>)) import Data.String import Data.Text (Text) import qualified Data.Text as T import Data.Traversable - -import Control.Arrow ((***)) import Control.DeepSeq import Control.Exception (assert) -import Data.Maybe (fromMaybe) +import Data.Maybe (isJust, mapMaybe, listToMaybe, fromMaybe) import Text.Printf (printf) import Language.Fixpoint.Misc @@ -191,6 +202,7 @@ import qualified Data.HashSet as S import Language.Fixpoint.Names + class Fixpoint a where toFix :: a -> Doc @@ -208,7 +220,7 @@ | Wfc (WfC a) | Con Symbol Sort | Qul Qualifier - | Kut Symbol + | Kut KVar | IBind Int Symbol SortedReft deriving (Generic) -- Sol of solbind @@ -220,19 +232,14 @@ showFix = render . toFix traceFix :: (Fixpoint a) => String -> a -> a -traceFix s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showFix x) $ x +traceFix s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showFix x) x type TCEmb a = M.HashMap a FTycon --- instance (Eq a, Hashable a) => Monoid (TCEmb a) where --- mappend m1 m2 = M.fromList (M.toList m1 ++ M.toList m2) --- mempty = M.empty - exprSymbols :: Expr -> [Symbol] exprSymbols = go where go (EVar x) = [x] - -- go (EDat x _) = [x] go (ELit x _) = [val x] go (EApp f es) = val f : concatMap go es go (ENeg e) = go e @@ -244,32 +251,42 @@ predSymbols :: Pred -> [Symbol] predSymbols = go where - go (PAnd ps) = concatMap go ps - go (POr ps) = concatMap go ps - go (PNot p) = go p - go (PIff p1 p2) = go p1 ++ go p2 - go (PImp p1 p2) = go p1 ++ go p2 - go (PBexp e) = exprSymbols e - go (PAtom _ e1 e2) = exprSymbols e1 ++ exprSymbols e2 - go (PAll xts p) = (fst <$> xts) ++ go p - go _ = [] - -reftKVars :: Reft -> [Symbol] -reftKVars (Reft (_,ras)) = [k | (RKvar k _) <- ras] + go (PAnd ps) = concatMap go ps + go (POr ps) = concatMap go ps + go (PNot p) = go p + go (PIff p1 p2) = go p1 ++ go p2 + go (PImp p1 p2) = go p1 ++ go p2 + go (PBexp e) = exprSymbols e + go (PAtom _ e1 e2) = exprSymbols e1 ++ exprSymbols e2 + go (PKVar _ (Su su')) = {- CUTSOLVER k : -} concatMap syms su' + go (PAll xts p) = (fst <$> xts) ++ go p + go _ = [] --------------------------------------------------------------- ---------- (Kut) Sets of Kvars -------------------------------- --------------------------------------------------------------- +newtype KVar = KV {kv :: Symbol } deriving (Eq, Ord, Data, Typeable, Generic, IsString) -newtype Kuts = KS (S.HashSet Symbol) +intKvar :: Integer -> KVar +intKvar = KV . intSymbol "k_" +instance Show KVar where + show (KV x) = "$" ++ show x + +instance Hashable KVar + +newtype Kuts = KS { ksVars :: S.HashSet KVar } deriving (Show) + instance NFData Kuts where rnf (KS _) = () -- rnf s instance Fixpoint Kuts where toFix (KS s) = vcat $ ((text "cut " <>) . toFix) <$> S.toList s +ksEmpty :: Kuts ksEmpty = KS S.empty + +ksUnion :: [KVar] -> Kuts -> Kuts ksUnion kvs (KS s') = KS (S.union (S.fromList kvs) s') --------------------------------------------------------------- @@ -289,31 +306,36 @@ simplify = map simplify instance (Fixpoint a, Fixpoint b) => Fixpoint (a,b) where - toFix (x,y) = (toFix x) <+> text ":" <+> (toFix y) + toFix (x,y) = toFix x <+> text ":" <+> toFix y simplify (x,y) = (simplify x, simplify y) -toFix_gs (SE e) - = vcat $ map (toFix_constant . mapSnd sr_sort) $ hashMapToAscList e -toFix_constant (c, so) - = text "constant" <+> toFix c <+> text ":" <+> toFix so +toFixGs :: SEnv SortedReft -> Doc +toFixGs (SE e) = vcat $ map (toFixConstant . mapSnd sr_sort) $ hashMapToAscList e +toFixConstant (c, so) + = text "constant" <+> toFix c <+> text ":" <+> parens (toFix so) + ---------------------------------------------------------------------- ------------------------ Type Constructors --------------------------- ---------------------------------------------------------------------- newtype FTycon = TC LocSymbol deriving (Eq, Ord, Show, Data, Typeable, Generic) +intFTyCon, boolFTyCon, realFTyCon, strFTyCon, propFTyCon, appFTyCon, listFTyCon :: FTycon intFTyCon = TC $ dummyLoc "int" boolFTyCon = TC $ dummyLoc "bool" realFTyCon = TC $ dummyLoc "real" strFTyCon = TC $ dummyLoc strConName propFTyCon = TC $ dummyLoc propConName +listFTyCon = TC $ dummyLoc listConName appFTyCon = TC $ dummyLoc "FAppTy" -isListTC (TC (Loc _ c)) = c == listConName -isTupTC (TC (Loc _ c)) = c == tupConName +isListTC, isFAppTyTC :: FTycon -> Bool +isListTC (TC (Loc _ _ c)) = c == listConName +isTupTC (TC (Loc _ _ c)) = c == tupConName isFAppTyTC = (== appFTyCon) +fTyconSymbol :: FTycon -> Located Symbol fTyconSymbol (TC s) = s symbolFTycon :: LocSymbol -> FTycon @@ -334,7 +356,8 @@ | otherwise = fAppSorts (fTyconSort c) ts fApp (Right t) ts = fAppSorts t ts -fAppSorts t ts = foldl' (\t1 t2 -> FApp appFTyCon [t1, t2]) t ts +fAppSorts :: Sort -> [Sort] -> Sort +fAppSorts = foldl' (\t1 t2 -> FApp appFTyCon [t1, t2]) fTyconSort :: FTycon -> Sort fTyconSort = (`FApp` []) @@ -357,31 +380,32 @@ | FApp FTycon [Sort] -- ^ constructed type deriving (Eq, Ord, Show, Data, Typeable, Generic) +{-@ FFunc :: Nat -> ListNE Sort -> Sort @-} + instance Hashable Sort newtype Sub = Sub [(Int, Sort)] instance Fixpoint Sort where - toFix = toFix_sort + toFix = toFixSort -toFix_sort (FVar i) = text "@" <> parens (toFix i) -toFix_sort FInt = text "int" -toFix_sort FReal = text "real" -toFix_sort FFrac = text "frac" -toFix_sort (FObj x) = toFix x -toFix_sort FNum = text "num" -toFix_sort (FFunc n ts) = text "func" <> parens ((toFix n) <> (text ", ") <> (toFix ts)) -toFix_sort (FApp c [t]) - | isListTC c - = brackets $ toFix_sort t -toFix_sort (FApp c [FApp c' [],t]) - | isFAppTyTC c && isListTC c' - = brackets $ toFix_sort t -toFix_sort (FApp c ts) - | otherwise - = toFix c <+> intersperse space (fp <$> ts) - where fp s@(FApp _ (_:_)) = parens $ toFix_sort s - fp s = toFix_sort s +toFixSort :: Sort -> Doc +toFixSort (FVar i) = text "@" <> parens (toFix i) +toFixSort FInt = text "int" +toFixSort FReal = text "real" +toFixSort FFrac = text "frac" +toFixSort (FObj x) = toFix x +toFixSort FNum = text "num" +toFixSort (FFunc n ts) = text "func" <> parens (toFix n <> text ", " <> toFix ts) +toFixSort (FApp c [t]) + | isListTC c = brackets $ toFixSort t +toFixSort (FApp c [FApp c' [],t]) + | isFAppTyTC c && + isListTC c' = brackets $ toFixSort t +toFixSort (FApp c ts) = toFix c <+> intersperse space (fp <$> ts) + where + fp s@(FApp _ (_:_)) = parens $ toFixSort s + fp s = toFixSort s instance Fixpoint FTycon where @@ -389,7 +413,7 @@ ------------------------------------------------------------------------ -sortSubst :: (M.HashMap Symbol Sort) -> Sort -> Sort +sortSubst :: M.HashMap Symbol Sort -> Sort -> Sort ------------------------------------------------------------------------ sortSubst θ t@(FObj x) = fromMaybe t (M.lookup x θ) sortSubst θ (FFunc n ts) = FFunc n (sortSubst θ <$> ts) @@ -403,8 +427,9 @@ instance Fixpoint Subst where toFix (Su m) = case {- hashMapToAscList -} m of [] -> empty - xys -> hcat $ map (\(x,y) -> brackets $ (toFix x) <> text ":=" <> (toFix y)) xys + xys -> hcat $ map (\(x,y) -> brackets $ toFix x <> text ":=" <> toFix y) xys +targetSubstSyms :: Subst -> [Symbol] targetSubstSyms (Su ms) = syms $ snd <$> ms @@ -458,6 +483,9 @@ instance Fixpoint Symbol where toFix = text . encode . T.unpack . symbolText +instance Fixpoint KVar where + toFix (KV k) = text "$" <> toFix k + instance Fixpoint Text where toFix = text . T.unpack @@ -484,7 +512,7 @@ toFix (ECon c) = toFix c toFix (EVar s) = toFix s toFix (ELit s _) = toFix s - toFix (EApp f es) = (toFix f) <> (parens $ toFix es) + toFix (EApp f es) = toFix f <> parens (toFix es) toFix (ENeg e) = parens $ text "-" <+> parens (toFix e) toFix (EBin o e1 e2) = parens $ toFix e1 <+> toFix o <+> toFix e2 toFix (EIte p e1 e2) = parens $ toFix p <+> text "?" <+> toFix e1 <+> text ":" <+> toFix e2 @@ -495,31 +523,48 @@ --------------------- Predicates ------------------------- ---------------------------------------------------------- + data Pred = PTrue | PFalse - | PAnd ![Pred] - | POr ![Pred] - | PNot !Pred - | PImp !Pred !Pred - | PIff !Pred !Pred - | PBexp !Expr - | PAtom !Brel !Expr !Expr - | PAll ![(Symbol, Sort)] !Pred + | PAnd ![Pred] + | POr ![Pred] + | PNot !Pred + | PImp !Pred !Pred + | PIff !Pred !Pred + | PBexp !Expr + | PAtom !Brel !Expr !Expr + | PKVar !KVar !Subst + | PAll ![(Symbol, Sort)] !Pred | PTop deriving (Eq, Ord, Show, Data, Typeable, Generic) +{-@ type ListNE a = {v:[a] | 0 < len v} @-} + +{-@ PAnd :: ListNE Pred -> Pred @-} + + + +instance Hashable Brel +instance Hashable Bop +instance Hashable SymConst +instance Hashable Constant +instance Hashable Subst +instance Hashable Expr +instance Hashable Pred + instance Fixpoint Pred where toFix PTop = text "???" toFix PTrue = text "true" toFix PFalse = text "false" toFix (PBexp e) = parens $ text "?" <+> toFix e toFix (PNot p) = parens $ text "~" <+> parens (toFix p) - toFix (PImp p1 p2) = parens $ (toFix p1) <+> text "=>" <+> (toFix p2) - toFix (PIff p1 p2) = parens $ (toFix p1) <+> text "<=>" <+> (toFix p2) + toFix (PImp p1 p2) = parens $ toFix p1 <+> text "=>" <+> toFix p2 + toFix (PIff p1 p2) = parens $ toFix p1 <+> text "<=>" <+> toFix p2 toFix (PAnd ps) = text "&&" <+> toFix ps toFix (POr ps) = text "||" <+> toFix ps toFix (PAtom r e1 e2) = parens $ toFix e1 <+> toFix r <+> toFix e2 - toFix (PAll xts p) = text "forall" <+> (toFix xts) <+> text "." <+> (toFix p) + toFix (PKVar k su) = toFix k <> toFix su + toFix (PAll xts p) = text "forall" <+> toFix xts <+> text "." <+> toFix p simplify (PAnd []) = PTrue simplify (POr []) = PFalse @@ -539,9 +584,7 @@ | isTautoPred p = PTrue | otherwise = p -zero = ECon (I 0) -one = ECon (I 1) - +isContraPred :: Pred -> Bool isContraPred z = eqC z || (z `elem` contras) where contras = [PFalse] @@ -556,10 +599,9 @@ = x == y eqC _ = False -isTautoPred z = eqT z || (z `elem` tautos) +isTautoPred :: Pred -> Bool +isTautoPred z = z == PTop || z == PTrue || eqT z where - tautos = [PTop, PTrue] - eqT (PAtom Le x y) = x == y eqT (PAtom Ge x y) @@ -574,20 +616,29 @@ = x /= y eqT _ = False - -isTautoReft (Reft (_, ras)) = all isTautoRa ras -isTautoRa (RConc p) = isTautoPred p -isTautoRa _ = False - +isEVar :: Expr -> Bool isEVar (EVar _) = True isEVar _ = False +isEq :: Brel -> Bool isEq r = r == Eq || r == Ueq -isSingletonReft (Reft (v, [RConc (PAtom r e1 e2)])) +isSingletonReft :: Reft -> Maybe Expr +isSingletonReft (Reft (v, ra)) = firstMaybe (isSingletonExpr v) $ conjuncts $ raPred ra + +firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b +firstMaybe f = listToMaybe . mapMaybe f + +-- where +-- go (PAtom r e1 e2) | e1 == EVar v && isEq r = Just e2 +-- | e2 == EVar v && isEq r = Just e1 +-- go _ = Nothing + +isSingletonExpr :: Symbol -> Pred -> Maybe Expr +isSingletonExpr v (PAtom r e1 e2) | e1 == EVar v && isEq r = Just e2 | e2 == EVar v && isEq r = Just e1 -isSingletonReft _ = Nothing +isSingletonExpr _ _ = Nothing pAnd = simplify . PAnd pOr = simplify . POr @@ -595,17 +646,17 @@ mkProp = PBexp . EApp (dummyLoc propConName) . (: []) -ppr_reft (Reft (v, ras)) d - | all isTautoRa ras +pprReft (Reft (v, Refa p)) d + | isTautoPred p = d | otherwise - = braces (toFix v <+> colon <+> d <+> text "|" <+> ppRas ras) + = braces (toFix v <+> colon <+> d <+> text "|" <+> ppRas [Refa p]) -ppr_reft_pred (Reft (_, ras)) - | all isTautoRa ras +pprReftPred (Reft (_, Refa p)) + | isTautoPred p = text "true" | otherwise - = ppRas ras + = ppRas [Refa p] ppRas = cat . punctuate comma . map toFix . flattenRefas @@ -660,7 +711,7 @@ eProp = mkProp . eVar relReft :: (Expression a) => Brel -> a -> Reft -relReft r e = Reft (vv_, [RConc $ PAtom r (eVar vv_) (expr e)]) +relReft r e = Reft (vv_, Refa $ PAtom r (eVar vv_) (expr e)) exprReft, notExprReft, uexprReft :: (Expression a) => a -> Reft exprReft = relReft Eq @@ -668,21 +719,27 @@ uexprReft = relReft Ueq propReft :: (Predicate a) => a -> Reft -propReft p = Reft (vv_, [RConc $ PIff (eProp vv_) (prop p)]) +propReft p = Reft (vv_, Refa $ PIff (eProp vv_) (prop p)) predReft :: (Predicate a) => a -> Reft -predReft p = Reft (vv_, [RConc $ prop p]) +predReft p = Reft (vv_, Refa $ prop p) +reft :: Symbol -> Pred -> Reft +reft v p = Reft (v, Refa p) + +mapPredReft :: (Pred -> Pred) -> Reft -> Reft +mapPredReft f (Reft (v, Refa p)) = Reft (v, Refa (f p)) + + --------------------------------------------------------------- ----------------- Refinements --------------------------------- --------------------------------------------------------------- -data Refa - = RConc !Pred - | RKvar !Symbol !Subst - deriving (Eq, Ord, Show, Data, Typeable, Generic) +newtype Refa = Refa { raPred :: Pred } + deriving (Eq, Ord, Show, Data, Typeable, Generic) -newtype Reft = Reft (Symbol, [Refa]) deriving (Eq, Ord, Data, Typeable, Generic) +newtype Reft = Reft (Symbol, Refa) + deriving (Eq, Ord, Data, Typeable, Generic) instance Show Reft where show (Reft x) = render $ toFix x @@ -690,24 +747,43 @@ data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft } deriving (Eq, Show, Data, Typeable, Generic) -isNonTrivialSortedReft (RR _ (Reft (_, ras))) - = not $ null ras +isFunctionSortedReft :: SortedReft -> Bool +isFunctionSortedReft = isJust . functionSort . sr_sort -isFunctionSortedReft (RR (FFunc _ _) _) - = True -isFunctionSortedReft _ - = False +functionSort :: Sort -> Maybe (Int, [Sort], Sort) +functionSort (FFunc n ts) = Just (n, its, t) + where + (its, t) = safeUnsnoc "functionSort" ts +functionSort _ = Nothing -sortedReftValueVariable (RR _ (Reft (v,_))) = v + + +isNonTrivial :: Reftable r => r -> Bool +isNonTrivial = not .isTauto + +-- sortedReftValueVariable (RR _ (Reft (v,_))) = v + +reftPred :: Reft -> Pred +reftPred (Reft (_, Refa p)) = p + +reftBind :: Reft -> Symbol +reftBind (Reft (x, _)) = x + +refa :: [Pred] -> Refa +refa = Refa . pAnd + + --------------------------------------------------------------- ------------------ Environments ------------------------------- +-- | Environments --------------------------------------------- --------------------------------------------------------------- + toListSEnv :: SEnv a -> [(Symbol, a)] toListSEnv (SE env) = M.toList env fromListSEnv :: [(Symbol, a)] -> SEnv a fromListSEnv = SE . M.fromList + mapSEnv f (SE env) = SE (fmap f env) mapSEnvWithKey f = fromListSEnv . fmap f . toListSEnv deleteSEnv x (SE env) = SE (M.delete x env) @@ -719,20 +795,21 @@ filterSEnv f (SE m) = SE (M.filter f m) lookupSEnvWithDistance x (SE env) = case M.lookup x env of - Just x -> Found x + Just z -> Found z Nothing -> Alts $ symbol . T.pack <$> alts - where alts = takeMin $ (zip (editDistance x' <$> ss) ss) - ss = T.unpack . symbolText <$> fst <$> M.toList env - x' = T.unpack $ symbolText x - takeMin = \xs -> [x | (d, x) <- xs, d == getMin xs] - getMin = minimum . (fst <$>) + where + alts = takeMin $ zip (editDistance x' <$> ss) ss + ss = T.unpack . symbolText <$> fst <$> M.toList env + x' = T.unpack $ symbolText x + takeMin xs = [z | (d, z) <- xs, d == getMin xs] + getMin = minimum . (fst <$>) data SESearch a = Found a | Alts [Symbol] -- | Functions for Indexed Bind Environment emptyIBindEnv :: IBindEnv -emptyIBindEnv = FB (S.empty) +emptyIBindEnv = FB S.empty deleteIBindEnv :: BindId -> IBindEnv -> IBindEnv deleteIBindEnv i (FB s) = FB (S.delete i s) @@ -740,6 +817,10 @@ insertsIBindEnv :: [BindId] -> IBindEnv -> IBindEnv insertsIBindEnv is (FB s) = FB (foldr S.insert s is) +elemsIBindEnv :: IBindEnv -> [BindId] +elemsIBindEnv (FB s) = S.toList s + + -- | Functions for Global Binder Environment insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv) insertBindEnv x r (BE n m) = (n, BE (n + 1) (M.insert n (x, r) m)) @@ -747,49 +828,59 @@ emptyBindEnv :: BindEnv emptyBindEnv = BE 0 M.empty -rawBindEnv :: [(BindId, Symbol, SortedReft)] -> BindEnv -rawBindEnv bs = BE (1 + nbs) be' +bindEnvFromList :: [(BindId, Symbol, SortedReft)] -> BindEnv +bindEnvFromList bs = BE (1 + nbs) be' where - nbs = length bs - be = M.fromList [(n, (x, r)) | (n, x, r) <- bs] - be' = assert (M.size be == nbs) be + nbs = length bs + be = M.fromList [(n, (x, r)) | (n, x, r) <- bs] + be' = assert (M.size be == nbs) be +bindEnvToList :: BindEnv -> [(BindId, Symbol, SortedReft)] +bindEnvToList (BE _ be) = [(n, x, r) | (n, (x, r)) <- M.toList be] + mapBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv -mapBindEnv f (BE n m) = (BE n $ M.map f m) +mapBindEnv f (BE n m) = BE n $ M.map f m +lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft) +lookupBindEnv k (BE _ m) = fromMaybe err (M.lookup k m) + where + err = errorstar $ "lookupBindEnv: cannot find binder" ++ show k +unionIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv +unionIBindEnv (FB m1) (FB m2) = FB $ m1 `S.union` m2 + instance Functor SEnv where - fmap f (SE m) = SE $ fmap f m + fmap = mapSEnv instance Fixpoint Refa where - toFix (RConc p) = toFix p - toFix (RKvar k su) = toFix k <> toFix su + toFix (Refa p) = toFix $ conjuncts p -- toFix (RPvar p) = toFix p instance Fixpoint Reft where - toFix = ppr_reft_pred + toFix = pprReftPred instance Fixpoint SortedReft where - toFix (RR so (Reft (v, ras))) + toFix (RR so (Reft (v, ra))) = braces - $ (toFix v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> toFix ras - -instance Fixpoint FEnv where - toFix (SE m) = toFix (hashMapToAscList m) + $ toFix v <+> text ":" <+> toFix so <+> text "|" <+> toFix ra instance Fixpoint BindEnv where - toFix (BE _ m) = vcat $ map toFix_bind $ hashMapToAscList m + toFix (BE _ m) = vcat $ map toFixBind $ hashMapToAscList m -toFix_bind (i, (x, r)) = text "bind" <+> toFix i <+> toFix x <+> text ":" <+> toFix r +toFixBind (i, (x, r)) = text "bind" <+> toFix i <+> toFix x <+> text ":" <+> toFix r insertFEnv = insertSEnv . lower where lower s = case unconsSym s of Nothing -> s Just (c,s') -> consSym (toLower c) s' +-- instance (Fixpoint a) => Fixpoint (SEnv a) where +-- toFix (SE e) = vcat $ map pprxt $ hashMapToAscList e +-- where +-- pprxt (x,t) = toFix x <+> colon <> colon <+> toFix t + instance (Fixpoint a) => Fixpoint (SEnv a) where - toFix (SE e) = vcat $ map pprxt $ hashMapToAscList e - where pprxt (x, t) = toFix x <+> colon <> colon <+> toFix t + toFix (SE m) = toFix (hashMapToAscList m) instance Fixpoint (SEnv a) => Show (SEnv a) where show = render . toFix @@ -803,14 +894,18 @@ type BindId = Int type FEnv = SEnv SortedReft +type BindMap a = M.HashMap BindId a -- (Symbol, SortedReft) newtype IBindEnv = FB (S.HashSet BindId) deriving (Data, Typeable) -newtype SEnv a = SE { se_binds :: M.HashMap Symbol a } deriving (Eq, Data, Typeable, Generic, F.Foldable, Traversable) -data BindEnv = BE { be_size :: Int - , be_binds :: M.HashMap BindId (Symbol, SortedReft) - } +newtype SEnv a = SE { seBinds :: M.HashMap Symbol a } + deriving (Eq, Data, Typeable, Generic, F.Foldable, Traversable) +data BindEnv = BE { beSize :: Int + , beBinds :: BindMap (Symbol, SortedReft) + } + deriving (Show) + data SubC a = SubC { senv :: !IBindEnv , sgrd :: !Pred , slhs :: !SortedReft @@ -828,13 +923,21 @@ } deriving (Generic) + +--------------------------------------------------------------------------- +-- | The output of the Solver +--------------------------------------------------------------------------- +type Result a = (FixResult (SubC a), M.HashMap KVar Pred) +--------------------------------------------------------------------------- + + data FixResult a = Crash [a] String | Safe | Unsafe ![a] | UnknownError !String deriving (Show, Generic) -type FixSolution = M.HashMap Symbol Pred +type FixSolution = M.HashMap KVar Pred instance Eq a => Eq (FixResult a) where Crash xs _ == Crash ys _ = xs == ys @@ -861,27 +964,26 @@ instance (Ord a, Fixpoint a) => Fixpoint (FixResult (SubC a)) where toFix Safe = text "Safe" toFix (UnknownError d) = text $ "Unknown Error: " ++ d - toFix (Crash xs msg) = vcat $ [ text "Crash!" ] ++ ppr_sinfos "CRASH: " xs ++ [parens (text msg)] - toFix (Unsafe xs) = vcat $ text "Unsafe:" : ppr_sinfos "WARNING: " xs + toFix (Crash xs msg) = vcat $ [ text "Crash!" ] ++ pprSinfos "CRASH: " xs ++ [parens (text msg)] + toFix (Unsafe xs) = vcat $ text "Unsafe:" : pprSinfos "WARNING: " xs -ppr_sinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc] -ppr_sinfos msg = map ((text msg <>) . toFix) . sort . fmap sinfo +pprSinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc] +pprSinfos msg = map ((text msg <>) . toFix) . sort . fmap sinfo resultDoc :: (Ord a, Fixpoint a) => FixResult a -> Doc resultDoc Safe = text "Safe" resultDoc (UnknownError d) = text $ "Unknown Error: " ++ d -resultDoc (Crash xs msg) = vcat $ (text ("Crash!: " ++ msg)) : (((text "CRASH:" <+>) . toFix) <$> xs) -resultDoc (Unsafe xs) = vcat $ (text "Unsafe:") : (((text "WARNING:" <+>) . toFix) <$> xs) - - - +resultDoc (Crash xs msg) = vcat $ text ("Crash!: " ++ msg) : (((text "CRASH:" <+>) . toFix) <$> xs) +resultDoc (Unsafe xs) = vcat $ text "Unsafe:" : (((text "WARNING:" <+>) . toFix) <$> xs) colorResult (Safe) = Happy colorResult (Unsafe _) = Angry colorResult (_) = Sad +instance Show (WfC a) where + show = showFix instance Show (SubC a) where show = showFix @@ -934,7 +1036,7 @@ | x `elem` xs = z | otherwise = subst1 z su -substfExcept :: (Symbol -> Expr) -> [Symbol] -> (Symbol -> Expr) +substfExcept :: (Symbol -> Expr) -> [Symbol] -> Symbol -> Expr substfExcept f xs y = if y `elem` xs then EVar y else f y substExcept :: Subst -> [Symbol] -> Subst @@ -942,7 +1044,7 @@ substExcept (Su xes) xs = Su $ filter (not . (`elem` xs) . fst) xes instance Subable Symbol where - substa f x = f x + substa f = f substf f x = subSymbol (Just (f x)) x subst su x = subSymbol (Just $ appSubst su x) x -- subSymbol (M.lookup x s) x syms x = [x] @@ -981,7 +1083,8 @@ substf f (PIff p1 p2) = PIff (substf f p1) (substf f p2) substf f (PBexp e) = PBexp $ substf f e substf f (PAtom r e1 e2) = PAtom r (substf f e1) (substf f e2) - substf _ (PAll _ _) = errorstar $ "substf: FORALL" + substf _ p@(PKVar _ _) = p + substf _ (PAll _ _) = errorstar "substf: FORALL" substf _ p = p subst su (PAnd ps) = PAnd $ map (subst su) ps @@ -991,18 +1094,16 @@ subst su (PIff p1 p2) = PIff (subst su p1) (subst su p2) subst su (PBexp e) = PBexp $ subst su e subst su (PAtom r e1 e2) = PAtom r (subst su e1) (subst su e2) - subst _ (PAll _ _) = errorstar $ "subst: FORALL" + subst su (PKVar k su') = PKVar k $ su' `catSubst` su + subst _ (PAll _ _) = errorstar "subst: FORALL" subst _ p = p instance Subable Refa where - syms (RConc p) = syms p - syms (RKvar k (Su su')) = k : concatMap syms ({- M.elems -} su') - subst su (RConc p) = RConc $ subst su p - subst su (RKvar k su') = RKvar k $ su' `catSubst` su - -- subst _ (RPvar p) = RPvar p + syms (Refa p) = syms p + -- syms (RKvar k (Su su')) = k : concatMap syms ({- M.elems -} su') + subst su (Refa p) = Refa $ subst su p substa f = substf (EVar . f) - substf f (RConc p) = RConc (substf f p) - substf _ ra@(RKvar _ _) = ra + substf f (Refa p) = Refa (substf f p) instance (Subable a, Subable b) => Subable (a,b) where syms (x, y) = syms x ++ syms y @@ -1036,17 +1137,26 @@ substf f (RR so r) = RR so $ substf f r substa f (RR so r) = RR so $ substa f r -newtype Subst = Su [(Symbol, Expr)] deriving (Eq, Ord, Data, Typeable, Generic) +newtype Subst = Su [(Symbol, Expr)] + deriving (Eq, Ord, Data, Typeable, Generic) +appSubst :: Subst -> Symbol -> Expr appSubst (Su s) x = fromMaybe (EVar x) (lookup x s) -emptySubst = Su [] -- M.empty +emptySubst :: Subst +emptySubst = Su [] -- M.empty +catSubst :: Subst -> Subst -> Subst catSubst = unsafeCatSubst -mkSubst = unsafeMkSubst -unsafeMkSubst = Su -- . M.fromList +mkSubst :: [(Symbol, Expr)] -> Subst +mkSubst = unsafeMkSubst +isEmptySubst :: Subst -> Bool +isEmptySubst (Su xes) = null xes + +unsafeMkSubst = Su + unsafeCatSubst (Su s1) θ2@(Su s2) = Su $ s1' ++ s2 where s1' = mapSnd (subst θ2) <$> s1 @@ -1058,7 +1168,7 @@ unsafeCatSubstIgnoringDead (Su s1) (Su s2) = Su $ s1' ++ s2' where s1' = mapSnd (subst (Su s2')) <$> s1 - s2' = filter (\(x,_) -> not (x `elem` (fst <$> s1))) s2 + s2' = filter (\(x,_) -> (x `notElem` (fst <$> s1))) s2 -- TODO: nano-js throws all sorts of issues, will look into this later... -- but also, the check is too conservative, because of degenerate substitutions, @@ -1097,32 +1207,36 @@ usymbolReft :: (Symbolic a) => a -> Reft usymbolReft = uexprReft . eVar -vv_ = vv Nothing +vv_ :: Symbol +vv_ = vv Nothing trueSortedReft :: Sort -> SortedReft trueSortedReft = (`RR` trueReft) -trueReft = Reft (vv_, []) -falseReft = Reft (vv_, [RConc PFalse]) +trueReft = Reft (vv_, trueRefa) +falseReft = Reft (vv_, Refa PFalse) -trueRefa = RConc PTrue +trueRefa :: Refa +trueRefa = Refa PTrue flattenRefas :: [Refa] -> [Refa] flattenRefas = concatMap flatRa where - flatRa (RConc p) = RConc <$> flatP p + flatRa (Refa p) = Refa <$> flatP p flatRa ra = [ra] flatP (PAnd ps) = concatMap flatP ps flatP p = [p] -squishRefas :: [Refa] -> [Refa] -squishRefas ras = (squish [p | RConc p <- ras]) : [] +squishRefas :: [Refa] -> [Refa] +squishRefas ras = [squish (raPred <$> ras)] where - squish = RConc . pAnd . sortNub . filter (not . isTautoPred) . concatMap conjuncts + squish = Refa . pAnd . sortNub . filter (not . isTautoPred) . concatMap conjuncts -conjuncts (PAnd ps) = concatMap conjuncts ps -conjuncts p | isTautoPred p = [] - | otherwise = [p] +conjuncts (PAnd ps) = concatMap conjuncts ps +conjuncts p + | isTautoPred p = [] + | otherwise = [p] + ---------------------------------------------------------------- ---------------------- Strictness ------------------------------ ---------------------------------------------------------------- @@ -1187,8 +1301,8 @@ rnf (_) = () instance NFData Refa where - rnf (RConc x) = rnf x - rnf (RKvar x1 x2) = rnf x1 `seq` rnf x2 + rnf (Refa x) = rnf x + -- rnf (RKvar x1 x2) = rnf x1 `seq` rnf x2 -- rnf (RPvar _) = () -- rnf x instance NFData Reft where @@ -1216,32 +1330,76 @@ -------- Constraint Constructor Wrappers ---------------------------------- --------------------------------------------------------------------------- +wfC :: IBindEnv -> SortedReft -> Maybe Integer -> a -> WfC a wfC = WfC -subC γ p (RR t1 r1) (RR t2 (Reft (v2, ra2s))) x y z - = [subC' r2' | r2' <- [r2K, r2P], not $ isTauto r2'] - where - subC' r2' = SubC γ p (RR t1 (shiftVV r1 vvCon)) (RR t2 (shiftVV r2' vvCon)) x y z - r2K = Reft (v2, [ra | ra@(RKvar _ _) <- ra2s]) - r2P = Reft (v2, [ra | ra@(RConc _ ) <- ra2s]) +-- subC :: IBindEnv -> Pred -> SortedReft -> SortedReft -> Maybe Integer -> Tag -> a -> [SubC a] +-- subC γ p (RR t1 r1) (RR t2 (Reft (v2, ra2s))) i y z +-- = error "TODO:subC" -- NEW [subC' r2' | r2' <- [r2P], not $ isTauto r2'] +-- where +-- subC' r2' = SubC γ p (RR t1 (shiftVV r1 vv')) (RR t2 (shiftVV r2' vv')) i y z +-- r2P = Reft (v2, ra2s) -- ORIG [ra | ra@(Refa _ ) <- ra2s]) +-- -- ORIG r2K = Reft (v2, [ra | ra@(RKvar _ _) <- ra2s]) +-- vv' = mkVV i -lhsCs = sr_reft . slhs -rhsCs = sr_reft . srhs +-- ORIG subC γ p (RR t1 r1) (RR t2 (Reft (v2, ra2s))) x y z +-- ORIG = [subC' r2' | r2' <- [r2K, r2P], not $ isTauto r2'] +-- ORIG where +-- ORIG subC' r2' = SubC γ p (RR t1 (shiftVV r1 vvCon)) (RR t2 (shiftVV r2' vvCon)) x y z +-- ORIG r2K = Reft (v2, [ra | ra@(RKvar _ _) <- ra2s]) +-- ORIG r2P = Reft (v2, [ra | ra@(RConc _ ) <- ra2s]) + + +subC :: IBindEnv -> Pred -> SortedReft -> SortedReft -> Maybe Integer -> Tag -> a -> [SubC a] +-- subC γ p (RR t1 r1) (RR t2 r2) i y z +subC γ p sr1 sr2 i y z = [SubC γ p sr1' (sr2' r2') i y z | r2' <- reftConjuncts r2] + where + RR t1 r1 = sr1 + RR t2 r2 = sr2 + sr1' = RR t1 $ shiftVV r1 vv' + sr2' r2' = RR t2 $ shiftVV r2' vv' + vv' = mkVV i + +reftConjuncts :: Reft -> [Reft] +reftConjuncts (Reft (v, ra)) = [Reft (v, ra') | ra' <- refaConjuncts ra] + +refaConjuncts :: Refa -> [Refa] +refaConjuncts (Refa p) = [Refa p' | p' <- conjuncts p, not $ isTautoPred p'] + +mkVV :: Maybe Integer -> Symbol +mkVV (Just i) = vv $ Just i +mkVV Nothing = vvCon + +lhsCs, rhsCs :: SubC a -> Reft +lhsCs = sr_reft . slhs +rhsCs = sr_reft . srhs + +envCs :: BindEnv -> IBindEnv -> [(Symbol, SortedReft)] +envCs be env = [lookupBindEnv i be | i <- elemsIBindEnv env] + +-- mkFEnv :: BindEnv -> IBindEnv -> FEnv +-- mkFEnv be env = fromListSEnv $ envCs be env + + + removeLhsKvars cs vs - = cs{slhs = goRR (slhs cs)} - where goRR rr = rr{sr_reft = goReft (sr_reft rr)} - goReft (Reft(v, rs)) = Reft(v, filter f rs) - f (RKvar v _) | v `elem` vs = False - f r = True + = error "TODO:cutsolver: removeLhsKvars (why is this function needed?)" -trueSubCKvar v - = subC emptyIBindEnv PTrue mempty (RR mempty (Reft(vv_, [RKvar v emptySubst]))) Nothing [0] +-- CUTSOLVER = cs {slhs = goRR (slhs cs)} +-- CUTSOLVER where goRR rr = rr{sr_reft = goReft (sr_reft rr)} +-- CUTSOLVER goReft (Reft(v, rs)) = Reft(v, filter f rs) +-- CUTSOLVER f (RKvar v _) | v `elem` vs = False +-- CUTSOLVER f r = True +trueSubCKvar k = subC emptyIBindEnv PTrue mempty rhs Nothing [0] + where + rhs = RR mempty (Reft (vv_, Refa $ PKVar k mempty)) + shiftVV :: Reft -> Symbol -> Reft shiftVV r@(Reft (v, ras)) v' | v == v' = r - | otherwise = Reft (v', (subst1 ras (v, EVar v'))) + | otherwise = Reft (v', subst1 ras (v, EVar v')) addIds = zipWith (\i c -> (i, shiftId i $ c {sid = Just i})) [1..] @@ -1252,28 +1410,6 @@ shiftR i r@(Reft (v, _)) = shiftVV r (v `mappend` symbol (show i)) --- subC γ p r1 r2 x y z = (vvsu, SubC γ p r1' r2' x y z) --- where (vvsu, r1', r2') = unifySRefts r1 r2 - --- unifySRefts (RR t1 r1) (RR t2 r2) = (z, RR t1 r1', RR t2 r2') --- where (r1', r2') = unifyRefts r1 r2 - --- unifyRefts r1@(Reft (v1, _)) r2@(Reft (v2, _)) --- | v1 == v2 = (r1, r2) --- | otherwise = (r1, shiftVV r2 v1) - --- unifySRefts (RR t1 r1) (RR t2 r2) = (z, RR t1 r1', RR t2 r2') --- where (z, r1', r2') = unifyRefts r1 r2 --- --- unifyRefts r1@(Reft (v1, _)) r2@(Reft (v2, _)) --- | v1 == v2 = ((v1, emptySubst), r1, r2) --- | v1 /= vv_ = let (su, r2') = shiftVV r2 v1 in ((v1, su), r1 , r2') --- | otherwise = let (su, r1') = shiftVV r1 v2 in ((v2, su), r1', r2 ) --- --- shiftVV (Reft (v, ras)) v' = (su, (Reft (v', subst su ras))) --- where su = mkSubst [(v, EVar v')] - - ------------------------------------------------------------------------ ----------------- Qualifiers ------------------------------------------- ------------------------------------------------------------------------ @@ -1293,8 +1429,13 @@ rnf (Q x1 x2 x3 _) = rnf x1 `seq` rnf x2 `seq` rnf x3 pprQual (Q n xts p l) = text "qualif" <+> text (symbolString n) <> parens args <> colon <+> toFix p <+> text "//" <+> toFix l - where args = intersperse comma (toFix <$> xts) + where + args = intersperse comma (toFix <$> xts) +------------------------------------------------------------------------ +----------------- Top-Level Constraint System -------------------------- +------------------------------------------------------------------------ + data FInfo a = FI { cm :: M.HashMap Integer (SubC a) , ws :: ![WfC a] , bs :: !BindEnv @@ -1303,37 +1444,41 @@ , kuts :: Kuts , quals :: ![Qualifier] } - --- Original Ocaml definition --- --- type 'bind cfg = { --- a : int (* Tag arity *) --- ; ts : Ast.Sort.t list (* New sorts, now = [] *) --- ; ps : Ast.pred list (* New axioms, now = [] *) --- ; cs : FixConstraint.t list (* Implication Constraints *) --- ; ws : FixConstraint.wf list (* Well-formedness Constraints *) --- ; ds : FixConstraint.dep list (* Constraint Dependencies *) --- ; qs : Qualifier.t list (* Qualifiers *) --- ; kuts : Ast.Symbol.t list (* "Cut"-Kvars, which break cycles *) --- ; bm : 'bind Ast.Symbol.SMap.t (* Initial Sol Bindings *) --- ; uops : Ast.Sort.t Ast.Symbol.SMap.t (* Globals: measures + distinct consts) *) --- ; cons : Ast.Symbol.t list (* Distinct Constants, defined in uops *) --- ; assm : FixConstraint.soln (* Seed Solution: must be a fixpoint over constraints *) --- } + deriving (Show) +instance Monoid Kuts where + mempty = KS S.empty + mappend k1 k2 = KS $ S.union (ksVars k1) (ksVars k2) --- toFixs = brackets . hsep . punctuate comma -- . map toFix +instance Monoid (SEnv a) where + mempty = SE M.empty + mappend s1 s2 = SE $ M.union (seBinds s1) (seBinds s2) -toFixpoint x' = kutsDoc x' $+$ gsDoc x' $+$ conDoc x' $+$ bindsDoc x' $+$ csDoc x' $+$ wsDoc x' - where conDoc = vcat . map toFix_constant . getLits - csDoc = vcat . map toFix . M.elems . cm - wsDoc = vcat . map toFix . ws - kutsDoc = toFix . kuts - bindsDoc = toFix . bs - gsDoc = toFix_gs . gs +instance Monoid BindEnv where + mempty = BE 0 M.empty + mappend (BE 0 _) b = b + mappend b (BE 0 _) = b + mappend _ _ = errorstar "mappend on non-trivial BindEnvs" -getLits x = lits x -- ++ symConstLits x +instance Monoid (FInfo a) where + mempty = FI M.empty mempty mempty mempty mempty mempty mempty + mappend i1 i2 = FI { cm = mappend (cm i1) (cm i2) + , ws = mappend (ws i1) (ws i2) + , bs = mappend (bs i1) (bs i2) + , gs = mappend (gs i1) (gs i2) + , lits = mappend (lits i1) (lits i2) + , kuts = mappend (kuts i1) (kuts i2) + , quals = mappend (quals i1) (quals i2) + } +toFixpoint x' = kutsDoc x' $+$ gsDoc x' $+$ conDoc x' $+$ bindsDoc x' $+$ csDoc x' $+$ wsDoc x' + where + conDoc = vcat . map toFixConstant . lits + csDoc = vcat . map toFix . M.elems . cm + wsDoc = vcat . map toFix . ws + kutsDoc = toFix . kuts + bindsDoc = toFix . bs + gsDoc = toFixGs . gs ------------------------------------------------------------------------- -- | A Class Predicates for Valid Refinements Types --------------------- @@ -1358,15 +1503,20 @@ instance Monoid Pred where mempty = PTrue mappend p q = pAnd [p, q] + mconcat = pAnd +instance Monoid Refa where + mempty = Refa mempty + mappend ra1 ra2 = Refa $ mappend (raPred ra1) (raPred ra2) + instance Monoid Reft where mempty = trueReft mappend = meetReft -meetReft r@(Reft (v, ras)) r'@(Reft (v', ras')) - | v == v' = Reft (v , ras ++ ras') - | v == dummySymbol = Reft (v', ras' ++ (ras `subst1` (v , EVar v'))) - | otherwise = Reft (v , ras ++ (ras' `subst1` (v', EVar v ))) +meetReft (Reft (v, ra)) (Reft (v', ra')) + | v == v' = Reft (v , ra `mappend` ra') + | v == dummySymbol = Reft (v', ra' `mappend` (ra `subst1` (v , EVar v'))) + | otherwise = Reft (v , ra `mappend` (ra' `subst1` (v', EVar v ))) instance Subable () where syms _ = [] @@ -1384,15 +1534,22 @@ ofReft _ = mempty params _ = [] +-- NUKE isTautoReft :: Reft -> Bool +-- NUKE isTautoReft (Reft (_, ra)) = isTautoRa ra +-- NUKE +-- NUKE isTautoRa :: Refa -> Bool +-- NUKE isTautoRa = isTautoPred . raPred + + instance Reftable Reft where - isTauto = isTautoReft - ppTy = ppr_reft + isTauto = all isTautoPred . conjuncts . reftPred + ppTy = pprReft toReft = id ofReft = id params _ = [] bot _ = falseReft - top (Reft(v,_)) = Reft(v,[]) + top (Reft(v,_)) = Reft (v, mempty) instance Monoid Sort where mempty = FObj "any" @@ -1422,11 +1579,10 @@ isFalse _ = False instance Falseable Refa where - isFalse (RConc p) = isFalse p - isFalse _ = False + isFalse (Refa p) = isFalse p instance Falseable Reft where - isFalse (Reft(_, rs)) = or [isFalse p | RConc p <- rs] + isFalse (Reft(_, (Refa p))) = isFalse p --------------------------------------------------------------- -- | String Constants ----------------------------------------- @@ -1439,6 +1595,9 @@ -- Used to transform parsed output from fixpoint back into fq. +instance Symbolic SymConst where + symbol = encodeSymConst + encodeSymConst :: SymConst -> Symbol encodeSymConst (SL s) = symbol $ litPrefix `mappend` s @@ -1452,8 +1611,7 @@ litPrefix = "lit" `T.snoc` symSepName strSort :: Sort -strSort = FApp strFTyCon [] - +strSort = FInt class SymConsts a where symConsts :: a -> [SymConst] @@ -1462,8 +1620,8 @@ symConsts fi = sortNub $ csLits ++ bsLits ++ gsLits ++ qsLits where csLits = concatMap symConsts $ M.elems $ cm fi - bsLits = concatMap symConsts $ map snd $ M.elems $ be_binds $ bs fi - gsLits = concatMap symConsts $ M.elems $ se_binds $ gs fi + bsLits = concatMap symConsts $ map snd $ M.elems $ beBinds $ bs fi + gsLits = concatMap symConsts $ M.elems $ seBinds $ gs fi qsLits = concatMap symConsts $ q_body <$> quals fi instance SymConsts (SubC a) where @@ -1475,11 +1633,10 @@ symConsts = symConsts . sr_reft instance SymConsts Reft where - symConsts (Reft (_, ras)) = concatMap symConsts ras + symConsts (Reft (_, ra)) = symConsts ra instance SymConsts Refa where - symConsts (RConc p) = symConsts p - symConsts (RKvar _ (Su xes)) = concatMap symConsts $ snd <$> xes + symConsts (Refa p) = symConsts p instance SymConsts Expr where symConsts (ESym c) = [c] @@ -1491,15 +1648,16 @@ symConsts _ = [] instance SymConsts Pred where - symConsts (PNot p) = symConsts p - symConsts (PAnd ps) = concatMap symConsts ps - symConsts (POr ps) = concatMap symConsts ps - symConsts (PImp p q) = concatMap symConsts [p, q] - symConsts (PIff p q) = concatMap symConsts [p, q] - symConsts (PAll _ p) = symConsts p - symConsts (PBexp e) = symConsts e - symConsts (PAtom _ e e') = concatMap symConsts [e, e'] - symConsts _ = [] + symConsts (PNot p) = symConsts p + symConsts (PAnd ps) = concatMap symConsts ps + symConsts (POr ps) = concatMap symConsts ps + symConsts (PImp p q) = concatMap symConsts [p, q] + symConsts (PIff p q) = concatMap symConsts [p, q] + symConsts (PAll _ p) = symConsts p + symConsts (PBexp e) = symConsts e + symConsts (PAtom _ e e') = concatMap symConsts [e, e'] + symConsts (PKVar _ (Su xes)) = concatMap symConsts $ snd <$> xes + symConsts _ = [] --------------------------------------------------------------- -- | Edit Distance -------------------------------------------- @@ -1527,8 +1685,9 @@ -- | Located Values --------------------------------------------------------- ----------------------------------------------------------------------------- -data Located a = Loc { loc :: !SourcePos - , val :: a +data Located a = Loc { loc :: !SourcePos -- ^ Start Position + , locE :: !SourcePos -- ^ End Position + , val :: a } deriving (Data, Typeable, Generic) instance (IsString a) => IsString (Located a) where @@ -1538,7 +1697,7 @@ type LocText = Located Text dummyLoc :: a -> Located a -dummyLoc = Loc (dummyPos "Fixpoint.Types.dummyLoc") +dummyLoc = Loc l l where l = dummyPos "Fixpoint.Types.dummyLoc" dummyPos :: String -> SourcePos dummyPos s = newPos s 0 0 @@ -1559,32 +1718,32 @@ expr = expr . val instance Functor Located where - fmap f (Loc l x) = Loc l (f x) + fmap f (Loc l l' x) = Loc l l' (f x) instance F.Foldable Located where - foldMap f (Loc _ x) = f x + foldMap f (Loc _ _ x) = f x instance Traversable Located where - traverse f (Loc l x) = Loc l <$> f x + traverse f (Loc l l' x) = Loc l l' <$> f x instance Show a => Show (Located a) where - show (Loc l x) = show x ++ " defined at " ++ show l + show (Loc l l' x) = show x ++ " defined from: " ++ show l ++ " to: " ++ show l' instance Eq a => Eq (Located a) where - (Loc _ x) == (Loc _ y) = x == y + (Loc _ _ x) == (Loc _ _ y) = x == y instance Ord a => Ord (Located a) where compare x y = compare (val x) (val y) instance Subable a => Subable (Located a) where - syms (Loc _ x) = syms x - substa f (Loc l x) = Loc l (substa f x) - substf f (Loc l x) = Loc l (substf f x) - subst su (Loc l x) = Loc l (subst su x) + syms (Loc _ _ x) = syms x + substa f (Loc l l' x) = Loc l l' (substa f x) + substf f (Loc l l' x) = Loc l l' (substf f x) + subst su (Loc l l' x) = Loc l l' (subst su x) instance Hashable a => Hashable (Located a) where hashWithSalt i = hashWithSalt i . val instance (NFData a) => NFData (Located a) where -- FIXME: no instance NFData SrcSpan - rnf (Loc l x) = rnf x + rnf (Loc _ _ x) = rnf x diff --git a/src/Language/Fixpoint/Visitor.hs b/src/Language/Fixpoint/Visitor.hs --- a/src/Language/Fixpoint/Visitor.hs +++ b/src/Language/Fixpoint/Visitor.hs @@ -13,20 +13,25 @@ -- * Accumulators , fold + -- * Clients + , kvars + , envKVars + , mapKVars + + -- * Sorts + , foldSort, mapSort ) where -import Control.Applicative (Applicative (), (<$>), (<*>)) -import Control.Exception (throw) +import Control.Applicative (Applicative, (<$>), (<*>)) import Control.Monad.Trans.State (State, modify, runState) import Data.Monoid -import Data.Traversable (traverse) -import Language.Fixpoint.Misc (mapSnd) +import Data.Traversable (Traversable, traverse) import Language.Fixpoint.Types - - +import qualified Data.HashSet as S +import qualified Data.List as L data Visitor acc ctx = Visitor { - -- | Context @ctx@ is built up in a "top-down" fashion but not across siblings + -- | Context @ctx@ is built in a "top-down" fashion; not "across" siblings ctxExpr :: ctx -> Expr -> ctx , ctxPred :: ctx -> Pred -> ctx @@ -51,7 +56,6 @@ , accPred = \_ _ -> mempty } - ------------------------------------------------------------------------ fold :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> a @@ -67,6 +71,7 @@ accum :: (Monoid a) => a -> VisitM a () accum = modify . mappend +(<$$>) :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) f <$$> x = traverse f x ------------------------------------------------------------------------------ @@ -80,11 +85,10 @@ visit = visitPred instance Visitable Refa where - visit v c (RConc p) = RConc <$> visit v c p - visit _ _ r = return r + visit v c (Refa p) = Refa <$> visit v c p instance Visitable Reft where - visit v c (Reft (vv, ras)) = (Reft . (vv,)) <$> visitMany v c ras + visit v c (Reft (x, ra)) = (Reft . (x, )) <$> visit v c ra visitMany :: (Monoid a, Visitable t) => Visitor a ctx -> ctx -> [t] -> VisitM a [t] visitMany v c xs = visit v c <$$> xs @@ -92,15 +96,15 @@ visitExpr :: (Monoid a) => Visitor a ctx -> ctx -> Expr -> VisitM a Expr visitExpr v = vE where - vP = visitPred v - vE c e = accum acc >> step c' e' where c' = ctxExpr v c e - e' = txExpr v c' e - acc = accExpr v c' e - step c e@EBot = return e - step c e@(ESym _) = return e - step c e@(ECon _) = return e - step c e@(ELit _ _) = return e - step c e@(EVar _) = return e + vP = visitPred v + vE c e = accum acc >> step c' e' where c' = ctxExpr v c e + e' = txExpr v c' e + acc = accExpr v c' e + step _ e@EBot = return e + step _ e@(ESym _) = return e + step _ e@(ECon _) = return e + step _ e@(ELit _ _) = return e + step _ e@(EVar _) = return e step c (EApp f es) = EApp f <$> (vE c <$$> es) step c (ENeg e) = ENeg <$> vE c e step c (EBin o e1 e2) = EBin o <$> vE c e1 <*> vE c e2 @@ -110,10 +114,12 @@ visitPred :: (Monoid a) => Visitor a ctx -> ctx -> Pred -> VisitM a Pred visitPred v = vP where - vE = visitExpr v - vP c p = accum acc >> step c' p' where c' = ctxPred v c p - p' = txPred v c' p - acc = accPred v c' p + -- vS1 c (x, e) = (x,) <$> vE c e + -- vS c (Su xes) = Su <$> vS1 c <$$> xes + vE = visitExpr v + vP c p = accum acc >> step c' p' where c' = ctxPred v c p + p' = txPred v c' p + acc = accPred v c' p step c (PAnd ps) = PAnd <$> (vP c <$$> ps) step c (POr ps) = POr <$> (vP c <$$> ps) step c (PNot p) = PNot <$> vP c p @@ -122,6 +128,61 @@ step c (PBexp e) = PBexp <$> vE c e step c (PAtom r e1 e2) = PAtom r <$> vE c e1 <*> vE c e2 step c (PAll xts p) = PAll xts <$> vP c p - step c p@PTrue = return p - step c p@PFalse = return p - step c p@PTop = return p + step _ p@(PKVar _ _) = return p -- PAtom r <$> vE c e1 <*> vE c e2 + step _ p@PTrue = return p + step _ p@PFalse = return p + step _ p@PTop = return p + + +--------------------------------------------------------------------------------- +-- reftKVars :: Reft -> [KVar] +--------------------------------------------------------------------------------- + +-- reftKVars (Reft (_, ra)) = predKVars $ raPred ra +-- predKVars :: Pred -> [Symbol] + +mapKVars :: Visitable t => (KVar -> Maybe Pred) -> t -> t +mapKVars f = trans kvVis () [] + where + kvVis = defaultVisitor { txPred = txK } + txK _ (PKVar k su) + | Just p' <- f k = subst su p' + txK _ p = p + +kvars :: Visitable t => t -> [KVar] +kvars = fold kvVis () [] + where + kvVis = defaultVisitor { accPred = kv } + kv _ (PKVar k _) = [k] + kv _ _ = [] + +envKVars :: BindEnv -> SubC a -> [KVar] +envKVars be c = squish [ kvs sr | (_, sr) <- envCs be (senv c)] + where + squish = S.toList . S.fromList . concat + kvs = kvars . sr_reft + + + +--------------------------------------------------------------------------------- +-- | Visitors over @Sort@ +--------------------------------------------------------------------------------- +foldSort :: (a -> Sort -> a) -> a -> Sort -> a +--------------------------------------------------------------------------------- +foldSort f = step + where + step b t = go (f b t) t + go b (FFunc _ ts) = L.foldl' step b ts + go b (FApp _ ts) = L.foldl' step b ts + go b _ = b + + +--------------------------------------------------------------------------------- +mapSort :: (Sort -> Sort) -> Sort -> Sort +--------------------------------------------------------------------------------- +mapSort f = step + where + step = go . f + go (FFunc n ts) = FFunc n $ step <$> ts + go (FApp c ts) = FApp c $ step <$> ts + go t = t diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main where + +-- import Language.Fixpoint.Config +-- import Language.Fixpoint.Names +-- import Language.Fixpoint.Parse +-- import Language.Fixpoint.PrettyPrint +-- import Language.Fixpoint.Types + +import Control.Applicative +-- import Data.Char +-- import Data.Tagged +-- import Data.Typeable +-- import Options.Applicative +import System.Directory +import System.Exit +import System.FilePath +import System.IO +-- import qualified System.Posix as Posix +import System.Process + +-- import Control.Monad +-- import Data.Proxy +-- import Data.Text (Text, cons, inits, pack) +-- import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +-- import Test.Tasty.Ingredients.Rerun +-- import Test.Tasty.Options +-- import Test.Tasty.QuickCheck +-- import Test.Tasty.Runners +import Text.Printf + +main :: IO () +main = defaultMain =<< tests + where + tests = group "Tests" [unitTests] -- [ quickCheckTests ] + -- run = defaultMainWithIngredients [ + -- rerunningTests [ listingTests, consoleTestReporter ] + -- , includingOptions [ Option (Proxy :: Proxy QuickCheckTests) + -- ] + -- ] + + +unitTests + = group "Unit" [ + testGroup "pos" <$> dirTests "tests/pos" [] ExitSuccess + , testGroup "neg" <$> dirTests "tests/neg" [] (ExitFailure 1) + ] + +--------------------------------------------------------------------------- +dirTests :: FilePath -> [FilePath] -> ExitCode -> IO [TestTree] +--------------------------------------------------------------------------- +dirTests root ignored code + = do files <- walkDirectory root + let tests = [ rel | f <- files, isTest f, let rel = makeRelative root f, rel `notElem` ignored ] + return $ mkTest code root <$> tests -- hs f code | f <- hs] + +isTest :: FilePath -> Bool +isTest f = takeExtension f `elem` [".fq"] + +--------------------------------------------------------------------------- +mkTest :: ExitCode -> FilePath -> FilePath -> TestTree +--------------------------------------------------------------------------- +mkTest code dir file + = -- askOption $ \(smt :: SMTSolver) -> + testCase file $ + if test `elem` knownToFail + then do + printf "%s is known to fail: SKIPPING" test + assertEqual "" True True + else do + createDirectoryIfMissing True $ takeDirectory log + bin <- canonicalizePath "dist/build/fixpoint/fixpoint" + withFile log WriteMode $ \h -> do + let cmd = testCmd bin dir file + (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h} + c <- waitForProcess ph + assertEqual "Wrong exit code" code c + where + test = dir file + log = let (d,f) = splitFileName file in dir d ".liquid" f <.> "log" + +knownToFail = [] + +--------------------------------------------------------------------------- +testCmd :: FilePath -> FilePath -> FilePath -> String +--------------------------------------------------------------------------- +testCmd bin dir file = printf "cd %s && %s -n %s" dir bin file + + + + + + + + + + + + + + + +--------------------------------------------------------------------------- +--------------------------------------------------------------------------- +--------------------------------------------------------------------------- +--------------------------------------------------------------------------- +--------------------------------------------------------------------------- +--------------------------------------------------------------------------- +--------------------------------------------------------------------------- + +{- + +quickCheckTests :: TestTree +quickCheckTests + = testGroup "Properties" + [ testProperty "prop_pprint_parse_inv_expr" prop_pprint_parse_inv_expr + , testProperty "prop_pprint_parse_inv_pred" prop_pprint_parse_inv_pred + ] + +prop_pprint_parse_inv_pred :: Pred -> Bool +prop_pprint_parse_inv_pred p = p == rr (showpp p) + +prop_pprint_parse_inv_expr :: Expr -> Bool +prop_pprint_parse_inv_expr p = simplify p == rr (showpp $ simplify p) + +instance Arbitrary Sort where + arbitrary = sized arbSort + +arbSort 0 = oneof [return FInt, return FReal, return FNum] +arbSort n = frequency + [(1, return FInt) + ,(1, return FReal) + ,(1, return FNum) + ,(2, fmap FObj arbitrary) + ] + + +instance Arbitrary Pred where + arbitrary = sized arbPred + shrink = filter valid . genericShrink + where + valid (PAnd []) = False + valid (PAnd [_]) = False + valid (POr []) = False + valid (POr [_]) = False + valid (PBexp (EBin _ _ _)) = True + valid (PBexp _) = False + valid _ = True + +arbPred 0 = elements [PTrue, PFalse] +arbPred n = frequency + [(1, return PTrue) + ,(1, return PFalse) + ,(2, fmap PAnd twoPreds) + ,(2, fmap POr twoPreds) + ,(2, fmap PNot (arbPred (n `div` 2))) + ,(2, liftM2 PImp (arbPred (n `div` 2)) (arbPred (n `div` 2))) + ,(2, liftM2 PIff (arbPred (n `div` 2)) (arbPred (n `div` 2))) + ,(2, fmap PBexp (arbExpr (n `div` 2))) + ,(2, liftM3 PAtom arbitrary (arbExpr (n `div` 2)) (arbExpr (n `div` 2))) + -- ,liftM2 PAll arbitrary arbitrary + -- ,return PTop + ] + where + twoPreds = do + x <- arbPred (n `div` 2) + y <- arbPred (n `div` 2) + return [x,y] + +instance Arbitrary Expr where + arbitrary = sized arbExpr + shrink = filter valid . genericShrink + where valid (EApp _ []) = False + valid _ = True + +arbExpr 0 = oneof [fmap ESym arbitrary, fmap ECon arbitrary, fmap EVar arbitrary, return EBot] +arbExpr n = frequency + [(1, fmap ESym arbitrary) + ,(1, fmap ECon arbitrary) + ,(1, fmap EVar arbitrary) + ,(1, return EBot) + -- ,liftM2 ELit arbitrary arbitrary -- restrict literals somehow + ,(2, choose (1,3) >>= \m -> liftM2 EApp arbitrary (vectorOf m (arbExpr (n `div` 2)))) + ,(2, liftM3 EBin arbitrary (arbExpr (n `div` 2)) (arbExpr (n `div` 2))) + ,(2, liftM3 EIte (arbPred (max 2 (n `div` 2)) `suchThat` isRel) + (arbExpr (n `div` 2)) + (arbExpr (n `div` 2))) + ,(2, liftM2 ECst (arbExpr (n `div` 2)) (arbSort (n `div` 2))) + ] + where + isRel (PAtom _ _ _) = True + isRel _ = False + +instance Arbitrary Brel where + arbitrary = oneof (map return [Eq, Ne, Gt, Ge, Lt, Le, Ueq, Une]) + +instance Arbitrary Bop where + arbitrary = oneof (map return [Plus, Minus, Times, Div, Mod]) + +instance Arbitrary SymConst where + arbitrary = fmap SL arbitrary + +instance Arbitrary Symbol where + arbitrary = fmap (symbol :: Text -> Symbol) arbitrary + +instance Arbitrary Text where + arbitrary = choose (1,4) >>= \n -> + fmap pack (vectorOf n char `suchThat` valid) + where + char = elements ['a'..'z'] + valid x = x `notElem` fixpointNames && not (isFixKey x) + +instance Arbitrary FTycon where + arbitrary = do + c <- elements ['A'..'Z'] + t <- arbitrary + return $ symbolFTycon $ dummyLoc $ symbol $ cons c t + +instance Arbitrary Constant where + arbitrary = oneof [fmap I (arbitrary `suchThat` (>=0)) + -- ,fmap R arbitrary + ] + shrink = genericShrink + +instance Arbitrary a => Arbitrary (Located a) where + arbitrary = fmap dummyLoc arbitrary + shrink = fmap dummyLoc . shrink . val + +-} + +---------------------------------------------------------------------------------------- +-- Generic Helpers +---------------------------------------------------------------------------------------- + +group n xs = testGroup n <$> sequence xs + +---------------------------------------------------------------------------------------- +walkDirectory :: FilePath -> IO [FilePath] +---------------------------------------------------------------------------------------- +walkDirectory root + = do (ds,fs) <- partitionM doesDirectoryExist . candidates =<< getDirectoryContents root + (fs++) <$> concatMapM walkDirectory ds + where + candidates fs = [root f | f <- fs, not (isExtSeparator (head f))] + +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a],[a]) +partitionM f = go [] [] + where + go ls rs [] = return (ls,rs) + go ls rs (x:xs) = do b <- f x + if b then go (x:ls) rs xs + else go ls (x:rs) xs + +-- isDirectory :: FilePath -> IO Bool +-- isDirectory = fmap Posix.isDirectory . Posix.getFileStatus + +concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b] +concatMapM _ [] = pure [] +concatMapM f (x:xs) = (++) <$> f x <*> concatMapM f xs