liquid-fixpoint 0.1.0.0 → 0.2.0.0
raw patch · 46 files changed
+4245/−3826 lines, 46 filesdep +attoparsecdep +interndep +text-formatdep −ghcdep ~basedep ~hashablesetup-changednew-component:exe:fixpoint.native
Dependencies added: attoparsec, intern, text-format, transformers
Dependencies removed: ghc
Dependency ranges changed: base, hashable
Files
- Fixpoint.hs +50/−14
- Setup.hs +21/−12
- external/fixpoint/ast.ml +135/−49
- external/fixpoint/ast.mli +7/−4
- external/fixpoint/cindex.ml +25/−9
- external/fixpoint/fixConfig.mli +1/−0
- external/fixpoint/fixConstraint.ml +111/−98
- external/fixpoint/fixConstraint.mli +11/−9
- external/fixpoint/fixLex.mll +8/−0
- external/fixpoint/fixParse.mly +16/−9
- external/fixpoint/fixpoint.ml +4/−4
- external/fixpoint/kvgraph.ml +1/−1
- external/fixpoint/predAbs.ml +563/−296
- external/fixpoint/proverArch.ml +14/−6
- external/fixpoint/smtLIB2.ml +17/−13
- external/fixpoint/smtZ3.mem.ml +11/−6
- external/fixpoint/smtZ3.ml +54/−139
- external/fixpoint/smtZ3.nomem.ml +3/−0
- external/fixpoint/solve.ml +4/−4
- external/fixpoint/solverArch.ml +1/−1
- external/fixpoint/theories.ml +4/−2
- external/fixpoint/theories.mli +1/−1
- external/fixpoint/toImp.ml +6/−4
- external/fixpoint/toSmtLib.ml +3/−2
- external/fixpoint/tpGen.ml +23/−9
- external/fixpoint/tpNull.ml +3/−2
- external/misc/constants.ml +31/−3
- external/misc/fcommon.ml +30/−10
- external/misc/fixMisc.ml +10/−0
- external/misc/misc.ml +0/−1346
- external/ocamlgraph/.depend +108/−108
- external/ocamlgraph/Makefile +6/−6
- external/ocamlgraph/src/dot_parser.ml +49/−48
- external/ocamlgraph/src/version.ml +1/−1
- liquid-fixpoint.cabal +49/−9
- src/Language/Fixpoint/Config.hs +23/−6
- src/Language/Fixpoint/Errors.hs +132/−0
- src/Language/Fixpoint/Files.hs +57/−25
- src/Language/Fixpoint/Interface.hs +14/−8
- src/Language/Fixpoint/Misc.hs +37/−8
- src/Language/Fixpoint/Names.hs +245/−15
- src/Language/Fixpoint/Parse.hs +301/−89
- src/Language/Fixpoint/PrettyPrint.hs +4/−6
- src/Language/Fixpoint/SmtLib2.hs +444/−0
- src/Language/Fixpoint/Sort.hs +43/−8
- src/Language/Fixpoint/Types.hs +1564/−1436
Fixpoint.hs view
@@ -6,27 +6,44 @@ import Data.Maybe (fromMaybe, listToMaybe) import System.Console.CmdArgs 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 whenLoud $ putStrLn $ "Options: " ++ show cfg- solveFile 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"-} &= 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"- ]+ 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 @@ -35,3 +52,22 @@ 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"
Setup.hs view
@@ -8,27 +8,36 @@ import System.Process import System.Exit -main = defaultMainWithHooks fixHooks - where - fixHooks = simpleUserHooks { postInst = buildAndCopyFixpoint } - -buildAndCopyFixpoint _ _ pkg lbi - = do putStrLn $ "Post Install: " ++ show binDir- setEnv "Z3MEM" (show z3mem) True+main = defaultMainWithHooks fixHooks+ where+ fixHooks = simpleUserHooks { postBuild = buildFixpoint+ , postCopy = copyFixpoint+ , postInst = copyFixpoint+ }++buildFixpoint _ _ pkg lbi+ = do setEnv "Z3MEM" (show z3mem) True executeShellCommand "./configure" executeShellCommand "./build.sh" executeShellCommand "chmod a+x external/fixpoint/fixpoint.native "- executeShellCommand $ "cp external/fixpoint/fixpoint.native " ++ binDir+ where+ allDirs = absoluteInstallDirs pkg lbi NoCopyDest+ binDir = bindir allDirs ++ "/"+ flags = configConfigurationsFlags $ configFlags lbi+ z3mem = fromMaybe False $ lookup (FlagName "z3mem") flags++copyFixpoint _ _ pkg lbi+ = do executeShellCommand $ "cp external/fixpoint/fixpoint.native " ++ binDir when z3mem $ executeShellCommand $ "cp external/z3/lib/libz3.* " ++ binDir- where + where allDirs = absoluteInstallDirs pkg lbi NoCopyDest binDir = bindir allDirs ++ "/" flags = configConfigurationsFlags $ configFlags lbi- z3mem = fromJust $ lookup (FlagName "z3mem") flags+ z3mem = fromMaybe False $ lookup (FlagName "z3mem") flags executeShellCommand cmd = putStrLn ("EXEC: " ++ cmd) >> system cmd >>= check- where + where check (ExitSuccess) = return ()- check (ExitFailure n) = error $ "cmd: " ++ cmd ++ " failure code " ++ show n + check (ExitFailure n) = error $ "cmd: " ++ cmd ++ " failure code " ++ show n
external/fixpoint/ast.ml view
@@ -58,6 +58,7 @@ type t = | Int+ | Real | Bool | Obj | Var of int (* type-var *)@@ -84,17 +85,22 @@ let t_obj = Obj let t_bool = Bool let t_int = Int+ let t_real = Real let t_generic = fun i -> let _ = asserts (0 <= i) "t_generic: %d" i in Var i let t_ptr = fun l -> Ptr l let t_func = fun i ts -> Func (i, ts) let tycon s = s - + let tc_app = "FAppTy"+ (* let tycon_re = Str.regexp "[A-Z][0-9 a-z A-Z '.']" * function | s when Str.string_match tycon_re s 0 -> s | s -> assertf "Error: Invalid tycon: %s" s *) - let t_app c ts = App (c, ts)+ let t_app c ts = if c = tc_app then App (c, ts) else + List.fold_left (fun t1 t2 -> App (tc_app, [t1; t2])) (App (c, [])) ts+ (* let t_app c ts = List.fold_left (fun t1 t2 -> App ("FAppTy", [t1; t2])) (App (c, [])) ts *) + (* let t_app c ts = App (c, ts) *) let loc_to_string = function | Loc s -> s@@ -104,6 +110,7 @@ let rec to_string = function | Var i -> Printf.sprintf "@(%d)" i | Int -> "int"+ | Real -> "real" | Bool -> "bool" | Obj -> "obj" | Num -> "num"@@ -159,15 +166,42 @@ | Int -> true | _ -> false + let is_real = function+ | Real -> true+ | _ -> false+ let is_func = function | Func _ -> true | _ -> false + let is_kind = function+ | Num -> true+ | _ -> false+ let app_of_t = function | App (c, ts) -> Some (c, ts) | _ -> None + (* (L t1 t2 t3) is now encoded as+ ---> (((L @ t1) @ t2) @ t3)+ ---> App(@, [App(@, [App(@, [L[]; t1]); t2]); t3])+ The following decodes the above as + *)+ let rec app_args_of_t acc = function + | App (c, [t1; t2]) when c = tc_app -> app_args_of_t (t2 :: acc) t1 + | App (c, []) -> (c, acc)+ | t -> (tc_app, t :: acc)+ + (*+ | Ptr (Loc s) -> (tycon s, acc)+ | t -> assertf "app_args_of_t: unexpected t1 = %s" (to_string t)+ *) + let app_of_t = function+ | App (c, _) as t when c = tc_app -> Some (app_args_of_t [] t)+ | App (c, ts) -> Some (c, ts)+ | _ -> None + let func_of_t = function | Func (i, ts) -> let (xts, t) = ts |> Misc.list_snoc |> Misc.swap in Some (i, xts, t)@@ -250,7 +284,7 @@ end let rec fold f acc t = match t with- | Var _ | Int | Bool | Obj | Num | Ptr _ + | Var _ | Int | Real | Bool | Obj | Num | Ptr _ -> f acc t | Func (_, ts) | App (_, ts) -> List.fold_left (fold f) (f acc t) ts @@ -364,19 +398,27 @@ module Constant = struct- type t = Int of int+ type t = Int of int | Real of float let to_string = function | Int i -> string_of_int i+ | Real i -> string_of_float i ^ "0" let print fmt s = to_string s |> Format.fprintf fmt "%s" end -type tag = int+type tag = int -type brel = Eq | Ne | Gt | Ge | Lt | Le +type brel = Eq (* equal *)+ | Ne (* not-equal *)+ | Gt (* greater than *) + | Ge (* greater than or equal *)+ | Lt (* less than *)+ | Le (* less than or equal *)+ | Ueq (* unsorted-equality *) + | Une (* unsorted-disequality *) type bop = Plus | Minus | Times | Div | Mod (* NOTE: For "Mod" 2nd expr should be a constant or a var *) @@ -412,7 +454,7 @@ let list_hash b xs = List.fold_left (fun v (_,id) -> 2*v + id) b xs -module Hashcons (X : sig type t +module Hashcons (X : sig type t val sub_equal : t -> t -> bool val hash : t -> int end) = struct @@ -465,6 +507,8 @@ let hash = function | Con (Constant.Int x) -> x+ | Con (Constant.Real x) -> + 64 + int_of_float x | MExp es -> list_hash 6 es | Var x -> @@ -555,7 +599,10 @@ let zero = eInt 0 let one = eInt 1 let bot = ewr Bot-let eMod = fun (e, m) -> ewr (Bin (e, Mod, eInt m))+let eMod = fun (e, e') -> ewr (Bin (e, Mod, e'))++(* let eMod = fun (e, m) -> ewr (Bin (e, Mod, eInt m)) *)+ let eModExp = fun (e, m) -> ewr (Bin (e, Mod, m)) let eVar = fun s -> ewr (Var s) let eApp = fun (s, es) -> ewr (App (s, es))@@ -583,17 +630,18 @@ (* Constructors: Predicates *)-let pTrue = pwr True-let pFalse = pwr False-let pAtom = fun (e1, r, e2) -> pwr (Atom (e1, r, e2))-let pMAtom = fun (e1, r, e2) -> pwr (MAtom (e1, r, e2))-let pOr = fun ps -> pwr (Or ps)-let pNot = fun p -> pwr (Not p)-let pBexp = fun e -> pwr (Bexp e)-let pImp = fun (p1,p2) -> pwr (Imp (p1,p2))-let pIff = fun (p1,p2) -> pwr (Iff (p1,p2))-let pForall= fun (qs, p) -> pwr (Forall (qs, p))-let pEqual = fun (e1,e2) -> pAtom (e1, Eq, e2)+let pTrue = pwr True+let pFalse = pwr False+let pAtom = fun (e1, r, e2) -> pwr (Atom (e1, r, e2))+let pMAtom = fun (e1, r, e2) -> pwr (MAtom (e1, r, e2))+let pOr = fun ps -> pwr (Or ps)+let pNot = fun p -> pwr (Not p)+let pBexp = fun e -> pwr (Bexp e)+let pImp = fun (p1,p2) -> pwr (Imp (p1,p2))+let pIff = fun (p1,p2) -> pwr (Iff (p1,p2))+let pForall = fun (qs, p) -> pwr (Forall (qs, p))+let pEqual = fun (e1,e2) -> pAtom (e1, Eq, e2)+let pUequal = fun (e1,e2) -> pAtom (e1, Ueq, e2) let pAnd = fun ps -> match Misc.flap conjuncts ps with @@ -623,12 +671,14 @@ | Mod -> "mod" let brel_to_string = function - | Eq -> "="- | Ne -> "!="- | Gt -> ">"- | Ge -> ">="- | Lt -> "<"- | Le -> "<="+ | Eq -> "="+ | Ne -> "!="+ | Gt -> ">"+ | Ge -> ">="+ | Lt -> "<"+ | Le -> "<="+ | Ueq -> "~~"+ | Une -> "!~" let print_brel ppf r = F.fprintf ppf "%s" (brel_to_string r)@@ -660,12 +710,21 @@ print_expr e1 (ops |>: bop_to_string |> String.concat " ; ") print_expr e2- + + | Ite (ip, te, ee) -> + F.fprintf ppf "if %a then %a else %a" + print_pred ip + print_expr te+ print_expr ee+ + (* DEPRECATED TO HELP HS Parser | Ite(ip,te,ee) -> F.fprintf ppf "(%a ? %a : %a)" print_pred ip print_expr te print_expr ee+ *) + | Fld(s, e) -> F.fprintf ppf "%a.%s" print_expr e s | Cst(e,t) ->@@ -976,12 +1035,13 @@ let rec is_tauto = function- | Atom(e1, Eq, e2), _ -> snd e1 == snd e2- | Imp (p1, p2), _ -> snd p1 == snd p2- | And ps, _ -> List.for_all is_tauto ps- | Or ps, _ -> List.exists is_tauto ps- | True, _ -> true- | _ -> false+ | Atom(e1, Eq, e2), _ -> snd e1 == snd e2+ | Atom(e1, Ueq, e2), _ -> snd e1 == snd e2+ | Imp (p1, p2), _ -> snd p1 == snd p2+ | And ps, _ -> List.for_all is_tauto ps+ | Or ps, _ -> List.exists is_tauto ps+ | True, _ -> true+ | _ -> false let has_bot p = let r = ref false in@@ -1077,8 +1137,10 @@ match euw e with | Bot -> None- | Con _ -> + | Con (Constant.Int _) -> Some Sort.Int + | Con (Constant.Real _) -> + Some Sort.Real | Var s -> sortcheck_sym f s | Bin (e1, op, e2) -> @@ -1141,11 +1203,22 @@ -and sortcheck_op g f (e1, op, e2) = +and sortcheck_op g f (e1, op, e2) =+(* DEBUGGING + let (s1, s2) = Misc.map_pair (sortcheck_expr g f) (e1, e2) in + let _ = match (s1, s2) with + | (Some t1, Some t2) -> F.printf "sortcheck_op : \n%s - %s\n" (Sort.to_string t1) (Sort.to_string t2) + | (_, Some t2) -> F.printf "sortcheck_op1 : \n - %s\n" (Sort.to_string t2) + | (Some t1, _) -> F.printf "sortcheck_op2 : \n%s \n" (Sort.to_string t1) + | (_, _) -> F.printf "sortcheck_op3 : \n" + in *) match Misc.map_pair (sortcheck_expr g f) (e1, e2) with | (Some Sort.Int, Some Sort.Int) -> Some Sort.Int- ++ | (Some Sort.Real, Some Sort.Real) + -> Some Sort.Real+ (* only allow when language is Haskell *) | (Some (Sort.Ptr l), Some (Sort.Ptr l')) when (l = l' && sortcheck_loc f l = Some Sort.Num)@@ -1173,11 +1246,16 @@ | _ , Some Sort.Int, Some (Sort.Ptr l) | _ , Some (Sort.Ptr l), Some Sort.Int -> (sortcheck_loc f l = Some Sort.Num)- | _ , Some (Sort.Ptr l1), Some (Sort.Ptr l2) when (sortcheck_loc f l1 = Some Sort.Num) && (sortcheck_loc f l2 = Some Sort.Num)+ | _ , Some (Sort.Ptr l1), Some (Sort.Ptr l2) + when (sortcheck_loc f l1 = Some Sort.Num) + && (sortcheck_loc f l2 = Some Sort.Num) -> true | 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 | _ , Some (Sort.App (tc,_)), _ when (g tc) (* tc is an interpreted tycon *) -> false@@ -1200,6 +1278,11 @@ | 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)) && + (not (None = sortcheck_expr g f e2)) + | Atom ((Con (Constant.Int(0)),_), _, e) | Atom (e, _, (Con (Constant.Int(0)),_)) when not (!Constants.strictsortcheck)@@ -1277,21 +1360,24 @@ else p let symm_brel = function- | Eq -> Eq - | Ne -> Ne - | Gt -> Lt- | Ge -> Le- | Lt -> Gt- | Le -> Ge-+ | Eq -> Eq + | Ueq -> Ueq + | Ne -> Ne + | Une -> Une + | Gt -> Lt+ | Ge -> Le+ | Lt -> Gt+ | Le -> Ge let neg_brel = function - | Eq -> Ne- | Ne -> Eq- | Gt -> Le- | Ge -> Lt- | Lt -> Ge- | Le -> Gt+ | Eq -> Ne+ | Ueq -> Une+ | Ne -> Eq+ | Une -> Ueq+ | Gt -> Le+ | Ge -> Lt+ | Lt -> Ge+ | Le -> Gt let rec push_neg ?(neg=false) ((p, _) as pred) = match p with
external/fixpoint/ast.mli view
@@ -60,6 +60,7 @@ val t_obj : t val t_bool : t val t_int : t+ val t_real : t val t_generic : int -> t val t_ptr : loc -> t val t_func : int -> t list -> t@@ -68,7 +69,9 @@ 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 func_of_t : t -> (int * t list * t) option val ptr_of_t : t -> loc option@@ -102,14 +105,14 @@ module Constant : sig- type t = Int of int+ type t = Int of int | Real of float val to_string : t -> string val print : Format.formatter -> t -> unit end type tag (* externally opaque *) -type brel = Eq | Ne | Gt | Ge | Lt | Le +type brel = Eq | Ne | Gt | Ge | Lt | Le | Ueq | Une type bop = Plus | Minus | Times | Div | Mod (* NOTE: For "Mod" 2nd expr should be a constant or a var *) @@ -147,7 +150,7 @@ val eInt : int -> expr val eCon : Constant.t -> expr val eMExp : expr list -> expr-val eMod : expr * int -> expr+val eMod : expr * expr -> expr val eModExp : expr * expr -> expr val eVar : Symbol.t -> expr val eApp : Symbol.t * expr list -> expr@@ -169,7 +172,7 @@ val pBexp : expr -> pred val pForall: ((Symbol.t * Sort. t) list) * pred -> pred val pEqual : expr * expr -> pred-+val pUequal : expr * expr -> pred val neg_brel : brel -> brel module Expression :
external/fixpoint/cindex.ml view
@@ -38,7 +38,7 @@ open Misc.Ops -let mydebug = false +let mydebug = false (* TODO: Describe the SCC ordering scheme! *) @@ -228,7 +228,7 @@ * lives := Pre*(roots) where Pre* is refl-trans-clos of the depends-on relation *) let make_lives cm real_deps =- let dm = real_deps |>: Misc.swap |> IM.of_alist in+ let dm = real_deps |> List.rev_map Misc.swap |> IM.of_alist in let js = cm |> IM.filter (fun _ -> C.is_conc_rhs) |> IM.domain |> IS.of_list in (js, IS.empty) |> Misc.fixpoint begin fun (js, vm) ->@@ -242,7 +242,7 @@ in ((js, vm), not (IS.is_empty js)) end |> (fst <+> snd) - >> (IS.cardinal <+> Co.bprintf mydebug "#Live Constraints: %d \n") + >> (IS.cardinal <+> Co.bprintf mydebug "#Live Constraints: %d \n") let create_raw kuts ds cm dm real_deps = let deps = adjust_deps cm ds real_deps in@@ -250,7 +250,6 @@ { cnst = cm; ds = ds; kuts = kuts; rdeps = real_deps; rnkm = rnkm ; depm = dm; rts = make_roots rnkm deps ; pend = H.create 17} - (***********************************************************************) (**************************** API **************************************) (***********************************************************************)@@ -279,7 +278,7 @@ (* API *) let slice me = - let lives = make_lives me.cnst me.rdeps in+ let lives = BS.time "make_lives" (make_lives me.cnst) me.rdeps in let cm = me.cnst |> IM.filter (fun i _ -> IS.mem i lives) in let dm = me.depm @@ -287,9 +286,24 @@ |> IM.map (List.filter (fun j -> IS.mem j lives)) in let rdeps = me.rdeps |> Misc.filter (fun (i,j) -> IS.mem i lives && IS.mem j lives) in - create_raw me.kuts me.ds cm dm rdeps- >> save !Co.save_file+ (BS.time "create_raw" (create_raw me.kuts me.ds cm dm) rdeps)+ >> (fun z -> if !Co.save_slice then save (Co.get_save_file ()) z) +(* +let slice me = + let lives = BS.time "make_lives" (make_lives me.cnst) me.rdeps in+ let cm = BS.time "slice-filter-1" (IM.filter (fun i _ -> IS.mem i lives)) me.cnst in+ let dm0 = me.depm in+ let dm1 = BS.time "slice-filter-2" (IM.filter (fun i _ -> IS.mem i lives)) dm0 in + let dm2 = BS.time "slice-filter-2" (IM.map (List.filter (fun j -> IS.mem j lives))) dm1 in+ let rdeps = BS.time "slice-filter-4" (Misc.filter (fun (i,j) -> IS.mem i lives && IS.mem j lives)) me.rdeps in + let rv = (BS.time "create_raw" (create_raw me.kuts me.ds cm dm2) rdeps) in+ let _ = if !Co.save_slice then BS.time "save slice" (save (Co.get_save_file ())) rv in + rv++*)++ (* API *) let slice_wf me ws = let ks = me.cnst @@ -297,8 +311,10 @@ |> Misc.flap C.kvars_of_t |> Misc.map snd |> SS.of_list - in Misc.filter (C.reft_of_wf <+> C.kvars_of_reft <+> List.exists (fun (_,k) -> SS.mem k ks)) ws- + >> (SS.cardinal <+> Co.bprintf mydebug "#Live KVars: %d \n")+ in + Misc.filter (C.reft_of_wf <+> C.kvars_of_reft <+> List.exists (fun (_,k) -> SS.mem k ks)) ws+ >> (List.length <+> Co.bprintf mydebug "#Live WF: %d \n") let pp_cstr_id ppf c = F.fprintf ppf "%d" (C.id_of_t c) let pp_cstr_ids ppf cs = F.fprintf ppf "@[%a@.@]" (Misc.pprint_many false "," pp_cstr_id) cs
external/fixpoint/fixConfig.mli view
@@ -4,6 +4,7 @@ exception UnmappedKvar of Ast.Symbol.t *) type solbind = Ast.Symbol.t * ((Ast.Symbol.t * (Ast.expr list)) list)+ type deft = Srt of Ast.Sort.t | Axm of Ast.pred | Cst of FixConstraint.t
external/fixpoint/fixConstraint.ml view
@@ -45,6 +45,7 @@ type refa = Conc of A.pred | Kvar of Su.t * Sy.t type reft = Sy.t * A.Sort.t * refa list (* { VV: t | [ra] } *) type envt = reft SM.t+type senvt = So.t SM.t type wf = envt * reft * (id option) * (Qualifier.t -> bool) type t = { full : envt; nontriv : envt;@@ -67,7 +68,54 @@ *) let mydebug = false + +(***************************************************************)+(*********************** Getter/Setter *************************)+(***************************************************************) +let vv_of_reft = fst3+let sort_of_reft = snd3+let ras_of_reft = thd3+let shape_of_reft = fun (v, so, _) -> (v, so, [])+++(* 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 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 make_t = fun env p ((v,t,ras1) as r1) r2 io is ->+ let p = A.simplify_pred p in+ 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 + ; nontriv = ne+ ; guard = p+ ; iguard = A.pAnd gps + ; lhs = (v, t, kras) + ; rhs = r2+ ; ido = io+ ; tag = is }+*)++(* API *)+let make_wf = fun env r io -> (env, r, io, fun _ -> true)+let make_filtered_wf = fun env r io fltr -> (env, r, io, fltr)+let env_of_wf = fst4+let reft_of_wf = snd4+let id_of_wf = function (_,_,Some i,_) -> i | _ -> assertf "C.id_of_wf"+let filter_of_wf = fth4+ + (*************************************************************) (************************** Misc. ***************************) (*************************************************************)@@ -79,9 +127,11 @@ 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 tick, _ = Misc.mk_int_factory () in tick <+> string_of_int <+> (^) "k_" <+> Sy.of_string@@ -148,12 +198,6 @@ let is_conc_refa = function Conc p -> not (P.is_tauto p) | _ -> false (* API *)-let is_conc_rhs {rhs = (_,_,ras)} =- List.exists is_conc_refa ras- >> (fun rv -> if rv then (asserts (List.for_all is_conc_refa ras) "is_conc_rhs"))---(* API *) let kvars_of_t {nontriv = env; lhs = lhs; rhs = rhs} = [lhs; rhs] |> SM.fold (fun _ r acc -> r :: acc) env@@ -189,6 +233,20 @@ 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 + ; nontriv = ne+ ; guard = p+ ; iguard = A.pAnd (p::ps) + ; lhs = r1 + ; rhs = r2+ ; ido = io+ ; tag = is }+++(* API *) let is_conc_refa = function | Conc _ -> true | _ -> false@@ -224,8 +282,8 @@ env [] (* API *)-let wellformed_pred env = - A.sortcheck_pred Theories.is_interp (Misc.maybe_map snd3 <.> Misc.flip SM.maybe_find env)+let wellformed_pred senv = + A.sortcheck_pred Theories.is_interp (Misc.flip SM.maybe_find senv) (* API *) let preds_of_lhs_nofilter f c = @@ -245,19 +303,19 @@ else ps *) -let report_wellformed env c p wf = +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) env 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 _ = 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 if !Co.strictsortcheck then raise (BadConstraint (Misc.maybe c.ido, c.tag, msg)) (* API *) let preds_of_lhs f c = - let env = SM.add (fst3 c.lhs) c.lhs c.full in+ let senv = senv_of_t c in (* SM.add (fst3 c.lhs) c.lhs c.full in *) preds_of_lhs_nofilter f c - |> List.filter (fun p -> wellformed_pred env p >> report_wellformed env c p)+ |> List.filter (fun p -> wellformed_pred senv p >> report_wellformed senv c p) (* API *) let vars_of_t f ({rhs = r2} as c) =@@ -376,88 +434,6 @@ -(***************************************************************)-(*********************** Getter/Setter *************************)-(***************************************************************)--let theta_ra (su': Su.t) = function- | Conc p -> Conc (A.substs_pred p su')- | 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))--let vv_of_reft = fst3-let sort_of_reft = snd3-let ras_of_reft = thd3-let shape_of_reft = fun (v, so, _) -> (v, so, [])-let theta = fun subs (v, so, ras) -> (v, so, Misc.map (theta_ra subs) ras)---(* 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 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 is_tauto = rhs_of_t <+> ras_of_reft <+> List.for_all is_tauto_refatom-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 - ; nontriv = ne- ; guard = p- ; iguard = A.pAnd (p::ps) - ; lhs = r1 - ; rhs = r2- ; ido = io- ; tag = is }--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 make_t = fun env p ((v,t,ras1) as r1) r2 io is ->- let p = A.simplify_pred p in- 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 - ; nontriv = ne- ; guard = p- ; iguard = A.pAnd gps - ; lhs = (v, t, kras) - ; rhs = r2- ; ido = io- ; tag = is }-*)--let reft_of_sort so = make_reft (Sy.value_variable so) so []--let add_consts_env consts env =- consts- |> List.map (Misc.app_snd reft_of_sort)- |> List.fold_left (fun env (x,r) -> SM.add x r env) env--(* API *)-let add_consts_wf consts (env,x,y,z) = (add_consts_env consts env, x, y, z)--(* API *)-let add_consts_t consts t = {t with full = add_consts_env consts t.full}--(* API *)-let make_wf = fun env r io -> (env, r, io, fun _ -> true)-let make_filtered_wf = fun env r io fltr -> (env, r, io, fltr)-let env_of_wf = fst4-let reft_of_wf = snd4-let id_of_wf = function (_,_,Some i,_) -> i | _ -> assertf "C.id_of_wf"-let filter_of_wf = fth4- let intersect_maps m1 m2 = SM.filter begin fun k elt -> SM.mem k m2 && SM.find k m2 = elt end m1@@ -510,7 +486,33 @@ | Kvar (xes, kvar) -> ps, (xes, kvar) :: ks end ([], []) (ras_of_reft reft) +(***************************************************************************************)+(***************************************************************************************)+(***************************************************************************************) +let theta_ra (su': Su.t) = function+ | Conc p -> Conc (A.substs_pred p su')+ | 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))+let theta = fun subs (v, so, ras) -> (v, so, Misc.map (theta_ra subs) ras)++let reft_of_sort so = make_reft (Sy.value_variable so) so []++let add_consts_env consts env =+ consts+ |> List.map (Misc.app_snd reft_of_sort)+ |> List.fold_left (fun env (x,r) -> SM.add x r env) env++(* API *)+let add_consts_wf consts (env,x,y,z) = (add_consts_env consts env, x, y, z)++(* API *)+let add_consts_t consts t = {t with full = add_consts_env consts t.full}+++ (***************************************************************) (************* Add Distinct Ids to Constraints *****************) (***************************************************************)@@ -539,3 +541,14 @@ | {ido = None} -> j+1, {c with ido = Some j} | c -> j, c end ((max_id n cs) + 1) cs++++(* API *)+let is_conc_rhs {ido = i; rhs = (_,_,ras)} =+ 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))++ +
external/fixpoint/fixConstraint.mli view
@@ -33,11 +33,13 @@ exception BadConstraint of (id * tag * string) -type soln = Ast.Symbol.t -> Ast.pred list-type refa = Conc of Ast.pred | Kvar of Ast.Subst.t * Ast.Symbol.t-type reft = Ast.Symbol.t * Ast.Sort.t * refa list (* { VV: t | [ra] } *)-type envt = reft Ast.Symbol.SMap.t+type soln = Ast.Symbol.t -> Ast.pred list+type refa = Conc of Ast.pred | Kvar of Ast.Subst.t * Ast.Symbol.t+type reft = Ast.Symbol.t * Ast.Sort.t * refa list (* { VV: t | [ra] } *)+type envt = reft Ast.Symbol.SMap.t+type senvt = Ast.Sort.t Ast.Symbol.SMap.t + val fresh_kvar : unit -> Ast.Symbol.t val kvars_of_reft : reft -> (Ast.Subst.t * Ast.Symbol.t) list val kvars_of_t : t -> (Ast.Subst.t * Ast.Symbol.t) list@@ -49,10 +51,10 @@ val meet_solution : soln -> soln -> soln val apply_solution : soln -> reft -> reft -val wellformed_pred : envt -> Ast.pred -> bool-val preds_of_refa : soln -> refa -> Ast.pred list-val preds_of_reft : soln -> reft -> Ast.pred list-val preds_of_lhs : soln -> t -> Ast.pred list+val wellformed_pred : senvt -> Ast.pred -> bool+val preds_of_refa : soln -> refa -> Ast.pred list+val preds_of_reft : soln -> reft -> Ast.pred list+val preds_of_lhs : soln -> t -> Ast.pred list val preds_of_lhs_nofilter : soln -> t -> Ast.pred list val vars_of_t : soln -> t -> Ast.Symbol.t list@@ -115,7 +117,7 @@ val sort_of_t : t -> Ast.Sort.t val vv_of_t : t -> Ast.Symbol.t-val senv_of_t : t -> Ast.Sort.t Ast.Symbol.SMap.t+val senv_of_t : t -> senvt val env_of_t : t -> envt val grd_of_t : t -> Ast.pred val lhs_of_t : t -> reft
external/fixpoint/fixLex.mll view
@@ -45,6 +45,10 @@ | i -> accum (acc str.[i]) (d * 10) (i - 1) in accum 0 1 (len-1) *)+ let safe_float_of_string s = + try float_of_string s with ex -> + let _ = Printf.printf "safe_int_of_string crashes on: %s (error = %s)" s (Printexc.to_string ex) in+ raise ex let safe_int_of_string s = try int_of_string s with ex -> @@ -103,6 +107,8 @@ | "=>" { IMPL } | "!=" { NE } | "=" { EQ }+ | "~~" { UEQ }+ | "!~" { UNE } | "<=" { LE } | "<" { LT } | ">=" { GE }@@ -111,6 +117,7 @@ | "obj" { OBJ } | "num" { NUM } | "int" { INT }+ | "real" { REAL } | "ptr" { PTR } | "<fun>" { LFUN } (* | "fptr" { FPTR } *)@@ -134,6 +141,7 @@ | "rhs" { RHS } | "reft" { REF } | "@" { TVAR } + | (digit)+'.'(digit)+ { Real (safe_float_of_string (Lexing.lexeme lexbuf)) } | (digit)+ { Num (safe_int_of_string (Lexing.lexeme lexbuf)) } | (alphlet)letdig* { Id (Lexing.lexeme lexbuf) } | '''[^''']*''' { let str = Lexing.lexeme lexbuf in
external/fixpoint/fixParse.mly view
@@ -54,12 +54,13 @@ %token <string> Id %token <int> Num+%token <float> Real %token TVAR %token TAG ID %token BEXP %token TRUE FALSE %token LPAREN RPAREN LB RB LC RC-%token EQ NE GT GE LT LE+%token EQ NE GT GE LT LE UEQ UNE %token AND OR NOT NOTWORD IMPL IFF IFFWORD FORALL SEMI COMMA COLON MID %token EOF %token MOD @@ -68,7 +69,7 @@ %token TIMES %token DIV %token QM DOT ASGN-%token OBJ INT NUM PTR LFUN BOOL UNINT FUNC+%token OBJ REAL INT NUM PTR LFUN BOOL UNINT FUNC %token SRT AXM CON CST WF SOL QUL KUT BIND ADP DDP %token ENV GRD LHS RHS REF @@ -161,6 +162,7 @@ bsort: | INT { So.t_int }+ | REAL { So.t_real } | BOOL { So.t_bool } | PTR { So.t_ptr (So.Lvar 0) } | PTR LPAREN LFUN RPAREN { So.t_ptr (So.LFun) }@@ -178,6 +180,7 @@ So.t_app (So.tycon s) [] (* tycon *) } | LPAREN sort RPAREN { $2 }+ | LB RB { So.t_app (So.tycon "List") [] } ; @@ -207,12 +210,14 @@ ; rel:- EQ { A.Eq }- | NE { A.Ne } - | GT { A.Gt }- | GE { A.Ge }- | LT { A.Lt }- | LE { A.Le }+ EQ { A.Eq }+ | NE { A.Ne } + | UEQ { A.Ueq } + | UNE { A.Une } + | GT { A.Gt }+ | GE { A.Ge }+ | LT { A.Lt }+ | LE { A.Le } ; @@ -268,7 +273,7 @@ Id { A.eVar (Sy.of_string $1) } | con { A.eCon $1 } | exprs { A.eMExp $1 } - | LPAREN expr MOD Num RPAREN { A.eMod ($2, $4) }+ | LPAREN expr MOD expr RPAREN { A.eMod ($2, $4) } | expr PLUS expr { A.eBin ($1, A.Plus, $3) } | expr MINUS expr { A.eBin ($1, A.Minus, $3) } | expr TIMES expr { A.eBin ($1, A.Times, $3) }@@ -302,8 +307,10 @@ con:+ | Real { (A.Constant.Real $1) } | Num { (A.Constant.Int $1) } | MINUS Num { (A.Constant.Int (-1 * $2)) }+ | MINUS Real { (A.Constant.Real (-. $2)) } ; cons:
external/fixpoint/fixpoint.ml view
@@ -64,13 +64,13 @@ end let solve ac = - let _ = Co.bprintflush mydebug "Fixpoint: Creating CI\n" in+ let _ = Co.bprintflush mydebug "Fixpoint: Creating CI\n" in let ctx, s = BS.time "create" SPA.create ac None in let _ = Co.bprintflush mydebug "Fixpoint: Solving \n" in let s, cs',_ = BS.time "solve" (SPA.solve ctx) s in let _ = Co.bprintflush mydebug "Fixpoint: Saving Result \n" in- let _ = BS.time "save" (save_raw !Co.out_file cs') s in+ let _ = BS.time "save" (save_raw (Co.get_out_file ()) cs') s in let _ = Co.bprintflush mydebug "Fixpoint: Saving Result DONE \n" in cs' @@ -84,7 +84,7 @@ with (C.BadConstraint (id, tag, msg)) -> begin Format.printf "Fixpoint: Bad Constraint! id = %d (%s) tag = %a \n" id msg C.print_tag tag;- save_crash !Co.out_file (id, tag, msg); + save_crash (Co.get_out_file ()) (id, tag, msg); end (*****************************************************************)@@ -112,7 +112,7 @@ let dump_simp ac = let ac = {ac with Cg.cs = simplify_ts ac.Cg.cs; Cg.bm = SM.empty} in- Misc.with_out_formatter !Co.save_file (fun ppf -> Cg.print ppf ac)+ Misc.with_out_formatter (Co.get_save_file ()) (fun ppf -> Cg.print ppf ac) (* let dump_simp ac =
external/fixpoint/kvgraph.ml view
@@ -203,7 +203,7 @@ (* API *) let print_stats g = - g >> dump_graph (!Constants.save_file^".dot")+ g >> dump_graph ((Constants.get_out_file ())^".dot") >> (single_wr_ks <+> print_ks "single write kvs:") >> (multi_wr_ks <+> print_ks "multi write kvs:") >> (undef_ks <+> print_ks "undefined kvs:")
external/fixpoint/predAbs.ml view
@@ -44,9 +44,10 @@ module H = Hashtbl module PH = A.Predicate.Hash -module CX = Counterexample+module CX = Counterexample module Misc = FixMisc -module IM = Misc.IntMap+module IM = Misc.IntMap+module IS = Misc.IntSet open Misc.Ops let mydebug = false @@ -89,18 +90,27 @@ end module G = Graph.Persistent.Digraph.ConcreteLabeled(V)(Id)+ module SCC = Graph.Components.Make(G) -type bind = Q.t list+type bind = Bot | NonBot of Q.t list -type t = - { tpc : ProverArch.prover- ; m : bind 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 *)- ; qleqs: Q2S.t (* (q1,q2) \in qleqs implies q1 => q2 *)- +(* API *)+let meet_bind b1 b2 = match (b1, b2) with+ | (Bot, _) -> b2+ | (_, Bot) -> b1+ | (NonBot x, NonBot y) -> NonBot (x ++ y)++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 *) + ; qleqs : Q2S.t (* (q1,q2) \in qleqs implies q1 => q2 *)+ ; seen : IS.t (* constraint (ids) that have been "refined" once *) (* counterexamples *) ; step : CX.step (* which iteration *) ; ctrace : CX.ctrace @@ -117,9 +127,10 @@ ; stat_emptyRHS : int ref } +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 = F.fprintf ppf "(%a, %a)" P.print (Q.pred_of_t q) Q.print_args q@@ -127,12 +138,17 @@ let pprint_ds = Misc.pprint_many false ";" pprint_dep +let pprint_bind ppf = function + | Bot -> F.fprintf ppf "(false, BOT())"+ | NonBot qs -> pprint_ds ppf qs+ 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 + (*************************************************************) (************* Breadcrumbs for Cex Generation ****************) (*************************************************************)@@ -145,9 +161,16 @@ 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 + |> function | Bot -> []+ | NonBot qs -> qs++ let cx_update ks kqsm' me : t = List.fold_left begin fun me k -> - let qs = QS.of_list (SM.finds k me.m) in+ 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 @@ -185,7 +208,6 @@ (*************************** Dumping to Dot *****************************) (************************************************************************) - module DotGraph = struct type t = G.t module V = G.V@@ -208,17 +230,16 @@ >> (fun oc -> Dot.output_graph oc g) |> close_out -let p_read s k =- let _ = asserts (SM.mem k s.m) "ERROR: p_read : unknown kvar %s\n" (Sy.to_string k) in- SM.find k s.m |>: (fun q -> ((k, q), Q.pred_of_t q)) + (* INV: qs' \subseteq qs *) let update m k ds' =- let ds = SM.finds k m in- let n = List.length ds in- let n' = List.length ds' in + 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 - ((n != n'), SM.add k ds' m)+ ((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" @@ -263,45 +284,449 @@ |> snd (***************************************************************)-(************************** Refinement *************************)+(**************** Query Current Solution ***********************) (***************************************************************) -let rhs_cands s = function- | C.Kvar (su, k) -> k (* >> (fun k -> Co.bprintflush mydebug ("rhs_cands: k = "^(Sy.to_string k)^"\n")) *)- |> p_read s - (* >> (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")) *)+let preds_of_bind = function+ | Bot -> [A.pFalse]+ | NonBot qs -> List.rev_map Q.pred_of_t qs++let raw_read me k = match SM.maybe_find k me.m with+ | None -> []+ | Some z -> preds_of_bind z++(* API *)+let read me k = (me.assm k) ++ (raw_read me k)++(* API *)+let read_bind s k = failwith "PredAbs.read_bind"+++(***************************************************************)+(******************** Qualifier Instantiation ******************)+(***************************************************************)+++(* DEBUG ONLY *)+let print_param ppf (x, 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) =+ F.fprintf ppf "[%a := %a]" Sy.print x Sy.print y+let print_valid_bindings ppf xys =+ F.printf "[%a]" (Misc.pprint_many false "" print_valid_binding) xys++(* +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'+*)++let varmatch_ctr = ref 0++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+ let x' = Misc.suffix_of_string x 1 in+ Misc.is_prefix x' y+ else true++let sort_compat t1 t2 = A.Sort.unify [t1] [t2] <> None++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. *)++(***************************************************************)+(**************** Lazy Instantiation: WF-Index *****************)+(***************************************************************)++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 + >> 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') -> + env |> SM.filter (fun x _ -> SM.mem x env')+ |> (fun env' -> (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 -> + 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 + |> (function None -> [y] | Some ye -> E.support ye)+ |> List.for_all f ++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) ++ + (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 = + 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 + 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 + *)+ end wm ksus++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+ upds_wf_index (env, r) wm (kvars_of_wf w)+ end SM.empty ws++let create_wf_index_refine_sort cs wm =+ wm |> SM.map (fun (env,v,t) -> ((SM.to_list env), v, t))+ |> Misc.flip (List.fold_left refine_wf_index) cs+ |> SM.map (fun (xts,v,t) -> (SM.of_list xts, v, t))++(* API *)+let create_wf_index cs ws =+ ws |> create_wf_index_basic+ |> ((!Constants.refine_sort) <?> (create_wf_index_refine_sort cs))++(********************************************************************************)+(****** Brute Force (Post-Selection based) Qualifier Instantiation **************)+(********************************************************************************)++type qual_binding = (Sy.t * Sy.t) list++let is_valid_binding (xys : qual_binding) : bool = + List.for_all varmatch xys++let valid_bindings ys (x,_) =+ ys |> List.map (fun y -> (x, y))+ |> List.filter varmatch++let inst_qual env ys evv (q : Q.t) : Q.t list =+ let vve = (Q.vv_of_t q, evv) in+ match Q.params_of_t q with+ | [] ->+ [(Q.inst q [vve])]+ | xts ->+ 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 *) + (* >> (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)) *)+ |> List.rev_map (List.map (Misc.app_snd A.eVar)) (* instantiations *)+ |> 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 + |> Misc.filter (not <.> A.Sort.is_func <.> snd)++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') ++(********************************************************************************)+(****** Sort Based Qualifier Instantiation **************************************)+(********************************************************************************)++(* [ (su', (x,y) : xys) | (su, xys) <- wkl+ , (y, ty) <- yts+ , varmatch (x, y)+ , Some su' <- unifyWith su [tx] [ty] ] *)++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) -> + match A.Sort.unifyWith su [tx] [ty] with+ | None -> None+ | Some su' -> Some (su', (x,y) :: xys)+ ) yts+ ) wkl ++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 -> + 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 -> [] ++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++(***************************************************************)+(**************** Lazy Instantiation ***************************)+(***************************************************************)++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') ++ +(*+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+*)++let is_non_trivial_var me c su =+ let senv = C.senv_of_t c in+ let ok z = SM.mem z senv in+ fun y _ -> valid_after_substitution ok su y+++(* RJ: DO NOT DELETE EVER! *)+let ppBinding k zs = + F.printf "ppBind %a := %a \n" + Sy.print k + (Misc.pprint_many false ", " Q.print) zs++(* API *)+let lazy_instantiate_with me c lps k su : Q.t list =+ let (env,v,t) = SM.safeFind k me.wm "lazy_instantiate" in+ let env' = SM.filter (is_non_trivial_var me c (* lps *) su) env in+ inst_ext me.qs env env' v t+ (* >> 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 + (* >> (fun k -> Co.bprintflush mydebug ("rhs_cands: k = "^(Sy.to_string k)^"\n")) *)+ |> 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")) *) | _ -> []+}}} *) +let get_lhs me c = BS.time "preds_of_lhs" (C.preds_of_lhs (read me)) c++let bind_read me k = SM.find_default Bot k me.m++let is_bot_reft me (_,_,ras) =+ 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 + |> List.exists (is_bot_reft me)++let is_bot_rhs me c =+ is_bot_reft me <| C.rhs_of_t c++let make_cand k su q =+ let qp = Q.pred_of_t q in+ let qp' = A.substs_pred qp su in+ ((k, q), qp')++let quals_of_bind me c lhs k su = function+ | NonBot qs -> + (qs, me)+ | 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" + | NonBot qs -> qs |>: make_cand k su+ end+ | _ -> []++let rhs_cands_noinst me c =+ c |> C.rhs_of_t+ |> 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 _ -> + (me, [])+ | 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 + (Misc.flatten zs, me)++let lhs_preds me c = + let lps = BS.time "preds_of_lhs" (C.preds_of_lhs (read me)) c in+ (lps, me)++let refine_sort_bot_rhs me c =+ let (lps, me) = lhs_preds me c in+ let (rcs, me) = rhs_cands_inst me c lps in+ 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 (lps, me) = lhs_preds 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 + (false, me, lps, rcs)++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_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 + C.rhs_of_t c+ |> 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 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+ let _ = me.stat_matches += (List.length x1) in+ (List.map fst x1, x2)+ let check_tp me env vv t lps = function [] -> [] | rcs ->- (* let rv = TP.set_filter me.tpc env vv lps rcs in- let _ = ignore(me.stat_tp_refines += 1)- ; ignore(me.stat_imp_queries += (List.length rcs))- ; ignore(me.stat_valid_queries += (List.length rv)) - in rv *) 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) -+let refine_tp me c lps x2 =+ if C.is_simple c then+ (me.stat_simple_refines += 1) >| []+ else+ let senv = C.senv_of_t c in+ let vv = C.vv_of_t c in+ 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) + else+ let (ch, me, lps, rcs) = refine_sort me c in+ if BS.time "lhs_contra" (List.exists P.is_contra) lps then+ let _ = me.stat_unsatLHS += 1 in+ let _ = me.stat_umatches += List.length rcs in+ (ch, me)+ else+ let rcs = List.filter (fun (_,p) -> not (P.is_contra p)) rcs in+ let (kqs1, x2) = refine_match me lps rcs in+ let kqs2 = refine_tp me c lps x2 in+ let ks = C.rhs_of_t c |> C.kvars_of_reft |>: snd in+ let (ch', me) = p_update me ks (kqs1 ++ kqs2) in+ (ch || ch', me) -(* API *)-let read me k = (me.assm k) ++ (if SM.mem k me.m then p_read me k |>: snd else [])+let refine me c =+ let (ch, me) = refine me c in+ (ch, {me with seen = IS.add (C.id_of_t c) me.seen}) -(* API *)-let read_bind s k = failwith "PredAbs.read_bind"+(* LAZYINST +let refine me c =+ let lps = lazy (get_lhs me c) in+ let (_,_,ra2s) as r = C.rhs_of_t c in+ let (ins, rcs) = BS.time "rhs_cands" (Misc.flap (rhs_cands me lps)) ra2s in+ if rcs = [] then + let _ = me.stat_emptyRHS += 1 in+ (false, me)+ else if BS.time "lhs_contra" (List.exists P.is_contra) (Lazy.force lps) then + let _ = me.stat_unsatLHS += 1 in+ let _ = me.stat_umatches += List.length rcs in+ (ch, me)+ else+ let lps = Lazy.force lps in+ let rcs = List.filter (fun (_,p) -> not (P.is_contra p)) rcs in+ 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+ let _ = me.stat_matches += (List.length x1) in+ let kqs1 = List.map fst x1 in+ (if C.is_simple c + then (ignore(me.stat_simple_refines += 1); kqs1) + else let senv = C.senv_of_t c in+ let vv = C.vv_of_t c in+ let t = C.sort_of_t c in+ kqs1 ++ (BS.time "check tp" (check_tp me senv vv t lps) x2))+ |> p_update me (get_rhs_kvars c)+ |> (fun (ch', z) -> (ch || ch', z)) let refine me c = let (_,_,ra2s) as r2 = C.rhs_of_t c in let k2s = r2 |> C.kvars_of_reft |> List.map snd in- let rcs = BS.time "rhs_cands" (Misc.flap (rhs_cands me)) ra2s in- if rcs = [] then+ let rcs = BS.time "rhs_cands" (Misc.flap (rhs_cands me c)) ra2s in+ if rcs = [] then let _ = me.stat_emptyRHS += 1 in (false, me)- else + else let lps = BS.time "preds_of_lhs" (C.preds_of_lhs (read me)) c in if BS.time "lhs_contra" (List.exists P.is_contra) lps then let _ = me.stat_unsatLHS += 1 in@@ -321,6 +746,7 @@ let t = C.sort_of_t c in kqs1 ++ (BS.time "check tp" (check_tp me senv vv t lps) x2)) |> p_update me k2s+*) let refine me c = let me = me |> (!Co.cex <?> cx_iter c) in@@ -329,35 +755,7 @@ (b, me) -(***************************************************************)-(****************** Sort Check Based Refinement ****************)-(***************************************************************) -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 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 - |> 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)); - List.rev_map fst xs)- >> (fun _ -> Co.bprintflush mydebug "\n refine_sort_reft TICK 4 \n")- *)- |> p_update me ks- |> snd--let refine_sort me c =- 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 - (* >> (fun _ -> Co.bprintflush mydebug "\n refine_sort TICK 2 \n") *)- (***************************************************************) (************************* Satisfaction ************************) (***************************************************************)@@ -384,9 +782,8 @@ *) let args_leq q1 q2 =- let xe1s, xe2s = (Q.args_of_t q1, Q.args_of_t q2) in- let xe1e2s = Misc.join fst xe1s xe2s in- List.for_all (fun ((_,e1),(_,e2)) -> e1 = e2) xe1e2s + 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 = @@ -411,7 +808,9 @@ (* API *) let min_binds s ds = ds |> min_binds_bot |> Misc.rootsBy (def_leq s)-let min_read s k = SM.finds k s.m |> min_binds s |>: pred_of_bind+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 @@ -466,174 +865,7 @@ |> Misc.map (Misc.map_pair Q.name_of_t) |> Q2S.of_list -(***************************************************************)-(******************** Qualifier Instantiation ******************)-(***************************************************************) -type qual_binding = (Sy.t * Sy.t) list--(* DEBUG ONLY *)-let print_param ppf (x, 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) =- F.fprintf ppf "[%a := %a]" Sy.print x Sy.print y-let print_valid_bindings ppf xys =- F.printf "[%a]" (Misc.pprint_many false "" print_valid_binding) xys--(* -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'-*)--let varmatch_ctr = ref 0--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- let x' = Misc.suffix_of_string x 1 in- Misc.is_prefix x' y- else true--let sort_compat t1 t2 = A.Sort.unify [t1] [t2] <> None--(* {{{ DONT DELETE FOR NOW let valid_bindings_sort env (x, t) =- let _ = failwith "valid_bindings_sort: slow AND incorrect. suppressed!" in- env |> SM.to_list- |> Misc.filter (snd <+> C.sort_of_reft <+> (sort_compat t))- |> Misc.map (fun (y,_) -> (x, y))- |> Misc.filter varmatch--let valid_bindings env ys (x, t) =- if !Co.sorted_quals- then valid_bindings_sort env (x, t)- else valid_bindings ys x-}}} *)--let wellformed_qual wf f q = - q |> Q.pred_of_t - |> 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. *)--(********************************************************************************)-(****** Brute Force (Post-Selection based) Qualifier Instantiation **************)-(********************************************************************************)--let is_valid_binding (xys : qual_binding) : bool = - List.for_all varmatch xys--let valid_bindings ys (x,_) =- ys |> List.map (fun y -> (x, y))- |> List.filter varmatch--let inst_qual env ys evv (q : Q.t) : Q.t list =- let vve = (Q.vv_of_t q, evv) in- match Q.params_of_t q with- | [] ->- [(Q.inst q [vve])]- | xts ->- 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 *) - (* >> (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)) *)- |> List.rev_map (List.map (Misc.app_snd A.eVar)) (* instantiations *)- |> 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_vars env = - env |> Sy.SMap.to_list - |> List.filter (fun (_, (_,so,_)) -> not (A.Sort.is_func so))- |> List.map fst --let inst_ext qs wf = - let _ = Misc.display_tick () in- let r = C.reft_of_wf wf in - let ks = C.kvars_of_reft r |> List.map snd in- let env = C.env_of_wf wf in- let vv = fst3 r in- let t = snd3 r in- let ys = inst_vars env in- let env' = Misc.maybe_map C.sort_of_reft <.> C.lookup_env (SM.add vv r 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 wf env' <&&> C.filter_of_wf wf)- |> Misc.cross_product ks- -(********************************************************************************)-(****** Sort Based Qualifier Instantiation **************************************)-(********************************************************************************)--let inst_binds env = - env |> SM.to_list - |> Misc.map (Misc.app_snd snd3) - |> Misc.filter (not <.> A.Sort.is_func <.> snd)--(* [ (su', (x,y) : xys) | (su, xys) <- wkl- , (y, ty) <- yts- , varmatch (x, y)- , Some su' <- unifyWith su [tx] [ty] ] *)--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) -> - match A.Sort.unifyWith su [tx] [ty] with- | None -> None- | Some su' -> Some (su', (x,y) :: xys)- ) yts- ) wkl --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 -> - 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 -> [] --let inst_ext_sorted qs wf = - let _ = Misc.display_tick () in- let r = C.reft_of_wf wf in - let ks = List.map snd <| C.kvars_of_reft r in- let env = C.env_of_wf wf in- let vv = fst3 r in- let t = snd3 r in- let yts = inst_binds env in- qs |> Misc.flap (inst_qual_sorted yts vv t)- |> Misc.cross_product ks--(*************************************************************************************)--let inst_ext qs wf =- if !Co.sorted_quals - then inst_ext_sorted qs wf - else inst_ext qs wf- -let inst_ext qs wf =- if mydebug then - let msg = Printf.sprintf "inst_ext wf id = %d" (C.id_of_wf wf) in- Misc.trace msg (inst_ext qs) wf- >> (List.length <+> F.printf "\n\ninst_ext wfid = %d: size = %d\n" (C.id_of_wf wf))- else inst_ext qs wf--(* API *)-let inst ws qs =- Misc.flap (inst_ext qs) ws - |> Misc.kgroupby fst - |> Misc.map (Misc.app_snd (List.map snd)) --- (*************************************************************************) (*************************** Creation ************************************) (*************************************************************************)@@ -643,14 +875,18 @@ then BS.time "Annots: make qleqs" (qleqs_of_qs ts sm consts ps) qs else Q2S.empty -let create ts sm ps consts assm qs bm =- { m = bm+let create obm cs ws ts sm ps consts assm qs bm =+ { m = bm+ ; om = SM.map (function Bot -> [] | NonBot qs -> qs) obm+ ; wm = create_wf_index cs ws ; assm = assm- ; qm = qs |>: Misc.pad_fst Q.name_of_t |> SM.of_list+(*; 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) ; tpc = TpNull.create ts sm ps consts- + ; seen = IS.empty+ (* Counterexamples *) ; step = 0 ; ctrace = IM.empty@@ -664,12 +900,42 @@ ; stat_emptyRHS = ref 0 } -(* RJ: DO NOT DELETE! *)-let ppBinding (k, zs) = - F.printf "ppBind %a := %a \n" - Sy.print k - (Misc.pprint_many false "," Q.print) zs+(***************************************************************)+(****************** Sort Check Based Refinement ****************)+(***************************************************************)+(* LAZYINST+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 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 + |> 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)); + List.rev_map fst xs)+ >> (fun _ -> Co.bprintflush mydebug "\n refine_sort_reft TICK 4 \n")+ *)+ |> p_update me ks+ |> snd++let refine_sort me c =+ 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 + (* >> (fun _ -> Co.bprintflush mydebug "\n refine_sort TICK 2 \n") *)+*)++(****************************************************************************)+(****************** APPLYING FACTS FOR INCREMENTAL SOLVING ******************)+(****************************************************************************)++(* LAZYINST+ (* Take in a solution of things that are known to be true, kf. Using this, we can prune qualifiers whose negations are implied by information in kf *)@@ -678,7 +944,7 @@ 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))) + |> List.filter (fun q -> (not (List.mem (k, q) false_qs))) in SM.add k qs m end me.m ks @@ -688,7 +954,7 @@ let (_,_,ras) as rhs = C.rhs_of_t c in let ks = rhs |> C.kvars_of_reft |> List.map snd in let lps = C.preds_of_lhs kf c in (* Use the known facts here *)- let rcs = (Misc.flap (rhs_cands me)) ras in+ let rcs = Misc.flap (rhs_cands me) ras in if rcs = [] then (* Nothing on the right hand side *) me else if check_tp me env vv t lps [(0, A.pFalse)] = [0] then@@ -710,42 +976,32 @@ let _ = Printf.printf "Started with %d, proved %d false\n" numqs (numqs-numqs') in sol -let binds_of_quals ws qs =- qs- (* |> Q.normalize *)- >> (fun qs -> Co.bprintf mydebug "Using Quals: \n%a" (Misc.pprint_many true "\n" Q.print) qs)- >> (fun _ -> Co.bprintflush mydebug "\nBEGIN: Qualifier Instantiation\n")- |> BS.time "Qual Inst" (inst ws) - >> (fun _ -> Co.bprintflush mydebug "\nDONE: Qualifier Instantiation\n")- (* >> List.iter ppBinding *)- |> SM.of_list - >> (fun _ -> Co.bprintflush mydebug "\nDONE: Qualifier Instantiation: Built Map \n")---let binds_of_quals ws qs = - match !Constants.dump_simp with- | "" -> binds_of_quals ws qs (* regular solving mode *)- | _ -> SM.empty (* constraint simplification mode *)+*) +(* LAZYINST: map each KVAR to BOT *)+let initial_solution c = + c.Cg.ws+ |> Misc.flap kvars_of_wf + |>: (fun k -> (k, Bot))+ |> SM.of_list (* API *)-let create c facts = - binds_of_quals c.Cg.ws c.Cg.qs- |> SM.extendWith (fun _ -> (++)) c.Cg.bm- |> create c.Cg.ts c.Cg.uops c.Cg.ps c.Cg.cons c.Cg.assm c.Cg.qs- >> (fun _ -> Co.bprintflush mydebug "\nBEGIN: refine_sort\n")- |> ((!Constants.refine_sort) <?> Misc.flip (List.fold_left refine_sort) c.Cg.cs)- >> (fun _ -> Co.bprintflush mydebug "\nEND: refine_sort\n")- |> Misc.maybe_apply (apply_facts c.Cg.cs) facts---+let create c = function+ | 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+ >> (fun _ -> Co.bprintflush mydebug "\nBEGIN: refine_sort\n")+ |> ((!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" (* API *)-let empty = create Cg.empty None+let empty () = create Cg.empty None (* API *)-let meet me you = {me with m = SM.extendWith (fun _ -> (++)) 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 *****************)@@ -755,7 +1011,11 @@ >> Printf.printf "minBinds: [%a] \n\n" pprint_ds *) -let simplify s = {s with m = SM.map (min_binds s) s.m} +let simplify s = { s with m = SM.map begin function + | Bot -> Bot + | NonBot qs -> NonBot (min_binds s qs)+ end s.m + } (************************************************************************) (****************** Counterexample Generation ***************************)@@ -772,31 +1032,38 @@ (*******************************************************************************) let print_m ppf s = - SM.iter begin fun k ds ->- ds |> (<?>) (!Co.minquals) (min_binds s)- |> F.fprintf ppf "solution: %a := [%a] \n\n" Sy.print k pprint_ds + SM.iter begin fun k -> function+ | Bot -> F.fprintf ppf "solution: %a := [%a] \n\n" Sy.print k pprint_bind Bot+ | 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 = - SM.range s.qm- >> (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) - *) |> ignore+ 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) *) + |> ignore (* API *) let print ppf s = s >> print_m ppf >> print_qs ppf |> ignore -let botInt qs = if List.exists (Q.pred_of_t <+> P.is_contra) qs then 1 else 0+let botInt = function+ | Bot -> 1+ | NonBot qs -> if List.exists (Q.pred_of_t <+> P.is_contra) qs then 1 else 0 +let bindSize = function+ | Bot -> 0+ | NonBot x -> List.length x+ (* API *) let print_stats ppf me = let (sum, max, min, bot) = - (SM.fold (fun _ qs x -> (+) x (List.length qs)) me.m 0,- SM.fold (fun _ qs x -> max x (List.length qs)) me.m min_int,- SM.fold (fun _ qs x -> min x (List.length qs)) me.m max_int,- SM.fold (fun _ qs x -> x + botInt qs) me.m 0) in+ (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" @@ -822,13 +1089,13 @@ |> String.concat "," (* API *)-let mkbind = id (* Misc.flatten <+> Misc.sort_and_compact *)+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 <+> List.map Q.pred_of_t)+ |> List.map (snd <+> preds_of_bind) |> Misc.groupby key_of_quals |> List.map begin function | [] -> assertf "impossible"
external/fixpoint/proverArch.ml view
@@ -46,10 +46,16 @@ type sort type fun_decl + (* Sorts *)+ val mkIntSort : context -> sort+ val mkRealSort : context -> sort+ val mkBoolSort : context -> sort+ (* Expression *) val mkAll : context -> sort array -> symbol array -> ast -> ast val mkApp : context -> fun_decl -> ast list -> ast val mkMul : context -> ast -> ast -> ast+ val mkDiv : context -> ast -> ast -> ast val mkAdd : context -> ast -> ast -> ast val mkSub : context -> ast -> ast -> ast val mkMod : context -> ast -> ast -> ast@@ -57,6 +63,7 @@ (* Predicates *) val mkIte : context -> ast -> ast -> ast -> ast val mkInt : context -> int -> sort -> ast+ val mkReal : context -> float -> sort -> ast val mkTrue : context -> ast val mkFalse : context -> ast val mkNot : context -> ast -> ast@@ -81,14 +88,15 @@ (* Constructors *) val mkContext : (string * string) array -> context- val mkIntSort : context -> sort- val mkBoolSort : context -> sort- val var : context -> symbol -> sort -> ast- val boundVar : context -> int -> sort -> ast+ val stringSymbol : context -> string -> symbol- val funcDecl : context -> symbol -> sort array -> sort -> fun_decl val isBool : context -> ast -> bool+ val boundVar : context -> int -> sort -> ast + (* Declarations *)+ val var : context -> symbol -> sort -> ast+ val funcDecl : context -> symbol -> sort array -> sort -> fun_decl+ (* Queries *) val bracket : context -> (unit -> 'a) -> 'a val assertAxiom : context -> ast -> unit@@ -103,7 +111,7 @@ class type prover = object (* AST/TC Interface *)- method interp_syms : (Ast.Symbol.t * Ast.Sort.t) list+ method interp_syms : unit -> (Ast.Symbol.t * Ast.Sort.t) list (* Query Interface *) method set_filter : 'a . Ast.Sort.t Ast.Symbol.SMap.t
external/fixpoint/smtLIB2.ml view
@@ -118,8 +118,9 @@ *) (* z3 specific *)-let z3_preamble - = [ spr "(define-sort %s () Int)"+let z3_preamble _ + = if not !Co.set_theory then [] else+ [ spr "(define-sort %s () Int)" elt ; spr "(define-sort %s () (Array %s Bool))" set elt@@ -140,7 +141,7 @@ ; spr "(define-fun %s ((s1 %s) (s2 %s)) Bool (= %s (%s s1 s2)))" sub set set emp dif ] - + let smtlib_preamble = [ spr "(set-logic QF_UFLIA)" ; spr "(define-sort %s () Int)" elt@@ -196,12 +197,10 @@ | Cvc4 -> "cvc4 --incremental -L smtlib2" let smt_preamble = function- | Z3 -> z3_preamble+ | Z3 -> z3_preamble () | _ -> smtlib_preamble -let smt_file = fun () -> !Co.out_file ^ ".smt2"- let smt_write_raw me s = output_now me.clog s; output_now me.cout s@@ -294,7 +293,7 @@ let mkContext _ = let s = solver () in let ci, co = Unix.open_process <| smt_cmd s in- let cl = smt_file () |> open_out in+ let cl = open_out <| Co.get_smt2_file () in let pre = smt_preamble s in let ctx = { cin = ci; cout = co; clog = cl } in let _ = List.iter (smt_write ctx) pre in@@ -318,9 +317,11 @@ s let mkIntSort _ = "Int" +let mkRealSort _ = "Real" let mkBoolSort _ = "Bool" let mkInt _ i _ = string_of_int i+let mkReal _ i _ = string_of_float i let mkTrue _ = "true" let mkFalse _ = "false" @@ -328,12 +329,14 @@ let mkRel _ r a1 a2 = match r with - | A.Eq -> spr "(= %s %s)" a1 a2 - | A.Ne -> 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 + | 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 @@ -352,6 +355,7 @@ = spr "(%s %s %s)" (opStr op) a1 a2 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
external/fixpoint/smtZ3.mem.ml view
@@ -73,21 +73,25 @@ let mkRel c r a1 a2 = match r with- | A.Eq -> Z3.mk_eq c a1 a2 - | A.Ne -> Z3.mk_distinct c [| a1; a2 |]- | A.Gt -> Z3.mk_gt c a1 a2 - | A.Ge -> Z3.mk_ge c a1 a2- | A.Lt -> Z3.mk_lt c a1 a2- | A.Le -> Z3.mk_le c a1 a2+ | A.Eq + | A.Ueq -> Z3.mk_eq c a1 a2 + | A.Ne + | A.Une -> Z3.mk_distinct c [| a1; a2 |]+ | A.Gt -> Z3.mk_gt c a1 a2 + | A.Ge -> Z3.mk_ge c a1 a2+ | A.Lt -> Z3.mk_lt c a1 a2+ | A.Le -> Z3.mk_le c a1 a2 let mkApp c f az = Z3.mk_app c f (Array.of_list az) let mkMul c a1 a2 = Z3.mk_mul c [| a1; a2|]+let mkDiv c a1 a2 = Z3.mk_div c a1 a2 let mkAdd c a1 a2 = Z3.mk_add c [| a1; a2|] let mkSub c a1 a2 = Z3.mk_sub c [| a1; a2|] let mkMod = Z3.mk_mod let mkIte = Z3.mk_ite let mkInt = Z3.mk_int +let mkReal c f = Z3.mk_numeral c (string_of_float f) let mkTrue = Z3.mk_true let mkFalse = Z3.mk_false let mkNot = Z3.mk_not@@ -97,6 +101,7 @@ let mkIff = Z3.mk_iff let astString = Z3.ast_to_string let mkIntSort = Z3.mk_int_sort +let mkRealSort = Z3.mk_real_sort let mkBoolSort = Z3.mk_bool_sort let mkSetSort = Z3.mk_set_sort let mkEmptySet = Z3.mk_empty_set
external/fixpoint/smtZ3.ml view
@@ -20,150 +20,65 @@ * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. *) -(* This file is part of the LiquidC Project *)--module H = Hashtbl-module F = Format-module Co = Constants-module BS = BNstats-module A = Ast-module Sy = A.Symbol-module So = A.Sort-module SM = Sy.SMap-module P = A.Predicate-module E = A.Expression-module Misc = FixMisc open Misc.Ops-module SSM = Misc.StringMap-module Th = Theories--module SMTZ3 : ProverArch.SMTSOLVER = struct--let mydebug = false - (********************************************************************************)-(************ SMT INTERFACE *****************************************************) +(** DUMMY SMT-Z3 Solver (for non Z3MEM builds) **********************************) (********************************************************************************) -let nb_unsat = ref 0-let nb_pop = ref 0-let nb_push = ref 0--type context = Z3.context-type symbol = Z3.symbol-type sort = Z3.sort-type ast = Z3.ast-type fun_decl = Z3.func_decl --let var = Z3.mk_const -let boundVar = Z3.mk_bound-let stringSymbol = Z3.mk_string_symbol -let funcDecl = Z3.mk_func_decl--let isBool c a =- a |> Z3.get_sort c - |> Z3.sort_to_string c- |> (=) "bool"--let isInt me a =- a |> Z3.get_sort me - |> Z3.sort_to_string me- |> (=) "int"--let mkAll me = Z3.mk_forall me 0 [||]--let mkRel c r a1 a2 - = match r with- | A.Eq -> Z3.mk_eq c a1 a2 - | A.Ne -> Z3.mk_distinct c [| a1; a2 |]- | A.Gt -> Z3.mk_gt c a1 a2 - | A.Ge -> Z3.mk_ge c a1 a2- | A.Lt -> Z3.mk_lt c a1 a2- | A.Le -> Z3.mk_le c a1 a2--let mkApp c f az = Z3.mk_app c f (Array.of_list az)-let mkMul c a1 a2 = Z3.mk_mul c [| a1; a2|]-let mkAdd c a1 a2 = Z3.mk_add c [| a1; a2|]-let mkSub c a1 a2 = Z3.mk_sub c [| a1; a2|]-let mkMod = Z3.mk_mod -let mkIte = Z3.mk_ite--let mkInt = Z3.mk_int -let mkTrue = Z3.mk_true-let mkFalse = Z3.mk_false-let mkNot = Z3.mk_not-let mkAnd c az = Z3.mk_and c (Array.of_list az) -let mkOr c az = Z3.mk_or c (Array.of_list az) -let mkImp = Z3.mk_implies-let mkIff = Z3.mk_iff-let astString = Z3.ast_to_string -let mkIntSort = Z3.mk_int_sort -let mkBoolSort = Z3.mk_bool_sort -let mkSetSort = Z3.mk_set_sort -let mkEmptySet = Z3.mk_empty_set -let mkSetAdd = Z3.mk_set_add-let mkSetMem = Z3.mk_set_member -let mkSetCup = fun me s1 s2 -> Z3.mk_set_union me [| s1; s2 |]-let mkSetCap = fun me s1 s2 -> Z3.mk_set_intersect me [| s1; s2 |]-let mkSetDif = Z3.mk_set_difference-let mkSetSub = Z3.mk_set_subset -let mkContext = Z3.mk_context_x --(*********************************************************)--let z3push me =- let _ = nb_push += 1 in- let _ = BS.time "Z3.push" Z3.push me in- () --let z3pop me =- let _ = incr nb_pop in- BS.time "Z3.pop" (Z3.pop me) 1 ---(* Z3 API *)-let unsat = - let us_ref = ref 0 in- fun me ->- let _ = if mydebug then (Printf.printf "[%d] UNSAT 1 " (us_ref += 1); flush stdout) in- let rv = (BS.time "Z3.check" Z3.check me) = Z3.L_FALSE in- let _ = if mydebug then (Printf.printf "UNSAT 2 \n"; flush stdout) in- let _ = if rv then ignore (nb_unsat += 1) in - rv--(* API *)-let assertAxiom me p =- Co.bprintf mydebug "@[Pushing axiom %s@]@." (astString me p); - BS.time "Z3 assert axiom" (Z3.assert_cnstr me) p;- asserts (not (unsat me)) "ERROR: Axiom makes background theory inconsistent!"--(* API *)-let assertDistinct me xs =- xs |> Array.of_list |> Z3.mk_distinct me |> assertAxiom me--(* Z3 API *)-let bracket me f = Misc.bracket (fun _ -> z3push me) (fun _ -> z3pop me) f--(* Z3 API *)-let assertPreds me ps = List.iter (fun p -> BS.time "Z3.ass_cst" (Z3.assert_cnstr me) p) ps+let assertf = FixMisc.Ops.assertf+let msg = "This build is NOT linked against Z3. Please rebuild with Z3MEM=true. Only possible on linux" -(* Z3 API *)-let valid me p = - bracket me begin fun _ ->- assertPreds me [Z3.mk_not me p];- BS.time "unsat" unsat me - end+module SMTZ3 : ProverArch.SMTSOLVER = struct -(* Z3 API *)-let contra me p = - bracket me begin fun _ ->- assertPreds me [p];- BS.time "unsat" unsat me - end+type context = ()+type symbol = () +type sort = () +type ast = () +type fun_decl = () -(* API *)-let print_stats ppf () =- F.fprintf ppf- "SMT stats: pushes=%d, pops=%d, unsats=%d \n" - !nb_push !nb_pop !nb_unsat +let var _ = failwith msg +let boundVar _ = failwith msg+let stringSymbol _ = failwith msg+let funcDecl _ = failwith msg+let isBool _ = failwith msg+let isInt _ = failwith msg+let mkAll _ = failwith msg+let mkRel _ = 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 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 mkIff _ = failwith msg+let astString _ = failwith msg+let mkIntSort _ = failwith msg+let mkRealSort _ = failwith msg+let mkBoolSort _ = failwith msg+let mkSetSort _ = failwith msg+let mkEmptySet _ = failwith msg+let mkSetAdd _ = failwith msg+let mkSetMem _ = failwith msg+let mkSetCup _ = failwith msg+let mkSetCap _ = failwith msg+let mkSetDif _ = failwith msg+let mkSetSub _ = failwith msg+let mkContext _ = 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 contra _ = failwith msg+let print_stats _ = failwith msg end
external/fixpoint/smtZ3.nomem.ml view
@@ -45,11 +45,13 @@ let mkRel _ = 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 mkReal _ = failwith msg let mkTrue _ = failwith msg let mkFalse _ = failwith msg let mkNot _ = failwith msg@@ -59,6 +61,7 @@ let mkIff _ = failwith msg let astString _ = failwith msg let mkIntSort _ = failwith msg+let mkRealSort _ = failwith msg let mkBoolSort _ = failwith msg let mkSetSort _ = failwith msg let mkEmptySet _ = failwith msg
external/fixpoint/solve.ml view
@@ -37,7 +37,6 @@ module Ci = Cindex module PP = Prepass module Cg = FixConfig-(* module TP = TpNull.Prover *) module Misc = FixMisc open Misc.Ops @@ -139,7 +138,8 @@ try BS.time "refine" (Dom.refine s) c with ex -> let _ = F.printf "constraint refinement fails with: %s\n" (Printexc.to_string ex) in let _ = F.printf "Failed on constraint:\n%a\n" (C.print_t None) c in- assert false+ raise ex+ (* assert false *) let update_worklist me s' c w' = c |> Ci.deps me.sri @@ -224,7 +224,7 @@ let global_symbols cfg = (SM.to_list cfg.Cg.uops) (* specified globals *) - ++ (Theories.interp_syms) (* theory globals *)+ ++ (Theories.interp_syms ()) (* theory globals *) (* API *) let create cfg kf =@@ -241,7 +241,7 @@ |> BS.time "Constant EnvWF" (List.map (C.add_consts_wf gts)) |> PP.validate_wfs in let cfg = { cfg with Cg.cs = Ci.to_list sri; Cg.ws = ws } in- let s = if !Constants.dump_simp <> "" then Dom.empty else BS.time "Dom.create" (Dom.create cfg) kf in+ let s = if !Constants.dump_simp <> "" then Dom.empty () else BS.time "Dom.create" (Dom.create cfg) kf in let _ = Co.bprintflush mydebug "\nDONE: Dom.create\n" in let _ = Co.bprintflush mydebug "\nBEGIN: PP.validate\n" in let _ = Ci.to_list sri
external/fixpoint/solverArch.ml view
@@ -26,7 +26,7 @@ module type DOMAIN = sig type t type bind- val empty : t + val empty : unit -> t (* val meet : t -> t -> t *) val min_read : t -> FixConstraint.soln val read : t -> FixConstraint.soln
external/fixpoint/theories.ml view
@@ -22,7 +22,6 @@ module So = Ast.Sort module Sy = Ast.Symbol-(* module SMT = SmtZ3.SMTZ3 *) open ProverArch open FixMisc.Ops@@ -56,7 +55,10 @@ let sub = ( Sy.of_string "Set_sub" , So.t_func 1 [t_set (So.t_generic 0); t_set (So.t_generic 0); So.t_bool] ) -let interp_syms = [emp; sng; mem; cup; cap; dif; sub]+let interp_syms _ + = if !Constants.set_theory + then [emp; sng; mem; cup; cap; dif; sub]+ else [] module MakeTheory(SMT : SMTSOLVER): (THEORY with type context = SMT.context
external/fixpoint/theories.mli view
@@ -21,7 +21,7 @@ *) val is_interp : Ast.Sort.tycon -> bool-val interp_syms : (Ast.Symbol.t * Ast.Sort.t) list+val interp_syms : unit -> (Ast.Symbol.t * Ast.Sort.t) list module MakeTheory(SMT : ProverArch.SMTSOLVER): (ProverArch.THEORY with type context = SMT.context and type sort = SMT.sort and type ast = SMT.ast)
external/fixpoint/toImp.ml view
@@ -328,12 +328,13 @@ let set_instr decls (subs, kvar) = Rset (List.map (fun v -> TVar v) (get_kdecl kvar decls), kvar) -let emptySol = PredAbs.read PredAbs.empty+let emptySol () = PredAbs.read (PredAbs.empty ()) let reft_to_get_instrs decls reft =- let vv = C.vv_of_reft reft in+ let vv = C.vv_of_reft reft in let kvars = C.kvars_of_reft reft in- let preds = C.preds_of_reft emptySol reft in+ let sol0 = emptySol () in+ let preds = C.preds_of_reft sol0 reft in match (kvars, preds) with | ([], preds) -> Havc (PVar vv) :: Assm preds :: [] | (kvars, []) -> Misc.flap (get_instrs vv decls) kvars@@ -342,8 +343,9 @@ (* [[{t | p}]]_set *) let reft_to_set_instrs decls reft =+ let sol0 = emptySol () in let kvars = C.kvars_of_reft reft in- let preds = C.preds_of_reft emptySol reft in+ let preds = C.preds_of_reft sol0 reft in match (kvars, preds) with | ([], preds) -> Asst preds :: [] | (kvars, []) -> List.map (set_instr decls) kvars
external/fixpoint/toSmtLib.ml view
@@ -480,11 +480,12 @@ let dump_smtlib_indexed (no, cfg) = let su = Misc.maybe_apply (fun x _ -> "." ^ (string_of_int x)) no "" in- let fn = !Constants.out_file ^ su ^ ".smt2" in + let fo = Constants.get_out_file () in+ let fn = fo ^ su ^ ".smt2" in let _ = Co.bprintflush mydebug ("BEGIN: Dump SMTLIB \n") in let me = tx_defs cfg in let _ = Misc.with_out_formatter fn (fun ppf -> F.fprintf ppf "%a" print me) in- let _ = Co.bprintflush mydebug ("DONE: Dump SMTLIB to " ^ !Constants.out_file ^"\n") in+ let _ = Co.bprintflush mydebug ("DONE: Dump SMTLIB to " ^ fo ^"\n") in () let dump_smtlib_mono cfg =
external/fixpoint/tpGen.ml view
@@ -56,6 +56,7 @@ type t = { c : SMT.context; tint : SMT.sort;+ treal : SMT.sort; tbool : SMT.sort; vart : (decl, var_ast) H.t; funt : (decl, SMT.fun_decl) H.t;@@ -131,9 +132,10 @@ 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- match z3TypeThy me t with - | Some t' -> t'- | None -> me.tint+ if So.is_real t then me.treal else+ match z3TypeThy me t with + | Some t' -> t'+ | None -> me.tint end t t and z3TypeThy me t = match So.app_of_t t with@@ -225,6 +227,12 @@ |> E.to_string |> assertf "z3AppThy: sort error %s" +and z3Div me env = function+ | (e1, e2) when !Co.uif_divide -> + z3App me env div_n (List.map (z3Exp me env) [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) | (e, (A.Con (A.Constant.Int i), _)) ->@@ -237,6 +245,8 @@ and z3Exp me env = function | A.Con (A.Constant.Int i), _ -> SMT.mkInt me.c i me.tint + | A.Con (A.Constant.Real i), _ -> + SMT.mkReal me.c i me.treal | A.Var s, _ -> z3Var me env s | A.Cst ((A.App (f, es), _), t), _ when (H.mem me.thy_symm f) -> @@ -253,8 +263,8 @@ SMT.mkInt me.c (n1 * n2) me.tint | A.Bin (e1, A.Times, e2), _ -> z3Mul me env (e1, e2)- | A.Bin (e1, A.Div, e2), _ -> - z3App me env div_n (List.map (z3Exp me env) [e1;e2])+ | A.Bin (e1, A.Div, e2), _ ->+ z3Div me env (e1, e2) | A.Bin (e, A.Mod, (A.Con (A.Constant.Int i), _)), _ -> SMT.mkMod me.c (z3Exp me env e) (SMT.mkInt me.c i me.tint) | A.Bin (e1, A.Mod, e2), _ ->@@ -289,7 +299,10 @@ | A.Bexp e, _ -> let a = z3Exp me env e in let s2 = E.to_string e in- let Some so = A.sortcheck_expr Theories.is_interp (Misc.flip SM.maybe_find env) e in+ let so = match A.sortcheck_expr Theories.is_interp (Misc.flip SM.maybe_find env) e with + | Some so -> so+ | _ -> F.printf "No type for %s" (E.to_string e);+ 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) @@ -312,7 +325,7 @@ let z3Pred me env p = try - let p = BS.time "fixdiv" A.fixdiv p in+ 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 @@ -415,7 +428,7 @@ (* API *) let unsat_core me env bgp ips = let _ = H.clear me.vart in - let p2z = A.fixdiv <+> z3Pred me env in+ let p2z = (*A.fixdiv <+>*) z3Pred me env 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)@@ -460,11 +473,12 @@ (* API *) let create ts env ps consts =- let _ = asserts (ts = []) "ERROR: TPZ3-create non-empty sorts!" in+ 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;
external/fixpoint/tpNull.ml view
@@ -28,11 +28,12 @@ let mydebug = false let create ts env ps cs - = match !Constants.smt_solver with+ = let xxx = Constants.get_smt2_file () in+ match !Constants.smt_solver with | None -> Constants.bprintflush mydebug "\nUSING z3 bindings \n"; Mem.mkProver ts env ps cs | Some s -> - Constants.bprintflush mydebug ("\nUSING SMTLIB bindings with " ^ s ^ "\n"); + Constants.bprintflush mydebug ("\nUSING SMTLIB bindings -- " ^ xxx ^ " -- with " ^ s ^ "\n"); Smt.mkProver ts env ps cs
external/misc/constants.ml view
@@ -33,8 +33,11 @@ let csolve_file_prefix = ref "csolve" (* where to find/place csolve-related files *) let safe = ref false (* -safe *) let manual = ref false (* -manual *)-let out_file = ref "out" (* -save *)-let save_file = ref "out.fq" (* -save *)+let out_file_name = ref "out" (* -out *)+(*+let save_file = ref "out.fq" (* -save *)+*)+let save_slice = ref false (* -save-slice *) let dump_ref_constraints= ref false (* -drconstr *) let ctypes_only = ref false (* -ctypes *) let verbose_level = ref 0 (* -v *)@@ -77,6 +80,8 @@ let gen_qual_sorts = ref true (* -no-gen-qual-sorts *) let web_demo = ref false (* -web-demo *) let simple = ref true (* -simple *) +let set_theory = ref true (* -set-theory *) +let ueq_all_sorts = ref false (* -ueq-all-sorts *) (* JHALA: what do these do ? *) let psimple = ref true (* -psimple *)@@ -87,6 +92,7 @@ let trace_scalar = ref false (* -trace-scalar *) let prune_index = ref false (* -prune-index *) let uif_multiply = ref true (* -no-uif-multiply *) +let uif_divide = ref true (* -no-uif-multiply *) (****************************************************************) (************* Output levels ************************************)@@ -151,6 +157,10 @@ let blogPrintf b = if b then logPrintf else nprintf let cLogPrintf l = if ck_olev l then logPrintf else nprintf +let get_out_file = fun () -> !out_file_name +let get_save_file = fun () -> (!out_file_name ^ ".fq")+let get_smt2_file = fun () -> (!out_file_name ^ ".smt2")+ (*****************************************************************) (*********** Command Line Options ********************************) (*****************************************************************)@@ -159,11 +169,15 @@ let arg_spec = [("-out", - Arg.String (fun s -> out_file := s), + Arg.String (fun s -> out_file_name := s), " Save solution to file [out]"); ++ (* ("-save", Arg.String (fun s -> save_file := s), " Save constraints to file [out.fq]"); + *)+ ("-inccheck", Arg.String (fun s -> true_unconstrained := false; inccheck := SS.add s !inccheck), @@ -193,6 +207,10 @@ ("-ctypes", Arg.Set ctypes_only, " Infer ctypes only [false]");+ ("-saveslice", + Arg.Set save_slice, + " save slices to file [false]");+ ("-safe", Arg.Set safe, " run in failsafe mode [false]");@@ -226,6 +244,9 @@ ( "-nosimple" , Arg.Clear simple , " Directly propagate qualifiers for simple constraints (K1 <: K2) [true]");+ ( "-nosettheory"+ , Arg.Clear set_theory+ , " Support for set theory on Z3 [true]"); ("-psimple", Arg.Set psimple, " prioritize simple constraints [true]");@@ -350,6 +371,10 @@ Arg.Clear uif_multiply, " Don't encode non-linear multiplication with UIFs [true]" );+ ("-no-uif-divide",+ Arg.Clear uif_divide,+ " Don't encode non-linear division with UIFs [true]"+ ); ("-simp", Arg.String ((:=) dump_simp), " print simplified constraints to save-file (experimental) use [andrey] or [jhala] or [id]"@@ -376,6 +401,9 @@ ("-web-demo", Arg.Set(web_demo), " set HTML output to web demo mode");+ ("-ueq-all-sorts",+ Arg.Set(ueq_all_sorts),+ " make ~~ (UEq) accept all inputs [false]"); ]
external/misc/fcommon.ml view
@@ -30,9 +30,9 @@ (************* SCC Ranking **************************************) (****************************************************************) -module Int : Graph.Sig.COMPARABLE with type t = int * string =+module Int : Graph.Sig.COMPARABLE with type t = int = struct- type t = int * string + type t = int let compare = compare let hash = Hashtbl.hash let equal = (=)@@ -57,8 +57,8 @@ let iter_edges_e = G.iter_edges_e let graph_attributes g = [`Size (11.0, 8.5); `Ratio (`Float 1.29)] let default_vertex_attributes g = [`Shape `Box]- let vertex_name (i,_) = string_of_int i (* Printf.sprintf "V_%d" i *) - let vertex_attributes (_,s) = [`Label s]+ let vertex_name i = string_of_int i (* Printf.sprintf "V_%d" i *) + let vertex_attributes _ = [] (* [`Label s] *) let default_edge_attributes g = [] let edge_attributes e = [] let get_subgraph v = None@@ -71,33 +71,53 @@ Dot.output_graph oc g; close_out oc + (* let int_s_to_string ppf (i,s) = F.fprintf ppf "(%d,%s)" i s +*) -let scc_print g a = - C.bprintf mydebug "dep graph: vertices= %d, sccs= %d \n" (G.nb_vertex g) (Array.length a);+let int_s_to_string ppf i = + F.fprintf ppf "(%d)" i +++let scc_print s g a = + C.bprintf mydebug "dep graph (%s): vertices= %d, sccs= %d \n" s (G.nb_vertex g) (Array.length a); C.bprintf mydebug "scc sizes: \n"; Array.iteri begin fun i xs -> C.bprintf mydebug "%d : [%a] \n" i (FixMisc.pprint_many false "," int_s_to_string) xs end a; C.bprintf mydebug "\n" + let make_graph s f is ijs = let g = G.create () in+ let _ = List.iter (G.add_vertex g) is in+ let _ = List.iter (fun (i,j) -> G.add_edge g i j) ijs in+ let _ = if !Constants.dump_graph then dump_graph s g in+ g+++ (* +let make_graph s f is ijs = + let g = G.create () in let _ = List.iter (fun i -> G.add_vertex g (i, (f i))) is in let _ = List.iter (fun (i,j) -> G.add_edge g (i,(f i)) (j,(f j))) ijs in let _ = if !Constants.dump_graph then dump_graph s g in g- ++ *)++let my_scc_array _ g = SCC.scc_array g+ (* Given list [(u,v)] returns a numbering [(ui,ri)] s.t. * 1. if ui,uj in same SCC then ri = rj * 2. if ui -> uj then ui >= uj *) let scc_rank s f is ijs = let g = BNstats.time "making_graph" (make_graph s f is) ijs in- let a = SCC.scc_array g in- let _ = scc_print g a in+ let a = BNstats.time "scc_array" (my_scc_array ()) g in+ let _ = scc_print s g a in let sccs = FixMisc.array_to_index_list a in- FixMisc.flap (fun (i,vs) -> List.map (fun (j,_) -> (j,i)) vs) sccs+ FixMisc.flap (fun (i,vs) -> List.map (fun j -> (j,i)) vs) sccs (* let g1 = [(1,2);(2,3);(3,1);(2,4);(3,4);(4,5)];;
external/misc/fixMisc.ml view
@@ -124,6 +124,14 @@ open Ops ++let debugTicker msg = + let x = ref 0 in+ fun () -> print_now ("\nDEBUG TICKER " ^ msg ^ " : " ^ (string_of_int (x += 1)))++++ let maybe_fold f b xs = let fo = fun bo x -> match bo with Some b -> f b x | _ -> None in List.fold_left fo (Some b) xs@@ -131,6 +139,8 @@ let maybe_map f = function Some x -> Some (f x) | None -> None let maybe_iter f = function Some x -> f x | None -> ()++let safe_maybe msg = function Some x -> x | _ -> assertf msg let maybe = function Some x -> x | _ -> assertf "maybe called with None"
− external/misc/misc.ml
@@ -1,1346 +0,0 @@-(*- * Copyright ? 1990-2007 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 - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.- *- *)--(* $Id: misc.ml,v 1.14 2006/09/26 01:47:01 jhala Exp $- *- * This file is part of the SIMPLE Project.- *)--(**- * This module provides some miscellaneous useful helper functions.- *)--module Ops = struct-- type ('a, 'b) either = Left of 'a | Right of 'b-- let (>|) _ x = x-- let (|>) x f = f x-- let (<|) f x = f x-- let (>>) x f = f x; x-- let (|>>) xo f = match xo with None -> None | Some x -> f x-- let (|>:) xs f = List.map f xs-- let (=+) x n = let v = !x in (x := v + n; v)-- let (+=) x n = x := !x + n; !x-- let (++) = List.rev_append-- let (+++)= fun (x1s, y1s) (x2s, y2s) -> (x1s ++ x2s, y1s ++ y2s)-- let id = fun x -> x-- let un = fun x -> ()-- let const x = fun _ -> x-- let (<.>) f g = fun x -> x |> g |> f-- let (<+>) f g = fun x -> x |> f |> g -- let (<?>) b f = fun x -> if b then f x else x-- let wwhen b f = fun x -> if b then f x -- let (<*>) f g = fun x -> (f x, g x)- - let (<**>) f g = fun (x, y) -> (f x, g y)-- let (<&&>) f g = fun x -> f x && g x-- let failure fmt = Printf.ksprintf failwith fmt-- let foreach xs f = List.map f xs-- let asserts p fmt =- Printf.ksprintf (fun x -> if not p then failwith x) fmt--let asserti = asserts- (*-let asserti p fmt = - Printf.ksprintf (fun x -> if not p then (print_string (x^"\n"); ignore(0/0)) else ()) fmt-*)--let assertf fmt =- Printf.ksprintf failwith fmt--let halt _ =- assert false--let fst3 (x,_,_) = x-let snd3 (_,x,_) = x-let thd3 (_,_,x) = x--let fst4 (x, _, _, _) = x-let snd4 (_, x, _, _) = x-let thd4 (_, _, x, _) = x-let fth4 (_, _, _, x) = x--let withfst3 (_,y,z) x = (x,y,z)-let withsnd3 (x,_,z) y = (x,y,z)-let withthd3 (x,y,_) z = (x,y,z)--let print_now s = - print_string s;- flush stdout--let print_now_error msg =- prerr_string msg;- flush stderr--let output_now c s = - output_string c s; - flush c--let some = fun x -> Some x--end--open Ops--let maybe_fold f b xs = - let fo = fun bo x -> match bo with Some b -> f b x | _ -> None in- List.fold_left fo (Some b) xs--let maybe_map f = function Some x -> Some (f x) | None -> None--let maybe_iter f = function Some x -> f x | None -> ()--let maybe = function Some x -> x | _ -> assertf "maybe called with None"--let maybe_apply f xo v = match xo with Some x -> f x v | None -> v--let maybe_default xo y = match xo with Some x -> x | None -> y--let maybe_string f = function Some x -> "Some " ^ (f x) | None -> "None"--let rec maybe_chain x d = function - | f::fs -> (match f x with - | Some y -> y - | None -> maybe_chain x d fs)- | [] -> d------let trace s f x =- let _ = print_now <| Printf.sprintf "BEGIN: %s \n" s in- let r = f x in- let _ = print_now <| Printf.sprintf "END: %s \n" s in- r--(* ORIG-let rec pprint_many_box s f ppf = function- | [] -> ()- | x::[] -> Format.fprintf ppf "%a" f x- | x::xs' -> (Format.fprintf ppf "%a%s@\n" f x s; pprint_many_box s f ppf xs')-*)-let rec pprint_many_prefix sep base f ppf = function- | x::xs -> Format.fprintf ppf "(%s %a %a)" - sep f x (pprint_many_prefix sep base f) xs- | [] -> Format.fprintf ppf "%a" f base---let rec pprint_many_box brk s f ppf = function- | [] -> ()- | [x] -> Format.fprintf ppf "%a" f x- | x::xs' when brk -> Format.fprintf ppf "%a@\n%s" f x s; - pprint_many_box brk s f ppf xs'- | x::xs' -> Format.fprintf ppf "%a@,%s" f x s;- pprint_many_box brk s f ppf xs'--let pprint_many_box brk l s r f ppf = function- | [] -> Format.fprintf ppf "[]"- | xs -> Format.fprintf ppf "@[%s%a%s@]" l (pprint_many_box brk s f) xs r--let pprint_many_brackets brk f ppf x = - Format.fprintf ppf "%a" (pprint_many_box brk "[ " "; " "]" f) x--let rec pprint_many brk s f ppf = function- | [] -> ()- | [x] -> Format.fprintf ppf "%a" f x- | x::xs' when brk -> Format.fprintf ppf "%a%s@," f x s; pprint_many brk s f ppf xs'- | x::xs' -> Format.fprintf ppf "%a%s" f x s ; pprint_many brk s f ppf xs'--let pprint_maybe f ppf = function- | Some x -> Format.fprintf ppf "Some %a" f x- | None -> Format.fprintf ppf "None"--let pprint_int ppf i =- Format.fprintf ppf "%d" i--let pprint_int_o = pprint_maybe pprint_int-(*-let pprint_int_o ppf = function- | None -> Format.fprintf ppf "None" - | Some d -> Format.fprintf ppf "Some(%d)" d-*)--let pprint_str ppf s =- Format.fprintf ppf "%s" s--let pprint_ints ppf is = - pprint_many_brackets false (fun ppf i -> Format.fprintf ppf "%d" i) ppf is--let pprint_pretty_ints ppf is = - is |> List.map string_of_int |> String.concat ";" |> Format.fprintf ppf "[%s]"--let pprint_tuple pp1 pp2 ppf (x1, x2) = - Format.fprintf ppf "(%a, %a)" pp1 x1 pp2 x2--let rec subsets n = function- | _ when n <= 0 - -> [[]]- | xs when n > List.length xs->- []- | x::xs - -> (List.map (fun ys -> x :: ys) (subsets (n-1) xs))- ++ (subsets n xs)- | _ -> assertf "Misc.subsets"--let choose b f g = if b then f else g--let liftfst2 (f: 'a -> 'a -> 'b) (x: 'a * 'c) (y: 'a * 'c): 'b =- f (fst x) (fst y)--let curry = fun f x y -> f (x,y)-let uncurry = fun f (x,y) -> f x y-let flip = fun f x y -> f y x--let maybe_bool = function- | Some _ -> true- | None -> false--module type EMapType = sig- include Map.S- val extendWith : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t- val extend : 'a t -> 'a t -> 'a t- val filter : (key -> 'a -> bool) -> 'a t -> 'a t- val of_list : (key * 'a) list -> 'a t- val to_list : 'a t -> (key * 'a) list- val length : 'a t -> int- val domain : 'a t -> key list- val range : 'a t -> 'a list- val join : 'a t -> 'b t -> ('a * 'b) t- val adds : key -> 'a list -> 'a list t -> 'a list t- val of_alist : (key * 'a) list -> 'a list t- val finds : key -> 'a list t -> 'a list- val safeFind : key -> 'a t -> string -> 'a- val safeAdd : key -> 'a -> 'a t -> string -> 'a t- val single : key -> 'a -> 'a t- val map_partial : ('a -> 'b option) -> 'a t -> 'b t- val maybe_find : key -> 'a t -> 'a option- val find_default : 'a -> key -> 'a t -> 'a- val frequency : key list -> int t-end--module type ESetType = sig- include Set.S- val of_list : elt list -> t-end--module ESet (K: Set.OrderedType) = - struct- include Set.Make(K)- let of_list = List.fold_left (flip add) empty -end--module type EOrderedType = sig- include Map.OrderedType - val print : Format.formatter -> t -> unit-end--(* module EMap (K: Map.OrderedType) = *) -module EMap (K: EOrderedType) = - struct- include Map.Make(K)-- let extendWith (f: key -> 'a -> 'a -> 'a) (m1: 'a t) (m2: 'a t) =- fold begin fun k v m -> - let v' = if mem k m then f k v (find k m) else v in- add k v' m- end m2 m1 - - let extend (m1: 'a t) (m2: 'a t) : 'a t = fold add m2 m1-- (* in 3.12 *)- let filter (f: key -> 'a -> bool) (m: 'a t) : 'a t = - fold (fun x y m -> if f x y then add x y m else m) m empty - - let of_list (kvs : (key * 'a) list) = - List.fold_left (fun m (k, v) -> add k v m) empty kvs-- (* in 3.12 -- bindings *)- let to_list (m : 'a t) : (key * 'a) list = - fold (fun k v acc -> (k,v)::acc) m [] -- (* in 3.12 -- cardinality *)- let length (m : 'a t) : int = - fold (fun _ _ i -> i+1) m 0-- (* in 3.12 -- singleton *)- let single k v = add k v empty-- let domain m =- fold (fun k _ acc -> k :: acc) m []-- let range (m : 'a t) : 'a list = - fold (fun _ v acc -> v :: acc) m []- - let join (m1 : 'a t) (m2 : 'b t) : ('a * 'b) t =- mapi begin fun k v1 ->- let _ = asserts (mem k m2) "EMap.join" in- (v1, find k m2) - end m1-- let maybe_find k m = - try Some (find k m) with Not_found -> None-- let find_default d k m = - maybe_default (maybe_find k m) d -- (* let finds k m = try find k m with Not_found -> [] *)- let finds k m = find_default [] k m-- let adds (k: key) (vs: 'a list) (m : ('a list) t) : 'a list t = - add k (vs ++ find_default [] k m) m-- let of_alist (kvs : (key * 'a) list) =- List.fold_left (fun m (k, v) -> adds k [v] m) empty kvs- - let frequency (ks : key list) : int t =- List.fold_left (fun m k -> - add k (1 + (find_default 0 k m)) m- ) empty ks -- let safeFind k m msg =- try find k m with Not_found -> - let err = Format.fprintf Format.str_formatter - "ERROR: safeFind (%s): %a" msg K.print k; - Format.flush_str_formatter ()- in failwith err-- let safeAdd k v m msg =- if mem k m then - let err = Format.fprintf Format.str_formatter - "ERROR: safeAdd (%s): %a" msg K.print k; - Format.flush_str_formatter ()- in failwith err- else add k v m-- let map_partial f m = - fold (fun x yo m -> match yo with Some y -> add x y m | _ -> m) (map f m) empty - end--module type KeyValType =- sig- type t- val compare : t -> t -> int- val print : Format.formatter -> t -> unit -- type v- val default : v- end--module MapWithDefault (K: KeyValType) =- struct- include EMap(K)- let find (i: K.t) (m: K.v t): K.v =- try find i m with Not_found -> K.default- end--module IntMap = - EMap- (struct- type t = int- let compare i1 i2 = compare i1 i2- let print = pprint_int- end)--module IntSet =- ESet- (struct- type t = int- let compare i1 i2 =- compare i1 i2- end)--module IntIntMap = - EMap - (struct- type t = int * int- let compare i1 i2 = compare i1 i2- let print ppf (i1, i2) = Format.fprintf ppf "(%d, %d)" i1 i2- end)--module StringMap = - EMap - (struct- type t = string - let compare i1 i2 = compare i1 i2- let print ppf s = Format.fprintf ppf "%s" s- end)--module StringSet =- ESet- (struct- type t = string- let compare i1 i2 = compare i1 i2- end)--(* -let sm_join sm1 sm2 = - StringMap.mapi (fun k v1 ->- let v2 = asserts (StringMap.mem k sm2) "sm_join"; StringMap.find k sm2 in- (v1, v2)- ) sm1--let sm_extend sm1 sm2 =- StringMap.fold StringMap.add sm2 sm1 --let sm_filter f sm = - StringMap.fold begin fun x y sm -> - if f x y then StringMap.add x y sm else sm - end sm StringMap.empty --let sm_of_list kvs = - List.fold_left (fun sm (k,v) -> StringMap.add k v sm) StringMap.empty kvs--let sm_to_list sm = - StringMap.fold (fun k v acc -> (k,v)::acc) sm [] --let sm_to_range sm = - sm |> sm_to_list |> List.map snd-*)--let sm_print_keys name sm =- sm |> StringMap.to_list - |> List.map fst - |> String.concat ", "- |> Printf.printf "%s : %s \n" name--let foldn f n b = - let rec foo acc i = - if i >= n then acc else foo (f acc i) (i+1) - in foo b 0 --let rec range i j = - if i >= j then [] else i::(range (i+1) j)--let dump s = - print_string s; flush stdout--let mapn f n = - foldn (fun acc i -> (f i) :: acc) n [] - |> List.rev--let chop_last = function- | [] -> failure "ERROR: Misc.chop_last"- | xs -> xs |> List.rev |> List.tl |> List.rev--let list_snoc xs = - match List.rev xs with - | [] -> assertf "list_snoc with empty list!"- | h::t -> h, List.rev t--let negfilter f xs = - List.fold_left (fun acc x -> if f x then acc else x::acc) [] xs - |> List.rev--let get_option d = function - | Some x -> x - | None -> d--let list_somes xs =- xs |> List.fold_left begin fun acc -> function - | Some x -> x :: acc - | None -> acc - end []- |> List.rev--(* let map_partial f = list_somes <.> List.map f *)--let map_partial f xs =- List.rev - (List.fold_left - (fun acc x -> - match f x with- | None -> acc- | Some z -> (z::acc)) [] xs)---let fold_left_partial f b xs =- List.fold_left begin fun b xo ->- match xo with- | Some x -> f b x- | None -> b- end b xs--let list_reduce msg f = function- | [] -> assertf "ERROR: list_reduce with empty list: %s" msg - | x::xs -> List.fold_left f x xs--let nonnull = function- | [] -> false- | _ -> true--(*-let list_is_empty = function- | [] -> true- | _::_ -> false-*)--let list_max x xs = - List.fold_left max x xs--let list_min x xs = - List.fold_left min x xs--let list_max_with msg f = function- | [] -> assertf "ERROR: list_max_with with empty list: %s" msg - | x::xs -> List.fold_left (fun acc x -> if f x > f acc then x else acc) x xs--let rec take_max n = function- | x :: xs when n > 0 -> x :: take_max (n - 1) xs- | _ -> []- -let rec drop n = function- | x :: xs when n > 0 -> drop (n - 1) xs- | [] when n > 0 -> assertf "ERROR: dropped too many"- | xs -> xs--let getf a i fmt = - try a.(i) with ex -> assertf fmt--let do_catchu f x g =- try f x with ex -> (g ex; raise ex)--let do_catchf s f x =- try f x with ex -> - assertf "%s hits exn: %s \n" s (Printexc.to_string ex)--let do_catch s f x =- try f x with ex -> - (Printf.printf "%s hits exn: %s \n" s (Printexc.to_string ex); raise ex) --let do_catch_ret s f x y = - try f x with ex -> - (Printf.printf "%s hits exn: %s \n" s (Printexc.to_string ex); y) --let do_memo memo f args key = - try Hashtbl.find memo key with Not_found ->- let rv = f args in- let _ = Hashtbl.replace memo key rv in- rv--let do_bimemo fmemo rmemo f args key =- try Hashtbl.find fmemo key with Not_found ->- let rv = f args in- let _ = Hashtbl.replace fmemo key rv in- let _ = Hashtbl.replace rmemo rv key in- rv--let rec exists_maybe f = function- | [] -> None- | x::xs -> (match f x with None -> exists_maybe f xs | z -> z)--let map_pair = fun f (x1, x2) -> (f x1, f x2)-let map_triple = fun f (x1, x2, x3) -> (f x1, f x2, f x3)-let app_fst = fun f (a, b) -> (f a, b)-let app_snd = fun f (a, b) -> (a, f b)-let app_fst3 = fun f (a, b, c) -> (f a, b, c)--let app_snd3 = fun f (a, b, c) -> (a, f b, c)--let app_thd3 = fun f (a, b, c) -> (a, b, f c)-let pad_snd = fun f x -> (x, f x)-let pad_fst = fun f y -> (f y, y)-let tmap2 = fun (f, g) x -> (f x, g x)-let tmap3 = fun (f, g, h) x -> (f x, g x, h x)-let iter_fst = fun f (a, b) -> f a-let iter_snd = fun f (a, b) -> f b--let split3 lst =- List.fold_right (fun (x, y, z) (xs, ys, zs) -> (x :: xs, y :: ys, z :: zs)) lst ([], [], [])--let split4 lst =- List.fold_right (fun (w, x, y, z) (ws, xs, ys, zs) -> (w :: ws, x :: xs, y :: ys, z :: zs)) lst ([], [], [], [])--let twrap s f x =- let _ = Printf.printf "calling %s \n" s in- let rv = f x in- let _ = Printf.printf "returned from %s \n" s in- rv--let mapfold_rev f b xs = - List.fold_left begin fun (acc, ys) x -> - let (acc', y) = f acc x in - (acc', y::ys)- end (b, []) xs--let mapfold f b xs =- mapfold_rev f b xs - |> app_snd List.rev --let rootsBy leq xs = - let notDomBy x = not <.> (leq x) in- let rec loop acc = function- | [] -> - acc- | (x::xs) ->- let acc', xs' = map_pair (List.filter (notDomBy x)) (acc, xs) in- loop (x::acc') xs'- in loop [] xs--let cov_filter cov f xs = - let rec loop acc = function- | [] -> - acc- | (x::xs) when f x ->- let covs, uncovs = List.partition (cov x) xs in- loop ((x, covs) :: acc) uncovs - | (_::xs) ->- loop acc xs- in loop [] xs--let filter f xs = - List.fold_left (fun xs' x -> if f x then x::xs' else xs') [] xs- |> List.rev--let iter f xs = - List.fold_left (fun () x -> f x) () xs--let map2 f xs ys = - let _ = asserti (List.length xs = List.length ys) "Misc.map2" in- List.map2 f xs ys--let map f xs = - List.rev_map f xs |> List.rev--let flatten xss =- xss- |> List.fold_left (fun acc xs -> xs ++ acc) []- |> List.rev--let flatsingles xss =- xss |> List.fold_left (fun acc -> function [x] -> x::acc | _ -> assertf "flatsingles") []- |> List.rev--let splitflatten xsyss = - let xss, yss = List.split xsyss in- (flatten xss, flatten yss)--let splitflatten3 xsyszss =- let xss, yss, zss = split3 xsyszss in- (flatten xss, flatten yss, flatten zss)--let flap f xs =- xs |> List.rev_map f |> flatten |> List.rev--let flap_pair f = splitflatten <.> map f--let tr_rev_flatten xs =- List.fold_left (fun x xs -> x ++ xs) [] xs--let tr_rev_flap f xs =- List.fold_left (fun xs x -> (f x) ++ xs) [] xs--let rec fast_unflat ys = function- | x :: xs -> fast_unflat ([x] :: ys) xs- | [] -> ys--let dup x = (x, x)---let rec rev_perms s = function- | [] -> s- | e :: es -> rev_perms - (tr_rev_flap (fun e -> List.rev_map (fun s -> e :: s) s) e) es --let product = function- | e :: es -> rev_perms (fast_unflat [] e) es- | es -> es --let pairs xs =- let rec pairs_aux ps = function- | [] -> ps- | x :: xs -> pairs_aux (List.fold_left (fun ps y -> (x, y) :: ps) ps xs) xs- in pairs_aux [] xs--let cross_product xs ys = - map begin fun x ->- map begin fun y ->- (x,y)- end ys- end xs- |> flatten--let rec cross_flatten = function- | [] -> - [[]]- | xs::xss ->- map begin fun x ->- map begin fun ys ->- (x::ys)- end (cross_flatten xss)- end xs- |> flatten---let append_pref p s =- (p ^ "." ^ s)---let fsort f xs =- let cmp = fun (k1,_) (k2,_) -> compare k1 k2 in- xs |> map (fun x -> ((f x), x)) - |> List.sort cmp - |> map snd--let sort_and_compact ls =- let rec _sorted_compact l = - match l with- h1::h2::tl ->- let rest = _sorted_compact (h2::tl) in- if h1 = h2 then rest else h1::rest- | tl -> tl- in- _sorted_compact (List.sort compare ls) --let sort_and_compact xs = - List.sort compare xs - |> List.fold_left - (fun ys x -> match ys with- | y::_ when x=y -> ys- | _::_ -> x::ys- | [] -> [x])- [] - |> List.rev--let hashtbl_to_list t = - Hashtbl.fold (fun x y l -> (x,y)::l) t []--let hashtbl_keys t = - Hashtbl.fold (fun x y l -> x::l) t []- |> sort_and_compact--let hashtbl_invert t = - let t' = Hashtbl.create 17 in- hashtbl_to_list t - |> List.iter (fun (x,y) -> Hashtbl.replace t' y x) - |> fun _ -> t'---let distinct xs = - List.length xs = List.length (sort_and_compact xs)--(** repeats f: unit - > unit i times *)-let rec repeat_fn f i = - if i = 0 then ()- else (f (); repeat_fn f (i-1))--(* chop s chopper returns ([x;y;z...]) if s = x.chopper.y.chopper ...*)-let chop s chopper = Str.split (Str.regexp chopper) s --(* like chop only the chop is by chop+ *)-let chop_star chopper s = - Str.split (Str.regexp (Printf.sprintf "[%s+]" chopper)) s--let bounded_chop s chopper i = Str.bounded_split (Str.regexp chopper) s i --let is_prefix p s = - let (ls, lp) = (String.length s, String.length p) in- if ls < lp- then false- else- (String.sub s 0 lp) = p--let is_substring s subs = - let reg = Str.regexp subs in- try ignore(Str.search_forward reg s 0); true- with Not_found -> false--let replace_substring src dst s =- Str.global_replace (Str.regexp src) dst s--let is_suffix suffix s = - let k = String.length suffix- and n = String.length s in- (n-k >= 0) && Str.string_match (Str.regexp suffix) s (n-k)--let iteri f xs =- List.fold_left (fun i x -> f i x; i+1) 0 xs- |> ignore--let numbered_list xs =- xs |> List.fold_left (fun (i, acc) x -> (i+1, (i,x)::acc)) (0,[]) - |> snd - |> List.rev --exception FalseException--let sm_protected_add fail k v sm = - if not (StringMap.mem k sm) then StringMap.add k v sm else - if not fail then sm else - assertf "protected_add: duplicate binding for %s \n" k--let hashtbl_to_list_all t = - hashtbl_keys t |> map (Hashtbl.find_all t) --let clone x n =- let rec f n xs = if n <= 0 then xs else f (n-1) (x::xs) in- f n []--let single x = [x]--let distinct xs = - List.length (sort_and_compact xs) = List.length xs--let trunc i j = - let (ai,aj) = (abs i, abs j) in- if aj <= ai then j else ai*j/aj --let map_to_string f xs = - String.concat "," (List.map f xs)--let suffix_of_string = fun s i -> String.sub s i (String.length s - 1)--(* [count_map xs] = fun x -> number of times x appears in xs if non-zero *)-let count_map rs =- List.fold_left begin fun m r -> - let c = try IntMap.find r m with Not_found -> 0 in- IntMap.add r (c+1) m- end IntMap.empty rs--let o2s f = function- | Some x -> "Some "^ (f x)- | None -> "None"--let fixpoint f x =- let rec acf b x =- let x', b' = f x in- if b' then acf true x' else (x', b) in- acf false x---let fsprintf f p = - Format.fprintf Format.str_formatter "@[%a@]" f p;- Format.flush_str_formatter ()--let rec same_length l1 l2 = match l1, l2 with- | [], [] -> true- | _ :: xs, _ :: ys -> same_length xs ys- | _ -> false--let ex_one s = function- | [x] -> x- | _ :: _ -> failwith s- | _ -> failwith (s ^ ". empty")--let only_one s = function- x :: [] -> Some x- | _ :: _ -> failwith s- | [] -> None--let maybe_one = function- | [x] -> Some x- | _ -> None---let int_of_bool b = if b then 1 else 0--(*****************************************************************)-(******************** Mem Management *****************************)-(*****************************************************************)--open Gc-(* open Format *)--let pprint_gc s =- (*printf "@[Gc@ Stats:@]@.";- printf "@[minor@ words:@ %f@]@." s.minor_words;- printf "@[promoted@ words:@ %f@]@." s.promoted_words;- printf "@[major@ words:@ %f@]@." s.major_words;*)- (*printf "@[total allocated:@ %fMB@]@." (floor ((s.major_words +. s.minor_words -. s.promoted_words) *. (4.0) /. (1024.0 *. 1024.0)));*)-- Format.printf "@[total allocated:@ %fMB@]@." (floor ((allocated_bytes ()) /. (1024.0 *. 1024.0)));- Format.printf "@[minor@ collections:@ %i@]@." s.minor_collections;- Format.printf "@[major@ collections:@ %i@]@." s.major_collections;- Format.printf "@[heap@ size:@ %iMB@]@." (s.heap_words * 4 / (1024 * 1024));- (*printf "@[heap@ chunks:@ %i@]@." s.heap_chunks;- (*printf "@[live@ words:@ %i@]@." s.live_words;- printf "@[live@ blocks:@ %i@]@." s.live_blocks;- printf "@[free@ words:@ %i@]@." s.free_words;- printf "@[free@ blocks:@ %i@]@." s.free_blocks;- printf "@[largest@ free:@ %i@]@." s.largest_free;- printf "@[fragments:@ %i@]@." s.fragments;*)*)- Format.printf "@[compactions:@ %i@]@." s.compactions;- (*printf "@[top@ heap@ words:@ %i@]@." s.top_heap_words*) ()--let dump_gc s =- Format.printf "@[%s@]@." s;- pprint_gc (Gc.quick_stat ())---let append_to_file f s = - let oc = Unix.openfile f [Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT] 420 in- ignore (Unix.write oc s 0 ((String.length s)-1) ); - Unix.close oc--(*-let with_out_file file f =- let oc = open_out file in- f oc;- close_out oc-*)--let display_tick = fun () -> print_now "."--let display_tick = - let icona = [| "|"; "/" ; "-"; "\\" |] in- let pos = ref 0 in- fun () -> - let k = !pos in- let _ = print_now ("\b."^icona.(k)) in- let _ = pos := (k + 1) mod 4 in- ()--let with_out_file file f = file |> open_out >> f |> close_out--let write_to_file f s =- with_out_file f (fun oc -> output_string oc s)--let with_out_formatter file f =- with_out_file file (fun oc -> f (Format.formatter_of_out_channel oc))--let get_unique =- let cnt = ref 0 in- (fun () -> let rv = !cnt in incr cnt; rv)--let lines_of_file filename = - let lines = ref [] in- let chan = open_in filename in- try - while true; do- lines := input_line chan :: !lines- done; [] - with End_of_file ->- close_in chan;- List.rev !lines--let map_lines_of_file infile outfile f =- let ic = open_in infile in- let oc = open_out outfile in- try- while true; do- ic |> input_line |> f |> output_string oc- done;- with End_of_file -> - (close_in ic; close_out oc)--let maybe_cons m xs = match m with- | None -> xs- | Some x -> x :: xs--let maybe_list xs = - List.fold_right maybe_cons xs []--let rec list_first_maybe f = function- | x::xs -> begin match f x with - | Some y -> Some y - | _ -> list_first_maybe f xs- end- | [] -> None--let list_find_maybe f xs =- try some <| List.find f xs with Not_found -> None--let list_assoc_maybe k kvs =- try Some (List.assoc k kvs) with Not_found -> None--let list_assoc_default d kvs k =- try List.assoc k kvs with Not_found -> d--let list_assoc_flip xs = - let r (x, y) = (y, x) in- List.map r xs--let fold_lefti f b xs =- List.fold_left (fun (i,b) x -> ((i+1), f i b x)) (0,b) xs--let mapi f xs = - xs |> fold_lefti (fun i acc x -> (f i x) :: acc) [] - |> snd |> List.rev--let index_from n xs = - let is = range n (n + List.length xs) in- List.combine is xs--let fold_left_flip f b xs =- List.fold_left (flip f) b xs--let fold_left_swap f xs b =- List.fold_left f b xs--let rec map3 f xs ys zs = match (xs, ys, zs) with- | ([], [], []) -> []- | (x :: xs, y :: ys, z :: zs) -> f x y z :: map3 f xs ys zs- | _ -> assert false--let rec fold_right3 f xs ys zs acc = match xs, ys, zs with- | x :: xs, y :: ys, z :: zs -> f x y z (fold_right3 f xs ys zs acc)- | [], [], [] -> acc- | _ -> assert false--let rec fold_left3 f acc xs ys zs = match xs, ys, zs with- | x :: xs, y :: ys, z :: zs -> fold_left3 f (f acc x y z) xs ys zs- | [], [], [] -> acc- | _ -> assert false--let zip_partition xs bs =- let (xbs, xbs') = List.partition snd (List.combine xs bs) in- (List.map fst xbs, List.map fst xbs')--let rec map4 f ws xs ys zs = match ws, xs, ys, zs with- | [], [], [], [] -> []- | w :: ws, x :: xs, y :: ys, z :: zs -> f w x y z :: map4 f ws xs ys zs- | _ -> asserti false "map4"; assert false---let rec perms es =- match es with- | s :: [] ->- List.map (fun c -> [c]) s- | s :: es ->- flap (fun c -> List.map (fun d -> c :: d) (perms es)) s- | [] ->- []--let flap2 f xs ys = - List.flatten (List.map2 f xs ys)--let flap3 f xs ys zs =- List.flatten (map3 f xs ys zs)--let combine msg xs ys =- let _ = asserts (List.length xs = List.length ys) "%s" msg in- List.combine xs ys--let combine3 xs ys zs =- map3 (fun x y z -> (x, y, z)) xs ys zs--let combine4 ws xs ys zs =- map4 (fun w x y z -> (w, x, y, z)) ws xs ys zs--let tr_partition f xs =- List.fold_left begin fun (xs,ys) z -> - if f z - then (z::xs, ys) - else (xs, z::ys)- end ([],[]) xs--let either_partition f xs =- List.fold_left begin fun (xs, ys) z -> - match f z with- | Left x -> (x::xs, ys)- | Right y -> (xs, y::ys)- end ([], []) xs--(* these do odd things with order for performance - * it is possible that fast is a misnomer *)-let fast_flatten xs =- List.fold_left (++) [] xs--let fast_append v v' =- let (v, v') = if List.length v > List.length v' then (v', v) else (v, v') in- List.rev_append v v'--let fast_flap f xs =- List.fold_left (fun xs x -> List.rev_append (f x) xs) [] xs--let rec fast_unflat ys = function- | x :: xs -> fast_unflat ([x] :: ys) xs- | [] -> ys--let rec rev_perms s = function- | [] -> s- | e :: es -> rev_perms - (fast_flap (fun e -> List.rev_map (fun s -> e :: s) s) e) es --let rev_perms = function- | e :: es -> rev_perms (fast_unflat [] e) es- | es -> es --let tflap2 (e1, e2) f =- List.fold_left (fun bs b -> List.fold_left (fun aas a -> f a b :: aas) bs e1) [] e2--let tflap3 (e1, e2, e3) f =- List.fold_left begin fun cs c -> - List.fold_left begin fun bs b -> - List.fold_left begin fun aas a -> - f a b c :: aas- end bs e1- end cs e2- end[] e3--let rec expand f xs ys =- match xs with- | [] -> ys- | x::xs -> let (xs', ys') = f x in- expand f (xs' ++ xs) (ys' ++ ys)--let rec get_first f = function- | x::xs when f x -> Some x - | _::xs -> get_first f xs- | [] -> None--let join f xs ys = - let rec fuse acc xs ys = - match xs, ys with - | [],_ | _, [] -> List.rev acc- | ((kx, _)::xs', (ky,_)::_ ) when kx < ky -> fuse acc xs' ys- | ((kx, _)::_ , (ky,_)::ys') when kx > ky -> fuse acc xs ys' - | ((kx, x)::xs', (ky,y)::ys') (* kx = ky *) -> fuse ((x,y)::acc) xs' ys' in- let xs' = List.map (fun x -> (f x, x)) xs |> List.sort compare in- let ys' = List.map (fun y -> (f y, y)) ys |> List.sort compare in- fuse [] xs' ys'--let hashtbl_find_default d t x =- try Hashtbl.find t x with Not_found -> d--let frequency (xs : 'a list) : ('a * int) list = - let t = Hashtbl.create 17 in- List.iter begin fun x ->- let n = hashtbl_find_default 0 t x in- Hashtbl.replace t x (n + 1)- end xs;- hashtbl_to_list t--let kgroupby (f: 'a -> 'b) (xs: 'a list): ('b * 'a list) list =- let t = Hashtbl.create 17 in- let lookup x = try Hashtbl.find t x with Not_found -> [] in- (* build table *)- List.iter begin fun x -> - Hashtbl.replace t (f x) (x :: lookup (f x))- end xs;- (* build cluster *)- Hashtbl.fold (fun k xs xxs -> (k, xs) :: xxs) t []----let groupby (f: 'a -> 'b) (xs: 'a list): 'a list list =- kgroupby f xs |> List.map (snd <+> List.rev)--let full_join f xs ys =- (xs, ys)- |> map_pair (kgroupby f)- |> uncurry (join fst)- |> flap (map_pair snd <+> uncurry cross_product)--let exists_pair (f: 'a -> 'a -> bool) (xs: 'a list): bool =- fst (List.fold_left (fun (b, ys) x -> (b || List.exists (f x) ys, x :: ys)) (false, []) xs)--let rec find_pair (f: 'a -> 'a -> bool): 'a list -> 'a * 'a = function- | [] -> raise Not_found- | x::xs -> try (x, List.find (f x) xs) with Not_found -> find_pair f xs--let rec is_unique = function- | [] -> true- | x :: xs -> if List.mem x xs then false else is_unique xs--let map_opt f = function- | Some o -> Some (f o)- | None -> None--let resl_opt f = function- | Some o -> f o- | None -> []--let resi_opt f = function- | Some o -> f o- | None -> ()--let opt_iter f l = - List.iter (resi_opt f) l--let array_findi p arr =- let rec look i =- if i < 0 then raise Not_found else- if p arr.(i) then i else look i - 1- in look (Array.length arr - 1)--let array_to_index_list a =- Array.fold_left (fun (i, rv) v -> (i+1,(i,v)::rv)) (0,[]) a- |> snd- |> List.rev---let hashtbl_of_list xys = - let t = Hashtbl.create 37 in- let _ = List.iter (fun (x,y) -> Hashtbl.add t x y) xys in- t--let hashtbl_of_list_with kf xs = - xs |>: pad_fst kf |> hashtbl_of_list--let array_flapi f a =- Array.fold_left (fun (i, acc) x -> (i+1, (f i x) :: acc)) (0,[]) a- |> snd - |> List.rev- |> flatten--let array_fold_lefti f acc a =- Array.fold_left (fun (i, acc) x -> (i + 1, f i acc x)) (0, acc) a |> snd--let array_map2 f xa ya = - Array.mapi (fun i x -> f x (ya.(i))) xa--let array_rev_iteri f a =- for i = Array.length a - 1 downto 0 do- f i a.(i)- done--exception NotForall--let array_forall f a =- try- Array.iter (fun e -> if f e then () else raise NotForall) a; true- with NotForall ->- false--let array_combine a1 a2 = - asserts (Array.length a1 = Array.length a2) "array_combine";- Array.init (Array.length a1) (fun i -> (a1.(i), a2.(i)))---let compose f g a = f (g a)---let rec gcd (a: int) (b: int): int =- if b = 0 then a else gcd b (a mod b)--let lcm (a: int) (b: int): int =- if a = 0 then a else (abs (a * b)) / (gcd a b)--let mk_int_factory () =- let id = ref (-1) in- ((fun () -> incr id; !id), (fun () -> id := -1))--let mk_char_factory () =- let (fresh_int, reset_fresh_int) = mk_int_factory () in- ((fun () -> Char.chr (fresh_int () + Char.code 'a')), reset_fresh_int)--let mk_string_factory s =- let (fresh_int, reset_fresh_int) = mk_int_factory () in- ((fun () -> s^(string_of_int (fresh_int ()))), reset_fresh_int)--let swap (x,y) = (y,x)--(* ('a * (int * 'b) list) list -> (int * ('a * 'b) list) list *)-let transpose x_iys_s = - let t = Hashtbl.create 17 in- List.iter begin fun (x, iys) ->- List.iter begin fun (i, y) -> - Hashtbl.add t i (x,y) - end iys- end x_iys_s; - hashtbl_keys t |> List.map (fun i -> (i, Hashtbl.find_all t i))--let basename_no_extension fname =- fname |> Filename.basename |> Filename.chop_extension--let absolute_name name =- if not (Filename.is_relative name) then name else- let b = Filename.basename name in- let d = Filename.dirname name in- let dir = Sys.getcwd () in- let _ = Sys.chdir (Filename.concat dir d) in- let dir' = Sys.getcwd () in- let rv = Filename.concat dir' b in- let _ = Sys.chdir dir in- rv--let cardinality = fun xs -> xs |> sort_and_compact |> List.length-let disjoint = fun xs ys -> cardinality xs + cardinality ys = cardinality (xs ++ ys)--let bracket (l : unit -> unit) (r : unit -> unit) (f : unit -> 'a) : 'a = - try l () |> f >> (fun _ -> r ())- with ex -> assertf "bracket hits exn: %s \n" (Printexc.to_string ex)--(*-let with_ref_at x v f =- let oldv = !x in - bracket (fun _ -> x := v) (fun _ -> x := oldv) f -*)--let with_ref_at x v f = - let oldv = !x in - let _ = x := v in- let res = f () in- let _ = x := oldv in- res----let rec isPrefix = function- | ([], _) -> true- | (x::xs, y::ys) when x = y -> isPrefix (xs, ys)- | _ -> false--let find_first_true f lo hi =- let rec go lo hi = - let mid = lo + ((hi - lo) / 2) in- match () with- | _ when lo >= hi -> None- | _ when lo = hi - 1 -> Some hi - | _ when f mid -> go lo mid - | _ -> go mid hi - in if f lo then Some lo - else if not (f hi) then None - else go lo hi--let safeHead msg = function- | [x] -> x- | _ -> failwith ("ERROR: safeHead" ^ msg) --let safeApply pp f x = match f x with- | Some y -> y- | None -> failwith ("ERROR: safeApply " ^ (pp x)) --let stringIsUpper = function- | "" -> false- | s -> let c = s.[0] in c = Char.uppercase c--let stringIsLower = function- | "" -> false- | s -> let c = s.[0] in c = Char.lowercase c---
external/ocamlgraph/.depend view
@@ -1,128 +1,128 @@-lib/bitv.cmo: lib/bitv.cmi-lib/bitv.cmx: lib/bitv.cmi-lib/heap.cmo: lib/heap.cmi-lib/heap.cmx: lib/heap.cmi-lib/unionfind.cmo: lib/unionfind.cmi-lib/unionfind.cmx: lib/unionfind.cmi-lib/bitv.cmi:-lib/heap.cmi:-lib/unionfind.cmi:-src/blocks.cmo: src/util.cmi src/sig.cmi-src/blocks.cmx: src/util.cmx src/sig.cmi-src/builder.cmo: src/sig.cmi src/builder.cmi-src/builder.cmx: src/sig.cmi src/builder.cmi-src/classic.cmo: src/sig.cmi src/builder.cmi src/classic.cmi-src/classic.cmx: src/sig.cmi src/builder.cmx src/classic.cmi-src/cliquetree.cmo: src/util.cmi src/sig.cmi src/persistent.cmi src/oper.cmi \- src/gmap.cmi src/builder.cmi src/cliquetree.cmi-src/cliquetree.cmx: src/util.cmx src/sig.cmi src/persistent.cmx src/oper.cmx \- src/gmap.cmx src/builder.cmx src/cliquetree.cmi-src/components.cmo: src/util.cmi src/sig.cmi src/components.cmi-src/components.cmx: src/util.cmx src/sig.cmi src/components.cmi-src/delaunay.cmo: src/delaunay.cmi-src/delaunay.cmx: src/delaunay.cmi-src/dot.cmo: src/dot_parser.cmi src/dot_lexer.cmo src/dot_ast.cmi \+lib/bitv.cmo : lib/bitv.cmi+lib/bitv.cmx : lib/bitv.cmi+lib/heap.cmo : lib/heap.cmi+lib/heap.cmx : lib/heap.cmi+lib/unionfind.cmo : lib/unionfind.cmi+lib/unionfind.cmx : lib/unionfind.cmi+lib/bitv.cmi :+lib/heap.cmi :+lib/unionfind.cmi :+src/blocks.cmo : src/util.cmi src/sig.cmi+src/blocks.cmx : src/util.cmx src/sig.cmi+src/builder.cmo : src/sig.cmi src/builder.cmi+src/builder.cmx : src/sig.cmi src/builder.cmi+src/classic.cmo : src/sig.cmi src/builder.cmi src/classic.cmi+src/classic.cmx : src/sig.cmi src/builder.cmx src/classic.cmi+src/cliquetree.cmo : src/util.cmi src/sig.cmi src/persistent.cmi \+ src/oper.cmi src/gmap.cmi src/builder.cmi src/cliquetree.cmi+src/cliquetree.cmx : src/util.cmx src/sig.cmi src/persistent.cmx \+ src/oper.cmx src/gmap.cmx src/builder.cmx src/cliquetree.cmi+src/components.cmo : src/util.cmi src/sig.cmi src/components.cmi+src/components.cmx : src/util.cmx src/sig.cmi src/components.cmi+src/delaunay.cmo : src/delaunay.cmi+src/delaunay.cmx : src/delaunay.cmi+src/dot.cmo : src/dot_parser.cmi src/dot_lexer.cmo src/dot_ast.cmi \ src/builder.cmi src/dot.cmi-src/dot.cmx: src/dot_parser.cmx src/dot_lexer.cmx src/dot_ast.cmi \+src/dot.cmx : src/dot_parser.cmx src/dot_lexer.cmx src/dot_ast.cmi \ src/builder.cmx src/dot.cmi-src/dot_lexer.cmo: src/dot_parser.cmi src/dot_ast.cmi-src/dot_lexer.cmx: src/dot_parser.cmx src/dot_ast.cmi-src/dot_parser.cmo: src/dot_ast.cmi src/dot_parser.cmi-src/dot_parser.cmx: src/dot_ast.cmi src/dot_parser.cmi-src/flow.cmo: src/util.cmi src/sig.cmi src/flow.cmi-src/flow.cmx: src/util.cmx src/sig.cmi src/flow.cmi-src/gcoloring.cmo: src/traverse.cmi src/sig.cmi src/gcoloring.cmi-src/gcoloring.cmx: src/traverse.cmx src/sig.cmi src/gcoloring.cmi-src/gmap.cmo: src/sig.cmi src/gmap.cmi-src/gmap.cmx: src/sig.cmi src/gmap.cmi-src/gml.cmo: src/builder.cmi src/gml.cmi-src/gml.cmx: src/builder.cmx src/gml.cmi-src/gpath.cmo: src/util.cmi src/sig.cmi lib/heap.cmi src/gpath.cmi-src/gpath.cmx: src/util.cmx src/sig.cmi lib/heap.cmx src/gpath.cmi-src/graphviz.cmo: src/graphviz.cmi-src/graphviz.cmx: src/graphviz.cmi-src/imperative.cmo: src/sig.cmi src/blocks.cmo lib/bitv.cmi \+src/dot_lexer.cmo : src/dot_parser.cmi src/dot_ast.cmi+src/dot_lexer.cmx : src/dot_parser.cmx src/dot_ast.cmi+src/dot_parser.cmo : src/dot_ast.cmi src/dot_parser.cmi+src/dot_parser.cmx : src/dot_ast.cmi src/dot_parser.cmi+src/flow.cmo : src/util.cmi src/sig.cmi src/flow.cmi+src/flow.cmx : src/util.cmx src/sig.cmi src/flow.cmi+src/gcoloring.cmo : src/traverse.cmi src/sig.cmi src/gcoloring.cmi+src/gcoloring.cmx : src/traverse.cmx src/sig.cmi src/gcoloring.cmi+src/gmap.cmo : src/sig.cmi src/gmap.cmi+src/gmap.cmx : src/sig.cmi src/gmap.cmi+src/gml.cmo : src/builder.cmi src/gml.cmi+src/gml.cmx : src/builder.cmx src/gml.cmi+src/gpath.cmo : src/util.cmi src/sig.cmi lib/heap.cmi src/gpath.cmi+src/gpath.cmx : src/util.cmx src/sig.cmi lib/heap.cmx src/gpath.cmi+src/graphviz.cmo : src/graphviz.cmi+src/graphviz.cmx : src/graphviz.cmi+src/imperative.cmo : src/sig.cmi src/blocks.cmo lib/bitv.cmi \ src/imperative.cmi-src/imperative.cmx: src/sig.cmi src/blocks.cmx lib/bitv.cmx \+src/imperative.cmx : src/sig.cmi src/blocks.cmx lib/bitv.cmx \ src/imperative.cmi-src/kruskal.cmo: src/util.cmi lib/unionfind.cmi src/sig.cmi src/kruskal.cmi-src/kruskal.cmx: src/util.cmx lib/unionfind.cmx src/sig.cmi src/kruskal.cmi-src/mcs_m.cmo: src/util.cmi src/sig.cmi src/persistent.cmi src/oper.cmi \+src/kruskal.cmo : src/util.cmi lib/unionfind.cmi src/sig.cmi src/kruskal.cmi+src/kruskal.cmx : src/util.cmx lib/unionfind.cmx src/sig.cmi src/kruskal.cmi+src/mcs_m.cmo : src/util.cmi src/sig.cmi src/persistent.cmi src/oper.cmi \ src/imperative.cmi src/gmap.cmi src/builder.cmi src/mcs_m.cmi-src/mcs_m.cmx: src/util.cmx src/sig.cmi src/persistent.cmx src/oper.cmx \+src/mcs_m.cmx : src/util.cmx src/sig.cmi src/persistent.cmx src/oper.cmx \ src/imperative.cmx src/gmap.cmx src/builder.cmx src/mcs_m.cmi-src/md.cmo: src/sig.cmi src/oper.cmi src/gmap.cmi src/cliquetree.cmi \+src/md.cmo : src/sig.cmi src/oper.cmi src/gmap.cmi src/cliquetree.cmi \ src/builder.cmi src/md.cmi-src/md.cmx: src/sig.cmi src/oper.cmx src/gmap.cmx src/cliquetree.cmx \+src/md.cmx : src/sig.cmi src/oper.cmx src/gmap.cmx src/cliquetree.cmx \ src/builder.cmx src/md.cmi-src/minsep.cmo: src/sig.cmi src/oper.cmi src/components.cmi src/minsep.cmi-src/minsep.cmx: src/sig.cmi src/oper.cmx src/components.cmx src/minsep.cmi-src/oper.cmo: src/sig.cmi src/builder.cmi src/oper.cmi-src/oper.cmx: src/sig.cmi src/builder.cmx src/oper.cmi-src/pack.cmo: src/traverse.cmi src/topological.cmi src/sig.cmi src/rand.cmi \+src/minsep.cmo : src/sig.cmi src/oper.cmi src/components.cmi src/minsep.cmi+src/minsep.cmx : src/sig.cmi src/oper.cmx src/components.cmx src/minsep.cmi+src/oper.cmo : src/sig.cmi src/builder.cmi src/oper.cmi+src/oper.cmx : src/sig.cmi src/builder.cmx src/oper.cmi+src/pack.cmo : src/traverse.cmi src/topological.cmi src/sig.cmi src/rand.cmi \ src/oper.cmi src/kruskal.cmi src/imperative.cmi src/graphviz.cmi \ src/gpath.cmi src/gml.cmi src/flow.cmi src/dot.cmi src/components.cmi \ src/classic.cmi src/builder.cmi src/pack.cmi-src/pack.cmx: src/traverse.cmx src/topological.cmx src/sig.cmi src/rand.cmx \+src/pack.cmx : src/traverse.cmx src/topological.cmx src/sig.cmi src/rand.cmx \ src/oper.cmx src/kruskal.cmx src/imperative.cmx src/graphviz.cmx \ src/gpath.cmx src/gml.cmx src/flow.cmx src/dot.cmx src/components.cmx \ src/classic.cmx src/builder.cmx src/pack.cmi-src/persistent.cmo: src/util.cmi src/sig.cmi src/blocks.cmo \+src/persistent.cmo : src/util.cmi src/sig.cmi src/blocks.cmo \ src/persistent.cmi-src/persistent.cmx: src/util.cmx src/sig.cmi src/blocks.cmx \+src/persistent.cmx : src/util.cmx src/sig.cmi src/blocks.cmx \ src/persistent.cmi-src/rand.cmo: src/sig.cmi src/delaunay.cmi src/builder.cmi src/rand.cmi-src/rand.cmx: src/sig.cmi src/delaunay.cmx src/builder.cmx src/rand.cmi-src/strat.cmo: src/sig.cmi src/strat.cmi-src/strat.cmx: src/sig.cmi src/strat.cmi-src/topological.cmo: src/sig.cmi src/topological.cmi-src/topological.cmx: src/sig.cmi src/topological.cmi-src/traverse.cmo: src/sig.cmi src/traverse.cmi-src/traverse.cmx: src/sig.cmi src/traverse.cmi-src/util.cmo: src/sig.cmi src/util.cmi-src/util.cmx: src/sig.cmi src/util.cmi-src/version.cmo:-src/version.cmx:-src/builder.cmi: src/sig.cmi-src/classic.cmi: src/sig.cmi-src/cliquetree.cmi: src/sig.cmi-src/components.cmi: src/util.cmi src/sig.cmi-src/delaunay.cmi:-src/dot.cmi: src/dot_ast.cmi src/builder.cmi-src/dot_ast.cmi:-src/dot_parser.cmi: src/dot_ast.cmi-src/flow.cmi: src/sig.cmi-src/gcoloring.cmi: src/sig.cmi-src/gmap.cmi: src/sig.cmi-src/gml.cmi: src/builder.cmi-src/gpath.cmi: src/sig.cmi-src/graphviz.cmi:-src/imperative.cmi: src/sig.cmi-src/kruskal.cmi: src/sig.cmi-src/mcs_m.cmi: src/sig.cmi-src/md.cmi: src/sig.cmi-src/minsep.cmi: src/sig.cmi-src/oper.cmi: src/sig.cmi src/builder.cmi-src/pack.cmi: src/sig_pack.cmi-src/persistent.cmi: src/sig.cmi-src/rand.cmi: src/sig.cmi src/builder.cmi-src/sig.cmi:-src/sig_pack.cmi:-src/strat.cmi: src/sig.cmi-src/topological.cmi: src/sig.cmi-src/traverse.cmi: src/sig.cmi-src/util.cmi: src/sig.cmi-editor/ed_display.cmo:-editor/ed_display.cmx:-editor/ed_draw.cmo: src/components.cmi-editor/ed_draw.cmx: src/components.cmx-editor/ed_graph.cmo: src/traverse.cmi src/imperative.cmi src/graphviz.cmi \+src/rand.cmo : src/sig.cmi src/delaunay.cmi src/builder.cmi src/rand.cmi+src/rand.cmx : src/sig.cmi src/delaunay.cmx src/builder.cmx src/rand.cmi+src/strat.cmo : src/sig.cmi src/strat.cmi+src/strat.cmx : src/sig.cmi src/strat.cmi+src/topological.cmo : src/sig.cmi src/topological.cmi+src/topological.cmx : src/sig.cmi src/topological.cmi+src/traverse.cmo : src/sig.cmi src/traverse.cmi+src/traverse.cmx : src/sig.cmi src/traverse.cmi+src/util.cmo : src/sig.cmi src/util.cmi+src/util.cmx : src/sig.cmi src/util.cmi+src/version.cmo :+src/version.cmx :+src/builder.cmi : src/sig.cmi+src/classic.cmi : src/sig.cmi+src/cliquetree.cmi : src/sig.cmi+src/components.cmi : src/util.cmi src/sig.cmi+src/delaunay.cmi :+src/dot.cmi : src/dot_ast.cmi src/builder.cmi+src/dot_ast.cmi :+src/dot_parser.cmi : src/dot_ast.cmi+src/flow.cmi : src/sig.cmi+src/gcoloring.cmi : src/sig.cmi+src/gmap.cmi : src/sig.cmi+src/gml.cmi : src/builder.cmi+src/gpath.cmi : src/sig.cmi+src/graphviz.cmi :+src/imperative.cmi : src/sig.cmi+src/kruskal.cmi : src/sig.cmi+src/mcs_m.cmi : src/sig.cmi+src/md.cmi : src/sig.cmi+src/minsep.cmi : src/sig.cmi+src/oper.cmi : src/sig.cmi src/builder.cmi+src/pack.cmi : src/sig_pack.cmi+src/persistent.cmi : src/sig.cmi+src/rand.cmi : src/sig.cmi src/builder.cmi+src/sig.cmi :+src/sig_pack.cmi :+src/strat.cmi : src/sig.cmi+src/topological.cmi : src/sig.cmi+src/traverse.cmi : src/sig.cmi+src/util.cmi : src/sig.cmi+editor/ed_display.cmo :+editor/ed_display.cmx :+editor/ed_draw.cmo : src/components.cmi+editor/ed_draw.cmx : src/components.cmx+editor/ed_graph.cmo : src/traverse.cmi src/imperative.cmi src/graphviz.cmi \ src/gml.cmi src/dot_ast.cmi src/dot.cmi src/components.cmi \ src/builder.cmi-editor/ed_graph.cmx: src/traverse.cmx src/imperative.cmx src/graphviz.cmx \+editor/ed_graph.cmx : src/traverse.cmx src/imperative.cmx src/graphviz.cmx \ src/gml.cmx src/dot_ast.cmi src/dot.cmx src/components.cmx \ src/builder.cmx-editor/ed_hyper.cmo:-editor/ed_hyper.cmx:-editor/ed_main.cmo:-editor/ed_main.cmx:+editor/ed_hyper.cmo :+editor/ed_hyper.cmx :+editor/ed_main.cmo :+editor/ed_main.cmx :
external/ocamlgraph/Makefile view
@@ -24,15 +24,15 @@ MANDIR=${prefix}/share/man # Other variables set by ./configure-OCAMLC = ocamlc-OCAMLOPT = ocamlopt+OCAMLC = ocamlc.opt+OCAMLOPT = ocamlopt.opt OCAMLDEP = ocamldep-OCAMLDOC = ocamldoc-OCAMLLEX = ocamllex+OCAMLDOC = ocamldoc.opt+OCAMLLEX = ocamllex.opt OCAMLYACC= ocamlyacc-OCAMLLIB = /usr/lib/ocaml+OCAMLLIB = /nix/store/547bsyhad0whqa62qkji1q0pfy5lm0qx-ocaml-4.01.0/lib/ocaml OCAMLBEST= opt-OCAMLVERSION = 3.12.1+OCAMLVERSION = 4.01.0 OCAMLWEB = true OCAMLWIN32 = no OCAMLFIND =
external/ocamlgraph/src/dot_parser.ml view
@@ -18,6 +18,7 @@ | EOF open Parsing;;+let _ = parse_error;; # 23 "src/dot_parser.mly" open Dot_ast open Parsing@@ -33,7 +34,7 @@ | Ident "nw" -> Nw | _ -> invalid_arg "compass_pt" -# 37 "src/dot_parser.ml"+# 38 "src/dot_parser.ml" let yytransl_const = [| 258 (* COLON *); 259 (* COMMA *);@@ -195,44 +196,44 @@ Obj.repr( # 49 "src/dot_parser.mly" ( { strict = _1; digraph = _2; id = _3; stmts = _5 } )-# 199 "src/dot_parser.ml"+# 200 "src/dot_parser.ml" : Dot_ast.file)) ; (fun __caml_parser_env -> Obj.repr( # 53 "src/dot_parser.mly" ( false )-# 205 "src/dot_parser.ml"+# 206 "src/dot_parser.ml" : 'strict_opt)) ; (fun __caml_parser_env -> Obj.repr( # 54 "src/dot_parser.mly" ( true )-# 211 "src/dot_parser.ml"+# 212 "src/dot_parser.ml" : 'strict_opt)) ; (fun __caml_parser_env -> Obj.repr( # 58 "src/dot_parser.mly" ( false )-# 217 "src/dot_parser.ml"+# 218 "src/dot_parser.ml" : 'graph_or_digraph)) ; (fun __caml_parser_env -> Obj.repr( # 59 "src/dot_parser.mly" ( true )-# 223 "src/dot_parser.ml"+# 224 "src/dot_parser.ml" : 'graph_or_digraph)) ; (fun __caml_parser_env -> Obj.repr( # 63 "src/dot_parser.mly" ( [] )-# 229 "src/dot_parser.ml"+# 230 "src/dot_parser.ml" : 'stmt_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'list1_stmt) in Obj.repr( # 64 "src/dot_parser.mly" ( _1 )-# 236 "src/dot_parser.ml"+# 237 "src/dot_parser.ml" : 'stmt_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'stmt) in@@ -240,7 +241,7 @@ Obj.repr( # 68 "src/dot_parser.mly" ( [_1] )-# 244 "src/dot_parser.ml"+# 245 "src/dot_parser.ml" : 'list1_stmt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'stmt) in@@ -249,40 +250,40 @@ Obj.repr( # 69 "src/dot_parser.mly" ( _1 :: _3 )-# 253 "src/dot_parser.ml"+# 254 "src/dot_parser.ml" : 'list1_stmt)) ; (fun __caml_parser_env -> Obj.repr( # 73 "src/dot_parser.mly" ( () )-# 259 "src/dot_parser.ml"+# 260 "src/dot_parser.ml" : 'semicolon_opt)) ; (fun __caml_parser_env -> Obj.repr( # 74 "src/dot_parser.mly" ( () )-# 265 "src/dot_parser.ml"+# 266 "src/dot_parser.ml" : 'semicolon_opt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'node_stmt) in Obj.repr( # 78 "src/dot_parser.mly" ( _1 )-# 272 "src/dot_parser.ml"+# 273 "src/dot_parser.ml" : 'stmt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'edge_stmt) in Obj.repr( # 79 "src/dot_parser.mly" ( _1 )-# 279 "src/dot_parser.ml"+# 280 "src/dot_parser.ml" : 'stmt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'attr_stmt) in Obj.repr( # 80 "src/dot_parser.mly" ( _1 )-# 286 "src/dot_parser.ml"+# 287 "src/dot_parser.ml" : 'stmt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Dot_ast.id) in@@ -290,14 +291,14 @@ Obj.repr( # 81 "src/dot_parser.mly" ( Equal (_1, _3) )-# 294 "src/dot_parser.ml"+# 295 "src/dot_parser.ml" : 'stmt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'subgraph) in Obj.repr( # 82 "src/dot_parser.mly" ( Subgraph _1 )-# 301 "src/dot_parser.ml"+# 302 "src/dot_parser.ml" : 'stmt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'node_id) in@@ -305,7 +306,7 @@ Obj.repr( # 86 "src/dot_parser.mly" ( Node_stmt (_1, _2) )-# 309 "src/dot_parser.ml"+# 310 "src/dot_parser.ml" : 'node_stmt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'node) in@@ -314,28 +315,28 @@ Obj.repr( # 90 "src/dot_parser.mly" ( Edge_stmt (_1, _2, _3) )-# 318 "src/dot_parser.ml"+# 319 "src/dot_parser.ml" : 'edge_stmt)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in Obj.repr( # 94 "src/dot_parser.mly" ( Attr_graph _2 )-# 325 "src/dot_parser.ml"+# 326 "src/dot_parser.ml" : 'attr_stmt)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in Obj.repr( # 95 "src/dot_parser.mly" ( Attr_node _2 )-# 332 "src/dot_parser.ml"+# 333 "src/dot_parser.ml" : 'attr_stmt)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in Obj.repr( # 96 "src/dot_parser.mly" ( Attr_edge _2 )-# 339 "src/dot_parser.ml"+# 340 "src/dot_parser.ml" : 'attr_stmt)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'node) in@@ -343,13 +344,13 @@ Obj.repr( # 100 "src/dot_parser.mly" ( _2 :: _3 )-# 347 "src/dot_parser.ml"+# 348 "src/dot_parser.ml" : 'edge_rhs)) ; (fun __caml_parser_env -> Obj.repr( # 104 "src/dot_parser.mly" ( [] )-# 353 "src/dot_parser.ml"+# 354 "src/dot_parser.ml" : 'edge_rhs_opt)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'node) in@@ -357,21 +358,21 @@ Obj.repr( # 105 "src/dot_parser.mly" ( _2 :: _3 )-# 361 "src/dot_parser.ml"+# 362 "src/dot_parser.ml" : 'edge_rhs_opt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'node_id) in Obj.repr( # 109 "src/dot_parser.mly" ( NodeId _1 )-# 368 "src/dot_parser.ml"+# 369 "src/dot_parser.ml" : 'node)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'subgraph) in Obj.repr( # 110 "src/dot_parser.mly" ( NodeSub _1 )-# 375 "src/dot_parser.ml"+# 376 "src/dot_parser.ml" : 'node)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : Dot_ast.id) in@@ -379,20 +380,20 @@ Obj.repr( # 114 "src/dot_parser.mly" ( _1, _2 )-# 383 "src/dot_parser.ml"+# 384 "src/dot_parser.ml" : 'node_id)) ; (fun __caml_parser_env -> Obj.repr( # 118 "src/dot_parser.mly" ( None )-# 389 "src/dot_parser.ml"+# 390 "src/dot_parser.ml" : 'port_opt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'port) in Obj.repr( # 119 "src/dot_parser.mly" ( Some _1 )-# 396 "src/dot_parser.ml"+# 397 "src/dot_parser.ml" : 'port_opt)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in@@ -400,7 +401,7 @@ # 123 "src/dot_parser.mly" ( try PortC (compass_pt _2) with Invalid_argument _ -> PortId (_2, None) )-# 404 "src/dot_parser.ml"+# 405 "src/dot_parser.ml" : 'port)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 2 : Dot_ast.id) in@@ -411,27 +412,27 @@ try compass_pt _4 with Invalid_argument _ -> raise Parse_error in PortId (_2, Some cp) )-# 415 "src/dot_parser.ml"+# 416 "src/dot_parser.ml" : 'port)) ; (fun __caml_parser_env -> Obj.repr( # 133 "src/dot_parser.mly" ( [] )-# 421 "src/dot_parser.ml"+# 422 "src/dot_parser.ml" : 'attr_list_opt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in Obj.repr( # 134 "src/dot_parser.mly" ( _1 )-# 428 "src/dot_parser.ml"+# 429 "src/dot_parser.ml" : 'attr_list_opt)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'a_list) in Obj.repr( # 138 "src/dot_parser.mly" ( [_2] )-# 435 "src/dot_parser.ml"+# 436 "src/dot_parser.ml" : 'attr_list)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 2 : 'a_list) in@@ -439,20 +440,20 @@ Obj.repr( # 139 "src/dot_parser.mly" ( _2 :: _4 )-# 443 "src/dot_parser.ml"+# 444 "src/dot_parser.ml" : 'attr_list)) ; (fun __caml_parser_env -> Obj.repr( # 143 "src/dot_parser.mly" ( None )-# 449 "src/dot_parser.ml"+# 450 "src/dot_parser.ml" : 'id_opt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in Obj.repr( # 144 "src/dot_parser.mly" ( Some _1 )-# 456 "src/dot_parser.ml"+# 457 "src/dot_parser.ml" : 'id_opt)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'equality) in@@ -460,7 +461,7 @@ Obj.repr( # 148 "src/dot_parser.mly" ( [_1] )-# 464 "src/dot_parser.ml"+# 465 "src/dot_parser.ml" : 'a_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'equality) in@@ -469,14 +470,14 @@ Obj.repr( # 149 "src/dot_parser.mly" ( _1 :: _3 )-# 473 "src/dot_parser.ml"+# 474 "src/dot_parser.ml" : 'a_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in Obj.repr( # 153 "src/dot_parser.mly" ( _1, None )-# 480 "src/dot_parser.ml"+# 481 "src/dot_parser.ml" : 'equality)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : Dot_ast.id) in@@ -484,26 +485,26 @@ Obj.repr( # 154 "src/dot_parser.mly" ( _1, Some _3 )-# 488 "src/dot_parser.ml"+# 489 "src/dot_parser.ml" : 'equality)) ; (fun __caml_parser_env -> Obj.repr( # 158 "src/dot_parser.mly" ( () )-# 494 "src/dot_parser.ml"+# 495 "src/dot_parser.ml" : 'comma_opt)) ; (fun __caml_parser_env -> Obj.repr( # 159 "src/dot_parser.mly" ( () )-# 500 "src/dot_parser.ml"+# 501 "src/dot_parser.ml" : 'comma_opt)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in Obj.repr( # 164 "src/dot_parser.mly" ( SubgraphId _2 )-# 507 "src/dot_parser.ml"+# 508 "src/dot_parser.ml" : 'subgraph)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 3 : Dot_ast.id) in@@ -511,21 +512,21 @@ Obj.repr( # 165 "src/dot_parser.mly" ( SubgraphDef (Some _2, _4) )-# 515 "src/dot_parser.ml"+# 516 "src/dot_parser.ml" : 'subgraph)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 1 : 'stmt_list) in Obj.repr( # 166 "src/dot_parser.mly" ( SubgraphDef (None, _3) )-# 522 "src/dot_parser.ml"+# 523 "src/dot_parser.ml" : 'subgraph)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'stmt_list) in Obj.repr( # 167 "src/dot_parser.mly" ( SubgraphDef (None, _2) )-# 529 "src/dot_parser.ml"+# 530 "src/dot_parser.ml" : 'subgraph)) (* Entry file *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))
external/ocamlgraph/src/version.ml view
@@ -1,2 +1,2 @@ let version = "0.99b"-let date = "Sun Sep 22 21:13:17 PDT 2013"+let date = "Tue Aug 12 13:29:08 PDT 2014"
liquid-fixpoint.cabal view
@@ -1,10 +1,10 @@ name: liquid-fixpoint-version: 0.1.0.0+version: 0.2.0.0 synopsis: Predicate Abstraction-based Horn-Clause/Implication Constraint Solver homepage: https://github.com/ucsd-progsys/liquid-fixpoint license: BSD3 license-file: LICENSE-author: Ranjit Jhala+author: Ranjit Jhala, Niki Vazou, Eric Seidel maintainer: jhala@cs.ucsd.edu category: Language build-type: Custom @@ -36,7 +36,6 @@ . - A Z3 Binary (<http://z3.codeplex.com>) - Extra-Source-Files: configure , external/fixpoint/Makefile , external/fixpoint/*.ml@@ -73,10 +72,44 @@ Description: Link to Z3 Default: False +Source-Repository head+ Type: git+ Location: https://github.com/ucsd-progsys/liquid-fixpoint/++-- FIXME: This is a terrible hack. We build Fixpoint.hs *twice*, once+-- targeting fixpoint.native so we can then *clobber* it with the+-- OCaml fixpoint.native. This is required for cabal-install to detect+-- fixpoint.native as an executable, and properly symlink it when+-- asked.+Executable fixpoint.native+ Main-is: Fixpoint.hs+ Build-Depends: base >= 4 && < 5+ , array+ , syb+ , cmdargs+ , ansi-terminal+ , bifunctors+ , bytestring+ , containers+ , deepseq+ , directory+ , filemanip+ , filepath+ , mtl+ , parsec+ , pretty+ , process+ , syb+ , text+ , hashable+ , unordered-containers+ , text-format+ , liquid-fixpoint+ + Executable fixpoint Main-is: Fixpoint.hs Build-Depends: base >= 4 && < 5- , ghc==7.6.3 , array , syb , cmdargs@@ -88,31 +121,34 @@ , directory , filemanip , filepath- , ghc-prim , mtl , parsec , pretty , process+ , syb , text- , hashable<1.2+ , hashable , unordered-containers+ , text-format , liquid-fixpoint Library hs-source-dirs: src Exposed-Modules: Language.Fixpoint.Names, Language.Fixpoint.Files,+ Language.Fixpoint.Errors, Language.Fixpoint.Config, Language.Fixpoint.Types, Language.Fixpoint.Sort, Language.Fixpoint.Interface, Language.Fixpoint.Parse, Language.Fixpoint.PrettyPrint,+ Language.Fixpoint.SmtLib2, Language.Fixpoint.Misc - Build-Depends: base- , ghc==7.6.3+ Build-Depends: base >= 4 && < 5 , array+ , attoparsec , syb , cmdargs , ansi-terminal@@ -124,10 +160,14 @@ , filemanip , filepath , ghc-prim+ , intern , mtl , parsec , pretty , process+ , syb , text- , hashable<1.2+ , transformers+ , hashable , unordered-containers+ , text-format
src/Language/Fixpoint/Config.hs view
@@ -10,7 +10,9 @@ , Command (..) , SMTSolver (..) , GenQualifierSort (..)+ , UeqAllSorts (..) , withTarget + , withUEqAllSorts ) where import Language.Fixpoint.Files@@ -32,17 +34,21 @@ data Config = Config { - inFile :: FilePath -- target fq-file - , outFile :: FilePath -- output file- , solver :: SMTSolver -- which SMT solver to use - , genSorts :: GenQualifierSort -- generalize qualifier sorts+ 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 } deriving (Eq,Data,Typeable,Show) instance Default Config where- def = Config "" def def def+ def = Config "" def def def def def def instance Command Config where command c = command (genSorts c) + ++ command (ueqAllSorts c) ++ command (solver c) ++ " -out " ++ (outFile c) ++ " " ++ (inFile c)@@ -67,6 +73,18 @@ command (GQS True) = "" command (GQS False) = "-no-gen-qual-sorts" +newtype UeqAllSorts = UAS Bool + deriving (Eq, Data,Typeable,Show)++instance Default UeqAllSorts where+ def = UAS False++instance Command UeqAllSorts where+ command (UAS True) = " -ueq-all-sorts "+ command (UAS False) = "" ++withUEqAllSorts c b = c { ueqAllSorts = UAS b }+ --------------------------------------------------------------------------------------- data SMTSolver = Z3 | Cvc4 | Mathsat | Z3mem@@ -92,6 +110,5 @@ -- defaultSolver :: Maybe SMTSolver -> SMTSolver -- defaultSolver = fromMaybe Z3 -
+ src/Language/Fixpoint/Errors.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Language.Fixpoint.Errors (+ -- * Concrete Location Type+ SrcSpan (..)+ , dummySpan+ , sourcePosElts++ -- * Abstract Error Type+ , Error++ -- * Constructor+ , err++ -- * Accessors+ , errLoc+ , errMsg+ -- , errorInfo++ -- * Adding Insult to Injury+ , catMessage+ , catError++ -- * Fatal Exit+ , die++ ) where++import System.FilePath +import Text.PrettyPrint.HughesPJ+import Text.Parsec.Pos +import Data.Typeable+import Data.Generics (Data)+import Text.Printf +import Data.Hashable+import Control.Exception+import qualified Control.Monad.Error as E +import Language.Fixpoint.PrettyPrint+import Language.Fixpoint.Types+import GHC.Generics (Generic)++-----------------------------------------------------------------------+-- | A Reusable SrcSpan Type ------------------------------------------+-----------------------------------------------------------------------++data SrcSpan = SS { sp_start :: !SourcePos, sp_stop :: !SourcePos} + deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance PPrint SrcSpan where+ pprint = ppSrcSpan++-- ppSrcSpan_short z = parens+-- $ text (printf "file %s: (%d, %d) - (%d, %d)" (takeFileName f) l c l' c') +-- where +-- (f,l ,c ) = sourcePosElts $ sp_start z+-- (_,l',c') = sourcePosElts $ sp_stop z+++ppSrcSpan z = text (printf "%s:%d:%d-%d:%d" f l c l' c') + -- parens $ text (printf "file %s: (%d, %d) - (%d, %d)" (takeFileName f) l c l' c') + where + (f,l ,c ) = sourcePosElts $ sp_start z+ (_,l',c') = sourcePosElts $ sp_stop z++sourcePosElts s = (src, line, col)+ where + src = sourceName s + line = sourceLine s+ col = sourceColumn s ++instance Hashable SourcePos where + hashWithSalt i = hashWithSalt i . sourcePosElts++instance Hashable SrcSpan where + hashWithSalt i z = hashWithSalt i (sp_start z, sp_stop z)++++---------------------------------------------------------------------------+-- errorInfo :: Error -> (SrcSpan, String)+-- ------------------------------------------------------------------------+-- errorInfo (Error l msg) = (l, msg)+++-----------------------------------------------------------------------+-- | A BareBones Error Type -------------------------------------------+-----------------------------------------------------------------------++data Error = Error { errLoc :: SrcSpan, errMsg :: String }+ deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance PPrint Error where+ pprint (Error l msg) = ppSrcSpan l <> text (": Error: " ++ msg)+ -- text $ printf "%s\n %s\n" (showpp l) msg + +instance Fixpoint Error where+ toFix = pprint++instance Exception Error++instance E.Error Error where+ strMsg = Error dummySpan+ +dummySpan = SS l l + where l = initialPos ""+++---------------------------------------------------------------------+catMessage :: Error -> String -> Error+---------------------------------------------------------------------+catMessage err msg = err {errMsg = msg ++ errMsg err} ++---------------------------------------------------------------------+catError :: Error -> Error -> Error+---------------------------------------------------------------------+catError e1 e2 = catMessage e1 $ show e2++++---------------------------------------------------------------------+err :: SrcSpan -> String -> Error+---------------------------------------------------------------------+err = Error++---------------------------------------------------------------------+die :: Error -> a+---------------------------------------------------------------------+die = throw+
src/Language/Fixpoint/Files.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} --- | This module contains Haskell variables representing globally visible +-- | This module contains Haskell variables representing globally visible -- names for files, paths, extensions. -- -- Rather than have strings floating around the system, all constant names@@ -8,15 +8,17 @@ -- manipulated elsewhere. module Language.Fixpoint.Files (- + -- * Hardwired file extension names Ext (..) , extFileName+ , extFileNameR+ , tempDirectory , extModuleName , withExt , isExtFile- - -- * Hardwired paths ++ -- * Hardwired paths , getFixpointPath, getZ3LibPath -- * Various generic utility functions for finding and removing files@@ -24,7 +26,7 @@ , getFileInDirs , findFileInDirs , copyFiles- + ) where import qualified Control.Exception as Ex@@ -48,34 +50,39 @@ getZ3LibPath = dropFileName <$> getFixpointPath -checkM f msg p +checkM f msg p = do ex <- f p if ex then return p else errorstar $ "Cannot find " ++ msg ++ " at :" ++ p ----------------------------------------------------------------------------------- -data Ext = Cgi -- ^ Constraint Generation Information +data Ext = Cgi -- ^ Constraint Generation Information | Fq -- ^ Input to constraint solving (fixpoint) | Out -- ^ Output from constraint solving (fixpoint) | Html -- ^ HTML file with inferred type annotations | Annot -- ^ Text file with inferred types - | Hs -- ^ Target source - | LHs -- ^ Literate Haskell target source file- | Spec -- ^ Spec file (e.g. include/Prelude.spec) + | Vim -- ^ Vim annotation file + | Hs -- ^ Haskell source + | LHs -- ^ Literate Haskell source + | Js -- ^ JavaScript source+ | Ts -- ^ Typescript source+ | Spec -- ^ Spec file (e.g. include/Prelude.spec) | Hquals -- ^ Qualifiers file (e.g. include/Prelude.hquals) | Result -- ^ Final result: SAFE/UNSAFE | Cst -- ^ HTML file with templates?- | Mkdn -- ^ Markdown file (temporarily generated from .Lhs + annots) + | Mkdn -- ^ Markdown file (temporarily generated from .Lhs + annots) | Json -- ^ JSON file containing result (annots + errors)- | Saved -- ^ Previous version of source (for incremental checking)- | Pred - | PAss - | Dat + | Saved -- ^ Previous source (for incremental checking)+ | Cache -- ^ Previous output (for incremental checking)+ | Pred+ | PAss+ | Dat+ | Smt2 -- ^ SMTLIB2 query file deriving (Eq, Ord, Show) extMap e = go e- where + where go Cgi = ".cgi" go Pred = ".pred" go PAss = ".pass"@@ -85,31 +92,54 @@ go Html = ".html" go Cst = ".cst" go Annot = ".annot"+ go Vim = ".vim.annot" go Hs = ".hs" go LHs = ".lhs"+ go Js = ".js"+ go Ts = ".ts" go Mkdn = ".markdown" go Json = ".json" go Spec = ".spec"- go Hquals = ".hquals" + go Hquals = ".hquals" go Result = ".out" go Saved = ".bak"+ go Cache = ".err"+ go Smt2 = ".smt2" go _ = errorstar $ "extMap: Unknown extension " ++ show e -withExt :: FilePath -> Ext -> FilePath +withExt :: FilePath -> Ext -> FilePath withExt f ext = replaceExtension f (extMap ext) extFileName :: Ext -> FilePath -> FilePath-extFileName ext = (`addExtension` (extMap ext))+extFileName e f = path </> addExtension file ext+ where+ path = tempDirectory f+ file = takeFileName f+ ext = extMap e +tempDirectory :: FilePath -> FilePath+tempDirectory f + | isTmp dir = dir + | otherwise = dir </> tmpDirName+ where+ dir = takeDirectory f+ isTmp = (tmpDirName `isSuffixOf`)++tmpDirName = ".liquid"++extFileNameR :: Ext -> FilePath -> FilePath+extFileNameR ext = (`addExtension` extMap ext)+ isExtFile :: Ext -> FilePath -> Bool-isExtFile ext = ((extMap ext) ==) . takeExtension+isExtFile ext = (extMap ext ==) . takeExtension extModuleName :: String -> Ext -> FilePath extModuleName modName ext = case explode modName of [] -> errorstar $ "malformed module name: " ++ modName- ws -> extFileName ext $ foldr1 (</>) ws- where explode = words . map (\c -> if c == '.' then ' ' else c)+ ws -> extFileNameR ext $ foldr1 (</>) ws+ where + explode = words . map (\c -> if c == '.' then ' ' else c) copyFiles :: [FilePath] -> FilePath -> IO () copyFiles srcs tgt@@ -119,9 +149,11 @@ ---------------------------------------------------------------------------------- -getHsTargets p- | hasTrailingPathSeparator p = getHsSourceFiles p- | otherwise = return [p]+getHsTargets p = mapM canonicalizePath =<< files+ where+ files+ | hasTrailingPathSeparator p = getHsSourceFiles p+ | otherwise = return [p] getHsSourceFiles = find dirs hs where hs = extension ==? ".hs" ||? extension ==? ".lhs"
src/Language/Fixpoint/Interface.hs view
@@ -58,9 +58,9 @@ (bids, benv) = foldlMap (\e (x,t) -> insertBindEnv x t e) emptyBindEnv binds validSubc :: a -> IBindEnv -> Pred -> SubC a -validSubc l env p = subC env PTrue lhs rhs i t l+validSubc l env p = safeHead "Interface.validSubC" $ subC env PTrue lhs rhs i t l where - lhs = top+ lhs = mempty rhs = RR mempty (predReft p) i = Just 0 t = []@@ -99,19 +99,25 @@ = 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+ ec <- {-# SCC "sysCall:Fixpoint" #-} executeShellCommand "fixpoint" $ fixCommand cfg fp z3 v rf return ec- -fixCommand cfg fp z3 verbosity - = printf "LD_LIBRARY_PATH=%s %s %s -notruekvars -refinesort -noslice -nosimple -strictsortcheck -sortedquals %s" - z3 fp verbosity (command cfg)+ where realFlags = "-no-uif-multiply " + ++ "-no-uif-divide "+ rf = if (real cfg) then realFlags else "" +fixCommand cfg fp z3 verbosity realFlags + = printf "LD_LIBRARY_PATH=%s %s %s %s -notruekvars -refinesort -nosimple -strictsortcheck -sortedquals %s" + z3 fp verbosity realFlags (command cfg)+ 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) = {-# SCC "parseFixOut" #-} rr ({-# SCC "sanitizeFixpointOutput" #-} sanitizeFixpointOutput str)+ let (x, y) = parseFixpointOutput str -- {-# SCC "parseFixOut" #-} rr ({-# SCC "sanitizeFixpointOutput" #-} sanitizeFixpointOutput str) return $ (plugC cm x, y) ++parseFixpointOutput :: String -> (FixResult Integer, FixSolution)+parseFixpointOutput str = {-# SCC "parseFixOut" #-} rr ({-# SCC "sanitizeFixpointOutput" #-} sanitizeFixpointOutput str) plugC = fmap . mlookup
src/Language/Fixpoint/Misc.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, TupleSections, NoMonomorphismRestriction, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} module Language.Fixpoint.Misc where @@ -8,9 +9,10 @@ import qualified Data.HashMap.Strict as M import qualified Data.List as L import qualified Data.ByteString as B+import qualified Data.Text as T import Data.ByteString.Char8 (pack, unpack) import Control.Applicative ((<$>))-import Control.Monad (forM_)+import Control.Monad (forM_, (>=>)) import Data.Maybe (fromJust) import Data.Maybe (catMaybes, fromMaybe) @@ -36,6 +38,9 @@ moodColor Angry = Red wrapStars msg = "\n**** " ++ msg ++ " " ++ replicate (74 - length msg) '*'++wrapStarsWithOptStars True msg = "\n**** " ++ msg ++ " " ++ replicate (74 - length msg) '*'+wrapStarsWithOptStars False msg = wrapStars msg withColor c act = do setSGR [ SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid c] @@ -47,11 +52,21 @@ startPhase c msg = colorPhaseLn c "START: " msg >> colorStrLn Ok " " doneLine c msg = colorPhaseLn c "DONE: " msg >> colorStrLn Ok " " +colorPhaseLnWithOptStars v c msg = colorStrLn c . wrapStarsWithOptStars v . (msg ++)+startPhaseWithOptStars v c msg = colorPhaseLnWithOptStars v c "START: " msg >> colorStrLn Ok " "+doneLineWithOptStars v c msg = colorPhaseLnWithOptStars v c "DONE: " msg >> colorStrLn Ok " "+ donePhase c str = case lines str of (l:ls) -> doneLine c l >> forM_ ls (colorPhaseLn c "") _ -> return () +donePhaseWithOptStars v c str + = case lines str of + (l:ls) -> doneLineWithOptStars v c l >> forM_ ls (colorPhaseLnWithOptStars v c "")+ _ -> return ()++ ----------------------------------------------------------------------------------- data Empty = Emp deriving (Data, Typeable, Eq, Show)@@ -69,7 +84,8 @@ repeats n = concat . replicate n errorstar = error . wrap (stars ++ "\n") (stars ++ "\n") - where stars = repeats 3 $ wrapStars "ERROR"+ where + stars = repeats 3 $ wrapStars "ERROR" errortext = errorstar . render @@ -90,7 +106,6 @@ thd3 :: (a, b, c) -> c thd3 (_,_,x) = x - single :: a -> [a] single x = [x] @@ -123,7 +138,7 @@ tryIgnore :: String -> IO () -> IO () tryIgnore s a = Ex.catch a $ \e -> do let err = show (e :: Ex.IOException)- putStrLn ("Warning: Couldn't do " ++ s ++ ": " ++ err)+ whenLoud $ putStrLn ("Warning: Couldn't do " ++ s ++ ": " ++ err) return () traceShow :: Show a => String -> a -> a@@ -135,6 +150,8 @@ -- inserts :: Hashable k => k -> v -> M.HashMap k [v] -> M.HashMap k [v] inserts k v m = M.insert k (v : M.lookupDefault [] k m) m +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 @@ -307,10 +324,10 @@ -- unions = foldl' S.union S.empty -- Just S.unions! -stripParens ('(':xs) = stripParens xs-stripParens xs = stripParens' (reverse xs)-stripParens' (')':xs) = stripParens' xs-stripParens' xs = reverse xs+stripParens :: T.Text -> T.Text+stripParens t = fromMaybe t (strip t)+ where+ strip = T.stripPrefix "(" >=> T.stripSuffix ")" ifM :: (Monad m) => m Bool -> m a -> m a -> m a ifM bm xm ym @@ -321,6 +338,10 @@ = do whenLoud $ putStrLn $ "EXEC: " ++ cmd Ex.bracket_ (startPhase Loud phase) (donePhase Loud phase) $ system cmd +executeShellCommandWithOptStars v phase cmd + = do whenLoud $ putStrLn $ "EXEC: " ++ cmd + Ex.bracket_ (startPhaseWithOptStars v Loud phase) (donePhaseWithOptStars v Loud phase) $ system cmd+ checkExitCode _ (ExitSuccess) = return () checkExitCode cmd (ExitFailure n) = errorstar $ "cmd: " ++ cmd ++ " failure code " ++ show n @@ -354,5 +375,13 @@ where (zs, res) = L.foldl' ff ([], b) xs ff (ys, acc) x = let (y, acc') = f acc x in (y:ys, acc')++mapEither :: (a -> Either b c) -> [a] -> ([b], [c])+mapEither f = go [] [] + where + go ls rs [] = (reverse ls, reverse rs)+ go ls rs (x:xs) = case f x of+ Left l -> go (l:ls) rs xs+ Right r -> go ls (r:rs) xs
src/Language/Fixpoint/Names.hs view
@@ -1,4 +1,12 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | This module contains Haskell variables representing globally visible names. -- Rather than have strings floating around the system, all constant names@@ -6,29 +14,230 @@ -- manipulated elsewhere. module Language.Fixpoint.Names (- ++ -- * Symbols+ Symbol+ , Symbolic (..)+ , anfPrefix, tempPrefix, vv, intKvar, isPrefixOfSym, isSuffixOfSym, stripParensSym+ , consSym, unconsSym, dropSym, singletonSym, headSym, takeWhileSym, lengthSym+ , symChars, isNonSymbol, nonSymbol+ , isNontrivialVV+ , symbolText, symbolString+ , encode, vvCon+ , dropModuleNames+ , takeModuleNames++ -- * Creating Symbols+ , dummySymbol, intSymbol, tempSymbol+ , qualifySymbol+ , suffixSymbol+ -- * Hardwired global names - dummyName+ , dummyName , preludeName , boolConName , funConName , listConName , tupConName , propConName+ , hpropConName , strConName , vvName , symSepName- , dropModuleNames - , takeModuleNames+ , prims ) where -import Data.List (intercalate)-import Language.Fixpoint.Misc (errorstar, safeLast, stripParens)+import GHC.Generics (Generic)+import Data.Char+import Data.String+import Data.Typeable (Typeable)+import Data.Generics (Data)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Monoid+import Data.Interned+import Data.Interned.Internal.Text+import Data.Interned.Text+import Data.Hashable+import qualified Data.HashSet as S+import Control.Applicative+import Control.DeepSeq +import Language.Fixpoint.Misc (errorstar, stripParens, mapSnd)++---------------------------------------------------------------+---------------------------- Symbols --------------------------+---------------------------------------------------------------++symChars+ = ['a' .. 'z']+ ++ ['A' .. 'Z']+ ++ ['0' .. '9']+ ++ ['_', '%', '.', '#']++deriving instance Data InternedText+deriving instance Typeable InternedText+deriving instance Generic InternedText++newtype Symbol = S InternedText deriving (Eq, Ord, Data, Typeable, Generic, IsString)++instance Monoid Symbol where+ mempty = ""+ mappend x y = S . intern $ mappend (symbolText x) (symbolText y)++instance Hashable InternedText where+ hashWithSalt s (InternedText i t) = hashWithSalt s i++instance NFData InternedText where+ rnf (InternedText id t) = rnf id `seq` rnf t `seq` ()++instance Show Symbol where+ show (S x) = show x++instance NFData Symbol where+ rnf (S x) = rnf x++instance Hashable Symbol where+ hashWithSalt i (S s) = hashWithSalt i s++symbolString :: Symbol -> String+symbolString = T.unpack . symbolText++---------------------------------------------------------------------------+------ Converting Strings To Fixpoint -------------------------------------+---------------------------------------------------------------------------++-- stringSymbolRaw :: String -> Symbol+-- stringSymbolRaw = S++encode :: String -> String+encode s+ | isFixKey s = encodeSym s+ | isFixSym' s = s+ | otherwise = encodeSym s -- S $ fixSymPrefix ++ concatMap encodeChar s++encodeSym s = fixSymPrefix ++ concatMap encodeChar s++symbolText :: Symbol -> Text+symbolText (S s) = unintern s++-- symbolString :: Symbol -> String+-- symbolString (S str)+-- = case chopPrefix fixSymPrefix str of+-- Just s -> concat $ zipWith tx indices $ chunks s+-- Nothing -> str+-- where+-- chunks = unIntersperse symSepName+-- tx i s = if even i then s else [decodeStr s]++indices :: [Integer]+indices = [0..]++okSymChars+ = S.fromList+ $ ['a' .. 'z']+ ++ ['A' .. 'Z']+ ++ ['0' .. '9']+ ++ ['_', '.' ]++fixSymPrefix = "fix" ++ [symSepName]++isPrefixOfSym (symbolText -> p) (symbolText -> x) = p `T.isPrefixOf` x+isSuffixOfSym (symbolText -> p) (symbolText -> x) = p `T.isSuffixOf` x+takeWhileSym p (symbolText -> t) = symbol $ T.takeWhile p t++headSym (symbolText -> t) = T.head t+consSym c (symbolText -> s) = symbol $ T.cons c s+singletonSym = (`consSym` "")++lengthSym (symbolText -> t) = T.length t++unconsSym :: Symbol -> Maybe (Char, Symbol)+unconsSym (symbolText -> s) = mapSnd symbol <$> T.uncons s++dropSym :: Int -> Symbol -> Symbol+dropSym n (symbolText -> t) = symbol $ T.drop n t++stripParensSym (symbolText -> t) = symbol $ stripParens t++suffixSymbol (S s) suf = symbol $ (unintern s) `mappend` suf++isFixSym' (c:chs) = isAlpha c && all (`S.member` (symSepName `S.insert` okSymChars)) chs+isFixSym' _ = False++isFixKey x = S.member x keywords+keywords = S.fromList ["env", "id", "tag", "qualif", "constant", "cut", "bind", "constraint", "grd", "lhs", "rhs"]++encodeChar c+ | c `S.member` okSymChars+ = [c]+ | otherwise+ = [symSepName] ++ (show $ ord c) ++ [symSepName]++decodeStr s+ = chr ((read s) :: Int)++qualifySymbol :: Symbol -> Symbol -> Symbol+qualifySymbol m'@(symbolText -> m) x'@(symbolText -> x)+ | isQualified x = x'+ | isParened x = symbol (wrapParens (m `mappend` "." `mappend` stripParens x))+ | otherwise = symbol (m `mappend` "." `mappend` x)++isQualified y = "." `T.isInfixOf` y+wrapParens x = "(" `mappend` x `mappend` ")"+isParened xs = xs /= stripParens xs++---------------------------------------------------------------------++vv :: Maybe Integer -> Symbol+vv (Just i) = symbol $ symbolText vvName `T.snoc` symSepName `mappend` T.pack (show i) -- S (vvName ++ [symSepName] ++ show i)+vv Nothing = vvName++vvCon = symbol $ symbolText vvName `T.snoc` symSepName `mappend` "F" -- S (vvName ++ [symSepName] ++ "F")++isNontrivialVV = not . (vv Nothing ==)+++dummySymbol = dummyName+intSymbol x i = x `mappend` symbol (show i)++tempSymbol :: Symbol -> Integer -> Symbol+tempSymbol prefix n = intSymbol (tempPrefix `mappend` prefix) n++tempPrefix, anfPrefix :: Symbol+tempPrefix = "lq_tmp_"+anfPrefix = "lq_anf_"++nonSymbol :: Symbol+nonSymbol = ""+isNonSymbol = (== nonSymbol)++intKvar :: Integer -> Symbol+intKvar = intSymbol "k_"++-- | Values that can be viewed as Symbols++class Symbolic a where+ symbol :: a -> Symbol++instance Symbolic String where+ symbol = symbol . T.pack++instance Symbolic Text where+ symbol = S . intern++instance Symbolic InternedText where+ symbol = S++instance Symbolic Symbol where+ symbol = id++ ---------------------------------------------------------------------------- --------------- Global Name Definitions ------------------------------------ ---------------------------------------------------------------------------- +preludeName, dummyName, boolConName, funConName, listConName, tupConName, propConName, strConName, vvName :: Symbol preludeName = "Prelude" dummyName = "_LIQUID_dummy" boolConName = "Bool"@@ -36,10 +245,28 @@ listConName = "[]" -- "List" tupConName = "()" -- "Tuple" propConName = "Prop"+hpropConName = "HProp" strConName = "Str" vvName = "VV" symSepName = '#' +prims :: [Symbol]+prims = [ propConName+ , hpropConName+ , vvName+ , "Pred"+ , "List"+ , "Set_Set"+ , "Set_sng"+ , "Set_cup"+ , "Set_cap"+ , "Set_dif"+ , "Set_emp"+ , "Set_mem"+ , "Set_sub"+ , "FAppTy" + ]+ -- dropModuleNames [] = [] -- dropModuleNames s -- | s == tupConName = tupConName @@ -52,14 +279,17 @@ dropModuleNames = mungeModuleNames safeLast "dropModuleNames: " takeModuleNames = mungeModuleNames safeInit "takeModuleNames: " -safeInit _ xs@(_:_) = intercalate "." $ init xs+safeInit :: String -> [T.Text] -> Symbol+safeInit _ xs@(_:_) = symbol $ T.intercalate "." $ init xs safeInit msg _ = errorstar $ "safeInit with empty list " ++ msg -mungeModuleNames _ _ [] = []-mungeModuleNames f msg s - | s == tupConName = tupConName - | otherwise = f (msg ++ s) $ words $ dotWhite `fmap` stripParens s- where - dotWhite '.' = ' '- dotWhite c = c+safeLast :: String -> [T.Text] -> Symbol+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)+ | s' == tupConName+ = tupConName+ | otherwise = f (msg ++ T.unpack s) $ T.splitOn "." $ stripParens s
src/Language/Fixpoint/Parse.hs view
@@ -13,10 +13,11 @@ -- * Some Important keyword and parsers , reserved, reservedOp- , parens , brackets+ , parens , brackets, angles, braces , semi , comma , colon , dcolon - , whiteSpace, blanks+ , whiteSpace+ , blanks -- * Parsing basic entities , fTyConP -- Type constructors@@ -25,15 +26,25 @@ , symbolP -- Arbitrary Symbols , constantP -- (Integer) Constants , integer -- Integer+ , bindP -- Binder (lowerIdP <* colon) -- * Parsing recursive entities , exprP -- Expressions , predP -- Refinement Predicates+ , funAppP -- Function Applications , qualifierP -- Qualifiers+ , refP -- (Sorted) Refinements+ , refDefP -- (Sorted) Refinements with default binder+ , refBindP -- (Sorted) Refinements with configurable sub-parsers -- * Some Combinators- , condIdP -- condIdP :: [Char] -> (String -> Bool) -> Parser String+ , condIdP -- condIdP :: [Char] -> (Text -> Bool) -> Parser Text + -- * Add a Location to a parsed value+ , locParserP+ , locLowerIdP+ , locUpperIdP+ -- * Getting a Fresh Integer while parsing , freshIntP @@ -47,19 +58,28 @@ import Control.Monad import Text.Parsec import Text.Parsec.Expr+import Text.Parsec.Pos import Text.Parsec.Language import Text.Parsec.String hiding (Parser, parseFromFile) import Text.Printf (printf) import qualified Text.Parsec.Token as Token import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import Data.Text (Text)+import qualified Data.Text as T import Data.Char (isLower, toUpper) import Language.Fixpoint.Misc hiding (dcolon) import Language.Fixpoint.Types-import Data.Maybe(maybe)+import Language.Fixpoint.Errors+import Language.Fixpoint.SmtLib2 -type Parser = Parsec String Integer +import Data.Maybe(maybe, fromJust) +import Data.Monoid (mempty)++type Parser = Parsec String Integer+ -------------------------------------------------------------------- languageDef =@@ -107,83 +127,146 @@ reservedOp = Token.reservedOp lexer parens = Token.parens lexer brackets = Token.brackets lexer+angles = Token.angles lexer semi = Token.semi lexer colon = Token.colon lexer comma = Token.comma lexer whiteSpace = Token.whiteSpace lexer stringLiteral = Token.stringLiteral lexer+braces = Token.braces lexer+double = Token.float lexer+-- integer = Token.integer lexer -- identifier = Token.identifier lexer blanks = many (satisfy (`elem` [' ', '\t'])) -integer = try (liftM toInt is) - <|> liftM (negate . toInt) (char '-' >> is)- where is = liftM2 (\is _ -> is) (many1 digit) blanks - toInt s = (read s) :: Integer +integer = posInteger + +-- try (char '-' >> (negate <$> posInteger))+-- <|> posInteger +posInteger = toI <$> (many1 digit <* spaces)+ where+ toI :: String -> Integer + toI = read+ ---------------------------------------------------------------- ------------------------- Expressions -------------------------- ---------------------------------------------------------------- -condIdP :: [Char] -> (String -> Bool) -> Parser String+locParserP :: Parser a -> Parser (Located a)+locParserP p = liftM2 Loc getPosition p++condIdP :: [Char] -> (String -> Bool) -> Parser Symbol condIdP chars f = do c <- letter cs <- many (satisfy (`elem` chars)) blanks- if f (c:cs) then return (c:cs) else parserZero+ if f (c:cs) then return (symbol $ T.pack $ c:cs) else parserZero -upperIdP :: Parser String+upperIdP :: Parser Symbol upperIdP = condIdP symChars (not . isLower . head) -lowerIdP :: Parser String+lowerIdP :: Parser Symbol lowerIdP = condIdP symChars (isLower . head) +locLowerIdP = locParserP lowerIdP +locUpperIdP = locParserP upperIdP+ symbolP :: Parser Symbol-symbolP = liftM stringSymbol symCharsP +symbolP = symbol <$> symCharsP constantP :: Parser Constant-constantP = liftM I integer+constantP = try (liftM R double) <|> liftM I integer symconstP :: Parser SymConst-symconstP = SL <$> stringLiteral --exprP :: Parser Expr -exprP = expr2P <|> lexprP+symconstP = SL . T.pack <$> stringLiteral -lexprP :: Parser Expr -lexprP - = try (parens exprP)- <|> try (parens exprCastP)- <|> try (parens $ condP EIte exprP)- <|> try exprFunP- <|> try (liftM (EVar . stringSymbol) upperIdP)- <|> liftM expr symbolP - <|> liftM ECon constantP- <|> liftM ESym symconstP+expr0P :: Parser Expr+expr0P + = (fastIfP EIte exprP)+ <|> (ESym <$> symconstP)+ <|> (ECon <$> constantP) <|> (reserved "_|_" >> return EBot)+ <|> try (parens exprP)+ <|> try (parens exprCastP)+ <|> (charsExpr <$> symCharsP) -exprFunP = (try exprFunSpacesP) <|> (try exprFunSemisP) <|> exprFunCommasP+charsExpr cs+ | isLower (T.head t) = expr cs+ | otherwise = EVar cs+ where t = symbolText cs+-- <|> try (parens $ condP EIte exprP)++fastIfP f bodyP + = do reserved "if" + p <- predP+ reserved "then"+ b1 <- bodyP + reserved "else"+ b2 <- bodyP + return $ f p b1 b2+++expr1P :: Parser Expr+expr1P + = try funAppP + <|> expr0P ++exprP :: Parser Expr +exprP = buildExpressionParser bops expr1P++funAppP = (try exprFunSpacesP) <|> (try exprFunSemisP) <|> exprFunCommasP where - exprFunSpacesP = parens $ liftM2 EApp funSymbolP (sepBy exprP spaces) + exprFunSpacesP = liftM2 EApp funSymbolP (sepBy1 expr0P spaces) exprFunCommasP = liftM2 EApp funSymbolP (parens $ sepBy exprP comma) exprFunSemisP = liftM2 EApp funSymbolP (parenBrackets $ sepBy exprP semi)- funSymbolP = symbolP -- liftM stringSymbol lowerIdP+ funSymbolP = locParserP symbolP +++-- ORIG exprP :: Parser Expr +-- ORIG exprP = expr2P <|> lexprP+-- +-- ORIG lexprP :: Parser Expr +-- ORIG lexprP +-- ORIG = try (parens exprP)+-- ORIG <|> try (parens exprCastP)+-- ORIG <|> try (parens $ condP EIte exprP)+-- ORIG <|> try exprFunP+-- ORIG <|> try (liftM (EVar . stringSymbol) upperIdP)+-- ORIG <|> liftM expr symbolP +-- ORIG <|> liftM ECon constantP+-- ORIG <|> liftM ESym symconstP+-- ORIG <|> (reserved "_|_" >> return EBot)+-- ORIG +-- ORIG exprFunP = (try exprFunSpacesP) <|> (try exprFunSemisP) <|> exprFunCommasP+-- ORIG where +-- ORIG exprFunSpacesP = parens $ liftM2 EApp funSymbolP (sepBy exprP spaces) +-- ORIG exprFunCommasP = liftM2 EApp funSymbolP (parens $ sepBy exprP comma)+-- ORIG exprFunSemisP = liftM2 EApp funSymbolP (parenBrackets $ sepBy exprP semi)+-- ORIG funSymbolP = locParserP symbolP -- liftM stringSymbol lowerIdP+ parenBrackets = parens . brackets -expr2P = buildExpressionParser bops lexprP+-- ORIG expr2P = buildExpressionParser bops lexprP -bops = [ [Infix (reservedOp "*" >> return (EBin Times)) AssocLeft]- , [Infix (reservedOp "/" >> return (EBin Div )) AssocLeft]- , [Infix (reservedOp "+" >> return (EBin Plus )) AssocLeft]- , [Infix (reservedOp "-" >> return (EBin Minus)) AssocLeft]- , [Infix (reservedOp "mod" >> return (EBin Mod )) AssocLeft]+bops = [ [ Prefix (reservedOp "-" >> return eMinus)]+ , [ Infix (reservedOp "*" >> return (EBin Times)) AssocLeft+ , Infix (reservedOp "/" >> return (EBin Div )) AssocLeft+ ]+ , [ Infix (reservedOp "-" >> return (EBin Minus)) AssocLeft+ , Infix (reservedOp "+" >> return (EBin Plus )) AssocLeft+ ]+ , [Infix (reservedOp "mod" >> return (EBin Mod )) AssocLeft] ] +eMinus = EBin Minus (expr (0 :: Integer)) + exprCastP = do e <- exprP ((try dcolon) <|> colon)@@ -196,54 +279,69 @@ = try (string "Integer" >> return FInt) <|> try (string "Int" >> return FInt) <|> try (string "int" >> return FInt)- <|> try (FObj . stringSymbol <$> lowerIdP)- <|> (FApp <$> fTyConP <*> many sortP )+ <|> try (FObj . symbol <$> lowerIdP)+ <|> (fApp <$> (Left <$> fTyConP) <*> many sortP) -symCharsP = (condIdP symChars (\_ -> True))+symCharsP = condIdP symChars (`notElem` keyWordSyms) +keyWordSyms = ["if", "then", "else", "mod"]+ --------------------------------------------------------------------- -------------------------- Predicates ------------------------------- --------------------------------------------------------------------- -predP :: Parser Pred-predP = try (parens pred2P)- <|> try (parens $ condP pIte predP)- <|> try (reservedOp "not" >> liftM PNot predP)- <|> try (reservedOp "&&" >> liftM PAnd predsP)- <|> try (reservedOp "||" >> liftM POr predsP)- <|> (qmP >> liftM PBexp exprP)- <|> (reserved "true" >> return PTrue)- <|> (reserved "false" >> return PFalse)- <|> (try predrP)- <|> (try (liftM PBexp exprFunP))+trueP = reserved "true" >> return PTrue+falseP = reserved "false" >> return PFalse -qmP = reserved "?" <|> reserved "Bexp"+pred0P :: Parser Pred+pred0P = trueP + <|> falseP + <|> try (fastIfP pIte predP)+ <|> try predrP + <|> try (parens predP)+ <|> try (liftM PBexp funAppP)+ <|> try (reservedOp "&&" >> liftM PAnd predsP)+ <|> try (reservedOp "||" >> liftM POr predsP) -pred2P = buildExpressionParser lops predP +predP :: Parser Pred+predP = buildExpressionParser lops pred0P + predsP = brackets $ sepBy predP semi -lops = [ [Prefix (reservedOp "~" >> return PNot)]- , [Infix (reservedOp "&&" >> return (\x y -> PAnd [x,y])) AssocRight]- , [Infix (reservedOp "||" >> return (\x y -> POr [x,y])) AssocRight]- , [Infix (reservedOp "=>" >> return PImp) AssocRight]- , [Infix (reservedOp "<=>" >> return PIff) AssocRight]]+qmP = reserved "?" <|> reserved "Bexp"++lops = [ [Prefix (reservedOp "~" >> return PNot)]+ , [Prefix (reservedOp "not " >> return PNot)]+ , [Infix (reservedOp "&&" >> return (\x y -> PAnd [x,y])) AssocRight]+ , [Infix (reservedOp "||" >> return (\x y -> POr [x,y])) AssocRight]+ , [Infix (reservedOp "=>" >> return PImp) AssocRight]+ , [Infix (reservedOp "<=>" >> return PIff) AssocRight]] -predrP = do e1 <- expr2P+predrP = do e1 <- exprP r <- brelP- e2 <- expr2P + e2 <- exprP return $ r e1 e2 brelP :: Parser (Expr -> Expr -> Pred) brelP = (reservedOp "==" >> return (PAtom Eq)) <|> (reservedOp "=" >> return (PAtom Eq))+ <|> (reservedOp "~~" >> return (PAtom Ueq)) <|> (reservedOp "!=" >> return (PAtom Ne)) <|> (reservedOp "/=" >> return (PAtom Ne))+ <|> (reservedOp "!~" >> return (PAtom Une)) <|> (reservedOp "<" >> return (PAtom Lt)) <|> (reservedOp "<=" >> return (PAtom Le)) <|> (reservedOp ">" >> return (PAtom Gt)) <|> (reservedOp ">=" >> return (PAtom Ge)) +condP f bodyP + = try (condIteP f bodyP)+ <|> (condQmP f bodyP)++condI = condIteP EIte ++ condIteP f bodyP = do reserved "if" p <- predP@@ -261,10 +359,6 @@ b2 <- bodyP return $ f p b1 b2 -condP f bodyP - = try (condIteP f bodyP)- <|> (condQmP f bodyP)- ---------------------------------------------------------------------------------- ------------------------------------ BareTypes ----------------------------------- ----------------------------------------------------------------------------------@@ -272,39 +366,119 @@ fTyConP = (reserved "int" >> return intFTyCon) <|> (reserved "bool" >> return boolFTyCon)- <|> (stringFTycon <$> upperIdP)+ <|> (reserved "real" >> return realFTyCon)+ <|> (symbolFTycon <$> locUpperIdP) refasP :: Parser [Refa] refasP = (try (brackets $ sepBy (RConc <$> predP) semi)) <|> liftM ((:[]) . RConc) predP +refBindP :: Parser Symbol -> Parser [Refa] -> Parser (Reft -> a) -> Parser a+refBindP bp rp kindP+ = braces $ do+ vv <- bp+ t <- kindP+ reserved "|"+ ras <- rp <* spaces+ return $ t (Reft (vv, ras))++bindP = liftM symbol (lowerIdP <* colon)+optBindP vv = try bindP <|> return vv++refP = refBindP bindP refasP+refDefP vv = refBindP (optBindP vv)+ --------------------------------------------------------------------- -- | Parsing Qualifiers --------------------------------------------- --------------------------------------------------------------------- -- qualifierP = mkQual <$> upperIdP <*> parens $ sepBy1 sortBindP comma <*> predP -qualifierP = do n <- upperIdP +qualifierP = do pos <- getPosition + n <- upperIdP params <- parens $ sepBy1 sortBindP comma _ <- colon body <- predP- return $ mkQual n params body+ return $ mkQual n params body pos sortBindP = (,) <$> symbolP <* colon <*> sortP -mkQual n xts p = Q n ((vv, t) : yts) (subst su p)+mkQual n xts p pos = Q n ((vv, t) : yts) (subst su p) pos where - (vv,t):zts = xts- yts = mapFst mkParam <$> zts- su = mkSubst $ zipWith (\(z,_) (y,_) -> (z, eVar y)) zts yts + (vv,t):zts = xts+ yts = mapFst mkParam <$> zts+ su = mkSubst $ zipWith (\(z,_) (y,_) -> (z, eVar y)) zts yts -mkParam s = stringSymbolRaw ('~' : toUpper c : cs) +mkParam s = symbol ('~' `T.cons` toUpper c `T.cons` cs) where - (c:cs) = symbolString s + Just (c,cs)= T.uncons $ symbolText s +---------------------------------------------------------------------+-- | Parsing Constraints (.fq files) --------------------------------+--------------------------------------------------------------------- +fInfoP :: Parser (FInfo ())+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)++sortedReftP :: Parser SortedReft+sortedReftP = refP (RR <$> (sortP <* spaces)) ++wfCP :: Parser (WfC ())+wfCP = do reserved "env"+ env <- envP+ reserved "reft"+ r <- sortedReftP+ return $ wfC env r Nothing ()++subCP :: Parser (SubC ())+subCP = do reserved "env" + env <- envP + reserved "grd"+ grd <- predP+ reserved "lhs"+ lhs <- sortedReftP + reserved "rhs"+ rhs <- sortedReftP + reserved "id"+ i <- (integer <* spaces)+ tag <- tagP+ return $ safeHead "subCP" $ subC env grd lhs rhs (Just i) tag () ++tagP :: Parser [Int]+tagP = try (reserved "tag" >> spaces >> (brackets $ sepBy intP semi))+ <|> (return [])++envP :: Parser IBindEnv+envP = do binds <- brackets $ sepBy (intP <* spaces) semi + return $ insertsIBindEnv binds emptyIBindEnv++intP :: Parser Int+intP = fromInteger <$> integer++defsFInfo :: [Def a] -> FInfo a+defsFInfo defs = FI cm ws bs gs lts kts qs+ 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]+ 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] + qs = [q | Qul q <- defs]+ cid = fromJust . sid+ notFun = not . isFunctionSortedReft . (`RR` trueReft) ---------------------------------------------------------------------------------- Interacting with Fixpoint ------------------------------+-- | Interacting with Fixpoint -------------------------------------- --------------------------------------------------------------------- fixResultP :: Parser a -> Parser (FixResult a)@@ -313,8 +487,6 @@ <|> (reserved "UNSAT" >> Unsafe <$> (brackets $ sepBy pp comma)) <|> (reserved "CRASH" >> crashP pp) -- crashP pp = do i <- pp msg <- many anyChar@@ -346,17 +518,16 @@ remainderP p = do res <- p str <- stateInput <$> getParserState- return (res, str) + pos <- getPosition + return (res, str, pos) doParse' parser f s- = case runParser (remainderP p) 0 f s of- Left e -> errorstar $ printf "parseError %s\n when parsing from %s\n" - (show e) f - Right (r, "") -> r- Right (_, rem) -> errorstar $ printf "doParse has leftover when parsing: %s\nfrom file %s\n"- rem f- where p = whiteSpace >> parser-+ = 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+ +errorSpan e = SS l l where l = errorPos e parseFromFile :: Parser b -> SourceName -> IO b parseFromFile p f = doParse' p f <$> readFile f@@ -366,10 +537,30 @@ updateState (+ 1) return n ------------------------------------------------------------------------------------------------------------------ Bundling Parsers into a Typeclass ----------------------------------------------------------------------------------------------------------------------+---------------------------------------------------------------------+-- Standalone SMTLIB2 commands --------------------------------------+--------------------------------------------------------------------- +commandsP = sepBy commandP semi++commandP + = (reserved "var" >> cmdVarP)+ <|> (reserved "push" >> return Push)+ <|> (reserved "pop" >> return Pop)+ <|> (reserved "check" >> return CheckSat)+ <|> (reserved "assert" >> (Assert Nothing <$> predP))+ <|> (reserved "distinct" >> (Distinct <$> (brackets $ sepBy exprP comma)))++cmdVarP + = do x <- bindP + t <- sortP+ return $ Declare x [] t+++---------------------------------------------------------------------+-- Bundling Parsers into a Typeclass --------------------------------+---------------------------------------------------------------------+ class Inputable a where rr :: String -> a rr' :: String -> String -> a@@ -397,10 +588,31 @@ instance Inputable (FixResult Integer, FixSolution) where rr' = doParse' solutionFileP +instance Inputable (FInfo ()) where+ rr' = doParse' fInfoP++instance Inputable Command where+ rr' = doParse' commandP ++instance Inputable [Command] where+ rr' = doParse' commandsP+ {- --------------------------------------------------------------- --------------------------- Testing --------------------------- ---------------------------------------------------------------++-- A few tricky predicates for parsing+-- myTest1 = "((((v >= 56320) && (v <= 57343)) => (((numchars a o ((i - o) + 1)) == (1 + (numchars a o ((i - o) - 1)))) && (((numchars a o (i - (o -1))) >= 0) && (((i - o) - 1) >= 0)))) && ((not (((v >= 56320) && (v <= 57343)))) => (((numchars a o ((i - o) + 1)) == (1 + (numchars a o (i - o)))) && ((numchars a o (i - o)) >= 0))))"+-- +-- myTest2 = "len x = len y - 1"+-- myTest3 = "len x y z = len a b c - 1"+-- myTest4 = "len x y z = len a b (c - 1)"+-- myTest5 = "x >= -1"+-- myTest6 = "(bLength v) = if n > 0 then n else 0"+-- myTest7 = "(bLength v) = (if n > 0 then n else 0)"+-- myTest8 = "(bLength v) = (n > 0 ? n : 0)"+ sa = "0" sb = "x"
src/Language/Fixpoint/PrettyPrint.hs view
@@ -9,6 +9,7 @@ import Language.Fixpoint.Misc import Control.Applicative ((<$>)) import Text.Parsec+import qualified Data.Text as T class PPrint a where pprint :: a -> Doc@@ -62,7 +63,7 @@ pprint = toFix instance PPrint SymConst where- pprint (SL x) = doubleQuotes $ text x+ pprint (SL x) = doubleQuotes $ text $ T.unpack x instance PPrint Expr where pprint (EApp f es) = parens $ intersperse empty $ (pprint f) : (pprint <$> es) @@ -96,10 +97,6 @@ pprintBin b _ [] = b pprintBin _ o xs = intersperse o $ pprint <$> xs -pprintBin b o [] = b-pprintBin b o [x] = pprint x-pprintBin b o (x:xs) = pprint x <+> o <+> pprintBin b o xs - instance PPrint Refa where pprint (RConc p) = pprint p pprint k = toFix k@@ -116,7 +113,8 @@ = braces $ (pprint v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> pprint ras -+instance PPrint a => PPrint (Located a) where+ pprint (Loc _ x) = pprint x
+ src/Language/Fixpoint/SmtLib2.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}++-- | This module contains an SMTLIB2 interface for+-- 1. checking the validity, and,+-- 2. computing satisfying assignments+-- for formulas.+-- By implementing a binary interface over the SMTLIB2 format defined at+-- http://www.smt-lib.org/+-- http://www.grammatech.com/resource/smt/SMTLIBTutorial.pdf++module Language.Fixpoint.SmtLib2 (++ -- * Commands+ Command (..)++ -- * Responses+ , Response (..)++ -- * Typeclass for SMTLIB2 conversion+ , SMTLIB2 (..)++ -- * Creating and killing SMTLIB2 Process+ , Context (..)+ , makeContext+ , cleanupContext++ -- * Execute Queries+ , command+ , smtWrite++ , smt_set_funs+ ) where++import Language.Fixpoint.Config (SMTSolver (..))+import Language.Fixpoint.Files+import Language.Fixpoint.Types++import Control.Arrow+import Control.Monad+import Control.Monad.IO.Class+import Data.Char+import qualified Data.List as L+import qualified Data.HashMap.Strict as M+import Data.Monoid+import Data.Text.Format+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.IO as LTIO+import System.Directory+import System.Exit+import System.FilePath+import System.Process+import System.IO (openFile, IOMode (..), Handle, hFlush, hClose, hReady)+import Control.Applicative ((<$>), (<|>), (*>), (<*))++import Text.Parsec.Text.Lazy ()+import Text.Parsec.Char+import Text.Parsec.Combinator+import Text.Parsec.Prim (ParsecT, runPT, getState, setInput, try)+import qualified Data.Attoparsec.Text as A++{- Usage:+runFile f+ = readFile f >>= runString++runString str+ = runCommands $ rr str++runCommands cmds+ = do me <- makeContext Z3+ mapM_ (T.putStrLn . smt2) cmds+ zs <- mapM (command me) cmds+ return zs+-}++--------------------------------------------------------------------------+-- | Types ---------------------------------------------------------------+--------------------------------------------------------------------------++type Raw = T.Text++-- | Commands issued to SMT engine+data Command = Push+ | Pop+ | CheckSat+ | Declare Symbol [Sort] Sort+ | Define Sort+ | Assert (Maybe Int) Pred+ | Distinct [Expr] -- {v:[Expr] | (len v) >= 2}+ | GetValue [Symbol]+ deriving (Eq, Show)++-- | Responses received from SMT engine+data Response = Ok+ | Sat+ | Unsat+ | Unknown+ | Values [(Symbol, Raw)]+ | Error Raw+ deriving (Eq, Show)++-- | Information about the external SMT process+data Context = Ctx { pId :: ProcessHandle+ , cIn :: Handle+ , cOut :: Handle+ , cLog :: Handle+ , verbose :: Bool+ }++--------------------------------------------------------------------------+-- | SMT IO --------------------------------------------------------------+--------------------------------------------------------------------------++--------------------------------------------------------------------------+-- commands :: Context -> [Command] -> IO [Response]+-- -----------------------------------------------------------------------+-- commands = mapM . command++--------------------------------------------------------------------------+command :: Context -> Command -> IO Response+--------------------------------------------------------------------------+command me !cmd = {-# SCC command #-} say me cmd >> hear me cmd+ where+ say me = smtWrite me . smt2+ hear me CheckSat = smtRead me+ hear me (GetValue _) = smtRead me+ hear me _ = return Ok++++smtWrite :: Context -> LT.Text -> IO ()+smtWrite me !s = smtWriteRaw me s++smtRead :: Context -> IO Response+smtRead me = {-# SCC smtRead #-}+ do ln <- smtReadRaw me+ res <- A.parseWith (smtReadRaw me) responseP ln+ case A.eitherResult res of+ Left e -> error e+ Right r -> do+ hPutStrLnNow (cLog me) $ format "; SMT Says: {}" (Only $ show r)+ when (verbose me) $+ LTIO.putStrLn $ format "SMT Says: {}" (Only $ show r)+ return r++responseP = {-# SCC responseP #-} A.char '(' *> sexpP+ <|> A.string "sat" *> return Sat+ <|> A.string "unsat" *> return Unsat+ <|> A.string "unknown" *> return Unknown++sexpP = {-# SCC sexpP #-} A.string "error" *> (Error <$> errorP)+ <|> Values <$> valuesP++errorP = A.skipSpace *> A.char '"' *> A.takeWhile1 (/='"') <* A.string "\")"++valuesP = A.many1' pairP <* (A.char ')')++pairP = {-# SCC pairP #-}+ do A.skipSpace+ A.char '('+ !x <- symbolP+ A.skipSpace+ !v <- valueP+ A.char ')'+ return (x,v)++symbolP = {-# SCC symbolP #-} symbol <$> A.takeWhile1 (not . isSpace)++valueP = {-# SCC valueP #-} negativeP+ <|> A.takeWhile1 (\c -> not (c == ')' || isSpace c))++negativeP+ = do v <- A.char '(' *> A.takeWhile1 (/=')') <* A.char ')'+ return $ "(" <> v <> ")"++{-@ pairs :: {v:[a] | (len v) mod 2 = 0} -> [(a,a)] @-}+pairs :: [a] -> [(a,a)]+pairs !xs = case L.splitAt 2 xs of+ ([],b) -> []+ ((x:y:[]),zs) -> (x,y) : pairs zs++smtWriteRaw :: Context -> LT.Text -> IO ()+smtWriteRaw me !s = {-# SCC smtWriteRaw #-} hPutStrLnNow (cOut me) s >> hPutStrLnNow (cLog me) s++smtReadRaw :: Context -> IO Raw+smtReadRaw me = {-# SCC smtReadRaw #-} TIO.hGetLine (cIn me)++hPutStrLnNow h !s = LTIO.hPutStrLn h s >> hFlush h++--------------------------------------------------------------------------+-- | SMT Context ---------------------------------------------------------+--------------------------------------------------------------------------++--------------------------------------------------------------------------+makeContext :: SMTSolver -> IO Context+--------------------------------------------------------------------------+makeContext s+ = do me <- makeProcess s+ mapM_ (smtWrite me) $ smtPreamble s+ return me++makeProcess s+ = do (hOut, hIn, _ ,pid) <- runInteractiveCommand $ smtCmd s+ createDirectoryIfMissing True $ takeDirectory smtFile+ hLog <- openFile smtFile WriteMode+ return $ Ctx pid hIn hOut hLog False++--------------------------------------------------------------------------+cleanupContext :: Context -> IO ExitCode+--------------------------------------------------------------------------+cleanupContext me@(Ctx {..})+ = do smtWrite me "(exit)"+ code <- waitForProcess pId+ hClose cIn+ hClose cOut+ hClose cLog+ return code++{- "z3 -smt2 -in" -}+{- "z3 -smtc SOFT_TIMEOUT=1000 -in" -}+{- "z3 -smtc -in MBQI=false" -}++-- ERIC: Do we really need to set mbqi to false? It seems useful for generating test data+smtCmd Z3 = "z3 -smt2 -in MODEL=true MODEL.PARTIAL=true auto-config=false"+smtCmd Mathsat = "mathsat -input=smt2"+smtCmd Cvc4 = "cvc4 --incremental -L smtlib2"++smtPreamble Z3 = z3Preamble+smtPreamble _ = 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)+smtAssert me p = interact' me (Assert Nothing p)+smtDistinct me az = interact' me (Distinct az)+smtCheckUnsat me = respSat <$> command me CheckSat++respSat Unsat = True+respSat Sat = False+respSat Unknown = False+respSat r = error "crash: SMTLIB2 respSat"++interact' me cmd = command me cmd >> return ()+++--------------------------------------------------------------------------+-- | Set Theory ----------------------------------------------------------+--------------------------------------------------------------------------++elt, set :: Raw+elt = "Elt"+set = "Set"++emp, add, cup, cap, mem, dif, sub, com :: Raw+emp = "smt_set_emp"+add = "smt_set_add"+cup = "smt_set_cup"+cap = "smt_set_cap"+mem = "smt_set_mem"+dif = "smt_set_dif"+sub = "smt_set_sub"+com = "smt_set_com"++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)]++z3Preamble+ = [ format "(define-sort {} () Int)"+ (Only elt)+ , format "(define-sort {} () (Array {} Bool))"+ (set, elt)+ , format "(define-fun {} () {} ((as const {}) false))"+ (emp, set, set)+ , format "(define-fun {} ((x {}) (s {})) Bool (select s x))"+ (mem, elt, set)+ , format "(define-fun {} ((s {}) (x {})) {} (store s x true))"+ (add, set, elt, set)+ , format "(define-fun {} ((s1 {}) (s2 {})) {} ((_ map or) s1 s2))"+ (cup, set, set, set)+ , format "(define-fun {} ((s1 {}) (s2 {})) {} ((_ map and) s1 s2))"+ (cap, set, set, set)+ , format "(define-fun {} ((s {})) {} ((_ map not) s))"+ (com, set, set)+ , format "(define-fun {} ((s1 {}) (s2 {})) {} ({} s1 ({} s2)))"+ (dif, set, set, set, cap, com)+ , format "(define-fun {} ((s1 {}) (s2 {})) Bool (= {} ({} s1 s2)))"+ (sub, set, set, emp, dif)+ ]++smtlibPreamble+ = [ "(set-logic QF_UFLIA)"+ , format "(define-sort {} () Int)" (Only elt)+ , format "(define-sort {} () Int)" (Only set)+ , format "(declare-fun {} () {})" (emp, set)+ , format "(declare-fun {} ({} {}) {})" (add, set, elt, set)+ , format "(declare-fun {} ({} {}) {})" (cup, set, set, set)+ , format "(declare-fun {} ({} {}) {})" (cap, set, set, set)+ , format "(declare-fun {} ({} {}) {})" (dif, set, set, set)+ , format "(declare-fun {} ({} {}) Bool)" (sub, set, set)+ , format "(declare-fun {} ({} {}) Bool)" (mem, elt, set)+ ]++mkSetSort _ _ = set+mkEmptySet _ _ = emp+mkSetAdd _ s x = format "({} {} {})" (add, s, x)+mkSetMem _ x s = format "({} {} {})" (mem, x, s)+mkSetCup _ s t = format "({} {} {})" (cup, s, t)+mkSetCap _ s t = format "({} {} {})" (cap, s, t)+mkSetDif _ s t = format "({} {} {})" (dif, s, t)+mkSetSub _ s t = format "({} {} {})" (sub, s, t)++-----------------------------------------------------------------------+-- | AST Conversion ---------------------------------------------------+-----------------------------------------------------------------------++-- | Types that can be serialized+class SMTLIB2 a where+ smt2 :: a -> LT.Text++instance SMTLIB2 Sort where+ smt2 FInt = "Int"+ 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 _ = "Int"++instance SMTLIB2 Symbol where+ smt2 s | Just t <- M.lookup s smt_set_funs+ = LT.fromStrict t+ smt2 s = LT.fromStrict . encode . symbolText $ s++-- FIXME: this is probably too slow+encode :: T.Text -> T.Text+encode t = {-# SCC encode #-}+ foldr (\(x,y) t -> T.replace x y t) t [("[", "ZM"), ("]", "ZN"), (":", "ZC")+ ,("(", "ZL"), (")", "ZR"), (",", "ZT")+ ,("|", "zb"), ("#", "zh"), ("\\","zr")+ ,("z", "zz"), ("Z", "ZZ")]++instance SMTLIB2 SymConst where+ smt2 (SL s) = LT.fromStrict s++instance SMTLIB2 Constant where+ smt2 (I n) = format "{}" (Only n)++instance SMTLIB2 LocSymbol where+ smt2 = smt2 . val++instance SMTLIB2 Bop where+ smt2 Plus = "+"+ smt2 Minus = "-"+ smt2 Times = "*"+ smt2 Div = "/"+ smt2 Mod = "mod"++instance SMTLIB2 Brel where+ smt2 Eq = "="+ smt2 Ueq = "="+ smt2 Gt = ">"+ smt2 Ge = ">="+ smt2 Lt = "<"+ smt2 Le = "<="+ smt2 _ = error "SMTLIB2 Brel"++instance SMTLIB2 Expr where+ smt2 (ESym z) = smt2 z+ 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 (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"++instance SMTLIB2 Pred where+ smt2 (PTrue) = "true"+ smt2 (PFalse) = "false"+ smt2 (PAnd ps) = format "(and {})" (Only $ smt2s ps)+ 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)+ smt2 (PIff p q) = format "(= {} {})" (smt2 p, smt2 q)+ smt2 (PBexp e) = smt2 e+ smt2 (PAtom r e1 e2) = mkRel r e1 e2+ smt2 _ = error "smtlib2 Pred"+++mkRel Ne e1 e2 = mkNe e1 e2+mkRel Une e1 e2 = mkNe e1 e2+mkRel r e1 e2 = format "({} {} {})" (smt2 r, smt2 e1, smt2 e2)+mkNe e1 e2 = format "(not (= {} {}))" (smt2 e1, smt2 e2)++instance SMTLIB2 Command where+ smt2 (Declare x ts t) = format "(declare-fun {} ({}) {})" (smt2 x, smt2s ts, smt2 t)+ smt2 (Define t) = format "(declare-sort {})" (Only $ smt2 t)+ smt2 (Assert Nothing p) = format "(assert {})" (Only $ smt2 p)+ smt2 (Assert (Just i) p) = format "(assert (! {} :named p-{}))" (smt2 p, i)+ smt2 (Distinct az) = format "(assert (distinct {}))" (Only $ smt2s az)+ smt2 (Push) = "(push 1)"+ smt2 (Pop) = "(pop 1)"+ smt2 (CheckSat) = "(check-sat)"+ smt2 (GetValue xs) = LT.unwords $ ["(get-value ("] ++ map smt2 xs ++ ["))"]++smt2s = LT.intercalate " " . fmap smt2++{-+(declare-fun x () Int)+(declare-fun y () Int)+(assert (<= 0 x))+(assert (< x y))+(push 1)+(assert (not (<= 0 y)))+(check-sat)+(pop 1)+(push 1)+(assert (<= 0 y))+(check-sat)+(pop 1)+-}
src/Language/Fixpoint/Sort.hs view
@@ -7,6 +7,7 @@ checkSorted , checkSortedReft , checkSortedReftFull+ , checkSortFull , pruneUnsortedReft ) where @@ -50,6 +51,14 @@ where γ' = mapSEnv sr_sort γ +checkSortFull :: Checkable a => SEnv SortedReft -> Sort -> a -> Maybe Doc+checkSortFull γ s t+ = case checkSort γ' s t of+ Left err -> Just (text err)+ Right _ -> Nothing+ where + γ' = mapSEnv sr_sort γ + checkSorted :: Checkable a => SEnv Sort -> a -> Maybe Doc checkSorted γ t = case check γ t of@@ -73,8 +82,11 @@ class Checkable a where- check :: SEnv Sort -> a -> CheckM ()+ check :: SEnv Sort -> a -> CheckM ()+ checkSort :: SEnv Sort -> Sort -> a -> CheckM () + checkSort γ _ = check γ+ instance Checkable Refa where check γ = checkRefa (`lookupSEnvWithDistance` γ) @@ -82,6 +94,17 @@ check γ e = do {checkExpr f e; return ()} where f = (`lookupSEnvWithDistance` γ) + checkSort γ s e = do {t <- checkExpr f e; checkEqSort s t}+ where f = (`lookupSEnvWithDistance` γ)+++checkEqSort s t+ | s == t = return ()+ | otherwise = throwError $ "Couldn't match expected type '" + ++ show s ++ "'"+ ++ "\n\t\t with actual type '" + ++ show t ++ "'"+ instance Checkable Pred where check γ = checkPred f where f = (`lookupSEnvWithDistance` γ)@@ -97,7 +120,8 @@ checkExpr :: Env -> Expr -> CheckM Sort checkExpr _ EBot = throwError "Type Error: Bot"-checkExpr _ (ECon _) = return FInt +checkExpr _ (ECon (I _)) = return FInt +checkExpr _ (ECon (R _)) = return FReal checkExpr f (EVar x) = checkSym f x checkExpr f (EBin o e1 e2) = checkOp f e1 o e2 checkExpr f (EIte p e1 e2) = checkIte f p e1 e2@@ -113,6 +137,8 @@ Alts xs -> throwError $ errUnboundAlts x xs -- $ traceFix ("checkSym: x = " ++ showFix x) (f x) +checkLocSym f x = checkSym f (val x)+ -- | Helper for checking if-then-else expressions checkIte f p e1 e2 @@ -136,7 +162,7 @@ -- | Helper for checking uninterpreted function applications checkApp' f to g es - = do gt <- checkSym f g+ = do gt <- checkLocSym f g (n, its, ot) <- sortFunction gt unless (length its == length es) $ throwError (errArgArity g its es) ets <- mapM (checkExpr f) es@@ -159,6 +185,9 @@ t2 <- checkExpr f e2 checkOpTy f (EBin o e1 e2) t1 t2 +checkOpTy f _ FReal FReal + = return FReal+ checkOpTy f _ FInt FInt = return FInt @@ -209,9 +238,13 @@ = (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 _ e Eq t1 t2 = unless (t1 == t2 && t1 /= fProp) (throwError $ errRel e t1 t2)-checkRelTy _ e Ne t1 t2 = unless (t1 == t2 && t1 /= fProp) (throwError $ errRel e t1 t2)-checkRelTy _ e _ t1 t2 = unless (t1 == t2) (throwError $ errRel e t1 t2)+checkRelTy f _ _ FReal (FObj l) = (checkNumeric f l) `catchError` (\_ -> throwError $ errNonNumeric l) +checkRelTy f _ _ (FObj l) FReal = (checkNumeric f l) `catchError` (\_ -> throwError $ errNonNumeric l)+checkRelTy _ e Eq t1 t2 = unless (t1 == t2 && t1 /= fProp) (throwError $ errRel e t1 t2)+checkRelTy _ e Ne t1 t2 = unless (t1 == t2 && t1 /= fProp) (throwError $ errRel e t1 t2)+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 _ t1 t2 = unless (t1 == t2) (throwError $ errRel e t1 t2) -- | Special case for polymorphic singleton variable equality e.g. (x = Set_emp) @@ -220,8 +253,10 @@ _ <- checkApp f (Just tx) g es return () --+-- | Special case for Unsorted Dis/Equality+isAppTy :: Sort -> Bool+isAppTy (FApp _ _) = True+isAppTy _ = False ------------------------------------------------------------------------- -- | Error messages -----------------------------------------------------
src/Language/Fixpoint/Types.hs view
@@ -1,1439 +1,1567 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# 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.--module Language.Fixpoint.Types (-- -- * Top level serialization - Fixpoint (..)- , toFixpoint- , FInfo (..)-- -- * Rendering- , showFix- , traceFix- , resultDoc -- -- * Embedding to Fixpoint Types- , Sort (..), FTycon, TCEmb- , intFTyCon, boolFTyCon, strFTyCon, propFTyCon- , stringFTycon, fTyconString-- -- * Symbols- , Symbol(..)- , anfPrefix, tempPrefix, vv, intKvar- , symChars, isNonSymbol, nonSymbol- , isNontrivialVV- , stringSymbol, symbolString- - -- * Creating Symbols- , dummySymbol, intSymbol, tempSymbol- , qualifySymbol, stringSymbolRaw- , suffixSymbol-- -- * Expressions and Predicates- , SymConst (..), Constant (..)- , Bop (..), Brel (..)- , Expr (..), Pred (..)- , eVar- , eProp- , pAnd, pOr, pIte- , isTautoPred-- -- * Generalizing Embedding with Typeclasses - , Symbolic (..)- , Expression (..)- , Predicate (..)-- -- * Constraints and Solutions- , SubC, WfC, subC, lhsCs, rhsCs, wfC, Tag, FixResult (..), FixSolution, addIds, sinfo - , trueSubCKvar- , removeLhsKvars-- -- * Environments- , SEnv, SESearch(..)- , emptySEnv, toListSEnv, fromListSEnv- , mapSEnv- , insertSEnv, deleteSEnv, memberSEnv, lookupSEnv- , intersectWithSEnv- , filterSEnv- , lookupSEnvWithDistance-- , FEnv, insertFEnv - , IBindEnv, BindId, insertsIBindEnv, deleteIBindEnv, emptyIBindEnv- , BindEnv, insertBindEnv, emptyBindEnv-- -- * Refinements- , Refa (..), SortedReft (..), Reft(..), Reftable(..) - - -- * Constructing Refinements- , trueSortedReft -- trivial reft- , trueRefa -- trivial reft- , exprReft -- singleton: v == e- , notExprReft -- singleton: v /= e- , symbolReft -- singleton: v == x- , propReft -- singleton: Prop(v) <=> p- , predReft -- any pred : p- , isFunctionSortedReft- , isNonTrivialSortedReft- , isTautoReft- , isSingletonReft- , isEVar- , isFalse- , flattenRefas, squishRefas- , shiftVV-- -- * Substitutions - , Subst, Subable (..)- , emptySubst, mkSubst, catSubst- , substExcept, substfExcept, subst1Except- , sortSubst-- -- * Visitors- , reftKVars-- -- * Functions on @Result@- , colorResult -- -- * Cut KVars- , Kuts (..), ksEmpty, ksUnion-- -- * Qualifiers- , Qualifier (..)-- ) where--import GHC.Generics (Generic)-import Debug.Trace (trace)--import Data.Typeable (Typeable)-import Data.Generics (Data)-import Data.Monoid hiding ((<>))-import Data.Functor-import Data.Char (ord, chr, isAlpha, isUpper, toLower)-import Data.List (sort, stripPrefix)-import Data.Hashable --import Data.Maybe (fromMaybe)-import Text.Printf (printf)-import Control.DeepSeq-import Control.Arrow ((***))--import Language.Fixpoint.Misc-import Text.PrettyPrint.HughesPJ--import qualified Data.HashMap.Strict as M-import qualified Data.HashSet as S-import Data.Array hiding (indices)-import Language.Fixpoint.Names--class Fixpoint a where- toFix :: a -> Doc-- simplify :: a -> a - simplify = id-----------------------------------------------------------------------------showFix :: (Fixpoint a) => a -> String-showFix = render . toFix--traceFix :: (Fixpoint a) => String -> a -> a-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 _) = [x]- go (EApp f es) = f : concatMap go es- go (EBin _ e1 e2) = go e1 ++ go e2 - go (EIte p e1 e2) = predSymbols p ++ go e1 ++ go e2 - go (ECst e _) = go e- go _ = []--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]---------------------------------------------------------------------------- (Kut) Sets of Kvars --------------------------------------------------------------------------------------------------newtype Kuts = KS (S.HashSet Symbol) --instance NFData Kuts where- rnf (KS _) = () -- rnf s--instance Fixpoint Kuts where- toFix (KS s) = vcat $ ((text "cut " <>) . toFix) <$> S.toList s--ksEmpty = KS S.empty-ksUnion kvs (KS s') = KS (S.union (S.fromList kvs) s')---------------------------------------------------------------------------- Converting Constraints to Fixpoint Input -----------------------------------------------------------------------------instance (Eq a, Hashable a, Fixpoint a) => Fixpoint (S.HashSet a) where- toFix xs = brackets $ sep $ punctuate (text ";") (toFix <$> S.toList xs)- simplify = S.fromList . map simplify . S.toList--instance Fixpoint a => Fixpoint (Maybe a) where- toFix = maybe (text "Nothing") ((text "Just" <+>) . toFix)- simplify = fmap simplify--instance Fixpoint a => Fixpoint [a] where- toFix xs = brackets $ sep $ punctuate (text ";") (fmap toFix xs)- simplify = map simplify--instance (Fixpoint a, Fixpoint b) => Fixpoint (a,b) where- 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 --------------------------------------------------------------------------------------------------- Type Constructors ----------------------------------------------------------------------------------------------------newtype FTycon = TC Symbol deriving (Eq, Ord, Show, Data, Typeable)---intFTyCon = TC (S "int")-boolFTyCon = TC (S "bool")-strFTyCon = TC (S strConName)-propFTyCon = TC (S propConName)---- listFTyCon = TC (S listConName)---- isListTC = (listFTyCon ==)-isListTC (TC (S c)) = c == listConName-isTupTC (TC (S c)) = c == tupConName--fTyconString (TC (S s)) = s--stringFTycon :: String -> FTycon-stringFTycon c - | c == listConName = TC . S $ listConName- | otherwise = TC $ stringSymbol c--------------------------------------------------------------------------------------------------------- Sorts ---------------------------------------------------------------------------------------------------------data Sort = FInt - | FNum -- ^ numeric kind for Num tyvars- | FObj Symbol -- ^ uninterpreted type- | FVar !Int -- ^ fixpoint type variable- | FFunc !Int ![Sort] -- ^ type-var arity, in-ts ++ [out-t]- | FApp FTycon [Sort] -- ^ constructed type - deriving (Eq, Ord, Show, Generic, Data, Typeable)--instance Hashable Sort--newtype Sub = Sub [(Int, Sort)]--instance Fixpoint Sort where- toFix = toFix_sort--toFix_sort (FVar i) = text "@" <> parens (toFix i)-toFix_sort FInt = text "int"-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 ts) - | isTupTC c = parens $ intersperse comma $ toFix_sort <$> ts - | otherwise = toFix c <+> intersperse space (fp <$> ts)- where fp s@(FApp _ (_:_)) = parens $ toFix_sort s - fp s = toFix_sort s---instance Fixpoint FTycon where- toFix (TC s) = toFix s----------------------------------------------------------------------------------------------sortSubst :: (M.HashMap Symbol Sort) -> Sort -> Sort---------------------------------------------------------------------------------------------sortSubst θ t@(FObj x) = fromMaybe t (M.lookup x θ) -sortSubst θ (FFunc n ts) = FFunc n (sortSubst θ <$> ts)-sortSubst θ (FApp c ts) = FApp c (sortSubst θ <$> ts)-sortSubst _ t = t----------------------------------------------------------------------------------------------- Symbols --------------------------------------------------------------------------------------------symChars - = ['a' .. 'z']- ++ ['A' .. 'Z'] - ++ ['0' .. '9'] - ++ ['_', '%', '.', '#']--data Symbol = S !String deriving (Eq, Ord, Data, Typeable)--instance Fixpoint Symbol where- toFix (S x) = text x--instance Show Symbol where- show (S x) = x--instance Show Subst where- show = showFix--instance Fixpoint Subst where- toFix (Su m) = case {- hashMapToAscList -} m of - [] -> empty- xys -> hcat $ map (\(x,y) -> brackets $ (toFix x) <> text ":=" <> (toFix y)) xys------------------------------------------------------------------------------------- Converting Strings To Fixpoint ------------------------------------- ------------------------------------------------------------------------------stringSymbolRaw :: String -> Symbol-stringSymbolRaw = S--stringSymbol :: String -> Symbol-stringSymbol s- | isFixKey s = encodeSym s - | isFixSym' s = S s - | otherwise = encodeSym s -- S $ fixSymPrefix ++ concatMap encodeChar s--encodeSym s = S $ fixSymPrefix ++ concatMap encodeChar s--symbolString :: Symbol -> String-symbolString (S str) - = case chopPrefix fixSymPrefix str of- Just s -> concat $ zipWith tx indices $ chunks s - Nothing -> str- where - chunks = unIntersperse symSepName - tx i s = if even i then s else [decodeStr s]--indices :: [Integer]-indices = [0..]--okSymChars- = ['a' .. 'z']- ++ ['A' .. 'Z'] - ++ ['0' .. '9'] - ++ ['_', '.' ]--fixSymPrefix = "fix" ++ [symSepName]--suffixSymbol s suf = stringSymbol (symbolString s ++ suf)--isFixSym' (c:chs) = isAlpha c && all (`elem` (symSepName:okSymChars)) chs-isFixSym' _ = False--isFixKey x = S.member x keywords-keywords = S.fromList ["env", "id", "tag", "qualif", "constant", "cut", "bind", "constraint", "grd", "lhs", "rhs"]--encodeChar c - | c `elem` okSymChars - = [c]- | otherwise- = [symSepName] ++ (show $ ord c) ++ [symSepName]--decodeStr s - = chr ((read s) :: Int)--qualifySymbol x sy - | isQualified x' = sy - | isParened x' = stringSymbol (wrapParens (x ++ "." ++ stripParens x')) - | otherwise = stringSymbol (x ++ "." ++ x')- where x' = symbolString sy --isQualified y = '.' `elem` y -wrapParens x = "(" ++ x ++ ")"-isParened xs = xs /= stripParens xs-------------------------------------------------------------------------vv :: Maybe Integer -> Symbol-vv (Just i) = S (vvName ++ [symSepName] ++ show i)-vv Nothing = S vvName--vvCon = S (vvName ++ [symSepName] ++ "F")--isNontrivialVV = not . (vv_ ==) ---dummySymbol = S dummyName-intSymbol x i = S $ x ++ show i --tempSymbol :: String -> Integer -> Symbol-tempSymbol prefix n = intSymbol (tempPrefix ++ prefix) n--tempPrefix = "lq_tmp_"-anfPrefix = "lq_anf_" -nonSymbol = S ""-isNonSymbol = (0 ==) . length . symbolString--intKvar :: Integer -> Symbol-intKvar = intSymbol "k_" ------------------------------------------------------------------------------------------- Expressions --------------------------------------------------------------------------------------------- | Uninterpreted constants that are embedded as "constant symbol : Str"--data SymConst = SL !String- deriving (Eq, Ord, Show, Data, Typeable)--data Constant = I !Integer - deriving (Eq, Ord, Show, Data, Typeable)--data Brel = Eq | Ne | Gt | Ge | Lt | Le - deriving (Eq, Ord, Show, Data, Typeable)--data Bop = Plus | Minus | Times | Div | Mod - deriving (Eq, Ord, Show, Data, Typeable) - -- NOTE: For "Mod" 2nd expr should be a constant or a var *)--data Expr = ESym !SymConst - | ECon !Constant - | EVar !Symbol- | ELit !Symbol !Sort- | EApp !Symbol ![Expr]- | EBin !Bop !Expr !Expr- | EIte !Pred !Expr !Expr- | ECst !Expr !Sort- | EBot- deriving (Eq, Ord, Show, Data, Typeable)--instance Fixpoint Integer where- toFix = integer --instance Fixpoint Constant where- toFix (I i) = toFix i--instance Fixpoint SymConst where - toFix = toFix . encodeSymConst--instance Fixpoint Brel where- toFix Eq = text "="- toFix Ne = text "!="- toFix Gt = text ">"- toFix Ge = text ">="- toFix Lt = text "<"- toFix Le = text "<="--instance Fixpoint Bop where- toFix Plus = text "+"- toFix Minus = text "-"- toFix Times = text "*"- toFix Div = text "/"- toFix Mod = text "mod"--instance Fixpoint Expr where- toFix (ESym c) = toFix $ encodeSymConst c- 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 (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 - toFix (ECst e so) = parens $ toFix e <+> text " : " <+> toFix so - toFix (EBot) = text "_|_"---------------------------------------------------------------------------------- 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- | PTop- deriving (Eq, Ord, Show, Data, Typeable)--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 (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)-- simplify (PAnd []) = PTrue- simplify (POr []) = PFalse- simplify (PAnd [p]) = simplify p- simplify (POr [p]) = simplify p- - simplify (PAnd ps) - | any isContraPred ps = PFalse- | otherwise = PAnd $ filter (not . isTautoPred) $ map simplify ps- - simplify (POr ps) - | any isTautoPred ps = PTrue- | otherwise = POr $ filter (not . isContraPred) $ map simplify ps -- simplify p - | isContraPred p = PFalse- | isTautoPred p = PTrue- | otherwise = p--zero = ECon (I 0)-one = ECon (I 1)--isContraPred z = eqC z || (z `elem` contras)- where- contras = [PFalse] - - eqC (PAtom Eq (ECon x) (ECon y))- = x /= y- eqC (PAtom Ne x y)- = x == y- eqC _ = False--isTautoPred z = eqT z || (z `elem` tautos)- where - tautos = [PTrue]- - eqT (PAtom Le x y) - = x == y- eqT (PAtom Ge x y) - = x == y- eqT (PAtom Eq x y) - = x == y- eqT (PAtom Ne (ECon x) (ECon y))- = x /= y- eqT _ = False ----isTautoReft (Reft (_, ras)) = all isTautoRa ras-isTautoRa (RConc p) = isTautoPred p-isTautoRa _ = False--isEVar (EVar _) = True-isEVar _ = False--isSingletonReft (Reft (v, [RConc (PAtom Eq e1 e2)])) - | e1 == EVar v = Just e2- | e2 == EVar v = Just e1-isSingletonReft _ = Nothing --pAnd = simplify . PAnd -pOr = simplify . POr -pIte p1 p2 p3 = pAnd [p1 `PImp` p2, (PNot p1) `PImp` p3] --mkProp = PBexp . EApp (S propConName) . (: [])--ppr_reft (Reft (v, ras)) d - | all isTautoRa ras- = d- | otherwise- = braces (toFix v <+> colon <+> d <+> text "|" <+> ppRas ras)--ppr_reft_pred (Reft (_, ras))- | all isTautoRa ras- = text "true"- | otherwise- = ppRas ras--ppRas = cat . punctuate comma . map toFix . flattenRefas----------------------------------------------------------------------------- | Generalizing Symbol, Expression, Predicate into Classes ---------------------------------------------------------------------------------------- | Values that can be viewed as Symbols--class Symbolic a where- symbol :: a -> Symbol---- | Values that can be viewed as Expressions--class Expression a where- expr :: a -> Expr---- | Values that can be viewed as Predicates--class Predicate a where- prop :: a -> Pred--instance Symbolic String where - symbol = stringSymbol--instance Symbolic Symbol where - symbol = id --instance Expression Expr where- expr = id---- | The symbol may be an encoding of a SymConst.--instance Expression Symbol where- expr s = maybe (eVar s) ESym (decodeSymConst s) - -- expr = eVar--instance Expression String where - expr = ESym . SL--instance Expression Integer where- expr = ECon . I--instance Expression Int where- expr = expr . toInteger--instance Predicate Symbol where- prop = eProp--instance Predicate Pred where- prop = id --instance Predicate Bool where- prop True = PTrue - prop False = PFalse --eVar :: Symbolic a => a -> Expr -eVar = EVar . symbol --eProp :: Symbolic a => a -> Pred-eProp = mkProp . eVar--exprReft, notExprReft :: (Expression a) => a -> Reft-exprReft e = Reft (vv_, [RConc $ PAtom Eq (eVar vv_) (expr e)])-notExprReft e = Reft (vv_, [RConc $ PAtom Ne (eVar vv_) (expr e)])--propReft :: (Predicate a) => a -> Reft-propReft p = Reft (vv_, [RConc $ PIff (eProp vv_) (prop p)]) --predReft :: (Predicate a) => a -> Reft-predReft p = Reft (vv_, [RConc $ prop p])-------------------------------------------------------------------------------------- Refinements ---------------------------------------------------------------------------------------------------data Refa - = RConc !Pred - | RKvar !Symbol !Subst- deriving (Eq, Ord, Show, Data, Typeable)--newtype Reft = Reft (Symbol, [Refa]) deriving (Eq, Ord, Data, Typeable)--instance Show Reft where- show (Reft x) = render $ toFix x --data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft } deriving (Eq)--isNonTrivialSortedReft (RR _ (Reft (_, ras)))- = not $ null ras--isFunctionSortedReft (RR (FFunc _ _) _)- = True-isFunctionSortedReft _- = False--sortedReftValueVariable (RR _ (Reft (v,_))) = v----------------------------------------------------------------------------------- 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)-deleteSEnv x (SE env) = SE (M.delete x env)-insertSEnv x y (SE env) = SE (M.insert x y env)-lookupSEnv x (SE env) = M.lookup x env-emptySEnv = SE M.empty-memberSEnv x (SE env) = M.member x env-intersectWithSEnv f (SE m1) (SE m2) = SE (M.intersectionWith f m1 m2)-filterSEnv f (SE m) = SE (M.filter f m)-lookupSEnvWithDistance x (SE env)- = case M.lookup x env of - Just x -> Found x- Nothing -> Alts $ stringSymbol <$> alts - where alts = takeMin $ (zip (editDistance x' <$> ss) ss)- ss = symbolString <$> fst <$> M.toList env- x' = symbolString x- takeMin = \xs -> [x | (d, x) <- 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)--deleteIBindEnv :: BindId -> IBindEnv -> IBindEnv-deleteIBindEnv i (FB s) = FB (S.delete i s)--insertsIBindEnv :: [BindId] -> IBindEnv -> IBindEnv-insertsIBindEnv is (FB s) = FB (foldr S.insert s is)---- | 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))--emptyBindEnv :: BindEnv-emptyBindEnv = BE 0 M.empty---instance Functor SEnv where- fmap f (SE m) = SE $ fmap f m--instance Fixpoint Refa where- toFix (RConc p) = toFix p- toFix (RKvar k su) = toFix k <> toFix su- -- toFix (RPvar p) = toFix p--instance Fixpoint Reft where- toFix = ppr_reft_pred--instance Fixpoint SortedReft where- toFix (RR so (Reft (v, ras))) - = braces - $ (toFix v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> toFix ras--instance Fixpoint FEnv where- toFix (SE m) = toFix (hashMapToAscList m)--instance Fixpoint BindEnv where- toFix (BE _ m) = vcat $ map toFix_bind $ hashMapToAscList m --toFix_bind (i, (x, r)) = text "bind" <+> toFix i <+> toFix x <+> text ":" <+> toFix r --insertFEnv = insertSEnv . lower - where lower x@(S (c:chs)) - | isUpper c = S $ toLower c : chs- | otherwise = x- lower z = z--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 (SEnv a) => Show (SEnv a) where- show = render . toFix --------------------------------------------------------------------------------------------------- Constraints -----------------------------------------------------------------------------------------------------------------------------{-@ type Tag = { v : [Int] | len(v) = 1 } @-}-type Tag = [Int] --type BindId = Int-type FEnv = SEnv SortedReft --newtype IBindEnv = FB (S.HashSet BindId)-newtype SEnv a = SE { se_binds :: M.HashMap Symbol a } deriving (Eq, Data, Typeable)-data BindEnv = BE { be_size :: Int- , be_binds :: M.HashMap BindId (Symbol, SortedReft) - }---data SubC a = SubC { senv :: !IBindEnv- , sgrd :: !Pred- , slhs :: !SortedReft- , srhs :: !SortedReft- , sid :: !(Maybe Integer)- , stag :: !Tag- , sinfo :: !a- }--data WfC a = WfC { wenv :: !IBindEnv- , wrft :: !SortedReft- , wid :: !(Maybe Integer) - , winfo :: !a- } -- deriving (Eq)--data FixResult a = Crash [a] String - | Safe - | Unsafe ![a] - | UnknownError !Doc- deriving (Show)--type FixSolution = M.HashMap Symbol Pred--instance Eq a => Eq (FixResult a) where - Crash xs _ == Crash ys _ = xs == ys- Unsafe xs == Unsafe ys = xs == ys- Safe == Safe = True- _ == _ = False--instance Monoid (FixResult a) where- mempty = Safe- mappend Safe x = x- mappend x Safe = x- mappend _ c@(Crash _ _) = c - mappend c@(Crash _ _) _ = c - mappend (Unsafe xs) (Unsafe ys) = Unsafe (xs ++ ys)- mappend u@(UnknownError _) _ = u - mappend _ u@(UnknownError _) = u --instance Functor FixResult where - fmap f (Crash xs msg) = Crash (f <$> xs) msg- fmap f (Unsafe xs) = Unsafe (f <$> xs)- fmap _ Safe = Safe- fmap _ (UnknownError d) = UnknownError d--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--ppr_sinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc]-ppr_sinfos 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)------colorResult (Safe) = Happy -colorResult (Unsafe _) = Angry -colorResult (_) = Sad ---instance Show (SubC a) where- show = showFix --instance Fixpoint (IBindEnv) where- toFix (FB ids) = text "env" <+> toFix ids --instance Fixpoint (SubC a) where- toFix c = hang (text "\n\nconstraint:") 2 bd- where bd = -- text "env" <+> toFix (senv c) - toFix (senv c)- $+$ text "grd" <+> toFix (sgrd c) - $+$ text "lhs" <+> toFix (slhs c) - $+$ text "rhs" <+> toFix (srhs c)- $+$ (pprId (sid c) <+> pprTag (stag c)) --instance Fixpoint (WfC a) where - toFix w = hang (text "\n\nwf:") 2 bd - where bd = -- text "env" <+> toFix (wenv w)- toFix (wenv w)- $+$ text "reft" <+> toFix (wrft w) - $+$ pprId (wid w)--pprId (Just i) = text "id" <+> tshow i-pprId _ = text ""--pprTag [] = text ""-pprTag is = text "tag" <+> toFix is --instance Fixpoint Int where- toFix = tshow ----------------------------------------------------------------------------- Substitutions -------------------------------------------------------------------------------class Subable a where- syms :: a -> [Symbol]- substa :: (Symbol -> Symbol) -> a -> a- -- substa f = substf (EVar . f) - - substf :: (Symbol -> Expr) -> a -> a- subst :: Subst -> a -> a- subst1 :: a -> (Symbol, Expr) -> a- -- subst1 y (x, e) = subst (Su $ M.singleton x e) y- subst1 y (x, e) = subst (Su [(x,e)]) y--subst1Except :: (Subable a) => [Symbol] -> a -> (Symbol, Expr) -> a-subst1Except xs z su@(x, _) - | x `elem` xs = z- | otherwise = subst1 z su--substfExcept :: (Symbol -> Expr) -> [Symbol] -> (Symbol -> Expr)-substfExcept f xs y = if y `elem` xs then EVar y else f y--substExcept :: Subst -> [Symbol] -> Subst--- substExcept (Su m) xs = Su (foldr M.delete m xs) -substExcept (Su xes) xs = Su $ filter (not . (`elem` xs) . fst) xes--instance Subable Symbol where- substa f x = f x- 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]--subSymbol (Just (EVar y)) _ = y-subSymbol Nothing x = x-subSymbol a b = errorstar (printf "Cannot substitute symbol %s with expression %s" (showFix b) (showFix a))--instance Subable Expr where- syms = exprSymbols- substa f = substf (EVar . f) - substf f (EApp s es) = EApp (substf f s) $ map (substf f) es - substf f (EBin op e1 e2) = EBin op (substf f e1) (substf f e2)- substf f (EIte p e1 e2) = EIte (substf f p) (substf f e1) (substf f e2)- substf f (ECst e so) = ECst (substf f e) so- substf f e@(EVar x) = f x - substf _ e = e- - subst su (EApp f es) = EApp (subst su f) $ map (subst su) es - subst su (EBin op e1 e2) = EBin op (subst su e1) (subst su e2)- subst su (EIte p e1 e2) = EIte (subst su p) (subst su e1) (subst su e2)- subst su (ECst e so) = ECst (subst su e) so- subst su (EVar x) = appSubst su x- subst _ e = e---instance Subable Pred where- syms = predSymbols- substa f = substf (EVar . f) - substf f (PAnd ps) = PAnd $ map (substf f) ps- substf f (POr ps) = POr $ map (substf f) ps- substf f (PNot p) = PNot $ substf f p- substf f (PImp p1 p2) = PImp (substf f p1) (substf f p2)- 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 = p-- subst su (PAnd ps) = PAnd $ map (subst su) ps- subst su (POr ps) = POr $ map (subst su) ps- subst su (PNot p) = PNot $ subst su p- subst su (PImp p1 p2) = PImp (subst su p1) (subst su p2)- 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 _ 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- substa f = substf (EVar . f) - substf f (RConc p) = RConc (substf f p)- substf _ ra@(RKvar _ _) = ra--instance (Subable a, Subable b) => Subable (a,b) where- syms (x, y) = syms x ++ syms y- subst su (x,y) = (subst su x, subst su y)- substf f (x,y) = (substf f x, substf f y)- substa f (x,y) = (substa f x, substa f y)--instance Subable a => Subable [a] where- syms = concatMap syms- subst = map . subst - substf = map . substf - substa = map . substa --instance Subable a => Subable (M.HashMap k a) where- syms = syms . M.elems - subst = M.map . subst - substf = M.map . substf - substa = M.map . substa--instance Subable Reft where- syms (Reft (v, ras)) = v : syms ras- substa f (Reft (v, ras)) = Reft (f v, substa f ras) - subst su (Reft (v, ras)) = Reft (v, subst (substExcept su [v]) ras)- substf f (Reft (v, ras)) = Reft (v, substf (substfExcept f [v]) ras)- subst1 (Reft (v, ras)) su = Reft (v, subst1Except [v] ras su)---instance Subable SortedReft where- syms = syms . sr_reft - subst su (RR so r) = RR so $ subst su r- substf f (RR so r) = RR so $ substf f r- substa f (RR so r) = RR so $ substa f r----- newtype Subst = Su (M.HashMap Symbol Expr) deriving (Eq)-newtype Subst = Su [(Symbol, Expr)] deriving (Eq, Ord, Data, Typeable)--mkSubst = Su -- . M.fromList-appSubst (Su s) x = fromMaybe (EVar x) (lookup x s)-emptySubst = Su [] -- M.empty-catSubst (Su s1) (Su s2) = Su $ s1' ++ s2- where s1' = mapSnd (subst (Su s2)) <$> s1- -- = Su $ s1' `M.union` s2- -- where s1' = subst (Su s2) `M.map` s1--instance Monoid Subst where- mempty = emptySubst- mappend = catSubst ---------------------------------------------------------------------------- Generally Useful Refinements --------------------------------------------------------------------------------symbolReft = exprReft . eVar --vv_ = vv Nothing--trueSortedReft :: Sort -> SortedReft-trueSortedReft = (`RR` trueReft) --trueReft = Reft (vv_, [])-falseReft = Reft (vv_, [RConc PFalse])--trueRefa = RConc PTrue--flattenRefas :: [Refa] -> [Refa]-flattenRefas = concatMap flatRa- where - flatRa (RConc p) = RConc <$> flatP p- flatRa ra = [ra]- flatP (PAnd ps) = concatMap flatP ps- flatP p = [p]--squishRefas :: [Refa] -> [Refa]-squishRefas ras = (squish [p | RConc p <- ras]) : []- where - squish = RConc . pAnd . sortNub . filter (not . isTautoPred) . concatMap conjuncts - -conjuncts (PAnd ps) = concatMap conjuncts ps-conjuncts p | isTautoPred p = []- | otherwise = [p]---------------------------------------------------------------------------------------- Strictness -------------------------------------------------------------------------------------------------instance NFData Symbol where- rnf (S x) = rnf x--instance NFData FTycon where- rnf (TC c) = rnf c--instance NFData Sort where- rnf (FVar x) = rnf x- rnf (FFunc n ts) = rnf n `seq` (rnf <$> ts) `seq` () - rnf (FApp c ts) = rnf c `seq` (rnf <$> ts) `seq` ()- rnf (z) = z `seq` ()--instance NFData Sub where- rnf (Sub x) = rnf x--instance NFData Subst where- rnf (Su x) = rnf x--instance NFData FEnv where- rnf (SE x) = rnf x--instance NFData IBindEnv where- rnf (FB x) = rnf x--instance NFData BindEnv where- rnf (BE x m) = rnf x `seq` rnf m--instance NFData Constant where- rnf (I x) = rnf x--instance NFData SymConst where - rnf (SL x) = rnf x--instance NFData Brel -instance NFData Bop--instance NFData Expr where- rnf (ESym x) = rnf x- rnf (ECon x) = rnf x- rnf (EVar x) = rnf x- -- rnf (EDat x1 x2) = rnf x1 `seq` rnf x2- rnf (ELit x1 x2) = rnf x1 `seq` rnf x2- rnf (EApp x1 x2) = rnf x1 `seq` rnf x2- rnf (EBin x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3- rnf (EIte x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3- rnf (ECst x1 x2) = rnf x1 `seq` rnf x2- rnf (_) = ()--instance NFData Pred where- rnf (PAnd x) = rnf x- rnf (POr x) = rnf x- rnf (PNot x) = rnf x- rnf (PBexp x) = rnf x- rnf (PImp x1 x2) = rnf x1 `seq` rnf x2- rnf (PIff x1 x2) = rnf x1 `seq` rnf x2- rnf (PAll x1 x2) = rnf x1 `seq` rnf x2- rnf (PAtom x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3- rnf (_) = ()--instance NFData Refa where- rnf (RConc x) = rnf x- rnf (RKvar x1 x2) = rnf x1 `seq` rnf x2- -- rnf (RPvar _) = () -- rnf x--instance NFData Reft where - rnf (Reft (v, ras)) = rnf v `seq` rnf ras--instance NFData SortedReft where - rnf (RR so r) = rnf so `seq` rnf r--instance (NFData a) => NFData (SubC a) where- rnf (SubC x1 x2 x3 x4 x5 x6 x7) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7--instance (NFData a) => NFData (WfC a) where- rnf (WfC x1 x2 x3 x4) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4--------------------------------------------------------------------------------------------- Hashable Instances -----------------------------------------------------------------------------------------------------------------------instance Hashable Symbol where - hashWithSalt i (S s) = hashWithSalt i s--instance Hashable FTycon where- hashWithSalt i (TC s) = hashWithSalt i s-------------------------------------------------------------------------------------- Constraint Constructor Wrappers ----------------------------------------------------------------------------------------------------------------wfC = WfC---- subC γ p r1@(RR _ (Reft (v,_))) (RR t2 r2) x y z --- = SubC γ p r1 (RR t2 (shiftVV r2 v)) x y z-subC γ p (RR t1 r1) (RR t2 r2) x y z - = SubC γ p (RR t1 (shiftVV r1 vvCon)) (RR t2 (shiftVV r2 vvCon)) x y z--lhsCs = sr_reft . slhs-rhsCs = sr_reft . srhs--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 - -trueSubCKvar v- = subC emptyIBindEnv PTrue mempty (RR mempty (Reft(vv_, [RKvar v emptySubst]))) Nothing [0] --shiftVV r@(Reft (v, ras)) v' - | v == v' = r- | otherwise = Reft (v', (subst1 ras (v, EVar v')))---addIds = zipWith (\i c -> (i, shiftId i $ c {sid = Just i})) [1..]- where -- Adding shiftId to have distinct VV for SMT conversion - shiftId i c = c { slhs = shiftSR i $ slhs c } - { srhs = shiftSR i $ srhs c }- shiftSR i sr = sr { sr_reft = shiftR i $ sr_reft sr }- shiftR i r@(Reft (S v, _)) = shiftVV r (S (v ++ 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 -----------------------------------------------------------------------------------------------------------------------data Qualifier = Q { q_name :: String -- ^ Name- , q_params :: [(Symbol, Sort)] -- ^ Parameters- , q_body :: Pred -- ^ Predicate- }- deriving (Eq, Ord, Show, Data, Typeable)--instance Fixpoint Qualifier where - toFix = pprQual--instance NFData Qualifier where- rnf (Q x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3--pprQual (Q n xts p) = text "qualif" <+> text n <> parens args <> colon <+> toFix p - where args = intersperse comma (toFix <$> xts)--data FInfo a = FI { cm :: M.HashMap Integer (SubC a)- , ws :: ![WfC a] - , bs :: !BindEnv- , gs :: !FEnv- , lits :: ![(Symbol, Sort)]- , kuts :: Kuts - , quals :: ![Qualifier]- }---- toFixs = brackets . hsep . punctuate comma -- . map toFix --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--getLits x = lits x ++ symConstLits x------------------------------------------------------------------------------- | A Class Predicates for Valid Refinements Types -------------------------------------------------------------------------------------------------class (Monoid r, Subable r) => Reftable r where - isTauto :: r -> Bool- ppTy :: r -> Doc -> Doc- - top :: r- top = mempty- - -- | should also refactor `top` so it takes a parameter.- bot :: r -> r-- meet :: r -> r -> r- meet = mappend-- toReft :: r -> Reft- params :: r -> [Symbol] -- ^ parameters for Reft, vv + others--instance Monoid Pred where- mempty = PTrue - mappend p q = pAnd [p, q]--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 )))--instance Subable () where- syms _ = []- subst _ () = ()- substf _ () = ()- substa _ () = ()--instance Reftable () where- isTauto _ = True- ppTy _ d = d- top = ()- bot _ = ()- meet _ _ = ()- toReft _ = top- params _ = []--instance Reftable Reft where- isTauto = isTautoReft- ppTy = ppr_reft- toReft = id- params _ = []- bot _ = falseReft--instance Monoid Sort where- mempty = FObj (S "any")- mappend t1 t2 - | t1 == mempty = t2- | t2 == mempty = t1- | t1 == t2 = t1- | otherwise = errorstar $ "mappend-sort: conflicting sorts t1 =" ++ show t1 ++ " t2 = " ++ show t2--instance Monoid SortedReft where- mempty = RR mempty mempty- mappend t1 t2 = RR (mappend (sr_sort t1) (sr_sort t2)) (mappend (sr_reft t1) (sr_reft t2))--instance Reftable SortedReft where- isTauto = isTauto . toReft- ppTy = ppTy . toReft- toReft = sr_reft- params _ = []- bot s = s { sr_reft = falseReft }--class Falseable a where- isFalse :: a -> Bool--instance Falseable Pred where- isFalse (PFalse) = True- isFalse _ = False--instance Falseable Refa where- isFalse (RConc p) = isFalse p- isFalse _ = False--instance Falseable Reft where- isFalse (Reft(_, rs)) = or [isFalse p | RConc p <- rs]---- instance Expression a => Reftable a where--- isTauto _ = isTauto . toReft --- ppTy = ppTy . toReft--- toReft = exprReft --- params _ = []---- instance Predicate a => Reftable a where--- isTauto = isTauto . toReft --- ppTy = ppTy . toReft--- toReft = propReft --- params _ = []--------------------------------------------------------------------- |String Constants ------------------------------------------------------------------------------------------------------------symConstLits :: FInfo a -> [(Symbol, Sort)]-symConstLits fi = [(encodeSymConst c, sortSymConst c) | c <- symConsts fi]---- | Replace all symbol-representations-of-string-literals with string-literal--- Used to transform parsed output from fixpoint back into fq.---encodeSymConst :: SymConst -> Symbol-encodeSymConst (SL s) = stringSymbol $ litPrefix ++ s--sortSymConst :: SymConst -> Sort-sortSymConst (SL _) = strSort--decodeSymConst :: Symbol -> Maybe SymConst -decodeSymConst = fmap SL . stripPrefix litPrefix . symbolString--litPrefix :: String-litPrefix = "lit" ++ [symSepName]--strSort :: Sort-strSort = FApp strFTyCon []--class SymConsts a where - symConsts :: a -> [SymConst]--instance SymConsts (FInfo a) where - 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- qsLits = concatMap symConsts $ q_body <$> quals fi --instance SymConsts (SubC a) where - symConsts c = symConsts (sgrd c) ++ - symConsts (slhs c) ++ - symConsts (srhs c) --instance SymConsts SortedReft where- symConsts = symConsts . sr_reft--instance SymConsts Reft where- symConsts (Reft (_, ras)) = concatMap symConsts ras--instance SymConsts Refa where- symConsts (RConc p) = symConsts p- symConsts (RKvar _ (Su xes)) = concatMap symConsts $ snd <$> xes --instance SymConsts Expr where- symConsts (ESym c) = [c] - symConsts (EApp _ es) = concatMap symConsts es- symConsts (EBin _ e e') = concatMap symConsts [e, e']- symConsts (EIte p e e') = symConsts p ++ concatMap symConsts [e, e']- symConsts (ECst e _) = symConsts e- 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 _ = []-------------------------------------------------------------------- | Edit Distance ---------------------------------------------------------------------------------------------------------------editDistance :: Eq a => [a] -> [a] -> Int-editDistance xs ys = table ! (m,n)- where- (m,n) = (length xs, length ys)- x = array (1,m) (zip [1..] xs)- y = array (1,n) (zip [1..] ys)- - table :: Array (Int,Int) Int- table = array bnds [(ij, dist ij) | ij <- range bnds]- bnds = ((0,0),(m,n))- - dist (0,j) = j- dist (i,0) = i- dist (i,j) = minimum [table ! (i-1,j) + 1, table ! (i,j-1) + 1,- if x ! i == y ! j then table ! (i-1,j-1) else 1 + table ! (i-1,j-1)]+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+++-- | 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 (++ -- * Top level serialization+ Fixpoint (..)+ , toFixpoint+ , FInfo (..)++ -- * Rendering+ , showFix+ , traceFix+ , resultDoc++ -- * Symbols+ , Symbol(..)+ , anfPrefix, tempPrefix, vv, intKvar+ , symChars, isNonSymbol, nonSymbol+ , isNontrivialVV+ , symbolText, symbolString++ -- * Creating Symbols+ , dummySymbol+ , intSymbol+ , tempSymbol+ , qualifySymbol+ , suffixSymbol++ -- * Embedding to Fixpoint Types+ , Sort (..), FTycon, TCEmb+ , intFTyCon+ , boolFTyCon+ , realFTyCon+ , strFTyCon+ , propFTyCon+ , appFTyCon+ , fTyconSymbol+ , symbolFTycon+ , fApp+ , fObj++ -- * Expressions and Predicates+ , SymConst (..), Constant (..)+ , Bop (..), Brel (..)+ , Expr (..), Pred (..)+ , eVar+ , eProp+ , pAnd, pOr, pIte+ , isTautoPred+ , symConstLits++ -- * Generalizing Embedding with Typeclasses+ , Symbolic (..)+ , Expression (..)+ , Predicate (..)++ -- * Constraints and Solutions+ , SubC --(..)+ , WfC --(..)+ , sid+ , subC, lhsCs, rhsCs, wfC+ , Tag+ , FixResult (..)+ , FixSolution+ , addIds, sinfo+ , trueSubCKvar+ , removeLhsKvars++ -- * Environments+ , SEnv, SESearch(..)+ , emptySEnv, toListSEnv, fromListSEnv+ , mapSEnv, mapSEnvWithKey+ , insertSEnv, deleteSEnv, memberSEnv, lookupSEnv+ , intersectWithSEnv+ , filterSEnv+ , lookupSEnvWithDistance++ , FEnv, insertFEnv+ , IBindEnv, BindId+ , emptyIBindEnv, insertsIBindEnv, deleteIBindEnv+ , BindEnv+ , rawBindEnv, insertBindEnv, emptyBindEnv, mapBindEnv++ -- * Refinements+ , Refa (..), SortedReft (..), Reft(..), Reftable(..)++ -- * Constructing Refinements+ , trueSortedReft -- trivial reft+ , trueRefa -- trivial reft+ , trueReft -- trivial reft+ , exprReft -- singleton: v == e+ , notExprReft -- singleton: v /= e+ , uexprReft -- singleton: v ~~ e+ , symbolReft -- singleton: v == x+ , propReft -- singleton: Prop(v) <=> p+ , predReft -- any pred : p+ , isFunctionSortedReft+ , isNonTrivialSortedReft+ , isTautoReft+ , isSingletonReft+ , isEVar+ , isFalse+ , flattenRefas, squishRefas+ , shiftVV++ -- * Substitutions+ , Subst+ , Subable (..)+ , mkSubst+ -- , emptySubst+ -- , catSubst+ , substExcept+ , substfExcept+ , subst1Except+ , sortSubst++ -- * Visitors+ , reftKVars++ -- * Functions on @Result@+ , colorResult++ -- * Cut KVars+ , Kuts (..)+ , ksEmpty+ , ksUnion++ -- * Qualifiers+ , Qualifier (..)++ -- * FQ Definitions+ , Def (..)++ -- * Located Values+ , Located (..)+ , LocSymbol, LocText+ , dummyLoc, dummyPos, dummyName, isDummy+ ) where++import GHC.Generics (Generic)+import Debug.Trace (trace)++import Data.Typeable (Typeable)+import Data.Generics (Data)+import Data.Monoid hiding ((<>))+import Data.Functor+import Data.Char (ord, chr, isAlpha, isUpper, toLower)+import Data.List (nub, foldl', sort, stripPrefix, intersect)+import Data.Hashable+import qualified Data.Foldable as F+import Data.Traversable+import Data.Interned+import Data.String+import Data.Text (Text)+import qualified Data.Text as T++import Data.Maybe (fromMaybe)+import Text.Printf (printf)+import Control.DeepSeq+import Control.Arrow ((***))+import Control.Exception (assert)++import Language.Fixpoint.Misc+import Text.PrettyPrint.HughesPJ+import Text.Parsec.Pos++import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import Data.Array hiding (indices)+import Language.Fixpoint.Names++class Fixpoint a where+ toFix :: a -> Doc++ simplify :: a -> a+ simplify = id++------------------------------------------------------------------------+-- | Entities in Query File --------------------------------------------+------------------------------------------------------------------------++data Def a+ = Srt Sort+ | Axm Pred+ | Cst (SubC a)+ | Wfc (WfC a)+ | Con Symbol Sort+ | Qul Qualifier+ | Kut Symbol+ | IBind Int Symbol SortedReft+ deriving (Generic)+ -- Sol of solbind+ -- Dep of FixConstraint.dep++------------------------------------------------------------------------++showFix :: (Fixpoint a) => a -> String+showFix = render . toFix++traceFix :: (Fixpoint a) => String -> a -> a+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 (EBin _ e1 e2) = go e1 ++ go e2+ go (EIte p e1 e2) = predSymbols p ++ go e1 ++ go e2+ go (ECst e _) = go e+ go _ = []++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]++---------------------------------------------------------------+---------- (Kut) Sets of Kvars --------------------------------+---------------------------------------------------------------++newtype Kuts = KS (S.HashSet Symbol)++instance NFData Kuts where+ rnf (KS _) = () -- rnf s++instance Fixpoint Kuts where+ toFix (KS s) = vcat $ ((text "cut " <>) . toFix) <$> S.toList s++ksEmpty = KS S.empty+ksUnion kvs (KS s') = KS (S.union (S.fromList kvs) s')++---------------------------------------------------------------+---------- Converting Constraints to Fixpoint Input -----------+---------------------------------------------------------------++instance (Eq a, Hashable a, Fixpoint a) => Fixpoint (S.HashSet a) where+ toFix xs = brackets $ sep $ punctuate (text ";") (toFix <$> S.toList xs)+ simplify = S.fromList . map simplify . S.toList++instance Fixpoint a => Fixpoint (Maybe a) where+ toFix = maybe (text "Nothing") ((text "Just" <+>) . toFix)+ simplify = fmap simplify++instance Fixpoint a => Fixpoint [a] where+ toFix xs = brackets $ sep $ punctuate (text ";") (fmap toFix xs)+ simplify = map simplify++instance (Fixpoint a, Fixpoint b) => Fixpoint (a,b) where+ 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++++----------------------------------------------------------------------+------------------------ Type Constructors ---------------------------+----------------------------------------------------------------------++newtype FTycon = TC LocSymbol deriving (Eq, Ord, Show, Data, Typeable, Generic)++intFTyCon = TC $ dummyLoc "int"+boolFTyCon = TC $ dummyLoc "bool"+realFTyCon = TC $ dummyLoc "real"+strFTyCon = TC $ dummyLoc strConName+propFTyCon = TC $ dummyLoc propConName+appFTyCon = TC $ dummyLoc "FAppTy"+++isListTC (TC (Loc _ c)) = c == listConName+isTupTC (TC (Loc _ c)) = c == tupConName+isFAppTyTC = (== appFTyCon)++fTyconSymbol (TC s) = s++symbolFTycon :: LocSymbol -> FTycon+symbolFTycon c+ | val c == listConName+ = TC $ fmap (const listConName) c+ | otherwise+ = TC c++-- stringSort :: String -> Sort+-- stringSort s = FApp (stringFTycon s) []+-- -- ALTERNATIVEL = FObj . stringSymbol++fApp :: Either FTycon Sort -> [Sort] -> Sort+fApp (Left c) ts+ | c == intFTyCon = FInt+ | c == realFTyCon = FReal+ | otherwise = fAppSorts (fTyconSort c) ts+fApp (Right t) ts = fAppSorts t ts++fAppSorts t ts = foldl' (\t1 t2 -> FApp appFTyCon [t1, t2]) t ts++fTyconSort :: FTycon -> Sort+fTyconSort = (`FApp` [])++fObj :: LocSymbol -> Sort+fObj = fTyconSort . TC+----------------------------------------------------------------------+------------------------------- Sorts --------------------------------+----------------------------------------------------------------------++data Sort = FInt+ | FReal+ | FNum -- ^ numeric kind for Num tyvars+ | FObj Symbol -- ^ uninterpreted type+ | FVar !Int -- ^ fixpoint type variable+ | FFunc !Int ![Sort] -- ^ type-var arity, in-ts ++ [out-t]+ | FApp FTycon [Sort] -- ^ constructed type+ deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance Hashable Sort++newtype Sub = Sub [(Int, Sort)]++instance Fixpoint Sort where+ toFix = toFix_sort++toFix_sort (FVar i) = text "@" <> parens (toFix i)+toFix_sort FInt = text "int"+toFix_sort FReal = text "real"+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+++instance Fixpoint FTycon where+ toFix (TC s) = toFix s++-------------------------------------------------------------------------------------------+sortSubst :: (M.HashMap Symbol Sort) -> Sort -> Sort+-------------------------------------------------------------------------------------------+sortSubst θ t@(FObj x) = fromMaybe t (M.lookup x θ)+sortSubst θ (FFunc n ts) = FFunc n (sortSubst θ <$> ts)+sortSubst θ (FApp c ts) = FApp c (sortSubst θ <$> ts)+sortSubst _ t = t+++instance Show Subst where+ show = showFix++instance Fixpoint Subst where+ toFix (Su m) = case {- hashMapToAscList -} m of+ [] -> empty+ xys -> hcat $ map (\(x,y) -> brackets $ (toFix x) <> text ":=" <> (toFix y)) xys+++---------------------------------------------------------------+------------------------- Expressions -------------------------+---------------------------------------------------------------++-- | Uninterpreted constants that are embedded as "constant symbol : Str"++data SymConst = SL !Text+ deriving (Eq, Ord, Show, Data, Typeable, Generic)++data Constant = I !Integer | R !Double+ deriving (Eq, Ord, Show, Data, Typeable, Generic)++data Brel = Eq | Ne | Gt | Ge | Lt | Le | Ueq | Une+ deriving (Eq, Ord, Show, Data, Typeable, Generic)++data Bop = Plus | Minus | Times | Div | Mod+ deriving (Eq, Ord, Show, Data, Typeable, Generic)+ -- NOTE: For "Mod" 2nd expr should be a constant or a var *)++data Expr = ESym !SymConst+ | ECon !Constant+ | EVar !Symbol+ | ELit !LocSymbol !Sort+ | EApp !LocSymbol ![Expr]+ | EBin !Bop !Expr !Expr+ | EIte !Pred !Expr !Expr+ | ECst !Expr !Sort+ | EBot+ deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance Fixpoint Integer where+ toFix = integer++instance Fixpoint Double where+ toFix = double++instance Fixpoint Constant where+ toFix (I i) = toFix i+ toFix (R i) = toFix i++instance Fixpoint SymConst where+ toFix = toFix . encodeSymConst++instance Fixpoint Symbol where+ toFix = text . encode . T.unpack . symbolText++instance Fixpoint Text where+ toFix = text . T.unpack+++instance Fixpoint Brel where+ toFix Eq = text "="+ toFix Ne = text "!="+ toFix Ueq = text "~~"+ toFix Une = text "!~"+ toFix Gt = text ">"+ toFix Ge = text ">="+ toFix Lt = text "<"+ toFix Le = text "<="++instance Fixpoint Bop where+ toFix Plus = text "+"+ toFix Minus = text "-"+ toFix Times = text "*"+ toFix Div = text "/"+ toFix Mod = text "mod"++instance Fixpoint Expr where+ toFix (ESym c) = toFix $ encodeSymConst c+ 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 (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+ toFix (ECst e so) = parens $ toFix e <+> text " : " <+> toFix so+ toFix (EBot) = text "_|_"++----------------------------------------------------------+--------------------- 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+ | PTop+ deriving (Eq, Ord, Show, Data, Typeable, Generic)++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 (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)++ simplify (PAnd []) = PTrue+ simplify (POr []) = PFalse+ simplify (PAnd [p]) = simplify p+ simplify (POr [p]) = simplify p++ simplify (PAnd ps)+ | any isContraPred ps = PFalse+ | otherwise = PAnd $ filter (not . isTautoPred) $ map simplify ps++ simplify (POr ps)+ | any isTautoPred ps = PTrue+ | otherwise = POr $ filter (not . isContraPred) $ map simplify ps++ simplify p+ | isContraPred p = PFalse+ | isTautoPred p = PTrue+ | otherwise = p++zero = ECon (I 0)+one = ECon (I 1)++isContraPred z = eqC z || (z `elem` contras)+ where+ contras = [PFalse]++ eqC (PAtom Eq (ECon x) (ECon y))+ = x /= y+ eqC (PAtom Ueq (ECon x) (ECon y))+ = x /= y+ eqC (PAtom Ne x y)+ = x == y+ eqC (PAtom Une x y)+ = x == y+ eqC _ = False++isTautoPred z = eqT z || (z `elem` tautos)+ where+ tautos = [PTop, PTrue]++ eqT (PAtom Le x y)+ = x == y+ eqT (PAtom Ge x y)+ = x == y+ eqT (PAtom Eq x y)+ = x == y+ eqT (PAtom Ueq x y)+ = x == y+ eqT (PAtom Ne (ECon x) (ECon y))+ = x /= y+ eqT (PAtom Une (ECon x) (ECon y))+ = x /= y+ eqT _ = False+++isTautoReft (Reft (_, ras)) = all isTautoRa ras+isTautoRa (RConc p) = isTautoPred p+isTautoRa _ = False++isEVar (EVar _) = True+isEVar _ = False++isEq r = r == Eq || r == Ueq++isSingletonReft (Reft (v, [RConc (PAtom r e1 e2)]))+ | e1 == EVar v && isEq r = Just e2+ | e2 == EVar v && isEq r = Just e1+isSingletonReft _ = Nothing++pAnd = simplify . PAnd+pOr = simplify . POr+pIte p1 p2 p3 = pAnd [p1 `PImp` p2, (PNot p1) `PImp` p3]++mkProp = PBexp . EApp (dummyLoc propConName) . (: [])++ppr_reft (Reft (v, ras)) d+ | all isTautoRa ras+ = d+ | otherwise+ = braces (toFix v <+> colon <+> d <+> text "|" <+> ppRas ras)++ppr_reft_pred (Reft (_, ras))+ | all isTautoRa ras+ = text "true"+ | otherwise+ = ppRas ras++ppRas = cat . punctuate comma . map toFix . flattenRefas++------------------------------------------------------------------------+-- | Generalizing Symbol, Expression, Predicate into Classes -----------+------------------------------------------------------------------------++-- | Values that can be viewed as Expressions++class Expression a where+ expr :: a -> Expr++-- | Values that can be viewed as Predicates++class Predicate a where+ prop :: a -> Pred++instance Expression Expr where+ expr = id++-- | The symbol may be an encoding of a SymConst.++instance Expression Symbol where+ expr s = maybe (eVar s) ESym (decodeSymConst s)+ -- expr = eVar++instance Expression Text where+ expr = ESym . SL++instance Expression Integer where+ expr = ECon . I++instance Expression Int where+ expr = expr . toInteger++instance Predicate Symbol where+ prop = eProp++instance Predicate Pred where+ prop = id++instance Predicate Bool where+ prop True = PTrue+ prop False = PFalse++eVar :: Symbolic a => a -> Expr+eVar = EVar . symbol++eProp :: Symbolic a => a -> Pred+eProp = mkProp . eVar++relReft :: (Expression a) => Brel -> a -> Reft+relReft r e = Reft (vv_, [RConc $ PAtom r (eVar vv_) (expr e)])++exprReft, notExprReft, uexprReft :: (Expression a) => a -> Reft+exprReft = relReft Eq+notExprReft = relReft Ne+uexprReft = relReft Ueq++-- exprReft e = Reft (vv_, [RConc $ PAtom Eq (eVar vv_) (expr e)])+-- notExprReft e = Reft (vv_, [RConc $ PAtom Ne (eVar vv_) (expr e)])+-- exprReft e = Reft (vv_, [RConc $ PAtom Eq (eVar vv_) (expr e)])++propReft :: (Predicate a) => a -> Reft+propReft p = Reft (vv_, [RConc $ PIff (eProp vv_) (prop p)])++predReft :: (Predicate a) => a -> Reft+predReft p = Reft (vv_, [RConc $ prop p])++---------------------------------------------------------------+----------------- Refinements ---------------------------------+---------------------------------------------------------------++data Refa+ = RConc !Pred+ | RKvar !Symbol !Subst+ deriving (Eq, Ord, Show, Data, Typeable, Generic)++newtype Reft = Reft (Symbol, [Refa]) deriving (Eq, Ord, Data, Typeable, Generic)++instance Show Reft where+ show (Reft x) = render $ toFix x++data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft } + deriving (Eq, Show, Data, Typeable, Generic)++isNonTrivialSortedReft (RR _ (Reft (_, ras)))+ = not $ null ras++isFunctionSortedReft (RR (FFunc _ _) _)+ = True+isFunctionSortedReft _+ = False++sortedReftValueVariable (RR _ (Reft (v,_))) = v++---------------------------------------------------------------+----------------- 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)+insertSEnv x y (SE env) = SE (M.insert x y env)+lookupSEnv x (SE env) = M.lookup x env+emptySEnv = SE M.empty+memberSEnv x (SE env) = M.member x env+intersectWithSEnv f (SE m1) (SE m2) = SE (M.intersectionWith f m1 m2)+filterSEnv f (SE m) = SE (M.filter f m)+lookupSEnvWithDistance x (SE env)+ = case M.lookup x env of+ Just x -> Found x+ 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 <$>)++data SESearch a = Found a | Alts [Symbol]++-- | Functions for Indexed Bind Environment++emptyIBindEnv :: IBindEnv+emptyIBindEnv = FB (S.empty)++deleteIBindEnv :: BindId -> IBindEnv -> IBindEnv+deleteIBindEnv i (FB s) = FB (S.delete i s)++insertsIBindEnv :: [BindId] -> IBindEnv -> IBindEnv+insertsIBindEnv is (FB s) = FB (foldr S.insert s is)++-- | 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))++emptyBindEnv :: BindEnv+emptyBindEnv = BE 0 M.empty++rawBindEnv :: [(BindId, Symbol, SortedReft)] -> BindEnv+rawBindEnv 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++mapBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv+mapBindEnv f (BE n m) = (BE n $ M.map f m)+++instance Functor SEnv where+ fmap f (SE m) = SE $ fmap f m++instance Fixpoint Refa where+ toFix (RConc p) = toFix p+ toFix (RKvar k su) = toFix k <> toFix su+ -- toFix (RPvar p) = toFix p++instance Fixpoint Reft where+ toFix = ppr_reft_pred++instance Fixpoint SortedReft where+ toFix (RR so (Reft (v, ras)))+ = braces+ $ (toFix v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> toFix ras++instance Fixpoint FEnv where+ toFix (SE m) = toFix (hashMapToAscList m)++instance Fixpoint BindEnv where+ toFix (BE _ m) = vcat $ map toFix_bind $ hashMapToAscList m++toFix_bind (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 (SEnv a) => Show (SEnv a) where+ show = render . toFix++-----------------------------------------------------------------------------+------------------- Constraints ---------------------------------------------+-----------------------------------------------------------------------------++{-@ type Tag = { v : [Int] | len(v) = 1 } @-}+type Tag = [Int]++type BindId = Int+type FEnv = SEnv SortedReft++newtype IBindEnv = FB (S.HashSet BindId)+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)+ }+++data SubC a = SubC { senv :: !IBindEnv+ , sgrd :: !Pred+ , slhs :: !SortedReft+ , srhs :: !SortedReft+ , sid :: !(Maybe Integer)+ , stag :: !Tag+ , sinfo :: !a+ }+ deriving (Generic)++data WfC a = WfC { wenv :: !IBindEnv+ , wrft :: !SortedReft+ , wid :: !(Maybe Integer)+ , winfo :: !a+ }+ deriving (Generic)++data FixResult a = Crash [a] String+ | Safe+ | Unsafe ![a]+ | UnknownError !String + deriving (Show, Generic)++type FixSolution = M.HashMap Symbol Pred++instance Eq a => Eq (FixResult a) where+ Crash xs _ == Crash ys _ = xs == ys+ Unsafe xs == Unsafe ys = xs == ys+ Safe == Safe = True+ _ == _ = False++instance Monoid (FixResult a) where+ mempty = Safe+ mappend Safe x = x+ mappend x Safe = x+ mappend _ c@(Crash _ _) = c+ mappend c@(Crash _ _) _ = c+ mappend (Unsafe xs) (Unsafe ys) = Unsafe (xs ++ ys)+ mappend u@(UnknownError _) _ = u+ mappend _ u@(UnknownError _) = u++instance Functor FixResult where+ fmap f (Crash xs msg) = Crash (f <$> xs) msg+ fmap f (Unsafe xs) = Unsafe (f <$> xs)+ fmap _ Safe = Safe+ fmap _ (UnknownError d) = UnknownError d++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++ppr_sinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc]+ppr_sinfos 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)++++++colorResult (Safe) = Happy+colorResult (Unsafe _) = Angry+colorResult (_) = Sad+++instance Show (SubC a) where+ show = showFix++instance Fixpoint (IBindEnv) where+ toFix (FB ids) = text "env" <+> toFix ids++instance Fixpoint (SubC a) where+ toFix c = hang (text "\n\nconstraint:") 2 bd+ where bd = -- text "env" <+> toFix (senv c)+ toFix (senv c)+ $+$ text "grd" <+> toFix (sgrd c)+ $+$ text "lhs" <+> toFix (slhs c)+ $+$ text "rhs" <+> toFix (srhs c)+ $+$ (pprId (sid c) <+> pprTag (stag c))++instance Fixpoint (WfC a) where+ toFix w = hang (text "\n\nwf:") 2 bd+ where bd = -- text "env" <+> toFix (wenv w)+ toFix (wenv w)+ $+$ text "reft" <+> toFix (wrft w)+ $+$ pprId (wid w)++pprId (Just i) = text "id" <+> tshow i+pprId _ = text ""++pprTag [] = text ""+pprTag is = text "tag" <+> toFix is++instance Fixpoint Int where+ toFix = tshow++-------------------------------------------------------+------------------- Substitutions ---------------------+-------------------------------------------------------++class Subable a where+ syms :: a -> [Symbol]+ substa :: (Symbol -> Symbol) -> a -> a+ -- substa f = substf (EVar . f)++ substf :: (Symbol -> Expr) -> a -> a+ subst :: Subst -> a -> a+ subst1 :: a -> (Symbol, Expr) -> a+ -- subst1 y (x, e) = subst (Su $ M.singleton x e) y+ subst1 y (x, e) = subst (Su [(x,e)]) y++subst1Except :: (Subable a) => [Symbol] -> a -> (Symbol, Expr) -> a+subst1Except xs z su@(x, _)+ | x `elem` xs = z+ | otherwise = subst1 z su++substfExcept :: (Symbol -> Expr) -> [Symbol] -> (Symbol -> Expr)+substfExcept f xs y = if y `elem` xs then EVar y else f y++substExcept :: Subst -> [Symbol] -> Subst+-- substExcept (Su m) xs = Su (foldr M.delete m xs)+substExcept (Su xes) xs = Su $ filter (not . (`elem` xs) . fst) xes++instance Subable Symbol where+ substa f x = f x+ 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]++subSymbol (Just (EVar y)) _ = y+subSymbol Nothing x = x+subSymbol a b = errorstar (printf "Cannot substitute symbol %s with expression %s" (showFix b) (showFix a))++instance Subable Expr where+ syms = exprSymbols+ substa f = substf (EVar . f)+ substf f (EApp s es) = EApp (substf f s) $ map (substf f) es+ substf f (EBin op e1 e2) = EBin op (substf f e1) (substf f e2)+ substf f (EIte p e1 e2) = EIte (substf f p) (substf f e1) (substf f e2)+ substf f (ECst e so) = ECst (substf f e) so+ substf f e@(EVar x) = f x+ substf _ e = e++ subst su (EApp f es) = EApp (subst su f) $ map (subst su) es+ subst su (EBin op e1 e2) = EBin op (subst su e1) (subst su e2)+ subst su (EIte p e1 e2) = EIte (subst su p) (subst su e1) (subst su e2)+ subst su (ECst e so) = ECst (subst su e) so+ subst su (EVar x) = appSubst su x+ subst _ e = e+++instance Subable Pred where+ syms = predSymbols+ substa f = substf (EVar . f)+ substf f (PAnd ps) = PAnd $ map (substf f) ps+ substf f (POr ps) = POr $ map (substf f) ps+ substf f (PNot p) = PNot $ substf f p+ substf f (PImp p1 p2) = PImp (substf f p1) (substf f p2)+ 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 = p++ subst su (PAnd ps) = PAnd $ map (subst su) ps+ subst su (POr ps) = POr $ map (subst su) ps+ subst su (PNot p) = PNot $ subst su p+ subst su (PImp p1 p2) = PImp (subst su p1) (subst su p2)+ 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 _ 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+ substa f = substf (EVar . f)+ substf f (RConc p) = RConc (substf f p)+ substf _ ra@(RKvar _ _) = ra++instance (Subable a, Subable b) => Subable (a,b) where+ syms (x, y) = syms x ++ syms y+ subst su (x,y) = (subst su x, subst su y)+ substf f (x,y) = (substf f x, substf f y)+ substa f (x,y) = (substa f x, substa f y)++instance Subable a => Subable [a] where+ syms = concatMap syms+ subst = map . subst+ substf = map . substf+ substa = map . substa++instance Subable a => Subable (M.HashMap k a) where+ syms = syms . M.elems+ subst = M.map . subst+ substf = M.map . substf+ substa = M.map . substa++instance Subable Reft where+ syms (Reft (v, ras)) = v : syms ras+ substa f (Reft (v, ras)) = Reft (f v, substa f ras)+ subst su (Reft (v, ras)) = Reft (v, subst (substExcept su [v]) ras)+ substf f (Reft (v, ras)) = Reft (v, substf (substfExcept f [v]) ras)+ subst1 (Reft (v, ras)) su = Reft (v, subst1Except [v] ras su)+++instance Subable SortedReft where+ syms = syms . sr_reft+ subst su (RR so r) = RR so $ subst su r+ 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)++appSubst (Su s) x = fromMaybe (EVar x) (lookup x s)+emptySubst = Su [] -- M.empty+++catSubst = unsafeCatSubst+mkSubst = unsafeMkSubst++unsafeMkSubst = Su -- . M.fromList++unsafeCatSubst (Su s1) θ2@(Su s2) = Su $ s1' ++ s2+ where+ s1' = mapSnd (subst θ2) <$> s1++-- TODO: this is **not used**, because of degenerate substitutions.+-- e.g. consider: s1 = [v := v], s2 = [v := x].+-- We want s1 `cat` s2 to be [v := x] and not [v := v] ...++unsafeCatSubstIgnoringDead (Su s1) (Su s2) = Su $ s1' ++ s2'+ where+ s1' = mapSnd (subst (Su s2')) <$> s1+ s2' = filter (\(x,_) -> not (x `elem` (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,+-- see above.+safeCatSubst θ1@(Su s1) θ2@(Su s2)+ | null $ intersect xs1 xs2+ = unsafeCatSubst θ1 θ2+ | otherwise+ = errorstar msg+ where+ s1' = mapSnd (subst (Su s2)) <$> s1+ xs1 = fst <$> s1+ xs2 = fst <$> s2+ msg = printf "Fixpoint.Types catSubst on overlapping substitutions θ1 = %s, θ2 = %s" (showFix θ1) (showFix θ2)+++safeMkSubst θ+ | nub θ == θ+ = Su θ+ | otherwise+ = errorstar msg+ where+ msg = printf "Fixpoint.Types mkSubst on overlapping substitution θ = %s" (showFix θ)++instance Monoid Subst where+ mempty = emptySubst+ mappend = catSubst++------------------------------------------------------------+------------- Generally Useful Refinements -----------------+------------------------------------------------------------++symbolReft :: (Symbolic a) => a -> Reft+symbolReft = exprReft . eVar++vv_ = vv Nothing++trueSortedReft :: Sort -> SortedReft+trueSortedReft = (`RR` trueReft)++trueReft = Reft (vv_, [])+falseReft = Reft (vv_, [RConc PFalse])++trueRefa = RConc PTrue++flattenRefas :: [Refa] -> [Refa]+flattenRefas = concatMap flatRa+ where+ flatRa (RConc p) = RConc <$> flatP p+ flatRa ra = [ra]+ flatP (PAnd ps) = concatMap flatP ps+ flatP p = [p]++squishRefas :: [Refa] -> [Refa]+squishRefas ras = (squish [p | RConc p <- ras]) : []+ where+ squish = RConc . pAnd . sortNub . filter (not . isTautoPred) . concatMap conjuncts++conjuncts (PAnd ps) = concatMap conjuncts ps+conjuncts p | isTautoPred p = []+ | otherwise = [p]+----------------------------------------------------------------+---------------------- Strictness ------------------------------+----------------------------------------------------------------++instance NFData FTycon where+ rnf (TC c) = rnf c++instance NFData Sort where+ rnf (FVar x) = rnf x+ rnf (FFunc n ts) = rnf n `seq` (rnf <$> ts) `seq` ()+ rnf (FApp c ts) = rnf c `seq` (rnf <$> ts) `seq` ()+ rnf (z) = z `seq` ()++instance NFData Sub where+ rnf (Sub x) = rnf x++instance NFData Subst where+ rnf (Su x) = rnf x++instance NFData FEnv where+ rnf (SE x) = rnf x++instance NFData IBindEnv where+ rnf (FB x) = rnf x++instance NFData BindEnv where+ rnf (BE x m) = rnf x `seq` rnf m++instance NFData Constant where+ rnf (I x) = rnf x+ rnf (R x) = rnf x++instance NFData SymConst where+ rnf (SL x) = rnf x++instance NFData Brel+instance NFData Bop++instance NFData Expr where+ rnf (ESym x) = rnf x+ rnf (ECon x) = rnf x+ rnf (EVar x) = rnf x+ -- rnf (EDat x1 x2) = rnf x1 `seq` rnf x2+ rnf (ELit x1 x2) = rnf x1 `seq` rnf x2+ rnf (EApp x1 x2) = rnf x1 `seq` rnf x2+ rnf (EBin x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3+ rnf (EIte x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3+ rnf (ECst x1 x2) = rnf x1 `seq` rnf x2+ rnf (_) = ()++instance NFData Pred where+ rnf (PAnd x) = rnf x+ rnf (POr x) = rnf x+ rnf (PNot x) = rnf x+ rnf (PBexp x) = rnf x+ rnf (PImp x1 x2) = rnf x1 `seq` rnf x2+ rnf (PIff x1 x2) = rnf x1 `seq` rnf x2+ rnf (PAll x1 x2) = rnf x1 `seq` rnf x2+ rnf (PAtom x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3+ rnf (_) = ()++instance NFData Refa where+ rnf (RConc x) = rnf x+ rnf (RKvar x1 x2) = rnf x1 `seq` rnf x2+ -- rnf (RPvar _) = () -- rnf x++instance NFData Reft where+ rnf (Reft (v, ras)) = rnf v `seq` rnf ras++instance NFData SortedReft where+ rnf (RR so r) = rnf so `seq` rnf r++instance (NFData a) => NFData (SubC a) where+ rnf (SubC x1 x2 x3 x4 x5 x6 x7)+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7++instance (NFData a) => NFData (WfC a) where+ rnf (WfC x1 x2 x3 x4)+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4++----------------------------------------------------------------------------+-------------- Hashable Instances -----------------------------------------+---------------------------------------------------------------------------++instance Hashable FTycon where+ hashWithSalt i (TC s) = hashWithSalt i s++---------------------------------------------------------------------------+-------- Constraint Constructor Wrappers ----------------------------------+---------------------------------------------------------------------------++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])++lhsCs = sr_reft . slhs+rhsCs = sr_reft . srhs++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++trueSubCKvar v+ = subC emptyIBindEnv PTrue mempty (RR mempty (Reft(vv_, [RKvar v emptySubst]))) Nothing [0]++shiftVV :: Reft -> Symbol -> Reft+shiftVV r@(Reft (v, ras)) v'+ | v == v' = r+ | otherwise = Reft (v', (subst1 ras (v, EVar v')))+++addIds = zipWith (\i c -> (i, shiftId i $ c {sid = Just i})) [1..]+ where -- Adding shiftId to have distinct VV for SMT conversion+ shiftId i c = c { slhs = shiftSR i $ slhs c }+ { srhs = shiftSR i $ srhs c }+ shiftSR i sr = sr { sr_reft = shiftR i $ sr_reft sr }+ 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 -------------------------------------------+------------------------------------------------------------------------+++data Qualifier = Q { q_name :: Symbol -- ^ Name+ , q_params :: [(Symbol, Sort)] -- ^ Parameters+ , q_body :: Pred -- ^ Predicate+ , q_pos :: !SourcePos -- ^ Source Location+ }+ deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance Fixpoint Qualifier where+ toFix = pprQual++instance NFData Qualifier where+ rnf (Q x1 x2 x3 _) = rnf x1 `seq` rnf x2 `seq` rnf x3 ++pprQual (Q n xts p _) = text "qualif" <+> text (symbolString n) <> parens args <> colon <+> toFix p+ where args = intersperse comma (toFix <$> xts)++data FInfo a = FI { cm :: M.HashMap Integer (SubC a)+ , ws :: ![WfC a]+ , bs :: !BindEnv+ , gs :: !FEnv+ , lits :: ![(Symbol, Sort)]+ , 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 *)+-- }+++-- toFixs = brackets . hsep . punctuate comma -- . map toFix++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++getLits x = lits x -- ++ symConstLits x+++-------------------------------------------------------------------------+-- | A Class Predicates for Valid Refinements Types ---------------------+-------------------------------------------------------------------------++class (Monoid r, Subable r) => Reftable r where+ isTauto :: r -> Bool+ ppTy :: r -> Doc -> Doc++ top :: r -> r+ top _ = mempty++ bot :: r -> r++ meet :: r -> r -> r+ meet = mappend++ toReft :: r -> Reft+ ofReft :: Reft -> r+ params :: r -> [Symbol] -- ^ parameters for Reft, vv + others+ +instance Monoid Pred where+ mempty = PTrue+ mappend p q = pAnd [p, q]++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 )))++instance Subable () where+ syms _ = []+ subst _ () = ()+ substf _ () = ()+ substa _ () = ()++instance Reftable () where+ isTauto _ = True+ ppTy _ d = d+ top _ = ()+ bot _ = ()+ meet _ _ = ()+ toReft _ = mempty+ ofReft _ = mempty+ params _ = []++instance Reftable Reft where+ isTauto = isTautoReft+ ppTy = ppr_reft+ toReft = id+ ofReft = id+ params _ = []++ bot _ = falseReft+ top (Reft(v,_)) = Reft(v,[])++instance Monoid Sort where+ mempty = FObj "any"+ mappend t1 t2+ | t1 == mempty = t2+ | t2 == mempty = t1+ | t1 == t2 = t1+ | otherwise = errorstar $ "mappend-sort: conflicting sorts t1 =" ++ show t1 ++ " t2 = " ++ show t2++instance Monoid SortedReft where+ mempty = RR mempty mempty+ mappend t1 t2 = RR (mappend (sr_sort t1) (sr_sort t2)) (mappend (sr_reft t1) (sr_reft t2))++instance Reftable SortedReft where+ isTauto = isTauto . toReft+ ppTy = ppTy . toReft+ toReft = sr_reft+ ofReft = error "No instance of ofReft for SortedReft"+ params _ = []+ bot s = s { sr_reft = falseReft }++class Falseable a where+ isFalse :: a -> Bool++instance Falseable Pred where+ isFalse (PFalse) = True+ isFalse _ = False++instance Falseable Refa where+ isFalse (RConc p) = isFalse p+ isFalse _ = False++instance Falseable Reft where+ isFalse (Reft(_, rs)) = or [isFalse p | RConc p <- rs]++---------------------------------------------------------------+-- | String Constants -----------------------------------------+---------------------------------------------------------------++symConstLits :: FInfo a -> [(Symbol, Sort)]+symConstLits fi = [(encodeSymConst c, sortSymConst c) | c <- symConsts fi]++-- | Replace all symbol-representations-of-string-literals with string-literal+-- Used to transform parsed output from fixpoint back into fq.+++encodeSymConst :: SymConst -> Symbol+encodeSymConst (SL s) = symbol $ litPrefix `mappend` s++sortSymConst :: SymConst -> Sort+sortSymConst (SL _) = strSort++decodeSymConst :: Symbol -> Maybe SymConst+decodeSymConst = fmap SL . T.stripPrefix litPrefix . symbolText++litPrefix :: Text+litPrefix = "lit" `T.snoc` symSepName++strSort :: Sort+strSort = FApp strFTyCon []+++class SymConsts a where+ symConsts :: a -> [SymConst]++instance SymConsts (FInfo a) where+ 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+ qsLits = concatMap symConsts $ q_body <$> quals fi++instance SymConsts (SubC a) where+ symConsts c = symConsts (sgrd c) +++ symConsts (slhs c) +++ symConsts (srhs c)++instance SymConsts SortedReft where+ symConsts = symConsts . sr_reft++instance SymConsts Reft where+ symConsts (Reft (_, ras)) = concatMap symConsts ras++instance SymConsts Refa where+ symConsts (RConc p) = symConsts p+ symConsts (RKvar _ (Su xes)) = concatMap symConsts $ snd <$> xes++instance SymConsts Expr where+ symConsts (ESym c) = [c]+ symConsts (EApp _ es) = concatMap symConsts es+ symConsts (EBin _ e e') = concatMap symConsts [e, e']+ symConsts (EIte p e e') = symConsts p ++ concatMap symConsts [e, e']+ symConsts (ECst e _) = symConsts e+ 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 _ = []++---------------------------------------------------------------+-- | Edit Distance --------------------------------------------+---------------------------------------------------------------+++editDistance :: Eq a => [a] -> [a] -> Int+editDistance xs ys = table ! (m,n)+ where+ (m,n) = (length xs, length ys)+ x = array (1,m) (zip [1..] xs)+ y = array (1,n) (zip [1..] ys)++ table :: Array (Int,Int) Int+ table = array bnds [(ij, dist ij) | ij <- range bnds]+ bnds = ((0,0),(m,n))++ dist (0,j) = j+ dist (i,0) = i+ dist (i,j) = minimum [table ! (i-1,j) + 1, table ! (i,j-1) + 1,+ if x ! i == y ! j then table ! (i-1,j-1) else 1 + table ! (i-1,j-1)]+++-----------------------------------------------------------------------------+-- | Located Values ---------------------------------------------------------+-----------------------------------------------------------------------------++data Located a = Loc { loc :: !SourcePos+ , val :: a+ } deriving (Data, Typeable, Generic)++instance (IsString a) => IsString (Located a) where+ fromString = dummyLoc . fromString++type LocSymbol = Located Symbol+type LocText = Located Text++dummyLoc :: a -> Located a+dummyLoc = Loc (dummyPos "Fixpoint.Types.dummyLoc")++dummyPos :: String -> SourcePos+dummyPos s = newPos s 0 0++isDummy :: (Symbolic a) => a -> Bool+isDummy a = symbol a == symbol dummyName++instance Fixpoint SourcePos where+ toFix = text . show++instance Fixpoint a => Fixpoint (Located a) where+ toFix = toFix . val++instance Symbolic a => Symbolic (Located a) where+ symbol = symbol . val++instance Expression a => Expression (Located a) where+ expr = expr . val++instance Functor Located where+ fmap f (Loc l x) = Loc l (f x)++instance F.Foldable Located where+ foldMap f (Loc _ x) = f x++instance Traversable Located where+ traverse f (Loc l x) = Loc l <$> f x++instance Show a => Show (Located a) where+ show (Loc l x) = show x ++ " defined at " ++ show l++instance Eq a => Eq (Located a) where+ (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)++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