diff --git a/Fixpoint.hs b/Fixpoint.hs --- a/Fixpoint.hs +++ b/Fixpoint.hs @@ -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" diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/external/fixpoint/ast.ml b/external/fixpoint/ast.ml --- a/external/fixpoint/ast.ml +++ b/external/fixpoint/ast.ml @@ -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 diff --git a/external/fixpoint/ast.mli b/external/fixpoint/ast.mli --- a/external/fixpoint/ast.mli +++ b/external/fixpoint/ast.mli @@ -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 : diff --git a/external/fixpoint/cindex.ml b/external/fixpoint/cindex.ml --- a/external/fixpoint/cindex.ml +++ b/external/fixpoint/cindex.ml @@ -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 diff --git a/external/fixpoint/fixConfig.mli b/external/fixpoint/fixConfig.mli --- a/external/fixpoint/fixConfig.mli +++ b/external/fixpoint/fixConfig.mli @@ -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 diff --git a/external/fixpoint/fixConstraint.ml b/external/fixpoint/fixConstraint.ml --- a/external/fixpoint/fixConstraint.ml +++ b/external/fixpoint/fixConstraint.ml @@ -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)) + + + diff --git a/external/fixpoint/fixConstraint.mli b/external/fixpoint/fixConstraint.mli --- a/external/fixpoint/fixConstraint.mli +++ b/external/fixpoint/fixConstraint.mli @@ -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 diff --git a/external/fixpoint/fixLex.mll b/external/fixpoint/fixLex.mll --- a/external/fixpoint/fixLex.mll +++ b/external/fixpoint/fixLex.mll @@ -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 } | "" { 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 diff --git a/external/fixpoint/fixParse.mly b/external/fixpoint/fixParse.mly --- a/external/fixpoint/fixParse.mly +++ b/external/fixpoint/fixParse.mly @@ -54,12 +54,13 @@ %token Id %token Num +%token 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: diff --git a/external/fixpoint/fixpoint.ml b/external/fixpoint/fixpoint.ml --- a/external/fixpoint/fixpoint.ml +++ b/external/fixpoint/fixpoint.ml @@ -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 = diff --git a/external/fixpoint/kvgraph.ml b/external/fixpoint/kvgraph.ml --- a/external/fixpoint/kvgraph.ml +++ b/external/fixpoint/kvgraph.ml @@ -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:") diff --git a/external/fixpoint/predAbs.ml b/external/fixpoint/predAbs.ml --- a/external/fixpoint/predAbs.ml +++ b/external/fixpoint/predAbs.ml @@ -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" diff --git a/external/fixpoint/proverArch.ml b/external/fixpoint/proverArch.ml --- a/external/fixpoint/proverArch.ml +++ b/external/fixpoint/proverArch.ml @@ -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 diff --git a/external/fixpoint/smtLIB2.ml b/external/fixpoint/smtLIB2.ml --- a/external/fixpoint/smtLIB2.ml +++ b/external/fixpoint/smtLIB2.ml @@ -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 diff --git a/external/fixpoint/smtZ3.mem.ml b/external/fixpoint/smtZ3.mem.ml --- a/external/fixpoint/smtZ3.mem.ml +++ b/external/fixpoint/smtZ3.mem.ml @@ -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 diff --git a/external/fixpoint/smtZ3.ml b/external/fixpoint/smtZ3.ml --- a/external/fixpoint/smtZ3.ml +++ b/external/fixpoint/smtZ3.ml @@ -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 diff --git a/external/fixpoint/smtZ3.nomem.ml b/external/fixpoint/smtZ3.nomem.ml --- a/external/fixpoint/smtZ3.nomem.ml +++ b/external/fixpoint/smtZ3.nomem.ml @@ -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 diff --git a/external/fixpoint/solve.ml b/external/fixpoint/solve.ml --- a/external/fixpoint/solve.ml +++ b/external/fixpoint/solve.ml @@ -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 diff --git a/external/fixpoint/solverArch.ml b/external/fixpoint/solverArch.ml --- a/external/fixpoint/solverArch.ml +++ b/external/fixpoint/solverArch.ml @@ -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 diff --git a/external/fixpoint/theories.ml b/external/fixpoint/theories.ml --- a/external/fixpoint/theories.ml +++ b/external/fixpoint/theories.ml @@ -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 diff --git a/external/fixpoint/theories.mli b/external/fixpoint/theories.mli --- a/external/fixpoint/theories.mli +++ b/external/fixpoint/theories.mli @@ -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) diff --git a/external/fixpoint/toImp.ml b/external/fixpoint/toImp.ml --- a/external/fixpoint/toImp.ml +++ b/external/fixpoint/toImp.ml @@ -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 diff --git a/external/fixpoint/toSmtLib.ml b/external/fixpoint/toSmtLib.ml --- a/external/fixpoint/toSmtLib.ml +++ b/external/fixpoint/toSmtLib.ml @@ -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 = diff --git a/external/fixpoint/tpGen.ml b/external/fixpoint/tpGen.ml --- a/external/fixpoint/tpGen.ml +++ b/external/fixpoint/tpGen.ml @@ -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; diff --git a/external/fixpoint/tpNull.ml b/external/fixpoint/tpNull.ml --- a/external/fixpoint/tpNull.ml +++ b/external/fixpoint/tpNull.ml @@ -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 diff --git a/external/misc/constants.ml b/external/misc/constants.ml --- a/external/misc/constants.ml +++ b/external/misc/constants.ml @@ -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]"); ] diff --git a/external/misc/fcommon.ml b/external/misc/fcommon.ml --- a/external/misc/fcommon.ml +++ b/external/misc/fcommon.ml @@ -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)];; diff --git a/external/misc/fixMisc.ml b/external/misc/fixMisc.ml --- a/external/misc/fixMisc.ml +++ b/external/misc/fixMisc.ml @@ -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" diff --git a/external/misc/misc.ml b/external/misc/misc.ml deleted file mode 100644 --- a/external/misc/misc.ml +++ /dev/null @@ -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 - - - diff --git a/external/ocamlgraph/.depend b/external/ocamlgraph/.depend --- a/external/ocamlgraph/.depend +++ b/external/ocamlgraph/.depend @@ -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 : diff --git a/external/ocamlgraph/Makefile b/external/ocamlgraph/Makefile --- a/external/ocamlgraph/Makefile +++ b/external/ocamlgraph/Makefile @@ -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 = diff --git a/external/ocamlgraph/src/dot_parser.ml b/external/ocamlgraph/src/dot_parser.ml --- a/external/ocamlgraph/src/dot_parser.ml +++ b/external/ocamlgraph/src/dot_parser.ml @@ -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))) diff --git a/external/ocamlgraph/src/version.ml b/external/ocamlgraph/src/version.ml --- a/external/ocamlgraph/src/version.ml +++ b/external/ocamlgraph/src/version.ml @@ -1,2 +1,2 @@ let version = "0.99b" -let date = "Sun Sep 22 21:13:17 PDT 2013" +let date = "Tue Aug 12 13:29:08 PDT 2014" diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -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 () - 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 diff --git a/src/Language/Fixpoint/Config.hs b/src/Language/Fixpoint/Config.hs --- a/src/Language/Fixpoint/Config.hs +++ b/src/Language/Fixpoint/Config.hs @@ -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 - diff --git a/src/Language/Fixpoint/Errors.hs b/src/Language/Fixpoint/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Errors.hs @@ -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 + diff --git a/src/Language/Fixpoint/Files.hs b/src/Language/Fixpoint/Files.hs --- a/src/Language/Fixpoint/Files.hs +++ b/src/Language/Fixpoint/Files.hs @@ -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" diff --git a/src/Language/Fixpoint/Interface.hs b/src/Language/Fixpoint/Interface.hs --- a/src/Language/Fixpoint/Interface.hs +++ b/src/Language/Fixpoint/Interface.hs @@ -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 diff --git a/src/Language/Fixpoint/Misc.hs b/src/Language/Fixpoint/Misc.hs --- a/src/Language/Fixpoint/Misc.hs +++ b/src/Language/Fixpoint/Misc.hs @@ -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 diff --git a/src/Language/Fixpoint/Names.hs b/src/Language/Fixpoint/Names.hs --- a/src/Language/Fixpoint/Names.hs +++ b/src/Language/Fixpoint/Names.hs @@ -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 diff --git a/src/Language/Fixpoint/Parse.hs b/src/Language/Fixpoint/Parse.hs --- a/src/Language/Fixpoint/Parse.hs +++ b/src/Language/Fixpoint/Parse.hs @@ -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" diff --git a/src/Language/Fixpoint/PrettyPrint.hs b/src/Language/Fixpoint/PrettyPrint.hs --- a/src/Language/Fixpoint/PrettyPrint.hs +++ b/src/Language/Fixpoint/PrettyPrint.hs @@ -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 diff --git a/src/Language/Fixpoint/SmtLib2.hs b/src/Language/Fixpoint/SmtLib2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/SmtLib2.hs @@ -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) +-} diff --git a/src/Language/Fixpoint/Sort.hs b/src/Language/Fixpoint/Sort.hs --- a/src/Language/Fixpoint/Sort.hs +++ b/src/Language/Fixpoint/Sort.hs @@ -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 ----------------------------------------------------- diff --git a/src/Language/Fixpoint/Types.hs b/src/Language/Fixpoint/Types.hs --- a/src/Language/Fixpoint/Types.hs +++ b/src/Language/Fixpoint/Types.hs @@ -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