liquid-fixpoint 0.2.3.2 → 0.3.0.0

raw patch · 39 files changed

+3326/−1599 lines, 39 filesdep +tastydep +tasty-hunitdep +tasty-rerundep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty, tasty-hunit, tasty-rerun

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Fixpoint.hs +8/−70
• Setup.hs +1/−1
• external/fixpoint/ast.ml +88/−28
• external/fixpoint/ast.mli +56/−57
• external/fixpoint/fixConstraint.ml +136/−131
• external/fixpoint/fixLex.mll +2/−1
• external/fixpoint/fixParse.mly +10/−5
• external/fixpoint/fixpoint.native-i386-linux binary
• external/fixpoint/fixpoint.native-i686-w64-mingw32 too large to diff
• external/fixpoint/fixpoint.native-x86_64-darwin too large to diff
• external/fixpoint/fixpoint.native-x86_64-linux too large to diff
• external/fixpoint/predAbs.ml +243/−243
• external/fixpoint/qualifier.ml +96/−97
• external/fixpoint/smtLIB2.ml +103/−103
• external/fixpoint/smtZ3.ml +14/−14
• external/fixpoint/smtZ3.nomem.ml +14/−14
• external/fixpoint/tpGen.ml +158/−147
• external/ocamlgraph/src/version.ml +1/−1
• liquid-fixpoint.cabal +28/−22
• src/Language/Fixpoint/Config.hs +45/−9
• src/Language/Fixpoint/Errors.hs +11/−5
• src/Language/Fixpoint/Files.hs +6/−4
• src/Language/Fixpoint/Interface.hs +126/−60
• src/Language/Fixpoint/Misc.hs +41/−9
• src/Language/Fixpoint/Names.hs +32/−14
• src/Language/Fixpoint/Parse.hs +148/−74
• src/Language/Fixpoint/PrettyPrint.hs +27/−10
• src/Language/Fixpoint/SmtLib2.hs +84/−33
• src/Language/Fixpoint/Solver/Deps.hs +96/−0
• src/Language/Fixpoint/Solver/Eliminate.hs +126/−0
• src/Language/Fixpoint/Solver/Monad.hs +103/−0
• src/Language/Fixpoint/Solver/Solution.hs +229/−0
• src/Language/Fixpoint/Solver/Solve.hs +114/−0
• src/Language/Fixpoint/Solver/Validate.hs +100/−0
• src/Language/Fixpoint/Solver/Worklist.hs +128/−0
• src/Language/Fixpoint/Sort.hs +138/−116
• src/Language/Fixpoint/Types.hs +463/−304
• src/Language/Fixpoint/Visitor.hs +88/−27
• tests/test.hs +263/−0

@@ -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

@@ -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 ++ "/"

@@ -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) *)  (***************************************************************************)

@@ -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-

@@ -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))-- -

@@ -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 }

@@ -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:

binary file changed (1693827 → 1695021 bytes)

file too large to diff

file too large to diff

file too large to diff

@@ -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--

@@ -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)-

@@ -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

@@ -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 

@@ -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 

@@ -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 

@@ -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"

@@ -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

@@ -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"+

@@ -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

@@ -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 

@@ -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 

@@ -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]

@@ -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

@@ -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

@@ -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

@@ -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) -}++-------------------------------------------------------------------+

@@ -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+++---------------------------------------------------------------

@@ -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))

@@ -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

@@ -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)+

@@ -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+

@@ -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+++

@@ -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+

@@ -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)+

@@ -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