g2 0.1.0.1 → 0.2.0.0
raw patch · 184 files changed
+29598/−7214 lines, 184 filesdep +Diffdep +bimapdep +clockdep −hpcdep ~Cabaldep ~MissingHdep ~arraynew-component:exe:G2LHnew-component:exe:Inferencenew-component:exe:Nebula
Dependencies added: Diff, bimap, clock, deepseq, deferred-folds, language-sygus, optparse-applicative, pretty, random, tasty-quickcheck, text-builder
Dependencies removed: hpc
Dependency ranges changed: Cabal, MissingH, array, base, bytestring, concurrent-extra, containers, directory, extra, filepath, ghc, ghc-paths, hashable, liquid-fixpoint, liquidhaskell, mtl, process, regex-base, tasty, tasty-hunit, template-haskell, text, time, unordered-containers
Files
- LICENSE +1/−1
- README.md +6/−21
- exe/Main.hs +17/−50
- g2.cabal +286/−87
- inference/Main.hs +90/−0
- lh/Main.hs +26/−0
- nebula/Main.hs +37/−0
- quasiquote/Arithmetics/Interpreter.hs +0/−87
- quasiquote/Arithmetics/Test.hs +0/−83
- quasiquote/DeBruijn/Interpreter.hs +0/−48
- quasiquote/DeBruijn/Test.hs +0/−62
- quasiquote/Evaluations.hs +0/−194
- quasiquote/Lambda/Interpreter.hs +0/−38
- quasiquote/Lambda/Test.hs +0/−19
- quasiquote/Main.hs +0/−255
- quasiquote/NQueens/Encoding.hs +0/−62
- quasiquote/NQueens/Test.hs +0/−19
- quasiquote/RegEx/RegEx.hs +0/−36
- quasiquote/RegEx/Test.hs +0/−25
- src/G2/Config/Config.hs +165/−52
- src/G2/Config/Interface.hs +35/−17
- src/G2/Data/Timer.hs +95/−0
- src/G2/Data/UFMap.hs +288/−0
- src/G2/Data/UnionFind.hs +168/−0
- src/G2/Data/Utils.hs +25/−0
- src/G2/Equiv/Approximation.hs +125/−0
- src/G2/Equiv/Config.hs +107/−0
- src/G2/Equiv/EquivADT.hs +127/−0
- src/G2/Equiv/G2Calls.hs +504/−0
- src/G2/Equiv/Generalize.hs +140/−0
- src/G2/Equiv/InitRewrite.hs +38/−0
- src/G2/Equiv/Summary.hs +588/−0
- src/G2/Equiv/Tactics.hs +729/−0
- src/G2/Equiv/Types.hs +202/−0
- src/G2/Equiv/Uninterpreted.hs +139/−0
- src/G2/Equiv/Verifier.hs +816/−0
- src/G2/Execution/HPC.hs +148/−0
- src/G2/Execution/Interface.hs +2/−2
- src/G2/Execution/Memory.hs +73/−36
- src/G2/Execution/NewPC.hs +49/−0
- src/G2/Execution/NormalForms.hs +52/−2
- src/G2/Execution/PrimitiveEval.hs +145/−43
- src/G2/Execution/Reducer.hs +1341/−933
- src/G2/Execution/RuleTypes.hs +10/−2
- src/G2/Execution/Rules.hs +658/−239
- src/G2/Initialization/DeepSeqWalks.hs +51/−25
- src/G2/Initialization/ElimTicks.hs +6/−6
- src/G2/Initialization/ElimTypeSynonyms.hs +7/−6
- src/G2/Initialization/Interface.hs +13/−10
- src/G2/Initialization/KnownValues.hs +68/−13
- src/G2/Initialization/MkCurrExpr.hs +49/−30
- src/G2/Initialization/StructuralEq.hs +0/−290
- src/G2/Initialization/Types.hs +13/−8
- src/G2/Interface/Interface.hs +360/−162
- src/G2/Interface/OutputTypes.hs +22/−7
- src/G2/Language/AST.hs +80/−37
- src/G2/Language/AlgDataTy.hs +37/−12
- src/G2/Language/Approximation.hs +309/−0
- src/G2/Language/ArbValueGen.hs +121/−41
- src/G2/Language/CallGraph.hs +86/−0
- src/G2/Language/Casts.hs +32/−10
- src/G2/Language/Expr.hs +312/−60
- src/G2/Language/ExprEnv.hs +141/−24
- src/G2/Language/Ids.hs +10/−6
- src/G2/Language/KnownValues.hs +44/−7
- src/G2/Language/Located.hs +2/−1
- src/G2/Language/Monad/AST.hs +20/−9
- src/G2/Language/Monad/Expr.hs +18/−13
- src/G2/Language/Monad/ExprEnv.hs +19/−12
- src/G2/Language/Monad/Naming.hs +12/−12
- src/G2/Language/Monad/Primitives.hs +30/−23
- src/G2/Language/Monad/Support.hs +166/−20
- src/G2/Language/Monad/TypeClasses.hs +2/−2
- src/G2/Language/Monad/TypeEnv.hs +4/−4
- src/G2/Language/Monad/Typing.hs +9/−1
- src/G2/Language/Naming.hs +275/−149
- src/G2/Language/PathConds.hs +331/−156
- src/G2/Language/Primitives.hs +106/−150
- src/G2/Language/Simplification.hs +97/−0
- src/G2/Language/Stack.hs +14/−18
- src/G2/Language/Support.hs +98/−93
- src/G2/Language/Syntax.hs +119/−103
- src/G2/Language/TypeClasses/Extra.hs +1/−29
- src/G2/Language/TypeClasses/TypeClasses.hs +90/−55
- src/G2/Language/TypeEnv.hs +8/−90
- src/G2/Language/Typing.hs +190/−131
- src/G2/Lib/Printers.hs +493/−151
- src/G2/Liquid/AddCFBranch.hs +115/−35
- src/G2/Liquid/AddLHTC.hs +60/−45
- src/G2/Liquid/AddOrdToNum.hs +27/−18
- src/G2/Liquid/AddTyVars.hs +240/−0
- src/G2/Liquid/Annotations.hs +7/−5
- src/G2/Liquid/Config.hs +83/−0
- src/G2/Liquid/Conversion.hs +433/−137
- src/G2/Liquid/ConvertCurrExpr.hs +125/−14
- src/G2/Liquid/G2Calls.hs +531/−0
- src/G2/Liquid/Helpers.hs +196/−0
- src/G2/Liquid/Inference/Config.hs +431/−0
- src/G2/Liquid/Inference/FuncConstraint.hs +199/−0
- src/G2/Liquid/Inference/G2Calls.hs +1110/−0
- src/G2/Liquid/Inference/GeneratedSpecs.hs +322/−0
- src/G2/Liquid/Inference/InfStack.hs +167/−0
- src/G2/Liquid/Inference/Initalization.hs +63/−0
- src/G2/Liquid/Inference/Interface.hs +777/−0
- src/G2/Liquid/Inference/PolyRef.hs +212/−0
- src/G2/Liquid/Inference/QualifGen.hs +260/−0
- src/G2/Liquid/Inference/Sygus.hs +7/−0
- src/G2/Liquid/Inference/Sygus/FCConverter.hs +299/−0
- src/G2/Liquid/Inference/Sygus/LiaSynth.hs +1661/−0
- src/G2/Liquid/Inference/Sygus/RefSynth.hs +1531/−0
- src/G2/Liquid/Inference/Sygus/SimplifySygus.hs +440/−0
- src/G2/Liquid/Inference/Sygus/SpecInfo.hs +620/−0
- src/G2/Liquid/Inference/Sygus/Sygus.hs +417/−0
- src/G2/Liquid/Inference/Sygus/UnsatCoreElim.hs +36/−0
- src/G2/Liquid/Inference/UnionPoly.hs +153/−0
- src/G2/Liquid/Inference/Verify.hs +402/−0
- src/G2/Liquid/Interface.hs +521/−200
- src/G2/Liquid/LHReducers.hs +280/−84
- src/G2/Liquid/Measures.hs +79/−20
- src/G2/Liquid/MkLHVals.hs +120/−0
- src/G2/Liquid/Simplify.hs +114/−1
- src/G2/Liquid/SpecialAsserts.hs +98/−19
- src/G2/Liquid/TCGen.hs +100/−48
- src/G2/Liquid/TCValues.hs +50/−5
- src/G2/Liquid/TyVarBags.hs +426/−0
- src/G2/Liquid/Types.hs +465/−78
- src/G2/Nebula.hs +113/−0
- src/G2/Postprocessing/Interface.hs +1/−1
- src/G2/Preprocessing/AdjustTypes.hs +4/−4
- src/G2/Preprocessing/NameCleaner.hs +21/−14
- src/G2/QuasiQuotes/FloodConsts.hs +7/−8
- src/G2/QuasiQuotes/G2Rep.hs +0/−1
- src/G2/QuasiQuotes/Internals/G2Rep.hs +42/−10
- src/G2/QuasiQuotes/Parser.hs +1/−1
- src/G2/QuasiQuotes/QuasiQuotes.hs +114/−71
- src/G2/QuasiQuotes/Support.hs +9/−8
- src/G2/Solver.hs +6/−2
- src/G2/Solver/ADTNumericalSolver.hs +46/−0
- src/G2/Solver/ADTSolver.hs +0/−206
- src/G2/Solver/Converters.hs +294/−186
- src/G2/Solver/Interface.hs +59/−40
- src/G2/Solver/Language.hs +142/−37
- src/G2/Solver/Maximize.hs +161/−0
- src/G2/Solver/ParseSMT.hs +14/−3
- src/G2/Solver/SMT2.hs +256/−271
- src/G2/Solver/Simplifier.hs +25/−0
- src/G2/Solver/Solver.hs +71/−49
- src/G2/Translation/Cabal/Cabal.hs +25/−2
- src/G2/Translation/GHC.hs +150/−0
- src/G2/Translation/Haskell.hs +511/−330
- src/G2/Translation/HaskellCheck.hs +52/−32
- src/G2/Translation/InjectSpecials.hs +62/−17
- src/G2/Translation/Interface.hs +83/−88
- src/G2/Translation/PrimInject.hs +115/−43
- src/G2/Translation/TransTypes.hs +17/−12
- tests/DefuncTest.hs +0/−46
- tests/Expr.hs +2/−5
- tests/GetNthTest.hs +0/−63
- tests/InputOutputTest.hs +71/−70
- tests/Reqs.hs +17/−35
- tests/RewriteVerify/RewriteVerifyTest.hs +227/−0
- tests/Simplifications.hs +66/−0
- tests/Test.hs +470/−438
- tests/TestUtils.hs +21/−13
- tests/Typing.hs +20/−10
- tests/UFMapTests.hs +245/−0
- tests/UnionFindTests.hs +41/−0
- tests_lh/LHTest.hs +590/−0
- tests_lh/UnionPoly.hs +140/−0
- tests_nebula_plugin/Main.hs +77/−0
- tests_quasiquote/Arithmetics/Interpreter.hs +87/−0
- tests_quasiquote/Arithmetics/Test.hs +117/−0
- tests_quasiquote/DeBruijn/Interpreter.hs +48/−0
- tests_quasiquote/DeBruijn/Test.hs +62/−0
- tests_quasiquote/Evaluations.hs +60/−0
- tests_quasiquote/Lambda/Interpreter.hs +38/−0
- tests_quasiquote/Lambda/Test.hs +19/−0
- tests_quasiquote/Main.hs +296/−0
- tests_quasiquote/NQueens/Encoding.hs +62/−0
- tests_quasiquote/NQueens/Test.hs +19/−0
- tests_quasiquote/RegEx/RegEx.hs +36/−0
- tests_quasiquote/RegEx/Test.hs +44/−0
- tests_quasiquote/Simple/Simple1.hs +33/−0
- tests_quasiquote/Simple/SimpleTest1.hs +15/−0
LICENSE view
@@ -1,6 +1,6 @@ G2 -Copyright 2019. William Hallahan, Anton Xue.+Copyright 2022. William Hallahan, Anton Xue, John Kolesar. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
README.md view
@@ -7,21 +7,15 @@ --- #### Dependencies-* GHC 8.2.2: https://www.haskell.org/ghc/-* Custom Haskell Standard Library: https://github.com/AntonXue/base-4.9.1.0+* GHC: https://www.haskell.org/ghc/+* Custom Haskell Standard Library: https://github.com/BillHallahan/base-4.9.1.0 * Z3 SMT Solver: https://github.com/Z3Prover/z3 --- #### Setup:-1) Install GHC 8.2.2 (other GHC 8 versions might also work)-2) Install Z3-3) Either:-- a) Pull the Custom Haskell Standard Library into ~/.g2 by running `bash base_setup.sh` -- b) Manually pull the base library. Add a file to the G2 folder, called g2.cfg that contains:- `base = /path/to/custom/library`-+1) Install GHC.+2) Install Z3. Ensure Z3 is in your system's path.+3) Pull the Custom Haskell Standard Library into ~/.g2 by running `bash base_setup.sh`. --- #### Command line:@@ -32,7 +26,7 @@ ###### LiquidHaskell: -`cabal run G2 -- --liquid ./tests/Liquid/Peano.hs --liquid-func add`+`cabal run G2LH ./tests/Liquid/Peano.hs add` ###### Arguments: @@ -40,12 +34,3 @@ * `--max-outputs` number of inputs/results to display * `--smt` Pass "z3" or "cvc4" to select a solver [Default: Z3] * `--time` Set a timeout in seconds-------#### Authors-* Bill Hallahan (Yale)-* Anton Xue (Yale)-* Maxwell Troy Bland (UCSD)-* Ranjit Jhala (UCSD)-* Ruzica Piskac (Yale)
exe/Main.hs view
@@ -2,14 +2,18 @@ module Main (main) where -import DynFlags+import G2.Translation.GHC (GeneralFlag(Opt_Hpc)) import System.Environment import System.FilePath +import Data.Foldable (toList) import qualified Data.Map as M import Data.Maybe+import Data.Monoid ((<>))+import qualified Data.Sequence as S import qualified Data.Text as T+import qualified Data.Text.IO as T import G2.Lib.Printers @@ -18,60 +22,30 @@ import G2.Language import G2.Translation -import G2.Liquid.Interface- main :: IO () main = do as <- getArgs-- let m_liquid_file = mkLiquid as- let m_liquid_func = mkLiquidFunc as-- let libs = maybeToList $ mkMapSrc as- let lhlibs = maybeToList $ mkLiquidLibs as-- case (m_liquid_file, m_liquid_func) of- (Just lhfile, Just lhfun) -> do- let m_idir = mIDir as- proj = maybe (takeDirectory lhfile) id m_idir- runSingleLHFun proj lhfile lhfun libs lhlibs as- _ -> do- runWithArgs as--runSingleLHFun :: FilePath -> FilePath -> String -> [FilePath] -> [FilePath] -> [String] -> IO ()-runSingleLHFun proj lhfile lhfun libs lhlibs ars = do- config <- getConfig ars- _ <- doTimeout (timeLimit config) $ do- ((in_out, _), entry) <- findCounterExamples [proj] [lhfile] (T.pack lhfun) libs lhlibs config- printLHOut entry in_out- return ()+ runWithArgs as runWithArgs :: [String] -> IO () runWithArgs as = do-- let (src:entry:tail_args) = as+ let (_:_:tail_args) = as+ (src, entry, m_assume, m_assert, config) <- getConfig proj <- guessProj src --Get args- let m_assume = mAssume tail_args- let m_assert = mAssert tail_args let m_reaches = mReaches tail_args let m_retsTrue = mReturnsTrue tail_args - let m_mapsrc = mkMapSrc tail_args- let tentry = T.pack entry - let libs = maybeToList m_mapsrc-- config <- getConfig as _ <- doTimeout (timeLimit config) $ do ((in_out, b), entry_f@(Id (Name _ mb_modname _ _) _)) <-- runG2FromFile [proj] [src] libs (fmap T.pack m_assume)+ runG2FromFile [proj] [src] (fmap T.pack m_assume) (fmap T.pack m_assert) (fmap T.pack m_reaches) (isJust m_assert || isJust m_reaches || m_retsTrue) - tentry config+ tentry simplTranslationConfig config case validate config of True -> do@@ -88,17 +62,16 @@ printFuncCalls :: Config -> Id -> Bindings -> [ExecRes t] -> IO () printFuncCalls config entry b = mapM_ (\execr@(ExecRes { final_state = s}) -> do- let funcCall = mkCleanExprHaskell s+ let pg = mkPrettyGuide (exprNames $ conc_args execr)+ let funcCall = printHaskellPG pg s . foldl (\a a' -> App a a') (Var entry) $ (conc_args execr) - let funcOut = mkCleanExprHaskell s $ (conc_out execr)-- ppStatePiece (printExprEnv config) "expr_env" $ ppExprEnv s- ppStatePiece (printRelExprEnv config) "rel expr_env" $ ppRelExprEnv s b- ppStatePiece (printCurrExpr config) "curr_expr" $ ppCurrExpr s- ppStatePiece (printPathCons config) "path_cons" $ ppPathConds s+ let funcOut = printHaskellPG pg s $ (conc_out execr)+ sym_gen_out = fmap (printHaskellPG pg s) $ conc_sym_gens execr - putStrLn $ funcCall ++ " = " ++ funcOut)+ case sym_gen_out of+ S.Empty -> T.putStrLn $ funcCall <> " = " <> funcOut+ _ -> T.putStrLn $ funcCall <> " = " <> funcOut <> "\t| generated: " <> T.intercalate ", " (toList sym_gen_out)) ppStatePiece :: Bool -> String -> String -> IO () ppStatePiece b n res =@@ -129,9 +102,3 @@ mkLiquidFunc :: [String] -> Maybe String mkLiquidFunc a = strArg "liquid-func" a M.empty Just Nothing--mkMapSrc :: [String] -> Maybe String-mkMapSrc a = strArg "mapsrc" a M.empty Just Nothing--mkLiquidLibs :: [String] -> Maybe String-mkLiquidLibs a = strArg "liquid-libs" a M.empty Just Nothing
g2.cabal view
@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: g2-version: 0.1.0.1+version: 0.2.0.0 synopsis: Haskell symbolic execution engine. description: A Haskell symbolic execution engine. @@ -10,13 +10,17 @@ License: BSD3 License-file: LICENSE author: William Hallahan, Anton Xue-maintainer: william.hallahan@yale.edu+maintainer: whallahan@binghamton.edu -- copyright: category: Formal Methods, Symbolic Computation build-type: Simple extra-source-files: README.md cabal-version: 1.24 +Flag support-lh+ Description: Build modules for reasoning about LiquidHaskell+ Default: True+ source-repository head type: git location: https://github.com/BillHallahan/G2.git@@ -24,10 +28,32 @@ library exposed-modules: G2.Config+ , G2.Config.Config+ , G2.Config.Interface+ , G2.Config.ParseConfig + , G2.Data.Timer+ , G2.Data.UFMap+ , G2.Data.UnionFind+ , G2.Data.Utils++ , G2.Equiv.Approximation+ , G2.Equiv.Config+ , G2.Equiv.InitRewrite+ , G2.Equiv.EquivADT+ , G2.Equiv.G2Calls+ , G2.Equiv.Verifier+ , G2.Equiv.Tactics+ , G2.Equiv.Types+ , G2.Equiv.Generalize+ , G2.Equiv.Summary+ , G2.Equiv.Uninterpreted+ , G2.Execution+ , G2.Execution.HPC , G2.Execution.Interface , G2.Execution.Memory+ , G2.Execution.NewPC , G2.Execution.NormalForms , G2.Execution.PrimitiveEval , G2.Execution.Reducer@@ -41,15 +67,18 @@ , G2.Initialization.InitVarLocs , G2.Initialization.KnownValues , G2.Initialization.MkCurrExpr- , G2.Initialization.StructuralEq , G2.Initialization.Types , G2.Interface+ , G2.Interface.Interface+ , G2.Interface.OutputTypes , G2.Language , G2.Language.AlgDataTy+ , G2.Language.Approximation , G2.Language.ArbValueGen , G2.Language.AST+ , G2.Language.CallGraph , G2.Language.Casts , G2.Language.CreateFuncs , G2.Language.Expr@@ -71,6 +100,7 @@ , G2.Language.Naming , G2.Language.PathConds , G2.Language.Primitives+ , G2.Language.Simplification , G2.Language.Stack , G2.Language.Support , G2.Language.Syntax@@ -82,7 +112,7 @@ , G2.Lib.Printers - , G2.Liquid.Interface+ , G2.Nebula , G2.Postprocessing.Interface @@ -90,8 +120,17 @@ , G2.Preprocessing.Interface , G2.Preprocessing.NameCleaner + , G2.Postprocessing.NameSwitcher+ , G2.Solver+ , G2.Solver.ADTNumericalSolver+ , G2.Solver.Converters , G2.Solver.Interface+ , G2.Solver.Language+ , G2.Solver.Maximize+ , G2.Solver.ParseSMT+ , G2.Solver.Simplifier+ , G2.Solver.SMT2 , G2.Solver.Solver , G2.QuasiQuotes.Internals.G2Rep@@ -103,35 +142,7 @@ , G2.Translation , G2.Translation.Cabal.Cabal- other-modules: G2.Config.Config- , G2.Config.Interface- , G2.Config.ParseConfig-- , G2.Interface.Interface- , G2.Interface.OutputTypes-- , G2.Liquid.AddCFBranch- , G2.Liquid.AddLHTC- , G2.Liquid.AddOrdToNum- , G2.Liquid.Annotations- , G2.Liquid.Conversion- , G2.Liquid.ConvertCurrExpr- , G2.Liquid.LHReducers- , G2.Liquid.Measures- , G2.Liquid.Simplify- , G2.Liquid.SpecialAsserts- , G2.Liquid.TCGen- , G2.Liquid.TCValues- , G2.Liquid.Types-- , G2.Postprocessing.NameSwitcher-- , G2.Solver.ADTSolver- , G2.Solver.Converters- , G2.Solver.Language- , G2.Solver.ParseSMT- , G2.Solver.SMT2-+ , G2.Translation.GHC , G2.Translation.Haskell , G2.Translation.HaskellCheck , G2.Translation.InjectSpecials@@ -139,96 +150,201 @@ , G2.Translation.PrimInject , G2.Translation.TransTypes - build-depends: array >= 0.5.1.1 && <= 0.5.3.0 - , Cabal >= 2.0.1.0 && <= 2.0.1.1- , base >= 4.8 && < 5- , bytestring >= 0.10.8.0 && <= 0.10.8.2- , concurrent-extra >= 0.7- , containers >= 0.5 && < 0.6- , directory >= 1.3.0.2 && <= 1.3.3.2- , extra >= 1.6.14 && <= 1.6.17- , filepath == 1.4.1.2+ if flag(support-lh) && impl(ghc < 9.2)+ exposed-modules: + G2.Liquid.AddCFBranch+ , G2.Liquid.AddLHTC+ , G2.Liquid.AddOrdToNum+ , G2.Liquid.AddTyVars+ , G2.Liquid.Annotations+ , G2.Liquid.Config+ , G2.Liquid.Conversion+ , G2.Liquid.ConvertCurrExpr+ , G2.Liquid.Helpers+ , G2.Liquid.Interface+ , G2.Liquid.LHReducers+ , G2.Liquid.Measures+ , G2.Liquid.MkLHVals+ , G2.Liquid.Simplify+ , G2.Liquid.SpecialAsserts+ , G2.Liquid.TCGen+ , G2.Liquid.TCValues+ , G2.Liquid.Types+ , G2.Liquid.TyVarBags+ , G2.Liquid.G2Calls+ , G2.Liquid.Inference.Config+ , G2.Liquid.Inference.FuncConstraint+ , G2.Liquid.Inference.G2Calls+ , G2.Liquid.Inference.InfStack+ , G2.Liquid.Inference.Initalization+ , G2.Liquid.Inference.Interface+ , G2.Liquid.Inference.PolyRef+ , G2.Liquid.Inference.Sygus.UnsatCoreElim+ , G2.Liquid.Inference.Sygus+ , G2.Liquid.Inference.Sygus.FCConverter+ , G2.Liquid.Inference.Sygus.RefSynth+ , G2.Liquid.Inference.Sygus.LiaSynth+ , G2.Liquid.Inference.Sygus.SimplifySygus+ , G2.Liquid.Inference.Sygus.SpecInfo+ , G2.Liquid.Inference.Sygus.Sygus+ , G2.Liquid.Inference.UnionPoly+ , G2.Liquid.Inference.Verify+ , G2.Liquid.Inference.GeneratedSpecs+ , G2.Liquid.Inference.QualifGen++ build-depends: array >= 0.5.1.1 && <= 0.5.5.0 + , Cabal >= 2.0.1.0 && < 3.11+ , base >= 4.8 && < 4.19+ , bimap == 0.3.3+ , bytestring >= 0.10.8.0 && < 0.11.5+ , clock >= 0.8 && < 0.9+ , concurrent-extra >= 0.7 && < 0.8+ , containers >= 0.5 && < 0.7+ , directory >= 1.3.0.2 && <= 1.3.8.1+ , extra >= 1.6.14 && < 1.7.13+ , filepath >= 1.4 && <= 1.5 , ghc-paths >= 0.1 && < 0.2- , ghc == 8.2.2- , hashable >= 1.2.6.0 && <= 1.3.0.0- , hpc >= 0.6.0.0 && < 0.6.1+ , ghc (>= 8.2.2 && < 8.4) || (>= 8.6 && < 8.7) || (>= 8.10 && < 9.7)+ , hashable >= 1.2.6.0 && <= 1.4.2.0 , HTTP >= 4000.3.0 && < 4001.0- , liquidhaskell == 0.8.2.2- , liquid-fixpoint >= 0.7.0.7- , MissingH >= 1.4.0.0 && < 1.5- , mtl >= 2.2 && < 2.3+ , language-sygus >= 0.1.1.3 && < 0.2+ , MissingH >= 1.4.0.0 && < 1.7+ , mtl >= 2.2 && < 2.4+ , random >= 1.1 && < 1.3 , reducers >= 3.12 && < 3.13 , regex-compat >= 0.95 && < 0.96- , regex-base >= 0.93 && < 0.94+ , regex-base >= 0.93 && < 0.94.0.3 , parsec >= 3.1 && < 3.2- , process >=1 && < 1.7+ , pretty >= 1.1 && < 1.4+ , process >=1.6 && < 1.7+ , optparse-applicative >=0.15.0.0 && < 0.18.0.0 , split >= 0.2.3 && < 0.2.4- , template-haskell == 2.12.0.0+ , tasty-quickcheck >= 0.10.1.1 && < 0.11+ , template-haskell >= 2.12.0.0 && <= 2.20.0.0 , temporary-rc >= 1.2 && < 1.3- , text == 1.2.3.1- , time >= 1.6 && <= 1.9.3- , unordered-containers >= 0.2 && < 0.3+ , text >= 1.2.3.1 && <= 2.1+ , text-builder >= 0.6.6.1 && < 0.7+ , time >= 1.6 && <= 1.13+ , unordered-containers >= 0.2.10.0 && < 0.3+ + -- remove this eventually+ , deferred-folds <= 0.9.18.3+ + if flag(support-lh) && impl(ghc < 9.2)+ build-depends: liquidhaskell >= 0.8.10.2 && <= 0.9.0.2.1+ , liquid-fixpoint >= 0.8.10.2 && < 0.10+ , Diff == 0.3.4++ if flag(support-lh) && impl(ghc < 9)+ build-depends: liquidhaskell == 0.8.10.2+ , liquid-fixpoint == 0.8.10.2+ default-language: Haskell2010 ghc-options: -Wall+ -- -O1+ -fno-ignore-asserts+ -- -ddump-rule-rewrites -- -ddump-splices- -- -fprof-auto- -- -fexternal-interpreter -opti+RTS -opti-p+ -- -fexternal-interpreter+ -- ghc-prof-options: -fprof-auto+ other-extensions: CPP+ if flag(support-lh) && impl(ghc < 9)+ cpp-options: -DSUPPORT_LH+ hs-source-dirs: src executable G2 -- other-modules: - -- other-extensions: + -- other-extensions: build-depends: g2 , base >= 4.8 && < 5- , containers >= 0.5 && < 0.6- , filepath == 1.4.1.2- , ghc == 8.2.2- , hpc >= 0.6.0.0 && < 0.6.1- , text == 1.2.3.1+ , containers+ , filepath >= 1.4 && <= 1.5+ , ghc+ , text , unordered-containers >= 0.2 && < 0.3 default-language: Haskell2010 ghc-options: -threaded -Wall- -- -fprof-auto "-with-rtsopts=-p"+ -- -fexternal-interpreter -opti+RTS -opti-p+ -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" hs-source-dirs: exe main-is: Main.hs -executable QuasiQuote- -- other-extensions: +executable G2LH+ if flag(support-lh) && impl(ghc < 9.2)+ buildable: True+ else+ buildable: False+ -- other-modules: + -- other-extensions: build-depends: g2 , base >= 4.8 && < 5- , time >= 1.6 && <= 1.9.3+ , containers+ , filepath >= 1.4 && <= 1.5+ , ghc+ , text+ , unordered-containers >= 0.2 && < 0.3 default-language: Haskell2010- ghc-options: -Wall- -- -ddump-splices+ ghc-options: -threaded -Wall -- -fprof-auto "-with-rtsopts=-p"- hs-source-dirs: quasiquote+ -- -fexternal-interpreter -opti+RTS -opti-p+ -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p"+ hs-source-dirs: lh main-is: Main.hs- other-modules: Arithmetics.Interpreter- , Arithmetics.Test- , DeBruijn.Interpreter- , DeBruijn.Test- , Evaluations- , Lambda.Interpreter- , Lambda.Test- , NQueens.Encoding- , NQueens.Test- , RegEx.RegEx- , RegEx.Test +executable Inference+ if flag(support-lh) && impl(ghc < 9.2)+ buildable: True+ else+ buildable: False+ -- other-modules: + -- other-extensions: + build-depends: g2+ , base >= 4.8 && < 5+ , containers+ , deepseq >= 1.4 && < 2+ , liquid-fixpoint+ , liquidhaskell+ , text+ , time+ default-language: Haskell2010+ ghc-options: -threaded -Wall+ -- -O1+ -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p"+ hs-source-dirs: inference+ main-is: Main.hs++executable Nebula+ -- other-modules: + -- other-extensions:+ build-depends: g2+ , base >= 4.8 && < 5+ , containers+ , filepath >= 1.4 && <= 1.5+ , ghc+ , text+ , unordered-containers >= 0.2 && < 0.3+ default-language: Haskell2010+ ghc-options: -threaded -Wall+ -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p"+ hs-source-dirs: nebula+ main-is: Main.hs+ test-suite test build-depends: g2 , base >= 4.8 && < 5- , containers >= 0.5 && < 0.6+ , containers+ , directory , filepath- , ghc-paths >= 0.1 && < 0.2+ , ghc-paths , ghc , hashable- , hpc , tagged- , tasty >= 1.0- , tasty-hunit >= 0.10+ , tasty >= 1.0 && < 2.0+ , tasty-hunit >= 0.10 && < 0.10.0.3+ , tasty-quickcheck , text- , time >= 1.6+ , time , unordered-containers default-language: Haskell2010 hs-source-dirs: tests@@ -241,9 +357,92 @@ , InputOutputTest , PeanoTest , Reqs+ , Simplifications , TestUtils , Typing+ , UFMapTests+ , UnionFindTests+ , RewriteVerify.RewriteVerifyTest ghc-options: -Wall+ -threaded+ -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p"+ type: exitcode-stdio-1.0++test-suite test-lh+ if flag(support-lh) && impl(ghc < 9.2)+ buildable: True+ else+ buildable: False+ build-depends: g2+ , base >= 4.8 && < 5+ , containers+ , directory+ , filepath+ , ghc-paths+ , ghc+ , hashable+ , liquidhaskell+ , tagged+ , tasty >= 1.0 && < 2.0+ , tasty-hunit >= 0.10 && < 0.10.0.3+ , tasty-quickcheck+ , text+ , time+ , unordered-containers+ default-language: Haskell2010+ hs-source-dirs: tests_lh, tests+ main-is: LHTest.hs+ other-modules: GetNthTest+ , PeanoTest+ , Reqs+ , TestUtils+ , UnionPoly+ ghc-options: -Wall+ -threaded+ -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p"+ type: exitcode-stdio-1.0++test-suite test-g2q+ -- other-extensions: + build-depends: g2+ , base >= 4.8 && < 5+ , tasty >= 1.0 && < 2.0+ , tasty-hunit >= 0.10 && < 0.10.0.3+ , time+ default-language: Haskell2010+ ghc-options: -Wall+ -- -ddump-splices -- -fprof-auto "-with-rtsopts=-p"+ hs-source-dirs: tests_quasiquote+ main-is: Main.hs+ other-modules: Arithmetics.Interpreter+ , Arithmetics.Test+ , DeBruijn.Interpreter+ , DeBruijn.Test+ , Evaluations+ , Lambda.Interpreter+ , Lambda.Test+ , NQueens.Encoding+ , NQueens.Test+ , RegEx.RegEx+ , RegEx.Test+ , Simple.Simple1+ , Simple.SimpleTest1+ ghc-options: -Wall -threaded+ -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p"+ type: exitcode-stdio-1.0++test-suite test-nebula-plugin+ build-depends: base >= 4.8 && < 5+ , process+ , tasty >= 1.0 && < 2.0+ , tasty-hunit >= 0.10 && < 0.10.0.3+ default-language: Haskell2010+ hs-source-dirs: tests_nebula_plugin+ main-is: Main.hs+ -- other-modules: + ghc-options: -Wall+ -threaded+ -- ghc-prof-options: -fprof-auto "-with-rtsopts=-p" type: exitcode-stdio-1.0
+ inference/Main.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import G2.Config as G2+import G2.Interface+import G2.Liquid.Config+import G2.Liquid.Interface+import G2.Liquid.Inference.Config+import G2.Liquid.Inference.G2Calls+import G2.Liquid.Inference.Initalization+import G2.Liquid.Inference.Interface+import G2.Liquid.Inference.Verify+import G2.Liquid.Helpers++import Language.Fixpoint.Solver+import Language.Fixpoint.Types.Constraints+import Language.Haskell.Liquid.Types as LH++import Control.DeepSeq+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Time.Clock+import System.Environment++main :: IO ()+main = do+ (f, count, config, g2lhconfig, infconfig, func) <- getAllConfigsForInf++ case func of+ Nothing -> do+ if count+ then checkFuncNums f infconfig config g2lhconfig+ else callInference f infconfig config g2lhconfig+ Just func' -> do+ ((in_out, _), entry) <- runLHInferenceAll infconfig config g2lhconfig (T.pack func') [] [f]+ printLHOut entry in_out+ return ()++-- checkQualifs :: String -> G2.Config -> IO ()+-- checkQualifs f config = do+-- undefined+-- -- qualifGen "qualif.hquals" + +-- finfo <- parseFInfo ["qualif.hquals"]++-- let infconfig = mkInferenceConfig []+-- lhconfig <- quals finfo `deepseq` defLHConfig [] []+-- let lhconfig' = lhconfig { pruneUnsorted = True }+-- ghcis <- ghcInfos Nothing lhconfig' [f]+-- let ghcis' = map (\ghci ->+-- let+-- ghci_quals = getQualifiers ghci-- spc = spec ghci+-- new_quals = ghci_quals ++ quals finfo +-- in+-- putQualifiers ghci new_quals) ghcis++-- start <- getCurrentTime+-- res <- doTimeout 360 $ verify infconfig lhconfig' ghcis'+-- stop <- getCurrentTime++-- case res of -- print $ quals finfo+-- Just Safe -> do+-- putStrLn "Safe"+-- print (stop `diffUTCTime` start)+-- Just _ -> putStrLn "Unsafe"+-- Nothing -> putStrLn "Timeout"++callInference :: String -> InferenceConfig -> G2.Config -> LHConfig -> IO ()+callInference f infconfig config lhconfig = do+ (s, gs) <- inferenceCheck infconfig config lhconfig [] [f]+ case gs of+ Left gs' -> do+ putStrLn "Counterexample"+ printCE s gs'+ Right gs' -> do+ putStrLn "Safe"+ print gs'++checkFuncNums :: String -> InferenceConfig -> G2.Config -> LHConfig -> IO ()+checkFuncNums f infconfig config g2lhconfig = do+ (ghci, lhconfig) <- getGHCI infconfig [] [f]+ (lrs, _, _, _, main_mod) <- getInitState [] [f] ghci infconfig config g2lhconfig+ let nls = getNameLevels main_mod lrs++ print nls++ print $ length nls+ print $ length (concat nls) - 1++ return ()
+ lh/Main.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import System.FilePath++import qualified Data.Text as T++import G2.Config+import G2.Interface++import G2.Liquid.Config+import G2.Liquid.Interface++main :: IO ()+main = do+ runSingleLHFun [] []++runSingleLHFun :: [FilePath] -> [FilePath] -> IO ()+runSingleLHFun libs lhlibs = do+ (src, func, config, lhconfig) <- getLHConfig+ let proj = takeDirectory src+ _ <- doTimeout (timeLimit config) $ do+ ((in_out, _), entry) <- findCounterExamples [proj] [src] (T.pack func) config lhconfig+ printLHOut entry in_out+ return ()
+ nebula/Main.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import qualified Data.Text as T++import G2.Config+import G2.Interface+import G2.Language+import G2.Translation++import G2.Equiv.Config+import G2.Equiv.Verifier++import Data.List++main :: IO ()+main = do+ (src, entry, total, nebula_config) <- getNebulaConfig++ proj <- guessProj src++ let tentry = T.pack entry++ config <- getConfigDirect++ (init_state, bindings) <- initialStateNoStartFunc [proj] [src]+ (simplTranslationConfig { simpl = True, load_rewrite_rules = True, hpc_ticks = False }) config++ let rule = find (\r -> tentry == ru_name r) (rewrite_rules bindings)+ rule' = case rule of+ Just r -> r+ Nothing -> error "not found"+ res <- checkRule config nebula_config init_state bindings total rule'+ print res+ return ()
− quasiquote/Arithmetics/Interpreter.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--module Arithmetics.Interpreter where--import Control.Monad-import Data.Data-import G2.QuasiQuotes.G2Rep--type Ident = String-type Env = [(Ident, Int)]--data AExpr = I Int | Var Ident- | Add AExpr AExpr | Mul AExpr AExpr- deriving (Eq, Show, Data)--$(derivingG2Rep ''AExpr)--data BExpr = Not BExpr | And BExpr BExpr | Or BExpr BExpr- | Lt AExpr AExpr | Eq AExpr AExpr- deriving (Eq, Show, Data)--$(derivingG2Rep ''BExpr)--type Stmts = [Stmt]-data Stmt = Assign Ident AExpr- | If BExpr Stmts Stmts- | While BExpr Stmts- | Assert BExpr- deriving (Eq, Show, Data)- -$(derivingG2Rep ''Stmt)--type Bound = [Ident]-type Return = Ident-data Func = Func Bound Stmts Return--$(derivingG2Rep ''Func)--evalFunc :: [Int] -> Func -> Maybe Int-evalFunc is (Func b s r) =- lookup r =<< evalStmts (zip b is) s--evalStmts :: Env -> Stmts -> Maybe Env-evalStmts = foldM evalStmt --evalStmt :: Env -> Stmt -> Maybe Env-evalStmt env (Assign ident aexpr) =- Just $ (ident, evalA env aexpr):env-evalStmt env (If bexpr lhs rhs) =- if evalB env bexpr- then evalStmts env lhs- else evalStmts env rhs-evalStmt env (While bexpr loop) =- if evalB env bexpr- then evalStmts env (loop ++ [While bexpr loop])- else Just env-evalStmt env (Assert bexpr) =- if evalB env bexpr- then Just env- else Nothing--evalA :: Env -> AExpr -> Int-evalA _ (I int) = int-evalA env (Add lhs rhs) =- evalA env lhs + evalA env rhs-evalA env (Mul lhs rhs) =- evalA env lhs * evalA env rhs-evalA env (Var ident) =- case lookup ident env of- Just int -> int- _ -> error $- "lookup with " ++ show (ident, env)--evalB :: Env -> BExpr -> Bool-evalB env (Not bexpr) = not $ evalB env bexpr-evalB env (And lhs rhs) =- evalB env lhs && evalB env rhs-evalB env (Or lhs rhs) =- evalB env lhs || evalB env rhs-evalB env (Lt lhs rhs) =- evalA env lhs < evalA env rhs-evalB env (Eq lhs rhs) =- evalA env lhs == evalA env rhs-
− quasiquote/Arithmetics/Test.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module Arithmetics.Test where--import Arithmetics.Interpreter-import G2.QuasiQuotes.QuasiQuotes--productTest :: IO (Maybe (AExpr, AExpr))-productTest =- [g2| \(a :: Int) -> ?(s1 :: AExpr)- ?(s2 :: AExpr) |- let env = [("x", 23), ("y", 59)] in- let lhs = Mul (Var "x") (Var "y") in- let rhs = Mul s1 s2 in- evalB env (Eq lhs rhs) |] 0--envTest :: BExpr -> IO (Maybe Env)-envTest = [g2|\(b :: BExpr) -> ?(env :: Env) |- evalB env b |]--assertViolation :: Stmts -> IO (Maybe Env)-assertViolation = [g2|\(stmts :: Stmts) -> ?(env :: Env) |- evalStmts env stmts == Nothing|]--productSumTest :: IO (Maybe Env)-productSumTest =- envTest $ And- ((Eq - (Mul (Var "x") (Var "y"))- (Add (Var "x") (Var "y"))))- (Lt (I 0) (Var "x"))---assertViolationTest1 :: IO (Maybe Env)-assertViolationTest1 = assertViolation- [ Assert (Lt (I 5) (I 3)) ]---- x^2 + y^2 + z^2 < (x + y + z)^2-assertViolationTest2 :: IO (Maybe Env)-assertViolationTest2 = assertViolation- [ Assign "v1" (Add (Var "x") (Add (Var "y") (Var "z")))- , Assign "v1" (Mul (Var "v1") (Var "v1"))- , Assign "v2" (Add (Mul (Var "x") (Var "x"))- (Add (Mul (Var "y") (Var "y"))- (Mul (Var "z") (Var "z"))))- , Assert (Lt (Var "v2") (Var "v1"))- ]---assertViolationTest3 :: IO (Maybe Env)-assertViolationTest3 = assertViolation- [- Assign "k" (I 1),- Assign "i" (I 0),- Assign "j" (I 0),- Assign "n" (I 5),- While (Or (Lt (Var "i") (Var "n"))- (Eq (Var "i") (Var "n")))- [ Assign "i" (Add (Var "i") (I 1))- , Assign "j" (Add (Var "j") (Var "i"))- ],- Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))),- Assert (Lt (Mul (Var "n") (I 2)) (Var "z"))- ]- --assertViolationTest4 :: IO (Maybe Env)-assertViolationTest4 = assertViolation- [- Assign "k" (I 1),- Assign "i" (I 0),- -- Assign "j" (I 0),- Assign "n" (I 5),- While (Or (Lt (Var "i") (Var "n"))- (Eq (Var "i") (Var "n")))- [ Assign "i" (Add (Var "i") (I 1))- , Assign "j" (Add (Var "j") (Var "i"))- ],- Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))),- Assert (Lt (Mul (Var "n") (I 2)) (Var "z"))- ]- -
− quasiquote/DeBruijn/Interpreter.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--module DeBruijn.Interpreter ( Expr (..)- , Ident- , eval- , app- , lams- , num) where--import Data.Data-import G2.QuasiQuotes.G2Rep--type Ident = Int--data Expr = Var Ident- | Lam Expr- | App Expr Expr- deriving (Show, Read, Eq, Data)--$(derivingG2Rep ''Expr)--type Stack = [Expr]--eval :: Expr -> Expr-eval = eval' []--eval' :: Stack -> Expr -> Expr-eval' (e:stck) (Lam e') = eval' stck (rep 1 e e')-eval' stck (App e1 e2) = eval' (e2:stck) e1-eval' stck e = app $ e:stck--rep :: Int -> Expr -> Expr -> Expr-rep i e v@(Var j)- | i == j = e- | otherwise = v-rep i e (Lam e') = Lam (rep (i + 1) e e')-rep i e (App e1 e2) = App (rep i e e1) (rep i e e2)--app :: [Expr] -> Expr-app = foldl1 App--lams :: Int -> Expr -> Expr-lams n e = iterate Lam e !! n--num :: Int -> Expr-num n = Lam $ Lam $ foldr1 App (replicate n (Var 2) ++ [Var 1])
− quasiquote/DeBruijn/Test.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module DeBruijn.Test where--import DeBruijn.Interpreter-import G2.QuasiQuotes.QuasiQuotes--solveDeBruijn1 :: IO (Maybe Expr)-solveDeBruijn1 =- [g2| \(x :: Int) -> ?(syExpr :: Expr) |- let expr = App syExpr in- eval (expr (Lam (Var 1))) == (Lam (Var 1))- && eval (expr (Lam (Var 2))) == (Lam (Var 2)) |] 6--solveDeBruijn :: [([Expr], Expr)] -> IO (Maybe Expr)-solveDeBruijn =- [g2| \(es :: [([Expr], Expr)]) -> ?(func :: Expr) |- all (\e -> (eval (app (func:fst e))) == snd e) es |]--solveDeBruijnI :: IO (Maybe Expr)-solveDeBruijnI = solveDeBruijn [ ([num 1], num 1)- , ([num 2], num 2) ]--solveDeBruijnK :: IO (Maybe Expr)-solveDeBruijnK = solveDeBruijn [ ([num 1, num 2], num 2)- , ([num 2, num 3], num 3)]--trueLam :: Expr-trueLam = Lam (Lam (Var 2))--falseLam :: Expr-falseLam = Lam (Lam (Var 1))--solveDeBruijnAnd :: IO (Maybe Expr)-solveDeBruijnAnd = solveDeBruijn [ ([trueLam, trueLam], trueLam)- , ([falseLam, falseLam], falseLam)- , ([falseLam, trueLam], falseLam) - , ([trueLam, falseLam], falseLam) ]--solveDeBruijnOr :: IO (Maybe Expr)-solveDeBruijnOr = solveDeBruijn [ ([trueLam, trueLam], trueLam)- , ([falseLam, falseLam], falseLam)- , ([falseLam, trueLam], trueLam) - , ([trueLam, falseLam], trueLam) ]--solveDeBruijnIte :: IO (Maybe Expr)-solveDeBruijnIte = solveDeBruijn [ ([trueLam, Var 2, Var 4], Var 2)- , ([falseLam, Var 2, Var 4], Var 4) ]--solveDeBruijnS :: IO (Maybe Expr)-solveDeBruijnS =- solveDeBruijn- [ ([Lam (Lam (Var 1)), Lam (Var 1), num 2], num 2)- , ([Lam (Lam (Var 1)), Lam (Lam (Var 2)), num 3], num 3) ]- -- [g2| \(_ :: ()) -> ?(func :: Expr) |- -- let- -- k = Lam (Lam (Var 2))- -- in- -- eval (App func (App k (App (num 1) (num 2)))) == num 2- -- |] ()- -- , ([Lam (Lam (Var 1)), Lam (num 3), num 1], num 3)]- -- , ([Lam (Lam (Lam (Var 2))), Lam (Lam (Var 1)), num 1], Lam (Lam (num 1)))]
− quasiquote/Evaluations.hs
@@ -1,194 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module Evaluations where--import Data.Time.Clock-import G2.QuasiQuotes.QuasiQuotes--import Arithmetics.Interpreter as A-import DeBruijn.Interpreter as D-import RegEx.RegEx as R---timeIOAction :: IO a -> IO (a, NominalDiffTime)-timeIOAction action = do- start <- getCurrentTime- res <- action- end <- getCurrentTime- let diff = diffUTCTime end start- return (res, diff)--timeIOActionPrint :: Show a => IO a -> IO ()-timeIOActionPrint action = do- (res, time) <- timeIOAction action- putStrLn $ show res- putStrLn $ "time: " ++ show time--------------------------------------------------------------------------------------------- Section 2 (Arithmetics)-searchBadEnv :: Stmts -> IO (Maybe Env)-searchBadEnv =- [g2| \(stmts :: Stmts) -> ?(env :: Env) |- evalStmts env stmts == Nothing|]--envTest :: BExpr -> IO (Maybe Env)-envTest = [g2|\(b :: BExpr) -> ?(env :: Env) |- evalB env b |]--badProg :: Stmts-badProg =- [- Assign "k" (I 1),- Assign "i" (I 0),- -- Assign "j" (I 0),- Assign "n" (I 5),- While (A.Or (Lt (A.Var "i") (A.Var "n"))- (Eq (A.Var "i") (A.Var "n")))- [ Assign "i" (Add (A.Var "i") (I 1))- , Assign "j" (Add (A.Var "j") (A.Var "i"))- ],- Assign "z" (Add (A.Var "k") (Add (A.Var "i") (A.Var "j"))),- Assert (Lt (Mul (A.Var "n") (I 2)) (A.Var "z"))- ]--productSumTest :: BExpr-productSumTest =- And- ((Eq - (Mul (A.Var "x") (A.Var "y"))- (Add (A.Var "x") (A.Var "y"))))- (Lt (I 0) (A.Var "x"))--runArithmeticsEval :: IO ()-runArithmeticsEval = do- putStrLn "------------------------"- putStrLn "-- Arithmetics Eval -------"- timeIOActionPrint $ searchBadEnv badProg- timeIOActionPrint $ envTest productSumTest- putStrLn ""---------------------------------------------------------------------------------------------- Section 5.1 (n Queens)--------------------------------------------------------------------------------------------- Section 5.2 (Lambda Calculus)--solveDeBruijn :: [([Expr], Expr)] -> IO (Maybe Expr)-solveDeBruijn =- [g2| \(es :: [([Expr], Expr)]) -> ?(func :: Expr) |- all (\e -> (eval (app (func:fst e))) == snd e) es |]--idDeBruijn :: [([D.Expr], D.Expr)]-idDeBruijn = [ ([num 1], num 1)- , ([num 2], num 2) ]--const2Example :: [([D.Expr], D.Expr)]-const2Example =- [ ([num 1, num 2], num 1)- , ([num 2, num 3], num 2) ] --trueLam :: D.Expr-trueLam = Lam (Lam (D.Var 2))--falseLam :: D.Expr-falseLam = Lam (Lam (D.Var 1))--notExample :: [([D.Expr], D.Expr)]-notExample =- [ ([trueLam], falseLam)- , ([falseLam], trueLam) ]--orExample :: [([D.Expr], D.Expr)]-orExample =- [ ([trueLam, trueLam], trueLam)- , ([falseLam, falseLam], falseLam)- , ([falseLam, trueLam], trueLam)- , ([trueLam, falseLam], trueLam )]--andExample :: [([D.Expr], D.Expr)]-andExample =- [ ([trueLam, trueLam], trueLam)- , ([falseLam, falseLam], falseLam)- , ([falseLam, trueLam], falseLam)- , ([trueLam, falseLam], falseLam )]---runDeBruijnEval :: IO ()-runDeBruijnEval = do- putStrLn "------------------------"- putStrLn "-- DeBruijn Eval -------"- timeIOActionPrint $ solveDeBruijn idDeBruijn- timeIOActionPrint $ solveDeBruijn const2Example- -- timeIOActionPrint $ solveDeBruijn notExample- timeIOActionPrint $ solveDeBruijn orExample- -- timeIOActionPrint $ solveDeBruijn andExample- putStrLn ""--------------------------------------------------------------------------------------------- Section 5.3 (Regular Expressions)--stringSearch :: RegEx -> IO (Maybe String)-stringSearch =- [g2| \(r :: RegEx) -> ?(str :: String) |- match r str |]---- (a + b)* c (d + (e f)*)-regex1 :: RegEx-regex1 =- Concat (Star (R.Or (Atom 'a') (Atom 'b')))- (Concat (Atom 'c')- (R.Or (Atom 'd')- (Concat (Atom 'e')- (Atom 'f'))))--regex2 :: RegEx-regex2 = Concat (Atom 'a')- (Concat (Atom 'b')- (Concat (Atom 'c')- (Concat (Atom 'd')- (Concat (Atom 'e')- ((Atom 'f'))))))--regex3 :: RegEx-regex3 = R.Or (Atom 'a')- (R.Or (Atom 'b')- (R.Or (Atom 'c')- (R.Or (Atom 'd')- (R.Or (Atom 'e')- ((Atom 'f'))))))--regex4 :: RegEx-regex4 = Concat (Star (Atom 'a'))- (Concat (Star (Atom 'b'))- (Concat (Star (Atom 'c'))- (Concat (Star (Atom 'd'))- (Concat (Star (Atom 'e'))- ((Star (Atom 'f')))))))----runRegExEval :: IO ()-runRegExEval = do- putStrLn "------------------------"- putStrLn "-- RegEx Eval ----------"- timeIOActionPrint $ stringSearch regex1- timeIOActionPrint $ stringSearch regex2- timeIOActionPrint $ stringSearch regex3- timeIOActionPrint $ stringSearch regex4- putStrLn ""---------------------------------------------------------------------------------------------
− quasiquote/Lambda/Interpreter.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--module Lambda.Interpreter where--import Data.Data-import Data.List-import G2.QuasiQuotes.QuasiQuotes-import G2.QuasiQuotes.G2Rep--type Id = String--data Prim = I Int | B Bool | Fun Id- deriving (Show, Eq, Data)--$(derivingG2Rep ''Prim)--data Expr- = Var Id- | Lam Id Expr- | App Expr Expr- | Const Prim- deriving (Show, Eq, Data)--$(derivingG2Rep ''Expr)--type Env = [(Id, Expr)]--eval :: Env -> Expr -> Expr-eval env (Var id) =- case lookup id env of- Just expr -> eval env expr- Nothing -> Const (Fun id)-eval env (App (Lam i body) arg) =- eval ((i, arg) : env) body-eval env expr = expr-
− quasiquote/Lambda/Test.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module Lambda.Test where--import Lambda.Interpreter-import G2.QuasiQuotes.QuasiQuotes--lambdaTest1 :: IO (Maybe Expr)-lambdaTest1 = [g2| \(x :: Int ) -> ?(symExpr :: Expr) |- let env = [] in- let expr = App (Lam "b" (Var "b")) symExpr in- eval env expr == (Const (I 40)) |] 0---lambdaTest2 :: IO (Maybe Expr)-lambdaTest2 = [g2| \(x :: Int ) -> ?(symExpr :: Expr) |- let env = [] in- let expr = symExpr in- eval env expr == (Const (I 43)) |] 0
− quasiquote/Main.hs
@@ -1,255 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module Main where--import DeBruijn.Test-import Arithmetics.Test-import Lambda.Test-import NQueens.Test-import RegEx.Test--import Evaluations hiding (productSumTest)--arithmeticsTests :: IO ()-arithmeticsTests = do- putStrLn "---------------------"- putStrLn "arithmeticsTests ----"-- putStrLn "-- productTest"- timeIOActionPrint productTest- putStrLn ""-- putStrLn "-- productSumTest"- timeIOActionPrint productSumTest- putStrLn ""-- putStrLn "-- assertViolationTest1"- timeIOActionPrint assertViolationTest1- putStrLn ""-- -- Technically this is non-linear integer arithm so undecidable- -- putStrLn "-- assertViolationTest2"- -- timeIOActionPrint assertViolationTest2- -- putStrLn ""-- -- About 6 secs- putStrLn "-- assertViolationTest3"- timeIOActionPrint assertViolationTest3- putStrLn ""-- -- About 51 secs- putStrLn "-- assertViolationTest4"- timeIOActionPrint assertViolationTest4- putStrLn ""----- putStrLn "---------------------\n\n"---lambdaTests :: IO ()-lambdaTests = do- putStrLn "---------------------"- putStrLn "lambdaTests ---------"-- putStrLn "-- lambdaTest1"- timeIOActionPrint lambdaTest1- putStrLn ""-- putStrLn "-- lambdaTest2"- timeIOActionPrint lambdaTest2- putStrLn ""-- putStrLn "---------------------\n\n"- return ()---nqueensTests :: IO ()-nqueensTests = do- putStrLn "---------------------"- putStrLn "nqueensTests --------"-- putStrLn "-- queensTestN 4"- timeIOActionPrint $ queensTestN 4- putStrLn ""-- putStrLn "-- queensTestN 5"- timeIOActionPrint $ queensTestN 5- putStrLn ""-- putStrLn "-- queensTestN 6"- timeIOActionPrint $ queensTestN 6- putStrLn ""-- putStrLn "-- queensTestN 7"- timeIOActionPrint $ queensTestN 7- putStrLn ""-- putStrLn "-- queensTestN 8"- timeIOActionPrint $ queensTestN 8- putStrLn ""-- putStrLn "---------------------\n\n"- return ()---debruijnTests :: IO ()-debruijnTests = do- putStrLn "---------------------"- putStrLn "debruijnTests -------"-- putStrLn "-- solveDeBruijnI" -- identity- timeIOActionPrint $ solveDeBruijnI-- putStrLn "-- solveDeBruijnK" -- const- timeIOActionPrint $ solveDeBruijnK-- putStrLn "-- solveDeBruijnOr"- timeIOActionPrint $ solveDeBruijnOr-- -- putStrLn "-- solveDeBruijnAnd"- -- timeIOActionPrint $ solveDeBruijnAnd-- putStrLn "-- solveDeBruijnIte"- timeIOActionPrint $ solveDeBruijnIte-- putStrLn "---------------------\n\n"- return ()--regexTests :: IO ()-regexTests = do- putStrLn "---------------------"- putStrLn "regexTests ----------"-- putStrLn "-- regexTest1"- timeIOActionPrint regexTest1- putStrLn ""-- putStrLn "-- regexTest2"- timeIOActionPrint regexTest2- putStrLn ""-- putStrLn "---------------------\n\n"- return ()----main :: IO ()-main = do- putStrLn "main: compiles!"-- -- arithmeticsTests- -- lambdaTests- -- nqueensTests- -- debruijnTests- -- regexTests-- nqueensTests- runArithmeticsEval- runDeBruijnEval- runRegExEval---- putStrLn "main: done"--- -- print =<< queensTestN 6- -- print =<< solveDeBruijnI- -- print =<< solveDeBruijnK- -- print =<< lambdaTest2- - -- putStrLn "-- Basic Test --"- -- r <- f 8 10- -- print r-- -- r2 <- g 7- -- print r2-- -- r3 <- h 11- -- print r3- - -- putStrLn "\n-- Bool Test --"- -- print =<< boolTest 2- -- print =<< boolTest 4-- -- putStrLn "\n-- maybeOrdering Test --"- -- print =<< maybeOrderingTest (Just LT)-- -- putStrLn "\n-- Rearrange Tuples Test --"- -- print =<< rearrangeTuples (4, 5) (-6, -4)-- -- putStrLn "\n-- Float Test --"- -- print =<< floatTest (6.7) (9.5)-- -- putStrLn "\n-- Double Test --"- -- print =<< doubleTest (2.2) (4.9)-- -- putStrLn "\n-- String Test --"- -- print =<< stringTest "hiiiiiiiiiiiiiiiit!"-- -- putStrLn "\n-- Import Test --"- -- print =<< importTest 5-- -- putStrLn "\n-- Infinite Test --"- -- print =<< infiniteTest [5..]-- -- putStrLn "\n-- Infinite Test 2 --"- -- print =<< infiniteTest2 [5..] 3-- -- putStrLn "\n-- Infinite Return --"- -- ir <- infiniteReturn 8- -- print $ fmap (headInf . tailInf) ir---- fBad1 :: Float -> Int -> IO (Maybe Int)--- fBad1 = [g2|(\y z -> \x ? x + 2 == y + z) :: Int -> Int -> Int -> Bool|]---- fBad2 :: Int -> Int -> IO (Maybe Float)--- fBad2 = [g2|(\y z -> \x ? x + 2 == y + z) :: Int -> Int -> Int -> Bool|]---- f :: Int -> Int -> IO (Maybe Int)--- f = [g2|\(y :: Int) (z :: Int) -> ?(x :: Int) | x + 2 == y + z|]---- g :: Int -> IO (Maybe (Int, Int))--- g = [g2|\(a :: Int) -> ?(x :: Int) ?(y :: Int) | x < a && a < y && y - x > 10|]---- h :: Int -> IO (Maybe [Int])--- h = [g2|\(total :: Int) -> ?(lst :: [Int]) | sum lst == total && length lst >= 2|]---- boolTest :: Int -> IO (Maybe Bool)--- boolTest = [g2|\(i ::Int) -> ?(b :: Bool) | (i == 4) == b|]---- maybeOrderingTest :: Maybe Ordering -> IO (Maybe (Maybe Ordering))--- maybeOrderingTest = [g2|\(m1 :: Maybe Ordering) -> ?(m2 :: Maybe Ordering) | (fmap succ m1 == m2)|]---- rearrangeTuples :: (Int, Int) -> (Int, Int) -> IO (Maybe (Int, Int))--- rearrangeTuples = [g2|\(ux :: (Int, Int)) (yz :: (Int, Int)) -> ?(ab :: (Int, Int)) |--- let--- (u, x) = ux--- (y, z) = yz--- (a, b) = ab--- in--- (a == u || a == y)--- && (b == x || b == z) && (a + b == 0 )|]---- floatTest :: Float -> Float -> IO (Maybe Float)--- floatTest = [g2|\(f1 :: Float) (f2 :: Float) -> ?(f3 :: Float) | f1 < f3 && f3 < f2|]---- doubleTest :: Double -> Double -> IO (Maybe Double)--- doubleTest = [g2|\(d1 :: Double) (d2 :: Double) -> ?(d3 :: Double) | d1 <= d3 && d3 <= d2|]---- stringTest :: String -> IO (Maybe String)--- stringTest = [g2|\(str1 :: String) -> ?(str2 :: String) | str1 == str2 ++ "!"|]---- importTest :: Int -> IO (Maybe Int)--- importTest = [g2|\(x :: Int) -> ?(ans :: Int) | addTwo x == ans|]---- infiniteTest :: [Int] -> IO (Maybe Int)--- infiniteTest = [g2|\(xs :: [Int]) -> ?(x :: Int) | x == head xs|]---- infiniteTest2 :: [Int] -> Int -> IO (Maybe [Int])--- infiniteTest2 = [g2|\(xs :: [Int]) (t :: Int) -> ?(ys :: [Int]) | ys == take t xs|]---- infiniteReturn :: Int -> IO (Maybe (InfList Int))--- infiniteReturn = [g2|\(t :: Int) -> ?(ys :: InfList Int) | headInf ys == t |]
− quasiquote/NQueens/Encoding.hs
@@ -1,62 +0,0 @@-module NQueens.Encoding where--import Data.List--type Queen = Int--indexPairs :: Int -> [(Int,Int)]-indexPairs n = [(i, j) | i <- [0..n-1], j <- [i+1..n-1]]--legal :: Int -> Queen -> Bool-legal n qs = 1 <= qs && qs <= n--queenPairSafe :: Int -> [Queen] -> (Int, Int) -> Bool-queenPairSafe n qs (i, j) =- let qs_i = qs !! i- qs_j = qs !! j- in (qs_i /= qs_j)- -- && (abs (qs_j - qs_i) /= (j - i))- && qs_j - qs_i /= j - i- && qs_j - qs_i /= i - j--allQueensSafe :: Int -> [Queen] -> Bool-allQueensSafe n qs =- (n == length qs)- && all (legal n) qs- && (all (queenPairSafe n qs) (indexPairs n))--solveListCompN :: Int -> [Int]-solveListCompN n =- head . filter (allQueensSafe n) $ [x | x <- mapM (const [1..n]) [1..n]]--{---- Gets all pairs of unique positions-pairs :: Ord a => [a] -> [(a, a)]-pairs xs = [(a, b) | a <- xs, b <- xs, a < b]---- Checks if all elements of list are unique-allUnique :: Ord a => [a] -> Bool-allUnique xs = length xs == length (nub xs)---- Check if two positions are safe-pairSafe :: (Queen, Queen) -> Bool-pairSafe ((x1, y1), (x2, y2)) =- -- No same x and y value- (x1 /= x2) && (y1 /= y2)- -- Not on the same diagonal- && (abs (x1 - x2) /= abs (y1 - y2))---- Check that all queens in a list are safe-allSafe :: [Queen] -> Bool-allSafe queens = all pairSafe $ pairs queens---- Valid Queens on an n x n board-legalQueens :: Int -> [Queen] -> Bool-legalQueens n queens =- (length queens == n)- && (n == length (nub queens))- && all (\(x, y) -> 1 <= x && x <= n && 1 <= y && y <= n) queens- -- && all (\p -> (1, 1) <= p && p <= (n, n)) queens---}-
− quasiquote/NQueens/Test.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module NQueens.Test where--import NQueens.Encoding-import G2.QuasiQuotes.QuasiQuotes--{--queensTestN :: Int -> IO (Maybe [Queen])-queensTestN n = [g2| \(n :: Int) -> ?(queens :: [Queen]) |- legalQueens n queens- && allSafe queens |] n--}--queensTestN :: Int -> IO (Maybe [Queen])-queensTestN num = [g2| \(n :: Int) -> ?(qs :: [Queen]) |- allQueensSafe n qs |] num--
− quasiquote/RegEx/RegEx.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--module RegEx.RegEx where--import Data.Data-import G2.QuasiQuotes.G2Rep---data RegEx = Empty | Epsilon | Atom Char- | Star RegEx | Concat RegEx RegEx | Or RegEx RegEx- deriving (Show, Eq, Data)--$(derivingG2Rep ''RegEx)--match :: RegEx -> String -> Bool-match Empty _ = False-match Epsilon s = null s-match (Atom x) s = s == [x]-match (Star _) [] = True-match r@(Star x) s = any (match2 x r)- (splits [1..length s] s)-match (Concat a b) s = any (match2 a b)- (splits [0..length s] s)-match (Or a b) s = match a s || match b s--match2 :: RegEx -> RegEx -> (String, String) -> Bool-match2 a b (sa, sb) = match a sa && match b sb--splits :: [Int] -> [a] -> [([a], [a])]-splits ns x = map (\n -> splitAt n x) ns----
− quasiquote/RegEx/Test.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module RegEx.Test where--import RegEx.RegEx-import G2.QuasiQuotes.QuasiQuotes--regexTest1 :: IO (Maybe String)-regexTest1 = stringSearch (Concat (Atom 'a') (Atom 'b'))--regexTest2 :: IO (Maybe String)-regexTest2 = stringSearch r- where- r = Concat- (Star (Or (Atom 'a') (Atom 'b')))- (Concat (Atom 'c')- (Or (Atom 'd')- (Concat (Atom 'e')- (Atom 'f'))))- --stringSearch :: RegEx -> IO (Maybe String)-stringSearch = [g2| \(r :: RegEx) -> ?(str :: String) |- match r str |]-
src/G2/Config/Config.hs view
@@ -1,27 +1,50 @@ module G2.Config.Config ( Mode (..)+ , LogMode (..)+ , LogMethod (..)+ , Sharing (..) , SMTSolver (..)+ , SearchStrategy (..) , HigherOrderSolver (..) , IncludePath , Config (..) , BoolDef (..) , mkConfig+ , mkConfigDirect++ , mkLogMode+ , strArg- , boolArg) where+ , boolArg+ , boolArg' + , baseDef+ , baseSimple) where + import Data.Char import Data.List import qualified Data.Map as M+import Data.Monoid ((<>))+import Options.Applicative+import Text.Read -import System.Directory+data Mode = Regular | Liquid deriving (Eq, Show, Read) +data LogMode = Log LogMethod String | NoLog deriving (Eq, Show, Read) -data Mode = Regular | Liquid deriving (Eq, Show, Read)+data LogMethod = Raw | Pretty deriving (Eq, Show, Read) +-- | Do we use sharing to only reduce variables once?+data Sharing = Sharing | NoSharing deriving (Eq, Show, Read)+ data SMTSolver = ConZ3 | ConCVC4 deriving (Eq, Show, Read) +data SearchStrategy = Iterative | Subpath deriving (Eq, Show, Read)+ data HigherOrderSolver = AllFuncs- | SingleFunc deriving (Eq, Show, Read)+ | SingleFunc+ | SymbolicFunc + | SymbolicFuncTemplate deriving (Eq, Show, Read) type IncludePath = FilePath @@ -31,82 +54,176 @@ , base :: [FilePath] -- ^ Filepath(s) to base libraries. Get compiled in order from left to right , extraDefaultInclude :: [IncludePath] , extraDefaultMods :: [FilePath]- , logStates :: Maybe String -- ^ If Just, dumps all thes states into the given folder+ , logStates :: LogMode -- ^ Determines whether to Log states, and if logging states, how to do so.+ , sharing :: Sharing , maxOutputs :: Maybe Int -- ^ Maximum number of examples/counterexamples to output. TODO: Currently works only with LiquidHaskell- , printCurrExpr :: Bool -- ^ Controls whether the curr expr is printed- , printExprEnv :: Bool -- ^ Controls whether the expr env is printed- , printRelExprEnv :: Bool -- ^ Controls whether the portion of the expr env relevant to the curr expr and path constraints is printed- , printPathCons :: Bool -- ^ Controls whether path constraints are printed , returnsTrue :: Bool -- ^ If True, shows only those inputs that do not return True , higherOrderSolver :: HigherOrderSolver -- ^ How to try and solve higher order functions+ , search_strat :: SearchStrategy -- ^ The search strategy for the symbolic executor to use+ , subpath_length :: Int -- ^ When using subpath search strategy, the length of the subpaths. , smt :: SMTSolver -- ^ Sets the SMT solver to solve constraints with , steps :: Int -- ^ How many steps to take when running States- , cut_off :: Int -- ^ How many steps to take after finding an equally good equiv state, in LH mode- , switch_after :: Int --- ^ How many steps to take in a single step, in LH mode+ , hpc :: Bool -- ^ Should HPC ticks be generated and tracked during execution? , strict :: Bool -- ^ Should the function output be strictly evaluated? , timeLimit :: Int -- ^ Seconds- , validate :: Bool -- ^ If True, HPC is run on G2's output, to measure code coverage. TODO: Currently doesn't work- -- , baseLibs :: [BaseLib]+ , validate :: Bool -- ^ If True, run on G2's input, and check against expected output. } --- mkConfigDef :: Config--- mkConfigDef = mkConfig [] M.empty+mkConfig :: String -> Parser Config+mkConfig homedir = Config Regular+ <$> mkBaseInclude homedir+ <*> mkBase homedir+ <*> mkExtraDefault homedir+ <*> pure []+ <*> mkLogMode+ <*> flag Sharing NoSharing (long "no-sharing" <> help "disable sharing")+ <*> mkMaxOutputs+ <*> switch (long "returns-true" <> help "assert that the function returns true, show only those outputs which return false")+ <*> mkHigherOrder+ <*> mkSearchStrategy+ <*> option auto (long "subpath-len"+ <> metavar "L"+ <> value 4+ <> help "when using subpath search strategy, the length of the subpaths")+ <*> mkSMTSolver+ <*> option auto (long "n"+ <> metavar "N"+ <> value 1000+ <> help "how many steps to take when running states")+ <*> flag False True (long "hpc"+ <> help "Generate and report on HPC ticks")+ <*> flag True False (long "no-strict" <> help "do not evaluate the output strictly")+ <*> option auto (long "time"+ <> metavar "T"+ <> value 600+ <> help "time limit, in seconds")+ <*> switch (long "validate" <> help "use GHC to automatically compile and run on generated inputs, and check that generated outputs are correct") -baseRoot :: IO FilePath-baseRoot = do- g2Dir <- getHomeDirectory >>= \f -> return $ f ++ "/.g2"- return $ g2Dir ++ "/base-4.9.1.0"+mkBaseInclude :: String -> Parser [IncludePath]+mkBaseInclude homedir =+ option (eitherReader (Right . baseIncludeDef))+ ( long "base"+ <> metavar "FILE"+ <> value (baseIncludeDef homedir)+ <> help "where to look for base files") +mkBase :: String -> Parser [IncludePath]+mkBase homedir =+ option (eitherReader (Right . baseDef))+ ( long "base-def"+ <> metavar "FILE"+ <> value (baseDef homedir)+ <> help "where to look for base files") -mkConfig :: String -> [String] -> M.Map String [String] -> Config-mkConfig homedir as m = Config {+mkExtraDefault :: String -> Parser [IncludePath]+mkExtraDefault homedir =+ option (eitherReader (\v -> Right (v:extraDefaultIncludePaths homedir)))+ ( long "extra-def"+ <> metavar "FILE"+ <> value (extraDefaultIncludePaths homedir)+ <> help "where to look for base files")++mkLogMode :: Parser LogMode+mkLogMode =+ (option (eitherReader (Right . Log Raw))+ (long "log-states"+ <> metavar "FOLDER"+ <> value NoLog+ <> help "log all states with raw printing"))+ <|>+ (option (eitherReader (Right . Log Pretty))+ (long "log-pretty"+ <> metavar "FOLDER"+ <> value NoLog+ <> help "log all states with pretty printing"))++mkMaxOutputs :: Parser (Maybe Int)+mkMaxOutputs =+ option (maybeReader (Just . readMaybe))+ ( long "max-outputs"+ <> metavar "MAX"+ <> value Nothing+ <> help "the maximum number of input/output pairs to output")++mkHigherOrder :: Parser HigherOrderSolver+mkHigherOrder =+ option (eitherReader (\s -> case s of+ "all" -> Right AllFuncs+ "single" -> Right SingleFunc+ "symbolic" -> Right SymbolicFunc+ "symbolic-temp" -> Right SymbolicFuncTemplate+ _ -> Left "Unsupported higher order function handling"))+ ( long "higher-order"+ <> metavar "HANDLING"+ <> value SingleFunc+ <> help "either all or single, to specify whether all possible higher order instantiations should be searched for, or just a single instantiation")++mkSMTSolver :: Parser SMTSolver+mkSMTSolver =+ option (eitherReader (\s -> case s of+ "z3" -> Right ConZ3+ "cvc4" -> Right ConCVC4+ _ -> Left "Unsupported SMT solver"))+ ( long "smt"+ <> metavar "SMT-SOLVER"+ <> value ConZ3+ <> help "either z3 or cvc4, to select the solver to use")++mkSearchStrategy :: Parser SearchStrategy+mkSearchStrategy =+ option (eitherReader (\s -> case s of+ "iter" -> Right Iterative+ "subpath" -> Right Subpath+ _ -> Left "Unsupported search strategy"))+ ( long "search"+ <> metavar "SEARCH"+ <> value Iterative+ <> help "either iter or subpath, to select a search strategy")++mkConfigDirect :: String -> [String] -> M.Map String [String] -> Config+mkConfigDirect homedir as m = Config { mode = Regular , baseInclude = baseIncludeDef (strArg "base" as m id homedir) , base = baseDef (strArg "base" as m id homedir) , extraDefaultInclude = extraDefaultIncludePaths (strArg "extra-base-inc" as m id homedir)- , extraDefaultMods = extraDefaultPaths (strArg "extra-base" as m id homedir)- , logStates = strArg "log-states" as m Just Nothing+ , extraDefaultMods = []+ , logStates = strArg "log-states" as m (Log Raw)+ (strArg "log-pretty" as m (Log Pretty) NoLog)+ , sharing = boolArg' "sharing" as Sharing Sharing NoSharing+ , maxOutputs = strArg "max-outputs" as m (Just . read) Nothing- , printCurrExpr = boolArg "print-ce" as m Off- , printExprEnv = boolArg "print-eenv" as m Off- , printPathCons = boolArg "print-pc" as m Off- , printRelExprEnv = boolArg "print-rel-eenv" as m Off , returnsTrue = boolArg "returns-true" as m Off , higherOrderSolver = strArg "higher-order" as m higherOrderSolArg SingleFunc+ , search_strat = Iterative+ , subpath_length = 4 , smt = strArg "smt" as m smtSolverArg ConZ3 , steps = strArg "n" as m read 1000- , cut_off = strArg "cut-off" as m read 600- , switch_after = strArg "switch-after" as m read 300+ , hpc = False , strict = boolArg "strict" as m On , timeLimit = strArg "time" as m read 300 , validate = boolArg "validate" as m Off- -- , baseLibs = [BasePrelude, BaseException] } baseIncludeDef :: FilePath -> [FilePath] baseIncludeDef root = [ root ++ "/.g2/base-4.9.1.0/Control/Exception/"- , root ++ "/.g2/base-4.9.1.0/" , root ++ "/.g2/base-4.9.1.0/" , root ++ "/.g2/base-4.9.1.0/Data/Internal/" ] baseDef :: FilePath -> [FilePath]-baseDef root =+baseDef root = baseSimple root++baseSimple :: FilePath -> [FilePath]+baseSimple root = [ root ++ "/.g2/base-4.9.1.0/Control/Exception/Base.hs" , root ++ "/.g2/base-4.9.1.0/Prelude.hs"- , root ++ "/.g2/base-4.9.1.0/Control/Monad.hs"- , root ++ "/.g2/base-4.9.1.0/Data/Internal/Map.hs"- ]+ , root ++ "/.g2/base-4.9.1.0/Control/Monad.hs" ] extraDefaultIncludePaths :: FilePath -> [FilePath] extraDefaultIncludePaths root = [ root ++ "/.g2/G2Stubs/src/" ] -extraDefaultPaths :: FilePath -> [FilePath]-extraDefaultPaths root =- [ root ++ "/.g2/G2Stubs/src/G2/QuasiQuotes/G2Rep.hs" ] - smtSolverArg :: String -> SMTSolver smtSolverArg = smtSolverArg' . map toLower @@ -142,6 +259,15 @@ Just st -> strToBool st d Nothing -> d +boolArg' :: String -> [String] -> b -> b -> b -> b+boolArg' s a b_default b1 b2 =+ if "--" ++ s `elem` a + then b1+ else if "--no-" ++ s `elem` a + then b2+ else b_default++ strToBool :: [String] -> Bool -> Bool strToBool [s] b | s' == "true" = True@@ -167,16 +293,3 @@ strToArg :: [String] -> (String -> a) -> a -> a strToArg [s] f _ = f s strToArg _ _ d = d--strArgs :: String -> [String] -> M.Map String [String] -> (String -> a) -> [a] -> [a]-strArgs s a m f d = - case elemIndex ("--" ++ s) a of- Just i -> if i >= length a- then error ("Invalid use of " ++ s)- else [f (a !! (i + 1))]- Nothing -> case M.lookup s m of - Just st -> strsToArgs st f- Nothing -> d--strsToArgs :: [String] -> (String -> a) -> [a]-strsToArgs = flip map
src/G2/Config/Interface.hs view
@@ -1,32 +1,50 @@ module G2.Config.Interface where import G2.Config.Config-import G2.Config.ParseConfig -import qualified Data.Map as M+import qualified Data.Map.Lazy as M+import Data.Monoid ((<>))+import Options.Applicative import System.Directory configName :: FilePath configName = "g2.cfg" -getConfig :: [String] -> IO Config-getConfig ars = do- let con = strArg "config" ars M.empty id configName-- ex <- configExists con+getConfigDirect :: IO Config+getConfigDirect = do+ homedir <- getHomeDirectory+ return $ mkConfigDirect homedir [] M.empty +getConfig :: IO (String, String, Maybe String, Maybe String, Config)+getConfig = do homedir <- getHomeDirectory- case ex of- True -> do- conf <- parseConfig con+ execParser (mkConfigInfo homedir) - case conf of- Right conf' -> return (mkConfig homedir ars conf')- Left e -> do- putStrLn "Configuration file parsing error:"- print e- return (mkConfig homedir ars M.empty)- False -> return (mkConfig homedir ars M.empty)+mkConfigInfo :: String -> ParserInfo (String, String, Maybe String, Maybe String, Config)+mkConfigInfo homedir =+ info (((,,,,)+ <$> getFileName+ <*> getFunctionName+ <*> option (eitherReader (Right . Just))+ (long "assume"+ <> metavar "F"+ <> value Nothing+ <> help "a function to use as an assumption")+ <*> option (eitherReader (Right . Just))+ (long "assert"+ <> metavar "F"+ <> value Nothing+ <> help "a function to use as an assertion")+ <*> mkConfig homedir) <**> helper)+ ( fullDesc+ <> progDesc "Symbolic Execution of Haskell code"+ <> header "The G2 Symbolic Execution Engine" )++getFileName :: Parser String+getFileName = argument str (metavar "FILE")++getFunctionName :: Parser String+getFunctionName = argument str (metavar "FUNCTION") configExists :: FilePath -> IO Bool configExists cn = do
+ src/G2/Data/Timer.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleInstances #-}++module G2.Data.Timer ( Timer+ , TimerLog+ , newTimer+ , logEventStart+ , logEventEnd+ , getLog++ , runTimer+ , logEventStartM+ , logEventEndM+ , getLogM++ , orderLogBySpeed+ , sumLog+ , mapLabels+ , logToSecs ) where++import Control.Monad.IO.Class +import Control.Monad.State.Lazy+import Data.Ord+import Data.List+import System.Clock++type TimerLog label = [(label, TimeSpec)]++data Timer label =+ Timer { timer_log :: TimerLog label -- ^ Labelled events with time measurements (in picoseconds)+ , for_next :: Maybe (label, TimeSpec) -- ^ What is the next label, and when did we start timing?+ }++newTimer :: IO (Timer label)+newTimer = do+ return $ Timer { timer_log = []+ , for_next = Nothing } ++logEventStart :: label -> Timer label -> IO (Timer label)+logEventStart label timer = do+ curr <- getTime Realtime+ return $ logEventStart' label curr timer++logEventStart' :: label -> TimeSpec -> Timer label -> Timer label+logEventStart' label curr timer@( Timer { for_next = Nothing }) =+ timer { for_next = Just (label, curr) } +logEventStart' _ _ _ = error "Timer started before ending"++logEventEnd :: Timer label -> IO (Timer label)+logEventEnd timer = do+ curr <- getTime Realtime+ return $ logEventEnd' curr timer++logEventEnd' :: TimeSpec -> Timer label -> Timer label+logEventEnd' curr (Timer { timer_log = lg, for_next = Just (label, lst) }) =+ Timer { timer_log = (label, curr - lst):lg+ , for_next = Nothing }+logEventEnd' _ _ = error "Timer ended but never started"++getLog :: Timer label -> TimerLog label+getLog = timer_log++runTimer :: StateT (Timer label) m a -> Timer label -> m (a, Timer label)+runTimer = runStateT++logEventStartM :: MonadIO m => label -> StateT (Timer label) m ()+logEventStartM n = do+ curr <- liftIO $ getTime Realtime+ modify' (logEventStart' n curr)++logEventEndM :: MonadIO m => StateT (Timer label) m ()+logEventEndM = do+ curr <- liftIO $ getTime Realtime+ modify' (logEventEnd' curr)++getLogM :: Monad m => StateT (Timer label) m (TimerLog label)+getLogM = gets getLog++-- Working with the generated logs+orderLogBySpeed :: TimerLog label -> TimerLog label+orderLogBySpeed = reverse . sortBy (comparing snd)++sumLog :: Eq label => TimerLog label -> TimerLog label+sumLog tl =+ let+ labs = nub $ map fst tl+ grped = map (sum . map snd)+ $ map (\l -> filter (\(l', _) -> l == l') tl) labs+ in+ zip labs grped++mapLabels :: (label1 -> label2) -> TimerLog label1 -> TimerLog label2+mapLabels f = map (\(l, i) -> (f l, i))++logToSecs :: TimerLog label -> [(label, Double)]+logToSecs = map (\(l, s) -> (l, fromInteger (toNanoSecs s) / (10 ^ (9 :: Int) :: Double)))
+ src/G2/Data/UFMap.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-}++module G2.Data.UFMap ( UFMap+ , empty+ , toList+ , fromList+ , toSet+ , fromSet+ , toSimpleMap+ , join+ , joinAll+ , lookup+ , lookupWithRep+ , (!)+ , find+ , insert+ , insertWith+ , adjust+ , alter+ , clear+ , filterWithKey++ , unionWith+ , mergeJoiningWithKey++ , map++ , null+ , keys+ , joinedKeys+ , elems+ , member) where++import qualified G2.Data.UnionFind as UF++import Control.Exception+import qualified Control.Monad as Mon++import Data.Data (Data (..), Typeable)+import Data.Hashable+import qualified Data.HashMap.Lazy as M+import qualified Data.HashSet as S+import qualified Data.List as L+import Data.Maybe++import Prelude hiding (lookup, null, map)+import qualified Prelude as P++import Text.Read+import qualified Text.Read.Lex as L+import GHC.Read++import GHC.Generics (Generic)++import Test.Tasty.QuickCheck++-- | A map allowing inserts and lookups via keys, and for sets of keys to be+-- unioned so that all keys in the set point to the same element.+-- Keys @k1@ and @k2@ may be unioned regardless of whether both are already in the `UFMap`.+-- If @k1@ and @k2@ are unioned without either being in the `UFMap`, and then a value+-- for either is inserted, the other will also then point to that value.+data UFMap k v = UFMap { joined :: UF.UnionFind k+ , store :: M.HashMap k v }+ deriving (Typeable, Data, Generic)++instance (Eq k, Hashable k, Hashable v) => Hashable (UFMap k v)++-- | An empty `UFMap`. +empty :: UFMap k v+empty = UFMap UF.empty M.empty++-- | Convert a @`UFMap` k v@ to a list. Each tuple in the list contains a list of+-- unioned keys, alongside a @`Maybe` v@. If the keys were pointing to a value+-- @v@ in the Map, this is @`Just` v@, otherwise it is `Nothing`. +toList :: (Eq k, Hashable k) => UFMap k v -> [([k], Maybe v)]+toList uf =+ let+ uf_l = UF.toList $ joined uf++ c_uf_l = concat uf_l+ not_acc = P.map (:[]) $ keys uf L.\\ c_uf_l+ in+ P.map (\l -> (l, lookup (head l) uf)) $ uf_l ++ not_acc++toSet :: (Eq k, Eq v, Hashable k, Hashable v) => UFMap k v -> S.HashSet (S.HashSet k, Maybe v)+toSet = S.fromList . P.map (\(ks, v) -> (S.fromList ks, v)) . toList++fromList :: (Eq k, Hashable k) => [([k], Maybe v)] -> UFMap k v+fromList xs =+ let+ xs_j = concatMap (\(ks, v) -> case v of + Just v' -> P.map (\k -> (k, v')) ks+ Nothing -> [] ) xs+ m = foldr (uncurry insert) empty xs_j+ in+ foldr (\(ks, _) m' ->+ case ks of+ [] -> m'+ (k:_) -> foldr (\k' -> join const k k') m' ks)+ m xs++fromSet :: (Eq k, Hashable k) => S.HashSet (S.HashSet k, Maybe v) -> UFMap k v+fromSet = fromList . P.map (\(ks, v) -> (S.toList ks, v)) . S.toList++toSimpleMap :: UFMap k v -> M.HashMap k v+toSimpleMap = store++-- | Joins two keys, regardless of whether they are present in the map.+-- If the keys are already joined, the map is not changed+join :: (Eq k, Hashable k) => (v -> v -> v) -> k -> k -> UFMap k v -> UFMap k v+join f k1 k2 ufm@(UFMap uf m)+ | UF.find k1 uf == UF.find k2 uf = ufm+ | otherwise =+ let+ (r1, v1) = lookupWithRep k1 ufm+ (r2, v2) = lookupWithRep k2 ufm++ uf' = UF.union k1 k2 uf+ r = UF.find k1 uf'++ m' = M.delete r1 . M.delete r2 $ m++ m'' = case (v1, v2) of+ (Just v1', Just v2') -> M.insert r (f v1' v2') m'+ (Just v1', _) -> M.insert r v1' m'+ (_, Just v2') -> M.insert r v2' m'+ _ -> m+ in+ assert (isNothing (M.lookup k1 m'') || isNothing (M.lookup k2 m''))+ UFMap uf' m''++joinAll :: (Eq k, Hashable k) => (v -> v -> v) -> [k] -> UFMap k v -> UFMap k v+joinAll _ [] uf = uf+joinAll f xs@(x:_) uf = foldr (join f x) uf xs++-- | Lookup the value at a key in the `UFMap`.+-- Returns the corresponding @`Just` v@, or `Nothing` if the key isn't in the map.+lookup :: (Eq k, Hashable k) => k -> UFMap k v -> Maybe v+lookup k = snd . lookupWithRep k++-- | Lookup the value at a key in the `UFMap`, as well as the representative of the key.+-- Returns the corresponding value as @`Just` v@, or `Nothing` if the key isn't in the map.+lookupWithRep :: (Eq k, Hashable k) => k -> UFMap k v -> (k, Maybe v)+lookupWithRep k (UFMap uf m) =+ let r = UF.find k uf in+ (r, M.lookup r m)++-- | Find the representative of the key in the `UFMap`.+find :: (Eq k, Hashable k) => k -> UFMap k v -> k+find k = UF.find k . joined++-- | Lookup the value at a key in the `UFMap`.+-- The function will call error if the key isn't in the map.+(!) :: (Eq k, Hashable k) => UFMap k v -> k -> v+uf ! k = case lookup k uf of+ Just v -> v+ Nothing -> error "!: key not found"++-- | Adds a key-value pair to the `UFMap`.+-- If the key is already in the map, it's value is overwritten.+insert :: (Eq k, Hashable k) => k -> v -> UFMap k v -> UFMap k v+insert k v (UFMap uf m) =+ let+ m' = M.insert (UF.find k uf) v m+ in+ assert (UF.find k uf == k || isNothing (M.lookup k m'))+ UFMap uf m'++insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> UFMap k v -> UFMap k v+insertWith f k v (UFMap uf m) = UFMap uf $ M.insertWith f (UF.find k uf) v m++adjust :: (Eq k, Hashable k) => (v -> v) -> k -> UFMap k v -> UFMap k v+adjust f k (UFMap uf m) = UFMap uf $ M.adjust f (UF.find k uf) m++alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> UFMap k v -> UFMap k v+alter f k (UFMap uf m) = UFMap uf $ M.alter f (UF.find k uf) m++-- | Preserves the joined keys, but deletes all contained elements+clear :: UFMap k v -> UFMap k v+clear (UFMap uf _) = UFMap uf M.empty++filterWithKey :: (k -> v -> Bool) -> UFMap k v -> UFMap k v+filterWithKey p (UFMap uf m) = UFMap uf $ M.filterWithKey p m++unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> UFMap k v -> UFMap k v -> UFMap k v+unionWith f ufm1 (UFMap uf2 m2) =+ let+ ufm1' = foldr (joinAll f) ufm1 (UF.toList uf2) + in+ M.foldrWithKey (insertWith f) ufm1' m2 ++-- One key (from the joined set of keys) is given+mergeJoiningWithKey :: (Eq k, Hashable k, Show k, Show v, Show v1, Show v2)+ => (k -> v1 -> v2 -> (v, [(k, k)])) -- ^ How to merge values that are joined from both maps+ -> (k -> v1 -> (v, [(k, k)])) -- ^ How to merge values of keys only in the first map+ -> (k -> v2 -> (v, [(k, k)])) -- ^ How to merge values of keys only in the second map+ -> (v1 -> v1 -> v1) -- ^ How to merge values that are joined within the first map+ -> (v2 -> v2 -> v2) -- ^ How to merge values that are joined within the second map+ -> (v -> v -> v) -- ^ Final extra joins, generated by prior higher order functions+ -> UFMap k v1+ -> UFMap k v2+ -> UFMap k v+mergeJoiningWithKey fb f1 f2 fj1 fj2 j (UFMap uf1 m1) (UFMap uf2 m2) =+ let+ j_uf = UF.unionOfUFs uf1 uf2++ -- We build a map where the keys are the values of j_f, and the values have type (Maybe v1, Maybe v2)+ j_m1 = foldr (\(k, v) m ->+ let uf_k = UF.find k j_uf in+ case M.lookup uf_k m of+ Nothing -> M.insert uf_k (Just v, Nothing) m+ Just (Nothing, _) -> M.insert uf_k (Just v, Nothing) m+ Just (Just v1, v2) -> M.insert uf_k (Just $ fj1 v v1, v2) m+ ) M.empty (M.toList m1)+ j_m2 = foldr (\(k, v) m ->+ let uf_k = UF.find k j_uf in+ case M.lookup uf_k m of+ Nothing -> M.insert uf_k (Nothing, Just v) m+ Just (v1, Nothing) -> M.insert uf_k (v1, Just v) m+ Just (v1, Just v2) -> M.insert uf_k (v1, Just $ fj2 v v2) m+ ) j_m1 (M.toList m2)++ j_m = M.mapWithKey (\k (v1, v2) -> case (v1, v2) of+ (Just v1', Just v2') -> fb k v1' v2'+ (Just v1', Nothing) -> f1 k v1'+ (Nothing, Just v2') -> f2 k v2'+ _ -> error "merge: impossible state!") j_m2++ ks = concat . M.elems $ M.map snd j_m++ n_ufm = UFMap j_uf $ M.map fst j_m+ n_ufm' = foldr (uncurry (join j)) n_ufm ks+ in+ n_ufm'++map :: (v1 -> v2) -> UFMap k v1 -> UFMap k v2+map f uf = uf { store = M.map f $ store uf }++null :: UFMap k v -> Bool+null = M.null . store++keys :: (Eq k, Hashable k) => UFMap k v -> [k]+keys = S.toList . keysSet++keysSet :: (Eq k, Hashable k) => UFMap k v -> S.HashSet k+keysSet uf =+ (foldr S.union S.empty . UF.toSet . joined $ uf) `S.union` (M.keysSet . store $ uf)++joinedKeys :: UFMap k v -> UF.UnionFind k+joinedKeys = joined++elems :: UFMap k v -> [v]+elems = M.elems . store++member :: (Eq k, Hashable k) => k -> UFMap k v -> Bool+member k = M.member k . store++instance (Eq k, Eq v, Hashable k, Hashable v) => Eq (UFMap k v) where+ x == y = toSet x == toSet y++instance (Eq k, Hashable k, Show k, Show v) => Show (UFMap k v) where+ show uf = "fromList " ++ show (toList uf)+++instance (Eq k, Hashable k, Read k, Read v) => Read (UFMap k v) where+ readPrec = parens $+ do expectP (L.Ident "fromList")+ x <- step readListPrec+ return (fromList x)+ readListPrec = readListPrecDefault ++instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) => Arbitrary (UFMap k v) where+ arbitrary = do + ufsz <- arbitrary+ jnum <- arbitrary+ ks <- Mon.replicateM ufsz arbitrary+ vs <- Mon.replicateM ufsz arbitrary+ js <- Mon.replicateM jnum arbitrary++ let uf = foldr (uncurry insert) empty (zip ks vs)+ ufm = foldr (uncurry (join const)) uf js++ return ufm++ shrink = P.map fromList . shrink . toList+ -- shrink = P.map (fromList . filter (not . P.null . fst)) . shrink . toList
+ src/G2/Data/UnionFind.hs view
@@ -0,0 +1,168 @@+-- | A union-find data structure.+-- Based on:+-- +-- A Persistent Union-Find Data Structure+--+-- by Sylvain Conchon and Jean-Cristophe Filliatre++{-# OPTIONS_GHC -fno-warn-orphans -fno-full-laziness #-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE InstanceSigs #-}++module G2.Data.UnionFind ( UnionFind+ , empty+ , fromList+ , toList+ , toSet+ , union+ , unionOfUFs+ , find) where++import Data.Data (Data (..), Typeable)+import Data.Hashable+import qualified Data.HashMap.Lazy as M+import qualified Data.HashSet as S+import Data.IORef+import Data.Semigroup (Semigroup (..))++import System.IO.Unsafe++import Text.Read+import qualified Text.Read.Lex as L+import GHC.Read++import Test.Tasty.QuickCheck++data UnionFind k = UF { rank :: M.HashMap k Int+ , parent :: IORef (M.HashMap k k) }+ deriving (Typeable, Data)++{-# NOINLINE empty #-}+-- | A `UnionFind` with nothing unioned. +empty :: UnionFind k+empty = UF { rank = M.empty+ , parent = unsafePerformIO $ newIORef M.empty }++-- | Build a UnionFind uf, where if k1, k2 are in the same input list,+-- find k1 uf == find k2 uf+fromList :: (Eq k, Hashable k) => [[k]] -> UnionFind k+fromList = foldr unions empty++unions :: (Eq k, Hashable k) => [k] -> UnionFind k -> UnionFind k+unions ks uf = foldr (uncurry union) uf prod+ where prod = [(k1, k2) | k1 <- ks, k2 <- ks]++-- | Convert a `UnionFind` into a list of lists.+-- Elements in the same list in the returned list were unioned in the `UnionFind`. +toList :: (Eq k, Hashable k) => UnionFind k -> [[k]]+toList = map S.toList . S.toList . toSet++-- | Convert a `UnionFind` into a `S.HashSet` of `S.HashSet`s.+-- Elements in the same `S.HashSet` in the returned `S.HashSet` were unioned in the `UnionFind`. +toSet :: (Eq k, Hashable k) => UnionFind k -> S.HashSet (S.HashSet k)+toSet uf =+ let+ par = unsafePerformIO $ readIORef (parent uf)+ m = foldr (\k -> M.insertWith S.union (find k uf) $ S.singleton k) M.empty (M.keys par)+ in+ S.fromList . map (\(k, v) -> S.insert k v) $ M.toList m++{-# NOINLINE union #-}+-- | @`union` k1 k2 uf@ unions the keys @k1@ and @k2@ in @uf@.+union :: (Eq k, Hashable k) => k -> k -> UnionFind k -> UnionFind k+union x y h =+ let+ cx = find x h+ cy = find y h+ in+ if cx /= cy+ then+ let+ rx = M.lookupDefault 0 cx (rank h)+ ry = M.lookupDefault 0 cy (rank h)+ in+ if rx > ry+ then unsafePerformIO $ do+ par_h <- readIORef (parent h)+ par_h' <- newIORef (M.insert cy cx par_h)+ return $ h { parent = par_h' } + else if rx < ry+ then unsafePerformIO $ do+ par_h <- readIORef (parent h)+ par_h' <- newIORef (M.insert cx cy par_h)+ return $ h { parent = par_h' }+ else unsafePerformIO $ do+ par_h <- readIORef (parent h)+ par_h' <- newIORef (M.insert cy cx par_h)+ return $ h { rank = M.insert cx (rx + 1) (rank h)+ , parent = par_h' } + else h++-- | Take the union of two `UnionFind`s, by taking the union of any overlapping sets.+{-# NOINLINE unionOfUFs #-}+unionOfUFs :: (Eq k, Hashable k) => UnionFind k -> UnionFind k -> UnionFind k+unionOfUFs uf1 (UF { parent = par }) = unsafePerformIO $ do+ par' <- readIORef par+ return $ M.foldrWithKey union uf1 par'++{-# NOINLINE find #-}+-- | @`find` k uf@ returns the representative of @k@ in @uf@.+find :: (Eq k, Hashable k) => k -> UnionFind k -> k+find x h =+ unsafePerformIO (do+ h_par <- readIORef (parent h)+ let (cx, f) = findAux x h_par+ atomicWriteIORef (parent h) f+ return cx+ )++findAux :: (Eq k, Hashable k) => k -> M.HashMap k k -> (k, M.HashMap k k)+findAux i f =+ let fi = M.lookupDefault i i f in+ if fi == i+ then (i, f)+ else+ let+ (r, f') = findAux fi f+ f'' = M.insert i r f'+ in+ (r, f'')+ +instance (Eq k, Hashable k) => Eq (UnionFind k) where+ x == y = toSet x == toSet y ++instance (Eq k, Hashable k, Show k) => Show (UnionFind k) where+ {-# NOINLINE show #-}+ show uf = "fromList " ++ show (toList uf) ++instance (Eq k, Hashable k, Read k) => Read (UnionFind k) where+ readPrec = parens $+ do expectP (L.Ident "fromList")+ x <- step readListPrec+ return (fromList x)+ readListPrec = readListPrecDefault ++instance (Eq k, Hashable k) => Hashable (UnionFind k) where+ hashWithSalt i = hashWithSalt i . toList++instance (Eq k, Hashable k) => Semigroup (UnionFind k) where+ (<>) = unionOfUFs++instance (Eq k, Hashable k) => Monoid (UnionFind k) where+ mempty = empty++instance (Arbitrary k, Eq k, Hashable k) => Arbitrary (UnionFind k) where+ arbitrary :: (Arbitrary k, Eq k, Hashable k) => Gen (UnionFind k)+ arbitrary = do + ks <- arbitrary++ return $ fromList ks++ shrink = map fromList . shrink . toList++-- Hack for compilation+instance Typeable a => Data (IORef a) where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = error "dataTypeOf"
+ src/G2/Data/Utils.hs view
@@ -0,0 +1,25 @@+module G2.Data.Utils ( uncurry3+ , uncurry4++ , fst4+ , snd4+ , thd4+ , fth4) where++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a, b, c) = f a b c++uncurry4 :: (a -> b -> c -> d -> e) -> ((a, b, c, d) -> e)+uncurry4 f (a,b,c,d) = f a b c d++fst4 :: (a, b, c, d) -> a+fst4 (a, _, _, _) = a++snd4 :: (a, b, c, d) -> b+snd4 (_, b, _, _) = b++thd4 :: (a, b, c, d) -> c+thd4 (_, _, c, _) = c++fth4 :: (a, b, c, d) -> d+fth4 (_, _, _, d) = d
+ src/G2/Equiv/Approximation.hs view
@@ -0,0 +1,125 @@+module G2.Equiv.Approximation where++import G2.Equiv.Types+import G2.Language+import qualified G2.Language.Approximation as A+import qualified G2.Language.ExprEnv as E++import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HM+import Data.List+import Data.Maybe++moreRestrictive :: StateET+ -> StateET+ -> HS.HashSet Name+ -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+ -> Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+moreRestrictive s1 s2 =+ let+ lkp n s = lookupConcOrSymBoth n (expr_env s) (opp_env $ track s)+ in+ A.moreRestrictive moreRestrictiveCont generateLemma lkp s1 s2++moreRestrictiveCont :: StateET+ -> StateET+ -> HS.HashSet Name+ -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+ -> Bool -- ^ indicates whether this is part of the "active expression"+ -> [(Name, Expr)] -- ^ variables inlined previously on the LHS+ -> [(Name, Expr)] -- ^ variables inlined previously on the RHS+ -> Expr+ -> Expr+ -> Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+moreRestrictiveCont s1 s2 ns hm active n1 n2 e1 e2 =+ let+ lkp n s = lookupConcOrSymBoth n (expr_env s) (opp_env $ track s)+ in+ case (e1, e2) of+ (Tick t1 e1', Tick t2 e2') | labeledErrorName t1 == labeledErrorName t2 ->+ A.moreRestrictive' moreRestrictiveCont generateLemma lkp s1 s2 ns hm active n1 n2 e1' e2'+ (Tick t e1', _) | isNothing $ labeledErrorName t ->+ A.moreRestrictive' moreRestrictiveCont generateLemma lkp s1 s2 ns hm active n1 n2 e1' e2+ (_, Tick t e2') | isNothing $ labeledErrorName t ->+ A.moreRestrictive' moreRestrictiveCont generateLemma lkp s1 s2 ns hm active n1 n2 e1 e2'+ _ -> Left []++-- When we make the two sides for a new lemma, if the two expressions+-- contain any variables that aren't present in the expression environment,+-- we add them to the expression environment as non-total symbolic+-- variables. This can happen if an expression for a lemma is a+-- sub-expression of a Case branch, a Let statement, or a lambda expression+-- body. It is possible that we may lose information about the variables+-- because of these insertions, but this cannot lead to spurious+-- counterexamples because these insertions apply only to lemmas and lemmas+-- are not used for counterexample generation.+generateLemma :: A.GenerateLemma EquivTracker Lemma+generateLemma s1 s2@(State {expr_env = h2}) hm e1 e2 =+ let+ h2' = opp_env $ track s2++ v_rep = HM.toList $ fst hm+ e1' = replaceVars e1 v_rep+ cs (E.Conc e_) = E.Conc e_+ cs (E.Sym i_) = case E.lookupConcOrSym (idName i_) h2' of+ Nothing -> E.Sym i_+ Just c -> c+ h2_ = envMerge (E.mapConcOrSym cs h2) h2'+ h2_' = E.mapConc (flip replaceVars v_rep) h2_+ et' = (track s2) { opp_env = E.empty }+ ids1 = varIds e1'+ ids1' = filter (\(Id n _) -> not $ E.member n h2_') ids1+ ids2 = varIds e2+ ids2' = filter (\(Id n _) -> not $ E.member n h2_) ids2+ ids_both = nub $ ids1' ++ ids2'+ h_lem1 = foldr E.insertSymbolic h2_' ids_both+ h_lem2 = foldr E.insertSymbolic h2_ ids_both+ ls1 = s2 { expr_env = h_lem1, curr_expr = CurrExpr Evaluate e1', track = et' }+ ls2 = s2 { expr_env = h_lem2, curr_expr = CurrExpr Evaluate e2, track = et' }+ in+ mkProposedLemma "lemma" s1 s2 ls2 ls1++replaceVars :: Expr -> [(Id, Expr)] -> Expr+replaceVars = foldr (\(Id n _, e) -> replaceVar n e)++mkProposedLemma :: String+ -> StateET+ -> StateET+ -> StateET+ -> StateET+ -> ProposedLemma+mkProposedLemma lm_name or_s1 or_s2 s1 s2 =+ let h1 = expr_env s1+ h2 = expr_env s2+ cs _ (E.Conc e) = E.Conc e+ cs h (E.Sym i) = case E.lookupConcOrSym (idName i) h of+ Nothing -> E.Sym i+ Just c -> c+ h1' = E.mapConcOrSym (cs h2) h1+ h2' = E.mapConcOrSym (cs h1) h2+ f (E.SymbObj _) e2 = e2+ f e1 _ = e1+ h1'' = E.unionWith f h1' h2'+ h2'' = E.unionWith f h2' h1'+ s1' = s1 { expr_env = h1'' }+ s2' = s2 { expr_env = h2'' }+ in+ Lemma { lemma_name = lm_name+ , lemma_lhs = s1'+ , lemma_rhs = s2'+ , lemma_lhs_origin = folder_name . track $ or_s1+ , lemma_rhs_origin = folder_name . track $ or_s2+ , lemma_to_be_proven =[(newStateH s1', newStateH s2')] }++syncEnvs :: StateET -> StateET -> (StateET, StateET)+syncEnvs s1 s2 =+ let h1 = envMerge (expr_env s1) (expr_env s2)+ h2 = envMerge (expr_env s2) (expr_env s1)+ in (s1 { expr_env = h1 }, s2 { expr_env = h2 })++-- the left one takes precedence+envMerge :: ExprEnv -> ExprEnv -> ExprEnv+envMerge env h =+ let f (E.SymbObj _) e2 = e2+ f e1 _ = e1+ in E.unionWith f env h
+ src/G2/Equiv/Config.hs view
@@ -0,0 +1,107 @@+module G2.Equiv.Config ( NebulaConfig (..)+ , SummaryMode (..)+ , UseLabeledErrors (..)+ , getNebulaConfig+ , getNebulaConfigPlugin+ , mkNebulaConfigInfo+ , mkNebulaConfig) where++import G2.Config.Config++import Data.Monoid ((<>))+import qualified Data.Text as T+import Options.Applicative+import Text.Read++-- Config options+data NebulaConfig = NC { limit :: Int+ , num_lemmas :: Int+ , print_summary :: SummaryMode+ , use_labeled_errors :: UseLabeledErrors+ , log_states :: LogMode -- ^ Determines whether to Log states, and if logging states, how to do so.+ , log_rule :: Maybe String -- ^ Allow user to log the states for specific rule. + , sync :: Bool + , symbolic_unmapped :: Bool}++data SummaryMode = SM { have_summary :: Bool+ , have_history :: Bool+ , have_lemma_details :: Bool }++noSummary :: SummaryMode+noSummary = SM False False False++data UseLabeledErrors = UseLabeledErrors | NoLabeledErrors deriving (Eq, Show, Read)++getNebulaConfig :: IO (String, String, [T.Text], NebulaConfig)+getNebulaConfig = execParser mkNebulaConfigInfo++getNebulaConfigPlugin :: [String] -> ParserResult (Maybe String, NebulaConfig)+getNebulaConfigPlugin =+ execParserPure defaultPrefs $+ info (((,) <$> maybeGetRuleName <*> mkNebulaConfig) <**> helper)+ ( fullDesc+ <> progDesc "Equivalence Checking for Haskell Rewrite Rules"+ <> header "The Nebula Equivalence Checker" )++mkNebulaConfigInfo :: ParserInfo (String, String, [T.Text], NebulaConfig)+mkNebulaConfigInfo =+ info (((,,,) <$> getFileName <*> getRuleName <*> getTotal <*> mkNebulaConfig) <**> helper)+ ( fullDesc+ <> progDesc "Equivalence Checking for Haskell Rewrite Rules"+ <> header "The Nebula Equivalence Checker" )++getFileName :: Parser String+getFileName = argument str (metavar "FILE")++getRuleName :: Parser String+getRuleName = argument str (metavar "RULE")++maybeGetRuleName :: Parser (Maybe String)+maybeGetRuleName =+ argument (maybeReader (Just . Just)) (metavar "RULE" <> value Nothing)++getTotal :: Parser [T.Text]+getTotal = many (argument (maybeReader (Just . T.pack)) (metavar "TOTAL"))++mkNebulaConfig :: Parser NebulaConfig+mkNebulaConfig = NC+ <$> option auto (long "limit"+ <> metavar "N"+ <> value (-1)+ <> help "how many iterations the equivalence checker should go through before giving up")+ <*> option auto (long "num_lemmas"+ <> metavar "L"+ <> value 2+ <> help "how many lemmas can be applied to an expression simultaneously")+ <*> mkSummaryMode+ <*> flag UseLabeledErrors NoLabeledErrors (long "no-labeled-errors" <> help "disable labeled errors, treating all errors as equivalent")+ <*> mkLogMode+ <*> mkLogRule+ <*> flag False True (long "sync" <> help "sync the left and right expressions prior to symbolic execution")+ <*> flag True False (long "sym-unmapped" <> help "automatically treat unmapped function as symbolic")++mkLogRule :: Parser (Maybe String)+mkLogRule =+ option (maybeReader (Just . Just))+ ( long "log-rule"+ <> metavar "RULE"+ <> value Nothing+ <> help "Output states for this rule when logging")++mkSummaryMode :: Parser SummaryMode+mkSummaryMode =+ (flag noSummary (SM True False False)+ (long "summarize"+ <> help "provide a summary with no history"))+ <|>+ (flag noSummary (SM True True False)+ (long "hist-summarize"+ <> help "provide a summary with history"))+ <|>+ (flag noSummary (SM True False True)+ (long "lemmas-summarize"+ <> help "provide a summary with all lemma results"))+ <|>+ (flag noSummary (SM True True True)+ (long "lemmas-hist-summarize"+ <> help "provide a summary with history and lemma results"))
+ src/G2/Equiv/EquivADT.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module G2.Equiv.EquivADT (+ proofObligations+ , Obligation (..)+ , unAppNoTicks+ ) where++import G2.Language+import qualified G2.Language.ExprEnv as E+import qualified G2.Language.Typing as T+import qualified Data.HashSet as HS++import G2.Execution.NormalForms+import G2.Equiv.G2Calls++import GHC.Generics (Generic)+import Data.Data+import Data.Hashable+import Data.Maybe++-- The information that comes before the Expr pair is used for checking+-- the validity of guarded coinduction and also for counterexample+-- summarization in the event of a SAT output.+-- earlier DataCons in the list are farther out+-- the first Int tag indicates which argument of the constructor this was+-- the second one indicates the total number of arguments for that constructor+-- if there are lambdas, we handle them in Verifier+data Obligation = Ob [(DataCon, Int, Int)] Expr Expr+ deriving (Show, Eq, Read, Generic, Typeable, Data)++instance Hashable Obligation++proofObligations :: HS.HashSet Name+ -> State t+ -> State t+ -> Expr+ -> Expr+ -> Maybe (HS.HashSet Obligation)+proofObligations ns s1 s2 e1 e2 =+ exprPairing ns s1 s2 e1 e2 HS.empty [] []++removeTicks :: Expr -> Expr+removeTicks (Tick _ e) = removeTicks e+removeTicks e = e++removeAllTicks :: Expr -> Expr+removeAllTicks = modifyASTs removeTicks++unAppNoTicks :: Expr -> [Expr]+unAppNoTicks e =+ let e_list = unApp e+ in case e_list of+ e':t -> (removeTicks e'):t+ _ -> e_list++exprPairing :: HS.HashSet Name -- ^ vars that should not be inlined on either side+ -> State t+ -> State t+ -> Expr+ -> Expr+ -> HS.HashSet Obligation -- ^ accumulator for output obligations+ -> [Name] -- ^ variables inlined previously on the LHS+ -> [Name] -- ^ variables inlined previously on the RHS+ -> Maybe (HS.HashSet Obligation)+exprPairing ns s1@(State {expr_env = h1}) s2@(State {expr_env = h2}) e1 e2 pairs n1 n2 =+ case (e1, e2) of+ _ | e1 == e2 -> Just pairs+ -- ignore all Ticks+ (Tick t1 e1', Tick t2 e2') | labeledErrorName t1 == labeledErrorName t2 -> exprPairing ns s1 s2 e1' e2' pairs n1 n2+ (Tick t e1', _) | isNothing $ labeledErrorName t -> exprPairing ns s1 s2 e1' e2 pairs n1 n2+ (_, Tick t e2') | isNothing $ labeledErrorName t -> exprPairing ns s1 s2 e1 e2' pairs n1 n2+ -- catch mismatches between labeled errors and other SWHNF expressions+ (Tick _ _, _) | isExprValueForm h2 (removeAllTicks e2) -> Nothing+ (_, Tick _ _) | isExprValueForm h1 (removeAllTicks e1) -> Nothing+ -- We have two error labels that are different from each other+ (Tick _ _, Tick _ _) -> Nothing+ -- keeping track of inlined vars prevents looping+ (Var i1, Var i2) | (idName i1) `elem` n1+ , (idName i2) `elem` n2 -> Just $ HS.insert (Ob [] e1 e2) pairs+ -- reject distinct polymorphic variables as inequivalent+ -- this works for function variables too+ | E.isSymbolic (idName i1) h1+ , E.isSymbolic (idName i2) h2+ , idName i1 /= idName i2+ , not (concretizable $ T.typeOf e1) -> Nothing+ (Var i, _) | E.isSymbolic (idName i) h1 -> Just $ HS.insert (Ob [] e1 e2) pairs+ | m <- idName i+ , not $ m `elem` ns+ , Just e <- E.lookup m h1 -> exprPairing ns s1 s2 e e2 pairs (m:n1) n2+ | not $ (idName i) `elem` ns -> error "unmapped variable"+ (_, Var i) | E.isSymbolic (idName i) h2 -> Just $ HS.insert (Ob [] e1 e2) pairs+ | m <- idName i+ , not $ m `elem` ns+ , Just e <- E.lookup m h2 -> exprPairing ns s1 s2 e1 e pairs n1 (m:n2)+ | not $ (idName i) `elem` ns -> error $ "unmapped variable" ++ show (idName i)+ (Prim p1 _, Prim p2 _) | p1 == Error || p1 == Undefined+ , p2 == Error || p2 == Undefined -> Just pairs+ -- extra cases for avoiding Error problems+ (Prim p _, _) | (p == Error || p == Undefined)+ , isExprValueForm h2 (removeAllTicks e2) -> Nothing+ (_, Prim p _) | (p == Error || p == Undefined)+ , isExprValueForm h1 (removeAllTicks e1) -> Nothing+ (Lit l1, Lit l2) | l1 == l2 -> Just pairs+ | otherwise -> Nothing+ -- assume that all types line up between the two expressions+ (Type _, Type _) -> Just pairs+ -- See note in `moreRestrictive` regarding comparing DataCons+ _+ | (Data d@(DataCon d1 _)):l1 <- unAppNoTicks e1+ , (Data (DataCon d2 _)):l2 <- unAppNoTicks e2 ->+ if d1 == d2 then+ let ep = uncurry (exprPairing ns s1 s2)+ ep' hs p = ep p hs n1 n2+ l = zip l1 l2+ extend i (Ob ds e1_ e2_) = Ob ((d, i, length l):ds) e1_ e2_+ make_exts (i, l_pair) = case ep' HS.empty l_pair of+ Nothing -> Nothing+ Just hs -> Just $ map (extend i) $ HS.toList hs+ hl = map make_exts $ zip [0..] l+ in+ if any isNothing hl+ then Nothing+ else Just $ HS.union pairs $ HS.fromList $ concat (map fromJust hl)+ else Nothing+ | otherwise -> Just $ HS.insert (Ob [] e1 e2) pairs
+ src/G2/Equiv/G2Calls.hs view
@@ -0,0 +1,504 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}++module G2.Equiv.G2Calls ( StateET+ , EquivTracker (..)+ , BlockInfo (..)+ , emptyEquivTracker+ , runG2ForNebula+ , totalExpr+ , argCount+ , concretizable++ , isLabeledErrorName+ , labeledErrorName+ , isLabeledError++ , lookupBoth+ , lookupConcOrSymBoth+ , isSymbolicBoth ) where++import G2.Config+import G2.Execution+import G2.Execution.NormalForms+import G2.Interface+import G2.Language+import G2.Lib.Printers+import qualified G2.Language.ExprEnv as E+import qualified G2.Language.Stack as S+import qualified G2.Language.Typing as TY+import G2.Solver+import G2.Equiv.Config++import Control.Monad.IO.Class+import qualified Control.Monad.State as SM+import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HS++import qualified Data.Text as T++import Data.Hashable+import qualified Data.List as L++import GHC.Generics (Generic)++-- get names from symbolic ids in the state+runG2ForNebula :: Solver solver =>+ solver ->+ StateET ->+ E.ExprEnv ->+ EquivTracker ->+ Config ->+ NebulaConfig ->+ Bindings ->+ IO ([ExecRes EquivTracker], Bindings)+runG2ForNebula solver state h_opp track_opp config nc bindings = do+ --SomeSolver solver <- initSolver config+ let simplifier = IdSimplifier+ sym_config = PreserveAllMC+ {-+ sym_config = addSearchNames (namesList $ track state)+ $ addSearchNames (input_names bindings)+ $ addSearchNames (M.keys $ deepseq_walkers bindings) emptyMemConfig+ -}++ state' = state { track = (track state) { saw_tick = Nothing } }++ (in_out, bindings') <- case rewriteRedHaltOrd solver simplifier h_opp track_opp config nc of+ (red, hal, ord) ->+ SM.evalStateT (runG2WithSomes red hal ord solver simplifier sym_config state' bindings) (mkPrettyGuide ())++ --close solver++ return (in_out, bindings')++rewriteRedHaltOrd :: (MonadIO m, Solver solver, Simplifier simplifier) =>+ solver ->+ simplifier ->+ E.ExprEnv ->+ EquivTracker ->+ Config ->+ NebulaConfig ->+ ( SomeReducer (SM.StateT PrettyGuide m) EquivTracker+ , SomeHalter (SM.StateT PrettyGuide m) EquivTracker+ , SomeOrderer (SM.StateT PrettyGuide m) EquivTracker)+rewriteRedHaltOrd solver simplifier h_opp track_opp config (NC { use_labeled_errors = use_labels }) =+ let+ share = sharing config+ state_name = Name "state" Nothing 0 Nothing++ m_logger = fmap SomeReducer $ getLogger config+ some_std_red = enforceProgressRed :== NoProgress --> stdRed share retReplaceSymbFuncVar solver simplifier+ extra_red = symbolicSwapperRed h_opp track_opp ~> concSymReducer use_labels ~> labeledErrorsRed+ red = equivReducer :== NoProgress .--> extra_red :== NoProgress .--> some_std_red+ in+ (case m_logger of+ Just logger -> logger .~> red + Nothing -> red + , SomeHalter+ (discardIfAcceptedTagHalter state_name+ <~> enforceProgressHalter+ <~> swhnfHalter+ <~> labeledErrorsHalter)+ , SomeOrderer $ pickLeastUsedOrderer)++type StateET = State EquivTracker++data BlockInfo = BlockDC DataCon Int Int+ | BlockLam Id+ deriving (Show, Eq, Generic)++instance Hashable BlockInfo++instance Named BlockInfo where+ names (BlockDC dc _ _) = names dc+ names (BlockLam i) = names i+ rename old new (BlockDC dc n1 n2) = BlockDC (rename old new dc) n1 n2+ rename old new (BlockLam i) = BlockLam (rename old new i)++-- Maps higher order function calls to symbolic replacements.+-- This allows the same call to be replaced by the same Id consistently.+data EquivTracker = EquivTracker { higher_order :: HM.HashMap Expr Id+ , saw_tick :: Maybe Int+ , total_vars :: HS.HashSet Name+ , dc_path :: [BlockInfo]+ , opp_env :: ExprEnv+ , folder_name :: String } deriving (Show, Eq, Generic)++instance Hashable EquivTracker++-- | Forces a lone symbolic variable with a type corresponding to an ADT+-- to evaluate to some value of that ADT+concSymReducer :: Monad m => UseLabeledErrors -> Reducer m () EquivTracker+concSymReducer use_labels = mkSimpleReducer+ (const ())+ rr+ where+ rr _+ s@(State { curr_expr = CurrExpr _ (Var (Id n t))+ , expr_env = eenv+ , type_env = tenv+ , track = EquivTracker et m total dcp opp fname })+ b@(Bindings { name_gen = ng })+ | E.isSymbolic n eenv+ , Just (dc_symbs, ng') <- arbDC use_labels tenv ng t n total = do+ let new_names = map idName $ concat $ map snd dc_symbs+ total' = if n `elem` total+ then foldr HS.insert total new_names+ else total+ xs = map (\(e, symbs') ->+ s { curr_expr = CurrExpr Evaluate e+ , expr_env =+ foldr E.insertSymbolic+ (E.insert n e eenv)+ symbs'+ , track = EquivTracker et m total' dcp opp fname+ }) dc_symbs+ b' = b { name_gen = ng' }+ -- only add to total if n was total+ -- not all of these will be used on each branch+ -- they're all fresh, though, so overlap is not a problem+ return (InProgress, zip xs (repeat ()) , b')+ rr _ s b = return (NoProgress, [(s, ())], b)++-- | Build a case expression with one alt for each data constructor of the given type+-- and symbolic arguments. Thus, the case expression could evaluate to any value of the+-- given type.+arbDC :: UseLabeledErrors+ -> TypeEnv+ -> NameGen+ -> Type+ -> Name+ -> HS.HashSet Name+ -> Maybe ([(Expr, [Id])], NameGen)+arbDC use_labels tenv ng t n total+ | TyCon tn _:ts <- unTyApp t+ , Just adt <- HM.lookup tn tenv =+ let+ dcs = dataCon adt++ bound = bound_ids adt+ bound_ts = zip bound ts++ (err_lab, ng') = freshLabeledError ng+ err = if use_labels == UseLabeledErrors+ then Tick (NamedLoc err_lab) (Prim Error TyBottom)+ else Prim Error TyBottom++ ty_apped_dcs = map (\dc -> mkApp $ Data dc:map Type ts) dcs+ ty_apped_dcs' = err:ty_apped_dcs+ (ng'', dc_symbs) = + L.mapAccumL+ (\ng_ dc ->+ let+ anon_ts = anonArgumentTypes dc+ re_anon = foldr (\(i, ty) -> retype i ty) anon_ts bound_ts+ (ars, ng_') = freshIds re_anon ng_+ in+ (ng_', (mkApp $ dc:map Var ars, ars))+ )+ ng'+ (if n `elem` total then ty_apped_dcs else ty_apped_dcs')+ in+ Just (dc_symbs, ng'')+ | otherwise = Nothing++symbolicSwapperRed :: Monad m => E.ExprEnv -> EquivTracker -> Reducer m () EquivTracker+symbolicSwapperRed h_opp track_opp = mkSimpleReducer+ (const ())+ rr+ where+ rr rv+ s@(State { curr_expr = CurrExpr _ e+ , expr_env = h+ , track = EquivTracker et m tot dcp opp fname })+ b =+ case e of+ Var (Id n _) | E.isSymbolic n h ->+ case E.lookupConcOrSym n h_opp of+ Just (E.Conc e') ->+ let vi = varIds e'+ vi_hs = HS.fromList $ map idName vi+ h' = foldr (\j -> E.insertSymbolic j) (E.insert n e' h) (L.nub vi)+ total' = HS.union (HS.intersection (total_vars track_opp) vi_hs) tot+ track' = EquivTracker et m total' dcp opp fname+ s' = s {+ expr_env = h'+ , track = track'+ }+ in return (InProgress, [(s', rv)], b)+ _ -> return (NoProgress, [(s, rv)], b)+ _ -> return (NoProgress, [(s, rv)], b)++enforceProgressRed :: Monad m => Reducer m () EquivTracker+enforceProgressRed = mkSimpleReducer+ (const ())+ rr+ where+ rr rv s@(State { curr_expr = CurrExpr _ e+ , num_steps = n+ , track = EquivTracker et m total dcp opp fname })+ b =+ let s' = s { track = EquivTracker et (Just n) total dcp opp fname }+ need_more = case m of+ Nothing -> True+ Just n0 -> n > n0 + 1+ in+ case e of+ Tick (NamedLoc (Name p _ _ _)) _ ->+ if p == T.pack "STACK" && need_more+ then return (InProgress, [(s', ())], b)+ else return (NoProgress, [(s, ())], b)+ _ -> return (NoProgress, [(s, rv)], b)++labeledErrorStringSeed :: T.Text+labeledErrorStringSeed = "__ERROR_LABEL__"++labeledErrorNameSeed :: Name+labeledErrorNameSeed = Name "__ERROR_LABEL__" Nothing 0 Nothing++isLabeledErrorName :: Name -> Bool+isLabeledErrorName (Name n _ _ _) = n == labeledErrorStringSeed++labeledErrorName :: Tickish -> Maybe Name+labeledErrorName (NamedLoc n) | isLabeledErrorName n = Just n+labeledErrorName _ = Nothing++freshLabeledError :: NameGen -> (Name, NameGen)+freshLabeledError = freshSeededName labeledErrorNameSeed++isLabeledError :: Expr -> Bool+isLabeledError (Tick (NamedLoc n) (Prim Error _)) = isLabeledErrorName n+isLabeledError (Tick (NamedLoc n) (Prim Undefined _)) = isLabeledErrorName n+isLabeledError _ = False++labeledErrorsRed :: Monad m => Reducer m () t+labeledErrorsRed = mkSimpleReducer+ (const ())+ rr+ where+ rr rv s@(State { curr_expr = CurrExpr _ ce }) b+ | isLabeledError ce = return (Finished, [(s { exec_stack = S.empty }, rv)], b)+ | otherwise = return (NoProgress, [(s, rv)], b)++labeledErrorsHalter :: Monad m => Halter m () t+labeledErrorsHalter = mkSimpleHalter (const ())+ (\hv _ _ -> hv)+ stop+ (\hv _ _ _ -> hv)+ where+ stop _ _ (State { curr_expr = CurrExpr _ ce, exec_stack = stck })+ | isLabeledError ce, S.null stck = return Accept+ | otherwise = return Continue+++-- this does not account for type arguments+argCount :: Type -> Int+argCount = length . spArgumentTypes . PresType++exprFullApp :: ExprEnv -> Expr -> Bool+exprFullApp h e | (Tick (NamedLoc (Name p _ _ _)) f):as <- unApp e+ , p == T.pack "REC" = exprFullApp h (mkApp $ f:as)+exprFullApp h e | (Var (Id n t)):_ <- unApp e+ -- We require that the variable be the center of a function+ -- application, have at least one argument, and not map to a variable for two reasons:+ -- (1) We do not want to count symbolic function applications as in FAF form+ -- (2) We need to ensure we make sufficient progress to avoid+ -- moreRestrictive matching states spuriously.+ -- Consider an expression environment with a mapping of `x :: Int` to `f y`.+ -- We want to avoid storing a previous state using x,+ -- having the symbolic execution inline `f y`, and then deciding that + -- the two states match and are sufficient for verification to succeed,+ -- when, in isMoreRestrictive, x is inlined.+ , Just e' <- E.lookup n h+ , not (isVar e')+ , c_unapp <- length (unApp e)+ , c_unapp >= 2 = c_unapp == 1 + argCount t+exprFullApp _ _ = False++isVar :: Expr -> Bool+isVar (Tick _ e) = isVar e+isVar (Var _) = True+isVar _ = False++-- induction only works if both states in a pair satisfy this+-- there's no harm in stopping here for just one, though+-- TODO removing the Case requirement doesn't fix forceIdempotent+recursionInCase :: State t -> Bool+recursionInCase (State { curr_expr = CurrExpr _ e }) =+ case e of+ Tick (NamedLoc (Name p _ _ _)) _ ->+ p == T.pack "REC" -- && containsCase sk+ _ -> False++enforceProgressHalter :: Monad m => Halter m () EquivTracker+enforceProgressHalter = mkSimpleHalter+ (const ())+ (\_ _ _ -> ())+ stop+ (\_ _ _ _ -> ())+ where+ stop _ _ s =+ let CurrExpr _ e = curr_expr s+ n' = num_steps s+ EquivTracker _ m _ _ _ _ = track s+ h = expr_env s+ in+ case m of+ Nothing -> return Continue+ -- Execution needs to take strictly more than one step beyond the+ -- point when it reaches the Tick because the act of unwrapping the+ -- expression inside the Tick counts as one step.+ Just n0 -> do+ if (isExecValueForm s) || (exprFullApp h e) || (recursionInCase s)+ then return (if n' > n0 + 1 then Accept else Continue)+ else return Continue++emptyEquivTracker :: EquivTracker+emptyEquivTracker = EquivTracker HM.empty Nothing HS.empty [] E.empty ""++equivReducer :: Monad m => Reducer m () EquivTracker+equivReducer = mkSimpleReducer+ (const ())+ rr+ where+ rr _+ s@(State { expr_env = eenv+ , curr_expr = CurrExpr Evaluate e+ , track = EquivTracker et m total dcp opp fname })+ b@(Bindings { name_gen = ng })+ | isSymFuncApp eenv (removeAllTicks e) =+ let+ -- We inline variables to have a higher chance of hitting in the Equiv Tracker+ e' = removeAllTicks $ inlineApp eenv e+ in+ case HM.lookup e' et of+ Just v ->+ let eenv' = case E.lookup (idName v) eenv of+ Just _ -> eenv+ Nothing -> E.insertSymbolic v eenv+ s' = s {+ curr_expr = CurrExpr Evaluate (Var v)+ , expr_env = eenv'+ }+ in+ return (InProgress, [(s', ())], b)+ Nothing ->+ let+ (v, ng') = freshId (typeOf e) ng+ et' = HM.insert e' v et+ -- carry over totality if function and all args are total+ all_total = all (totalExpr s HS.empty []) $ unApp e'+ total' = if all_total+ then HS.insert (idName v) total+ else total+ s' = s { curr_expr = CurrExpr Evaluate (Var v)+ , track = EquivTracker et' m total' dcp opp fname+ , expr_env = E.insertSymbolic v eenv }+ b' = b { name_gen = ng' }+ in+ return (InProgress, [(s', ())], b')+ rr rv s b = return (NoProgress, [(s, rv)], b)++-- not exhaustive, but totality is undecidable in general+-- cyclic expressions do not count as total for now+-- if a cycle never goes through a Data constructor, it's not total+totalExpr :: StateET ->+ HS.HashSet Name ->+ [Name] -> -- variables inlined previously+ Expr ->+ Bool+totalExpr s@(State { expr_env = h, track = EquivTracker _ _ total _ h' _ }) ns n e =+ case e of+ Tick _ e' -> totalExpr s ns n e'+ Var i | m <- idName i+ , isSymbolicBoth m h h' -> m `elem` total+ | m <- idName i+ , not $ HS.member m ns+ , not $ m `elem` n+ , Just e' <- lookupBoth m h h' -> totalExpr s ns (m:n) e'+ | (idName i) `elem` n -> False+ | HS.member (idName i) ns -> False+ | otherwise -> error $ "unmapped variable " ++ show i ++ " " ++ (folder_name $ track s)+ App f a -> totalExpr s ns n f && totalExpr s ns n a+ Data _ -> True+ Prim p _ -> not (p == Error || p == Undefined)+ Lit _ -> True+ Lam _ _ _ -> False+ Type _ -> True+ Let _ _ -> False+ Case _ _ _ _ -> False+ _ -> False++-- helper function to circumvent syncSymbolic+-- for symbolic things, lookup returns the variable+lookupBoth :: Name -> ExprEnv -> ExprEnv -> Maybe Expr+lookupBoth n h1 = fmap E.concOrSymToExpr . lookupConcOrSymBoth n h1++lookupConcOrSymBoth :: Name -> ExprEnv -> ExprEnv -> Maybe E.ConcOrSym+lookupConcOrSymBoth n h1 h2 = case E.lookupConcOrSym n h1 of+ e@(Just (E.Conc _)) -> e+ sym@(Just (E.Sym _)) -> case E.lookupConcOrSym n h2 of+ Nothing -> sym+ m -> m+ Nothing -> E.lookupConcOrSym n h2++-- doesn't count as symbolic if it's unmapped+-- condition we need: n is symbolic in every env where it's mapped+isSymbolicBoth :: Name -> ExprEnv -> ExprEnv -> Bool+isSymbolicBoth n h1 h2 =+ case E.lookupConcOrSym n h1 of+ Just (E.Sym _) -> case E.lookupConcOrSym n h2 of+ Just (E.Conc _) -> False+ _ -> True+ Just (E.Conc _) -> False+ Nothing -> E.isSymbolic n h2++isSymFuncApp :: ExprEnv -> Expr -> Bool+isSymFuncApp eenv e+ | v@(Var _):(_:_) <- unApp e+ , (Var (Id f t)) <- inlineVars eenv v =+ E.isSymbolic f eenv && hasFuncType (PresType t)+ | otherwise = False++removeTicks :: Expr -> Expr+removeTicks (Tick _ e) = removeTicks e+removeTicks e = e++removeAllTicks :: Expr -> Expr+removeAllTicks = modifyASTs removeTicks++inlineApp :: ExprEnv -> Expr -> Expr+inlineApp eenv = mkApp . map (inlineVars eenv) . unApp++inlineVars :: ExprEnv -> Expr -> Expr+inlineVars = inlineVars' HS.empty++inlineVars' :: HS.HashSet Name -> ExprEnv -> Expr -> Expr+inlineVars' seen eenv (Var (Id n _))+ | not (n `HS.member` seen)+ , Just e <- E.lookup n eenv = inlineVars' (HS.insert n seen) eenv e+inlineVars' seen eenv (App e1 e2) = App (inlineVars' seen eenv e1) (inlineVars' seen eenv e2)+inlineVars' _ _ e = e++instance ASTContainer EquivTracker Expr where+ containedASTs (EquivTracker hm _ _ _ _ _) = HM.keys hm+ modifyContainedASTs f (EquivTracker hm m total dcp opp fname) =+ (EquivTracker . HM.fromList . map (\(k, v) -> (f k, v)) $ HM.toList hm)+ m total dcp opp fname++instance ASTContainer EquivTracker Type where+ containedASTs (EquivTracker hm _ _ _ _ _) = containedASTs $ HM.keys hm+ modifyContainedASTs f (EquivTracker hm m total dcp opp fname) =+ ( EquivTracker+ . HM.fromList+ . map (\(k, v) -> (modifyContainedASTs f k, modifyContainedASTs f v))+ $ HM.toList hm )+ m total dcp opp fname++instance Named EquivTracker where+ names (EquivTracker hm _ _ _ _ _) = names hm+ rename old new (EquivTracker hm m total dcp opp fname) =+ EquivTracker (rename old new hm) m (rename old new total) (rename old new dcp) (rename old new opp) fname
+ src/G2/Equiv/Generalize.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}++module G2.Equiv.Generalize ( generalizeFull ) where++import G2.Language++import qualified G2.Language.ExprEnv as E++import Data.Maybe++import qualified Data.HashSet as HS+import qualified G2.Solver as S++import G2.Equiv.G2Calls+import G2.Equiv.Tactics++import Data.Monoid (Any (..))++import qualified Control.Monad.Writer.Lazy as W++innerScrutinees :: Expr -> [Expr]+innerScrutinees (Tick _ e) = innerScrutinees e+innerScrutinees e@(Case e' _ _ _) = e:(innerScrutinees e')+innerScrutinees e = [e]++replaceScrutinee :: Expr -> Expr -> Expr -> Expr+replaceScrutinee e1 e2 e | e1 == e = e2+replaceScrutinee e1 e2 (Tick nl e) = Tick nl (replaceScrutinee e1 e2 e)+replaceScrutinee e1 e2 (Case e i t a) = Case (replaceScrutinee e1 e2 e) i t a+replaceScrutinee _ _ e = e++generalizeAux :: S.Solver solver =>+ solver ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ [StateET] ->+ StateET ->+ W.WriterT [Marker] IO (Maybe (PrevMatch EquivTracker))+generalizeAux solver num_lems ns lemmas s1_list s2 = do+ -- Originally, this equality check did not allow for lemma usage+ -- because it was supposed to check only for syntactic equality.+ -- However, there do not seem to be any soundness issues with+ -- enabling lemma usage here to make the tactic more powerful.+ let check_equiv s1_ = moreRestrictiveEqual solver num_lems ns lemmas s1_ s2+ res <- mapM check_equiv s1_list+ let res' = filter isJust res+ case res' of+ [] -> return Nothing+ h:_ -> return h++adjustStateForGeneralization :: Expr -> Name -> StateET -> StateET+adjustStateForGeneralization e_old fresh_name s =+ let e = getExpr s+ fresh_id = Id fresh_name (typeOf e)+ fresh_var = Var fresh_id+ e' = replaceScrutinee e fresh_var e_old+ h = expr_env s+ h' = E.insertSymbolic fresh_id h+ in s {+ curr_expr = CurrExpr Evaluate e'+ , expr_env = h'+ }++-- replace the largest sub-expression possible with a fresh symbolic var+generalize :: S.Solver solver =>+ solver ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ Name ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO (Maybe (StateET, StateET))+generalize solver num_lems ns lemmas fresh_name (s1, s2) | dc_path (track s1) == dc_path (track s2) = do+ -- expressions are ordered from outer to inner+ -- the largest ones are on the outside+ -- take the earliest array entry that works+ -- for anything on one side, there can only be one match on the other side+ let e1 = getExpr s1+ scr1 = innerScrutinees e1+ scr_states1 = map (\e -> s1 { curr_expr = CurrExpr Evaluate e }) scr1+ e2 = getExpr s2+ scr2 = innerScrutinees e2+ scr_states2 = map (\e -> s2 { curr_expr = CurrExpr Evaluate e }) scr2+ res <- mapM (generalizeAux solver num_lems ns lemmas scr_states1) scr_states2+ -- no equiv tracker changes seem to be necessary+ let res' = filter isJust res+ case res' of+ (Just pm):_ -> let (s1', s2') = present pm+ s1'' = adjustStateForGeneralization e1 fresh_name s1'+ s2'' = adjustStateForGeneralization e2 fresh_name s2'+ in return $ Just $ syncSymbolic s1'' s2''+ _ -> return Nothing+ | otherwise = return Nothing++generalizeFoldL :: S.Solver solver =>+ solver ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ Name ->+ [StateET] ->+ StateET ->+ W.WriterT [Marker] IO (Maybe (StateET, StateET, StateET, StateET))+generalizeFoldL solver num_lems ns lemmas fresh_name prev2 s1 = do+ case prev2 of+ [] -> return Nothing+ p2:t -> do+ gen <- generalize solver num_lems ns lemmas fresh_name (s1, p2)+ case gen of+ Just (s1', s2') -> return $ Just (s1, p2, s1', s2')+ _ -> generalizeFoldL solver num_lems ns lemmas fresh_name t s1++generalizeFold :: S.Solver solver =>+ solver ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ Name ->+ (StateH, StateH) ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO (Maybe (StateET, StateET, StateET, StateET))+generalizeFold solver num_lems ns lemmas fresh_name (sh1, sh2) (s1, s2) = do+ fl <- generalizeFoldL solver num_lems ns lemmas fresh_name (s2:history sh2) s1+ case fl of+ Just _ -> return fl+ Nothing -> do+ fr <- generalizeFoldL solver num_lems ns lemmas fresh_name (s1:history sh1) s2+ case fr of+ Just (q2, q1, q2', q1') -> return $ Just (q1, q2, q1', q2')+ Nothing -> return Nothing++generalizeFull :: S.Solver s => Tactic s+generalizeFull solver num_lems ns lemmas (fresh_name:_) sh_pair s_pair = do+ gfold <- generalizeFold solver num_lems ns lemmas fresh_name sh_pair s_pair+ case gfold of+ Nothing -> return $ NoProof []+ Just (s1, s2, q1, q2) -> let lem = mkProposedLemma "Generalization" s1 s2 q1 q2+ in return $ NoProof $ [lem]+generalizeFull _ _ _ _ _ _ _ = return $ NoProof []
+ src/G2/Equiv/InitRewrite.hs view
@@ -0,0 +1,38 @@+module G2.Equiv.InitRewrite (initWithRHS, initWithLHS) where++import G2.Language+import qualified G2.Language.ExprEnv as E+import qualified G2.Language.Typing as T+import qualified G2.Language.Expr as X++import G2.Execution.Memory++initWithRHS :: State t -> Bindings -> RewriteRule -> (State t, Bindings)+initWithRHS s b r =+ let s' = s {+ curr_expr = CurrExpr Evaluate (ru_rhs r)+ , expr_env = foldr E.insertSymbolic (expr_env s) (ru_bndrs r)+ }+ b' = b { input_names = map idName $ ru_bndrs r }+ in+ markAndSweepPreserving emptyMemConfig s' b'++initWithLHS :: State t -> Bindings -> RewriteRule -> (State t, Bindings)+initWithLHS s b r =+ -- make LHS into a single expr+ let f_name = ru_head r+ f_maybe = E.lookup f_name (expr_env s)+ in+ case f_maybe of+ Nothing -> error "function name not found"+ Just f -> let t = T.typeOf f+ i = Id f_name t+ v = Var i+ app = X.mkApp (v:ru_args r)+ s' = s {+ curr_expr = CurrExpr Evaluate app+ , expr_env = foldr E.insertSymbolic (expr_env s) (ru_bndrs r)+ }+ b' = b { input_names = map idName $ ru_bndrs r }+ in+ markAndSweepPreserving emptyMemConfig s' b'
+ src/G2/Equiv/Summary.hs view
@@ -0,0 +1,588 @@+{-# LANGUAGE OverloadedStrings #-}++module G2.Equiv.Summary+ ( SummaryMode (..)+ , summarize+ , summarizeAct+ , summarizeLemmaMarker+ , printPG+ , showCX+ , showCycle+ , stateMaxDepth+ , stateSumDepths+ , minMaxDepth+ , minSumDepth+ )+ where++import G2.Language++import qualified G2.Language.ExprEnv as E+import qualified G2.Language.Expr as X++import Data.List+import Data.Maybe+import Data.Tuple+import qualified Data.Text as DT++import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HM++import G2.Equiv.Config+import G2.Equiv.EquivADT+import G2.Equiv.G2Calls+import G2.Equiv.Tactics++import G2.Lib.Printers++sideName :: Side -> String+sideName ILeft = "Left"+sideName IRight = "Right"++trackName :: StateET -> String+trackName s =+ let str = folder_name $ track s+ substrs = DT.splitOn (DT.pack "/") $ DT.pack str+ final_sub = case reverse substrs of+ [] -> error "No Substring"+ fs:_ -> DT.unpack fs+ in case final_sub of+ "" -> "Start"+ _ -> final_sub++printPG :: PrettyGuide -> HS.HashSet Name -> [Id] -> StateET -> String+printPG pg ns sym_ids s =+ let label_str = trackName s+ h = expr_env s+ e = inlineVars ns h $ getExpr s+ e_str = DT.unpack $ printHaskellDirtyPG pg e+ -- sym exec keeps higher_order in sync but not concretizations+ -- this means that the ids in func_ids are not always mapped+ -- if they are unmapped, they will not be printed for a state+ depth_str1 = "\nMax Depth: " ++ (show $ maxArgDepth ns sym_ids s)+ depth_str2 = "\nSum Depth: " ++ (show $ sumArgDepths ns sym_ids s)+ func_ids = map snd $ HM.toList $ higher_order $ track s+ sym_vars = varsFullList h ns $ sym_ids ++ func_ids+ sym_str = printVars pg ns s sym_vars+ sym_print = case sym_str of+ "" -> ""+ _ -> "\nMain Symbolic Variables:\n" ++ sym_str+ other_vars = varsFull h ns e \\ sym_vars+ var_str = printVars pg ns s other_vars+ var_print = case var_str of+ "" -> ""+ _ -> "\nOther Variables:\n" ++ var_str+ map_str = printMappings pg s+ map_print = case map_str of+ "" -> ""+ _ -> "\nSymbolic Function Mappings:\n" ++ map_str+ dc_print = "\nPath Length: " ++ (show $ length $ dc_path $ track s)+ in label_str ++ "\n" ++ e_str ++ depth_str1 ++ depth_str2 +++ sym_print ++ var_print ++ map_print ++ dc_print ++ "\n---"++inlineVars :: HS.HashSet Name -> ExprEnv -> Expr -> Expr+inlineVars = inlineVars' HS.empty++inlineVars' :: HS.HashSet Name -> HS.HashSet Name -> ExprEnv -> Expr -> Expr+inlineVars' seen ns eenv v@(Var (Id n _))+ | n `elem` ns = v+ | n `HS.member` seen = v+ | Just (E.Conc e) <- E.lookupConcOrSym n eenv = inlineVars' (HS.insert n seen) ns eenv e+inlineVars' seen ns eenv e = modifyChildren (inlineVars' seen ns eenv) e++data ChainEnd = Symbolic Id+ | Cycle Id+ | Terminal Expr+ | Unmapped++-- don't include ns names in the result here+-- this does not remove duplicates+varsInExpr :: HS.HashSet Name -> Expr -> [Id]+varsInExpr ns e = filter (\i -> not ((idName i) `elem` ns)) $ X.vars e++-- new function for getting all of the variables right away+-- some of the computations here are redundant with what happens later+-- need to prune out repeats+-- should things count as repeats if they appear in the chain?+-- no need to remove duplicates if HashSet used internally+varsFull :: ExprEnv -> HS.HashSet Name -> Expr -> [Id]+varsFull h ns e =+ let v_ids = varsInExpr ns e+ in HS.toList $ varsFullRec ns h (HS.fromList v_ids) v_ids++varsFullList :: ExprEnv -> HS.HashSet Name -> [Id] -> [Id]+varsFullList h ns v_ids =+ HS.toList $ varsFullRec ns h (HS.fromList v_ids) v_ids++varsFullRec :: HS.HashSet Name -> ExprEnv -> HS.HashSet Id -> [Id] -> HS.HashSet Id+varsFullRec ns h seen search+ | null search = seen+ | otherwise =+ let all_exprs = mapMaybe (flip E.lookup h) $ map idName search+ all_vars = vars all_exprs+ all_new = filter+ (\i -> not (((idName i) `elem` ns) || HS.member i seen))+ all_vars+ new_seen = HS.union (HS.fromList all_new) seen+ in varsFullRec ns h new_seen all_new++-- the terminal expression can have variables of its own+-- seemingly, they're not needed for anything+varChain :: ExprEnv -> HS.HashSet Name -> [Id] -> Id -> ([Id], ChainEnd)+varChain h ns inlined i =+ if i `elem` inlined then (reverse inlined, Cycle i)+ else if (idName i) `elem` ns then (reverse inlined, Terminal (Var i))+ else case E.lookupConcOrSym (idName i) h of+ Nothing -> ([], Unmapped)+ Just (E.Sym i') -> (reverse (i:inlined), Symbolic i')+ Just (E.Conc e) -> exprChain h ns (i:inlined) e++exprChain :: ExprEnv -> HS.HashSet Name -> [Id] -> Expr -> ([Id], ChainEnd)+exprChain h ns inlined e = case e of+ Tick _ (Prim Error _) -> (reverse inlined, Terminal e)+ Tick _ e' -> exprChain h ns inlined e'+ Var i -> varChain h ns inlined i+ _ -> (reverse inlined, Terminal e)++-- stop inlining when something in ns reached+printVar :: PrettyGuide -> HS.HashSet Name -> StateET -> Id -> String+printVar pg ns (State{ expr_env = h }) i =+ let (chain, c_end) = varChain h ns [] i+ chain_strs = map (\i_ -> DT.unpack . printHaskellDirtyPG pg $ Var i_) chain+ end_str = case c_end of+ Symbolic (Id _ t) -> "Symbolic " ++ DT.unpack (mkTypeHaskellPG pg t)+ Cycle i' -> "Cycle " ++ DT.unpack (printHaskellDirtyPG pg (Var i'))+ Terminal e -> DT.unpack $ printHaskellDirtyPG pg e+ Unmapped -> ""+ in case c_end of+ Unmapped -> ""+ _ -> (foldr (\str acc -> str ++ " = " ++ acc) "" chain_strs) ++ end_str++printVars :: PrettyGuide -> HS.HashSet Name -> StateET -> [Id] -> String+printVars pg ns s v_ids =+ let var_strs = map (printVar pg ns s) v_ids+ non_empty_strs = filter (not . null) var_strs+ in intercalate "\n" non_empty_strs++printMapping :: PrettyGuide -> (Expr, Id) -> String+printMapping pg (e, i) =+ let e_str = DT.unpack $ printHaskellDirtyPG pg e+ i_str = DT.unpack $ printHaskellDirtyPG pg (Var i)+ in e_str ++ " --> " ++ i_str++printMappings :: PrettyGuide -> StateET -> String+printMappings pg s =+ let mapping_list = HM.toList $ higher_order $ track s+ in intercalate "\n" $ map (printMapping pg) mapping_list++printLemma :: PrettyGuide -> HS.HashSet Name -> [Id] -> Lemma -> String+printLemma pg ns sym_ids (Lemma{+ lemma_name = n+ , lemma_lhs = s1+ , lemma_rhs = s2+ , lemma_lhs_origin = n1+ , lemma_rhs_origin = n2+ }) =+ n ++ ": from " +++ n1 ++ ", " ++ n2 ++ "\n" +++ (summarizeStatePairTrack "States" pg ns sym_ids s1 s2)++-- no new line at end+summarizeStatePairTrack :: String ->+ PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ StateET ->+ StateET ->+ String+summarizeStatePairTrack str pg ns sym_ids s1 s2 =+ str ++ ": " +++ (trackName s1) ++ ", " +++ (trackName s2) ++ "\n" +++ (printPG pg ns sym_ids s1) ++ "\n" +++ (printPG pg ns sym_ids s2)++summarizeLemma :: String+ -> PrettyGuide+ -> HS.HashSet Name+ -> [Id]+ -> Lemma+ -> String+summarizeLemma str pg ns sym_ids lem =+ str ++ ":\n" +++ printLemma pg ns sym_ids lem++summarizeLemmaSubst :: String+ -> PrettyGuide+ -> HS.HashSet Name+ -> [Id]+ -> (StateET, Lemma)+ -> String+summarizeLemmaSubst str pg ns sym_ids (s, lem) =+ "\n" ++ str ++ " Lemma:\n" ++ printLemma pg ns sym_ids lem +++ "\n" ++ str ++ " Before Lemma Usage:\n" ++ printPG pg ns sym_ids s++summarizeCoinduction :: PrettyGuide -> HS.HashSet Name -> [Id] -> CoMarker -> String+summarizeCoinduction pg ns sym_ids (CoMarker {+ co_used_present = (q1, q2)+ , co_past = (p1, p2)+ , lemma_used_left = lemma_l+ , lemma_used_right = lemma_r+ }) =+ "Coinduction:\n" +++ --(summarizeStatePairTrack "Real Present" pg ns sym_ids s1 s2) ++ "\n" +++ (summarizeStatePairTrack "Used Present" pg ns sym_ids q1 q2) ++ "\n" +++ (summarizeStatePairTrack "Past" pg ns sym_ids p1 p2) +++ (intercalate "\n" $ map (summarizeLemmaSubst "Left" pg ns sym_ids) lemma_l) +++ (intercalate "\n" $ map (summarizeLemmaSubst "Right" pg ns sym_ids) lemma_r)++-- variables: find all names used in here+-- look them up, find a fixed point+-- print all relevant vars beside the expressions+-- don't include definitions from the initial state (i.e. things in ns)+summarizeEquality :: PrettyGuide -> HS.HashSet Name -> [Id] -> EqualMarker -> String+summarizeEquality pg ns sym_ids (EqualMarker { eq_used_present = (q1, q2) }) =+ "Equivalent Expressions:\n" +++ --(summarizeStatePairTrack "Real Present" pg ns sym_ids s1 s2) ++ "\n" +++ (summarizeStatePairTrack "Used States" pg ns sym_ids q1 q2)++summarizeCycleFound :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ CycleMarker ->+ String+summarizeCycleFound pg ns sym_ids (CycleMarker (s1, s2) p _ sd) =+ "CYCLE FOUND:\n" +++ (summarizeStatePairTrack "Real Present" pg ns sym_ids s1 s2) +++ "\nPast State:\n" ++ (printPG pg ns sym_ids p) +++ "\nSide: " ++ (sideName sd)++summarizeNoObligations :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (StateET, StateET) ->+ String+summarizeNoObligations = summarizeStatePair "No Obligations Produced"++summarizeNotEquivalent :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (StateET, StateET) ->+ String+summarizeNotEquivalent = summarizeStatePair "NOT EQUIVALENT"++summarizeSolverFail :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (StateET, StateET) ->+ String+summarizeSolverFail = summarizeStatePair "SOLVER FAIL"++summarizeLemmaProposed :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ Lemma ->+ String+summarizeLemmaProposed = summarizeLemma "Lemma Proposed"++summarizeLemmaProven :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ Lemma ->+ String+summarizeLemmaProven = summarizeLemma "Lemma Proven"++summarizeLemmaRejected :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ Lemma ->+ String+summarizeLemmaRejected = summarizeLemma "Lemma Rejected"++summarizeLemmaProvenEarly :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (Lemma, Lemma) ->+ String+summarizeLemmaProvenEarly = summarizeLemmaPair "Lemma Superseded"++summarizeLemmaRejectedEarly :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (Lemma, Lemma) ->+ String+summarizeLemmaRejectedEarly = summarizeLemmaPair "Lemma Discarded"++summarizeLemmaUnresolved :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ Lemma ->+ String+summarizeLemmaUnresolved = summarizeLemma "Lemma Unresolved"++summarizeUnresolved :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (StateET, StateET) ->+ String+summarizeUnresolved = summarizeStatePair "Unresolved"++summarizeStatePair :: String ->+ PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (StateET, StateET) ->+ String+summarizeStatePair str pg ns sym_ids (s1, s2) =+ str ++ ":\n" +++ trackName s1 ++ ", " +++ trackName s2 ++ "\n" +++ printPG pg ns sym_ids s1 ++ "\n" +++ printPG pg ns sym_ids s2++-- we care principally about l2 here+summarizeLemmaPair :: String ->+ PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (Lemma, Lemma) ->+ String+summarizeLemmaPair str pg ns sym_ids (l1, l2) =+ str ++ ":\n" +++ lemma_lhs_origin l2 ++ ", " +++ lemma_rhs_origin l2 ++ "\n" +++ printLemma pg ns sym_ids l1 ++ "\n" +++ printLemma pg ns sym_ids l2++-- TODO s_mode not used for now+summarizeAct :: PrettyGuide+ -> HS.HashSet Name+ -> [Id]+ -> ActMarker+ -> String+summarizeAct pg ns sym_ids m = case m of+ Coinduction cm -> summarizeCoinduction pg ns sym_ids cm+ Equality em -> summarizeEquality pg ns sym_ids em+ NoObligations s_pair -> summarizeNoObligations pg ns sym_ids s_pair+ NotEquivalent s_pair -> summarizeNotEquivalent pg ns sym_ids s_pair+ SolverFail s_pair -> summarizeSolverFail pg ns sym_ids s_pair+ CycleFound cm -> summarizeCycleFound pg ns sym_ids cm+ Unresolved s_pair -> summarizeUnresolved pg ns sym_ids s_pair++summarizeLemmaMarker :: PrettyGuide+ -> HS.HashSet Name+ -> [Id]+ -> LemmaMarker+ -> String+summarizeLemmaMarker pg ns sym_ids lm = case lm of+ LemmaProposed l -> summarizeLemmaProposed pg ns sym_ids l+ LemmaProven l -> summarizeLemmaProven pg ns sym_ids l+ LemmaRejected l -> summarizeLemmaRejected pg ns sym_ids l+ LemmaProvenEarly lp -> summarizeLemmaProvenEarly pg ns sym_ids lp+ LemmaRejectedEarly lp -> summarizeLemmaRejectedEarly pg ns sym_ids lp+ LemmaUnresolved l -> summarizeLemmaUnresolved pg ns sym_ids l++summarizeHistory :: PrettyGuide -> HS.HashSet Name -> [Id] -> StateH -> String+summarizeHistory pg ns sym_ids =+ intercalate "\n" . map (printPG pg ns sym_ids) . reverse . history++tabsAfterNewLines :: String -> String+tabsAfterNewLines [] = []+tabsAfterNewLines ('\n':t) = '\n':'\t':(tabsAfterNewLines t)+tabsAfterNewLines (c:t) = c:(tabsAfterNewLines t)++-- generate the guide for the whole summary externally+summarize :: SummaryMode -> PrettyGuide -> HS.HashSet Name -> [Id] -> Marker -> String+summarize s_mode pg ns sym_ids (Marker (sh1, sh2) m) =+ let names1 = map trackName $ (latest sh1):history sh1+ names2 = map trackName $ (latest sh2):history sh2+ in+ "***\nLeft Path: " +++ (intercalate " -> " $ (reverse names1)) +++ "\nRight Path: " +++ (intercalate " -> " $ (reverse names2)) ++ "\n" +++ (if have_history s_mode+ then "Left:\n\t" ++ tabsAfterNewLines (summarizeHistory pg ns sym_ids sh1)+ ++ "\nRight:\n\t" ++ tabsAfterNewLines (summarizeHistory pg ns sym_ids sh2) ++ "\n"+ else "")+ +++ (tabsAfterNewLines $ summarizeAct pg ns sym_ids m)+summarize s_mode pg ns sym_ids (LMarker lm) =+ if have_lemma_details s_mode+ then "***\n" ++ (tabsAfterNewLines $ summarizeLemmaMarker pg ns sym_ids lm)+ else ""++printDC :: PrettyGuide -> [BlockInfo] -> String -> String+printDC _ [] str = str+printDC pg ((BlockDC d i n):ds) str =+ let d_str = DT.unpack $ printHaskellDirtyPG pg $ Data d+ str' = "(" ++ printDC pg ds str ++ ")"+ pre_blanks = replicate i "_"+ post_blanks = replicate (n - (i + 1)) "_"+ in intercalate " " $ d_str:(pre_blanks ++ (str':post_blanks))+printDC pg (_:ds) str = printDC pg ds str++-- instead of interleaving DCs and lambdas, we handle them separately+-- for lambdas, we wrap applications around the starting exprs+-- earlier list entries represent applications that are farther in+printLams :: PrettyGuide ->+ HS.HashSet Name ->+ ExprEnv ->+ [BlockInfo] ->+ String ->+ String+printLams _ _ _ [] str = str+printLams pg ns h ((BlockLam i):ds) str =+ let arg = inlineVars ns h $ Var i+ arg_str = DT.unpack $ printHaskellDirtyPG pg arg+ str' = "(" ++ str ++ ") " ++ arg_str+ in printLams pg ns h ds str'+printLams pg ns h (_:ds) str = printLams pg ns h ds str++-- for both cycles and regular counterexamples+printCX :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (StateH, StateH) ->+ (State t, State t) ->+ (StateET, StateET) ->+ String ->+ String ->+ String+printCX pg ns sym_ids (sh1, sh2) (s1, s2) (q1', q2') end1_str end2_str =+ let h = expr_env q2'+ names1 = map trackName $ (latest sh1):history sh1+ names2 = map trackName $ (latest sh2):history sh2+ e1 = inlineVars ns (expr_env q1') $ getExpr s1+ e1_str = DT.unpack $ printHaskellPG pg q1' e1+ e1_str' = printLams pg ns (expr_env q1') (dc_path $ track q1') e1_str+ e2 = inlineVars ns h $ getExpr s2+ e2_str = DT.unpack $ printHaskellPG pg q2' e2+ e2_str' = printLams pg ns (expr_env q2') (dc_path $ track q2') e2_str+ cx_str = e1_str' ++ " = " ++ end1_str ++ " but " +++ e2_str' ++ " = " ++ end2_str+ func_ids = map snd $ HM.toList $ higher_order $ track q2'+ sym_vars = varsFullList h ns $ sym_ids ++ func_ids+ sym_str = printVars pg ns q2' sym_vars+ sym_print = case sym_str of+ "" -> ""+ _ -> "\nMain Symbolic Variables:\n" ++ sym_str+ other_vars = varsFull h ns (App (getExpr q1') (getExpr q2')) \\ sym_vars+ var_str = printVars pg ns q2' other_vars+ var_print = case var_str of+ "" -> ""+ _ -> "\nOther Variables:\n" ++ var_str+ map_str = printMappings pg q2'+ map_print = case map_str of+ "" -> ""+ _ -> "\nSymbolic Function Mappings:\n" ++ map_str+ in+ "Left Path: " +++ (intercalate " -> " $ (reverse names1)) +++ "\nRight Path: " +++ (intercalate " -> " $ (reverse names2)) ++ "\n" +++ intercalate "" [cx_str, sym_print, var_print, map_print]++-- counterexample printing+-- first state pair is initial states, second is from counterexample+showCX :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (StateH, StateH) ->+ (State t, State t) ->+ (StateET, StateET) ->+ String+showCX pg ns sym_ids sh_pair s_pair (q1, q2) =+ -- main part showing contradiction+ let (q1', q2') = syncEnvs q1 q2+ end1 = inlineVars ns (expr_env q1') $ getExpr q1'+ end1_str = printDC pg (dc_path $ track q1') . DT.unpack $ printHaskellPG pg q1' end1+ end2 = inlineVars ns (expr_env q2') $ getExpr q2'+ end2_str = printDC pg (dc_path $ track q2') . DT.unpack $ printHaskellPG pg q2' end2+ in printCX pg ns sym_ids sh_pair s_pair (q1', q2') end1_str end2_str++showCycle :: PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (StateH, StateH) ->+ (State t, State t) ->+ CycleMarker ->+ String+showCycle pg ns sym_ids sh_pair s_pair cm =+ let (q1, q2) = cycle_real_present cm+ (q1', q2') = syncEnvs q1 q2+ end1 = inlineVars ns (expr_env q1') $ getExpr q1'+ end1_str = case cycle_side cm of+ ILeft -> "{HAS NON-TERMINATING PATH}"+ IRight -> printDC pg (dc_path $ track q1') . DT.unpack $ printHaskellPG pg q1' end1+ end2 = inlineVars ns (expr_env q2') $ getExpr q2'+ end2_str = case cycle_side cm of+ ILeft -> printDC pg (dc_path $ track q2') . DT.unpack $ printHaskellPG pg q2' end2+ IRight -> "{HAS NON-TERMINATING PATH}"+ mappings = map swap $ HM.toList $ cycle_mapping cm+ mapping_str = intercalate "\n" $ map (printMapping pg) mappings+ mapping_print = "\nMapping for Cycle:\n" ++ mapping_str+ in+ (printCX pg ns sym_ids sh_pair s_pair (q1', q2') end1_str end2_str) ++ mapping_print++-- type arguments do not contribute to the depth of an expression+-- this takes the opposite side's expression environment into account+exprDepth :: ExprEnv -> ExprEnv -> HS.HashSet Name -> [Name] -> Expr -> Int+exprDepth h h' ns n e = case e of+ Tick _ e' -> exprDepth h h' ns n e'+ Var i | isSymbolicBoth (idName i) h h' -> 0+ | m <- idName i+ , not $ m `elem` ns+ , Just e' <- lookupBoth m h h' -> exprDepth h h' ns (m:n) e'+ | not $ (idName i) `elem` ns -> error "unmapped variable"+ _ | d@(Data (DataCon _ _)):l <- unAppNoTicks e+ , not $ null (anonArgumentTypes d) ->+ 1 + (maximum $ 0:(map (exprDepth h h' ns n) l))+ | otherwise -> 0++getDepth :: StateET -> HS.HashSet Name -> Id -> Int+getDepth s ns i = exprDepth (expr_env s) (opp_env $ track s) ns [] (Var i)++maxArgDepth :: HS.HashSet Name -> [Id] -> StateET -> Int+maxArgDepth ns sym_ids s = case sym_ids of+ [] -> 0+ _ -> maximum $ map (getDepth s ns) sym_ids++sumArgDepths :: HS.HashSet Name -> [Id] -> StateET -> Int+sumArgDepths ns sym_ids s = foldr (+) 0 $ map (getDepth s ns) sym_ids++minDepthMetric :: (HS.HashSet Name -> [Id] -> StateET -> Int) ->+ HS.HashSet Name ->+ [Id] ->+ [(StateH, StateH)] ->+ Int+minDepthMetric m ns sym_ids states =+ let lefts = map (\(sh1, _) -> latest sh1) states+ rights = map (\(_, sh2) -> latest sh2) states+ (lefts', rights') = unzip $ map (uncurry syncSymbolic) (zip lefts rights)+ depths = map (m ns sym_ids) $ lefts' ++ rights'+ in case states of+ [] -> 0+ _ -> minimum depths++stateDepthMetric :: (HS.HashSet Name -> [Id] -> StateET -> Int) ->+ HS.HashSet Name ->+ [Id] ->+ (StateH, StateH) ->+ Int+stateDepthMetric m ns sym_ids (sh1, sh2) =+ let (s1, s2) = syncSymbolic (latest sh1) (latest sh2)+ in min (m ns sym_ids s1) (m ns sym_ids s2)++stateMaxDepth :: HS.HashSet Name -> [Id] -> (StateH, StateH) -> Int+stateMaxDepth = stateDepthMetric maxArgDepth++stateSumDepths :: HS.HashSet Name -> [Id] -> (StateH, StateH) -> Int+stateSumDepths = stateDepthMetric sumArgDepths++minMaxDepth :: HS.HashSet Name -> [Id] -> [(StateH, StateH)] -> Int+minMaxDepth = minDepthMetric maxArgDepth++-- correct to sync beforehand for all these+minSumDepth :: HS.HashSet Name -> [Id] -> [(StateH, StateH)] -> Int+minSumDepth = minDepthMetric sumArgDepths
+ src/G2/Equiv/Tactics.hs view
@@ -0,0 +1,729 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module G2.Equiv.Tactics+ ( module G2.Equiv.Types+ , TacticResult (..)+ , Tactic++ , Lemmas (..)++ , isSWHNF+ , tryEquality+ , moreRestrictiveEqual+ , tryCoinduction+ , checkObligations+ , LA.applySolver+ , backtrackOne+ , syncSymbolic+ , A.syncEnvs++ , emptyLemmas+ , insertProposedLemma+ , proposedLemmas+ , replaceProposedLemmas+ , insertProvenLemma+ , provenLemmas++ , disprovenLemmas+ , insertDisprovenLemma++ , A.mkProposedLemma+ , checkCycle+ )+ where++import G2.Language++import qualified Control.Monad.State.Lazy as CM++import qualified G2.Equiv.Approximation as A+import qualified G2.Language.Approximation as LA+import qualified G2.Language.ExprEnv as E+import G2.Language.Monad.AST+import qualified G2.Language.Typing as T++import Data.List+import Data.Maybe+import Data.Tuple+import qualified Data.HashSet as HS+import qualified G2.Solver as S++import qualified G2.Language.PathConds as P++import G2.Equiv.G2Calls+import G2.Equiv.Types++import Data.Either+import Data.Either.Extra+import qualified Data.HashMap.Lazy as HM+import Data.Monoid ((<>))++import G2.Execution.NormalForms+import Control.Monad.Extra++import qualified Control.Monad.Writer.Lazy as W++-- the Bool value for Failure is True if a cycle has been found+data TacticResult = Success+ | NoProof [Lemma]+ | Failure Bool++-- this takes a list of fresh names as input+-- equality and coinduction don't need them+-- induction just needs one+-- all tactics now take a lemma count+type Tactic s = s ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ [Name] ->+ (StateH, StateH) ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO TacticResult++validTotal :: StateET ->+ StateET ->+ HS.HashSet Name ->+ HM.HashMap Id Expr ->+ Bool+validTotal s1 s2 ns hm =+ let hm_list = HM.toList hm+ total_hs = total_vars $ track s1+ check (i, e) = (not $ (idName i) `elem` total_hs) || (totalExpr s2 ns [] e)+ in all check hm_list++validTypes :: HM.HashMap Id Expr -> Bool+validTypes hm = all (\((Id _ t), e) -> e T..:: t) $ HM.toList hm++restrictHelper :: StateET ->+ StateET ->+ HS.HashSet Name ->+ Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) ->+ Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+restrictHelper s1 s2 ns hm_hs =+ (\(hm, hs) -> if (validTotal s1 s2 ns hm) && (validTypes hm)+ then Right (hm, hs)+ else Left [])+ =<< A.moreRestrictive s1 s2 ns =<< hm_hs++syncSymbolic :: StateET -> StateET -> (StateET, StateET)+syncSymbolic s1 s2 =+ let et1 = (track s1) { opp_env = expr_env s2 }+ et2 = (track s2) { opp_env = expr_env s1 }+ in (s1 { track = et1 }, s2 { track = et2 })++obligationWrap :: HS.HashSet (Expr, Expr) -> Maybe PathCond+obligationWrap obligations =+ let obligation_list = HS.toList obligations+ eq_list = map (\(e1, e2) -> App (App (Prim Eq TyUnknown) e1) e2) obligation_list+ conj = foldr1 (\o1 o2 -> App (App (Prim And TyUnknown) o1) o2) eq_list+ in+ if null eq_list+ then Nothing+ else Just $ ExtCond (App (Prim Not TyUnknown) conj) True++checkObligations :: S.Solver solver =>+ solver ->+ StateET ->+ StateET ->+ HS.HashSet (Expr, Expr) ->+ IO (S.Result () () ())+checkObligations solver s1 s2 obligation_set | not $ HS.null obligation_set =+ case obligationWrap $ modifyASTs stripTicks obligation_set of+ Nothing -> LA.applySolver solver P.empty s1 s2+ Just allPO -> LA.applySolver solver (P.insert allPO P.empty) s1 s2+ | otherwise = return $ S.UNSAT ()++-- extra filter on top of isJust for maybe_pairs+-- if restrictHelper end result is Just, try checking the corresponding PCs+-- for True output, there needs to be an entry for which that check succeeds+-- return the previous state pair that was used for the discharge+-- return Nothing if there was no discharge+-- if there are multiple, just return the first+-- first pair is "current," second pair is the match from the past+-- the third entry in a prev triple is the original for left or right+moreRestrictivePair :: S.Solver solver =>+ solver ->+ ((StateET, StateET) -> (StateET, StateET) -> Bool) ->+ HS.HashSet Name ->+ [(StateET, StateET)] ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO (Either [Lemma] (PrevMatch EquivTracker))+moreRestrictivePair solver valid ns prev (s1, s2) | dc_path (track s1) == dc_path (track s2) = do+ let (s1', s2') = syncSymbolic s1 s2+ mr (p1, p2) =+ if valid (p1, p2) (s1', s2') then+ let hm_obs = let (p1', p2') = syncSymbolic p1 p2+ in restrictHelper p2' s2' ns $+ restrictHelper p1' s1' ns (Right (HM.empty, HS.empty))+ hm_obs_ = case hm_obs of+ Left lems -> Left $ zip lems [1..length lems]+ Right hmo -> Right hmo+ in+ mapLeft (fmap (\(l, i) -> l { lemma_name = "Lem" ++ show i+ ++ " past_1 = " ++ folder p1+ ++ " present_1 = " ++ folder s1+ ++ " past_2 = " ++ folder p2+ ++ " present_2 = " ++ folder s2 }))+ $ fmap (\hm_obs' -> PrevMatch (s1, s2) (p1, p2) hm_obs' p2) hm_obs_+ else Left []+ + (possible_lemmas, possible_matches) = partitionEithers $ map mr prev++ folder = folder_name . track+ -- As a heuristic, take only lemmas where both sides are not in SWHNF+ possible_lemmas' = filter (\(Lemma { lemma_lhs = s1_, lemma_rhs = s2_ }) ->+ not (isSWHNF s1_)+ && not (isSWHNF s2_))+ $ concat possible_lemmas++ mpc (PrevMatch _ (p1, p2) (hm, _) _) =+ andM [LA.moreRestrictivePC solver p1 s1 hm, LA.moreRestrictivePC solver p2 s2 hm]++ possible_matches' <- filterM mpc possible_matches+ -- check obligations individually rather than as one big group+ res_list <- W.liftIO (findM (\pm -> isUnsat =<< checkObligations solver s1 s2 (snd . conditions $ pm)) (possible_matches'))+ return $ maybe (Left possible_lemmas') Right res_list+ | otherwise = return $ Left []+ where+ isUnsat (S.UNSAT _) = return True+ isUnsat _ = return False++moreRestrictiveSingle :: S.Solver solver =>+ solver ->+ HS.HashSet Name ->+ StateET ->+ StateET ->+ W.WriterT [Marker] IO (Either [Lemma] (HM.HashMap Id Expr))+moreRestrictiveSingle solver ns s1 s2 = do+ case restrictHelper s1 s2 ns $ Right (HM.empty, HS.empty) of+ (Left l) -> return $ Left l+ Right (hm, obs) -> do+ more_res_pc <- LA.moreRestrictivePC solver s1 s2 hm+ case more_res_pc of+ False -> return $ Left []+ True -> do+ obs' <- W.liftIO (checkObligations solver s1 s2 obs)+ case obs' of+ S.UNSAT _ -> return (Right hm)+ _ -> return $ Left []++-------------------------------------------------------------------------------+-- Equality+-------------------------------------------------------------------------------++-- approximation should be the identity map+-- needs to be enforced, won't just happen naturally+moreRestrictiveEqual :: S.Solver solver =>+ solver ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ StateET ->+ StateET ->+ W.WriterT [Marker] IO (Maybe (PrevMatch EquivTracker))+moreRestrictiveEqual solver num_lems ns lemmas s1 s2 = do+ let (s1', s2') = syncSymbolic s1 s2+ if dc_path (track s1') /= dc_path (track s2') then return Nothing+ else do+ -- no need to enforce dc path condition for this function+ pm_maybe <- moreRestrictivePairWithLemmasPast solver num_lems ns lemmas [(s2', s1')] (s1', s2')+ case pm_maybe of+ Left _ -> return Nothing+ Right (_, _, pm@(PrevMatch _ _ (hm, _) _)) ->+ if all isIdentity $ HM.toList hm+ then return $ Just pm+ else return Nothing+ where+ isIdentity :: (Id, Expr) -> Bool+ isIdentity (i1, Tick _ e2) = isIdentity (i1, e2)+ isIdentity (i1, (Var i2)) = i1 == i2+ isIdentity _ = False++-- This tries all of the allowable combinations for equality checking. First+-- it tries matching the left-hand present state with all of the previously+-- encountered right-hand states. If all of those fail, it tries matching the+-- right-hand present state with all of the previously encountered left-hand+-- states.+equalFold :: S.Solver solver =>+ solver ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ (StateH, StateH) ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO (Maybe (PrevMatch EquivTracker))+equalFold solver num_lems ns lemmas (sh1, sh2) (s1, s2) = do+ -- This attempts to find a pair of equal expressions between the left and right+ -- sides. The state used for the left side stays constant, but the recursion+ -- iterates through all of the states in the right side's history.+ let equalFoldL s = firstJustM (moreRestrictiveEqual solver num_lems ns lemmas s)++ pm_l <- equalFoldL s1 (s2:history sh2)+ case pm_l of+ Just pm -> return $ Just pm+ _ -> do+ pm_r <- equalFoldL s2 (s1:history sh1)+ return $ fmap (\pm -> pm { present = swap $ present pm }) pm_r++tryEquality :: S.Solver s => Tactic s+tryEquality solver num_lems ns lemmas _ sh_pair (s1, s2) = do+ res <- equalFold solver num_lems ns lemmas sh_pair (s1, s2)+ case res of+ Just pm -> do+ W.tell $ [Marker sh_pair $ Equality $ EqualMarker (s1, s2) (present pm)]+ return Success+ _ -> return (NoProof [])++-------------------------------------------------------------------------------+-- Coinduction+-------------------------------------------------------------------------------++-- This attempts to find a past-present combination that works for coinduction.+-- The left-hand present state stays fixed, but the recursion iterates through+-- all of the possible options for the right-hand present state.+coinductionFoldL :: S.Solver solver =>+ solver ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ [Lemma] ->+ (StateH, StateH) ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO (Either [Lemma] ([(StateET, Lemma)], [(StateET, Lemma)], PrevMatch EquivTracker))+coinductionFoldL solver num_lems ns lemmas gen_lemmas (sh1, sh2) (s1, s2) = do+ let prev = [(p1, p2) | p1 <- history sh1, p2 <- history sh2]+ res <- moreRestrictivePairWithLemmasOnFuncApps solver num_lems validCoinduction ns lemmas prev (s1', s2')+ case res of+ Right _ -> return res+ Left new_lems -> backtrack new_lems+ where+ (s1', s2') = syncSymbolic s1 s2++ backtrack new_lems_ =+ case backtrackOne sh2 of+ Nothing -> return . Left $ new_lems_ ++ gen_lemmas+ Just sh2' -> coinductionFoldL solver num_lems ns lemmas+ (new_lems_ ++ gen_lemmas) (sh1, sh2') (s1, latest sh2')++validCoinduction :: (StateET, StateET) -> (StateET, StateET) -> Bool+validCoinduction (p1, p2) (q1, q2) =+ let dcp1 = dc_path $ track p1+ dcp2 = dc_path $ track p2+ dcq1 = dc_path $ track q1+ dcq2 = dc_path $ track q2+ consistent = dcp1 == dcp2 && dcq1 == dcq2+ unguarded = all (not . isSWHNF) [p1, p2, q1, q2]+ guarded = length dcp1 < length dcq1+ in consistent && (guarded || unguarded)++backtrackOne :: StateH -> Maybe StateH+backtrackOne sh =+ case history sh of+ [] -> Nothing+ h:t -> Just $ sh { latest = h+ , history = t+ }++tryCoinduction :: S.Solver s => Tactic s+tryCoinduction solver num_lems ns lemmas _ (sh1, sh2) (s1, s2) = do+ res_l <- coinductionFoldL solver num_lems ns lemmas [] (sh1, sh2) (s1, s2)+ case res_l of+ Right (lem_l, lem_r, pm) -> do+ let cml = CoMarker {+ co_real_present = (s1, s2)+ , co_used_present = present pm+ , co_past = past pm+ , lemma_used_left = lem_l+ , lemma_used_right = lem_r+ }+ W.tell [Marker (sh1, sh2) $ Coinduction cml]+ return Success+ Left l_lemmas -> do+ res_r <- coinductionFoldL solver num_lems ns lemmas [] (sh2, sh1) (s2, s1)+ case res_r of+ Right (lem_l, lem_r, pm) -> do+ let cmr = CoMarker {+ co_real_present = (s2, s1)+ , co_used_present = present pm+ , co_past = past pm+ , lemma_used_left = lem_l+ , lemma_used_right = lem_r+ }+ W.tell [Marker (sh1, sh2) $ Coinduction $ reverseCoMarker cmr]+ return Success+ Left r_lemmas -> return . NoProof $ l_lemmas ++ r_lemmas++-------------------------------------------------------------------------------+-- Lemmas+-------------------------------------------------------------------------------++data Lemmas = Lemmas { proposed_lemmas :: [ProposedLemma]+ , proven_lemmas :: [ProvenLemma]+ , disproven_lemmas :: [DisprovenLemma]}++emptyLemmas :: Lemmas+emptyLemmas = Lemmas [] [] []++insertProposedLemma :: S.Solver solver => solver -> HS.HashSet Name -> Lemma -> Lemmas -> W.WriterT [Marker] IO Lemmas+insertProposedLemma solver ns lem lems@(Lemmas { proposed_lemmas = prop_lems+ , proven_lemmas = proven_lems+ , disproven_lemmas = disproven_lems }) = do+ same_as_proposed <- equivLemma solver ns lem prop_lems+ implied_by_proven <- moreRestrictiveLemma solver ns lem proven_lems+ implies_disproven <- anyM (\dl -> moreRestrictiveLemma solver ns dl [lem]) disproven_lems+ case same_as_proposed || implied_by_proven || implies_disproven of+ True -> return lems+ False -> do+ W.tell [LMarker $ LemmaProposed lem]+ return lems { proposed_lemmas = lem:prop_lems }++proposedLemmas :: Lemmas -> [ProposedLemma]+proposedLemmas = proposed_lemmas++provenLemmas :: Lemmas -> [ProposedLemma]+provenLemmas = proven_lemmas++disprovenLemmas :: Lemmas -> [ProposedLemma]+disprovenLemmas = disproven_lemmas++replaceProposedLemmas :: [ProposedLemma] -> Lemmas -> Lemmas+replaceProposedLemmas pl lems = lems { proposed_lemmas = pl }++-- proactively confirm lemmas implied by this+-- this might be redundant with the verifier's work+insertProvenLemma :: S.Solver solver =>+ solver+ -> HS.HashSet Name+ -> Lemmas+ -> ProvenLemma+ -> W.WriterT [Marker] IO Lemmas+insertProvenLemma solver ns lems lem = do+ W.tell [LMarker $ LemmaProven lem]+ let prop_lems = proposed_lemmas lems+ (extra_proven, still_prop) <- partitionM (\l -> moreRestrictiveLemma solver ns l [lem]) prop_lems+ W.tell $ map (\l -> LMarker $ LemmaProvenEarly (lem, l)) extra_proven+ return $ lems {+ proposed_lemmas = still_prop+ , proven_lemmas = lem:(extra_proven ++ proven_lemmas lems)+ }++-- remove lemmas that imply the disproven lemma+-- for every discarded lemma, add a marker+insertDisprovenLemma :: S.Solver solver =>+ solver+ -> HS.HashSet Name+ -> Lemmas+ -> DisprovenLemma+ -> W.WriterT [Marker] IO Lemmas+insertDisprovenLemma solver ns lems lem = do+ W.tell [LMarker $ LemmaRejected lem]+ -- the one implied is the more specific one+ -- the one doing the implying is the more general one+ let prop_lems = proposed_lemmas lems+ (extra_disproven, still_prop) <- partitionM (\l -> moreRestrictiveLemma solver ns lem [l]) prop_lems+ W.tell $ map (\l -> LMarker $ LemmaRejectedEarly (lem, l)) extra_disproven+ return $ lems {+ proposed_lemmas = still_prop+ , disproven_lemmas = lem:(extra_disproven ++ disproven_lemmas lems)+ }++moreRestrictiveLemma :: S.Solver solver => solver -> HS.HashSet Name -> Lemma -> [Lemma] -> W.WriterT [Marker] IO Bool +moreRestrictiveLemma solver ns (Lemma { lemma_lhs = l1_1, lemma_rhs = l1_2 }) lems = do+ mr <- moreRestrictivePair solver (\_ _ -> True) ns+ (map (\(Lemma { lemma_lhs = l2_1, lemma_rhs = l2_2 }) -> (l2_1, l2_2)) lems)+ (l1_1, l1_2)+ case mr of+ Left _ -> return False+ Right _ -> return True++equivLemma :: S.Solver solver => solver -> HS.HashSet Name -> Lemma -> [Lemma] -> W.WriterT [Marker] IO Bool +equivLemma solver ns (Lemma { lemma_lhs = l1_1, lemma_rhs = l1_2 }) lems = do+ anyM (\(Lemma { lemma_lhs = l2_1, lemma_rhs = l2_2 }) -> do+ mr1 <- moreRestrictivePair solver (\_ _ -> True) ns [(l2_1, l2_2)] (l1_1, l1_2)+ mr2 <- moreRestrictivePair solver (\_ _ -> True) ns [(l1_1, l1_2)] (l2_1, l2_2)+ case (mr1, mr2) of+ (Right _, Right _) -> return True+ _ -> return False) lems++-- TODO: Does substLemma need to do something more to check correctness of path constraints?+-- `substLemma state lemmas` tries to apply each proven lemma in `lemmas` to `state`.+-- In particular, for each `lemma = (lemma_l `equiv lemma_r` in the proven lemmas, it+-- searches for a subexpression `e'` of `state`'s current expression such that `e' <=_V lemma_l`.+-- If it find such a subexpression, it adds state[e'[V(x)/x]] to the returned+-- list of States.+substLemma :: S.Solver solver =>+ solver ->+ HS.HashSet Name ->+ StateET ->+ Lemmas ->+ W.WriterT [Marker] IO [(Lemma, StateET)]+substLemma solver ns s =+ mapMaybeM (\lem -> replaceMoreRestrictiveSubExpr solver ns lem s) . provenLemmas++-- int counter is a safeguard against divergence+-- optimization: lemmas that go unused in one iteration are removed for+-- the next iteration; lost opportunities possible but not observed yet+substLemmaLoopAux :: S.Solver solver =>+ Int ->+ solver ->+ HS.HashSet Name ->+ Lemmas ->+ [(Lemma, StateET)] ->+ StateET ->+ W.WriterT [Marker] IO [([(Lemma, StateET)], StateET)]+substLemmaLoopAux 0 _ _ _ _ _ =+ return []+substLemmaLoopAux i solver ns lems past_lems s = do+ lem_states <- substLemma solver ns s lems+ let lem_states' = map (\(l, s') -> ((l, s):past_lems, s')) lem_states+ lems_used = lems { proven_lemmas = nub $ map fst lem_states }+ lem_state_lists <- mapM (uncurry (substLemmaLoopAux (i - 1) solver ns lems_used)) lem_states'+ return $ lem_states' ++ concat lem_state_lists++substLemmaLoop :: S.Solver solver =>+ Int ->+ solver ->+ HS.HashSet Name ->+ StateET ->+ Lemmas ->+ W.WriterT [Marker] IO [([(Lemma, StateET)], StateET)]+substLemmaLoop i solver ns s lems = substLemmaLoopAux i solver ns lems [] s++replaceMoreRestrictiveSubExpr :: S.Solver solver =>+ solver ->+ HS.HashSet Name ->+ Lemma ->+ StateET ->+ W.WriterT [Marker] IO (Maybe (Lemma, StateET))+replaceMoreRestrictiveSubExpr solver ns lemma s@(State { curr_expr = CurrExpr er _ }) = do+ let sound = lemmaSound ns s lemma+ (e, replaced) <- CM.runStateT (replaceMoreRestrictiveSubExpr' solver ns lemma s sound $ getExpr s) Nothing+ case replaced of+ Nothing -> return Nothing+ Just new_vars -> let new_ids = map fst new_vars+ h = foldr E.insertSymbolic (expr_env s) new_ids+ new_total = map (idName . fst) $ filter snd new_vars+ total' = foldr HS.insert (total_vars $ track s) new_total+ track' = (track s) { total_vars = total' }+ s' = s {+ curr_expr = CurrExpr er e+ , expr_env = h+ , track = track'+ }+ in return $ Just (lemma, s')++{-+If a symbolic variable is on the RHS of a lemma but not the LHS, add it to the+expression environment of the state receiving the substitution.+No need to carry over concretized ones because of inlineEquiv.+Get all of the symbolic IDs that are not in v_rep from the lemma RHS.+Keep track of totality info for variables that get migrated.+If the variable is concrete in one location but symbolic in another, making the+substitution from the symbolic place to the concrete place is still valid.+If it's unmapped, put it in as symbolic.+If it's concrete or symbolic, just leave it as it is.+This implementation does not cover finiteness information.+The Bool argument of this function is used to determine whether a lemma+substitution can be applied soundly at the current location. If an+expression is in FAF with no nested applications of the function at the+outermost layer, substitutions are sound. Any sub-expression of an FAF+expression like this can also receive substitutions soundly. If the+recursion has ever passed through a sub-expression that fits the FAF+format, then the Bool argument carries that information down to lower+recursive calls.+-}+replaceMoreRestrictiveSubExpr' :: S.Solver solver =>+ solver ->+ HS.HashSet Name ->+ Lemma ->+ StateET ->+ Bool ->+ Expr ->+ CM.StateT (Maybe [(Id, Bool)]) (W.WriterT [Marker] IO) Expr+replaceMoreRestrictiveSubExpr' solver ns lemma@(Lemma { lemma_lhs = lhs_s, lemma_rhs = rhs_s })+ s2 sound e = do+ replaced <- CM.get+ if isNothing replaced then do+ mr_sub <- CM.lift $ moreRestrictiveSingle solver ns lhs_s (s2 { curr_expr = CurrExpr Evaluate e })+ case mr_sub of+ Right hm -> do+ let v_rep = HM.toList hm+ ids_l = E.symbolicIds $ opp_env $ track rhs_s+ ids_r = E.symbolicIds $ expr_env rhs_s+ ids_both = nub (ids_l ++ ids_r)+ new_ids = filter (\(Id n _) -> not (E.member n (expr_env s2) || E.member n (opp_env $ track s2))) ids_both+ new_info = map (\(Id n _) -> n `elem` (total_vars $ track rhs_s)) new_ids+ + lkp n s = lookupConcOrSymBoth n (expr_env s) (opp_env $ track s)+ rhs_e' = A.replaceVars (LA.inlineEquiv lkp rhs_s ns $ getExpr rhs_s) v_rep+ CM.put $ Just $ zip new_ids new_info+ return rhs_e'+ Left _ -> do+ let ns' = foldr HS.insert ns (bind e)+ sound' = lemmaSound ns' s2 lemma+ modifyChildrenM (replaceMoreRestrictiveSubExpr' solver ns' lemma s2 (sound || sound')) e+ else return e+ where+ bind (Lam _ i _) = [idName i]+ bind (Case _ i _ as) = idName i:concatMap altBind as+ bind (Let b _) = map (idName . fst) b+ bind _ = []++ altBind (Alt (DataAlt _ is) _) = map idName is+ altBind _ = []++-- This is a looser version of the lemma soundness check from the paper.+-- Instead of checking that the expression receiving the substitution is+-- a suitable function application at the outermost level, we simply look+-- for a sub-expression that fits that mold. Substitutions can only+-- happen within sub-expressions that satisfy the conditions.+-- This is still just as safe as the original soundness check. The+-- original soundness check serves to prevent lemmas from reversing+-- evaluation steps so that a substitution does not trick Nebula into+-- thinking that it has reached a cycle when it has not. If we confirm+-- that evaluation steps are not being reversed within a sub-expression,+-- that same guarantee should extend to the expression as a whole.+lemmaSound :: HS.HashSet Name -> StateET -> Lemma -> Bool+lemmaSound ns s lem =+ let lkp n s_ = lookupConcOrSymBoth n (expr_env s_) (opp_env $ track s_) in+ case unApp . modifyASTs stripTicks . LA.inlineEquiv lkp s ns $ getExpr s of+ Var (Id f _):_ ->+ let+ lem_vars = varNames $ LA.inlineEquiv lkp s ns $ getExpr (lemma_rhs lem)+ in+ not $ f `elem` lem_vars+ _ -> False++-- Tries to apply lemmas to expressions only in FAF form, and only if the function being applied can not be+-- called in any way by the lemma.+moreRestrictivePairWithLemmasOnFuncApps :: S.Solver solver =>+ solver ->+ Int ->+ ((StateET, StateET) -> (StateET, StateET) -> Bool) ->+ HS.HashSet Name ->+ Lemmas ->+ [(StateET, StateET)] ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO (Either [Lemma] ([(StateET, Lemma)], [(StateET, Lemma)], PrevMatch EquivTracker))+moreRestrictivePairWithLemmasOnFuncApps solver num_lems valid ns =+ moreRestrictivePairWithLemmas solver num_lems valid ns++moreRestrictivePairWithLemmas :: S.Solver solver =>+ solver ->+ Int ->+ ((StateET, StateET) -> (StateET, StateET) -> Bool) ->+ HS.HashSet Name ->+ Lemmas ->+ [(StateET, StateET)] ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO (Either [Lemma] ([(StateET, Lemma)], [(StateET, Lemma)], PrevMatch EquivTracker))+moreRestrictivePairWithLemmas solver num_lems valid ns lemmas past_list (s1, s2) = do+ let (s1', s2') = syncSymbolic s1 s2+ xs1 <- substLemmaLoop num_lems solver ns s1' lemmas+ xs2 <- substLemmaLoop num_lems solver ns s2' lemmas++ let xs1' = ([], s1'):xs1+ xs2' = ([], s2'):xs2+ pairs = [ (pair1, pair2) | pair1 <- xs1', pair2 <- xs2' ]++ rp <- mapM (\((l1, s1_), (l2, s2_)) -> do+ mrp <- moreRestrictivePair solver valid ns past_list (s1_, s2_)+ -- the underscore states here are ones with substs applied+ let l1' = map swap l1+ let l2' = map swap l2+ return $ fmap (l1', l2', ) mrp) pairs+ let (possible_lemmas, possible_matches) = partitionEithers rp++ case possible_matches of+ x:_ -> return $ Right x+ [] -> return . Left $ concat possible_lemmas++moreRestrictivePairWithLemmasPast :: S.Solver solver =>+ solver ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ [(StateET, StateET)] ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO (Either [Lemma] ([(StateET, Lemma)], [(StateET, Lemma)], PrevMatch EquivTracker))+moreRestrictivePairWithLemmasPast solver num_lems ns lemmas past_list s_pair = do+ let (past1, past2) = unzip past_list+ xs_past1 <- mapM (\(q1, _) -> substLemmaLoop num_lems solver ns q1 lemmas) past_list+ xs_past2 <- mapM (\(_, q2) -> substLemmaLoop num_lems solver ns q2 lemmas) past_list+ let plain_past1 = map (\s_ -> (Nothing, s_)) past1+ plain_past2 = map (\s_ -> (Nothing, s_)) past2+ xs_past1' = plain_past1 ++ (map (\(l, s) -> (Just l, s)) $ concat xs_past1)+ xs_past2' = plain_past2 ++ (map (\(l, s) -> (Just l, s)) $ concat xs_past2)+ pair_past (_, p1) (_, p2) = syncSymbolic p1 p2+ past_list' = [pair_past pair1 pair2 | pair1 <- xs_past1', pair2 <- xs_past2']+ moreRestrictivePairWithLemmas solver num_lems (\_ _ -> True) ns lemmas past_list' s_pair++-------------------------------------------------------------------------------+-- CounterExample Generation+-------------------------------------------------------------------------------++checkCycle :: S.Solver s => Tactic s+checkCycle solver _ ns _ _ (sh1, sh2) (s1, s2) = do+ --W.liftIO $ putStrLn $ "Cycle?" ++ (folder_name $ track s1) ++ (folder_name $ track s2)+ let (s1', s2') = syncSymbolic s1 s2+ hist1 = filter (\p -> dc_path (track p) == dc_path (track s1')) $ history sh1+ hist2 = filter (\p -> dc_path (track p) == dc_path (track s2')) $ history sh2+ hist1' = zip hist1 (map expr_env hist2)+ hist2' = zip hist2 (map expr_env hist1)+ -- histories must have the same length and have matching entries+ mr1 <- mapM (\(p1, hp2) -> moreRestrictiveSingle solver ns s1' (p1 { track = (track p1) { opp_env = hp2 } })) hist1'+ mr2 <- mapM (\(p2, hp1) -> moreRestrictiveSingle solver ns s2' (p2 { track = (track p2) { opp_env = hp1 } })) hist2'+ let vh _ (Left _, _) = False+ vh s (Right hm, p) = validHigherOrder s p ns $ Right (hm, HS.empty)+ mr1_pairs = zip mr1 hist1+ mr1_pairs' = filter (vh s1') mr1_pairs+ mr1_pair = find (isRight . fst) mr1_pairs'+ mr2_pairs = zip mr2 hist2+ mr2_pairs' = filter (vh s2') mr2_pairs+ mr2_pair = find (isRight . fst) mr2_pairs'+ case (isSWHNF s1', isSWHNF s2', mr2_pair) of+ (True, False, Just (Right hm, p2)) -> do+ W.tell [Marker (sh1, sh2) $ CycleFound $ CycleMarker (s1, s2) p2 hm IRight]+ return $ Failure True+ _ -> case (isSWHNF s1', isSWHNF s2', mr1_pair) of+ (False, True, Just (Right hm, p1)) -> do+ W.tell [Marker (sh1, sh2) $ CycleFound $ CycleMarker (s1, s2) p1 hm ILeft]+ return $ Failure True+ _ -> return $ NoProof []++-- This function helps us to avoid certain spurious counterexamples when+-- dealing with symbolic functions. Specifically, it detects apparent+-- counterexamples that are invalid because they map expressions with+-- differently-concretized symbolic function mappings to each other.+validHigherOrder :: StateET ->+ StateET ->+ HS.HashSet Name ->+ Either [Lemma] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) ->+ Bool+validHigherOrder s1 s2 ns hm_hs | Right (hm, _) <- hm_hs =+ let -- empty these to avoid an infinite loop+ s1' = s1 { track = (track s1) { higher_order = HM.empty } }+ s2' = s2 { track = (track s2) { higher_order = HM.empty } }+ -- if the Id isn't present, the mapping isn't relevant+ mappings1 = HM.toList $ higher_order $ track s1+ mappings2 = HM.toList $ higher_order $ track s2+ old_pairs = filter (\(_, i) -> (E.member (idName i) (expr_env s1)) || (E.member (idName i) (opp_env $ track s1))) mappings1+ new_pairs = filter (\(_, i) -> (E.member (idName i) (expr_env s2)) || (E.member (idName i) (opp_env $ track s2))) mappings2+ old_states = map (\(e, i) -> (s1' { curr_expr = CurrExpr Evaluate e },+ s1' { curr_expr = CurrExpr Evaluate (Var i) })) old_pairs+ new_states = map (\(e, i) -> (s2' { curr_expr = CurrExpr Evaluate e },+ s2' { curr_expr = CurrExpr Evaluate (Var i) })) new_pairs+ zipped = [(p, q) | p <- old_states, q <- new_states]+ -- only current expressions change between all these states+ -- I can keep the other-side expr envs the same+ check ((p1, p2), (q1, q2)) =+ case restrictHelper p1 q1 ns hm_hs of+ Right (hm', hs') -> if HM.size hm' == HM.size hm+ then restrictHelper p2 q2 ns (Right (hm', hs'))+ else Right (hm', hs')+ _ -> hm_hs+ in all isRight $ map check zipped+ | otherwise = False
+ src/G2/Equiv/Types.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}++module G2.Equiv.Types ( module G2.Equiv.Config+ , module G2.Equiv.Types+ , module G2.Equiv.G2Calls) where++import G2.Equiv.Config+import G2.Equiv.G2Calls+import G2.Language++import GHC.Generics (Generic)+import Data.Data (Typeable)+import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HS+import qualified Data.Sequence as DS+++-- States++data StateH = StateH {+ latest :: StateET+ , history :: [StateET]+ , discharge :: Maybe StateET+ }+ deriving (Eq, Generic)++instance Named StateH where+ names (StateH s h d) =+ names s DS.>< names h DS.>< names d+ rename old new (StateH s h d) =+ StateH (rename old new s) (rename old new h) (rename old new d)++newStateH :: StateET -> StateH+newStateH s = StateH {+ latest = s+ , history = []+ , discharge = Nothing+ }++-- The container field is only relevant for induction. When the expression for+-- one past state is actually an inner scrutinee of an expression that really+-- was encountered in the past, the container holds the full expression.+data PrevMatch t = PrevMatch {+ present :: (State t, State t)+ , past :: (State t, State t)+ , conditions :: (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+ , container :: State t+}++data ActMarker = Coinduction CoMarker+ | Equality EqualMarker+ | NoObligations (StateET, StateET)+ | NotEquivalent (StateET, StateET)+ | SolverFail (StateET, StateET)+ | CycleFound CycleMarker+ | Unresolved (StateET, StateET)++instance Named ActMarker where+ names (Coinduction cm) = names cm+ names (Equality em) = names em+ names (NoObligations s_pair) = names s_pair+ names (NotEquivalent s_pair) = names s_pair+ names (SolverFail s_pair) = names s_pair+ names (CycleFound cm) = names cm+ names (Unresolved s_pair) = names s_pair+ rename old new m = case m of+ Coinduction cm -> Coinduction $ rename old new cm+ Equality em -> Equality $ rename old new em+ NoObligations s_pair -> NoObligations $ rename old new s_pair+ NotEquivalent s_pair -> NotEquivalent $ rename old new s_pair+ SolverFail s_pair -> SolverFail $ rename old new s_pair+ CycleFound cm -> CycleFound $ rename old new cm+ Unresolved s_pair -> Unresolved $ rename old new s_pair++data LemmaMarker = LemmaProposed Lemma+ | LemmaProven Lemma+ | LemmaRejected Lemma+ | LemmaProvenEarly (Lemma, Lemma)+ | LemmaRejectedEarly (Lemma, Lemma)+ | LemmaUnresolved Lemma++instance Named LemmaMarker where+ names (LemmaProposed l) = names l+ names (LemmaProven l) = names l+ names (LemmaRejected l) = names l+ names (LemmaProvenEarly l_pair) = names l_pair+ names (LemmaRejectedEarly l_pair) = names l_pair+ names (LemmaUnresolved l) = names l+ rename old new lm = case lm of+ LemmaProposed l -> LemmaProposed $ rename old new l+ LemmaProven l -> LemmaProven $ rename old new l+ LemmaRejected l -> LemmaRejected $ rename old new l+ LemmaProvenEarly lp -> LemmaProvenEarly $ rename old new lp+ LemmaRejectedEarly lp -> LemmaRejectedEarly $ rename old new lp+ LemmaUnresolved l -> LemmaUnresolved $ rename old new l++data Marker = Marker (StateH, StateH) ActMarker+ | LMarker LemmaMarker++instance Named Marker where+ names (Marker (sh1, sh2) m) =+ names sh1 DS.>< names sh2 DS.>< names m+ names (LMarker lm) = names lm+ rename old new (Marker (sh1, sh2) m) =+ Marker (rename old new sh1, rename old new sh2) $ rename old new m+ rename old new (LMarker lm) =+ LMarker $ rename old new lm++data Side = ILeft | IRight deriving (Eq, Show, Typeable, Generic)++data IndMarker = IndMarker {+ ind_real_present :: (StateET, StateET)+ , ind_used_present :: (StateET, StateET)+ , ind_past :: (StateET, StateET)+ , ind_result :: (StateET, StateET)+ , ind_present_scrutinees :: (Expr, Expr)+ , ind_past_scrutinees :: (StateET, StateET)+ , ind_side :: Side+ , ind_fresh_name :: Name+ }+ deriving (Eq, Generic)++-- states paired with lemmas show what the state was before lemma usage+data CoMarker = CoMarker {+ co_real_present :: (StateET, StateET)+ , co_used_present :: (StateET, StateET)+ , co_past :: (StateET, StateET)+ , lemma_used_left :: [(StateET, Lemma)]+ , lemma_used_right :: [(StateET, Lemma)]+}++instance Named CoMarker where+ names (CoMarker (s1, s2) (q1, q2) (p1, p2) lemma_l lemma_r) =+ (DS.><) (names [s1, s2, q1, q2, p1, p2]) ((names lemma_l) DS.>< (names lemma_r))+ rename old new (CoMarker (s1, s2) (q1, q2) (p1, p2) lemma_l lemma_r) =+ let r = rename old new+ s1' = r s1+ s2' = r s2+ q1' = r q1+ q2' = r q2+ p1' = r p1+ p2' = r p2+ lemma_l' = rename old new lemma_l+ lemma_r' = rename old new lemma_r+ in CoMarker (s1', s2') (q1', q2') (p1', p2') lemma_l' lemma_r'++reverseCoMarker :: CoMarker -> CoMarker+reverseCoMarker (CoMarker (s1, s2) (q1, q2) (p1, p2) lemma_l lemma_r) =+ CoMarker (s2, s1) (q2, q1) (p2, p1) lemma_r lemma_l++data EqualMarker = EqualMarker {+ eq_real_present :: (StateET, StateET)+ , eq_used_present :: (StateET, StateET)+}++instance Named EqualMarker where+ names (EqualMarker (s1, s2) (q1, q2)) =+ foldr (DS.><) DS.empty $ map names [s1, s2, q1, q2]+ rename old new (EqualMarker (s1, s2) (q1, q2)) =+ let r = rename old new+ s1' = r s1+ s2' = r s2+ q1' = r q1+ q2' = r q2+ in EqualMarker (s1', s2') (q1', q2')++-- the indicated side is the one with the cycle+-- cycle_past is the past state that matches the present+data CycleMarker = CycleMarker {+ cycle_real_present :: (StateET, StateET)+ , cycle_past :: StateET+ , cycle_mapping :: HM.HashMap Id Expr+ , cycle_side :: Side+}++instance Named CycleMarker where+ names (CycleMarker (s1, s2) p _ _) =+ names s1 DS.>< names s2 DS.>< names p+ rename old new (CycleMarker (s1, s2) p hm sd) =+ let r = rename old new+ s1' = r s1+ s2' = r s2+ p' = r p+ in CycleMarker (s1', s2') p' hm sd++data Lemma = Lemma { lemma_name :: String+ , lemma_lhs :: StateET+ , lemma_rhs :: StateET+ , lemma_lhs_origin :: String+ , lemma_rhs_origin :: String+ , lemma_to_be_proven :: [(StateH, StateH)] }+ deriving (Eq, Generic)++instance Named Lemma where+ names (Lemma _ s1 s2 _ _ sh) = names s1 DS.>< names s2 DS.>< names sh+ rename old new (Lemma lnm s1 s2 f1 f2 sh) =+ Lemma lnm (rename old new s1) (rename old new s2) f1 f2 (rename old new sh)++type ProposedLemma = Lemma+type ProvenLemma = Lemma+type DisprovenLemma = Lemma
+ src/G2/Equiv/Uninterpreted.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+++module G2.Equiv.Uninterpreted where ++import G2.Language+import qualified G2.Language.ExprEnv as E+import Data.Foldable+import Data.Maybe +import qualified Data.Monoid as DM+import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HS+import Debug.Trace+import qualified Data.Text as T++-- | Find variables that don't have binding and adjust the epxression environment to treat them as symbolic +addFreeVarsAsSymbolic :: ExprEnv -> ExprEnv +addFreeVarsAsSymbolic eenv = let xs = freeVars eenv eenv + in foldl' (flip E.insertSymbolic) eenv xs ++-- | changing the signature of addFreeTypes so that we have +-- we want to modify the rewrite-rules passed in checkrule +-- (AstContainer c Expr, Astcontainer c Type, AstContainer t Expr, Astcontainer t Type) => c -> State t -> NameGen -> (c, State t, NameGen)+-- | apply subvars to the rule +addFreeTypes :: (ASTContainer c Expr, ASTContainer c Type, ASTContainer t Expr, ASTContainer t Type) => c -> State t -> NameGen -> (c, State t, NameGen) +addFreeTypes c s@(State {type_env = tenv }) ng =+ let + (tenv', ng') = freeTypesToTypeEnv (freeTypes tenv s) ng+ tenv'' = HM.union tenv tenv'+ free_dc = HS.toList $ freeDC tenv'' s+ m = dataConMapping free_dc+ s' = subVars m s+ c' = subVars m c+ n_te = addDataCons tenv'' free_dc+ in (c', s' { type_env = n_te }, ng' )+ -- trace ("show map " ++ show m) (s' { type_env = n_te }, ng') +++allDC :: ASTContainer t Expr => t -> HS.HashSet DataCon+allDC = evalASTs allDC' ++allDC' :: Expr -> HS.HashSet DataCon+allDC' e = case e of + Data dc -> HS.singleton dc+ Case _ _ _ as ->+ HS.fromList $ mapMaybe (\(Alt am _) -> case am of + DataAlt dc _ -> Just dc+ _ -> Nothing) as + _ -> HS.empty++++freeDC :: ASTContainer e Expr => TypeEnv -> e -> HS.HashSet DataCon+freeDC typeEnv e =+ let al = allDC e+ inTEnv = HS.map (\(DataCon n _) -> n)+ . HS.fromList+ . concatMap dataCon+ . HM.elems $ typeEnv in+ HS.filter (\(DataCon n _) -> not (HS.member n inTEnv)) al+++allTypes :: ASTContainer t Type => t -> [(Name, Kind)]+allTypes = evalASTs allTypes' ++allTypes' :: Type -> [(Name, Kind)]+allTypes' t = case t of + TyCon n k -> [(n,k)]+ _ -> []+++freeTypes :: ASTContainer t Type => TypeEnv -> t -> [(Name, Kind)]+freeTypes typeEnv t = HM.toList $ HM.difference (HM.fromList $ allTypes t) typeEnv +++-- | we getting "free" typesnames and insert it into the TypeEnv with a "uninterprted " dataCons +-- Uninterpreted means there are potentially unlimited amount of datacons for a free type+freeTypesToTypeEnv :: [(Name,Kind)] -> NameGen -> (TypeEnv, NameGen)+freeTypesToTypeEnv nks ng = + let (adts, ng') = mapNG freeTypesToTypeEnv' nks ng + in (HM.fromList adts, ng') ++freeTypesToTypeEnv' :: (Name, Kind) -> NameGen -> ( (Name, AlgDataTy), NameGen)+freeTypesToTypeEnv' (n,k) ng =+ let (bids, ng') = freshIds (argumentTypes $ PresType k) ng + (dcs,ng'') = unknownDC ng' n k bids+ n_adt = (n, DataTyCon {bound_ids = bids,+ data_cons = [dcs]})+ in (n_adt, ng'')++unknownDC :: NameGen -> Name -> Kind -> [Id] -> (DataCon, NameGen)+unknownDC ng n@(Name occn _ _ _) k is =+ let tc = TyCon n k + tv = map TyVar is+ ta = foldl' TyApp tc tv + ti = TyLitInt `TyFun` ta + tfa = foldl' (flip TyForAll) ti is+ (dc_n, ng') = freshSeededString ("Unknown" DM.<> occn) ng + in (DataCon dc_n tfa, ng')++-- | add free Datacons into the TypeEnv at the appriorpate Type)+addDataCons :: TypeEnv -> [DataCon] -> TypeEnv+addDataCons = foldl' addDataCon++addDataCon :: TypeEnv -> DataCon -> TypeEnv+addDataCon te dc | (TyCon n _):_ <- unTyApp $ returnType dc = + let dtc = HM.lookup n te+ adt = case dtc of + Just (DataTyCon ids' dcs) -> DataTyCon {bound_ids = ids', data_cons = dc : dcs}+ Nothing -> error "addDataCons: cannot find corresponding Name in TypeEnv"+ Just _ -> error "addDataCons: Not DataTyCon AlgDataTy found"+ in HM.insert n adt te +addDataCon _ _ = error "addDataCon: Type of DataCon had incorrect form"++-- | addMapping will handle classification between the DataCon and Type+addMapping :: [DataCon] -> ExprEnv -> ExprEnv +addMapping dcs ee = foldl' addMapping' ee dcs++addMapping' :: ExprEnv -> DataCon -> ExprEnv +addMapping' ee dc@(DataCon name _) = E.insert name (Data dc) ee+++-- | The translation between GHC and g2 didn't have a matching id for the same occurence name+-- so we are using brute force by matching the same occurence name ++dataConMapping :: [DataCon] -> HM.HashMap (T.Text, Maybe T.Text) DataCon+dataConMapping dcs = HM.fromList $ map dataConMapping' dcs ++dataConMapping' :: DataCon -> ((T.Text, Maybe T.Text ), DataCon)+dataConMapping' dc@(DataCon (Name t mt _ _ ) _ ) = ((t,mt), dc)++subVars :: ASTContainer t Expr => HM.HashMap (T.Text, Maybe T.Text) DataCon -> t -> t+subVars m = modifyASTs (subVars' m) ++subVars' :: HM.HashMap (T.Text, Maybe T.Text) DataCon -> Expr -> Expr+subVars' m expr@(Var (Id (Name t mt _ _) _ )) = case HM.lookup (t,mt) m of + Just (DataCon n' k) -> Data (DataCon n' k)+ Nothing -> expr +subVars' _ expr = expr
+ src/G2/Equiv/Verifier.hs view
@@ -0,0 +1,816 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module G2.Equiv.Verifier+ ( verifyLoop+ , checkRule+ ) where++import G2.Language++import G2.Config++import G2.Interface++import qualified Control.Monad.State.Lazy as CM+++import qualified G2.Language.ExprEnv as E+import qualified G2.Language.CallGraph as G+import qualified G2.Language.Typing as T++import Data.Maybe+import Data.List+import qualified Data.Text as DT+import qualified Data.Text.IO as DT++import qualified Data.HashSet as HS+import qualified G2.Solver as S++import qualified G2.Language.PathConds as P++import G2.Equiv.InitRewrite+import G2.Equiv.EquivADT+import G2.Equiv.G2Calls+import G2.Equiv.Tactics+import G2.Equiv.Generalize+import G2.Equiv.Summary+import G2.Equiv.Uninterpreted ++import qualified Data.Map as M+import G2.Execution.Memory+import Data.Monoid (Any (..))++import qualified G2.Language.Stack as Stck+import Control.Monad++import G2.Lib.Printers++-- reader / writer monad source consulted+-- https://mmhaskell.com/monads/reader-writer++import qualified Control.Monad.Writer.Lazy as W++import System.IO++statePairReadyForSolver :: (State t, State t) -> Bool+statePairReadyForSolver (s1, s2) =+ let h1 = expr_env s1+ h2 = expr_env s2+ CurrExpr _ e1 = curr_expr s1+ CurrExpr _ e2 = curr_expr s2+ in+ exprReadyForSolver h1 e1 && exprReadyForSolver h2 e2++exprReadyForSolver :: ExprEnv -> Expr -> Bool+exprReadyForSolver h (Tick _ e) = exprReadyForSolver h e+exprReadyForSolver h (Var i) = E.isSymbolic (idName i) h && T.isPrimType (typeOf i)+exprReadyForSolver h (App f a) = exprReadyForSolver h f && exprReadyForSolver h a+exprReadyForSolver _ (Prim _ _) = True+exprReadyForSolver _ (Lit _) = True+exprReadyForSolver _ _ = False++-- don't log when the base folder name is empty+logStatesFolder :: String -> LogMode -> LogMode+logStatesFolder pre (Log method n) = Log method $ n ++ "/" ++ pre+logStatesFolder _ NoLog = NoLog++logStatesET :: String -> LogMode -> String+logStatesET pre (Log _ n) = n ++ "/" ++ pre+logStatesET pre NoLog = "/" ++ pre++runSymExec :: S.Solver solver =>+ solver ->+ Config ->+ NebulaConfig ->+ HS.HashSet Name ->+ StateET ->+ StateET ->+ CM.StateT (Bindings, Int) IO [(StateET, StateET)]+runSymExec solver config nc@(NC { sync = sy }) ns s1 s2 = do+ (bindings, k) <- CM.get+ let config' = config { logStates = logStatesFolder ("a" ++ show k) (log_states nc) }+ t1 = (track s1) { folder_name = logStatesET ("a" ++ show k) (log_states nc) }+ CurrExpr r1 e1 = curr_expr s1+ e1' = addStackTickIfNeeded ns (expr_env s1) e1+ s1' = s1 { track = t1, curr_expr = CurrExpr r1 e1' }+ --CM.liftIO $ putStrLn $ (folder_name $ track s1) ++ " becomes " ++ (folder_name t1)+ (er1, bindings') <- CM.lift $ runG2ForNebula solver s1' (expr_env s2) (track s2) config' nc bindings+ CM.put (bindings', k + 1)+ let final_s1 = map final_state er1+ pairs <- mapM (\s1_ -> do+ (b_, k_) <- CM.get+ let s2_ = transferInfo sy s1_ (snd $ syncSymbolic s1_ s2)+ let config'' = config { logStates = logStatesFolder ("b" ++ show k_) (log_states nc) }+ t2 = (track s2_) { folder_name = logStatesET ("b" ++ show k_) (log_states nc) }+ CurrExpr r2 e2 = curr_expr s2_+ e2' = addStackTickIfNeeded ns (expr_env s2) e2+ s2' = s2_ { track = t2, curr_expr = CurrExpr r2 e2' }+ --CM.liftIO $ putStrLn $ (folder_name $ track s2_) ++ " becomes " ++ (folder_name t2)+ (er2, b_') <- CM.lift $ runG2ForNebula solver s2' (expr_env s1_) (track s1_) config'' nc b_+ CM.put (b_', k_ + 1)+ return $ map (\er2_ -> + let+ s2_' = final_state er2_+ s1_' = transferInfo sy s2_' (snd $ syncSymbolic s2_' s1_)+ in+ (addStamps k $ prepareState s1_', addStamps k_ $ prepareState s2_')+ ) er2) final_s1+ CM.liftIO $ filterM (pathCondsConsistent solver) (concat pairs)++pathCondsConsistent :: S.Solver solver =>+ solver ->+ (StateET, StateET) ->+ IO Bool+pathCondsConsistent solver (s1, s2) = do+ res <- applySolver solver P.empty s1 s2+ case res of+ S.UNSAT () -> return False+ _ -> return True++-- info goes from left to right for expression environment too+transferInfo :: Bool -> StateET -> StateET -> StateET+transferInfo True s1 s2 =+ transferTrackerInfo s1 (s2 { expr_env = expr_env s1 })+transferInfo False s1 s2 = transferTrackerInfo s1 s2++-- Don't share expr env and path constraints between sides+-- info goes from left to right+transferTrackerInfo :: StateET -> StateET -> StateET+transferTrackerInfo s1 s2 =+ let t1 = track s1+ t2 = track s2+ t2' = t2 {+ higher_order = higher_order t1+ , total_vars = total_vars t1+ --, opp_env = expr_env s1+ }+ in s2 { track = t2' }++frameWrap :: Frame -> Expr -> Expr+frameWrap (CaseFrame i t alts) e = Case e i t alts+frameWrap (ApplyFrame e') e = App e e'+frameWrap (UpdateFrame _) e = e+frameWrap (CastFrame co) e = Cast e co+frameWrap _ _ = error "unsupported frame"++stackWrap :: Stck.Stack Frame -> Expr -> Expr+stackWrap sk e =+ case Stck.pop sk of+ Nothing -> e+ Just (fr, sk') -> stackWrap sk' $ frameWrap fr e++loc_name :: Name+loc_name = Name (DT.pack "STACK") Nothing 0 Nothing++rec_name :: Name+rec_name = Name (DT.pack "REC") Nothing 0 Nothing++wrapRecursiveCall :: Name -> Expr -> Expr+-- This first case prevents recursive calls from being wrapped twice+wrapRecursiveCall n e@(Tick (NamedLoc n'@(Name t _ _ _)) e') =+ if t == DT.pack "REC"+ then e+ else Tick (NamedLoc n') $ wrapRecursiveCall n e'+wrapRecursiveCall n e@(Var (Id n' _)) =+ if n == n'+ then Tick (NamedLoc rec_name) e+ else wrcHelper n e+wrapRecursiveCall n e = wrcHelper n e++wrcHelper :: Name -> Expr -> Expr+wrcHelper n e = case e of+ Tick (NamedLoc (Name t _ _ _)) _ | t == DT.pack "REC" -> e+ _ -> modifyChildren (wrapRecursiveCall n) e++-- Creating a new expression environment lets us use the existing reachability+-- functions.+-- look inside the bindings and inside the body for recursion+wrapLetRec :: ExprEnv -> Expr -> Expr+wrapLetRec h (Let binds e) =+ let binds1 = map (\(i, e_) -> (idName i, e_)) binds+ fresh_name = Name (DT.pack "FRESH") Nothing 0 Nothing+ h' = foldr (\(n_, e_) h_ -> E.insert n_ e_ h_) h ((fresh_name, e):binds1)+ wrap_cg = wrapAllRecursion (G.getCallGraph h') h'+ binds2 = map (\(n_, e_) -> (n_, wrap_cg n_ e_)) binds1+ e' = foldr (wrapIfCorecursive (G.getCallGraph h') h' fresh_name) e (map fst binds1)+ e'' = wrapLetRec h' $ modifyChildren (wrapLetRec h') e'+ binds3 = map ((wrapLetRec h') . modifyChildren (wrapLetRec h')) (map snd binds2)+ binds4 = zip (map fst binds) binds3+ in+ -- REC tick getting inserted in binds but not in body+ -- it's only needed where the recursion actually happens+ -- need to apply wrap_cg over it with the new names?+ -- wrap_cg with fresh_name won't help because nothing can reach fresh_name+ Let binds4 e''+wrapLetRec h e = modifyChildren (wrapLetRec h) e++-- first Name is the one that maps to the Expr in the environment+-- second Name is the one that might be wrapped+-- do not allow wrapping for symbolic variables+-- modifyChildren can't see a REC tick that was just inserted above it+wrapIfCorecursive :: G.CallGraph -> ExprEnv -> Name -> Name -> Expr -> Expr+wrapIfCorecursive cg h n m e =+ let n_list = G.reachable n cg+ m_list = G.reachable m cg+ in+ if (n `elem` m_list) && (m `elem` n_list)+ then+ if E.isSymbolic m h+ then e+ else wrcHelper m (wrapRecursiveCall m e)+ else e++-- the call graph must be based on the given environment+-- the Name must map to the Expr in the environment+wrapAllRecursion :: G.CallGraph -> ExprEnv -> Name -> Expr -> Expr+wrapAllRecursion cg h n e =+ let n_list = G.reachable n cg+ in+ if (not $ E.isSymbolic n h) && (n `elem` n_list)+ then foldr (wrapIfCorecursive cg h n) e n_list+ else e++-- stack tick not added here anymore+prepareState :: StateET -> StateET+prepareState s =+ let e = getExpr s+ in s {+ curr_expr = CurrExpr Evaluate $ stackWrap (exec_stack s) $ e+ , num_steps = 0+ , rules = []+ , exec_stack = Stck.empty+ }++-- "stamps" for Case statements enforce induction validity+stampName :: Int -> Int -> Name+stampName x k =+ Name (DT.pack $ (show x) ++ "STAMP:" ++ (show k)) Nothing 0 Nothing++-- leave existing stamp ticks unaffected; don't cover them with more layers+-- only stamp strings should contain a colon+insertStamps :: Int -> Int -> Expr -> Expr+insertStamps x k (Tick nl e) = Tick nl (insertStamps x k e)+insertStamps x k (Case e i t a) =+ case a of+ (Alt am1 a1):as -> case a1 of+ Tick (NamedLoc (Name n _ _ _)) _ | str <- DT.unpack n+ , ':' `elem` str ->+ Case (insertStamps (x + 1) k e) i t a+ _ -> let sn = stampName x k+ a1' = Alt am1 (Tick (NamedLoc sn) a1)+ in Case (insertStamps (x + 1) k e) i t (a1':as)+ _ -> error "Empty Alt List"+insertStamps _ _ e = e++addStamps :: Int -> StateET -> StateET+addStamps k s =+ let CurrExpr c e = curr_expr s+ e' = insertStamps 0 k e+ in s { curr_expr = CurrExpr c e' }++getLatest :: (StateH, StateH) -> (StateET, StateET)+getLatest (StateH { latest = s1 }, StateH { latest = s2 }) = (s1, s2)++type NewLemmaTactic solver = String -> String -> Tactic solver++-- discharge only has a meaningful value when execution is done for a branch+appendH :: StateH -> StateET -> StateH+appendH sh s =+ StateH {+ latest = s+ , history = (latest sh):(history sh)+ , discharge = discharge sh+ }++replaceH :: StateH -> StateET -> StateH+replaceH sh s = sh { latest = s }++allTactics :: S.Solver s => [Tactic s]+allTactics = [+ tryEquality+ , tryCoinduction+ , generalizeFull+ , trySolver+ , checkCycle+ ]++allNewLemmaTactics :: S.Solver s => [NewLemmaTactic s]+allNewLemmaTactics = map applyTacticToLabeledStates [tryEquality, tryCoinduction]++-- negative loop iteration count means there's no limit+-- The (null states) check ensures that we return UNSAT rather than+-- Unknown when states is empty and n = 0.+verifyLoop :: S.Solver solver =>+ solver ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ [(StateH, StateH)] ->+ Bindings ->+ Config ->+ NebulaConfig ->+ [Id] ->+ Int ->+ Int ->+ W.WriterT [Marker] IO (S.Result () () ())+verifyLoop solver num_lems ns lemmas states b config nc sym_ids k n | (n /= 0) || (null states) = do+ W.liftIO $ putStrLn "<Loop Iteration>"+ W.liftIO $ putStrLn $ show n+ -- this printing allows our Python script to report depth stats+ let min_max_depth = minMaxDepth ns sym_ids states+ min_sum_depth = minSumDepth ns sym_ids states+ case states of+ [] -> return ()+ _ -> do+ W.liftIO $ putStrLn $ "<<Min Max Depth>> " ++ show min_max_depth+ W.liftIO $ putStrLn $ "<<Min Sum Depth>> " ++ show min_sum_depth+ W.liftIO $ hFlush stdout+ (b', k', proven, lemmas') <- verifyLoopPropLemmas solver allTactics num_lems ns lemmas b config nc k++ -- W.liftIO $ putStrLn $ "proposed_lemmas: " ++ show (length $ proposed_lemmas lemmas')+ -- W.liftIO $ putStrLn $ "proven_lemmas: " ++ show (length $ proven_lemmas lemmas')+ -- W.liftIO $ putStrLn $ "continued_lemmas: " ++ show (length continued_lemmas)+ -- W.liftIO $ putStrLn $ "disproven_lemmas: " ++ show (length $ disproven_lemmas lemmas')++ (b'', k'', proven', lemmas'') <- verifyLemmasWithNewProvenLemmas solver allNewLemmaTactics num_lems ns proven lemmas' b' config nc k'+ (pl_sr, b''') <- verifyWithNewProvenLemmas solver allNewLemmaTactics num_lems ns proven' lemmas'' b'' states++ case pl_sr of+ CounterexampleFound -> return $ S.SAT ()+ Proven -> return $ S.UNSAT ()+ ContinueWith _ pl_lemmas -> do+ (sr, b'''', k''') <- verifyLoopWithSymEx solver allTactics num_lems ns lemmas'' b''' config nc k'' states+ case sr of+ ContinueWith new_obligations new_lemmas -> do+ let n' = if n > 0 then n - 1 else n+ --W.liftIO $ putStrLn $ show $ length new_obligations+ --W.liftIO $ putStrLn $ "length new_lemmas = " ++ show (length $ pl_lemmas ++ new_lemmas)++ final_lemmas <- foldM (flip (insertProposedLemma solver ns))+ lemmas''+ (pl_lemmas ++ new_lemmas)+ verifyLoop solver num_lems ns final_lemmas new_obligations b'''' config nc sym_ids k''' n'+ CounterexampleFound -> do+ let un l = LMarker $ LemmaUnresolved l+ un_lemmas = (proposedLemmas lemmas \\ provenLemmas lemmas) \\ disprovenLemmas lemmas+ W.tell $ map un un_lemmas+ return $ S.SAT ()+ Proven -> do+ let un l = LMarker $ LemmaUnresolved l+ un_lemmas = (proposedLemmas lemmas \\ provenLemmas lemmas) \\ disprovenLemmas lemmas+ W.tell $ map un un_lemmas+ W.liftIO $ putStrLn $ "proposed = " ++ show (length $ proposedLemmas lemmas)+ W.liftIO $ putStrLn $ "proven = " ++ show (length $ provenLemmas lemmas) + W.liftIO $ putStrLn $ "disproven = " ++ show (length $ disprovenLemmas lemmas) + return $ S.UNSAT ()+ | otherwise = do+ W.liftIO $ putStrLn $ "proposed = " ++ show (length $ proposedLemmas lemmas)+ W.liftIO $ putStrLn $ "proven = " ++ show (length $ provenLemmas lemmas) + W.liftIO $ putStrLn $ "disproven = " ++ show (length $ disprovenLemmas lemmas)+ W.liftIO $ putStrLn $ "Unresolved Obligations: " ++ show (length states)+ let ob (sh1, sh2) = Marker (sh1, sh2) $ Unresolved (latest sh1, latest sh2)+ un l = LMarker $ LemmaUnresolved l+ un_lemmas = (proposedLemmas lemmas \\ provenLemmas lemmas) \\ disprovenLemmas lemmas+ W.tell $ map ob states+ W.tell $ map un un_lemmas+ return $ S.Unknown "Loop Iterations Exhausted" ()++data StepRes = CounterexampleFound+ | ContinueWith [(StateH, StateH)] [Lemma]+ | Proven++verifyLoopPropLemmas :: S.Solver solver =>+ solver+ -> [Tactic solver]+ -> Int+ -> HS.HashSet Name+ -> Lemmas+ -> Bindings+ -> Config+ -> NebulaConfig+ -> Int+ -> (W.WriterT [Marker] IO) (Bindings, Int, [ProvenLemma], Lemmas)+verifyLoopPropLemmas solver tactics num_lems ns lemmas b config nc k = do+ let prop_lemmas = proposedLemmas lemmas+ verify_lemma = verifyLoopPropLemmas' solver tactics num_lems ns lemmas config nc+ (prop_lemmas', (b', k')) <- CM.runStateT (mapM verify_lemma prop_lemmas) (b, k)++ let (proven, continued_lemmas, disproven, new_lemmas) = partitionLemmas ([], [], [], []) prop_lemmas'+ lemmas' = replaceProposedLemmas continued_lemmas lemmas+ lemmas'' <- foldM (insertProvenLemma solver ns) lemmas' proven+ lemmas''' <- foldM (insertDisprovenLemma solver ns) lemmas'' disproven++ lemmas'''' <- foldM (flip (insertProposedLemma solver ns))+ lemmas'''+ new_lemmas++ return (b', k', proven, lemmas'''')+ where+ partitionLemmas (p, c, d, n) ((CounterexampleFound, lem):xs) = partitionLemmas (p, c, lem:d, n) xs+ partitionLemmas (p, c, d, n) ((ContinueWith _ new_lem, lem):xs) = partitionLemmas (p, lem:c, d, new_lem ++ n) xs+ partitionLemmas (p, c, d, n) ((Proven, lem):xs) = partitionLemmas (lem:p, c, d, n) xs+ partitionLemmas r [] = r++verifyLoopPropLemmas' :: S.Solver solver =>+ solver+ -> [Tactic solver]+ -> Int+ -> HS.HashSet Name+ -> Lemmas+ -> Config+ -> NebulaConfig+ -> ProposedLemma+ -> CM.StateT (Bindings, Int) (W.WriterT [Marker] IO) (StepRes, Lemma)+verifyLoopPropLemmas' solver tactics num_lems ns lemmas config nc+ l@(Lemma { lemma_to_be_proven = states }) = do+ (b, k) <- CM.get+ --W.liftIO $ putStrLn $ "k = " ++ show k+ --W.liftIO $ putStrLn $ lemma_name l+ (sr, b', k') <- W.lift (verifyLoopWithSymEx solver tactics num_lems ns lemmas b config nc k states)+ CM.put (b', k')+ lem <- case sr of+ CounterexampleFound -> {-trace "COUNTEREXAMPLE verifyLemma"-} return $ l { lemma_to_be_proven = [] }+ ContinueWith states' _ -> return $ l { lemma_to_be_proven = states' }+ Proven -> return $ l { lemma_to_be_proven = [] }+ return (sr, lem)++verifyLoopWithSymEx :: S.Solver solver =>+ solver+ -> [Tactic solver]+ -> Int+ -> HS.HashSet Name+ -> Lemmas+ -> Bindings+ -> Config+ -> NebulaConfig+ -> Int+ -> [(StateH, StateH)]+ -> W.WriterT [Marker] IO (StepRes, Bindings, Int)+verifyLoopWithSymEx solver tactics num_lems ns lemmas b config nc k states = do+ let current_states = map getLatest states+ (paired_states, (b', k')) <- W.liftIO $ CM.runStateT (mapM (uncurry (runSymExec solver config nc ns)) current_states) (b, k)++ --W.liftIO $ putStrLn "verifyLoopWithSymEx"+ -- for every internal list, map with its corresponding original state+ let app_pair (sh1, sh2) (s1, s2) = (appendH sh1 s1, appendH sh2 s2)+ updated_hists = map (\(s, ps) -> map (app_pair s) ps) $ zip states paired_states+ --W.liftIO $ putStrLn $ show $ length $ concat updated_hists++ (res, b'') <- verifyLoop' solver tactics num_lems ns lemmas b' (concat updated_hists)+ return (res, b'', k')++verifyWithNewProvenLemmas :: S.Solver solver =>+ solver+ -> [NewLemmaTactic solver]+ -> Int+ -> HS.HashSet Name+ -> [ProvenLemma]+ -> Lemmas+ -> Bindings+ -> [(StateH, StateH)]+ -> W.WriterT [Marker] IO (StepRes, Bindings)+verifyWithNewProvenLemmas solver nl_tactics num_lems ns proven lemmas b states = do+ let rel_states = map (\pl -> (lemma_lhs_origin pl, lemma_rhs_origin pl)) proven+ tactics = concatMap (\t -> map (uncurry t) rel_states) nl_tactics+ verifyLoop' solver tactics num_lems ns lemmas b states++verifyLemmasWithNewProvenLemmas :: S.Solver solver =>+ solver+ -> [NewLemmaTactic solver]+ -> Int+ -> HS.HashSet Name+ -> [ProvenLemma]+ -> Lemmas+ -> Bindings+ -> Config+ -> NebulaConfig+ -> Int+ -> W.WriterT [Marker] IO (Bindings, Int, [ProvenLemma], Lemmas)+verifyLemmasWithNewProvenLemmas solver nl_tactics num_lems ns proven lemmas b config nc k = do+ let rel_states = map (\pl -> (lemma_lhs_origin pl, lemma_rhs_origin pl)) proven+ tactics = concatMap (\t -> map (uncurry t) rel_states) nl_tactics++ --W.liftIO $ putStrLn "verifyLemmasWithNewProvenLemmas"+ (b', k', new_proven, lemmas') <-+ verifyLoopPropLemmas solver tactics num_lems ns lemmas b config nc k+ case null new_proven of+ True -> return (b', k', proven, lemmas')+ False ->+ let+ proven' = new_proven ++ proven+ in+ verifyLemmasWithNewProvenLemmas solver nl_tactics num_lems ns proven' lemmas' b' config nc k'++verifyLoop' :: S.Solver solver =>+ solver+ -> [Tactic solver]+ -> Int+ -> HS.HashSet Name+ -> Lemmas+ -> Bindings+ -> [(StateH, StateH)]+ -> W.WriterT [Marker] IO (StepRes, Bindings)+verifyLoop' solver tactics num_lems ns lemmas b states = do+ --W.liftIO $ putStrLn "verifyLoop'"+ let (fn1, ng') = freshName (name_gen b)+ (fn2, ng'') = freshName ng'+ b' = b { name_gen = ng'' }+ + td (sh1, sh2) = tryDischarge solver tactics num_lems ns lemmas [fn1, fn2] sh1 sh2++ proof_lemma_list <- mapM td states++ let new_obligations = concatMap fst $ catMaybes proof_lemma_list+ new_lemmas = concatMap snd $ catMaybes proof_lemma_list++ let res = if | null proof_lemma_list -> Proven+ | all isJust proof_lemma_list -> ContinueWith new_obligations new_lemmas+ | otherwise -> CounterexampleFound+ return (res, b')++applyTacticToLabeledStates :: Tactic solver -> String -> String -> Tactic solver+applyTacticToLabeledStates tactic lbl1 lbl2 solver num_lems ns lemmas fresh_names (sh1, sh2) (s1, s2)+ | Just sh1' <- digInStateH lbl1 $ appendH sh1 s1 =+ tactic solver num_lems ns lemmas fresh_names (sh1', sh2) (latest sh1', latest sh2)+ | Just sh2' <- digInStateH lbl2 $ appendH sh2 s2 =+ tactic solver num_lems ns lemmas fresh_names (sh1, sh2') (latest sh1, latest sh2')+ | otherwise = return . NoProof $ []++digInStateH :: String -> StateH -> Maybe StateH+digInStateH lbl sh+ | (folder_name . track $ latest sh) == lbl = Just sh+ | Just sh' <- backtrackOne sh = digInStateH lbl sh'+ | otherwise = Nothing++updateDC :: EquivTracker -> [BlockInfo] -> EquivTracker+updateDC et ds = et { dc_path = dc_path et ++ ds }++-- It is not a problem that this function uses the type variable from only+-- the first lambda. If the two StateET inputs come from corresponding+-- points in symbolic execution, the type variables from the two lambdas+-- must align with each other.+stateWrap :: Name -> StateET -> StateET -> Obligation -> (StateET, StateET)+stateWrap fresh_name s1 s2 (Ob ds e1 e2) =+ let ds' = map (\(d, i, n) -> BlockDC d i n) ds+ in case (e1, e2) of+ (Lam _ (Id _ t) _, Lam _ _ _) ->+ let fresh_id = Id fresh_name t+ fresh_var = Var fresh_id+ s1' = s1 {+ curr_expr = CurrExpr Evaluate $ App e1 fresh_var+ , track = updateDC (track s1) $ ds' ++ [BlockLam fresh_id]+ , expr_env = E.insertSymbolic fresh_id $ expr_env s1+ }+ s2' = s2 {+ curr_expr = CurrExpr Evaluate $ App e2 fresh_var+ , track = updateDC (track s2) $ ds' ++ [BlockLam fresh_id]+ , expr_env = E.insertSymbolic fresh_id $ expr_env s2+ }+ in (s1', s2')+ _ -> ( s1 { curr_expr = CurrExpr Evaluate e1, track = updateDC (track s1) ds' }+ , s2 { curr_expr = CurrExpr Evaluate e2, track = updateDC (track s2) ds' } )++-- the Bool value for EFail is True if a cycle has been found+data TacticEnd = EFail Bool+ | EDischarge+ | EContinue [Lemma] (StateH, StateH)++getRemaining :: TacticEnd -> [(StateH, StateH)] -> [(StateH, StateH)]+getRemaining (EContinue _ sh_pair) acc = sh_pair:acc+getRemaining _ acc = acc++getLemmas :: TacticEnd -> [Lemma]+getLemmas (EContinue lemmas _) = lemmas+getLemmas _ = []++hasFail :: [TacticEnd] -> Bool+hasFail [] = False+hasFail ((EFail _):_) = True+hasFail (_:es) = hasFail es++hasSolverFail :: [TacticEnd] -> Bool+hasSolverFail [] = False+hasSolverFail ((EFail False):_) = True+hasSolverFail (_:es) = hasSolverFail es++-- covers all of the solver obligations at once+trySolver :: S.Solver s => Tactic s+trySolver solver _ _ _ _ _ (s1, s2) | statePairReadyForSolver (s1, s2) = do+ let e1 = getExpr s1+ e2 = getExpr s2+ res <- W.liftIO $ checkObligations solver s1 s2 (HS.fromList [(e1, e2)])+ case res of+ S.UNSAT () -> return Success+ _ -> return $ Failure False+trySolver _ _ _ _ _ _ _ = return $ NoProof []++-- apply all tactics sequentially in a single run+-- make StateH adjustments between each application, if necessary+-- if Success ever appears, it's done+applyTactics :: S.Solver solver =>+ solver ->+ [Tactic solver] ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ [Lemma] ->+ [Name] ->+ (StateH, StateH) ->+ (StateET, StateET) ->+ W.WriterT [Marker] IO TacticEnd+applyTactics solver (tac:tacs) num_lems ns lemmas gen_lemmas fresh_names (sh1, sh2) (s1, s2) = do+ tr <- tac solver num_lems ns lemmas fresh_names (sh1, sh2) (s1, s2)+ case tr of+ Failure b -> return $ EFail b+ NoProof new_lemmas -> applyTactics solver tacs num_lems ns lemmas (new_lemmas ++ gen_lemmas) fresh_names (sh1, sh2) (s1, s2)+ Success -> return EDischarge+applyTactics _ _ _ _ _ gen_lemmas _ (sh1, sh2) (s1, s2) =+ return $ EContinue gen_lemmas (replaceH sh1 s1, replaceH sh2 s2)++-- Nothing output means failure+-- fresh_names must have at least two elements+-- the first name is for stateWrap, the second is for the tactics+-- the only tactic left that uses fresh names is generalizeFull+-- still, there may be new tactics in the future that use fresh names+tryDischarge :: S.Solver solver =>+ solver ->+ [Tactic solver] ->+ Int ->+ HS.HashSet Name ->+ Lemmas ->+ [Name] ->+ StateH ->+ StateH ->+ W.WriterT [Marker] IO (Maybe ([(StateH, StateH)], [Lemma]))+tryDischarge solver tactics num_lems ns lemmas (fn:fresh_names) sh1 sh2 =+ let s1 = latest sh1+ s2 = latest sh2+ in case getObligations ns s1 s2 of+ Nothing -> do+ W.tell [Marker (sh1, sh2) $ NotEquivalent (s1, s2)]+ return Nothing+ Just obs -> do+ case obs of+ [] -> W.tell [Marker (sh1, sh2) $ NoObligations (s1, s2)]+ _ -> return ()+ -- just like with tactics, we only need one fresh name here+ let states = map (stateWrap fn s1 s2) obs+ res <- mapM (applyTactics solver tactics num_lems ns lemmas [] fresh_names (sh1, sh2)) states+ -- list of remaining obligations in StateH form+ let res' = foldr getRemaining [] res+ new_lemmas = concatMap getLemmas res+ if hasFail res then do+ if hasSolverFail res+ then W.tell [Marker (sh1, sh2) $ SolverFail (s1, s2)]+ else return ()+ return Nothing+ else do+ return $ Just (res', new_lemmas)+tryDischarge _ _ _ _ _ _ _ _ = error "Need more fresh names"++getObligations :: HS.HashSet Name ->+ State t ->+ State t ->+ Maybe [Obligation]+getObligations ns s1 s2 =+ case proofObligations ns s1 s2 (getExpr s1) (getExpr s2) of+ Nothing -> Nothing+ Just obs -> Just $ HS.toList obs++addStackTickIfNeeded :: HS.HashSet Name -> ExprEnv -> Expr -> Expr+addStackTickIfNeeded ns h e' =+ let has_tick = getAny . evalASTs (\e -> case e of+ Tick (NamedLoc l) _+ | l == loc_name -> Any True+ _ -> Any False) $ e'+ in if has_tick then e' else tickWrap ns h e'++tickWrap :: HS.HashSet Name -> ExprEnv -> Expr -> Expr+tickWrap ns h (Var (Id n _))+ | not (n `HS.member` ns)+ , Just (E.Conc e) <- E.lookupConcOrSym n h = tickWrap ns h e +tickWrap ns h (Case e i t a) = Case (tickWrap ns h e) i t a+tickWrap ns h (App e1 e2) = App (tickWrap ns h e1) e2+tickWrap ns h te@(Tick nl e) | not (isLabeledError te) = Tick nl (tickWrap ns h e)+tickWrap _ _ e = Tick (NamedLoc loc_name) e++includedName :: [DT.Text] -> Name -> Bool+includedName texts (Name t _ _ _) = t `elem` texts++-- stack tick should appear inside rec tick+startingState :: EquivTracker -> HS.HashSet Name -> State t -> StateH+startingState et ns s =+ let h = expr_env s+ -- Tick wrapping for recursive and corecursive functions+ wrap_cg = wrapAllRecursion (G.getCallGraph h) h+ h' = E.map (wrapLetRec h) $ E.mapWithKey wrap_cg h+ all_names = E.keys h+ s' = s {+ track = et+ , curr_expr = CurrExpr Evaluate $ tickWrap ns h $ foldr wrap_cg (getExpr s) all_names+ , expr_env = h'+ }+ in newStateH s'++cleanState :: State t -> Bindings -> (State t, Bindings)+cleanState state bindings =+ let sym_config = addSearchNames (input_names bindings)+ $ addSearchNames (M.keys $ deepseq_walkers bindings) emptyMemConfig+ in markAndSweepPreserving sym_config state bindings++-- If the Marker list is reversed from how it was when it was fetched, then+-- we're guaranteed to get something that came from the main proof rather than+-- a lemma. Lemma examination happens first within iterations.+writeCX :: [Marker] ->+ PrettyGuide ->+ HS.HashSet Name ->+ [Id] ->+ (State t, State t) ->+ String+writeCX [] _ _ _ _ = error "No Counterexample"+writeCX ((Marker hist m):ms) pg ns sym_ids init_pair = case m of+ NotEquivalent s_pair -> showCX pg ns sym_ids hist init_pair s_pair+ SolverFail s_pair -> showCX pg ns sym_ids hist init_pair s_pair+ CycleFound cm -> showCycle pg ns sym_ids hist init_pair cm+ _ -> writeCX ms pg ns sym_ids init_pair+writeCX (_:ms) pg ns sym_ids init_pair =+ writeCX ms pg ns sym_ids init_pair++-- This function relies on the assumption that, if symbolic execution for+-- the main expression pair hits a counterexample, that counterexample+-- will be the final counterexample in the Marker list (alternatively, the+-- first counterexample in the reversed list that this takes as input).+-- Lemma counterexamples appear in the same list and are not distinguished+-- in any special way, but, in each loop iteration, lemma execution happens+-- before execution on the main expression pair. If the main execution+-- hits a counterexample, the iteration when it happens will be the final+-- loop iteration, so we have an indirect guarantee that the counterexample+-- covered here will not be one from a lemma.+reducedGuide :: [Marker] -> PrettyGuide+reducedGuide [] = error "No Counterexample"+reducedGuide ((Marker _ m):ms) = case m of+ NotEquivalent _ -> mkPrettyGuide m+ SolverFail _ -> mkPrettyGuide m+ CycleFound _ -> mkPrettyGuide m+ _ -> reducedGuide ms+reducedGuide (_:ms) = reducedGuide ms++checkRule :: (ASTContainer t Type, ASTContainer t Expr) => Config+ -> NebulaConfig+ -> State t+ -> Bindings+ -> [DT.Text] -- ^ names of forall'd variables required to be total+ -> RewriteRule+ -> IO (S.Result () () ())+checkRule config nc init_state bindings total rule = do+ let (rule' ,mod_state@(State { expr_env = ee }), te_ng) = addFreeTypes rule init_state (name_gen bindings)+ (mod_state', ng') = if symbolic_unmapped nc + then + ( mod_state { expr_env = addFreeVarsAsSymbolic ee }+ , te_ng)+ else (init_state, name_gen bindings)+ (rewrite_state_l, bindings') = initWithLHS mod_state' (bindings { name_gen = ng' }) $ rule'+ (rewrite_state_r, bindings'') = initWithRHS mod_state' bindings' $ rule'+ sym_ids = ru_bndrs rule' + total_names = filter (includedName total) (map idName sym_ids)+ total_hs = foldr HS.insert HS.empty total_names+ EquivTracker et m _ _ _ _ = emptyEquivTracker+ start_equiv_tracker = EquivTracker et m total_hs [] E.empty ""+ -- the keys are the same between the old and new environments+ ns_l = HS.fromList $ E.keys $ expr_env rewrite_state_l+ ns_r = HS.fromList $ E.keys $ expr_env rewrite_state_r+ -- no need for two separate name sets+ ns = HS.filter (\n -> not (E.isSymbolic n $ expr_env rewrite_state_l)) $ HS.union ns_l ns_r+ e_l = getExpr rewrite_state_l+ (rewrite_state_l',_) = cleanState (rewrite_state_l { curr_expr = CurrExpr Evaluate e_l }) bindings+ e_r = getExpr rewrite_state_r+ (rewrite_state_r',_) = cleanState (rewrite_state_r { curr_expr = CurrExpr Evaluate e_r }) bindings+ + rewrite_state_l'' = startingState start_equiv_tracker ns rewrite_state_l'+ rewrite_state_r'' = startingState start_equiv_tracker ns rewrite_state_r'+ + S.SomeSolver solver <- initSolver config+ putStrLn $ "***\n" ++ (show $ ru_name rule) ++ "\n***"+ (res, w) <- W.runWriterT $ verifyLoop solver (num_lemmas nc) ns+ emptyLemmas+ [(rewrite_state_l'', rewrite_state_r'')]+ bindings'' config nc sym_ids 0 (limit nc)+ let pg = if have_summary $ print_summary nc+ then mkPrettyGuide w+ else reducedGuide (reverse w)+ if have_summary $ print_summary nc then do+ putStrLn "--- SUMMARY ---"+ _ <- mapM (putStrLn . (summarize (print_summary nc) pg ns sym_ids)) w+ putStrLn "--- END OF SUMMARY ---"+ else return ()+ case res of+ S.SAT () -> do+ putStrLn "--------------------"+ putStrLn "COUNTEREXAMPLE FOUND"+ putStrLn "--------------------"+ putStrLn $ writeCX (reverse w) pg ns sym_ids (rewrite_state_l, rewrite_state_r)+ _ -> return ()+ S.close solver+ return res
+ src/G2/Execution/HPC.hs view
@@ -0,0 +1,148 @@+{-# Language FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,+ MultiParamTypeClasses, StandaloneDeriving #-}++-- | Provides infrastructure to track which HPC ticks have been encountered during symbolic execution.+module G2.Execution.HPC ( HpcT+ , HpcM+ , HpcTracker+ , LengthNTrack+ + , hpcTracker+ , hpcReducer+ + , lnt+ , lengthNSubpathOrderer) where++import G2.Execution.Reducer+import G2.Language++import Control.Monad.Identity+import Control.Monad.IO.Class+import qualified Control.Monad.State.Lazy as SM+import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HM+import Data.Maybe+import Data.Monoid+import qualified Data.Text as T+import System.IO+import System.Clock++newtype HpcT m a = HpcT (SM.StateT (HS.HashSet (Int, T.Text)) m a) deriving (Functor, Applicative, Monad)++deriving instance Monad m => (SM.MonadState (HS.HashSet (Int, T.Text)) (HpcT m))++type HpcM a = HpcT Identity a++data HpcTracker = HPC {+ hpc_ticks :: HS.HashSet (Int, T.Text) -- ^ The HPC ticks that execution has reached++ , tick_count :: Maybe Int -- ^ Total number of HPC ticks that we could reach. See [HPC Total Tick Count]+ , num_reached :: Int -- ^ Total number of HPC ticks currently reached by execution++ , initial_time :: TimeSpec -- ^ The initial creation time of the HpcTracker+ , times_reached :: [TimeSpec] -- ^ A list of times, where each time corresponds to a new tick being reached, in reverse order+ }++-- [HPC Total Tick Count]+-- We want to know (as good an approximation as possible of) how many HPC ticks our execution+-- could potentially reach. Knowing this requires the state, after memory cleaning has occurred.+--+-- Memory cleaning happens after the Reducer has been created, so we want to delay computing the+-- total tick count until execution has begun. But we don't want to repeatedly recompute+-- the total tick count, because this requires scanning the entire state. So instead,+-- we track the total tick count as a `Maybe Int`, which is `Nothing` (if we have not yet computed+-- the total tick count) or `Just i`, where `i` is the total tick count.++-- | State used by `hpcReducer`.+hpcTracker :: MonadIO m => m HpcTracker+hpcTracker = do+ ts <- liftIO $ getTime Monotonic+ return $ HPC { hpc_ticks = HS.empty, tick_count = Nothing, num_reached = 0, initial_time = ts, times_reached = [] }++hpcInsert :: MonadIO m => Int -> T.Text -> HpcTracker -> m HpcTracker+hpcInsert i t hpc@(HPC { hpc_ticks = tr, num_reached = nr, times_reached = reached, initial_time = init_ts }) =+ case HS.member (i, t) tr of+ True -> return hpc+ False -> do+ ts <- liftIO $ getTime Monotonic+ return $ hpc { hpc_ticks = HS.insert (i, t) tr, num_reached = nr + 1, times_reached = ts:reached }++totalTickCount :: SM.MonadState HpcTracker m => Maybe T.Text -> State t -> m Int+totalTickCount m s = do+ hpc@(HPC { tick_count = ttc }) <- SM.get+ case ttc of+ Just i -> return i+ Nothing -> do+ let i = getSum $ evalASTs (countHPCTicks m) (expr_env s)+ SM.put $ hpc { tick_count = Just i }+ return i++-- | A reducer that tracks and prints the number of HPC ticks encountered during execution.+hpcReducer :: (MonadIO m, SM.MonadState HpcTracker m) =>+ Maybe T.Text -- ^ A module to track tick count in+ -> Reducer m () t+hpcReducer md = (mkSimpleReducer (const ()) logTick) { afterRed = after }+ where+ logTick _ s@(State {curr_expr = CurrExpr _ (Tick (HpcTick i tm) _)}) b+ | Just tm == md = do+ hpc <- SM.get+ hpc'@(HPC { num_reached = nr }) <- hpcInsert i tm hpc+ SM.put hpc'+ hpc_tick_num <- totalTickCount md s+ liftIO $ putStr ("\r" ++ show nr ++ " / " ++ show hpc_tick_num)+ liftIO $ hFlush stdout+ return (NoProgress, [(s, ())], b)+ logTick _ s b = return (NoProgress, [(s, ())], b)++ after = do+ hpc <- SM.get+ let init_ts = initial_time hpc+ ts = times_reached hpc+ liftIO $ putStrLn $ "\nTicks reached: " ++ show (num_reached hpc)+ case ts of+ [] -> liftIO $ putStrLn $ "Last tick reached: N/A"+ (t:_) -> liftIO $ putStrLn $ "Last tick reached: " ++ showTS (t - init_ts)++showTS :: TimeSpec -> String+showTS (TimeSpec { sec = s, nsec = n }) = let str_n = show n in show s ++ "." ++ replicate (9 - length str_n) '0' ++ show n++countHPCTicks :: Maybe T.Text -> Expr -> Sum Int+countHPCTicks m (Tick (HpcTick _ m2) _) | m == Just m2 = Sum 1+countHPCTicks _ _ = 0+++-------------------------------------------------------------------------------+-- Length N Subpaths+-------------------------------------------------------------------------------++newtype LengthNTrack = LNT { unLNT :: HM.HashMap [(Int, T.Text)] Int }++-- | State used by `lengthNSubpathOrderer`.+lnt :: LengthNTrack+lnt = LNT HM.empty++-- | Orders states based on length N subpaths.+-- Each time execution switches states, the state with the least common most+-- recently explored length N subpath is chosen.+--+-- Based on the paper:+-- Steering Symbolic Execution to Less Traveled Paths+-- You Li, Zhendong Su, Linzhang Wang, Xuandong Li+lengthNSubpathOrderer :: SM.MonadState LengthNTrack m =>+ Int -- ^ N, the length of the subpaths to track+ -> Orderer m [(Int, T.Text)] Int t+lengthNSubpathOrderer n = (mkSimpleOrderer initial order update) { stepOrderer = step }+ where+ initial _ = []++ order p _ _ = do+ LNT sp <- SM.get+ return $ fromMaybe 0 (HM.lookup p sp)++ update p _ _ = p++ step p _ _ (State { curr_expr = CurrExpr _ (Tick (HpcTick i m) _) }) = do+ let p' = take n $ (i, m):p+ SM.modify (LNT . HM.insertWith (+) p' 1 . unLNT)+ return p'+ step p _ _ _ = return p
src/G2/Execution/Interface.hs view
@@ -11,11 +11,11 @@ import G2.Language.Support {-# INLINE runExecutionToProcessed #-}-runExecutionToProcessed :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) => r -> h -> or -> State t -> Bindings -> IO (Processed (State t), Bindings)+runExecutionToProcessed :: (Monad m, Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t -> State t -> Bindings -> m (Processed (State t), Bindings) runExecutionToProcessed = runReducer {-# INLINE runExecution #-}-runExecution :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) => r -> h -> or -> State t -> Bindings -> IO ([State t], Bindings)+runExecution :: (Monad m, Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t -> State t -> Bindings -> m ([State t], Bindings) runExecution r h ord s b = do (pr, b') <- runReducer r h ord s b return (accepted pr, b')
src/G2/Execution/Memory.hs view
@@ -1,5 +1,10 @@+{-# LANGUAGE RankNTypes #-}+ module G2.Execution.Memory - ( markAndSweep+ ( MemConfig (..)+ , emptyMemConfig+ , addSearchNames+ , markAndSweep , markAndSweepIgnoringKnownValues , markAndSweepPreserving ) where@@ -10,26 +15,55 @@ import qualified G2.Language.ExprEnv as E import G2.Language.Typing +import Data.Foldable import Data.List-import qualified Data.HashSet as S+import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M +import qualified Data.Sequence as S+import Data.Semigroup +type PreservingFunc = forall t . State t -> Bindings -> HS.HashSet Name -> HS.HashSet Name++data MemConfig = MemConfig { search_names :: [Name]+ , pres_func :: PreservingFunc }+ | PreserveAllMC++instance Semigroup MemConfig where+ (MemConfig { search_names = sn1, pres_func = pf1 }) <> (MemConfig { search_names = sn2, pres_func = pf2 }) =+ MemConfig { search_names = sn1 ++ sn2+ , pres_func = \s b hs -> pf1 s b hs `HS.union` pf2 s b hs}+ _ <> _ = PreserveAllMC++instance Monoid MemConfig where+ mempty = MemConfig { search_names = [], pres_func = \ _ _ -> id }++ mappend = (<>)++emptyMemConfig :: MemConfig+emptyMemConfig = MemConfig { search_names = [], pres_func = \_ _ a -> a }+ markAndSweep :: State t -> Bindings -> (State t, Bindings)-markAndSweep s = markAndSweepPreserving [] s+markAndSweep s = markAndSweepPreserving emptyMemConfig s +addSearchNames :: [Name] -> MemConfig -> MemConfig+addSearchNames ns mc@(MemConfig { search_names = ns' }) = mc { search_names = ns ++ ns' }+addSearchNames _ PreserveAllMC = PreserveAllMC+ markAndSweepIgnoringKnownValues :: State t -> Bindings -> (State t, Bindings)-markAndSweepIgnoringKnownValues = markAndSweepPreserving' []+markAndSweepIgnoringKnownValues = markAndSweepPreserving' emptyMemConfig -markAndSweepPreserving :: [Name] -> State t -> Bindings -> (State t, Bindings)-markAndSweepPreserving ns s = markAndSweepPreserving' (ns ++ names (known_values s)) s+markAndSweepPreserving :: MemConfig -> State t -> Bindings -> (State t, Bindings)+markAndSweepPreserving mc s =+ markAndSweepPreserving' (toList (names (known_values s)) `addSearchNames` mc) s -markAndSweepPreserving' :: [Name] -> State t -> Bindings -> (State t, Bindings)-markAndSweepPreserving' ns (state@State { expr_env = eenv+markAndSweepPreserving' :: MemConfig -> State t -> Bindings -> (State t, Bindings)+markAndSweepPreserving' PreserveAllMC s b = (s, b)+markAndSweepPreserving' mc (state@State { expr_env = eenv , type_env = tenv , curr_expr = cexpr , path_conds = pc- , symbolic_ids = iids , exec_stack = es }) (bindings@Bindings { deepseq_walkers = dsw , higher_order_inst = inst }) = -- error $ show $ length $ take 20 $ PC.toList path_conds@@ -40,38 +74,41 @@ } bindings' = bindings { deepseq_walkers = dsw'} - active = activeNames tenv eenv S.empty $ names cexpr ++- names es ++- names pc ++- names iids ++- higher_ord_rel ++- ns+ active = activeNames tenv (E.redirsToExprs eenv) HS.empty $ names cexpr <>+ names es <>+ names pc <>+ names (E.symbolicIds eenv) <>+ S.fromList higher_ord_rel <>+ S.fromList (search_names mc) + active' = HS.union (pres_func mc state bindings active) active+ isActive :: Name -> Bool- isActive = (flip S.member) active+ isActive = (flip HS.member) active' eenv' = E.filterWithKey (\n _ -> isActive n) eenv- tenv' = M.filterWithKey (\n _ -> isActive n) tenv+ tenv' = HM.filterWithKey (\n _ -> isActive n) tenv dsw' = M.filterWithKey (\n _ -> isActive n) dsw - higher_ord_eenv = E.filterWithKey (\n _ -> n `elem` inst) eenv- higher_ord = map PresType $ nubBy (.::.) $ argTypesTEnv tenv ++ E.higherOrderExprs higher_ord_eenv- higher_ord_rel = E.keys $ E.filter (\e -> any (.:: typeOf e) higher_ord) higher_ord_eenv--activeNames :: TypeEnv -> ExprEnv -> S.HashSet Name -> [Name] -> S.HashSet Name-activeNames _ _ explored [] = explored-activeNames tenv eenv explored (n:ns) =- if S.member n explored- then activeNames tenv eenv explored ns- else activeNames tenv eenv explored' ns'- where- explored' = S.insert n explored- tenv_hits = case M.lookup n tenv of- Nothing -> []- Just r -> names r- eenv_hits = case E.lookup n eenv of- Nothing -> []- Just r -> names r- ns' = tenv_hits ++ eenv_hits ++ ns+ higher_ord_eenv = E.filterWithKey (\n _ -> n `HS.member` inst) eenv+ higher_ord = nubBy (.::.) $ argTypesTEnv tenv ++ E.higherOrderExprs higher_ord_eenv+ higher_ord_rel = E.keys $ E.filter (\e -> any (e .::) higher_ord) higher_ord_eenv +activeNames :: TypeEnv -> ExprEnv -> HS.HashSet Name -> S.Seq Name -> HS.HashSet Name+activeNames tenv eenv explored nss+ | n S.:< ns <- S.viewl nss =+ let+ explored' = HS.insert n explored+ tenv_hits = case HM.lookup n tenv of+ Nothing -> S.empty+ Just r -> names r+ eenv_hits = case E.lookup n eenv of+ Nothing -> S.empty+ Just r -> names r+ ns' = tenv_hits <> eenv_hits <> ns+ in+ if HS.member n explored+ then activeNames tenv eenv explored ns+ else activeNames tenv eenv explored' ns'+ | otherwise = explored
+ src/G2/Execution/NewPC.hs view
@@ -0,0 +1,49 @@+module G2.Execution.NewPC ( NewPC (..)+ , newPCEmpty+ , reduceNewPC ) where++import G2.Language+import qualified G2.Language.PathConds as PC+import G2.Solver++import qualified Data.List as L++data NewPC t = NewPC { state :: State t+ , new_pcs :: [PathCond]+ , concretized :: [Id] }++newPCEmpty :: State t -> NewPC t+newPCEmpty s = NewPC { state = s, new_pcs = [], concretized = []}++reduceNewPC :: (Solver solver, Simplifier simplifier) => solver -> simplifier -> NewPC t -> IO (Maybe (State t))+reduceNewPC solver simplifier+ (NewPC { state = s@(State { path_conds = spc })+ , new_pcs = pc+ , concretized = concIds })+ | not (null pc) || not (null concIds) = do+ let (s', pc') = L.mapAccumL (simplifyPC simplifier) s pc+ pc'' = concat pc'+++ -- Optimization+ -- We replace the path_conds with only those that are directly+ -- affected by the new path constraints+ -- This allows for more efficient solving, and in some cases may+ -- change an Unknown into a SAT or UNSAT+ let new_pc = foldr PC.insert spc $ pc''+ new_pc' = foldr (simplifyPCs simplifier s') new_pc pc''++ s'' = s' {path_conds = new_pc'}++ let ns = (concatMap PC.varNamesInPC pc) ++ namesList concIds+ rel_pc = case ns of+ [] -> PC.fromList pc''+ _ -> PC.scc ns new_pc'++ res <- check solver s' rel_pc++ if res == SAT () then+ return $ Just s''+ else+ return Nothing+ | otherwise = return $ Just s
src/G2/Execution/NormalForms.hs view
@@ -3,7 +3,34 @@ import G2.Language import qualified G2.Language.Stack as S import qualified G2.Language.ExprEnv as E+import G2.Language.Typing +import qualified Data.HashSet as HS++-- A Var counts as being in EVF if it's symbolic or if it's unmapped.+isSWHNF :: State t -> Bool+isSWHNF (State { expr_env = h, curr_expr = CurrExpr _ e }) =+ let e' = modifyASTs stripTicks e+ t = typeOf e'+ in case e' of+ Var _ -> (isPrimType t || not (concretizable t)) && isExprValueForm h e'+ _ -> isExprValueForm h e'++stripTicks :: Expr -> Expr+stripTicks (Tick _ e) = e+stripTicks e = e++-- used by EquivADT and Tactics+concretizable :: Type -> Bool+concretizable (TyVar _) = False+concretizable (TyForAll _ _) = False+concretizable (TyFun _ _) = False+concretizable t@(TyApp _ _) =+ concretizable $ last $ unTyApp t+concretizable TYPE = False+concretizable TyUnknown = False+concretizable _ = True+ -- | If something is in "value form", then it is essentially ready to be -- returned and popped off the heap. This will be the SSTG equivalent of having -- Return vs Evaluate for the ExecCode of the `State`.@@ -22,11 +49,11 @@ ((Var _):_) -> False _ -> False isExprValueForm _ (Let _ _) = False-isExprValueForm _ (Case _ _ _) = False+isExprValueForm _ (Case _ _ _ _) = False isExprValueForm eenv (Cast e (t :~ _)) = not (hasFuncType t) && isExprValueForm eenv e isExprValueForm _ (Tick _ _) = False isExprValueForm _ (NonDet _) = False-isExprValueForm _ (SymGen _) = False+isExprValueForm _ (SymGen _ _) = False isExprValueForm _ (Assume _ _ _) = False isExprValueForm _ (Assert _ _ _) = False isExprValueForm _ _ = True@@ -44,3 +71,26 @@ isExecValueFormDisNonRedPC :: State t -> Bool isExecValueFormDisNonRedPC s = isExecValueForm $ s {non_red_path_conds = []}++normalForm :: E.ExprEnv -> Expr -> Bool+normalForm = normalForm' HS.empty++normalForm' :: HS.HashSet Name -> E.ExprEnv -> Expr -> Bool+normalForm' looked eenv (Var (Id n _))+ | n `HS.member` looked = True+ | Just e <- E.lookup n eenv = normalForm' (HS.insert n looked) eenv e+ | otherwise = E.isSymbolic n eenv+normalForm' looked eenv (App f a) = case unApp (App f a) of+ (Prim _ _:xs) -> all (normalForm' looked eenv) xs+ (Data _:xs) -> all (normalForm' looked eenv) xs+ ((Var _):_) -> False+ _ -> False+normalForm' _ _ (Let _ _) = False+normalForm' _ _ (Case _ _ _ _) = False+normalForm' looked eenv (Cast e (t :~ _)) = not (hasFuncType t) && normalForm' looked eenv e+normalForm' _ _ (Tick _ _) = False+normalForm' _ _ (NonDet _) = False+normalForm' _ _ (SymGen _ _) = False+normalForm' _ _ (Assume _ _ _) = False+normalForm' _ _ (Assert _ _ _) = False+normalForm' _ _ _ = True
src/G2/Execution/PrimitiveEval.hs view
@@ -1,88 +1,138 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} -module G2.Execution.PrimitiveEval (evalPrims, evalPrim) where+module G2.Execution.PrimitiveEval (evalPrims, maybeEvalPrim, evalPrimSymbolic) where import G2.Language.AST import G2.Language.Expr+import G2.Language.Naming+import G2.Language.Primitives import G2.Language.Support import G2.Language.Syntax+import G2.Language.Typing -evalPrims :: ASTContainer m Expr => KnownValues -> m -> m-evalPrims kv = modifyContainedASTs (evalPrims' kv . simplifyCasts)+import Control.Exception+import Data.Char+import qualified Data.HashMap.Lazy as M+import qualified Data.List as L+import Data.Maybe+import qualified G2.Language.ExprEnv as E -evalPrim :: KnownValues -> Expr -> Expr-evalPrim kv a@(App _ _) =+evalPrims :: ASTContainer m Expr => TypeEnv -> KnownValues -> m -> m+evalPrims tenv kv = modifyContainedASTs (evalPrims' tenv kv . simplifyCasts)++evalPrims' :: TypeEnv -> KnownValues -> Expr -> Expr+evalPrims' tenv kv a@(App x y) = case unApp a of- [p@(Prim _ _), l@(Lit _)] -> evalPrim' kv [p, l]- [p@(Prim _ _), l1@(Lit _), l2@(Lit _)] -> evalPrim' kv [p, l1, l2]- _ -> a-evalPrim _ e = e+ [p@(Prim _ _), l] -> evalPrim' tenv kv [p, evalPrims' tenv kv l]+ [p@(Prim _ _), l1, l2] ->+ evalPrim' tenv kv [p, evalPrims' tenv kv l1, evalPrims' tenv kv l2]+ _ -> App (evalPrims' tenv kv x) (evalPrims' tenv kv y)+evalPrims' tenv kv e = modifyChildren (evalPrims' tenv kv) e +evalPrim' :: TypeEnv -> KnownValues -> [Expr] -> Expr+evalPrim' tenv kv xs = fromMaybe (mkApp xs) (maybeEvalPrim' tenv kv xs) -evalPrims' :: KnownValues -> Expr -> Expr-evalPrims' kv a@(App x y) =- case unApp a of- [p@(Prim _ _), l] -> evalPrim' kv [p, evalPrims' kv l]- [p@(Prim _ _), l1, l2] -> evalPrim' kv [p, evalPrims' kv l1, evalPrims' kv l2]- _ -> App (evalPrims' kv x) (evalPrims' kv y)-evalPrims' kv e = modifyChildren (evalPrims' kv) e+maybeEvalPrim :: TypeEnv -> KnownValues -> Expr -> Maybe Expr+maybeEvalPrim tenv kv = maybeEvalPrim' tenv kv . unApp -evalPrim' :: KnownValues -> [Expr] -> Expr-evalPrim' kv xs+maybeEvalPrim' :: TypeEnv -> KnownValues -> [Expr] -> Maybe Expr+maybeEvalPrim' tenv kv xs | [Prim p _, x] <- xs- , Lit x' <- getLit x =- case evalPrim1 p x' of- Just e -> e- Nothing -> mkApp xs+ , Lit x' <- x+ , Just e <- evalPrim1 p x' = Just e+ | [Prim p _, x] <- xs+ , Lit x' <- x = evalPrim1' tenv kv p x' | [Prim p _, x, y] <- xs- , Lit x' <- getLit x- , Lit y' <- getLit y =- case evalPrim2 kv p x' y' of- Just e -> e- Nothing -> mkApp xs+ , Lit x' <- x+ , Lit y' <- y = evalPrim2 kv p x' y' - | otherwise = mkApp xs+ | [Prim p _, Type t, dc_e] <- xs, Data dc:_ <- unApp dc_e =+ evalTypeDCPrim2 tenv p t dc -getLit :: Expr -> Expr-getLit l@(Lit _) = l-getLit x = x+ | [Prim p _, Type t, Lit (LitInt l)] <- xs =+ evalTypeLitPrim2 tenv p t l + | otherwise = Nothing+ evalPrim1 :: Primitive -> Lit -> Maybe Expr evalPrim1 Negate (LitInt x) = Just . Lit $ LitInt (-x) evalPrim1 Negate (LitFloat x) = Just . Lit $ LitFloat (-x) evalPrim1 Negate (LitDouble x) = Just . Lit $ LitDouble (-x)+evalPrim1 Abs (LitInt x) = Just . Lit $ LitInt (abs x)+evalPrim1 Abs (LitFloat x) = Just . Lit $ LitFloat (abs x)+evalPrim1 Abs (LitDouble x) = Just . Lit $ LitDouble (abs x) evalPrim1 SqRt x = evalPrim1Floating (sqrt) x evalPrim1 IntToFloat (LitInt x) = Just . Lit $ LitFloat (fromIntegral x) evalPrim1 IntToDouble (LitInt x) = Just . Lit $ LitDouble (fromIntegral x)+evalPrim1 Chr (LitInt x) = Just . Lit $ LitChar (chr $ fromInteger x)+evalPrim1 OrdChar (LitChar x) = Just . Lit $ LitInt (toInteger $ ord x)+evalPrim1 WGenCat (LitInt x) = Just . Lit $ LitInt (toInteger . fromEnum . generalCategory . toEnum $ fromInteger x) evalPrim1 _ _ = Nothing +evalPrim1' :: TypeEnv -> KnownValues -> Primitive -> Lit -> Maybe Expr+evalPrim1' tenv kv IntToString (LitInt x) =+ let+ char_dc = mkDCChar kv tenv+ in+ Just . mkG2List kv tenv TyLitChar . map (App char_dc . Lit . LitChar) $ show x+evalPrim1' _ _ _ _ = Nothing+ evalPrim2 :: KnownValues -> Primitive -> Lit -> Lit -> Maybe Expr-evalPrim2 kv Ge x y = evalPrim2NumBool (>=) kv x y-evalPrim2 kv Gt x y = evalPrim2NumBool (>) kv x y-evalPrim2 kv Eq x y = evalPrim2NumBool (==) kv x y-evalPrim2 kv Lt x y = evalPrim2NumBool (<) kv x y-evalPrim2 kv Le x y = evalPrim2NumBool (<=) kv x y+evalPrim2 kv Ge x y = evalPrim2NumCharBool (>=) kv x y+evalPrim2 kv Gt x y = evalPrim2NumCharBool (>) kv x y+evalPrim2 kv Eq x y = evalPrim2NumCharBool (==) kv x y+evalPrim2 kv Lt x y = evalPrim2NumCharBool (<) kv x y+evalPrim2 kv Le x y = evalPrim2NumCharBool (<=) kv x y evalPrim2 _ Plus x y = evalPrim2Num (+) x y evalPrim2 _ Minus x y = evalPrim2Num (-) x y evalPrim2 _ Mult x y = evalPrim2Num (*) x y-evalPrim2 _ Div x y = if isZero y then error "Have Div _ 0" else evalPrim2Fractional (/) x y+evalPrim2 _ Div x y = if isZero y then error "Have Div _ 0" else evalPrim2Fractional (/) x y evalPrim2 _ Quot x y = if isZero y then error "Have Quot _ 0" else evalPrim2Integral quot x y-evalPrim2 _ Mod x y = evalPrim2Integral (mod) x y+evalPrim2 _ Mod x y = evalPrim2Integral mod x y evalPrim2 _ _ _ _ = Nothing +evalTypeDCPrim2 :: TypeEnv -> Primitive -> Type -> DataCon -> Maybe Expr+evalTypeDCPrim2 tenv DataToTag t dc =+ case unTyApp t of+ TyCon n _:_ | Just adt <- M.lookup n tenv ->+ let+ dcs = dataCon adt+ in+ fmap (Lit . LitInt . fst) . L.find ((==) dc . snd) $ zip [1..] dcs+ _ -> error "evalTypeDCPrim2: Unsupported Primitive Op"+evalTypeDCPrim2 _ _ _ _ = Nothing++evalTypeLitPrim2 :: TypeEnv -> Primitive -> Type -> Integer -> Maybe Expr+evalTypeLitPrim2 tenv TagToEnum t i =+ case unTyApp t of+ TyCon n _:_ | Just adt <- M.lookup n tenv ->+ let+ dcs = dataCon adt+ in+ maybe (Just $ Prim Error TyBottom) (Just . Data)+ $ ith dcs (fromInteger i)+ _ -> error "evalTypeLitPrim2: Unsupported Primitive Op"+evalTypeLitPrim2 _ _ _ _ = Nothing++ith :: [a] -> Integer -> Maybe a+ith (x:_) 0 = Just x+ith (_:xs) n = assert (n > 0) ith xs (n - 1)+ith _ _ = Nothing+ isZero :: Lit -> Bool isZero (LitInt 0) = True isZero (LitFloat 0) = True isZero (LitDouble 0) = True isZero _ = False -evalPrim2NumBool :: (forall a . Ord a => a -> a -> Bool) -> KnownValues -> Lit -> Lit -> Maybe Expr-evalPrim2NumBool f kv (LitInt x) (LitInt y) = Just . mkBool kv $ f x y-evalPrim2NumBool f kv (LitFloat x) (LitFloat y) = Just . mkBool kv $ f x y-evalPrim2NumBool f kv (LitDouble x) (LitDouble y) = Just . mkBool kv $ f x y-evalPrim2NumBool _ _ _ _ = Nothing+evalPrim2NumCharBool :: (forall a . Ord a => a -> a -> Bool) -> KnownValues -> Lit -> Lit -> Maybe Expr+evalPrim2NumCharBool f kv (LitInt x) (LitInt y) = Just . mkBool kv $ f x y+evalPrim2NumCharBool f kv (LitFloat x) (LitFloat y) = Just . mkBool kv $ f x y+evalPrim2NumCharBool f kv (LitDouble x) (LitDouble y) = Just . mkBool kv $ f x y+evalPrim2NumCharBool f kv (LitChar x) (LitChar y) = Just . mkBool kv $ f x y+evalPrim2NumCharBool _ _ _ _ = Nothing evalPrim2Num :: (forall a . Num a => a -> a -> a) -> Lit -> Lit -> Maybe Expr evalPrim2Num f (LitInt x) (LitInt y) = Just . Lit . LitInt $ f x y@@ -103,3 +153,55 @@ evalPrim1Floating f (LitFloat x) = Just . Lit . LitFloat . toRational $ f (fromRational x :: Double) evalPrim1Floating f (LitDouble x) = Just . Lit . LitDouble . toRational $ f (fromRational x :: Double) evalPrim1Floating _ _ = Nothing++-- | Evaluate certain primitives applied to symbolic expressions, when possible+evalPrimSymbolic :: ExprEnv -> TypeEnv -> NameGen -> KnownValues -> Expr -> Maybe (Expr, ExprEnv, [PathCond], NameGen)+evalPrimSymbolic eenv tenv ng kv e+ | [Prim DataToTag _, type_t, cse] <- unApp e+ , Type t <- dig eenv type_t+ , Case v@(Var (Id n _)) _ _ alts <- cse+ , TyCon tn _:_ <- unTyApp t+ , Just adt <- M.lookup tn tenv =+ let+ alt_p = map (\(Alt (LitAlt l) e) ->+ let+ Data dc = head $ unApp e+ in+ (l, dc)) alts++ dcs = dataCon adt+ num_dcs = zip (map (Lit . LitInt) [0..]) dcs++ (ret, ng') = freshId TyLitInt ng ++ new_pc = map (`ExtCond` True)+ $ mapMaybe (\(alt_l, alt_dc) ->+ fmap (\(nn, n_dc) -> eq v (Lit alt_l) `eq` eq (Var ret) nn)+ $ L.find ((==) alt_dc . snd) num_dcs) alt_p+ in+ Just (Var ret, E.insertSymbolic ret eenv, new_pc, ng')+ -- G2 uses actual Bools in primitive comparisons, whereas GHC uses 0# and 1#.+ -- We thus need special handling so that, in G2, we don't try to convert to Bool via a TagToEnum+ -- (which has type Int# -> a). Instead, we simply return the Bool directly.+ | tBool <- tyBool kv+ , [Prim TagToEnum _, _, pe] <- unApp e+ , typeOf (dig eenv pe) == tBool = Just (pe, eenv, [], ng)+ | [Prim TagToEnum _, type_t, pe] <- unApp e+ , Type t <- dig eenv type_t =+ case unTyApp t of+ TyCon n _:_ | Just adt <- M.lookup n tenv ->+ let+ (b, ng') = freshId TyLitInt ng + dcs = dataCon adt+ alts = zipWith (\l dc -> Alt (LitAlt (LitInt l)) (Data dc)) [0..] dcs+ alt_d = Alt Default (Prim Error t)+ in+ Just (Case pe b t (alt_d:alts), E.insertSymbolic b eenv, [], ng')+ _ -> error "evalTypeLitPrim2: Unsupported Primitive Op"+ | otherwise = Nothing+ where+ eq e1 = App (App (mkEqPrimType (typeOf e1) kv) e1)++dig :: ExprEnv -> Expr -> Expr+dig eenv (Var (Id n _)) | Just (E.Conc e) <- E.lookupConcOrSym n eenv = dig eenv e+dig _ e = e
src/G2/Execution/Reducer.hs view
@@ -1,933 +1,1341 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE UndecidableInstances #-}--module G2.Execution.Reducer ( Reducer (..)- , Halter (..)- , Orderer (..)-- , Processed (..)- , mapProcessed-- , ReducerRes (..)- , HaltC (..)-- , SomeReducer (..)- , SomeHalter (..)- , SomeOrderer (..)-- -- Reducers- , RCombiner (..)- , StdRed (..)- , NonRedPCRed (..)- , TaggerRed (..)- , Logger (..)-- , (<~)- , (<~?)- , (<~|)-- -- Halters- , AcceptHalter (..)- , HCombiner (..)- , ZeroHalter (..)- , DiscardIfAcceptedTag (..)- , MaxOutputsHalter (..)- , SwitchEveryNHalter (..)- , BranchAdjSwitchEveryNHalter (..)- , RecursiveCutOff (..)- , VarLookupLimit (..)- , BranchAdjVarLookupLimit (..)-- -- Orderers- , OCombiner (..)- , NextOrderer (..)- , PickLeastUsedOrderer (..)- , BucketSizeOrderer (..)- , CaseCountOrderer (..)- , SymbolicADTOrderer (..)- , ADTHeightOrderer (..)- , IncrAfterN (..)-- , runReducer ) where--import qualified G2.Language.ExprEnv as E-import G2.Execution.Rules-import G2.Language-import qualified G2.Language.Stack as Stck-import G2.Solver-import G2.Lib.Printers--import Data.Foldable-import qualified Data.HashSet as S-import qualified Data.HashMap.Strict as HM-import qualified Data.Map as M-import Data.Maybe-import qualified Data.List as L-import System.Directory---- | Used when applying execution rules--- Allows tracking extra information to control halting of rule application,--- and to reorder states--- see also, the Reducer, Halter, Orderer typeclasses--- cases is used for logging states-data ExState rv hv sov t = ExState { state :: State t- , reducer_val :: rv- , halter_val :: hv- , order_val :: sov- }---- | Keeps track of type a's that have either been accepted or dropped-data Processed a = Processed { accepted :: [a]- , discarded :: [a] }--mapProcessed :: (a -> b) -> Processed a -> Processed b-mapProcessed f pr = Processed { accepted = map f (accepted pr)- , discarded = map f (discarded pr)}---- | Used by Reducers to indicate their progress reducing.-data ReducerRes = NoProgress | InProgress | Finished deriving (Eq, Ord, Show, Read)--progPrioritizer :: ReducerRes -> ReducerRes -> ReducerRes-progPrioritizer InProgress _ = InProgress-progPrioritizer _ InProgress = InProgress-progPrioritizer Finished _ = Finished-progPrioritizer _ Finished = Finished-progPrioritizer _ _ = NoProgress---- | Used by members of the Halter typeclass to control whether to continue--- evaluating the current State, or switch to evaluating a new state.-data HaltC = Discard -- ^ Switch to evaluating a new state, and reject the current state- | Accept -- ^ Switch to evaluating a new state, and accept the current state- | Switch -- ^ Switch to evaluating a new state, but continue evaluating the current state later- | Continue -- ^ Continue evaluating the current State- deriving (Eq, Ord, Show, Read)---- | A Reducer is used to describe a set of Reduction Rules.--- Reduction Rules take a State, and output new states.--- The type parameter r is used to disambiguate between different producers.--- To create a new reducer, define some new type, and use it as r. --- The reducer value, rv, can be used to track special, per Reducer, information.-class Reducer r rv t | r -> rv where- -- | Initialized the reducer value- initReducer :: r -> State t -> rv-- -- | Takes a State, and performs the appropriate Reduction Rule- redRules :: r -> rv -> State t -> Bindings -> IO (ReducerRes, [(State t, rv)], Bindings, r) - - -- | Gives an opportunity to update with all States and Reducer Val's,- -- output by all Reducer's, visible- -- Errors if the returned list is too short.- {-# INLINE updateWithAll #-}- updateWithAll :: r -> [(State t, rv)] -> [rv]- updateWithAll _ = map snd ----- | Determines when to stop evaluating a state--- The type parameter h is used to disambiguate between different producers.--- To create a new Halter, define some new type, and use it as h.-class Halter h hv t | h -> hv where- -- | Initializes each state halter value- initHalt :: h -> State t -> hv-- -- | Runs whenever we switch to evaluating a different state,- -- to update the halter value of that new state- updatePerStateHalt :: h -> hv -> Processed (State t) -> State t -> hv-- -- | Runs when we start execution on a state, immediately after- -- `updatePerStateHalt`. Allows a State to be discarded right- -- before execution is about to (re-)begin.- -- Return True if execution should proceed, False to discard- discardOnStart :: h -> hv -> Processed (State t) -> State t -> Bool- discardOnStart _ _ _ _ = False-- -- | Determines whether to continue reduction on the current state- stopRed :: h -> hv -> Processed (State t) -> State t -> HaltC-- -- | Takes a state, and updates it's halter record field- stepHalter :: h -> hv -> Processed (State t) -> [State t] -> State t -> hv---- | Picks an order to evaluate the states, to allow prioritizing some over others --- The type parameter or is used to disambiguate between different producers.--- To create a new reducer, define some new type, and use it as or.-class Ord b => Orderer or sov b t | or -> sov, or -> b where- -- | Initializing the per state ordering value - initPerStateOrder :: or -> State t -> sov-- -- | Assigns each state some value of an ordered type, and then proceeds with execution on the- -- state assigned the minimal value- orderStates :: or -> sov -> State t -> b-- -- | Run on the selected state, to update it's sov field- updateSelected :: or -> sov -> Processed (State t) -> State t -> sov-- -- | Run on the state at each step, to update it's sov field- stepOrderer :: or -> sov -> Processed (State t) -> [State t] -> State t -> sov - stepOrderer _ sov _ _ _ = sov--data SomeReducer t where- SomeReducer :: forall r rv t . Reducer r rv t => r -> SomeReducer t--data SomeHalter t where- SomeHalter :: forall h hv t . Halter h hv t => h -> SomeHalter t--data SomeOrderer t where- SomeOrderer :: forall or sov b t . Orderer or sov b t => or -> SomeOrderer t---- | Combines reducers in various ways--- updateWithAll is called by all Reducers, regardless of which combinator is used-data RCombiner r1 r2 = r1 :<~ r2 -- ^ Apply r2, followed by r1. Takes the leftmost update to r1- | r1 :<~? r2 -- ^ Apply r2, apply r1 only if r2 returns NoProgress- | r1 :<~| r2 -- ^ Apply r2, apply r1 only if r2 returns Finished- deriving (Eq, Show, Read)---- We use RC to combine the reducer values for RCombiner--- We should never define any other instance of Reducer with RC, or export it--- because this could lead to undecidable instances-data RC a b = RC a b--instance (Reducer r1 rv1 t, Reducer r2 rv2 t) => Reducer (RCombiner r1 r2) (RC rv1 rv2) t where- initReducer (r1 :<~ r2) s =- let- rv1 = initReducer r1 s- rv2 = initReducer r2 s- in- RC rv1 rv2- initReducer (r1 :<~? r2) s =- let- rv1 = initReducer r1 s- rv2 = initReducer r2 s- in- RC rv1 rv2- initReducer (r1 :<~| r2) s =- let- rv1 = initReducer r1 s- rv2 = initReducer r2 s- in- RC rv1 rv2-- redRules (r1 :<~ r2) (RC rv1 rv2) s b = do- (rr2, srv2, b', r2') <- redRules r2 rv2 s b- (rr1, srv1, b'', r1') <- redRulesToStates r1 rv1 srv2 b'-- return (progPrioritizer rr1 rr2, srv1, b'', r1' :<~ r2')-- redRules (r1 :<~? r2) (RC rv1 rv2) s b = do- (rr2, srv2, b', r2') <- redRules r2 rv2 s b- let (s', rv2') = unzip srv2-- case rr2 of- NoProgress -> do- (rr1, ss, b'', r1') <- redRulesToStates r1 rv1 srv2 b'- return (rr1, ss, b'', r1' :<~? r2')- _ -> return (rr2, zip s' (map (uncurry RC) (zip (repeat rv1) rv2')), b', r1 :<~? r2')-- redRules (r1 :<~| r2) (RC rv1 rv2) s b = do- (rr2, srv2, b', r2') <- redRules r2 rv2 s b- let (s', rv2') = unzip srv2-- case rr2 of- Finished -> do- (rr1, ss, b'', r1') <- redRulesToStates r1 rv1 srv2 b'- return (rr1, ss, b'', r1' :<~| r2')- _ -> return (rr2, zip s' (map (uncurry RC) (zip (repeat rv1) rv2')), b', r1 :<~| r2')-- updateWithAll (r1 :<~ r2) = updateWithAllRC r1 r2- updateWithAll (r1 :<~? r2) = updateWithAllRC r1 r2- updateWithAll (r1 :<~| r2) = updateWithAllRC r1 r2--{-# INLINE updateWithAllRC #-}-updateWithAllRC :: (Reducer r1 rv1 t, Reducer r2 rv2 t) => r1 -> r2 -> [(State t, RC rv1 rv2)] -> [RC rv1 rv2]-updateWithAllRC r1 r2 srv =- let- srv1 = map (\(s, RC rv1 _) -> (s, rv1)) srv- srv2 = map (\(s, RC _ rv2) -> (s, rv2)) srv-- rv1' = updateWithAll r1 srv1- rv2' = updateWithAll r2 srv2- in- map (uncurry RC) $ zip rv1' rv2'---- Applies function to first (State t, rv2), gets new Bindings and recursively applies function to rest of array using new Bindings-mapMAccumB :: (Bindings -> (State t, rv2) -> IO (Bindings, (ReducerRes, [(State t, RC rv rv2)], r))) -> Bindings -> [(State t, rv2)] - -> IO (Bindings, [(ReducerRes, [(State t, RC rv rv2)], r)])-mapMAccumB _ b [] = do- return (b, [])-mapMAccumB f b (x:xs) = do- (b', res) <- f b x- (b'', res2) <- mapMAccumB f b' xs- return $ (b'', res:res2)--redRulesToStatesAux :: Reducer r rv t => r -> rv -> Bindings -> (State t, rv2) -> IO (Bindings, (ReducerRes, [(State t, RC rv rv2)], r))-redRulesToStatesAux r rv1 b (is, rv2) = do- (rr_, is', b', r') <- redRules r rv1 is b- return (b', (rr_, map (\(is'', rv1') -> (is'', RC rv1' rv2) ) is', r'))- -redRulesToStates :: Reducer r rv t => r -> rv -> [(State t, rv2)] -> Bindings -> IO (ReducerRes, [(State t, RC rv rv2)], Bindings, r)-redRulesToStates r rv1 s b = do- let redRulesToStatesAux' = redRulesToStatesAux r rv1- (b', rs) <- mapMAccumB redRulesToStatesAux' b s-- let (rr, s', r') = L.unzip3 rs-- let rf = foldr progPrioritizer NoProgress rr-- return $ (rf, concat s', b', head r')--{-# INLINE (<~) #-}--- | Combines two @`SomeReducer`@s with a @`:<~`@-(<~) :: SomeReducer t -> SomeReducer t -> SomeReducer t-SomeReducer r1 <~ SomeReducer r2 = SomeReducer (r1 :<~ r2)--{-# INLINE (<~?) #-}--- | Combines two @`SomeReducer`@s with a @`:<~?`@-(<~?) :: SomeReducer t -> SomeReducer t -> SomeReducer t-SomeReducer r1 <~? SomeReducer r2 = SomeReducer (r1 :<~? r2)--{-# INLINE (<~|) #-}--- | Combines two @`SomeReducer`@s with a @`:<~|`@-(<~|) :: SomeReducer t -> SomeReducer t -> SomeReducer t-SomeReducer r1 <~| SomeReducer r2 = SomeReducer (r1 :<~| r2)--data StdRed con = StdRed con--instance Solver con => Reducer (StdRed con) () t where- initReducer _ _ = ()-- redRules stdr@(StdRed solver) _ s b = do- (r, s', b') <- stdReduce solver s b- - return (if r == RuleIdentity then Finished else InProgress, s', b', stdr)---- | Removes and reduces the values in a State's non_red_path_conds field. -data NonRedPCRed = NonRedPCRed--instance Reducer NonRedPCRed () t where- initReducer _ _ = ()-- redRules nrpr _ s@(State { expr_env = eenv- , curr_expr = cexpr- , exec_stack = stck- , non_red_path_conds = nr:nrs- , symbolic_ids = si- , model = m })- b@(Bindings { higher_order_inst = inst }) = do- let stck' = Stck.push (CurrExprFrame cexpr) stck-- let cexpr' = CurrExpr Evaluate nr-- let eenv_si_ces = substHigherOrder eenv m si inst cexpr'-- let s' = s { exec_stack = stck'- , non_red_path_conds = nrs- }- xs = map (\(eenv', m', si', ce) -> (s' { expr_env = eenv'- , model = m'- , curr_expr = ce- , symbolic_ids = si' }, ())) eenv_si_ces-- return (InProgress, xs, b, nrpr)- redRules nrpr _ s b = return (Finished, [(s, ())], b, nrpr)---- [Higher-Order Model]--- Substitutes all possible higher order functions for symbolic higher order functions.--- We insert the substituted higher order function directly into the model, because, due--- to the VAR-RED rule, the function name will (if the function is called) be lost during execution.-substHigherOrder :: ExprEnv -> Model -> SymbolicIds -> [Name] -> CurrExpr -> [(ExprEnv, Model, SymbolicIds, CurrExpr)]-substHigherOrder eenv m si ns ce =- let- is = mapMaybe (\n -> case E.lookup n eenv of- Just e -> Just $ Id n (typeOf e)- Nothing -> Nothing) ns-- higherOrd = filter (isTyFun . typeOf) . mapMaybe varId . symbVars eenv $ ce- higherOrdSub = map (\v -> (v, mapMaybe (genSubstitutable v) is)) higherOrd- in- substHigherOrder' [(eenv, m, si, ce)] higherOrdSub- where- genSubstitutable v i- | (True, bm) <- specializes M.empty (typeOf v )(typeOf i) =- let- bnds = map idName $ leadingTyForAllBindings i- tys = mapMaybe (\b -> fmap Type $ M.lookup b bm) bnds- in- Just . mkApp $ Var i:tys- | otherwise = Nothing--substHigherOrder' :: [(ExprEnv, Model, SymbolicIds, CurrExpr)] -> [(Id, [Expr])] -> [(ExprEnv, Model, SymbolicIds, CurrExpr)]-substHigherOrder' eenvsice [] = eenvsice-substHigherOrder' eenvsice ((i, es):iss) =- substHigherOrder'- (concatMap (\e_rep -> - map (\(eenv, m, si, ce) -> ( E.insert (idName i) e_rep eenv- , M.insert (idName i) e_rep m- , filter (/= i) si- , replaceASTs (Var i) e_rep ce)- ) eenvsice)- es) iss--data TaggerRed = TaggerRed Name NameGen--instance Reducer TaggerRed () t where- initReducer _ _ = ()-- redRules tr@(TaggerRed n ng) _ s@(State {tags = ts}) b =- let- (n'@(Name n_ m_ _ _), ng') = freshSeededName n ng- in- if null $ S.filter (\(Name n__ m__ _ _) -> n_ == n__ && m_ == m__) ts then- return (Finished, [(s {tags = S.insert n' ts}, ())], b, TaggerRed n ng')- else- return (Finished, [(s, ())], b, tr)---- | A Reducer to producer logging output -data Logger = Logger String--instance Reducer Logger [Int] t where- initReducer _ _ = []-- redRules l@(Logger fn) li s b = do- outputState fn li s b- return (NoProgress, [(s, li)], b, l)- - updateWithAll _ [(_, l)] = [l]- updateWithAll _ ss = map (\(l, i) -> l ++ [i]) $ zip (map snd ss) [1..]--outputState :: String -> [Int] -> State t -> Bindings -> IO ()-outputState fdn is s b = do- let dir = fdn ++ "/" ++ foldl' (\str i -> str ++ show i ++ "/") "" is- createDirectoryIfMissing True dir-- let fn = dir ++ "state" ++ show (length $ rules s) ++ ".txt"- let write = pprExecStateStr s b- writeFile fn write-- putStrLn fn----- | Allows executing multiple halters.--- If the halters disagree, prioritizes the order:--- Discard, Accept, Switch, Continue-data HCombiner h1 h2 = h1 :<~> h2 deriving (Eq, Show, Read)---- We use C to combine the halter values for HCombiner--- We should never define any other instance of Halter with C, or export it--- because this could lead to undecidable instances-data C a b = C a b--instance (ASTContainer a Expr, ASTContainer b Expr) => ASTContainer (C a b) Expr where- containedASTs (C a b) = containedASTs a ++ containedASTs b- modifyContainedASTs f (C a b) = C (modifyContainedASTs f a) (modifyContainedASTs f b)--instance (ASTContainer a Type, ASTContainer b Type) => ASTContainer (C a b) Type where- containedASTs (C a b) = containedASTs a ++ containedASTs b- modifyContainedASTs f (C a b) = C (modifyContainedASTs f a) (modifyContainedASTs f b)--instance (Named a, Named b) => Named (C a b) where- names (C a b) = names a ++ names b- rename old new (C a b) = C (rename old new a) (rename old new b)- renames hm (C a b) = C (renames hm a) (renames hm b)--instance (Halter h1 hv1 t, Halter h2 hv2 t) => Halter (HCombiner h1 h2) (C hv1 hv2) t where- initHalt (h1 :<~> h2) s =- let- hv1 = initHalt h1 s- hv2 = initHalt h2 s- in- C hv1 hv2-- updatePerStateHalt (h1 :<~> h2) (C hv1 hv2) proc s =- let- hv1' = updatePerStateHalt h1 hv1 proc s- hv2' = updatePerStateHalt h2 hv2 proc s- in- C hv1' hv2'-- discardOnStart (h1 :<~> h2) (C hv1 hv2) proc s =- let- b1 = discardOnStart h1 hv1 proc s- b2 = discardOnStart h2 hv2 proc s- in- b1 || b2-- stopRed (h1 :<~> h2) (C hv1 hv2) proc s =- let- hc1 = stopRed h1 hv1 proc s- hc2 = stopRed h2 hv2 proc s- in- min hc1 hc2-- stepHalter (h1 :<~> h2) (C hv1 hv2) proc xs s =- let- hv1' = stepHalter h1 hv1 proc xs s- hv2' = stepHalter h2 hv2 proc xs s- in- C hv1' hv2'---- | Accepts a state when it is in ExecNormalForm-data AcceptHalter = AcceptHalter--instance Halter AcceptHalter () t where- initHalt _ _ = ()- updatePerStateHalt _ _ _ _ = ()- stopRed _ _ _ s =- case isExecValueForm s && true_assert s of- True -> Accept- False -> Continue- stepHalter _ _ _ _ _ = ()---- | Allows execution to continue until the step counter hits 0, then discards the state-data ZeroHalter = ZeroHalter Int--instance Halter ZeroHalter Int t where- initHalt (ZeroHalter n) _ = n- updatePerStateHalt _ hv _ _ = hv- stopRed = halterIsZero- stepHalter = halterSub1--halterSub1 :: Halter h Int t => h -> Int -> Processed (State t) -> [State t] -> State t -> Int-halterSub1 _ h _ _ _ = h - 1--halterIsZero :: Halter h Int t => h -> Int -> Processed (State t) -> State t -> HaltC-halterIsZero _ 0 _ _ = Discard-halterIsZero _ _ _ _ = Continue--data MaxOutputsHalter = MaxOutputsHalter (Maybe Int)--instance Halter MaxOutputsHalter (Maybe Int) t where- initHalt (MaxOutputsHalter m) _ = m- updatePerStateHalt _ hv _ _ = hv- stopRed _ m (Processed {accepted = acc}) _ =- case m of- Just m' -> if length acc >= m' then Discard else Continue- _ -> Continue- stepHalter _ hv _ _ _ = hv---- | Switch execution every n steps-data SwitchEveryNHalter = SwitchEveryNHalter Int--instance Halter SwitchEveryNHalter Int t where- initHalt (SwitchEveryNHalter sw) _ = sw- updatePerStateHalt (SwitchEveryNHalter sw) _ _ _ = sw- stopRed _ i _ _ = if i <= 0 then Switch else Continue- stepHalter _ i _ _ _ = i - 1---- | Switches execution every n steps, where n is divided every time--- a case split happens, by the number of states.--- That is, if n is 2100, and the case splits into 3 states, each new state will--- will then get only 700 steps-data BranchAdjSwitchEveryNHalter = BranchAdjSwitchEveryNHalter { switch_def :: Int- , switch_min :: Int }--data SwitchingPerState = SwitchingPerState { switch_at :: Int -- ^ Max number of steps- , counter :: Int -- ^ Current step counter- }--instance Halter BranchAdjSwitchEveryNHalter SwitchingPerState t where- initHalt (BranchAdjSwitchEveryNHalter { switch_def = sw }) _ =- SwitchingPerState { switch_at = sw, counter = sw }- updatePerStateHalt _ sps@(SwitchingPerState { switch_at = sw }) _ _ =- sps { counter = sw }- stopRed _ (SwitchingPerState { counter = i }) _ _ =- if i <= 0 then Switch else Continue- stepHalter (BranchAdjSwitchEveryNHalter { switch_min = mi })- sps@(SwitchingPerState { switch_at = sa, counter = i }) _ xs _ =- let- new_sa = max mi (sa `div` length xs)- new_i = min (i - 1) new_sa- in- sps { switch_at = new_sa, counter = new_i}--data BranchAdjVarLookupLimit = BranchAdjVarLookupLimit { var_switch_def :: Int- , var_switch_min :: Int }--instance Halter BranchAdjVarLookupLimit SwitchingPerState t where- initHalt (BranchAdjVarLookupLimit { var_switch_def = sw }) _ =- SwitchingPerState { switch_at = sw, counter = sw }- updatePerStateHalt _ sps@(SwitchingPerState { switch_at = sw }) _ _ =- sps { counter = sw }- stopRed _ (SwitchingPerState { counter = i }) _ _ =- if i <= 0 then Switch else Continue-- stepHalter (BranchAdjVarLookupLimit { var_switch_min = mi })- sps@(SwitchingPerState { switch_at = sa, counter = i }) _ xs- (State { curr_expr = CurrExpr Evaluate (Var _) }) =- let- new_sa = max mi (sa `div` length xs)- new_i = min (i - 1) new_sa- in- sps { switch_at = new_sa, counter = new_i}- stepHalter _ sps _ _ _ = sps----- Cutoff recursion after n recursive calls-data RecursiveCutOff = RecursiveCutOff Int--instance Halter RecursiveCutOff (HM.HashMap SpannedName Int) t where- initHalt _ _ = HM.empty- updatePerStateHalt _ hv _ _ = hv-- stopRed (RecursiveCutOff co) hv _ (State { curr_expr = CurrExpr _ (Var (Id n _)) }) =- case HM.lookup (SpannedName n) hv of- Just i- | i > co -> Discard- | otherwise -> Continue- Nothing -> Continue- stopRed _ _ _ _ = Continue-- stepHalter _ hv _ _ s@(State { curr_expr = CurrExpr _ (Var (Id n _)) })- | not $ E.isSymbolic n (expr_env s) =- case HM.lookup sn hv of- Just i -> HM.insert sn (i + 1) hv- Nothing -> HM.insert sn 1 hv- | otherwise = hv- where- sn = SpannedName n- stepHalter _ hv _ _ _ = hv---- | If the Name, disregarding the Unique, in the DiscardIfAcceptedTag--- matches a Tag in the Accepted State list,--- and in the State being evaluated, discard the State-data DiscardIfAcceptedTag = DiscardIfAcceptedTag Name --instance Halter DiscardIfAcceptedTag (S.HashSet Name) t where- initHalt _ _ = S.empty- - -- updatePerStateHalt gets the intersection of the accepted States Tags,- -- and the Tags of the State being evaluated.- -- Then, it filters further by the name in the Halter- updatePerStateHalt (DiscardIfAcceptedTag (Name n m _ _)) - _ - (Processed {accepted = acc})- (State {tags = ts}) =- let- allAccTags = S.unions $ map tags acc- matchCurrState = S.intersection ts allAccTags- in- S.filter (\(Name n' m' _ _) -> n == n' && m == m') matchCurrState-- stopRed _ ns _ _ =- if not (S.null ns) then Discard else Continue-- stepHalter _ hv _ _ _ = hv---- | Counts the number of variable lookups are made, and switches the state--- whenever we've hit a threshold--data VarLookupLimit = VarLookupLimit Int--instance Halter VarLookupLimit Int t where- initHalt (VarLookupLimit lim) _ = lim- updatePerStateHalt (VarLookupLimit lim) _ _ _ = lim- stopRed _ lim _ _ = if lim <= 0 then Switch else Continue-- stepHalter _ lim _ _ (State { curr_expr = CurrExpr Evaluate (Var _) }) = lim - 1- stepHalter _ lim _ _ _ = lim----- Orderer things-data OCombiner o1 o2 = o1 :<-> o2 deriving (Eq, Show, Read)--instance (Orderer or1 sov1 b1 t, Orderer or2 sov2 b2 t)- => Orderer (OCombiner or1 or2) (C sov1 sov2) (b1, b2) t where- - -- | Initializing the per state ordering value - -- initPerStateOrder :: or -> State t -> sov- initPerStateOrder (or1 :<-> or2) s =- let- sov1 = initPerStateOrder or1 s- sov2 = initPerStateOrder or2 s- in- C sov1 sov2-- -- | Assigns each state some value of an ordered type, and then proceeds with execution on the- -- state assigned the minimal value- -- orderStates :: or -> sov -> State t -> b- orderStates (or1 :<-> or2) (C sov1 sov2) s =- let- sov1' = orderStates or1 sov1 s- sov2' = orderStates or2 sov2 s- in- (sov1', sov2')-- -- | Run on the selected state, to update it's sov field- -- updateSelected :: or -> sov -> Processed (State t) -> State t -> sov- updateSelected (or1 :<-> or2) (C sov1 sov2) proc s = - let- sov1' = updateSelected or1 sov1 proc s- sov2' = updateSelected or2 sov2 proc s- in- C sov1' sov2'-- stepOrderer (or1 :<-> or2) (C sov1 sov2) proc xs s =- let- sov1' = stepOrderer or1 sov1 proc xs s- sov2' = stepOrderer or2 sov2 proc xs s- in- C sov1' sov2'---data NextOrderer = NextOrderer--instance Orderer NextOrderer () Int t where- initPerStateOrder _ _ = ()- orderStates _ _ _ = 0- updateSelected _ v _ _ = v---- | Continue execution on the state that has been picked the least in the past. -data PickLeastUsedOrderer = PickLeastUsedOrderer--instance Orderer PickLeastUsedOrderer Int Int t where- initPerStateOrder _ _ = 0- orderStates _ v _ = v- updateSelected _ v _ _ = v + 1---- | Floors and does bucket size-data BucketSizeOrderer = BucketSizeOrderer Int--instance Orderer BucketSizeOrderer Int Int t where- initPerStateOrder _ _ = 0-- orderStates (BucketSizeOrderer b) v _ = floor (fromIntegral v / fromIntegral b :: Float)-- updateSelected _ v _ _ = v + 1---- | Order by the number of PCs-data CaseCountOrderer = CaseCountOrderer--instance Orderer CaseCountOrderer Int Int t where- initPerStateOrder _ _ = 0-- orderStates _ v _ = v-- updateSelected _ v _ _ = v-- stepOrderer _ v _ _ (State { curr_expr = CurrExpr _ (Case _ _ _) }) = v + 1- stepOrderer _ v _ _ _ = v----- Orders by the smallest symbolic ADTs-data SymbolicADTOrderer = SymbolicADTOrderer--instance Orderer SymbolicADTOrderer (S.HashSet Name) Int t where- initPerStateOrder _ = S.fromList . map idName . symbolic_ids- orderStates _ v _ = S.size v-- updateSelected _ v _ _ = v-- stepOrderer _ v _ _ s =- v `S.union` (S.fromList . map idName . symbolic_ids $ s)---- Orders by the largest (in terms of height) (previously) symbolic ADT-data ADTHeightOrderer = ADTHeightOrderer--instance Orderer ADTHeightOrderer (S.HashSet Name) Int t where- initPerStateOrder _ = S.fromList . map idName . symbolic_ids- orderStates _ v s = maximum . S.toList $ S.map (flip adtHeight s) v-- updateSelected _ v _ _ = v-- -- stepOrderer _ v _ _ s =- -- v `S.union` (S.fromList . map idName . symbolic_ids $ s)--adtHeight :: Name -> State t -> Int-adtHeight n s@(State { expr_env = eenv })- | Just (E.Sym _) <- v = 0- | Just (E.Conc e) <- v =- 1 + adtHeight' e s- | otherwise = 0- where- v = E.lookupConcOrSym n eenv--adtHeight' :: Expr -> State t -> Int-adtHeight' e s =- let- _:es = unApp e - in- maximum $ map (\e' -> case e' of- Var (Id n _) -> adtHeight n s- _ -> 0) es---- Wraps an existing Orderer, and increases it's value by 1, every time--- it doesn't change after N steps -data IncrAfterN ord = IncrAfterN Int ord--data IncrAfterNTr sov = IncrAfterNTr { steps_since_change :: Int- , incr_by :: Int- , underlying :: sov }--instance (Eq sov, Enum b, Orderer ord sov b t) => Orderer (IncrAfterN ord) (IncrAfterNTr sov) b t where- initPerStateOrder (IncrAfterN _ ord) s =- IncrAfterNTr { steps_since_change = 0- , incr_by = 0- , underlying = initPerStateOrder ord s }- orderStates (IncrAfterN _ ord) sov s =- let- b = orderStates ord (underlying sov) s- in- succNTimes (incr_by sov) b- updateSelected (IncrAfterN _ ord) sov pr s =- sov { underlying = updateSelected ord (underlying sov) pr s }- stepOrderer (IncrAfterN ma ord) sov pr xs s- | steps_since_change sov >= ma =- sov' { incr_by = incr_by sov' + 1- , steps_since_change = 0 }- | under /= under' =- sov' { steps_since_change = 0 }- | otherwise =- sov' { steps_since_change = steps_since_change sov' + 1}- where- under = underlying sov- under' = stepOrderer ord under pr xs s- sov' = sov { underlying = under' }---succNTimes :: Enum b => Int -> b -> b-succNTimes x b- | x <= 0 = b- | otherwise = succNTimes (x - 1) (succ b)----------------------- | Uses a passed Reducer, Halter and Orderer to execute the reduce on the State, and generated States-runReducer :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) => r -> h -> or -> State t -> Bindings -> IO (Processed (State t), Bindings)-runReducer red hal ord s b = do- let pr = Processed {accepted = [], discarded = []}- let s' = ExState { state = s- , reducer_val = initReducer red s- , halter_val = initHalt hal s- , order_val = initPerStateOrder ord s }-- (states, b') <- runReducer' red hal ord pr s' b M.empty- let states' = mapProcessed state states- return (states', b')--runReducer' :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) - => r - -> h - -> or - -> Processed (ExState rv hv sov t) - -> ExState rv hv sov t - -> Bindings- -> M.Map b [ExState rv hv sov t] - -> IO (Processed (ExState rv hv sov t), Bindings)-runReducer' red hal ord pr rs@(ExState { state = s, reducer_val = r_val, halter_val = h_val, order_val = o_val }) b xs- | hc == Accept =- let- pr' = pr {accepted = rs:accepted pr}- jrs = minState xs- in- case jrs of- Just (rs', xs') -> do- switchState red hal ord pr' rs' b xs'- -- runReducer' red hal ord pr' (updateExStateHalter hal pr' rs') b xs'- Nothing -> return (pr', b)- | hc == Discard =- let- pr' = pr {discarded = rs:discarded pr}- jrs = minState xs- in- case jrs of- Just (rs', xs') ->- switchState red hal ord pr' rs' b xs'- -- runReducer' red hal ord pr' (updateExStateHalter hal pr' rs') b xs'- Nothing -> return (pr', b)- | hc == Switch =- let- k = orderStates ord (order_val rs') (state rs)- rs' = rs { order_val = updateSelected ord (order_val rs) ps (state rs) }-- Just (rs'', xs') = minState (M.insertWith (++) k [rs'] xs)- in- switchState red hal ord pr rs'' b xs'- -- if not $ discardOnStart hal (halter_val rs''') ps (state rs''')- -- then runReducer' red hal ord pr rs''' b xs'- -- else runReducerList red hal ord (pr {discarded = rs''':discarded pr}) xs' b- | otherwise = do- (_, reduceds, b', red') <- redRules red r_val s b- let reduceds' = map (\(r, rv) -> (r {num_steps = num_steps r + 1}, rv)) reduceds-- let r_vals = updateWithAll red reduceds' ++ error "List returned by updateWithAll is too short."- new_states = map fst reduceds'- - mod_info = map (\(s', r_val') ->- rs { state = s'- , reducer_val = r_val'- , halter_val = stepHalter hal h_val ps new_states s'- , order_val = stepOrderer ord o_val ps new_states s'}) $ zip new_states r_vals- - case mod_info of- (s_h:ss_tail) -> do- let xs' = foldr (\s' -> M.insertWith (++) (orderStates ord (order_val s') (state s')) [s']) xs ss_tail- runReducer' red' hal ord pr s_h b' xs'- [] -> runReducerList red' hal ord pr xs b' - where- hc = stopRed hal h_val ps s- ps = processedToState pr--switchState :: (Reducer r rv t, Halter h hv t, Orderer or sov b t)- => r- -> h- -> or- -> Processed (ExState rv hv sov t) - -> ExState rv hv sov t - -> Bindings- -> M.Map b [ExState rv hv sov t] - -> IO (Processed (ExState rv hv sov t), Bindings)-switchState red hal ord pr rs b xs- | not $ discardOnStart hal (halter_val rs') ps (state rs') =- runReducer' red hal ord pr rs' b xs- | otherwise =- runReducerListSwitching red hal ord (pr {discarded = rs':discarded pr}) xs b- where- ps = processedToState pr- rs' = rs { halter_val = updatePerStateHalt hal (halter_val rs) ps (state rs) }---- To be used when we we need to select a state without switching -runReducerList :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) - => r - -> h - -> or - -> Processed (ExState rv hv sov t)- -> M.Map b [ExState rv hv sov t]- -> Bindings- -> IO (Processed (ExState rv hv sov t), Bindings)-runReducerList red hal ord pr m binds =- case minState m of- Just (x, m') -> runReducer' red hal ord pr x binds m'- Nothing -> return (pr, binds)---- To be used when we are possibly switching states -runReducerListSwitching :: (Reducer r rv t, Halter h hv t, Orderer or sov b t) - => r - -> h - -> or - -> Processed (ExState rv hv sov t)- -> M.Map b [ExState rv hv sov t]- -> Bindings- -> IO (Processed (ExState rv hv sov t), Bindings)-runReducerListSwitching red hal ord pr m binds =- case minState m of- Just (x, m') -> switchState red hal ord pr x binds m'- Nothing -> return (pr, binds)--processedToState :: Processed (ExState rv hv sov t) -> Processed (State t)-processedToState (Processed {accepted = app, discarded = dis}) =- Processed {accepted = map state app, discarded = map state dis}---- Uses the Orderer to determine which state to continue execution on.--- Returns that State, and a list of the rest of the states -minState :: Ord b => M.Map b [ExState rv hv sov t] -> Maybe ((ExState rv hv sov t), M.Map b [ExState rv hv sov t])-minState m =- case M.minViewWithKey m of- Just ((k, x:xs), _) -> Just (x, M.insert k xs m)- Just ((_, []), m') -> minState m'- Nothing -> Nothing--numStates :: M.Map b [ExState rv hv sov t] -> Int-numStates = sum . map length . M.elems+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++{-| Module: G2.Execution.Reducer++Controls reduction of `State`s.++The `runReducer` function reduces States, guided by a `Reducer`, `Halter`, and `Orderer`.+The `Reducer` defines the reduction rules used to map a State to one or more further States.+The `Halter` determines when to accept (return) or completely discard a state,+and allows /temporarily/ stopping reduction of a particular state, to allow reduction of other states.+The `Orderer` determines which state should be executed next when the Halter chooses to accept, reject,+or switch to executing a different state.+-}+module G2.Execution.Reducer ( Reducer (..)++ , Halter (..)+ , InitHalter+ , UpdatePerStateHalt+ , StopRed+ , StepHalter++ , Orderer (..)+ , InitOrderer+ , OrderStates+ , UpdateSelected++ , Processed (..)+ , mapProcessed++ , ReducerRes (..)+ , HaltC (..)++ , SomeReducer (..)+ , SomeHalter (..)+ , SomeOrderer (..)++ -- * Reducers+ , InitReducer+ , RedRules+ , mkSimpleReducer+ , liftReducer+ , liftSomeReducer++ , stdRed+ , nonRedPCTemplates+ , nonRedPCRed+ , nonRedPCRedConst+ , taggerRed+ , getLogger+ , simpleLogger+ , prettyLogger+ , limLogger+ , LimLogger (..)++ , ReducerEq (..)+ , (.==)+ , (~>)+ , (.~>)+ , (-->)+ , (.-->)++ , (.|.)++ -- * Halters+ , mkSimpleHalter+ , liftHalter+ , liftSomeHalter++ , swhnfHalter+ , acceptIfViolatedHalter+ , (<~>)+ , zeroHalter+ , discardIfAcceptedTagHalter+ , maxOutputsHalter+ , switchEveryNHalter+ , varLookupLimitHalter+ , stdTimerHalter+ , timerHalter++ -- * Orderers+ , mkSimpleOrderer+ , (<->)+ , ordComb+ , nextOrderer+ , pickLeastUsedOrderer+ , bucketSizeOrderer+ , adtHeightOrderer+ , adtSizeOrderer+ , pcSizeOrderer+ , incrAfterN+ , quotTrueAssert++ -- * Execution+ , runReducer ) where++import G2.Config+import qualified G2.Language.ExprEnv as E+import G2.Execution.Rules+import G2.Language+import qualified G2.Language.Monad as MD+import qualified G2.Language.PathConds as PC+import qualified G2.Language.Stack as Stck+import G2.Solver+import G2.Lib.Printers++import Control.Monad.IO.Class+import qualified Control.Monad.State as SM+import Data.Foldable+import qualified Data.HashSet as HS+import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid ((<>))+import qualified Data.List as L+import qualified Data.Text as T+import Data.Tuple+import Data.Time.Clock+import System.Directory++-- | Used when applying execution rules+-- Allows tracking extra information to control halting of rule application,+-- and to reorder states+-- see also, the Reducer, Halter, Orderer typeclasses+-- cases is used for logging states+data ExState rv hv sov t = ExState { state :: State t+ , reducer_val :: rv+ , halter_val :: hv+ , order_val :: sov+ }++-- | Keeps track of type a's that have either been accepted or dropped+data Processed a = Processed { accepted :: [a]+ , discarded :: [a] }++mapProcessed :: (a -> b) -> Processed a -> Processed b+mapProcessed f pr = Processed { accepted = map f (accepted pr)+ , discarded = map f (discarded pr)}++-- | Used by Reducers to indicate their progress reducing.+data ReducerRes = NoProgress | InProgress | Finished deriving (Eq, Ord, Show, Read)++progPrioritizer :: ReducerRes -> ReducerRes -> ReducerRes+progPrioritizer InProgress _ = InProgress+progPrioritizer _ InProgress = InProgress+progPrioritizer Finished _ = Finished+progPrioritizer _ Finished = Finished+progPrioritizer _ _ = NoProgress++-- | Used by members of the Halter typeclass to control whether to continue+-- evaluating the current State, or switch to evaluating a new state.+data HaltC = Discard -- ^ Switch to evaluating a new state, and reject the current state+ | Accept -- ^ Switch to evaluating a new state, and accept the current state+ | Switch -- ^ Switch to evaluating a new state, but continue evaluating the current state later+ | Continue -- ^ Continue evaluating the current State+ deriving (Eq, Ord, Show, Read)++type InitReducer rv t = State t -> rv+type RedRules m rv t = rv -> State t -> Bindings -> m (ReducerRes, [(State t, rv)], Bindings)+++-- | A Reducer is used to define a set of Reduction Rules.+-- Reduction Rules take a `State`, and output new `State`s.+-- The reducer value, rv, can be used to track extra information, on a per `State` basis.+data Reducer m rv t = Reducer {+ -- | Initialized the reducer value+ initReducer :: InitReducer rv t++ -- | Takes a State, and performs the appropriate Reduction Rule+ , redRules :: RedRules m rv t++ -- | After a reducer returns multiple states,+ -- gives an opportunity to update with all States and Reducer values's,+ -- visible.+ -- Errors if the returned list is too short.+ -- If only one state is returned by all reducers, updateWithAll does not run.+ , updateWithAll :: [(State t, rv)] -> [rv]++ -- Action to run after a State is accepted.+ , onAccept :: State t -> rv -> m ()++ -- | Action to run after execution of all states has terminated.+ , afterRed :: m ()+ }++-- | A simple, default reducer.+-- `updateWithAll` does not change or adjust the reducer values.+-- `onAccept` immediately returns the empty tuple.+mkSimpleReducer :: Monad m => InitReducer rv t -> RedRules m rv t -> Reducer m rv t+mkSimpleReducer init_red red_rules =+ Reducer {+ initReducer = init_red+ , redRules = red_rules+ , updateWithAll = map snd+ , onAccept = \_ _ -> return ()+ , afterRed = return ()+ }+{-# INLINE mkSimpleReducer #-}++-- | Lift a reducer from a component monad to a constructed monad. +liftReducer :: (Monad m1, SM.MonadTrans m2) => Reducer m1 rv t -> Reducer (m2 m1) rv t+liftReducer r = Reducer { initReducer = initReducer r+ , redRules = \rv s b -> SM.lift ((redRules r) rv s b)+ , updateWithAll = updateWithAll r+ , onAccept = \s rv -> SM.lift ((onAccept r) s rv)+ , afterRed = SM.lift (afterRed r)}++-- | Lift a SomeReducer from a component monad to a constructed monad. +liftSomeReducer :: (Monad m1, SM.MonadTrans m2) => SomeReducer m1 t -> SomeReducer (m2 m1) t+liftSomeReducer (SomeReducer r) = SomeReducer (liftReducer r)++type InitHalter hv t = State t -> hv+type UpdatePerStateHalt hv t = hv -> Processed (State t) -> State t -> hv+type StopRed m hv t = hv -> Processed (State t) -> State t -> m HaltC+type StepHalter hv t = hv -> Processed (State t) -> [State t] -> State t -> hv++-- | Determines when to stop evaluating a state+-- The halter value, hv, can be used to track extra information, on a per `State` basis.+data Halter m hv t = Halter {+ -- | Initializes each state halter value+ initHalt :: InitHalter hv t++ -- | Runs whenever we switch to evaluating a different state,+ -- to update the halter value of that new state+ , updatePerStateHalt :: UpdatePerStateHalt hv t++ -- | Runs when we start execution on a state, immediately after+ -- `updatePerStateHalt`. Allows a State to be discarded right+ -- before execution is about to (re-)begin.+ -- Return True if execution should proceed, False to discard+ , discardOnStart :: hv -> Processed (State t) -> State t -> Bool++ -- | Determines whether to continue reduction on the current state+ , stopRed :: StopRed m hv t++ -- | Takes a state, and updates its halter record field+ , stepHalter :: StepHalter hv t++ -- | After multiple states, are returned+ -- gives an opportunity to update halters with all States and halter values visible.+ -- Errors if the returned list is too short.+ -- If only one state is returned, updateHalterWithAll does not run.+ , updateHalterWithAll :: [(State t, hv)] -> [hv]+ }++-- | A simple, default halter.+mkSimpleHalter :: Monad m => InitHalter hv t -> UpdatePerStateHalt hv t -> StopRed m hv t -> StepHalter hv t -> Halter m hv t+mkSimpleHalter initial update stop step = Halter { initHalt = initial+ , updatePerStateHalt = update+ , discardOnStart = \_ _ _ -> False+ , stopRed = stop+ , stepHalter = step+ , updateHalterWithAll = map snd }+{-# INLINE mkSimpleHalter #-}++-- | Lift a halter from a component monad to a constructed monad. +liftHalter :: (Monad m1, SM.MonadTrans m2) => Halter m1 rv t -> Halter (m2 m1) rv t+liftHalter h = Halter { initHalt = initHalt h+ , updatePerStateHalt = updatePerStateHalt h+ , discardOnStart = discardOnStart h+ , stopRed = \hv pr s -> SM.lift ((stopRed h) hv pr s)+ , stepHalter = stepHalter h+ , updateHalterWithAll = updateHalterWithAll h }++-- | Lift a SomeHalter from a component monad to a constructed monad. +liftSomeHalter :: (Monad m1, SM.MonadTrans m2) => SomeHalter m1 t -> SomeHalter (m2 m1) t+liftSomeHalter (SomeHalter r) = SomeHalter (liftHalter r)++{-# INLINE mkStoppingHalter #-}+mkStoppingHalter :: Monad m => StopRed m () t -> Halter m () t+mkStoppingHalter stop =+ mkSimpleHalter+ (const ())+ (\_ _ _ -> ())+ stop+ (\_ _ _ _ -> ())++type InitOrderer sov t = State t -> sov+type OrderStates m sov b t = sov -> Processed (State t) -> State t -> m b+type UpdateSelected sov t = sov -> Processed (State t) -> State t -> sov++-- | Picks an order to evaluate the states, to allow prioritizing some over others.+-- The orderer value, sov, can be used to track extra information, on a per `State` basis.+-- The ordering type b, is used to determine what order to execute the states in.+-- In practice, `b` must be an instance of `Ord`. When the orderer is called, the `State` corresponding+-- to the minimal `b` is executed.+data Orderer m sov b t = Orderer {+ -- | Initializing the per state ordering value + initPerStateOrder :: InitOrderer sov t++ -- | Assigns each state some value of an ordered type, and then proceeds with execution on the+ -- state assigned the minimal value+ , orderStates :: OrderStates m sov b t++ -- | Run on the selected state, to update it's sov field+ , updateSelected :: UpdateSelected sov t++ -- | Run on the state at each step, to update it's sov field+ , stepOrderer :: sov -> Processed (State t) -> [State t] -> State t -> m sov+ }++-- | A simple, default orderer.+mkSimpleOrderer :: Monad m => InitOrderer sov t -> OrderStates m sov b t -> UpdateSelected sov t -> Orderer m sov b t+mkSimpleOrderer initial order update = Orderer { initPerStateOrder = initial+ , orderStates = order+ , updateSelected = update+ , stepOrderer = \sov _ _ _ -> return sov}++getState :: M.Map b [s] -> Maybe (b, [s])+getState = M.lookupMin++-- | Hide the details of a Reducer's reducer value.+data SomeReducer m t where+ SomeReducer :: forall m rv t . Reducer m rv t -> SomeReducer m t++-- | Hide the details of a Halter's halter value.+data SomeHalter m t where+ SomeHalter :: forall m hv t . Halter m hv t -> SomeHalter m t++-- | Hide the details of an Orderer's orderer value and ordering type.+data SomeOrderer m t where+ SomeOrderer :: forall m sov b t . Ord b => Orderer m sov b t -> SomeOrderer m t+++-- Combines multiple reducers together into a single reducer.++-- We use RC to combine the reducer values for RCombiner+-- We should never define any other instance of Reducer with RC, or export it+-- because this could lead to undecidable instances+data RC a b = RC a b++-- | Check if a `Reducer` returns some specific `ReducerRes`+data ReducerEq m t where+ (:==) :: forall m rv t . Reducer m rv t -> ReducerRes -> ReducerEq m t++(.==) :: SomeReducer m t -> ReducerRes -> ReducerEq m t+SomeReducer r .== res = r :== res++infixr 8 .==++infixr 7 ~>, .~>++infixr 5 -->, .-->++-- | @r1 ~> r2@ applies `Reducer` `r1`, followed by reducer `r2`. +(~>) :: Monad m => Reducer m rv1 t -> Reducer m rv2 t -> Reducer m (RC rv1 rv2) t+r1 ~> r2 =+ Reducer { initReducer = \s -> RC (initReducer r1 s) (initReducer r2 s)++ , redRules = \(RC rv1 rv2) s b -> do+ (rr1, srv1, b') <- redRules r1 rv1 s b+ (rr2, srv2, b'') <- redRulesToStates r2 rv2 srv1 b'++ return (progPrioritizer rr1 rr2, srv2, b'')++ , updateWithAll = updateWithAllPair (updateWithAll r1) (updateWithAll r2)++ , onAccept = \s (RC rv1 rv2) -> do+ onAccept r1 s rv1+ onAccept r2 s rv2++ , afterRed = do+ afterRed r1+ afterRed r2++ }+{-# INLINE (~>) #-}++-- | `~>` adjusted to work on `SomeReducer`s, rather than `Reducer`s.+(.~>) :: Monad m => SomeReducer m t -> SomeReducer m t -> SomeReducer m t+SomeReducer r1 .~> SomeReducer r2 = SomeReducer (r1 ~> r2)+{-# INLINE (.~>) #-}++-- | @r1 := res --> r2@ applies `Reducer` `r1`. If `r1` returns the `ReducerRes` `res`,+-- then `Reducer` `r2` is applied. Otherwise, reduction halts. +(-->) :: Monad m => ReducerEq m t -> Reducer m rv2 t -> SomeReducer m t+(r1 :== res) --> r2 =+ SomeReducer $+ Reducer { initReducer = \s -> RC (initReducer r1 s) (initReducer r2 s)++ , redRules = \(RC rv1 rv2) s b -> do+ (rr1, srv1, b') <- redRules r1 rv1 s b+ let (s', rv1') = unzip srv1++ case rr1 == res of+ True -> do+ (rr2, ss, b'') <- redRulesToStates r2 rv2 srv1 b'+ return (rr2, ss, b'')+ False -> return (rr1, zip s' (map (flip RC rv2) rv1'), b')++ , updateWithAll = updateWithAllPair (updateWithAll r1) (updateWithAll r2)++ , onAccept = \s (RC rv1 rv2) -> do+ onAccept r1 s rv1+ onAccept r2 s rv2++ , afterRed = do+ afterRed r1+ afterRed r2+ }+{-# INLINE (-->) #-}++-- | `.-->` adjusted to take a `SomeReducer`, rather than a `Reducer`s.+(.-->) :: Monad m => ReducerEq m t -> SomeReducer m t -> SomeReducer m t+req .--> SomeReducer r = req --> r++redRulesToStatesAux :: Monad m => Reducer m rv2 t -> rv2 -> Bindings -> (State t, rv1) -> m (Bindings, (ReducerRes, [(State t, RC rv1 rv2)]))+redRulesToStatesAux r rv2 b (is, rv1) = do+ (rr_, is', b') <- redRules r rv2 is b+ return (b', (rr_, map (\(is'', rv2') -> (is'', RC rv1 rv2') ) is'))++redRulesToStates :: Monad m => Reducer m rv2 t -> rv2 -> [(State t, rv1)] -> Bindings -> m (ReducerRes, [(State t, RC rv1 rv2)], Bindings)+redRulesToStates r rv1 s b = do+ let redRulesToStatesAux' = redRulesToStatesAux r rv1+ (b', rs) <- MD.mapMAccumB redRulesToStatesAux' b s++ let (rr, s') = L.unzip rs++ let rf = foldr progPrioritizer NoProgress rr++ return $ (rf, concat s', b')++-- | @r1 .|. r2@ applies both Reducer r1 and Reducer r2 to the \inital\ state passed to the reducer,+-- and returns the list of states returned from both reducers combined.+-- Care should be taken to avoid unwanted duplication of states if, for example, neither of the reducers+-- makes progress.+(.|.) :: Monad m => Reducer m rv1 t -> Reducer m rv2 t -> Reducer m (RC rv1 rv2) t+r1 .|. r2 =+ Reducer { initReducer = \s -> RC (initReducer r1 s) (initReducer r2 s)++ , redRules = \(RC rv1 rv2) s b -> do+ (rr2, srv2, b') <- redRules r2 rv2 s b+ (rr1, srv1, b'') <- redRules r1 rv1 s b'++ let srv2' = map (\(s_, rv2_) -> (s_, RC rv1 rv2_) ) srv2+ srv1' = map (\(s_, rv1_) -> (s_, RC rv1_ rv2) ) srv1++ return (progPrioritizer rr1 rr2, srv2' ++ srv1', b'')++ , updateWithAll = updateWithAllPair (updateWithAll r1) (updateWithAll r2)++ , onAccept = \s (RC rv1 rv2) -> do+ onAccept r1 s rv1+ onAccept r2 s rv2++ , afterRed = do+ afterRed r1+ afterRed r2++ }+{-# INLINE (.|.) #-}++updateWithAllPair :: ([(State t, rv1)] -> [rv1]) -> ([(State t, rv2)] -> [rv2]) -> [(State t, RC rv1 rv2)] -> [RC rv1 rv2]+updateWithAllPair update1 update2 srv =+ let+ srv1 = map (\(s, RC rv1 _) -> (s, rv1)) srv+ srv2 = map (\(s, RC _ rv2) -> (s, rv2)) srv++ rv1' = update1 srv1+ rv2' = update2 srv2+ in+ map (uncurry RC) $ zip rv1' rv2'++{-#INLINE stdRed #-}+{-# SPECIALIZE stdRed :: (Solver solver, Simplifier simplifier) => Sharing -> SymbolicFuncEval t -> solver -> simplifier -> Reducer IO () t #-}+stdRed :: (MonadIO m, Solver solver, Simplifier simplifier) => Sharing -> SymbolicFuncEval t -> solver -> simplifier -> Reducer m () t+stdRed share symb_func_eval solver simplifier =+ mkSimpleReducer (\_ -> ())+ (\_ s b -> do+ (r, s', b') <- liftIO $ stdReduce share symb_func_eval solver simplifier s b++ return (if r == RuleIdentity then Finished else InProgress, s', b')+ )++-- | Pushes non_red_path_conds onto the exec_stack for solving higher order symbolic function +nonRedPCTemplates :: Monad m => Reducer m () t+nonRedPCTemplates = mkSimpleReducer (\_ -> ())+ nonRedPCTemplatesFunc++nonRedPCTemplatesFunc :: Monad m => RedRules m () t+nonRedPCTemplatesFunc _+ s@(State { expr_env = eenv+ , curr_expr = cexpr+ , exec_stack = stck+ , non_red_path_conds = (nre1, nre2):nrs+ , model = m })+ b@(Bindings { name_gen = ng }) =+ + let+ stck' = Stck.push (CurrExprFrame (EnsureEq nre2) cexpr) stck+ s' = s { exec_stack = stck', non_red_path_conds = nrs }+ in+ case retReplaceSymbFuncTemplate s' ng nre1 of+ Just (r, s'', ng') -> return (InProgress, zip s'' (repeat ()), b {name_gen = ng'})+ Nothing ->+ let + s'' = s' {curr_expr = CurrExpr Evaluate nre1}+ in return (InProgress, [(s'', ())], b)+nonRedPCTemplatesFunc _ s b = return (Finished, [(s, ())], b)++-- | Removes and reduces the values in a State's non_red_path_conds field. +{-#INLINE nonRedPCRed #-}+nonRedPCRed :: Monad m => Reducer m () t+nonRedPCRed = mkSimpleReducer (\_ -> ())+ nonRedPCRedFunc++nonRedPCRedFunc :: Monad m => RedRules m () t+nonRedPCRedFunc _+ s@(State { expr_env = eenv+ , curr_expr = cexpr+ , exec_stack = stck+ , non_red_path_conds = (nre1, nre2):nrs+ , model = m })+ b@(Bindings { higher_order_inst = inst })+ | Var (Id n t) <- nre2+ , E.isSymbolic n eenv+ , hasFuncType (PresType t) =+ let+ s' = s { expr_env = E.insert n nre1 eenv+ , non_red_path_conds = nrs }+ in+ return (InProgress, [(s', ())], b)+ | Var (Id n t) <- nre1+ , E.isSymbolic n eenv+ , hasFuncType (PresType t) =+ let+ s' = s { expr_env = E.insert n nre2 eenv+ , non_red_path_conds = nrs }+ in+ return (InProgress, [(s', ())], b)+ | otherwise = do+ let stck' = Stck.push (CurrExprFrame (EnsureEq nre2) cexpr) stck++ let cexpr' = CurrExpr Evaluate nre1++ let eenv_si_ces = substHigherOrder eenv m inst cexpr'++ let s' = s { exec_stack = stck'+ , non_red_path_conds = nrs+ }+ xs = map (\(eenv', m', ce) -> (s' { expr_env = eenv'+ , model = m'+ , curr_expr = ce }, ())) eenv_si_ces++ return (InProgress, xs, b)+nonRedPCRedFunc _ s b = return (Finished, [(s, ())], b)++-- [Higher-Order Model]+-- Substitutes all possible higher order functions for symbolic higher order functions.+-- We insert the substituted higher order function directly into the model, because, due+-- to the VAR-RED rule, the function name will (if the function is called) be lost during execution.+substHigherOrder :: ExprEnv -> Model -> HS.HashSet Name -> CurrExpr -> [(ExprEnv, Model, CurrExpr)]+substHigherOrder eenv m ns ce =+ let+ is = mapMaybe (\n -> case E.lookup n eenv of+ Just e -> Just $ Id n (typeOf e)+ Nothing -> Nothing) $ HS.toList ns++ higherOrd = filter (isTyFun . typeOf) . symbVars eenv $ ce+ higherOrdSub = map (\v -> (v, mapMaybe (genSubstitutable v) is)) higherOrd+ in+ substHigherOrder' [(eenv, m, ce)] higherOrdSub+ where+ genSubstitutable v i+ | Just bm <- specializes (typeOf v) (typeOf i) =+ let+ bnds = map idName $ leadingTyForAllBindings i+ tys = mapMaybe (\b -> fmap Type $ M.lookup b bm) bnds+ in+ Just . mkApp $ Var i:tys+ | otherwise = Nothing++substHigherOrder' :: [(ExprEnv, Model, CurrExpr)] -> [(Id, [Expr])] -> [(ExprEnv, Model, CurrExpr)]+substHigherOrder' eenvsice [] = eenvsice+substHigherOrder' eenvsice ((i, es):iss) =+ substHigherOrder'+ (concatMap (\e_rep ->+ map (\(eenv, m, ce) -> ( E.insert (idName i) e_rep eenv+ , HM.insert (idName i) e_rep m+ , replaceASTs (Var i) e_rep ce)+ ) eenvsice)+ es) iss++-- | Removes and reduces the values in a State's non_red_path_conds field+-- by instantiating higher order functions to be constant.+-- Does not return any states if the state does not contain at least one+-- higher order symbolic variable.+nonRedPCRedConst :: Monad m => Reducer m () t+nonRedPCRedConst = mkSimpleReducer (\_ -> ())+ nonRedPCRedConstFunc++nonRedPCRedConstFunc :: Monad m => RedRules m () t+nonRedPCRedConstFunc _+ s@(State { expr_env = eenv+ , curr_expr = cexpr+ , exec_stack = stck+ , non_red_path_conds = (nre1, nre2):nrs+ , model = m })+ b@(Bindings { name_gen = ng })+ | higher_ord <- L.filter (isTyFun . typeOf) $ E.symbolicIds eenv+ , not (null higher_ord) = do+ let stck' = Stck.push (CurrExprFrame (EnsureEq nre2) cexpr) stck++ let cexpr' = CurrExpr Evaluate nre1++ let (ng', new_lam_is) = L.mapAccumL (\ng_ ts -> swap $ freshIds ts ng_) ng (map anonArgumentTypes higher_ord)+ (new_sym_gen, ng'') = freshIds (map returnType higher_ord) ng'++ es = map (\(f_id, lam_i, sg_i) -> (f_id, mkLams (zip (repeat TermL) lam_i) (Var sg_i)) )+ $ zip3 higher_ord new_lam_is new_sym_gen++ eenv' = foldr (uncurry E.insert) eenv (map (\(i, e) -> (idName i, e)) es)+ eenv'' = foldr E.insertSymbolic eenv' new_sym_gen+ m' = foldr (\(i, e) -> HM.insert (idName i) e) m es++ let s' = s { expr_env = eenv''+ , curr_expr = cexpr'+ , model = m'+ , exec_stack = stck'+ , non_red_path_conds = nrs+ }++ return (InProgress, [(s', ())], b { name_gen = ng'' })+nonRedPCRedConstFunc _ s b = return (Finished, [], b)++{-# INLINE taggerRed #-}+taggerRed :: Monad m => Name -> Reducer m () t+taggerRed n = mkSimpleReducer (const ()) (taggerRedStep n)++taggerRedStep :: Monad m => Name -> RedRules m () t+taggerRedStep n _ s@(State {tags = ts}) b@(Bindings { name_gen = ng }) =+ let+ (n'@(Name n_ m_ _ _), ng') = freshSeededName n ng+ in+ if null $ HS.filter (\(Name n__ m__ _ _) -> n_ == n__ && m_ == m__) ts then+ return (Finished, [(s {tags = HS.insert n' ts}, ())], b { name_gen = ng' })+ else+ return (Finished, [(s, ())], b)+++getLogger :: (MonadIO m, SM.MonadState PrettyGuide m, Show t) => Config -> Maybe (Reducer m [Int] t)+getLogger config = case logStates config of+ Log Raw fp -> Just (simpleLogger fp)+ Log Pretty fp -> Just (prettyLogger fp)+ NoLog -> Nothing++-- | A Reducer to producer logging output +simpleLogger :: (MonadIO m, Show t) => FilePath -> Reducer m [Int] t+simpleLogger fn =+ (mkSimpleReducer (const [])+ (\li s b -> do+ liftIO $ outputState fn li s b pprExecStateStr+ return (NoProgress, [(s, li)], b) ))+ { updateWithAll = \s -> map (\(l, i) -> l ++ [i]) $ zip (map snd s) [1..] }++-- | A Reducer to producer logging output +prettyLogger :: (MonadIO m, SM.MonadState PrettyGuide m, Show t) => FilePath -> Reducer m [Int] t+prettyLogger fp =+ (mkSimpleReducer+ (const [])+ (\li s b -> do+ pg <- SM.get+ let pg' = updatePrettyGuide (s { track = () }) pg+ SM.put pg'+ liftIO $ outputState fp li s b (\s_ _ -> T.unpack $ prettyState pg' s_)+ return (NoProgress, [(s, li)], b)+ )+ ) { updateWithAll = \s -> map (\(l, i) -> l ++ [i]) $ zip (map snd s) [1..]+ , onAccept = \_ ll -> liftIO . putStrLn $ "Accepted on path " ++ show ll }++-- | A Reducer to producer limited logging output.+data LimLogger =+ LimLogger { every_n :: Int -- Output a state every n steps+ , after_n :: Int -- Only begin outputting after passing a certain n+ , before_n :: Maybe Int -- Only output before a certain n+ , down_path :: [Int] -- Output states that have gone down or are going down the given path prefix+ , lim_output_path :: String+ }++data LLTracker = LLTracker { ll_count :: Int, ll_offset :: [Int]}++limLogger :: (MonadIO m, Show t) => LimLogger -> Reducer m LLTracker t+limLogger ll@(LimLogger { after_n = aft, before_n = bfr, down_path = down }) =+ (mkSimpleReducer (const $ LLTracker { ll_count = every_n ll, ll_offset = []}) rr)+ { updateWithAll = updateWithAllLL+ , onAccept = \_ llt -> liftIO . putStrLn $ "Accepted on path " ++ show (ll_offset llt)}+ where+ rr llt@(LLTracker { ll_count = 0, ll_offset = off }) s b+ | down `L.isPrefixOf` off || off `L.isPrefixOf` down+ , aft <= length_rules && maybe True (length_rules <=) bfr = do+ liftIO $ outputState (lim_output_path ll) off s b pprExecStateStr+ return (NoProgress, [(s, llt { ll_count = every_n ll })], b)+ | otherwise =+ return (NoProgress, [(s, llt { ll_count = every_n ll })], b)+ where+ length_rules = length (rules s)+ rr llt@(LLTracker {ll_count = n}) s b =+ return (NoProgress, [(s, llt { ll_count = n - 1 })], b)++ updateWithAllLL [(_, l)] = [l]+ updateWithAllLL ss =+ map (\(llt, i) -> llt { ll_offset = ll_offset llt ++ [i] }) $ zip (map snd ss) [1..]++outputState :: FilePath -> [Int] -> State t -> Bindings -> (State t -> Bindings -> String) -> IO ()+outputState dn is s b printer = do+ fn <- getFile dn is "state" s++ -- Don't re-output states that already exist+ exists <- doesPathExist fn++ if not exists+ then do+ let write = printer s b+ writeFile fn write++ putStrLn fn+ else return ()++getFile :: String -> [Int] -> String -> State t -> IO String+getFile dn is n s = do+ let dir = dn ++ "/" ++ foldl' (\str i -> str ++ show i ++ "/") "" is+ createDirectoryIfMissing True dir+ let fn = dir ++ n ++ show (length $ rules s) ++ ".txt"+ return fn++-- We use C to combine the halter values for HCombiner+-- We should never define any other instance of Halter with C, or export it+-- because this could lead to undecidable instances+data C a b = C a b deriving Eq++instance (ASTContainer a Expr, ASTContainer b Expr) => ASTContainer (C a b) Expr where+ containedASTs (C a b) = containedASTs a ++ containedASTs b+ modifyContainedASTs f (C a b) = C (modifyContainedASTs f a) (modifyContainedASTs f b)++instance (ASTContainer a Type, ASTContainer b Type) => ASTContainer (C a b) Type where+ containedASTs (C a b) = containedASTs a ++ containedASTs b+ modifyContainedASTs f (C a b) = C (modifyContainedASTs f a) (modifyContainedASTs f b)++instance (Named a, Named b) => Named (C a b) where+ names (C a b) = names a <> names b+ rename old new (C a b) = C (rename old new a) (rename old new b)+ renames hm (C a b) = C (renames hm a) (renames hm b)++-- | Allows executing multiple halters.+-- If the halters disagree, prioritizes the order:+-- Discard, Accept, Switch, Continue+(<~>) :: Monad m => Halter m hv1 t -> Halter m hv2 t -> Halter m (C hv1 hv2) t+h1 <~> h2 =+ Halter {+ initHalt = \s ->+ let+ hv1 = initHalt h1 s+ hv2 = initHalt h2 s+ in+ C hv1 hv2++ , updatePerStateHalt = \(C hv1 hv2) proc s ->+ let+ hv1' = updatePerStateHalt h1 hv1 proc s+ hv2' = updatePerStateHalt h2 hv2 proc s+ in+ C hv1' hv2'++ , discardOnStart = \(C hv1 hv2) proc s ->+ let+ b1 = discardOnStart h1 hv1 proc s+ b2 = discardOnStart h2 hv2 proc s+ in+ b1 || b2++ , stopRed = \(C hv1 hv2) proc s -> do+ hc1 <- stopRed h1 hv1 proc s+ hc2 <- stopRed h2 hv2 proc s++ return $ min hc1 hc2++ , stepHalter = \(C hv1 hv2) proc xs s ->+ let+ hv1' = stepHalter h1 hv1 proc xs s+ hv2' = stepHalter h2 hv2 proc xs s+ in+ C hv1' hv2'++ , updateHalterWithAll = \shv ->+ let+ shv1 = map (\(s, C hv1 _) -> (s, hv1)) shv+ shv2 = map (\(s, C _ hv2) -> (s, hv2)) shv++ shv1' = updateHalterWithAll h1 shv1+ shv2' = updateHalterWithAll h2 shv2+ in+ map (uncurry C) $ zip shv1' shv2'+ }+{-# INLINE (<~>) #-}++{-# INLINE swhnfHalter #-}+swhnfHalter :: Monad m => Halter m () t+swhnfHalter = mkStoppingHalter stop+ where+ stop _ _ s =+ case isExecValueForm s of+ True -> return Accept+ False -> return Continue++-- | Accepts a state when it is in SWHNF and true_assert is true+-- Discards it if in SWHNF and true_assert is false+acceptIfViolatedHalter :: Monad m => Halter m () t+acceptIfViolatedHalter = mkStoppingHalter stop+ where+ stop _ _ s =+ case isExecValueForm s of+ True+ | true_assert s -> return Accept+ | otherwise -> return Discard+ False -> return Continue++-- | Allows execution to continue until the step counter hits 0, then discards the state+zeroHalter :: Monad m => Int -> Halter m Int t+zeroHalter n = mkSimpleHalter+ (const n)+ (\h _ _ -> h)+ (\h _ _ -> if h == 0 then return Discard else return Continue)+ (\h _ _ _ -> h - 1)++maxOutputsHalter :: Monad m => Maybe Int -> Halter m (Maybe Int) t+maxOutputsHalter m = mkSimpleHalter+ (const m)+ (\hv _ _ -> hv)+ (\_ (Processed {accepted = acc}) _ ->+ case m of+ Just m' -> return $ if length acc >= m' then Discard else Continue+ _ -> return Continue)+ (\hv _ _ _ -> hv)++-- | Switch execution every n steps+{-# INLINE switchEveryNHalter #-}+switchEveryNHalter :: Monad m => Int -> Halter m Int t+switchEveryNHalter sw = (mkSimpleHalter+ (const sw)+ (\_ _ _ -> sw)+ (\i _ _ -> return $ if i <= 0 then Switch else Continue)+ (\i _ _ _ -> i - 1))+ { updateHalterWithAll = updateAll }+ where+ updateAll [] = []+ updateAll xs@((_, c):_) =+ let+ len = length xs+ c' = c `quot` len+ in+ replicate len c'++-- | If the Name, disregarding the Unique, in the DiscardIfAcceptedTag+-- matches a Tag in the Accepted State list,+-- and in the State being evaluated, discard the State+discardIfAcceptedTagHalter :: Monad m => Name -> Halter m (HS.HashSet Name) t+discardIfAcceptedTagHalter (Name n m _ _) =+ mkSimpleHalter+ (const HS.empty)+ ups+ (\ns _ _ -> return $ if not (HS.null ns) then Discard else Continue)+ (\hv _ _ _ -> hv)+ where+ ups _+ (Processed {accepted = acc})+ (State {tags = ts}) =+ let+ allAccTags = HS.unions $ map tags acc+ matchCurrState = HS.intersection ts allAccTags+ in+ HS.filter (\(Name n' m' _ _) -> n == n' && m == m') matchCurrState++-- | Counts the number of variable lookups are made, and switches the state+-- whenever we've hit a threshold+varLookupLimitHalter :: Monad m => Int -> Halter m Int t+varLookupLimitHalter lim = mkSimpleHalter+ (const lim)+ (\_ _ _ -> lim)+ (\l _ _ -> return $ if l <= 0 then Switch else Continue)+ step+ where+ step l _ _ (State { curr_expr = CurrExpr Evaluate (Var _) }) = l - 1+ step l _ _ _ = l++{-# INLINE stdTimerHalter #-}+stdTimerHalter :: (MonadIO m, MonadIO m_run) => NominalDiffTime -> m (Halter m_run Int t)+stdTimerHalter ms = timerHalter ms Discard 10++{-# INLINE timerHalter #-}+timerHalter :: (MonadIO m, MonadIO m_run) => NominalDiffTime -> HaltC -> Int -> m (Halter m_run Int t)+timerHalter ms def ce = do+ curr <- liftIO $ getCurrentTime+ return $ mkSimpleHalter+ (const 0)+ (\_ _ _ -> 0)+ (stop curr)+ step+ where+ stop it v (Processed { accepted = acc }) _+ | v == 0+ , not (null acc) = do+ curr <- liftIO $ getCurrentTime+ let diff = diffUTCTime curr it++ if diff > ms+ then return def+ else return Continue+ | otherwise = return Continue++ step v _ _ _+ | v >= ce = 0+ | otherwise = v + 1++-- Orderer things+(<->) :: Monad m => Orderer m sov1 b1 t -> Orderer m sov2 b2 t -> Orderer m (C sov1 sov2) (b1, b2) t+or1 <-> or2 = Orderer {+ initPerStateOrder = \s ->+ let+ sov1 = initPerStateOrder or1 s+ sov2 = initPerStateOrder or2 s+ in+ C sov1 sov2++ , orderStates = \(C sov1 sov2) pr s -> do+ sov1' <- orderStates or1 sov1 pr s+ sov2' <- orderStates or2 sov2 pr s+ return (sov1', sov2')++ , updateSelected = \(C sov1 sov2) proc s ->+ let+ sov1' = updateSelected or1 sov1 proc s+ sov2' = updateSelected or2 sov2 proc s+ in+ C sov1' sov2'++ , stepOrderer = \(C sov1 sov2) proc xs s -> do+ sov1' <- stepOrderer or1 sov1 proc xs s+ sov2' <- stepOrderer or2 sov2 proc xs s+ + return (C sov1' sov2')+ }++ordComb :: Monad m => (v1 -> v2 -> v3) -> Orderer m sov1 v1 t -> Orderer m sov2 v2 t -> Orderer m (C sov1 sov2) v3 t+ordComb f or1 or2 = Orderer {+ initPerStateOrder = \s ->+ let+ sov1 = initPerStateOrder or1 s+ sov2 = initPerStateOrder or2 s+ in+ C sov1 sov2++ , orderStates = \(C sov1 sov2) pr s -> do+ sov1' <- orderStates or1 sov1 pr s+ sov2' <- orderStates or2 sov2 pr s+ return (f sov1' sov2')++ , updateSelected = \(C sov1 sov2) proc s ->+ let+ sov1' = updateSelected or1 sov1 proc s+ sov2' = updateSelected or2 sov2 proc s+ in+ C sov1' sov2'++ , stepOrderer = \(C sov1 sov2) proc xs s -> do+ sov1' <- stepOrderer or1 sov1 proc xs s+ sov2' <- stepOrderer or2 sov2 proc xs s+ return (C sov1' sov2')+ }++nextOrderer :: Monad m => Orderer m () Int t+nextOrderer = mkSimpleOrderer (const ()) (\_ _ _ -> return 0) (\v _ _ -> v)++-- | Continue execution on the state that has been picked the least in the past. +pickLeastUsedOrderer :: Monad m => Orderer m Int Int t+pickLeastUsedOrderer = mkSimpleOrderer (const 0) (\v _ _ -> return v) (\v _ _ -> v + 1)++-- | Floors and does bucket size+bucketSizeOrderer :: Monad m => Int -> Orderer m Int Int t+bucketSizeOrderer b =+ mkSimpleOrderer (const 0)+ (\v _ _ -> return $ floor (fromIntegral v / fromIntegral b :: Float))+ (\v _ _ -> v + 1)++-- | Orders by the size (in terms of height) of (previously) symbolic ADT.+-- In particular, aims to first execute those states with a height closest to+-- the specified height.+adtHeightOrderer :: Monad m => Int -> Maybe Name -> Orderer m (HS.HashSet Name, Bool) Int t+adtHeightOrderer pref_height mn =+ (mkSimpleOrderer initial+ order+ (\v _ _ -> v))+ { stepOrderer = \sov pr st s -> return $ step sov pr st s }+ where+ -- Normally, each state tracks the names of currently symbolic variables,+ -- but here we want all variables that were ever symbolic.+ -- To track this, we use a HashSet.+ -- The tracked bool is to speed up adjusting this hashset- if it is set to false,+ -- we do not update the hashset. If it is set to true,+ -- after the next step the hashset will be updated, and the bool will be set+ -- back to false.+ -- This avoids repeated operations on the hashset after rules that we know+ -- will not add symbolic variables.+ initial s = (HS.fromList . map idName . E.symbolicIds . expr_env $ s, False)+ order (v, _) _ s =+ let+ m = maximum $ (-1):(HS.toList $ HS.map (flip adtHeight s) v)+ h = abs (pref_height - m)+ in+ return h++ step (v, _) _ _+ (State { curr_expr = CurrExpr _ (SymGen _ _) }) = (v, True)+ step(v, True) _ _ s =+ (v `HS.union` (HS.fromList . map idName . E.symbolicIds . expr_env $ s), False)+ step (v, _) _ _+ (State { curr_expr = CurrExpr _ (Tick (NamedLoc n') (Var (Id vn _))) })+ | Just n <- mn, n == n' =+ (HS.insert vn v, False)+ step v _ _ _ = v++adtHeight :: Name -> State t -> Int+adtHeight n s@(State { expr_env = eenv })+ | Just (E.Sym _) <- v = 0+ | Just (E.Conc e) <- v =+ 1 + adtHeight' e s+ | otherwise = 0+ where+ v = E.lookupConcOrSym n eenv++adtHeight' :: Expr -> State t -> Int+adtHeight' e s =+ let+ _:es = unApp e+ in+ maximum $ 0:map (\e' -> case e' of+ Var (Id n _) -> adtHeight n s+ _ -> 0) es++-- | Orders by the combined size of (previously) symbolic ADT.+-- In particular, aims to first execute those states with a combined ADT size closest to+-- the specified zize.+adtSizeOrderer :: Monad m => Int -> Maybe Name -> Orderer m (HS.HashSet Name, Bool) Int t+adtSizeOrderer pref_height mn =+ (mkSimpleOrderer initial+ order+ (\v _ _ -> v))+ { stepOrderer = \sov pr st s -> return $ step sov pr st s }+ where+ -- Normally, each state tracks the names of currently symbolic variables,+ -- but here we want all variables that were ever symbolic.+ -- To track this, we use a HashSet.+ -- The tracked bool is to speed up adjusting this hashset- if it is set to false,+ -- we do not update the hashset. If it is set to true,+ -- after the next step the hashset will be updated, and the bool will be set+ -- back to false.+ -- This avoids repeated operations on the hashset after rules that we know+ -- will not add symbolic variables.+ initial s = (HS.fromList . map idName . E.symbolicIds . expr_env $ s, False)+ order (v, _) _ s =+ let+ m = sum (HS.toList $ HS.map (flip adtSize s) v)+ h = abs (pref_height - m)+ in+ return h++ step (v, _) _ _+ (State { curr_expr = CurrExpr _ (SymGen _ _) }) = (v, True)+ step (v, True) _ _ s =+ (v `HS.union` (HS.fromList . map idName . E.symbolicIds . expr_env $ s), False)+ step (v, _) _ _+ (State { curr_expr = CurrExpr _ (Tick (NamedLoc n') (Var (Id vn _))) })+ | Just n <- mn, n == n' = (HS.insert vn v, False)+ step v _ _ _ = v++adtSize :: Name -> State t -> Int+adtSize n s@(State { expr_env = eenv })+ | Just (E.Sym _) <- v = 0+ | Just (E.Conc e) <- v =+ 1 + adtSize' e s+ | otherwise = 0+ where+ v = E.lookupConcOrSym n eenv++adtSize' :: Expr -> State t -> Int+adtSize' e s =+ let+ _:es = unApp e+ in+ sum $ 0:map (\e' -> case e' of+ Var (Id n _) -> adtSize n s+ _ -> 0) es++-- | Orders by the number of Path Constraints+pcSizeOrderer :: Monad m =>+ Int -- ^ What size should we prioritize?+ -> Orderer m () Int t+pcSizeOrderer pref_height = mkSimpleOrderer (const ())+ order+ (\v _ _ -> v)+ where+ order _ _ s =+ let+ m = PC.number (path_conds s)+ h = abs (pref_height - m)+ in+ return h++data IncrAfterNTr sov = IncrAfterNTr { steps_since_change :: Int+ , incr_by :: Int+ , underlying :: sov }++-- | Wraps an existing Orderer, and increases it's value by 1, every time+-- it doesn't change after N steps +incrAfterN :: (Eq sov, Enum b, Monad m) => Int -> Orderer m sov b t -> Orderer m (IncrAfterNTr sov) b t+incrAfterN n ord = (mkSimpleOrderer initial order update) { stepOrderer = step }+ where+ initial s =+ IncrAfterNTr { steps_since_change = 0+ , incr_by = 0+ , underlying = initPerStateOrder ord s }++ order sov pr s = do+ b <- orderStates ord (underlying sov) pr s+ return $ succNTimes (incr_by sov) b++ update sov pr s =+ sov { underlying = updateSelected ord (underlying sov) pr s }++ step sov pr xs s = do+ let under = underlying sov+ under' <- stepOrderer ord under pr xs s+ let sov' = sov { underlying = under' }++ if | steps_since_change sov >= n ->+ return $ sov' { incr_by = incr_by sov' + 1+ , steps_since_change = 0 }+ | under /= under' ->+ return $ sov' { steps_since_change = 0 }+ | otherwise ->+ return $ sov' { steps_since_change = steps_since_change sov' + 1}++succNTimes :: Enum b => Int -> b -> b+succNTimes x b+ | x <= 0 = b+ | otherwise = succNTimes (x - 1) (succ b)++-- | Wraps an existing orderer, and divides its value by 2 if true_assert is true+quotTrueAssert :: (Monad m, Integral b) => Orderer m sov b t -> Orderer m sov b t+quotTrueAssert ord = (mkSimpleOrderer (initPerStateOrder ord)+ order+ (updateSelected ord))+ { stepOrderer = stepOrderer ord}+ where+ order sov pr s = do+ b <- orderStates ord sov pr s+ return (if true_assert s then b `quot` 2 else b)++--------+--------++{-# INLINABLE runReducer #-}+{-# SPECIALIZE runReducer :: Ord b =>+ Reducer IO rv t+ -> Halter IO hv t+ -> Orderer IO sov b t+ -> State t+ -> Bindings+ -> IO (Processed (State t), Bindings)+ #-}+{-# SPECIALIZE runReducer :: Ord b =>+ Reducer (SM.StateT PrettyGuide IO) rv t+ -> Halter (SM.StateT PrettyGuide IO) hv t+ -> Orderer (SM.StateT PrettyGuide IO) sov b t+ -> State t+ -> Bindings+ -> SM.StateT PrettyGuide IO (Processed (State t), Bindings)+ #-}+-- | Uses a passed Reducer, Halter and Orderer to execute the reduce on the State, and generated States+runReducer :: (Monad m, Ord b) =>+ Reducer m rv t+ -> Halter m hv t+ -> Orderer m sov b t+ -> State t+ -> Bindings+ -> m (Processed (State t), Bindings)+runReducer red hal ord s b = do+ let pr = Processed {accepted = [], discarded = []}+ let s' = ExState { state = s+ , reducer_val = initReducer red s+ , halter_val = initHalt hal s+ , order_val = initPerStateOrder ord s }++ (states, b') <- runReducer' red hal ord pr s' b M.empty+ afterRed red+ return (states, b')++{-# INLINABLE runReducer' #-}+runReducer' :: (Monad m, Ord b)+ => Reducer m rv t+ -> Halter m hv t+ -> Orderer m sov b t+ -> Processed (State t)+ -> ExState rv hv sov t+ -> Bindings+ -> M.Map b [ExState rv hv sov t]+ -> m (Processed (State t), Bindings)+runReducer' red hal ord pr rs@(ExState { state = s, reducer_val = r_val, halter_val = h_val, order_val = o_val }) b xs = do+ hc <- stopRed hal h_val pr s+ case () of+ ()+ | hc == Accept -> do+ onAccept red s r_val+ let pr' = pr {accepted = state rs:accepted pr}+ jrs = minState ord pr' xs+ case jrs of+ Just (rs', xs') -> switchState red hal ord pr' rs' b xs'+ Nothing -> return (pr', b)+ | hc == Discard ->+ let+ pr' = pr {discarded = state rs:discarded pr}+ jrs = minState ord pr' xs+ in+ case jrs of+ Just (rs', xs') ->+ switchState red hal ord pr' rs' b xs'+ Nothing -> return (pr', b)+ | hc == Switch -> do+ let rs' = rs { order_val = updateSelected ord (order_val rs) pr (state rs) }+ k <- orderStates ord (order_val rs') pr (state rs)+ let Just (rs'', xs') = minState ord pr (M.insertWith (++) k [rs'] xs)+ switchState red hal ord pr rs'' b xs'+ | otherwise -> do+ (_, reduceds, b') <- redRules red r_val s b+ let reduceds' = map (\(r, rv) -> (r {num_steps = num_steps r + 1}, rv)) reduceds++ r_vals = if length reduceds' > 1+ then updateWithAll red reduceds' ++ error "List returned by updateWithAll is too short."+ else map snd reduceds++ reduceds_h_vals = map (\(r, _) -> (r, h_val)) reduceds'+ h_vals = if length reduceds' > 1+ then updateHalterWithAll hal reduceds_h_vals ++ error "List returned by updateWithAll is too short."+ else repeat h_val++ new_states = map fst reduceds'++ mod_info <- mapM (\(s', r_val', h_val') -> do+ or_v <- stepOrderer ord o_val pr new_states s'+ return $ rs { state = s'+ , reducer_val = r_val'+ , halter_val = stepHalter hal h_val' pr new_states s'+ , order_val = or_v}) $ zip3 new_states r_vals h_vals+++++ case mod_info of+ (s_h:ss_tail) -> do+ b_ss_tail <- mapM (\s' -> do+ n_b <- orderStates ord (order_val s') pr (state s')+ return (n_b, s')) ss_tail++ let xs' = foldr (\(or_b, s') -> M.insertWith (++) or_b [s']) xs b_ss_tail++ runReducer' red hal ord pr s_h b' xs'+ [] -> runReducerList red hal ord pr xs b'++{-# INLINABLE switchState #-}+switchState :: (Monad m, Ord b)+ => Reducer m rv t+ -> Halter m hv t+ -> Orderer m sov b t+ -> Processed (State t)+ -> ExState rv hv sov t+ -> Bindings+ -> M.Map b [ExState rv hv sov t]+ -> m (Processed (State t), Bindings)+switchState red hal ord pr rs b xs+ | not $ discardOnStart hal (halter_val rs') pr (state rs') =+ runReducer' red hal ord pr rs' b xs+ | otherwise =+ runReducerListSwitching red hal ord (pr {discarded = state rs':discarded pr}) xs b+ where+ rs' = rs { halter_val = updatePerStateHalt hal (halter_val rs) pr (state rs) }++{-# INLINABLE runReducerList #-}+-- To be used when we we need to select a state without switching +runReducerList :: (Monad m, Ord b)+ => Reducer m rv t+ -> Halter m hv t+ -> Orderer m sov b t+ -> Processed (State t)+ -> M.Map b [ExState rv hv sov t]+ -> Bindings+ -> m (Processed (State t), Bindings)+runReducerList red hal ord pr m binds =+ case minState ord pr m of+ Just (rs, m') ->+ let+ rs' = rs { halter_val = updatePerStateHalt hal (halter_val rs) pr (state rs) }+ in+ runReducer' red hal ord pr rs' binds m'+ Nothing -> return (pr, binds)++{-# INLINABLE runReducerListSwitching #-}+-- To be used when we are possibly switching states +runReducerListSwitching :: (Monad m, Ord b)+ => Reducer m rv t+ -> Halter m hv t+ -> Orderer m sov b t+ -> Processed (State t)+ -> M.Map b [ExState rv hv sov t]+ -> Bindings+ -> m (Processed (State t), Bindings)+runReducerListSwitching red hal ord pr m binds =+ case minState ord pr m of+ Just (x, m') -> switchState red hal ord pr x binds m'+ Nothing -> return (pr, binds)++{-# INLINABLE minState #-}+-- Uses the Orderer to determine which state to continue execution on.+-- Returns that State, and a list of the rest of the states +minState :: Ord b+ => Orderer m sov b t+ -> Processed (State t)+ -> M.Map b [ExState rv hv sov t]+ -> Maybe ((ExState rv hv sov t), M.Map b [ExState rv hv sov t])+minState ord pr m =+ case getState m of+ Just (k, x:[]) -> Just (x, M.delete k m)+ Just (k, x:xs) -> Just (x, M.insert k xs m)+ Just (k, []) -> minState ord pr $ M.delete k m+ Nothing -> Nothing+
src/G2/Execution/RuleTypes.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -10,6 +11,11 @@ import G2.Language.Naming import G2.Language.Syntax +import Data.Hashable+import qualified Data.Sequence as S++import GHC.Generics (Generic)+ data Rule = RuleEvalVal | RuleEvalVarNonVal Name | RuleEvalVarVal Name@@ -73,12 +79,14 @@ | RuleTick | RuleOther- deriving (Show, Eq, Read, Typeable, Data)+ deriving (Show, Eq, Read, Typeable, Data, Generic) +instance Hashable Rule+ instance AST e => ASTContainer Rule e where containedASTs _ = [] modifyContainedASTs _ r = r instance Named Rule where- names _ = []+ names _ = S.empty rename _ _ = id
src/G2/Execution/Rules.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module G2.Execution.Rules ( module G2.Execution.RuleTypes+ , Sharing (..) , stdReduce- , evalVar+ , evalVarSharing , evalApp , evalLam , retLam@@ -15,132 +16,130 @@ , evalAssume , evalAssert - , isExecValueForm ) where+ , isExecValueForm + + , SymbolicFuncEval+ , retReplaceSymbFuncVar+ , retReplaceSymbFuncTemplate) where +import G2.Config.Config+import G2.Execution.NewPC import G2.Execution.NormalForms import G2.Execution.PrimitiveEval import G2.Execution.RuleTypes import G2.Language import qualified G2.Language.ExprEnv as E+import qualified G2.Language.TypeEnv as TE+import qualified G2.Language.Typing as T import qualified G2.Language.KnownValues as KV-import qualified G2.Language.PathConds as PC import qualified G2.Language.Stack as S+import G2.Preprocessing.NameCleaner import G2.Solver hiding (Assert) import Control.Monad.Extra import Data.Maybe+import qualified Data.HashMap.Lazy as HM+import qualified Data.List as L+import qualified Data.Sequence as S -stdReduce :: Solver solver => solver -> State t -> Bindings -> IO (Rule, [(State t, ())], Bindings)-stdReduce solver s b@(Bindings {name_gen = ng}) = do- (r, s', ng') <- stdReduce' solver s ng+import Control.Exception++stdReduce :: (Solver solver, Simplifier simplifier) => Sharing -> SymbolicFuncEval t -> solver -> simplifier -> State t -> Bindings -> IO (Rule, [(State t, ())], Bindings)+stdReduce share symb_func_eval solver simplifier s b@(Bindings {name_gen = ng}) = do+ (r, s', ng') <- stdReduce' share symb_func_eval solver simplifier s ng let s'' = map (\ss -> ss { rules = r:rules ss }) s' return (r, zip s'' (repeat ()), b { name_gen = ng'}) -stdReduce' :: Solver solver => solver -> State t -> NameGen -> IO (Rule, [State t], NameGen)-stdReduce' solver s@(State { curr_expr = CurrExpr Evaluate ce }) ng- | Var i <- ce = return $ evalVar s ng i- | App e1 e2 <- ce = return $ evalApp s ng e1 e2+stdReduce' :: (Solver solver, Simplifier simplifier) => Sharing -> SymbolicFuncEval t -> solver -> simplifier -> State t -> NameGen -> IO (Rule, [State t], NameGen)+stdReduce' share _ solver simplifier s@(State { curr_expr = CurrExpr Evaluate ce }) ng+ | Var i <- ce+ , share == Sharing = return $ evalVarSharing s ng i+ | Var i <- ce+ , share == NoSharing = return $ evalVarNoSharing s ng i+ | App e1 e2 <- ce = do+ let (r, xs, ng') = evalApp s ng e1 e2+ xs' <- mapMaybeM (reduceNewPC solver simplifier) xs+ return (r, xs', ng') | Let b e <- ce = return $ evalLet s ng b e- | Case e i a <- ce = do- let (r, xs, ng') = evalCase s ng e i a- xs' <- mapMaybeM (reduceNewPC solver) xs+ | Case e i t a <- ce = do+ let (r, xs, ng') = evalCase s ng e i t a+ xs' <- mapMaybeM (reduceNewPC solver simplifier) xs return (r, xs', ng') | Cast e c <- ce = return $ evalCast s ng e c | Tick t e <- ce = return $ evalTick s ng t e | NonDet es <- ce = return $ evalNonDet s ng es- | SymGen t <- ce = return $ evalSymGen s ng t+ | SymGen sl t <- ce = return $ evalSymGen s ng sl t | Assume fc e1 e2 <- ce = return $ evalAssume s ng fc e1 e2 | Assert fc e1 e2 <- ce = return $ evalAssert s ng fc e1 e2 | otherwise = return (RuleReturn, [s { curr_expr = CurrExpr Return ce }], ng)-stdReduce' solver s@(State { curr_expr = CurrExpr Return ce- , exec_stack = stck }) ng- | Prim Error _ <- ce+stdReduce' _ symb_func_eval solver simplifier s@(State { curr_expr = CurrExpr Return ce+ , exec_stack = stck }) ng+ | isError ce , Just (AssertFrame is _, stck') <- S.pop stck = return (RuleError, [s { exec_stack = stck' , true_assert = True- , assert_ids = is }], ng)- | Prim Error _ <- ce- , Just (_, stck') <- S.pop stck = return (RuleError, [s { exec_stack = stck' }], ng)+ , assert_ids = fmap (\fc -> fc { returns = Prim Error TyBottom }) is }], ng) | Just (UpdateFrame n, stck') <- frstck = return $ retUpdateFrame s ng n stck'- | Lam u i e <- ce = return $ retLam s ng u i e- | Just (ApplyFrame e, stck') <- S.pop stck = return $ retApplyFrame s ng ce e stck'- | Just rs <- retReplaceSymbFunc s ng ce = return rs- | Just (CaseFrame i a, stck') <- frstck = return $ retCaseFrame s ng ce i a stck'+ | isError ce+ , Just (_, stck') <- S.pop stck = return (RuleError, [s { exec_stack = stck' }], ng)+ | Just rs <- symb_func_eval s ng ce = return rs+ | Just (CaseFrame i t a, stck') <- frstck = return $ retCaseFrame s ng ce i t a stck' | Just (CastFrame c, stck') <- frstck = return $ retCastFrame s ng ce c stck'+ | Lam u i e <- ce+ , Just (ApplyFrame ae, stck') <- S.pop stck = return $ retLam s ng u i e ae stck'+ | Just (ApplyFrame e, stck') <- S.pop stck = return $ retApplyFrame s ng ce e stck' | Just (AssumeFrame e, stck') <- frstck = do let (r, xs, ng') = retAssumeFrame s ng ce e stck'- xs' <- mapMaybeM (reduceNewPC solver) xs+ xs' <- mapMaybeM (reduceNewPC solver simplifier) xs return (r, xs', ng') | Just (AssertFrame ais e, stck') <- frstck = do let (r, xs, ng') = retAssertFrame s ng ce ais e stck'- xs' <- mapMaybeM (reduceNewPC solver) xs+ xs' <- mapMaybeM (reduceNewPC solver simplifier) xs return (r, xs', ng')- | Just (CurrExprFrame e, stck') <- frstck = do- let (r, xs) = retCurrExpr s ce e stck'- xs' <- mapMaybeM (reduceNewPC solver) xs+ | Just (CurrExprFrame act e, stck') <- frstck = do+ let (r, xs) = retCurrExpr s ce act e stck'+ xs' <- mapMaybeM (reduceNewPC solver simplifier) xs return (r, xs', ng) | Nothing <- frstck = return (RuleIdentity, [s], ng) | otherwise = error $ "stdReduce': Unknown Expr" ++ show ce ++ show (S.pop stck) where frstck = S.pop stck -data NewPC t = NewPC { state :: State t- , new_pcs :: [PathCond] }--newPCEmpty :: State t -> NewPC t-newPCEmpty s = NewPC { state = s, new_pcs = []}--reduceNewPC :: Solver solver => solver -> NewPC t -> IO (Maybe (State t))-reduceNewPC solver- (NewPC { state = s@(State { known_values = kv- , path_conds = spc })- , new_pcs = pc })- | not (null pc) = do- -- In the case of newtypes, the PC exists we get may have the correct name- -- but incorrect type.- -- We do not want to add these to the State- -- This is a bit ugly, but not a huge deal, since the State already has PCExists- let pc' = filter (not . PC.isPCExists) pc-- -- Optimization- -- We replace the path_conds with only those that are directly- -- affected by the new path constraints- -- This allows for more efficient solving, and in some cases may- -- change an Unknown into a SAT or UNSAT- let new_pc = foldr (PC.insert kv) spc $ pc'- s' = s { path_conds = new_pc}-- let rel_pc = PC.filter (not . PC.isPCExists) $ PC.relevant kv pc new_pc-- res <- check solver s rel_pc+ isError (Prim Error _) = True+ isError (Prim Undefined _) = True+ isError _ = False - if res == SAT then- return $ Just s'- else- return Nothing- | otherwise = return $ Just s+evalVarSharing :: State t -> NameGen -> Id -> (Rule, [State t], NameGen)+evalVarSharing s@(State { expr_env = eenv+ , exec_stack = stck })+ ng i+ | E.isSymbolic (idName i) eenv =+ (RuleEvalVal, [s { curr_expr = CurrExpr Return (Var i)}], ng)+ -- If the target in our environment is already a value form, we do not+ -- need to push additional redirects for updating later on.+ -- If our variable is not in value form, we first push the+ -- current name of the variable onto the stack and evaluate the+ -- expression that it points to. After the evaluation,+ -- we pop the stack to add a redirection pointer into the heap.+ | Just e' <- e+ , isExprValueForm eenv e' =+ ( RuleEvalVarVal (idName i), [s { curr_expr = CurrExpr Evaluate e' }], ng)+ | Just e' <- e = -- e' is NOT in SWHNF+ ( RuleEvalVarNonVal (idName i)+ , [s { curr_expr = CurrExpr Evaluate e'+ , exec_stack = S.push (UpdateFrame (idName i)) stck }]+ , ng)+ | otherwise = error $ "evalVar: bad input." ++ show i+ where+ e = E.lookup (idName i) eenv -evalVar :: State t -> NameGen -> Id -> (Rule, [State t], NameGen)-evalVar s@(State { expr_env = eenv- , exec_stack = stck })- ng i+evalVarNoSharing :: State t -> NameGen -> Id -> (Rule, [State t], NameGen)+evalVarNoSharing s@(State { expr_env = eenv })+ ng i | E.isSymbolic (idName i) eenv = (RuleEvalVal, [s { curr_expr = CurrExpr Return (Var i)}], ng) | Just e <- E.lookup (idName i) eenv =- -- If the target in our environment is already a value form, we do not- -- need to push additional redirects for updating later on.- -- If our variable is not in value form, we first push the- -- current name of the variable onto the stack and evaluate the- -- expression that it points to. After the evaluation,- -- we pop the stack to add a redirection pointer into the heap.- let- (r, stck') = if isExprValueForm eenv e - then ( RuleEvalVarVal (idName i), stck) - else ( RuleEvalVarNonVal (idName i)- , S.push (UpdateFrame (idName i)) stck)- in- (r, [s { curr_expr = CurrExpr Evaluate e- , exec_stack = stck' }], ng)+ (RuleEvalVarNonVal (idName i), [s { curr_expr = CurrExpr Evaluate e }], ng) | otherwise = error $ "evalVar: bad input." ++ show i -- | If we have a primitive operator, we are at a point where either:@@ -148,39 +147,40 @@ -- (2) We have a symbolic value, and no evaluation is possible, so we return -- If we do not have a primitive operator, we go into the center of the apps, -- to evaluate the function call-evalApp :: State t -> NameGen -> Expr -> Expr -> (Rule, [State t], NameGen)+evalApp :: State t -> NameGen -> Expr -> Expr -> (Rule, [NewPC t], NameGen) evalApp s@(State { expr_env = eenv+ , type_env = tenv , known_values = kv , exec_stack = stck }) ng e1 e2- | (App (Prim BindFunc _) v) <- e1- , Var i1 <- findSym v- , v2 <- e2 =- ( RuleBind- , [s { expr_env = E.insert (idName i1) v2 eenv- , curr_expr = CurrExpr Return (mkTrue kv) }]- , ng)- | isExprValueForm eenv (App e1 e2) =- ( RuleReturnAppSWHNF- , [s { curr_expr = CurrExpr Return (App e1 e2) }]- , ng)+ | ac@(Prim Error _) <- appCenter e1 =+ (RuleError, [newPCEmpty $ s { curr_expr = CurrExpr Return ac }], ng)+ | Just (e, eenv', pc, ng') <- evalPrimSymbolic eenv tenv ng kv (App e1 e2) =+ ( RuleEvalPrimToNorm+ , [ (newPCEmpty $ s { expr_env = eenv'+ , curr_expr = CurrExpr Return e }) { new_pcs = pc} ]+ , ng') | (Prim prim ty):ar <- unApp (App e1 e2) = let ar' = map (lookupForPrim eenv) ar appP = mkApp (Prim prim ty : ar')- exP = evalPrims kv appP+ exP = evalPrims tenv kv appP in ( RuleEvalPrimToNorm- , [s { curr_expr = CurrExpr Return exP }]+ , [newPCEmpty $ s { curr_expr = CurrExpr Return exP }] , ng)+ | isExprValueForm eenv (App e1 e2) =+ ( RuleReturnAppSWHNF+ , [newPCEmpty $ s { curr_expr = CurrExpr Return (App e1 e2) }]+ , ng) | otherwise = let frame = ApplyFrame e2 stck' = S.push frame stck in ( RuleEvalApp e2- , [s { curr_expr = CurrExpr Evaluate e1- , exec_stack = stck' }]+ , [newPCEmpty $ s { curr_expr = CurrExpr Evaluate e1+ , exec_stack = stck' }] , ng) where findSym v@(Var (Id n _))@@ -206,38 +206,32 @@ evalLam :: State t -> LamUse -> Id -> Expr -> (Rule, [State t]) evalLam = undefined -retLam :: State t -> NameGen -> LamUse -> Id -> Expr -> (Rule, [State t], NameGen)-retLam s@(State { expr_env = eenv- , exec_stack = stck })- ng u i e- | TypeL <- u- , Just (ApplyFrame tf, stck') <- S.pop stck =- case traceType eenv tf of+retLam :: State t -> NameGen -> LamUse -> Id -> Expr -> Expr -> S.Stack Frame -> (Rule, [State t], NameGen)+retLam s@(State { expr_env = eenv })+ ng u i e ae stck'+ | TypeL <- u =+ case traceType eenv ae of Just t -> let- e' = retype i t e+ e' = retypeRespectingTyForAll i t e - binds = [(i, Type t)]- (eenv', e'', ng', news) = liftBinds binds eenv e' ng+ (eenv', e'', ng', news) = liftBind i (Type t) eenv e' ng in- ( RuleReturnEApplyLamType news+ ( RuleReturnEApplyLamType [news] , [s { expr_env = eenv' , curr_expr = CurrExpr Evaluate e'' , exec_stack = stck' }] , ng')- Nothing -> error "retLam: Bad type"- | TermL <- u- , Just (ApplyFrame ae, stck') <- S.pop stck =+ Nothing -> error $ "retLam: Bad type\ni = " ++ show i+ | otherwise = let- binds = [(i, ae)]- (eenv', e', ng', news) = liftBinds binds eenv e ng+ (eenv', e', ng', news) = liftBind i ae eenv e ng in- ( RuleReturnEApplyLamExpr news+ ( RuleReturnEApplyLamExpr [news] , [s { expr_env = eenv' , curr_expr = CurrExpr Evaluate e' , exec_stack = stck' }] ,ng')- | otherwise = error "retLam: Bad type" traceType :: E.ExprEnv -> Expr -> Maybe Type traceType _ (Type t) = Just t@@ -263,10 +257,10 @@ , ng') -- | Handle the Case forms of Evaluate.-evalCase :: State t -> NameGen -> Expr -> Id -> [Alt] -> (Rule, [NewPC t], NameGen)+evalCase :: State t -> NameGen -> Expr -> Id -> Type -> [Alt] -> (Rule, [NewPC t], NameGen) evalCase s@(State { expr_env = eenv , exec_stack = stck })- ng mexpr bind alts+ ng mexpr bind t alts -- Is the current expression able to match with a literal based `Alt`? If -- so, we do the cvar binding, and proceed with evaluation of the body. | (Lit lit) <- unsafeElimOuterCast mexpr@@ -306,7 +300,11 @@ -- We hit a DEFAULT instead. -- We perform the cvar binding and proceed with the alt -- expression.- | (Data _):_ <- unApp $ unsafeElimOuterCast mexpr+ | e:_ <- unApp $ unsafeElimOuterCast mexpr+ , isData e+ || isLit e+ || isLam e+ || (case e of Var i@(Id n _) -> E.isSymbolic n eenv && hasFuncType i; _ -> False) , (Alt _ expr):_ <- matchDefaultAlts alts = let binds = [(bind, mexpr)]@@ -336,9 +334,12 @@ _ -> error $ "unmatched expr" ++ show (unApp $ unsafeElimOuterCast mexpr) lsts_cs = liftSymLitAlt s mexpr bind lalts- def_sts = liftSymDefAlt s mexpr bind alts+ (def_sts, ng'') = liftSymDefAlt s ng' mexpr bind alts++ alt_res = dsts_cs ++ lsts_cs ++ def_sts in- (RuleEvalCaseSym, dsts_cs ++ lsts_cs ++ def_sts, ng')+ assert (length alt_res == length dalts + length lalts + length defs)+ (RuleEvalCaseSym, alt_res, ng'') -- Case evaluation also uses the stack in graph reduction based evaluation -- semantics. The case's binding variable and alts are pushed onto the stack@@ -346,7 +347,7 @@ -- is only done when the matching expression is NOT in value form. Value -- forms should be handled by other RuleEvalCase* rules. | not (isExprValueForm eenv mexpr) =- let frame = CaseFrame bind alts+ let frame = CaseFrame bind t alts in ( RuleEvalCaseNonVal , [newPCEmpty $ s { expr_env = eenv , curr_expr = CurrExpr Evaluate mexpr@@ -357,28 +358,29 @@ -- | Remove everything from an [Expr] that are actually Types. removeTypes :: [Expr] -> E.ExprEnv -> [Expr] removeTypes ((Type _):es) eenv = removeTypes es eenv-removeTypes ((Var (Id n ty)):es) eenv = case E.lookup n eenv of- Just (Type _) -> removeTypes es eenv- _ -> (Var (Id n ty)) : removeTypes es eenv+removeTypes (v@(Var _):es) eenv = case repeatedLookup eenv v of+ (Type _) -> removeTypes es eenv+ -- Just v@(Var (Id n' _)) -> removeTypes (v:es) eenv + _ -> v : removeTypes es eenv removeTypes (e:es) eenv = e : removeTypes es eenv removeTypes [] _ = [] -- | DEFAULT `Alt`s. matchDefaultAlts :: [Alt] -> [Alt]-matchDefaultAlts alts = [a | a @ (Alt Default _) <- alts]+matchDefaultAlts alts = [a | a@(Alt Default _) <- alts] -- | Match data constructor based `Alt`s. matchDataAlts :: DataCon -> [Alt] -> [Alt] matchDataAlts (DataCon n _) alts =- [a | a @ (Alt (DataAlt (DataCon n' _) _) _) <- alts, n == n']+ [a | a@(Alt (DataAlt (DataCon n' _) _) _) <- alts, n == n'] -- | Match literal constructor based `Alt`s. matchLitAlts :: Lit -> [Alt] -> [Alt]-matchLitAlts lit alts = [a | a @ (Alt (LitAlt alit) _) <- alts, lit == alit]+matchLitAlts lit alts = [a | a@(Alt (LitAlt alit) _) <- alts, lit == alit] liftCaseBinds :: [(Id, Expr)] -> Expr -> Expr liftCaseBinds [] expr = expr-liftCaseBinds ((b, e):xs) expr = liftCaseBinds xs $ replaceASTs (Var b) e expr+liftCaseBinds ((b, e):xs) expr = liftCaseBinds xs $ replaceVar (idName b) e expr -- | `DataCon` `Alt`s. dataAlts :: [Alt] -> [(DataCon, [Id], Expr)]@@ -390,7 +392,7 @@ -- | DEFAULT `Alt`s. defaultAlts :: [Alt] -> [Alt]-defaultAlts alts = [a | a @ (Alt Default _) <- alts]+defaultAlts alts = [a | a@(Alt Default _) <- alts] -- | Lift positive datacon `State`s from symbolic alt matching. This in -- part involves erasing all of the parameters from the environment by rename@@ -404,40 +406,31 @@ (newPCs, ng'') = concretizeVarExpr s ng' mexpr_id cvar xs maybeC concretizeVarExpr' :: State t -> NameGen -> Id -> Id -> (DataCon, [Id], Expr) -> Maybe Coercion -> (NewPC t, NameGen)-concretizeVarExpr' s@(State {expr_env = eenv, type_env = tenv, symbolic_ids = syms})- ngen mexpr_id cvar (dcon, params, aexpr) maybeC = +concretizeVarExpr' s@(State {expr_env = eenv, type_env = tenv, known_values = kv})+ ngen mexpr_id cvar (dcon, params, aexpr) maybeC = (NewPC { state = s { expr_env = eenv''- , symbolic_ids = syms' , curr_expr = CurrExpr Evaluate aexpr''}- -- It is VERY important that we insert a PCExists with the mexpr_id+ -- It is VERY important that we insert the mexpr_id in `concretized` -- This forces reduceNewPC to check that the concretized data constructor does -- not violate any path constraints from default cases. - , new_pcs = [PCExists mexpr_id]- }, ngen')+ , new_pcs = pcs+ , concretized = [mexpr_id]+ }, ngen'') where -- Make sure that the parameters do not conflict in their symbolic reps. olds = map idName params-- -- [ChildrenNames]- -- Optimization- -- We use the same names repeatedly for the children of the same ADT- -- Haskell is purely functional, so this is OK! The children can't change- -- Then, in the constraint solver, we can consider fewer constraints at once- -- (see note [AltCond] in Language/PathConds.hs) - mexpr_n = idName mexpr_id- (news, ngen') = childrenNames mexpr_n olds ngen+ clean_olds = map cleanName olds - --Update the expr environment- newIds = map (\(Id _ t, n) -> (n, Id n t)) (zip params news)- eenv' = foldr (uncurry E.insertSymbolic) eenv newIds+ (news, ngen') = freshSeededNames clean_olds ngen (dcon', aexpr') = renameExprs (zip olds news) (Data dcon, aexpr) newparams = map (uncurry Id) $ zip news (map typeOf params) dConArgs = (map (Var) newparams) -- Get list of Types to concretize polymorphic data constructor and concatenate with other arguments- mexpr_t = (\(Id _ t) -> t) (mexpr_id)- exprs = [dcon'] ++ (mexprTyToExpr mexpr_t tenv) ++ dConArgs+ mexpr_t = typeOf mexpr_id+ type_ars = mexprTyToExpr mexpr_t tenv+ exprs = [dcon'] ++ type_ars ++ dConArgs -- Apply list of types (if present) and DataCon children to DataCon dcon'' = mkApp exprs@@ -447,22 +440,96 @@ (Just (t1 :~ t2)) -> Cast dcon'' (t2 :~ t1) Nothing -> dcon'' - syms' = newparams ++ (filter (/= mexpr_id) syms)-- -- concretizes the mexpr to have same form as the DataCon specified- eenv'' = E.insert mexpr_n dcon''' eenv' - -- Now do a round of rename for binding the cvar. binds = [(cvar, (Var mexpr_id))] aexpr'' = liftCaseBinds binds aexpr' - + (eenv'', pcs, ngen'') = adjustExprEnvAndPathConds kv tenv eenv ngen' dcon dcon''' mexpr_id params news++-- [String Concretizations and Constraints]+-- Generally speaking, the values of symbolic variable are determined by one of two methods:+-- in the case of primitive values (Int#, Float#, ...), we generate path constraints, which can be solved+-- via an SMT solver. In the case of algebraic data types, we use concretization, in which+-- the symbolic variable is replaced by a (partially) concrete expression.+--+-- We play a bit of a funny trick for Strings. In Haskell, String is really just a type alias+-- for a list of Chars:+-- type String = [Char] +-- The obvious thing to do, then, is just allow concretization to kick in: and indeed, this is sometimes+-- necessary, if a String is directly pattern matched on, or if a String is passed to a function expecting+-- a generic list [a].+--+-- However, SMT solvers also support reasoning about Strings, and concretization can sometimes lead to a blow up+-- in the state space. For instance, when applying+-- show :: Int -> String+-- concretization would result in infinite recursive branching to potentially print different Ints. +-- Thus, it is appealing to allow reasoning about Strings in the SMT solver, when possible, to avoid this blowup. +--+-- In principle, allowing reasoning about Strings both via concretization and the SMT solver: we simply perform both+-- concretization and path constraint generation. Care must be taken to keep this in sync. That is, we must+-- ensure that the value of a String is equally constrained by both the concretization and the generated path constraints.+-- When a String s is concretized to the empty String, [], we generate a path constraint that `strLen s == 0`.+-- When a String s is concretized to a cons, (C# c:xs), we generate a path constraint that `c ++ xs == s`.+-- Note that in the cons case, we must also concretize the Char in the list to obtain the primitive Char#,+-- as this will be the symbolic variable that may be inserted into other path constraints.++-- | Determines an ExprEnv and Path Constraints from following a particular branch of symbolic execution.+-- Has special handling for Strings- see [String Concretizations and Constraints]+adjustExprEnvAndPathConds :: KnownValues+ -> TypeEnv+ -> ExprEnv+ -> NameGen+ -> DataCon -- ^ The data con in the scrutinee (as in `case scrutinee of ...`)+ -> Expr -- ^ The scrutinee+ -> Id -- ^ Symbolic Variable Id + -> [Id] -- ^ Constructor Argument Ids+ -> [Name]+ -> (ExprEnv, [PathCond], NameGen)+adjustExprEnvAndPathConds kv tenv eenv ng dc dc_e mexpr params dc_args+ | Just (dcName dc) == fmap dcName (getDataCon tenv (KV.tyList kv) (KV.dcEmpty kv))+ , typeOf mexpr == TyApp (T.tyList kv) (T.tyChar kv) =+ assert (length params == 0)+ (eenv''+ , [ExtCond (mkEqExpr kv+ (App (mkStringLen kv) (Var mexpr))+ (Lit (LitInt 0)))+ True]+ , ng)+ | Just (dcName dc) == fmap dcName (getDataCon tenv (KV.tyList kv) (KV.dcCons kv))+ , typeOf mexpr == TyApp (T.tyList kv) (T.tyChar kv)+ , [_, _] <- params+ , [arg_h, arg_t] <- newIds =+ let+ (char_i, ng') = freshId TyLitChar ng+ char_dc = App (mkDCChar kv tenv) (Var char_i)+ eenv''' = E.insertSymbolic char_i $ E.insert (idName arg_h) char_dc eenv''+ in+ assert (length params == 2)+ (eenv'''+ , [ExtCond (mkEqExpr kv+ (App (App (mkStringAppend kv) (Var char_i)) (Var arg_t))+ (Var mexpr))+ True]+ , ng')+ | otherwise = (eenv'', [], ng)+ where+ mexpr_n = idName mexpr++ --Update the expr environment+ newIds = zipWith (\(Id _ t) n -> Id n t) params dc_args+ eenv' = foldr E.insertSymbolic eenv newIds+ -- concretizes the mexpr to have same form as the DataCon specified+ eenv'' = E.insert mexpr_n dc_e eenv' + -- | Given the Type of the matched Expr, looks for Type in the TypeEnv, and returns Expr level representation of the Type mexprTyToExpr :: Type -> TypeEnv -> [Expr]-mexprTyToExpr mexpr_t tenv +mexprTyToExpr mexpr_t = reverse . mexprTyToExpr' mexpr_t++mexprTyToExpr' :: Type -> TypeEnv -> [Expr]+mexprTyToExpr' mexpr_t tenv -- special case for NewTyCon, involves looking up tyVars and binding them to concrete types specified by mexpr_t | Just (algDataTy, bindings) <- getAlgDataTy mexpr_t tenv - , (isNewTyCon algDataTy) = dconTyToExpr (data_con algDataTy) bindings+ , NewTyCon {} <- algDataTy = dconTyToExpr (data_con algDataTy) bindings | otherwise = typeToExpr mexpr_t -- | Given a DataCon, and an (Id, Type) mapping, returns list of Expression level Type Arguments to DataCon@@ -480,22 +547,76 @@ (x', ng') = createExtCond s ng mexpr cvar x (newPCs, ng'') = createExtConds s ng' mexpr cvar xs +-- | Creating a path constraint. The passed Expr should have type Bool or type [Char].+-- In the latter case, the note [String Concretizations and Constraints] is relevant. createExtCond :: State t -> NameGen -> Expr -> Id -> (DataCon, [Id], Expr) -> (NewPC t, NameGen)-createExtCond s ngen mexpr cvar (dcon, _, aexpr) =- (NewPC { state = res, new_pcs = [cond] }, ngen)- where- -- Get the Bool value specified by the matching DataCon- -- Throws an error if dcon is not a Bool Data Constructor- boolValue = getBoolFromDataCon s dcon- cond = ExtCond mexpr boolValue+createExtCond s ngen mexpr cvar (dcon, bindees, aexpr)+ | typeOf mexpr == tyBool kv =+ let+ -- Get the Bool value specified by the matching DataCon+ -- Throws an error if dcon is not a Bool Data Constructor+ boolValue = getBoolFromDataCon (known_values s) dcon+ cond = ExtCond mexpr boolValue - -- Now do a round of rename for binding the cvar.- binds = [(cvar, mexpr)]- aexpr' = liftCaseBinds binds aexpr- res = s {curr_expr = CurrExpr Evaluate aexpr'}+ -- Now do a round of rename for binding the cvar.+ binds = [(cvar, mexpr)]+ aexpr' = liftCaseBinds binds aexpr+ res = s {curr_expr = CurrExpr Evaluate aexpr'}+ in+ (NewPC { state = res, new_pcs = [cond] , concretized = []}, ngen)+ | Just (dcName dcon) == fmap dcName (getDataCon tenv (KV.tyList kv) (KV.dcEmpty kv)) =+ -- Concretize a primitive application which creates a symbolic [Char] into an empty list.+ let+ eq_str = ExtCond (mkEqExpr kv+ (App (mkStringLen kv) mexpr)+ (Lit (LitInt 0)))+ True+ + new_list = App (mkEmpty kv tenv) (Type $ tyChar kv)+ binds = [(cvar, new_list)]+ aexpr' = liftCaseBinds binds aexpr+ res = s { curr_expr = CurrExpr Return aexpr' }+ in+ (NewPC { state = res, new_pcs = [eq_str] , concretized = []}, ngen) -getBoolFromDataCon :: State t -> DataCon -> Bool-getBoolFromDataCon (State {known_values = kv}) dcon+ | Just (dcName dcon) == fmap dcName (getDataCon tenv (KV.tyList kv) (KV.dcCons kv))+ , [h, t] <- bindees =+ -- Concretize a primitive application which creates a symbolic [Char] into symbolic head and tail.+ let+ ty_char_list = TyApp (tyList kv) (tyChar kv)++ (n_char, ng') = freshSeededName (idName cvar) ngen+ (n_char_list, ng'') = freshSeededName (idName cvar) ng'+ + i_char = Id n_char TyLitChar+ v_char = Var i_char+ dc_char = App (mkDCChar kv tenv) v_char+ + i_char_list = Id n_char_list ty_char_list+ v_char_list = Var i_char_list++ eq_str = ExtCond (mkEqExpr kv+ (App (App (mkStringAppend kv) v_char) v_char_list)+ mexpr)+ True++ new_list = App (App (App (mkCons kv tenv) (Type $ tyChar kv)) dc_char) v_char_list+ binds = [(cvar, new_list), (h, dc_char), (t, v_char_list)]+ aexpr' = liftCaseBinds binds aexpr+ res = s { expr_env = E.insertSymbolic i_char $ E.insertSymbolic i_char_list (expr_env s)+ , curr_expr = CurrExpr Return aexpr' }+ in+ (NewPC { state = res, new_pcs = [eq_str] , concretized = [i_char, i_char_list]}, ng'')+ | otherwise = error $ "createExtCond: unsupported type" ++ "\n" ++ show (typeOf mexpr) ++ "\n" ++ show dcon+ where+ kv = known_values s+ tenv = type_env s++ +++getBoolFromDataCon :: KnownValues -> DataCon -> Bool+getBoolFromDataCon kv dcon | (DataCon dconName dconType) <- dcon , dconType == (tyBool kv) , dconName == (KV.dcTrue kv) = True@@ -510,7 +631,7 @@ -- | Lift literal alts found in symbolic case matching. liftSymLitAlt' :: State t -> Expr -> Id -> (Lit, Expr) -> NewPC t liftSymLitAlt' s mexpr cvar (lit, aexpr) =- NewPC { state = res, new_pcs = [cond] }+ NewPC { state = res, new_pcs = [cond] , concretized = [] } where -- Condition that was matched. cond = AltCond lit mexpr True@@ -519,40 +640,134 @@ aexpr' = liftCaseBinds binds aexpr res = s { curr_expr = CurrExpr Evaluate aexpr' } -liftSymDefAlt :: State t -> Expr -> Id -> [Alt] -> [NewPC t]-liftSymDefAlt s mexpr cvar as =+----------------------------------------------------+-- Default Alternatives++liftSymDefAlt :: State t -> NameGen -> Expr -> Id -> [Alt] -> ([NewPC t], NameGen)+liftSymDefAlt s ng mexpr cvar as = let- aexpr = defAltExpr as+ match = defAltExpr as in- case aexpr of- Just aexpr' -> liftSymDefAlt' s mexpr aexpr' cvar as- _ -> []+ case match of+ Just aexpr -> liftSymDefAlt' s ng mexpr aexpr cvar as -- (liftSymDefAlt'' s mexpr aexpr cvar as, ng)+ _ -> ([], ng) -liftSymDefAlt' :: State t -> Expr -> Expr -> Id -> [Alt] -> [NewPC t]-liftSymDefAlt' s mexpr aexpr cvar as =+-- | Concretize Symbolic variable to Case Expr on its possible Data Constructors+liftSymDefAlt' :: State t -> NameGen -> Expr -> Expr -> Id -> [Alt] -> ([NewPC t], NameGen)+liftSymDefAlt' s@(State {type_env = tenv}) ng mexpr aexpr cvar alts+ | (Var i):_ <- unApp $ unsafeElimOuterCast mexpr+ , isADTType (typeOf i)+ , (Var i'):_ <- unApp $ exprInCasts mexpr = -- Id with original Type+ let (adt, bi) = fromJust $ getCastedAlgDataTy (typeOf i) tenv+ maybeC = case mexpr of+ (Cast _ c) -> Just c+ _ -> Nothing+ dcs = dataCon adt+ badDCs = mapMaybe (\alt -> case alt of+ (Alt (DataAlt (DataCon dcn _) _) _) -> Just dcn+ _ -> Nothing) alts+ dcs' = filter (\(DataCon dcn _) -> dcn `notElem` badDCs) dcs++ (newId, ng') = freshId TyLitInt ng++ ((s', ng''), dcs'') = L.mapAccumL (concretizeSym bi maybeC) (s, ng') dcs'++ mexpr' = createCaseExpr newId (typeOf i) dcs''+ binds = [(cvar, mexpr')]+ aexpr' = liftCaseBinds binds aexpr++ -- add PC restricting range of values for newSymId+ newSymConstraint = restrictSymVal (known_values s') 1 (toInteger $ length dcs'') newId++ eenv' = E.insert (idName i') mexpr' (expr_env s')+ s'' = s' { curr_expr = CurrExpr Evaluate aexpr'+ , expr_env = eenv'}+ in+ ([NewPC { state = s'', new_pcs = [newSymConstraint], concretized = [] }], ng'')+ | Prim _ _:_ <- unApp mexpr = (liftSymDefAlt'' s mexpr aexpr cvar alts, ng)+ | isPrimType (typeOf mexpr) = (liftSymDefAlt'' s mexpr aexpr cvar alts, ng)+ | otherwise = error $ "liftSymDefAlt': unhandled Expr" ++ "\n" ++ show mexpr++liftSymDefAlt'' :: State t -> Expr -> Expr -> Id -> [Alt] -> [NewPC t]+liftSymDefAlt'' s mexpr aexpr cvar as = let- conds = mapMaybe (liftSymDefAltPCs mexpr) (map altMatch as)+ conds = mapMaybe (liftSymDefAltPCs (known_values s) mexpr) (map altMatch as) binds = [(cvar, mexpr)] aexpr' = liftCaseBinds binds aexpr in [NewPC { state = s { curr_expr = CurrExpr Evaluate aexpr' }- , new_pcs = conds }]+ , new_pcs = conds+ , concretized = [] }] +liftSymDefAltPCs :: KnownValues -> Expr -> AltMatch -> Maybe PathCond+liftSymDefAltPCs kv mexpr (DataAlt dc _) = -- Only DataAlts would be True/False+ let boolVal = getBoolFromDataCon kv dc+ in case boolVal of+ True -> Just $ ExtCond mexpr False+ False -> Just $ ExtCond mexpr True+liftSymDefAltPCs _ mexpr (LitAlt lit) = Just $ AltCond lit mexpr False+liftSymDefAltPCs _ _ Default = Nothing+ defAltExpr :: [Alt] -> Maybe Expr defAltExpr [] = Nothing defAltExpr (Alt Default e:_) = Just e defAltExpr (_:xs) = defAltExpr xs -liftSymDefAltPCs :: Expr -> AltMatch -> Maybe PathCond-liftSymDefAltPCs mexpr (DataAlt dc _) = Just $ ConsCond dc mexpr False-liftSymDefAltPCs mexpr (LitAlt lit) = Just $ AltCond lit mexpr False-liftSymDefAltPCs _ Default = Nothing+-- | Creates and applies new symbolic variables for arguments of Data Constructor+concretizeSym :: [(Id, Type)] -> Maybe Coercion -> (State t, NameGen) -> DataCon -> ((State t, NameGen), Expr)+concretizeSym bi maybeC (s, ng) dc@(DataCon _ ts) =+ let dc' = Data dc+ ts' = anonArgumentTypes $ PresType ts+ ts'' = foldr (\(i, t) e -> retype i t e) ts' bi+ (ns, ng') = freshNames (length ts'') ng+ newParams = map (\(n, t) -> Id n t) (zip ns ts'')+ ts2 = map snd bi+ dc'' = mkApp $ dc' : (map Type ts2) ++ (map Var newParams)+ dc''' = case maybeC of+ (Just (t1 :~ t2)) -> Cast dc'' (t2 :~ t1)+ Nothing -> dc''+ eenv = foldr E.insertSymbolic (expr_env s) newParams+ in ((s {expr_env = eenv} , ng'), dc''') +createCaseExpr :: Id -> Type -> [Expr] -> Expr+createCaseExpr _ _ [e] = e+createCaseExpr newId t es@(_:_) =+ let+ -- We assume that PathCond restricting newId's range is added elsewhere+ (_, alts) = bindExprToNum (\num e -> Alt (LitAlt (LitInt num)) e) es+ in Case (Var newId) newId t alts+createCaseExpr _ _ [] = error "No exprs"++bindExprToNum :: (Integer -> a -> b) -> [a] -> (Integer, [b])+bindExprToNum f es = L.mapAccumL (\num e -> (num + 1, f num e)) 1 es+++-- | Return PathCond restricting value of `newId` to [lower, upper]+restrictSymVal :: KnownValues -> Integer -> Integer -> Id -> PathCond+restrictSymVal kv lower upper newId =+ ExtCond (mkAndExpr kv (mkGeIntExpr kv (Var newId) lower) (mkLeIntExpr kv (Var newId) upper)) True++----------------------------------------------------+ evalCast :: State t -> NameGen -> Expr -> Coercion -> (Rule, [State t], NameGen)-evalCast s@(State { exec_stack = stck }) - ng e c- | cast /= cast' =+evalCast s@(State { expr_env = eenv+ , exec_stack = stck }) + ng e c@(t1 :~ t2)+ | Var (Id n _) <- e+ , E.isSymbolic n eenv+ , hasFuncType (PresType t2) && not (hasFuncType $ PresType t1) =+ let+ (i, ng') = freshId t2 ng+ new_e = Cast (Var i) (t2 :~ t1)+ in+ ( RuleOther+ , [s { expr_env = E.insertSymbolic i $ E.insert n new_e eenv+ , curr_expr = CurrExpr Return (Var i) }]+ , ng')+ | cast <- Cast e c+ , (cast', ng') <- splitCast ng cast+ , cast /= cast' = ( RuleEvalCastSplit , [ s { curr_expr = CurrExpr Evaluate $ simplifyCasts cast' }] , ng')@@ -562,8 +777,7 @@ , exec_stack = S.push frame stck}] , ng) where- cast = Cast e c- (cast', ng') = splitCast ng cast+ frame = CastFrame c evalTick :: State t -> NameGen -> Tickish -> Expr -> (Rule, [State t], NameGen)@@ -576,18 +790,21 @@ in (RuleNonDet, s', ng) -evalSymGen :: State t -> NameGen -> Type -> (Rule, [State t], NameGen)+evalSymGen :: State t -> NameGen -> SymLog -> Type -> (Rule, [State t], NameGen) evalSymGen s@( State { expr_env = eenv }) - ng t =+ ng sl t = let (n, ng') = freshSeededString "symG" ng i = Id n t - eenv' = E.insertSymbolic n i eenv+ eenv' = E.insertSymbolic i eenv+ sg = case sl of+ SLog -> sym_gens s S.:|> n+ SNoLog -> sym_gens s in (RuleSymGen, [s { expr_env = eenv' , curr_expr = CurrExpr Evaluate (Var i)- , symbolic_ids = i:symbolic_ids s }]+ , sym_gens = sg }] , ng') evalAssume :: State t -> NameGen -> Maybe FuncCall -> Expr -> Expr -> (Rule, [State t], NameGen)@@ -639,10 +856,10 @@ , [s { curr_expr = CurrExpr Evaluate (App e1 e2) , exec_stack = stck' }], ng) -retCaseFrame :: State t -> NameGen -> Expr -> Id -> [Alt] -> S.Stack Frame -> (Rule, [State t], NameGen)-retCaseFrame s b e i a stck =+retCaseFrame :: State t -> NameGen -> Expr -> Id -> Type -> [Alt] -> S.Stack Frame -> (Rule, [State t], NameGen)+retCaseFrame s b e i t a stck = ( RuleReturnECase- , [s { curr_expr = CurrExpr Evaluate (Case e i a)+ , [s { curr_expr = CurrExpr Evaluate (Case e i t a) , exec_stack = stck }] , b) @@ -653,12 +870,83 @@ , exec_stack = stck}] , ng) -retCurrExpr :: State t -> Expr -> CurrExpr -> S.Stack Frame -> (Rule, [NewPC t])-retCurrExpr s e1 e2 stck = +retCurrExpr :: State t -> Expr -> CEAction -> CurrExpr -> S.Stack Frame -> (Rule, [NewPC t])+retCurrExpr s@(State { expr_env = eenv, known_values = kv }) e1 (EnsureEq e2) orig_ce stck+ | e1 == e2 =+ ( RuleReturnCurrExprFr+ , [NewPC { state = s { curr_expr = orig_ce+ , exec_stack = stck }+ , new_pcs = []+ , concretized = [] }] )+ | Cast e1' c1 <- e1+ , Cast e2' c2 <- e2+ , c1 == c2 = retCurrExpr s e1' (EnsureEq e2') orig_ce stck++ | isExprValueForm eenv e1+ , isExprValueForm eenv e2+ , t1 <- typeOf e1+ , isPrimType t1 || t1 == tyBool kv =+ assert (typeOf e2 == t1)+ ( RuleReturnCurrExprFr+ , [NewPC { state = s { curr_expr = orig_ce+ , exec_stack = stck}+ , new_pcs = [ExtCond (mkEqPrimExpr kv e1 e2) True]+ , concretized = [] }] )++ -- Symmetric cases for e1/e2 being symbolic variables + | Var (Id n t) <- e1+ , E.isSymbolic n eenv+ , not (isPrimType t || t == tyBool kv) =+ ( RuleReturnCurrExprFr+ , [NewPC { state = s { curr_expr = orig_ce+ , expr_env = E.insert n e2 eenv+ , exec_stack = stck}+ , new_pcs = []+ , concretized = [] }] )+ | Var (Id n t) <- e2+ , E.isSymbolic n eenv+ , not (isPrimType t || t == tyBool kv) =+ ( RuleReturnCurrExprFr+ , [NewPC { state = s { curr_expr = orig_ce+ , expr_env = E.insert n e1 eenv+ , exec_stack = stck}+ , new_pcs = []+ , concretized = [] }] )++ | Data dc1:es1 <- unApp e1+ , Data dc2:es2 <- unApp e2 =+ case dc1 == dc2 of+ True ->+ let+ es = zip es1 es2+ in+ ( RuleReturnCurrExprFr+ , [NewPC { state = s { curr_expr = orig_ce+ , non_red_path_conds = es ++ non_red_path_conds s+ , exec_stack = stck}+ , new_pcs = []+ , concretized = [] }] )+ False ->+ ( RuleReturnCurrExprFr+ , [NewPC { state = s { curr_expr = orig_ce+ , exec_stack = stck}+ , new_pcs = [ExtCond (mkFalse kv) True]+ , concretized = [] }] )+ | otherwise =+ assert (not (isExprValueForm eenv e2))+ ( RuleReturnCurrExprFr+ , [NewPC { state = s { curr_expr = CurrExpr Evaluate e2+ , non_red_path_conds = non_red_path_conds s+ , exec_stack = S.push (CurrExprFrame (EnsureEq e1) orig_ce) stck}+ , new_pcs = []+ , concretized = [] }] )++retCurrExpr s _ NoAction orig_ce stck = ( RuleReturnCurrExprFr- , [NewPC { state = s { curr_expr = e2+ , [NewPC { state = s { curr_expr = orig_ce , exec_stack = stck}- , new_pcs = [ExtCond e1 True]}] )+ , new_pcs = []+ , concretized = []}] ) retAssumeFrame :: State t -> NameGen -> Expr -> Expr -> S.Stack Frame -> (Rule, [NewPC t], NameGen) retAssumeFrame s@(State {known_values = kv@@ -669,10 +957,18 @@ dalt = case (getDataCon tenv (KV.tyBool kv) (KV.dcTrue kv)) of Just dc -> [dc] _ -> []- -- If Assume is just a Var, concretize the Expr to a True Bool DataCon. Else add an ExtCond+ -- Special handling in case we just have a concrete DataCon, or a lone Var (newPCs, ng') = case unApp $ unsafeElimOuterCast e1 of+ [Data (DataCon dcn _)]+ | dcn == KV.dcFalse kv -> ([], ng)+ | dcn == KV.dcTrue kv ->+ ( [NewPC { state = s { curr_expr = CurrExpr Evaluate e2+ , exec_stack = stck }+ , new_pcs = []+ , concretized = [] }]+ , ng) (Var i@(Id _ _)):_ -> concretizeExprToBool s ng i dalt e2 stck- _ -> addExtCond s ng e1 e2 True stck+ _ -> addExtCond s ng e1 e2 stck in (RuleReturnCAssume, newPCs, ng') @@ -685,8 +981,23 @@ dalts = case getDataCons (KV.tyBool kv) tenv of Just dcs -> dcs _ -> []- -- If Assert is just a Var, concretize the Expr to a True or False Bool DataCon, else add an ExtCond+ -- Special handling in case we just have a concrete DataCon, or a lone Var (newPCs, ng') = case unApp $ unsafeElimOuterCast e1 of+ [Data (DataCon dcn _)]+ | dcn == KV.dcFalse kv ->+ ( [NewPC { state = s { curr_expr = CurrExpr Evaluate e2+ , exec_stack = stck+ , true_assert = True+ , assert_ids = ais } + , new_pcs = []+ , concretized = [] }]+ , ng)+ | dcn == KV.dcTrue kv ->+ ( [NewPC { state = s { curr_expr = CurrExpr Evaluate e2+ , exec_stack = stck }+ , new_pcs = []+ , concretized = [] }]+ , ng) (Var i@(Id _ _)):_ -> concretizeExprToBool s ng i dalts e2 stck _ -> addExtConds s ng e1 ais e2 stck @@ -703,31 +1014,31 @@ concretizeExprToBool' :: State t -> NameGen -> Id -> DataCon -> Expr -> S.Stack Frame -> (NewPC t, NameGen) concretizeExprToBool' s@(State {expr_env = eenv- , symbolic_ids = syms , known_values = kv}) ngen mexpr_id dcon@(DataCon dconName _) e2 stck = - (newPCEmpty $ s { expr_env = eenv'- , symbolic_ids = syms'+ (NewPC { state = s { expr_env = eenv' , exec_stack = stck , curr_expr = CurrExpr Evaluate e2 , true_assert = assertVal}- , ngen)+ , new_pcs = []+ , concretized = [] }+ , ngen) where mexpr_n = idName mexpr_id -- concretize the mexpr to the DataCon specified eenv' = E.insert mexpr_n (Data dcon) eenv- syms' = filter (/= mexpr_id) syms assertVal = if (dconName == (KV.dcTrue kv)) then False else True -addExtCond :: State t -> NameGen -> Expr -> Expr -> Bool -> S.Stack Frame -> ([NewPC t], NameGen)-addExtCond s ng e1 e2 boolVal stck = +addExtCond :: State t -> NameGen -> Expr -> Expr -> S.Stack Frame -> ([NewPC t], NameGen)+addExtCond s ng e1 e2 stck = ([NewPC { state = s { curr_expr = CurrExpr Evaluate e2 , exec_stack = stck}- , new_pcs = [ExtCond e1 boolVal]}], ng)+ , new_pcs = [ExtCond e1 True]+ , concretized = [] }], ng) addExtConds :: State t -> NameGen -> Expr -> Maybe (FuncCall) -> Expr -> S.Stack Frame -> ([NewPC t], NameGen) addExtConds s ng e1 ais e2 stck =@@ -739,11 +1050,13 @@ condf = [ExtCond e1 False] strue = NewPC { state = s'- , new_pcs = condt }+ , new_pcs = condt+ , concretized = []} sfalse = NewPC { state = s' { true_assert = True , assert_ids = ais }- , new_pcs = condf }+ , new_pcs = condf+ , concretized = []} in ([strue, sfalse], ng) @@ -757,49 +1070,155 @@ olds = map (idName) bindsLHS (news, ngen') = freshSeededNames olds ngen- expr' = renameExprs (zip olds news) expr- bindsLHS' = renameExprs (zip olds news) bindsLHS - binds' = zip bindsLHS' bindsRHS+ olds_news = HM.fromList $ zip olds news+ expr' = renamesExprs olds_news expr - eenv' = E.insertExprs (zip news (map snd binds')) eenv+ eenv' = E.insertExprs (zip news bindsRHS) eenv +liftBind :: Id -> Expr -> E.ExprEnv -> Expr -> NameGen ->+ (E.ExprEnv, Expr, NameGen, Name)+liftBind bindsLHS bindsRHS eenv expr ngen = (eenv', expr', ngen', new)+ where+ old = idName bindsLHS+ (new, ngen') = freshSeededName old ngen++ expr' = renameExpr old new expr++ eenv' = E.insert new bindsRHS eenv++type SymbolicFuncEval t = State t -> NameGen -> Expr -> Maybe (Rule, [State t], NameGen)++-- change literal rule to only match on arguments+retReplaceSymbFuncTemplate :: State t -> NameGen -> Expr -> Maybe (Rule, [State t], NameGen)+retReplaceSymbFuncTemplate s@(State { expr_env = eenv+ , type_env = tenv+ , known_values = kv })+ ng ce++ -- DC-SPLIT+ | Var (Id n (TyFun t1 t2)):es <- unApp ce+ , TyCon tname _:ts <- unTyApp t1 + , E.isSymbolic n eenv+ , Just alg_data_ty <- HM.lookup tname tenv+ = let+ ty_map = HM.fromList $ zip (map idName bound) ts++ dcs = applyTypeHashMap ty_map $ dataCon alg_data_ty+ bound = applyTypeHashMap ty_map $ bound_ids alg_data_ty++ (x, ng') = freshId t1 ng+ (x', ng'') = freshId t1 ng'+ (alts, symIds, ng''') =+ foldr (\dc@(DataCon _ dcty) (as, sids, ng1) ->+ let (argIds, ng1') = genArgIds dc ng1+ data_alt = DataAlt dc argIds+ sym_fun_ty = mkTyFun $ fst (argTypes dcty) ++ [t2]+ (fi, ng1'') = freshSeededId (Name "symFun" Nothing 0 Nothing) sym_fun_ty ng1'+ vargs = map Var argIds+ in (Alt data_alt (mkApp (Var fi : vargs)) : as, fi : sids, ng1'')+ ) ([], [], ng'') dcs+ -- alts = map (\dc -> Alt (Alt)) dcs+ e = Lam TermL x $ Case (Var x) x' t2 alts+ e' = mkApp (e:es)+ eenv' = foldr E.insertSymbolic eenv symIds+ eenv'' = E.insert n e eenv'+ (constState, ng'''') = mkFuncConst s es n t1 t2 ng'''+ in Just (RuleReturnReplaceSymbFunc, [s {+ curr_expr = CurrExpr Evaluate e',+ expr_env = eenv''+ }, constState], ng'''')++ -- FUNC-APP+ | Var (Id n (TyFun t1@(TyFun _ _) t2)):es <- unApp ce+ , E.isSymbolic n eenv+ = let+ (tfs, tr) = argTypes t1+ (xIds, ng') = freshIds tfs ng+ xs = map Var xIds+ (fId, ng'') = freshId (TyFun tr $ TyFun t1 t2) ng'+ f = Var fId+ (fa, ng''') = freshId t1 ng''+ e = Lam TermL fa $ mkApp [f, mkApp (Var fa : xs), Var fa]+ eenv' = foldr E.insertSymbolic eenv xIds+ -- eenv'' = E.insertSymbolic (idName fId) fId eenv'+ eenv'' = E.insertSymbolic fId eenv'+ eenv''' = E.insert n e eenv''+ (constState, ng'''') = mkFuncConst s es n t1 t2 ng'''+ in Just (RuleReturnReplaceSymbFunc, [s {+ curr_expr = CurrExpr Evaluate $ mkApp (e:es),+ expr_env = eenv'''+ }, constState], ng'''')++ -- LIT-SPLIT+ | App (Var (Id n (TyFun t1 t2))) ea <- ce+ , isPrimType t1+ , E.isSymbolic n eenv+ = let+ boolTy = (TyCon (KV.tyBool kv) TYPE)+ trueDc = DataCon (KV.dcTrue kv) boolTy+ falseDc = DataCon (KV.dcFalse kv) boolTy+ eqT1 = mkEqPrimType t1 kv+ (f1Id:f2Id:xId:discrimId:[], ng') = freshIds [t2, TyFun t1 t2, t1, boolTy] ng+ x = Var xId+ e = Lam TermL xId $ Case (mkApp [eqT1, x, ea]) discrimId t2+ [ Alt (DataAlt trueDc []) (Var f1Id)+ , Alt (DataAlt falseDc []) (App (Var f2Id) x)]+ eenv' = foldr E.insertSymbolic eenv [f1Id, f2Id]+ eenv'' = E.insert n e eenv'+ in Just (RuleReturnReplaceSymbFunc, [s {+ -- because we are always going down true branch+ curr_expr = CurrExpr Evaluate (Var f1Id),+ expr_env = eenv''+ }], ng')+ | otherwise = Nothing++argTypes :: Type -> ([Type], Type)+argTypes t = (anonArgumentTypes $ PresType t, returnType $ PresType t)++genArgIds :: DataCon -> NameGen -> ([Id], NameGen)+genArgIds (DataCon _ dcty) ng =+ let (argTys, _) = argTypes dcty+ in foldr (\ty (is, ng') -> let (i, ng'') = freshId ty ng' in ((i:is), ng'')) ([], ng) argTys++mkFuncConst :: State t -> [Expr] -> Name -> Type -> Type -> NameGen -> (State t, NameGen)+mkFuncConst s@(State { expr_env = eenv } ) es n t1 t2 ng =+ let+ (fId:xId:[], ng') = freshIds [t2, t1] ng+ eenv' = foldr E.insertSymbolic eenv [fId]+ e = Lam TermL xId $ Var fId+ eenv'' = E.insert n e eenv'+ in (s {+ curr_expr = CurrExpr Evaluate $ mkApp (e:es),+ -- symbolic_ids = fId:symbolic_ids state,+ expr_env = eenv''+ }, ng')+ -- If the expression is a symbolic higher order function application, replaces -- it with a symbolic variable of the correct type. -- A non reduced path constraint is added, to force solving for the symbolic -- function later.-retReplaceSymbFunc :: State t -> NameGen -> Expr -> Maybe (Rule, [State t], NameGen)-retReplaceSymbFunc s@(State { expr_env = eenv- , known_values = kv- , type_classes = tc- , exec_stack = stck })- ng ce+retReplaceSymbFuncVar :: State t -> NameGen -> Expr -> Maybe (Rule, [State t], NameGen)+retReplaceSymbFuncVar s@(State { expr_env = eenv+ , known_values = kv+ , type_classes = tc+ , exec_stack = stck })+ ng ce | Just (frm, _) <- S.pop stck , not (isApplyFrame frm) , (Var (Id f idt):_) <- unApp ce , E.isSymbolic f eenv , isTyFun idt , t <- typeOf ce- , not (isTyFun t)- , Just eq_tc <- concreteSatStructEq kv tc t =+ , not (isTyFun t) = let (new_sym, ng') = freshSeededString "sym" ng new_sym_id = Id new_sym t-- s_eq_f = KV.structEqFunc kv-- nrpc_e = mkApp $ - [ Var (Id s_eq_f TyUnknown)- , Type t- , eq_tc- , Var new_sym_id- , ce ] in Just (RuleReturnReplaceSymbFunc, - [s { expr_env = E.insertSymbolic new_sym new_sym_id eenv+ [s { expr_env = E.insertSymbolic new_sym_id eenv , curr_expr = CurrExpr Return (Var new_sym_id)- , symbolic_ids = new_sym_id:symbolic_ids s- , non_red_path_conds = non_red_path_conds s ++ [nrpc_e] }]+ , non_red_path_conds = non_red_path_conds s ++ [(ce, Var new_sym_id)] }] , ng') | otherwise = Nothing
src/G2/Initialization/DeepSeqWalks.hs view
@@ -17,7 +17,7 @@ createDeepSeqWalks :: ExprEnv -> TypeEnv -> NameGen -> (ExprEnv, NameGen, Walkers) createDeepSeqWalks eenv tenv ng = let- tenv' = M.toList tenv+ tenv' = HM.toList tenv in createFuncs eenv ng tenv' M.empty (createDeepSeqName . fst) createDeepSeqStore (createDeepSeqExpr tenv) @@ -31,10 +31,12 @@ bn = map TyVar $ bound_ids adt bnf = map (\b -> TyFun b b) bn - base = TyFun (TyCon n TYPE) (TyCon n TYPE)+ dc_t = foldr (const $ TyFun TYPE) TYPE [1..length bi] + base = TyFun (TyCon n dc_t) (TyCon n dc_t)+ t = foldr TyFun base (bn ++ bnf)- t' = foldr TyForAll t $ map NamedTyBndr bi+ t' = foldr TyForAll t bi i = Id n' t' in M.insert n i w@@ -70,7 +72,11 @@ (alts, ng''') = createDeepSeqDataConCase1Alts tenv w ti n caseB rm bn ng'' dc - c = Case (Var i) caseB alts+ dc_t = case dc of+ (d:_) -> typeOf d+ _ -> TyBottom++ c = Case (Var i) caseB dc_t alts in (Lam TermL i c, ng''') createDeepSeqCase1 _ w ti n rm bn (NewTyCon {rep_type = t}) ng =@@ -83,14 +89,14 @@ cast = Cast (Var i) (t' :~ t'') - e = deepSeqFuncCall w ti rm (Var caseB)+ (e, ng''') = deepSeqFuncCall w ng'' ti rm (Var caseB) e' = Cast e (t'' :~ t') alt = Alt Default e' - c = Case cast caseB [alt]+ c = Case cast caseB t' [alt] in- (Lam TermL i c, ng'')+ (Lam TermL i c, ng''') createDeepSeqCase1 _ _ _ _ _ _ _ _ = error "createDeepSeqCase1: bad argument passed" createDeepSeqDataConCase1Alts :: TypeEnv -> Walkers -> [(Name, Id)] -> Name -> Id -> RenameMap -> [BoundName] -> NameGen -> [DataCon] -> ([Alt], NameGen)@@ -119,45 +125,45 @@ foldl' App e tb tyForAllIds :: Type -> [Id]-tyForAllIds (TyForAll (NamedTyBndr i) t) = i:tyForAllIds t+tyForAllIds (TyForAll i t) = i:tyForAllIds t tyForAllIds _ = [] createDeepSeqDataConCase2 :: TypeEnv -> Walkers -> [(Name, Id)] -> RenameMap -> [Id] -> NameGen -> Expr -> (Expr, NameGen) createDeepSeqDataConCase2 _ _ _ _ [] ng e = (e, ng) createDeepSeqDataConCase2 tenv w ti rm (i:is) ng e | t@(TyCon n _) <- typeOf i - , Just (NewTyCon {rep_type = rt}) <- M.lookup n tenv =+ , Just (NewTyCon {rep_type = rt}) <- HM.lookup n tenv = let (i', ng') = freshId rt ng - b = deepSeqFuncCall w ti rm (Var i)+ (b, ng'') = deepSeqFuncCall w ng' ti rm (Var i) bCast = Cast b (t :~ rt) vi = Var i' viCast = Cast vi (rt :~ t) - (ae, ng'') = createDeepSeqDataConCase2 tenv w ti rm is ng' (App e viCast)+ (ae, ng''') = createDeepSeqDataConCase2 tenv w ti rm is ng'' (App e viCast) in- (Case bCast i' [Alt Default ae], ng'')+ (Case bCast i' (typeOf e) [Alt Default ae], ng''') | otherwise = let (i', ng') = freshId (typeOf i) ng - b = deepSeqFuncCall w ti rm (Var i)+ (b, ng'') = deepSeqFuncCall w ng' ti rm (Var i) - (ae, ng'') = createDeepSeqDataConCase2 tenv w ti rm is ng' (App e (Var i'))+ (ae, ng''') = createDeepSeqDataConCase2 tenv w ti rm is ng'' (App e (Var i')) in- (Case b i' [Alt Default ae], ng'')+ (Case b i' (typeOf ae) [Alt Default ae], ng''') -- Calling a higher order function-deepSeqFuncCall :: Walkers -> [(Name, Id)] -> RenameMap -> Expr -> Expr-deepSeqFuncCall w ti rm e =- case deepSeqFunc w ti rm e of- Just e' -> App e' e- Nothing -> e+deepSeqFuncCall :: Walkers -> NameGen -> [(Name, Id)] -> RenameMap -> Expr -> (Expr, NameGen)+deepSeqFuncCall w ng ti rm e =+ case deepSeqFunc w ng ti rm e of+ Just (e', ng') -> (App e' e, ng')+ Nothing -> (e, ng) -deepSeqFunc :: Typed t => Walkers -> [(Name, Id)] -> RenameMap -> t -> Maybe Expr-deepSeqFunc w ti rm e+deepSeqFunc :: Typed t => Walkers -> NameGen -> [(Name, Id)] -> RenameMap -> t -> Maybe (Expr, NameGen)+deepSeqFunc w ng ti rm e | t <- typeOf e , TyCon n _ <- tyAppCenter t , ts <- tyAppArgs t@@ -166,10 +172,30 @@ as = map Type $ renames rm ts as' = map (walkerFunc w ti rm) ts in- Just $ foldl' App (Var f) (as ++ as')+ Just $ (foldl' App (Var f) (as ++ as'), ng)+ | t@(TyFun _ _) <- typeOf e =+ let+ (a_in, ng') = freshId t ng++ tys = anonArgumentTypes e+ (f_is, ng'') = freshIds tys ng' + + cll = mkApp $ Var a_in:map Var f_is+ let_cll = Let (zip f_is $ map (SymGen SNoLog) tys) cll++ ds_type = typeOf ds_cll++ (ds_cll, ng''') = deepSeqFuncCall w ng'' ti rm let_cll+ (bnd, ng'''') = freshId ds_type ng'''++ (lam_ids, ng''''') = freshIds tys ng''''++ cse = Case ds_cll bnd ds_type [Alt Default $ mkLams (zip (repeat TermL) lam_ids) (Var bnd)]+ in+ Just (Lam TermL a_in cse, ng''''') | (TyVar (Id n _)) <- typeOf e , Just f <- lookup n ti =- Just $ Var f+ Just (Var f, ng) | otherwise = Nothing walkerFunc :: Walkers -> [(Name, Id)] -> RenameMap -> Type -> Expr@@ -182,7 +208,7 @@ , Just f <- M.lookup n w = let as = renames rm $ map Type ts- ft = renames rm $ mapMaybe (deepSeqFunc w ti rm . PresType) ts+ ft = renames rm . map fst $ mapMaybe (deepSeqFunc w undefined ti rm . PresType) ts in foldl' App (Var f) (as ++ ft) walkerFunc _ ni _ t = error $ "walkerFunc: bad argument passed" ++ "\n" ++ show ni ++ "\n" ++ show t
src/G2/Initialization/ElimTicks.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} -module G2.Initialization.ElimTicks (elimTicks) where+module G2.Initialization.ElimTicks (elimBreakpoints) where import G2.Language -elimTicks :: ASTContainer m Expr => m -> m-elimTicks = modifyASTsFix elimTicks'+elimBreakpoints :: ASTContainer m Expr => m -> m+elimBreakpoints = modifyASTs elimBreakpoints' -elimTicks' :: Expr -> Expr-elimTicks' (Tick _ e) = e-elimTicks' e = e+elimBreakpoints' :: Expr -> Expr+elimBreakpoints' (Tick (Breakpoint _) e) = elimBreakpoints' e+elimBreakpoints' e = e
src/G2/Initialization/ElimTypeSynonyms.hs view
@@ -1,26 +1,27 @@ {-# LANGUAGE FlexibleContexts #-} module G2.Initialization.ElimTypeSynonyms ( elimTypeSyms- , elimTypeSymsTEnv) where+ , elimTypeSymsTEnv) where import G2.Language -import qualified Data.Map as M+import qualified Data.HashMap.Lazy as HM elimTypeSyms :: ASTContainer m Type => TypeEnv -> m -> m-elimTypeSyms tenv = modifyASTsFix (elimTypeSyms' tenv)+elimTypeSyms tenv = modifyASTs (elimTypeSyms' tenv) elimTypeSyms' :: TypeEnv -> Type -> Type elimTypeSyms' tenv t | (TyCon n _) <- tyAppCenter t , ts <- tyAppArgs t- , Just (TypeSynonym { bound_ids = is, synonym_of = st }) <- M.lookup n tenv+ , Just (TypeSynonym { bound_ids = is, synonym_of = st }) <- HM.lookup n tenv , length ts == length is =- foldr (uncurry replaceASTs) st $ zip (map TyVar is) ts+ -- We recursively call elimTypeSyms, in case a type synonym maps directly to a type synonym+ elimTypeSyms' tenv $ foldr (uncurry replaceASTs) st $ zip (map TyVar is) ts elimTypeSyms' _ t = t elimTypeSymsTEnv :: TypeEnv -> TypeEnv-elimTypeSymsTEnv tenv = elimTypeSyms tenv . M.filter (not . typeSym) $ tenv+elimTypeSymsTEnv tenv = elimTypeSyms tenv . HM.filter (not . typeSym) $ tenv typeSym :: AlgDataTy -> Bool typeSym (TypeSynonym _ _) = True
src/G2/Initialization/Interface.hs view
@@ -6,26 +6,29 @@ import G2.Initialization.ElimTicks import G2.Initialization.ElimTypeSynonyms import G2.Initialization.InitVarLocs-import G2.Initialization.StructuralEq import G2.Initialization.Types as IT -runInitialization :: IT.SimpleState -> [Type] -> (IT.SimpleState, Walkers)-runInitialization s@(IT.SimpleState { IT.expr_env = eenv- , IT.type_env = tenv- , IT.name_gen = ng- , IT.type_classes = tc }) ts =+type MkArgTypes = IT.SimpleState -> [Type]++runInitialization1 :: IT.SimpleState -> IT.SimpleState+runInitialization1 = elimBreakpoints . initVarLocs++runInitialization2 :: IT.SimpleState -> MkArgTypes -> (IT.SimpleState, Walkers)+runInitialization2 s@(IT.SimpleState { IT.expr_env = eenv+ , IT.type_env = tenv+ , IT.name_gen = ng+ , IT.type_classes = tc }) argTys = let eenv2 = elimTypeSyms tenv eenv tenv2 = elimTypeSymsTEnv tenv tc2 = elimTypeSyms tenv tc (eenv3, ng2, ds_walkers) = createDeepSeqWalks eenv2 tenv2 ng + ts = argTys (s { IT.expr_env = eenv3, IT.type_env = tenv2, IT.type_classes = tc2 })+ s' = s { IT.expr_env = eenv3 , IT.type_env = tenv2 , IT.name_gen = ng2 , IT.type_classes = tc2 }-- s'' = execSimpleStateM (createStructEqFuncs ts) s'- s''' = elimTicks . initVarLocs $ s'' in- (s''', ds_walkers)+ (s', ds_walkers)
src/G2/Initialization/KnownValues.hs view
@@ -1,17 +1,27 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module G2.Initialization.KnownValues (initKnownValues) where import qualified G2.Language.ExprEnv as E import G2.Language.KnownValues import G2.Language.Syntax+import G2.Language.TypeClasses import G2.Language.TypeEnv+import G2.Language.Typing (PresType (..), tyAppCenter, returnType) -import qualified Data.Map as M+import Data.List+import qualified Data.HashMap.Lazy as HM import qualified Data.Text as T -initKnownValues :: E.ExprEnv -> TypeEnv -> KnownValues-initKnownValues eenv tenv =+initKnownValues :: E.ExprEnv -> TypeEnv -> TypeClasses -> KnownValues+initKnownValues eenv tenv tc =+ let+ numT = typeWithStrName tenv "Num"+ integralT = typeWithStrName tenv "Integral"+ realT = typeWithStrName tenv "Real"+ eqT = typeWithStrName tenv "Eq"+ ordT = typeWithStrName tenv "Ord"+ in KnownValues { tyInt = typeWithStrName tenv "Int" , dcInt = dcWithStrName tenv "Int" "I#"@@ -32,15 +42,37 @@ , dcTrue = dcWithStrName tenv "Bool" "True" , dcFalse = dcWithStrName tenv "Bool" "False" + , tyRational = typeWithStrName tenv "Rational"++#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+ , tyList = typeWithStrName tenv "List"+ , dcCons = dcWithStrName tenv "List" ":"+ , dcEmpty = dcWithStrName tenv "List" "[]"+#else , tyList = typeWithStrName tenv "[]" , dcCons = dcWithStrName tenv "[]" ":" , dcEmpty = dcWithStrName tenv "[]" "[]"+#endif - , eqTC = typeWithStrName tenv "Eq"- , numTC = typeWithStrName tenv "Num"- , ordTC = typeWithStrName tenv "Ord"- , integralTC = typeWithStrName tenv "Integral"+ , tyMaybe = typeWithStrName tenv "Maybe"+ , dcJust = dcWithStrName tenv "Maybe" "Just"+ , dcNothing = dcWithStrName tenv "Maybe" "Nothing" + , tyUnit = typeWithStrName tenv "()"+ , dcUnit = dcWithStrName tenv "()" "()"++ , eqTC = eqT+ , numTC = numT+ , ordTC = ordT+ , integralTC = integralT+ , realTC = realT+ , fractionalTC = typeWithStrName tenv "Fractional"++ , integralExtactReal = superClassExtractor tc integralT realT+ , realExtractNum = superClassExtractor tc realT numT+ , realExtractOrd = superClassExtractor tc realT ordT+ , ordExtractEq = superClassExtractor tc ordT eqT+ , eqFunc = exprWithStrName eenv "==" , neqFunc = exprWithStrName eenv "/=" @@ -50,20 +82,28 @@ , divFunc = exprWithStrName eenv "/" , negateFunc = exprWithStrName eenv "negate" , modFunc = exprWithStrName eenv "mod"+ , fromIntegerFunc = exprWithStrName eenv "fromInteger" , toIntegerFunc = exprWithStrName eenv "toInteger" + , toRatioFunc = exprWithStrName eenv "%"+ , fromRationalFunc = exprWithStrName eenv "fromRational"+ , geFunc = exprWithStrName eenv ">=" , gtFunc = exprWithStrName eenv ">" , ltFunc = exprWithStrName eenv "<" , leFunc = exprWithStrName eenv "<=" - , structEqTC = Name "NotDefinedYet" Nothing 0 Nothing- , structEqFunc = Name "NotDefinedYet" Nothing 0 Nothing+ , impliesFunc = exprWithStrName eenv "implies"+ , iffFunc = exprWithStrName eenv "iff" , andFunc = exprWithStrName eenv "&&" , orFunc = exprWithStrName eenv "||"+ , notFunc = exprWithStrName eenv "not" + , errorFunc = exprWithStrName eenv "error"+ , errorEmptyListFunc = exprWithStrName eenv "errorEmptyList"+ , errorWithoutStackTraceFunc = exprWithStrName eenv "errorWithoutStackTrace" , patErrorFunc = exprWithStrName eenv "patError" } @@ -75,14 +115,14 @@ typeWithStrName :: TypeEnv -> T.Text -> Name typeWithStrName tenv s =- case M.toList $ M.filterWithKey (\(Name n _ _ _) _ -> n == s) tenv of+ case HM.toList $ HM.filterWithKey (\(Name n _ _ _) _ -> n == s) tenv of (n, _):_ -> n _ -> error $ "No type found in typeWithStrName " ++ (show $ T.unpack s) dcWithStrName :: TypeEnv -> T.Text -> T.Text -> Name dcWithStrName tenv ts dcs =- case concatMap dataCon . M.elems $ M.filterWithKey (\(Name n _ _ _) _ -> n == ts) tenv of- [] -> error $ "No type found in typeWithStrName [" +++ case concatMap dataCon . HM.elems $ HM.filterWithKey (\(Name n _ _ _) _ -> n == ts) tenv of+ [] -> error $ "No type found in dcWithStrName [" ++ (show $ T.unpack ts) ++ "] [" ++ (show $ T.unpack dcs) ++ "]" dc -> dcWithStrName' dc dcs @@ -91,3 +131,18 @@ if n' == s then n else dcWithStrName' xs s dcWithStrName' _ s = error $ "No dc found in dcWithStrName [" ++ (show $ T.unpack s) ++ "]" +superClassExtractor :: TypeClasses -> Name -> Name -> Name+superClassExtractor tc tc_n sc_n =+ case lookupTCClass tc_n tc of+ Just c+ | Just (_, i) <- find extractsSC (superclasses c) -> idName i+ | otherwise -> error $ "superClassExtractor: Extractor not found\n" ++ show sc_n ++ "\n" ++ show (superclasses c)+ Nothing -> error $ "superClassExtractor: Class not found " ++ show tc_n+ where+ extractsSC (t, _) =+ let+ t_c = tyAppCenter . returnType . PresType $ t+ in+ case t_c of+ TyCon n _ -> n == sc_n+ _ -> False
src/G2/Initialization/MkCurrExpr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase, OverloadedStrings #-} module G2.Initialization.MkCurrExpr ( mkCurrExpr , checkReaches@@ -10,23 +10,29 @@ import qualified G2.Language.ExprEnv as E import Data.List+import qualified Data.Map as M+import Data.Maybe import qualified Data.Text as T mkCurrExpr :: Maybe T.Text -> Maybe T.Text -> Id- -> TypeClasses -> NameGen -> ExprEnv -> Walkers+ -> TypeClasses -> NameGen -> ExprEnv -> TypeEnv -> Walkers -> KnownValues -> Config -> (Expr, [Id], [Expr], NameGen)-mkCurrExpr m_assume m_assert f@(Id (Name _ m_mod _ _) _) tc ng eenv walkers kv config =+mkCurrExpr m_assume m_assert f@(Id (Name _ m_mod _ _) _) tc ng eenv _ walkers kv config = case E.lookup (idName f) eenv of Just ex -> let- typs = spArgumentTypes ex+ var_ex = Var (Id (idName f) (typeOf ex))+ -- typs = spArgumentTypes ex - (typsE, typs') = instantitateTypes tc kv typs+ -- (typsE, typs') = instantitateTypes tc kv typs - (var_ids, is, ng') = mkInputs ng typs'+ -- (var_ids, is, ng') = mkInputs ng typs' - var_ex = Var f- app_ex = foldl' App var_ex $ typsE ++ var_ids+ -- -- We refind the type of f, because type synonyms get replaced during the initializaton,+ -- -- after we first got the type of f.+ -- app_ex = foldl' App var_ex $ typsE ++ var_ids+ (app_ex, is, typsE, ng') = mkMainExpr tc kv ng var_ex+ var_ids = map Var is -- strict_app_ex = app_ex strict_app_ex = if strict config then mkStrict walkers app_ex else app_ex@@ -45,6 +51,19 @@ (let_ex, is, typsE, ng'') Nothing -> error "mkCurrExpr: Bad Name" +mkMainExpr :: TypeClasses -> KnownValues -> NameGen -> Expr -> (Expr, [Id], [Expr], NameGen)+mkMainExpr tc kv ng ex =+ let+ typs = spArgumentTypes ex++ (typsE, typs') = instantitateTypes tc kv typs++ (var_ids, is, ng') = mkInputs ng typs'+ + app_ex = foldl' App ex $ typsE ++ var_ids+ in+ (app_ex, is, typsE, ng')+ mkInputs :: NameGen -> [Type] -> ([Expr], [Id], NameGen) mkInputs ng [] = ([], [], ng) mkInputs ng (t:ts) =@@ -82,7 +101,7 @@ [] -> Right $ "No functions with name " ++ (T.unpack s) [(n, e)] -> Left (Id n (typeOf e) , e) pairs -> case m_mod of- Nothing -> Right $ "Multiple functions with same name. " +++ Nothing -> Right $ "Multiple functions with same name. " ++ show s ++ " " ++ show m_mod ++ "Wrap the target function in a module so we can try again!" Just m -> case filter (\(n, _) -> nameModule n == Just m) pairs of [(n, e)] -> Left (Id n (typeOf e), e)@@ -90,7 +109,6 @@ _ -> Right $ "Multiple functions with same name " ++ (T.unpack s) ++ " in module " ++ (T.unpack m) - instantiateArgTypes :: TypeClasses -> KnownValues -> Expr -> ([Expr], [Type]) instantiateArgTypes tc kv e = let@@ -101,20 +119,24 @@ instantitateTypes :: TypeClasses -> KnownValues -> [ArgType] -> ([Expr], [Type]) instantitateTypes tc kv ts = let- tv = map (typeNamedId) $ filter (typeNamed) ts+ tv = mapMaybe (\case NamedType i -> Just i; AnonType _ -> Nothing) ts -- Get non-TyForAll type reqs, identify typeclasses- ts' = map typeAnonType $ filter (not . typeNamed) ts- tcSat = map (\i -> (i, satisfyingTCTypes kv tc i ts')) tv+ ts' = mapMaybe (\case AnonType t -> Just t; NamedType _ -> Nothing) ts+ tcSat = snd $ mapAccumL (\ts'' i ->+ let+ sat = satisfyingTCTypes kv tc i ts''+ pt = pickForTyVar kv sat+ in+ (replaceTyVar (idName i) pt ts'', (i, pt))) ts' tv - -- TyForAll type reqs- tv' = map (\(i, ts'') -> (i, pickForTyVar kv ts'')) tcSat- tvt = map (\(i, t) -> (TyVar i, t)) tv'- -- Dictionary arguments- vi = concatMap (uncurry (satisfyingTC tc ts')) tv'+ -- Get dictionary arguments+ vi = mapMaybe (instantiateTCDict tc tcSat) ts' - ex = map (Type . snd) tv' ++ vi- tss = filter (not . isTypeClass tc) $ foldr (uncurry replaceASTs) ts' tvt+ ex = map (Type . snd) tcSat ++ vi+ tss = filter (not . isTypeClass tc)+ . foldr (uncurry replaceASTs) ts'+ $ map (\(i, t) -> (TyVar i, t)) tcSat in (ex, tss) @@ -125,17 +147,14 @@ | t:_ <- ts = t | otherwise = error "No type found in pickForTyVar" -typeNamedId :: ArgType -> Id-typeNamedId (NamedType i) = i-typeNamedId (AnonType _) = error "No Id in T" -typeAnonType :: ArgType -> Type-typeAnonType (NamedType _) = error "No type in NamedType"-typeAnonType (AnonType t) = t --typeNamed :: ArgType -> Bool-typeNamed (NamedType _) = True-typeNamed _ = False+instantiateTCDict :: TypeClasses -> [(Id, Type)] -> Type -> Maybe Expr+instantiateTCDict tc it tyapp@(TyApp _ t) | TyCon n _ <- tyAppCenter tyapp =+ let+ t' = applyTypeMap (M.fromList $ map (\(Id ni _, ti) -> (ni,ti)) it) t+ in+ return . Var =<< lookupTCDict tc n t'+instantiateTCDict _ _ _ = Nothing checkReaches :: ExprEnv -> KnownValues -> Maybe T.Text -> Maybe T.Text -> ExprEnv checkReaches eenv _ Nothing _ = eenv
− src/G2/Initialization/StructuralEq.hs
@@ -1,290 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}--module G2.Initialization.StructuralEq ( createStructEqFuncs- , structEqFuncType- , structEqFuncTypeM) where--import G2.Language as L-import G2.Language.Monad-import G2.Language.KnownValues--import qualified Data.Foldable as F-import Data.List-import qualified Data.Map as M-import Data.Maybe-import qualified Data.Text as T---- | createStructEqFuncs--- Creates a typeclass to compare two ADTs based on there structural equality---- that is, compare if they have exactly the same (possibly recursive) constructors.--- If some of the constructors have higher order function arguments,--- those higher order functions are not checked for equality, and do not prevent--- the overall ADTs from being called structurally equal.--- Returns the name of the typeclass, and the function that checks for structural equality. -createStructEqFuncs :: ExState s m => [Type] -> m ()-createStructEqFuncs ts = do- -- Create a name for the new type class, adt, and datacon- tcn <- freshSeededStringN "structEq"- adtn <- freshSeededStringN "structEq"- dcn <- freshSeededStringN "structEq"-- let t = TyCon tcn TYPE-- tyvn <- freshSeededStringN "a"- let tyvn' = TyVar (Id tyvn TYPE)- tb <- tyBoolT-- let dc = DataCon dcn (TyFun (TyFun tyvn' (TyFun tyvn' tb)) t)-- ex <- genExtractor t dc-- -- Update KnownValues- kv <- knownValues- let kv' = kv { structEqTC = tcn, structEqFunc = ex }- putKnownValues kv'-- tenv <- typeEnv- -- For efficiency, we only generate structural equality when it's needed- let types = mapMaybe (tcaName . returnType . PresType) $ filter isTyFun ts ++ (nubBy (.::.) $ argTypesTEnv tenv)- let tenv' = M.filterWithKey (\n _ -> n `elem` types) tenv-- insertT adtn (DataTyCon {bound_ids = [Id tyvn TYPE], data_cons = [dc]})-- let (tenvK, tenvV) = unzip $ M.toList tenv'-- -- Create names for the new functions- let ns = map (\(Name n _ _ _) -> Name ("structEq" `T.append` n) Nothing 0 Nothing) tenvK- ns' <- freshSeededNamesN ns- let nsT = zip tenvK $ map (flip Id (TyCon tcn TYPE)) ns'-- tc <- typeClasses- tci <- freshIdN TYPE-- ins <- genInsts tcn nsT t dc $ M.toList tenv'-- let tc' = insertClass tcn (Class { insts = ins, typ_ids = [tci] }) tc- putTypeClasses tc'-- F.mapM_ (\(n, n', adt) -> createStructEqFunc dcn n n' adt) $ zip3 ns' tenvK tenvV--tcaName :: Type -> Maybe Name-tcaName (TyCon n _) = Just n-tcaName (TyApp t _) = tcaName t-tcaName _ = Nothing--genExtractor :: ExState s m => Type -> DataCon -> m Name-genExtractor t dc = do- lami <- freshIdN t- ci <- freshIdN t-- tb <- tyBoolT- tyvn <- freshSeededStringN "a"- let tyvn' = TyVar (Id tyvn TYPE)- fi <- freshIdN $ TyFun tyvn' (TyFun tyvn' tb)-- let alt = Alt (DataAlt dc [fi]) $ Var fi- let e = Lam TypeL (Id tyvn TYPE) $ Lam TermL lami $ Case (Var lami) ci $ [alt]-- extractN <- freshSeededStringN "structEq"-- insertE extractN e-- return extractN---genInsts :: ExState s m => Name -> [(Name, Id)] -> Type -> DataCon -> [(Name, AlgDataTy)] -> m [(Type, Id)]-genInsts _ _ _ _ [] = return []-genInsts tcn nsT t dc ((n@(Name n' _ _ _), adt):xs) = do- let bn = map idName $ bound_ids adt- bn' <- freshSeededNamesN bn-- let bni = map (flip Id TYPE) bn- bnid = map (\(dni, i) -> Id dni (TyApp (TyCon tcn (TyFun TYPE TYPE)) (TyVar i))) $ zip bn' bni- - -- Make the expressions- bnv = map TyVar bni- bnvK = mkTyApp $ map (const TYPE) bnv- tbnv = map Type bnv- dv = map Var bnid-- eqfn = case lookup n nsT of- Just f -> f- Nothing -> error "No name found in genInsts"-- vs = mkApp (Var eqfn:tbnv ++ dv)-- e = mkLams (map (TypeL,) bni ++ map (TermL,) bnid) $ App (Data dc) vs-- dn <- freshSeededNameN (Name ("structEqDict" `T.append` n') Nothing 0 Nothing)- insertE dn e-- xs' <- genInsts tcn nsT t dc xs-- return $ (mkTyApp (TyCon n bnvK:bnv), Id dn t):xs'---createStructEqFunc :: ExState s m => Name -> Name -> Name -> AlgDataTy -> m ()-createStructEqFunc dcn fn tn (DataTyCon {bound_ids = ns, data_cons = dc}) = do- ns' <- freshSeededNamesN $ map idName ns- let t = mkFullAppedTyCon tn (map (TyVar . flip Id TYPE) ns') TYPE-- bt <- freshIdsN $ map (const TYPE) ns- bd <- freshIdsN $ map (\i -> TyApp (TyCon dcn (TyFun TYPE TYPE)) (TyVar i)) bt-- let bm = zip (map idName bt) $ zip bt bd-- let dc' = foldr (\(i, rt) -> retype i rt) dc $ zip ns (map TyVar bt)-- e <- createStructEqFuncDC t bt bd bm dc'- insertE fn e-createStructEqFunc dcn fn tn (NewTyCon {bound_ids = ns, rep_type = rt}) = do- kv <- knownValues-- let t = mkFullAppedTyCon tn (map TyVar ns) TYPE-- bt <- freshIdsN $ map typeOf ns- bd <- freshIdsN $ map (\i -> TyApp (TyCon dcn (TyFun TYPE TYPE)) (TyVar i)) bt- let bm = zip (map idName bt) $ zip bt bd-- let t' = foldr (\(i, t_) -> retype i t_) t $ zip ns (map TyVar bt)-- lam1I <- freshIdN t'- lam2I <- freshIdN t'-- let rt' = foldr (\(i, rt_) -> retype i rt_) rt $ zip ns (map TyVar bt)- d <- dictForType bm rt'-- let ex = Var $ Id (structEqFunc kv) $ TyFun (typeOf (Type rt')) $ TyFun (typeOf d) $ TyFun t' $ TyFun t' t- let c = t' :~ rt'- let cLam1I = Cast (Var lam1I) c- let cLam2I = Cast (Var lam2I) c--- let e = Lam TermL lam1I $ Lam TermL lam2I $ App (App (App (App ex (Type rt')) d) cLam1I) cLam2I- let e' = mkLams (map (TermL,) bd) e- let e'' = mkLams (map (TypeL,) bt) e'-- insertE fn e''-createStructEqFunc _ _ _ (TypeSynonym {}) = error "Type synonym in createStructEqFunc"--createStructEqFuncDC :: ExState s m => Type -> [Id] -> [Id] -> [(Name, (Id, Id))] -> [DataCon] -> m Expr-createStructEqFuncDC t bt bd bm dc = do- lam1I <- freshIdN t- lam2I <- freshIdN t-- b1 <- freshIdN t-- alts <- mapM (createStructEqFuncDCAlt (Var lam2I) t bm) dc-- let e = Lam TermL lam1I $ Lam TermL lam2I $ Case (Var lam1I) b1 alts- let e' = mkLams (map (TermL,) bd) e- return $ mkLams (map (TypeL,) bt) e'--createStructEqFuncDCAlt :: ExState s m => Expr -> Type -> [(Name, (Id, Id))] -> DataCon -> m Alt-createStructEqFuncDCAlt e2 t bm dc@(DataCon _ _) = do- false <- mkFalseE-- bs <- freshIdsN $ anonArgumentTypes dc-- b <- freshIdN t- bs2 <- freshIdsN $ anonArgumentTypes dc-- sEqCheck <- boundChecks bs bs2 bm-- let alt2 = Alt (DataAlt dc bs2) sEqCheck- let altD = Alt Default false-- return $ Alt (DataAlt dc bs) (Case e2 b [alt2, altD])--boundChecks :: ExState s m => [Id] -> [Id] -> [(Name, (Id, Id))] -> m Expr-boundChecks is1 is2 bm = do- andE <- mkAndE- true <- mkTrueE-- bc <- mapM (uncurry (boundCheck bm)) $ zip is1 is2-- return $ foldr (\e -> App (App andE e)) true bc--boundCheck :: ExState s m => [(Name, (Id, Id))] -> Id -> Id -> m Expr-boundCheck bm i1 i2 = do- structEqCheck bm (typeOf i1) i1 i2--structEqCheck :: ExState s m => [(Name, (Id, Id))] -> Type -> Id -> Id -> m Expr-structEqCheck bm t i1 i2- | TyCon _ _ <- tyAppCenter t = do- kv <- knownValues- sft <- structEqFuncTypeM-- let ex = Var $ Id (structEqFunc kv) sft-- dict <- dictForType bm t-- return (App (App (App (App ex (Type t)) dict) (Var i1)) (Var i2))-structEqCheck bm (TyVar (Id n _)) (Id n' _) (Id n'' _) = do- kv <- knownValues- sft <- structEqFuncTypeM-- case lookup n bm of- Just (ty, dict) -> do- let ex = Var $ Id (structEqFunc kv) sft-- return (App (App (App (App ex (Var ty)) (Var dict)) (Var (Id n' (TyVar ty)))) (Var (Id n'' (TyVar ty))))- Nothing -> error "Unaccounted for TyVar in structEqCheck"-structEqCheck _ TyLitInt i1 i2 = do- eq <- mkEqPrimIntE- return $ App (App eq (Var i1)) (Var i2)-structEqCheck _ TyLitFloat i1 i2 = do- eq <- mkEqPrimFloatE- return $ App (App eq (Var i1)) (Var i2)-structEqCheck _ TyLitDouble i1 i2 = do- eq <- mkEqPrimDoubleE- return $ App (App eq (Var i1)) (Var i2)-structEqCheck _ TyLitChar i1 i2 = do- eq <- mkEqPrimCharE- return $ App (App eq (Var i1)) (Var i2)-structEqCheck _ (TyForAll _ _) _ _ = mkTrueE-structEqCheck _ (TyFun _ _) i1 i2 = do- boolT <- tyBoolT- return $ App (App (Prim BindFunc (TyFun (typeOf i1) (TyFun (typeOf i2) boolT))) (Var i1)) (Var i2)-structEqCheck _ t _ _ = error $ "Unsupported type in structEqCheck" ++ show t--dictForType :: ExState s m => [(Name, (Id, Id))] -> Type -> m Expr-dictForType bm t- | TyCon _ _ <- tyAppCenter t- , ts <- tyAppArgs t = do- kv <- knownValues- tc <- typeClasses-- ds <- mapM (dictForType bm) ts-- case structEqTCDict kv tc t of- Just i -> return $ foldl' App (Var i) (map Type ts ++ ds)- Nothing -> error $ "Required typeclass not found in dictForType"-dictForType bm (TyVar (Id n _)) =- case lookup n bm of- Just (_, dict) -> return (Var dict)- Nothing -> error "Unaccounted for TyVar in dictForType"-dictForType _ t = error $ "Unsupported type in dictForType" ++ show t---- | Returns the type for the StructEq func.--- The Name is used for a bound type, and should be generated with a NameGen.-structEqFuncType :: KnownValues -> Name -> Type-structEqFuncType kv n =- let- i = Id n TYPE- dict = structEqTC kv- bool = L.tyBool kv- in- TyForAll (NamedTyBndr i)- (TyFun (TyCon dict TYPE) - (TyFun (TyVar i) - (TyFun (TyVar i) bool)- )- )--structEqFuncTypeM :: ExState s m => m Type-structEqFuncTypeM = do- kv <- knownValues- n <- freshNameN- return $ structEqFuncType kv n
src/G2/Initialization/Types.hs view
@@ -28,16 +28,18 @@ instance SM.MonadState SimpleState SimpleStateM where state f = SimpleStateM (SM.state f) -instance ExState SimpleState SimpleStateM where+instance NamingM SimpleState SimpleStateM where+ nameGen = return . name_gen =<< SM.get+ putNameGen = rep_name_genM++instance ExprEnvM SimpleState SimpleStateM where exprEnv = return . expr_env =<< SM.get putExprEnv = rep_expr_envM +instance ExState SimpleState SimpleStateM where typeEnv = return . type_env =<< SM.get putTypeEnv = rep_type_envM - nameGen = return . name_gen =<< SM.get- putNameGen = rep_name_genM- knownValues = return . known_values =<< SM.get putKnownValues = rep_known_valuesM @@ -79,10 +81,13 @@ SM.put $ s {type_classes = tc} instance ASTContainer SimpleState Expr where- containedASTs s = containedASTs (expr_env s)- modifyContainedASTs f s = s { expr_env = modifyContainedASTs f (expr_env s) }+ containedASTs s = containedASTs (expr_env s) ++ containedASTs (rewrite_rules s)+ modifyContainedASTs f s = s { expr_env = modifyContainedASTs f (expr_env s)+ , rewrite_rules = modifyContainedASTs f (rewrite_rules s) } instance ASTContainer SimpleState Type where- containedASTs s = containedASTs (expr_env s) ++ containedASTs (type_env s)+ containedASTs s =+ containedASTs (expr_env s) ++ containedASTs (type_env s) ++ containedASTs (rewrite_rules s) modifyContainedASTs f s = s { expr_env = modifyContainedASTs f (expr_env s)- , type_env = modifyContainedASTs f (type_env s) }+ , type_env = modifyContainedASTs f (type_env s)+ , rewrite_rules = modifyContainedASTs f (rewrite_rules s) }
src/G2/Interface/Interface.hs view
@@ -1,14 +1,22 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module G2.Interface.Interface ( doTimeout+module G2.Interface.Interface ( MkCurrExpr+ , MkArgTypes+ , IT.SimpleState+ , doTimeout , maybeDoTimeout - , initState- , initState'+ , initStateWithCall+ , initStateWithCall' , initStateFromSimpleState , initStateFromSimpleState'+ , initStateFromSimpleStateWithCall , initSimpleState++ , mkArgTys , initRedHaltOrd , initSolver@@ -16,6 +24,7 @@ , initialStateFromFileSimple , initialStateFromFile+ , initialStateNoStartFunc , runG2FromFile , runG2WithConfig@@ -24,6 +33,7 @@ , runG2Post , runG2ThroughExecution , runExecution+ , runG2SolvingResult , runG2Solving , runG2 , Config) where@@ -39,13 +49,17 @@ import G2.Preprocessing.Interface +import G2.Execution.HPC import G2.Execution.Interface import G2.Execution.Reducer+import G2.Execution.Rules import G2.Execution.PrimitiveEval import G2.Execution.Memory import G2.Interface.OutputTypes +import G2.Lib.Printers+ import G2.Translation import G2.Solver@@ -56,10 +70,12 @@ import qualified G2.Language.PathConds as PC import qualified G2.Language.Stack as Stack +import Control.Monad.IO.Class+import qualified Control.Monad.State as SM import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as S-import qualified Data.Map as M import Data.Maybe+import qualified Data.Sequence as Seq import qualified Data.Text as T import System.Timeout@@ -71,7 +87,7 @@ type StartFunc = T.Text type ModuleName = Maybe T.Text -type MkCurrExpr = Id -> TypeClasses -> NameGen -> ExprEnv -> Walkers+type MkCurrExpr = TypeClasses -> NameGen -> ExprEnv -> TypeEnv -> Walkers -> KnownValues -> Config -> (Expr, [Id], [Expr], NameGen) doTimeout :: Int -> IO a -> IO (Maybe a)@@ -87,84 +103,122 @@ maybeDoTimeout (Just secs) = doTimeout secs maybeDoTimeout Nothing = fmap Just -initState :: ExtractedG2 -> Bool -> StartFunc -> ModuleName- -> MkCurrExpr- -> Config -> (State (), Id, Bindings)-initState exg2 useAssert f m_mod mkCurr config =++{-# INLINE initStateWithCall #-}+initStateWithCall :: ExtractedG2+ -> Bool+ -> StartFunc+ -> ModuleName+ -> (Id -> MkCurrExpr)+ -> (Expr -> MkArgTypes)+ -> Config+ -> (State (), Bindings)+initStateWithCall exg2 useAssert f m_mod mkCurr argTys config = let s = initSimpleState exg2++ (ie, fe) = case findFunc f m_mod (IT.expr_env s) of+ Left ie' -> ie'+ Right errs -> error errs in- initStateFromSimpleState s useAssert f m_mod mkCurr config+ initStateFromSimpleState s m_mod useAssert (mkCurr ie) (argTys fe) config -initState' :: ExtractedG2- -> StartFunc- -> ModuleName- -> MkCurrExpr- -> Config- -> (State (), Id, Bindings)-initState' exg2 sf m_mod mkCurr =- initState exg2 False sf m_mod mkCurr+{-# INLINE initStateWithCall' #-}+initStateWithCall' :: ExtractedG2+ -> StartFunc+ -> ModuleName+ -> (Id -> MkCurrExpr)+ -> (Expr -> MkArgTypes)+ -> Config+ -> (State (), Bindings)+initStateWithCall' exg2 =+ initStateWithCall exg2 False +{-# INLINE initStateFromSimpleStateWithCall #-}+initStateFromSimpleStateWithCall :: IT.SimpleState+ -> Bool+ -> StartFunc+ -> ModuleName+ -> (Id -> MkCurrExpr)+ -> (Expr -> MkArgTypes)+ -> Config+ -> (State (), Id, Bindings)+initStateFromSimpleStateWithCall simp_s useAssert f m_mod mkCurr argTys config =+ let+ (ie, fe) = case findFunc f m_mod (IT.expr_env simp_s) of+ Left ie' -> ie'+ Right errs -> error errs+ + (s, b) = initStateFromSimpleState simp_s m_mod useAssert (mkCurr ie) (argTys fe) config+ in+ (s, ie, b)+ initStateFromSimpleState :: IT.SimpleState+ -> Maybe T.Text -> Bool- -> StartFunc- -> ModuleName -> MkCurrExpr+ -> MkArgTypes -> Config- -> (State (), Id, Bindings)-initStateFromSimpleState s useAssert f m_mod mkCurr config =+ -> (State (), Bindings)+initStateFromSimpleState s m_mod useAssert mkCurr argTys config = let- (ie, fe) = case findFunc f m_mod (IT.expr_env s) of- Left ie' -> ie'- Right errs -> error errs- (_, ts) = instantiateArgTypes (IT.type_classes s) (IT.known_values s) fe-- (s', ds_walkers) = runInitialization s ts+ (s', ds_walkers) = runInitialization2 s argTys eenv' = IT.expr_env s' tenv' = IT.type_env s' ng' = IT.name_gen s' kv' = IT.known_values s' tc' = IT.type_classes s' - (ce, is, f_i, ng'') = mkCurr ie tc' ng' eenv' ds_walkers kv' config+ (ce, is, f_i, ng'') = mkCurr tc' ng' eenv' tenv' ds_walkers kv' config in (State {- expr_env = foldr (\i@(Id n _) -> E.insertSymbolic n i) eenv' is+ expr_env = foldr E.insertSymbolic eenv' is , type_env = tenv' , curr_expr = CurrExpr Evaluate ce- , path_conds = PC.fromList kv' $ map PCExists is+ , path_conds = PC.fromList [] , non_red_path_conds = [] , true_assert = if useAssert then False else True , assert_ids = Nothing , type_classes = tc'- , symbolic_ids = is , exec_stack = Stack.empty- , model = M.empty+ , model = HM.empty , known_values = kv' , rules = [] , num_steps = 0 , track = ()+ , sym_gens = Seq.empty , tags = S.empty }- , ie , Bindings { deepseq_walkers = ds_walkers , fixed_inputs = f_i , arb_value_gen = arbValueInit , cleaned_names = HM.empty , input_names = map idName is- , higher_order_inst = IT.exports s+ , higher_order_inst = S.filter (\n -> nameModule n == m_mod) . S.fromList $ IT.exports s , rewrite_rules = IT.rewrite_rules s- , name_gen = ng''})+ , name_gen = ng''+ , exported_funcs = IT.exports s }) +mkArgTys :: Expr -> MkArgTypes+mkArgTys e simp_s =+ snd $ instantiateArgTypes (IT.type_classes simp_s) (IT.known_values simp_s) e++{-# INLINE initStateFromSimpleState' #-} initStateFromSimpleState' :: IT.SimpleState -> StartFunc -> ModuleName -> Config- -> (State (), Id, Bindings)+ -> (State (), Bindings) initStateFromSimpleState' s sf m_mod =- initStateFromSimpleState s False sf m_mod (mkCurrExpr Nothing Nothing)+ let+ (ie, fe) = case findFunc sf m_mod (IT.expr_env s) of+ Left ie' -> ie'+ Right errs -> error errs+ in+ initStateFromSimpleState s m_mod False (mkCurrExpr Nothing Nothing ie) (mkArgTys fe) +{-# INLINE initSimpleState #-} initSimpleState :: ExtractedG2 -> IT.SimpleState initSimpleState (ExtractedG2 { exg2_binds = prog@@ -173,53 +227,94 @@ , exg2_exports = es , exg2_rules = rs }) = let- eenv = mkExprEnv prog+ eenv = E.fromExprMap prog tenv = mkTypeEnv prog_typ tc = initTypeClasses cls- kv = initKnownValues eenv tenv- ng = mkNameGen (prog, prog_typ)+ kv = initKnownValues eenv tenv tc+ ng = mkNameGen (prog, prog_typ, rs)++ s = IT.SimpleState { IT.expr_env = eenv+ , IT.type_env = tenv+ , IT.name_gen = ng+ , IT.known_values = kv+ , IT.type_classes = tc+ , IT.rewrite_rules = rs+ , IT.exports = es } in- IT.SimpleState { IT.expr_env = eenv- , IT.type_env = tenv- , IT.name_gen = ng- , IT.known_values = kv- , IT.type_classes = tc- , IT.rewrite_rules = rs- , IT.exports = es }+ runInitialization1 s initCheckReaches :: State t -> ModuleName -> Maybe ReachFunc -> State t initCheckReaches s@(State { expr_env = eenv , known_values = kv }) m_mod reaches = s {expr_env = checkReaches eenv kv reaches m_mod } -initRedHaltOrd :: Solver conv => conv -> Config -> (SomeReducer (), SomeHalter (), SomeOrderer ())-initRedHaltOrd conv config =+type RHOStack m = SM.StateT LengthNTrack (SM.StateT PrettyGuide (SM.StateT HpcTracker m))++{-# SPECIALIZE runReducer :: Ord b =>+ Reducer (RHOStack IO) rv ()+ -> Halter (RHOStack IO) hv ()+ -> Orderer (RHOStack IO) sov b ()+ -> State ()+ -> Bindings+ -> (RHOStack IO) (Processed (State ()), Bindings)+ #-}++{-# SPECIALIZE + initRedHaltOrd :: (Solver solver, Simplifier simplifier) =>+ Maybe T.Text+ -> solver+ -> simplifier+ -> Config+ -> (SomeReducer (RHOStack IO) (), SomeHalter (RHOStack IO) (), SomeOrderer (RHOStack IO) ())+ #-}+initRedHaltOrd :: (MonadIO m, Solver solver, Simplifier simplifier) =>+ Maybe T.Text+ -> solver+ -> simplifier+ -> Config+ -> (SomeReducer (RHOStack m) (), SomeHalter (RHOStack m) (), SomeOrderer (RHOStack m) ())+initRedHaltOrd mod_name solver simplifier config = let- tr_ng = mkNameGen ()+ share = sharing config+ state_name = Name "state" Nothing 0 Nothing++ m_logger = fmap SomeReducer $ getLogger config++ hpc_red f = case hpc config of+ True -> SomeReducer (hpcReducer mod_name ~> stdRed share f solver simplifier)+ False -> SomeReducer (stdRed share f solver simplifier)++ logger_std_red f = case m_logger of+ Just logger -> liftSomeReducer (logger .~> liftSomeReducer (hpc_red f))+ Nothing -> liftSomeReducer (liftSomeReducer (hpc_red f))++ halter = switchEveryNHalter 20+ <~> maxOutputsHalter (maxOutputs config)+ <~> zeroHalter (steps config)+ <~> acceptIfViolatedHalter++ orderer = case search_strat config of+ Subpath -> SomeOrderer $ lengthNSubpathOrderer (subpath_length config)+ Iterative -> SomeOrderer $ pickLeastUsedOrderer in- if higherOrderSolver config == AllFuncs- then (SomeReducer (NonRedPCRed)- <~| (case logStates config of- Just fp -> SomeReducer (StdRed conv :<~ Logger fp)- Nothing -> SomeReducer (StdRed conv))- , SomeHalter- (SwitchEveryNHalter 20- :<~> MaxOutputsHalter (maxOutputs config)- :<~> ZeroHalter (steps config)- :<~> AcceptHalter)- , SomeOrderer $ PickLeastUsedOrderer)- else ( SomeReducer (NonRedPCRed :<~| TaggerRed state_name tr_ng)- <~| (case logStates config of- Just fp -> SomeReducer (StdRed conv :<~ Logger fp)- Nothing -> SomeReducer (StdRed conv))- , SomeHalter- (DiscardIfAcceptedTag state_name- :<~> SwitchEveryNHalter 20- :<~> MaxOutputsHalter (maxOutputs config) - :<~> ZeroHalter (steps config)- :<~> AcceptHalter)- , SomeOrderer $ PickLeastUsedOrderer)+ case higherOrderSolver config of+ AllFuncs ->+ ( logger_std_red retReplaceSymbFuncVar .== Finished .--> SomeReducer nonRedPCRed+ , SomeHalter halter+ , orderer)+ SingleFunc ->+ ( logger_std_red retReplaceSymbFuncVar .== Finished .--> taggerRed state_name :== Finished --> nonRedPCRed+ , SomeHalter (discardIfAcceptedTagHalter state_name <~> halter)+ , orderer)+ SymbolicFunc ->+ ( logger_std_red retReplaceSymbFuncTemplate .== Finished .--> SomeReducer nonRedPCRed+ , SomeHalter halter+ , orderer)+ SymbolicFuncTemplate ->+ ( logger_std_red retReplaceSymbFuncVar .== Finished .--> taggerRed state_name :== Finished --> nonRedPCTemplates+ , SomeHalter (discardIfAcceptedTagHalter state_name <~> halter)+ , orderer) initSolver :: Config -> IO SomeSolver initSolver = initSolver' arbValue@@ -230,167 +325,270 @@ initSolver' :: ArbValueFunc -> Config -> IO SomeSolver initSolver' avf config = do SomeSMTSolver con <- getSMTAV avf config- let con' = GroupRelated avf (UndefinedHigherOrder :?> ADTSolver avf :?> con)+ let con' = GroupRelated avf (UndefinedHigherOrder :?> (ADTNumericalSolver avf con)) return (SomeSolver con') -mkExprEnv :: [(Id, Expr)] -> E.ExprEnv-mkExprEnv = E.fromExprList . map (\(i, e) -> (idName i, e))--mkTypeEnv :: [ProgramType] -> TypeEnv-mkTypeEnv = M.fromList . map (\(n, dcs) -> (n, dcs))+mkTypeEnv :: HM.HashMap Name AlgDataTy -> TypeEnv+mkTypeEnv = id +{-# INLINE initialStateFromFileSimple #-} initialStateFromFileSimple :: [FilePath] -> [FilePath]- -> [FilePath] -> StartFunc- -> MkCurrExpr+ -> (Id -> MkCurrExpr)+ -> (Expr -> MkArgTypes) -> Config -> IO (State (), Id, Bindings)-initialStateFromFileSimple proj src libs f mkCurr config =- initialStateFromFile proj src libs Nothing False f mkCurr config+initialStateFromFileSimple proj src f mkCurr argTys config =+ initialStateFromFile proj src Nothing False f mkCurr argTys simplTranslationConfig config -initialStateFromFile :: [FilePath]+initialStateNoStartFunc :: [FilePath] -> [FilePath]+ -> TranslationConfig+ -> Config+ -> IO (State (), Bindings)+initialStateNoStartFunc proj src transConfig config = do+ (m_mod, exg2) <- translateLoaded proj src transConfig config++ let simp_state = initSimpleState exg2++ (init_s, bindings) = initStateFromSimpleState simp_state m_mod False+ (\_ ng _ _ _ _ _ -> (Prim Undefined TyBottom, [], [], ng))+ (E.higherOrderExprs . IT.expr_env)+ config++ return (init_s, bindings)++initialStateFromFile :: [FilePath] -> [FilePath] -> Maybe ReachFunc -> Bool -> StartFunc- -> MkCurrExpr+ -> (Id -> MkCurrExpr)+ -> (Expr -> MkArgTypes)+ -> TranslationConfig -> Config -> IO (State (), Id, Bindings)-initialStateFromFile proj src libs m_reach def_assert f mkCurr config = do- (mb_modname, exg2) <- translateLoaded proj src libs simplTranslationConfig config- let (init_s, ent_f, bindings) = initState exg2 def_assert- f mb_modname mkCurr config+initialStateFromFile proj src m_reach def_assert f mkCurr argTys transConfig config = do+ (mb_modname, exg2) <- translateLoaded proj src transConfig config++ let simp_state = initSimpleState exg2+ (ie, fe) = case findFunc f mb_modname (IT.expr_env simp_state) of+ Left ie' -> ie'+ Right errs -> error errs++ (init_s, bindings) = initStateFromSimpleState simp_state mb_modname def_assert+ (mkCurr ie) (argTys fe) config+ -- let (init_s, ent_f, bindings) = initState exg2 def_assert+ -- f mb_modname mkCurr argTys config reaches_state = initCheckReaches init_s mb_modname m_reach - return (reaches_state, ent_f, bindings)+ return (reaches_state, ie, bindings) runG2FromFile :: [FilePath] -> [FilePath]- -> [FilePath] -> Maybe AssumeFunc -> Maybe AssertFunc -> Maybe ReachFunc -> Bool -> StartFunc+ -> TranslationConfig -> Config -> IO (([ExecRes ()], Bindings), Id)-runG2FromFile proj src libs m_assume m_assert m_reach def_assert f config = do- (init_state, entry_f, bindings) <- initialStateFromFile proj src libs- m_reach def_assert f (mkCurrExpr m_assume m_assert) config+runG2FromFile proj src m_assume m_assert m_reach def_assert f transConfig config = do+ (init_state, entry_f, bindings) <- initialStateFromFile proj src+ m_reach def_assert f (mkCurrExpr m_assume m_assert) (mkArgTys)+ transConfig config - r <- runG2WithConfig init_state config bindings+ r <- runG2WithConfig (nameModule $ idName entry_f) init_state config bindings return (r, entry_f) -runG2WithConfig :: State () -> Config -> Bindings -> IO ([ExecRes ()], Bindings)-runG2WithConfig state config bindings = do- SomeSolver con <- initSolver config+runG2WithConfig :: Maybe T.Text -> State () -> Config -> Bindings -> IO ([ExecRes ()], Bindings)+runG2WithConfig mod_name state config bindings = do+ SomeSolver solver <- initSolver config+ let simplifier = IdSimplifier - (in_out, bindings') <- case initRedHaltOrd con config of+ hpc_t <- hpcTracker++ (in_out, bindings') <- case initRedHaltOrd mod_name solver simplifier config of (red, hal, ord) ->- runG2WithSomes red hal ord con [] state bindings+ SM.evalStateT+ (SM.evalStateT+ (SM.evalStateT+ (runG2WithSomes red hal ord solver simplifier emptyMemConfig state bindings)+ lnt+ )+ (mkPrettyGuide ())+ )+ hpc_t - close con+ close solver return (in_out, bindings') -runG2WithSomes :: ( Named t++{-# SPECIALIZE + runG2WithSomes :: ( Solver solver+ , Simplifier simplifier)+ => SomeReducer (RHOStack IO) ()+ -> SomeHalter (RHOStack IO) ()+ -> SomeOrderer (RHOStack IO) ()+ -> solver+ -> simplifier+ -> MemConfig+ -> State ()+ -> Bindings+ -> RHOStack IO ([ExecRes ()], Bindings)+ #-}+runG2WithSomes :: ( MonadIO m+ , Named t , ASTContainer t Expr , ASTContainer t Type- , Solver solver)- => (SomeReducer t)- -> (SomeHalter t)- -> (SomeOrderer t)+ , Solver solver+ , Simplifier simplifier)+ => SomeReducer m t+ -> SomeHalter m t+ -> SomeOrderer m t -> solver- -> [Name]+ -> simplifier+ -> MemConfig -> State t -> Bindings- -> IO ([ExecRes t], Bindings)-runG2WithSomes red hal ord con pns state bindings =+ -> m ([ExecRes t], Bindings)+runG2WithSomes red hal ord solver simplifier mem state bindings = case (red, hal, ord) of (SomeReducer red', SomeHalter hal', SomeOrderer ord') ->- runG2 red' hal' ord' con pns state bindings+ runG2 red' hal' ord' solver simplifier mem state bindings runG2Pre :: ( Named t , ASTContainer t Expr- , ASTContainer t Type) => [Name] -> State t -> Bindings -> (State t, Bindings)-runG2Pre pns s@(State { known_values = kv, type_classes = tc }) bindings =+ , ASTContainer t Type) => MemConfig -> State t -> Bindings -> (State t, Bindings)+runG2Pre mem s bindings = let- (swept, bindings') = markAndSweepPreserving (pns ++ names (lookupStructEqDicts kv tc)) s bindings+ (swept, bindings') = markAndSweepPreserving mem s bindings in runPreprocessing swept bindings' -runG2Post :: ( Named t+runG2Post :: ( MonadIO m+ , Named t , ASTContainer t Expr , ASTContainer t Type- , Reducer r rv t- , Halter h hv t- , Orderer or sov b t- , Solver solver) => r -> h -> or ->- solver -> State t -> Bindings -> IO ([ExecRes t], Bindings)-runG2Post red hal ord con is bindings = do+ , Solver solver+ , Simplifier simplifier+ , Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t ->+ solver -> simplifier -> State t -> Bindings -> m ([ExecRes t], Bindings)+runG2Post red hal ord solver simplifier is bindings = do (exec_states, bindings') <- runExecution red hal ord is bindings- sol_states <- mapM (runG2Solving con bindings') exec_states+ sol_states <- mapM (runG2Solving solver simplifier bindings') exec_states return (catMaybes sol_states, bindings') -runG2ThroughExecution ::+{-# SPECIALISE runG2ThroughExecution :: ( Named t , ASTContainer t Expr , ASTContainer t Type- , Reducer r rv t- , Halter h hv t- , Orderer or sov b t) => r -> h -> or ->- [Name] -> State t -> Bindings -> IO ([State t], Bindings)-runG2ThroughExecution red hal ord pns is bindings = do- let (is', bindings') = runG2Pre pns is bindings+ , Ord b) => Reducer IO rv t -> Halter IO hv t -> Orderer IO sov b t ->+ MemConfig -> State t -> Bindings -> IO ([State t], Bindings) #-}+{-# SPECIALISE runG2ThroughExecution ::+ ( Named t+ , ASTContainer t Expr+ , ASTContainer t Type+ , Ord b) => Reducer (SM.StateT PrettyGuide IO) rv t -> Halter (SM.StateT PrettyGuide IO) hv t -> Orderer (SM.StateT PrettyGuide IO) sov b t ->+ MemConfig -> State t -> Bindings -> SM.StateT PrettyGuide IO ([State t], Bindings) #-}+runG2ThroughExecution ::+ ( Monad m+ , Named t+ , ASTContainer t Expr+ , ASTContainer t Type+ , Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t ->+ MemConfig -> State t -> Bindings -> m ([State t], Bindings)+runG2ThroughExecution red hal ord mem is bindings = do+ let (is', bindings') = runG2Pre mem is bindings runExecution red hal ord is' bindings'+{-# INLINABLE runG2ThroughExecution #-} -runG2Solving :: ( Named t- , ASTContainer t Expr- , ASTContainer t Type- , Solver solver) =>- solver -> Bindings -> State t -> IO (Maybe (ExecRes t))-runG2Solving con bindings s@(State { known_values = kv })+runG2SolvingResult :: ( Named t+ , Solver solver+ , Simplifier simplifier) =>+ solver+ -> simplifier+ -> Bindings+ -> State t+ -> IO (Result (ExecRes t) () ())+runG2SolvingResult solver simplifier bindings s | true_assert s = do- (_, m) <- solve con s bindings (symbolic_ids s) (path_conds s)- case m of- Just m' -> do- let s' = s { model = m' }+ r <- solve solver s bindings (E.symbolicIds . expr_env $ s) (path_conds s) - let (es, e, ais) = subModel s' bindings- sm = ExecRes { final_state = s'- , conc_args = es- , conc_out = e- , violated = ais}+ case r of+ SAT m -> do+ let m' = reverseSimplification simplifier s bindings m+ return . SAT $ runG2SubstModel m' s bindings+ UNSAT _ -> return $ UNSAT ()+ Unknown reason _ -> return $ Unknown reason () - let sm' = runPostprocessing bindings sm+ | otherwise = return $ UNSAT () - let sm'' = ExecRes { final_state = final_state sm'- , conc_args = fixed_inputs bindings ++ conc_args sm'- , conc_out = evalPrims kv (conc_out sm')- , violated = evalPrims kv (violated sm')}- - return (Just sm'')- Nothing -> do- return Nothing+runG2Solving :: ( MonadIO m+ , Named t+ , Solver solver+ , Simplifier simplifier) =>+ solver+ -> simplifier+ -> Bindings+ -> State t+ -> m (Maybe (ExecRes t))+runG2Solving solver simplifier bindings s = do+ res <- liftIO $ runG2SolvingResult solver simplifier bindings s+ case res of+ SAT m -> return $ Just m+ _ -> return Nothing - | otherwise = return Nothing+runG2SubstModel :: Named t =>+ Model+ -> State t+ -> Bindings+ -> ExecRes t+runG2SubstModel m s@(State { type_env = tenv, known_values = kv }) bindings =+ let+ s' = s { model = m } + (es, e, ais, gens) = subModel s' bindings+ sm = ExecRes { final_state = s'+ , conc_args = es+ , conc_out = e+ , conc_sym_gens = gens+ , violated = ais}++ sm' = runPostprocessing bindings sm++ sm'' = ExecRes { final_state = final_state sm'+ , conc_args = fixed_inputs bindings ++ conc_args sm'+ , conc_out = evalPrims tenv kv (conc_out sm')+ , conc_sym_gens = gens+ , violated = evalPrims tenv kv (violated sm')}+ in+ sm''++{-# SPECIALIZE runG2 :: ( Solver solver+ , Simplifier simplifier+ , Ord b) => Reducer (RHOStack IO) rv () -> Halter (RHOStack IO) hv () -> Orderer (RHOStack IO) sov b () ->+ solver -> simplifier -> MemConfig -> State () -> Bindings -> RHOStack IO ([ExecRes ()], Bindings)+ #-}++ -- | Runs G2, returning both fully executed states, -- and states that have only been partially executed.-runG2 :: ( Named t+runG2 :: ( MonadIO m+ , Named t , ASTContainer t Expr , ASTContainer t Type- , Reducer r rv t- , Halter h hv t- , Orderer or sov b t- , Solver solver) => r -> h -> or ->- solver -> [Name] -> State t -> Bindings -> IO ([ExecRes t], Bindings)-runG2 red hal ord con pns is bindings = do- (exec_states, bindings') <- runG2ThroughExecution red hal ord pns is bindings- sol_states <- mapM (runG2Solving con bindings') exec_states+ , Solver solver+ , Simplifier simplifier+ , Ord b) => Reducer m rv t -> Halter m hv t -> Orderer m sov b t ->+ solver -> simplifier -> MemConfig -> State t -> Bindings -> m ([ExecRes t], Bindings)+runG2 red hal ord solver simplifier mem is bindings = do+ (exec_states, bindings') <- runG2ThroughExecution red hal ord mem is bindings+ sol_states <- mapM (runG2Solving solver simplifier bindings') exec_states return (catMaybes sol_states, bindings')
src/G2/Interface/OutputTypes.hs view
@@ -5,10 +5,14 @@ import G2.Language --- | A fully executed State-data ExecRes t = ExecRes { final_state :: State t- , conc_args :: [Expr]- , conc_out :: Expr+import Data.Monoid ((<>))+import qualified Data.Sequence as S++-- | A fully executed `State`.+data ExecRes t = ExecRes { final_state :: State t -- ^ The final state.+ , conc_args :: [Expr] -- ^ Fully concrete arguments for the state.+ , conc_out :: Expr -- ^ Fully concrete output (final `curr_expr`) for the state+ , conc_sym_gens :: S.Seq Expr , violated :: Maybe FuncCall -- ^ A violated assertion } deriving (Show, Read) @@ -16,55 +20,66 @@ names (ExecRes { final_state = s , conc_args = es , conc_out = r+ , conc_sym_gens = g , violated = fc }) =- names s ++ names es ++ names r ++ names fc+ names s <> names es <> names r <> names g <> names fc rename old new (ExecRes { final_state = s , conc_args = es , conc_out = r+ , conc_sym_gens = g , violated = fc }) = ExecRes { final_state = rename old new s , conc_args = rename old new es , conc_out = rename old new r+ , conc_sym_gens = rename old new g , violated = rename old new fc} renames hm (ExecRes { final_state = s , conc_args = es , conc_out = r+ , conc_sym_gens = g , violated = fc }) = ExecRes { final_state = renames hm s , conc_args = renames hm es , conc_out = renames hm r+ , conc_sym_gens = renames hm g , violated = renames hm fc } instance ASTContainer t Expr => ASTContainer (ExecRes t) Expr where containedASTs (ExecRes { final_state = s , conc_args = es , conc_out = r+ , conc_sym_gens = g , violated = fc }) =- containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs fc+ containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs g ++ containedASTs fc modifyContainedASTs f (ExecRes { final_state = s , conc_args = es , conc_out = r+ , conc_sym_gens = g , violated = fc }) = ExecRes { final_state = modifyContainedASTs f s , conc_args = modifyContainedASTs f es , conc_out = modifyContainedASTs f r+ , conc_sym_gens = modifyContainedASTs f g , violated = modifyContainedASTs f fc} instance ASTContainer t Type => ASTContainer (ExecRes t) Type where containedASTs (ExecRes { final_state = s , conc_args = es , conc_out = r+ , conc_sym_gens = g , violated = fc }) =- containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs fc+ containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs g ++ containedASTs fc modifyContainedASTs f (ExecRes { final_state = s , conc_args = es , conc_out = r+ , conc_sym_gens = g , violated = fc }) = ExecRes { final_state = modifyContainedASTs f s , conc_args = modifyContainedASTs f es , conc_out = modifyContainedASTs f r+ , conc_sym_gens = modifyContainedASTs f g , violated = modifyContainedASTs f fc }
src/G2/Language/AST.hs view
@@ -1,4 +1,4 @@--- | Defines typeclasses and functions for ease of AST manipulation.+-- | Defines typeclasses and functions to make it easier to write functions that require traversing ASTs. {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -10,6 +10,7 @@ , modify , modifyMonoid , modifyFix+ , modifyMaybe , modifyContainedFix , modifyFixMonoid , eval@@ -26,6 +27,7 @@ , replaceASTs ) where +import qualified G2.Data.UFMap as UF import G2.Language.Syntax import G2.Language.AlgDataTy @@ -33,17 +35,26 @@ import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as HS import qualified Data.Map as M+import qualified Data.Sequence as S import qualified Data.Text as T -- | Describes data types that define an AST. class AST t where -- | Gets the direct children of the given node. children :: t -> [t]- -- | Applies the given function to all children of the given node.+ -- | Applies the given function to all direct children of the given node. modifyChildren :: (t -> t) -> t -> t + -- | Calls the given function on the given node, and all of the descendants--- in a recursive, top down, manner.+-- top down recursively.+-- Typically, the passed higher order function will modify some subset+-- of the constructors of the given type, and leave the rest unchanged.+--+-- >>> let go e = case e of Var (Id _ t) -> SymGen SLog t; _ -> e+-- >>> let n = Name "x" Nothing 0 Nothing+-- >>> modify go (Lam TypeL (Id n TyLitInt) (App (Var $ Id n TyLitInt) (Var $ Id n TyLitFloat)))+-- Lam TypeL (Id (Name "x" Nothing 0 Nothing) TyLitInt) (App (SymGen SLog TyLitInt) (SymGen SLog TyLitFloat)) modify :: AST t => (t -> t) -> t -> t modify f t = go t where@@ -70,6 +81,16 @@ go t' = let t'' = f t' in if t' == t'' then modifyChildren go t'' else go t'' +-- | Runs the given function f on the node t repeatedly, until f t = Nothing, then does the+-- same on all decendants of t recursively.+modifyMaybe :: AST t => (t -> Maybe t) -> t -> t+modifyMaybe f = go+ where+ go t = let mt = f t in+ case mt of+ Just v -> go v+ Nothing -> modifyChildren go t+ -- | Runs the given function f on the node t, t until t = f t modifyContainedFix :: (AST t, Eq t, Show t) => (t -> t) -> t -> t modifyContainedFix f t = let t' = f t@@ -92,6 +113,12 @@ -- | Recursively runs the given function on each node, top down. Uses mappend -- to combine the results after evaluation of the entire tree.+--+-- >>> let go e = case e of Lit l -> [l]; _ -> []+-- >>> plusInt = Prim Plus (TyFun TyLitInt (TyFun TyLitInt TyLitInt))+-- >>> eval go $ App (App plusInt (Lit $ LitInt 0)) (Lit $ LitInt 1)+-- [LitInt 0, LitInt 1]+{-# INLINE eval #-} eval :: (AST t, Monoid a) => (t -> a) -> t -> a eval f t = go t where@@ -112,6 +139,7 @@ -- | Evaluates all children of the given AST node with the given monoid, -- and `mconcat`s the results+{-# INLINE evalChildren #-} evalChildren :: (AST t, Monoid a) => (t -> a) -> t -> a evalChildren f = mconcat . map f . children @@ -160,20 +188,20 @@ children (App f a) = [f, a] children (Lam _ _ e) = [e] children (Let bind e) = e : containedASTs bind- children (Case m _ as) = m : map (\(Alt _ e) -> e) as+ children (Case m _ _ as) = m : map (\(Alt _ e) -> e) as children (Cast e _) = [e] children (Coercion _) = [] children (Type _) = [] children (Tick _ e) = [e] children (NonDet es) = es- children (SymGen _) = []- children (Assume is e e') = containedASTs is ++ [e, e']- children (Assert is e e') = containedASTs is ++ [e, e']+ children (SymGen _ _) = []+ children (Assume _ e e') = [e, e']+ children (Assert _ e e') = [e, e'] modifyChildren f (App fx ax) = App (f fx) (f ax) modifyChildren f (Lam u b e) = Lam u b (f e) modifyChildren f (Let bind e) = Let (modifyContainedASTs f bind) (f e)- modifyChildren f (Case m b as) = Case (f m) b (mapAlt f as)+ modifyChildren f (Case m b t as) = Case (f m) b t (mapAlt f as) where mapAlt :: (Expr -> Expr) -> [Alt] -> [Alt] mapAlt g alts = map (\(Alt ac e) -> Alt ac (g e)) alts@@ -203,8 +231,7 @@ children _ = [] modifyChildren _ (DataCon n ty) = DataCon n ty --- | Instance ASTContainer of Itself--- Every AST is defined as an ASTContainer of itself. Generally, functions+-- | Every AST is defined as an ASTContainer of itself. Generally, functions -- should be written using the ASTContainer typeclass. instance AST t => ASTContainer t t where containedASTs t = [t]@@ -218,13 +245,13 @@ containedASTs (App e1 e2) = containedASTs e1 ++ containedASTs e2 containedASTs (Lam _ b e) = containedASTs b ++ containedASTs e containedASTs (Let bnd e) = containedASTs bnd ++ containedASTs e- containedASTs (Case e i as) = containedASTs e ++ containedASTs i ++ containedASTs as+ containedASTs (Case e i t as) = containedASTs e ++ containedASTs i ++ containedASTs t ++ containedASTs as containedASTs (Cast e c) = containedASTs e ++ containedASTs c containedASTs (Coercion c) = containedASTs c containedASTs (Type t) = [t] containedASTs (Tick _ e) = containedASTs e containedASTs (NonDet es) = containedASTs es- containedASTs (SymGen t) = [t]+ containedASTs (SymGen _ t) = [t] containedASTs (Assume is e e') = containedASTs is ++ containedASTs e ++ containedASTs e' containedASTs (Assert is e e') = containedASTs is ++ containedASTs e ++ containedASTs e' containedASTs _ = []@@ -235,18 +262,26 @@ modifyContainedASTs f (App fx ax) = App (modifyContainedASTs f fx) (modifyContainedASTs f ax) modifyContainedASTs f (Lam u b e) = Lam u (modifyContainedASTs f b)(modifyContainedASTs f e) modifyContainedASTs f (Let bnd e) = Let (modifyContainedASTs f bnd) (modifyContainedASTs f e)- modifyContainedASTs f (Case m i as) = Case (modifyContainedASTs f m) (modifyContainedASTs f i) (modifyContainedASTs f as) + modifyContainedASTs f (Case m i t as) = Case (modifyContainedASTs f m) (modifyContainedASTs f i) (f t) (modifyContainedASTs f as) modifyContainedASTs f (Type t) = Type (f t) modifyContainedASTs f (Cast e c) = Cast (modifyContainedASTs f e) (modifyContainedASTs f c) modifyContainedASTs f (Coercion c) = Coercion (modifyContainedASTs f c) modifyContainedASTs f (Tick t e) = Tick t (modifyContainedASTs f e) modifyContainedASTs f (NonDet es) = NonDet (modifyContainedASTs f es)- modifyContainedASTs f (SymGen t) = SymGen (f t)+ modifyContainedASTs f (SymGen sl t) = SymGen sl (f t) modifyContainedASTs f (Assume is e e') = Assume (modifyContainedASTs f is) (modifyContainedASTs f e) (modifyContainedASTs f e') modifyContainedASTs f (Assert is e e') = Assert (modifyContainedASTs f is) (modifyContainedASTs f e) (modifyContainedASTs f e') modifyContainedASTs _ e = e +instance ASTContainer LamUse Expr where+ containedASTs _ = []+ modifyContainedASTs _ i = i++instance ASTContainer LamUse Type where+ containedASTs _ = []+ modifyContainedASTs _ i = i+ instance ASTContainer Id Expr where containedASTs (Id _ _) = [] @@ -275,7 +310,6 @@ instance ASTContainer DataCon Type where containedASTs (DataCon _ t) = [t]- modifyContainedASTs f (DataCon n t) = DataCon n (f t) instance ASTContainer AltMatch Expr where@@ -298,17 +332,6 @@ modifyContainedASTs f (Alt a e) = Alt (modifyContainedASTs f a) (modifyContainedASTs f e) -instance ASTContainer TyBinder Expr where- containedASTs _ = []- modifyContainedASTs _ b = b--instance ASTContainer TyBinder Type where- containedASTs (AnonTyBndr t) = [t]- containedASTs (NamedTyBndr i) = containedASTs i-- modifyContainedASTs f (AnonTyBndr t) = AnonTyBndr (f t)- modifyContainedASTs f (NamedTyBndr i) = NamedTyBndr (modifyContainedASTs f i)- instance ASTContainer Coercion Expr where containedASTs _ = [] modifyContainedASTs _ c = c@@ -324,32 +347,52 @@ instance ASTContainer FuncCall Type where containedASTs (FuncCall { arguments = as, returns = r}) = containedASTs as ++ containedASTs r- modifyContainedASTs f fc@(FuncCall { arguments = as, returns = r}) = + modifyContainedASTs f fc@(FuncCall { arguments = as, returns = r}) = fc {arguments = modifyContainedASTs f as, returns = modifyContainedASTs f r} +instance ASTContainer RewriteRule Expr where+ containedASTs (RewriteRule { ru_args = a, ru_rhs = s }) = a ++ [s]+ modifyContainedASTs f rr@(RewriteRule { ru_args = a, ru_rhs = s }) =+ rr { ru_args = modifyContainedASTs f a, ru_rhs = modifyContainedASTs f s }++instance ASTContainer RewriteRule Type where+ containedASTs (RewriteRule { ru_bndrs = b, ru_args = a, ru_rhs = s }) =+ (containedASTs b) ++ (containedASTs a) ++ (containedASTs s)+ modifyContainedASTs f rr@(RewriteRule { ru_bndrs = b, ru_args = a, ru_rhs = s }) =+ rr {+ ru_bndrs = modifyContainedASTs f b+ , ru_args = modifyContainedASTs f a+ , ru_rhs = modifyContainedASTs f s+ }+ -- instance (Foldable f, Functor f, ASTContainer c t) => ASTContainer (f c) t where -- containedASTs = foldMap (containedASTs) -- modifyContainedASTs f = fmap (modifyContainedASTs f) instance ASTContainer c t => ASTContainer [c] t where- containedASTs = foldMap (containedASTs)+ containedASTs = foldMap containedASTs modifyContainedASTs f = fmap (modifyContainedASTs f) +instance ASTContainer c t => ASTContainer (S.Seq c) t where+ containedASTs = foldMap containedASTs++ modifyContainedASTs f = fmap (modifyContainedASTs f)+ instance ASTContainer c t => ASTContainer (Maybe c) t where- containedASTs = foldMap (containedASTs)+ containedASTs = foldMap containedASTs modifyContainedASTs f = fmap (modifyContainedASTs f) instance ASTContainer c t => ASTContainer (HM.HashMap k c) t where- containedASTs = foldMap (containedASTs)+ containedASTs = foldMap containedASTs modifyContainedASTs f = fmap (modifyContainedASTs f) instance ASTContainer c t => ASTContainer (M.Map k c) t where- containedASTs = foldMap (containedASTs)+ containedASTs = foldMap containedASTs modifyContainedASTs f = fmap (modifyContainedASTs f) @@ -389,10 +432,11 @@ modifyContainedASTs f (x, y, z, w, a) = (modifyContainedASTs f x, modifyContainedASTs f y, modifyContainedASTs f z, modifyContainedASTs f w, modifyContainedASTs f a) --- | Miscellaneous Instances+-- Miscellaneous Instances -- These instances exist so that we can use them in other types that contain -- ASTs and still consider those types ASTContainers. For example (Expr, Bool) -- should be an ASTContainer.+ instance ASTContainer Lit Expr where containedASTs _ = [] modifyContainedASTs _ t = t@@ -458,18 +502,17 @@ modifyContainedASTs f (NewTyCon ns dc rt) = NewTyCon ns (modifyContainedASTs f dc) rt modifyContainedASTs _ st@(TypeSynonym _ _) = st +instance (ASTContainer k t, ASTContainer v t, Eq k, Hashable k) => ASTContainer (UF.UFMap k v) t where+ containedASTs = containedASTs . UF.toList+ modifyContainedASTs f = UF.fromList . modifyContainedASTs f . UF.toList -- ====== -- -- AST Helper functions -- ====== -- --- | replaceASTs--- Replaces all instances of old with new in the ASTContainer+-- | `replaceASTs old new container` returns `container` but with all occurences of `old` replaced with `new`. replaceASTs :: (Eq e, ASTContainer c e) => e -> e -> c -> c replaceASTs old new = modifyContainedASTs (replaceASTs' old new) replaceASTs' :: (Eq e, AST e) => e -> e -> e -> e replaceASTs' old new e = if e == old then new else modifyChildren (replaceASTs' old new) e---
src/G2/Language/AlgDataTy.hs view
@@ -1,25 +1,50 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -module G2.Language.AlgDataTy where+module G2.Language.AlgDataTy ( AlgDataTy (..)+ , dataCon+ , dataConWithName) where +import GHC.Generics (Generic) import Data.Data (Data, Typeable)+import Data.Hashable+import Data.List import G2.Language.Syntax --type ProgramType = (Name, AlgDataTy)- -- | Algebraic data types are types constructed with parametrization of some -- names over types, and a list of data constructors for said type.-data AlgDataTy = DataTyCon { bound_ids :: [Id]- , data_cons :: [DataCon] }- | NewTyCon { bound_ids :: [Id]- , data_con :: DataCon- , rep_type :: Type }- | TypeSynonym { bound_ids :: [Id]- , synonym_of :: Type- } deriving (Show, Eq, Read, Typeable, Data)+data AlgDataTy = + -- | A type defined using the `data` keyword.+ DataTyCon { bound_ids :: [Id] -- ^ Polymorphic type variables+ , data_cons :: [DataCon] -- ^ Data constructors for the type+ }+ -- | A type defined using the `newtype` keyword.+ | NewTyCon { bound_ids :: [Id] -- ^ Polymorphic type variables+ , data_con :: DataCon -- ^ The data constructor for the newtype+ , rep_type :: Type -- ^ The type being wrapped by the newtype+ }+ -- | A type defined using the `type` keyword.+ | TypeSynonym { bound_ids :: [Id] -- ^ Polymorphic type variables+ , synonym_of :: Type -- ^ What type is the type synonym equivalent to?+ } deriving (Show, Eq, Read, Generic, Typeable, Data) +-- | Get the data constructors for the passed data type.+--+-- Warning: Does not "dig in" to type synonyms- a type synonym+-- will just give back an empty list.+dataCon :: AlgDataTy -> [DataCon]+dataCon (DataTyCon {data_cons = dc}) = dc+dataCon (NewTyCon {data_con = dc}) = [dc]+dataCon (TypeSynonym {}) = [] +dataConWithName :: AlgDataTy -> Name -> Maybe DataCon+dataConWithName (DataTyCon _ dcs) n = find (`dataConHasName` n) dcs+dataConWithName _ _ = Nothing++dataConHasName :: DataCon -> Name -> Bool+dataConHasName (DataCon n _) n' = n == n'++instance Hashable AlgDataTy
+ src/G2/Language/Approximation.hs view
@@ -0,0 +1,309 @@+module G2.Language.Approximation ( GenerateLemma+ , Lookup+ , MRCont+ + , moreRestrictive+ , moreRestrictive'+ , moreRestrictivePC++ , applySolver+ + , inlineEquiv) where++import G2.Execution.NormalForms+import G2.Language.Expr+import qualified G2.Language.ExprEnv as E+import G2.Language.Naming+import qualified G2.Language.PathConds as P+import G2.Language.Support+import G2.Language.Syntax+import G2.Language.Typing as T+import qualified G2.Solver as S++import Control.Monad.Extra+import Control.Monad.IO.Class+import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HM++type GenerateLemma t l = State t -> State t -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr)) -> Expr -> Expr -> l+type Lookup t = Name -> State t -> Maybe E.ConcOrSym++type MRCont t l = State t+ -> State t+ -> HS.HashSet Name+ -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+ -> Bool -- ^ indicates whether this is part of the "active expression"+ -> [(Name, Expr)] -- ^ variables inlined previously on the LHS+ -> [(Name, Expr)] -- ^ variables inlined previously on the RHS+ -> Expr+ -> Expr+ -> Either [l] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))++-------------------------------------------------------------------------------+-- [Inlining]+-- We keep two separate lists of variables that have been inlined previously on+-- the LHS and RHS. This means that inlinings on one side do not block any inlinings+-- that need to happen on the other side.+--+-- Whenever a variable is inlined, we record the expression that was on the+-- opposite side at the time. Not allowing a variable to be inlined at all on one+-- side in any sub-expressions that resulted from an inlining of it is too restrictive+-- in practice. We allow repeated inlinings of a variable as long as the expression on+-- the opposite side is not the same as it was when a previous inlining of the+-- same variable happened.+-------------------------------------------------------------------------------++-- | Check is s1 is an approximation of s2 (if s2 is more restrictive than s1.)+moreRestrictive :: MRCont t l -- ^ For special case handling - what to do if we don't match elsewhere in moreRestrictive+ -> GenerateLemma t l+ -> Lookup t -- ^ How to lookup variable names+ -> State t -- ^ s1+ -> State t -- ^ s2+ -> HS.HashSet Name -- ^ Names that should not be inlined (often: top level names from the original source code)+ -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+ -> Either [l] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+moreRestrictive mr_cont gen_lemma lkp s1 s2 ns hm =+ moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm True [] [] (getExpr s1) (getExpr s2)++moreRestrictive' :: MRCont t l -- ^ For special case handling - what to do if we don't match elsewhere in moreRestrictive'+ -> GenerateLemma t l+ -> Lookup t+ -> State t+ -> State t+ -> HS.HashSet Name -- ^ Names that should not be inlined (often: top level names from the original source code)+ -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+ -> Bool -- ^ indicates whether this is part of the "active expression"+ -> [(Name, Expr)] -- ^ variables inlined previously on the LHS (see [Inlining])+ -> [(Name, Expr)] -- ^ variables inlined previously on the RHS+ -> Expr+ -> Expr+ -> Either [l] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+moreRestrictive' mr_cont gen_lemma lkp s1@(State {expr_env = h1}) s2@(State {expr_env = h2}) ns hm active n1 n2 e1 e2 =+ case (e1, e2) of+ (Var i, _) | m <- idName i+ , not $ HS.member m ns+ , not $ (m, e2) `elem` n1+ , Just (E.Conc e) <- lkp m s1 ->+ moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active ((m, e2):n1) n2 e e2+ (_, Var i) | m <- idName i+ , not $ HS.member m ns+ , not $ (m, e1) `elem` n2+ , Just (E.Conc e) <- lkp m s2 ->+ moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 ((m, e1):n2) e1 e+ (Var i1, Var i2) | HS.member (idName i1) ns+ , idName i1 == idName i2 -> Right hm+ | HS.member (idName i1) ns -> Left []+ | HS.member (idName i2) ns -> Left []+ (Var i, _) | Just (E.Sym _) <- lkp (idName i) s1+ , (hm', hs) <- hm+ , Nothing <- HM.lookup i hm' -> Right (HM.insert i (inlineEquiv lkp s2 ns e2) hm', hs)+ | Just (E.Sym _) <- lkp (idName i) s1+ , Just e <- HM.lookup i (fst hm)+ , e == inlineEquiv lkp s2 ns e2 -> Right hm+ -- this last case means there's a mismatch+ | Just (E.Sym _) <- lkp (idName i) s1 -> Left []+ | not $ (idName i, e2) `elem` n1+ , not $ HS.member (idName i) ns -> error $ "unmapped variable " ++ (show i)+ (_, Var i) | Just (E.Sym _) <- lkp (idName i) s2 -> Left [] -- sym replaces non-sym+ | not $ (idName i, e1) `elem` n2+ , not $ HS.member (idName i) ns -> error $ "unmapped variable " ++ (show i)+ + (App f1 a1, App f2 a2) | Right hm_fa <- moreResFA -> Right hm_fa+ -- don't just choose the minimal conflicting expressions+ -- collect all suitable pairs for potential lemmas+ | not (hasFuncType e1)+ , not (hasFuncType e2)+ , not active+ , Var (Id m1 _):_ <- unApp (modifyASTs stripTicks e1)+ , Var (Id m2 _):_ <- unApp (modifyASTs stripTicks e2)+ , nameOcc m1 == nameOcc m2+ , Left lems <- moreResFA ->+ Left $ (gen_lemma s1 s2 hm e1 e2):lems+ | Left (_:_) <- moreResFA -> moreResFA+ where+ moreResFA = do+ hm_f <- moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 f1 f2+ moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm_f False n1 n2 a1 a2+ -- These two cases should come after the main App-App case. If an+ -- expression pair fits both patterns, then discharging it in a way that+ -- does not add any extra proof obligations is preferable.+ --+ -- We use an empty HashSet when inlining because when generating a path constraint+ -- we DO NOT want any top level names being preserved- these would just confuse the SMT solver.+ (App _ _, _) | e1':_ <- unApp e1+ , (Prim _ _) <- inlineEquiv lkp s1 HS.empty e1'+ , T.isPrimType $ typeOf e1+ , T.isPrimType $ typeOf e2+ , isSWHNF $ (s2 { curr_expr = CurrExpr Evaluate e2 }) ->+ let (hm', hs) = hm+ in Right (hm', HS.insert (inlineEquiv lkp s1 HS.empty e1, inlineEquiv lkp s2 HS.empty e2) hs)+ (_, App _ _) | e2':_ <- unApp e2+ , (Prim _ _) <- inlineEquiv lkp s2 HS.empty e2'+ , T.isPrimType $ typeOf e2+ , T.isPrimType $ typeOf e1+ , isSWHNF $ (s1 { curr_expr = CurrExpr Evaluate e1 }) ->+ let (hm', hs) = hm+ in Right (hm', HS.insert (inlineEquiv lkp s1 HS.empty e1, inlineEquiv lkp s2 HS.empty e2) hs)+ -- We just compare the names of the DataCons, not the types of the DataCons.+ -- This is because (1) if two DataCons share the same name, they must share the+ -- same type, but (2) "the same type" may be represented in different syntactic+ -- ways, most significantly bound variable names may differ+ -- "forall a . a" is the same type as "forall b . b", but fails a syntactic check.+ (Data (DataCon d1 _), Data (DataCon d2 _))+ | d1 == d2 -> Right hm+ | otherwise -> Left []+ -- We neglect to check type equality here for the same reason.+ (Prim p1 _, Prim p2 _) | p1 == p2 -> Right hm+ | otherwise -> Left []+ (Lit l1, Lit l2) | l1 == l2 -> Right hm+ | otherwise -> Left []+ (Lam lu1 i1 b1, Lam lu2 i2 b2)+ | lu1 == lu2+ , i1 == i2 ->+ let ns' = HS.insert (idName i1) ns+ -- no need to insert twice over because they're equal+ in moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns' hm active n1 n2 b1 b2+ | otherwise -> Left []+ -- ignore types, like in exprPairing+ (Type _, Type _) -> Right hm+ -- only works if both binding lists are the same length+ (Let binds1 e1', Let binds2 e2') ->+ let pairs = (e1', e2'):(zip (map snd binds1) (map snd binds2))+ ins (i_, e_) h_ = E.insert (idName i_) e_ h_+ h1_ = foldr ins h1 binds1+ h2_ = foldr ins h2 binds2+ s1' = s1 { expr_env = h1_ }+ s2' = s2 { expr_env = h2_ }+ mf hm_ (e1_, e2_) = moreRestrictive' mr_cont gen_lemma lkp s1' s2' ns hm_ active n1 n2 e1_ e2_+ in+ if length binds1 == length binds2+ then foldM mf hm pairs+ else Left []+ -- id equality never checked directly, but it's covered indirectly+ (Case e1' i1 _ a1, Case e2' i2 _ a2)+ | Right hm' <- b_mr ->+ let h1_ = E.insert (idName i1) e1' h1+ h2_ = E.insert (idName i2) e2' h2+ s1' = s1 { expr_env = h1_ }+ s2' = s2 { expr_env = h2_ }+ mf hm_ (e1_, e2_) = moreRestrictiveAlt mr_cont gen_lemma lkp s1' s2' ns hm_ False n1 n2 e1_ e2_+ l = zip a1 a2+ in foldM mf hm' l+ | otherwise -> b_mr+ where+ b_mr = moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 e1' e2'+ (Cast e1' c1, Cast e2' c2) | c1 == c2 ->+ moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 e1' e2'++ -- ignore all Ticks+ _ -> mr_cont s1 s2 ns hm active n1 n2 e1 e2++-- check only the names for DataAlt+altEquiv :: AltMatch -> AltMatch -> Bool+altEquiv (DataAlt dc1 ids1) (DataAlt dc2 ids2) =+ let DataCon dn1 _ = dc1+ DataCon dn2 _ = dc2+ n1 = map idName ids1+ n2 = map idName ids2+ in+ dn1 == dn2 && n1 == n2+altEquiv (LitAlt l1) (LitAlt l2) = l1 == l2+altEquiv Default Default = True+altEquiv _ _ = False++inlineEquiv :: Lookup t -> State t -> HS.HashSet Name -> Expr -> Expr+inlineEquiv lkp s ns v@(Var (Id n _))+ | Just (E.Sym _) <- cs = v+ | HS.member n ns = v+ | Just (E.Conc e) <- cs = inlineEquiv lkp s (HS.insert n ns) e+ where+ cs = lkp n s+inlineEquiv lkp s ns e = modifyChildren (inlineEquiv lkp s ns) e++-- ids are the same between both sides; no need to insert twice+moreRestrictiveAlt :: MRCont t l+ -> GenerateLemma t l+ -> Lookup t+ -> State t+ -> State t+ -> HS.HashSet Name+ -> (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+ -> Bool -- ^ active expression?+ -> [(Name, Expr)] -- ^ variables inlined previously on the LHS+ -> [(Name, Expr)] -- ^ variables inlined previously on the RHS+ -> Alt+ -> Alt+ -> Either [l] (HM.HashMap Id Expr, HS.HashSet (Expr, Expr))+moreRestrictiveAlt mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 (Alt am1 e1) (Alt am2 e2) =+ if altEquiv am1 am2 then+ case am1 of+ DataAlt _ t1 -> let ns' = foldr HS.insert ns $ map idName t1+ in moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns' hm active n1 n2 e1 e2+ _ -> moreRestrictive' mr_cont gen_lemma lkp s1 s2 ns hm active n1 n2 e1 e2+ else Left []++-- s1 is old state, s2 is new state+-- only apply to old-new state pairs for which moreRestrictive' works+moreRestrictivePC :: (MonadIO m, S.Solver solver) =>+ solver ->+ State t ->+ State t ->+ HM.HashMap Id Expr ->+ m Bool+moreRestrictivePC solver s1 s2 hm = do+ let new_conds = map extractCond (P.toList $ path_conds s2)+ old_conds = map extractCond (P.toList $ path_conds s1)+ l = map (\(i, e) -> (Var i, e)) $ HM.toList hm+ -- this should only be used with primitive types+ -- no apparent problems come from using TyUnknown+ l' = map (\(e1, e2) ->+ if (T.isPrimType $ typeOf e1) && (T.isPrimType $ typeOf e2)+ then Just $ App (App (Prim Eq TyUnknown) e1) e2+ else Nothing) l+ l'' = [c | Just c <- l']+ new_conds' = l'' ++ new_conds+ -- not safe to use unless the lists are non-empty+ conj_new = foldr1 (\o1 o2 -> App (App (Prim And TyUnknown) o1) o2) new_conds'+ conj_old = foldr1 (\o1 o2 -> App (App (Prim And TyUnknown) o1) o2) old_conds++ imp = App (App (Prim Implies TyUnknown) conj_new) conj_old+ neg_imp = ExtCond (App (Prim Not TyUnknown) imp) True+ neg_conj = ExtCond (App (Prim Not TyUnknown) conj_old) True+ + res <- if null old_conds+ then return $ S.UNSAT ()+ else if null new_conds'+ then liftIO $ applySolver solver (P.insert neg_conj P.empty) s1 s2+ else liftIO $ applySolver solver (P.insert neg_imp P.empty) s1 s2+ case res of+ S.UNSAT () -> return True+ _ -> return False++-- shortcut: don't invoke Z3 if there are no path conds+applySolver :: S.Solver solver =>+ solver ->+ PathConds ->+ State t ->+ State t ->+ IO (S.Result () () ())+applySolver solver extraPC s1 s2 =+ let unionEnv = E.union (expr_env s1) (expr_env s2)+ rightPC = P.toList $ path_conds s2+ unionPC = foldr P.insert (path_conds s1) rightPC+ -- adding extraPC in here may be redundant+ allPC = foldr P.insert unionPC (P.toList extraPC)+ newState = s1 { expr_env = unionEnv, path_conds = extraPC }+ in case (P.toList allPC) of+ [] -> return $ S.SAT ()+ _ -> S.check solver newState allPC++-- All the PathConds that this receives are generated by symbolic execution.+-- Consequently, non-primitive types are not an issue here.+extractCond :: PathCond -> Expr+extractCond (ExtCond e True) = e+extractCond (ExtCond e False) = App (Prim Not TyUnknown) e+extractCond (AltCond l e True) =+ App (App (Prim Eq TyUnknown) e) (Lit l)+extractCond (AltCond l e False) =+ App (App (Prim Neq TyUnknown) e) (Lit l)+extractCond _ = error "Not Supported"
src/G2/Language/ArbValueGen.hs view
@@ -1,20 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+ module G2.Language.ArbValueGen ( ArbValueGen , ArbValueFunc , arbValueInit , arbValue- , arbValueInfinite ) where+ , arbValueInfinite+ , constArbValue ) where -import G2.Language.AST import G2.Language.Expr import G2.Language.Support import G2.Language.Syntax import G2.Language.Typing import Data.List-import qualified Data.Map as M+import qualified Data.HashMap.Lazy as HM import Data.Ord import Data.Tuple +-- | A default `ArbValueGen`. arbValueInit :: ArbValueGen arbValueInit = ArbValueGen { intGen = 0 , floatGen = 0@@ -32,94 +35,171 @@ charGenInit :: [Char] charGenInit = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] --- | arbValue--- Allows the generation of arbitrary values of the given type.+-- | Allows the generation of arbitrary values of the given type. -- Cuts off recursive ADTs with a Prim Undefined -- Returns a new ArbValueGen that (in the case of the primitives) -- will give a different value the next time arbValue is called with -- the same Type. arbValue :: Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen)-arbValue = arbValue' getFiniteADT+arbValue t tenv = arbValue' getFiniteADT HM.empty t tenv --- | arbValue--- Allows the generation of arbitrary values of the given type.+-- | Allows the generation of arbitrary values of the given type.+-- Cuts off recursive ADTs with a Prim Undefined+-- Returns a new ArbValueGen that is identical to the passed ArbValueGen+constArbValue :: Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen)+constArbValue = constArbValue' getFiniteADT HM.empty++-- | Allows the generation of arbitrary values of the given type. -- Does not always cut off recursive ADTs. -- Returns a new ArbValueGen that (in the case of the primitives) -- will give a different value the next time arbValue is called with -- the same Type. arbValueInfinite :: Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen)-arbValueInfinite = arbValue' getADT+arbValueInfinite t = arbValueInfinite' cutOffVal HM.empty t -arbValue' :: GetADT -> Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen)-arbValue' getADTF t tenv av+arbValueInfinite' :: Int -> HM.HashMap Name Type -> Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen)+arbValueInfinite' cutoff = arbValue' (getADT cutoff)++arbValue' :: GetADT+ -> HM.HashMap Name Type -- ^ Maps TyVar's to Types+ -> Type+ -> TypeEnv+ -> ArbValueGen+ -> (Expr, ArbValueGen)+arbValue' getADTF m (TyFun t t') tenv av =+ let+ (e, av') = arbValue' getADTF m t' tenv av+ in+ (Lam TermL (Id (Name "_" Nothing 0 Nothing) t) e, av')+arbValue' getADTF m t tenv av | TyCon n _ <- tyAppCenter t , ts <- tyAppArgs t = maybe (Prim Undefined TyBottom, av) - (\adt -> getADTF tenv av adt ts)- (M.lookup n tenv)-arbValue' getADTF (TyApp t1 t2) tenv av =+ (\adt -> getADTF m tenv av adt ts)+ (HM.lookup n tenv)+arbValue' getADTF m (TyApp t1 t2) tenv av = let- (e1, av') = arbValue' getADTF t1 tenv av- (e2, av'') = arbValue' getADTF t2 tenv av'+ (e1, av') = arbValue' getADTF m t1 tenv av+ (e2, av'') = arbValue' getADTF m t2 tenv av' in (App e1 e2, av'')-arbValue' _ TyLitInt _ av =+arbValue' _ _ TyLitInt _ av = let i = intGen av in (Lit (LitInt $ i), av { intGen = i + 1 })-arbValue' _ TyLitFloat _ av =+arbValue' _ _ TyLitFloat _ av = let f = floatGen av in (Lit (LitFloat $ f), av { floatGen = f + 1 })-arbValue' _ TyLitDouble _ av =+arbValue' _ _ TyLitDouble _ av = let d = doubleGen av in (Lit (LitDouble $ d), av { doubleGen = d + 1 })-arbValue' _ TyLitChar _ av =+arbValue' _ _ TyLitChar _ av = let c:cs = case charGen av of xs@(_:_) -> xs _ -> charGenInit in (Lit (LitChar c), av { charGen = cs})-arbValue' _ t _ av = (Prim Undefined t, av)+arbValue' getADTF m (TyVar (Id n _)) tenv av+ | Just t <- HM.lookup n m = arbValue' getADTF m t tenv av+arbValue' _ _ t _ av = (Prim Undefined t, av) -type GetADT = TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen) --- Generates an arbitrary value of the given ADT,--- but will return something containing @(Prim Undefined)@ instead of an infinite Expr-getFiniteADT :: TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen)-getFiniteADT tenv av adt ts =+constArbValue' :: GetADT -> HM.HashMap Name Type -> Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen)+constArbValue' getADTF m (TyFun t t') tenv av = let- (e, av') = getADT tenv av adt ts+ (e, _) = constArbValue' getADTF m t' tenv av in+ (Lam TermL (Id (Name "_" Nothing 0 Nothing) t) e, av)+constArbValue' getADTF m t tenv av+ | TyCon n _ <- tyAppCenter t+ , ts <- tyAppArgs t =+ maybe (Prim Undefined TyBottom, av) + (\adt -> getADTF m tenv av adt ts)+ (HM.lookup n tenv)+constArbValue' getADTF m (TyApp t1 t2) tenv av =+ let+ (e1, _) = constArbValue' getADTF m t1 tenv av+ (e2, _) = constArbValue' getADTF m t2 tenv av+ in+ (App e1 e2, av)+constArbValue' _ _ TyLitInt _ av =+ let+ i = intGen av+ in+ (Lit (LitInt $ i), av)+constArbValue' _ _ TyLitFloat _ av =+ let+ f = floatGen av+ in+ (Lit (LitFloat $ f), av)+constArbValue' _ _ TyLitDouble _ av =+ let+ d = doubleGen av+ in+ (Lit (LitDouble $ d), av)+constArbValue' _ _ TyLitChar _ av =+ let+ c:_ = case charGen av of+ xs@(_:_) -> xs+ _ -> charGenInit+ in+ (Lit (LitChar c), av)+constArbValue' getADTF m (TyVar (Id n _)) tenv av+ | Just t <- HM.lookup n m = constArbValue' getADTF m t tenv av+constArbValue' _ _ t _ av = (Prim Undefined t, av)++type GetADT = HM.HashMap Name Type -> TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen)++-- | Generates an arbitrary value of the given ADT,+-- but will return something containing @(Prim Undefined)@ instead of an infinite Expr.+getFiniteADT :: HM.HashMap Name Type -> TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen)+getFiniteADT m tenv av adt ts =+ let+ (e, av') = getADT cutOffVal m tenv av adt ts+ in (cutOff [] e, av') +-- | How long to go before cutting off finite ADTs?+cutOffVal :: Int+cutOffVal = 3+ cutOff :: [Name] -> Expr -> Expr cutOff ns a@(App _ _) | Data (DataCon n _) <- appCenter a =- case n `elem` ns of+ case length (filter (== n) ns) > cutOffVal of True -> Prim Undefined TyBottom False -> mapArgs (cutOff (n:ns)) a cutOff _ e = e -- | Generates an arbitrary value of the given AlgDataTy--- If there is no such finite value, this may return an infinite Expr-getADT :: TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen)-getADT tenv av adt ts =- let- dcs = dataCon adt- ids = boundIds adt+-- If there is no such finite value, this may return an infinite Expr.+--+-- Has a bit of a hack: will update the ArbValueGen, but only for a limited number of loops.+-- This is to ensure that an ArbValueGen is eventually returned.+-- To see why this is needed, suppose we are returning an infinitely large Expr.+-- This Expr will be returned lazily. But the return of the ArbValueGen is not lazy-+-- so we must just cut off and return at some point.+getADT :: Int -> HM.HashMap Name Type -> TypeEnv -> ArbValueGen -> AlgDataTy -> [Type] -> (Expr, ArbValueGen)+getADT cutoff m tenv av adt ts + | dcs <- dataCon adt+ , _:_ <- dcs =+ let+ ids = bound_ids adt - -- Finds the DataCon for adt with the least arguments- min_dc = minimumBy (comparing (length . dataConArgs)) dcs+ -- Finds the DataCon for adt with the least arguments+ min_dc = minimumBy (comparing (length . anonArgumentTypes)) dcs - tyVIds = map TyVar ids- min_dc' = foldr (uncurry replaceASTs) min_dc $ zip tyVIds ts+ m' = foldr (uncurry HM.insert) m $ zip (map idName ids) ts - (av', es) = mapAccumL (\av_ t -> swap $ arbValueInfinite t tenv av_) av $ dataConArgs min_dc'- in- (mkApp $ Data min_dc':map Type ts ++ es, av')+ (av', es) = mapAccumL (\av_ t -> swap $ arbValueInfinite' (cutoff - 1) m' (applyTypeHashMap m' t) tenv av_) av $ anonArgumentTypes min_dc++ final_av = if cutoff >= 0 then av' else av+ in+ (mkApp $ Data min_dc:map Type ts ++ es, final_av)+ | otherwise = (Prim Undefined TyBottom, av)
+ src/G2/Language/CallGraph.hs view
@@ -0,0 +1,86 @@+module G2.Language.CallGraph ( CallGraph+ , getCallGraph+ , functions+ , calls+ , calledBy+ , nameLevels+ , reachable ) where++import qualified G2.Language.ExprEnv as E+import G2.Language.Naming+import G2.Language.Syntax++import Data.Graph hiding (reachable)+import qualified Data.Graph as G+import Data.Maybe++data CallGraph = CallGraph { graph :: Graph+ , nfv :: Vertex -> ((), Name, [Name])+ , vert :: Name -> Maybe Vertex}++getCallGraph :: E.ExprEnv -> CallGraph+getCallGraph eenv =+ let+ funcs = E.keys eenv+ + (g, nfv', vert') = graphFromEdges+ . map (\(n, e) -> + let+ clls = filter (\n' -> n' `elem` funcs) . map idName $ varIds e+ in+ ((), n, clls)) $ E.toList eenv+ in+ CallGraph g nfv' vert'++functions :: CallGraph -> [Name]+functions cg = map (\(_, n, _) -> n) . map (nfv cg) . vertices $ graph cg++callsList :: CallGraph -> [(Name, Name)]+callsList cg = map (\(v1, v2) -> (mid $ nfv cg v1, mid $ nfv cg v2)) . edges $ graph cg+ where+ mid (_, m, _) = m++nodeName :: CallGraph -> Vertex -> Name+nodeName g v = (\(_, n, _) -> n) $ nfv g v++-- | Functions directly called by the named function+calls :: Name -> CallGraph -> Maybe [Name]+calls n g = fmap (\(_, _, ns) -> ns) . fmap (nfv g) $ vert g n++calledBy :: Name -> CallGraph -> [Name]+calledBy n g = map fst+ . filter ((==) n . snd)+ . map (\(v1, v2) -> (nodeName g v1, nodeName g v2)) $ edges (graph g)++-- Functions directly and indirectly called by the named function+reachable :: Name -> CallGraph -> [Name]+reachable n g =+ map ((\(_, x, _) -> x) . nfv g) . maybe [] (G.reachable $ graph g) $ vert g n++-- | Returns:+-- (1) a list of list of names, where the first list contains functions+-- that are not called by any functions (except themselves), and the nth list, n > 2,+-- includes functions called by functions in the (n - 1)th list.+nameLevels :: CallGraph -> [[Name]]+nameLevels cg =+ let+ fs = functions cg+ eds = callsList cg++ callers = fs+ called_by_others = mapMaybe (\(n1, n2) -> if n1 /= n2 then Just n2 else Nothing) eds++ only_caller = filter (`notElem` called_by_others) callers+ in+ only_caller:nameLevels' only_caller (removeEdgesTo only_caller eds)++nameLevels' :: [Name] -> [(Name, Name)] -> [[Name]]+nameLevels' [] _ = []+nameLevels' callers eds =+ let+ called = map snd $ filter (\(n1, _) -> n1 `elem` callers) eds+ in+ called:nameLevels' called (removeEdgesTo called eds)++removeEdgesTo :: [Name] -> [(Name, Name)] -> [(Name, Name)]+removeEdgesTo ns = filter (\(_, n2) -> n2 `notElem` ns)
src/G2/Language/Casts.hs view
@@ -13,22 +13,44 @@ import G2.Language.Naming import G2.Language.Syntax import G2.Language.Typing+import Data.Monoid as M +containsCast :: ASTContainer m Expr => m -> M.Any+containsCast = evalASTs isCast++isCast :: Expr -> M.Any+isCast (Cast _ _) = Any True+isCast _ = Any False+ -- | Removes all casts from the expression. Makes no guarantees about the type -- correctness of the resulting expression. In particular, the expression -- is likely to not actually type correctly if it contains variables that -- are mapped in the Expression Environment unsafeElimCast :: ASTContainer m Expr => m -> m-unsafeElimCast = modifyASTsFix unsafeElimOuterCast+unsafeElimCast e = if (getAny $ containsCast e) then modifyContainedASTs unsafeElimOuterCast e else e unsafeElimOuterCast :: Expr -> Expr unsafeElimOuterCast (Cast e (t1 :~ t2)) = replaceASTs t1 t2 e unsafeElimOuterCast e = e -- | Given a function cast from (t1 -> t2) to (t1' -> t2'), decomposes it to two--- seperate casts, from t1 to t1', and from t2 to t2'. Given a cast (t1 ~ t2)--- where t1 is a NewTyCon N t3 such that t2 /= t3, changes the cast to be--- (t1 ~ t3) (t3 ~ t2).+-- seperate casts, from t1' to t1, and from t2 to t2'.+-- Note that the direction of the cast differs intentionally. Consider:+--+-- @ newtype Money = Money Int+-- newtype Person = Person String +-- f :: String -> Money+-- p :: Person+-- +-- g = coerce (f :: Person -> Int) p+-- g' = coerce (f (coerce p :: String)) :: Int+-- @+-- g and g' are equivalent. To shift the coercion from a function coercion to coercions on the inputs and outputs,+-- we keep the same result type coercion, but have to flip the argument coercion. +--+-- In addition to splitting function casts, given a cast (t1 ~ t2) where t1 is a NewTyCon N t3 such that t2 /= t3,+-- we change the cast to be (t1 ~ t3) (t3 ~ t2).+-- -- Given any other expression, acts as the identity function splitCast :: NameGen -> Expr -> (Expr, NameGen) splitCast ng (Cast e ((TyFun t1 t2) :~ (TyFun t1' t2'))) =@@ -39,13 +61,13 @@ (Cast (App e- (Cast (Var i) (t1 :~ t1'))+ (Cast (Var i) (t1' :~ t1)) ) (t2 :~ t2') ) in (e', ng')-splitCast ng (Cast e ((TyForAll (NamedTyBndr ni) t2) :~ (TyForAll (NamedTyBndr ni') t2'))) =+splitCast ng (Cast e ((TyForAll ni t2) :~ (TyForAll ni' t2'))) = let t1 = typeOf ni t1' = typeOf ni'@@ -58,12 +80,12 @@ e (Cast (Var i) (t1 :~ t1')) )- (t2 :~ t2')+ (rename (idName ni) (idName i) t2 :~ rename (idName ni') (idName i) t2') ) in (e', ng')-splitCast ng c@(Cast e (t1 :~ t2)) =- if hasFuncType (PresType t1) || hasFuncType (PresType t2) then (e, ng) else (c, ng)+-- splitCast ng c@(Cast e (t1 :~ t2)) =+-- if hasFuncType (PresType t1) || hasFuncType (PresType t2) then (e, ng) else (c, ng) splitCast ng e = (e, ng) -- | Eliminates redundant casts.@@ -89,7 +111,7 @@ liftCasts' e = e liftCasts'' :: Expr-> Expr-liftCasts'' (App (Cast f (TyForAll (NamedTyBndr b1) t1 :~ TyForAll (NamedTyBndr b2) t2)) e@(Type t)) =+liftCasts'' (App (Cast f (TyForAll b1 t1 :~ TyForAll b2 t2)) e@(Type t)) = let t1' = retype b1 t t1 t2' = retype b2 t t2
src/G2/Language/Expr.hs view
@@ -3,51 +3,85 @@ {-# LANGUAGE OverloadedStrings #-} module G2.Language.Expr ( module G2.Language.Casts- , unApp- , mkApp- , mkDCTrue- , mkDCFalse- , mkTrue- , mkFalse- , mkBool- , mkDCInt- , mkDCInteger- , mkDCFloat- , mkDCDouble- , mkDCChar- , mkCons- , mkEmpty- , mkIdentity- , getFuncCalls- , getFuncCallsRHS- , modifyAppTop- , modifyAppLHS- , modifyAppRHS- , modifyLamTop- , nonDataFunctionCalls- , appCenter- , mapArgs- , mkLams- , elimAsserts- , leadingLamUsesIds- , leadingLamIds- , insertInLams- , maybeInsertInLams- , inLams- , replaceASTs- , args- , passedArgs- , vars- , varIds- , varNames- , varId- , symbVars- , freeVars- , alphaReduction- , varBetaReduction- , etaExpandTo- , mkStrict) where+ , eqUpToTypes+ , unApp+ , mkApp+ , mkDCTrue+ , mkDCFalse+ , mkTrue+ , mkFalse+ , mkBool+ , mkDCInt+ , mkDCInteger+ , mkDCFloat+ , mkDCDouble+ , mkDCChar+ , mkCons+ , mkEmpty+ , mkG2List+ , mkJust+ , mkNothing+ , mkUnit + , mkIdentity+ , mkEqExpr+ , mkGeIntExpr+ , mkLeIntExpr+ , mkAndExpr+ , mkOrExpr+ , mkNotExpr+ , mkImpliesExpr+ , mkToRatioExpr+ , mkFromRationalExpr+ , mkIntegralExtactReal+ , mkRealExtractNum+ , mkRealExtractOrd+ , mkOrdExtractEq++ , mkEqPrimExpr++ , isData+ , isLit+ , isLam+ , isADT++ , replaceVar+ , getFuncCalls+ , getFuncCallsRHS+ , modifyAppTop+ , modifyAppedDatas+ , modifyAppLHS+ , modifyAppRHS+ , modifyLamTop+ , nonDataFunctionCalls+ , appCenter+ , mapArgs+ , mkLams+ , elimAsserts+ , elimAssumes+ , assertsToAssumes+ , leadingLamUsesIds+ , leadingLamIds+ , insertInLams+ , maybeInsertInLams+ , inLams+ , simplifyLams+ , flattenLets+ , replaceASTs+ , args+ , passedArgs+ , vars+ , varIds+ , varNames+ , varId+ , symbVars+ , freeVars+ , alphaReduction+ , varBetaReduction+ , etaExpandTo+ , mkStrict+ , mkStrict_maybe) where+ import G2.Language.AST import G2.Language.Casts import qualified G2.Language.ExprEnv as E@@ -56,17 +90,44 @@ import G2.Language.Support import G2.Language.Syntax import G2.Language.Typing+import G2.Language.Primitives import Data.Foldable import qualified Data.Map as M import Data.Maybe import Data.Semigroup +eqUpToTypes :: Expr -> Expr -> Bool+eqUpToTypes (Var (Id n _)) (Var (Id n' _)) = n == n'+eqUpToTypes (Lit l) (Lit l') = l == l'+eqUpToTypes (Prim p _) (Prim p' _) = p == p'+eqUpToTypes (Data (DataCon n _)) (Data (DataCon n' _)) = n == n'+eqUpToTypes (App e1 e2) (App e1' e2') = e1 `eqUpToTypes` e1' && e2 `eqUpToTypes` e2'+eqUpToTypes (Lam lu (Id n _) e) (Lam lu' (Id n' _) e') = lu == lu' && n == n' && e `eqUpToTypes` e'+eqUpToTypes (Let b e) (Let b' e') =+ let+ be_eq = all (\((Id n _, be), (Id n' _, be')) -> n == n' && be `eqUpToTypes` be') $ zip b b'+ in+ be_eq && e `eqUpToTypes` e'+eqUpToTypes (Case _ _ _ _) (Case _ _ _ _) = error "Case not supported"+eqUpToTypes (Type _) (Type _) = True+eqUpToTypes (Cast e _) (Cast e' _) = e `eqUpToTypes` e'+eqUpToTypes (Coercion _) (Coercion _) = True+eqUpToTypes (Tick _ e) (Tick _ e') = e `eqUpToTypes` e'+eqUpToTypes (NonDet es) (NonDet es') = all (uncurry eqUpToTypes) $ zip es es'+eqUpToTypes (SymGen _ _) (SymGen _ _) = True+eqUpToTypes (Assume _ _ _) (Assume _ _ _) = True+eqUpToTypes (Assert _ _ _) (Assert _ _ _) = True+eqUpToTypes _ _ = False+ -- | Unravels the application spine. unApp :: Expr -> [Expr]-unApp (App f a) = unApp f ++ [a]-unApp expr = [expr]+unApp = unApp' [] +unApp' :: [Expr] -> Expr -> [Expr]+unApp' xs (App f a) = unApp' (a:xs) f+unApp' xs e = e:xs+ -- | Turns the Expr list into an Application -- -- @ mkApp [e1, e2, e3] == App (App e1 e2) e3@@@ -110,7 +171,29 @@ mkEmpty :: KnownValues -> TypeEnv -> Expr mkEmpty kv tenv = Data . fromJust $ getDataCon tenv (KV.tyList kv) (KV.dcEmpty kv)+ +-- | Construct a G2 list `Expr` containing a list of `Expr`s+mkG2List :: KnownValues+ -> TypeEnv+ -> Type -- ^ The type of the values in the list.+ -> [Expr]+ -> Expr+mkG2List kv tenv t = foldr go (App emp (Type t))+ where+ cons = mkCons kv tenv+ emp = mkEmpty kv tenv + go e es = App (App (App cons (Type t)) e) es++mkJust :: KnownValues -> TypeEnv -> Expr+mkJust kv tenv = Data . fromJust $ getDataCon tenv (KV.tyMaybe kv) (KV.dcJust kv)++mkNothing :: KnownValues -> TypeEnv -> Expr+mkNothing kv tenv = Data . fromJust $ getDataCon tenv (KV.tyMaybe kv) (KV.dcNothing kv)++mkUnit :: KnownValues -> TypeEnv -> Expr+mkUnit kv tenv = Data . fromJust $ getDataCon tenv (KV.tyUnit kv) (KV.dcUnit kv)+ mkIdentity :: Type -> Expr mkIdentity t = let@@ -118,6 +201,89 @@ in Lam TermL x (Var x) +mkEqExpr :: KnownValues -> Expr -> Expr -> Expr+mkEqExpr kv e1 e2 = App (App eq e1) e2+ where eq = mkEqPrimType (typeOf e1) kv++mkEqPrimExpr :: KnownValues -> Expr -> Expr -> Expr+mkEqPrimExpr kv e1 e2 = App (App eq e1) e2+ where eq = mkEqPrimType (typeOf e1) kv++mkGeIntExpr :: KnownValues -> Expr -> Integer -> Expr+mkGeIntExpr kv e num = App (App ge e) (Lit (LitInt num))+ where ge = mkGePrimInt kv++mkLeIntExpr :: KnownValues -> Expr -> Integer -> Expr+mkLeIntExpr kv e num = App (App le e) (Lit (LitInt num))+ where le = mkLePrimInt kv++mkAndExpr :: KnownValues -> Expr -> Expr -> Expr+mkAndExpr kv e1 e2 = App (App andEx e1) e2+ where andEx = mkAndPrim kv++mkOrExpr :: KnownValues -> Expr -> Expr -> Expr+mkOrExpr kv e1 e2 = App (App orEx e1) e2+ where orEx = mkOrPrim kv++mkImpliesExpr :: KnownValues -> Expr -> Expr -> Expr+mkImpliesExpr kv e1 e2 = App (App impEx e1) e2+ where impEx = mkImpliesPrim kv++mkNotExpr :: KnownValues -> Expr -> Expr+mkNotExpr kv e = App notEx e+ where notEx = mkNotPrim kv++mkToRatioExpr :: KnownValues -> Expr+mkToRatioExpr kv = Var $ Id (KV.toRatioFunc kv) TyUnknown++mkFromRationalExpr :: KnownValues -> Expr+mkFromRationalExpr kv = Var $ Id (KV.fromRationalFunc kv) TyUnknown++mkIntegralExtactReal :: KnownValues -> Expr+mkIntegralExtactReal kv = Var $ Id (KV.integralExtactReal kv) TyUnknown++mkRealExtractNum :: KnownValues -> Expr+mkRealExtractNum kv = Var $ Id (KV.realExtractNum kv) TyUnknown++mkRealExtractOrd :: KnownValues -> Expr+mkRealExtractOrd kv = Var $ Id (KV.realExtractOrd kv) TyUnknown++mkOrdExtractEq :: KnownValues -> Expr+mkOrdExtractEq kv = Var $ Id (KV.ordExtractEq kv) TyUnknown++isData :: Expr -> Bool+isData (Data _) = True+isData _ = False++isLit :: Expr -> Bool+isLit (Lit _) = True+isLit _ = False++isLam :: Expr -> Bool+isLam (Lam _ _ _) = True+isLam _ = False++isADT :: Expr -> Bool+isADT e+ | Data _:_ <- unApp e = True+ | otherwise = False++replaceVar :: ASTContainer m Expr => Name -> Expr -> m -> m+replaceVar n e = modifyContainedASTs (replaceVar' n e)++replaceVar' :: Name -> Expr -> Expr -> Expr+replaceVar' n e v@(Var (Id n' _)) =+ if n == n' then e else v+replaceVar' n _ le@(Lam _ (Id n' _) _) | n == n' = le+replaceVar' n e (Case b i@(Id n' _) t as) | n == n' = Case (replaceVar n e b) i t as+replaceVar' n e (Case b i t as) = Case (replaceVar' n e b) i t (map repAlt as)+ where+ repAlt a@(Alt (DataAlt _ is) _)+ | n `elem` map idName is = a+ repAlt a = modifyContainedASTs (replaceVar' n e) a+replaceVar' n _ le@(Let b _) | n `elem` map (idName . fst) b = le+replaceVar' n e e' = modifyChildren (replaceVar' n e) e'+ getFuncCalls :: ASTContainer m Expr => m -> [Expr] getFuncCalls = evalContainedASTs getFuncCalls' @@ -141,17 +307,33 @@ let e' = f e in- modifyAppRHS (modifyAppTop' f) e' -modifyAppTop' f e = modifyChildren f e+ modifyAppCenter (modifyChildren (modifyAppTop' f)) $ modifyAppRHS (modifyAppTop' f) e' +modifyAppTop' f e = modifyChildren (modifyAppTop' f) e -modifyAppLHS :: (Expr -> Expr) -> Expr -> Expr-modifyAppLHS f (App e e') = App (f e) (modifyAppLHS f e')-modifyAppLHS _ e = e+modifyAppedDatas :: ASTContainer m Expr => (DataCon -> [Expr] -> Expr) -> m -> m+modifyAppedDatas f = modifyContainedASTs (modifyAppedDatas' f) +modifyAppedDatas' :: (DataCon -> [Expr] -> Expr) -> Expr -> Expr+modifyAppedDatas' f e+ | (Data dc:es) <- unApp e =+ let+ e' = f dc es+ in+ modifyAppCenter (modifyChildren (modifyAppedDatas' f)) $ modifyAppRHS (modifyAppedDatas' f) e'+ | otherwise = modifyChildren (modifyAppedDatas' f) e+ modifyAppRHS :: (Expr -> Expr) -> Expr -> Expr modifyAppRHS f (App e e') = App (modifyAppRHS f e) (f e') modifyAppRHS _ e = e +modifyAppLHS :: (Expr -> Expr) -> Expr -> Expr+modifyAppLHS f (App e e') = App (f e) (modifyAppLHS f e')+modifyAppLHS _ e = e++modifyAppCenter :: (Expr -> Expr) -> Expr -> Expr+modifyAppCenter f (App e e') = App (modifyAppCenter f e) e'+modifyAppCenter f e = f e+ modifyLamTop :: ASTContainer m Expr => (Expr -> Expr) -> m -> m modifyLamTop f = modifyContainedASTs (modifyLamTop' f) @@ -196,6 +378,21 @@ elimAsserts' (Assert _ _ e) = e elimAsserts' e = e +-- | Remove all @Assume@s from the given `Expr`+elimAssumes :: ASTContainer m Expr => m -> m+elimAssumes = modifyASTs elimAssumes'++elimAssumes' :: Expr -> Expr+elimAssumes' (Assume _ _ e) = e+elimAssumes' e = e++assertsToAssumes :: ASTContainer m Expr => m -> m+assertsToAssumes = modifyASTs assertsToAssumes'++assertsToAssumes' :: Expr -> Expr+assertsToAssumes' (Assert fc e e') = Assume fc e e'+assertsToAssumes' e = e+ -- Runs the given function f on the expression nested in the lambdas, and -- rewraps the new expression with the Lambdas insertInLams :: ([Id] -> Expr -> Expr) -> Expr -> Expr@@ -217,6 +414,13 @@ inLams (Lam _ _ e) = inLams e inLams e = e +simplifyLams :: ASTContainer c Expr => c -> c+simplifyLams = modifyASTs simplifyLams'++simplifyLams' :: Expr -> Expr+simplifyLams' (App (Lam _ i e1) e2) = replaceASTs (Var i) e2 e1+simplifyLams' e = e+ leadingLamUsesIds :: Expr -> [(LamUse, Id)] leadingLamUsesIds (Lam u i e) = (u, i):leadingLamUsesIds e leadingLamUsesIds _ = []@@ -225,6 +429,28 @@ leadingLamIds (Lam _ i e) = i:leadingLamIds e leadingLamIds _ = [] +flattenLets :: ASTContainer m Expr => m -> m+flattenLets = modifyASTs flattenLet++flattenLet :: Expr -> Expr+flattenLet l@(Let be e) =+ case findElem (isLet . snd) be of+ Just ((bi, Let ibe ie), be') -> flattenLet $ Let (ibe ++ (bi, ie):be') e+ _ -> l+flattenLet e = e++isLet :: Expr -> Bool+isLet (Let _ _) = True+isLet _ = False++findElem :: (a -> Bool) -> [a] -> Maybe (a, [a])+findElem p = find' id+ where+ find' _ [] = Nothing+ find' pre (x : xs)+ | p x = Just (x, pre xs)+ | otherwise = find' (pre . (x:)) xs+ -- | Returns all Ids from Lam's at the top of the Expr args :: Expr -> [Id] args (Lam _ i e) = i:args e@@ -238,32 +464,36 @@ passedArgs' _ = [] --Returns all Vars in an ASTContainer-vars :: (ASTContainer m Expr) => m -> [Expr]+vars :: (ASTContainer m Expr) => m -> [Id] vars = evalASTs vars' -vars' :: Expr -> [Expr]-vars' v@(Var _) = [v]+vars' :: Expr -> [Id]+vars' (Var i) = [i] vars' _ = [] varId :: Expr -> Maybe Id varId (Var i) = Just i varId _ = Nothing -symbVars :: (ASTContainer m Expr) => ExprEnv -> m -> [Expr]+symbVars :: (ASTContainer m Expr) => ExprEnv -> m -> [Id] symbVars eenv = filter (symbVars' eenv) . vars -symbVars' :: ExprEnv -> Expr -> Bool-symbVars' eenv (Var (Id n _)) = E.isSymbolic n eenv-symbVars' _ _ = False+symbVars' :: ExprEnv -> Id -> Bool+symbVars' eenv (Id n _) = E.isSymbolic n eenv -- | freeVars -- Returns the free (unbound by a Lambda, Let, or the Expr Env) variables of an expr freeVars :: ASTContainer m Expr => E.ExprEnv -> m -> [Id] freeVars eenv = evalASTsMonoid (freeVars' eenv) +freeAltMatch :: AltMatch -> [Id]+freeAltMatch (DataAlt _ is) = is+freeAltMatch _ = []+ freeVars' :: E.ExprEnv -> [Id] -> Expr -> ([Id], [Id]) freeVars' _ _ (Let b _) = (map fst b, []) freeVars' _ _ (Lam _ b _) = ([b], [])+freeVars' _ _ (Case _ b _ alt) = (b:concatMap (freeAltMatch . altMatch) alt, []) freeVars' eenv bound (Var i) = if E.member (idName i) eenv || i `elem` bound then ([], [])@@ -357,6 +587,7 @@ | otherwise = n' where m' = M.insert v i m+ validN _ _ i (Data _) = i validN eenv' m i (App e' _) = validN eenv' m (i + 1) e' validN eenv' m i (Let b e') = let@@ -367,8 +598,8 @@ addLamApps :: [Name] -> Type -> Expr -> Expr addLamApps [] _ e' = e'- addLamApps (_:ns) (TyForAll (NamedTyBndr b) t') e' =- Lam TypeL b (App (addLamApps ns t' e') (Var b))+ addLamApps (_:ns) (TyForAll b t') e' =+ Lam TypeL b (App (addLamApps ns t' e') (Type (TyVar b))) addLamApps (ln:ns) (TyFun t t') e' = Lam TermL (Id ln t) (App (addLamApps ns t' e') (Var (Id ln t))) addLamApps _ _ e' = e'@@ -399,3 +630,24 @@ Just i -> foldl' (App) (Var i) (map Type ts ++ map (typeToWalker w) ts) Nothing -> error $ "typeToWalker: failed to find type: " ++ show n typeToWalker _ t = mkIdentity t++mkStrict_maybe :: Walkers -> Expr -> Maybe Expr+mkStrict_maybe w e =+ let+ t = tyAppCenter (typeOf e)+ ts = tyAppArgs (typeOf e)+ in+ case t of+ (TyCon n _) -> case M.lookup n w of+ Just i -> Just $ App (foldl' (App) (Var i) (map Type ts ++ map (typeToWalker_maybe w) ts)) e+ Nothing -> Nothing+ _ -> Nothing++typeToWalker_maybe :: Walkers -> Type -> Expr+typeToWalker_maybe w t+ | TyCon n _ <- tyAppCenter t+ , ts <- tyAppArgs t =+ case M.lookup n w of+ Just i -> foldl' (App) (Var i) (map Type ts ++ map (typeToWalker_maybe w) ts)+ Nothing -> mkIdentity t+typeToWalker_maybe _ t = mkIdentity t
src/G2/Language/ExprEnv.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}@@ -6,6 +7,10 @@ module G2.Language.ExprEnv ( ExprEnv , ConcOrSym (..)+ , EnvObj (..)++ , concOrSymToExpr+ , empty , singleton , fromList@@ -14,21 +19,31 @@ , member , lookup , lookupConcOrSym+ , lookupEnvObj , deepLookup , isSymbolic , occLookup , lookupNameMod+ , nameModMap , insert , insertSymbolic , insertExprs , redirect+ , difference , union+ , union'+ , unionWith+ , unionWithM+ , unionWithNameM , (!) , map , map'+ , mapConc , mapWithKey , mapWithKey'- , mapKeys+ , mapConcWithKey+ , mapConcOrSym+ , mapConcOrSymWithKey , mapM , mapWithKeyM , filter@@ -37,12 +52,15 @@ , getIdFromName , funcsOfType , keys- , symbolicKeys+ , symbolicIds , elems , higherOrderExprs+ , redirsToExprs , toList , toExprList , fromExprList+ , fromExprMap+ , toHashMap ) where import G2.Language.AST@@ -58,14 +76,24 @@ import qualified Prelude as Pre import Data.Coerce import Data.Data (Data, Typeable)+import Data.Hashable import qualified Data.List as L-import qualified Data.Map as M+import qualified Data.HashMap.Lazy as M import Data.Maybe+import Data.Monoid ((<>))+import qualified Data.Sequence as S import qualified Data.Text as T+import qualified Data.Traversable as Trav+import GHC.Generics (Generic) data ConcOrSym = Conc Expr | Sym Id+ deriving (Show) +concOrSymToExpr :: ConcOrSym -> Expr+concOrSymToExpr (Conc e) = e+concOrSymToExpr (Sym i) = Var i+ -- From a user perspective, `ExprEnv`s are mappings from `Name` to -- `Expr`s. however, there are two complications: -- 1) Redirection pointers can map two names to the same expr@@ -75,14 +103,27 @@ data EnvObj = ExprObj Expr | RedirObj Name | SymbObj Id- deriving (Show, Eq, Read, Typeable, Data)+ deriving (Show, Eq, Read, Generic, Typeable, Data) -newtype ExprEnv = ExprEnv (M.Map Name EnvObj)- deriving (Show, Eq, Read, Typeable, Data)+instance Hashable EnvObj -unwrapExprEnv :: ExprEnv -> M.Map Name EnvObj+-- | Maps `Name`s to `Expr`s. Tracks `Type`s of symbolic variables. +newtype ExprEnv = ExprEnv (M.HashMap Name EnvObj)+ deriving (Show, Eq, Read, Generic, Typeable, Data)++instance Hashable ExprEnv++{-# INLINE unwrapExprEnv #-}+unwrapExprEnv :: ExprEnv -> M.HashMap Name EnvObj unwrapExprEnv = coerce +toHashMap :: ExprEnv -> M.HashMap Name Expr+toHashMap eenv =+ M.map(\e -> case e of+ ExprObj e' -> e'+ RedirObj n' -> eenv ! n'+ SymbObj i -> Var i) . unwrapExprEnv $ eenv+ -- | Constructs an empty `ExprEnv` empty :: ExprEnv empty = ExprEnv M.empty@@ -95,7 +136,7 @@ fromList :: [(Name, Expr)] -> ExprEnv fromList = ExprEnv . M.fromList . Pre.map (\(n, e) -> (n, ExprObj e)) --- Is the `ExprEnv` empty?+-- | Is the `ExprEnv` empty? null :: ExprEnv -> Bool null = M.null . unwrapExprEnv @@ -125,6 +166,9 @@ Just (SymbObj i) -> Just $ Sym i Nothing -> Nothing +lookupEnvObj :: Name -> ExprEnv -> Maybe EnvObj+lookupEnvObj n = M.lookup n . unwrapExprEnv+ -- | Lookup the `Expr` with the given `Name`. -- If the name is bound to a @Var@, recursively searches that @Vars@ name. -- Returns `Nothing` if the `Name` is not in the `ExprEnv`.@@ -153,6 +197,9 @@ lookupNameMod ns ms = listToMaybe . L.filter (\(Name n m _ _, _) -> ns == n && ms == m) . toExprList +nameModMap :: ExprEnv -> M.HashMap (T.Text, Maybe T.Text) (Name, Expr)+nameModMap = M.fromList . L.map (\(n@(Name n' m _ _), e) -> ((n', m), (n, e))) . toExprList+ -- | Looks up a `Name` in the `ExprEnv`. Crashes if the `Name` is not found. (!) :: ExprEnv -> Name -> Expr (!) env@(ExprEnv env') n =@@ -167,8 +214,8 @@ insert :: Name -> Expr -> ExprEnv -> ExprEnv insert n e = ExprEnv . M.insert n (ExprObj e) . unwrapExprEnv -insertSymbolic :: Name -> Id -> ExprEnv -> ExprEnv-insertSymbolic n i = ExprEnv. M.insert n (SymbObj i) . unwrapExprEnv+insertSymbolic :: Id -> ExprEnv -> ExprEnv+insertSymbolic i = ExprEnv. M.insert (idName i) (SymbObj i) . unwrapExprEnv insertExprs :: [(Name, Expr)] -> ExprEnv -> ExprEnv insertExprs kvs scope = foldr (uncurry insert) scope kvs@@ -177,19 +224,54 @@ redirect :: Name -> Name -> ExprEnv -> ExprEnv redirect n n' = ExprEnv . M.insert n (RedirObj n') . unwrapExprEnv +difference :: ExprEnv -> ExprEnv -> ExprEnv+difference (ExprEnv m1) (ExprEnv m2) =+ ExprEnv $ M.difference m1 m2++-- | Get the union of two `ExprEnv`. If names overlap, keep the mapping in the left `ExprEnv`. union :: ExprEnv -> ExprEnv -> ExprEnv union (ExprEnv eenv) (ExprEnv eenv') = ExprEnv $ eenv `M.union` eenv' +union' :: M.HashMap Name Expr -> ExprEnv -> ExprEnv+union' m (ExprEnv eenv) = ExprEnv (M.map ExprObj m `M.union` eenv)++-- | Get the union of two `ExprEnv`. If names overlap, use the passed function to get an `EnvObj`.+unionWith :: (EnvObj -> EnvObj -> EnvObj) -> ExprEnv -> ExprEnv -> ExprEnv+unionWith f (ExprEnv m1) (ExprEnv m2) =+ ExprEnv $ M.unionWith f m1 m2++unionWithM :: Monad m => (EnvObj -> EnvObj -> m EnvObj) -> ExprEnv -> ExprEnv -> m ExprEnv+unionWithM f (ExprEnv m1) (ExprEnv m2) =+ return . ExprEnv =<< (Trav.sequence $ M.unionWith (\x y -> do+ x' <- x+ y' <- y+ f x' y') + (M.map return m1)+ (M.map return m2))++unionWithNameM :: Monad m => (Name -> EnvObj -> EnvObj -> m EnvObj) -> ExprEnv -> ExprEnv -> m ExprEnv+unionWithNameM f (ExprEnv m1) (ExprEnv m2) =+ return . ExprEnv =<< (Trav.sequence $ M.unionWithKey (\n x y -> do+ x' <- x+ y' <- y+ f n x' y') + (M.map return m1)+ (M.map return m2))+ -- | Map a function over all `Expr` in the `ExprEnv`. -- Will not replace symbolic variables with non-symbolic values,--- but will rename symbolic values.+-- but will rename symbolic values if the passed function+-- returns a `Var`. map :: (Expr -> Expr) -> ExprEnv -> ExprEnv map f = mapWithKey (\_ -> f) --- | Maps a function with an arbitrary return type over all `Expr` in the `ExprEnv`, to get a `Data.Map`.-map' :: (Expr -> a) -> ExprEnv -> M.Map Name a+-- | Maps a function with an arbitrary return type over all `Expr` in the `ExprEnv`, to get a `Data.HashMap`.+map' :: (Expr -> a) -> ExprEnv -> M.HashMap Name a map' f = mapWithKey' (\_ -> f) +mapConc :: (Expr -> Expr) -> ExprEnv -> ExprEnv+mapConc f = mapConcWithKey (\_ -> f)+ -- | Map a function over all `Expr` in the `ExprEnv`, with access to the `Name`. -- Will not replace symbolic variables with non-symbolic values, -- but will rename symbolic values.@@ -204,12 +286,31 @@ _ -> s f' _ n = n -mapWithKey' :: (Name -> Expr -> a) -> ExprEnv -> M.Map Name a+mapWithKey' :: (Name -> Expr -> a) -> ExprEnv -> M.HashMap Name a mapWithKey' f = M.mapWithKey f . toExprMap -mapKeys :: (Name -> Name) -> ExprEnv -> ExprEnv-mapKeys f = coerce . M.mapKeys f . unwrapExprEnv+mapConcWithKey :: (Name -> Expr -> Expr) -> ExprEnv -> ExprEnv+mapConcWithKey f (ExprEnv env) = ExprEnv $ M.mapWithKey f' env+ where+ f' :: Name -> EnvObj -> EnvObj+ f' n (ExprObj e) = ExprObj $ f n e+ f' _ s@(SymbObj _) = s+ f' _ n = n +mapConcOrSym :: (ConcOrSym -> ConcOrSym) -> ExprEnv -> ExprEnv+mapConcOrSym f = mapConcOrSymWithKey (\_ -> f)++mapConcOrSymWithKey :: (Name -> ConcOrSym -> ConcOrSym) -> ExprEnv -> ExprEnv+mapConcOrSymWithKey f (ExprEnv env) = ExprEnv $ M.mapWithKey f' env+ where+ g :: ConcOrSym -> EnvObj+ g (Conc e) = ExprObj e+ g (Sym i) = SymbObj i+ f' :: Name -> EnvObj -> EnvObj+ f' n (ExprObj e) = g $ f n $ Conc e+ f' n (SymbObj i) = g $ f n $ Sym i+ f' _ e = e+ mapM :: Monad m => (Expr -> m Expr) -> ExprEnv -> m ExprEnv mapM f eenv = return . ExprEnv =<< Pre.mapM f' (unwrapExprEnv eenv) where@@ -246,7 +347,9 @@ -- | Returns a new `ExprEnv`, which contains only the symbolic values. filterToSymbolic :: ExprEnv -> ExprEnv-filterToSymbolic eenv = filterWithKey (\n _ -> isSymbolic n eenv) eenv+filterToSymbolic = ExprEnv . M.filter (\e -> case e of+ SymbObj _ -> True+ _ -> False) . unwrapExprEnv -- | Returns the names of all expressions with the given type in the expression environment funcsOfType :: Type -> ExprEnv -> [Name]@@ -255,8 +358,10 @@ keys :: ExprEnv -> [Name] keys = M.keys . unwrapExprEnv -symbolicKeys :: ExprEnv -> [Name]-symbolicKeys eenv = M.keys . unwrapExprEnv . filterWithKey (\n _ -> isSymbolic n eenv) $ eenv+symbolicIds :: ExprEnv -> [Id]+symbolicIds = mapMaybe (\e -> case e of+ SymbObj i -> Just i+ _ -> Nothing) . M.elems . unwrapExprEnv -- | Returns all `Expr`@s@ in the `ExprEnv` elems :: ExprEnv -> [Expr]@@ -266,6 +371,13 @@ higherOrderExprs :: ExprEnv -> [Type] higherOrderExprs = concatMap (higherOrderFuncs) . elems +-- | Converts all RedirObjs in ExprObjs. Useful for certain kinds of analysis+redirsToExprs :: ExprEnv -> ExprEnv+redirsToExprs eenv = coerce . M.map rToE . coerce $ eenv+ where+ rToE (RedirObj n) = ExprObj . Var . Id n . typeOf $ eenv ! n+ rToE e = e+ toList :: ExprEnv -> [(Name, EnvObj)] toList = M.toList . unwrapExprEnv @@ -279,7 +391,10 @@ fromExprList :: [(Name, Expr)] -> ExprEnv fromExprList = ExprEnv . M.fromList . L.map (\(n, e) -> (n, ExprObj e)) -toExprMap :: ExprEnv -> M.Map Name Expr+fromExprMap :: M.HashMap Name Expr -> ExprEnv+fromExprMap = ExprEnv . M.map ExprObj++toExprMap :: ExprEnv -> M.HashMap Name Expr toExprMap env = M.mapWithKey (\k _ -> env ! k) $ unwrapExprEnv env getIdFromName :: ExprEnv -> Name -> Maybe Id@@ -322,23 +437,25 @@ modifyContainedASTs _ r = r instance Named ExprEnv where- names (ExprEnv eenv) = names (M.keys eenv) ++ names eenv+ names (ExprEnv eenv) = names (M.keys eenv) <> names eenv rename old new = ExprEnv - . M.mapKeys (\k -> if k == old then new else k)+ . M.fromList . rename old new+ . M.toList . unwrapExprEnv renames hm = ExprEnv- . M.mapKeys (renames hm)+ . M.fromList . renames hm+ . M.toList . unwrapExprEnv instance Named EnvObj where names (ExprObj e) = names e- names (RedirObj r) = [r]+ names (RedirObj r) = S.singleton r names (SymbObj s) = names s rename old new (ExprObj e) = ExprObj $ rename old new e
src/G2/Language/Ids.hs view
@@ -3,10 +3,13 @@ module G2.Language.Ids where +import qualified G2.Data.UnionFind as UF+import qualified G2.Data.UFMap as UFM import G2.Language.Syntax import G2.Language.AST import qualified Data.Map as M+import Data.Hashable import qualified Data.HashSet as HS class Ided a where@@ -29,7 +32,7 @@ go (Data d) = ids d go (Lam _ i _) = ids i go (Let b _) = concatMap (ids . fst) b- go (Case _ i a) = ids i ++ concatMap (ids . altMatch) a+ go (Case _ i t a) = ids i ++ ids t ++ concatMap (ids . altMatch) a go (Type t) = ids t go _ = [] @@ -49,11 +52,6 @@ ids (DataAlt dc i) = ids dc ++ i ids _ = [] -instance Ided TyBinder where- {-# INLINE ids #-}- ids (AnonTyBndr t) = ids t- ids (NamedTyBndr i) = ids i- instance Ided Coercion where {-# INLINE ids #-} ids (t1 :~ t2) = ids t1 ++ ids t2@@ -79,3 +77,9 @@ instance (Ided a, Ided b, Ided c) => Ided (a, b, c) where ids (a, b, c) = ids a ++ ids b ++ ids c++instance (Eq k, Hashable k, Ided k) => Ided (UF.UnionFind k) where+ ids = ids . UF.toList++instance (Eq k, Hashable k, Ided k, Ided v) => Ided (UFM.UFMap k v) where+ ids = ids . UFM.toList
src/G2/Language/KnownValues.hs view
@@ -1,14 +1,17 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} --- We define a datatype to hol the names of other data types we know should--- exist, and that we care about for some special reason--- (for example: the Bool type)--- Try to avoid imports from G2 other than G2.Internal.Language.Syntax here!+ module G2.Language.KnownValues where +-- Try to avoid imports from G2 other than G2..Language.Syntax here! import G2.Language.Syntax import Data.Data (Data, Typeable)+import Data.Hashable+import GHC.Generics (Generic) +-- | A `KnownValues` tracks the names of data types we know should+-- exist, and that we care about for some special reason. data KnownValues = KnownValues { tyInt :: Name , dcInt :: Name@@ -29,15 +32,33 @@ , dcTrue :: Name , dcFalse :: Name + , tyRational :: Name+ , tyList :: Name , dcCons :: Name , dcEmpty :: Name + , tyMaybe :: Name+ , dcJust :: Name+ , dcNothing :: Name++ , tyUnit :: Name+ , dcUnit :: Name++ -- Typeclasses , eqTC :: Name , numTC :: Name , ordTC :: Name , integralTC :: Name+ , realTC :: Name+ , fractionalTC :: Name + -- Typeclass superclass extractors+ , integralExtactReal :: Name+ , realExtractNum :: Name+ , realExtractOrd :: Name+ , ordExtractEq :: Name+ , eqFunc :: Name , neqFunc :: Name @@ -51,16 +72,32 @@ , fromIntegerFunc :: Name , toIntegerFunc :: Name + , toRatioFunc :: Name+ , fromRationalFunc :: Name+ , geFunc :: Name , gtFunc :: Name , ltFunc :: Name , leFunc :: Name - , structEqTC :: Name- , structEqFunc :: Name+ , impliesFunc :: Name+ , iffFunc :: Name , andFunc :: Name , orFunc :: Name+ , notFunc :: Name + , errorFunc :: Name+ , errorWithoutStackTraceFunc :: Name+ , errorEmptyListFunc :: Name , patErrorFunc :: Name- } deriving (Show, Eq, Read, Typeable, Data)+ } deriving (Show, Eq, Read, Typeable, Data, Generic)++instance Hashable KnownValues++-- | Checks if the `Name` corresponds to a function that is an error.+isErrorFunc :: KnownValues -> Name -> Bool+isErrorFunc kv n = n == errorFunc kv+ || n == errorEmptyListFunc kv + || n == errorWithoutStackTraceFunc kv+ || n == patErrorFunc kv
src/G2/Language/Located.hs view
@@ -18,6 +18,7 @@ import Data.Hashable import qualified Data.Map as M import Data.Maybe+import Data.Foldable class Located l where loc :: l -> Maybe Loc@@ -102,7 +103,7 @@ -- | Constructs a map of Spans to Names, based on all Names in the ExprEnv spanLookup :: ExprEnv -> M.Map Span Name spanLookup =- M.fromList . mapMaybe (\n -> maybe Nothing (\s -> Just (s, n)) (spanning n)) . names+ M.fromList . mapMaybe (\n -> maybe Nothing (\s -> Just (s, n)) (spanning n)) . toList . names -- | Constructs a map of Locs to Names, based on all Names in the ExprEnv locLookup :: ExprEnv -> M.Map Loc Name
src/G2/Language/Monad/AST.hs view
@@ -44,9 +44,9 @@ modifyChildrenM f (Let bind e) = do bind' <- modifyContainedASTsM f bind return . Let bind' =<< f e- modifyChildrenM f (Case m b as) = do+ modifyChildrenM f (Case m b t as) = do m' <- f m- return . Case m' b =<< modifyContainedASTsM f as+ return . Case m' b t =<< modifyContainedASTsM f as modifyChildrenM f (Cast e c) = do e' <- f e return $ Cast e' c@@ -97,11 +97,12 @@ bnd' <- modifyContainedASTsM f bnd e' <- modifyContainedASTsM f e return $ Let bnd' e'- modifyContainedASTsM f (Case m i as) = do+ modifyContainedASTsM f (Case m i t as) = do m' <- modifyContainedASTsM f m i' <- modifyContainedASTsM f i+ t' <- f t as' <- modifyContainedASTsM f as- return $ Case m' i' as'+ return $ Case m' i' t' as' modifyContainedASTsM f (Type t) = return . Type =<< f t modifyContainedASTsM f (Cast e c) = do e' <- modifyContainedASTsM f e@@ -134,17 +135,27 @@ y' <- modifyContainedASTsM f y return (x', y') +instance (ASTContainerM c t, ASTContainerM d t, ASTContainerM e t) => ASTContainerM (c, d, e) t where+ modifyContainedASTsM f (x, y, z) = do+ x' <- modifyContainedASTsM f x+ y' <- modifyContainedASTsM f y+ z' <- modifyContainedASTsM f z+ return (x', y', z')++instance ASTContainerM LamUse Expr where+ {-# INLINE modifyContainedASTsM #-}+ modifyContainedASTsM _ i = return i++instance ASTContainerM LamUse Type where+ {-# INLINE modifyContainedASTsM #-}+ modifyContainedASTsM _ i = return i+ instance ASTContainerM Id Expr where {-# INLINE modifyContainedASTsM #-} modifyContainedASTsM _ i = return i instance ASTContainerM Id Type where modifyContainedASTsM f (Id n t) = return . Id n =<< f t--instance ASTContainerM TyBinder Type where- modifyContainedASTsM f (AnonTyBndr t) = return . AnonTyBndr =<< f t- modifyContainedASTsM f (NamedTyBndr i) =- return . NamedTyBndr =<< modifyContainedASTsM f i instance ASTContainerM DataCon Expr where {-# INLINE modifyContainedASTsM #-}
src/G2/Language/Monad/Expr.hs view
@@ -2,19 +2,21 @@ {-# LANGUAGE TupleSections #-} module G2.Language.Monad.Expr ( mkDCTrueM- , mkDCFalseM- , mkDCIntE- , mkDCIntegerE- , mkDCFloatE- , mkDCDoubleE- , mkTrueE- , mkFalseE- , mkConsE- , mkEmptyE- , modifyAppTopE- , modifyLamTopE- , insertInLamsE- , etaExpandToE ) where+ , mkDCFalseM+ , mkDCIntE+ , mkDCIntegerE+ , mkDCFloatE+ , mkDCDoubleE+ , mkTrueE+ , mkFalseE+ , mkConsE+ , mkEmptyE+ , mkUnitE+ , modifyAppTopE+ , modifyLamTopE+ , modifyAppRHSE+ , insertInLamsE+ , etaExpandToE ) where import G2.Language.Expr import G2.Language.Syntax@@ -63,6 +65,9 @@ mkEmptyE :: ExState s m => m Expr mkEmptyE = appKVTEnv mkEmpty++mkUnitE :: ExState s m => m Expr+mkUnitE = appKVTEnv mkUnit modifyAppTopE :: (Monad m, ASTContainerM c Expr) => (Expr -> m Expr) -> c -> m c modifyAppTopE f = modifyContainedASTsM (modifyAppTopE' f)
src/G2/Language/Monad/ExprEnv.hs view
@@ -1,9 +1,10 @@ module G2.Language.Monad.ExprEnv ( memberE- , lookupE- , insertE- , mapE- , mapME- , mapWithKeyME ) where+ , lookupE+ , insertE+ , insertSymbolicE+ , mapE+ , mapME+ , mapWithKeyME ) where import G2.Language @@ -15,34 +16,40 @@ , map , null) -liftEE :: ExState s m => (ExprEnv -> a) -> m a+liftEE :: ExprEnvM s m => (ExprEnv -> a) -> m a liftEE f = return . f =<< exprEnv -memberE :: ExState s m => Name -> m Bool+memberE :: ExprEnvM s m => Name -> m Bool memberE n = liftEE (E.member n) -lookupE :: ExState s m => Name -> m (Maybe Expr)+lookupE :: ExprEnvM s m => Name -> m (Maybe Expr) lookupE n = liftEE (E.lookup n) -insertE :: ExState s m => Name -> Expr -> m ()+insertE :: ExprEnvM s m => Name -> Expr -> m () insertE n e = do eenv <- exprEnv let eenv' = E.insert n e eenv putExprEnv eenv' -mapE :: ExState s m => (Expr -> Expr) -> m ()+insertSymbolicE :: ExprEnvM s m => Id -> m ()+insertSymbolicE i = do+ eenv <- exprEnv+ let eenv' = E.insertSymbolic i eenv+ putExprEnv eenv'++mapE :: ExprEnvM s m => (Expr -> Expr) -> m () mapE f = do eenv <- exprEnv let eenv' = E.map f eenv putExprEnv eenv' -mapME :: ExState s m => (Expr -> m Expr) -> m ()+mapME :: ExprEnvM s m => (Expr -> m Expr) -> m () mapME f = do eenv <- exprEnv eenv' <- E.mapM f eenv putExprEnv eenv' -mapWithKeyME :: ExState s m => (Name -> Expr -> m Expr) -> m ()+mapWithKeyME :: ExprEnvM s m => (Name -> Expr -> m Expr) -> m () mapWithKeyME f = do eenv <- exprEnv eenv' <- E.mapWithKeyM f eenv
src/G2/Language/Monad/Naming.hs view
@@ -17,38 +17,38 @@ import qualified Data.Text as T -doRenameN :: (ExState s m, Named a) => Name -> a -> m a+doRenameN :: (NamingM s m, Named a) => Name -> a -> m a doRenameN n a = withNG $ \ng -> doRename n ng a -doRenamesN :: (ExState s m, Named a) => [Name] -> a -> m a+doRenamesN :: (NamingM s m, Named a) => [Name] -> a -> m a doRenamesN ns a = withNG $ \ng -> doRenames ns ng a -renameAllN :: (ExState s m, Named a) => a -> m a+renameAllN :: (NamingM s m, Named a) => a -> m a renameAllN a = withNG (renameAll a) -freshSeededStringN :: ExState s m => T.Text -> m Name+freshSeededStringN :: NamingM s m => T.Text -> m Name freshSeededStringN t = withNG (freshSeededString t) -freshSeededStringsN :: ExState s m => [T.Text] -> m [Name]+freshSeededStringsN :: NamingM s m => [T.Text] -> m [Name] freshSeededStringsN t = withNG (freshSeededStrings t) -freshSeededNameN :: ExState s m => Name -> m Name+freshSeededNameN :: NamingM s m => Name -> m Name freshSeededNameN n = withNG (freshSeededName n) -freshSeededNamesN :: ExState s m => [Name] -> m [Name]+freshSeededNamesN :: NamingM s m => [Name] -> m [Name] freshSeededNamesN ns = withNG (freshSeededNames ns) -freshNameN :: ExState s m => m Name+freshNameN :: NamingM s m => m Name freshNameN = withNG (freshName) -freshNamesN :: ExState s m => Int -> m [Name]+freshNamesN :: NamingM s m => Int -> m [Name] freshNamesN i = withNG (freshNames i) -freshIdN :: ExState s m => Type -> m Id+freshIdN :: NamingM s m => Type -> m Id freshIdN t = withNG (freshId t) -freshSeededIdN :: (Named n, ExState s m) => n -> Type -> m Id+freshSeededIdN :: (Named n, NamingM s m) => n -> Type -> m Id freshSeededIdN n t = withNG (freshSeededId n t) -freshIdsN :: ExState s m => [Type] -> m [Id]+freshIdsN :: NamingM s m => [Type] -> m [Id] freshIdsN ts = withNG (freshIds ts)
src/G2/Language/Monad/Primitives.hs view
@@ -22,71 +22,78 @@ , mkEqPrimDoubleE , mkEqPrimCharE ) where +import G2.Language.KnownValues import G2.Language.Primitives import G2.Language.Syntax-import G2.Language.Support+import G2.Language.Typing +import G2.Language.Monad.ExprEnv import G2.Language.Monad.Support -appExpr :: ExState s m => (ExprEnv -> Expr) -> m Expr-appExpr f = return . f =<< exprEnv- mkGeE :: ExState s m => m Expr-mkGeE = appExpr mkGe+mkGeE = appKVEEnv geFunc mkGtE :: ExState s m => m Expr-mkGtE = appExpr mkGt+mkGtE = appKVEEnv gtFunc mkEqE :: ExState s m => m Expr-mkEqE = appExpr mkEq+mkEqE = appKVEEnv eqFunc mkNeqE :: ExState s m => m Expr-mkNeqE = appExpr mkNeq+mkNeqE = appKVEEnv neqFunc mkLtE :: ExState s m => m Expr-mkLtE = appExpr mkLt+mkLtE = appKVEEnv ltFunc mkLeE :: ExState s m => m Expr-mkLeE = appExpr mkLe+mkLeE = appKVEEnv leFunc mkAndE :: ExState s m => m Expr-mkAndE = appExpr mkAnd+mkAndE = appKVEEnv andFunc mkOrE :: ExState s m => m Expr-mkOrE = appExpr mkOr+mkOrE = appKVEEnv orFunc mkNotE :: ExState s m => m Expr-mkNotE = appExpr mkNot+mkNotE = appKVEEnv notFunc mkPlusE :: ExState s m => m Expr-mkPlusE = appExpr mkPlus+mkPlusE = appKVEEnv plusFunc mkMinusE :: ExState s m => m Expr-mkMinusE = appExpr mkMinus+mkMinusE = appKVEEnv minusFunc mkMultE :: ExState s m => m Expr-mkMultE = appExpr mkMult+mkMultE = appKVEEnv timesFunc mkDivE :: ExState s m => m Expr-mkDivE = appExpr mkDiv+mkDivE = appKVEEnv divFunc mkModE :: ExState s m => m Expr-mkModE = appExpr mkMod+mkModE = appKVEEnv modFunc mkNegateE :: ExState s m => m Expr-mkNegateE = appExpr mkNegate+mkNegateE = appKVEEnv negateFunc mkImpliesE :: ExState s m => m Expr-mkImpliesE = appExpr mkImplies+mkImpliesE = appKVEEnv impliesFunc mkIffE :: ExState s m => m Expr-mkIffE = appExpr mkIff+mkIffE = appKVEEnv iffFunc mkFromIntegerE :: ExState s m => m Expr-mkFromIntegerE = appExpr mkFromInteger+mkFromIntegerE = appKVEEnv fromIntegerFunc mkToIntegerE :: ExState s m => m Expr-mkToIntegerE = appExpr mkToInteger+mkToIntegerE = appKVEEnv toIntegerFunc++appKVEEnv :: ExState s m => (KnownValues -> Name) -> m Expr+appKVEEnv f = do+ n <- return . f =<< knownValues+ e <- lookupE n+ case e of+ Just e' -> return . Var $ Id n (typeOf e')+ Nothing -> error "appKVEEnv: not found" appKV :: ExState s m => (KnownValues -> Expr) -> m Expr appKV f = return . f =<< knownValues
src/G2/Language/Monad/Support.hs view
@@ -2,43 +2,84 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} -module G2.Language.Monad.Support ( StateM+module G2.Language.Monad.Support ( StateT+ , StateM+ , StateNGT+ , StateNG+ , NameGenT+ , NameGenM+ , NamingM (..)+ , ExprEnvM (..) , ExState (..) , FullState (..) , runStateM+ , execStateM+ , runNamingM+ , runNamingT+ , runExprEnvM+ , runStateMInNamingM+ , runStateNG+ , execStateNG , readRecord , withNG- , mapCurrExpr ) where+ , mapCurrExpr+ , insertPC+ , insertPCStateNG+ , mapMAccumB ) where +import Control.Monad.Identity import qualified Control.Monad.State.Lazy as SM import G2.Language.Naming+import qualified G2.Language.PathConds as PC import G2.Language.Syntax import G2.Language.Support import G2.Language.TypeClasses -- | A wrapper for `State`, allowing it to be used as a monadic context.-newtype StateM t a = StateM (SM.State (State t, Bindings) a) deriving (Applicative, Functor, Monad)+type StateT t m a = SM.StateT (State t, Bindings) m a+type StateM t a = StateT t Identity a -instance SM.MonadState (State t, Bindings) (StateM t) where- state f = StateM (SM.state f)+type StateNGT t m a = SM.StateT (State t, NameGen) m a+type StateNG t a = StateNGT t Identity a +-- | A wrapper for `NameGen`, allowing it to be used as a monadic context.+type NameGenT m a = SM.StateT NameGen m a+type NameGenM a = NameGenT Identity a++-- | A wrapper for `ExprEnv`, allowing it to be used as a monadic context.+type EET m a = SM.StateT ExprEnv m a+type EEM a = EET Identity a++-- instance SM.MonadState (State t, Bindings) (SM.State (State t, Bindings)) where+-- state f = StateM (SM.state f)++-- instance SM.MonadState (State t, NameGen) (SM.State (State t, NameGen)) where+-- state f = StateNG (SM.state f)++-- instance SM.MonadState NameGen (SM.State NameGen) where+-- state f = NameGenM (SM.state f)+ -- We split the State Monad into two pieces, so we can use it in the--- initialization stage of G2. In this stage, we do not have an entire State.--- See G2.Initialization.Types+-- initialization stage of G2 (in this stage, we do not have an entire State.+-- See G2.Initialization.Types), or so that we can just use it with smaller+-- pieces of a state. --- | Allows access to certain basic components of a state.-class SM.MonadState s m => ExState s m | m -> s where+class Monad m => NamingM s m | m -> s where+ nameGen :: m NameGen+ putNameGen :: NameGen -> m ()++class Monad m => ExprEnvM s m | m -> s where exprEnv :: m ExprEnv putExprEnv :: ExprEnv -> m () +-- | Allows access to certain basic components of a state.+class (ExprEnvM s m, NamingM s m) => ExState s m | m -> s where typeEnv :: m TypeEnv putTypeEnv :: TypeEnv -> m () - nameGen :: m NameGen- putNameGen :: NameGen -> m ()- knownValues :: m KnownValues putKnownValues :: KnownValues -> m () @@ -51,35 +92,91 @@ currExpr :: m CurrExpr putCurrExpr :: CurrExpr -> m () + pathConds :: m PathConds+ putPathConds :: PathConds -> m ()+ inputNames :: m [Name] fixedInputs :: m [Expr] -instance ExState (State t, Bindings) (StateM t) where+instance Monad m => NamingM NameGen (SM.StateT NameGen m) where+ nameGen = SM.get+ putNameGen = SM.put++instance Monad m => NamingM (State t, Bindings) (SM.StateT (State t, Bindings) m) where+ nameGen = readRecord (\(_, b) -> name_gen b)+ putNameGen = rep_name_genM++instance Monad m => NamingM (State t, NameGen) (SM.StateT (State t, NameGen) m) where+ nameGen = readRecord (\(_, ng) -> ng)+ putNameGen = rep_name_genNG++instance ExprEnvM (State t, Bindings) (SM.State (State t, Bindings)) where exprEnv = readRecord (\(s, _) -> expr_env s) putExprEnv = rep_expr_envM +instance ExprEnvM (State t, NameGen) (SM.State (State t, NameGen)) where+ exprEnv = readRecord (\(s, _) -> expr_env s)+ putExprEnv = rep_expr_envNG++instance ExState (State t, Bindings) (SM.State (State t, Bindings)) where typeEnv = readRecord (\(s, _) -> type_env s) putTypeEnv = rep_type_envM - nameGen = readRecord (\(_, b) -> name_gen b)- putNameGen = rep_name_genM- knownValues = readRecord (\(s, _) -> known_values s) putKnownValues = rep_known_valuesM typeClasses = readRecord (\(s, _) -> type_classes s) putTypeClasses = rep_type_classesM -instance FullState (State t, Bindings) (StateM t) where+instance ExState (State t, NameGen) (SM.State (State t, NameGen)) where+ typeEnv = readRecord (\(s, _) -> type_env s)+ putTypeEnv = rep_type_envNG++ knownValues = readRecord (\(s, _) -> known_values s)+ putKnownValues = rep_known_valuesNG++ typeClasses = readRecord (\(s, _) -> type_classes s)+ putTypeClasses = rep_type_classesNG++instance FullState (State t, Bindings) (SM.State (State t, Bindings)) where currExpr = readRecord (\(s, _) -> curr_expr s) putCurrExpr = rep_curr_exprM + pathConds = readRecord (\(s, _) -> path_conds s)+ putPathConds = rep_path_condsM+ inputNames = readRecord (\(_, b) -> input_names b) fixedInputs = readRecord (\(_,b) -> fixed_inputs b) + runStateM :: StateM t a -> State t -> Bindings -> (a, (State t, Bindings))-runStateM (StateM s) s' b = SM.runState s (s', b)+runStateM s s' b = SM.runState s (s', b) +execStateM :: StateM t a -> State t -> Bindings -> (State t, Bindings)+execStateM s = (\lh_s b -> snd (runStateM s lh_s b))++runStateNG :: StateNG t a -> State t -> NameGen -> (a, (State t, NameGen))+runStateNG s s' ng = SM.runState s (s', ng)++execStateNG :: StateNG t a -> State t -> NameGen -> (State t, NameGen)+execStateNG s = (\lh_s ng -> snd (runStateNG s lh_s ng))++runNamingT :: NameGenT m a -> NameGen -> m (a, NameGen)+runNamingT s = SM.runStateT s++runNamingM :: NameGenM a -> NameGen -> (a, NameGen)+runNamingM s = SM.runState s++runExprEnvM :: EEM a -> ExprEnv -> (a, ExprEnv)+runExprEnvM s = SM.runState s++runStateMInNamingM :: (Monad m, NamingM s m) => StateNG t a -> State t -> m (a, State t)+runStateMInNamingM m s = do+ ng <- nameGen+ let (a, (s', ng')) = runStateNG m s ng+ putNameGen ng'+ return (a, s')+ readRecord :: SM.MonadState s m => (s -> r) -> m r readRecord f = return . f =<< SM.get @@ -88,33 +185,59 @@ (s,b) <- SM.get SM.put $ (s {expr_env = eenv}, b) +rep_expr_envNG :: ExprEnv -> StateNG t ()+rep_expr_envNG eenv = do+ (s,b) <- SM.get+ SM.put $ (s {expr_env = eenv}, b)+ rep_type_envM :: TypeEnv -> StateM t () rep_type_envM tenv = do (s,b) <- SM.get SM.put $ (s {type_env = tenv}, b) -withNG :: ExState s m => (NameGen -> (a, NameGen)) -> m a+rep_type_envNG :: TypeEnv -> StateNG t ()+rep_type_envNG tenv = do+ (s,b) <- SM.get+ SM.put $ (s {type_env = tenv}, b)++withNG :: NamingM s m => (NameGen -> (a, NameGen)) -> m a withNG f = do ng <- nameGen let (a, ng') = f ng putNameGen ng' return a -rep_name_genM :: NameGen -> StateM t ()+rep_name_genM :: Monad m => NameGen -> StateT t m () rep_name_genM ng = do (s,b) <- SM.get SM.put $ (s, b {name_gen = ng}) +rep_name_genNG :: Monad m => NameGen -> StateNGT t m ()+rep_name_genNG ng = do+ (s, _) <- SM.get+ SM.put $ (s, ng)+ rep_known_valuesM :: KnownValues -> StateM t () rep_known_valuesM kv = do (s, b) <- SM.get SM.put $ (s {known_values = kv}, b) +rep_known_valuesNG :: KnownValues -> StateNG t ()+rep_known_valuesNG kv = do+ (s, b) <- SM.get+ SM.put $ (s {known_values = kv}, b)++ rep_type_classesM :: TypeClasses -> StateM t () rep_type_classesM tc = do (s, b) <- SM.get SM.put $ (s {type_classes = tc}, b) +rep_type_classesNG :: TypeClasses -> StateNG t ()+rep_type_classesNG tc = do+ (s, b) <- SM.get+ SM.put $ (s {type_classes = tc}, b)+ rep_curr_exprM :: CurrExpr -> StateM t () rep_curr_exprM ce = do (s, b) <- SM.get@@ -125,3 +248,26 @@ (CurrExpr er e) <- currExpr e' <- f e putCurrExpr (CurrExpr er e') ++rep_path_condsM :: PathConds -> StateM t ()+rep_path_condsM pc = do+ (s, b) <- SM.get+ SM.put $ (s {path_conds = pc}, b)++insertPC :: FullState s m => PathCond -> m ()+insertPC pc = do+ pcs <- pathConds+ putPathConds $ PC.insert pc pcs ++insertPCStateNG :: PathCond -> StateNG t ()+insertPCStateNG pc = do+ (s@(State { path_conds = pcs }), ng) <- SM.get+ SM.put (s { path_conds = PC.insert pc pcs}, ng)++mapMAccumB :: Monad m => (a -> b -> m (a, c)) -> a -> [b] -> m (a, [c])+mapMAccumB _ a [] = do+ return (a, [])+mapMAccumB f a (x:xs) = do+ (a', res) <- f a x+ (a'', res2) <- mapMAccumB f a' xs+ return $ (a'', res:res2)
src/G2/Language/Monad/TypeClasses.hs view
@@ -8,14 +8,14 @@ import G2.Language.TypeClasses import G2.Language.Monad.Support -import qualified Data.Map as M+import qualified Data.HashMap.Lazy as HM lookupTCDictTC :: FullState s m => Name -> Type -> m (Maybe Id) lookupTCDictTC n t = do tc <- typeClasses return $ lookupTCDict tc n t -typeClassInstTC :: FullState s m => M.Map Name Id -> Name -> Type -> m (Maybe Expr)+typeClassInstTC :: FullState s m => HM.HashMap Name Id -> Name -> Type -> m (Maybe Expr) typeClassInstTC m n t = do tc <- typeClasses return $ typeClassInst tc m n t
src/G2/Language/Monad/TypeEnv.hs view
@@ -1,11 +1,11 @@ module G2.Language.Monad.TypeEnv ( lookupT- , insertT ) where+ , insertT ) where import G2.Language import G2.Language.Monad.Support -import qualified Data.Map as M+import qualified Data.HashMap.Lazy as HM import Prelude hiding( filter , lookup@@ -16,10 +16,10 @@ liftTE f = return . f =<< typeEnv lookupT :: ExState s m => Name -> m (Maybe AlgDataTy)-lookupT n = liftTE (M.lookup n)+lookupT n = liftTE (HM.lookup n) insertT :: ExState s m => Name -> AlgDataTy -> m () insertT n t = do tenv <- typeEnv- let tenv' = M.insert n t tenv+ let tenv' = HM.insert n t tenv putTypeEnv tenv'
src/G2/Language/Monad/Typing.hs view
@@ -2,7 +2,9 @@ , tyIntegerT , tyDoubleT , tyFloatT- , tyBoolT ) where+ , tyBoolT+ , tyRationalT+ , tyUnitT ) where import G2.Language.Syntax import G2.Language.Support@@ -30,3 +32,9 @@ tyBoolT :: ExState s m => m Type tyBoolT = appKV tyBool++tyRationalT :: ExState s m => m Type+tyRationalT = appKV tyRational++tyUnitT :: ExState s m => m Type+tyUnitT = appKV tyUnit
src/G2/Language/Naming.hs view
@@ -6,14 +6,21 @@ module G2.Language.Naming ( nameOcc , nameModule+ , nameUnique+ , nameTuple , nameLoc , NameGen- , Named (names, rename, renames)+ , Named (..)+ , namesList , doRename , doRenames , renameAll , nameToStr+ , nameToBuilder , strToName+ , maybe_StrToName+ , builderToName+ , mkNameGen , varIds , varNames@@ -21,6 +28,7 @@ , typeNames , renameExprs+ , renamesExprs , renameExpr , renameVars @@ -37,71 +45,107 @@ , freshIds , freshVar - , childrenNames- , mapNG ) where +import qualified G2.Data.UFMap as UF import G2.Language.AST import G2.Language.KnownValues import G2.Language.Syntax import G2.Language.TypeEnv import Data.Data (Data, Typeable)+import Data.Foldable import Data.Hashable import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as HS import Data.List import Data.List.Utils import qualified Data.Map as M+import Data.Monoid ((<>))+import qualified Data.Sequence as S import qualified Data.Text as T import Data.Tuple+import qualified Text.Builder as TB +-- | Extract the "occurence" from a `Name`.+--+-- >>> nameOcc (Name "x" (Just "mod") 100 Nothing)+-- "x" nameOcc :: Name -> T.Text nameOcc (Name occ _ _ _) = occ +-- | Extract the module from a `Name`.+--+-- >>> nameModule (Name "x" (Just "mod") 100 Nothing)+-- Just "mod" nameModule :: Name -> Maybe T.Text nameModule (Name _ mb _ _) = mb +-- | Extract the "unique" from a `Name`.+--+-- >>> nameUnique (Name "x" (Just "mod") 100 Nothing)+-- 100+nameUnique :: Name -> Int+nameUnique (Name _ _ i _) = i++-- | Get a tuple with the "occurence" and module of a `Name`.+--+-- >>> nameTuple (Name "x" (Just "mod") 100 Nothing)+-- ("x", Just "mod")+nameTuple :: Name -> (T.Text, Maybe T.Text)+nameTuple n = (nameOcc n, nameModule n)++-- | Get the location of a `Name`. nameLoc :: Name -> Maybe Span nameLoc (Name _ _ _ s) = s -- | Allows the creation of fresh `Name`s.-data NameGen = NameGen { max_uniq :: (HM.HashMap (T.Text, Maybe T.Text) Int)- , dc_children :: (HM.HashMap Name [Name]) }+newtype NameGen = NameGen (HM.HashMap (T.Text, Maybe T.Text) Int) deriving (Show, Eq, Read, Typeable, Data) -- nameToStr relies on NameCleaner eliminating all '_', to preserve uniqueness--- | Converts a name to a string, which is useful to interact with solvers.+-- | Converts a `Name` to a string, which is useful to interact with solvers. nameToStr :: Name -> String nameToStr (Name n (Just m) i _) = T.unpack n ++ "_m_" ++ T.unpack m ++ "_" ++ show i nameToStr (Name n Nothing i _) = T.unpack n ++ "_n__" ++ show i --- | Converts a string generated by nameToStr to a name.+-- | Similar to `nameToStr`, but converts a `Name` to a `TB.Builder`.+nameToBuilder :: Name -> TB.Builder+nameToBuilder (Name n (Just m) i _) = mconcat [TB.text n, TB.text "_m_", TB.text m, TB.text "_", TB.string $ show i]+nameToBuilder (Name n Nothing i _) = mconcat [TB.text n, TB.text "_n__", TB.string $ show i]++-- | Converts a `String` generated by `nameToStr` to a `Name`. -- Loses location information strToName :: String -> Name strToName str =+ case maybe_StrToName str of+ Just n -> n+ Nothing -> error "strToName: Bad conversion"++maybe_StrToName :: String -> Maybe Name+maybe_StrToName str+ | (n, _:q:_:mi) <- breakList (\s -> isPrefixOf "_m_" s || isPrefixOf "_n_" s) str+ , (m, _:i) <- break ((==) '_') mi = let- (n, _:q:_:mi) = breakList (\s -> isPrefixOf "_m_" s || isPrefixOf "_n_" s) str- (m, _:i) = break ((==) '_') mi m' = if q == 'm' then Just m else Nothing in- Name (T.pack n) (fmap T.pack m') (read i :: Int) Nothing+ Just $ Name (T.pack n) (fmap T.pack m') (read i :: Int) Nothing+ | otherwise = Nothing +-- | Converts a `TB.Builder` generated by `nameToBuilder` to a `Name`.+-- Loses location information+builderToName :: TB.Builder -> Name+builderToName txt = strToName $ show txt+ -- | Initializes a `NameGen`. The returned `NameGen` is guarenteed to not give any `Name` -- in the given `Named` type. mkNameGen :: Named n => n -> NameGen mkNameGen nmd = let- allNames = names nmd+ allNames = toList $ names nmd in- NameGen {- max_uniq = HM.fromListWith max $ map (\(Name n m i _) -> ((n, m), i + 1)) allNames- -- (foldr (\(Name n m i _) hm -> HM.insertWith max (n, m) (i + 1) hm) - -- HM.empty allNames- -- )- , dc_children = HM.empty- }+ NameGen (HM.fromListWith max $ map (\(Name n m i _) -> ((n, m), i + 1)) allNames) -- | Returns all @Var@ Ids in an ASTContainer varIds :: (ASTContainer m Expr) => m -> [Id]@@ -123,7 +167,7 @@ exprTopNames (Data dc) = dataConName dc exprTopNames (Lam _ b _) = [idName b] exprTopNames (Let kvs _) = map (idName . fst) kvs-exprTopNames (Case _ cvar as) = idName cvar :+exprTopNames (Case _ cvar _ as) = idName cvar : concatMap (\(Alt am _) -> altMatchNames am) as exprTopNames (Assume (Just is) _ _) = [funcName is]@@ -143,7 +187,7 @@ typeTopNames :: Type -> [Name] typeTopNames (TyVar i) = [idName i] typeTopNames (TyCon n _) = [n]-typeTopNames (TyForAll (NamedTyBndr v) _) = [idName v]+typeTopNames (TyForAll v _) = [idName v] typeTopNames _ = [] doRename :: Named a => Name -> NameGen -> a -> (a, NameGen)@@ -161,13 +205,16 @@ renameAll :: (Named a) => a -> NameGen -> (a, NameGen) renameAll x ng = let- old = nub $ names x+ old = nub . toList $ names x in doRenames old ng x +namesList :: Named a => a -> [Name]+namesList = toList . names+ -- | Types that contain `Name`@s@ class Named a where- names :: a -> [Name]+ names :: a -> S.Seq Name rename :: Name -> Name -> a -> a renames :: HM.HashMap Name Name -> a -> a @@ -175,7 +222,7 @@ instance Named Name where {-# INLINE names #-}- names n = [n]+ names n = S.singleton n {-# INLINE rename #-} rename old (Name nn nm ni _) n@(Name _ _ _ l) = if old == n then Name nn nm ni l else n {-# INLINE renames #-}@@ -185,7 +232,7 @@ instance Named Id where {-# INLINE names #-}- names (Id n t) = n:names t+ names (Id n t) = n S.<| names t {-# INLINE rename #-} rename old new (Id n t) = Id (rename old new n) (rename old new t) {-# INLINE renames #-}@@ -194,21 +241,21 @@ instance Named Expr where names = eval go where- go :: Expr -> [Name]+ go :: Expr -> S.Seq Name go (Var i) = names i go (Prim _ t) = names t go (Data d) = names d go (Lam _ i _) = names i- go (Let b _) = concatMap (names . fst) b- go (Case _ i a) = names i ++ concatMap (names . altMatch) a+ go (Let b _) = foldr (<>) S.empty $ map (names . fst) b+ go (Case _ i t a) = names i <> names t <> (foldr (<>) S.empty $ map (names . altMatch) a) go (Type t) = names t go (Cast _ c) = names c go (Coercion c) = names c go (Tick t _) = names t- go (SymGen t) = names t+ go (SymGen _ t) = names t go (Assume is _ _) = names is go (Assert is _ _) = names is- go _ = []+ go _ = S.empty rename old new = modify go where@@ -219,13 +266,13 @@ go (Let b e) = let b' = map (\(n, e') -> (rename old new n, e')) b in Let b' e- go (Case e i a) =- Case e (rename old new i) (map goAlt a)+ go (Case e i t a) =+ Case e (rename old new i) (rename old new t) (map goAlt a) go (Type t) = Type (rename old new t) go (Cast e c) = Cast e (rename old new c) go (Coercion c) = Coercion (rename old new c) go (Tick t e) = Tick (rename old new t) e- go (SymGen t) = SymGen (rename old new t)+ go (SymGen sl t) = SymGen sl (rename old new t) go (Assume is e e') = Assume (rename old new is) e e' go (Assert is e e') = Assert (rename old new is) e e' go e = e@@ -242,12 +289,12 @@ go (Let b e) = let b' = map (\(n, e') -> (renames hm n, e')) b in Let b' e- go (Case e i a) = Case e (renames hm i) (map goAlt a)+ go (Case e i t a) = Case e (renames hm i) (renames hm t) (map goAlt a) go (Type t) = Type (renames hm t) go (Cast e c) = Cast e (renames hm c) go (Coercion c) = Coercion (renames hm c) go (Tick t e) = Tick (renames hm t) e- go (SymGen t) = SymGen (renames hm t)+ go (SymGen sl t) = SymGen sl (renames hm t) go (Assume is e e') = Assume (renames hm is) e e' go (Assert is e e') = Assert (renames hm is) e e' go e = e@@ -256,7 +303,7 @@ goAlt (Alt am e) = Alt (renames hm am) e renameExprs :: ASTContainer m Expr => [(Name, Name)] -> m -> m-renameExprs n a = foldr (\(old, new) -> renameExpr old new) a n+renameExprs n = renamesExprs (HM.fromList n) -- | Rename only the names in an `Expr` that are the `Name` of an `Id`/`Let`/`Data`/`Case` Binding. -- Does not change Types.@@ -268,7 +315,7 @@ renameExpr' old new (Data d) = Data (renameExprDataCon old new d) renameExpr' old new (Lam u i e) = Lam u (renameExprId old new i) e renameExpr' old new (Let b e) = Let (map (\(b', e') -> (renameExprId old new b', e')) b) e-renameExpr' old new (Case e i a) = Case e (renameExprId old new i) $ map (renameExprAlt old new) a+renameExpr' old new (Case e i t a) = Case e (renameExprId old new i) t $ map (renameExprAlt old new) a renameExpr' old new (Assume is e e') = Assume (fmap (rename old new) is) e e' renameExpr' old new (Assert is e e') = Assert (fmap (rename old new) is) e e' renameExpr' _ _ e = e@@ -281,7 +328,7 @@ renameVars' old new (Var i) = Var (renameExprId old new i) renameVars' old new (Lam u i e) = Lam u (renameExprId old new i) e renameVars' old new (Let b e) = Let (map (\(b', e') -> (renameExprId old new b', e')) b) e-renameVars' old new (Case e i a) = Case e (renameExprId old new i) $ map (renameExprAltIds old new) a+renameVars' old new (Case e i t a) = Case e (renameExprId old new i) t $ map (renameExprAltIds old new) a renameVars' old new (Assert is e e') = Assert (fmap (rename old new) is) e e' renameVars' _ _ e = e @@ -309,21 +356,48 @@ Alt (DataAlt dc is') e renameExprAltIds _ _ a = a +renamesExprs :: ASTContainer m Expr => HM.HashMap Name Name -> m -> m+renamesExprs hm = modifyASTs (renamesExprs' hm) +renamesExprs' :: HM.HashMap Name Name -> Expr -> Expr+renamesExprs' hm (Var i) = Var (renamesExprId hm i)+renamesExprs' hm (Data d) = Data (renamesExprDataCon hm d)+renamesExprs' hm (Lam u i e) = Lam u (renamesExprId hm i) e+renamesExprs' hm (Let b e) = Let (map (\(b', e') -> (renamesExprId hm b', e')) b) e+renamesExprs' hm (Case e i t a) = Case e (renamesExprId hm i) t $ map (renamesExprAlt hm) a+renamesExprs' hm (Assume is e e') = Assume (fmap (renames hm) is) e e'+renamesExprs' hm (Assert is e e') = Assert (fmap (renames hm) is) e e'+renamesExprs' _ e = e++renamesExprId :: HM.HashMap Name Name -> Id -> Id+renamesExprId hm (Id n t) = Id (renames hm n) t++renamesExprDataCon :: HM.HashMap Name Name -> DataCon -> DataCon+renamesExprDataCon hm (DataCon n t) = DataCon (renames hm n) t++renamesExprAlt :: HM.HashMap Name Name -> Alt -> Alt+renamesExprAlt hm (Alt (DataAlt dc is) e) =+ let+ dc' = renamesExprDataCon hm dc+ is' = map (renamesExprId hm) is+ in+ Alt (DataAlt dc' is') e+renamesExprAlt _ a = a+ instance Named Type where names = eval go where go (TyVar i) = idNamesInType i- go (TyCon n _) = [n]- go (TyForAll b _) = tyBinderNamesInType b- go _ = []+ go (TyCon n _) = S.singleton n+ go (TyForAll b _) = idNamesInType b+ go _ = S.empty rename old new = modify go where go :: Type -> Type go (TyVar i) = TyVar (renameIdInType old new i) go (TyCon n ts) = TyCon (rename old new n) ts- go (TyForAll tb t) = TyForAll (renameTyBinderInType old new tb) t+ go (TyForAll tb t) = TyForAll (renameIdInType old new tb) t go t = t renames hm = modify go@@ -331,35 +405,23 @@ go :: Type -> Type go (TyVar i) = TyVar (renamesIdInType hm i) go (TyCon n ts) = TyCon (renames hm n) ts- go (TyForAll tb t) = TyForAll (renamesTyBinderInType hm tb) t+ go (TyForAll tb t) = TyForAll (renamesIdInType hm tb) t go t = t --- We don't want both modify and go to recurse on the Type's in TyBinders or Ids+-- We don't want both modify and go to recurse on the Type's in Ids -- so we introduce functions to collect or rename only the Names directly in those types-tyBinderNamesInType :: TyBinder -> [Name]-tyBinderNamesInType (NamedTyBndr i) = idNamesInType i-tyBinderNamesInType _ = []--idNamesInType :: Id -> [Name]-idNamesInType (Id n _) = [n]--renameTyBinderInType :: Name -> Name -> TyBinder -> TyBinder-renameTyBinderInType old new (NamedTyBndr i) = NamedTyBndr $ renameIdInType old new i-renameTyBinderInType _ _ tyb = tyb+idNamesInType :: Id -> S.Seq Name+idNamesInType (Id n _) = S.singleton n renameIdInType :: Name -> Name -> Id -> Id renameIdInType old new (Id n t) = Id (rename old new n) t -renamesTyBinderInType :: HM.HashMap Name Name -> TyBinder -> TyBinder-renamesTyBinderInType hm (NamedTyBndr i) = NamedTyBndr $ renamesIdInType hm i-renamesTyBinderInType _ tyb = tyb- renamesIdInType :: HM.HashMap Name Name -> Id -> Id renamesIdInType hm (Id n t) = Id (renames hm n) t instance Named Alt where {-# INLINE names #-}- names (Alt am e) = names am ++ names e+ names (Alt am e) = names am <> names e {-# INLINE rename #-} rename old new (Alt am e) = Alt (rename old new am) (rename old new e)@@ -369,7 +431,7 @@ instance Named DataCon where {-# INLINE names #-}- names (DataCon n t) = n:names t+ names (DataCon n t) = n S.<| names t {-# INLINE rename #-} rename old new (DataCon n t) =@@ -381,8 +443,8 @@ instance Named AltMatch where {-# INLINE names #-}- names (DataAlt dc i) = names dc ++ names i- names _ = []+ names (DataAlt dc i) = names dc <> names i+ names _ = S.empty {-# INLINE rename #-} rename old new (DataAlt dc i) =@@ -394,29 +456,22 @@ DataAlt (renames hm dc) (renames hm i) renames _ am = am -instance Named TyBinder where- names (AnonTyBndr t) = names t- names (NamedTyBndr i) = names i-- rename old new (AnonTyBndr t) = AnonTyBndr (rename old new t)- rename old new (NamedTyBndr i) = NamedTyBndr (rename old new i)-- renames hm (AnonTyBndr t) = AnonTyBndr (renames hm t)- renames hm (NamedTyBndr i) = NamedTyBndr (renames hm i)- instance Named Coercion where- names (t1 :~ t2) = names t1 ++ names t2+ names (t1 :~ t2) = names t1 <> names t2 rename old new (t1 :~ t2) = rename old new t1 :~ rename old new t2 renames hm (t1 :~ t2) = renames hm t1 :~ renames hm t2 instance Named Tickish where- names (Breakpoint _) = []- names (NamedLoc n) = [n]+ names (Breakpoint _) = S.empty+ names (HpcTick _ _) = S.empty+ names (NamedLoc n) = S.singleton n rename _ _ bp@(Breakpoint _) = bp+ rename _ _ hpc@(HpcTick _ _) = hpc rename old new (NamedLoc n) = NamedLoc $ rename old new n renames _ bp@(Breakpoint _) = bp+ renames _ hpc@(HpcTick _ _) = hpc renames hm (NamedLoc n) = NamedLoc $ renames hm n instance Named RewriteRule where@@ -425,15 +480,17 @@ , ru_bndrs = b , ru_args = as , ru_rhs = rhs}) =- h:names rs ++ names b ++ names as ++ names rhs+ h S.<| names rs <> names b <> names as <> names rhs rename old new (RewriteRule { ru_name = n+ , ru_module = mdl , ru_head = h , ru_rough = rs , ru_bndrs = b , ru_args = as , ru_rhs = rhs}) = RewriteRule { ru_name = n+ , ru_module = mdl , ru_head = rename old new h , ru_rough = rename old new rs , ru_bndrs = rename old new b@@ -441,12 +498,14 @@ , ru_rhs = rename old new rhs} renames hm (RewriteRule { ru_name = n+ , ru_module = mdl , ru_head = h , ru_rough = rs , ru_bndrs = b , ru_args = as , ru_rhs = rhs}) = RewriteRule { ru_name = n+ , ru_module = mdl , ru_head = renames hm h , ru_rough = renames hm rs , ru_bndrs = renames hm b@@ -454,7 +513,7 @@ , ru_rhs = renames hm rhs} instance Named FuncCall where- names (FuncCall {funcName = n, arguments = as, returns = r}) = n:names as ++ names r+ names (FuncCall {funcName = n, arguments = as, returns = r}) = n S.<| names as <> names r rename old new (FuncCall {funcName = n, arguments = as, returns = r}) = FuncCall {funcName = rename old new n, arguments = rename old new as, returns = rename old new r} renames hm (FuncCall {funcName = n, arguments = as, returns = r} ) =@@ -462,9 +521,9 @@ instance Named AlgDataTy where- names (DataTyCon ns dc) = names ns ++ names dc- names (NewTyCon ns dc rt) = names ns ++ names dc ++ names rt- names (TypeSynonym is st) = names is ++ names st+ names (DataTyCon ns dc) = names ns <> names dc+ names (NewTyCon ns dc rt) = names ns <> names dc <> names rt+ names (TypeSynonym is st) = names is <> names st rename old new (DataTyCon n dc) = DataTyCon (rename old new n) (rename old new dc) rename old new (NewTyCon n dc rt) = NewTyCon (rename old new n) (rename old new dc) (rename old new rt)@@ -492,15 +551,31 @@ , dcTrue = dcT , dcFalse = dcF + , tyRational = tR+ , tyList = tList , dcCons = tCons , dcEmpty = tEmp + , tyMaybe = tMaybe+ , dcJust = dJust+ , dcNothing = dNothing++ , tyUnit = tUnit+ , dcUnit = dUnit+ , eqTC = eqT , numTC = numT , ordTC = ordT , integralTC = integralT+ , realTC = realT+ , fractionalTC = fractionalT + , integralExtactReal = integralEReal+ , realExtractNum = realENum+ , realExtractOrd = realEOrd+ , ordExtractEq = ordEEq+ , eqFunc = eqF , neqFunc = neqF @@ -510,26 +585,44 @@ , divFunc = divF , negateFunc = negF , modFunc = modF+ , fromIntegerFunc = fromIntegerF , toIntegerFunc = toIntegerF + , toRatioFunc = toRatioF+ , fromRationalFunc = fromRationalF+ , geFunc = geF , gtFunc = gtF , ltFunc = ltF , leFunc = leF - , structEqTC = seT- , structEqFunc = seF+ , impliesFunc = impF+ , iffFunc = iffF , andFunc = andF , orFunc = orF+ , notFunc = notF + , errorFunc = errF+ , errorEmptyListFunc = errEmpListF+ , errorWithoutStackTraceFunc = errWOST , patErrorFunc = patE }) =- [dI, dF, dD, dI2, dcCh, tI, tI2, tF, tD, tCh, tB, dcT, dcF, tList, tCons, tEmp- , eqT, numT, ordT, integralT, eqF, neqF, plF, minusF, tmsF, divF, negF, modF, fromIntegerF, toIntegerF- , geF, gtF, ltF, leF, seT, seF- , andF, orF, patE]+ S.fromList+ [dI, dF, dD, dI2, dcCh, tI, tI2, tF, tD, tCh, tB, dcT, dcF, tR+ , tList, tCons, tEmp+ , tMaybe, dJust, dNothing+ , tUnit, dUnit+ , eqT, numT, ordT, integralT, realT, fractionalT+ , integralEReal, realENum, realEOrd, ordEEq+ , eqF, neqF, plF, minusF, tmsF, divF, negF, modF+ , fromIntegerF, toIntegerF+ , toRatioF, fromRationalF+ , geF, gtF, ltF, leF+ , impF, iffF+ , andF, orF, notF+ , errF, errEmpListF, errWOST, patE] rename old new (KnownValues { dcInt = dI@@ -548,15 +641,31 @@ , dcTrue = dcT , dcFalse = dcF + , tyRational = tR+ , tyList = tList , dcCons = tCons , dcEmpty = tEmp + , tyMaybe = tMaybe+ , dcJust = dJust+ , dcNothing = dNothing++ , tyUnit = tUnit+ , dcUnit = dUnit+ , eqTC = eqT , numTC = numT , ordTC = ordT , integralTC = integralT+ , realTC = realT+ , fractionalTC = fractionalT + , integralExtactReal = integralEReal+ , realExtractNum = realENum+ , realExtractOrd = realEOrd+ , ordExtractEq = ordEEq+ , eqFunc = eqF , neqFunc = neqF @@ -566,20 +675,28 @@ , divFunc = divF , negateFunc = negF , modFunc = modF+ , fromIntegerFunc = fromIntegerF , toIntegerFunc = toIntegerF + , toRatioFunc = toRatioF+ , fromRationalFunc = fromRationalF+ , geFunc = geF , gtFunc = gtF , ltFunc = ltF , leFunc = leF - , structEqTC = seT- , structEqFunc = seF+ , impliesFunc = impF+ , iffFunc = iffF , andFunc = andF , orFunc = orF+ , notFunc = notF + , errorFunc = errF+ , errorEmptyListFunc = errEmpListF+ , errorWithoutStackTraceFunc = errWOST , patErrorFunc = patE }) = (KnownValues {@@ -598,15 +715,32 @@ , tyBool = rename old new tB , dcTrue = rename old new dcT , dcFalse = rename old new dcF++ , tyRational = rename old new tR+ , tyList = rename old new tList , dcCons = rename old new tCons , dcEmpty = rename old new tEmp + , tyMaybe = rename old new tMaybe+ , dcJust = rename old new dJust+ , dcNothing = rename old new dNothing++ , tyUnit = rename old new tUnit+ , dcUnit = rename old new dUnit+ , eqTC = rename old new eqT , numTC = rename old new numT , ordTC = rename old new ordT , integralTC = rename old new integralT+ , realTC = rename old new realT+ , fractionalTC = rename old new fractionalT + , integralExtactReal = rename old new integralEReal+ , realExtractNum = rename old new realENum+ , realExtractOrd = rename old new realEOrd+ , ordExtractEq = rename old new ordEEq+ , eqFunc = rename old new eqF , neqFunc = rename old new neqF @@ -616,20 +750,28 @@ , divFunc = rename old new divF , negateFunc = rename old new negF , modFunc = rename old new modF+ , fromIntegerFunc = rename old new fromIntegerF , toIntegerFunc = rename old new toIntegerF + , toRatioFunc = rename old new toRatioF+ , fromRationalFunc = rename old new fromRationalF+ , geFunc = rename old new geF , gtFunc = rename old new gtF , ltFunc = rename old new ltF , leFunc = rename old new leF-- , structEqTC = rename old new seT- , structEqFunc = rename old new seF+ + , impliesFunc = rename old new impF+ , iffFunc = rename old new iffF , andFunc = rename old new andF , orFunc = rename old new orF+ , notFunc = rename old new notF + , errorFunc = rename old new errF+ , errorEmptyListFunc = rename old new errEmpListF+ , errorWithoutStackTraceFunc = rename old new errWOST , patErrorFunc = rename old new patE }) @@ -641,7 +783,15 @@ {-# INLINE renames #-} renames hm = fmap (renames hm) +instance Named a => Named (S.Seq a) where+ {-# INLINE names #-}+ names = foldMap names+ {-# INLINE rename #-}+ rename old new = fmap (rename old new)+ {-# INLINE renames #-}+ renames hm = fmap (renames hm) + instance Named a => Named (Maybe a) where {-# INLINE names #-} names = foldMap names@@ -668,7 +818,7 @@ instance Named () where {-# INLINE names #-}- names _ = []+ names _ = S.empty {-# INLINE rename #-} rename _ _ = id {-# INLINE renames #-}@@ -683,37 +833,55 @@ renames hm = HS.map (renames hm) instance (Named a, Named b) => Named (a, b) where- names (a, b) = names a ++ names b+ names (a, b) = names a <> names b rename old new (a, b) = (rename old new a, rename old new b) renames hm (a, b) = (renames hm a, renames hm b) instance (Named a, Named b, Named c) => Named (a, b, c) where- names (a, b, c) = names a ++ names b ++ names c+ names (a, b, c) = names a <> names b <> names c rename old new (a, b, c) = (rename old new a, rename old new b, rename old new c) renames hm (a, b, c) = (renames hm a, renames hm b, renames hm c) instance (Named a, Named b, Named c, Named d) => Named (a, b, c, d) where- names (a, b, c, d) = names a ++ names b ++ names c ++ names d+ names (a, b, c, d) = names a <> names b <> names c <> names d rename old new (a, b, c, d) = (rename old new a, rename old new b, rename old new c, rename old new d) renames hm (a, b, c, d) = (renames hm a, renames hm b, renames hm c, renames hm d) instance (Named a, Named b, Named c, Named d, Named e) => Named (a, b, c, d, e) where- names (a, b, c, d, e) = names a ++ names b ++ names c ++ names d ++ names e+ names (a, b, c, d, e) = names a <> names b <> names c <> names d <> names e rename old new (a, b, c, d, e) = (rename old new a, rename old new b, rename old new c, rename old new d, rename old new e) renames hm (a, b, c, d, e) = (renames hm a, renames hm b, renames hm c, renames hm d, renames hm e) +instance Named Bool where+ {-# INLINE names #-}+ names _ = S.empty+ {-# INLINE rename #-}+ rename _ _ = id+ instance Named Int where {-# INLINE names #-}- names _ = []+ names _ = S.empty {-# INLINE rename #-} rename _ _ = id +instance Named Integer where+ {-# INLINE names #-}+ names _ = S.empty+ {-# INLINE rename #-}+ rename _ _ = id+ instance Named T.Text where {-# INLINE names #-}- names _ = []+ names _ = S.empty {-# INLINE rename #-} rename _ _ = id +instance (Named k, Named v, Eq k, Hashable k) => Named (UF.UFMap k v) where+ names = names . UF.toList+ rename old new = UF.fromList . rename old new . UF.toList+ renames hm = UF.fromList . renames hm . UF.toList++ freshSeededString :: T.Text -> NameGen -> (Name, NameGen) freshSeededString t = freshSeededName (Name t Nothing 0 Nothing) @@ -721,28 +889,25 @@ freshSeededStrings t = freshSeededNames (map (\t' -> Name t' Nothing 0 Nothing) t) freshSeededName :: Name -> NameGen -> (Name, NameGen)-freshSeededName (Name n m _ l) (NameGen { max_uniq = hm, dc_children = chm }) =- (Name n m i' l, NameGen hm' chm)+freshSeededName (Name n m _ l) (NameGen hm) =+ (Name n m i' l, NameGen hm') where i' = HM.lookupDefault 0 (n, m) hm hm' = HM.insert (n, m) (i' + 1) hm freshSeededNames :: [Name] -> NameGen -> ([Name], NameGen)-freshSeededNames [] r = ([], r)-freshSeededNames (n:ns) r = (n':ns', ngen'') - where (n', ngen') = freshSeededName n r- (ns', ngen'') = freshSeededNames ns ngen'+freshSeededNames ns ng = swap $ mapAccumR (\ng' n -> swap $ freshSeededName n ng') ng ns freshName :: NameGen -> (Name, NameGen) freshName ngen = freshSeededName seed ngen where- seed = Name "fs?" Nothing 0 Nothing+ seed = Name "fs" Nothing 0 Nothing freshNames :: Int -> NameGen -> ([Name], NameGen)-freshNames i ngen = freshSeededNames (replicate i (Name "fs?" Nothing 0 Nothing)) ngen+freshNames i ngen = freshSeededNames (replicate i (Name "fs" Nothing 0 Nothing)) ngen freshId :: Type -> NameGen -> (Id, NameGen)-freshId = freshSeededId (Name "fs?" Nothing 0 Nothing)+freshId = freshSeededId (Name "fs" Nothing 0 Nothing) freshIds :: [Type] -> NameGen -> ([Id], NameGen) freshIds ts ngen = @@ -754,7 +919,9 @@ freshSeededId :: Named a => a -> Type -> NameGen -> (Id, NameGen) freshSeededId x t ngen = let- (n, ngen') = freshSeededName (head $ names x) ngen+ (n, ngen') = case S.viewl (names x) of+ S.EmptyL -> error "freshSeededId: no names available"+ x' S.:< _ -> freshSeededName x' ngen in (Id n t, ngen') @@ -765,48 +932,7 @@ in (Var i, ngen') --- | Given the name n of a datacon, and some names for it's children,--- returns new names ns for the children--- Returns a new NameGen that will always return the same ns for that n--- If this is called with different length ns's, the shorter will be the prefix--- of the longer-childrenNames :: Name -> [Name] -> NameGen -> ([Name], NameGen)-childrenNames n ns ng@(NameGen { dc_children = chm }) =- case HM.lookup n chm of- Just ens' -> childrenNamesExisting n ns ens' ng- Nothing -> childrenNamesNew n ns ng-- []--childrenNamesExisting :: Name -> [Name] -> [Name] -> NameGen -> ([Name], NameGen)-childrenNamesExisting n ns ens ng =- let- (fns, NameGen hm chm) = freshSeededNames (drop (length ens) ns) ng- ns' = ens ++ fns-- chm' = HM.insert n ns' chm- in- case length ns `compare` length ens of- LT -> (take (length ns) ens, ng)- EQ -> (ens, ng)- GT -> (ns', NameGen hm chm')--childrenNamesNew :: Name -> [Name] -> NameGen -> ([Name], NameGen)-childrenNamesNew n ns ng =- let- (fns, NameGen hm chm) = freshSeededNames ns ng- chm' = HM.insert n fns chm- in- (fns, NameGen hm chm')-- -- | Allows mapping, while passing a NameGen along mapNG :: (a -> NameGen -> (b, NameGen)) -> [a] -> NameGen -> ([b], NameGen)-mapNG f xs ng = swap $ mapAccumR (\xs' ng' -> swap $ f ng' xs') ng xs -- mapNG' f (reverse xs) ng []+mapNG f xs ng = swap $ mapAccumR (\xs' ng' -> swap $ f ng' xs') ng xs {-# INLINE mapNG #-}---- mapNG' :: (a -> NameGen -> (b, NameGen)) -> [a] -> NameGen -> [b] -> ([b], NameGen)--- mapNG' _ [] ng xs = (xs, ng)--- mapNG' f (x:xs) ng xs' =--- let--- (x', ng') = f x ng--- in--- mapNG' f xs ng' (x':xs')
src/G2/Language/PathConds.hs view
@@ -4,114 +4,194 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -module G2.Language.PathConds ( PathCond (..)- , Constraint- , Assertion- , PathConds- , empty- , fromList- , map- , filter- , insert- , null- , number- , relevant- , relatedSets- , scc- , varIdsInPC- , toList- , isPCExists) where+module G2.Language.PathConds ( PathConds+ , PCGroup (..)+ , PathCond (..)+ , HashedPathCond+ , Constraint+ , Assertion+ , mkAssumePC+ , mkSingletonAssumePC + , toUFMap+ , toUFList+ , empty+ , fromList+ , fromHashedList+ , map+ , mapHashedPCs+ , map'+ , filter+ , alter+ , alterHashed+ , unionAlterHashed+ , insert+ , null+ , number+ , relatedSets+ , scc+ , varIdsInPC+ , varNamesInPC+ , allIds+ , toList+ , toHashedList+ , toHashSet+ , union+ -- , intersection+ -- , difference+ , mergeWithAssumePCs++ , hashedPC+ , unhashedPC+ , mapHashedPC) where++import qualified G2.Data.UFMap as UF import G2.Language.AST import G2.Language.Ids-import qualified G2.Language.KnownValues as KV import G2.Language.Naming import G2.Language.Syntax import Data.Coerce import Data.Data (Data, Typeable)+import qualified Data.Foldable as F import GHC.Generics (Generic) import Data.Hashable import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HM import qualified Data.List as L-import qualified Data.Map as M import Data.Maybe+import Data.Monoid (Monoid (..)) import Prelude hiding (map, filter, null) import qualified Prelude as P (map)+import Data.Semigroup (Semigroup (..)) --- In the implementation:--- Each name (Just n) maps to some (but not neccessarily all) of the PathCond's that--- contain n, and a list of all names that appear in some PathCond alongside--- the name n--- PathConds that contain no names are stored in Nothing------ You can visualize this as a graph, with Names and Nothing as Nodes.--- Edges exist in a PathConds pcs netween a name n, and any names in--- snd $ M.lookup n (toMap pcs)+-- Conceptually, the path constraints are a graph, with (Maybe Name)'s Nodes.+-- Edges exist between any names that are in the same path constraint.+-- Strongly connected components in the graph must be checked and solved together. --- | You can visualize a PathConds as [PathCond] (accessible via toList)-newtype PathConds = PathConds (M.Map (Maybe Name) (HS.HashSet PathCond, [Name]))- deriving (Show, Eq, Read, Typeable, Data)+-- A collection of path constraints- requirements on symbolic variables.+newtype PathConds = PathConds (UF.UFMap (Maybe Name) PCGroup)+ deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable PathConds++data PCGroup = PCGroup { pcs_contains :: HS.HashSet Id, pcs :: HS.HashSet HashedPathCond}+ deriving (Show, Eq, Read, Generic, Typeable, Data)++instance Hashable PCGroup++instance Semigroup PCGroup where+ pcg1 <> pcg2 =+ PCGroup { pcs_contains = pcs_contains pcg1 `HS.union` pcs_contains pcg2+ , pcs = pcs pcg1 `HS.union` pcs pcg2 }++instance Monoid PCGroup where+ mempty = PCGroup HS.empty HS.empty+ mappend = (<>)++mapMaybePCGroup :: (HashedPathCond -> Maybe HashedPathCond) -> PCGroup -> PCGroup+mapMaybePCGroup f pcg =+ let+ pcs' = HS.map fromJust . HS.filter isJust $ HS.map f (pcs pcg)+ in+ PCGroup { pcs_contains = HS.fromList (concatMap (varIdsInPC . unhashedPC) pcs'), pcs = pcs' }++unionMapMaybePCGroup :: (HashedPathCond -> HS.HashSet HashedPathCond) -> PCGroup -> PCGroup+unionMapMaybePCGroup f pcg =+ let+ pcs' = F.foldl' HS.union HS.empty $ HS.map f (pcs pcg)+ in+ PCGroup { pcs_contains = HS.fromList (concatMap (varIdsInPC . unhashedPC) pcs'), pcs = pcs' }++ -- | Path conditions represent logical constraints on our current execution -- path. We can have path constraints enforced due to case/alt branching, due -- to assertion / assumptions made, or some externally coded factors. data PathCond = AltCond Lit Expr Bool -- ^ The expression and Lit must match | ExtCond Expr Bool -- ^ The expression must be a (true) boolean- | ConsCond DataCon Expr Bool -- ^ The expression and datacon must match- | PCExists Id -- ^ Makes sure we find some value for the given name, of the correct type+ | SoftPC PathCond -- ^ A `PathCond` to satisfy if possible, but which is not absolutely required.+ | MinimizePC Expr -- ^ An expression to minimize+ | AssumePC Id Integer (HS.HashSet HashedPathCond) -- ^ An implication- if the `Id` equals the integer, that implies the `HashedPathCond` in the `HS.HashSet` deriving (Show, Eq, Read, Generic, Typeable, Data) type Constraint = PathCond type Assertion = PathCond -instance Hashable PathCond+instance Hashable PathCond where+ hashWithSalt s pc = s `hashWithSalt` hash pc -{-# INLINE toMap #-}-toMap :: PathConds -> M.Map (Maybe Name) (HS.HashSet PathCond, [Name])-toMap = coerce+ hash (AltCond l e b) = (1 :: Int) `hashWithSalt` l `hashWithSalt` e `hashWithSalt` b+ hash (ExtCond e b) = (2 :: Int) `hashWithSalt` e `hashWithSalt` b+ hash (SoftPC pc) = (3 :: Int) `hashWithSalt` pc+ hash (MinimizePC e) = (4 :: Int) `hashWithSalt` e+ hash (AssumePC i n pc) = (5 :: Int) `hashWithSalt` i `hashWithSalt` n `hashWithSalt` pc -- hashAssumePC i n pc +{-# INLINE toUFMap #-}+toUFMap :: PathConds -> UF.UFMap (Maybe Name) PCGroup+toUFMap = coerce++fromUFMap :: UF.UFMap (Maybe Name) PCGroup -> PathConds+fromUFMap = coerce++toUFList :: PathConds -> [([Maybe Name], PCGroup)]+toUFList = mapMaybe (\(ns, pc) -> case pc of Just pc' -> Just (ns, pc'); Nothing -> Nothing) . UF.toList . toUFMap+ {-# INLINE empty #-} -- | Constructs an empty `PathConds`. empty :: PathConds-empty = PathConds M.empty+empty = PathConds UF.empty -fromList :: KV.KnownValues -> [PathCond] -> PathConds-fromList kv = coerce . foldr (insert kv) empty+fromList :: [PathCond] -> PathConds+fromList = coerce . foldr insert empty -map :: (PathCond -> a) -> PathConds -> [a]-map f = L.map f . toList+fromHashedList :: [HashedPathCond] -> PathConds+fromHashedList = coerce . foldr insertHashed empty +map :: (PathCond -> PathCond) -> PathConds -> PathConds+map f = fromList . L.map f . toList++mapHashedPCs :: (HashedPathCond -> HashedPathCond) -> PathConds -> PathConds+mapHashedPCs f = fromHashedList . L.map f . toHashedList++map' :: (PathCond -> a) -> PathConds -> [a]+map' f = L.map f . toList+ filter :: (PathCond -> Bool) -> PathConds -> PathConds-filter f = PathConds - . M.filter (not . HS.null . fst)- . M.map (\(pc, ns) -> (HS.filter f pc, ns))- . toMap+filter f = fromHashedList + . L.filter (f . unhashedPC)+ . toHashedList +alter :: (PathCond -> Maybe PathCond) -> PathConds -> PathConds+alter f = fromList . mapMaybe f . toList++alterHashed :: (HashedPathCond -> Maybe HashedPathCond) -> PathConds -> PathConds+alterHashed f = fromUFMap . UF.map (mapMaybePCGroup f) . toUFMap++unionAlterHashed :: (HashedPathCond -> HS.HashSet HashedPathCond) -> PathConds -> PathConds+unionAlterHashed f = fromUFMap . UF.map (unionMapMaybePCGroup f) . toUFMap+ -- Each name n maps to all other names that are in any PathCond containing n -- However, each n does NOT neccessarily map to all PCs containing n- instead each -- PC is associated with only one name. -- This is ok, because the PCs can only be externally accessed by toList (which -- returns all PCs anyway) or scc (which forces exploration over all shared names) {-# INLINE insert #-}-insert :: KV.KnownValues -> PathCond -> PathConds -> PathConds-insert = insert' varNamesInPC+insert :: PathCond -> PathConds -> PathConds+insert pc = insertHashed (hashedPC pc) -insert' :: (KV.KnownValues -> PathCond -> [Name]) -> KV.KnownValues -> PathCond -> PathConds -> PathConds-insert' f kv p (PathConds pcs) =+insertHashed :: HashedPathCond -> PathConds -> PathConds+insertHashed pc (PathConds pcc) = let- ns = f kv p-- (hd, insertAt) = case ns of- [] -> (Nothing, [Nothing])- (h:_) -> (Just h, P.map Just ns)+ var_ids = varIdsInPC (unhashedPC pc)+ sing_pc = PCGroup (HS.fromList var_ids) (HS.singleton pc) in- PathConds $ M.adjust (\(p', ns') -> (HS.insert p p', ns')) hd- $ foldr (M.alter (insert'' ns)) pcs insertAt--insert'' :: [Name] -> Maybe (HS.HashSet PathCond, [Name]) -> Maybe (HS.HashSet PathCond, [Name])-insert'' ns Nothing = Just (HS.empty, ns)-insert'' ns (Just (p', ns')) = Just (p', ns ++ ns')+ case var_ids of+ [] -> PathConds $ UF.insertWith (<>) Nothing sing_pc pcc+ vs@(v:_) ->+ let+ ins_pcs = UF.insertWith (<>) (Just (idName v)) sing_pc pcc+ in+ PathConds $ UF.joinAll (<>) (P.map (Just . idName) vs) ins_pcs {-# INLINE number #-} number :: PathConds -> Int@@ -119,156 +199,251 @@ {-# INLINE null #-} null :: PathConds -> Bool-null = M.null . toMap---- | Filters a PathConds to only those PathCond's that potentially impact the--- given PathCond's satisfiability (i.e. they are somehow linked by variable names)-relevant :: KV.KnownValues -> [PathCond] -> PathConds -> PathConds-relevant kv pc pcs = - case concatMap (varNamesInPC kv) pc of- [] -> fromList kv pc- rel -> scc rel pcs+null = UF.null . toUFMap -- Returns a list of PathConds, where the union of the output PathConds -- is the input PathConds, and the PathCond are seperated into there SCCs-relatedSets :: KV.KnownValues -> PathConds -> [PathConds]-relatedSets kv pc@(PathConds pcm) = +relatedSets :: PathConds -> [PathConds]+relatedSets (PathConds ufm) = let- epc = case M.lookup Nothing pcm of- Just v -> PathConds $ M.singleton Nothing v- Nothing -> PathConds M.empty-- ns = catMaybes $ M.keys pcm+ c_ufm = UF.clear ufm in- if null epc then relatedSets' kv pc ns else epc:relatedSets' kv pc ns--relatedSets' :: KV.KnownValues -> PathConds -> [Name] -> [PathConds]-relatedSets' kv pc ns =- case ns of- k:_ ->- let- s = scc [k] pc- ns' = concat $ map (varNamesInPC kv) s- in- s:relatedSets' kv pc (ns L.\\ (k:ns'))- [] -> []+ P.map (\(k, v) -> PathConds $ UF.insert k v c_ufm) $ HM.toList (UF.toSimpleMap ufm) +varIdsInPC :: PathCond -> [Id]+varIdsInPC (AltCond _ e _) = varIds e+varIdsInPC (ExtCond e _) = varIds e+varIdsInPC (MinimizePC e) = varIds e+varIdsInPC (SoftPC pc) = varIdsInPC pc+varIdsInPC (AssumePC i _ pc) = i:concatMap (varIdsInPC . unhashedPC) pc -varIdsInPC :: KV.KnownValues -> PathCond -> [Id]--- [AltCond]--- Optimization--- When we have an AltCond with a Var expr, we only have to look at--- other PC's with that Var's name. This is because we assign all--- DCs from the same part in a DC tree the same name, and a DC's--- parents/children can't impose restrictions on it. We are completely--- guided by pattern matching from case statements.--- See note [ChildrenNames] in Execution/Rules.hs-varIdsInPC _ (AltCond _ e _) = varIds e-varIdsInPC _ (ExtCond e _) = varIds e-varIdsInPC _ (ConsCond _ e _) = varIds e-varIdsInPC _ (PCExists i) = [i]+varNamesInPC :: PathCond -> [Name]+varNamesInPC = P.map idName . varIdsInPC -varNamesInPC :: KV.KnownValues -> PathCond -> [Name]-varNamesInPC kv = P.map idName . varIdsInPC kv+allIds :: PathConds -> HS.HashSet Id+allIds (PathConds pc) = HS.unions . P.map pcs_contains $ UF.elems pc -{-# INLINE scc #-}+-- | Computes the path constraints that relate to the `Names` in the passed list. scc :: [Name] -> PathConds -> PathConds-scc ns (PathConds pc) = PathConds $ scc' ns pc M.empty--scc' :: [Name]- -> (M.Map (Maybe Name) (HS.HashSet PathCond, [Name]))- -> (M.Map (Maybe Name) (HS.HashSet PathCond, [Name]))- -> (M.Map (Maybe Name) (HS.HashSet PathCond, [Name]))-scc' [] _ pc = pc-scc' (n:ns) pc newpc =- -- Check if we already inserted the name information- case M.lookup (Just n) newpc of- Just _ -> scc' ns pc newpc- Nothing ->- -- If we didn't, lookup info to insert,- -- and add names to the list of names to search- case M.lookup (Just n) pc of- Just pcn@(_, ns') -> scc' (ns ++ ns') pc (M.insert (Just n) pcn newpc)- Nothing -> scc' ns pc newpc+scc ns (PathConds pcc) =+ let+ ns' = P.map (flip UF.find pcc . Just) ns+ in+ PathConds $ UF.filterWithKey (\k _ -> k `L.elem` ns') pcc {-# INLINE toList #-} toList :: PathConds -> [PathCond]-toList = concatMap (HS.toList . fst) . M.elems . toMap+toList = P.map unhashedPC . toHashedList -isPCExists :: PathCond -> Bool-isPCExists (PCExists _) = True-isPCExists _ = False+{-# INLINE toHashedList #-}+toHashedList :: PathConds -> [HashedPathCond]+toHashedList = HS.toList . toHashSet +{-# INLINE toHashSet #-}+toHashSet :: PathConds -> HS.HashSet HashedPathCond+toHashSet = HS.unions . UF.elems . UF.map pcs . toUFMap++union :: PathConds -> PathConds -> PathConds+union (PathConds pc1) (PathConds pc2) = PathConds $ UF.unionWith (<>) pc1 pc2++mergeWithAssumePCs :: Id -> PathConds -> PathConds -> PathConds+mergeWithAssumePCs i (PathConds pc1) (PathConds pc2) =+ let+ mrg = UF.mergeJoiningWithKey+ (mergeMatched i)+ (mergeOnlyIn i 1)+ (mergeOnlyIn i 2)+ (<>)+ (<>)+ (<>)+ pc1 pc2+ pc = PathConds $ adjustNothing (idName i) mrg+ in+ pc+ +mergeOnlyIn :: Id -> Integer -> Maybe Name -> PCGroup -> (PCGroup, [(Maybe Name, Maybe Name)])+mergeOnlyIn i n k (PCGroup { pcs_contains = contains, pcs = hpc }) =+ let+ n_hpc = HS.singleton . hashedPC $ mkAssumePC i n hpc -- HS.map (hashedAssumePC i n) hpc+ in+ ( PCGroup { pcs_contains = HS.insert i contains, pcs = n_hpc }+ , if not (HS.null hpc) then [(Just $ idName i, k)] else [])++mergeMatched :: Id+ -> Maybe Name+ -> PCGroup+ -> PCGroup+ -> (PCGroup, [(Maybe Name, Maybe Name)])+mergeMatched i k (PCGroup { pcs_contains = contains1, pcs = hpc1 }) (PCGroup { pcs_contains = contains2, pcs = hpc2 }) =+ let+ both = HS.intersection hpc1 hpc2+ onlyIn1 = HS.difference hpc1 hpc2 -- HS.map (hashedAssumePC i 1) $ HS.difference hpc1 hpc2+ onlyIn2 = HS.difference hpc2 hpc1-- HS.map (hashedAssumePC i 2) $ HS.difference hpc2 hpc1+ onlyIn1_pc = if not (HS.null onlyIn1) then HS.singleton . hashedPC $ mkAssumePC i 1 onlyIn1 else HS.empty+ onlyIn2_pc = if not (HS.null onlyIn2) then HS.singleton . hashedPC $ mkAssumePC i 2 onlyIn2 else HS.empty++ hpc = HS.union both (HS.union onlyIn1_pc onlyIn2_pc)+ ks = if not (HS.null onlyIn1) || not (HS.null onlyIn2)+ then [(Just $ idName i, k)]+ else []+ in+ ( PCGroup { pcs_contains = HS.insert i (contains1 `HS.union` contains2) , pcs = hpc }+ , ks)++adjustNothing :: Name+ -> UF.UFMap (Maybe Name) PCGroup+ -> UF.UFMap (Maybe Name) PCGroup+adjustNothing n hs+ | Just v <- UF.lookup Nothing hs = UF.insertWith (<>) (Just n) v hs+ | otherwise = hs+ instance ASTContainer PathConds Expr where- containedASTs = containedASTs . toMap+ containedASTs = containedASTs . toUFMap - modifyContainedASTs f = coerce . modifyContainedASTs f . toMap+ modifyContainedASTs f = fromList . modifyContainedASTs f . toList instance ASTContainer PathConds Type where- containedASTs = containedASTs . toMap+ containedASTs = containedASTs . toUFMap - modifyContainedASTs f = coerce . modifyContainedASTs f . toMap+ modifyContainedASTs f = fromList . modifyContainedASTs f . toList instance ASTContainer PathCond Expr where containedASTs (ExtCond e _ ) = [e] containedASTs (AltCond _ e _) = [e]- containedASTs (ConsCond _ e _) = [e]- containedASTs (PCExists _) = []+ containedASTs (MinimizePC e) = containedASTs e+ containedASTs (SoftPC pc) = containedASTs pc+ containedASTs (AssumePC _ _ pc) = containedASTs pc modifyContainedASTs f (ExtCond e b) = ExtCond (modifyContainedASTs f e) b modifyContainedASTs f (AltCond a e b) = AltCond (modifyContainedASTs f a) (modifyContainedASTs f e) b- modifyContainedASTs f (ConsCond dc e b) =- ConsCond (modifyContainedASTs f dc) (modifyContainedASTs f e) b- modifyContainedASTs _ pc = pc+ modifyContainedASTs f (MinimizePC e) = MinimizePC $ modifyContainedASTs f e+ modifyContainedASTs f (SoftPC pc) = SoftPC $ modifyContainedASTs f pc+ modifyContainedASTs f (AssumePC i num pc) = AssumePC i num (modifyContainedASTs f pc) instance ASTContainer PathCond Type where containedASTs (ExtCond e _) = containedASTs e containedASTs (AltCond e a _) = containedASTs e ++ containedASTs a- containedASTs (ConsCond dcl e _) = containedASTs dcl ++ containedASTs e- containedASTs (PCExists i) = containedASTs i+ containedASTs (MinimizePC pc) = containedASTs pc+ containedASTs (SoftPC pc) = containedASTs pc+ containedASTs (AssumePC i _ pc) = containedASTs i ++ containedASTs pc modifyContainedASTs f (ExtCond e b) = ExtCond e' b where e' = modifyContainedASTs f e modifyContainedASTs f (AltCond e a b) = AltCond e' a' b where e' = modifyContainedASTs f e a' = modifyContainedASTs f a- modifyContainedASTs f (ConsCond dc e b) =- ConsCond (modifyContainedASTs f dc) (modifyContainedASTs f e) b- modifyContainedASTs f (PCExists i) = PCExists (modifyContainedASTs f i)+ modifyContainedASTs f (MinimizePC pc) = MinimizePC $ modifyContainedASTs f pc+ modifyContainedASTs f (SoftPC pc) = SoftPC $ modifyContainedASTs f pc+ modifyContainedASTs f (AssumePC i num pc) = AssumePC (modifyContainedASTs f i) num (modifyContainedASTs f pc) instance Named PathConds where- names (PathConds pc) = (catMaybes $ M.keys pc) ++ concatMap (\(p, n) -> names p ++ n) pc+ -- In rename and renames, we loopup and rename individual keys, to avoid rehashing everything in the PathConds - rename old new (PathConds pc) =- PathConds . M.mapKeys (\k -> if k == (Just old) then (Just new) else k)- $ rename old new pc+ names = names . UF.toList . toUFMap - renames hm (PathConds pc) =- PathConds . M.mapKeys (renames hm)- $ renames hm pc+ rename old new (PathConds pcc) =+ let+ pcc' = UF.join (<>) (Just old) (Just new) pcc+ in+ case UF.lookup (Just old) pcc' of+ Just pc -> PathConds $ UF.insert (Just new) (rename old new pc) pcc'+ Nothing -> PathConds pcc' + renames hm (PathConds pcc) =+ let+ rep_ns = L.foldr (\k -> HS.insert (UF.find (Just k) pcc)) HS.empty $ HM.keys hm+ pcc' = L.foldr (\(k1, k2) -> UF.join (<>) (Just k1) (Just k2)) pcc $ HM.toList hm+ in+ PathConds $ L.foldr (\k pcs_ -> + case UF.lookup k pcs_ of+ Just pc -> UF.insert k (renames hm pc) pcs_+ Nothing -> pcs_) pcc' rep_ns++instance ASTContainer PCGroup Expr where+ containedASTs = containedASTs . pcs+ modifyContainedASTs f pcg = pcg { pcs = modifyContainedASTs f $ pcs pcg }++instance ASTContainer PCGroup Type where+ containedASTs = containedASTs . pcs+ modifyContainedASTs f pcg = pcg { pcs = modifyContainedASTs f $ pcs pcg }++instance Named PCGroup where+ names = names . pcs+ rename old new pcg = pcg { pcs_contains = rename old new (pcs_contains pcg)+ , pcs = rename old new (pcs pcg) } + renames hm pcg = pcg { pcs_contains = renames hm (pcs_contains pcg)+ , pcs = renames hm (pcs pcg) } ++instance Ided PCGroup where+ ids = ids . pcs+ instance Named PathCond where names (AltCond _ e _) = names e names (ExtCond e _) = names e- names (ConsCond d e _) = names d ++ names e- names (PCExists i) = names i+ names (MinimizePC pc) = names pc+ names (SoftPC pc) = names pc+ names (AssumePC i _ pc) = names i <> names pc rename old new (AltCond l e b) = AltCond l (rename old new e) b rename old new (ExtCond e b) = ExtCond (rename old new e) b- rename old new (ConsCond d e b) = ConsCond (rename old new d) (rename old new e) b- rename old new (PCExists i) = PCExists (rename old new i)+ rename old new (MinimizePC pc) = MinimizePC (rename old new pc)+ rename old new (SoftPC pc) = SoftPC (rename old new pc)+ rename old new (AssumePC i num pc) = AssumePC (rename old new i) num (rename old new pc) renames hm (AltCond l e b) = AltCond l (renames hm e) b renames hm (ExtCond e b) = ExtCond (renames hm e) b- renames hm (ConsCond d e b) = ConsCond (renames hm d) (renames hm e) b- renames hm (PCExists i) = PCExists (renames hm i)+ renames hm (MinimizePC pc) = MinimizePC (renames hm pc)+ renames hm (SoftPC pc) = SoftPC (renames hm pc)+ renames hm (AssumePC i num pc) = AssumePC (renames hm i) num (renames hm pc) instance Ided PathConds where- ids = ids . toMap+ ids = ids . toUFMap instance Ided PathCond where ids (AltCond _ e _) = ids e ids (ExtCond e _) = ids e- ids (ConsCond d e _) = ids d ++ ids e- ids (PCExists i) = [i]+ ids (MinimizePC pc) = ids pc+ ids (SoftPC pc) = ids pc+ ids (AssumePC i _ pc) = ids i ++ ids pc++data HashedPathCond = HashedPC PathCond {-# UNPACK #-} !Int+ deriving (Show, Read, Typeable, Data)++hashedPC :: PathCond -> HashedPathCond+hashedPC pc = HashedPC pc (hash pc)++unhashedPC :: HashedPathCond -> PathCond+unhashedPC (HashedPC pc _) = pc++mapHashedPC :: (PathCond -> PathCond) -> HashedPathCond -> HashedPathCond+mapHashedPC f (HashedPC pc _) = hashedPC (f pc)++instance Eq HashedPathCond where+ HashedPC pc h == HashedPC pc' h' = if h /= h' then False else pc == pc'++instance Hashable HashedPathCond where+ hashWithSalt s (HashedPC _ h) = s `hashWithSalt` h+ hash (HashedPC _ h) = h++instance ASTContainer HashedPathCond Expr where+ containedASTs = containedASTs . unhashedPC+ modifyContainedASTs f = mapHashedPC (modifyContainedASTs f)++instance ASTContainer HashedPathCond Type where+ containedASTs = containedASTs . unhashedPC+ modifyContainedASTs f = mapHashedPC (modifyContainedASTs f)++instance Named HashedPathCond where+ names = names . unhashedPC+ rename old new = mapHashedPC (rename old new)+ renames hm = mapHashedPC (renames hm)++instance Ided HashedPathCond where+ ids = ids . unhashedPC++mkAssumePC :: Id -> Integer -> HS.HashSet HashedPathCond -> PathCond+mkAssumePC i n = AssumePC i n++mkSingletonAssumePC :: Id -> Integer -> PathCond -> PathCond+mkSingletonAssumePC i n = AssumePC i n . HS.singleton . hashedPC
src/G2/Language/Primitives.hs view
@@ -1,177 +1,99 @@-{-# LANGUAGE OverloadedStrings #-}+module G2.Language.Primitives ( mkGe+ , mkGt+ , mkEq+ , mkNeq+ , mkLt+ , mkLe+ , mkAnd+ , mkOr+ , mkNot+ , mkPlus+ , mkMinus+ , mkMult+ , mkDiv+ , mkMod+ , mkNegate+ , mkImplies+ , mkIff+ , mkFromInteger+ , mkToInteger+ , mkEqPrimInt+ , mkEqPrimFloat+ , mkEqPrimDouble+ , mkEqPrimChar+ , mkAndPrim+ , mkGePrimInt+ , mkLePrimInt -module G2.Language.Primitives where+ , mkEqPrimType+ , mkOrPrim+ , mkImpliesPrim+ , mkNotPrim+ + , mkStringAppend+ , mkStringLen) where import qualified G2.Language.ExprEnv as E import G2.Language.KnownValues as KV import G2.Language.Syntax-import G2.Language.Typing--import Data.Foldable-import qualified Data.Text as T--primStr :: Primitive -> T.Text-primStr Ge = ">="-primStr Gt = ">"-primStr Eq = "=="-primStr Neq = "/="-primStr Lt = "<"-primStr Le = "<="-primStr And = "&&"-primStr Or = "||"-primStr Not = "not"-primStr Implies = "implies"-primStr Iff = "iff"-primStr Plus = "+"-primStr Minus = "-"-primStr Mult = "*"-primStr Div = "/"-primStr DivInt = "/"-primStr Quot = "quot"-primStr Mod = "mod"-primStr Negate = "negate"-primStr SqRt = "sqrt"-primStr IntToFloat = "fromIntegral"-primStr IntToDouble = "fromIntegral"-primStr FromInteger = "fromInteger"-primStr ToInteger = "toInteger"-primStr ToInt = "toInt"-primStr Error = "error"-primStr Undefined = "undefined"-primStr BindFunc = "BindFunc"--strToPrim :: T.Text -> Maybe Primitive-strToPrim "not" = Just Not-strToPrim "&&" = Just And-strToPrim "||" = Just Or-strToPrim ">=" = Just Ge-strToPrim ">" = Just Gt-strToPrim "==" = Just Eq-strToPrim "/=" = Just Neq-strToPrim "<=" = Just Le-strToPrim "<" = Just Lt-strToPrim "+" = Just Plus-strToPrim "-" = Just Minus-strToPrim "*" = Just Mult-strToPrim "quot" = Just Quot-strToPrim "/" = Just Div-strToPrim "mod" = Just Mod-strToPrim "negate" = Just Negate-strToPrim "sqrt" = Just SqRt-strToPrim "error" = Just Error-strToPrim "implies" = Just Implies-strToPrim "iff" = Just Iff-strToPrim _ = Nothing--findPrim :: Primitive -> [(Name, Type)] -> (Name, Type)-findPrim prim [] = error $ "findPrim: not found: " ++ (T.unpack $ primStr prim)-findPrim prim (p@(Name occ _ _ _, _):ps) =- if primStr prim == occ then p else findPrim prim ps--mkRawPrim :: [(Name, Type)] -> Name -> Expr-mkRawPrim primtys name@(Name occ _ _ _) = - case prim of- Just _ -> foldr (Lam TypeL) cases ids- Nothing -> Prim Undefined TyBottom- where- prim = strToPrim occ-- ty = snd . head $ filter (\p -> name == fst p) primtys- (forall_ids, ty') = splitTyForAlls ty- fun_tys = splitTyFuns ty'-- tys = (map typeOf forall_ids) ++ fun_tys-- ids = map (\(i, t) -> Id (Name "a" Nothing i Nothing) t) $ zip [1..] (init tys)- binds = map (\(i, t) -> Id (Name "b" Nothing i Nothing) t) $ zip [1..] (init tys)-- varIds = map Var ids- varBinds = map Var binds-- apps = foldl' App (Prim (case prim of- Just p -> p- Nothing -> error $ "PRIM = " ++ show prim) ty) varBinds-- cases = foldr (\(i, b) e -> Case i b [Alt Default e]) apps (zip varIds binds)---- | Primitive lookup helpers--mkPrim :: Primitive -> E.ExprEnv -> Expr-mkPrim p eenv = case (inClasses, inNum, inPrelude, inClasses2, inBase2, inReal) of- (Just e, _, _, _, _, _) -> e- (_, Just e, _, _, _, _) -> e- (_, _, Just e, _, _, _) -> e- (_, _, _, Just e, _, _) -> e- (_, _, _, _, Just e, _) -> e- (_, _, _, _, _, Just e) -> e- _ -> error $ "Unrecognized prim " ++ show p ++ " " ++ show (primStr p)- where- inClasses = E.occLookup (primStr p) (Just "GHC.Classes") eenv- inNum = E.occLookup (primStr p) (Just "GHC.Num") eenv- inPrelude = E.occLookup (primStr p) (Just "Prelude") eenv- inClasses2 = E.occLookup (primStr p) (Just "GHC.Classes2") eenv- inBase2 = E.occLookup (primStr p) (Just "GHC.Base2") eenv- inReal = E.occLookup (primStr p) (Just "GHC.Real") eenv--mkGe :: E.ExprEnv -> Expr-mkGe = mkPrim Ge+import qualified G2.Language.Typing as T -mkGt :: E.ExprEnv -> Expr-mkGt = mkPrim Gt+mkGe :: KnownValues -> E.ExprEnv -> Expr+mkGe kv eenv = eenv E.! (geFunc kv) -mkEq :: E.ExprEnv -> Expr-mkEq = mkPrim Eq+mkGt :: KnownValues -> E.ExprEnv -> Expr+mkGt kv eenv = eenv E.! (gtFunc kv) -mkEq' :: KnownValues -> Expr-mkEq' kv = Var (Id (eqFunc kv) TyBottom)+mkEq :: KnownValues -> E.ExprEnv -> Expr+mkEq kv eenv = eenv E.! (eqFunc kv) -mkNeq :: E.ExprEnv -> Expr-mkNeq = mkPrim Neq+mkNeq :: KnownValues -> E.ExprEnv -> Expr+mkNeq kv eenv = eenv E.! (neqFunc kv) -mkLt :: E.ExprEnv -> Expr-mkLt = mkPrim Lt+mkLt :: KnownValues -> E.ExprEnv -> Expr+mkLt kv eenv = eenv E.! (ltFunc kv) -mkLe :: E.ExprEnv -> Expr-mkLe = mkPrim Le+mkLe :: KnownValues -> E.ExprEnv -> Expr+mkLe kv eenv = eenv E.! (leFunc kv) -mkAnd :: E.ExprEnv -> Expr-mkAnd = mkPrim And+mkAnd :: KnownValues -> E.ExprEnv -> Expr+mkAnd kv eenv = eenv E.! (andFunc kv) -mkOr :: E.ExprEnv -> Expr-mkOr = mkPrim Or+mkOr :: KnownValues -> E.ExprEnv -> Expr+mkOr kv eenv = eenv E.! (orFunc kv) -mkNot :: E.ExprEnv -> Expr-mkNot = mkPrim Not+mkNot :: KnownValues -> E.ExprEnv -> Expr+mkNot kv eenv = eenv E.! (notFunc kv) -mkPlus :: E.ExprEnv -> Expr-mkPlus = mkPrim Plus+mkPlus :: KnownValues -> E.ExprEnv -> Expr+mkPlus kv eenv = eenv E.! (plusFunc kv) -mkMinus :: E.ExprEnv -> Expr-mkMinus = mkPrim Minus+mkMinus :: KnownValues -> E.ExprEnv -> Expr+mkMinus kv eenv = eenv E.! (minusFunc kv) -mkMult :: E.ExprEnv -> Expr-mkMult = mkPrim Mult+mkMult :: KnownValues -> E.ExprEnv -> Expr+mkMult kv eenv = eenv E.! (timesFunc kv) -mkDiv :: E.ExprEnv -> Expr-mkDiv = mkPrim Div+mkDiv :: KnownValues -> E.ExprEnv -> Expr+mkDiv kv eenv = eenv E.! (divFunc kv) -mkMod :: E.ExprEnv -> Expr-mkMod = mkPrim Mod+mkMod :: KnownValues -> E.ExprEnv -> Expr+mkMod kv eenv = eenv E.! (modFunc kv) -mkNegate :: E.ExprEnv -> Expr-mkNegate = mkPrim Negate+mkNegate :: KnownValues -> E.ExprEnv -> Expr+mkNegate kv eenv = eenv E.! (negateFunc kv) -mkImplies :: E.ExprEnv -> Expr-mkImplies = mkPrim Implies+mkImplies :: KnownValues -> E.ExprEnv -> Expr+mkImplies kv eenv = eenv E.! (impliesFunc kv) -mkIff :: E.ExprEnv -> Expr-mkIff = mkPrim Iff+mkIff :: KnownValues -> E.ExprEnv -> Expr+mkIff kv eenv = eenv E.! (iffFunc kv) -mkFromInteger :: E.ExprEnv -> Expr-mkFromInteger = mkPrim FromInteger+mkFromInteger :: KnownValues -> E.ExprEnv -> Expr+mkFromInteger kv eenv = eenv E.! (fromIntegerFunc kv) -mkToInteger :: E.ExprEnv -> Expr-mkToInteger = mkPrim ToInteger+mkToInteger :: KnownValues -> E.ExprEnv -> Expr+mkToInteger kv eenv = eenv E.! (toIntegerFunc kv) -- Primitives on primitive types mkEqPrimType :: Type -> KnownValues -> Expr@@ -189,3 +111,37 @@ mkEqPrimChar :: KnownValues -> Expr mkEqPrimChar = mkEqPrimType TyLitChar++mkGePrimInt :: KnownValues -> Expr+mkGePrimInt kv = Prim Ge $ TyFun t (TyFun t (TyCon (KV.tyBool kv) TYPE))+ where+ t = TyLitInt++mkLePrimInt :: KnownValues -> Expr+mkLePrimInt kv = Prim Le $ TyFun t (TyFun t (TyCon (KV.tyBool kv) TYPE))+ where+ t = TyLitInt++mkAndPrim :: KnownValues -> Expr+mkAndPrim kv = Prim And $ TyFun t (TyFun t (TyCon (KV.tyBool kv) TYPE))+ where t = (TyCon (KV.tyBool kv) TYPE)++mkOrPrim :: KnownValues -> Expr+mkOrPrim kv = Prim Or $ TyFun t (TyFun t (TyCon (KV.tyBool kv) TYPE))+ where t = (TyCon (KV.tyBool kv) TYPE)++mkNotPrim :: KnownValues -> Expr+mkNotPrim kv = Prim Not $ TyFun t (TyCon (KV.tyBool kv) TYPE)+ where t = (TyCon (KV.tyBool kv) TYPE)++mkImpliesPrim :: KnownValues -> Expr+mkImpliesPrim kv = Prim Implies $ TyFun t (TyFun t t)+ where t = (TyCon (KV.tyBool kv) TYPE)++mkStringAppend :: KnownValues -> Expr+mkStringAppend kv = Prim StrAppend $ TyFun t (TyFun t t)+ where t = TyApp (T.tyList kv) (T.tyChar kv)++mkStringLen :: KnownValues -> Expr+mkStringLen kv = Prim StrLen $ TyFun t TyLitInt+ where t = TyApp (T.tyList kv) (T.tyChar kv)
+ src/G2/Language/Simplification.hs view
@@ -0,0 +1,97 @@+-- Semantics-preserving syntactic transformations++{-# LANGUAGE FlexibleContexts #-}++module G2.Language.Simplification ( simplifyExprs+ , simplifyAppLambdas+ , inlineFunc+ , inlineFuncInCase) where++import G2.Language.AST+import G2.Language.Expr+import qualified G2.Language.ExprEnv as E+import G2.Language.Syntax+import G2.Language.Typing++import Data.List++simplifyExprs :: ASTContainer t Expr => E.ExprEnv -> E.ExprEnv -> t -> t+simplifyExprs eenv c_eenv = modifyContainedASTs (simplifyExpr eenv c_eenv)++simplifyExpr :: E.ExprEnv -> E.ExprEnv -> Expr -> Expr+simplifyExpr eenv c_eenv e =+ let+ e' = simplifyAppLambdas $ e+ -- e' = caseOfKnownCons+ -- . inlineFuncInCase c_eenv+ -- . inlineFunc eenv+ -- . simplifyAppLambdas $ e+ in+ if e == e' then e else simplifyExpr eenv c_eenv e'++-- | Reduce Lambdas that are being passed variables or values in SWHNF.+-- This AVOIDS reducing a lamba if it could cause us to miss an opportunity for sharing.+simplifyAppLambdas :: Expr -> Expr+simplifyAppLambdas (App (Lam TermL i e) e')+ | safeToInline e' = simplifyAppLambdas $ replaceVar (idName i) e' e+simplifyAppLambdas (App (Lam TypeL i e) (Var i')) =+ simplifyAppLambdas $ retype i (TyVar i') e+simplifyAppLambdas (App (Lam TypeL i e) (Type t)) =+ simplifyAppLambdas $ retype i t e+simplifyAppLambdas e@(App (App _ _) _) =+ let+ e' = modifyChildren simplifyAppLambdas e+ in+ if e == e' then e else simplifyAppLambdas e'+simplifyAppLambdas e = modifyChildren simplifyAppLambdas e++safeToInline :: Expr -> Bool+safeToInline (Var _) = True+safeToInline (Lit _) = True+safeToInline e@(App _ _) | Data _:_ <- unApp e = True+safeToInline e@(App _ _) | Prim _ _:_ <- unApp e = True+safeToInline _ = False++-- | Inline the functions in the ExprEnv+inlineFunc :: E.ExprEnv -> Expr -> Expr+inlineFunc eenv v@(Var (Id n _))+ | Just e <- E.lookup n eenv = inlineFunc eenv e+ | otherwise = v+inlineFunc eenv e =+ modifyChildren (inlineFunc eenv) e++-- | Inline the functions in the ExprEnv, if they are the bindee in a Case expression+inlineFuncInCase :: E.ExprEnv -> Expr -> Expr+inlineFuncInCase eenv c@(Case (Var (Id n _)) i t as)+ | Just e <- E.lookup n eenv =+ inlineFuncInCase eenv $ Case e i t as+ | otherwise = c+inlineFuncInCase eenv e =+ modifyChildren (inlineFuncInCase eenv) e++caseOfKnownCons :: Expr -> Expr+caseOfKnownCons (Case e i _ as)+ | Data (DataCon n t):es <- unApp e+ , Just (Alt (DataAlt _ is) ae) <- find (matchingDataAlt n) as =+ let+ tfa_count = length (leadingTyForAllBindings $ PresType t)+ es' = drop tfa_count es+ in+ foldr (uncurry replaceVar) (replaceVar (idName i) e ae) (zip (map idName is) es')+ | Lit l:_ <- unApp e+ , Just (Alt (LitAlt _) ae) <- find (matchingLitAlt l) as = replaceVar (idName i) e ae+ + | Data _:_ <- unApp e+ , Just (Alt Default ae) <- find (\(Alt am _) -> am == Default) as = replaceVar (idName i) e ae+ | Lit l:_ <- unApp e+ , Just (Alt Default ae) <- find (\(Alt am _) -> am == Default) as = replaceVar (idName i) e ae++caseOfKnownCons e = modifyChildren caseOfKnownCons e++matchingDataAlt :: Name -> Alt -> Bool+matchingDataAlt n (Alt (DataAlt (DataCon n' _) _) _) = n == n'+matchingDataAlt _ _ = False++matchingLitAlt :: Lit -> Alt -> Bool+matchingLitAlt l (Alt (LitAlt l') _) = l == l'+matchingLitAlt _ _ = False
src/G2/Language/Stack.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}@@ -8,19 +9,23 @@ , null , push , pop- , popN- , toList) where+ , toList+ , filter) where -import Prelude hiding (null)+import Prelude hiding (null, filter)+import GHC.Generics (Generic) import Data.Data (Data, Typeable)+import Data.Hashable import qualified Data.List as L import G2.Language.AST import G2.Language.Naming import G2.Language.Syntax -newtype Stack a = Stack [a] deriving (Show, Eq, Read, Typeable, Data)+newtype Stack a = Stack [a] deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable a => Hashable (Stack a)+ -- | Get an empty `Stack`. empty :: Stack a empty = Stack []@@ -29,30 +34,21 @@ null :: Stack a -> Bool null = L.null . toList --- | Push a `Frame` onto the `Stack`.+-- | Push a value onto the `Stack`. push :: a -> Stack a -> Stack a push x (Stack xs) = Stack (x : xs) --- | Pop a `Frame` from the `Stack`, should it exist.+-- | Pop a value from the `Stack`, should it exist. pop :: Stack a -> Maybe (a, Stack a) pop (Stack []) = Nothing pop (Stack (x:xs)) = Just (x, Stack xs) --- | Pop @n@ frames from the `Stack`, or, if the `Stack` has less than @n@--- frames, empty the `Stack`.-popN :: Stack a -> Int -> ([a], Stack a)-popN s 0 = ([], s)-popN s n = case pop s of- Just (x, s') -> - let- (xs, s'') = popN s' (n - 1)- in- (x:xs, s'')- Nothing -> ([], s)- -- | Convert a `Stack` to a list. toList :: Stack a -> [a] toList (Stack xs) = xs++filter :: (a -> Bool) -> Stack a -> Stack a+filter p (Stack stck) = Stack (L.filter p stck) instance ASTContainer a Expr => ASTContainer (Stack a) Expr where containedASTs (Stack s) = containedASTs s
src/G2/Language/Support.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}@@ -20,7 +21,7 @@ import qualified G2.Language.ExprEnv as E import G2.Language.KnownValues import G2.Language.Naming-import G2.Language.Stack+import G2.Language.Stack hiding (filter) import G2.Language.Syntax import G2.Language.TypeClasses import G2.Language.TypeEnv@@ -28,41 +29,50 @@ import G2.Language.PathConds hiding (map, filter) import G2.Execution.RuleTypes +import GHC.Generics (Generic) import Data.Data (Data, Typeable)+import Data.Hashable import qualified Data.Map as M import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as S+import Data.Monoid ((<>))+import qualified Data.Sequence as S import qualified Data.Text as T --- | The State is passed around in G2. It can be utilized to--- perform defunctionalization, execution, and SMT solving.+-- | `State`s represent an execution state of some (symbolic) Haskell code.+-- A state can be utilized to perform execution and SMT solving. -- The t parameter can be used to track extra information during the execution.-data State t = State { expr_env :: E.ExprEnv- , type_env :: TypeEnv- , curr_expr :: CurrExpr+data State t = State { expr_env :: E.ExprEnv -- ^ Mapping of `Name`s to `Expr`s+ , type_env :: TypeEnv -- ^ Type information+ , curr_expr :: CurrExpr -- ^ The expression represented by the state , path_conds :: PathConds -- ^ Path conditions, in SWHNF- , non_red_path_conds :: [Expr] -- ^ Path conditions that still need further reduction+ , non_red_path_conds :: [(Expr, Expr)] -- ^ Path conditions, in the form of (possibly non-reduced)+ -- expression pairs that must be proved equivalent , true_assert :: Bool -- ^ Have we violated an assertion? , assert_ids :: Maybe FuncCall , type_classes :: TypeClasses- , symbolic_ids :: SymbolicIds , exec_stack :: Stack Frame , model :: Model , known_values :: KnownValues , rules :: ![Rule] , num_steps :: !Int -- Invariant: The length of the rules list , tags :: S.HashSet Name -- ^ Allows attaching tags to a State, to identify it later+ , sym_gens :: S.Seq Name -- ^ Variable names generated by logging `SymGen`s , track :: t- } deriving (Show, Eq, Read, Typeable, Data)+ } deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable t => Hashable (State t)++-- | Global information, shared between all `State`s. data Bindings = Bindings { deepseq_walkers :: Walkers , fixed_inputs :: [Expr] , arb_value_gen :: ArbValueGen , cleaned_names :: CleanedNames- , higher_order_inst :: [Name] -- ^ Functions to try instantiating higher order functions with+ , higher_order_inst :: S.HashSet Name -- ^ Functions to try instantiating higher order functions with , input_names :: [Name] , rewrite_rules :: ![RewriteRule] , name_gen :: NameGen+ , exported_funcs :: [Name] } deriving (Show, Eq, Read, Typeable, Data) -- | The `InputIds` are a list of the variable names passed as input to the@@ -75,14 +85,16 @@ Just e -> Id n (typeOf e) Nothing -> error "inputIds: Name not found in ExprEnv") ns --- | The `SymbolicIds` are a list of the variable names that we should ensure are--- inserted in the model, after we solve the path constraints-type SymbolicIds = [Id]- -- | `CurrExpr` is the current expression we have. data CurrExpr = CurrExpr EvalOrReturn Expr- deriving (Show, Eq, Read, Typeable, Data)+ deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable CurrExpr++-- | Gets the `Expr` represented by a state.+getExpr :: State t -> Expr+getExpr (State { curr_expr = CurrExpr _ e }) = e+ -- | Tracks whether the `CurrExpr` is being evaluated, or if -- it is in some terminal form that is simply returned. Technically we do not -- need to make this distinction, and could simply call a `isTerm` function@@ -90,9 +102,12 @@ -- evaluation code. data EvalOrReturn = Evaluate | Return- deriving (Show, Eq, Read, Typeable, Data)+ deriving (Show, Eq, Read, Generic, Typeable, Data) --- Used to map names (typically of ADTs) to corresponding autogenerated function names+instance Hashable EvalOrReturn++-- | Used to map names of `Type`s to corresponding autogenerated functions+-- that force that `Type` to be evaluated. type Walkers = M.Map Name Id -- Map new names to old ones@@ -105,65 +120,47 @@ , boolGen :: Bool } deriving (Show, Eq, Read, Typeable, Data) --- | Naive expression lookup by only the occurrence name string.-naiveLookup :: T.Text -> E.ExprEnv -> [(Name, Expr)]-naiveLookup key = filter (\(Name occ _ _ _, _) -> occ == key) . E.toExprList---- | These are stack frames. They are used to guide evaluation.-data Frame = CaseFrame Id [Alt]+-- | These are stack frames that are used to guide evaluation.+data Frame = CaseFrame Id Type [Alt] | ApplyFrame Expr | UpdateFrame Name | CastFrame Coercion- | CurrExprFrame CurrExpr+ | CurrExprFrame CEAction CurrExpr | AssumeFrame Expr | AssertFrame (Maybe FuncCall) Expr- deriving (Show, Eq, Read, Typeable, Data)+ deriving (Show, Eq, Read, Generic, Typeable, Data) +instance Hashable Frame++-- | What to do with the current expression when a @CurrExprFrame@ reaches the+-- top of the stack and it is time to replace the `curr_expr`.+data CEAction = EnsureEq Expr -- ^ `EnsureEq e1` means that we should check if the `curr_expr` is equal to `e1`+ | NoAction -- ^ Just replace the curr_expr, no other actions are needed+ deriving (Show, Eq, Read, Generic, Typeable, Data)++instance Hashable CEAction+ -- | A model is a mapping of symbolic variable names to `Expr`@s@, -- typically produced by a solver. -type Model = M.Map Name Expr---- | Replaces all of the names old in state with a name seeded by new_seed-renameState :: Named t => Name -> Name -> State t -> Bindings -> (State t, Bindings)-renameState old new_seed s b =- let (new, ng') = freshSeededName new_seed (name_gen b)- in (State { expr_env = rename old new (expr_env s)- , type_env =- M.mapKeys (\k -> if k == old then new else k)- $ rename old new (type_env s)- , curr_expr = rename old new (curr_expr s)- , path_conds = rename old new (path_conds s)- , non_red_path_conds = rename old new (non_red_path_conds s)- , true_assert = true_assert s- , assert_ids = rename old new (assert_ids s)- , type_classes = rename old new (type_classes s)- , symbolic_ids = rename old new (symbolic_ids s)- , exec_stack = exec_stack s- , model = model s- , known_values = rename old new (known_values s)- , rules = rules s- , num_steps = num_steps s- , track = rename old new (track s)- , tags = tags s }- , b { name_gen = ng'})+type Model = HM.HashMap Name Expr instance Named t => Named (State t) where names s = names (expr_env s)- ++ names (type_env s)- ++ names (curr_expr s)- ++ names (path_conds s)- ++ names (assert_ids s)- ++ names (type_classes s)- ++ names (symbolic_ids s)- ++ names (exec_stack s)- ++ names (model s)- ++ names (known_values s)- ++ names (track s)+ <> names (type_env s)+ <> names (curr_expr s)+ <> names (path_conds s)+ <> names (assert_ids s)+ <> names (type_classes s)+ <> names (exec_stack s)+ <> names (model s)+ <> names (known_values s)+ <> names (track s)+ <> names (sym_gens s) rename old new s = State { expr_env = rename old new (expr_env s) , type_env =- M.mapKeys (\k -> if k == old then new else k)+ HM.mapKeys (\k -> if k == old then new else k) $ rename old new (type_env s) , curr_expr = rename old new (curr_expr s) , path_conds = rename old new (path_conds s)@@ -171,19 +168,19 @@ , true_assert = true_assert s , assert_ids = rename old new (assert_ids s) , type_classes = rename old new (type_classes s)- , symbolic_ids = rename old new (symbolic_ids s) , exec_stack = rename old new (exec_stack s) , model = rename old new (model s) , known_values = rename old new (known_values s) , rules = rules s , num_steps = num_steps s , track = rename old new (track s)+ , sym_gens = rename old new (sym_gens s) , tags = tags s } renames hm s = State { expr_env = renames hm (expr_env s) , type_env =- M.mapKeys (renames hm)+ HM.mapKeys (renames hm) $ renames hm (type_env s) , curr_expr = renames hm (curr_expr s) , path_conds = renames hm (path_conds s)@@ -191,13 +188,13 @@ , true_assert = true_assert s , assert_ids = renames hm (assert_ids s) , type_classes = renames hm (type_classes s)- , symbolic_ids = renames hm (symbolic_ids s) , exec_stack = renames hm (exec_stack s) , model = renames hm (model s) , known_values = renames hm (known_values s) , rules = rules s , num_steps = num_steps s , track = renames hm (track s)+ , sym_gens = renames hm (sym_gens s) , tags = tags s } instance ASTContainer t Expr => ASTContainer (State t) Expr where@@ -206,18 +203,20 @@ (containedASTs $ curr_expr s) ++ (containedASTs $ path_conds s) ++ (containedASTs $ assert_ids s) ++- (containedASTs $ symbolic_ids s) ++ (containedASTs $ exec_stack s) ++- (containedASTs $ track s)+ (containedASTs $ track s) ++ + (containedASTs $ sym_gens s) +++ (containedASTs $ rules s) modifyContainedASTs f s = s { type_env = modifyContainedASTs f $ type_env s , expr_env = modifyContainedASTs f $ expr_env s , curr_expr = modifyContainedASTs f $ curr_expr s , path_conds = modifyContainedASTs f $ path_conds s , assert_ids = modifyContainedASTs f $ assert_ids s- , symbolic_ids = modifyContainedASTs f $ symbolic_ids s , exec_stack = modifyContainedASTs f $ exec_stack s- , track = modifyContainedASTs f $ track s }+ , track = modifyContainedASTs f $ track s + , sym_gens = modifyContainedASTs f $ sym_gens s + , rules = modifyContainedASTs f $ rules s } instance ASTContainer t Type => ASTContainer (State t) Type where containedASTs s = ((containedASTs . expr_env) s) ++@@ -226,9 +225,10 @@ ((containedASTs . path_conds) s) ++ ((containedASTs . assert_ids) s) ++ ((containedASTs . type_classes) s) ++- ((containedASTs . symbolic_ids) s) ++ ((containedASTs . exec_stack) s) ++- (containedASTs $ track s)+ (containedASTs $ track s) ++ + (containedASTs $ sym_gens s) +++ (containedASTs $ rules s) modifyContainedASTs f s = s { type_env = (modifyContainedASTs f . type_env) s , expr_env = (modifyContainedASTs f . expr_env) s@@ -236,16 +236,19 @@ , path_conds = (modifyContainedASTs f . path_conds) s , assert_ids = (modifyContainedASTs f . assert_ids) s , type_classes = (modifyContainedASTs f . type_classes) s- , symbolic_ids = (modifyContainedASTs f . symbolic_ids) s , exec_stack = (modifyContainedASTs f . exec_stack) s- , track = modifyContainedASTs f $ track s }+ , track = modifyContainedASTs f $ track s + , sym_gens = modifyContainedASTs f $ sym_gens s + , rules = modifyContainedASTs f $ rules s } instance Named Bindings where names b = names (fixed_inputs b)- ++ names (deepseq_walkers b)- ++ names (cleaned_names b)- ++ names (higher_order_inst b)- ++ names (input_names b)+ <> names (deepseq_walkers b)+ <> names (cleaned_names b)+ <> names (higher_order_inst b)+ <> names (input_names b)+ <> names (exported_funcs b)+ <> names (rewrite_rules b) rename old new b = Bindings { fixed_inputs = rename old new (fixed_inputs b)@@ -256,6 +259,7 @@ , input_names = rename old new (input_names b) , rewrite_rules = rename old new (rewrite_rules b) , name_gen = name_gen b+ , exported_funcs = rename old new (exported_funcs b) } renames hm b =@@ -267,6 +271,7 @@ , input_names = renames hm (input_names b) , rewrite_rules = renames hm (rewrite_rules b) , name_gen = name_gen b+ , exported_funcs = renames hm (exported_funcs b) } instance ASTContainer Bindings Expr where@@ -290,32 +295,32 @@ modifyContainedASTs f (CurrExpr er e) = CurrExpr er (modifyContainedASTs f e) instance ASTContainer Frame Expr where- containedASTs (CaseFrame _ a) = containedASTs a+ containedASTs (CaseFrame _ _ a) = containedASTs a containedASTs (ApplyFrame e) = [e]- containedASTs (CurrExprFrame e) = containedASTs e+ containedASTs (CurrExprFrame _ e) = containedASTs e containedASTs (AssumeFrame e) = [e] containedASTs (AssertFrame _ e) = [e] containedASTs _ = [] - modifyContainedASTs f (CaseFrame i a) = CaseFrame i (modifyContainedASTs f a)+ modifyContainedASTs f (CaseFrame i t a) = CaseFrame i t (modifyContainedASTs f a) modifyContainedASTs f (ApplyFrame e) = ApplyFrame (f e)- modifyContainedASTs f (CurrExprFrame e) = CurrExprFrame (modifyContainedASTs f e)+ modifyContainedASTs f (CurrExprFrame act e) = CurrExprFrame act (modifyContainedASTs f e) modifyContainedASTs f (AssumeFrame e) = AssumeFrame (f e) modifyContainedASTs f (AssertFrame is e) = AssertFrame is (f e) modifyContainedASTs _ fr = fr instance ASTContainer Frame Type where- containedASTs (CaseFrame i a) = containedASTs i ++ containedASTs a+ containedASTs (CaseFrame i t a) = containedASTs i ++ containedASTs t ++ containedASTs a containedASTs (ApplyFrame e) = containedASTs e- containedASTs (CurrExprFrame e) = containedASTs e+ containedASTs (CurrExprFrame _ e) = containedASTs e containedASTs (AssumeFrame e) = containedASTs e containedASTs (AssertFrame _ e) = containedASTs e containedASTs _ = [] - modifyContainedASTs f (CaseFrame i a) =- CaseFrame (modifyContainedASTs f i) (modifyContainedASTs f a)+ modifyContainedASTs f (CaseFrame i t a) =+ CaseFrame (modifyContainedASTs f i) (f t) (modifyContainedASTs f a) modifyContainedASTs f (ApplyFrame e) = ApplyFrame (modifyContainedASTs f e)- modifyContainedASTs f (CurrExprFrame e) = CurrExprFrame (modifyContainedASTs f e)+ modifyContainedASTs f (CurrExprFrame act e) = CurrExprFrame act (modifyContainedASTs f e) modifyContainedASTs f (AssumeFrame e) = AssumeFrame (modifyContainedASTs f e) modifyContainedASTs f (AssertFrame is e) = AssertFrame (modifyContainedASTs f is) (modifyContainedASTs f e) modifyContainedASTs _ fr = fr@@ -326,26 +331,26 @@ renames hm (CurrExpr er e) = CurrExpr er $ renames hm e instance Named Frame where- names (CaseFrame i a) = names i ++ names a+ names (CaseFrame i t a) = names i <> names t <> names a names (ApplyFrame e) = names e- names (UpdateFrame n) = [n]+ names (UpdateFrame n) = names n names (CastFrame c) = names c- names (CurrExprFrame e) = names e+ names (CurrExprFrame _ e) = names e names (AssumeFrame e) = names e- names (AssertFrame is e) = names is ++ names e+ names (AssertFrame is e) = names is <> names e - rename old new (CaseFrame i a) = CaseFrame (rename old new i) (rename old new a)+ rename old new (CaseFrame i t a) = CaseFrame (rename old new i) (rename old new t) (rename old new a) rename old new (ApplyFrame e) = ApplyFrame (rename old new e) rename old new (UpdateFrame n) = UpdateFrame (rename old new n) rename old new (CastFrame c) = CastFrame (rename old new c)- rename old new (CurrExprFrame e) = CurrExprFrame (rename old new e)+ rename old new (CurrExprFrame act e) = CurrExprFrame act (rename old new e) rename old new (AssumeFrame e) = AssumeFrame (rename old new e) rename old new (AssertFrame is e) = AssertFrame (rename old new is) (rename old new e) - renames hm (CaseFrame i a) = CaseFrame (renames hm i) (renames hm a)+ renames hm (CaseFrame i t a) = CaseFrame (renames hm i) (renames hm t) (renames hm a) renames hm (ApplyFrame e) = ApplyFrame (renames hm e) renames hm (UpdateFrame n) = UpdateFrame (renames hm n) renames hm (CastFrame c) = CastFrame (renames hm c)- renames hm (CurrExprFrame e) = CurrExprFrame (renames hm e)+ renames hm (CurrExprFrame act e) = CurrExprFrame act (renames hm e) renames hm (AssumeFrame e) = AssumeFrame (renames hm e) renames hm (AssertFrame is e) = AssertFrame (renames hm is) (renames hm e)
src/G2/Language/Syntax.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} --- Defines most of the central language in G2. This language closely resembles Core Haskell.--- The central datatypes are `Expr` and `Type`.+-- | Defines most of the central language in G2. This language closely resembles Core Haskell.+-- The central datatypes are `Expr` and t`Type`.+ module G2.Language.Syntax ( module G2.Language.Syntax ) where@@ -11,11 +12,7 @@ import Data.Data import Data.Hashable import qualified Data.Text as T---- | The native GHC definition states that a `Program` is a list of `Binds`.--- This is used only in the initial stages of the translation from GHC Core.--- We quickly shift to using a `State`.-type Program = [Binds]+import qualified GHC.Generics as GHC -- | Binds `Id`s to `Expr`s, primarily in @let@ `Expr`s type Binds = [(Id, Expr)]@@ -56,8 +53,8 @@ n `hashWithSalt` m `hashWithSalt` i --- | Pairing of a `Name` with a `Type`-data Id = Id Name Type deriving (Show, Eq, Read, Generic, Typeable, Data)+-- | Pairing of a `Name` with a t`Type`+data Id = Id Name Type deriving (Show, Eq, Read, Generic, Typeable, Data, Ord) instance Hashable Id @@ -68,80 +65,84 @@ instance Hashable LamUse +-- | Extract the `Name` from an `Id`. idName :: Id -> Name idName (Id name _) = name- -{-| This is the main data type for our expression language. - 1. @`Var` `Id`@ is a variable. Variables may be bound by a `Lam`, `Let`- or `Case` `Expr`, or be bound in the `ExprEnv`. A variable may also be- free (unbound), in which case it is symbolic-- 2. @`Lit` `Lit`@ denotes a literal.-- 3. @`Data` `DataCon`@ denotes a Data Constructor-- 4. @`App` `Expr` `Expr`@ denotes function application.- For example, the function call:-- @ f x y @- would be represented as-- @ `App`- (`App`- (`Var` (`Id` (`Name` "f" Nothing 0 Nothing) (`TyFun` t (`TyFun` t t))))- (`Var` (`Id` (`Name` "x" Nothing 0 Nothing) t))- )- (`Var` (`Id` (`Name` "y" Nothing 0 Nothing) t)) @-- 5. @`Lam` `LamUse` `Id` `Expr`@ denotes a lambda function.- The `Id` is bound in the `Expr`.- This binding may be on the type type or term level, depending on the `LamUse`.-- 6. @`Case` e i as@ splits into multiple `Alt`s (Alternatives),- Depending on the value of @e@. In each Alt, the `Id` @i@ is bound to @e@.- The `Alt`s must always be exhaustive- there should never be a case where no `Alt`- can match a given `Expr`.-- 7. @`Type` `Type`@ gives a `Expr` level representation of a `Type`.- These only ever appear as the arguments to polymorphic functions,- to determine the `Type` bound to type level variables.-- 8. @`Cast` e (t1 `:~` t2)@ casts @e@ from the type @t1@ to @t2@- This requires that @t1@ and @t2@ have the same representation.-- 9. @`Coercion` `Coercion`@ allows runtime passing of `Coercion`s to `Cast`s.-- 10. @`Tick` `Tickish` `Expr`@ records some extra information into an `Expr`.-- 11. @`NonDet` [`Expr`] gives a nondeterministic choice between multiple options- to continue execution with.-- 12. @`SymGen` `Type`@ evaluates to a fresh symbolic variable of the given type.+-- | The `sym_gens` field of a `State` is used to record the values generated by certain `SymGen`s.+-- This allows us to track, and eventually print to display to the user, values generated by (certain) `SymGen`s.+-- `SymGen`s tagged with `SLog` are logged, i.e. will be recorded in the `sym_gens` field. Those tagged by `SNoLog` are not logged.+data SymLog = SLog | SNoLog+ deriving (Show, Eq, Read, Generic, Typeable, Data) - 13. @`Assume` b e@ takes a boolean typed expression @b@,- and an expression of arbitrary type @e@.- During exectuion, @b@ is reduced to SWHNF, and assumed.- Then, execution continues with @b@.+instance Hashable SymLog - 14. @`Assert` fc b e@ is similar to `Assume`, but asserts the @b@ holds.- The `Maybe` `FuncCall` allows us to optionally indicate that the- assertion is related to a specific function. -}-data Expr = Var Id+-- | Expressions, representing G2's intermediate language.+data Expr =+ -- | @`Var` `Id`@ is a variable. Variables may be bound by a `Lam`, `Let`+ -- or `Case` `Expr`, or be bound in the `G2.Language.ExprEnv.ExprEnv`. A variable may also be+ -- free (unbound), in which case it is symbolic+ Var Id+ -- | @v`Lit` t`Lit`@ denotes a literal. | Lit Lit+ -- | Primitive functions. Should be wrapped in `App`s. | Prim Primitive Type+ -- | @v`Data` `DataCon`@ denotes a Data Constructor | Data DataCon+ {-| @`App` `Expr` `Expr`@ denotes function application.+ For example, the function call:++ @ f x y @+ would be represented as++ @ `App`+ (`App`+ (`Var` (`Id` (`Name` "f" Nothing 0 Nothing) (`TyFun` t (`TyFun` t t))))+ (`Var` (`Id` (`Name` "x" Nothing 0 Nothing) t))+ )+ (`Var` (`Id` (`Name` "y" Nothing 0 Nothing) t)) @+ -} | App Expr Expr+ -- | @`Lam` `LamUse` `Id` `Expr`@ denotes a lambda function.+ -- The `Id` is bound in the `Expr`.+ -- This binding may be on the type or term level, depending on the `LamUse`. | Lam LamUse Id Expr+ -- | @`Let` b e@ gives a mapping of `Name`s to `Expr`s in `b`, allowing those names+ -- to be used in `e`. | Let Binds Expr- | Case Expr Id [Alt]+ -- | @`Case` e i as@ splits into multiple `Alt`s (Alternatives),+ -- Depending on the value of @e@. In each Alt, the `Id` @i@ is bound to @e@.+ -- The `Alt`s must always be exhaustive- there should never be a case where no `Alt`+ -- can match a given `Expr`.+ | Case Expr -- ^ Scrutinee+ Id -- ^ Bindee+ Type -- ^ Type of the case expression+ [Alt] -- ^ Alternatives+ + -- | @v`Type` t`Type`@ gives a `Expr` level representation of a t`Type`.+ -- These only ever appear as the arguments to polymorphic functions,+ -- to determine the t`Type` bound to type level variables. | Type Type+ -- | @`Cast` e (t1 `:~` t2)@ casts @e@ from the t`Type` @t1@ to @t2@+ -- This requires that @t1@ and @t2@ have the same representation. | Cast Expr Coercion+ -- | @v`Coercion` t`Coercion`@ allows runtime passing of t`Coercion`s to `Cast`s. | Coercion Coercion+ -- | @`Tick` `Tickish` `Expr`@ records some extra information into an `Expr`. | Tick Tickish Expr+ -- | @`NonDet` [`Expr`]@ gives a nondeterministic choice between multiple options+ -- to continue execution with. | NonDet [Expr]- | SymGen Type+ -- | @`SymGen` t`Type`@ evaluates to a fresh symbolic variable of the given type.+ -- The `SymLog` determines whether the SymGen logs its generated value in the `State`s `sym_gens` field.+ | SymGen SymLog Type+ -- | @`Assume` b e@ takes a boolean typed expression @b@, and an expression of+ -- arbitrary type @e@. During exectuion, @b@ is reduced to SWHNF, and assumed.+ -- Then, execution continues with @b@. | Assume (Maybe FuncCall) Expr Expr+ -- | @`Assert` fc b e@ is similar to `Assume`, but asserts the @b@ holds.+ -- The `Maybe` `FuncCall` allows us to optionally indicate that the+ -- assertion is related to a specific function. | Assert (Maybe FuncCall) Expr Expr deriving (Show, Eq, Read, Generic, Typeable, Data) @@ -156,7 +157,8 @@ -- And evaluation over literals can be peformed with the functions in: -- -- "G2.Execution.PrimitiveEval" -data Primitive = Ge+data Primitive = -- Mathematical and logical operators+ Ge | Gt | Eq | Neq@@ -174,16 +176,36 @@ | DivInt | Quot | Mod+ | Rem | Negate+ | Abs | SqRt+ + -- GHC conversions from data constructors to Int#, and vice versa+ | DataToTag+ | TagToEnum++ -- Numeric conversion | IntToFloat | IntToDouble+ | RationalToDouble | FromInteger | ToInteger | ToInt+ + -- String Handling+ | StrLen+ | StrAppend+ | Chr+ | OrdChar+ | WGenCat++ -- Convert a positive Int to a String. (This matches the SMT Str.from_int function, which supports only positive Ints.)+ | IntToString+ + -- Errors | Error | Undefined- | BindFunc deriving (Show, Eq, Read, Generic, Typeable, Data) instance Hashable Primitive@@ -200,11 +222,15 @@ instance Hashable Lit -- | Data constructor.-data DataCon = DataCon Name Type deriving (Show, Eq, Read, Generic, Typeable, Data)+data DataCon = DataCon Name Type deriving (Show, Eq, Read, Generic, Typeable, Data, Ord) instance Hashable DataCon --- | AltMatches.+-- | Extract the `Name` of a `DataCon`.+dcName :: DataCon -> Name+dcName (DataCon n _) = n++-- | Describe the conditions to match on a particular `Alt`. data AltMatch = DataAlt DataCon [Id] -- ^ Match a datacon. The number of `Id`s -- must match the number of term arguments -- for the datacon.@@ -217,62 +243,52 @@ -- | `Alt`s consist of the `AltMatch` that is used to match -- them, and the `Expr` that is evaluated provided that the `AltMatch` -- successfully matches.-data Alt = Alt AltMatch Expr deriving (Show, Eq, Read, Generic, Typeable, Data)+data Alt = Alt { altMatch :: AltMatch, altExpr :: Expr } deriving (Show, Eq, Read, Generic, Typeable, Data) instance Hashable Alt -altMatch :: Alt -> AltMatch-altMatch (Alt am _) = am---- | Used in the `TyForAll`, to bind an `Id` to a `Type`-data TyBinder = AnonTyBndr Type- | NamedTyBndr Id- deriving (Show, Eq, Read, Generic, Typeable, Data)--instance Hashable TyBinder-+-- | Concrete evidence of the equality or compatibility of two types. data Coercion = Type :~ Type deriving (Eq, Show, Read, Generic, Typeable, Data) instance Hashable Coercion --- | Types are decomposed as follows:--- * Type variables correspond to the aliasing of a type--- * TyLitInt, TyLitFloat etc denote unwrapped primitive types.--- * Function type. For instance (assume Int): \x -> x + 1 :: TyFun TyInt TyInt--- * Application, often reducible: (TyApp (TyFun TyInt TyInt) TyInt) :: TyInt--- * Type constructor (see below) application creates an actual type--- * For all types--- * BOTTOM-data Type = TyVar Id- | TyLitInt - | TyLitFloat - | TyLitDouble- | TyLitChar - | TyLitString- | TyFun Type Type- | TyApp Type Type- | TyCon Name Kind- | TyForAll TyBinder Type- | TyBottom+-- | Types information.+data Type = TyVar Id -- ^ Polymorphic type variable.+ | TyLitInt -- ^ Unwrapped primitive Int type.+ | TyLitFloat -- ^ Unwrapped primitive Float type.+ | TyLitDouble -- ^ Unwrapped primitive Int type.+ | TyLitChar -- ^ Unwrapped primitive Int type.+ | TyLitString -- ^ Unwrapped primitive String type.+ | TyFun Type Type -- ^ Function type. For instance (assume Int): \x -> x + 1 :: TyFun TyInt TyInt+ | TyApp Type Type -- ^ Application of a type.+ | TyCon Name Kind -- ^ Type constructor for a concrete type+ | TyForAll Id Type -- ^ Introduces a type variable.+ | TyBottom -- ^ Type for erroring/non-terminating expressions. | TYPE | TyUnknown- deriving (Show, Eq, Read, Generic, Typeable, Data)+ deriving (Show, Eq, Read, Generic, Typeable, Data, Ord) +-- | A `Kind` is a t`Type` of a t`Type`. type Kind = Type instance Hashable Type +-- | A `Tickish` allows storing extra information in a `Tick`. data Tickish = Breakpoint Span -- ^ A breakpoint for the GHC Debugger+ | HpcTick !Int T.Text -- ^ A tick used by HPC to track each subexpression in the original source code.+ --+ -- Together, the `Int` identifier and the Module Name indicate a unique location. | NamedLoc Name -- ^ A G2 specific tick, intended to allow,- -- in concert with a @`Reducer`@, for domain+ -- in concert with a @`G2.Execution.Reducer.Reducer`@, for domain -- specific modifications to a- -- @`State`@'s tracking field.+ -- @`G2.Language.Support.State`@'s tracking field. deriving (Show, Eq, Read, Generic, Typeable, Data) instance Hashable Tickish -- | Represents a rewrite rule data RewriteRule = RewriteRule { ru_name :: T.Text+ , ru_module :: T.Text , ru_head :: Name , ru_rough :: [Maybe Name] , ru_bndrs :: [Id]
src/G2/Language/TypeClasses/Extra.hs view
@@ -1,12 +1,7 @@ module G2.Language.TypeClasses.Extra ( eqTCDict , numTCDict , ordTCDict- , integralTCDict- , structEqTCDict- , lookupStructEqDicts- , concreteSatEq- , concreteSatStructEq- , concreteSatTC ) where+ , integralTCDict ) where import G2.Language.KnownValues import G2.Language.Syntax@@ -27,26 +22,3 @@ integralTCDict :: KnownValues -> TypeClasses -> Type -> Maybe Id integralTCDict kv tc t = lookupTCDict tc (integralTC kv) t--structEqTCDict :: KnownValues -> TypeClasses -> Type -> Maybe Id-structEqTCDict kv tc t = lookupTCDict tc (structEqTC kv) t--lookupStructEqDicts :: KnownValues -> TypeClasses -> Maybe [(Type, Id)]-lookupStructEqDicts kv = lookupTCDicts (structEqTC kv)--concreteSatEq :: KnownValues -> TypeClasses -> Type -> Maybe Expr-concreteSatEq kv tc t = concreteSatTC tc (eqTC kv) t--concreteSatStructEq :: KnownValues -> TypeClasses -> Type -> Maybe Expr-concreteSatStructEq kv tc t = concreteSatTC tc (structEqTC kv) t--concreteSatTC :: TypeClasses -> Name -> Type -> Maybe Expr-concreteSatTC tc tcn t- | TyCon _ _ <- tyAppCenter t- , ts <- tyAppArgs t- , tcs <- map (concreteSatTC tc tcn) ts- , all (isJust) tcs =- case lookupTCDict tc tcn t of- Just i -> Just (foldl' App (Var i) $ map Type ts ++ map fromJust tcs)- Nothing -> Nothing-concreteSatTC tc tcn t = fmap Var (lookupTCDict tc tcn t)
src/G2/Language/TypeClasses/TypeClasses.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}@@ -12,10 +13,11 @@ , isTypeClass , lookupTCDict , lookupTCDicts+ , lookupTCClass+ , tcWithNameMap , tcDicts , typeClassInst , satisfyingTCTypes- , satisfyingTC , toMap) where import G2.Language.AST@@ -26,23 +28,35 @@ import Data.Coerce import Data.Data (Data, Typeable)+import Data.Hashable import Data.List-import qualified Data.Map as M+import qualified Data.Map.Lazy as MM+import qualified Data.HashMap.Lazy as M import Data.Maybe+import Data.Monoid ((<>))+import qualified Data.Sequence as S+import GHC.Generics (Generic) -data Class = Class { insts :: [(Type, Id)], typ_ids :: [Id]}- deriving (Show, Eq, Read, Typeable, Data)+data Class = Class { insts :: [(Type, Id)], typ_ids :: [Id], superclasses :: [(Type, Id)]}+ deriving (Show, Eq, Read, Typeable, Data, Generic) -type TCType = M.Map Name Class+instance Hashable Class++type TCType = M.HashMap Name Class newtype TypeClasses = TypeClasses TCType- deriving (Show, Eq, Read, Typeable, Data)+ deriving (Show, Eq, Read, Typeable, Data, Generic) -initTypeClasses :: [(Name, Id, [Id])] -> TypeClasses+instance Hashable TypeClasses++initTypeClasses :: [(Name, Id, [Id], [(Type, Id)])] -> TypeClasses initTypeClasses nsi = let- ns = map (\(n, _, i) -> (n, i)) nsi+ ns = map (\(n, _, i, sc) -> (n, i, sc)) nsi nsi' = filter (not . null . insts . snd)- $ map (\(n, i) -> (n, Class { insts = mapMaybe (nameIdToTypeId n) nsi, typ_ids = i } )) ns+ $ map (\(n, i, sc) -> + (n, Class { insts = nub $ mapMaybe (nameIdToTypeId n) nsi+ , typ_ids = i+ , superclasses = sc } )) ns in coerce $ M.fromList nsi' @@ -52,39 +66,62 @@ unionTypeClasses :: TypeClasses -> TypeClasses -> TypeClasses unionTypeClasses (TypeClasses tc) (TypeClasses tc') = TypeClasses (M.union tc tc') -nameIdToTypeId :: Name -> (Name, Id, [Id]) -> Maybe (Type, Id)-nameIdToTypeId nm (n, i, _) =+nameIdToTypeId :: Name -> (Name, Id, [Id], [(Type, Id)]) -> Maybe (Type, Id)+nameIdToTypeId nm (n, i, _, _) = let t = affectedType $ returnType i in if n == nm then fmap (, i) t else Nothing affectedType :: Type -> Maybe Type-affectedType (TyApp (TyCon _ _) t) = Just t+affectedType (TyApp _ t) = Just t affectedType _ = Nothing +-- | Is there a typeclass with the given `Name`? isTypeClassNamed :: Name -> TypeClasses -> Bool isTypeClassNamed n = M.member n . (coerce :: TypeClasses -> TCType) +-- | Is the given type a type class? isTypeClass :: TypeClasses -> Type -> Bool isTypeClass tc (TyCon n _) = isTypeClassNamed n tc isTypeClass tc (TyApp t _) = isTypeClass tc t isTypeClass _ _ = False --- Returns the dictionary for the given typeclass and Type,--- if one exists-lookupTCDict :: TypeClasses -> Name -> Type -> Maybe Id+-- | Returns the dictionary for the given typeclass and Type,+-- if one exists.+lookupTCDict :: TypeClasses+ -> Name -- ^ `Name` of the typeclass to look for+ -> Type -- ^ The `Type` you want a dictionary for+ -> Maybe Id lookupTCDict tc n t = case fmap insts $ M.lookup n (toMap tc) of Just c -> fmap snd $ find (\(t', _) -> PresType t .:: t') c Nothing -> Nothing +-- | Given a typeclass `Name`, gives an association list of+-- `Type`s that have instances of that typeclass, and the+-- typeclass dictionaries. lookupTCDicts :: Name -> TypeClasses -> Maybe [(Type, Id)] lookupTCDicts n = fmap insts . M.lookup n . coerce -lookupTCDictsTypes :: TypeClasses -> Name -> Maybe [Type]-lookupTCDictsTypes tc = fmap (map fst) . flip lookupTCDicts tc+lookupTCClass :: Name -> TypeClasses -> Maybe Class+lookupTCClass n = M.lookup n . coerce +tcWithNameMap :: Name -> [Id] -> M.HashMap Name Id+tcWithNameMap n =+ M.fromList+ . map (\i -> (forType $ typeOf i, i))+ . filter (isTC . typeOf)+ where+ forType :: Type -> Name+ forType (TyApp _ (TyVar (Id n' _))) = n'+ forType _ = error "Bad type in forType"++ isTC :: Type -> Bool+ isTC t = case tyAppCenter t of+ TyCon n' _ -> n == n'+ _ -> False+ -- tcDicts tcDicts :: TypeClasses -> [Id] tcDicts = map snd . concatMap insts . M.elems . coerce@@ -96,12 +133,12 @@ -- Given a TypeClass name, a type that you want an instance of that typeclass -- for, and a mapping of TyVar name's to Id's for those types instances of -- the typeclass, returns an instance of the typeclass, if possible -typeClassInst :: TypeClasses -> M.Map Name Id -> Name -> Type -> Maybe Expr +typeClassInst :: TypeClasses -> M.HashMap Name Id -> Name -> Type -> Maybe Expr typeClassInst tc m tcn t | tca@(TyCon _ _) <- tyAppCenter t , ts <- tyAppArgs t , tcs <- map (typeClassInst tc m tcn) ts- , all (isJust) tcs =+ , all isJust tcs = case lookupTCDict tc tcn tca of Just i -> Just (foldl' App (Var i) $ map Type ts ++ map fromJust tcs) Nothing -> Nothing@@ -114,19 +151,27 @@ Nothing -> Nothing typeClassInst _ _ _ _ = Nothing --- satisfyingTCTypes--- Finds types/dict pairs that satisfy the given TC requirements for the given polymorphic argument--- returns a list of acceptable types-satisfyingTCTypes :: KnownValues -> TypeClasses -> Id -> [Type] -> [Type]+-- | Finds `Type`s that satisfy the given typeclass requirements for the given polymorphic argument.+-- Returns "Int" by default if there are no typeclass requirements.+satisfyingTCTypes :: KnownValues+ -> TypeClasses+ -> Id -- ^ The type variable to look for possible instantiations of + -> [Type] -- ^ Function arguments to satisfy typeclass requirements for+ -> [Type] satisfyingTCTypes kv tc i ts = let tcReq = satisfyTCReq tc i ts in- substKind i . inter kv $ mapMaybe (lookupTCDictsTypes tc) tcReq--inter :: KnownValues -> [[Type]] -> [Type]-inter kv [] = [tyInt kv]-inter _ xs = foldr1 intersect xs+ case mapMaybe lookupTCDictsTypes tcReq of+ [] -> [tyInt kv]+ xs -> substKind i $ foldr1 intersect xs+ where+ lookupTCDictsTypes (TyApp t1 t2) =+ fmap (mapMaybe (\t' -> MM.lookup (idName i) =<< specializes t' t2))+ . fmap (map fst)+ . flip lookupTCDicts tc+ =<< (tyConAppName . tyAppCenter $ t1)+ lookupTCDictsTypes _ = Nothing substKind :: Id -> [Type] -> [Type] substKind (Id _ t) ts = map (\t' -> case t' of @@ -137,29 +182,16 @@ tyFunToTyApp (TyFun t1 (TyFun t2 t3)) = TyApp (TyApp (tyFunToTyApp t1) (tyFunToTyApp t2)) (tyFunToTyApp t3) tyFunToTyApp t = modifyChildren tyFunToTyApp t --- satisfyingTCReq--- Finds the names of the required typeclasses for a TyVar Id--- See satisfyingTCTypes-satisfyTCReq :: TypeClasses -> Id -> [Type] -> [Name]-satisfyTCReq tc i =- mapMaybe (tyConAppName . tyAppCenter) . filter (isFor i) . filter (isTypeClass tc)+-- | Finds the names of the required typeclasses for a TyVar Id+satisfyTCReq :: TypeClasses -> Id -> [Type] -> [Type]+satisfyTCReq tc (Id n _) = filter isFor . filter (isTypeClass tc) where- isFor :: Id -> Type -> Bool- isFor ii (TyApp (TyCon _ _) a) = ii `elem` tyVarIds a- isFor _ _ = False---- Given a list of type arguments and a mapping of TyVar Ids to actual Types--- Gives the required TC's to pass to any TC arguments-satisfyingTC :: TypeClasses -> [Type] -> Id -> Type -> [Expr]-satisfyingTC tc ts i t =- let- tcReq = satisfyTCReq tc i ts- in- map (\n -> case lookupTCDict tc n t of- Just i' -> Var i'- Nothing -> error "No typeclass found.") tcReq+ isFor :: Type -> Bool+ isFor (TyVar (Id n' _)) = n == n'+ isFor (TyApp a1 a2) = isFor a1 || isFor a2+ isFor _ = False -toMap :: TypeClasses -> M.Map Name Class+toMap :: TypeClasses -> M.HashMap Name Class toMap = coerce instance ASTContainer TypeClasses Expr where@@ -176,20 +208,23 @@ modifyContainedASTs _ = id instance ASTContainer Class Type where- containedASTs = containedASTs . insts+ containedASTs c = (containedASTs . insts $ c) ++ containedASTs (superclasses c) modifyContainedASTs f c = Class { insts = modifyContainedASTs f $ insts c- , typ_ids = modifyContainedASTs f $ typ_ids c}+ , typ_ids = modifyContainedASTs f $ typ_ids c+ , superclasses = modifyContainedASTs f $ superclasses c} instance Named TypeClasses where- names = names . (coerce :: TypeClasses -> TCType)+ names (TypeClasses tc) = S.fromList (M.keys tc) <> names tc rename old new (TypeClasses m) = coerce $ M.mapKeys (rename old new) $ rename old new m renames hm (TypeClasses m) = coerce $ M.mapKeys (renames hm) $ renames hm m instance Named Class where- names = names . insts+ names (Class { insts = i, typ_ids = tids, superclasses = sc }) = names i <> names tids <> names sc rename old new c = Class { insts = rename old new $ insts c- , typ_ids = rename old new $ typ_ids c }+ , typ_ids = rename old new $ typ_ids c+ , superclasses = rename old new $ superclasses c } renames hm c = Class { insts = renames hm $ insts c- , typ_ids = renames hm $ typ_ids c }+ , typ_ids = renames hm $ typ_ids c+ , superclasses = renames hm $ superclasses c }
src/G2/Language/TypeEnv.hs view
@@ -6,25 +6,11 @@ , nameModMatch , argTypesTEnv- , dataCon- , boundIds- , isPolyAlgDataTy- , isDataTyCon- , isNewTyCon- , newTyConRepType- , typeStripCastType , getDataCons- , baseDataCons , getCastedAlgDataTy , getAlgDataTy , getDataCon- , getDataConNoType , getDataConNameMod- , getDataConNameMod'- , dataConArgs- , dataConWithName- , dcName- , retypeAlgDataTy , module G2.Language.AlgDataTy ) where @@ -34,18 +20,17 @@ import G2.Language.AlgDataTy import Data.List-import qualified Data.Map as M-import Data.Maybe+import qualified Data.HashMap.Lazy as M -- | The type environment maps names of types to their appropriate types. However -- our primary interest with these is for dealing with algebraic data types, -- and we only store those information accordingly.-type TypeEnv = M.Map Name AlgDataTy+type TypeEnv = M.HashMap Name AlgDataTy nameModMatch :: Name -> TypeEnv -> Maybe Name nameModMatch (Name n m _ _) = find (\(Name n' m' _ _) -> n == n' && m == m' ) . M.keys --- Returns a list of all argument function types in the type env+-- | Returns a list of all argument function types in the `TypeEnv` argTypesTEnv :: TypeEnv -> [Type] argTypesTEnv = concatMap (evalASTs argTypesTEnv') . M.elems @@ -53,53 +38,10 @@ argTypesTEnv' (TyFun t@(TyFun _ _) _) = [t] argTypesTEnv' _ = [] -dataCon :: AlgDataTy -> [DataCon]-dataCon (DataTyCon {data_cons = dc}) = dc-dataCon (NewTyCon {data_con = dc}) = [dc]-dataCon (TypeSynonym {}) = []--boundIds :: AlgDataTy -> [Id]-boundIds = bound_ids--dcName :: DataCon -> Name-dcName (DataCon n _) = n--isPolyAlgDataTy :: AlgDataTy -> Bool-isPolyAlgDataTy = not . null . bound_ids--isDataTyCon :: AlgDataTy -> Bool-isDataTyCon (DataTyCon {}) = True-isDataTyCon _ = False--isNewTyCon :: AlgDataTy -> Bool-isNewTyCon (NewTyCon {}) = True-isNewTyCon _ = False--newTyConRepType :: AlgDataTy -> Maybe Type-newTyConRepType (NewTyCon {rep_type = t}) = Just t-newTyConRepType _ = Nothing--typeStripCastType :: TypeEnv -> Type -> Type-typeStripCastType tenv t- | Just (adt, _) <- getCastedAlgDataTy t tenv- , Just rt <- newTyConRepType adt = rt-typeStripCastType _ t = t- getDataCons :: Name -> TypeEnv -> Maybe [DataCon]-getDataCons n tenv =- case M.lookup n tenv of- Just (DataTyCon _ dc) -> Just dc- Just (NewTyCon _ dc _) -> Just [dc]- Just (TypeSynonym _ (TyCon n' _)) -> getDataCons n' tenv- _ -> Nothing--baseDataCons :: [DataCon] -> [DataCon]-baseDataCons = filter baseDataCon--baseDataCon :: DataCon -> Bool-baseDataCon (DataCon _ t) = not $ hasTyFuns t+getDataCons n tenv = dataCon <$> M.lookup n tenv --- If the Type is a TyCon, (optionally) wrapped with TyApps,+-- | If the Type is a TyCon, (optionally) wrapped with TyApps, -- returns the AlgDataTy of the Cast type, along with mappings from -- the bound names of the cast type, to the types bound by the TyApps. getCastedAlgDataTy :: Type -> TypeEnv -> Maybe (AlgDataTy, [(Id, Type)])@@ -131,42 +73,18 @@ _ -> Nothing getDataCon :: TypeEnv -> Name -> Name -> Maybe DataCon-getDataCon tenv adt dc =- let- adt' = M.lookup adt tenv- in- maybe Nothing (flip dataConWithName dc) adt'--getDataConNoType :: TypeEnv -> Name -> Maybe DataCon-getDataConNoType tenv n = find (\dc -> dcName dc == n) . concatMap dataCon $ M.elems tenv+getDataCon tenv adt dc = flip dataConWithName dc =<< M.lookup adt tenv getDataConNameMod :: TypeEnv -> Name -> Name -> Maybe DataCon getDataConNameMod tenv (Name n m _ _) dc = let adt' = fmap snd $ find (\(Name n' m' _ _, _) -> n == n' && m == m') $ M.toList tenv in- maybe Nothing (flip dataConWithNameMod dc) adt'--getDataConNameMod' :: TypeEnv -> Name -> Maybe DataCon-getDataConNameMod' tenv n = find (flip dataConHasNameMod n) $ concatMap dataCon $ M.elems tenv--dataConArgs :: DataCon -> [Type]-dataConArgs dc = anonArgumentTypes dc--dataConWithName :: AlgDataTy -> Name -> Maybe DataCon-dataConWithName (DataTyCon _ dcs) n = listToMaybe $ filter (flip dataConHasName n) dcs-dataConWithName _ _ = Nothing--dataConHasName :: DataCon -> Name -> Bool-dataConHasName (DataCon n _) n' = n == n'+ flip dataConWithNameMod dc =<< adt' dataConWithNameMod :: AlgDataTy -> Name -> Maybe DataCon-dataConWithNameMod (DataTyCon _ dcs) n = listToMaybe $ filter (flip dataConHasNameMod n) dcs+dataConWithNameMod (DataTyCon _ dcs) n = find (`dataConHasNameMod` n) dcs dataConWithNameMod _ _ = Nothing dataConHasNameMod :: DataCon -> Name -> Bool dataConHasNameMod (DataCon (Name n m _ _) _) (Name n' m' _ _) = n == n' && m == m'--retypeAlgDataTy :: [Type] -> AlgDataTy -> AlgDataTy-retypeAlgDataTy ts adt =- foldr (uncurry retype) adt $ zip (bound_ids adt) ts
src/G2/Language/Typing.hs view
@@ -7,11 +7,19 @@ module G2.Language.Typing ( Typed (..) , PresType (..)++ , checkType+ , tyInt , tyInteger , tyDouble , tyFloat , tyBool+ , tyChar+ , tyRational+ , tyList+ , tyMaybe+ , tyUnit , mkTyApp , mkTyFun , tyAppCenter@@ -22,20 +30,21 @@ , (.::) , (.::.) , specializes+ , specializes' , hasFuncType- , appendType , higherOrderFuncs , isTYPE , isTyFun , hasTYPE , isTyVar- , hasTyBottom- , tyVars , tyVarIds , tyVarNames- , hasTyFuns- , isPolyFunc , numArgs++ , replaceTyVar+ , applyTypeMap+ , applyTypeHashMap+ , ArgType (..) , argumentTypes , argTypeToType@@ -45,25 +54,31 @@ , tyForAllBindings , anonArgumentTypes , returnType- , polyIds , splitTyForAlls , splitTyFuns , retype+ , retypeRespectingTyForAll , mapInTyForAlls , inTyForAlls , numTypeArgs , typeToExpr , getTyApps , tyAppsToExpr+ , isADTType+ , isPrimType ) where +import qualified G2.Data.UFMap as UF import G2.Language.AST import qualified G2.Language.KnownValues as KV import G2.Language.Syntax +import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M+import Data.Maybe import qualified Data.List as L import Data.Monoid hiding (Alt)+import Control.Monad tyInt :: KV.KnownValues -> Type tyInt kv = TyCon (KV.tyInt kv) (tyTYPE kv)@@ -80,11 +95,25 @@ tyBool :: KV.KnownValues -> Type tyBool kv = TyCon (KV.tyBool kv) (tyTYPE kv) +tyChar :: KV.KnownValues -> Type+tyChar kv = TyCon (KV.tyChar kv) (tyTYPE kv)++tyRational :: KV.KnownValues -> Type+tyRational kv = TyCon (KV.tyRational kv) (tyTYPE kv)++tyList :: KV.KnownValues -> Type+tyList kv = TyCon (KV.tyList kv) (TyFun TYPE TYPE)++tyMaybe :: KV.KnownValues -> Type+tyMaybe kv = TyCon (KV.tyMaybe kv) (TyFun TYPE TYPE)++tyUnit :: KV.KnownValues -> Type+tyUnit kv = TyCon (KV.tyUnit kv) (TyFun TYPE TYPE)+ tyTYPE :: KV.KnownValues -> Type tyTYPE _ = TYPE --- | mkTyFun--- Turns the Expr list into an application spine+-- | Turns the Expr list into an application spine mkTyFun :: [Type] -> Type mkTyFun [] = error "mkTyFun: empty list" mkTyFun [t] = t@@ -122,13 +151,12 @@ in mkTyApp $ TyCon n tsk:ts --- | unTyApp--- Unravels the application spine.+-- | Unravels the application spine of (nested) `TyApp`s. unTyApp :: Type -> [Type] unTyApp (TyApp t t') = unTyApp t ++ [t'] unTyApp t = [t] --- | Typed typeclass.+-- | Typeclass for things that have type information. class Typed a where typeOf :: a -> Type typeOf = typeOf' M.empty@@ -167,18 +195,17 @@ appTypeOf M.empty t as typeOf' m (Lam u b e) = case u of- TypeL -> TyForAll (NamedTyBndr b) (typeOf' m e)+ TypeL -> TyForAll b (typeOf' m e) TermL -> TyFun (typeOf' m b) (typeOf' m e) typeOf' m (Let _ expr) = typeOf' m expr- typeOf' m (Case _ _ (a:_)) = typeOf' m a- typeOf' _ (Case _ _ []) = TyBottom+ typeOf' _ (Case _ _ t _) = t typeOf' _ (Type _) = TYPE typeOf' m (Cast _ (_ :~ t')) = tyVarRename m t' typeOf' m (Coercion (_ :~ t')) = tyVarRename m t' typeOf' m (Tick _ e) = typeOf' m e typeOf' m (NonDet (e:_)) = typeOf' m e typeOf' _ (NonDet []) = TyBottom- typeOf' _ (SymGen t) = t+ typeOf' _ (SymGen _ t) = t typeOf' m (Assert _ _ e) = typeOf' m e typeOf' m (Assume _ _ e) = typeOf' m e @@ -194,20 +221,83 @@ appCenter e = e appTypeOf :: M.Map Name Type -> Type -> [Expr] -> Type-appTypeOf m (TyForAll (NamedTyBndr i) t) (Type t':es) =+appTypeOf m (TyForAll i t) (Type t':es) = let m' = M.insert (idName i) (tyVarRename m t') m in appTypeOf m' t es-appTypeOf m (TyForAll (NamedTyBndr _) t) (_:es) = appTypeOf m t es+appTypeOf m (TyForAll _ t) (_:es) = appTypeOf m t es appTypeOf m (TyFun _ t) (_:es) = appTypeOf m t es appTypeOf m t [] = tyVarRename m t appTypeOf m (TyVar (Id n _)) es = case M.lookup n m of Just t -> appTypeOf m t es Nothing -> error ("appTypeOf: Unknown TyVar")+appTypeOf _ TyBottom _ = TyBottom+appTypeOf _ TyUnknown _ = TyUnknown appTypeOf _ t es = error ("appTypeOf\n" ++ show t ++ "\n" ++ show es ++ "\n\n") +checkType :: Expr -> Maybe (UF.UFMap Name Type)+checkType = check' UF.empty++check' :: UF.UFMap Name Type -> Expr -> Maybe (UF.UFMap Name Type)+check' uf (Var (Id _ _)) = Just uf+check' uf (Lit _) = Just uf+check' uf (Prim _ _) = Just uf+check' uf (Data _) = Just uf+check' uf (App e1 e2) =+ let+ t1 = case typeOf e1 of+ TyFun t _ -> t+ TyForAll (Id _ t) _ -> t+ _ -> error "check: Unexpected type in App"+ t2 = typeOf e2+ in+ fmap snd (unify t1 t2 uf) >>= flip check' e1 >>= flip check' e2+check' uf (Lam u b e) = check' uf e+check' uf (Let b e) = foldM check' uf (map snd b) >>= flip check' e+check' uf (Case e _ _ alts) = foldM check' uf (map altExpr alts) >>= flip check' e+check' uf (Type t) = Just uf+check' uf (Cast e (t :~ t')) = check' uf e+check' uf (Coercion (t :~ t')) = Just uf+check' uf (Tick _ t) = check' uf t+check' uf (NonDet es) = foldM check' uf es+check' uf (SymGen _ _) = Just uf+check' uf (Assert _ e1 e2) = check' uf e1 >>= flip check' e2+check' uf (Assume _ e1 e2) = check' uf e1 >>= flip check' e2+check' _ _ = error "check'"++unify :: Type -> Type -> UF.UFMap Name Type -> Maybe (Type, UF.UFMap Name Type)+unify t@(TyVar (Id n1 _)) (TyVar (Id n2 _)) uf+ | Just t1 <- UF.lookup n1 uf+ , Just t2 <- UF.lookup n2 uf =+ case unify t1 t2 uf of+ Just (t, uf') -> Just (t, UF.join (\_ _ -> t) n1 n2 uf')+ Nothing -> Nothing+ | otherwise = Just (t, UF.join (error "unify: impossible, no need to join") n1 n2 uf)+unify (TyVar (Id n _)) t uf+ | Just t1 <- UF.lookup n uf = unify t1 t uf+ | otherwise = Just (t, UF.insert n t uf)+unify t (TyVar (Id n _)) uf+ | Just t2 <- UF.lookup n uf = unify t t2 uf+ | otherwise = Just (t, UF.insert n t uf)+unify (TyFun t1 t2) (TyFun t1' t2') uf = do+ (ft1, uf') <- unify t1 t1' uf+ (ft2, uf'') <- unify t2 t2' uf'+ return (TyFun ft1 ft2, uf'')+unify (TyApp t1 t2) (TyApp t1' t2') uf = do+ (ft1, uf') <- unify t1 t1' uf+ (ft2, uf'') <- unify t2 t2' uf'+ return (TyApp ft1 ft2, uf'')+unify (TyCon n1 k1) (TyCon n2 k2) uf | n1 == n2 = do+ (fk, uf') <- unify k1 k2 uf+ return (TyCon n1 fk, uf')+unify (TyForAll i t1) (TyForAll i2 t2) uf = do+ (t, uf') <- unify t1 t2 uf+ return (TyForAll i t, uf')+unify t1 t2 uf | t1 == t2 = return (t1, uf)+ | otherwise = Nothing+ instance Typed Type where typeOf' _ (TyVar (Id _ t)) = t typeOf' _ (TyFun _ _) = TYPE@@ -217,12 +307,12 @@ at = typeOf' m t2 in case (ft, at) of+ ((TyForAll _ t2'), _) -> t2' ((TyFun _ t2'), _) -> t2' ((TyApp t1' _), _) -> t1' _ -> error $ "Overapplied Type\n" ++ show t1 ++ "\n" ++ show t2 ++ "\n\n" ++ show ft ++ "\n" ++ show at typeOf' _ (TyCon _ t) = t- typeOf' m (TyForAll (NamedTyBndr b) t) = TyApp (typeOf b) (typeOf' m t)- typeOf' m (TyForAll _ t) = typeOf' m t+ typeOf' m (TyForAll b t) = TyApp (typeOf b) (typeOf' m t) typeOf' _ TyLitInt = TYPE typeOf' _ TyLitFloat = TYPE typeOf' _ TyLitDouble = TYPE@@ -245,12 +335,16 @@ retype' :: Id -> Type -> Type -> Type retype' key new (TyVar test) = if key == test then new else TyVar test-retype' key new (TyForAll (NamedTyBndr nid) ty) =- if key == nid- then modifyChildren (retype' key new) ty- else TyForAll (NamedTyBndr nid) (modifyChildren (retype' key new) ty) retype' key new ty = modifyChildren (retype' key new) ty +retypeRespectingTyForAll :: (ASTContainer m Type, Show m) => Id -> Type -> m -> m+retypeRespectingTyForAll key new = modifyContainedASTs (retypeRespectingTyForAll' key new)++retypeRespectingTyForAll' :: Id -> Type -> Type -> Type+retypeRespectingTyForAll' i _ t@(TyForAll ni _) | i == ni = t+retypeRespectingTyForAll' key new (TyVar test) = if idName key == idName test then new else TyVar test+retypeRespectingTyForAll' key new ty = modifyChildren (retypeRespectingTyForAll' key new) ty+ tyVarRename :: (ASTContainer t Type) => M.Map Name Type -> t -> t tyVarRename m = modifyASTs (tyVarRename' m) @@ -261,7 +355,7 @@ -- | Returns if the first type given is a specialization of the second, -- i.e. if given t1, t2, returns true iff t1 :: t2 (.::) :: Typed t => t -> Type -> Bool-t1 .:: t2 = fst $ specializes M.empty (typeOf t1) t2+t1 .:: t2 = isJust $ specializes (typeOf t1) t2 {-# INLINE (.::) #-} -- | Checks if the first type is equivalent to the second type.@@ -270,58 +364,58 @@ t1 .::. t2 = PresType t1 .:: t2 && PresType t2 .:: t1 {-# INLINE (.::.) #-} -specializes :: M.Map Name Type -> Type -> Type -> (Bool, M.Map Name Type)-specializes m _ TYPE = (True, m)-specializes m t (TyVar (Id n _)) =+specializes :: Type -> Type -> Maybe (M.Map Name Type)+specializes = specializes' M.empty++specializes' :: M.Map Name Type -> Type -> Type -> Maybe (M.Map Name Type)+specializes' m _ TYPE = Just m+specializes' m t (TyVar (Id n vt)) = case M.lookup n m of- Just (TyVar _) -> (True, m)- Just t' -> specializes m t t'- Nothing -> (True, M.insert n t m)-specializes m (TyFun t1 t2) (TyFun t1' t2') =- let- (b1, m') = specializes m t1 t1'- (b2, m'') = specializes m' t2 t2'- in- (b1 && b2, m'')-specializes m (TyApp t1 t2) (TyApp t1' t2') =- let- (b1, m') = specializes m t1 t1'- (b2, m'') = specializes m' t2 t2'- in- (b1 && b2, m'')-specializes m (TyCon n _) (TyCon n' _) = (n == n', m)-specializes m (TyFun t1 t2) (TyForAll (AnonTyBndr t1') t2') =- let- (b1, m') = specializes m t1 t1'- (b2, m'') = specializes m' t2 t2'- in (b1 && b2, m'')-specializes m (TyFun t1 t2) (TyForAll (NamedTyBndr _) t2') =- specializes m (TyFun t1 t2) t2'-specializes m (TyForAll (AnonTyBndr t1) t2) (TyFun t1' t2') =- let- (b1, m') = specializes m t1 t1'- (b2, m'') = specializes m' t2 t2'- in (b1 && b2, m'')-specializes m (TyForAll (AnonTyBndr t1) t2) (TyForAll (AnonTyBndr t1') t2') =- let- (b1, m') = specializes m t1 t1'- (b2, m'') = specializes m' t2 t2'- in (b1 && b2, m'')-specializes m (TyForAll (AnonTyBndr t1) t2) (TyForAll (NamedTyBndr _) t2') =- specializes m (TyForAll (AnonTyBndr t1) t2) t2'-specializes m (TyForAll (NamedTyBndr (Id _ t1)) t2) (TyForAll (NamedTyBndr (Id _ t1')) t2') =- let- (b1, m') = specializes m t1 t1'- (b2, m'') = specializes m' t2 t2'- in (b1 && b2, m'')-specializes m t (TyForAll _ t') =- specializes m t t'-specializes m TyUnknown _ = (True, m)-specializes m _ TyUnknown = (True, m)-specializes m TyBottom _ = (True, m)-specializes m _ TyBottom = (False, m)-specializes m t1 t2 = (t1 == t2, m)+ Just t' | t == t' -> Just m+ | otherwise -> Nothing+ Nothing -> M.insert n t <$> specializes' m (typeOf t) vt+specializes' m (TyFun t1 t2) (TyFun t1' t2') = do+ m' <- specializes' m t1 t1'+ specializes' m' t2 t2'+specializes' m (TyApp t1 t2) (TyApp t1' t2') = do+ m' <- specializes' m t1 t1'+ specializes' m' t2 t2'+specializes' m (TyCon n _) (TyCon n' _) = if n == n' then Just m else Nothing+specializes' m (TyForAll (Id _ t1) t2) (TyForAll (Id _ t1') t2') = do+ m' <- specializes' m t1 t1'+ specializes' m' t2 t2'+specializes' m t (TyForAll _ t') =+ specializes' m t t'+specializes' m TyUnknown _ = Just m+specializes' m _ TyUnknown = Just m+specializes' m TyBottom _ = Just m+specializes' _ _ TyBottom = Nothing+specializes' m t1 t2 = if t1 == t2 then Just m else Nothing +replaceTyVar :: ASTContainer e Type => Name -> Type -> e -> e+replaceTyVar n t = modifyASTs (replaceTyVar' n t)++replaceTyVar' :: Name -> Type -> Type -> Type+replaceTyVar' n t (TyVar (Id n' _)) | n == n' = t+replaceTyVar' _ _ t = t++applyTypeMap :: ASTContainer e Type => M.Map Name Type -> e -> e+applyTypeMap m = modifyASTs (applyTypeMap' m)++applyTypeMap' :: M.Map Name Type -> Type -> Type+applyTypeMap' m (TyVar (Id n _))+ | Just t <- M.lookup n m = t+applyTypeMap' _ t = t++applyTypeHashMap :: ASTContainer e Type => HM.HashMap Name Type -> e -> e+applyTypeHashMap m = modifyASTs (applyTypeHashMap' m)++applyTypeHashMap' :: HM.HashMap Name Type -> Type -> Type+applyTypeHashMap' m (TyVar (Id n _))+ | Just t <- HM.lookup n m = t+applyTypeHashMap' _ t = t++ hasFuncType :: (Typed t) => t -> Bool hasFuncType t = case typeOf t of@@ -329,13 +423,6 @@ (TyForAll _ _) -> True _ -> False --- | appendType--- Converts the (function) type t1 to return t2--- appendType (a -> b) c = (a -> b -> c)-appendType :: Type -> Type -> Type-appendType (TyFun t t1) t2 = TyFun t (appendType t1 t2)-appendType t1 t2 = TyFun t1 t2- -- | higherOrderFuncs -- Returns all internal higher order function types higherOrderFuncs :: Typed t => t -> [Type]@@ -368,24 +455,6 @@ isTyFun (TyFun _ _) = True isTyFun _ = False --- | isPolyFunc--- Checks if the given function is a polymorphic function-isPolyFunc :: Typed t => t -> Bool-isPolyFunc = isPolyFunc' . typeOf--isPolyFunc' :: Type -> Bool-isPolyFunc' (TyForAll _ _) = True-isPolyFunc' _ = False---- tyVars--- Returns a list of all tyVars-tyVars :: ASTContainer m Type => m -> [Type]-tyVars = evalASTs tyVars'--tyVars' :: Type -> [Type]-tyVars' t@(TyVar _) = [t]-tyVars' _ = []- -- | Returns a list of all tyVars Ids tyVarIds :: ASTContainer m Type => m -> [Id] tyVarIds = evalASTs tyVarIds'@@ -398,35 +467,18 @@ tyVarNames :: ASTContainer m Type => m -> [Name] tyVarNames = map idName . tyVarIds --- | hasTyFuns-hasTyFuns :: ASTContainer m Type => m -> Bool-hasTyFuns = getAny . evalASTs hasTyFuns'--hasTyFuns' :: Type -> Any-hasTyFuns' (TyFun _ _) = Any True-hasTyFuns' _ = Any False---- hasTyBottom-hasTyBottom :: ASTContainer m Type => m -> Bool-hasTyBottom = getAny . evalASTs hasTyBottom'--hasTyBottom' :: Type -> Any-hasTyBottom' TyBottom = Any True-hasTyBottom' _ = Any False---- | numArgs+-- | Computes the number of type and value level arguments numArgs :: Typed t => t -> Int numArgs = length . argumentTypes -data ArgType = AnonType Type | NamedType Id+data ArgType = AnonType Type | NamedType Id deriving (Show, Read) -- | Gives the types of the arguments of the functions argumentTypes :: Typed t => t -> [Type] argumentTypes = argumentTypes' . typeOf argumentTypes' :: Type -> [Type]-argumentTypes' (TyForAll (AnonTyBndr t1) t2) = t1:argumentTypes' t2-argumentTypes' (TyForAll (NamedTyBndr _) t2) = TYPE:argumentTypes' t2+argumentTypes' (TyForAll _ t2) = TYPE:argumentTypes' t2 argumentTypes' (TyFun t1 t2) = t1:argumentTypes' t2 argumentTypes' _ = [] @@ -442,8 +494,7 @@ spArgumentTypes = spArgumentTypes' . typeOf spArgumentTypes' :: Type -> [ArgType]-spArgumentTypes' (TyForAll (AnonTyBndr t1) t2) = AnonType t1:spArgumentTypes' t2-spArgumentTypes' (TyForAll (NamedTyBndr i) t2) = NamedType i:spArgumentTypes' t2+spArgumentTypes' (TyForAll i t2) = NamedType i:spArgumentTypes' t2 spArgumentTypes' (TyFun t1 t2) = AnonType t1:spArgumentTypes' t2 spArgumentTypes' _ = [] @@ -451,15 +502,14 @@ leadingTyForAllBindings = leadingTyForAllBindings' . typeOf leadingTyForAllBindings' :: Type -> [Id]-leadingTyForAllBindings' (TyForAll (NamedTyBndr i) t) = i:leadingTyForAllBindings' t+leadingTyForAllBindings' (TyForAll i t) = i:leadingTyForAllBindings' t leadingTyForAllBindings' _ = [] tyForAllBindings :: Typed t => t -> [Id] tyForAllBindings = tyForAllBindings' . typeOf tyForAllBindings' :: Type -> [Id]-tyForAllBindings' (TyForAll (NamedTyBndr i) t) = i:tyForAllBindings' t-tyForAllBindings' (TyForAll _ t) = tyForAllBindings' t+tyForAllBindings' (TyForAll i t) = i:tyForAllBindings' t tyForAllBindings' (TyFun t t') = tyForAllBindings' t ++ tyForAllBindings t' tyForAllBindings' _ = [] @@ -480,20 +530,15 @@ returnType' (TyFun _ t) = returnType' t returnType' t = t --- | Returns all polymorphic Ids in the given type-polyIds :: Type -> [Id]-polyIds = fst . splitTyForAlls- -- | Turns TyForAll types into a list of type ids splitTyForAlls :: Type -> ([Id], Type)-splitTyForAlls (TyForAll (NamedTyBndr i) t) =+splitTyForAlls (TyForAll i t) = let (i', t') = splitTyForAlls t in (i:i', t') splitTyForAlls t = ([], t) - -- | Turns TyFun types into a list of types splitTyFuns :: Type -> [Type] splitTyFuns (TyFun t t') = t:splitTyFuns t'@@ -513,7 +558,7 @@ numTypeArgs = numTypeArgs' . typeOf numTypeArgs' :: Type -> Int-numTypeArgs' (TyForAll (NamedTyBndr _) t) = 1 + numTypeArgs' t+numTypeArgs' (TyForAll _ t) = 1 + numTypeArgs' t numTypeArgs' _ = 0 -- | Converts nested TyApps into a list of Expr-level Types@@ -543,4 +588,18 @@ exprs = tyAppsToExpr t1 bindings tyAppsToExpr _ _ = [] +-- | Returns True if Type represents an ADT+isADTType :: Type -> Bool+isADTType t =+ let tCenter = tyAppCenter t+ in case tCenter of+ (TyCon _ _) -> True+ _ -> False +isPrimType :: Type -> Bool+isPrimType TyLitInt = True+isPrimType TyLitFloat = True+isPrimType TyLitDouble = True+isPrimType TyLitChar = True+isPrimType TyLitString = True+isPrimType _ = False
src/G2/Lib/Printers.hs view
@@ -1,16 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} -module G2.Lib.Printers ( mkCleanExprHaskell+module G2.Lib.Printers ( PrettyGuide+ , mkPrettyGuide+ , updatePrettyGuide++ , printName++ , printHaskell+ , printHaskellDirty+ , printHaskellDirtyPG+ , printHaskellPG , mkUnsugaredExprHaskell- , ppExprEnv- , ppRelExprEnv- , ppCurrExpr- , ppPathConds- , ppPathCond+ , mkTypeHaskell+ , mkTypeHaskellPG , pprExecStateStr- , pprExecEEnvStr) where+ , printFuncCall+ , prettyState -import G2.Execution.Memory+ , prettyGuideStr) where+ import G2.Language.Expr import qualified G2.Language.ExprEnv as E import G2.Language.KnownValues@@ -23,136 +31,287 @@ import G2.Language.Support import Data.Char-import Data.List+import Data.List as L import qualified Data.HashMap.Lazy as HM-import qualified Data.Map as M+import qualified Data.HashSet as HS+import Data.Monoid ((<>)) import qualified Data.Text as T -mkIdHaskell :: Id -> String-mkIdHaskell (Id n _) = mkNameHaskell n+data Clean = Cleaned | Dirty deriving Eq -mkNameHaskell :: Name -> String-mkNameHaskell = T.unpack . nameOcc+mkIdHaskell :: PrettyGuide -> Id -> T.Text+mkIdHaskell pg (Id n _) = mkNameHaskell pg n -mkUnsugaredExprHaskell :: State t -> Expr -> String+printName :: PrettyGuide -> Name -> T.Text+printName = mkNameHaskell++mkNameHaskell :: PrettyGuide -> Name -> T.Text+mkNameHaskell pg n+ | Just s <- lookupPG n pg = s+ | otherwise = nameOcc n++mkUnsugaredExprHaskell :: State t -> Expr -> T.Text mkUnsugaredExprHaskell (State {known_values = kv, type_classes = tc}) =- mkExprHaskell False kv . modifyFix (mkCleanExprHaskell' kv tc)+ mkExprHaskell Cleaned (mkPrettyGuide ()) . modifyMaybe (mkCleanExprHaskell' kv tc) -mkCleanExprHaskell :: State t -> Expr -> String-mkCleanExprHaskell (State {known_values = kv, type_classes = tc}) = - mkExprHaskell True kv . modifyFix (mkCleanExprHaskell' kv tc)+printHaskell :: State t -> Expr -> T.Text+printHaskell = mkCleanExprHaskell (mkPrettyGuide ()) -mkCleanExprHaskell' :: KnownValues -> TypeClasses -> Expr -> Expr+printHaskellDirty :: Expr -> T.Text+printHaskellDirty = mkExprHaskell Dirty (mkPrettyGuide ())++printHaskellDirtyPG :: PrettyGuide -> Expr -> T.Text+printHaskellDirtyPG = mkExprHaskell Dirty++printHaskellPG :: PrettyGuide -> State t -> Expr -> T.Text+printHaskellPG = mkCleanExprHaskell++mkCleanExprHaskell :: PrettyGuide -> State t -> Expr -> T.Text+mkCleanExprHaskell pg (State {known_values = kv, type_classes = tc}) = + mkExprHaskell Cleaned pg . modifyMaybe (mkCleanExprHaskell' kv tc)++mkCleanExprHaskell' :: KnownValues -> TypeClasses -> Expr -> Maybe Expr mkCleanExprHaskell' kv tc e | (App (Data (DataCon n _)) e') <- e- , n == dcInt kv || n == dcFloat kv || n == dcDouble kv || n == dcInteger kv || n == dcChar kv = e'+ , n == dcInt kv || n == dcFloat kv || n == dcDouble kv || n == dcInteger kv || n == dcChar kv = Just e' + | Case scrut i t [a] <- e = Case scrut i t . (:[]) <$> elimPrimDC a+ | (App e' e'') <- e , t <- typeOf e'- , isTypeClass tc t = e''+ , isTypeClass tc t = Just e'' | (App e' e'') <- e , t <- typeOf e''- , isTypeClass tc t = e'+ , isTypeClass tc t = Just e' - | App e' (Type _) <- e = e'+ | (App e' e'') <- e+ , isTypeClass tc (returnType e'') = Just e' - | otherwise = e+ | App e' (Type _) <- e = Just e' -mkExprHaskell :: Bool -> KnownValues -> Expr -> String-mkExprHaskell sugar kv ex = mkExprHaskell' ex 0+ | otherwise = Nothing++elimPrimDC :: Alt -> Maybe Alt+elimPrimDC (Alt (DataAlt (DataCon (Name n _ _ _) t) is) e)+ | n == "I#" || n == "F#" || n == "D#" || n == "Z#" || n == "C#" =+ Just $ Alt (DataAlt (DataCon (Name "" Nothing 0 Nothing) t) is) e+elimPrimDC _ = Nothing++mkDirtyExprHaskell :: PrettyGuide -> Expr -> T.Text+mkDirtyExprHaskell = mkExprHaskell Dirty++mkExprHaskell :: Clean -> PrettyGuide -> Expr -> T.Text+mkExprHaskell = mkExprHaskell' 0++mkExprHaskell' :: Int -> Clean -> PrettyGuide -> Expr -> T.Text+mkExprHaskell' off_init cleaned pg ex = mkExprHaskell'' off_init ex where- mkExprHaskell' :: Expr -> Int -> String- mkExprHaskell' (Var ids) _ = mkIdHaskell ids- mkExprHaskell' (Lit c) _ = mkLitHaskell c- mkExprHaskell' (Prim p _) _ = mkPrimHaskell p- mkExprHaskell' (Lam _ ids e) i = "\\" ++ mkIdHaskell ids ++ " -> " ++ mkExprHaskell' e i+ isCleaned = cleaned == Cleaned - mkExprHaskell' a@(App ea@(App e1 e2) e3) i+ mkExprHaskell'' :: Int -- ^ How much should a new line be indented?+ -> Expr+ -> T.Text+ mkExprHaskell'' _ (Var ids) = mkIdHaskell pg ids+ mkExprHaskell'' _ (Lit c) = mkLitHaskell c+ mkExprHaskell'' _ (Prim p _) = mkPrimHaskell p+ mkExprHaskell'' off (Lam _ ids e) =+ "(\\" <> mkIdHaskell pg ids <> " -> " <> mkExprHaskell'' off e <> ")"++ mkExprHaskell'' off a@(App ea@(App e1 e2) e3) | Data (DataCon n _) <- appCenter a , isTuple n- , sugar = printTuple kv a+ , isCleaned = printTuple pg a+ | Data (DataCon n _) <- appCenter a+ , isPrimTuple n+ , isCleaned = printPrimTuple pg a | Data (DataCon n1 _) <- e1 , nameOcc n1 == ":"- , sugar =- if isLitChar e2 then printString a else printList kv a+ , isCleaned =+ if isLitChar e2 then printString pg a else printList pg a - | isInfixable e1 =+ | isInfixable e1+ , isCleaned = let- e2P = if isApp e2 then "(" ++ mkExprHaskell' e2 i ++ ")" else mkExprHaskell' e2 i- e3P = if isApp e3 then "(" ++ mkExprHaskell' e3 i ++ ")" else mkExprHaskell' e3 i+ e2P = if isApp e2 then "(" <> mkExprHaskell'' off e2 <> ")" else mkExprHaskell'' off e2+ e3P = if isApp e3 then "(" <> mkExprHaskell'' off e3 <> ")" else mkExprHaskell'' off e3 in- e2P ++ " " ++ mkExprHaskell' e1 i ++ " " ++ e3P+ e2P <> " " <> mkExprHaskell'' off e1 <> " " <> e3P - | App _ _ <- e3 = mkExprHaskell' ea i ++ " (" ++ mkExprHaskell' e3 i ++ ")"- | otherwise = mkExprHaskell' ea i ++ " " ++ mkExprHaskell' e3 i+ | App _ _ <- e3 = mkExprHaskell'' off ea <> " (" <> mkExprHaskell'' off e3 <> ")"+ | otherwise = mkExprHaskell'' off ea <> " " <> mkExprHaskell'' off e3 - mkExprHaskell' (App e1 ea@(App _ _)) i = mkExprHaskell' e1 i ++ " (" ++ mkExprHaskell' ea i ++ ")"- mkExprHaskell' (App e1 e2) i = mkExprHaskell' e1 i ++ " " ++ mkExprHaskell' e2 i- mkExprHaskell' (Data d) _ = mkDataConHaskell d- mkExprHaskell' (Case e _ ae) i = "\n" ++ off (i + 1) ++ "case " ++ (mkExprHaskell' e i) ++ " of\n" - ++ intercalate "\n" (map (mkAltHaskell (i + 2)) ae)- mkExprHaskell' (Type _) _ = ""- mkExprHaskell' (Cast e (_ :~ t)) i = "((coerce " ++ mkExprHaskell' e i ++ ") :: " ++ mkTypeHaskell t ++ ")"- mkExprHaskell' e _ = "e = " ++ show e ++ " NOT SUPPORTED"+ mkExprHaskell'' off (App e1 ea@(App _ _)) = mkExprHaskell'' off e1 <> " (" <> mkExprHaskell'' off ea <> ")"+ mkExprHaskell'' off (App e1 e2) =+ parenWrap e1 (mkExprHaskell'' off e1) <> " " <> mkExprHaskell'' off e2+ mkExprHaskell'' _ (Data d) = mkDataConHaskell pg d+ mkExprHaskell'' off (Case e bndr _ ae) =+ "case " <> parenWrap e (mkExprHaskell'' off e) <> " of\n" + <> T.intercalate "\n" (map (mkAltHaskell (off + 2) cleaned pg bndr) ae)+ mkExprHaskell'' _ (Type t) = "@" <> mkTypeHaskellPG pg t+ mkExprHaskell'' off (Cast e (t1 :~ t2)) =+ let+ e_str = mkExprHaskell'' off e+ t1_str = mkTypeHaskellPG pg t1+ t2_str = mkTypeHaskellPG pg t2+ in+ "((coerce (" <> e_str <> " :: " <> t1_str <> ")) :: " <> t2_str <> ")"+ mkExprHaskell'' off (Coercion (t1 :~ t2)) =+ let+ t1_str = mkTypeHaskellPG pg t1+ t2_str = mkTypeHaskellPG pg t2+ in+ "(" <> t1_str <> " :~ " <> t2_str <> ")"+ mkExprHaskell'' off (Let binds e) =+ let+ binds' = T.intercalate (offset off <> "\n")+ $ map (\(i, be) -> mkIdHaskell pg i <> " = " <> mkExprHaskell'' off be) binds + in+ "let " <> binds' <> " in " <> mkExprHaskell'' off e+ mkExprHaskell'' off (Tick nl e) = "TICK[" <> printTickish pg nl <> "]{" <> mkExprHaskell'' off e <> "}"+ mkExprHaskell'' off (Assume m_fc e1 e2) =+ let+ print_fc = maybe "" (\fc -> "(" <> printFuncCallPG pg fc <> ") ") m_fc+ in+ "assume " <> print_fc+ <> "(" <> mkExprHaskell'' off e1+ <> ") (" <> mkExprHaskell'' off e2 <> ")"+ mkExprHaskell'' off (Assert m_fc e1 e2) =+ let+ print_fc = maybe "" (\fc -> "(" <> printFuncCallPG pg fc <> ") ") m_fc+ in+ "assert " <> print_fc+ <> "(" <> mkExprHaskell'' off e1+ <> ") (" <> mkExprHaskell'' off e2 <> ")"+ mkExprHaskell'' off (NonDet es) =+ let+ print_es = map (mkExprHaskell'' off) es+ in+ T.intercalate ("\n" <> offset off <> "[NonDet]\n") print_es + mkExprHaskell'' _ (SymGen SLog t) = "(symgen log " <> mkTypeHaskellPG pg t <> ")"+ mkExprHaskell'' _ (SymGen SNoLog t) = "(symgen no_log " <> mkTypeHaskellPG pg t <> ")"+ mkExprHaskell'' _ e = "e = " <> T.pack (show e) <> " NOT SUPPORTED" - mkAltHaskell :: Int -> Alt -> String- mkAltHaskell i (Alt am e) =- off i ++ mkAltMatchHaskell am ++ " -> " ++ mkExprHaskell' e i+ parenWrap :: Expr -> T.Text -> T.Text+ parenWrap (Case _ _ _ _) s = "(" <> s <> ")"+ parenWrap (Let _ _) s = "(" <> s <> ")"+ parenWrap (Tick _ e) s = parenWrap e s+ parenWrap _ s = s -mkAltMatchHaskell :: AltMatch -> String-mkAltMatchHaskell (DataAlt dc ids) = mkDataConHaskell dc ++ " " ++ intercalate " " (map mkIdHaskell ids)-mkAltMatchHaskell (LitAlt l) = mkLitHaskell l-mkAltMatchHaskell Default = "_"+mkAltHaskell :: Int -> Clean -> PrettyGuide -> Id -> Alt -> T.Text+mkAltHaskell off cleaned pg i_bndr@(Id bndr_name _) (Alt am e) =+ let+ needs_bndr = bndr_name `elem` names e+ in+ offset off <> mkAltMatchHaskell (if needs_bndr then Just i_bndr else Nothing) am <> " -> " <> mkExprHaskell' off cleaned pg e+ where+ mkAltMatchHaskell :: Maybe Id -> AltMatch -> T.Text+ mkAltMatchHaskell m_bndr (DataAlt dc@(DataCon n _) ids) | isTuple n =+ let+ pr_am = printTuple pg $ mkApp (Data dc:map Var ids)+ in+ case m_bndr of+ Just bndr | not (L.null ids) -> mkIdHaskell pg bndr <> "@" <> pr_am <> ""+ | otherwise -> mkIdHaskell pg bndr+ Nothing -> pr_am+ mkAltMatchHaskell m_bndr (DataAlt dc@(DataCon n _) [id1, id2]) | isInfixableName n =+ let+ pr_am = mkIdHaskell pg id1 <> " " <> mkDataConHaskell pg dc <> " " <> mkIdHaskell pg id2+ in+ case m_bndr of+ Just bndr -> mkIdHaskell pg bndr <> "@(" <> pr_am <> ")" + Nothing -> pr_am+ mkAltMatchHaskell m_bndr (DataAlt dc ids) =+ let+ pr_am = mkDataConHaskell pg dc <> " " <> T.intercalate " " (map (mkIdHaskell pg) ids)+ in+ case m_bndr of+ Just bndr | not (L.null ids) -> mkIdHaskell pg bndr <> "@(" <> pr_am <> ")"+ | otherwise -> mkIdHaskell pg bndr+ Nothing -> pr_am+ mkAltMatchHaskell m_bndr (LitAlt l) =+ case m_bndr of+ Just bndr -> mkIdHaskell pg bndr <> "@" <> mkLitHaskell l+ Nothing -> mkLitHaskell l+ mkAltMatchHaskell (Just bndr) Default = mkIdHaskell pg bndr+ mkAltMatchHaskell _ Default = "_" -mkDataConHaskell :: DataCon -> String+mkDataConHaskell :: PrettyGuide -> DataCon -> T.Text -- Special casing for Data.Map in the modified base-mkDataConHaskell (DataCon (Name "Assocs" _ _ _) _) = "fromList"-mkDataConHaskell (DataCon n _) = mkNameHaskell n+mkDataConHaskell _ (DataCon (Name "Assocs" _ _ _) _) = "fromList"+mkDataConHaskell pg (DataCon n _) = mkNameHaskell pg n -off :: Int -> String-off i = duplicate " " i+offset :: Int -> T.Text+offset i = duplicate " " i -printList :: KnownValues -> Expr -> String-printList kv a = "[" ++ intercalate ", " (printList' kv a) ++ "]"+printList :: PrettyGuide -> Expr -> T.Text+printList pg a =+ let (strs, b) = printList' pg a+ in case b of+ False -> "(" <> T.intercalate ":" strs <> ")"+ _ -> "[" <> T.intercalate ", " strs <> "]" -printList' :: KnownValues -> Expr -> [String]-printList' kv (App (App _ e) e') = mkExprHaskell True kv e:printList' kv e'-printList' _ _ = []+printList' :: PrettyGuide -> Expr -> ([T.Text], Bool)+printList' pg (App (App e1 e) e') | Data (DataCon n1 _) <- e1+ , nameOcc n1 == ":" =+ let (strs, b) = printList' pg e'+ in (mkExprHaskell Cleaned pg e:strs, b)+printList' pg e | Data (DataCon n _) <- appCenter e+ , nameOcc n == "[]" = ([], True)+ | otherwise = ([mkExprHaskell Cleaned pg e], False) -printString :: Expr -> String-printString a =+printString :: PrettyGuide -> Expr -> T.Text+printString pg a = let- str = printString' a- in- if all isPrint str then "\"" ++ str ++ "\""- else "[" ++ intercalate ", " (map stringToEnum str) ++ "]"+ maybe_str = printString' a+ in case maybe_str of+ Just str -> if T.all isPrint str then "\"" <> str <> "\""+ else "[" <> T.intercalate ", " (map (T.pack . stringToEnum) $ T.unpack str) <> "]"+ Nothing -> printList pg a where stringToEnum c | isPrint c = '\'':c:'\'':[] | otherwise = "toEnum " ++ show (ord c) -printString' :: Expr -> String-printString' (App (App _ (Lit (LitChar c))) e') = c:printString' e'-printString' _ = []+printString' :: Expr -> Maybe T.Text+printString' (App (App _ (Lit (LitChar c))) e') =+ case printString' e' of+ Nothing -> Nothing+ Just str -> Just (T.cons c str)+printString' e | Data (DataCon n _) <- appCenter e+ , nameOcc n == "[]" = Just ""+ | otherwise = Nothing isTuple :: Name -> Bool-isTuple (Name n _ _ _) = T.head n == '(' && T.last n == ')'+isTuple (Name n _ _ _) = fmap fst (T.uncons n) == Just '(' && fmap snd (T.unsnoc n) == Just ')' && T.all (\c -> c == '(' || c == ')' || c == ',') n -printTuple :: KnownValues -> Expr -> String-printTuple kv a = "(" ++ intercalate ", " (reverse $ printTuple' kv a) ++ ")"+isPrimTuple :: Name -> Bool+isPrimTuple (Name n _ _ _) = fmap fst (T.uncons n) == Just '(' && fmap snd (T.unsnoc n) == Just ')'+ && T.all (\c -> c == '(' || c == ')' || c == ',' || c == '#') n+ && T.any (\c -> c == '#') n -printTuple' :: KnownValues -> Expr -> [String]-printTuple' kv (App e e') = mkExprHaskell True kv e':printTuple' kv e+printTuple :: PrettyGuide -> Expr -> T.Text+printTuple pg a = "(" <> T.intercalate ", " (reverse $ printTuple' pg a) <> ")"++printPrimTuple :: PrettyGuide -> Expr -> T.Text+printPrimTuple pg a = "(#" <> T.intercalate ", " (reverse $ printTuple' pg a) <> "#)"++printTuple' :: PrettyGuide -> Expr -> [T.Text]+printTuple' pg (App e e') = mkExprHaskell Cleaned pg e':printTuple' pg e printTuple' _ _ = [] isInfixable :: Expr -> Bool-isInfixable (Data (DataCon n _)) = not $ T.any isAlphaNum $ nameOcc n+isInfixable (Var (Id n _)) = isInfixableName n+isInfixable (Data (DataCon n _)) = isInfixableName n+isInfixable (Prim p _) = not . T.any isAlphaNum $ mkPrimHaskell p isInfixable _ = False +isInfixableName :: Name -> Bool+isInfixableName = not . T.any isAlphaNum . nameOcc+ isApp :: Expr -> Bool isApp (App _ _) = True isApp _ = False@@ -161,15 +320,16 @@ isLitChar (Lit (LitChar _)) = True isLitChar _ = False -mkLitHaskell :: Lit -> String-mkLitHaskell (LitInt i) = if i < 0 then "(" ++ show i ++ ")" else show i-mkLitHaskell (LitInteger i) = if i < 0 then "(" ++ show i ++ ")" else show i-mkLitHaskell (LitFloat r) = "(" ++ show ((fromRational r) :: Float) ++ ")"-mkLitHaskell (LitDouble r) = "(" ++ show ((fromRational r) :: Double) ++ ")"-mkLitHaskell (LitChar c) = ['\'', c, '\'']-mkLitHaskell (LitString s) = s+mkLitHaskell :: Lit -> T.Text+mkLitHaskell (LitInt i) = T.pack $ if i < 0 then "(" <> show i <> ")" else show i+mkLitHaskell (LitInteger i) = T.pack $ if i < 0 then "(" <> show i <> ")" else show i+mkLitHaskell (LitFloat r) = "(" <> T.pack (show ((fromRational r) :: Float)) <> ")"+mkLitHaskell (LitDouble r) = "(" <> T.pack (show ((fromRational r) :: Double)) <> ")"+mkLitHaskell (LitChar c) | isPrint c = T.pack ['\'', c, '\'']+ | otherwise = "(chr " <> T.pack (show $ ord c) <> ")"+mkLitHaskell (LitString s) = T.pack s -mkPrimHaskell :: Primitive -> String+mkPrimHaskell :: Primitive -> T.Text mkPrimHaskell Ge = ">=" mkPrimHaskell Gt = ">" mkPrimHaskell Eq = "=="@@ -186,77 +346,227 @@ mkPrimHaskell DivInt = "/" mkPrimHaskell Quot = "quot" mkPrimHaskell Mod = "mod"+mkPrimHaskell Rem = "rem" mkPrimHaskell Negate = "-"+mkPrimHaskell Abs = "abs" mkPrimHaskell SqRt = "sqrt"++mkPrimHaskell DataToTag = "prim_dataToTag#"+mkPrimHaskell TagToEnum = "prim_tagToEnum#"++ mkPrimHaskell IntToFloat = "fromIntegral" mkPrimHaskell IntToDouble = "fromIntegral"+mkPrimHaskell RationalToDouble = "fromRational" mkPrimHaskell FromInteger = "fromInteger" mkPrimHaskell ToInteger = "toInteger"++mkPrimHaskell StrLen = "StrLen"+mkPrimHaskell StrAppend = "StrAppend"+mkPrimHaskell Chr = "chr"+mkPrimHaskell OrdChar = "ord"++mkPrimHaskell WGenCat = "wgencat"++mkPrimHaskell IntToString = "intToString"+ mkPrimHaskell ToInt = "toInt"+ mkPrimHaskell Error = "error" mkPrimHaskell Undefined = "undefined" mkPrimHaskell Implies = "undefined" mkPrimHaskell Iff = "undefined"-mkPrimHaskell BindFunc = "undefined" -mkTypeHaskell :: Type -> String-mkTypeHaskell (TyVar i) = mkIdHaskell i-mkTypeHaskell (TyFun t1 t2) = mkTypeHaskell t1 ++ " -> " ++ mkTypeHaskell t2-mkTypeHaskell (TyCon n _) = mkNameHaskell n-mkTypeHaskell (TyApp t1 t2) = "(" ++ mkTypeHaskell t1 ++ " " ++ mkTypeHaskell t2 ++ ")"-mkTypeHaskell _ = "Unsupported type in printer."+mkTypeHaskell :: Type -> T.Text+mkTypeHaskell = mkTypeHaskellPG (mkPrettyGuide ()) -duplicate :: String -> Int -> String+mkTypeHaskellPG :: PrettyGuide -> Type -> T.Text+mkTypeHaskellPG pg (TyVar i) = mkIdHaskell pg i+mkTypeHaskellPG _ TyLitInt = "Int#"+mkTypeHaskellPG _ TyLitFloat = "Float#"+mkTypeHaskellPG _ TyLitDouble = "Double#"+mkTypeHaskellPG _ TyLitChar = "Char#"+mkTypeHaskellPG _ TyLitString = "String#"+mkTypeHaskellPG pg (TyFun t1 t2)+ | isTyFun t1 = "(" <> mkTypeHaskellPG pg t1 <> ") -> " <> mkTypeHaskellPG pg t2+ | otherwise = mkTypeHaskellPG pg t1 <> " -> " <> mkTypeHaskellPG pg t2+mkTypeHaskellPG pg (TyCon n _) | nameOcc n == "List"+ , nameModule n == Just "GHC.Types" = "[]"+ | otherwise = mkNameHaskell pg n+mkTypeHaskellPG pg (TyApp t1 t2) = "(" <> mkTypeHaskellPG pg t1 <> " " <> mkTypeHaskellPG pg t2 <> ")"+mkTypeHaskellPG pg (TyForAll i t) = "forall " <> mkIdHaskell pg i <> " . " <> mkTypeHaskellPG pg t+mkTypeHaskellPG _ TyBottom = "Bottom"+mkTypeHaskellPG _ TYPE = "Type"+mkTypeHaskellPG _ (TyUnknown) = "Unknown"++duplicate :: T.Text -> Int -> T.Text duplicate _ 0 = ""-duplicate s n = s ++ duplicate s (n - 1)+duplicate s n = s <> duplicate s (n - 1) -ppExprEnv :: State t -> String-ppExprEnv s@(State {expr_env = eenv}) =+printTickish :: PrettyGuide -> Tickish -> T.Text+printTickish _ (Breakpoint sp) = printLoc (start sp) <> " - " <> printLoc (end sp)+printTickish _ (HpcTick i m) = "(hpc " <> T.pack (show i) <> " " <> m <> ")" +printTickish pg (NamedLoc n) = mkNameHaskell pg n++printLoc :: Loc -> T.Text+printLoc (Loc ln cl fl) = "(line " <> T.pack (show ln) <> " column " <> T.pack (show cl) <> " in " <> T.pack fl <> ")" ++-------------------------------------------------------------------------------++prettyState :: Show t => PrettyGuide -> State t -> T.Text+prettyState pg s =+ T.intercalate "\n"+ [ ">>>>> [State] >>>>>>>>>>>>>>>>>>>>>"+ , "----- [Code] ----------------------"+ , pretty_curr_expr+ , "----- [Stack] ----------------------"+ , pretty_stack+ , "----- [Env] -----------------------"+ , pretty_eenv+ , "----- [Paths] -----------------------"+ , pretty_paths+ , "----- [Non Red Paths] ---------------------"+ , pretty_non_red_paths+ , "----- [Types] ---------------------"+ , pretty_tenv+ , "----- [Typeclasses] ---------------------"+ , pretty_tc+ , "----- [True Assert] ---------------------"+ , T.pack (show (true_assert s))+ , "----- [Assert FC] ---------------------"+ , pretty_assert_fcs+ , "----- [Tracker] ---------------------"+ , T.pack (show (track s))+ , "----- [Pretty] ---------------------"+ , pretty_names+ ]+ where+ pretty_curr_expr = prettyCurrExpr pg (curr_expr s)+ pretty_stack = prettyStack pg (exec_stack s)+ pretty_eenv = prettyEEnv pg (expr_env s)+ pretty_paths = prettyPathConds pg (path_conds s)+ pretty_non_red_paths = prettyNonRedPaths pg (non_red_path_conds s)+ pretty_tenv = prettyTypeEnv pg (type_env s)+ pretty_tc = prettyTypeClasses pg (type_classes s)+ pretty_assert_fcs = maybe "None" (printFuncCallPG pg) (assert_ids s)+ pretty_names = prettyGuideStr pg+++prettyCurrExpr :: PrettyGuide -> CurrExpr -> T.Text+prettyCurrExpr pg (CurrExpr er e) = let- eenvs = M.toList $ E.map' (mkUnsugaredExprHaskell s) eenv+ e_str = mkDirtyExprHaskell pg e in- intercalate "\n" $ map (\(n, es) -> mkNameHaskell n ++ " = " ++ es) eenvs+ case er of+ Evaluate -> "evaluate: " <> e_str+ Return -> "return: " <> e_str --- | ppRelExprEnv--- Prints all variable definitions from the expression environment,--- that are required to understand the curr expr and path constraints-ppRelExprEnv :: State t -> Bindings -> String-ppRelExprEnv s b =+prettyStack :: PrettyGuide -> Stack Frame -> T.Text+prettyStack pg = T.intercalate "\n" . map (prettyFrame pg) . toList++prettyFrame :: PrettyGuide -> Frame -> T.Text+prettyFrame pg (CaseFrame i _ as) =+ "case frame: bindee:" <> mkIdHaskell pg i <> "\n" <> T.intercalate "\n" (map (mkAltHaskell 1 Dirty pg i) as)+prettyFrame pg (ApplyFrame e) = "apply frame: " <> mkDirtyExprHaskell pg e+prettyFrame pg (UpdateFrame n) = "update frame: " <> mkNameHaskell pg n+prettyFrame pg (CastFrame (t1 :~ t2)) = "cast frame: " <> mkTypeHaskellPG pg t1 <> " ~ " <> mkTypeHaskellPG pg t2+prettyFrame pg (CurrExprFrame act ce) = "curr_expr frame: " <> prettyCEAction pg act <> prettyCurrExpr pg ce+prettyFrame pg (AssumeFrame e) = "assume frame: " <> mkDirtyExprHaskell pg e+prettyFrame pg (AssertFrame m_fc e) = let- (s', _) = markAndSweep s b+ fc = case m_fc of+ Just fc_ -> "(from call " <> printFuncCallPG pg fc_ <> ")"+ Nothing -> "" in- ppExprEnv s'+ "assert frame: " <> fc <> mkDirtyExprHaskell pg e -ppCurrExpr :: State t -> String-ppCurrExpr s@(State {curr_expr = CurrExpr _ e}) = mkUnsugaredExprHaskell s e+prettyCEAction :: PrettyGuide -> CEAction -> T.Text+prettyCEAction pg (EnsureEq e) = "EnsureEq " <> mkDirtyExprHaskell pg e+prettyCEAction _ NoAction = "NoAction" -ppPathConds :: State t -> String-ppPathConds s@(State {path_conds = pc}) = intercalate "\n" $ PC.map (ppPathCond s) pc+prettyEEnv :: PrettyGuide -> ExprEnv -> T.Text+prettyEEnv pg eenv = T.intercalate "\n\n"+ . map (uncurry printFunc)+ . E.toList $ eenv+ where+ printFunc n e = mkNameHaskell pg n <> " :: " <> mkTypeHaskellPG pg (envObjType eenv e)+ <> "\n" <> mkNameHaskell pg n <> " = " <> printEnvObj pg e -ppPathCond :: State t -> PathCond -> String-ppPathCond s (AltCond l e b) =- mkLitHaskell l ++ (if b then " == " else " /= ") ++ mkUnsugaredExprHaskell s e-ppPathCond s (ExtCond e b) =+printEnvObj :: PrettyGuide -> E.EnvObj -> T.Text+printEnvObj pg (E.ExprObj e) = mkDirtyExprHaskell pg e+printEnvObj pg (E.SymbObj (Id _ t)) = "symbolic " <> mkTypeHaskellPG pg t+printEnvObj pg (E.RedirObj n) = "redir to " <> mkNameHaskell pg n++envObjType :: ExprEnv -> E.EnvObj -> Type+envObjType _ (E.ExprObj e) = typeOf e+envObjType _ (E.SymbObj (Id _ t)) = t+envObjType eenv (E.RedirObj n) = maybe (TyCon (Name "???" Nothing 0 Nothing) TYPE) typeOf $ E.lookup n eenv++prettyPathConds :: PrettyGuide -> PathConds -> T.Text+prettyPathConds pg = T.intercalate "\n" . map (prettyPathCond pg) . PC.toList++prettyPathCond :: PrettyGuide -> PathCond -> T.Text+prettyPathCond pg (AltCond l e b) = let- es = mkUnsugaredExprHaskell s e+ eq = mkLitHaskell l <> " = " <> mkDirtyExprHaskell pg e in- if b then es else "not (" ++ es ++ ")"-ppPathCond s (ConsCond dc e b) =+ if b then eq else "not (" <> eq <> ")"+prettyPathCond pg (ExtCond e b) =+ if b then mkDirtyExprHaskell pg e else "not (" <> mkDirtyExprHaskell pg e <> ")"+prettyPathCond pg (SoftPC pc) =+ "soft (" <> prettyPathCond pg pc <> ")"+prettyPathCond pg (MinimizePC e) =+ "minimize (" <> mkDirtyExprHaskell pg e <> ")"+prettyPathCond pg (AssumePC i l pc) = let- dcs = mkDataConHaskell dc- es = mkUnsugaredExprHaskell s e+ pc' = map PC.unhashedPC $ HS.toList pc in- if b then es ++ " is " ++ dcs else es ++ " is not " ++ dcs-ppPathCond _ (PCExists i) = "Exists " ++ mkIdHaskell i+ mkIdHaskell pg i <> " = " <> T.pack (show l) <> "=> (" <> T.intercalate "\nand " (map (prettyPathCond pg) pc') <> ")" +prettyNonRedPaths :: PrettyGuide -> [(Expr, Expr)] -> T.Text+prettyNonRedPaths pg = T.intercalate "\n" . map (\(e1, e2) -> mkDirtyExprHaskell pg e1 <> " == " <> mkDirtyExprHaskell pg e2)++prettyTypeEnv :: PrettyGuide -> TypeEnv -> T.Text+prettyTypeEnv pg = T.intercalate "\n" . map (uncurry (prettyADT pg)) . HM.toList++prettyADT :: PrettyGuide -> Name -> AlgDataTy -> T.Text+prettyADT pg n DataTyCon { bound_ids = bids, data_cons = dcs } =+ "data " <> mkNameHaskell pg n <> " "+ <> T.intercalate " " (map (mkIdHaskell pg) bids)+ <> " = " <> T.intercalate " | " (map (prettyDCWithType pg) dcs)+prettyADT pg n NewTyCon { bound_ids = bids, data_con = dc } =+ "newtype " <> mkNameHaskell pg n <> " "+ <> T.intercalate " " (map (mkIdHaskell pg) bids)+ <> " = " <> prettyDCWithType pg dc+prettyADT pg n TypeSynonym { bound_ids = bids, synonym_of = t } =+ "type " <> mkNameHaskell pg n <> " "+ <> T.intercalate " " (map (mkIdHaskell pg) bids)+ <> " = " <> mkTypeHaskellPG pg t++prettyDCWithType :: PrettyGuide -> DataCon -> T.Text+prettyDCWithType pg dc = mkDataConHaskell pg dc <> " :: " <> mkTypeHaskellPG pg (typeOf dc)++prettyTypeClasses :: PrettyGuide -> TypeClasses -> T.Text+prettyTypeClasses pg = T.intercalate "\n" . map (\(n, tc) -> mkNameHaskell pg n <> " = " <> prettyClass pg tc) . HM.toList . toMap++prettyClass :: PrettyGuide -> Class -> T.Text+prettyClass pg cls =+ let+ sc = T.intercalate ", " $ map (\(t, i) -> mkTypeHaskellPG pg t <> " " <> mkIdHaskell pg i) (superclasses cls)+ ti = T.intercalate " " . map (mkIdHaskell pg) $ typ_ids cls+ ins = T.intercalate "\n\t\t" $ map (\(t, i) -> mkTypeHaskellPG pg t <> " " <> mkIdHaskell pg i) (insts cls)+ in+ "\n\tsuper_classes = " <> sc+ <> "\n\ttype_ids = " <> ti+ <> "\n\tinsts = " <> ins++-------------------------------------------------------------------------------+ injNewLine :: [String] -> String injNewLine strs = intercalate "\n" strs -injTuple :: [String] -> String-injTuple strs = "(" ++ (intercalate "," strs) ++ ")"- -- | More raw version of state dumps.-pprExecStateStr :: State t -> Bindings -> String+pprExecStateStr :: Show t => State t -> Bindings -> String pprExecStateStr ex_state b = injNewLine acc_strs where eenv_str = pprExecEEnvStr (expr_env ex_state)@@ -264,7 +574,7 @@ estk_str = pprExecStackStr (exec_stack ex_state) code_str = pprExecCodeStr (curr_expr ex_state) names_str = pprExecNamesStr (name_gen b)- input_str = pprInputIdsStr (symbolic_ids ex_state)+ input_str = pprInputIdsStr (E.symbolicIds . expr_env $ ex_state) paths_str = pprPathsStr (PC.toList $ path_conds ex_state) non_red_paths_str = injNewLine (map show $ non_red_path_conds ex_state) tc_str = pprTCStr (type_classes ex_state)@@ -272,6 +582,7 @@ cleaned_str = pprCleanedNamesStr (cleaned_names b) model_str = pprModelStr (model ex_state) rules_str = intercalate "\n" $ map show (zip ([0..] :: [Integer]) $ rules ex_state)+ track_str = show (track ex_state) acc_strs = [ ">>>>> [State] >>>>>>>>>>>>>>>>>>>>>" , "----- [Code] ----------------------" , code_str@@ -301,6 +612,8 @@ , cleaned_str , "----- [Model] -------------------" , model_str+ , "----- [Track] -------------------"+ , track_str , "----- [Rules] -------------------" , rules_str , "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" @@ -314,12 +627,12 @@ pprTEnvStr :: TypeEnv -> String pprTEnvStr tenv = injNewLine kv_strs where- kv_strs = map show $ M.toList tenv+ kv_strs = map show $ HM.toList tenv pprModelStr :: Model -> String pprModelStr m = injNewLine kv_strs where- kv_strs = map show $ M.toList m+ kv_strs = map show $ HM.toList m pprExecStackStr :: Stack Frame -> String pprExecStackStr stk = injNewLine frame_strs@@ -343,7 +656,7 @@ pprTCStr :: TypeClasses -> String pprTCStr tc = injNewLine cond_strs where- cond_strs = map show $ M.toList $ toMap tc+ cond_strs = map show $ HM.toList $ toMap tc pprInputIdsStr :: InputIds -> String pprInputIdsStr i = injNewLine id_strs@@ -351,25 +664,54 @@ id_strs = map show i pprPathCondStr :: PathCond -> String-pprPathCondStr (AltCond am expr b) = injTuple acc_strs- where- am_str = show am- expr_str = show expr- b_str = show b- acc_strs = [am_str, expr_str, b_str]-pprPathCondStr (ExtCond am b) = injTuple acc_strs- where- am_str = show am- b_str = show b- acc_strs = [am_str, b_str]-pprPathCondStr (ConsCond d expr b) = injTuple acc_strs- where- d_str = show d- expr_str = show expr- b_str = show b- acc_strs = [d_str, expr_str, b_str]-pprPathCondStr (PCExists p) = show p+pprPathCondStr = show pprCleanedNamesStr :: CleanedNames -> String pprCleanedNamesStr = injNewLine . map show . HM.toList +printFuncCall :: FuncCall -> T.Text+printFuncCall = printFuncCallPG (mkPrettyGuide ())++printFuncCallPG :: PrettyGuide -> FuncCall -> T.Text+printFuncCallPG pg (FuncCall { funcName = f, arguments = ars, returns = r}) =+ let+ call_str fn = mkDirtyExprHaskell pg . foldl (\a a' -> App a a') (Var (Id fn TyUnknown)) $ ars+ r_str = mkDirtyExprHaskell pg r+ in+ "(" <> call_str f <> " " <> r_str <> ")"++-------------------------------------------------------------------------------+-- Pretty Guide+-------------------------------------------------------------------------------++-- | Maps G2 `Name`s to printable `String`s uniquely and consistently+-- (two `Name`s will not map to the same `String`, and on a per `PrettyGuide`+-- basis the same `Name` will always map to the same `String`.)+-- The `PrettyGuide` will only work on `Name`s it "knows" about.+-- It "knows" about names in the `Named` value it is passed in it's creation+-- (via `mkPrettyGuide`) and all `Name`s that it is passed via `updatePrettyGuide`.+data PrettyGuide = PG { pg_assigned :: HM.HashMap Name T.Text, pg_nums :: HM.HashMap T.Text Int }++mkPrettyGuide :: Named a => a -> PrettyGuide+mkPrettyGuide = foldr insertPG (PG HM.empty HM.empty) . names++updatePrettyGuide :: Named a => a -> PrettyGuide -> PrettyGuide+updatePrettyGuide ns pg = foldr insertPG pg $ names ns++insertPG :: Name -> PrettyGuide -> PrettyGuide+insertPG n pg@(PG { pg_assigned = as, pg_nums = nms })+ | not (HM.member n as) =+ case HM.lookup (nameOcc n) nms of+ Just i ->+ PG { pg_assigned = HM.insert n (nameOcc n <> "'" <> T.pack (show i)) as+ , pg_nums = HM.insert (nameOcc n) (i + 1) nms }+ Nothing ->+ PG { pg_assigned = HM.insert n (nameOcc n) as+ , pg_nums = HM.insert (nameOcc n) 1 nms }+ | otherwise = pg++lookupPG :: Name -> PrettyGuide -> Maybe T.Text+lookupPG n = HM.lookup n . pg_assigned++prettyGuideStr :: PrettyGuide -> T.Text+prettyGuideStr = T.intercalate "\n" . map (\(n, s) -> s <> " <-> " <> T.pack (show n)) . HM.toList . pg_assigned
src/G2/Liquid/AddCFBranch.hs view
@@ -1,11 +1,26 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module G2.Liquid.AddCFBranch (addCounterfactualBranch) where+module G2.Liquid.AddCFBranch ( CounterfactualName+ , addCounterfactualBranch+ , onlyCounterfactual+ , elimNonTop + , instFuncTickName+ , existentialInstId ) where+ import G2.Language+import qualified G2.Language.ExprEnv as E import G2.Language.Monad+import G2.Liquid.Config import G2.Liquid.Types+import G2.Liquid.TyVarBags +import qualified Data.HashSet as S+import Data.List++type CounterfactualName = Name+ -- Enables finding abstract counterexamples, by adding counterfactual branches -- with two states. -- (a) One state is exactly the same as the current reduce function: we lookup@@ -20,51 +35,116 @@ -- This is essentially abstracting away the function definition, leaving -- only the information that LH also knows (that is, the information in the -- refinment type.)-addCounterfactualBranch :: [Name] -> LHStateM Name-addCounterfactualBranch ns = do+addCounterfactualBranch :: CFModules+ -> [Name] -- ^ Which functions to consider abstracting+ -> LHStateM CounterfactualName+addCounterfactualBranch cf_mod ns = do+ let ns' = case cf_mod of+ CFAll -> ns+ CFOnly mods -> filter (\(Name n m _ _) -> (n, m) `S.member` mods) ns++ bag_func_ns <- return . concat =<< mapM argumentNames ns'+ inst_func_ns <- return . concat =<< mapM returnNames ns'++ createBagAndInstFuncs bag_func_ns inst_func_ns+ cfn <- freshSeededStringN "cf"- mapWithKeyME (addCounterfactualBranch' cfn ns)+ mapWithKeyME (addCounterfactualBranch' cfn ns') return cfn -addCounterfactualBranch' :: Name -> [Name]-> Name -> Expr -> LHStateM Expr+addCounterfactualBranch' :: CounterfactualName -> [Name] -> Name -> Expr -> LHStateM Expr addCounterfactualBranch' cfn ns n = if n `elem` ns then insertInLamsE (\_ -> addCounterfactualBranch'' cfn) else return -addCounterfactualBranch'' :: Name -> Expr -> LHStateM Expr+addCounterfactualBranch'' :: CounterfactualName -> Expr -> LHStateM Expr addCounterfactualBranch'' cfn orig_e@(Let - [(b, _)]- (Assert (Just (FuncCall { funcName = fn, arguments = ars })) a _)) = do- let t = returnType orig_e- sg = SymGen t-- -- Create lambdas, to gobble up any ApplyFrames left on the stack- lams <- tyBindings orig_e+ [(b, _)]+ (Assert (Just (FuncCall { funcName = fn, arguments = ars, returns = r })) a _)) = do+ sg <- cfRetValue ars rt - -- If the type of b is not the same as e's type, we have no assumption,- -- so we get a new b. Otherwise, we just keep our current b,- -- in case it is used in the assertion- b' <- if typeOf b == t then return b else freshIdN t+ -- If the type of b is not the same as e's type, we have no assumption,+ -- so we get a new b. Otherwise, we just keep our current b,+ -- in case it is used in the assertion+ b' <- if typeOf b == rt then return b else freshIdN rt - let fc = FuncCall { funcName = fn, arguments = ars', returns = (Var b')}- e' = lams $ Let [(b', sg)] $ Tick (NamedLoc cfn) $ Assume (Just fc) a (Var b')- -- We add the Id's from the newly created Lambdas to the arguments list- lamI = map Var $ leadingLamIds e'- ars' = ars ++ lamI+ let fc = FuncCall { funcName = fn, arguments = ars, returns = (Var b')}+ e' = Let [(b', sg)] $ Tick (NamedLoc cfn) $ Assume (Just fc) a (Var b') - return $ NonDet [orig_e, e']+ return $ NonDet [orig_e, e']+ where+ rt = typeOf r addCounterfactualBranch'' cfn e = modifyChildrenM (addCounterfactualBranch'' cfn) e --- Creates Lambda bindings to saturate the type of the given Typed thing,--- and a list of the bindings so they can be used elsewhere-tyBindings :: Typed t => t -> LHStateM (Expr -> Expr)-tyBindings t = do- let at = spArgumentTypes t- fn <- freshNamesN (length at)- return $ tyBindings' fn at+cfRetValue :: [Expr] -- ^ Arguments+ -> Type -- ^ Type of return value+ -> LHStateM Expr+cfRetValue ars rt+ | tvs <- tyVarIds rt+ , not (null tvs) = do+ let all_tvs = tvs ++ tyVarIds ars+ ty_bags <- getTyVarBags -tyBindings' :: [Name] -> [ArgType] -> Expr -> Expr-tyBindings' _ [] = id-tyBindings' ns (NamedType i:ts) = Lam TypeL i . tyBindings' ns ts-tyBindings' (n:ns) (AnonType t:ts) = Lam TermL (Id n t) . tyBindings' ns ts-tyBindings' [] _ = error "Name list exhausted in tyBindings'"+ ex_vrs <- freshIdsN (map TyVar all_tvs)+ let ex_tvs_to_vrs = zip all_tvs ex_vrs++ ex_ty_clls <- mapM + (\tv -> wrapExtractCalls+ . filter nullNonDet+ . concat+ =<< mapM (extractTyVarCall ty_bags ex_tvs_to_vrs tv) ars) (nub all_tvs)++ let ex_let_bnds = zip ex_vrs ex_ty_clls++ dUnit <- mkUnitE++ insts_f <- getInstFuncs+ inst_ret <- instTyVarCall insts_f ex_tvs_to_vrs rt+ let inst_ret_call = App inst_ret dUnit+ ir_bndr <- freshIdN (typeOf inst_ret_call)+ + return . Let ((ir_bndr, inst_ret_call):ex_let_bnds) $ Tick (NamedLoc instFuncTickName) (Var ir_bndr)+ | otherwise = do + return (SymGen SNoLog rt)++nullNonDet :: Expr -> Bool+nullNonDet (NonDet []) = False+nullNonDet _ = True++instFuncTickName :: Name+instFuncTickName = Name "INST_FUNC_TICK" Nothing 0 Nothing++argumentNames :: ExState s m => Name -> m [Name]+argumentNames n = do+ e <- lookupE n+ case e of+ Just e' -> return . concatMap tyConNames $ anonArgumentTypes e'+ Nothing -> return []++returnNames :: ExState s m => Name -> m [Name]+returnNames n = do+ e <- lookupE n+ case e of+ Just e' -> return . tyConNames $ returnType e'+ Nothing -> return []++tyConNames :: Type -> [Name]+tyConNames (TyCon n t) = n:tyConNames t +tyConNames t = evalChildren tyConNames t++-- | Eliminates the real branch of the non-deterministic choices, leaving only+-- the abstract branch. Assumes all non-determinisitic choices are for+-- counterfactual symbolic execution.+onlyCounterfactual :: ASTContainer m Expr => m -> m+onlyCounterfactual = modifyASTs onlyCounterfactual'++onlyCounterfactual' :: Expr -> Expr+onlyCounterfactual' (NonDet [_, e]) = e+onlyCounterfactual' e = e++-- | Eliminate all Asserts, except for the functions with names in the HashSet+elimNonTop :: S.HashSet Name -> State t -> State t+elimNonTop hs s@(State { expr_env = eenv }) = s { expr_env = E.mapWithKey (elimNonTop' hs) eenv }++elimNonTop' :: S.HashSet Name -> Name -> Expr -> Expr+elimNonTop' hs n e = if n `S.member` hs then e else elimAsserts e
src/G2/Liquid/AddLHTC.hs view
@@ -2,13 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} module G2.Liquid.AddLHTC ( addLHTC- , addLHTCExprPasses ) where+ , addLHTCCurrExpr+ , addLHTCExprPasses ) where import G2.Language import G2.Language.Monad import G2.Liquid.Types -import qualified Data.Map as M+import qualified Data.HashMap.Lazy as HM -- | Adds the LiquidHaskell typeclass to all functions in the ExprEnv, and to -- the current expression. This requires:@@ -18,9 +19,12 @@ addLHTC :: LHStateM () addLHTC = do mapME addLHTCExprEnv+ addLHTCCurrExpr +addLHTCCurrExpr :: LHStateM ()+addLHTCCurrExpr = do (CurrExpr er ce) <- currExpr- ce' <- addLHTCExprPasses M.empty ce+ ce' <- addLHTCExprPasses HM.empty ce putCurrExpr (CurrExpr er ce') addLHTCExprEnv :: Expr -> LHStateM Expr@@ -43,7 +47,7 @@ addTypeLams' :: Type -> Expr -> LHStateM Expr addTypeLams' (TyForAll _ t) (Lam TypeL i e) = return . Lam TypeL i =<< addTypeLams' t e-addTypeLams' (TyForAll (NamedTyBndr i) t) e =+addTypeLams' (TyForAll i t) e = return . Lam TypeL i =<< addTypeLams' t (App e (Type (TyVar i))) addTypeLams' _ e = return e @@ -62,7 +66,7 @@ addTypeLamsLet' e = return e -- Updates a function definition with Lambdas to take the LH TC for each type argument.-addLHTCExprEnvLams :: [Id] -> Expr -> LHStateM (Expr, M.Map Name Id)+addLHTCExprEnvLams :: [Id] -> Expr -> LHStateM (Expr, HM.HashMap Name Id) addLHTCExprEnvLams is (Lam TypeL i e) = do (e', m) <- addLHTCExprEnvLams (i:is) e return (Lam TypeL i e', m)@@ -70,7 +74,7 @@ lh <- lhTCM let is' = reverse is- let is'' = map (TyApp (TyCon lh (TyApp TYPE TYPE)) . TyVar) $ is'+ let is'' = map (TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) $ is' is''' <- freshIdsN is'' -- Lambdas may be nested in an Expr (for example, if the lambda is in a Let)@@ -80,19 +84,19 @@ let e' = foldr (Lam TermL) le is''' - let m = M.fromList $ zip (map idName is') is'''+ let m = HM.fromList $ zip (map idName is') is''' - return (e', M.union m m')+ return (e', HM.union m m') -addLHTCExprEnvNextLams :: Expr -> LHStateM (Expr, M.Map Name Id)-addLHTCExprEnvNextLams e@(Var _) = return (e, M.empty)-addLHTCExprEnvNextLams e@(Lit _) = return (e, M.empty)-addLHTCExprEnvNextLams e@(Prim _ _) = return (e, M.empty)-addLHTCExprEnvNextLams e@(Data _) = return (e, M.empty)+addLHTCExprEnvNextLams :: Expr -> LHStateM (Expr, HM.HashMap Name Id)+addLHTCExprEnvNextLams e@(Var _) = return (e, HM.empty)+addLHTCExprEnvNextLams e@(Lit _) = return (e, HM.empty)+addLHTCExprEnvNextLams e@(Prim _ _) = return (e, HM.empty)+addLHTCExprEnvNextLams e@(Data _) = return (e, HM.empty) addLHTCExprEnvNextLams (App e1 e2) = do (e1', m1) <- addLHTCExprEnvNextLams e1 (e2', m2) <- addLHTCExprEnvNextLams e2- return (App e1' e2', M.union m1 m2)+ return (App e1' e2', HM.union m1 m2) addLHTCExprEnvNextLams e@(Lam TypeL _ _) = addLHTCExprEnvLams [] e addLHTCExprEnvNextLams (Lam TermL i e) = do (e', m) <- addLHTCExprEnvNextLams e@@ -104,35 +108,35 @@ ) b (e', m) <- addLHTCExprEnvNextLams e - return (Let b' e', foldr M.union M.empty (m:ms))-addLHTCExprEnvNextLams (Case e i a) = do+ return (Let b' e', foldr HM.union HM.empty (m:ms))+addLHTCExprEnvNextLams (Case e i t a) = do (e', m) <- addLHTCExprEnvNextLams e (a', ms) <- return . unzip =<< mapM addLHTCExprEnvNextLamsAlt a - return (Case e' i a', foldr M.union M.empty (m:ms))-addLHTCExprEnvNextLams e@(Type _) = return (e, M.empty)+ return (Case e' i t a', foldr HM.union HM.empty (m:ms))+addLHTCExprEnvNextLams e@(Type _) = return (e, HM.empty) addLHTCExprEnvNextLams (Cast e c) = do (e', m) <- addLHTCExprEnvNextLams e return (Cast e' c, m)-addLHTCExprEnvNextLams e@(Coercion _) = return (e, M.empty)+addLHTCExprEnvNextLams e@(Coercion _) = return (e, HM.empty) addLHTCExprEnvNextLams (Tick t e) = do (e', m) <- addLHTCExprEnvNextLams e return (Tick t e', m) addLHTCExprEnvNextLams (NonDet es) = do (es', ms) <- return . unzip =<< mapM addLHTCExprEnvNextLams es- return (NonDet es', foldr M.union M.empty ms)-addLHTCExprEnvNextLams e@(SymGen _) = return (e, M.empty)+ return (NonDet es', foldr HM.union HM.empty ms)+addLHTCExprEnvNextLams e@(SymGen _ _) = return (e, HM.empty) addLHTCExprEnvNextLams (Assume fc e1 e2) = do (e1', m1) <- addLHTCExprEnvNextLams e1 (e2', m2) <- addLHTCExprEnvNextLams e2- return (Assume fc e1' e2', M.union m1 m2)+ return (Assume fc e1' e2', HM.union m1 m2) addLHTCExprEnvNextLams (Assert fc e1 e2) = do (e1', m1) <- addLHTCExprEnvNextLams e1 (e2', m2) <- addLHTCExprEnvNextLams e2- return (Assert fc e1' e2', M.union m1 m2)+ return (Assert fc e1' e2', HM.union m1 m2) -addLHTCExprEnvNextLamsAlt :: Alt -> LHStateM (Alt, M.Map Name Id)+addLHTCExprEnvNextLamsAlt :: Alt -> LHStateM (Alt, HM.HashMap Name Id) addLHTCExprEnvNextLamsAlt (Alt am e) = do (e', m) <- addLHTCExprEnvNextLams e return (Alt am e', m)@@ -141,26 +145,34 @@ -- This requires both: -- (1) Modifying the expression, to pass the appropriate arguments -- (2) Modifying the type of the function variable-addLHTCExprEnvPasses :: M.Map Name Id -> Expr -> LHStateM Expr+addLHTCExprEnvPasses :: HM.HashMap Name Id -> Expr -> LHStateM Expr addLHTCExprEnvPasses m e = addLHTCExprPasses m =<< addLHDictToTypes m e -- We only want to pass the LH TC to Var's (aka function calls) -- We DO NOT want to put it in DataCons-addLHTCExprPasses :: M.Map Name Id -> Expr -> LHStateM Expr+addLHTCExprPasses :: HM.HashMap Name Id -> Expr -> LHStateM Expr addLHTCExprPasses m = modifyAppTopE (addLHTCExprPasses' m) -addLHTCExprPasses' :: M.Map Name Id -> Expr -> LHStateM Expr+addLHTCExprPasses' :: HM.HashMap Name Id -> Expr -> LHStateM Expr addLHTCExprPasses' m a@(App _ _)- | (Data _:_) <- unApp a = return a- | otherwise = do- let a' = unApp a- a'' <- addLHTCExprPasses'' m [] a'- return $ mkApp a''+ | (Data _:_) <- as = return a+ | otherwise = do + if any (isLHDict) as+ then return a+ else do+ a' <- addLHTCExprPasses'' m [] as+ return $ mkApp a'+ where+ as = unApp a + isLHDict (Var (Id _ t))+ | TyCon (Name "lh" _ _ _) _ <- tyAppCenter t = True+ isLHDict _ = False+ addLHTCExprPasses' _ e = return e -addLHTCExprPasses'' :: M.Map Name Id -> [Expr] -> [Expr] -> LHStateM [Expr]+addLHTCExprPasses'' :: HM.HashMap Name Id -> [Expr] -> [Expr] -> LHStateM [Expr] addLHTCExprPasses'' _ es [] = return $ reverse es addLHTCExprPasses'' m es (te@(Type t):es') = do dict <- lhTCDict m t@@ -168,34 +180,37 @@ return $ te:as addLHTCExprPasses'' m es (e:es') | Var (Id n _) <- e- , Just dict <- M.lookup n m = do+ , Just dict <- HM.lookup n m = do as <- addLHTCExprPasses'' m (Var dict:es) es' return $ e:as | otherwise = do as <- addLHTCExprPasses'' m [] es' return $ reverse es ++ e:as --- We want to add a LH Dict Type argument to Var's, but not DataCons or Lambdas.+-- We want to add a LH Dict Type argument to Var's and Cases, but not DataCons or Lambdas. -- That is: function calls need to be passed the LH Dict but it -- doesn't need to be passed around in DataCons-addLHDictToTypes :: ASTContainerM e Expr => M.Map Name Id -> e -> LHStateM e+addLHDictToTypes :: ASTContainerM e Expr => HM.HashMap Name Id -> e -> LHStateM e addLHDictToTypes m = modifyASTsM (addLHDictToTypes' m) -addLHDictToTypes' :: M.Map Name Id -> Expr -> LHStateM Expr+addLHDictToTypes' :: HM.HashMap Name Id -> Expr -> LHStateM Expr addLHDictToTypes' m (Var (Id n t)) = return . Var . Id n =<< addLHDictToTypes'' m t+addLHDictToTypes' m (Case e i t a) = do+ t' <- addLHDictToTypes'' m t+ return $ Case e i t' a addLHDictToTypes' _ e = return e -addLHDictToTypes'' :: M.Map Name Id -> Type -> LHStateM Type-addLHDictToTypes'' m t@(TyForAll (NamedTyBndr _) _) = addLHDictToTypes''' m [] t+addLHDictToTypes'' :: HM.HashMap Name Id -> Type -> LHStateM Type+addLHDictToTypes'' m t@(TyForAll _ _) = addLHDictToTypes''' m [] t addLHDictToTypes'' m t = modifyChildrenM (addLHDictToTypes'' m) t -addLHDictToTypes''' :: M.Map Name Id -> [Id] -> Type -> LHStateM Type-addLHDictToTypes''' m is (TyForAll (NamedTyBndr b) t) =- return . TyForAll (NamedTyBndr b) =<< addLHDictToTypes''' m (b:is) t+addLHDictToTypes''' :: HM.HashMap Name Id -> [Id] -> Type -> LHStateM Type+addLHDictToTypes''' m is (TyForAll b t) =+ return . TyForAll b =<< addLHDictToTypes''' m (b:is) t addLHDictToTypes''' m is t = do lh <- lhTCM let is' = reverse is- let dictT = map (TyApp (TyCon lh (TyApp TYPE TYPE)) . TyVar) is'+ let dictT = map (TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) is' -- The recursive step in addLHDictToTypes'' only kicks in when it is not -- at a TyForAll. So we have to perform recursion here, on the type nested@@ -204,13 +219,13 @@ return $ foldr TyFun t' dictT -lhTCDict :: M.Map Name Id -> Type -> LHStateM Expr+lhTCDict :: HM.HashMap Name Id -> Type -> LHStateM Expr lhTCDict m t = do lh <- lhTCM tc <- typeClassInstTC m lh t case tc of Just e -> return $ dropAppedLH e- Nothing -> return $ Var (Id (Name "BAD 2" Nothing 0 Nothing) TyUnknown)+ Nothing -> return $ Var (Id (Name "bad2" Nothing 0 Nothing) (TyCon lh (TyFun TYPE TYPE))) where -- typeClassInstTC adds any needed LH Dict arguments for us. -- Unfortunately, the LH Dicts are then added AGAIN, by addLHTCExprEnvPasses
src/G2/Liquid/AddOrdToNum.hs view
@@ -23,13 +23,17 @@ addOrdToNum :: LHStateM () addOrdToNum = do tc <- typeClasses+ lh_tc <- lhRenamedTCM num <- numTCM -- Rewrite dictionary declaration let tcd = lookupTCDicts num tc- case tcd of- Just tcd' -> mapM_ (uncurry addOrdToNumDictDec) tcd'- Nothing -> return ()+ lh_tcd = lookupTCDicts num lh_tc+ case (tcd, lh_tcd) of+ (Just tcd', Just lh_tcd') -> do+ mapM_ (uncurry (addOrdToNumDictDec lookupE insertE)) tcd'+ mapM_ (uncurry (addOrdToNumDictDec lookupMeasureM insertMeasureM)) lh_tcd'+ _ -> return () -- Rewrite case statements mapME addOrdToNumCase@@ -45,11 +49,15 @@ -- Create a function to extract the Ord Dict ordDictFunc -addOrdToNumDictDec :: Type -> Id -> LHStateM ()-addOrdToNumDictDec t (Id n _) = do+addOrdToNumDictDec :: (Name -> LHStateM (Maybe Expr))+ -> (Name -> Expr -> LHStateM ())+ -> Type+ -> Id+ -> LHStateM ()+addOrdToNumDictDec lkup insert t (Id n _) = do ord <- ordTCM - me <- lookupE n+ me <- lkup n case me of Just e -> do@@ -58,14 +66,14 @@ e' <- insertInLamsE (\_ e'' -> return (App e'' ordD')) e - insertE n e'+ insert n e' Nothing -> return () addOrdToNumCase :: Expr -> LHStateM Expr addOrdToNumCase = modifyASTsM addOrdToNumCase' addOrdToNumCase' :: Expr -> LHStateM Expr-addOrdToNumCase' ce@(Case e i@(Id _ t) a@[Alt (DataAlt dc is) ae])+addOrdToNumCase' ce@(Case e i@(Id _ t) ct a@[Alt (DataAlt dc is) ae]) | (TyCon n ts) <- tyAppCenter t = do num <- numTCM ord <- ordTCM@@ -75,8 +83,8 @@ if num == n then do ordI <- freshIdN ordT let is' = is ++ [ordI]- return (Case e i [Alt (DataAlt dc is') ae])- else return (Case e i a)+ return (Case e i ct [Alt (DataAlt dc is') ae])+ else return (Case e i ct a) | otherwise = return ce addOrdToNumCase' e = return e @@ -90,10 +98,10 @@ | (TyCon n _) <- tyAppCenter $ returnType dc , num == n = return . Data =<< changeNumTypeDC dc | otherwise = return d-changeNumType' num ce@(Case e i@(Id n _) [Alt (DataAlt dc is) ae])+changeNumType' num ce@(Case e i@(Id n _) ct [Alt (DataAlt dc is) ae]) | num == n = do dc' <- changeNumTypeDC dc- return (Case e i [Alt (DataAlt dc' is) ae])+ return (Case e i ct [Alt (DataAlt dc' is) ae]) | otherwise = return ce changeNumType' _ e = return e @@ -103,8 +111,7 @@ return (DataCon n t') changeNumTypeType :: Maybe Id -> Type -> LHStateM Type-changeNumTypeType _ (TyForAll b@(NamedTyBndr i) t) = return . TyForAll b =<< changeNumTypeType (Just i) t-changeNumTypeType i (TyForAll b t) = return . TyForAll b =<< changeNumTypeType i t+changeNumTypeType _ (TyForAll i t) = return . TyForAll i =<< changeNumTypeType (Just i) t changeNumTypeType i (TyFun t t') = return . TyFun t =<< changeNumTypeType i t' changeNumTypeType i t = do ord <- ordTCM@@ -133,10 +140,12 @@ num <- numTCM let numT = TyCon num TYPE - Just numDC <- lookupT num- let [numDC'] = dataCon numDC+ numDC <- lookupT num+ let [numDC'] = case numDC of+ Just ndc -> dataCon ndc+ Nothing -> error "ordDictFunc: No NumDC" - let numA = dataConArgs numDC'+ let numA = anonArgumentTypes numDC' lamI <- freshIdN numT caseI <- freshIdN numT@@ -144,7 +153,7 @@ binds <- freshIdsN numA let cOrdBIs = last binds - let e = Lam TermL lamI $ Case (Var lamI) caseI [Alt (DataAlt numDC' binds) (Var cOrdBIs)]+ let e = Lam TermL lamI $ Case (Var lamI) caseI (typeOf cOrdBIs) [Alt (DataAlt numDC' binds) (Var cOrdBIs)] (Id n _) <- lhNumOrdM insertE n e
+ src/G2/Liquid/AddTyVars.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module G2.Liquid.AddTyVars ( addTyVarsEEnvTEnv+ , addTyVarsMeasures++ , PhantomTyVars) where++import G2.Initialization.Types+import G2.Language hiding (State (..), Bindings (..))+import G2.Liquid.Types++import qualified Data.HashMap.Lazy as HM+import Data.List+import Data.Maybe+import Data.Text as T (pack)++addTyVarsEEnvTEnv :: SimpleState -> (SimpleState, PhantomTyVars)+addTyVarsEEnvTEnv s@(SimpleState { expr_env = eenv+ , type_env = tenv+ , known_values = kv+ , name_gen = ng }) =+ let+ (new_mjn, ng') = mkNewMaybe kv ng++ unused_poly = getUnusedPoly tenv++ eenv' = addTyVarsExpr unused_poly eenv ng eenv+ tenv' = addTyVarsTypeEnv unused_poly tenv++ tenv'' = addNewMaybe new_mjn tenv'+ in+ (s { expr_env = eenv', type_env = tenv'', name_gen = ng' }+ , PhantomTyVars { ph_new_maybe = new_mjn, ph_unused_poly = unused_poly })++addTyVarsMeasures :: PhantomTyVars -> LHStateM ()+addTyVarsMeasures PhantomTyVars { ph_unused_poly = unused_poly } = do+ meenv <- measuresM+ ng <- nameGen+ putMeasuresM (addTyVarsExpr unused_poly meenv ng meenv)++-- | Identifies data constructors with unused polymorphic arguments+getUnusedPoly :: TypeEnv -> UnusedPoly +getUnusedPoly tenv =+ let+ adts = HM.elems tenv+ in+ foldr unionUP emptyUP $ map getUnusedPoly' adts++getUnusedPoly' :: AlgDataTy -> UnusedPoly+getUnusedPoly' adt =+ let+ bound = bound_ids adt+ dcs = case adt of+ DataTyCon { data_cons = dcs' } -> dcs'+ NewTyCon {} -> []+ TypeSynonym {} -> []+ in+ foldr (uncurry insertUP) emptyUP $ mapMaybe (getUnusedPoly'' bound) dcs++getUnusedPoly'' :: [Id] -> DataCon -> Maybe (Name, [Int])+getUnusedPoly'' is dc@(DataCon n _) =+ let+ used = tyVarIds . argumentTypes . PresType . inTyForAlls $ typeOf dc+ in+ case filter (flip notElem used) is of+ [] -> Nothing+ not_used -> Just (n, getTypeInds not_used (typeOf dc))++getTypeInds :: [Id] -> Type -> [Int]+getTypeInds is t =+ map fst+ . filter (flip elem is . snd)+ . zip [0..]+ . leadingTyForAllBindings+ $ PresType t++-------------------------------+-- Adjust TypeEnv+-------------------------------+addTyVarsTypeEnv :: UnusedPoly -> TypeEnv -> TypeEnv+addTyVarsTypeEnv unused = HM.map (addTyVarADT unused) ++addTyVarADT :: UnusedPoly -> AlgDataTy -> AlgDataTy+addTyVarADT unused dtc@(DataTyCon { data_cons = dcs }) =+ dtc { data_cons = map (addTyVarDC unused) dcs }+addTyVarADT _ adt = adt++addNewMaybe :: NewMaybe -> TypeEnv -> TypeEnv+addNewMaybe new_mb@(NewMaybe { new_maybe = new_mb_t }) tenv =+ let+ dtc = DataTyCon { bound_ids = [Id (new_maybe_bound new_mb) TYPE]+ , data_cons = [mkNewJustDC new_mb, mkNewNothingDC new_mb] }+ in+ HM.insert new_mb_t dtc tenv++-------------------------------+-- Adjust Expr+-------------------------------++addTyVarsExpr :: ASTContainer m Expr => UnusedPoly -> ExprEnv -> NameGen -> m -> m+addTyVarsExpr unused eenv ng =+ modifyASTs (addTyVarsExprCase unused) . addTyVarsExprDC unused . etaExpandDC eenv ng++etaExpandDC :: ASTContainer m Expr => ExprEnv -> NameGen -> m -> m+etaExpandDC eenv ng = modifyAppedDatas (etaExpandDC' eenv ng) ++etaExpandDC' :: ExprEnv -> NameGen -> DataCon -> [Expr] -> Expr+etaExpandDC' eenv ng dc ars =+ let+ e = mkApp (Data dc:ars)+ num_binds = length $ leadingTyForAllBindings dc+ (e', _) = etaExpandTo eenv ng num_binds e+ in+ e'++addTyVarsExprDC :: ASTContainer m Expr => UnusedPoly -> m -> m+addTyVarsExprDC unused = modifyAppedDatas (addTyVarsExprDC' unused)++addTyVarsExprDC' :: UnusedPoly -> DataCon -> [Expr] -> Expr+addTyVarsExprDC' unused dc@(DataCon n _) ars+ | Just is <- lookupUP n unused =+ let+ (ty_ars, expr_ars) = partition (isTypeExpr) ars++ sym_gens = map (\(Type t) -> SymGen SNoLog t) $ map (ars !!) is+ -- nothings = map (\(Type t) -> mkNewNothing new_mb) $ map (ars !!) is+ in+ mkApp $ Data (addTyVarDC unused dc):ty_ars ++ sym_gens ++ expr_ars+ | otherwise = mkApp $ Data dc:ars++addTyVarsExprCase :: UnusedPoly -> Expr -> Expr+addTyVarsExprCase unused (Case e i t as) =+ Case e i t $ map (addTyVarsAlt unused e) as+addTyVarsExprCase _ e = e++addTyVarsAlt :: UnusedPoly -> Expr -> Alt -> Alt+addTyVarsAlt unused case_e (Alt (DataAlt dc@(DataCon n _) is) alt_e)+ | Just i <- lookupUP n unused = + let+ dc' = addTyVarDC unused dc++ ty_binds = reverse . unTyApp $ typeOf case_e++ n_str = "a_FILLING_IN_HERE"+ new_is = map (\(l, tyi) -> Id (Name (T.pack $ n_str ++ show l) Nothing 0 Nothing) $ tyi) + . zip ([0..] :: [Int])+ $ map (ty_binds !!) i+ is' = new_is ++ is+ in+ Alt (DataAlt dc' is') alt_e+addTyVarsAlt _ _ alt = alt++-------------------------------+-- Generic+-------------------------------+addTyVarDC :: UnusedPoly -> DataCon -> DataCon+addTyVarDC unused dc@(DataCon n t)+ | Just is <- lookupUP n unused = DataCon n (addTyVarsToType is t)+ | otherwise = dc++addTyVarsToType :: [Int] -> Type -> Type+addTyVarsToType i t =+ let+ ty_binds = leadingTyForAllBindings (PresType t)+ is = map (ty_binds !!) i+ in+ mapInTyForAlls (\t' -> mkTyFun $ map TyVar is ++ [t']) t++isTypeExpr :: Expr -> Bool+isTypeExpr (Type _) = True+isTypeExpr _ = False++-------------------------------+-- Added TyVar+-------------------------------++data PhantomTyVars = PhantomTyVars { ph_new_maybe :: NewMaybe, ph_unused_poly :: UnusedPoly }++-------------------------------+-- New Maybe+-------------------------------+data NewMaybe = NewMaybe { new_maybe :: Name++ , new_maybe_bound :: Name+ , new_just :: Name+ , new_nothing :: Name }++mkNewMaybe :: KnownValues -> NameGen -> (NewMaybe, NameGen)+mkNewMaybe _ ng =+ let+ ((n_m, n_j, n_n), ng') = renameAll ( Name "NewMaybe" Nothing 0 Nothing+ , Name "NewJust" Nothing 0 Nothing+ , Name "NewNothing" Nothing 0 Nothing) ng+ bnd = Name "a_NEW_MAYBE" Nothing 0 Nothing+ in+ (NewMaybe { new_maybe = n_m, new_maybe_bound = bnd, new_just = n_j, new_nothing = n_n }, ng')++mkNewJustDC :: NewMaybe -> DataCon+mkNewJustDC new_mb =+ let+ n = new_just new_mb++ a = new_maybe_bound new_mb+ tya = TyVar (Id a TYPE)+ t = TyForAll (Id a TYPE)+ . TyFun tya+ $ TyApp (TyCon (new_maybe new_mb) TYPE) tya+ in+ DataCon n t++mkNewNothingDC :: NewMaybe -> DataCon+mkNewNothingDC new_mb =+ let+ n = new_nothing new_mb++ a = new_maybe_bound new_mb+ tya = TyVar (Id a TYPE)+ t = TyForAll (Id a TYPE)+ $ TyApp (TyCon (new_maybe new_mb) TYPE) tya+ in+ DataCon n t++-------------------------------+-- UnusedPoly+-------------------------------+newtype UnusedPoly = UnusedPoly (HM.HashMap Name [Int])+ deriving (Show, Read)++emptyUP :: UnusedPoly+emptyUP = UnusedPoly HM.empty++lookupUP :: Name -> UnusedPoly -> Maybe [Int]+lookupUP n (UnusedPoly up) = HM.lookup n up++insertUP :: Name -> [Int] -> UnusedPoly -> UnusedPoly+insertUP n is (UnusedPoly up) = UnusedPoly $ HM.insert n is up++unionUP :: UnusedPoly -> UnusedPoly -> UnusedPoly+unionUP (UnusedPoly up1) (UnusedPoly up2) = UnusedPoly $ HM.union up1 up2
src/G2/Liquid/Annotations.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module G2.Liquid.Annotations ( AnnotMap@@ -25,9 +25,11 @@ import Data.Maybe import qualified Data.Text as T +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+import GHC.Types.SrcLoc+#else import SrcLoc--import Debug.Trace+#endif lookupAnnot :: Name -> AnnotMap -> Maybe [(Maybe T.Text, Expr)] lookupAnnot (Name _ _ _ (Just s)) =@@ -69,7 +71,7 @@ let ai = leadingLamUsesIds e' dm <- dictMapFromIds (map snd ai) - ce <- convertSpecType dm M.empty (map snd ai) (Just i) ast+ ce <- convertSpecType CheckPre dm HM.empty (map snd ai) (Just i) ast let ce' = addIds ce (ai ++ [(TermL, i)]) insertAnnotM spn n ce'@@ -118,7 +120,7 @@ pickOneA xas = case (rs, ds, ls, us) of (x:_, _, _, _) -> [x] (_, x:_, _, _) -> [x]- (_, _, _:_, _) -> trace ("Loc") []+ (_, _, _:_, _) -> [] (_, _, _, x:_) -> [x] -- (_, x:_, _, _) -> [x]
+ src/G2/Liquid/Config.hs view
@@ -0,0 +1,83 @@+module G2.Liquid.Config ( LHConfig (..)+ , Counterfactual (..)+ , CFModules (..)+ , BlockErrorsMethod (..)+ , getLHConfig+ , mkLHConfig+ , mkLHConfigDirect) where++import G2.Config.Config++import qualified Data.HashSet as S+import qualified Data.Map.Lazy as M+import Data.Monoid ((<>))+import qualified Data.Text as T+import Options.Applicative+import System.Directory++data Counterfactual = Counterfactual CFModules | NotCounterfactual deriving (Eq, Show, Read)++data CFModules = CFAll | CFOnly (S.HashSet (T.Text, Maybe T.Text)) deriving (Eq, Show, Read)++data BlockErrorsMethod = ArbBlock+ | AssumeBlock deriving (Eq, Show, Read)++data LHConfig = LHConfig {+ cut_off :: Int -- ^ How many steps to take after finding an equally good equiv state, in LH mode+ , switch_after :: Int --- ^ How many steps to take in a single step, in LH mode+ , counterfactual :: Counterfactual -- ^ Which functions should be able to generate abstract counterexamples+ , only_top :: Bool -- ^ Only try to find counterexamples in the very first function definition, or directly called functions?+ , block_errors_in :: (S.HashSet (T.Text, Maybe T.Text)) -- ^ Prevents calls from errors occuring in the indicated functions+ , block_errors_method :: BlockErrorsMethod -- ^ Should errors be blocked with an Assume or with an arbitrarily inserted value+ , reduce_abs :: Bool+ , add_tyvars :: Bool+ }++getLHConfig :: IO (String, String, Config, LHConfig)+getLHConfig = do+ homedir <- getHomeDirectory+ execParser (mkConfigInfo homedir)++mkConfigInfo :: String -> ParserInfo (String, String, Config, LHConfig)+mkConfigInfo homedir =+ info (((,,,) <$> getFileName <*> getFunctionName <*> mkConfig homedir <*> mkLHConfig) <**> helper)+ ( fullDesc+ <> progDesc "Allows symbolically executing LiquidHaskell code"+ <> header "The G2 Symbolic Execution Engine" )++getFileName :: Parser String+getFileName = argument str (metavar "FILE")++getFunctionName :: Parser String+getFunctionName = argument str (metavar "FUNCTION")++mkLHConfig :: Parser LHConfig+mkLHConfig = LHConfig+ <$> option auto (long "cut-off"+ <> metavar "N"+ <> value 600+ <> help "how many steps to take after finding an equally good equivalent state, in LH mode ")+ <*> option auto (long "switch-after"+ <> metavar "N"+ <> value 300+ <> help "how many steps to take before switching states, in LH mode ")+ <*> flag (Counterfactual CFAll) (NotCounterfactual) (long "no-counterfactual" <> help "disable counterfactual counterexamples")+ <*> pure False+ <*> pure S.empty+ <*> pure AssumeBlock+ <*> pure True+ <*> pure False+++mkLHConfigDirect :: [String] -> M.Map String [String] -> LHConfig+mkLHConfigDirect as m = LHConfig {+ cut_off = strArg "cut-off" as m read 600+ , switch_after = strArg "switch-after" as m read 300+ , counterfactual = boolArg' "counterfactual" as+ (Counterfactual CFAll) (Counterfactual CFAll) NotCounterfactual+ , only_top = False+ , block_errors_in = S.empty+ , block_errors_method = AssumeBlock+ , reduce_abs = True+ , add_tyvars = False+}
src/G2/Liquid/Conversion.hs view
@@ -1,27 +1,35 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP, FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} module G2.Liquid.Conversion ( LHDictMap- , DictMaps (..)- , BoundTypes- , mergeLHSpecState- , convertSpecType- , dictMapFromIds- , convertLHExpr- , specTypeToType- , unsafeSpecTypeToType- , symbolName- , lhTCDict') where+ , DictMaps (..)+ , BoundTypes+ , CheckPre (..)+ , mergeLHSpecState+ , convertSpecType+ , dictMapFromIds+ , convertLHExpr+ , specTypeToType+ , unsafeSpecTypeToType+ , symbolName+ , lhTCDict' + , higherOrderTickName) where+ import G2.Language import qualified G2.Language.KnownValues as KV import G2.Language.Monad import qualified G2.Language.ExprEnv as E+import G2.Language.TypeEnv import G2.Liquid.Types import G2.Translation.Haskell +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+import qualified GHC.Types.Var as Var+#else import qualified Var as Var+#endif import Language.Fixpoint.Types.Names import Language.Fixpoint.Types.Sorts@@ -37,56 +45,72 @@ import qualified Data.Text as T -- | A mapping of TyVar Name's, to Id's for the LH dict's-type LHDictMap = M.Map Name Id+type LHDictMap = HM.HashMap Name Id -- | A mapping of TyVar Name's, to Id's for the Num dict's-type NumDictMap = M.Map Name Id+type NumDictMap = HM.HashMap Name Id -- | A mapping of TyVar Name's, to Id's for the Integral dict's-type IntegralDictMap = M.Map Name Id+type IntegralDictMap = HM.HashMap Name Id +-- | A mapping of TyVar Name's, to Id's for the Fractional dict's+type FractionalDictMap = HM.HashMap Name Id+ -- | A mapping of TyVar Name's, to Id's for the Ord dict's-type OrdDictMap = M.Map Name Id+type OrdDictMap = HM.HashMap Name Id -- | A collection of all DictMaps required to convert LH refinement types to G2 `Expr`@s@ data DictMaps = DictMaps { lh_dicts :: LHDictMap , num_dicts :: NumDictMap , integral_dicts :: IntegralDictMap+ , fractional_dicts :: FractionalDictMap , ord_dicts :: OrdDictMap } deriving (Eq, Show, Read) copyIds :: Name -> Name -> DictMaps -> DictMaps-copyIds n1 n2 dm@(DictMaps { lh_dicts = lhd, num_dicts = nd, integral_dicts = ind, ord_dicts = od }) =+copyIds n1 n2 dm@(DictMaps { lh_dicts = lhd+ , num_dicts = nd+ , integral_dicts = ind+ , fractional_dicts = frac+ , ord_dicts = od }) = let- dm2 = case M.lookup n1 lhd of- Just lh -> dm { lh_dicts = M.insert n2 lh lhd }+ dm2 = case HM.lookup n1 lhd of+ Just lh -> dm { lh_dicts = HM.insert n2 lh lhd } Nothing -> dm - dm3 = case M.lookup n1 nd of- Just num -> dm2 { num_dicts = M.insert n2 num nd }+ dm3 = case HM.lookup n1 nd of+ Just num -> dm2 { num_dicts = HM.insert n2 num nd } Nothing -> dm2 - dm4 = case M.lookup n1 ind of- Just int -> dm3 { integral_dicts = M.insert n2 int ind }+ dm4 = case HM.lookup n1 ind of+ Just int -> dm3 { integral_dicts = HM.insert n2 int ind } Nothing -> dm3 - dm5 = case M.lookup n1 od of- Just ord -> dm4 { ord_dicts = M.insert n2 ord od }+ dm5 = case HM.lookup n1 frac of+ Just fr -> dm4 { fractional_dicts = HM.insert n2 fr frac } Nothing -> dm4++ dm6 = case HM.lookup n1 od of+ Just ord -> dm5 { ord_dicts = HM.insert n2 ord od }+ Nothing -> dm5 in- dm5+ dm6 -- | A mapping of variable names to the corresponding types-type BoundTypes = M.Map Name Type+type BoundTypes = HM.HashMap Name Type -mergeLHSpecState :: [(Var.Var, LocSpecType)] -> LHStateM ()-mergeLHSpecState = mapM_ (uncurry mergeLHSpecState')+type NMExprEnv = HM.HashMap (T.Text, Maybe T.Text) (Name, Expr) -mergeLHSpecState' :: Var.Var -> LocSpecType -> LHStateM ()-mergeLHSpecState' v lst = do+mergeLHSpecState :: [(Var.Var, LocSpecType)] -> LHStateM ()+mergeLHSpecState var_st = do eenv <- exprEnv+ let nm_eenv = E.nameModMap eenv+ mapM_ (uncurry (mergeLHSpecState' nm_eenv)) var_st++mergeLHSpecState' :: NMExprEnv -> Var.Var -> LocSpecType -> LHStateM ()+mergeLHSpecState' nm_eenv v lst = do let (Id (Name n m _ _) _) = mkIdUnsafe v- g2N = E.lookupNameMod n m eenv+ g2N = HM.lookup (n, m) nm_eenv case g2N of Just (n', e) -> do@@ -97,10 +121,14 @@ assumpt <- createAssumption (val lst) e insertAssumptionM n' assumpt++ post <- createPost (val lst) e+ insertPostM n' post False -> return () Nothing -> return () convertVar :: Name -> Bool+convertVar (Name "fromInteger" _ _ _) = False convertVar (Name "error" _ _ _) = False convertVar (Name "patError" _ _ _) = False convertVar (Name "." _ _ _) = False@@ -118,25 +146,36 @@ -- Gather up LH TC's to use in Assertion dm@(DictMaps {lh_dicts = lhm}) <- dictMapFromIds is - let e' = foldl' (\e_ -> App e_ . Var) e is+ trueE <- mkTrueE+ higher_is <- handleHigherOrderSpecs CheckPre (mkHigherAssert trueE) lh dm (HM.map typeOf lhm) is st + let e' = foldl' App e . map (\(i, hi) -> maybe (Var i) id hi) $ zip is higher_is+ -- Create a variable for the returned value -- We do not pass the LH TC to the assertion, since there is no matching -- lambda for it in the LH Spec r <- freshIdN (typeOf e') let is' = filter (not . isTC lh . typeOf) is- assert <- convertAssertSpecType dm (M.map typeOf lhm) is' r st+ assert <- convertAssertSpecType dm (HM.map typeOf lhm) is' r st let fc = FuncCall { funcName = fn , arguments = map Var is , returns = Var r }- let rLet = Let [(r, e')] $ Assert (Just fc) assert (Var r)+ e'' = modifyASTs (repAssertFC fc) e'+ let rLet = Let [(r, e'')] $ Assert (Just fc) assert (Var r) let e''' = foldr (uncurry Lam) rLet $ zip lu is return e'''+ where+ -- We insert an extra, redundant assume to record information about the function being used as a higher order function+ mkHigherAssert true_dc spec i ars ret =+ Tick (NamedLoc higherOrderTickName) . Assume (Just $ FuncCall { funcName = idName i, arguments = map Var ars, returns = Var ret }) true_dc $ Assert Nothing spec (Var ret) -createAssumption :: SpecType -> Expr -> LHStateM Expr+ repAssertFC fc_ (Assert Nothing e1 e2) = Assert (Just fc_) e1 e2+ repAssertFC _ e_ = e_++createAssumption :: SpecType -> Expr -> LHStateM ([(LamUse, Id)], [Maybe Expr], Expr) createAssumption st e = do lh <- lhTCM @@ -148,38 +187,57 @@ let is' = filter (not . isTC lh . typeOf) is dm@(DictMaps {lh_dicts = lhm}) <- dictMapFromIds is - assume <- convertAssumeSpecType dm (M.map typeOf lhm) is' st+ assume <- convertAssumeSpecType dm (HM.map typeOf lhm) is' st+ higher_is <- handleHigherOrderSpecs CheckOnlyPost mkHigherAssume lh dm (HM.map typeOf lhm) is st - return . foldr (uncurry Lam) assume $ zip lu is+ let assume' = foldr (uncurry Lam) assume $ zip lu is+ return (zip lu is, higher_is, assume')+ where+ mkHigherAssume spec i ars ret =+ Tick (NamedLoc higherOrderTickName) $ Assume (Just $ FuncCall { funcName = idName i, arguments = map Var ars, returns = Var ret } ) spec (Var ret) +higherOrderTickName :: Name+higherOrderTickName = Name "HIGHER_ORDER_FUNC" Nothing 0 Nothing +createPost :: SpecType -> Expr -> LHStateM Expr+createPost st e = do+ lh <- lhTCM++ -- Create new bindings to use in the Ref. Type+ let argT = spArgumentTypes e+ is <- mapM argsFromArgT argT+ let lu = map argTypeToLamUse argT++ r <- freshIdN (returnType e)+ let is' = filter (not . isTC lh . typeOf) is+ dm@(DictMaps {lh_dicts = lhm}) <- dictMapFromIds is++ pst <- convertPostSpecType dm (HM.map typeOf lhm) is' r st++ return . foldr (uncurry Lam) pst $ zip (lu ++ [TermL]) (is ++ [r])+++ dictMapFromIds :: [Id] -> LHStateM DictMaps dictMapFromIds is = do lh <- lhTCM- num <- numTCM+ num <- lhNumTCM int <- return . KV.integralTC =<< knownValues+ frac <- return . KV.fractionalTC =<< knownValues ord <- ordTCM let lhm = tcWithNameMap lh is let nm = tcWithNameMap num is let im = tcWithNameMap int is+ let fr = tcWithNameMap frac is let om = tcWithNameMap ord is return $ DictMaps { lh_dicts = lhm , num_dicts = nm , integral_dicts = im+ , fractional_dicts = fr , ord_dicts = om } -tcWithNameMap :: Name -> [Id] -> M.Map Name Id-tcWithNameMap n =- M.fromList- . map (\i -> (forType $ typeOf i, i))- . filter (isTC n . typeOf)- where- forType :: Type -> Name- forType (TyApp _ (TyVar (Id n' _))) = n'- forType _ = error "Bad type in forType"- isTC :: Name -> Type -> Bool isTC n t = case tyAppCenter t of TyCon n' _ -> n == n'@@ -189,107 +247,148 @@ argsFromArgT (AnonType t) = freshIdN t argsFromArgT (NamedType i) = return i +-- | Should we translate the precondition in convertSpecType?+data CheckPre = CheckPre | CheckOnlyPost deriving Eq+ convertAssumeSpecType :: DictMaps -> BoundTypes -> [Id] -> SpecType -> LHStateM Expr convertAssumeSpecType m bt is st = do- convertSpecType m bt is Nothing st+ convertSpecType CheckPre m bt is Nothing st convertAssertSpecType :: DictMaps -> BoundTypes -> [Id] -> Id -> SpecType -> LHStateM Expr convertAssertSpecType m bt is r st = do- convertSpecType m bt is (Just r) st+ convertSpecType CheckPre m bt is (Just r) st +convertPostSpecType :: DictMaps -> BoundTypes -> [Id] -> Id -> SpecType -> LHStateM Expr+convertPostSpecType m bt is r st =+ convertSpecType CheckOnlyPost m bt is (Just r) st -- | See also: convertAssumeSpecType, convertAssertSpecType -- We can Maybe pass an Id for the value returned by the function -- If we do, our Expr includes the Refinement on the return value, -- otherwise it does not. This allows us to use this same function to -- translate both for assumptions and assertions-convertSpecType :: DictMaps -> BoundTypes -> [Id] -> Maybe Id -> SpecType -> LHStateM Expr-convertSpecType m bt _ r (RVar {rt_var = (RTV v), rt_reft = ref})+convertSpecType :: CheckPre -> DictMaps -> BoundTypes -> [Id] -> Maybe Id -> SpecType -> LHStateM Expr+convertSpecType _ m bt _ r (RVar {rt_var = (RTV v), rt_reft = ref}) | Just r' <- r = do let symb = reftSymbol $ ur_reft ref let i = mkIdUnsafe v let symbId = convertSymbolT symb (TyVar i) - let bt' = M.insert (idName symbId) (typeOf symbId) bt+ let bt' = HM.insert (idName symbId) (typeOf symbId) bt re <- convertLHExpr m bt' Nothing (reftExpr $ ur_reft ref) return $ App (Lam TermL symbId re) (Var r') | otherwise = mkTrueE-convertSpecType m bt (i:is) r (RFun {rt_bind = b, rt_in = fin, rt_out = fout }) = do+convertSpecType cp m bt (i:is) r (RFun {rt_bind = b, rt_in = fin, rt_out = fout }) = do t <- unsafeSpecTypeToType fin let i' = convertSymbolT b t - let bt' = M.insert (idName i') t bt+ let bt' = HM.insert (idName i') t bt - e <- convertSpecType m bt' is r fout+ e <- convertSpecType cp m bt' is r fout case hasFuncType i of True -> return $ App (Lam TermL i' e) (Var i) False -> do- e' <- convertSpecType m bt' [] (Just i') fin+ e' <- convertSpecType cp m bt' [] (Just i') fin an <- lhAndE- let e'' = App (App an e) e'+ let e'' = if cp == CheckPre+ then App (App an e') e+ else e return $ App (Lam TermL i' e'') (Var i)-convertSpecType m bt (i:is) r (RAllT {rt_tvbind = RTVar (RTV v) _, rt_ty = rty}) = do+convertSpecType cp m bt (i:is) r (RAllT {rt_tvbind = RTVar (RTV v) _, rt_ty = rty}) = do let i' = mkIdUnsafe v let m' = copyIds (idName i) (idName i') m- let bt' = M.insert (idName i') (typeOf i) bt+ let bt' = HM.insert (idName i') (typeOf i) bt - e <- convertSpecType m' bt' is r rty+ e <- convertSpecType cp m' bt' is r rty return $ App (Lam TypeL i' e) (Var i)-convertSpecType m bt _ r (RApp {rt_tycon = c, rt_reft = ref, rt_args = as})+convertSpecType cp m bt _ r (RApp {rt_tycon = c, rt_reft = ref, rt_args = as}) | Just r' <- r = do let symb = reftSymbol $ ur_reft ref ty <- return . maybe (error "Error in convertSpecType") id =<< rTyConType c as let i = convertSymbolT symb ty - let bt' = M.insert (idName i) ty bt+ let bt' = HM.insert (idName i) ty bt - argsPred <- polyPredFunc as ty m bt' r'+ argsPred <- polyPredFunc cp as ty m bt' r' re <- convertLHExpr m bt' Nothing (reftExpr $ ur_reft ref) an <- lhAndE return $ App (App an (App (Lam TermL i re) (Var r'))) argsPred | otherwise = mkTrueE-convertSpecType _ _ _ _ (RAppTy { }) = mkTrueE- -- | Just <- r = mkTrueE- -- t <- unsafeSpecTypeToType st- -- argsPred <- polyPredFunc2 [res] t m bt r'- -- return argsPred- -- | otherwise = mkTrueE-convertSpecType _ _ _ _ st@(RFun {}) = error $ "RFun " ++ show st-convertSpecType _ _ _ _ st@(RAllT {}) = error $ "RAllT " ++ show st-convertSpecType _ _ _ _ st@(RAllP {}) = error $ "RAllP " ++ show st-convertSpecType _ _ _ _ st@(RAllS {}) = error $ "RAllS " ++ show st-convertSpecType _ _ _ _ st@(RAllE {}) = error $ "RAllE " ++ show st-convertSpecType _ _ _ _ st@(REx {}) = error $ "REx " ++ show st-convertSpecType _ _ _ _ st@(RExprArg {}) = error $ "RExprArg " ++ show st-convertSpecType _ _ _ _ st@(RRTy {}) = error $ "RRTy " ++ show st-convertSpecType _ _ _ _ st = error $ "Bad st = " ++ show st+convertSpecType _ _ _ _ _ (RAppTy { }) = mkTrueE+convertSpecType _ _ _ _ _ st@(RFun {}) = error $ "RFun " ++ show st+convertSpecType _ _ _ _ _ st@(RAllT {}) = error $ "RAllT " ++ show st+convertSpecType _ _ _ _ _ st@(RAllP {}) = error $ "RAllP " ++ show st+convertSpecType _ _ _ _ _ st@(RAllE {}) = error $ "RAllE " ++ show st+convertSpecType _ _ _ _ _ st@(REx {}) = error $ "REx " ++ show st+convertSpecType _ _ _ _ _ st@(RExprArg {}) = error $ "RExprArg " ++ show st+convertSpecType _ _ _ _ _ st@(RRTy {}) = error $ "RRTy " ++ show st+convertSpecType _ _ _ _ _ st = error $ "Bad st = " ++ show st -polyPredFunc :: [SpecType] -> Type -> DictMaps -> BoundTypes -> Id -> LHStateM Expr-polyPredFunc as ty m bt b = do+handleHigherOrderSpecs :: CheckPre -> (Expr -> Id -> [Id] -> Id -> Expr) -> Name -> DictMaps -> BoundTypes -> [Id] -> SpecType -> LHStateM [Maybe Expr]+handleHigherOrderSpecs check_pre wrap_spec lh dm bt (i:is) st | isTC lh $ typeOf i = do+ es <- handleHigherOrderSpecs check_pre wrap_spec lh dm bt is st+ return $ Nothing:es+handleHigherOrderSpecs check_pre wrap_spec lh dm bt (i:is) (RFun {rt_bind = b, rt_in = fin, rt_out = fout })+ | hasFuncType i = do+ t <- unsafeSpecTypeToType fin+ let i' = convertSymbolT b t++ let bt' = HM.insert (idName i') t bt+ es <- handleHigherOrderSpecs check_pre wrap_spec lh dm bt' is fout++ ars <- freshIdsN (anonArgumentTypes i)+ ret <- freshIdN (returnType i)+ spec <- convertSpecType check_pre dm bt' ars (Just ret) fin++ let let_assert_spec = mkLams (zip (repeat TermL) ars)+ . Let [(ret, mkApp $ Var i:map Var ars)]+ $ wrap_spec spec i ars ret -- (Var ret)++ return $ Just let_assert_spec:es+ | otherwise = do+ t <- unsafeSpecTypeToType fin+ let i' = convertSymbolT b t++ let bt' = HM.insert (idName i') t bt+ es <- handleHigherOrderSpecs check_pre wrap_spec lh dm bt' is fout+ return $ Nothing:es+handleHigherOrderSpecs _ _ _ _ _ [] _ = return []+handleHigherOrderSpecs check_pre wrap_spec lh dm bt (i:is) (RAllT {rt_tvbind = RTVar (RTV v) _, rt_ty = rty}) = do+ let i' = mkIdUnsafe v++ let dm' = copyIds (idName i) (idName i') dm+ let bt' = HM.insert (idName i') (typeOf i) bt++ es <- handleHigherOrderSpecs check_pre wrap_spec lh dm' bt' is rty+ return $ Nothing:es+handleHigherOrderSpecs _ _ _ _ _ _ _ = error "handleHigherOrderSpecs: unhandled SpecType"++polyPredFunc :: CheckPre -> [SpecType] -> Type -> DictMaps -> BoundTypes -> Id -> LHStateM Expr+polyPredFunc cp as ty m bt b = do dict <- lhTCDict m ty- as' <- mapM (polyPredLam m bt) as+ as' <- mapM (polyPredLam cp m bt) as bool <- tyBoolT let ar1 = Type (typeOf b) ars = [dict] ++ as' ++ [Var b]- t = TyForAll (NamedTyBndr b) $ foldr1 TyFun $ map typeOf ars ++ [bool]+ t = TyForAll b $ foldr1 TyFun $ map typeOf ars ++ [bool] lhPP <- lhPPM return $ mkApp $ Var (Id lhPP t):ar1:ars -polyPredLam :: DictMaps -> BoundTypes -> SpecType -> LHStateM Expr-polyPredLam m bt rapp = do+polyPredLam :: CheckPre -> DictMaps -> BoundTypes -> SpecType -> LHStateM Expr+polyPredLam cp m bt rapp = do t <- unsafeSpecTypeToType rapp let argT = spArgumentTypes $ PresType t@@ -297,53 +396,63 @@ i <- freshIdN . returnType $ PresType t - st <- convertSpecType m bt is (Just i) rapp+ st <- convertSpecType cp m bt is (Just i) rapp return $ Lam TermL i st convertLHExpr :: DictMaps -> BoundTypes -> Maybe Type -> Ref.Expr -> LHStateM Expr convertLHExpr _ _ t (ECon c) = convertCon t c convertLHExpr _ bt t (EVar s) = convertEVar (symbolName s) bt t-convertLHExpr m bt _ (EApp e e') = do- f <- convertLHExpr m bt Nothing e+convertLHExpr m bt rt eapp@(EApp e e') = do+ meas <- measuresM+ m_set_e <- convertSetExpr meas m bt rt eapp+ + case m_set_e of+ Just set_e -> return set_e+ Nothing -> do+ f <- convertLHExpr m bt Nothing e - let at = argumentTypes f- f_ar_t = case at of- (_:_) -> Just $ last at- _ -> Nothing+ let at = argumentTypes f+ f_ar_t = case at of+ (_:_) -> Just $ last at+ _ -> Nothing - f_ar_ts = fmap tyAppArgs f_ar_t+ f_ar_ts = fmap relTyVars f_ar_t - argE <- convertLHExpr m bt f_ar_t e'+ argE <- convertLHExpr m bt f_ar_t e' - let tArgE = typeOf argE- ctArgE = tyAppCenter tArgE- ts = take (numTypeArgs f) $ tyAppArgs tArgE- - case (ctArgE, f_ar_ts) of- (TyCon _ _, Just f_ar_ts') -> do- let specTo = concatMap (map snd) $ map M.toList $ map (snd . uncurry (specializes M.empty)) $ zip ts f_ar_ts'- te = map Type specTo+ let tArgE = typeOf argE+ ctArgE = tyAppCenter tArgE+ ts = take (numTypeArgs f) $ relTyVars tArgE - tcs <- mapM (lhTCDict m) ts+ case (ctArgE, f_ar_ts) of+ (_, Just f_ar_ts') -> do+ let specTo = concatMap (map snd) $ map M.toList $ map (fromJust . uncurry specializes) $ zip ts f_ar_ts'+ te = map Type specTo - let fw = mkApp $ f:te+ tcs <- mapM (lhTCDict m) ts - apps = mkApp $ fw:tcs ++ [argE]- - return apps- _ -> return $ App f argE+ let fw = mkApp $ f:te++ apps = mkApp $ fw:tcs ++ [argE]+ + return apps+ _ -> return $ App f argE+ where+ relTyVars t@(TyVar _) = [t]+ relTyVars t@(TyApp _ _) = tyAppArgs t+ relTyVars _ = [] convertLHExpr m bt t (ENeg e) = do e' <- convertLHExpr m bt t e let t' = typeOf e' neg <- lhNegateM- num <- numTCM+ num <- lhNumTCM a <- freshIdN TYPE let tva = TyVar a let negate' = Var $ Id neg - (TyForAll (NamedTyBndr a)+ (TyForAll a (TyFun- (TyApp (TyCon num (TyApp TYPE TYPE)) tva)+ (TyApp (TyCon num (TyFun TYPE TYPE)) tva) (TyFun tva tva@@ -370,19 +479,29 @@ , nDict , e2 , e2' ]+convertLHExpr m bt t (EIte b e e') = do+ b2 <- convertLHExpr m bt t b+ (e2, e2') <- correctTypes m bt t e e'++ trueDC <- mkDCTrueM+ falseDC <- mkDCFalseM++ bnd <- freshIdN =<< tyBoolT++ return $ Case b2 bnd (typeOf e2) [Alt (DataAlt trueDC []) e2, Alt (DataAlt falseDC []) e2'] convertLHExpr m bt _ (ECst e s) = do t <- sortToType s convertLHExpr m bt (Just t) e convertLHExpr m bt _ (PAnd es) = do es' <- mapM (convertLHExpr m bt Nothing) es - true <- mkTrueE+ trueE <- mkTrueE an <- lhAndE case es' of- [] -> return $ true+ [] -> return $ trueE [e] -> return e- _ -> return $ foldr (\e -> App (App an e)) true es'+ _ -> return $ foldr (\e -> App (App an e)) trueE es' convertLHExpr m bt _ (POr es) = do es' <- mapM (convertLHExpr m bt Nothing) es @@ -395,7 +514,7 @@ _ -> return $ foldr (\e -> App (App orE e)) false es' convertLHExpr m bt _ (PNot e) = do e' <- convertLHExpr m bt Nothing e- no <- mkNotE+ no <- notM return (App no e') convertLHExpr m bt t (PImp e1 e2) = do e1' <- convertLHExpr m bt t e1@@ -418,6 +537,81 @@ return $ mkApp [brel', Type t', dict, e1', e2'] convertLHExpr _ _ _ e = error $ "Untranslated LH Expr " ++ (show e) +convertSetExpr :: Measures -> DictMaps -> BoundTypes -> Maybe Type -> Ref.Expr -> LHStateM (Maybe Expr)+convertSetExpr meas dm bt rt e+ | [EVar v, e1] <- unEApp e+ , Just (nm, nm_mod) <- get_nameTyVarAr v+ , Just (f_nm, f_e) <- E.lookupNameMod nm nm_mod meas = do+ e1' <- convertLHExpr dm bt rt e1+ tyI <- tyIntegerT+ t <- if typeOf e1' == tyI then tyIntT else return $ typeOf e1'+ e1'' <- if typeOf e1' == tyI then correctType dm t e1' else return e1'+ return . Just $ mkApp ([ Var (Id f_nm (typeOf f_e))+ , Type t+ , e1''])+ | [EVar v, e1, e2] <- unEApp e+ , Just (nm, nm_mod) <- get_nameTyVarArOrd v+ , Just (f_nm, f_e) <- E.lookupNameMod nm nm_mod meas = do+ e1' <- convertLHExpr dm bt rt e1+ e2' <- convertLHExpr dm bt rt e2+ let TyApp _ t2 = typeOf e2'+ e1'' <- correctType dm t2 e1'+ let t = typeOf e1''+ ord <- ordDict dm t+ return . Just $ mkApp ([ Var (Id f_nm (typeOf f_e))+ , Type t+ , ord+ , e1''+ , e2' ])+ | EVar v:es <- unEApp e+ , Just (nm, nm_mod) <- get_nameSetAr v+ , Just (f_nm, f_e) <- E.lookupNameMod nm nm_mod meas = do+ es' <- mapM (convertLHExpr dm bt rt) es+ case typeOf (head es') of+ TyApp _ t -> do+ return . Just $ mkApp ([ Var (Id f_nm (typeOf f_e))+ , Type t ]+ ++ es')+ _ -> do+ t <- tyIntT+ return . Just $ App (Var (Id f_nm (typeOf f_e))) (Type t)+ | EVar v:es <- unEApp e+ , Just (nm, nm_mod) <- get_nameSetArOrd v+ , Just (f_nm, f_e) <- E.lookupNameMod nm nm_mod meas = do+ es' <- mapM (convertLHExpr dm bt rt) es+ case typeOf (head es') of+ TyApp _ t -> do+ ord <- ordDict dm t+ return . Just $ mkApp ([ Var (Id f_nm (typeOf f_e))+ , Type t+ , ord ]+ ++ es')+ _ -> error "convertSetExpr: incorrect type"+ | otherwise = return Nothing+ where+ get_nameTyVarAr v = case nameOcc (symbolName v) of+ "Set_sng" -> Just ("singleton", Just "Data.Set.Internal")+ _ -> Nothing++ get_nameTyVarArOrd v = case nameOcc (symbolName v) of+ "Set_mem" -> Just ("member", Just "Data.Set.Internal")+ _ -> Nothing++ get_nameSetAr v = case nameOcc (symbolName v) of+ "Set_empty" -> Just ("empty", Just "Data.Set.Internal")+ "Set_emp" -> Just ("null", Just "Data.Set.Internal")+ _ -> Nothing++ get_nameSetArOrd v = case nameOcc (symbolName v) of+ "Set_cup" -> Just ("union", Just "Data.Set.Internal")+ "Set_cap" -> Just ("intersection", Just "Data.Set.Internal")+ "Set_sub" -> Just ("isSubsetOf", Just "Data.Set.Internal")+ _ -> Nothing++unEApp :: Ref.Expr -> [Ref.Expr]+unEApp (EApp f a) = unEApp f ++ [a]+unEApp e = [e]+ convertBop :: Bop -> LHStateM Expr convertBop Ref.Plus = convertBop' lhPlusM convertBop Ref.Minus = convertBop' lhMinusM@@ -429,13 +623,13 @@ convertBop' :: LHStateM Name -> LHStateM Expr convertBop' f = do- num <- numTCM+ num <- lhNumTCM n <- f a <- freshIdN TYPE let tva = TyVar a- return $ Var $ Id n (TyForAll (NamedTyBndr a)+ return $ Var $ Id n (TyForAll a (TyFun- (TyApp (TyCon num (TyApp TYPE TYPE)) tva)+ (TyApp (TyCon num (TyFun TYPE TYPE)) tva) (TyFun tva (TyFun @@ -469,27 +663,88 @@ let retT = returnType e let retT' = returnType e' - may_nDict <- maybeNumDict m t- may_nDict' <- maybeNumDict m t'+ may_nDict <- maybeNumDict m retT+ may_nDict' <- maybeNumDict m retT' - may_iDict <- maybeIntegralDict m t- may_iDict' <- maybeIntegralDict m t'+ may_iDict <- maybeIntegralDict m retT+ may_iDict' <- maybeIntegralDict m retT' + may_fDict <- maybeFractionalDict m retT+ may_fDict' <- maybeFractionalDict m retT'++ may_ratio_e <- maybeRatioFromInteger m e+ may_ratio_e' <- maybeRatioFromInteger m e'+ fromRationalF <- lhFromRationalM+ if | t == t' -> return (e, e') | retT /= tyI , retT' == tyI , Just nDict <- may_nDict -> return (e, mkApp [Var fIntgr, Type t, nDict, e'])+ | retT == tyI , retT' /= tyI , Just nDict' <- may_nDict' -> return (mkApp [Var fIntgr, Type t', nDict', e], e')+ | retT /= tyI , retT' == tyI , Just iDict <- may_iDict -> return (mkApp [Var tIntgr, Type t, iDict, e], e')+ | retT == tyI , retT' /= tyI , Just iDict' <- may_iDict' -> return (e, mkApp [Var tIntgr, Type t', iDict', e'])- | otherwise -> error "correctTypes: Unhandled case" + | Just ratio_e <- may_ratio_e+ , Just fDict' <- may_fDict' -> return (mkApp [Var fromRationalF, Type t', fDict', ratio_e], e')++ | Just fDict <- may_fDict+ , Just ratio_e' <- may_ratio_e' -> return (e, mkApp [Var fromRationalF, Type t, fDict, ratio_e'])++ | Just iDict <- may_iDict+ , Just nDict' <- may_nDict' ->+ return (mkApp [Var fIntgr, Type t', nDict', mkApp [Var tIntgr, Type t, iDict, e]], e')++ | Just nDict <- may_nDict+ , Just iDict' <- may_iDict' ->+ return (e, mkApp [Var fIntgr, Type t, nDict, mkApp [Var tIntgr, Type t', iDict', e']])++ | otherwise -> error $ "correctTypes: Unhandled case"+ ++ "\ne = " ++ show e+ ++ "\ne' = " ++ show e'+ ++ "\nt = " ++ show t+ ++ "\nt' = " ++ show t'+ ++ "\nretT = " ++ show retT+ ++ "\nretT' = " ++ show retT'+ ++ "\nm = " ++ show m++correctType :: DictMaps -> Type -> Expr -> LHStateM Expr+correctType m t e = do+ fIntgr <- lhFromIntegerM+ tyI <- tyIntegerT++ let t' = typeOf e++ may_nDict <- maybeNumDict m t++ if | t == t' -> return e+ | t' == tyI+ , t /= tyI+ , Just nDict <- may_nDict -> return $ mkApp [Var fIntgr, Type t, nDict, e]+ | otherwise -> error $ "correctType: unhandled case\n" ++ show e ++ "\nmay_nDict" ++ show may_nDict++maybeRatioFromInteger :: DictMaps -> Expr -> LHStateM (Maybe Expr)+maybeRatioFromInteger m e = do+ tyI <- tyIntegerT++ toRatioF <- lhToRatioFuncM -- return . mkToRatioExpr =<< knownValues+ may_iDict <- maybeIntegralDict m (typeOf e)++ dcIntegerE <- mkDCIntegerE++ if | Just iDict <- may_iDict+ , typeOf e == tyI ->+ return . Just $ mkApp [Var toRatioF, Type (typeOf e), iDict, e, App dcIntegerE (Lit (LitInt 1))]+ | otherwise -> return Nothing+ convertSymbolT :: Symbol -> Type -> Id convertSymbolT s = Id (symbolName s) @@ -525,7 +780,7 @@ convertEVar :: Name -> BoundTypes -> Maybe Type -> LHStateM Expr convertEVar nm@(Name n md _ _) bt mt- | Just t <- M.lookup nm bt = return $ Var (Id nm t)+ | Just t <- HM.lookup nm bt = return $ Var (Id nm t) | otherwise = do meas <- measuresM tenv <- typeEnv@@ -534,15 +789,22 @@ return . Var $ Id n' (typeOf e) | Just dc <- getDataConNameMod' tenv nm -> return $ Data dc | Just t <- mt -> return $ Var (Id nm t)- | otherwise -> error $ "convertEVar: Required type not found"+ | otherwise -> error $ "convertEVar: Required type not found" ++ "\n" ++ show n ++ "\nbt = " ++ show bt+ where+ getDataConNameMod' tenv n = find (flip dataConHasNameMod n) $ concatMap dataCon $ HM.elems tenv+ dataConHasNameMod (DataCon (Name n m _ _) _) (Name n' m' _ _) = n == n' && m == m' + convertCon :: Maybe Type -> Constant -> LHStateM Expr convertCon (Just (TyCon n _)) (Ref.I i) = do- (TyCon ti _) <- tyIntT- dc <- mkDCIntE- if n == ti- then return $ App dc (Lit . LitInt $ fromIntegral i)- else error $ "Unknown Con" ++ show n+ tyI <- tyIntT+ case tyI of+ TyCon ti _ -> do+ dc <- mkDCIntE+ if n == ti+ then return $ App dc (Lit . LitInt $ fromIntegral i)+ else error $ "Unknown Con" ++ show n+ _ -> error "convertCon: Non-tyInt" convertCon _ (Ref.I i) = do dc <- mkDCIntegerE return $ App dc (Lit . LitInt $ fromIntegral i)@@ -572,7 +834,7 @@ specTypeToType (RAllT {rt_tvbind = RTVar (RTV v) _, rt_ty = rty}) = do let i = mkIdUnsafe v t <- specTypeToType rty- return $ fmap (TyForAll (NamedTyBndr i)) t+ return $ fmap (TyForAll i) t specTypeToType (RApp {rt_tycon = c, rt_args = as}) = rTyConType c as specTypeToType (RAppTy {rt_arg = arg, rt_res = res}) = do argT <- specTypeToType arg@@ -586,7 +848,7 @@ rTyConType rtc sts = do tenv <- typeEnv - let tcn = mkTyConName HM.empty . rtc_tc $ rtc+ let tcn = mkTyConNameUnsafe . rtc_tc $ rtc n = nameModMatch tcn tenv ts <- mapM specTypeToType sts@@ -628,9 +890,9 @@ b <- tyBoolT let tva = TyVar a t = TyForAll - (NamedTyBndr a)+ a (TyFun- (TyCon lh TYPE)+ (TyCon lh (TyFun TYPE TYPE)) (TyFun tva (TyFun tva b)@@ -643,8 +905,18 @@ brelTCDict = lhTCDict bopTCDict :: Bop -> DictMaps -> Type -> LHStateM Expr-bopTCDict Ref.Mod = integralDict-bopTCDict _ = numDict+bopTCDict Ref.Mod dm t = integralDict dm t+bopTCDict Ref.Div dm t = do+ fd <- maybeFractionalDict dm t+ case fd of+ Just fd' -> return fd'+ Nothing -> integralDict dm t+bopTCDict Ref.RDiv dm t = do+ fd <- maybeFractionalDict dm t+ case fd of+ Just fd' -> return fd'+ Nothing -> integralDict dm t +bopTCDict _ dm t = numDict dm t lhTCDict :: DictMaps -> Type -> LHStateM Expr lhTCDict m t = do@@ -662,9 +934,28 @@ Just e -> return e Nothing -> error $ "No lh dict " ++ show lh ++ "\n" ++ show t ++ "\n" ++ show m +maybeOrdDict :: DictMaps -> Type -> LHStateM (Maybe Expr)+maybeOrdDict m t = do+ ordTC <- lhOrdTCM+ tc <- typeClassInstTC (ord_dicts m) ordTC t+ case tc of+ Just _ -> return tc+ Nothing -> do+ ord <- lhOrdM+ lh <- lhTCDict m t+ return . Just $ App (App (Var (Id ord TyUnknown)) (Type t)) lh+++ordDict :: DictMaps -> Type -> LHStateM Expr+ordDict m t = do+ tc <- maybeOrdDict m t+ case tc of+ Just e -> return e+ Nothing -> error $ "No ord dict \n" ++ show t ++ "\n" ++ show m+ maybeNumDict :: DictMaps -> Type -> LHStateM (Maybe Expr) maybeNumDict m t = do- num <- numTCM+ num <- lhNumTCM typeClassInstTC (num_dicts m) num t numDict :: DictMaps -> Type -> LHStateM Expr@@ -685,3 +976,8 @@ case tc of Just e -> return e Nothing -> error $ "No integral dict\n" ++ show t ++ "\n" ++ show m++maybeFractionalDict :: DictMaps -> Type -> LHStateM (Maybe Expr)+maybeFractionalDict m t = do+ integral <- return . KV.fractionalTC =<< knownValues+ typeClassInstTC (fractional_dicts m) integral t
src/G2/Liquid/ConvertCurrExpr.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -module G2.Liquid.ConvertCurrExpr (convertCurrExpr) where+module G2.Liquid.ConvertCurrExpr ( convertCurrExpr+ , initiallyCalledFuncName) where import G2.Language import G2.Language.Monad@@ -11,12 +14,14 @@ import G2.Liquid.Types import Control.Monad.Extra-import qualified Data.Map as M+import qualified Data.HashMap.Lazy as HM import Data.Maybe -convertCurrExpr :: Id -> Bindings -> LHStateM [Name]+-- | Returns (1) the Id of the new main function and (2) the functions that need counterfactual variants+convertCurrExpr :: Id -> Bindings -> LHStateM (Id, [Name]) convertCurrExpr ifi bindings = do ifi' <- modifyInputExpr ifi+ mapWithKeyME (\(Name _ m _ _) e -> if isJust m then letLiftHigherOrder e else return e) addCurrExprAssumption ifi bindings return ifi' @@ -33,7 +38,7 @@ -- it'll only be computed once. This is NOT just for efficiency. -- Since the choice is nondeterministic, this is the only way to ensure that -- we don't make two different choices, and get two different values.-modifyInputExpr :: Id -> LHStateM [Name]+modifyInputExpr :: Id -> LHStateM (Id, [Name]) modifyInputExpr i@(Id n _) = do (CurrExpr er ce) <- currExpr @@ -45,15 +50,16 @@ let ce' = replaceVarWithName (idName i) (Var newI) ce putCurrExpr (CurrExpr er ce')- return ns- Nothing -> return []+ return (newI, ns)+ Nothing -> return (error "Name not found", []) -- Actually does the work of modify the function for modifyInputExpr -- Inserts the new function in the ExprEnv, and returns the Id modifyInputExpr' :: Id -> Expr -> LHStateM (Id, [Name]) modifyInputExpr' i e = do (e', ns) <- rebindFuncs e- e''' <- letLiftFuncs e'+ e'' <- letLiftFuncs e'+ e''' <- replaceLocalAssert i e'' newI <- freshSeededIdN (idName i) (typeOf i) insertE (idName newI) e'''@@ -75,6 +81,33 @@ rewriteAssertName n (Assert (Just fc) e1 e2) = Assert (Just $ fc {funcName = n}) e1 e2 rewriteAssertName n e1 = modifyChildren (rewriteAssertName n) e1 +-- | We are assuming the precondiiton holds, so we only have to check the postcondition!+-- We also replace the name of the assert so we can recognize it as the inital call later.+replaceLocalAssert :: Id -> Expr -> LHStateM Expr+replaceLocalAssert (Id n _) ce = do+ n_assert <- lookupPostM n+ -- Replace the initial function assertion with one that only checks the postcondition,+ -- but is careful to not replace assertions tied to higher order functions.+ let ce' = insertInLams+ (\_ e -> case e of+ Let b (Assert (Just fc) e1 e2) ->+ let ars = arguments fc ++ [returns fc]+ assrt = case n_assert of+ Just a -> mkApp (a:ars)+ Nothing -> e1+ in + Let b $ Assert (Just fc) assrt e2+ _ -> e) ce+ ce'' = modifyASTs+ (\e -> case e of+ Assert (Just fc) e1 e2 ->+ Assert (Just $ fc { funcName = initiallyCalledFuncName}) e1 e2+ _ -> e) ce'+ return ce''++initiallyCalledFuncName :: Name+initiallyCalledFuncName = Name "INITIALLY_CALLED_FUNC" Nothing 0 Nothing+ replaceVarWithName :: Name -> Expr -> Expr -> Expr replaceVarWithName n new = modify (replaceVarWithName' n new) @@ -89,7 +122,9 @@ -- Furthermore, we have to be careful to not move bindings from Lambdas/other Let's -- out of scope. letLiftFuncs :: Expr -> LHStateM Expr-letLiftFuncs = modifyAppTopE letLiftFuncs'+letLiftFuncs e = do+ e' <- modifyAppTopE letLiftFuncs' e+ return $ flattenLets e' letLiftFuncs' :: Expr -> LHStateM Expr letLiftFuncs' e@@ -101,6 +136,59 @@ return . Let (zip is ars) . mkApp $ c:map Var is | otherwise = return e ++-- | Tries to be more selective then liftLetFuncs, doesn't really work yet...+letLiftHigherOrder :: Expr -> LHStateM Expr+letLiftHigherOrder e = return . shiftLetsOutOfApps =<< insertInLamsE letLiftHigherOrder' e++letLiftHigherOrder' :: [Id] -> Expr -> LHStateM Expr+letLiftHigherOrder' is e@(App _ _)+ | Var i <- appCenter e+ , i `elem` is = do+ ni <- freshIdN (typeOf e)+ e' <- modifyAppRHSE (letLiftHigherOrder' is) e+ return $ Let [(ni, e')] (Var ni)+ | d@(Data _) <- appCenter e = do+ let ars = passedArgs e+ f_is <- freshIdsN $ map typeOf ars++ ars' <- mapM (letLiftHigherOrder' f_is) ars++ return . Let (zip f_is ars') . mkApp $ d:map Var f_is+letLiftHigherOrder' is e@(Lam _ _ _) = insertInLamsE (\is' -> letLiftHigherOrder' (is ++ is')) e+letLiftHigherOrder' is e = modifyChildrenM (letLiftHigherOrder' is) e++shiftLetsOutOfApps :: Expr -> Expr+shiftLetsOutOfApps e@(App _ _) =+ case shiftLetsOutOfApps' e of+ Let b e' -> Let b . modifyBottomApp shiftLetsOutOfApps $ e'+ e' -> modifyBottomApp shiftLetsOutOfApps $ e'+shiftLetsOutOfApps e = modifyChildren shiftLetsOutOfApps e++shiftLetsOutOfApps' :: Expr -> Expr+shiftLetsOutOfApps' a@(App _ _) =+ let+ b = getLetsInApp a+ in+ case b of+ [] -> a+ _ -> Let b $ elimLetsInApp a+shiftLetsOutOfApps' _ = error "shiftLetsOutOfApps': must be passed an App"++getLetsInApp :: Expr -> Binds+getLetsInApp (Let b e) = b ++ getLetsInApp e+getLetsInApp (App e e') = getLetsInApp e ++ getLetsInApp e'+getLetsInApp _ = []++elimLetsInApp :: Expr -> Expr+elimLetsInApp (Let _ e) = elimLetsInApp e+elimLetsInApp (App e e') = App (elimLetsInApp e) (elimLetsInApp e')+elimLetsInApp e = e++modifyBottomApp :: (Expr -> Expr) -> Expr -> Expr+modifyBottomApp f (App e e') = App (modifyBottomApp f e) (modifyBottomApp f e')+modifyBottomApp f e = f e+ -- We add an assumption about the inputs to the current expression -- This prevents us from finding a violation of the output refinement type -- that requires a violation of the input refinement type@@ -108,22 +196,45 @@ addCurrExprAssumption ifi (Bindings {fixed_inputs = fi}) = do (CurrExpr er ce) <- currExpr + lh_tc_n <- lhTCM+ let lh_tc = TyCon lh_tc_n (TyFun TYPE TYPE)+ let fi' = filter (\e -> tyAppCenter (typeOf e) /= lh_tc) fi+ assumpt <- lookupAssumptionM (idName ifi) -- fi <- fixedInputs eenv <- exprEnv inames <- inputNames - lh <- mapM (lhTCDict' M.empty) $ mapMaybe typeType fi+ lh <- mapM (lhTCDict' HM.empty) $ mapMaybe typeType fi' let is = catMaybes (map (E.getIdFromName eenv) inames) - let (typs, ars) = span isType $ fi ++ map Var is+ let (typs, ars) = span isType $ fi' ++ map Var is case assumpt of- Just assumpt' -> do- let appAssumpt = mkApp $ assumpt':typs ++ lh ++ ars- let ce' = Assume Nothing appAssumpt ce- putCurrExpr (CurrExpr er ce')+ Just (assumpt_is, higher_is, assumpt') -> do+ let all_args = typs ++ lh ++ ars+ appAssumpt = mkApp $ assumpt':all_args++ inputs <- inputNames+ let matching = zipWith (\n (i, hi) -> (n, i, hi)) inputs $ drop (length higher_is - length inputs) $ zip assumpt_is higher_is+ matching_higher = mapMaybe (\(n, i, hi) -> maybe Nothing (Just . (n, i,)) hi) matching+ let_expr = Let (map (\(n, i, _) -> (snd i, Var (Id n . typeOf $ snd i))) matching_higher)++ let ce' = let_expr+ . flip (foldr (uncurry replaceAssumeFC)) (map (\(n, (_, i), _) -> (idName i, n)) matching_higher)+ $ foldr (uncurry replaceVar) ce (map (\(n, _, hi) -> (n, hi)) matching_higher)+ assume_ce = Assume Nothing appAssumpt ce'++ putCurrExpr (CurrExpr er assume_ce) Nothing -> return ()++replaceAssumeFC :: ASTContainer m Expr => Name -> Name -> m -> m+replaceAssumeFC old new = modifyASTs (replaceAssumeFC' old new)++replaceAssumeFC' :: Name -> Name -> Expr -> Expr+replaceAssumeFC' old new e@(Assume (Just fc) e1 e2) =+ if funcName fc == old then Assume (Just (fc { funcName = new })) e1 e2 else e+replaceAssumeFC' _ _ e = e isType :: Expr -> Bool isType (Type _) = True
+ src/G2/Liquid/G2Calls.hs view
@@ -0,0 +1,531 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module G2.Liquid.G2Calls ( G2Call+ , gathererReducer+ , checkAbstracted+ , reduceAbstracted+ , reduceAllCalls+ , reduceCalls+ , reduceFuncCall+ , mapAccumM) where++import G2.Config+import G2.Data.Utils+import G2.Execution+import G2.Interface+import G2.Language as G2+import qualified G2.Language.ExprEnv as E+import G2.Liquid.Helpers+import G2.Liquid.LHReducers+import G2.Liquid.SpecialAsserts+import G2.Liquid.Types+import G2.Liquid.TyVarBags+import G2.Solver++import Control.Monad+import Control.Monad.IO.Class+import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HS+import Data.Maybe+import Data.Monoid++-- | The function to actually use for Symbolic Execution+type G2Call solver simplifier =+ forall m t . ( MonadIO m+ , Named t+ , ASTContainer t Expr+ , ASTContainer t Type) =>+ SomeReducer m t -> SomeHalter m t -> SomeOrderer m t -> solver -> simplifier -> MemConfig -> State t -> Bindings -> m ([ExecRes t], Bindings)++-------------------------------+-- Check Abstracted+-------------------------------+-- Checks if the abstracted functions actually deviate from the real function behavior.+-- If they do not, they can simply be eliminated from the state.++-- The result of a call to checkAbstracted'. Either:+-- (1) the function does need to be abstract, and we get the actual result of executing the function call. +-- (2) the function does not need to be abstract+data AbstractedRes = AbstractRes Abstracted Model+ | NotAbstractRes++toAbstracted :: AbstractedRes -> Maybe Abstracted+toAbstracted (AbstractRes a _) = Just a+toAbstracted _ = Nothing++toModel :: AbstractedRes -> Maybe Model+toModel (AbstractRes _ m) = Just m+toModel _ = Nothing++-- | Checks if abstracted functions actually had to be abstracted.+checkAbstracted :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Config -> Id -> Bindings -> ExecRes LHTracker -> IO (ExecRes AbstractedInfo)+checkAbstracted g2call solver simplifier config init_id bindings er@(ExecRes{ final_state = s@State { track = lht }+ , conc_args = inArg+ , conc_out = ex }) = do+ -- Get `Abstracted`s for the abstracted functions + let chck = checkAbstracted' g2call solver simplifier (sharing config)+ ((s', bindings'), abstractedR) <- mapAccumM (uncurry chck) (s, bindings) (abstract_calls lht)+ let abstracted' = mapMaybe toAbstracted $ abstractedR+ models = mapMaybe toModel $ abstractedR++ -- Get an `Abstracted` for the initial call+ let init_call_fc = FuncCall (idName init_id) inArg ex+ (s'', bindings'', abs_init, model_init) <- getAbstracted g2call solver simplifier (sharing config) s' bindings' init_call_fc++ -- Get an `Abstracted` for the violated function (if it exists)+ (bindings''', viol_er) <- reduceViolated g2call solver simplifier (sharing config) bindings'' (er { final_state = s'' })+ abs_viol <- case violated viol_er of+ Just v -> return . Just =<<+ getAbstracted g2call solver simplifier (sharing config) (final_state viol_er) bindings''' v+ Nothing -> return Nothing+ let viol_model = maybeToList $ fmap fth4 abs_viol+ abs_info = AbstractedInfo { init_call = abs_init+ , abs_violated = fmap thd4 abs_viol+ , abs_calls = abstracted'+ , ai_all_calls = all_calls lht+ , ai_higher_order_calls = higher_order_calls lht }+ fs = maybe (final_state viol_er) fst4 abs_viol++ return $ viol_er { final_state = fs { track = abs_info+ , model = foldr HM.union (model s) (model_init:viol_model ++ models) }+ }++checkAbstracted' :: (Solver solver, Simplifier simplifier)+ => G2Call solver simplifier+ -> solver+ -> simplifier+ -> Sharing+ -> State LHTracker+ -> Bindings+ -> FuncCall+ -> IO ((State LHTracker, Bindings), AbstractedRes)+checkAbstracted' g2call solver simplifier share s bindings abs_fc@(FuncCall { funcName = n, arguments = ars, returns = r })+ | Just e <- E.lookup n $ expr_env s = do+ let + e' = mkApp $ Var (Id n (typeOf e)):ars++ ds = deepseq_walkers bindings+ strict_call = maybe e' (fillLHDictArgs ds) $ mkStrict_maybe ds e'++ -- We leave assertions in the code, and set true_assert to false so we can+ -- tell if an assertion was violated.+ -- If an assertion is violated, it means that the function did not need to be abstracted,+ -- but does need to be in `assert_ids` .+ -- We eliminate all assumes, except those blocking calls to library functions.+ -- See [BlockErrors] in G2.Liquid.SpecialAsserts+ let s' = elimAssumesExcept+ . pickHead+ . elimSymGens (arb_value_gen bindings)+ . modelToExprEnv $+ s { curr_expr = CurrExpr Evaluate strict_call+ , track = False }+++ let pres = HS.fromList $ namesList s' ++ namesList bindings+ (er, bindings') <- g2call + (SomeReducer (hitsLibError ~> stdRed share retReplaceSymbFuncVar solver simplifier))+ (SomeHalter (swhnfHalter <~> acceptOnlyOneHalter <~> switchEveryNHalter 200))+ (SomeOrderer (incrAfterN 2000 (adtSizeOrderer 0 Nothing)))+ solver simplifier+ (emptyMemConfig { pres_func = \_ _ _ -> pres })+ s' bindings++ case er of+ [ExecRes+ {+ final_state = fs@(State { curr_expr = CurrExpr _ ce, model = m, track = t})+ }] -> case not $ ce `eqUpToTypes` r of+ True -> do+ let ar = AbstractRes + ( Abstracted { abstract = repTCsFC (type_classes s) $ abs_fc+ , real = repTCsFC (type_classes s) $ abs_fc { returns = ce }+ , hits_lib_err_in_real = t+ , func_calls_in_real = [] }+ ) m+ return ( ( s { expr_env = foldr E.insertSymbolic (expr_env s) (E.symbolicIds $ expr_env fs)+ , path_conds = path_conds fs }+ , bindings'+ )+ , ar)+ False -> return ((s, bindings), NotAbstractRes)+ _ -> error $ "checkAbstracted': Bad return from g2call"+ | otherwise = error $ "checkAbstracted': Bad lookup in g2call"++getAbstracted :: (Solver solver, Simplifier simplifier)+ => G2Call solver simplifier+ -> solver+ -> simplifier+ -> Sharing + -> State LHTracker+ -> Bindings+ -> FuncCall+ -> IO (State LHTracker, Bindings, Abstracted, Model)+getAbstracted g2call solver simplifier share s bindings abs_fc@(FuncCall { funcName = n, arguments = ars })+ | Just e <- E.lookup n $ expr_env s = do+ let + e' = mkApp $ Var (Id n (typeOf e)):ars++ ds = deepseq_walkers bindings+ strict_call = maybe e' (fillLHDictArgs ds) $ mkStrict_maybe ds e'++ let s' = mkAssertsTrue (known_values s)+ . elimAssumesExcept+ . pickHead+ . elimSymGens (arb_value_gen bindings)+ . modelToExprEnv $+ s { curr_expr = CurrExpr Evaluate strict_call+ , track = ([] :: [FuncCall], False)}++ (er, bindings') <- g2call + (((hitsLibErrorGatherer ~> stdRed share retReplaceSymbFuncVar solver simplifier) :== Finished+ --> (nonRedPCRed .|. nonRedPCRedConst) ))+ (SomeHalter (swhnfHalter <~> acceptOnlyOneHalter <~> switchEveryNHalter 200))+ (SomeOrderer (incrAfterN 2000 (adtSizeOrderer 0 Nothing)))+ solver simplifier+ PreserveAllMC+ s' bindings++ case er of+ [ExecRes+ {+ final_state = fs@(State { curr_expr = CurrExpr _ ce, track = (gfc, hle), model = m})+ }] -> do+ let fs' = modelToExprEnv fs+ (fs'', bindings'', gfc') <- reduceFuncCallMaybeList g2call solver simplifier share bindings' fs' gfc+ let ar = Abstracted { abstract = repTCsFC (type_classes s) abs_fc+ , real = repTCsFC (type_classes s) $ abs_fc { returns = (inline (expr_env fs) HS.empty ce) }+ , hits_lib_err_in_real = hle+ , func_calls_in_real = gfc' }+ return ( s { expr_env = foldr E.insertSymbolic (expr_env s) (E.symbolicIds $ expr_env fs'')+ , path_conds = path_conds fs }+ , bindings''+ , ar+ , m)+ _ -> error $ "checkAbstracted': Bad return from g2call"+ | otherwise = error $ "getAbstracted: Bad lookup in g2call" ++ show n++repTCsFC :: TypeClasses -> FuncCall -> FuncCall +repTCsFC tc fc = fc { arguments = map (repTCs tc) (arguments fc)+ , returns = repTCs tc (returns fc) }++repTCs :: TypeClasses -> Expr -> Expr+repTCs tc e+ | isTypeClass tc $ (typeOf e)+ , TyCon n _:t:_ <- unTyApp (typeOf e)+ , Just tc_dict <- typeClassInst tc HM.empty n t = tc_dict+ | otherwise = e+++inline :: ExprEnv -> HS.HashSet Name -> Expr -> Expr+inline h ns v@(Var (Id n _))+ | E.isSymbolic n h = v+ | HS.member n ns = v+ | Just e <- E.lookup n h = inline h (HS.insert n ns) e+inline h ns e = modifyChildren (inline h ns) e++hitsLibError :: Monad m => Reducer m () Bool+hitsLibError = mkSimpleReducer+ (const ())+ rr+ where+ rr _ s@(State { curr_expr = CurrExpr _ ce }) b =+ case ce of+ Tick t _ + | t == assumeErrorTickish ->+ return (NoProgress, [(s { track = True }, ())], b)+ _ -> return (NoProgress, [(s, ())], b)++gathererReducer :: Monad m => Reducer m () [FuncCall]+gathererReducer = mkSimpleReducer+ (const ())+ rr+ where+ rr _ s@(State { curr_expr = CurrExpr Evaluate (e@(Assume (Just fc) _ _))+ , track = tr+ }) b =+ let+ s' = s { curr_expr = CurrExpr Evaluate e+ , track = fc:tr}+ in+ return (Finished, [(s', ())], b) + rr _ s@(State { curr_expr = CurrExpr Evaluate (e@(G2.Assert (Just fc) _ _))+ , track = tr+ }) b =+ let+ s' = s { curr_expr = CurrExpr Evaluate e+ , track = fc:tr}+ in+ return (Finished, [(s', ())], b) + rr _ s b = return (Finished, [(s, ())], b)++hitsLibErrorGatherer :: Monad m => Reducer m () ([FuncCall], Bool)+hitsLibErrorGatherer = mkSimpleReducer+ (const ())+ rr+ where+ rr _ s@(State { curr_expr = CurrExpr Evaluate (e@(Assume (Just fc) _ _))+ , track = (tr, hle)+ }) b =+ let+ s' = s { curr_expr = CurrExpr Evaluate e+ , track = (fc:tr, hle)}+ in+ return (Finished, [(s', ())], b) + rr _ s@(State { curr_expr = CurrExpr Evaluate (e@(G2.Assert (Just fc) _ _))+ , track = (tr, hle)+ }) b =+ let+ s' = s { curr_expr = CurrExpr Evaluate e+ , track = (fc:tr, hle)}+ in+ return (Finished, [(s', ())], b) + rr _ s@(State { curr_expr = CurrExpr _ ce, track = (glc, _) }) b =+ case ce of+ Tick t _ + | t == assumeErrorTickish ->+ return (NoProgress, [(s { track = (glc, True) }, ())], b)+ _ -> return (NoProgress, [(s, ())], b)++acceptOnlyOneHalter :: Monad m => Halter m () t+acceptOnlyOneHalter =+ (mkSimpleHalter (const ())+ (\hv _ _ -> hv)+ (\_ _ _ -> return Continue) + (\hv _ _ _ -> hv))+ { discardOnStart = \_ pr _ -> not . null $ accepted pr}++-- | Remove all @Assume@s from the given `Expr`, unless they have a particular @Tick@+elimAssumesExcept :: ASTContainer m Expr => m -> m+elimAssumesExcept = modifyASTs elimAssumesExcept'++elimAssumesExcept' :: Expr -> Expr+elimAssumesExcept' (Assume _ (Tick t _) e)+ | t == assumeErrorTickish = Tick t e+ | otherwise = e+elimAssumesExcept' (Assume _ _ e) = e+elimAssumesExcept' e = e+++-------------------------------+-- Reduce Calls+-------------------------------+-- Reduces the arguments and results of the violated and abstracted functions to normal form.++reduceCalls :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Config -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker)+reduceCalls g2call solver simplifier config bindings er = do+ (bindings', er') <- reduceAbstracted g2call solver simplifier (sharing config) bindings er+ (bindings'', er'') <- reduceAllCalls g2call solver simplifier (sharing config) bindings' er'+ (bindings''', er''') <- reduceHigherOrderCalls g2call solver simplifier (sharing config) bindings'' er''++ return (bindings''', er''')++reduceViolated :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker)+reduceViolated g2call solver simplifier share bindings er@(ExecRes { final_state = s, violated = Just v }) = do+ let red = redArbErrors :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier+ (s', bindings', v') <- reduceFuncCall g2call red solver simplifier s bindings v+ -- putStrLn $ "v = " ++ show v+ -- putStrLn $ "v' = " ++ show v'+ return (bindings', er { final_state = s { expr_env = foldr E.insertSymbolic (expr_env s) (E.symbolicIds $ expr_env s')+ , path_conds = path_conds s' }+ , violated = Just v' })+reduceViolated _ _ _ _ b er = return (b, er) ++reduceAbstracted :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker)+reduceAbstracted g2call solver simplifier share bindings+ er@(ExecRes { final_state = (s@State { track = lht}) }) = do+ let red = redArbErrors :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier+ fcs = abstract_calls lht++ ((s', bindings'), fcs') <- mapAccumM (\(s_, b_) fc -> do+ (new_s, new_b, r_fc) <- reduceFuncCall g2call red solver simplifier s_ b_ fc+ return ((new_s, new_b), r_fc))+ (s, bindings) fcs++ return (bindings', er { final_state = s { expr_env = foldr E.insertSymbolic (expr_env s) (E.symbolicIds $ expr_env s')+ , path_conds = path_conds s'+ , track = lht { abstract_calls = fcs' } }+ })++reduceAllCalls :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker)+reduceAllCalls g2call solver simplifier share bindings+ er@(ExecRes { final_state = (s@State { track = lht}) }) = do+ let fcs = all_calls lht++ (s', bindings', fcs') <- reduceFuncCallMaybeList g2call solver simplifier share bindings s fcs++ return (bindings', er { final_state = s' { track = lht { all_calls = fcs' } }})++reduceHigherOrderCalls :: (Solver solver, Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> ExecRes LHTracker -> IO (Bindings, ExecRes LHTracker)+reduceHigherOrderCalls g2call solver simplifier share bindings+ er@(ExecRes { final_state = (s@State { track = lht}) }) = do+ let fcs = higher_order_calls lht++ (s', bindings', fcs') <- reduceFuncCallMaybeList g2call solver simplifier share bindings s fcs++ return (bindings', er { final_state = s' { track = lht { higher_order_calls = fcs' } }})++reduceFuncCallMaybeList :: ( ASTContainer t Expr+ , ASTContainer t Type+ , Named t+ , Show t+ , Solver solver+ , Simplifier simplifier) => G2Call solver simplifier -> solver -> simplifier -> Sharing -> Bindings -> State t -> [FuncCall] -> IO (State t, Bindings, [FuncCall])+reduceFuncCallMaybeList g2call solver simplifier share bindings st fcs = do+ let red = redArbErrors :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier+ ((s', b'), fcs') <- mapAccumM (\(s, b) fc -> do+ s_b_fc <- reduceFuncCallMaybe g2call red solver simplifier s b fc+ case s_b_fc of+ Just (s', b', fc') -> return ((s', b'), Just fc')+ Nothing -> return ((s, b), Nothing)) (st, bindings) fcs+ return (s', b', catMaybes fcs')++reduceFuncCall :: ( MonadIO m+ , Solver solver+ , Simplifier simplifier+ , ASTContainer t Expr+ , ASTContainer t Type+ , Show t+ , Named t)+ => G2Call solver simplifier -> SomeReducer m t -> solver -> simplifier -> State t -> Bindings -> FuncCall -> m (State t, Bindings, FuncCall)+reduceFuncCall g2call red solver simplifier s bindings fc@(FuncCall { arguments = ars, returns = r }) = do+ -- (bindings', red_ars) <- mapAccumM (reduceFCExpr share (red <~ SomeReducer (Logger "arg")) solver simplifier s) bindings ars+ -- (bindings'', red_r) <- reduceFCExpr share (red <~ SomeReducer (Logger "ret")) solver simplifier s bindings' r+ ((s', bindings'), red_ars) <- mapAccumM (uncurry (reduceFCExpr g2call red solver simplifier)) (s, bindings) ars+ ((s'', bindings''), red_r) <- reduceFCExpr g2call red solver simplifier s' bindings' r++ return (s'', bindings'', fc { arguments = red_ars, returns = red_r })++reduceFCExpr :: ( MonadIO m+ , Solver solver+ , Simplifier simplifier+ , ASTContainer t Expr+ , ASTContainer t Type+ , Show t+ , Named t)+ => G2Call solver simplifier -> SomeReducer m t -> solver -> simplifier -> State t -> Bindings -> Expr -> m ((State t, Bindings), Expr)+reduceFCExpr g2call reducer solver simplifier s bindings e + | not . isTypeClass (type_classes s) $ (typeOf e)+ , ds <- deepseq_walkers bindings+ , Just strict_e <- mkStrict_maybe ds e = do+ let + e' = fillLHDictArgs ds strict_e++ let s' = elimAssumesExcept+ . elimAsserts+ . pickHead+ . elimSymGens (arb_value_gen bindings)+ . modelToExprEnv $+ s { curr_expr = CurrExpr Evaluate e'}++ (er, bindings') <- g2call + reducer+ (SomeHalter (acceptOnlyOneHalter <~> swhnfHalter <~> switchEveryNHalter 200))+ (SomeOrderer (incrAfterN 2000 (adtSizeOrderer 0 Nothing)))+ solver simplifier+ emptyMemConfig+ s' bindings++ case er of+ [er'] -> do+ let fs = final_state er'+ (CurrExpr _ ce) = curr_expr fs+ return ((s { expr_env = foldr E.insertSymbolic (expr_env s') (E.symbolicIds $ expr_env fs)+ , path_conds = path_conds fs }+ , bindings { name_gen = name_gen bindings' }), ce)+ _ -> error $ "reduceFCExpr: Bad reduction"+ | isTypeClass (type_classes s) $ (typeOf e)+ , TyCon n _:_ <- unTyApp (typeOf e)+ , _:Type t:_ <- unApp e+ , Just tc_dict <- typeClassInst (type_classes s) HM.empty n t = + return $ ((s, bindings), tc_dict) + | otherwise = return ((s, bindings), redVar (expr_env s) e) +++reduceFuncCallMaybe :: ( MonadIO m+ , Solver solver+ , Simplifier simplifier+ , ASTContainer t Expr+ , ASTContainer t Type+ , Show t+ , Named t)+ => G2Call solver simplifier -> SomeReducer m t -> solver -> simplifier -> State t -> Bindings -> FuncCall -> m (Maybe (State t, Bindings, FuncCall))+reduceFuncCallMaybe g2call red solver simplifier s bindings fc@(FuncCall { arguments = ars, returns = r }) = do+ ((s', bindings'), red_ars) <- mapAccumM (uncurry (reduceFCExpr g2call red solver simplifier)) (s, bindings) ars+ ((s'', bindings''), red_r) <- reduceFCExpr g2call red solver simplifier s' bindings' r++ return $ Just (s'', bindings'', fc { arguments = red_ars, returns = red_r })++redVar :: E.ExprEnv -> Expr -> Expr+redVar = redVar' HS.empty++-- We use the hashset to track names we've seen, and make sure we don't loop forever on the same variable+redVar' :: HS.HashSet Name -> E.ExprEnv -> Expr -> Expr+redVar' rep eenv v@(Var (Id n t))+ | n `HS.member` rep = v+ | Just e <- E.lookup n eenv = redVar' (HS.insert n rep) eenv e+ -- We fill in fake LH dict variable for reduction, so they don't exist in the ExprEnv,+ -- but we don't want them to error+ | TyCon (Name tn _ _ _) _ <- t+ , tn == "lh" = v+ | otherwise = error $ "redVar: variable not found"+redVar' _ _ e = e++mapAccumM :: (Monad m, MonadPlus p) => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)+mapAccumM _ z [] = return (z, mzero)+mapAccumM f z (x:xs) = do+ (z', y) <- f z x+ (z'', ys) <- mapAccumM f z' xs+ return (z'', return y `mplus` ys)++modelToExprEnv :: State t -> State t+modelToExprEnv s =+ let+ m = HM.filterWithKey (\k _ -> k /= idName existentialInstId && k /= idName postSeqExistentialInstId) (model s)+ in+ s { expr_env = m `E.union'` expr_env s+ , model = HM.empty }++mkAssertsTrue :: ASTContainer t Expr => KnownValues -> State t -> State t+mkAssertsTrue kv = modifyASTs (mkAssertsTrue' (mkTrue kv))++mkAssertsTrue' :: Expr -> Expr -> Expr+mkAssertsTrue' tre (G2.Assert fc _ e) = G2.Assert fc tre e+mkAssertsTrue' _ e = e++elimSymGens :: ArbValueGen -> State t -> State t+elimSymGens arb s = s { expr_env = E.map esg $ expr_env s }+ where+ -- Rewriting the whole ExprEnv is slow, so we only+ -- rewrite an Expr if needed.+ esg e = + if hasSymGen e+ then modify (elimSymGens' (type_env s) arb) e+ else e++elimSymGens' :: TypeEnv -> ArbValueGen -> Expr -> Expr+elimSymGens' tenv arb (SymGen _ t) = fst $ arbValue t tenv arb+elimSymGens' _ _ e = e++hasSymGen :: Expr -> Bool+hasSymGen = getAny . eval hasSymGen'++hasSymGen' :: Expr -> Any+hasSymGen' (SymGen _ _) = Any True+hasSymGen' _ = Any False++-------------------------------+-- Generic+-------------------------------++pickHead :: (ASTContainer m Expr) => m -> m+pickHead = modifyASTs pickHead'++pickHead' :: Expr -> Expr+pickHead' (NonDet xs)+ | x:_ <- xs = x+ | otherwise = error "pickHead: empty NonDet"+pickHead' e = e
+ src/G2/Liquid/Helpers.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++module G2.Liquid.Helpers ( MeasureSymbols (..)+ , getGHCInfos+ , funcSpecs+ + , getTySigs+ , putTySigs+ , getAssumedSigs+ , putAssumedSigs+ , getQualifiers+ , putQualifiers+ , findFuncSpec+ , measureSpecs+ , measureSymbols+ , measureNames+ , varToName+ , varEqName+ , namesEq+ , fillLHDictArgs ) where++import G2.Language as G2+import G2.Liquid.Types+import G2.Translation.Haskell++#if MIN_VERSION_liquidhaskell(0,9,0)+import qualified Liquid.GHC.Interface as LHI+#else+import qualified Language.Haskell.Liquid.GHC.Interface as LHI+#endif+import Language.Fixpoint.Types.Names+#if MIN_VERSION_liquidhaskell(0,8,10)+import Language.Haskell.Liquid.Types hiding+ (Config, TargetInfo (..), TargetSpec (..), GhcSpec (..), cls, names)+#else+import Language.Haskell.Liquid.Types+#endif+import qualified Language.Haskell.Liquid.UX.Config as LHC+import Language.Fixpoint.Types (Qualifier (..))++import Data.List+import qualified Data.Map as M+import qualified Data.Text as T++import GHC as GHC+#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+import GHC.Types.Name+import GHC.Types.Var as V+#else+import Name+import Var as V+#endif++-- | Interface with LH+getGHCInfos :: LHC.Config -> [FilePath] -> [FilePath] -> IO [GhcInfo]+getGHCInfos config proj fp = do+ let config' = config {idirs = idirs config ++ proj+ , files = files config+ , ghcOptions = ["-v"]}++ -- GhcInfo+#if MIN_VERSION_liquidhaskell(0,8,10)+ (ghci, _) <- LHI.getTargetInfos Nothing config' fp+#else+ (ghci, _) <- LHI.getGhcInfos Nothing config' fp+#endif++ return ghci+ +funcSpecs :: [GhcInfo] -> [(Var, LocSpecType)]+funcSpecs fs =+ let+ asserted = concatMap getTySigs fs+ assumed = concatMap getAssumedSigs fs+ in+ asserted ++ assumed++-- | Functions asserted in LH+getTySigs :: GhcInfo -> [(Var, LocSpecType)]+#if MIN_VERSION_liquidhaskell(0,8,6)+getTySigs = gsTySigs . gsSig . giSpec+#else+getTySigs = gsTySigs . spec+#endif++putTySigs :: GhcInfo -> [(Var, LocSpecType)] -> GhcInfo+#if MIN_VERSION_liquidhaskell(0,8,6)+putTySigs gi@(GI {+ giSpec = sp@(SP { gsSig = sp_sig })+ }+ ) new_ty_sigs = + gi { giSpec = sp { gsSig = sp_sig { gsTySigs = new_ty_sigs } } }+#else+putTySigs gi@(GI { spec = sp }) new_ty_sigs = + gi { spec = sp { gsTySigs = new_ty_sigs }}+#endif++-- | Functions assumed in LH+getAssumedSigs :: GhcInfo -> [(Var, LocSpecType)]+#if MIN_VERSION_liquidhaskell(0,8,6)+getAssumedSigs = gsAsmSigs . gsSig . giSpec+#else+getAssumedSigs = gsAsmSigs . spec+#endif++putAssumedSigs :: GhcInfo -> [(Var, LocSpecType)] -> GhcInfo+#if MIN_VERSION_liquidhaskell(0,8,6)+putAssumedSigs gi@(GI {+ giSpec = sp@(SP { gsSig = sp_sig })+ }+ ) new_ty_sigs = + gi { giSpec = sp { gsSig = sp_sig { gsTySigs = new_ty_sigs } } }+#else+putAssumedSigs gi@(GI { spec = sp }) new_ty_sigs = + gi { spec = sp { gsTySigs = new_ty_sigs }}+#endif++getQualifiers :: GhcInfo -> [Qualifier]+#if MIN_VERSION_liquidhaskell(0,8,6)+getQualifiers = gsQualifiers . gsQual . giSpec+#else+getQualifiers = gsQualifiers . spec+#endif++putQualifiers :: GhcInfo -> [Qualifier] -> GhcInfo+#if MIN_VERSION_liquidhaskell(0,8,6)+putQualifiers gi@(GI {+ giSpec = sp@(SP { gsQual = quals })+ }+ ) new_quals = + gi { giSpec = sp { gsQual = quals { gsQualifiers = new_quals } } }+#else+putQualifiers gi@(GI { spec = sp }) new_quals = + gi { spec = sp { gsQualifiers = new_quals }}+#endif+++findFuncSpec :: [GhcInfo] -> G2.Name -> Maybe SpecType+findFuncSpec ghci g2_n =+ let+ fs = funcSpecs ghci+ fs' = map (\(v, lst) -> (V.varName v, lst)) fs+ in+ case find (\(n, _) -> namesEq n g2_n) fs' of+ Just st -> Just . val . snd $ st+ Nothing -> Nothing++varToName :: V.Var -> G2.Name+varToName = mkName . V.varName++varEqName :: V.Var -> G2.Name -> Bool+varEqName v = namesEq (V.varName v)++namesEq :: GHC.Name -> G2.Name -> Bool+namesEq ghc_n (Name n m _ _) =+ T.pack (occNameString $ nameOccName ghc_n) == n+ && (case nameModule_maybe ghc_n of+ Just m' ->+ Just (T.pack . moduleNameString . moduleName $ m') == m+ Nothing -> m == Nothing)++measureSpecs :: [GhcInfo] -> [Measure SpecType GHC.DataCon]+#if MIN_VERSION_liquidhaskell(0,8,6)+measureSpecs = concatMap (gsMeasures . gsData . giSpec)+#else+measureSpecs = concatMap (gsMeasures . spec)+#endif++newtype MeasureSymbols = MeasureSymbols { symbols :: [Symbol] }++measureSymbols :: [GhcInfo] -> MeasureSymbols+measureSymbols = MeasureSymbols . measureNames++measureNames :: [GhcInfo] -> [Symbol]+#if MIN_VERSION_liquidhaskell(0,8,6)+measureNames = map (val . msName) . measureSpecs+#else+measureNames = map (val . name) . measureSpecs+#endif++-- The walk function takes lhDict arguments that are not correctly accounted for by mkStrict.+-- The arguments are not actually used, so, here, we fill them in with undefined. +fillLHDictArgs :: Walkers -> Expr -> Expr+fillLHDictArgs w = modifyAppTop (fillLHDictArgs' w)++fillLHDictArgs' :: Walkers -> Expr -> Expr+fillLHDictArgs' w e+ | f@(Var i):xs <- unApp e+ , any (\(_, i') -> i == i') (M.toList w) = mkApp $ f:fillLHDictArgs'' 0 xs+ | otherwise = e++fillLHDictArgs'' :: Int -> [Expr] -> [Expr]+fillLHDictArgs'' !n [] = replicate n (Prim Undefined TyBottom)+fillLHDictArgs'' !n (t@(Type _):xs) = t:fillLHDictArgs'' (n + 1) xs+fillLHDictArgs'' !n xs = replicate n (Prim Undefined TyBottom) ++ xs
+ src/G2/Liquid/Inference/Config.hs view
@@ -0,0 +1,431 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module G2.Liquid.Inference.Config (+ Progress (..)+ , Progresser (..)+ , ProgresserM (..)+ , MaxSize (..)+ , newProgress+ , runProgresser++ , InfConfigM (..)+ , InferenceConfig (..)+ , Configs (..)+ , InfConfig (..)+ , runConfigs++ , getAllConfigsForInf+ , mkInferenceConfig+ , mkInferenceConfigDirect+ , adjustConfig+ , adjustConfigPostLH++ , incrMaxSize ) where++import G2.Config.Config+import G2.Initialization.Types+import G2.Language ( ExprEnv+ , Expr+ , Name (..)+ , Type (..))+import qualified G2.Language.ExprEnv as E+import qualified G2.Language.Support as S+import G2.Language.Typing+import G2.Liquid.Config+import G2.Liquid.Conversion+import G2.Liquid.Helpers+import G2.Liquid.TCValues+import G2.Liquid.Types+import G2.Liquid.Inference.PolyRef+import G2.Translation.Haskell++#if MIN_VERSION_liquidhaskell(0,8,10)+import G2.Liquid.Types (GhcInfo (..), GhcSpec (..))+#else+import Language.Haskell.Liquid.Types (GhcInfo (..), GhcSpec (..))+#endif+import qualified Language.Haskell.Liquid.Types as LH++#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+import GHC.Types.Var as V+#else+import Var as V+#endif++import Control.Monad.Reader+import Control.Monad.State.Lazy+import qualified Data.HashSet as S+import qualified Data.Map as M+import Data.Maybe (isJust)+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Time.Clock+import Options.Applicative+import System.Directory+++-------------------------------+-- Progresser+-------------------------------++newtype MaxSize = MaxSize Integer++data Progress =+ Progress { ex_max_ce :: M.Map (T.Text, Maybe T.Text) Int -- ^ Gives an extra budget for maximum ce number+ , ex_max_depth :: Int -- ^ Gives an extra budget for the depth limit+ , ex_max_time :: M.Map (T.Text, Maybe T.Text) NominalDiffTime -- ^ Gives an extra max bufget for time+ , max_synth_form_size :: MaxSize+ , max_synth_coeff_size :: MaxSize+ , synth_fresh :: Int -- ^ An int to increment to get fresh names+ }++newProgress :: Progress+newProgress = Progress { ex_max_ce = M.empty+ , ex_max_depth = 0+ , ex_max_time = M.empty+ , max_synth_form_size = MaxSize 1+ , max_synth_coeff_size = MaxSize 2+ , synth_fresh = 0 }++class Progresser p where+ extraMaxCEx :: (T.Text, Maybe T.Text) -> p -> Int+ incrMaxCEx :: (T.Text, Maybe T.Text) -> p -> p++ extraMaxDepth :: p -> Int+ incrMaxDepth :: p -> p++ extraMaxTime :: (T.Text, Maybe T.Text) -> p -> NominalDiffTime+ incrMaxTime :: (T.Text, Maybe T.Text) -> p -> p++ maxSynthFormSize :: p -> MaxSize+ incrMaxSynthFormSize :: p -> p++ maxSynthCoeffSize :: p -> MaxSize+ incrMaxSynthCoeffSize :: p -> p+ setMaxSynthCoeffSize :: MaxSize -> p -> p++ synthFresh :: p -> Int+ incrSynthFresh :: p -> p++instance Progresser Progress where+ extraMaxCEx n (Progress { ex_max_ce = m }) = M.findWithDefault 0 n m+ incrMaxCEx n p@(Progress { ex_max_ce = m }) =+ p { ex_max_ce = M.insertWith (+) n 2 m }++ extraMaxDepth (Progress { ex_max_depth = m }) = m+ incrMaxDepth p@(Progress { ex_max_depth = m }) = p { ex_max_depth = m + 200 }++ extraMaxTime n (Progress { ex_max_time = m }) = M.findWithDefault 0 n m+ incrMaxTime n p@(Progress { ex_max_time = m }) =+ p { ex_max_time = M.insertWith (+) n 4 m }++ maxSynthFormSize (Progress { max_synth_form_size = mss }) = mss+ incrMaxSynthFormSize p@(Progress { max_synth_form_size = mss }) = p { max_synth_form_size = incrMaxSize 1 mss }++ maxSynthCoeffSize (Progress { max_synth_coeff_size = mss }) = mss+ incrMaxSynthCoeffSize p@(Progress { max_synth_coeff_size = mss }) = p { max_synth_coeff_size = incrMaxSize 2 mss }+ setMaxSynthCoeffSize max_size p = p { max_synth_coeff_size = max_size }+++ synthFresh (Progress { synth_fresh = syf }) = syf+ incrSynthFresh p@(Progress { synth_fresh = syf }) = p { synth_fresh = syf + 1 }++class Monad m => ProgresserM m where+ extraMaxCExM :: (T.Text, Maybe T.Text) -> m Int+ incrMaxCExM :: (T.Text, Maybe T.Text) -> m ()++ extraMaxDepthM :: m Int+ incrMaxDepthM :: m ()++ extraMaxTimeM :: (T.Text, Maybe T.Text) -> m NominalDiffTime+ incrMaxTimeM :: (T.Text, Maybe T.Text) -> m ()++ maxSynthFormSizeM :: m MaxSize+ incrMaxSynthFormSizeM :: m ()++ maxSynthCoeffSizeM :: m MaxSize+ incrMaxSynthCoeffSizeM :: m ()+ setMaxSynthCoeffSizeM :: MaxSize -> m ()++ synthFreshM :: m Int+ incrSynthFreshM :: m ()++instance (Monad m, Progresser p) => ProgresserM (StateT p m) where+ extraMaxCExM n = gets (extraMaxCEx n)+ incrMaxCExM n = modify' (incrMaxCEx n)++ extraMaxDepthM = gets extraMaxDepth+ incrMaxDepthM = modify' incrMaxDepth++ extraMaxTimeM n = gets (extraMaxTime n)+ incrMaxTimeM n = modify' (incrMaxTime n)++ maxSynthFormSizeM = gets maxSynthFormSize+ incrMaxSynthFormSizeM = modify' incrMaxSynthFormSize++ maxSynthCoeffSizeM = gets maxSynthCoeffSize+ incrMaxSynthCoeffSizeM = modify' incrMaxSynthCoeffSize+ setMaxSynthCoeffSizeM max_size = modify' (setMaxSynthCoeffSize max_size)++ synthFreshM = gets synthFresh+ incrSynthFreshM = modify' incrSynthFresh++instance ProgresserM m => ProgresserM (ReaderT env m) where+ extraMaxCExM n = lift (extraMaxCExM n)+ incrMaxCExM n = lift (incrMaxCExM n)++ extraMaxDepthM = lift extraMaxDepthM+ incrMaxDepthM = lift incrMaxDepthM++ extraMaxTimeM n = lift (extraMaxTimeM n)+ incrMaxTimeM n = lift (incrMaxTimeM n)++ maxSynthFormSizeM = lift maxSynthFormSizeM+ incrMaxSynthFormSizeM = lift incrMaxSynthFormSizeM++ maxSynthCoeffSizeM = lift maxSynthCoeffSizeM+ incrMaxSynthCoeffSizeM = lift incrMaxSynthCoeffSizeM+ setMaxSynthCoeffSizeM max_size = lift (setMaxSynthCoeffSizeM max_size)++ synthFreshM = lift synthFreshM+ incrSynthFreshM = lift incrSynthFreshM++runProgresser :: (Monad m, Progresser p) => StateT p m a -> p -> m a+runProgresser = evalStateT++incrMaxSize :: Integer -> MaxSize -> MaxSize+incrMaxSize incr (MaxSize sz) = MaxSize (sz + incr)++-------------------------------+-- Configurations+-------------------------------++data Configs = Configs { g2_config :: Config+ , g2lh_config :: LHConfig -- ^ Configurations for running G2 in LH mode+ , lh_config :: LH.Config -- ^ LiquidHaskell configuration settings+ , inf_config :: InferenceConfig }++class InfConfig c where+ g2Config :: c -> Config+ g2lhConfig :: c -> LHConfig+ lhConfig :: c -> LH.Config+ infConfig :: c -> InferenceConfig++class Monad m => InfConfigM m where+ g2ConfigM :: m Config+ g2lhConfigM :: m LHConfig+ lhConfigM :: m LH.Config+ infConfigM :: m InferenceConfig++instance InfConfig Configs where+ g2Config = g2_config+ g2lhConfig = g2lh_config+ lhConfig = lh_config+ infConfig = inf_config++instance InfConfig env => InfConfig (ReaderT env m a) where+ g2Config = return . g2Config =<< ask+ g2lhConfig = return . g2lhConfig =<< ask+ lhConfig = return . lhConfig =<< ask+ infConfig = return . infConfig =<< ask++instance (Monad m, InfConfig env) => InfConfigM (ReaderT env m) where + g2ConfigM = return . g2Config =<< ask + g2lhConfigM = return . g2lhConfig =<< ask+ lhConfigM = return . lhConfig =<< ask + infConfigM = return . infConfig =<< ask ++instance InfConfigM m => InfConfigM (StateT env m) where+ g2ConfigM = lift g2ConfigM+ g2lhConfigM = lift g2lhConfigM+ lhConfigM = lift lhConfigM+ infConfigM = lift infConfigM+++data InferenceConfig =+ InferenceConfig { keep_quals :: Bool++ , modules :: S.HashSet (Maybe T.Text)+ , max_ce :: Int++ , pre_refined :: S.HashSet (T.Text, Maybe T.Text)+ , refinable_funcs :: S.HashSet (T.Text, Maybe T.Text)++ , restrict_coeffs :: Bool -- ^ If true, only allow coefficients in the range of -1 <= c <= 1++ , use_extra_fcs :: Bool -- ^ If true, generate as many constraints as possible, if false, generate+ -- only those that are essential to block bad specifications + , use_level_dec :: Bool+ , use_negated_models :: Bool++ , use_binary_minimization :: Bool -- ^ In parallel to the SMT's solvers minimization support,+ -- use a binary search to minimize synthesis solutions++ , use_invs :: Bool+ + , timeout_se :: NominalDiffTime+ , timeout_sygus :: NominalDiffTime }++getAllConfigsForInf :: IO (String, Bool, Config, LHConfig, InferenceConfig, Maybe String)+getAllConfigsForInf = do+ homedir <- getHomeDirectory+ execParser (mkAllConfigsForInf homedir)++mkAllConfigsForInf :: String -> ParserInfo (String, Bool, Config, LHConfig, InferenceConfig, Maybe String)+mkAllConfigsForInf homedir =+ info (((,,,,,) <$> getFileName+ <*> flag False True (long "count" <> help "count the number of functions in the file")+ <*> mkConfig homedir+ <*> mkLHConfig+ <*> mkInferenceConfig+ <*> mkFuncCheck) <**> helper)+ ( fullDesc+ <> progDesc "Automatically infers specifications to verify code using LiquidHaskell."+ <> header "The G2 Symbolic Execution Engine" )++getFileName :: Parser String+getFileName = argument str (metavar "FILE")++runConfigs :: InfConfig env => ReaderT env m a -> env -> m a+runConfigs = runReaderT++mkInferenceConfig :: Parser InferenceConfig+mkInferenceConfig = InferenceConfig+ <$> flag True False (long "keep-quals" <> help "allow qualifiers to be generated and used during inference")+ <*> pure S.empty+ <*> option auto (long "max-ce"+ <> metavar "M"+ <> value 5+ <> help "the initial maximal number of counterexamples to return from any symbolic execution call")+ <*> pure S.empty+ <*> pure S.empty+ <*> switch (long "restrict-coeffs-1" <> help "restrict coefficients to -1, 0, 1")+ <*> flag True False (long "no-extra-fcs" <> help "do not generate extra (non-blocking) constraints")+ <*> flag True False (long "no-level-dec" <> help "do not use level descent")+ <*> flag True False (long "no-negated-models" <> help "do not use negated models")+ <*> flag True False (long "no-binary-min" <> help "use binary minimization during synthesis")+ <*> switch (long "use-invs" <> help "use invariant mode (benchmarking only)")+ <*> option (maybeReader (Just . fromInteger . read)) (long "timeout-se"+ <> metavar "T"+ <> value 5+ <> help "timeout for symbolic execution")+ <*> option (maybeReader (Just . fromInteger . read)) (long "timeout-sygus"+ <> metavar "T"+ <> value 5+ <> help "timeout for synthesis")++mkFuncCheck :: Parser (Maybe String)+mkFuncCheck =+ option (eitherReader (Right . Just))+ ( long "liquid-func"+ <> metavar "FUNC"+ <> value Nothing+ <> help "a function to directly run symbolic execution on")+++mkInferenceConfigDirect :: [String] -> InferenceConfig+mkInferenceConfigDirect as =+ InferenceConfig { keep_quals = boolArg "keep-quals" as M.empty On+ , modules = S.empty+ , max_ce = strArg "max-ce" as M.empty read 5+ , pre_refined = S.empty+ , refinable_funcs = S.empty+ , restrict_coeffs = boolArg "restrict-coeffs" as M.empty Off+ , use_extra_fcs = boolArg "use-extra-fc" as M.empty On+ , use_level_dec = boolArg "use-level-dec" as M.empty On+ , use_negated_models = boolArg "use-negated-models" as M.empty On+ , use_binary_minimization = True+ , use_invs = boolArg "use-invs" as M.empty Off+ , timeout_se = strArg "timeout-se" as M.empty (fromInteger . read) 5+ , timeout_sygus = strArg "timeout-sygus" as M.empty (fromInteger . read) 10 }++adjustConfig :: Maybe T.Text -> SimpleState -> Config -> LHConfig -> InferenceConfig -> [GhcInfo] -> (Config, LHConfig, InferenceConfig)+adjustConfig main_mod (SimpleState { expr_env = eenv }) config lhconfig infconfig ghci =+ let+ -- ref = refinable main_mod meas tcv eenv++ pre = S.fromList+ . map (\(Name n m _ _) -> (n, m))+ . map (mkName . V.varName . fst)+ $ concatMap getTySigs ghci++ -- ns_mm = map (\(Name n m _ _) -> (n, m))+ -- -- . filter (\(Name n m _ _) -> not $ (n, m) `S.member` pre)+ -- -- . filter (\(Name n _ _ _) -> n `notElem` [ "mapReduce" ])+ -- -- . filter (\(Name n _ _ _) -> n `notElem` [ "mapReduce", "singleton", "concat", "append"+ -- -- , "map", "replicate", "empty", "zipWith", "add"])+ -- . filter (\(Name n m _ _) -> (n, m) `elem` ref)+ -- . E.keys+ -- . E.filter (not . tyVarNoMeas meas tcv)+ -- $ E.filter (not . tyVarRetTy) eenv++ ns_not_main = filter (\(n, _) -> n == "foldr1")+ . map (\(Name n m _ _) -> (n, m))+ . filter (\(Name _ m _ _) -> m /= main_mod)+ $ E.keys eenv+ + lhconfig' = lhconfig { only_top = True+ , block_errors_in = S.fromList ns_not_main }++ infconfig' = infconfig { modules = S.singleton main_mod+ , pre_refined = pre }+ in+ (config, lhconfig', infconfig')++adjustConfigPostLH :: Maybe T.Text -> Measures -> TCValues -> S.State t -> [GhcInfo] -> LHConfig -> LHConfig+adjustConfigPostLH main_mod meas tcv (S.State { S.expr_env = eenv, S.known_values = kv }) ghci lhconfig =+ let+ ref = refinable main_mod meas tcv ghci kv eenv+ + ns_mm = map (\(Name n m _ _) -> (n, m))+ . filter (\(Name n m _ _) -> (n, m) `elem` ref)+ $ E.keys eenv++ in+ lhconfig { counterfactual = Counterfactual . CFOnly $ S.fromList ns_mm }++refinable :: Maybe T.Text -> Measures -> TCValues -> [GhcInfo] -> S.KnownValues -> ExprEnv -> [(T.Text, Maybe T.Text)]+refinable main_mod meas tcv ghci kv eenv = + let+ ns_mm = E.keys+ . E.filter (\e -> not (tyVarNoMeas meas tcv ghci e) || isPrimRetTy kv e)+ . E.filter (not . tyVarRetTy)+ $ E.filterWithKey (\(Name _ m _ _) _ -> m == main_mod) eenv+ ns_mm' = map (\(Name n m _ _) -> (n, m)) ns_mm+ in+ ns_mm'++isPrimRetTy :: S.KnownValues -> Expr -> Bool+isPrimRetTy kv e =+ let+ rel_t = extractValues . extractTypePolyBound $ returnType e+ in+ any (\t -> t == tyInt kv || t == tyBool kv) rel_t++tyVarNoMeas :: Measures -> TCValues -> [GhcInfo] -> Expr -> Bool+tyVarNoMeas meas tcv ghci e =+ let+ rel_t = extractValues . extractTypePolyBound $ returnType e+ rel_meas = E.filter (\e -> + case filter notLH . argumentTypes . PresType . inTyForAlls $ typeOf e of+ [t] -> any (\t' -> isJust $ t' `specializes` t) rel_t+ _ -> False ) meas'+ in+ E.null rel_meas+ where+ meas_names = measureNames ghci+ meas_nameOcc = map (\(Name n md _ _) -> (n, md)) $ map symbolName meas_names+ meas' = E.filterWithKey (\(Name n m _ _) _ -> (n, m) `elem` meas_nameOcc) meas++ notLH t+ | TyCon n _ <- tyAppCenter t = n /= lhTC tcv+ | otherwise = False++tyVarRetTy :: Expr -> Bool+tyVarRetTy e =+ case returnType e of+ TyVar _ -> True+ _ -> False+
+ src/G2/Liquid/Inference/FuncConstraint.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module G2.Liquid.Inference.FuncConstraint ( FuncConstraint (..)+ , SpecPart (..)+ -- , Polarity (..)+ -- , Violated (..)+ -- , Modification (..)+ -- , BoolRel (..)+ , FuncConstraints+ , HigherOrderFuncCall+ , emptyFC+ , fromSingletonFC+ , fromListFC+ , nullFC+ , insertFC+ , lookupFC+ , toListFC+ , unionFC+ , unionsFC+ , mapFC+ , filterFC+ , differenceFC+ , allCallNames+ , allCalls+ , allCallsFC++ , zeroOutUnq++ , printFCs+ , printFC) where++import G2.Language.AST+import G2.Language.Naming+import G2.Language.Support+import G2.Language.Syntax+import G2.Lib.Printers+import G2.Liquid.Interface+import G2.Liquid.Types++import Data.Coerce+import GHC.Generics (Generic)+import Data.Hashable+import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HM+import qualified Data.Map as M+import Data.Monoid hiding (All)+import qualified Data.Text as T++newtype FuncConstraints = FuncConstraints (M.Map Name (HS.HashSet FuncConstraint))+ deriving (Eq, Show, Read)++data SpecPart = All | Pre | Post deriving (Eq, Show, Read, Generic)++data FuncConstraint = Call SpecPart FuncCall [HigherOrderFuncCall]+ | AndFC [FuncConstraint]+ | OrFC [FuncConstraint]+ | ImpliesFC FuncConstraint FuncConstraint+ | NotFC FuncConstraint+ deriving (Eq, Show, Read, Generic)++instance Hashable SpecPart+instance Hashable FuncConstraint++emptyFC :: FuncConstraints+emptyFC = FuncConstraints M.empty++fromSingletonFC :: FuncConstraint -> FuncConstraints+fromSingletonFC = flip insertFC emptyFC++fromListFC :: [FuncConstraint] -> FuncConstraints+fromListFC = foldr insertFC emptyFC++nullFC :: FuncConstraints -> Bool+nullFC = null . toListFC++insertFC :: FuncConstraint -> FuncConstraints -> FuncConstraints+insertFC fc (FuncConstraints fcs) =+ let+ ns = allCallNames fc+ ns' = map zeroOutUnq ns+ fc' = renames (HM.fromList $ zip ns ns') fc+ hs_fc = HS.singleton fc'+ in+ FuncConstraints $ foldr (\n -> M.insertWith HS.union n hs_fc) fcs ns'+ -- coerce (M.insertWith (++) (zeroOutUnq . funcName . constraint $ fc) [fc])++lookupFC :: Name -> FuncConstraints -> [FuncConstraint]+lookupFC n = HS.toList . M.findWithDefault HS.empty (zeroOutUnq n) . coerce++zeroOutUnq :: Name -> Name+zeroOutUnq (Name n m _ l) = Name n m 0 l++toListFC :: FuncConstraints -> [FuncConstraint]+toListFC = HS.toList . HS.unions . M.elems . coerce++unionFC :: FuncConstraints -> FuncConstraints -> FuncConstraints+unionFC (FuncConstraints fc1) (FuncConstraints fc2) =+ coerce $ M.unionWith HS.union fc1 fc2++unionsFC :: [FuncConstraints] -> FuncConstraints+unionsFC = foldr unionFC emptyFC++mapFC :: (FuncConstraint -> FuncConstraint) -> FuncConstraints -> FuncConstraints+mapFC f = coerce (M.map (HS.map f))++filterFC :: (FuncConstraint -> Bool) -> FuncConstraints -> FuncConstraints+filterFC p = coerce (M.map (HS.filter p))++differenceFC :: FuncConstraints -> FuncConstraints -> FuncConstraints+differenceFC (FuncConstraints fc1) (FuncConstraints fc2) =+ FuncConstraints $ M.differenceWith+ (\v1 v2 -> let+ d = HS.difference v1 v2+ in+ case HS.null d of+ True -> Nothing+ False -> Just d)+ fc1 fc2++allCallNames :: FuncConstraint -> [Name]+allCallNames = map funcName . map fst . allCalls++allCalls :: FuncConstraint -> [(FuncCall, [HigherOrderFuncCall])]+allCalls (Call _ fc hfc) = [(fc, hfc)]+allCalls (AndFC fcs) = concatMap allCalls fcs+allCalls (OrFC fcs) = concatMap allCalls fcs+allCalls (ImpliesFC fc1 fc2) = allCalls fc1 ++ allCalls fc2+allCalls (NotFC fc) = allCalls fc++allCallsFC :: FuncConstraints -> [(FuncCall, [HigherOrderFuncCall])]+allCallsFC = concatMap allCalls . toListFC++printFCs :: LiquidReadyState -> FuncConstraints -> T.Text+printFCs lrs fcs =+ T.intercalate "\n" . map (printFC (state . lr_state $ lrs)) $ toListFC fcs++printFC :: State t -> FuncConstraint -> T.Text+printFC s (Call sp (FuncCall { funcName = Name f _ _ _, arguments = ars, returns = r}) hclls) =+ let+ call_str fn = printHaskell s . foldl (\a a' -> App a a') (Var (Id fn TyUnknown)) $ ars+ r_str = printHaskell s r++ hclls_str = case null hclls of+ True -> ""+ False -> ", higher_calls = " <> T.intercalate ", " (map printFuncCall hclls)+ in+ case sp of+ Pre -> "(" <> call_str (Name (f <> "_pre") Nothing 0 Nothing) <> hclls_str <> ")"+ Post -> "(" <> call_str (Name (f <> "_post") Nothing 0 Nothing) <> " " <> r_str <> hclls_str <> ")"+ All -> "(" <> call_str (Name f Nothing 0 Nothing) <> " " <> r_str <> hclls_str <> ")"+printFC s (AndFC fcs) =+ case fcs of+ (f:fcs') -> foldr (\fc fcs'' -> fcs'' <> " && " <> printFC s fc) (printFC s f) fcs'+ [] -> "True"+printFC s (OrFC fcs) =+ case fcs of+ (f:fcs') -> foldr (\fc fcs'' -> fcs'' <> " || " <> printFC s fc) (printFC s f) fcs'+ [] -> "False"+printFC s (ImpliesFC fc1 fc2) = "(" <> printFC s fc1 <> ") => (" <> printFC s fc2 <> ")"+printFC s (NotFC fc) = "not (" <> printFC s fc <> ")"++instance ASTContainer FuncConstraint Expr where+ containedASTs (Call _ fc hcalls) = containedASTs fc ++ containedASTs hcalls+ containedASTs (AndFC fcs) = containedASTs fcs+ containedASTs (OrFC fcs) = containedASTs fcs+ containedASTs (ImpliesFC fc1 fc2) = containedASTs fc1 ++ containedASTs fc2+ containedASTs (NotFC fc) = containedASTs fc++ modifyContainedASTs f (Call sp fc hcalls) = Call sp (modifyContainedASTs f fc) (modifyContainedASTs f hcalls)+ modifyContainedASTs f (AndFC fcs) = AndFC (modifyContainedASTs f fcs)+ modifyContainedASTs f (OrFC fcs) = OrFC (modifyContainedASTs f fcs)+ modifyContainedASTs f (ImpliesFC fc1 fc2) = ImpliesFC (modifyContainedASTs f fc1) (modifyContainedASTs f fc2)+ modifyContainedASTs f (NotFC fc) = NotFC (modifyContainedASTs f fc)++instance Named FuncConstraints where+ names (FuncConstraints fc) = names fc+ rename old new (FuncConstraints fc) = FuncConstraints (rename old new fc)+ renames hm (FuncConstraints fc) = FuncConstraints (renames hm fc)++instance Named FuncConstraint where+ names (Call _ fc hcalls) = names fc <> names hcalls+ names (AndFC fcs) = names fcs+ names (OrFC fcs) = names fcs+ names (ImpliesFC fc1 fc2) = names fc1 <> names fc2+ names (NotFC fc) = names fc++ rename old new (Call sp fc hcalls) = Call sp (rename old new fc) (rename old new hcalls)+ rename old new (AndFC fcs) = AndFC (rename old new fcs)+ rename old new (OrFC fcs) = OrFC (rename old new fcs)+ rename old new (ImpliesFC fc1 fc2) = ImpliesFC (rename old new fc1) (rename old new fc2)+ rename old new (NotFC fc) = NotFC (rename old new fc)++ renames hm (Call sp fc hcalls) = Call sp (renames hm fc) (renames hm hcalls)+ renames hm (AndFC fcs) = AndFC (renames hm fcs)+ renames hm (OrFC fcs) = OrFC (renames hm fcs)+ renames hm (ImpliesFC fc1 fc2) = ImpliesFC (renames hm fc1) (renames hm fc2)+ renames hm (NotFC fc) = NotFC (renames hm fc)
+ src/G2/Liquid/Inference/G2Calls.hs view
@@ -0,0 +1,1110 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module G2.Liquid.Inference.G2Calls ( MeasureExs+ , MaxMeasures+ , PreEvals+ , PostEvals+ , FCEvals+ , Evals (..)++ , SpreadOutSolver (..)++ , gatherAllowedCalls++ , runLHInferenceAll++ , runLHInferenceCore+ , runLHCExSearch+ , checkFuncCall+ , checkCounterexample+ + , emptyEvals+ , preEvals+ , postEvals+ , checkPre+ , checkPost+ , lookupEvals+ , mapEvals+ , mapAccumLEvals+ , deleteEvalsForFunc+ , printEvals++ , evalMeasures+ , formMeasureComps+ , chainReturnType) where++import G2.Config++import G2.Execution+import G2.Execution.PrimitiveEval+import G2.Interface+import G2.Language as G2+import qualified G2.Language.ExprEnv as E+import qualified G2.Language.PathConds as PC+import G2.Lib.Printers+import G2.Liquid.Inference.Config+import G2.Liquid.AddCFBranch+import G2.Liquid.Config+import G2.Liquid.Conversion+import G2.Liquid.ConvertCurrExpr+import G2.Liquid.G2Calls+import G2.Liquid.Helpers+import G2.Liquid.Interface+import G2.Liquid.LHReducers+import G2.Liquid.TCValues+import G2.Liquid.Types+import G2.Liquid.TyVarBags+import G2.Liquid.Inference.InfStack+import G2.Liquid.Inference.Initalization+import G2.Solver hiding (Assert)+import G2.Translation++import Language.Haskell.Liquid.Types hiding (Config, hs)++import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HM+import Data.List+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Sequence as S+import qualified Data.Text as T+import Data.Tuple.Extra++import Control.Monad+import Control.Monad.Extra+import Control.Exception+import Control.Monad.IO.Class+import qualified Control.Monad.State as SM+import Data.Function+import Data.Monoid++-------------------------------------+-- Solvers+-------------------------------------++-- | A solver that adds soft asserts to (try to) spread out integer values+-- returned in a model.+data SpreadOutSolver solver = SpreadOutSolver Integer solver++instance Solver solver => Solver (SpreadOutSolver solver) where+ check (SpreadOutSolver _ solver) s pc = check solver s pc+ + solve (SpreadOutSolver mx_size solver) s b is pc =+ let+ int_vs = filter (isInteger . typeOf) is+ max_vs = map (\i -> Id (Name "MAX_INT_ORD__??__" Nothing i Nothing) TyLitInt)+ . map fst+ $ zip [1..] int_vs++ max_vs_eq = map (flip ExtCond True)+ $ map (\mv -> foldr1 or_expr $ map (\iv -> abs_expr (Var iv) `eq` Var mv) int_vs) max_vs+ max_ord = map (flip ExtCond True) . map (\(x, y) -> Var x `le_expr` Var y) $ adj max_vs+ soft_space = map SoftPC+ . map (flip ExtCond True)+ . map (\(v, vs) -> sum_vars vs `lt_expr` Var v)+ . map (\(v:vs) -> (v, vs))+ . filter (not . null)+ . inits $ reverse max_vs++ pc' = PC.fromList $ max_vs_eq ++ max_ord ++ soft_space+ pc_union = pc `PC.union` pc'+ in+ case null int_vs of+ False -> solve solver s b is pc_union+ True -> solve solver s b is pc+ where+ isInteger TyLitInt = True+ isInteger _ = False++ abs_expr x = App (Prim Abs TyUnknown) x+ eq x y = App (App (Prim Eq TyUnknown) x) y+ or_expr x y = App (App (Prim Or TyUnknown) x) y+ le_expr x y = App (App (Prim Le TyUnknown) x) y+ lt_expr x y = App (App (Prim Lt TyUnknown) x) y+ plus_expr x y = App (App (Prim Plus TyUnknown) x) y+ mult_expr x y = App (App (Prim Mult TyUnknown) x) y++ sum_vars = foldr plus_expr (Lit (LitInt mx_size))+ . map (mult_expr (Lit (LitInt mx_size)))+ . map Var++ adj xs = zip xs $ tail xs++ close (SpreadOutSolver _ solver) = close solver++-------------------------------------+-- Calling G2+-------------------------------------+++{-# SPECIALISE+ runLHG2Inference :: (Solver solver, Simplifier simplifier)+ => Config+ -> SomeReducer (SM.StateT PrettyGuide IO) LHTracker+ -> SomeHalter (SM.StateT PrettyGuide IO) LHTracker+ -> SomeOrderer (SM.StateT PrettyGuide IO) LHTracker+ -> solver+ -> simplifier+ -> MemConfig+ -> Id+ -> State LHTracker+ -> Bindings+ -> SM.StateT PrettyGuide IO ([ExecRes AbstractedInfo], Bindings)+ #-}+runLHG2Inference :: (MonadIO m, Solver solver, Simplifier simplifier)+ => Config+ -> SomeReducer m LHTracker+ -> SomeHalter m LHTracker+ -> SomeOrderer m LHTracker+ -> solver+ -> simplifier+ -> MemConfig+ -> Id+ -> State LHTracker+ -> Bindings+ -> m ([ExecRes AbstractedInfo], Bindings)+runLHG2Inference config red hal ord solver simplifier pres_names init_id final_st bindings = do+ let only_abs_st = addTicksToDeepSeqCases (deepseq_walkers bindings) final_st+ (ret, final_bindings) <- case (red, hal, ord) of+ (SomeReducer red', SomeHalter hal', SomeOrderer ord') ->+ runG2ThroughExecution red' hal' ord' pres_names only_abs_st bindings+ + ret' <- filterM (satState solver) ret+ let ret'' = onlyMinimalStates $ map (earlyExecRes final_bindings) ret'++ cleanupResultsInference solver simplifier config init_id final_bindings ret''++cleanupResultsInference :: (MonadIO m, Solver solver, Simplifier simplifier) =>+ solver+ -> simplifier+ -> Config+ -> Id+ -> Bindings+ -> [ExecRes LHTracker]+ -> m ([ExecRes AbstractedInfo], Bindings)+cleanupResultsInference solver simplifier config init_id bindings ers = do+ let ers2 = map (\er -> er { final_state = putSymbolicExistentialInstInExprEnv (final_state er) }) ers+ let ers3 = map (replaceHigherOrderNames (idName init_id) (input_names bindings)) ers2+ (bindings', ers4) <- liftIO $ mapAccumM (reduceCalls runG2ThroughExecutionInference solver simplifier config) bindings ers3+ ers5 <- liftIO $ mapM (checkAbstracted runG2ThroughExecutionInference solver simplifier config init_id bindings') ers4+ ers6 <- liftIO $ mapM (runG2SolvingInference solver simplifier bindings') ers5++ let ers7 = + map (\er@(ExecRes { final_state = s }) ->+ (er { final_state =+ s {track = + mapAbstractedInfoFCs (evalPrims (type_env s) (known_values s)+ . subVarFuncCall True (model s) (expr_env s) (type_classes s))+ $ track s+ }+ })) ers6+ return (ers7, bindings')++replaceHigherOrderNames :: Name -> [Name] -> ExecRes LHTracker -> ExecRes LHTracker+replaceHigherOrderNames init_name input_names er@(ExecRes { final_state = s@(State { expr_env = eenv, track = t })}) =+ let+ higher = higher_order_calls t++ input_names' = filter (hasFuncType . (E.!) eenv) input_names+ higher_num_init = zip input_names' (map (higherOrderName (nameOcc init_name)) [1..])+ higher_num_all = concatMap (\fc -> let+ as = map nameFromVar $ filter hasFuncType (arguments fc)+ in+ zip as (map (higherOrderName (nameOcc $ funcName fc)) [1..]) )+ . map (\fc -> if nameOcc (funcName fc) == "INITIALLY_CALLED_FUNC" then fc { funcName = init_name } else fc)+ . nubBy ((==) `on` funcName) $ all_calls t+ higher_num = higher_num_init ++ higher_num_all++ higher' = map (\fc -> fc { funcName = lookupErr (funcName fc) higher_num }) higher+ in+ er { final_state = s { track = t { higher_order_calls = higher' }}}+ where+ lookupErr x xs = case lookup x xs of+ Just v -> v+ Nothing -> x -- error $ "replaceHigherOrderNames: missing function name" ++ "\nhigher_num = " ++ show xs ++ "\nx = " ++ show x ++ nameFromVar (Var (Id n _)) = n+ nameFromVar e = error $ "nameFromVar: not Var" ++ show e++higherOrderName :: T.Text -> Int -> Name+higherOrderName n i = Name n (Just "HIGHER_ORDER_??_") i Nothing++runG2ThroughExecutionInference :: G2Call solver simplifier+runG2ThroughExecutionInference red hal ord _ _ pres s b = do+ (fs, fb) <- case (red, hal, ord) of+ (SomeReducer red', SomeHalter hal', SomeOrderer ord') -> runG2ThroughExecution red' hal' ord' pres s b+ return (map (earlyExecRes fb) fs, fb)++runG2SolvingInference :: (MonadIO m, Solver solver, Simplifier simplifier) => solver -> simplifier -> Bindings -> ExecRes AbstractedInfo -> m (ExecRes AbstractedInfo)+runG2SolvingInference solver simplifier bindings (ExecRes { final_state = s }) = do+ let abs_resemble_real = softAbstractResembleReal s+ pc_with_soft = PC.union abs_resemble_real (path_conds s)+ s_with_soft_pc = s { path_conds = pc_with_soft }+ er_solving <- liftIO $ runG2SolvingResult solver simplifier bindings s_with_soft_pc+ case er_solving of+ SAT er_solving' -> do+ let er_solving'' = if fmap funcName (violated er_solving') == Just initiallyCalledFuncName+ then er_solving' { violated = Nothing }+ else er_solving'+ return er_solving''+ UNSAT _ -> error "runG2SolvingInference: solving failed"+ Unknown _ _ -> do+ er_solving_no_min <- liftIO $ runG2SolvingResult solver simplifier bindings s+ case er_solving_no_min of+ SAT er_solving_no_min' -> do+ let er_solving_no_min'' = if fmap funcName (violated er_solving_no_min') == Just initiallyCalledFuncName+ then er_solving_no_min' { violated = Nothing }+ else er_solving_no_min'+ return er_solving_no_min''+ _ -> error "runG2SolvingInference: solving failed with no minimization"++earlyExecRes :: Bindings -> State t -> ExecRes t+earlyExecRes b s@(State { expr_env = eenv, curr_expr = CurrExpr _ cexpr, sym_gens = gens }) =+ let+ viol = assert_ids s+ viol' = if fmap funcName viol == Just initiallyCalledFuncName+ then Nothing+ else viol+ in+ ExecRes { final_state = s+ , conc_args = fixed_inputs b ++ mapMaybe getArg (input_names b)+ , conc_out = cexpr+ , conc_sym_gens = fmap fromJust . S.filter isJust $ fmap getArg gens+ , violated = viol' }+ where+ getArg n = case E.lookup n eenv of+ Just e@(Lam _ _ _) -> Just . Var $ Id n (typeOf e)+ Just e -> Just e+ Nothing -> Nothing++satState :: ( MonadIO m+ , Named t+ , ASTContainer t Expr+ , ASTContainer t Type+ , Solver solver) =>+ solver+ -> State t+ -> m Bool+satState solver s+ | true_assert s = do+ r <- liftIO $ check solver s (path_conds s)++ case r of+ SAT _ -> return True+ UNSAT _ -> return False+ Unknown _ _ -> return False+ | otherwise = return False++-- | Generate soft path constraints that encourage the `abstract` function call arguments+-- to be the same as the `real` function call arguments.+softAbstractResembleReal :: State AbstractedInfo -> PathConds+softAbstractResembleReal =+ foldr PC.union PC.empty . map softAbstractResembleReal' . abs_calls . track++softAbstractResembleReal' :: Abstracted -> PathConds+softAbstractResembleReal' abstracted =+ let+ ars_pairs = zip (arguments $ abstract abstracted) (arguments $ real abstracted)+ ret_pair = (returns $ abstract abstracted, returns $ real abstracted)+ in+ foldr PC.union PC.empty . map PC.fromList $ map (uncurry softPair) (ret_pair:ars_pairs)++softPair :: Expr -> Expr -> [PathCond]+softPair v1@(Var (Id _ t1)) e2 | isPrimType t1 =+ assert (t1 == typeOf e2)+ [MinimizePC $ App (Prim Abs TyUnknown) (App (App (Prim Minus TyUnknown) v1) e2)]+softPair e1 v2@(Var (Id _ t2)) | isPrimType t2 =+ assert (typeOf e1 == t2)+ [MinimizePC $ App (Prim Abs TyUnknown) (App (App (Prim Minus TyUnknown) e1) v2)]+softPair (App e1 e2) (App e1' e2') = softPair e1 e1' ++ softPair e2 e2'+softPair _ _ = []++-------------------------------------+-- Generating Allowed Inputs/Outputs+-------------------------------------++-- By symbolically executing from user-specified functions, and gathering+-- all called functions, we can get functions calls that MUST be allowed by+-- the specifications++gatherAllowedCalls :: T.Text+ -> Maybe T.Text+ -> LiquidReadyState+ -> [GhcInfo]+ -> InferenceConfig+ -> Config+ -> LHConfig+ -> IO [FuncCall]+gatherAllowedCalls entry m lrs ghci infconfig config lhconfig = do+ let config' = config -- { only_top = False }++ LiquidData { ls_state = s+ , ls_bindings = bindings+ , ls_memconfig = pres_names } <-+ processLiquidReadyStateWithCall lrs ghci entry m config' lhconfig mempty++ let (s', bindings') = (s, bindings) -- execStateM addTrueAssertsAll s bindings++ SomeSolver solver <- initSolver config'+ let simplifier = IdSimplifier+ s'' = repCFBranch $+ s' { true_assert = True+ , track = [] :: [FuncCall] }++ (red, hal, ord) <- gatherReducerHalterOrderer infconfig config' lhconfig solver simplifier+ (exec_res, bindings'') <- SM.evalStateT (runG2WithSomes red hal ord solver simplifier pres_names s'' bindings') (mkPrettyGuide ())++ putStrLn $ "length exec_res = " ++ show (length exec_res)++ let called = concatMap (\er ->+ let fs = final_state er in+ map (fs,) $ track fs) exec_res++ fc_red = SomeReducer (stdRed (sharing config') retReplaceSymbFuncVar solver simplifier)++ (_, red_calls) <- mapAccumM + (\b (fs, fc) -> do+ (_, b', rfc) <- reduceFuncCall runG2WithSomes+ fc_red+ solver+ simplifier+ fs b fc+ return (b', rfc))+ bindings''+ called++ close solver++ return red_calls++repCFBranch :: ASTContainer t Expr => t -> t+repCFBranch = modifyASTs repCFBranch'++repCFBranch' :: Expr -> Expr+repCFBranch' nd@(NonDet (e:_))+ | Let b (Assert fc ae1 ae2) <- e = Let b $ Assume fc ae1 ae2+ | otherwise = nd+repCFBranch' (Let b (Assert fc ae1 ae2)) = Let b $ Assume fc ae1 ae2+repCFBranch' e = e++gatherReducerHalterOrderer :: (MonadIO m, Solver solver, Simplifier simplifier)+ => InferenceConfig+ -> Config+ -> LHConfig+ -> solver+ -> simplifier+ -> IO ( SomeReducer (SM.StateT PrettyGuide m) [FuncCall]+ , SomeHalter (SM.StateT PrettyGuide m) [FuncCall]+ , SomeOrderer (SM.StateT PrettyGuide m) [FuncCall])+gatherReducerHalterOrderer infconfig config lhconfig solver simplifier = do+ let+ share = sharing config++ state_name = Name "state" Nothing 0 Nothing++ m_logger = fmap SomeReducer $ getLogger config++ timer_halter <- stdTimerHalter (timeout_se infconfig * 3)++ let red = case m_logger of+ Just logger -> logger .~> SomeReducer (gathererReducer ~> stdRed share retReplaceSymbFuncVar solver simplifier)+ Nothing -> SomeReducer (gathererReducer ~> stdRed share retReplaceSymbFuncVar solver simplifier)++ return+ (red .== Finished .--> (taggerRed state_name :== Finished --> nonRedPCRed)+ , SomeHalter+ (discardIfAcceptedTagHalter state_name+ <~> switchEveryNHalter (switch_after lhconfig)+ <~> swhnfHalter+ <~> timer_halter)+ , SomeOrderer (incrAfterN 2000 (adtSizeOrderer 0 Nothing)))++-------------------------------+-- Direct Counterexamples Calls+-------------------------------+-- This does all the work to take LH source code and run symbolic execution on the named function.+-- In the inference algorithm itself, we don't want to use this, since if we did we would be+-- needlessly repeatedly reading and compiling the code. But it's to have an "end-to-end"+-- function to just running the symbolic execution, for debugging.++{-# SPECIALISE+ runLHInferenceAll :: InferenceConfig+ -> Config+ -> LHConfig+ -> T.Text+ -> [FilePath]+ -> [FilePath]+ -> IO (([ExecRes AbstractedInfo], Bindings), Id)+ #-}+runLHInferenceAll :: MonadIO m+ => InferenceConfig+ -> Config+ -> LHConfig+ -> T.Text+ -> [FilePath]+ -> [FilePath]+ -> m (([ExecRes AbstractedInfo], Bindings), Id)+runLHInferenceAll infconfig config g2lhconfig func proj fp = do+ -- Initialize LiquidHaskell+ (ghci, lhconfig) <- liftIO $ getGHCI infconfig proj fp++ let g2config = config { mode = Liquid+ , steps = 2000 }+ transConfig = simplTranslationConfig { simpl = False }+ (main_mod, exg2) <- liftIO $ translateLoaded proj fp transConfig g2config++ let (lrs, g2config', g2lhconfig', infconfig') = initStateAndConfig exg2 main_mod g2config g2lhconfig infconfig ghci++ let configs = Configs { g2_config = g2config', g2lh_config = g2lhconfig', lh_config = lhconfig, inf_config = infconfig'}++ execInfStack configs newProgress (runLHInferenceCore func main_mod lrs ghci)++-------------------------------+-- Generating Counterexamples+-------------------------------+runLHInferenceCore :: MonadIO m+ => T.Text+ -> Maybe T.Text+ -> LiquidReadyState+ -> [GhcInfo]+ -> InfStack m (([ExecRes AbstractedInfo], Bindings), Id)+runLHInferenceCore entry m lrs ghci = do+ MaxSize max_coeff_sz <- maxSynthCoeffSizeI++ g2config <- g2ConfigM+ lhconfig <- g2lhConfigM+ infconfig <- infConfigM++ LiquidData { ls_state = final_st+ , ls_bindings = bindings+ , ls_id = ifi+ , ls_counterfactual_name = cfn+ , ls_memconfig = pres_names } <- liftIO $ processLiquidReadyStateWithCall lrs ghci entry m g2config lhconfig mempty+ SomeSolver solver <- liftIO $ initSolver g2config+ -- let solver' = SpreadOutSolver max_coeff_sz solver+ let simplifier = IdSimplifier+ final_st' = swapHigherOrdForSymGen bindings final_st++ (red, hal, ord) <- inferenceReducerHalterOrderer infconfig g2config lhconfig solver simplifier entry m cfn final_st'+ -- liftIO is important so that we specialize runLHG2Inference+ (exec_res, final_bindings) <- liftIO $ SM.evalStateT (runLHG2Inference g2config red hal ord solver simplifier pres_names ifi final_st' bindings) (mkPrettyGuide ())++ liftIO $ close solver++ return ((exec_res, final_bindings), ifi)++inferenceReducerHalterOrderer :: (MonadIO m, MonadIO m_run, Solver solver, Simplifier simplifier)+ => InferenceConfig+ -> Config+ -> LHConfig+ -> solver+ -> simplifier+ -> T.Text+ -> Maybe T.Text+ -> Name+ -> State LHTracker+ -> InfStack m ( SomeReducer (SM.StateT PrettyGuide m_run) LHTracker+ , SomeHalter (SM.StateT PrettyGuide m_run) LHTracker+ , SomeOrderer (SM.StateT PrettyGuide m_run) LHTracker)+inferenceReducerHalterOrderer infconfig config lhconfig solver simplifier entry mb_modname cfn st = do+ extra_ce <- extraMaxCExI (entry, mb_modname)+ extra_time <- extraMaxTimeI (entry, mb_modname)++ -- time <- liftIO $ getCurrentTime+ let+ share = sharing config++ state_name = Name "state" Nothing 0 Nothing+ abs_ret_name = Name "abs_ret" Nothing 0 Nothing++ ce_num = max_ce infconfig + extra_ce+ lh_max_outputs = lhMaxOutputsHalter ce_num++ timeout = timeout_se infconfig + extra_time++ m_logger = fmap SomeReducer $ getLogger config+ -- m_logger = if entry == "mapReduce" then Just (SomeReducer $ PrettyLogger ("a_mapReduce" ++ show time) (mkPrettyGuide ())) else getLogger config++ liftIO $ putStrLn $ "ce num for " ++ T.unpack entry ++ " is " ++ show ce_num+ liftIO $ putStrLn $ "timeout for " ++ T.unpack entry ++ " is " ++ show timeout+ + timer_halter <- liftIO $ stdTimerHalter (timeout * 2)+ lh_timer_halter <- liftIO $ lhStdTimerHalter timeout++ let halter = lhAbsHalter entry mb_modname (expr_env st)+ <~> lh_max_outputs+ <~> switchEveryNHalter (switch_after lhconfig)+ <~> lhSWHNFHalter+ <~> timer_halter+ <~> lh_timer_halter+ let some_red = existentialInstRed :== NoProgress .-->+ lhRed cfn :== Finished .--> + redArbErrors :== Finished .-->+ SomeReducer (allCallsRed ~>+ higherOrderCallsRed ~>+ stdRed share retReplaceSymbFuncVar solver simplifier)++ return $+ (+ (case m_logger of+ Just logger -> logger .~> some_red+ Nothing -> some_red) .== Finished .-->+ (taggerRed state_name :== Finished --> nonRedPCRed) .== Finished .-->+ (taggerRed abs_ret_name :== Finished --> nonRedAbstractReturnsRed)+ , SomeHalter+ (discardIfAcceptedTagHalter state_name <~> halter)+ , SomeOrderer (incrAfterN 2000 (quotTrueAssert (ordComb (+) (pcSizeOrderer 0) (adtSizeOrderer 0 (Just instFuncTickName))))))++runLHCExSearch :: MonadIO m+ => T.Text+ -> Maybe T.Text+ -> LiquidReadyState+ -> [GhcInfo]+ -> InfStack m (([ExecRes AbstractedInfo], Bindings), Id)+runLHCExSearch entry m lrs ghci = do+ g2config <- g2ConfigM+ lhconfig <- g2lhConfigM+ infconfig <- infConfigM++ let lhconfig' = lhconfig { counterfactual = NotCounterfactual+ , only_top = False}++ LiquidData { ls_state = final_st+ , ls_bindings = bindings+ , ls_id = ifi+ , ls_counterfactual_name = cfn+ , ls_memconfig = pres_names } <- liftIO $ processLiquidReadyStateWithCall lrs ghci entry m g2config lhconfig' mempty+ SomeSolver solver <- liftIO $ initSolver g2config+ let simplifier = IdSimplifier+ final_st' = swapHigherOrdForSymGen bindings final_st++ (red, hal, ord) <- realCExReducerHalterOrderer infconfig g2config lhconfig' entry m solver simplifier cfn+ -- liftIO is important so that we specialize runLHG2Inference+ (exec_res, final_bindings) <- liftIO $ SM.evalStateT (runLHG2Inference g2config red hal ord solver simplifier pres_names ifi final_st' bindings) (mkPrettyGuide ())++ liftIO $ close solver++ return ((exec_res, final_bindings), ifi)++realCExReducerHalterOrderer :: (MonadIO m, MonadIO m_run, Solver solver, Simplifier simplifier)+ => InferenceConfig+ -> Config+ -> LHConfig+ -> T.Text+ -> Maybe T.Text+ -> solver+ -> simplifier+ -> Name+ -> InfStack m ( SomeReducer (SM.StateT PrettyGuide m_run) LHTracker+ , SomeHalter (SM.StateT PrettyGuide m_run) LHTracker+ , SomeOrderer (SM.StateT PrettyGuide m_run) LHTracker)+realCExReducerHalterOrderer infconfig config lhconfig entry modname solver simplifier cfn = do+ extra_ce <- extraMaxCExI (entry, modname)+ extra_depth <- extraMaxDepthI++ liftIO . putStrLn $ "extra_depth = " ++ show extra_depth++ let+ share = sharing config++ state_name = Name "state" Nothing 0 Nothing+ abs_ret_name = Name "abs_ret" Nothing 0 Nothing++ ce_num = max_ce infconfig + extra_ce+ lh_max_outputs = lhMaxOutputsHalter ce_num++ m_logger = fmap SomeReducer $ getLogger config++ timer_halter <- liftIO $ stdTimerHalter (timeout_se infconfig)++ let halter = lh_max_outputs+ <~> switchEveryNHalter (switch_after lhconfig)+ <~> zeroHalter (0 + extra_depth)+ <~> lhAcceptIfViolatedHalter+ <~> timer_halter+ + lh_std_red = lhRed cfn :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier+ log_opt_red = case m_logger of+ Just logger -> logger .~> lh_std_red+ Nothing -> lh_std_red++ return $+ (log_opt_red .== Finished .-->+ (taggerRed state_name :== Finished --> nonRedPCRed) .== Finished .-->+ (taggerRed abs_ret_name :== Finished --> nonRedAbstractReturnsRed)+ , SomeHalter+ (discardIfAcceptedTagHalter state_name <~> halter)+ , SomeOrderer (incrAfterN 1000 (adtSizeOrderer 0 Nothing)))+++swapHigherOrdForSymGen :: Bindings -> State t -> State t+swapHigherOrdForSymGen b s@(State { expr_env = eenv }) =+ let+ is = filter (isTyFun . typeOf) $ inputIds s b++ eenv' = foldr swapForSG eenv is+ in+ s { expr_env = eenv' }++swapForSG :: Id -> ExprEnv -> ExprEnv+swapForSG i eenv =+ let+ as = map (\at -> case at of+ NamedType i' -> (TypeL, i')+ AnonType t -> (TermL, Id (Name "x" Nothing 0 Nothing) t))+ $ spArgumentTypes i+ r = returnType i++ sg_i = Id (Name "sym_gen" Nothing 0 Nothing) r+ in+ E.insert (idName i) (Let [(sg_i, SymGen SNoLog r)] $ mkLams as (Var sg_i)) eenv++-------------------------------+-- Checking Counterexamples+-------------------------------++-- Does a given FuncCall (counterexample) violate a specification?+-- This allows us to check if a found counterexample violates a user-provided specifications,+-- or a synthesized specification.+-- Returns True if the original Assertions are True (i.e. not violated)+checkFuncCall :: LiquidReadyState -> [GhcInfo] -> Config -> LHConfig -> FuncCall -> IO Bool+checkFuncCall = checkCounterexample++checkCounterexample :: LiquidReadyState -> [GhcInfo] -> Config -> LHConfig -> FuncCall -> IO Bool+checkCounterexample lrs ghci config lhconfig cex@(FuncCall { funcName = Name n m _ _ }) = do+ let lhconfig' = lhconfig { counterfactual = NotCounterfactual }+ -- We use the same function to instantiate this state as in runLHInferenceCore, so all the names line up+ LiquidData { ls_state = s+ , ls_bindings = bindings } <- processLiquidReadyStateWithCall lrs ghci n m config lhconfig' mempty++ let s' = checkCounterexample' cex s++ SomeSolver solver <- initSolver config+ (fsl, _) <- genericG2Call config solver s' bindings+ close solver++ -- We may return multiple states if any of the specifications contained a SymGen+ return $ any (currExprIsTrue . final_state) fsl++checkCounterexample' :: FuncCall -> State t -> State t+checkCounterexample' fc@(FuncCall { funcName = n }) s@(State { expr_env = eenv, known_values = kv })+ | Just e <- E.lookup n eenv =+ let+ e' = toJustSpec kv fc (leadingLamIds e) (inLams e)+ in+ s { curr_expr = CurrExpr Evaluate e'+ , true_assert = True }+ | otherwise = error $ "checkCounterexample': Name not found " ++ show n++toJustSpec :: KnownValues -> FuncCall -> [Id] -> Expr -> Expr+toJustSpec _ (FuncCall { arguments = ars, returns = ret }) is (Let [(b, _)] (Assert _ e _)) =+ let+ rep = (Var b, ret):zip (map Var is) ars + in+ foldr (uncurry replaceASTs) e rep+toJustSpec kv _ _ e = assert (not $ hasAssert e) mkTrue kv++hasAssert :: Expr -> Bool+hasAssert = getAny . evalASTs hasAssert'++hasAssert' :: Expr -> Any+hasAssert' (Assert _ _ _) = Any True+hasAssert' _ = Any False+++currExprIsTrue :: State t -> Bool+currExprIsTrue (State { curr_expr = CurrExpr _ (Data (DataCon (Name dcn _ _ _) _))}) = dcn == "True"+currExprIsTrue _ = False++-------------------------------+-- Checking Pre and Post Conditions+-------------------------------+type PreEvals b = FCEvals b+type PostEvals b = FCEvals b+type FCEvals b = HM.HashMap Name (HM.HashMap FuncCall b)++data Evals b = Evals { pre_evals :: PreEvals b+ , post_evals :: PostEvals b }+ deriving Show++emptyEvals :: Evals b+emptyEvals = Evals { pre_evals = HM.empty, post_evals = HM.empty }++preEvals :: (InfConfigM m, MonadIO m) => Evals Bool -> LiquidReadyState -> [GhcInfo] -> [(FuncCall, [HigherOrderFuncCall])] -> m (Evals Bool)+preEvals evals@(Evals { pre_evals = pre }) lrs ghci fcs = do+ (pre', _) <- foldM (uncurry (runEvals checkPre' ghci lrs)) (pre, HM.empty) fcs+ return $ evals { pre_evals = pre' }+ -- return . HM.fromList =<< mapM (\fc -> return . (fc,) =<< checkPre lrs ghci fc) fcs++postEvals :: (InfConfigM m, MonadIO m) => Evals Bool -> LiquidReadyState -> [GhcInfo] -> [(FuncCall, [HigherOrderFuncCall])] -> m (Evals Bool)+postEvals evals@(Evals { post_evals = post }) lrs ghci fcs = do+ (post', _) <- foldM (uncurry (runEvals checkPost' ghci lrs)) (post, HM.empty) fcs+ return $ evals { post_evals = post' }++runEvals :: (InfConfigM m, MonadIO m) =>+ (LiquidData -> FuncCall -> [HigherOrderFuncCall] -> m Bool)+ -> [GhcInfo]+ -> LiquidReadyState+ -> FCEvals Bool+ -> HM.HashMap (T.Text, Maybe T.Text) LiquidData+ -> (FuncCall, [HigherOrderFuncCall])+ -> m (FCEvals Bool, HM.HashMap (T.Text, Maybe T.Text) LiquidData)+runEvals f ghci lrs hm ld_m (fc, hfc) =+ let+ n = zeroOutName $ funcName fc+ n_hm = maybe HM.empty id (HM.lookup n hm)+ in+ if fc `HM.member` n_hm+ then return (hm, ld_m)+ else do+ let nt = nameTuple (funcName fc)+ (ld, ld_m') <- case HM.lookup nt ld_m of+ Just ld' -> return (ld', ld_m)+ Nothing -> do+ ld' <- checkPreOrPostLD ghci lrs fc+ return (ld', HM.insert nt ld' ld_m)+ pr <- f ld fc hfc+ return $ (HM.insert n (HM.insert fc pr n_hm) hm, ld_m')++checkPre :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> FuncCall -> [HigherOrderFuncCall] -> m Bool+checkPre ghci lrs fc hfc = do+ ld <- checkPreOrPostLD ghci lrs fc+ checkPre' ld fc hfc++checkPre' :: (InfConfigM m, MonadIO m) => LiquidData -> FuncCall -> [HigherOrderFuncCall] -> m Bool+checkPre' ld fc@(FuncCall { funcName = n }) hfc = do+ r <- checkPreOrPost' (M.map thd3 . zeroOutKeys . ls_assumptions) arguments ld fc+ case r of+ False -> return False+ True -> do+ let assumpts = M.lookup (zeroOutName n) . zeroOutKeys . ls_assumptions $ ld+ case assumpts of+ Just (_, higher_assumpts, _) -> do+ rs <- allM (checkPreHigherOrder ld (catMaybes higher_assumpts)) $ filter (\h -> nameOcc (funcName h) == nameOcc n) hfc+ return rs+ Nothing -> return True++checkPreHigherOrder :: (InfConfigM m, MonadIO m) => LiquidData -> [Expr] -> HigherOrderFuncCall -> m Bool+checkPreHigherOrder ld es (FuncCall {funcName = (Name _ _ i _), arguments = as, returns = r }) = do+ config <- g2ConfigM+ SomeSolver solver <- liftIO $ initSolver config+ let e = es !! (i - 1)+ e' = insertInLams (\_ in_e -> + case in_e of+ Let [(b, _)] le -> Let [(b, r)] le+ _ -> error "checkPreHigherOrder: unexpected expresssion form") e+ s' = (ls_state ld) { curr_expr = CurrExpr Evaluate . modifyASTs repAssumeWithAssumption . mkApp $ e':as+ , true_assert = True }+ bindings = ls_bindings ld+ (fsl, _) <- liftIO $ genericG2Call config solver s' bindings+ liftIO $ close solver++ -- We may return multiple states if any of the specifications contained a SymGen+ return $ any (currExprIsTrue . final_state) fsl+ where+ repAssumeWithAssumption (Assume _ e _) = e+ repAssumeWithAssumption e = e ++checkPost :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> FuncCall -> [HigherOrderFuncCall] -> m Bool+checkPost ghci lrs fc hfc = do+ ld <- checkPreOrPostLD ghci lrs fc+ checkPost' ld fc hfc++checkPost' :: (InfConfigM m, MonadIO m) => LiquidData -> FuncCall -> [HigherOrderFuncCall] -> m Bool+checkPost' ld fc _ = checkPreOrPost' (zeroOutKeys . ls_posts) (\fc_ -> arguments fc_ ++ [returns fc_]) ld fc++zeroOutKeys :: M.Map Name v -> M.Map Name v+zeroOutKeys = M.mapKeys zeroOutName++zeroOutName :: Name -> Name+zeroOutName (Name n m _ l) = Name n m 0 l++checkPreOrPostLD :: (InfConfigM m, MonadIO m)+ => [GhcInfo] -> LiquidReadyState -> FuncCall -> m LiquidData+checkPreOrPostLD lrs ghci (FuncCall { funcName = Name n m _ _ }) = do+ config <- g2ConfigM+ lhconfig <- g2lhConfigM+ let lhconfig' = lhconfig { counterfactual = NotCounterfactual }+ -- We use the same function to instantiate this state as in runLHInferenceCore, so all the names line up+ liftIO $ processLiquidReadyStateWithCall ghci lrs n m config lhconfig' mempty++checkPreOrPost' :: (InfConfigM m, MonadIO m)+ => (LiquidData -> M.Map Name Expr) -> (FuncCall -> [Expr]) -> LiquidData -> FuncCall -> m Bool+checkPreOrPost' extract ars ld@(LiquidData { ls_state = s, ls_bindings = bindings }) cex = do+ config <- g2ConfigM++ -- We use the same function to instantiate this state as in runLHInferenceCore, so all the names line up+ case checkFromMap ars (extract ld) cex s of+ Just s' -> do+ SomeSolver solver <- liftIO $ initSolver config+ (fsl, _) <- liftIO $ genericG2Call config solver s' bindings+ liftIO $ close solver++ -- We may return multiple states if any of the specifications contained a SymGen+ return $ any (currExprIsTrue . final_state) fsl+ -- If there is no explicit specification, the specification is implicitly True+ Nothing -> return True++checkFromMap :: (FuncCall -> [Expr]) -> M.Map Name Expr -> FuncCall -> State t -> Maybe (State t)+checkFromMap ars specs fc@(FuncCall { funcName = n }) s =+ let+ e = M.lookup (zeroOutName n) specs+ in+ case e of+ Just e' ->+ let+ e'' = mkApp $ e':ars fc+ in+ Just $ s { curr_expr = CurrExpr Evaluate e''+ , true_assert = True }+ Nothing -> Nothing++lookupEvals :: FuncCall -> FCEvals a -> Maybe a+lookupEvals fc@(FuncCall { funcName = n }) fce =+ HM.lookup fc =<< HM.lookup (zeroOutName n) fce++mapEvals :: (a -> b) -> Evals a -> Evals b+mapEvals f (Evals { pre_evals = pre, post_evals = post }) =+ Evals { pre_evals = HM.map (HM.map f) pre, post_evals = HM.map (HM.map f) post }++mapAccumLEvals :: (a -> b -> (a, c)) -> a -> Evals b -> (a, Evals c)+mapAccumLEvals f inital ev =+ let+ (inital', pre') = mapAccumL (mapAccumL f) inital (pre_evals ev) + (inital'', post') = mapAccumL (mapAccumL f) inital' (post_evals ev) + in+ (inital'', ev { pre_evals = pre', post_evals = post' })++deleteEvalsForFunc :: Name -> Evals a -> Evals a+deleteEvalsForFunc n (Evals { pre_evals = pre_ev, post_evals = post_ev }) =+ Evals { pre_evals = HM.delete (zeroOutName n) pre_ev+ , post_evals = HM.delete (zeroOutName n) post_ev }++printEvals :: (a -> T.Text) -> Evals a -> T.Text+printEvals f (Evals { pre_evals = pre, post_evals = post }) =+ "Evals {\npre_evals = " <> printEvals' f pre <> "\npost_evals = " <> printEvals' f post <> "\n}"++printEvals' :: (a -> T.Text) -> FCEvals a -> T.Text+printEvals' f =+ T.intercalate "\n"+ . map (\(fc, v) -> printFuncCall fc <> " -> " <> f v)+ . HM.toList+ . HM.unions+ . HM.elems++-------------------------------+-- Eval Measures+-------------------------------+-- Evaluate all relevant measures on a given expression++type MeasureExs = HM.HashMap Expr (HM.HashMap [Name] Expr)++type MaxMeasures = Int++evalMeasures :: (InfConfigM m, ProgresserM m, MonadIO m) => MeasureExs -> LiquidReadyState -> [GhcInfo] -> [Expr] -> m MeasureExs+evalMeasures init_meas lrs ghci es = do+ config <- g2ConfigM++ let memc = emptyMemConfig { pres_func = presMeasureNames }+ LiquidData { ls_state = s+ , ls_bindings = bindings+ , ls_measures = meas+ , ls_tcv = tcv+ , ls_memconfig = pres_names } <- liftIO $ extractWithoutSpecs lrs (Id (Name "" Nothing 0 Nothing) TyUnknown) ghci memc++ let s' = s { true_assert = True }+ (final_s, final_b) = markAndSweepPreserving pres_names s' bindings++ tot_meas = E.filter (isTotal (type_env s)) meas++ SomeSolver solver <- liftIO $ initSolver config+ meas_res <- foldM (evalMeasures' (final_s {type_env = type_env s}) final_b solver config tot_meas tcv) init_meas $ filter (not . isError) es+ liftIO $ close solver+ return meas_res+ where+ meas_names = measureNames ghci+ meas_nameOcc = map (\(Name n md _ _) -> (n, md)) $ map symbolName meas_names++ presMeasureNames s _ hs =+ let+ eenv = E.filterWithKey (\(Name n md _ _) _ -> (n, md) `elem` meas_nameOcc) (expr_env s)+ eenv_meas_names = E.keys eenv+ in+ foldr HS.insert hs eenv_meas_names+ + isError (Prim Error _) = True+ isError _ = False++isTotal :: TypeEnv -> Expr -> Bool+isTotal tenv = getAll . evalASTs isTotal'+ where+ isTotal' (Case i _ _ as)+ | TyCon n _:_ <- unTyApp (typeOf i)+ , Just adt <- HM.lookup n tenv =+ All (length (dataCon adt) == length (filter isDataAlt as))+ isTotal' (Case _ _ _ _) = All False+ isTotal' _ = All True++ isDataAlt (G2.Alt (DataAlt _ _) _) = True+ isDataAlt _ = False+++evalMeasures' :: ( InfConfigM m+ , MonadIO m+ , ProgresserM m+ , ASTContainer t Expr+ , ASTContainer t Type+ , Named t+ , Solver solver+ , Show t) => State t -> Bindings -> solver -> Config -> Measures -> TCValues -> MeasureExs -> Expr -> m MeasureExs+evalMeasures' s bindings solver config meas tcv init_meas e = do+ MaxSize max_meas <- maxSynthFormSizeM+ let m_sts = evalMeasures'' (fromInteger max_meas) s bindings meas tcv e++ foldM (\meas_exs (ns, e_in, s_meas) -> do+ case HM.lookup ns =<< HM.lookup e_in meas_exs of+ Just _ -> return meas_exs+ Nothing -> do+ (er, _) <- liftIO $ genericG2Call config solver s_meas bindings+ case er of+ [er'] -> + let + e_out = conc_out er'+ in+ return $ HM.insertWith HM.union e_in (HM.singleton ns e_out) meas_exs+ [] -> return $ HM.insertWith HM.union e_in (HM.singleton ns (Prim Undefined TyBottom)) meas_exs+ _ -> error "evalMeasures': Bad G2 Call") init_meas m_sts++evalMeasures'' :: Int -> State t -> Bindings -> Measures -> TCValues -> Expr -> [([Name], Expr, State t)]+evalMeasures'' mx_meas s b m tcv e =+ let+ meas_comps = formMeasureComps mx_meas (type_env s) (typeOf e) m++ rel_m = mapMaybe (\ns_me ->+ case chainReturnType (typeOf e) (map snd ns_me) of+ Just (_, vms) -> Just (ns_me, vms)+ Nothing -> Nothing) meas_comps+ in+ map (\(ns_es, bound) ->+ let+ is = map (\(n, me) -> Id n (typeOf me)) ns_es+ str_call = evalMeasuresCE s b tcv is e bound+ in+ (map fst ns_es, e, s { curr_expr = CurrExpr Evaluate str_call })+ ) rel_m++-- Form all possible measure compositions, up to the maximal length+formMeasureComps :: MaxMeasures -- ^ max length+ -> TypeEnv+ -> Type -- ^ Type of input value to the measures+ -> Measures+ -> [[(Name, Expr)]]+formMeasureComps !mx tenv in_t meas =+ let+ meas' = E.toExprList $ E.filter (isTotal tenv) meas+ in+ formMeasureComps' mx in_t (map (:[]) meas') meas'++formMeasureComps' :: MaxMeasures -- ^ max length+ -> Type -- ^ Type of input value to the measures+ -> [[(Name, Expr)]]+ -> [(Name, Expr)]+ -> [[(Name, Expr)]]+formMeasureComps' !mx in_t existing ns_me+ | mx <= 1 = existing+ | otherwise =+ let + r = [ ne1:ne2 | ne1@(_, e1) <- ns_me+ , ne2 <- existing+ , case (filter notLH $ anonArgumentTypes e1, fmap fst . chainReturnType in_t $ map snd ne2) of+ ([at], Just t) -> PresType t .:: at+ _ -> False ]+ in+ formMeasureComps' (mx - 1) in_t (r ++ existing) ns_me++chainReturnType :: Type -> [Expr] -> Maybe (Type, [M.Map Name Type])+chainReturnType t ne =+ foldM (\(t', vms) et -> + case filter notLH . anonArgumentTypes $ PresType et of+ [at]+ | Just vm <- t' `specializes` at -> Just (applyTypeMap vm . returnType $ PresType et, vm:vms)+ _ -> Nothing) (t, []) (map typeOf $ reverse ne)++notLH :: Type -> Bool+notLH ty+ | TyCon (Name n _ _ _) _ <- tyAppCenter ty = n /= "lh"+ | otherwise = True++evalMeasuresCE :: State t -> Bindings -> TCValues -> [Id] -> Expr -> [M.Map Name Type] -> Expr+evalMeasuresCE s bindings tcv is e bound =+ let+ meas_call = map (uncurry tyAppId) $ zip is bound+ ds = deepseq_walkers bindings++ call = foldr App e meas_call+ str_call = mkStrict_maybe ds call+ lh_dicts_call = maybe call (fillLHDictArgs ds) str_call+ in+ lh_dicts_call+ where+ tyAppId i b =+ let+ bound_names = map idName $ tyForAllBindings i+ bound_tys = map (\n -> case M.lookup n b of+ Just t -> t+ Nothing -> TyUnknown) bound_names+ lh_dcts = map (\t -> case lookupTCDict (type_classes s) (lhTC tcv) t of+ Just tc -> Var tc+ Nothing -> Prim Undefined TyBottom) bound_tys -- map (const $ Prim Undefined TyBottom) bound_tys+ in+ mkApp $ Var i:map Type bound_tys ++ lh_dcts++-------------------------------+-- Generic+-------------------------------+genericG2Call :: ( MonadIO m+ , ASTContainer t Expr+ , ASTContainer t Type+ , Named t+ , Solver solver) => Config -> solver -> State t -> Bindings -> m ([ExecRes t], Bindings)+genericG2Call config solver s bindings = do+ let simplifier = IdSimplifier+ share = sharing config++ fslb <- runG2WithSomes (SomeReducer (stdRed share retReplaceSymbFuncVar solver simplifier))+ (SomeHalter swhnfHalter)+ (SomeOrderer nextOrderer)+ solver simplifier PreserveAllMC s bindings++ return fslb++genericG2CallLogging :: ( MonadIO m+ , ASTContainer t Expr+ , ASTContainer t Type+ , Named t+ , Show t+ , Solver solver) =>+ Config+ -> solver+ -> State t+ -> Bindings+ -> String+ -> (SM.StateT PrettyGuide m) ([ExecRes t], Bindings)+genericG2CallLogging config solver s bindings lg = do+ let simplifier = IdSimplifier+ share = sharing config++ fslb <- runG2WithSomes (SomeReducer (prettyLogger lg ~> stdRed share retReplaceSymbFuncVar solver simplifier))+ (SomeHalter swhnfHalter)+ (SomeOrderer nextOrderer)+ solver simplifier PreserveAllMC s bindings++ return fslb
+ src/G2/Liquid/Inference/GeneratedSpecs.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module G2.Liquid.Inference.GeneratedSpecs ( GeneratedSpecs+ , emptyGS+ , namesGS++ , nullAssumeGS++ , unionDroppingGS+ + , insertAssumeGS+ , insertAssertGS+ , insertNewSpec+ , insertQualifier+ , switchAssumesToAsserts++ , lookupAssertGS++ , filterAssertsKey+ , filterOutSpecs+ , filterOutAssertSpecs++ , addSpecsToGhcInfos+ , addAssumedSpecsToGhcInfos+ , addQualifiersToGhcInfos+ + , deleteAssume+ , deleteAssert+ , deleteAllAssumes+ , deleteAllAsserts++ , allExprs++ , genSpec+ , insertMissingAssertSpec ) where++import qualified G2.Language as G2+import G2.Liquid.Helpers+import G2.Liquid.Types+import G2.Liquid.Inference.PolyRef++import Language.Haskell.Liquid.Constraint.Init+import Language.Haskell.Liquid.Types hiding+ (TargetInfo (..), TargetSrc (..), TargetSpec (..), GhcSpec (..), qualifiers)+import Language.Haskell.Liquid.Types.Fresh+import Language.Fixpoint.Types.Refinements+import Language.Haskell.Liquid.Types.RefType+import Language.Fixpoint.Types (Qualifier (..))++import qualified Control.Monad.State as S+import Data.List+import qualified Data.Text as T+import qualified Data.Map as M++#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+import GHC.Types.Name (nameOccName, occNameString)+import GHC.Types.Var as V+#else+import Name (nameOccName, occNameString)+import Var as V+#endif+++data GeneratedSpecs = GeneratedSpecs { assert_specs :: M.Map G2.Name [PolyBound Expr]+ , assume_specs :: M.Map G2.Name [PolyBound Expr]+ , qualifiers :: [Qualifier] } deriving (Eq, Show)++emptyGS :: GeneratedSpecs+emptyGS = GeneratedSpecs M.empty M.empty []++nullAssumeGS :: GeneratedSpecs -> Bool+nullAssumeGS = M.null . assume_specs++namesGS :: GeneratedSpecs -> [G2.Name]+namesGS = M.keys . assert_specs++insertAssumeGS :: G2.Name -> [PolyBound Expr] -> GeneratedSpecs -> GeneratedSpecs+insertAssumeGS n e gs =+ gs { assume_specs = M.insert (zeroOutUnq n) e (assume_specs gs) }++insertAssertGS :: G2.Name -> [PolyBound Expr] -> GeneratedSpecs -> GeneratedSpecs+insertAssertGS n e gs =+ gs { assert_specs = M.insert (zeroOutUnq n) e (assert_specs gs) }++insertQualifier :: Qualifier -> GeneratedSpecs -> GeneratedSpecs+insertQualifier qual gs@(GeneratedSpecs { qualifiers = quals }) =+ gs { qualifiers = qual:quals }++insertNewSpec :: G2.Name -> [PolyBound Expr] -> GeneratedSpecs -> GeneratedSpecs+insertNewSpec n new_spec =+ insertAssertGS n (pre new_spec) . insertAssumeGS n (post new_spec)+ where+ pre xs = init xs ++ [PolyBound PTrue []]+ post xs = replicate (length $ init xs) (PolyBound PTrue []) ++ [last xs]++switchAssumesToAsserts :: GeneratedSpecs -> GeneratedSpecs+switchAssumesToAsserts gs =+ gs { assert_specs =+ M.unionWith+ (zipWith+ (zipWithMaybePB (\s1 s2 -> PAnd [maybe PTrue id s1, maybe PTrue id s2]))+ )+ (assert_specs gs) (assume_specs gs)+ , assume_specs = M.empty }++-- | Merges two GeneratedSpecs, favoring constraints in the first generated specs+unionDroppingGS :: GeneratedSpecs -> GeneratedSpecs -> GeneratedSpecs+unionDroppingGS gs1 gs2 =+ GeneratedSpecs { assert_specs = M.union (assert_specs gs1) (assert_specs gs2)+ , assume_specs = M.union (assume_specs gs1) (assume_specs gs2)+ , qualifiers = qualifiers gs1 ++ qualifiers gs2}++lookupAssertGS :: G2.Name -> GeneratedSpecs -> Maybe [PolyBound Expr]+lookupAssertGS n = M.lookup (zeroOutUnq n) . assert_specs++filterOutSpecs :: [G2.Name] -> GeneratedSpecs -> GeneratedSpecs+filterOutSpecs ns gs =+ let+ ns' = map zeroOutUnq ns+ fil = M.filterWithKey (\n _ -> n `notElem` ns')+ in+ gs { assert_specs = fil $ assert_specs gs+ , assume_specs = fil $ assume_specs gs }++filterOutAssertSpecs :: [G2.Name] -> GeneratedSpecs -> GeneratedSpecs+filterOutAssertSpecs ns gs =+ let+ ns' = map zeroOutUnq ns+ fil = M.filterWithKey (\n _ -> n `notElem` ns')+ in+ gs { assert_specs = fil $ assert_specs gs }+++filterAssertsKey :: (G2.Name -> Bool) -> GeneratedSpecs -> GeneratedSpecs+filterAssertsKey p gs = gs { assert_specs = M.filterWithKey (\n _ -> p n) $ assert_specs gs}++deleteAssume :: G2.Name -> GeneratedSpecs -> GeneratedSpecs+deleteAssume n gs@(GeneratedSpecs { assume_specs = as }) =+ gs { assume_specs = M.delete (zeroOutUnq n) as }++deleteAssert :: G2.Name -> GeneratedSpecs -> GeneratedSpecs+deleteAssert n gs@(GeneratedSpecs { assert_specs = as }) =+ gs { assert_specs = M.delete (zeroOutUnq n) as }++deleteAllAssumes :: GeneratedSpecs -> GeneratedSpecs+deleteAllAssumes gs = gs { assume_specs = M.empty }++deleteAllAsserts :: GeneratedSpecs -> GeneratedSpecs+deleteAllAsserts gs = gs { assert_specs = M.empty }++modifyGsTySigs :: (Var -> SpecType -> SpecType) -> GhcInfo -> GhcInfo+modifyGsTySigs f ghci =+ let+ ty_sigs = getTySigs ghci+ ty_sigs' = map (\(v, lst) -> (v, fmap (f v) lst)) ty_sigs+ in+ putTySigs ghci ty_sigs'++modifyGsAsmSigs :: (Var -> SpecType -> SpecType) -> GhcInfo -> GhcInfo+modifyGsAsmSigs f ghci =+ let+ ty_sigs = getAssumedSigs ghci+ ty_sigs' = map (\(v, lst) -> (v, fmap (f v) lst)) ty_sigs+ in+ putAssumedSigs ghci ty_sigs'++addSpecsToGhcInfos :: [GhcInfo] -> GeneratedSpecs -> [GhcInfo]+addSpecsToGhcInfos ghci gs = addAssumedSpecsToGhcInfos (addAssertedSpecsToGhcInfos ghci gs) gs++addAssertedSpecsToGhcInfos :: [GhcInfo] -> GeneratedSpecs -> [GhcInfo]+addAssertedSpecsToGhcInfos ghcis = foldr (uncurry addAssertedSpecToGhcInfos) ghcis+ . filter (not . allEmptyPAnds . snd)+ . M.toList+ . assert_specs++addAssertedSpecToGhcInfos :: G2.Name -> [PolyBound Expr] -> [GhcInfo] -> [GhcInfo]+addAssertedSpecToGhcInfos v e = map (addAssertedSpecToGhcInfo v e) . insertMissingAssertSpec v++addAssertedSpecToGhcInfo :: G2.Name -> [PolyBound Expr] -> GhcInfo -> GhcInfo+addAssertedSpecToGhcInfo n e =+ modifyGsTySigs (\v st -> if varEqName v n then addToSpecType e st else st)++addAssumedSpecsToGhcInfos :: [GhcInfo] -> GeneratedSpecs -> [GhcInfo]+addAssumedSpecsToGhcInfos ghcis = foldr (uncurry addAssumedSpecToGhcInfos) ghcis . M.toList . assume_specs++addAssumedSpecToGhcInfos :: G2.Name -> [PolyBound Expr] -> [GhcInfo] -> [GhcInfo]+addAssumedSpecToGhcInfos v e = map (addAssumedSpecToGhcInfo v e) . insertMissingAssumeSpec v++addAssumedSpecToGhcInfo :: G2.Name -> [PolyBound Expr] -> GhcInfo -> GhcInfo+addAssumedSpecToGhcInfo n e =+ modifyGsAsmSigs (\v st -> if varEqName v n then addToSpecType e st else st)++addQualifiersToGhcInfos :: GeneratedSpecs -> [GhcInfo] -> [GhcInfo]+addQualifiersToGhcInfos gs = map (addQualifiersToGhcInfo gs)++addQualifiersToGhcInfo :: GeneratedSpecs -> GhcInfo -> GhcInfo+addQualifiersToGhcInfo gs ghci =+ let+ old_quals = getQualifiers ghci+ in+ putQualifiers ghci (old_quals ++ qualifiers gs)++addToSpecType :: [PolyBound Expr] -> SpecType -> SpecType+addToSpecType _ rvar@(RVar {}) = rvar+addToSpecType ees@(e@(PolyBound _ ps):es) rfun@(RFun { rt_in = i, rt_out = out })+ | isFunTy i = rfun { rt_in = addToSpecType ps i, rt_out = addToSpecType es out }+ | not (isRVar i) = rfun { rt_in = addToSpecType [e] i, rt_out = addToSpecType es out }+ | otherwise = rfun {rt_out = addToSpecType ees out }+addToSpecType es rall@(RAllT { rt_ty = out }) =+ rall { rt_ty = addToSpecType es out }+addToSpecType [PolyBound e ps]+ rapp@(RApp { rt_reft = u@(MkUReft { ur_reft = Reft (ur_s, ur_e) }), rt_args = ars }) =+ let+ rt_reft' = u { ur_reft = Reft (ur_s, PAnd [ur_e, e])}+ ars' = map (uncurry addToSpecType) $ zipSpecTypes (map (:[]) ps) ars+ in+ rapp { rt_reft = rt_reft', rt_args = ars' }+addToSpecType [] st = st+addToSpecType _ st = error $ "addToSpecType: Unhandled SpecType " ++ show st++zipSpecTypes :: [[PolyBound Expr]] -> [SpecType] -> [([PolyBound Expr], SpecType)]+zipSpecTypes [] [] = []+zipSpecTypes (epb:epbs) (rfun@(RFun {}):sts) =+ (epb, rfun):zipSpecTypes epbs sts+zipSpecTypes epbs (rvar@(RVar {}):sts) =+ ([PolyBound PTrue []], rvar):zipSpecTypes epbs sts+zipSpecTypes (epb:epbs) (st@(RApp {}):sts) = (epb, st):zipSpecTypes epbs sts+zipSpecTypes [] (st:sts) = ([PolyBound PTrue []], st):zipSpecTypes [] sts+zipSpecTypes es st = error $ "zipSpecTypes: Unhandled case\n" ++ show es ++ "\n" ++ show st++zeroOutUnq :: G2.Name -> G2.Name+zeroOutUnq (G2.Name n m _ l) = G2.Name n m 0 l++allEmptyPAnds :: [PolyBound Expr] -> Bool+allEmptyPAnds = all (allPB (\e -> case e of+ PAnd [] -> True+ _ -> False))++-- | If the given variable does not have a specification, create it in the appropriate place+insertMissingAssumeSpec :: G2.Name -> [GhcInfo] -> [GhcInfo]+insertMissingAssumeSpec (G2.Name n _ _ _) = map create + where+ create ghci =+ let+ def_vs = definedVars ghci+ has_spec = map fst $ getAssumedSigs ghci+ def_no_spec = filter (`notElem` has_spec) def_vs ++ def_v = find (\v -> (T.pack . occNameString . nameOccName $ varName v) == n) def_no_spec+ in+ case def_v of+ Just v ->+ let+ new_spec = dummyLoc $ genSpec' ghci v+ in+ insertAssumeSig v new_spec ghci+ Nothing -> ghci++insertAssumeSig :: Var -> LocSpecType -> GhcInfo -> GhcInfo+insertAssumeSig v lst ghci =+ let+ spc = getAssumedSigs ghci+ in+ putAssumedSigs ghci ((v, lst):spc)++insertMissingAssertSpec :: G2.Name -> [GhcInfo] -> [GhcInfo]+insertMissingAssertSpec (G2.Name n _ _ _) = map create+ where+ create ghci =+ let+ def_vs = definedVars ghci+ has_spec = map fst $ getTySigs ghci+ def_no_spec = filter (`notElem` has_spec) def_vs++ def_v = find (\v -> (T.pack . occNameString . nameOccName $ varName v) == n) def_no_spec+ in+ case def_v of+ Just v ->+ let+ new_spec = dummyLoc $ genSpec' ghci v+ in+ insertTySig v new_spec ghci+ Nothing -> ghci++insertTySig :: Var -> LocSpecType -> GhcInfo -> GhcInfo+insertTySig v lst ghci =+ let+ spc = getTySigs ghci+ in+ putTySigs ghci ((v, lst):spc)++allExprs :: GeneratedSpecs -> [Expr]+allExprs gs = concatMap extractValues . concat $ M.elems (assume_specs gs) ++ M.elems (assert_specs gs)++genSpec :: [GhcInfo] -> G2.Name -> Maybe SpecType+genSpec ghcis (G2.Name n _ _ _) = foldr mappend Nothing $ map gen ghcis+ where+ gen ghci =+ let+ def_vs = definedVars ghci+ def_v = find (\v -> (T.pack . occNameString . nameOccName $ varName v) == n) def_vs++ specs = getTySigs ghci+ in+ case def_v of+ Just v+ | Just (_, s) <- find ((==) v . fst) specs -> Just (val s)+ _ -> fmap (genSpec' ghci) def_v++genSpec' :: GhcInfo -> Var -> SpecType+genSpec' ghci v =+ S.evalState (refreshTy (ofType $ varType v)) $ initCGI (getConfig ghci) ghci++definedVars :: GhcInfo -> [Var]+#if MIN_VERSION_liquidhaskell(0,8,6)+definedVars = giDefVars . giSrc+#else+definedVars = defVars+#endif++
+ src/G2/Liquid/Inference/InfStack.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE LambdaCase #-}++module G2.Liquid.Inference.InfStack ( InfStack+ , runInfStack+ , execInfStack+ + , infLiftIO++ , incrMaxDepthI+ , incrMaxCExI+ , incrMaxTimeI+ , incrMaxSynthSizeI++ , extraMaxDepthI+ , extraMaxCExI+ , extraMaxTimeI+ , maxSynthCoeffSizeI+ , setMaxSynthCoeffSizeI++ , logEventStartM+ , logEventEndM+ , getLogM++ , startLevelTimer+ , endLevelTimer++ , withConfigs++ , Event (..)+ , mapEvent++ , Counters (..)+ , incrLoopCountLog+ , incrBackTrackLog+ , incrSearchBelowLog+ , incrNegatedModelLog ) where++import G2.Data.Timer+import G2.Language+import G2.Liquid.Inference.Config++import Control.Monad.Reader+import Control.Monad.State.Lazy as S++import qualified Data.HashSet as HS+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Data.Time.Clock++data Event n = CExSE+ | InfSE n+ | Verify+ | Synth+ | UpdateMeasures+ | UpdateEvals+ deriving (Eq, Read, Show)++mapEvent :: (a -> b) -> Event a -> Event b+mapEvent _ CExSE = CExSE+mapEvent f (InfSE n) = InfSE (f n)+mapEvent _ Verify = Verify+mapEvent _ Synth = Synth+mapEvent _ UpdateMeasures = UpdateMeasures+mapEvent _ UpdateEvals = UpdateEvals++data Counters = Counters { loop_count :: HM.HashMap (HS.HashSet Name) Int+ , backtracks :: Int+ , searched_below :: Int+ , negated_models :: Int }++type InfStack m = StateT (Timer (Event Name))+ (StateT (Timer (HS.HashSet Name))+ (StateT Counters (ReaderT Configs (StateT Progress m)))+ )++runInfStack :: MonadIO m => Configs -> Progress -> InfStack m a+ -> m (a, Timer (Event Name), Timer (HS.HashSet Name), Counters)+runInfStack configs prog m = do+ ev_timer <- liftIO $ newTimer+ lvl_timer <- liftIO $ newTimer+ (((a, ev_tm), lvl_tm), loops) <- runProgresser + (runConfigs + (runStateT + (runTimer (runTimer m ev_timer) lvl_timer) + newCounter+ ) configs+ ) prog+ return (a, ev_tm, lvl_tm, loops)++execInfStack :: MonadIO m => Configs -> Progress -> InfStack m a -> m a+execInfStack configs prog s = return . (\(x, _, _, _) -> x) =<< runInfStack configs prog s ++infLiftIO :: MonadIO m => IO a -> InfStack m a+infLiftIO = lift . lift . lift . liftIO++incrMaxDepthI :: Monad m => InfStack m ()+incrMaxDepthI = lift . lift . lift $ incrMaxDepthM++incrMaxCExI :: Monad m => (T.Text, Maybe T.Text) -> InfStack m ()+incrMaxCExI = lift . lift . lift . incrMaxCExM++incrMaxTimeI :: Monad m => (T.Text, Maybe T.Text) -> InfStack m ()+incrMaxTimeI = lift . lift . lift . incrMaxTimeM++extraMaxCExI :: Monad m => (T.Text, Maybe T.Text) -> InfStack m Int+extraMaxCExI n = lift . lift . lift $ gets (extraMaxCEx n)++extraMaxDepthI :: Monad m => InfStack m Int+extraMaxDepthI = lift . lift . lift $ gets extraMaxDepth++extraMaxTimeI :: Monad m => (T.Text, Maybe T.Text) -> InfStack m NominalDiffTime+extraMaxTimeI n = lift . lift . lift $ gets (extraMaxTime n)++incrMaxSynthSizeI :: Monad m => InfStack m ()+incrMaxSynthSizeI = do+ lift . lift . lift $ incrMaxSynthFormSizeM+ lift . lift . lift $ incrMaxSynthCoeffSizeM++maxSynthCoeffSizeI :: Monad m => InfStack m MaxSize+maxSynthCoeffSizeI = lift . lift . lift $ maxSynthCoeffSizeM++setMaxSynthCoeffSizeI :: Monad m => MaxSize -> InfStack m ()+setMaxSynthCoeffSizeI max_size = do+ lift . lift . lift $ setMaxSynthCoeffSizeM max_size++startLevelTimer :: MonadIO m => [Name] -> InfStack m () +startLevelTimer = lift . logEventStartM . HS.fromList++endLevelTimer :: MonadIO m => InfStack m ()+endLevelTimer = lift $ logEventEndM++-- Configurations++withConfigs :: Monad m =>+ (Configs -> Configs)+ -> InfStack m a+ -> InfStack m a+withConfigs f m = do+ mapStateT (mapStateT (mapStateT (withReaderT f))) m++-- Counters+newCounter :: Counters+newCounter = Counters { loop_count = HM.empty, backtracks = 0, searched_below = 0, negated_models = 0 }++incrLoopCountLog :: Monad m => [Name] -> InfStack m ()+incrLoopCountLog ns =+ let+ hs_ns = HS.fromList ns+ in+ lift . lift $ S.modify (\c@(Counters { loop_count = lcs }) ->+ c { loop_count = HM.alter (\case (Just i) -> Just (i + 1)+ Nothing -> Just 0) hs_ns lcs+ }+ )+incrBackTrackLog :: Monad m => InfStack m ()+incrBackTrackLog =+ lift . lift $ S.modify (\c@(Counters { backtracks = i }) -> c { backtracks = i + 1 })+++incrSearchBelowLog :: Monad m => InfStack m ()+incrSearchBelowLog =+ lift . lift $ S.modify (\c@(Counters { searched_below = i }) -> c { searched_below = i + 1 })++incrNegatedModelLog :: Monad m => InfStack m ()+incrNegatedModelLog =+ lift . lift $ S.modify (\c@(Counters { negated_models = i }) -> c { negated_models = i + 1 })+
+ src/G2/Liquid/Inference/Initalization.hs view
@@ -0,0 +1,63 @@+module G2.Liquid.Inference.Initalization ( initStateAndConfig+ , createStateForInference+ , getGHCI ) where++import G2.Config.Config as G2+import qualified G2.Initialization.Types as IT+import G2.Interface hiding (violated)+import G2.Language+import qualified G2.Language.ExprEnv as E+import G2.Translation++import G2.Liquid.AddTyVars+import G2.Liquid.Config+import G2.Liquid.Interface+import G2.Liquid.Types+import G2.Liquid.Inference.Config+import G2.Liquid.Inference.Verify++import Language.Haskell.Liquid.Types as LH hiding (measures)+import qualified Language.Fixpoint.Types.Config as FP++import qualified Data.Text as T++initStateAndConfig :: ExtractedG2 -> Maybe T.Text -> G2.Config -> LHConfig -> InferenceConfig -> [GhcInfo]+ -> (LiquidReadyState, G2.Config, LHConfig, InferenceConfig)+initStateAndConfig exg2 main_mod g2config lhconfig infconfig ghci = + let+ simp_s = initSimpleState exg2+ (g2config', lhconfig', infconfig') = adjustConfig main_mod simp_s g2config lhconfig infconfig ghci++ lrs = createStateForInference simp_s main_mod g2config' lhconfig' ghci++ lh_s = lr_state lrs+ lhconfig'' = adjustConfigPostLH main_mod (measures lh_s) (tcvalues lh_s) (state lh_s) ghci lhconfig'+ in+ (lrs, g2config', lhconfig'', infconfig')++createStateForInference :: SimpleState -> Maybe T.Text -> G2.Config -> LHConfig -> [GhcInfo] -> LiquidReadyState+createStateForInference simp_s main_mod config lhconfig ghci =+ let+ (simp_s', ph_tyvars) = if add_tyvars lhconfig+ then fmap Just $ addTyVarsEEnvTEnv simp_s+ else (simp_s, Nothing)+ (s, b) = initStateFromSimpleState simp_s' main_mod True + (\_ ng _ _ _ _ _ -> (Prim Undefined TyBottom, [], [], ng))+ (E.higherOrderExprs . IT.expr_env)+ config+ in+ createLiquidReadyState s b ghci ph_tyvars lhconfig++getGHCI :: InferenceConfig -> [FilePath] -> [FilePath] -> IO ([GhcInfo], LH.Config)+getGHCI infconfig proj fp = do+ lhconfig <- defLHConfig proj+ let lhconfig' = lhconfig { pruneUnsorted = True+ -- Block qualifiers being auto-generated by LH+ , maxParams = if keep_quals infconfig then maxParams lhconfig else 0+ , eliminate = if keep_quals infconfig then eliminate lhconfig else FP.All+ , higherorderqs = False+ , scrapeImports = False+ , scrapeInternals = False+ , scrapeUsedImports = False }+ ghci <- ghcInfos Nothing lhconfig' fp+ return (ghci, lhconfig)
+ src/G2/Liquid/Inference/Interface.hs view
@@ -0,0 +1,777 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module G2.Liquid.Inference.Interface ( inferenceCheck+ , inference+ , getInitState+ , getNameLevels ) where++import G2.Config.Config as G2+import G2.Data.Timer+import G2.Interface hiding (violated)+import G2.Language.CallGraph+import G2.Language.Expr+import qualified G2.Language.ExprEnv as E+import G2.Language.Naming+import G2.Language.Support+import G2.Language.Syntax+import G2.Language.Typing+import G2.Liquid.Config+import G2.Liquid.ConvertCurrExpr+import G2.Liquid.Helpers+import G2.Liquid.Inference.Config+import G2.Liquid.Inference.FuncConstraint as FC+import G2.Liquid.Inference.G2Calls+import G2.Liquid.Inference.InfStack+import G2.Liquid.Inference.Initalization+import G2.Liquid.Inference.PolyRef+import G2.Liquid.Inference.Sygus+import G2.Liquid.Inference.UnionPoly+import G2.Liquid.Inference.GeneratedSpecs+import G2.Liquid.Inference.Verify+import G2.Liquid.Interface+import G2.Liquid.Types hiding (state)+import qualified G2.Liquid.Types as T+import qualified G2.Liquid.Types as G2LH+import G2.Solver+import G2.Translation++import Language.Haskell.Liquid.Types as LH++import Control.Monad.IO.Class +import Control.Monad.Reader+import Data.Either+import qualified Data.HashSet as S+import qualified Data.HashMap.Lazy as HM+import Data.List+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.IO as T++-- Run inference, with an extra, final check of correctness at the end.+-- Assuming inference is working correctly, this check should neve fail.+inferenceCheck :: InferenceConfig -> G2.Config -> LHConfig -> [FilePath] -> [FilePath] -> IO (State [FuncCall], Either [CounterExample] GeneratedSpecs)+inferenceCheck infconfig config g2lhconfig proj fp = do+ (ghci, lhconfig) <- getGHCI infconfig proj fp+ (s, res, _, loops) <- inference' infconfig config g2lhconfig lhconfig ghci proj fp+ print $ loop_count loops+ print . sum . HM.elems $ loop_count loops+ print $ backtracks loops+ print $ searched_below loops+ print $ negated_models loops+ case res of+ Right gs -> do+ check_res <- checkGSCorrect infconfig lhconfig ghci gs+ case check_res of+ Safe -> return (s, res)+ _ -> error "inferenceCheck: Check failed"+ _ -> return (s, res)++inference :: InferenceConfig -> G2.Config -> LHConfig -> [FilePath] -> [FilePath] -> IO (State [FuncCall], Either [CounterExample] GeneratedSpecs)+inference infconfig config g2lhconfig proj fp = do+ -- Initialize LiquidHaskell+ (ghci, lhconfig) <- getGHCI infconfig proj fp+ (s, res, timer, _) <- inference' infconfig config g2lhconfig lhconfig ghci proj fp+ print . logToSecs . sumLog . getLog $ timer+ return (s, res)++inference' :: InferenceConfig+ -> G2.Config+ -> LHConfig+ -> LH.Config+ -> [GhcInfo]+ -> [FilePath]+ -> [FilePath]+ -> IO (State [FuncCall], Either [CounterExample] GeneratedSpecs, Timer (Event Name), Counters)+inference' infconfig config g2lhconfig lhconfig ghci proj fp = do+ mapM_ (print . getQualifiers) ghci++ (lrs, g2config', g2lhconfig', infconfig', main_mod) <- getInitState proj fp ghci infconfig config g2lhconfig+ let nls = getNameLevels main_mod lrs++ let ut = sharedTyConsEE (concat nls) (expr_env . G2LH.state . lr_state $ lrs)++ let configs = Configs { g2_config = g2config', g2lh_config = g2lhconfig', lh_config = lhconfig, inf_config = infconfig'}+ prog = newProgress++ SomeSMTSolver solver <- getSMT g2config'+ let infL = iterativeInference solver ghci main_mod lrs nls HM.empty emptyGS emptyFC ut++ (res, ev_timer, lvl_timer, loops) <- runInfStack configs prog infL -- runProgresser (runConfigs (runTimer infL timer) configs) prog++ print . logToSecs . orderLogBySpeed . sumLog . getLog $ lvl_timer++ print . logToSecs . orderLogBySpeed . sumLog . mapLabels (mapEvent nameOcc) . getLog $ ev_timer+ print . logToSecs . orderLogBySpeed . sumLog . mapLabels (mapEvent (const ())) . getLog $ ev_timer+ return (G2LH.state . lr_state $ lrs, res, ev_timer, loops)++getInitState :: [FilePath]+ -> [FilePath]+ -> [GhcInfo]+ -> InferenceConfig+ -> G2.Config+ -> LHConfig+ -> IO (LiquidReadyState, G2.Config, LHConfig, InferenceConfig, Maybe T.Text)+getInitState proj fp ghci infconfig config lhconfig = do+ let g2config = config { mode = Liquid+ , steps = 2000 }+ transConfig = simplTranslationConfig { simpl = False }+ (main_mod, exg2) <- translateLoaded proj fp transConfig g2config++ let (lrs, g2config', lhconfig', infconfig') = initStateAndConfig exg2 main_mod g2config lhconfig infconfig ghci+ return (lrs, g2config', lhconfig', infconfig', main_mod)++getNameLevels :: Maybe T.Text -> LiquidReadyState -> NameLevels+getNameLevels main_mod =+ filter (not . null)+ . map nub+ . nameLevels+ . getCallGraph+ . E.filterWithKey (\(Name _ m _ _) _ -> m == main_mod)+ . expr_env . G2LH.state . lr_state+++data InferenceRes = CEx [CounterExample]+ | Env GeneratedSpecs FuncConstraints MaxSizeConstraints MeasureExs+ | Raise MeasureExs FuncConstraints MaxSizeConstraints+ deriving (Show)++type NameLevels = [[Name]]++type MaxSizeConstraints = FuncConstraints++iterativeInference :: (MonadIO m, SMTConverter con)+ => con+ -> [GhcInfo]+ -> Maybe T.Text+ -> LiquidReadyState+ -> NameLevels+ -> MeasureExs+ -> GeneratedSpecs+ -> FuncConstraints+ -> UnionedTypes+ -> InfStack m (Either [CounterExample] GeneratedSpecs)+iterativeInference con ghci m_modname lrs nls meas_ex gs fc ut = do+ res <- inferenceL con FirstRound ghci m_modname lrs nls emptyEvals meas_ex gs fc emptyFC ut emptyBlockedModels+ case res of+ CEx cex -> return $ Left cex+ Env n_gs _ _ _ -> return $ Right n_gs+ Raise _ r_fc _ -> do+ incrMaxDepthI+ -- We might be missing some internal GHC types from our deep_seq walkers+ -- We filter them out to avoid an error+ let eenv = expr_env . G2LH.state $ lr_state lrs+ chck = filter (\n -> + case E.lookup n eenv of+ Just e -> isJust $ + mkStrict_maybe + (deepseq_walkers $ lr_binding lrs) + (Var (Id (Name "" Nothing 0 Nothing) (returnType e)))+ Nothing -> False) (head nls)+ liftIO . putStrLn $ "head nls = " ++ show (head nls)++ logEventStartM CExSE+ ref <- getCEx ghci m_modname lrs gs chck+ logEventEndM+ case ref of+ Left cex -> return $ Left cex+ Right fc' -> do+ logEventStartM UpdateMeasures+ logEventEndM+ incrMaxSynthSizeI+ r_meas_ex' <- lift . lift . lift $ updateMeasureExs {- r_meas_ex -} HM.empty lrs ghci {- fc' -} (unionFC fc' r_fc)+ iterativeInference con ghci m_modname lrs nls r_meas_ex' gs (unionFC fc' r_fc) ut+++inferenceL :: (MonadIO m, SMTConverter con)+ => con+ -> Iteration+ -> [GhcInfo]+ -> Maybe T.Text+ -> LiquidReadyState+ -> NameLevels+ -> Evals Bool+ -> MeasureExs+ -> GeneratedSpecs+ -> FuncConstraints+ -> MaxSizeConstraints+ -> UnionedTypes+ -> BlockedModels+ -> InfStack m InferenceRes+inferenceL con iter ghci m_modname lrs nls evals meas_ex senv fc max_fc ut blk_mdls = do+ let sf = case nls of+ (_:sf_:_) -> sf_+ ([_])-> []+ [] -> []++ startLevelTimer (case nls of fs_:_ -> fs_; [] -> [])+ (resAtL, evals') <- inferenceB con iter ghci m_modname lrs nls evals meas_ex senv fc max_fc ut blk_mdls+ endLevelTimer++ liftIO $ do+ putStrLn "-------"+ putStrLn $ "lengths = " ++ show (HM.map (length . nub) (blockedHashMap blk_mdls))+ putStrLn "-------"++ case resAtL of+ Env senv' n_fc n_mfc meas_ex' -> + case nls of+ [] -> return resAtL+ (_:nls') -> do+ liftIO $ putStrLn "Down a level!"+ let evals'' = foldr deleteEvalsForFunc evals' sf+ inf_res <- inferenceL con FirstRound ghci m_modname lrs nls' evals'' meas_ex' senv'+ (unionFC fc n_fc) (unionFC max_fc n_mfc) ut emptyBlockedModels+ case inf_res of+ Raise r_meas_ex r_fc r_max_fc -> do+ liftIO $ putStrLn "Up a level!"+ + inferenceL con AfterFirstRound ghci m_modname lrs nls evals' r_meas_ex senv r_fc r_max_fc ut blk_mdls+ _ -> return inf_res+ _ -> return resAtL++inferenceB :: (MonadIO m, SMTConverter con)+ => con+ -> Iteration+ -> [GhcInfo]+ -> Maybe T.Text+ -> LiquidReadyState+ -> NameLevels+ -> Evals Bool+ -> MeasureExs+ -> GeneratedSpecs+ -> FuncConstraints+ -> MaxSizeConstraints+ -> UnionedTypes+ -> BlockedModels+ -> InfStack m (InferenceRes, Evals Bool)+inferenceB con iter ghci m_modname lrs nls evals meas_ex gs fc max_fc ut blk_mdls = do+ let (fs, sf, below_sf) = case nls of+ (fs_:sf_:be) -> (fs_, sf_, be)+ ([fs_])-> (fs_, [], [])+ [] -> ([], [], [])++ incrLoopCountLog fs++ let curr_ghci = addSpecsToGhcInfos ghci gs+ logEventStartM UpdateEvals+ evals' <- updateEvals curr_ghci lrs fc evals+ logEventEndM+ logEventStartM Synth+ synth_gs <- lift . lift . lift $ synthesize con iter curr_ghci lrs evals' meas_ex (unionFC max_fc fc) ut blk_mdls (concat below_sf) sf+ logEventEndM++ liftIO $ do+ putStrLn "-------"+ putStrLn $ "lengths = " ++ show (HM.map (length . nub) (blockedHashMap blk_mdls))+ putStrLn "-------"++ case synth_gs of+ SynthEnv envN sz smt_mdl blk_mdls' -> do+ let gs' = unionDroppingGS gs envN+ ghci' = addSpecsToGhcInfos ghci gs'+ liftIO $ do+ putStrLn "inferenceB"+ putStrLn $ "fs = " ++ show fs+ putStrLn $ "init gs' = " ++ show gs'++ logEventStartM Verify+ res <- tryToVerify ghci'+ logEventEndM+ let res' = filterNamesTo fs res++ case res' of+ Safe -> return $ (Env gs' fc max_fc meas_ex, evals')+ Unsafe bad -> do+ inf_con <- infConfigM+ ref <- tryToGen (nub bad) ((emptyFC, emptyBlockedModels), emptyFC)+ (\(fc1, bm1) (fc2, bm2) -> (fc1 `unionFC` fc2, bm1 `unionBlockedModels` bm2))+ unionFC+ [ (\n -> do+ logEventStartM (InfSE n)+ return $ Right (Nothing, emptyFC))+ , refineUnsafe ghci m_modname lrs gs'+ , if use_level_dec inf_con then searchBelowLevel ghci m_modname lrs res sf gs' else genEmp+ , if use_negated_models inf_con then adjModel lrs sz smt_mdl else incrCExAndTime ]+ logEventEndM++ case ref of+ Left cex -> return $ (CEx cex, evals')+ Right ((viol_fc, new_blk_mdls), no_viol_fc) -> do+ let fc' = viol_fc `unionFC` no_viol_fc+ blk_mdls'' = blk_mdls' `unionBlockedModels` new_blk_mdls+ liftIO $ putStrLn "Before genMeasureExs"+ logEventStartM UpdateMeasures+ meas_ex' <- lift . lift . lift $ updateMeasureExs meas_ex lrs ghci fc'+ logEventEndM+ liftIO $ putStrLn "After genMeasureExs"++ inferenceB con AfterFirstRound ghci m_modname lrs nls evals' meas_ex' gs (unionFC fc fc') max_fc ut blk_mdls''++ Crash e1 e2 -> error $ "inferenceB: LiquidHaskell crashed" ++ "\n" ++ show e1 ++ "\n" ++ e2+ SynthFail sf_fc -> do+ liftIO . T.putStrLn $ "synthfail fc = " <> (printFCs lrs sf_fc)+ incrBackTrackLog+ return $ (Raise meas_ex fc (unionFC max_fc sf_fc), evals')++tryToGen :: Monad m =>+ [n] -- ^ A list of values to produce results for+ -> (r, ex) -- ^ A default result, in case none of the strategies work, or we are passed an empty [n]+ -> (r -> r -> r) -- ^ Some way of combining results+ -> (ex -> ex -> ex) -- ^ Some way of joining extra results+ -> [n -> m (Either err (Maybe r, ex))] -- ^ A list of strategies, in order, to try and produce a result+ -> m () -- ^ A monadic action to run after each n is processed+ -> m (Either err (r, ex))+tryToGen [] def _ _ _ _= return $ Right def+tryToGen (n:ns) def join_r join_ex fs final_m = do+ gen1 <- tryToGen' n def join_ex fs+ final_m+ case gen1 of+ Left err -> return $ Left err+ Right (r1, ex1) -> do+ gen2 <- tryToGen ns def join_r join_ex fs final_m+ case gen2 of+ Left err -> return $ Left err+ Right (r2, ex2) -> return $ Right (r1 `join_r` r2, ex1 `join_ex` ex2) ++tryToGen' :: Monad m =>+ n+ -> (r, ex)+ -> (ex -> ex -> ex)+ -> [n -> m (Either err (Maybe r, ex))]+ -> m (Either err (r, ex))+tryToGen' _ def _ [] = return $ Right (def)+tryToGen' n def join_ex (f:fs) = do+ gen1 <- f n+ case gen1 of+ Left err -> return $ Left err+ Right (Just r, ex) -> return $ Right (r, ex)+ Right (Nothing, ex1) -> do+ gen2 <- tryToGen' n def join_ex fs+ case gen2 of+ Left err -> return $ Left err+ Right (r, ex2) -> return $ Right (r, ex1 `join_ex` ex2)++genEmp :: Monad m => Name -> InfStack m (Either [CounterExample] (Maybe a, FuncConstraints))+genEmp _ = return $ Right (Nothing, emptyFC)++refineUnsafeAll :: MonadIO m => + [GhcInfo]+ -> Maybe T.Text+ -> LiquidReadyState+ -> GeneratedSpecs+ -> [Name]+ -> InfStack m (Either [CounterExample] (Maybe FuncConstraints, FuncConstraints))+refineUnsafeAll ghci m_modname lrs gs bad = do+ res <- mapM (refineUnsafe ghci m_modname lrs gs) (nub bad)++ case fmap unzip $ partitionEithers res of+ (cex@(_:_), _) -> return . Left $ concat cex+ ([], (new_fcs, no_viol_fcs)) -> + let+ new_fcs' = unionsFC . map fst $ catMaybes new_fcs+ in+ return . Right $ (if nullFC new_fcs' then Nothing else Just new_fcs', unionsFC no_viol_fcs)++refineUnsafe :: MonadIO m => + [GhcInfo]+ -> Maybe T.Text+ -> LiquidReadyState+ -> GeneratedSpecs+ -> Name+ -> InfStack m (Either [CounterExample] (Maybe (FuncConstraints, BlockedModels), FuncConstraints))+refineUnsafe ghci m_modname lrs gs bad = do+ let merged_se_ghci = addSpecsToGhcInfos ghci gs++ (res, no_viol) <- genNewConstraints merged_se_ghci m_modname lrs (nameOcc bad)++ liftIO $ do+ putStrLn $ "--- Generated Counterexamples and Constraints for " ++ show bad ++ " ---"+ putStrLn "res = "+ printCE (T.state $ lr_state lrs) res++ let res' = filter (not . hasAbstractedArgError) res++ -- Either converts counterexamples to FuncConstraints, or returns them as errors to+ -- show to the user.+ new_fc <- checkNewConstraints ghci lrs res'++ case new_fc of+ Left cex -> return $ Left cex+ Right new_fc' -> do+ liftIO . T.putStrLn $ "new_fc' = " <> printFCs lrs new_fc'+ return $ Right (if nullFC new_fc'+ then Nothing+ else Just (new_fc', emptyBlockedModels), fromListFC no_viol)++searchBelowLevel :: MonadIO m =>+ [GhcInfo]+ -> Maybe T.Text+ -> LiquidReadyState+ -> VerifyResult Name+ -> [Name]+ -> GeneratedSpecs+ -> Name+ -> InfStack m (Either [CounterExample] (Maybe (FuncConstraints, BlockedModels), FuncConstraints))+searchBelowLevel ghci m_modname lrs verify_res lev_below gs bad = do+ incrSearchBelowLog+ let called_by_res = calledByFunc lrs bad+ case filterNamesTo called_by_res $ filterNamesTo lev_below verify_res of+ Unsafe bad_sf -> do+ liftIO $ putStrLn "About to run second run of CEx generation"+ ref_sf <- withConfigs (limitedCounterfactual $ namesGS gs) $ refineUnsafeAll ghci m_modname lrs gs bad_sf+ case ref_sf of+ Left cex -> return $ Left cex+ Right (viol_fc_sf, no_viol_fc_sf) ->+ return $ Right (fmap (, emptyBlockedModels) viol_fc_sf, no_viol_fc_sf)+ Safe -> return $ Right (Nothing, emptyFC)+ Crash _ _ -> error "inferenceB: LiquidHaskell crashed"++adjModel :: MonadIO m => + LiquidReadyState+ -> Size+ -> SMTModel+ -> Name+ -> InfStack m (Either a (Maybe (FuncConstraints, BlockedModels), FuncConstraints))+adjModel lrs sz smt_mdl n = do+ incrNegatedModelLog+ liftIO $ putStrLn "adjModel repeated_fc"+ let clls = calledByFunc lrs n+ blk_mdls' = insertBlockedModel sz (MNOnly (n:clls)) smt_mdl emptyBlockedModels++ liftIO . putStrLn $ "blocked models = " ++ show blk_mdls'++ _ <- incrCExAndTime n+ return . Right $ (Just (emptyFC, blk_mdls'), emptyFC)++incrCExAndTime :: Monad m => Name -> InfStack m (Either a (Maybe b, FuncConstraints))+incrCExAndTime (Name n m _ _) = do+ incrMaxCExI (n, m)+ incrMaxTimeI (n, m)+ return $ Right (Nothing, emptyFC) ++calledByFunc :: LiquidReadyState -> Name -> [Name]+calledByFunc lrs n = + let+ eenv = expr_env . G2LH.state $ lr_state lrs+ in+ map zeroOutUnq+ . filter (isJust . flip E.lookup eenv)+ . maybe [] id+ . fmap varNames+ . fmap snd+ $ E.lookupNameMod (nameOcc n) (nameModule n) eenv++filterNamesTo :: [Name] -> VerifyResult Name -> VerifyResult Name+filterNamesTo ns (Unsafe unsafe) = + case filter (\n -> toOccMod n `elem` ns_nm) unsafe of+ [] -> Safe+ unsafe' -> do+ Unsafe unsafe'+ where+ ns_nm = map toOccMod ns+ toOccMod (Name n m _ _) = (n, m)+filterNamesTo _ vr = vr++limitedCounterfactual :: [Name] -> Configs -> Configs+limitedCounterfactual ns cfgs@(Configs { g2lh_config = g2lh_c }) =+ cfgs { g2lh_config = g2lh_c { counterfactual = Counterfactual+ . CFOnly+ . S.fromList+ $ map (\(Name n m _ _) -> (n, m)) ns } }++genNewConstraints :: MonadIO m => + [GhcInfo]+ -> Maybe T.Text+ -> LiquidReadyState+ -> T.Text+ -> InfStack m ([CounterExample], [FuncConstraint])+genNewConstraints ghci m lrs n = do+ liftIO . putStrLn $ "Generating constraints for " ++ T.unpack n+ infconfig <- infConfigM++ ((exec_res, _), i) <- runLHInferenceCore n m lrs ghci+ let (exec_res', no_viol) = partition (true_assert . final_state) exec_res+ + allCCons = noAbsStatesToCons i $ exec_res' ++ if use_extra_fcs infconfig then no_viol else []+ return $ (filter (not . hasPreArgError) $ map lhStateToCE exec_res', allCCons)++getCEx :: MonadIO m =>+ [GhcInfo]+ -> Maybe T.Text+ -> LiquidReadyState+ -> GeneratedSpecs+ -> [Name]+ -> InfStack m (Either [CounterExample] FuncConstraints)+getCEx ghci m_modname lrs gs bad = do+ let merged_se_ghci = addSpecsToGhcInfos ghci gs++ liftIO $ mapM_ (print . getTySigs) merged_se_ghci++ let bad' = nub $ map nameOcc bad++ res <- mapM (checkForCEx merged_se_ghci m_modname lrs) bad'++ liftIO $ do+ putStrLn $ "getCEx res = "+ printCE (T.state $ lr_state lrs) $ concat res++ let res' = concat res++ -- Either converts counterexamples to FuncConstraints, or returns them as errors to+ -- show to the user.+ new_fc <- checkNewConstraints ghci lrs res'++ case new_fc of+ Left cex -> return $ Left cex+ Right new_fc' -> do+ liftIO . T.putStrLn $ "new_fc' = " <> printFCs lrs new_fc'+ return $ Right new_fc'++checkForCEx :: MonadIO m =>+ [GhcInfo]+ -> Maybe T.Text+ -> LiquidReadyState+ -> T.Text+ -> InfStack m [CounterExample]+checkForCEx ghci m lrs n = do+ liftIO . putStrLn $ "Checking CEx for " ++ T.unpack n+ ((exec_res, _), _) <- runLHCExSearch n m lrs ghci+ let exec_res' = filter (true_assert . final_state) exec_res+ return $ map lhStateToCE exec_res'++checkNewConstraints :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> [CounterExample] -> m (Either [CounterExample] FuncConstraints)+checkNewConstraints ghci lrs cexs = do+ infconfig <- infConfigM+ res <- mapM (cexsToBlockingFC lrs ghci) cexs+ res2 <- return . concat =<< mapM cexsToExtraFC cexs+ case lefts res of+ res'@(_:_) -> return . Left $ res'+ _ -> return . Right . unionsFC . map fromSingletonFC $ (rights res) ++ if use_extra_fcs infconfig then res2 else []++updateMeasureExs :: (InfConfigM m, ProgresserM m, MonadIO m) => MeasureExs -> LiquidReadyState -> [GhcInfo] -> FuncConstraints -> m MeasureExs+updateMeasureExs meas_ex lrs ghci fcs =+ let+ es = concatMap (\fc ->+ let+ clls = concatMap (\(mfc, hfc) -> mfc:hfc) $ allCalls fc+ vls = concatMap (\c -> returns c:arguments c) clls + ex_poly = concat . concatMap extractValues . concatMap extractExprPolyBound $ vls+ in+ vls ++ ex_poly+ ) (toListFC fcs)+ in+ evalMeasures meas_ex lrs ghci es++synthesize :: (InfConfigM m, ProgresserM m, MonadIO m, SMTConverter con)+ => con -> Iteration -> [GhcInfo] -> LiquidReadyState -> Evals Bool -> MeasureExs+ -> FuncConstraints -> UnionedTypes -> BlockedModels -> [Name] -> [Name] -> m SynthRes+synthesize con iter ghci lrs evals meas_ex fc ut blk_mdls to_be for_funcs = do+ liaSynth con iter ghci lrs evals meas_ex fc ut blk_mdls to_be for_funcs++updateEvals :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> FuncConstraints -> Evals Bool -> m (Evals Bool)+updateEvals ghci lrs fc evals = do+ let cs = allCallsFC fc++ liftIO $ putStrLn "Before check func calls"+ evals' <- preEvals evals lrs ghci cs+ liftIO $ putStrLn "After pre"+ evals'' <- postEvals evals' lrs ghci cs+ liftIO $ putStrLn "After check func calls"++ return evals''++-- | Converts counterexamples into constraints that block the current specification set+cexsToBlockingFC :: (InfConfigM m, MonadIO m) => LiquidReadyState -> [GhcInfo] -> CounterExample -> m (Either CounterExample FuncConstraint)+cexsToBlockingFC _ _ (DirectCounter dfc fcs@(_:_) higher)+ | (_:_, _) <- partition (hasArgError . abstract) fcs = undefined+ | isError (returns (abstract dfc)) = do+ infconfig <- infConfigM+ let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs++ let rhs = OrFC $ map (\(Abstracted { abstract = fc }) -> + ImpliesFC (Call Pre fc higher) (NotFC (Call Post fc higher))) fcs'++ return . Right $ ImpliesFC (Call Pre (abstract dfc) higher) rhs+ | otherwise = do+ infconfig <- infConfigM+ let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs++ let lhs = AndFC [Call Pre (abstract dfc) higher, NotFC (Call Post (abstract dfc) higher)]+ rhs = OrFC $ map (\(Abstracted { abstract = fc }) -> + ImpliesFC (Call Pre fc higher) (NotFC (Call Post fc higher))) fcs'++ if not . null $ fcs'+ then return . Right $ ImpliesFC lhs rhs+ else error "cexsToBlockingFC: Unhandled"+cexsToBlockingFC _ _ (CallsCounter dfc cfc fcs@(_:_) higher)+ | (_:_, _) <- partition (hasArgError . abstract) fcs = undefined+ | isError (returns (abstract cfc)) = do+ infconfig <- infConfigM+ let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs++ let lhs = Call Pre (abstract dfc) higher+ rhs = OrFC $ map (\(Abstracted { abstract = fc }) -> + ImpliesFC (Call Pre fc higher) (NotFC (Call Post fc higher))) fcs'++ if not . null $ fcs' + then return . Right $ ImpliesFC lhs rhs+ else error "cexsToBlockingFC: Should be unreachable! Non-refinable function abstracted!" ++ | otherwise = do+ infconfig <- infConfigM+ let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs++ let lhs = AndFC [Call Pre (abstract dfc) higher, NotFC (Call Pre (abstract cfc) higher)]+ rhs = OrFC $ map (\(Abstracted { abstract = fc }) -> + ImpliesFC (Call Pre fc higher) (NotFC (Call Post fc higher))) fcs'++ if not . null $ fcs' + then return . Right $ ImpliesFC lhs rhs+ else error "cexsToBlockingFC: Should be unreachable! Non-refinable function abstracted!" +cexsToBlockingFC lrs ghci cex@(DirectCounter dfc [] higher)+ | isError (returns (real dfc)) = do+ if isExported lrs (funcName (real dfc))+ then return . Left $ cex+ else return . Right . NotFC $ Call Pre (real dfc) higher+ | isExported lrs (funcName (real dfc)) = do+ post_ref <- checkPost ghci lrs (real dfc) higher+ case post_ref of+ True -> return $ Right (Call All (real dfc) higher)+ False -> return . Left $ cex+ | otherwise = return $ Right (Call All (real dfc) higher)+cexsToBlockingFC lrs ghci cex@(CallsCounter dfc cfc [] higher)+ | any isError (arguments (abstract cfc)) = do+ if+ | isExported lrs (funcName (real dfc))+ , isExported lrs (funcName (real cfc)) -> do+ called_pr <- checkPre ghci lrs (real cfc) higher -- TODO: Shouldn't be changing this?+ case called_pr of+ True -> return . Right $ NotFC (Call Pre (real dfc) higher)+ False -> return . Left $ cex+ | isExported lrs (funcName (real dfc)) -> do+ called_pr <- checkPre ghci lrs (real cfc) higher+ case called_pr of+ True -> return . Right $ NotFC (Call Pre (real dfc) higher)+ False -> return . Left $ cex+ | otherwise -> return . Right $ NotFC (Call Pre (real dfc) higher)+ | otherwise = do+ if+ | isExported lrs (funcName (real dfc))+ , isExported lrs (funcName (real cfc)) -> do+ called_pr <- checkPre ghci lrs (real cfc) higher -- TODO: Shouldn't be changing this?+ case called_pr of+ True -> return . Right $ ImpliesFC (Call Pre (real dfc) higher) (Call Pre (real cfc) higher)+ False -> return . Left $ cex+ | isExported lrs (funcName (real dfc)) -> do+ called_pr <- checkPre ghci lrs (real cfc) higher+ case called_pr of+ True -> return . Right $ ImpliesFC (Call Pre (real dfc) higher) (Call Pre (real cfc) higher)+ False -> return . Left $ cex+ | otherwise -> do+ return . Right $ ImpliesFC (Call Pre (real dfc) higher) (Call Pre (real cfc) higher)++-- Function constraints that don't block the current specification set, but which must be true+-- (i.e. the actual input and output for abstracted functions)+cexsToExtraFC :: InfConfigM m => CounterExample -> m [FuncConstraint]+cexsToExtraFC (DirectCounter dfc fcs@(_:_) higher) = do+ infconfig <- infConfigM+ let some_pre = ImpliesFC (Call Pre (real dfc) higher) $ OrFC (map (\fc -> Call Pre (real fc) higher) fcs)+ fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs+ return $ some_pre:mapMaybe (realToMaybeFC higher) fcs'+cexsToExtraFC (CallsCounter dfc cfc fcs@(_:_) higher) = do+ infconfig <- infConfigM+ let some_pre = ImpliesFC (Call Pre (real dfc) higher) $ OrFC (map (\fc -> Call Pre (real fc) higher) fcs)+ let fcs' = filter (\fc -> abstractedMod fc `S.member` modules infconfig) fcs++ let pre_real = maybeToList $ (realToMaybeFC higher) cfc+ as = mapMaybe (realToMaybeFC higher) fcs'+ clls = if not . isError . returns . real $ cfc+ then [Call All (real cfc) higher]+ else []++ return $ some_pre:clls ++ pre_real ++ as+cexsToExtraFC (DirectCounter _ [] _) = return []+cexsToExtraFC (CallsCounter dfc cfc [] higher)+ | isError (returns (real dfc)) = return []+ | isError (returns (real cfc)) = return []+ | any isError (arguments (real cfc)) = return []+ | otherwise =+ let+ call_all_dfc = Call All (real dfc) higher+ call_all_cfc = Call All (real cfc) higher+ imp_fc = ImpliesFC (Call Pre (real dfc) higher) (Call Pre (real cfc) higher)+ in+ return $ [call_all_dfc, call_all_cfc, imp_fc]++noAbsStatesToCons :: Id -> [ExecRes AbstractedInfo] -> [FuncConstraint]+noAbsStatesToCons i = concatMap (noAbsStatesToCons' i) -- . filter (null . abs_calls . track . final_state)++noAbsStatesToCons' :: Id -> ExecRes AbstractedInfo -> [FuncConstraint]+noAbsStatesToCons' i@(Id (Name _ m _ _) _) er =+ let+ higher_calls = erHigherOrder er++ pre_s = lhStateToPreFC i er+ clls = filter (\fc -> nameModule (funcName fc) == m) + . map (switchName (idName i))+ . filter (not . hasArgError)+ . func_calls_in_real+ . init_call+ . track+ $ final_state er++ preCons = map (ImpliesFC pre_s . flip (Call Pre) higher_calls) clls+ -- A function may return error because it was passed an erroring higher order function.+ -- In this case, it would be incorrect to add a constraint that the function itself calls error.+ -- Thus, we simply get rid of constraints that call error. + callsCons = mapMaybe (\fc -> case isError (returns fc) of+ True -> Nothing -- NotFC (Call Pre fc)+ False -> Just (Call All fc higher_calls)) clls+ callsCons' = if hits_lib_err_in_real (init_call . track . final_state $ er)+ then []+ else callsCons+ in+ preCons ++ callsCons'++switchName :: Name -> FuncCall -> FuncCall+switchName n fc = if funcName fc == initiallyCalledFuncName then fc { funcName = n } else fc++--------------------------------------------------------------------++realToMaybeFC :: [HigherOrderFuncCall] -> Abstracted -> Maybe FuncConstraint+realToMaybeFC higher a@(Abstracted { real = fc }) + | hits_lib_err_in_real a = Nothing+ | isError (returns fc) = Just $ NotFC (Call Pre fc higher)+ | otherwise = Just $ ImpliesFC (Call Pre fc higher) (Call Post fc higher)++isExported :: LiquidReadyState -> Name -> Bool+isExported lrs (Name n m _ _) =+ (n, m) `elem` map (\(Name n' m' _ _) -> (n', m')) (exported_funcs (lr_binding lrs))++lhStateToPreFC :: Id -> ExecRes AbstractedInfo -> FuncConstraint+lhStateToPreFC i er@(ExecRes { conc_args = inArg+ , conc_out = ex}) = Call Pre (FuncCall (idName i) inArg ex) (erHigherOrder er)++abstractedMod :: Abstracted -> Maybe T.Text+abstractedMod = nameModule . funcName . abstract++hasPreArgError :: CounterExample -> Bool+hasPreArgError (DirectCounter _ _ _) = False+hasPreArgError (CallsCounter _ calls_f _ _) = hasArgError $ real calls_f++hasAbstractedArgError :: CounterExample -> Bool+hasAbstractedArgError (DirectCounter _ as _) = any (hasArgError . real) as+hasAbstractedArgError (CallsCounter _ _ as _) = any (hasArgError . real) as++hasArgError :: FuncCall -> Bool+hasArgError = any isError . arguments++isError :: Expr -> Bool+isError (Prim Error _) = True+isError (Prim Undefined _) = True+isError _ = False++erHigherOrder :: ExecRes AbstractedInfo -> [HigherOrderFuncCall]+erHigherOrder = ai_higher_order_calls . track . final_state
+ src/G2/Liquid/Inference/PolyRef.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable#-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}++module G2.Liquid.Inference.PolyRef ( PolyBound (.. )+ , RefNamePolyBound+ , ExprPolyBound+ , extractExprPolyBoundWithRoot+ , extractExprPolyBound+ , extractTypePolyBound+ , extractTypeAppAndFuncPolyBound++ , headValue+ , removeHead+ , extractValues+ , uniqueIds+ , mapPB+ , filterPB+ , allPB+ , zipPB+ , zipWithPB+ , zipWithMaybePB+ , zip3PB) where++import G2.Language++import qualified Data.HashMap.Lazy as HM+import Data.List+import Data.Maybe++type RefNamePolyBound = PolyBound String+type ExprPolyBound = PolyBound [Expr]++type TypePolyBound = PolyBound Type++-- | The subexpressions of an expression corresponding to the polymorphic+-- arguments. If a polymorphic argument is instantiated with a polymorphic+-- type, these are nested recursively.+data PolyBound v = PolyBound v [PolyBound v] deriving (Eq, Read, Show, Functor, Foldable, Traversable)++-------------------------------+-- ExprPolyBound+-------------------------------++extractExprPolyBoundWithRoot :: Expr -> ExprPolyBound+extractExprPolyBoundWithRoot e = PolyBound [e] $ extractExprPolyBound e++extractExprPolyBound :: Expr -> [ExprPolyBound]+extractExprPolyBound e+ | Data dc:_ <- unApp e =+ let+ bound = leadingTyForAllBindings dc+ m = extractExprPolyBound' e++ bound_es = map (\i -> HM.lookupDefault [] i m) bound+ in+ map (\es -> PolyBound es (mergeExprPolyBound . transpose $ map extractExprPolyBound es)) bound_es+ | otherwise = []++mergeExprPolyBound :: [[ExprPolyBound]] -> [ExprPolyBound]+mergeExprPolyBound = mapMaybe (\pb -> case pb of+ (p:pbb) -> Just $ foldr mergeExprPolyBound' p pbb+ [] -> Nothing)++mergeExprPolyBound' :: ExprPolyBound -> ExprPolyBound -> ExprPolyBound+mergeExprPolyBound' (PolyBound es1 pb1) (PolyBound es2 pb2) =+ PolyBound (es1 ++ es2) (map (uncurry mergeExprPolyBound') $ zip pb1 pb2)++extractExprPolyBound' :: Expr -> HM.HashMap Id [Expr]+extractExprPolyBound' e+ | Data dc:es <- unApp e =+ let+ es' = filter (not . isType) es++ argtys = argumentTypes . PresType . inTyForAlls $ typeOf dc++ argtys_es = zip argtys es'++ (direct, indirect) = partition fstIsTyVar argtys_es+ direct' = mapMaybe fstMapTyVar direct+ indirect' = map (uncurry substTypes) indirect++ direct_hm = foldr (HM.unionWith (++)) HM.empty+ $ map (\(i, e_) -> uncurry HM.singleton (i, e_:[])) direct'+ in+ foldr (HM.unionWith (++)) direct_hm $ map (extractExprPolyBound' . adjustIndirectTypes) indirect'+ | otherwise = HM.empty+ where+ isType (Type _) = True+ isType _ = False++ fstIsTyVar (TyVar _, _) = True+ fstIsTyVar _ = False++ fstMapTyVar (TyVar i, x) = Just (i, x)+ fstMapTyVar _ = Nothing++substTypes :: Type -> Expr -> Expr+substTypes t e+ | _:ts <- unTyApp t+ , e':es <- unApp e =+ mkApp $ e':substTypes' ts es+substTypes _ e = e++substTypes' :: [Type] -> [Expr] -> [Expr]+substTypes' (t:ts) (Type _:es) = Type t:substTypes' ts es+substTypes' _ es = es++adjustIndirectTypes :: Expr -> Expr+adjustIndirectTypes e+ | Data dc:es <- unApp e =+ let+ tyses = filter (isType) es+ tyses' = map (\(Type t) -> t) tyses++ bound = leadingTyForAllBindings dc+ bound_tyses = zip bound tyses'+ in+ mkApp $ Data (foldr (uncurry retype) dc $ bound_tyses):es+ | otherwise = e+ where+ isType (Type _) = True+ isType _ = False+++-------------------------------+-- TypePolyBound+-------------------------------++-- | Unrolls TyApp'ed args, while also keeping them in the base type+extractTypePolyBound :: Type -> TypePolyBound+extractTypePolyBound t =+ let+ (_:ts) = unTyApp t+ in+ PolyBound t $ map extractTypePolyBound ts++-- | Unrolls TyApp'ed and TyFunc'ed args, while also keeping them in the base type+extractTypeAppAndFuncPolyBound :: Type -> TypePolyBound+extractTypeAppAndFuncPolyBound t@(TyApp _ _) =+ let+ (_:ts) = unTyApp t+ in+ PolyBound t $ map extractTypePolyBound ts+extractTypeAppAndFuncPolyBound t@(TyFun _ _) =+ let+ ts = splitTyFuns t+ in+ PolyBound t $ map extractTypePolyBound ts+extractTypeAppAndFuncPolyBound t = PolyBound t []++-------------------------------+-- Generic PolyBound functions+-------------------------------++headValue :: PolyBound v -> v+headValue (PolyBound v _) = v++removeHead :: PolyBound v -> [PolyBound v]+removeHead (PolyBound _ vs) = vs++extractValues :: PolyBound v -> [v]+extractValues (PolyBound v ps) = v:concatMap extractValues ps++uniqueIds :: PolyBound v -> PolyBound Int+uniqueIds = snd . uniqueIds' 0 ++uniqueIds' :: Int -> PolyBound v -> (Int, PolyBound Int)+uniqueIds' n (PolyBound _ ps) =+ let+ (n', ps') = mapAccumR (uniqueIds') (n + 1) ps+ in+ (n', PolyBound n ps')++mapPB :: (a -> b) -> PolyBound a -> PolyBound b+mapPB f (PolyBound v ps) = PolyBound (f v) (map (mapPB f) ps)++filterPB :: (PolyBound a -> Bool) -> PolyBound a -> Maybe (PolyBound a)+filterPB p pb@(PolyBound v xs) =+ case p pb of+ True -> Just $ PolyBound v (mapMaybe (filterPB p) xs)+ False -> Nothing++allPB :: (a -> Bool) -> PolyBound a -> Bool+allPB p = all p . extractValues++zipPB :: PolyBound a -> PolyBound b -> PolyBound (a, b)+zipPB (PolyBound a pba) (PolyBound b pbb) = PolyBound (a, b) (zipWith zipPB pba pbb)++zipWithPB :: (a -> b -> c) -> PolyBound a -> PolyBound b -> PolyBound c+zipWithPB f (PolyBound a pba) (PolyBound b pbb) = PolyBound (f a b) (zipWith (zipWithPB f) pba pbb)++zipWithMaybePB :: (Maybe a -> Maybe b -> c) -> PolyBound a -> PolyBound b -> PolyBound c+zipWithMaybePB f pba pbb = zipWithMaybePB' f (mapPB Just pba) (mapPB Just pbb)++zipWithMaybePB' :: (Maybe a -> Maybe b -> c) -> PolyBound (Maybe a) -> PolyBound (Maybe b) -> PolyBound c+zipWithMaybePB' f (PolyBound a pba) (PolyBound b pbb) =+ let+ c = f a b++ rep_nt = repeat (PolyBound Nothing [])++ pbc = takeWhile (\(x, y) -> isJust (headValue x) || isJust (headValue y))+ $ zip (pba ++ rep_nt) (pbb ++ rep_nt)+ in+ PolyBound c $ map (uncurry (zipWithMaybePB' f)) pbc++zip3PB :: PolyBound a -> PolyBound b -> PolyBound c -> PolyBound (a, b, c)+zip3PB (PolyBound a pba) (PolyBound b pbb) (PolyBound c pbc) =+ PolyBound (a, b, c) (zipWith3 zip3PB pba pbb pbc)
+ src/G2/Liquid/Inference/QualifGen.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module G2.Liquid.Inference.QualifGen () where -- qualifGen) where++-- import G2.Language.Naming+-- import G2.Liquid.Inference.Sygus+-- import G2.Liquid.Helpers++-- import Sygus.LexSygus+-- import Sygus.ParseSygus+-- import Sygus.Print+-- import Sygus.Syntax++-- import Language.Fixpoint.Types.Constraints+-- import qualified Language.Fixpoint.Types.Names as LH+-- import Language.Fixpoint.Types.PrettyPrint++-- import qualified Data.HashMap.Lazy as HM+-- import Data.List+-- import qualified Data.Map as M+-- import Data.Maybe+-- import qualified Data.Text as T+-- import Data.Tuple++-- -- | Mocking measures to generate Qualifs.+-- data QMeasure = QMeasure { m_name :: String+-- , m_in :: Sort+-- , m_out :: Sort+-- , triv_out :: Term }++-- -- Mocking datatypes+-- data QDataType = QDataType { dt_smt_name :: String+-- , dt_name :: String+-- , dt_cons :: [String] }++-- data QualifConfig = QualifConfig { max_vars :: Int+-- , max_size :: Int+-- , datatypes :: [QDataType]+-- , measures :: [QMeasure] }++-- qualifGen :: FilePath -> IO ()+-- qualifGen qualif_fp = undefined -- do+{- let qc = QualifConfig + { max_vars = 3+ , max_size = 5+ , datatypes = [ QDataType { dt_smt_name = "List"+ , dt_name = "ListQualif.List a"+ , dt_cons = ["cons", "nil"] }+ , QDataType { dt_smt_name = "List_List"+ , dt_name = "ListQualif.List (ListQualif.List b)"+ , dt_cons = ["cons_cons", "nil_nil"] }]+ , measures =+ [ QMeasure { m_name = "size_m__0"+ , m_in = listSort+ , m_out = intSort+ , triv_out = trivOutGen (TermIdent (ISymb "cons"))+ (TermLit $ LitNum 0)+ (TermLit $ LitNum 2000)+ }+ , QMeasure { m_name = "sizeXs_m__0"+ , m_in = IdentSort (ISymb "List_List")+ , m_out = intSort+ , triv_out = trivOutGen (TermIdent (ISymb "cons_cons"))+ (TermLit $ LitNum 0)+ (TermLit $ LitNum 4000)+ }+ ]+ }++ cmds <- qualifCalls qc++ let printable_quals = map (cmdToQualifs (datatypes qc) (measures qc)) cmds+ + writeFile qualif_fp (intercalate "\n" printable_quals)++trivOutGen :: Term -> Term -> Term -> Term+trivOutGen v t1 t2 =+ TermCall (ISymb "ite") + [TermCall (ISymb "=") [TermIdent (ISymb "a"), v], t1, t2]++qualifCalls :: QualifConfig -> IO [Cmd]+qualifCalls (QualifConfig { max_vars = max_v+ , max_size = max_s+ , datatypes = dt+ , measures = meas }) = do++ let srtss = concatMap (flip combinations (possibleDTs dt)) [1..max_v]++ r <- mapM (\srts -> do+ let varN = map (\i -> "x" ++ show i) ([0..] :: [Int])+ svs = map (uncurry SortedVar) $ zip varN srts++ let call = qualifCalls' dt meas svs+ putStrLn . T.unpack $ printSygus call+ res <- runCVC4Stream max_s . T.unpack $ printSygus call++ case res of+ Left err -> error "qualifGen: Bad call to CVC4"+ Right res' -> do+ let p_res = parse . lexSygus $ res'+ all_used_res = filter defineFunAllUsed p_res++ return all_used_res+ ) srtss++ return $ concat r++combinations :: Int -> [a] -> [[a]]+combinations 0 _ = [[]]+combinations !n xs = [x:ys | x <- xs, ys <- combinations (n - 1) xs]++possibleDTs :: [QDataType] -> [Sort]+possibleDTs dts =+ let+ srts = map (IdentSort . ISymb . dt_smt_name) dts+ in+ [intSort, boolSort] ++ srts++qualifCalls' :: [QDataType] -> [QMeasure] -> [SortedVar] -> [Cmd]+qualifCalls' q_dt q_meas sortVars =+ let+ dt_srts = filter (\s -> s /= intSort && s /= boolSort)+ . nub . map (\(SortedVar _ s) -> s) $ sortVars+ + gram_names = zip (map (\i -> "G" ++ show i) [0..]) dt_srts++ gram = qualifGrammar gram_names q_meas+ gram' = filterGrammar gram+ in+ [ SmtCmd (SetLogic "ALL")]+ +++ map qDataTypeToDeclareDataType q_dt+ +++ map qMeasureToDefineFun q_meas+ +++ [SynthFun "qualif" sortVars boolSort (Just gram')]+ +++ [ CheckSynth ]++qualifGrammar :: [(String, Sort)] -> [QMeasure] -> GrammarDef+qualifGrammar dt_gram_names meas =+ let+ sw_gram_names = map swap dt_gram_names++ brl = GroupedRuleList "B" boolSort+ (boolRuleList ++ qualifGramMeasCalls boolSort sw_gram_names meas)+ irl = GroupedRuleList "I" intSort+ (intRuleList ++ qualifGramMeasCalls intSort sw_gram_names meas)++ dt_rule_lists = map (\(gn, s) -> GroupedRuleList gn s [GVariable s]) dt_gram_names+ in+ GrammarDef+ ([ SortedVar "B" boolSort+ , SortedVar "I" intSort ]+ ++ map (uncurry SortedVar) dt_gram_names)+ ([brl, irl] ++ dt_rule_lists)++qualifGramMeasCalls :: Sort -> [(Sort, String)] -> [QMeasure] -> [GTerm]+qualifGramMeasCalls srt sort_to_gram = mapMaybe (qualifGramMeasCall srt sort_to_gram)++qualifGramMeasCall :: Sort -> [(Sort, String)] -> QMeasure -> Maybe GTerm+qualifGramMeasCall srt sort_to_gram meas@(QMeasure { m_name = f, m_in = i, m_out = out })+ | srt == out+ , Just g <- lookup i sort_to_gram =+ Just . GBfTerm $ BfIdentifierBfs (ISymb f) [BfIdentifier (ISymb g)]+ | otherwise = Nothing++-- | Eliminates or replaces the constant commands to avoid infinite grammars.+-- Eliminates And, since we get that anyway with Qualifs approach+filterGrammar :: GrammarDef -> GrammarDef+filterGrammar (GrammarDef sv grl) = GrammarDef sv $ map filterGrammar' grl++filterGrammar' :: GroupedRuleList -> GroupedRuleList+filterGrammar' (GroupedRuleList symb srt gterms) =+ GroupedRuleList symb srt . filter (not . isAnd) $ filter (not . isConstant) gterms++isConstant :: GTerm -> Bool+isConstant (GConstant _) = True+isConstant _ = False++isAnd :: GTerm -> Bool+isAnd (GBfTerm (BfIdentifierBfs (ISymb "and") _)) = True+isAnd _ = False++-- | Converts a QDataType to a declare-datatype+qDataTypeToDeclareDataType :: QDataType -> Cmd+qDataTypeToDeclareDataType q_dt =+ SmtCmd . DeclareDatatype (dt_smt_name q_dt)+ . DTDec . map (flip DTConsDec []) $ dt_cons q_dt ++-- | Converts a QMeasure to a define-fun+qMeasureToDefineFun :: QMeasure -> Cmd+qMeasureToDefineFun q_meas =+ let+ ar = SortedVar "a" (m_in q_meas)+ in+ SmtCmd $ DefineFun (m_name q_meas) [ar] (m_out q_meas) (triv_out q_meas)++-- | Returns True if given an SMT define fun command that uses all it's arguments. False otherwise+defineFunAllUsed :: Cmd -> Bool+defineFunAllUsed (SmtCmd (DefineFun _ sv _ t)) = allVariablesUsed sv t+defineFunAllUsed _ = False++-- | Returns true if all the variable are used in the Term. False otherwise. +allVariablesUsed :: [SortedVar] -> Term -> Bool+allVariablesUsed svs t =+ let+ vs = map (\(SortedVar i _) -> ISymb i) svs+ used = usedIdentifiers t+ in+ vs \\ used == []++usedIdentifiers :: Term -> [Identifier]+usedIdentifiers (TermIdent ind) = [ind]+usedIdentifiers (TermLit _) = []+usedIdentifiers (TermCall _ ts) = mconcat $ map usedIdentifiers ts+usedIdentifiers (TermExists _ t) = usedIdentifiers t+usedIdentifiers (TermForAll _ t) = usedIdentifiers t+usedIdentifiers (TermLet vb t) = concatMap usedInVarBindings vb ++ usedIdentifiers t++usedInVarBindings :: VarBinding -> [Identifier]+usedInVarBindings (VarBinding _ t) = usedIdentifiers t++cmdToQualifs :: [QDataType] -> [QMeasure] -> Cmd -> String+cmdToQualifs dts meas (SmtCmd (DefineFun _ sv _ t)) =+ let+ sv_str = map sortedVarSymbol sv+ sv_to_symb = M.fromList . zip sv_str $ map LH.symbol sv_str++ meas_names = map (nameOcc . strToName . m_name) meas++ lh_expr = termToLHExpr (MeasureSymbols $ map LH.symbol meas_names) sv_to_symb t+ lh_expr_str = map (\c -> if c == '\n' then ' ' else c) $ show (pprintTidy Full lh_expr)+ in+ "qualif Qualif(" ++ bindSortedVars dts sv ++ ") : (" ++ lh_expr_str ++ ")"++sortedVarSymbol :: SortedVar -> Symbol+sortedVarSymbol (SortedVar v _) = v++bindSortedVars :: [QDataType] -> [SortedVar] -> String+bindSortedVars dts = intercalate ", " . map (bindSortedVar dts)++bindSortedVar :: [QDataType] -> SortedVar -> String+bindSortedVar dts (SortedVar v srt) = v ++ ":" ++ sortString dts srt++sortString :: [QDataType] -> Sort -> String+sortString dts (IdentSort (ISymb s))+ | Just dt <- find (\d -> s == dt_smt_name d) dts = dt_name dt+ | otherwise = s+sortString _ _ = error "sortString: Unexpected sort"+++-------------------------------+-- Various specific sorts+-------------------------------++listSort :: Sort+listSort = IdentSort (ISymb "List")+-}
+ src/G2/Liquid/Inference/Sygus.hs view
@@ -0,0 +1,7 @@+module G2.Liquid.Inference.Sygus ( module G2.Liquid.Inference.Sygus.SimplifySygus+ , module G2.Liquid.Inference.Sygus.LiaSynth+ , module G2.Liquid.Inference.Sygus.UnsatCoreElim) where++import G2.Liquid.Inference.Sygus.SimplifySygus+import G2.Liquid.Inference.Sygus.LiaSynth+import G2.Liquid.Inference.Sygus.UnsatCoreElim
+ src/G2/Liquid/Inference/Sygus/FCConverter.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE OverloadedStrings #-}++module G2.Liquid.Inference.Sygus.FCConverter ( NMExprEnv+ , convertConstraints) where++import G2.Language as G2+import G2.Liquid.Types+import G2.Liquid.Inference.Config+import G2.Liquid.Inference.FuncConstraint+import G2.Liquid.Inference.G2Calls+import G2.Liquid.Inference.PolyRef+import G2.Liquid.Inference.Sygus.SpecInfo++import qualified Data.HashMap.Lazy as HM+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe+import Data.Tuple.Extra++type ConvertExpr a = G2.Expr -> a+type AndF a = [a] -> a+type OrF a = [a] -> a+type NotF a = a -> a+type ImpliesF a = a -> a -> a++type Func a = String -> [a] -> a+type KnownFunc a = String -> Integer -> Bool -> a+type ToBeFunc a = String -> Integer -> Bool -> a++------------------------------------+-- Building Formulas+------------------------------------++mkPreCall :: (InfConfigM m, ProgresserM m) => + ConvertExpr form+ -> AndF form+ -> Func form+ -> KnownFunc form+ -> ToBeFunc form+ -> NMExprEnv + -> TypeEnv + -> Measures+ -> MeasureExs+ -> Evals (Integer, Bool)+ -> M.Map Name SpecInfo+ -> FuncCall+ -> [HigherOrderFuncCall]+ -> m form+mkPreCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals m_si fc@(FuncCall { funcName = n }) hcalls+ | Just si <- M.lookup n m_si+ , Just (ev_i, ev_b) <- lookupEvals fc (pre_evals evals)+ , Just func_e <- HM.lookup (nameOcc n, nameModule n) eenv = do+ sy_body <- mkPreSynthBody convExpr funcF eenv tenv meas meas_ex (s_syn_pre si) (argumentTypes func_e) fc hcalls+ let fixed_body = knownF (s_known_pre_name si) ev_i ev_b+ to_be_body = toBeF (s_to_be_pre_name si) ev_i ev_b++ case s_status si of+ Synth -> return . andF $ fixed_body:sy_body+ ToBeSynthed -> return $ andF [fixed_body, to_be_body]+ Known -> return $ fixed_body+ | otherwise = error "mkPreCall: specification not found"++mkPreSynthBody :: (InfConfigM m, ProgresserM m) => + ConvertExpr form+ -> Func form+ -> NMExprEnv + -> TypeEnv + -> Measures+ -> MeasureExs+ -> [PolyBound SynthSpec]+ -> [Type]+ -> FuncCall+ -> [HigherOrderFuncCall]+ -> m [form]+mkPreSynthBody convExpr funcF eenv tenv meas meas_ex pre_spec func_ts (FuncCall { funcName = n, arguments = ars }) hcalls = do+ let v_ars = filter (validArgForSMT . thd3)+ . filter (\(_, t, _) -> not (isTyVar t))+ . assignNums 1+ $ zip func_ts ars++ sy_body_p <- mapM (\(si_pb, ts_es) ->+ let+ t_ars = map (\(_, t, e) -> (t, e)) $ init ts_es++ (i, l_rt, l_re) = last ts_es+ re_pb = extractExprPolyBoundWithRoot l_re+ rt_pb = extractTypePolyBound l_rt++ in+ case (i, l_rt) of+ (Just i', TyFun _ _) -> do -- error $ "HERE\npre_spec = " ++ show pre_spec ++ "\nts_es = " ++ show ts_es+ let arg_tys = argumentTypes $ PresType l_rt+ return_ty = returnType $ PresType l_rt+ hcalls' = filter (\hfc -> nameOcc (funcName hfc) == nameOcc n && nameUnique (funcName hfc) == i') hcalls+ clls <- mapM (mkHigherOrderCall convExpr funcF eenv tenv meas meas_ex (removeHead si_pb) arg_tys return_ty) hcalls'+ return $ concat clls+ _ -> formCalls convExpr funcF tenv meas meas_ex n t_ars si_pb re_pb rt_pb+ ) . zip pre_spec . filter (not . null) $ L.inits v_ars+ return $ concat sy_body_p+ where+ assignNums _ [] = []+ assignNums i ((t@(TyFun _ _), e):ts) = (Just i, t, e):assignNums (i + 1) ts+ assignNums i ((t, e):ts) = (Nothing, t, e):assignNums i ts++mkPostCall :: (InfConfigM m, ProgresserM m) => + ConvertExpr form+ -> AndF form+ -> Func form+ -> KnownFunc form+ -> ToBeFunc form+ -> NMExprEnv+ -> TypeEnv+ -> Measures+ -> MeasureExs+ -> Evals (Integer, Bool)+ -> M.Map Name SpecInfo+ -> FuncCall+ -> m form+mkPostCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals m_si fc@(FuncCall { funcName = n })+ | Just si <- M.lookup n m_si+ , Just (ev_i, ev_b) <- lookupEvals fc (post_evals evals)+ , Just func_e <- HM.lookup (nameOcc n, nameModule n) eenv = do+ let fixed_body = knownF (s_known_post_name si) ev_i ev_b+ to_be_body = toBeF (s_to_be_post_name si) ev_i ev_b++ sy_body <- mkPostSynthBody convExpr funcF tenv meas meas_ex (s_syn_post si) (argumentTypes func_e) (returnType func_e) fc+ case s_status si of+ Synth -> return . andF $ fixed_body:sy_body+ ToBeSynthed -> return $ andF [fixed_body, to_be_body]+ Known -> return $ fixed_body+ | otherwise = error "mkPostCall: specification not found"++mkPostSynthBody :: (InfConfigM m, ProgresserM m) => + ConvertExpr form+ -> Func form+ -> TypeEnv+ -> Measures+ -> MeasureExs+ -> PolyBound SynthSpec+ -> [Type]+ -> Type+ -> FuncCall+ -> m [form]+mkPostSynthBody convExpr funcF tenv meas meas_ex post_spec func_ts ret_ty (FuncCall { funcName = n, arguments = ars, returns = ret }) = do+ let v_ars = filter (\(t, _) -> not (isTyVar t))+ . filter (validArgForSMT . snd)+ $ zip func_ts ars++ smt_ret = extractExprPolyBoundWithRoot ret+ smt_ret_ty = extractTypePolyBound ret_ty++ formCalls convExpr funcF tenv meas meas_ex n v_ars post_spec smt_ret smt_ret_ty++mkHigherOrderCall :: (InfConfigM m, ProgresserM m) =>+ ConvertExpr form+ -> Func form+ -> NMExprEnv+ -> TypeEnv+ -> Measures+ -> MeasureExs+ -> [PolyBound SynthSpec]+ -> [Type] -- ^ Argument types+ -> Type -- ^ Return Type+ -> FuncCall+ -> m [form]+mkHigherOrderCall convExpr funcF eenv tenv meas meas_ex pb_synth@(_:_) ar_ts ret_t fc = do+ pre <- mkPreSynthBody convExpr funcF eenv tenv meas meas_ex (init pb_synth) ar_ts fc []+ post <- mkPostSynthBody convExpr funcF tenv meas meas_ex (last pb_synth) ar_ts ret_t fc+ return $ pre ++ post+mkHigherOrderCall _ _ _ _ _ _ _ _ _ _ = return []++formCalls :: (InfConfigM m, ProgresserM m) => ConvertExpr form -> Func form -> TypeEnv -> Measures -> MeasureExs -> Name -> [(Type, Expr)] -> PolyBound SynthSpec -> PolyBound [Expr] -> PolyBound Type -> m [form]+formCalls convExpr funcF tenv meas meas_ex n v_ars si_pb re_pb rt_pb = do+ MaxSize mx_meas <- maxSynthFormSizeM+ inf_con <- infConfigM+ let smt_ars = concatMap (uncurry (adjustArgsWithCare inf_con n convExpr (fromInteger mx_meas) tenv meas meas_ex)) v_ars+ si_re_rt_pb = case filterPBByType snd $ zipPB re_pb rt_pb of+ Just re_rt_pb -> zipWithPB (\x (y, z) -> (x, y, z)) si_pb re_rt_pb+ Nothing -> zipWithPB (\x (y, z) -> (x, y, z)) si_pb $ PolyBound ([], headValue rt_pb) [] -- error $ "formCalls: impossible, the polybound should have already been filtered" ++ "\nsi_pb = " ++ show si_pb ++ "\nre_pb = " ++ show re_pb ++ "\nrt_pb = " ++ show rt_pb+ return $ concatMap (\(psi, re, rt) ->+ let+ f_smt_ars = if null (sy_args psi) then [] else smt_ars+ smt_r = map (adjustArgs convExpr (fromInteger mx_meas) tenv meas meas_ex rt) re+ in+ map (\r -> funcF (sy_name psi) $ take (length (sy_args psi)) f_smt_ars ++ take (length (sy_rets psi)) r) smt_r+ ) $ extractValues si_re_rt_pb++convertConstraints :: (InfConfigM m, ProgresserM m) =>+ ConvertExpr form+ -> AndF form+ -> OrF form+ -> NotF form+ -> ImpliesF form+ -> Func form+ -> KnownFunc form+ -> ToBeFunc form+ -> NMExprEnv+ -> TypeEnv+ -> Measures+ -> MeasureExs+ -> Evals (Integer, Bool)+ -> M.Map Name SpecInfo+ -> FuncConstraints+ -> m [form]+convertConstraints convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si fc = do+ let fc' = toListFC fc+ mapM (convertConstraint + convExpr+ andF+ orF+ notF+ impF+ funcF+ knownF+ toBeF+ eenv tenv meas meas_ex evals si) fc'++convertConstraint :: (InfConfigM m, ProgresserM m) =>+ ConvertExpr form+ -> AndF form+ -> OrF form+ -> NotF form+ -> ImpliesF form+ -> Func form+ -> KnownFunc form+ -> ToBeFunc form+ -> NMExprEnv+ -> TypeEnv+ -> Measures+ -> MeasureExs+ -> Evals (Integer, Bool)+ -> M.Map Name SpecInfo+ -> FuncConstraint+ -> m form+convertConstraint convExpr andF _ _ impF funcF knownF toBeF eenv tenv meas meas_ex evals si (Call All fc hcalls) = do+ pre <- mkPreCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals si fc hcalls+ post <- mkPostCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals si fc+ return $ pre `impF` post+convertConstraint convExpr andF _ _ _ funcF knownF toBeF eenv tenv meas meas_ex evals si (Call Pre fc hcalls) =+ mkPreCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals si fc hcalls+convertConstraint convExpr andF _ _ _ funcF knownF toBeF eenv tenv meas meas_ex evals si (Call Post fc _) =+ mkPostCall convExpr andF funcF knownF toBeF eenv tenv meas meas_ex evals si fc+convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si (AndFC fs) =+ return . andF =<< mapM (convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si) fs+convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si (OrFC fs) =+ return . orF =<< mapM (convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si) fs+convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si (ImpliesFC fc1 fc2) = do+ lhs <- convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si fc1+ rhs <- convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si fc2+ return $ lhs `impF` rhs+convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si (NotFC fc) =+ return . notF =<< convertConstraint convExpr andF orF notF impF funcF knownF toBeF eenv tenv meas meas_ex evals si fc++adjustArgs :: ConvertExpr form -> Int -> TypeEnv -> Measures -> MeasureExs -> Type -> G2.Expr -> [form]+adjustArgs convExpr mx_meas tenv meas meas_ex t =+ map convExpr+ . map adjustLits+ . substMeasures mx_meas tenv meas meas_ex t++substMeasures :: Int -> TypeEnv -> Measures -> MeasureExs -> Type -> G2.Expr -> [G2.Expr]+substMeasures mx_meas tenv meas meas_ex t e =+ case typeToSort t of+ Just _ -> [e]+ Nothing ->+ case HM.lookup e meas_ex of+ Just es ->+ let+ -- Get a list of all measure/output pairs with usable types+ es' = filter (isJust . typeToSort . returnType . snd) $ HM.toList es+ -- Make sure that es's type is specific enough to be used with the measure+ app_meas = applicableMeasures mx_meas tenv meas t+ es'' = filter (\(ns, _) -> ns `HM.member` app_meas) es'+ in+ -- Sort to make sure we get the same order consistently+ map snd $ L.sortBy (\(n1, _) (n2, _) -> compare n1 n2) es''+ Nothing -> []++adjustArgsWithCare :: InferenceConfig -> Name -> ConvertExpr form -> Int -> TypeEnv -> Measures -> MeasureExs -> Type -> G2.Expr -> [form]+adjustArgsWithCare inf_con n convExpr mx_meas tenv meas meas_ex t+ | use_invs inf_con+ , specialFunction n =+ map convExpr+ . map adjustLits+ . (\e -> case typeToSort t of Just _ -> [e]; Nothing -> [])+ | otherwise = adjustArgs convExpr mx_meas tenv meas meas_ex t++adjustLits :: G2.Expr -> G2.Expr+adjustLits (App _ l@(Lit _)) = l+adjustLits e = e++validArgForSMT :: G2.Expr -> Bool+validArgForSMT e = not (isLHDict e) && not (isType e)+ where+ isType (Type _) = True+ isType _ = False++ isLHDict e_+ | (TyCon (Name n _ _ _) _):_ <- unTyApp (typeOf e_) = n == "lh"+ | otherwise = False
+ src/G2/Liquid/Inference/Sygus/LiaSynth.hs view
@@ -0,0 +1,1661 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module G2.Liquid.Inference.Sygus.LiaSynth ( SynthRes (..)+ , Size+ , ModelNames (..)+ , Iteration (..)+ , liaSynth++ , MaxSize+ , incrMaxSize++ , BlockedModels+ , emptyBlockedModels+ , insertBlockedModel+ , blockedHashMap+ , unionBlockedModels) where++import G2.Data.Utils+import G2.Language as G2+import qualified G2.Language.ExprEnv as E+import G2.Liquid.Interface+import G2.Liquid.Types+import G2.Liquid.Inference.Config+import G2.Liquid.Inference.FuncConstraint+import G2.Liquid.Inference.G2Calls+import G2.Liquid.Inference.GeneratedSpecs+import G2.Liquid.Inference.PolyRef+import G2.Liquid.Inference.UnionPoly+import G2.Liquid.Inference.Sygus.FCConverter+import G2.Liquid.Inference.Sygus.SpecInfo++import G2.Solver as Solver++import Control.Monad.IO.Class ++import Language.Haskell.Liquid.Types as LH hiding (SP, ms, isBool, diff, fresh)+import Language.Fixpoint.Types.Refinements as LH hiding (pAnd, pOr)+import qualified Language.Fixpoint.Types as LH+import qualified Language.Fixpoint.Types as LHF++import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HS+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Text as T+import qualified Text.Builder as TB+import qualified Data.Text.IO as T++data SynthRes = SynthEnv+ GeneratedSpecs -- ^ The synthesized specifications+ Size -- ^ The size that the synthesizer succeeded at+ SMTModel -- ^ An SMTModel corresponding to the new specifications+ BlockedModels -- ^ SMTModels that should be blocked in the future+ | SynthFail FuncConstraints++type Size = Integer++data Iteration = FirstRound | AfterFirstRound++liaSynth :: (InfConfigM m, ProgresserM m, MonadIO m, SMTConverter con)+ => con -> Iteration -> [GhcInfo] -> LiquidReadyState -> Evals Bool -> MeasureExs+ -> FuncConstraints+ -> UnionedTypes+ -> BlockedModels -- ^ SMT Models to block being returned by the synthesizer at various sizes+ -> ToBeNames -> ToSynthNames -> m SynthRes+liaSynth con iter ghci lrs evals meas_ex fc ut blk_mdls to_be_ns ns_synth = do++ -- Figure out the type of each of the functions we need to synthesize+ let eenv = buildNMExprEnv $ expr_env . state $ lr_state lrs+ tenv = type_env . state $ lr_state lrs+ tc = type_classes . state $ lr_state lrs+ meas = lrsMeasures ghci lrs++ si <- buildSpecInfo eenv tenv tc meas ghci fc ut to_be_ns ns_synth++ liftIO . putStrLn $ "si = " ++ show si++ MaxSize max_sz <- maxSynthFormSizeM++ synth con iter ghci eenv tenv meas meas_ex evals si fc blk_mdls max_sz++liaSynthOfSize :: (InfConfigM m, ProgresserM m) => Integer -> M.Map Name SpecInfo -> m (M.Map Name SpecInfo)+liaSynthOfSize sz m_si = do+ inf_c <- infConfigM+ MaxSize max_form_sz <- maxSynthFormSizeM+ MaxSize max_coeff_sz <- maxSynthCoeffSizeM+ let m_si' =+ M.map (\si -> + let+ s_syn_pre' =+ map (mapPB+ (\psi ->+ psi { sy_coeffs = mkCNF (>= 1) sz (fromInteger max_form_sz) (sy_name psi) psi }+ )+ ) (s_syn_pre si)+ s_syn_post' =+ mapPB (\psi -> + psi { sy_coeffs = mkCNF (>= 1) sz (fromInteger max_form_sz) (sy_name psi) psi }+ ) (s_syn_post si)+ in+ si { s_syn_pre = s_syn_pre' -- (s_syn_pre si) { sy_coeffs = pre_c }+ , s_syn_post = s_syn_post' -- (s_syn_post si) { sy_coeffs = post_c }+ , s_max_coeff = if restrict_coeffs inf_c then 1 else max_coeff_sz }) m_si+ return m_si'+ where++mkCNF :: (Int -> Bool) -> Integer -> Int -> String -> SynthSpec -> CNF+mkCNF prd sz ms s psi_ =+ (if length (set_sy_args psi_) + length (set_sy_rets psi_) == 0+ then+ [ + (+ s ++ "_c_coeff_act_" ++ show j+ ,+ [ mkCoeffs prd s psi_ j k | k <- [1..sz] ] -- Ors+ )+ | j <- [1..sz] ] -- Ands+ else [])+ +++ (if length (set_sy_args psi_) + length (set_sy_rets psi_) > 0+ then+ [ + (+ s ++ "_c_set_act_" ++ show j+ ,+ [ mkSetForms prd ms s psi_ j k | k <- [1..sz] ] -- Ors+ )+ | j <- [1..sz] ] -- Ands+ else [])+ +++ (if length (bool_sy_args psi_) + length (bool_sy_rets psi_) > 0+ then+ [ + (+ s ++ "_c_bool_act_" ++ show j+ ,+ [ mkBoolForms prd sz ms s psi_ j k | k <- [1..sz] ] -- Ors+ )+ | j <- [1..sz] ] -- Ands+ else [])+++mkCoeffs :: (Int -> Bool) -> String -> SynthSpec -> Integer -> Integer -> Forms+mkCoeffs prd s psi j k =+ let+ ars = length (int_sy_args psi)+ rets = length (int_sy_rets psi)+ in+ LIA+ {+ c_active = s ++ "_f_act_" ++ show j ++ "_t_" ++ show k+ , c_op_branch1 = s ++ "_lia_op1_" ++ show j ++ "_t_" ++ show k+ , c_op_branch2 = s ++ "_lia_op2_" ++ show j ++ "_t_" ++ show k+ , b0 = s ++ "_b_" ++ show j ++ "_t_" ++ show k+ + -- We only want solutions that have one or more return values with a+ -- non-zero coefficient. Thus, if we have no return values, we+ -- don't need to consider any arguments+ , ars_coeffs =+ if prd rets+ then+ [ s ++ "_a_c_" ++ show j ++ "_t_" ++ show k ++ "_a_" ++ show a+ | a <- [1..ars]]+ else+ []+ , rets_coeffs = + [ s ++ "_r_c_" ++ show j ++ "_t_" ++ show k ++ "_a_" ++ show a+ | a <- [1..rets]]+ }++mkSetForms :: (Int -> Bool) -> Int -> String -> SynthSpec -> Integer -> Integer -> Forms+mkSetForms prd max_sz s psi j k =+ let+ int_ars = length (int_sy_args psi)+ int_rets = length (int_sy_rets psi)++ ars = length (set_sy_args psi)+ rets = length (set_sy_rets psi)++ max_sets = min (ars + rets + int_ars + int_rets) 2 -- + max_sz - 1+ in+ Set+ { + c_active = s ++ "_s_act_" ++ show j ++ "_t_" ++ show k+ , c_op_branch1 = s ++ "_set_op1_" ++ show j ++ "_t_" ++ show k+ , c_op_branch2 = s ++ "_set_op2_" ++ show j ++ "_t_" ++ show k++ , int_sing_set_bools_lhs =+ if prd rets+ then+ [ + [ s ++ "_a_set_sing_lhs_" ++ show j ++ "_t_" ++ show k+ ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..int_ars + int_rets]]+ | a <- [1..max_sets]]+ else+ []++ , int_sing_set_bools_rhs =+ if prd rets+ then+ []+ {- [ + [ s ++ "_a_set_sing_rhs_" ++ show j ++ "_t_" ++ show k+ ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..int_ars + int_rets]]+ | a <- [1..ars + rets + max_sz - 1]] -}+ else+ []++ , ars_bools_lhs =+ if prd rets+ then+ [ + [ s ++ "_a_set_lhs_" ++ show j ++ "_t_" ++ show k+ ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..ars]]+ | a <- [1..max_sets]]+ else+ []+ , rets_bools_lhs = + [ [ s ++ "_r_set_lhs_" ++ show j ++ "_t_" ++ show k+ ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..rets]]+ | a <- [1..ars + rets + max_sz - 1]]++ , ars_bools_rhs =+ if prd rets+ then+ [ [ s ++ "_a_set_rhs_" ++ show j ++ "_t_" ++ show k+ ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..ars]]+ | a <- [1..max_sets]]+ else+ []+ , rets_bools_rhs = + [[ s ++ "_r_set_rhs_" ++ show j ++ "_t_" ++ show k+ ++ "_a_" ++ show a ++ "_int_" ++ show inter | inter <- [1..rets]]+ | a <- [1..max_sets]]+ }++mkBoolForms :: (Int -> Bool) -> Integer -> Int -> String -> SynthSpec -> Integer -> Integer -> Forms+mkBoolForms prd sz max_sz s psi j k =+ let+ ars = length (bool_sy_args psi)+ rets = length (bool_sy_rets psi)+ in+ BoolForm+ {+ c_active = s ++ "_bool_act_" ++ show j ++ "_t_" ++ show k+ , c_op_branch1 = s ++ "_bool_op1_" ++ show j ++ "_t_" ++ show k+ , c_op_branch2 = s ++ "_bool_op2_" ++ show j ++ "_t_" ++ show k++ , ars_bools =+ if prd rets+ then+ [ s ++ "_a_bool_" ++ show j ++ "_t_" ++ show k ++ "_a_" ++ show a+ | a <- [1..ars]]+ else+ []+ , rets_bools = + [ s ++ "_r_bool_" ++ show j ++ "_t_" ++ show k ++ "_a_" ++ show a+ | a <- [1..rets]]++ , forms = concat+ . map snd+ $ mkCNF (const True) sz max_sz (s ++ "_bool_" ++ show j ++ "_t_" ++ show k ++ "_" )+ (psi { sy_args = filter (not . isBool . smt_sort) (sy_args psi)+ , sy_rets = filter (not . isBool . smt_sort) (sy_rets psi) })+ }+ where+ isBool SortBool = True+ isBool _ = False++synth :: (InfConfigM m, ProgresserM m, MonadIO m, SMTConverter con)+ => con+ -> Iteration+ -> [GhcInfo]+ -> NMExprEnv+ -> TypeEnv+ -> Measures+ -> MeasureExs+ -> Evals Bool+ -> M.Map Name SpecInfo+ -> FuncConstraints+ -> BlockedModels+ -> Size+ -> m SynthRes+synth con iter ghci eenv tenv meas meas_ex evals si fc blk_mdls sz = do+ si' <- liaSynthOfSize sz si+ let zero_coeff_hdrs = softCoeffAssertZero si' ++ softClauseActAssertZero si' -- ++ softFuncActAssertZero si'+ -- zero_coeff_hdrs = softFuncActAssertZero si' ++ softClauseActAssertZero si'+ -- zero_coeff_hdrs = softCoeffAssertZero si' -- softFuncActAssertZero si' ++ softClauseActAssertZero si'++ max_coeffs_cons = maxCoeffConstraints si'+ soft_coeff_cons = softCoeffConstraints si'++ soft_set_bool_cons = softSetConstraints si'++ mdls = lookupBlockedModels sz blk_mdls+ rel_mdls = map (uncurry (filterModelToRel si')) mdls+ block_mdls = map blockModelDirectly rel_mdls++ non_equiv_mdls = lookupNonEquivBlockedModels sz blk_mdls+ rel_non_equiv_mdls = map (uncurry (filterModelToRel si')) non_equiv_mdls+ fun_block_mdls = concatMap (uncurry (blockModelWithFuns si')) $ zip (map show ([0..] :: [Integer])) rel_non_equiv_mdls++ ex_assrts1 = [Comment "enforce maximal and minimal values for coefficients"]+ ++ max_coeffs_cons++ ex_assrts2 = [Comment "favor making coefficients 0"]+ ++ zero_coeff_hdrs+ ++ [Comment "favor coefficients being -1, 0, or 1"]+ ++ soft_coeff_cons+ ++ [Comment "favor set booleans being false"]+ ++ soft_set_bool_cons+ ++ [Comment "block spurious models"]+ ++ block_mdls++ ex_assrts = ex_assrts1 ++ ex_assrts2++ drop_if_unknown = [Comment "stronger blocking of spurious models"] ++ fun_block_mdls++ MaxSize max_sz <- maxSynthFormSizeM++ res <- synth' con ghci eenv tenv meas meas_ex evals si' fc ex_assrts drop_if_unknown blk_mdls sz+ case res of+ SynthEnv _ _ n_mdl _ -> do+ new <- checkModelIsNewFunc con si' n_mdl non_equiv_mdls+ case new of+ Nothing -> return res+ Just (_, eq_mdl) -> do+ let sys = concatMap allSynthSpec $ M.elems si'+ rel_n_mdl = filterIrrelByConstruction sys n_mdl+ rel_eq_mdl = filterIrrelByConstruction sys eq_mdl++ mn = determineRelSynthSpecs si' rel_n_mdl rel_eq_mdl+ mdls' = foldr (\n -> insertEquivBlockedModel sz (MNOnlySMTNames [n]) n_mdl) blk_mdls mn++ liftIO . putStrLn $ "mn = " ++ show mn+ synth con iter ghci eenv tenv meas meas_ex evals si fc mdls' sz+ SynthFail _+ | sz < max_sz -> synth con iter ghci eenv tenv meas meas_ex evals si fc blk_mdls (sz + 1)+ | FirstRound <- iter -> do+ no_max_res <- synth' con ghci eenv tenv meas meas_ex evals si' fc ex_assrts2 drop_if_unknown blk_mdls sz+ case no_max_res of+ SynthEnv gs _ _ _ -> do+ let lits = concatMap exprIntegers $ allExprs gs+ max_lit = maximum $ map abs lits+ setMaxSynthCoeffSizeM (MaxSize max_lit)+ return no_max_res+ _ -> return no_max_res+ | otherwise -> return res+ +synth' :: (InfConfigM m, ProgresserM m, MonadIO m, SMTConverter con)+ => con+ -> [GhcInfo]+ -> NMExprEnv+ -> TypeEnv+ -> Measures+ -> MeasureExs+ -> Evals Bool+ -> M.Map Name SpecInfo+ -> FuncConstraints+ -> [SMTHeader]+ -> [SMTHeader]+ -> BlockedModels+ -> Size+ -> m SynthRes+synth' con ghci eenv tenv meas meas_ex evals m_si fc headers drop_if_unknown blk_mdls sz = do+ let n_for_m = namesForModel m_si+ let consts = arrayConstants m_si+ (constraints, nm_fc_map) <- nonMaxCoeffConstraints ghci eenv tenv meas meas_ex evals m_si fc+ let hdrs = SetLogic ALL:consts ++ constraints ++ headers ++ drop_if_unknown++ liftIO $ if not (null drop_if_unknown) then putStrLn "non empty drop_if_unknown" else return ()++ result <- return . adjustRes =<< runConstraintsForSynth hdrs n_for_m++ case result of+ SAT mdl -> do+ let gs' = modelToGS m_si mdl+ liftIO $ print gs'+ return (SynthEnv gs' sz mdl blk_mdls)+ UNSAT uc ->+ let+ fc_uc = fromSingletonFC . NotFC . AndFC . map (nm_fc_map HM.!) $ HS.toList uc+ in+ return (SynthFail fc_uc)+ Unknown _ maybe_mdl+ | not (null drop_if_unknown) ->+ synth' con ghci eenv tenv meas meas_ex evals m_si fc headers [] blk_mdls sz+ | Just mdl <- maybe_mdl -> do+ liftIO $ putStrLn "Unknown model!"+ let gs' = modelToGS m_si mdl+ liftIO $ print gs'+ return (SynthEnv gs' sz mdl blk_mdls)+ | otherwise -> error "synth': Unknown"+ where+ adjustRes (SAT m) = SAT m+ adjustRes (UNSAT uc) = UNSAT uc+ adjustRes (Unknown e ()) = Unknown e Nothing++runConstraintsForSynth :: (InfConfigM m, MonadIO m)+ => [SMTHeader] -> [(SMTName, Sort)] -> m (Result SMTModel UnsatCore ())+runConstraintsForSynth headers vs = do+ inf_con <- infConfigM+ if use_binary_minimization inf_con+ then do+ z3_dir <- liftIO $ getZ3 100000+ z3_max <-liftIO $ mkMaximizeSolver =<< getZ3 50000++ liftIO $ setProduceUnsatCores z3_dir+ liftIO $ setProduceUnsatCores z3_max++ -- liftIO $ T.putStrLn (TB.run $ toSolverText headers)+ liftIO $ addFormula z3_dir headers+ liftIO $ addFormula z3_max headers++ liftIO $ checkSatInstr z3_dir+ liftIO $ checkSatInstr z3_max+ + res <- liftIO $ waitForRes2 Nothing Nothing z3_dir z3_max vs++ liftIO $ closeIO z3_dir+ liftIO $ closeIO z3_max++ return res+ else do+ z3_dir <- liftIO $ getZ3 100000++ liftIO $ setProduceUnsatCores z3_dir+ liftIO $ addFormula z3_dir headers+ liftIO $ checkSatInstr z3_dir+ + res <- liftIO $ waitForRes z3_dir vs++ liftIO $ closeIO z3_dir++ return res++waitForRes2 :: (SMTConverter s1, SMTConverter s2) =>+ Maybe (Result () () ()) -- ^ Nothing, or an unknown returned by Solver 1+ -> Maybe (Result () () ()) -- ^ Nothing, or an unknown returned by Solver 2+ -> s1+ -> s2+ -> [(SMTName, Sort)]+ -> IO (Result SMTModel UnsatCore ())+waitForRes2 m_res1 m_res2 s1 s2 vs = do+ res1 <- maybe (maybeCheckSatResult s1) (return . Just) m_res1+ res2 <- maybe (maybeCheckSatResult s2) (return . Just) m_res2++ case (res1, res2) of+ (Just res1', _) | isSatOrUnsat res1' -> do+ putStrLn $ "res1 = " ++ show res1+ putStrLn $ "res2 = " ++ show res2+ getModelOrUnsatCore s1 vs res1'+ (_, Just res2') | isSatOrUnsat res2' -> do+ putStrLn $ "res1 = " ++ show res1+ putStrLn $ "res2 = " ++ show res2+ getModelOrUnsatCore s2 vs res2'+ (Just (Unknown err1 ()), Just (Unknown err2 ())) -> do+ return $ Unknown (err1 ++ "\n" ++ err2) ()+ _ -> waitForRes2 res1 res2 s1 s2 vs+ where+ isSatOrUnsat (SAT _) = True+ isSatOrUnsat (UNSAT _) = True+ isSatOrUnsat _ = False++waitForRes :: SMTConverter s =>+ s+ -> [(SMTName, Sort)]+ -> IO (Result SMTModel UnsatCore ())+waitForRes s vs = do+ res <- maybeCheckSatResult s++ case res of+ Just res' -> getModelOrUnsatCore s vs res'+ _ -> waitForRes s vs++getModelOrUnsatCore :: SMTConverter smt => smt -> [(SMTName, Sort)] -> Result () () () -> IO (Result SMTModel UnsatCore ())+getModelOrUnsatCore con vs (SAT ()) = do+ mdl <- getModelInstrResult con vs+ return (SAT mdl)+getModelOrUnsatCore con _ (UNSAT ()) = do+ uc <- getUnsatCoreInstrResult con+ return (UNSAT uc)+getModelOrUnsatCore _ _ (Unknown err ()) = return (Unknown err ())++-- | Extract Integer literals from a LH expression+exprIntegers :: LHF.Expr -> [Integer]+exprIntegers (ESym _) = []+exprIntegers (ECon (I i)) = [i]+exprIntegers (ECon _) = []+exprIntegers (EVar _) = []+exprIntegers (EApp e1 e2) = exprIntegers e1 ++ exprIntegers e2+exprIntegers (ENeg e) = exprIntegers e+exprIntegers (EBin _ e1 e2) = exprIntegers e1 ++ exprIntegers e2+exprIntegers (EIte e1 e2 e3) = exprIntegers e1 ++ exprIntegers e2 ++ exprIntegers e3+exprIntegers (ECst e _) = exprIntegers e+exprIntegers (ELam _ e) = exprIntegers e+exprIntegers (ETApp e _) = exprIntegers e+exprIntegers (ETAbs e _) = exprIntegers e+exprIntegers (PAnd es) = concatMap exprIntegers es+exprIntegers (POr es) = concatMap exprIntegers es+exprIntegers (PNot e) = exprIntegers e+exprIntegers (PImp e1 e2) = exprIntegers e1 ++ exprIntegers e2+exprIntegers (PIff e1 e2) = exprIntegers e1 ++ exprIntegers e2+exprIntegers (PAtom _ e1 e2) = exprIntegers e1 ++ exprIntegers e2+exprIntegers _ = error "exprIntegers: unsupported"++------------------------------------+-- Handling Models+------------------------------------++----------------------------------------------------------------------------+-- Blocking Models directly+data BlockedModels = Block { blocked :: HM.HashMap Size [(ModelNames, SMTModel)]+ , blocked_equiv :: HM.HashMap Size [(ModelNames, SMTModel)] -- ^ Models that should be blocked, and represent the same specification as a model in `blocked`+ }+ deriving (Show)++data ModelNames = MNAll | MNOnly [Name] | MNOnlySMTNames [SMTName]+ deriving (Eq, Show, Read)++emptyBlockedModels :: BlockedModels+emptyBlockedModels = Block HM.empty HM.empty++insertBlockedModel :: Size -> ModelNames -> SMTModel -> BlockedModels -> BlockedModels+insertBlockedModel sz mdl_nms mdl blk_mdls =+ blk_mdls { blocked = HM.insertWith (++) sz [(mdl_nms, mdl)] (blocked blk_mdls) }++insertEquivBlockedModel :: Size -> ModelNames -> SMTModel -> BlockedModels -> BlockedModels+insertEquivBlockedModel sz mdl_nms mdl blk_mdls =+ blk_mdls { blocked_equiv = HM.insertWith (++) sz [(mdl_nms, mdl)] (blocked_equiv blk_mdls) }++lookupBlockedModels :: Size -> BlockedModels -> [(ModelNames, SMTModel)]+lookupBlockedModels sz blk_mdls =+ HM.lookupDefault [] sz (blocked blk_mdls) ++ HM.lookupDefault [] sz (blocked_equiv blk_mdls)++lookupNonEquivBlockedModels :: Size -> BlockedModels -> [(ModelNames, SMTModel)]+lookupNonEquivBlockedModels sz blk_mdls =+ HM.lookupDefault [] sz (blocked blk_mdls)++blockedHashMap :: BlockedModels -> HM.HashMap Size [(ModelNames, SMTModel)]+blockedHashMap blk_mdls = HM.unionWith (++) (blocked blk_mdls) (blocked_equiv blk_mdls)++unionBlockedModels :: BlockedModels -> BlockedModels -> BlockedModels+unionBlockedModels bm1 bm2 =+ Block { blocked = HM.unionWith (++) (blocked bm1) (blocked bm2)+ , blocked_equiv = HM.unionWith (++) (blocked_equiv bm1) (blocked_equiv bm2) }++----------------------------------------------------------------------------+-- Blocking Models building/manipulation++namesForModel :: M.Map Name SpecInfo -> [(SMTName, Sort)]+namesForModel = concat . map siNamesForModel . M.elems++siNamesForModel :: SpecInfo -> [(SMTName, Sort)]+siNamesForModel si+ | s_status si == Synth = concatMap sySpecNamesForModel $ allSynthSpec si+ | otherwise = []++sySpecNamesForModel :: SynthSpec -> [(SMTName, Sort)]+sySpecNamesForModel sys =+ let+ all_coeffs = zip (sySpecGetCoeffs sys) (repeat SortInt)+ all_set_bools = zip (sySpecGetSetBools sys) (repeat SortBool)+ all_bool_bools = zip (sySpecGetBoolBools sys) (repeat SortBool)+ all_acts = zip (sySpecGetActs sys) (repeat SortInt)+ all_op_branch = zip (sySpecGetOpBranches sys) (repeat SortBool)+ in+ all_coeffs ++ all_set_bools ++ all_bool_bools ++ all_acts ++ all_op_branch++modelToGS :: M.Map Name SpecInfo -> SMTModel -> GeneratedSpecs+modelToGS m_si mdl =+ let+ lh_spec = M.map (\si -> buildLIA_LH si mdl) . M.filter (\si -> s_status si == Synth) $ m_si+ in+ M.foldrWithKey insertAssertGS emptyGS lh_spec++-- | Generates an Assert that, when added to a formula with the relevant variables,+-- blocks it from returning the model+blockModelDirectly :: SMTModel -> SMTHeader+blockModelDirectly = Solver.Assert . (:!) . foldr (.&&.) (VBool True) . map (\(n, v) -> V n (sortOf v) := v) . M.toList++-- | Filters a model to only those variable bindings relevant to the functions listed in the name bindings+filterModelToRel :: M.Map Name SpecInfo -> ModelNames -> SMTModel -> SMTModel+filterModelToRel m_si ns mdl =+ let+ sys = case ns of+ MNAll -> concatMap allSynthSpec $ M.elems m_si+ MNOnly ns' -> concatMap allSynthSpec $ mapMaybe (flip M.lookup m_si) ns'+ MNOnlySMTNames ns' -> filter (\sy -> sy_name sy `elem` ns')+ . concatMap allSynthSpec+ $ M.elems m_si+ vs = map fst $ concatMap sySpecNamesForModel sys+ in+ filterIrrelByConstruction sys $ M.filterWithKey (\n _ -> n `elem` vs) mdl++filterIrrelByConstruction :: Foldable f => f SynthSpec -> SMTModel -> SMTModel+filterIrrelByConstruction = flip (foldr filterIrrelByConstruction')++filterIrrelByConstruction' :: SynthSpec -> SMTModel -> SMTModel+filterIrrelByConstruction' sys = + filterClauseActiveBooleans sys+ . filterCoeffActiveBooleans sys+ . filterRelOpBranch sys++-- If the clause level boolean is set to true, we remove all the+-- formula level active booleans, since the formulas are+-- irrelevant.+filterClauseActiveBooleans :: SynthSpec -> SMTModel -> SMTModel+filterClauseActiveBooleans si mdl =+ let+ clauses = sy_coeffs si+ in+ foldr (\(cl_act, cfs) mdl_ -> if+ | M.lookup cl_act mdl_ == Just (VBool True) ->+ foldr (\c -> M.delete (c_active c)) mdl_ cfs+ | otherwise -> mdl_) mdl clauses++-- If the formula level active booleans are set to false, we remove all the+-- coefficients in the formula, since the formula is now irrelevant.+filterCoeffActiveBooleans :: SynthSpec -> SMTModel -> SMTModel+filterCoeffActiveBooleans si mdl =+ let+ clauses = sy_coeffs si+ cffs = concatMap snd clauses+ in+ foldr (\cf mdl_ -> if+ | M.lookup (c_active cf) mdl_ == Just (VBool False) ->+ foldr M.delete mdl_ (coeffs cf)+ | otherwise -> mdl_) mdl cffs+++filterRelOpBranch :: SynthSpec -> SMTModel -> SMTModel+filterRelOpBranch si mdl =+ let+ clauses = sy_coeffs si+ coeff_nms = concatMap snd clauses+ in+ -- If we are not using a clause, we don't care about c_op_branch1 and c_op_branch2+ -- If we are using a clause but c_op_branch1 is true, we don't care about c_op_branch2+ foldr (\form mdl_ -> if+ | M.lookup (c_active form) mdl == Just (VBool False) ->+ M.delete (c_op_branch2 form) $ M.delete (c_op_branch1 form) mdl_+ | M.lookup (c_op_branch1 form) mdl == Just (VBool True) ->+ M.delete (c_op_branch2 form) mdl_+ | otherwise -> mdl) mdl coeff_nms++-- | Create specification definitions corresponding to previously rejected models,+-- and add assertions that the new synthesized specification definition must+-- have a different output than the old specifications at at least one point.+-- Because this requires a symbolic point being input into the synthesized function+-- (with symbolic coefficients) this requires (undecidable) non linear arithmetic (NIA).+blockModelWithFuns :: M.Map Name SpecInfo -> String -> SMTModel -> [SMTHeader]+blockModelWithFuns si s mdl =+ let+ e_si = M.elems $ M.filter (\si' -> s_status si' == Synth) si++ vrs = map (uncurry blockVars) $ zip (map (\i -> s ++ "_" ++ show i) ([0..] :: [Integer])) e_si+ var_defs = concatMap varDefs vrs++ si_nsi = map (\(i, si') -> (si', renameByAdding i si'))+ . zip (map (\i -> s ++ "_" ++ show i) ([0..] :: [Integer]))+ $ e_si++ fun_defs = concatMap (defineModelLIAFuns mdl . snd) si_nsi++ eqs = map (\(vs, (si', nsi')) -> mkEqualityAST vs si' nsi') $ zip vrs si_nsi++ neq = [Solver.Assert . (:!) $ mkSMTAnd eqs]+ + in+ var_defs ++ fun_defs ++ neq++----------------------------------------------------------------------------+-- Blocking Models via checking after the fact++-- | Checks that the first model and each model in the list have at least+-- one point that they classifies differently,+-- i.e. for each model in the list, there must be at least one point that is+-- classified as true by that model, but false by the first model (or vice versa.)+-- As opposed to `blockModelWithFuns`, which enforced this as a constraint when+-- synthesizing the new specification, this function acts as a check on a newly+-- synthesized specification.+-- This avoids the need for non linear arithmetic, but allows us to quickly+-- reject newly synthesized specifications that are identical to some previous+-- specifications.+checkModelIsNewFunc :: (MonadIO m, SMTConverter con) => con -> M.Map Name SpecInfo -> SMTModel -> [(ModelNames, SMTModel)] -> m (Maybe (ModelNames, SMTModel))+checkModelIsNewFunc _ _ _ [] = return Nothing+checkModelIsNewFunc con si mdl ((mdl_nm, mdl'):mdls) = do+ b' <- checkModelIsNewFunc' con si mdl mdl'+ case b' of+ True -> checkModelIsNewFunc con si mdl mdls+ False -> do+ liftIO $ do+ putStrLn "Equiv!"+ print mdl_nm+ print mdl+ print mdl'+ putStrLn $ "diff 1 = " ++ show (M.toList mdl' L.\\ M.toList mdl)+ putStrLn $ "diff 2 = " ++ show (M.toList mdl L.\\ M.toList mdl')+ return (Just (mdl_nm, mdl'))++checkModelIsNewFunc' :: (MonadIO m, SMTConverter con) => con -> M.Map Name SpecInfo -> SMTModel -> SMTModel -> m Bool+checkModelIsNewFunc' con si mdl1 mdl2 = do+ let e_si = M.elems $ M.filter (\si' -> s_status si' == Synth) si++ vrs = map (uncurry blockVars) $ zip (map (\i -> "_c_" ++ show i) ([0..] :: [Integer])) e_si+ var_defs = concatMap varDefs vrs++ si_nsi = map (\(i, si') -> (si', renameByAdding i si'))+ . zip (map (\i -> "_c_" ++ show i) ([0..] :: [Integer]))+ $ e_si++ fun_defs1 = concatMap (defineModelLIAFuns mdl1 . fst) si_nsi+ fun_defs2 = concatMap (defineModelLIAFuns mdl2 . snd) si_nsi++ eqs = map (\(vs, (si', nsi')) -> mkEqualityAST vs si' nsi') $ zip vrs si_nsi++ neq = [Solver.Assert . (:!) $ mkSMTAnd eqs]+ + hdrs = arrayConstants si ++ var_defs ++ fun_defs1 ++ fun_defs2 ++ neq++ r <- liftIO $ checkConstraints con hdrs+ case r of+ SAT _ -> return True+ UNSAT _ -> return False+ -- If we get a result of Unknown, we might as well optimistically assume that the model is new+ Unknown _ _ -> do+ liftIO $ putStrLn "checkModelIsNewFunc' unknown result"+ return True++defineModelLIAFuns :: SMTModel -> SpecInfo -> [SMTHeader]+defineModelLIAFuns mdl si =+ let+ fs = L.nubBy (\si1 si2 -> sy_name si1 == sy_name si2)+ $ (extractValues $ s_syn_post si) ++ (concatMap extractValues $ s_syn_pre si)+ in+ if s_status si == Synth+ then map (defineModelLIAFuncSF mdl) fs+ else []++defineModelLIAFuncSF :: SMTModel -> SynthSpec -> SMTHeader+defineModelLIAFuncSF mdl sf = + let+ ars_nm = map smt_var (sy_args_and_ret sf)+ ars = zip ars_nm (map smt_sort $ sy_args_and_ret sf)+ in+ DefineFun (sy_name sf) ars SortBool (buildLIA_SMT_fromModel mdl sf)++renameByAdding :: String -> SpecInfo -> SpecInfo+renameByAdding i si =+ si { s_syn_pre = map (mapPB rn) $ s_syn_pre si+ , s_syn_post = mapPB rn $ s_syn_post si+ }+ where+ rn s = s { sy_name = sy_name s ++ "_MDL_" ++ i }++buildLIA_SMT_fromModel :: SMTModel -> SynthSpec -> SMTAST+buildLIA_SMT_fromModel mdl sf =+ buildSpec (:+) (:*) (.=.) (.=.) (:>) (:>=) Ite Ite+ mkSMTAnd mkSMTAnd mkSMTOr+ mkSMTUnion mkSMTIntersection smtSingleton+ mkSMTIsSubsetOf (flip ArraySelect)+ vint VInt vbool vset+ falseArray+ trueArray+ sf + where+ vint n+ | Just v <- M.lookup n mdl = v+ | otherwise = V n SortInt++ vbool n+ | Just v <- M.lookup n mdl = v+ | otherwise = V n SortBool++ vset n+ | Just v <- M.lookup n mdl = v+ | otherwise = V n (SortArray SortInt SortBool)++smtSingleton :: SMTAST -> SMTAST+smtSingleton mem = ArrayStore falseArray mem (VBool True)++blockVars :: String -> SpecInfo -> ([PolyBound [(SMTName, Sort)]], PolyBound [(SMTName, Sort)])+blockVars str si = ( map (uncurry mk_blk_vars) . zip (map show ([0..] :: [Integer])) $ s_syn_pre si+ , mk_blk_vars "r" $ s_syn_post si)+ where+ mk_blk_vars i sy_s =+ mapPB (\(j, s) -> + map (\(k, sa) ->+ ("x_MDL_" ++ str ++ "_" ++ i ++ "_" ++ show j ++ "_" ++ show k, smt_sort sa))+ . zip ([0..] :: [Integer])+ $ sy_args_and_ret s+ )+ $ zipPB (uniqueIds sy_s) sy_s++varDefs :: ([PolyBound [(SMTName, Sort)]], PolyBound [(SMTName, Sort)]) -> [SMTHeader]+varDefs = map (\(n, srt) -> VarDecl (TB.text . T.pack $ n) srt)+ . concat+ . concatMap extractValues+ . (\(x, y) -> y:x)++mkEqualityAST :: ([PolyBound [(SMTName, Sort)]], PolyBound [(SMTName, Sort)]) -> SpecInfo -> SpecInfo -> SMTAST+mkEqualityAST (avs, rvs) si nsi =+ let+ avs' = map (mapPB (map fst)) avs+ rvs' = mapPB (map fst) rvs++ pre_eq =+ map (mapPB (uncurry3 mkFuncEq) . uncurry3 zip3PB)+ $ zip3 avs' (s_syn_pre si) (s_syn_pre nsi)++ pre_eq' = concatMap extractValues pre_eq++ post_eq =+ mapPB (uncurry3 mkFuncEq) $ zip3PB rvs' (s_syn_post si) (s_syn_post nsi)++ post_eq' = extractValues post_eq+ in+ mkSMTAnd (post_eq' ++ pre_eq')++mkFuncEq :: [SMTName] -> SynthSpec -> SynthSpec -> SMTAST+mkFuncEq vs s_sp ns_sp = + let+ smt_vs = map (flip V SortInt) vs+ in+ Func (sy_name s_sp) smt_vs := Func (sy_name ns_sp) smt_vs++-- Determines which SynthSpecs have been assigned different values in the two models.+determineRelSynthSpecs :: M.Map Name SpecInfo -> SMTModel -> SMTModel -> [SMTName]+determineRelSynthSpecs m_si mdl1 mdl2 =+ let+ diff = M.keys + $ M.differenceWith (\v1 v2 -> case v1 == v2 of+ True -> Nothing+ False -> Just v1) mdl1 mdl2+ in+ map sy_name+ . filter + (\sys -> any (\n -> n `elem` diff) . map fst $ sySpecNamesForModel sys)+ . concatMap allSynthSpec + $ M.elems m_si++-- computing F_{Fixed}, i.e. what is the value of known specifications at known points +envToSMT :: Evals (Integer, Bool) -> M.Map Name SpecInfo -> Int -> FuncConstraints+ -> ([SMTHeader], HM.HashMap SMTName FuncConstraint)+envToSMT evals si fresh fc =+ let+ nm_fc = zip ["f" ++ show i ++ "_" ++ show fresh | i <- ([1..] :: [Integer])]+ . L.nub+ . map fst+ $ allCallsFC fc++ calls = concatMap (uncurry (flip (envToSMT' evals si))) nm_fc++ known_id_calls = map fst calls+ real_calls = map snd calls++ assrts = map Solver.Assert known_id_calls+ + in+ (assrts, HM.fromList real_calls)++envToSMT' :: Evals (Integer, Bool) -> M.Map Name SpecInfo -> FuncCall -> SMTName -> [(SMTAST, (SMTName, FuncConstraint))]+envToSMT' (Evals {pre_evals = pre_ev, post_evals = post_ev}) m_si fc@(FuncCall { funcName = f }) uc_n =+ case M.lookup f m_si of+ Just si ->+ let+ (pre_i, pre_res) = case lookupEvals fc pre_ev of+ Just b -> b+ Nothing -> error "envToSMT': pre not found"++ (post_i, post_res) = case lookupEvals fc post_ev of+ Just b -> b+ Nothing -> error "envToSMT': post not found"++ (pre_op, pre_op_fc) = if pre_res then (id, id) else ((:!), NotFC)+ (post_op, post_op_fc) = if post_res then (id, id) else ((:!), NotFC)++ pre = pre_op $ Func (s_known_pre_name si) [VInt pre_i]+ post = post_op $ Func (s_known_post_name si) [VInt post_i]++ pre_real = pre_op_fc (Call Pre fc [])+ post_real = post_op_fc (Call Post fc [])++ pre_name = "pre_" ++ uc_n+ post_name = "post_" ++ uc_n++ -- In the case that we get an unsat core, we are only interested in knowing which specifications+ -- that have already been chosen must be changed. Thus, we only name those pieeces of the environment.+ named_sp = case s_status si of+ Known -> Named+ _ -> \x _ -> x+ in+ [ (named_sp pre pre_name, (pre_name, pre_real))+ , (named_sp post post_name, (post_name, post_real))]+ Nothing -> error "envToSMT': function not found"++mkRetNonZero :: M.Map Name SpecInfo -> [SMTHeader]+mkRetNonZero = concatMap mkRetNonZero' . filter (\si -> s_status si == Synth) . M.elems++mkRetNonZero' :: SpecInfo -> [SMTHeader]+mkRetNonZero' si =+ let+ sy_sps = allSynthSpec si+ in+ concatMap (\sys ->+ let+ cffs = sy_coeffs sys+ in+ map+ (\(act, cff) ->+ Solver.Assert (((:!) $ V act SortBool)+ :=> + mkSMTOr (concatMap (\c -> mkCoeffRetNonZero c) cff))+ ) cffs+ ) sy_sps++mkCoeffRetNonZero :: Forms -> [SMTAST]+mkCoeffRetNonZero cffs@(LIA {}) =+ let+ act = c_active cffs+ ret_cffs = rets_coeffs cffs+ in+ case null ret_cffs of+ True -> [VBool True]+ False -> + [V act SortBool :=> mkSMTOr (map (\r -> V r SortInt :/= VInt 0) ret_cffs)]+mkCoeffRetNonZero cffs@(Set {}) =+ let+ act = c_active cffs+ ret_bools = concat $ rets_bools_lhs cffs ++ rets_bools_rhs cffs+ in+ case null ret_bools of+ True -> [VBool True]+ False -> + [V act SortBool :=> mkSMTOr (map (\r -> V r SortBool) ret_bools)]+mkCoeffRetNonZero cffs@(BoolForm {}) =+ let+ act = c_active cffs+ ret_bools = rets_bools cffs+ in+ case null ret_bools of+ True -> [VBool True]+ False -> + [V act SortBool :=> mkSMTOr (map (\r -> (:!) (V r SortBool)) ret_bools)]++-- This function aims to limit the number of different models that can be produced+-- that result in equivalent specifications. +-- This is important, because as a fallback when counterexamples are not+-- blocking bad solutions, we instead negate SMT models. So we want as+-- few different, but ultimately equivalent, models as possible.+-- In particualar:+-- (1) If the formula level active booleans are set to false, we force all the+-- coefficients in the formula to be 0, since the formula is now irrelevant.+-- (2) Similarly, if the clause level boolean is set to true, we force all the+-- formula level active booleans to be false, since the formulas are+-- irrelevant.+-- (3) If the n^th "or" is deactivated (by it's boolean being true),+-- then the n + 1^th "or" must also be deactivated +-- (4) If the n^th "and" is deactivated (by it's boolean being false),+-- then the n + 1^th "and" must also be deactivated +limitEquivModels :: M.Map Name SpecInfo -> [SMTHeader]+limitEquivModels m_si =+ let+ a_si = filter (\si -> s_status si == Synth) $ M.elems m_si+ -- (1)+ clauses = concatMap allCNFs a_si+ cl_imp_coeff = concatMap+ (\(cl_act, cff) ->+ map (\cf -> V cl_act SortBool :=> ((:!) $ V (c_active cf) SortBool)) cff+ ) clauses ++ -- (2)+ cffs = concatMap snd clauses+ coeff_act_imp_zero = concatMap+ (\cf ->+ map (\c -> ((:!) $ V (c_active cf) SortBool) :=> (V c SortInt := VInt 0)) (coeffs cf)+ ) cffs++ -- (3)+ or_acts = map (map (map fst) . allCNFsSeparated) a_si :: [[[SMTName]]]+ or_neighbors_deact =+ concatMap + (concatMap + (map (\(n1, n2) -> ((:!) $ V n2 SortBool) :=> ((:!) $ V n1 SortBool)) . neighbors)+ ) $ or_acts++ -- (4)+ and_neighbors_deact = and_block (\case LIA {} -> True; _ -> False) a_si+ ++ and_block (\case Set {} -> True; _ -> False) a_si+ in+ map Solver.Assert $ cl_imp_coeff ++ coeff_act_imp_zero -- ++ or_neighbors_deact ++ and_neighbors_deact+ where+ neighbors [] = []+ neighbors [_] = []+ neighbors (x:xs@(y:_)) = (x, y):neighbors xs++ and_block p a_si' = + let+ and_acts = concatMap (map (map snd) . allCNFsSeparated) a_si'+ in+ concatMap + (concatMap + ( mapMaybe + (\(n1, n2) -> if p n1 && p n2+ then Just (V (c_active n2) SortBool :=> V (c_active n1) SortBool)+ else Nothing)+ . neighbors+ )+ ) $ and_acts++softCoeffAssertZero :: M.Map Name SpecInfo -> [SMTHeader]+softCoeffAssertZero = map (\n -> AssertSoft (V n SortInt := VInt 0) (Just "minimal_size")) . getCoeffs++softFuncActAssertZero :: M.Map Name SpecInfo -> [SMTHeader]+softFuncActAssertZero = map (\n -> AssertSoft ((:!) $ V n SortBool) (Just "minimal_size")) . getFuncActs++softClauseActAssertZero :: M.Map Name SpecInfo -> [SMTHeader]+softClauseActAssertZero = map (\n -> AssertSoft (V n SortBool) (Just "minimal_size")) . getClauseActs++maxCoeffConstraints :: M.Map Name SpecInfo -> [SMTHeader]+maxCoeffConstraints = maxCoeffConstraints' Solver.Assert s_max_coeff++softCoeffConstraints :: M.Map Name SpecInfo -> [SMTHeader]+softCoeffConstraints = maxCoeffConstraints' (flip Solver.AssertSoft (Just "coeff")) (const 1)++maxCoeffConstraints' :: (SMTAST -> SMTHeader) -> (SpecInfo -> Integer) -> M.Map Name SpecInfo -> [SMTHeader]+maxCoeffConstraints' to_header max_c =+ map to_header+ . concatMap+ (\si ->+ let+ cffs = concatMap coeffs . concatMap snd $ allPreCoeffs si ++ allPostCoeffs si+ in+ if s_status si == Synth+ then map (\c -> (Neg (VInt (max_c si)) :<= V c SortInt)+ .&&. (V c SortInt :<= VInt (max_c si))) cffs+ else []) . M.elems++softSetConstraints :: M.Map Name SpecInfo -> [SMTHeader]+softSetConstraints =+ map (\n -> AssertSoft ((:!) (V n SortBool)) (Just "minimal_sets")) . getSetBools++arrayConstants :: M.Map Name SpecInfo -> [SMTHeader]+arrayConstants si =+ let+ frms = concatMap allForms $ M.elems si+ in+ if any (\case Set {} -> True; _ -> False) frms+ then+ [ VarDecl (TB.text "true_array") (SortArray SortInt SortBool)+ , Solver.Assert (trueArray := (mkSMTUniversalArray SortInt SortBool))+ , VarDecl (TB.text "false_array") (SortArray SortInt SortBool)+ , Solver.Assert (falseArray := (mkSMTEmptyArray SortInt SortBool))]+ else []++trueArray :: SMTAST+trueArray = V "true_array" (SortArray SortInt SortBool)++falseArray :: SMTAST+falseArray = V "false_array" (SortArray SortInt SortBool)++nonMaxCoeffConstraints :: (InfConfigM m, ProgresserM m) => [GhcInfo] -> NMExprEnv -> TypeEnv -> Measures -> MeasureExs -> Evals Bool -> M.Map Name SpecInfo -> FuncConstraints+ -> m ([SMTHeader], HM.HashMap SMTName FuncConstraint)+nonMaxCoeffConstraints ghci eenv tenv meas meas_ex evals m_si fc = do+ synth_fresh <- synthFreshM+ incrSynthFreshM+ let evals' = assignIds evals+ + all_acts = getActs m_si+ all_coeffs = getCoeffs m_si+ all_set_bools = getSetBools m_si+ all_bool_bools = getBoolBools m_si+ get_ops = getOpBranches m_si++ var_act_hdrs = map (flip VarDecl SortBool . TB.text . T.pack) $ L.nub all_acts+ var_int_hdrs = map (flip VarDecl SortInt . TB.text . T.pack) $ L.nub all_coeffs+ var_bool_set_hdrs = map (flip VarDecl SortBool . TB.text . T.pack) $ L.nub all_set_bools+ var_bool_bool_hdrs = map (flip VarDecl SortBool . TB.text . T.pack) $ L.nub all_bool_bools+ var_op_hdrs = map (flip VarDecl SortBool . TB.text . T.pack) $ L.nub get_ops++ def_funs = concatMap defineLIAFuns $ M.elems m_si+ (env_smt, nm_fc) = envToSMT evals' m_si synth_fresh fc++ ret_is_non_zero = mkRetNonZero m_si++ lim_equiv_smt = limitEquivModels m_si++ poly_access = polyAccessConstraints2 ghci meas m_si+ + fc_smt <- constraintsToSMT eenv tenv meas meas_ex evals' m_si fc++ return+ ( var_act_hdrs+ ++ var_int_hdrs+ ++ var_bool_set_hdrs+ ++ var_bool_bool_hdrs+ ++ var_op_hdrs+ ++ def_funs+ ++ [Comment "encode specification constraints"]+ ++ fc_smt+ ++ [Comment "encode the environment"]+ ++ env_smt + ++ [Comment "force return values to be nonzero"]+ ++ ret_is_non_zero + ++ [Comment "block equivalent formulas"]+ ++ lim_equiv_smt+ ++ [Comment "polymorphic access constraints"]+ ++ poly_access+ , nm_fc)++constraintsToSMT :: (InfConfigM m, ProgresserM m) =>+ NMExprEnv+ -> TypeEnv+ -> Measures+ -> MeasureExs+ -> Evals (Integer, Bool)+ -> M.Map Name SpecInfo+ -> FuncConstraints+ -> m [SMTHeader]+constraintsToSMT eenv tenv meas meas_ex evals si fc =+ return . map (Solver.Assert) =<<+ convertConstraints + convertExprToSMT+ (ifNotNull mkSMTAnd (VBool True))+ (ifNotNull mkSMTOr (VBool False))+ (:!)+ (:=>)+ Func+ (\n i _ -> Func n [VInt i])+ (\n i _ -> Func n [VInt i])+ eenv tenv meas meas_ex evals si fc+ where+ ifNotNull _ def [] = def+ ifNotNull f _ xs = f xs++convertExprToSMT :: G2.Expr -> SMTAST+convertExprToSMT e = + case e of+ (App (App (Data (DataCon _ _)) _) ls)+ | Just is <- extractInts ls ->+ foldr (\i arr -> ArrayStore arr (VInt i) (VBool True)) falseArray is+ _ -> exprToSMT e++extractInts :: G2.Expr -> Maybe [Integer]+extractInts (App (App (App (Data _ ) (Type _)) (App _ (Lit (LitInt i)))) xs) =+ return . (i:) =<< extractInts xs+extractInts (App (Data _) _) = Just []+extractInts _ = Nothing++---++getCoeffs :: M.Map Name SpecInfo -> [SMTName]+getCoeffs = concatMap siGetCoeffs . M.elems++sySpecGetCoeffsNoB :: SynthSpec -> [SMTName]+sySpecGetCoeffsNoB = concatMap coeffsNoB . concatMap snd . sy_coeffs++siGetCoeffs :: SpecInfo -> [SMTName]+siGetCoeffs si+ | s_status si == Synth = concatMap sySpecGetCoeffs $ allSynthSpec si+ | otherwise = []++sySpecGetCoeffs :: SynthSpec -> [SMTName]+sySpecGetCoeffs = concatMap coeffs . concatMap snd . sy_coeffs++getSetBools :: M.Map Name SpecInfo -> [SMTName]+getSetBools = concatMap siGetSetBools . M.elems++siGetSetBools :: SpecInfo -> [SMTName]+siGetSetBools si+ | s_status si == Synth = concatMap sySpecGetSetBools $ allSynthSpec si+ | otherwise = []++sySpecGetSetBools :: SynthSpec -> [SMTName]+sySpecGetSetBools = concatMap setBools . concatMap snd . sy_coeffs++getBoolBools :: M.Map Name SpecInfo -> [SMTName]+getBoolBools = concatMap siGetBoolBools . M.elems ++siGetBoolBools :: SpecInfo -> [SMTName]+siGetBoolBools si+ | s_status si == Synth = concatMap sySpecGetBoolBools $ allSynthSpec si+ | otherwise = []++sySpecGetBoolBools :: SynthSpec -> [SMTName]+sySpecGetBoolBools = concatMap boolBools . concatMap snd . sy_coeffs++---++getOpBranches:: M.Map Name SpecInfo -> [SMTName]+getOpBranches = concatMap siGetOpBranches . M.elems++siGetOpBranches :: SpecInfo -> [SMTName]+siGetOpBranches si+ | s_status si == Synth =+ concatMap sySpecGetOpBranches $ allSynthSpec si+ | otherwise = []++sySpecGetOpBranches :: SynthSpec -> [SMTName]+sySpecGetOpBranches = concatMap sySpecGetOpBranchesForm . concatMap snd . sy_coeffs++sySpecGetOpBranchesForm :: Forms -> [SMTName]+sySpecGetOpBranchesForm c@(BoolForm {}) =+ [c_op_branch1 c, c_op_branch2 c] ++ concatMap sySpecGetOpBranchesForm (forms c)+sySpecGetOpBranchesForm c = [c_op_branch1 c, c_op_branch2 c]+---++sySpecGetActs :: SynthSpec -> [SMTName]+sySpecGetActs sys = sySpecGetClauseActs sys ++ sySpecGetFuncActs sys++sySpecGetClauseActs :: SynthSpec -> [SMTName]+sySpecGetClauseActs = map fst . sy_coeffs++sySpecGetFuncActs :: SynthSpec -> [SMTName]+sySpecGetFuncActs = concatMap formActives . concatMap snd . sy_coeffs++getActs :: M.Map Name SpecInfo -> [SMTName]+getActs si = getClauseActs si ++ getFuncActs si++getClauseActs :: M.Map Name SpecInfo -> [SMTName]+getClauseActs m_si =+ concatMap siGetClauseActs $ M.elems m_si++siGetClauseActs :: SpecInfo -> [SMTName]+siGetClauseActs si+ | s_status si == Synth = map fst $ allCNFs si+ | otherwise = []++getFuncActs :: M.Map Name SpecInfo -> [SMTName]+getFuncActs m_si =+ concatMap siGetFuncActs $ M.elems m_si++siGetFuncActs :: SpecInfo -> [SMTName]+siGetFuncActs si+ | s_status si == Synth = concatMap formActives . concatMap snd $ allCNFs si+ | otherwise = []++formActives :: Forms -> [SMTName]+formActives cffs@(BoolForm {}) = c_active cffs:concatMap formActives (forms cffs)+formActives cffs = [c_active cffs]++defineLIAFuns :: SpecInfo -> [SMTHeader]+defineLIAFuns si =+ (if s_status si == Synth+ then+ let+ funcs = L.nubBy (\si1 si2 -> sy_name si1 == sy_name si2)+ $ (extractValues $ s_syn_post si) ++ (concatMap extractValues $ s_syn_pre si)+ in+ map defineSynthLIAFuncSF funcs+ else [])+ +++ [ defineFixedLIAFuncSF (s_known_pre si)+ , defineFixedLIAFuncSF (s_known_post si)+ , defineToBeFuncSF (s_to_be_pre si)+ , defineToBeFuncSF (s_to_be_post si)]++defineFixedLIAFuncSF :: FixedSpec -> SMTHeader+defineFixedLIAFuncSF fs =+ DeclareFun (fs_name fs) [SortInt] SortBool++defineToBeFuncSF :: ToBeSpec -> SMTHeader+defineToBeFuncSF tb =+ DeclareFun (tb_name tb) [SortInt] SortBool++defineSynthLIAFuncSF :: SynthSpec -> SMTHeader+defineSynthLIAFuncSF sf = + let+ ars_nm = map smt_var (sy_args_and_ret sf)+ ars = zip ars_nm (map smt_sort $ sy_args_and_ret sf)+ in+ DefineFun (sy_name sf) ars SortBool (buildLIA_SMT sf)++------------------------------------+-- Building LIA Formulas+------------------------------------++type Plus a = a -> a -> a+type Mult a = a -> a -> a+type EqF a b = a -> a -> b+type Gt a b = a -> a -> b+type GEq a b = a -> a -> b+type Ite b a = b -> a -> a -> a+type And b c = [b] -> c+type Or b = [b] -> b++type IsSubsetOf a b = a -> a -> b+type IsMember a b = a -> a -> b++type Union a = a -> a -> a+type Intersection a = a -> a -> a++type Singleton a = a -> a++type VInt a = SMTName -> a+type CInt a = Integer -> a+type VBool b = SMTName -> b+type VSet s = SMTName -> s+type EmptySet s = s+type UniversalSet s = s++buildLIA_SMT :: SynthSpec -> SMTAST+buildLIA_SMT sf =+ buildSpec (:+) (:*) (.=.) (.=.) (:>) (:>=) Ite Ite+ mkSMTAnd mkSMTAnd mkSMTOr mkSMTUnion mkSMTIntersection smtSingleton+ mkSMTIsSubsetOf (flip ArraySelect)+ (flip V SortInt) VInt (flip V SortBool) (flip V $ SortArray SortInt SortBool)+ falseArray+ trueArray+ sf++-- Get a list of all LIA formulas. We raise these as high in a PolyBound as possible,+-- because checking leaves is more expensive. Also, checking leaves only happens if those+-- leaves exists, i.e. consider a refinement on the elements of a list [{x:a | p x}],+-- p is only checked in the nonempty case.+buildLIA_LH :: SpecInfo -> SMTModel -> [PolyBound LHF.Expr]+buildLIA_LH si mv = map (mapPB pAnd) {- . map (uncurry raiseSpecs) . zip synth_specs -} $ buildLIA_LH' si mv+ where+ pAnd xs =+ case any (== PFalse) xs of+ True -> PFalse+ False -> PAnd $ filter (/= PTrue) xs++buildLIA_LH' :: SpecInfo -> SMTModel -> [PolyBound [LH.Expr]]+buildLIA_LH' si mv =+ let+ post_ars = allPostSpecArgs si++ build ars = buildSpec ePlus eTimes+ bEq bIff bGt bGeq+ eIte eIte id+ pAnd pOr+ eUnion eIntersection eSingleton+ bIsSubset bIsMember+ (detVar ars) (ECon . I) (detBool ars)+ (detSet ars) eEmptySet eUnivSet+ pre = map (mapPB (\psi -> build (all_sy_args_and_ret psi) psi)) $ s_syn_pre si+ post = mapPB (build post_ars) $ s_syn_post si+ in+ pre ++ [post]+ where+ detVar ars v + | Just (VInt c) <- M.lookup v mv = ECon (I c)+ | Just sa <- L.find (\sa_ -> v == smt_var sa_) ars = lh_rep sa+ | otherwise = error "detVar: variable not found"++ detBool ars v+ | Just (VBool b) <- M.lookup v mv = if b then PTrue else PFalse+ | Just sa <- L.find (\sa_ -> v == smt_var sa_) ars = lh_rep sa+ | otherwise = error $ "detBool: variable not found" ++ " " ++ show v ++ "\nars = " ++ show ars++ detSet ars v+ | Just sa <- L.find (\sa_ -> v == smt_var sa_) ars = lh_rep sa+ | otherwise = error "detSet: variable not found"++ eTimes (ECon (I 0)) _ = ECon (I 0)+ eTimes _ (ECon (I 0)) = ECon (I 0)+ eTimes (ECon (I 1)) x = x+ eTimes x (ECon (I 1)) = x+ eTimes (ECon (I (-1))) x = ENeg x+ eTimes x (ECon (I (-1))) = ENeg x+ eTimes x y = EBin LH.Times x y++ ePlus (ECon (I 0)) x = x+ ePlus x (ECon (I 0)) = x+ ePlus x (ENeg y) = EBin LH.Minus x y+ ePlus (ENeg x) y = EBin LH.Minus y x+ ePlus (ENeg x) y = EBin LH.Minus y x+ ePlus x (EBin LH.Times (ECon (I i)) y) | i < 0 = EBin LH.Minus x (EBin LH.Times (ECon (I $ - i)) y)+ ePlus (EBin LH.Times (ECon (I i)) x) y | i < 0 = EBin LH.Minus y (EBin LH.Times (ECon (I $ - i)) x)+ ePlus x y = EBin LH.Plus x y++ eIte PTrue x _ = x+ eIte PFalse _ y = y+ eIte _ _ _ = error "eIte: Should never have non-concrete bool"++ pAnd xs =+ case any (== PFalse) xs of+ True -> PFalse+ False -> PAnd $ filter (/= PTrue) xs++ pOr xs =+ case any (== PTrue) xs of+ True -> PTrue+ False -> POr $ filter (/= PFalse) xs++ bEq (ECon (I x)) (ECon (I y)) =+ if x == y then PTrue else PFalse+ bEq x y+ | x == y = PTrue+ | x == eUnivSet+ , y == eUnivSet = PTrue+ | x == eUnivSet || y == eUnivSet = PFalse+ | EBin LH.Minus e1 e2 <- x+ , ECon (I 0) <- y = PAtom LH.Eq e1 e2+ | otherwise = PAtom LH.Eq x y++ bIff x y+ | x == y = PTrue+ | otherwise = PIff x y+++ bGt (ECon (I x)) (ECon (I y)) =+ if x > y then PTrue else PFalse+ bGt x y+ | x == y = PFalse+ | EBin LH.Minus e1 e2 <- x+ , ECon (I 0) <- y = PAtom LH.Gt e1 e2+ | otherwise = PAtom LH.Gt x y++ bGeq (ECon (I x)) (ECon (I y)) =+ if x >= y then PTrue else PFalse+ bGeq x y+ | x == y = PTrue+ | EBin LH.Minus e1 e2 <- x+ , ECon (I 0) <- y = PAtom LH.Ge e1 e2+ | otherwise = PAtom LH.Ge x y++ eUnion x y+ | x == eEmptySet = y+ | y == eEmptySet = x+ | x == eUnivSet = eUnivSet+ | y == eUnivSet = eUnivSet+ | x == y = x+ | otherwise = EApp (EApp (EVar "Set_cup") x) y+ + eIntersection x y+ | x == eUnivSet = y+ | y == eUnivSet = x+ | x == eEmptySet = eEmptySet+ | y == eEmptySet = eEmptySet+ | x == y = x+ | otherwise = EApp (EApp (EVar "Set_cap") x) y++ eSingleton = EApp (EVar "Set_sng")++ bIsSubset x y+ | x == eEmptySet = PTrue+ | y == eUnivSet = PTrue+ | x == eUnivSet = PFalse+ | x == y = PTrue+ | otherwise = EApp (EApp (EVar "Set_sub") x) y++ bIsMember x y+ | y == eEmptySet = PFalse+ | y == eUnivSet = PTrue+ | otherwise = EApp (EApp (EVar "Set_mem") x) y++ eEmptySet = EApp (EVar "Set_empty") (ECon (I 0))+ eUnivSet = EVar ("Set_univ")++buildSpec :: Show b => Plus a+ -> Mult a+ -> EqF a b+ -> EqF b b+ -> Gt a b+ -> GEq a b+ -> Ite b b + -> Ite b a+ -> And b c+ -> And b b+ -> Or b++ -> Union a+ -> Intersection a+ -> Singleton a+ -> IsSubsetOf a b+ -> IsMember a b++ -> VInt a+ -> CInt a+ -> VBool b+ -> VSet a+ -> EmptySet a+ -> UniversalSet a+ -> SynthSpec+ -> c+buildSpec plus mult eq eq_bool gt geq ite ite_set mk_and_sp mk_and mk_or mk_union mk_intersection mk_sing is_subset is_member vint cint vbool vset cemptyset cunivset sf =+ let+ all_coeffs = sy_coeffs sf+ lin_ineqs = map (\(cl_act, cl) -> vbool cl_act:map toLinInEqs cl) all_coeffs+ in+ mk_and_sp . map mk_or $ lin_ineqs+ where+ int_args = map smt_var (int_sy_args_and_ret sf)+ set_args = map smt_var (set_sy_args_and_ret sf)+ bool_args = map smt_var (bool_sy_args_and_ret sf)++ toLinInEqs (LIA { c_active = act+ , c_op_branch1 = op_br1+ , c_op_branch2 = op_br2+ , b0 = b+ , ars_coeffs = acs+ , rets_coeffs = rcs }) =+ let+ sm = lia_form acs rcs+ in+ mk_and [vbool act, ite (vbool op_br1)+ (sm `eq` vint b)+ (ite (vbool op_br2) (sm `gt` vint b)+ (sm `geq` vint b)+ )+ ]+ toLinInEqs (Set { c_active = act++ , int_sing_set_bools_lhs = int_sing_bools_lhs+ , int_sing_set_bools_rhs = int_sing_bools_rhs++ , ars_bools_lhs = ars_b1+ , rets_bools_lhs = rets_b1+ , ars_bools_rhs = ars_b2+ , rets_bools_rhs = rets_b2 }) =+ let+ sm1 = set_form ars_b1 rets_b1 int_sing_bools_lhs+ sm2 = set_form ars_b2 rets_b2 int_sing_bools_rhs+ in+ mk_and [vbool act, sm1 `eq` sm2]+ toLinInEqs (BoolForm { c_active = act+ , ars_bools = as+ , rets_bools = rs+ , forms = frms }) =+ let+ bb = zipWith (\x y -> mk_or [x, y]) (map vbool $ as ++ rs) (map vbool bool_args)+ in+ mk_and [vbool act, mk_and bb `eq_bool` mk_and (map toLinInEqs frms)]++ lia_form acs rcs = foldr plus (cint 0)+ . map (uncurry mult)+ $ zip (map vint $ acs ++ rcs) (map vint int_args)++ set_form ars rts is_bools =+ let+ sets = map vset set_args+ ars_rts = map (map vbool) $ zipWith (++) ars rts++ ite_sets = map (zipWith (\s a -> ite_set a s cunivset) sets) ars_rts+ + ints = map vint int_args+ ite_sing_sets = map (:[]) $ map (foldr (\(i, b) -> ite_set (vbool b) (mk_sing i)) cunivset . zip ints) is_bools -- map (zipWith (\s a -> ite_set (vbool a) (mk_sing s) cunivset) ints) is_bools+ + ite_sets' = if not (null ite_sing_sets)+ then zipWith (++) ite_sets ite_sing_sets+ else ite_sets+ in+ if not (null ite_sets') && any (not . null) ite_sets'+ then foldr1 mk_union+ . map (foldr1 mk_intersection)+ $ ite_sets'+ else cemptyset+ -- foldr mk_union cemptyset+ -- . map (\(b, s) -> ite_set b s cemptyset)+ -- $ zip (map vbool $ ars ++ rts) (map vset set_args)+++----------------------------------------------------------------------------+-- Polymorphic access measures+-- A measure is a polymorphic access measure if it returns a value of a polymorphic type.+-- For example, `fst :: (a, b) -> a`.+-- Specifications that use both tuple style specs i.e. ( {x:Int > 0 }, Int)+-- and measure style specs i.e. { t:(Int, Int) | fst t > 0 } together can cause strange+-- errors from LH. Thus, we add softer assertions to, when possible,+-- avoid using polymorphic access measures.++polyAccessConstraints2 :: [GhcInfo] -> Measures -> M.Map Name SpecInfo -> [SMTHeader]+polyAccessConstraints2 ghci meas =+ let+ pa_meas = getPolyAccessMeasures ghci meas+ in+ map (flip AssertSoft Nothing)+ . polyAccessConstraints2' pa_meas+ . M.filter (\si -> s_status si == Synth)++polyAccessConstraints2' :: [(LH.Symbol, Type, Type)] -> M.Map Name SpecInfo -> [SMTAST]+polyAccessConstraints2' meas = concatMap (polyAccessConstraints2'' meas) . M.elems++polyAccessConstraints2'' :: [(LH.Symbol, Type, Type)] -> SpecInfo -> [SMTAST]+polyAccessConstraints2'' meas si =+ let+ poly = allSynthSpecPoly si+ in+ concatMap (polyAccessConstraints2''' meas) $ concatMap extractValues poly++polyAccessConstraints2''' :: [(LH.Symbol, Type, Type)] -> SynthSpec -> [SMTAST]+polyAccessConstraints2''' meas sys =+ let+ cffs = sySpecGetCoeffsNoB sys+ ars_cffs =+ if not (null (sy_args sys)) || not (null (sy_rets sys))+ then zip (cycle (sy_args sys ++ sy_rets sys)) cffs+ else []+ in+ concatMap (\(sy, c) -> if usesPolyAcc (lh_rep sy)+ then [V c SortInt := VInt 0]+ else []) ars_cffs+ where+ meas' = map (\(m, _, _) -> m) meas++ usesPolyAcc (EApp (EVar lh) e) = lh `elem` meas' || usesPolyAcc e+ usesPolyAcc _ = False++getPolyAccessMeasures :: [GhcInfo] -> Measures -> [(LH.Symbol, Type, Type)]+getPolyAccessMeasures ghci =+ map (\(n, at, rt) -> (getLHMeasureName ghci n, at, rt)) + . mapMaybe (\(n, (t:ts, rt)) -> if null ts then Just (n, t, rt) else Nothing)+ . HM.toList+ . E.map' (\e -> (filter (not . isLHDict) $ anonArgumentTypes e, returnType e))+ . E.filter (isTyVar . returnType)+ where+ isLHDict t+ | (TyCon (Name n _ _ _) _):_ <- unTyApp t = n == "lh"+ | otherwise = False++----------------------------------------------------------------------------++-- Helpers for SynthInfo+allSynthSpec :: SpecInfo -> [SynthSpec]+allSynthSpec si = allPreSynthSpec si ++ allPostSynthSpec si++allPreSynthSpec :: SpecInfo -> [SynthSpec]+allPreSynthSpec = concatMap extractValues . s_syn_pre++allPostSynthSpec :: SpecInfo -> [SynthSpec]+allPostSynthSpec = extractValues . s_syn_post++allSynthSpecPoly :: SpecInfo -> [PolyBound SynthSpec]+allSynthSpecPoly si = s_syn_pre si ++ [s_syn_post si]++allCNFs :: SpecInfo -> CNF+allCNFs si = allPreCoeffs si ++ allPostCoeffs si++allPreCoeffs :: SpecInfo -> CNF+allPreCoeffs = concatMap sy_coeffs . allPreSynthSpec++allPostCoeffs :: SpecInfo -> CNF+allPostCoeffs = concatMap sy_coeffs . allPostSynthSpec++allPostSpecArgs :: SpecInfo -> [SpecArg]+allPostSpecArgs = concatMap sy_args_and_ret . allPostSynthSpec++allCNFsSeparated :: SpecInfo -> [CNF]+allCNFsSeparated si = allPreCoeffsSeparated si ++ allPostCoeffsSeparated si++allPreCoeffsSeparated :: SpecInfo -> [CNF]+allPreCoeffsSeparated = map sy_coeffs . allPreSynthSpec++allPostCoeffsSeparated :: SpecInfo -> [CNF]+allPostCoeffsSeparated = map sy_coeffs . allPostSynthSpec++allForms :: SpecInfo -> [Forms]+allForms = concatMap allFormsFromForm+ . concatMap snd+ . allCNFs++allFormsFromForm :: Forms -> [Forms]+allFormsFromForm frm@(BoolForm { forms = frms }) = frm:concatMap allFormsFromForm frms+allFormsFromForm frm = [frm]
+ src/G2/Liquid/Inference/Sygus/RefSynth.hs view
@@ -0,0 +1,1531 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module G2.Liquid.Inference.Sygus.RefSynth ( -- refSynth+ + -- , grammar+ -- , intRuleList+ -- , boolRuleList++ -- , intSort+ -- , boolSort++ -- , termToLHExpr++ -- , runCVC4+ -- , runCVC4Stream+ ) where++-- import G2.Language.Expr+-- import qualified G2.Language.ExprEnv as E+-- import G2.Language.Naming+-- import G2.Language.Support+-- import G2.Language.Syntax as G2+-- import G2.Language.TypeClasses+-- import G2.Language.Typing+-- import G2.Liquid.Conversion+-- import G2.Liquid.Helpers+-- import G2.Liquid.Interface+-- import G2.Liquid.Types+-- import G2.Liquid.Inference.Config+-- import G2.Liquid.Inference.FuncConstraint+-- import G2.Liquid.Inference.G2Calls+-- import G2.Liquid.Inference.GeneratedSpecs+-- import G2.Liquid.Inference.PolyRef+-- import G2.Liquid.Inference.Sygus.SimplifySygus+-- import G2.Liquid.Inference.Sygus.UnsatCoreElim++-- import Sygus.LexSygus+-- import Sygus.ParseSygus+-- import Sygus.Print+-- import Sygus.Syntax as Sy+-- import Language.Haskell.Liquid.Types as LH+-- import Language.Haskell.Liquid.Types.RefType+-- import Language.Fixpoint.Types.Constraints+-- import Language.Fixpoint.Types.Refinements as LH+-- import qualified Language.Fixpoint.Types as LH+-- import qualified Language.Fixpoint.Types as LHF++-- import Control.Exception+-- import Control.Monad.IO.Class+-- import qualified Control.Monad.State as S+-- import Data.Coerce+-- import Data.List+-- import Data.Hashable+-- import qualified Data.HashMap.Lazy as HM+-- import qualified Data.HashSet as HS+-- import qualified Data.Map as M+-- import Data.Maybe+-- import Data.Monoid+-- import Data.Ratio+-- import qualified Data.Text as T+-- import Data.Tuple+-- import Data.Tuple.Extra+-- import System.Directory+-- import System.IO+-- import System.IO.Temp+-- import qualified System.Process as P++-- import TyCon+-- import qualified Var as V++-- import Debug.Trace++-- refSynth :: (InfConfigM m, MonadIO m) => [GhcInfo] -> LiquidReadyState -> MeasureExs+-- -> FuncConstraints -> Name -> m (Maybe ([PolyBound LH.Expr], [Qualifier]))+-- refSynth ghci lrs meas_ex fc n@(Name n' _ _ _) = undefined -- do+{-+ let eenv = expr_env . state $ lr_state lrs+ tc = type_classes . state $ lr_state lrs++ fc_of_n = lookupFC n fc+ fspec = case genSpec ghci n of+ Just spec' -> spec'+ _ -> error $ "synthesize: No spec found for " ++ show n+ e = case E.occLookup (nameOcc n) (nameModule n) eenv of+ Just e' -> e'+ Nothing -> error $ "synthesize: No expr found"++ meas = lrsMeasures ghci lrs++ liftIO . print $ "Synthesize spec for " ++ show n+ let tcemb = foldr (<>) mempty $ map (gsTcEmbeds . spec) ghci+ refSynth' fspec e tc meas meas_ex fc_of_n (measureSymbols ghci) tcemb++refSynth' :: (InfConfigM m, MonadIO m) => SpecType -> G2.Expr -> TypeClasses -> Measures+ -> MeasureExs -> [FuncConstraint] -> MeasureSymbols -> LH.TCEmb TyCon -> m (Maybe ([PolyBound LH.Expr], [Qualifier]))+refSynth' spc e tc meas meas_ex fc meas_sym tycons = do+ infconfig <- infConfigM+ liftIO $ do+ putStrLn "refSynth"+ let (call, f_num, arg_pb, ret_pb) = sygusCall e tc meas meas_ex fc+ s_call = nub+ . simplifyNegatedAnds+ . simplifyImpliesExistentials+ . elimNegatedExistential+ . simplifyImpliesLHS+ . splitAnds+ . elimRedundantAnds $ call+ (es_dt, s_call2) = elimSimpleDTs s_call+ no_unsat_call = unsatCoreElim s_call2++ let sygus = printSygus no_unsat_call+ putStrLn . T.unpack $ sygus++ res <- runCVC4 infconfig (T.unpack sygus)+ -- res <- runCVC4StreamSolutions infconfig f_num (T.unpack sygus)++ case res of+ Left _ -> do+ putStrLn "Timeout"+ return Nothing+ -- error "refSynth: Bad call to CVC4"+ Right smt_st -> do+ let smt_st' = restoreSimpleDTs es_dt smt_st++ putStrLn . T.unpack $ printSygus smt_st'++ let lh_st = refToLHExpr spc arg_pb ret_pb smt_st' meas_sym+ lh_quals = refToQualifiers spc arg_pb ret_pb smt_st' meas_sym tycons++ print lh_st+ print lh_quals++ return $ Just (lh_st, lh_quals)++-------------------------------+-- Constructing Sygus Formula+-------------------------------++sygusCall :: G2.Expr -> TypeClasses -> Measures -> MeasureExs -> [FuncConstraint] -> ([Cmd], Int, [RefNamePolyBound], RefNamePolyBound)+sygusCall e tc meas meas_ex fcs@(_:_) =+ let+ -- Figure out what measures we need to/can consider+ (arg_ty_c, ret_ty_c, ex_ty_c) = generateRelTypes tc e+ func_ty_c = arg_ty_c ++ [ret_ty_c]+ all_ty_c = func_ty_c ++ ex_ty_c++ rel_arg_ty_c = filter relTy arg_ty_c+ rel_fcs = map (relArgs tc arg_ty_c) fcs++ sorts = typesToSort meas meas_ex all_ty_c++ declare_dts = sortsToDeclareDTs sorts++ (grams, cons, arg_pb, ret_pb) = generateGrammarsAndConstraints sorts meas_ex rel_arg_ty_c ret_ty_c rel_fcs++ call = [ SmtCmd (SetLogic "ALL")]+ +++ declare_dts+ +++ [ safeModDecl+ , clampIntDecl clampUpper+ , clampDoubleDecl clampUpper ]+ +++ grams+ +++ cons+ +++ [ CheckSynth ]+ in+ (call, length grams, arg_pb, ret_pb)+sygusCall _ _ _ _ _ = error "sygusCall: empty list"++applicableMeasures :: Measures -> Type -> [Name]+applicableMeasures meas t =+ E.keys $ E.filter (applicableMeasure t) meas ++applicableMeasure :: Type -> G2.Expr -> Bool+applicableMeasure t e =+ let+ te = filter notLH . argumentTypes . PresType . inTyForAlls $ typeOf e+ in+ case te of+ [te'] -> PresType t .:: te'+ _ -> False+ where+ notLH ty+ | TyCon (Name n _ _ _) _ <- tyAppCenter ty = n /= "lh"+ | otherwise = False++generateGrammarsAndConstraints :: TypesToSorts -> MeasureExs -> [Type] -> Type -> [FuncConstraint] -> ([Cmd], [Cmd], [RefNamePolyBound], RefNamePolyBound)+generateGrammarsAndConstraints sorts meas_ex arg_tys ret_ty fcs@(fc:_) =+ let+ ret_names = refinementNames "ret" (typeOf . returns $ constraint fc)+ ret_gram_cmds = generateGrammars extGrammar sorts ret_names meas_ex arg_tys ret_ty++ arg_names_grams = generateParamRefGrammars fc sorts meas_ex arg_tys+ (arg_names, arg_grams_cmds) = unzip arg_names_grams++ cons = generateConstraints sorts meas_ex arg_names ret_names arg_tys ret_ty fcs+ in+ (concat arg_grams_cmds ++ ret_gram_cmds, cons, arg_names, ret_names)++refinementNames :: String -> G2.Type -> RefNamePolyBound+refinementNames prefix t =+ let+ poly_bd = extractTypePolyBound t+ in+ mapPB (\i -> prefix ++ "_refinement_" ++ show i) $ uniqueIds poly_bd++generateParamRefGrammars :: FuncConstraint -> TypesToSorts -> MeasureExs -> [Type] -> [(RefNamePolyBound, [Cmd])]+generateParamRefGrammars fc sorts meas_ex arg_tys =+ map (\(i, as@((_, a):_)) ->+ let+ arg_tys = map fst $ init as+ ret_ty = fst $ last as++ arg_ref_names = refinementNames ("args_" ++ show i) ret_ty -- a+ arg_gram_cmds = generateGrammars regGrammar sorts arg_ref_names meas_ex arg_tys ret_ty+ in+ (arg_ref_names, arg_gram_cmds))+ (zip [0..] . map (zip arg_tys) . filter (not . null) . inits . arguments $ constraint fc)++generateGrammars :: GrammarGen -> TypesToSorts -> RefNamePolyBound -> MeasureExs -> [Type] -> Type -> [Cmd]+generateGrammars g sorts ref_names meas_ex arg_tys ret_ty =+ let+ rt_bound = extractTypePolyBound ret_ty+ ns_rt = zipPB ref_names rt_bound+ in+ map (uncurry (generateSynthFun g sorts arg_tys))+ . filter (relTy . snd) + $ extractValues ns_rt++generateSynthFun :: GrammarGen+ -> TypesToSorts + -> [Type] -- ^ Argument types+ -> String -- ^ Name of function to synthesize+ -> Type -- ^ Return type+ -> Cmd+generateSynthFun g sorts arg_tys n rt =+ let+ param_vars = generateParams sorts arg_tys++ ret_sort_var = SortedVar "r" (typeToSort sorts rt)+ sort_vars = param_vars ++ [ret_sort_var]+ + gram = g param_vars ret_sort_var sorts+ in+ SynthFun n sort_vars boolSort (Just gram)++generateParams :: TypesToSorts -> [Type] -> [SortedVar]+generateParams sorts arg_tys =+ let+ varN = map (\i -> "x" ++ show i) ([0..] :: [Integer])+ in+ map (uncurry SortedVar) . zip varN+ . map (typeToSort sorts) . filter (not . isLHDict) $ arg_tys+ where+ isLHDict e+ | (TyCon (Name n _ _ _) _):_ <- unTyApp e = n == "lh"+ | otherwise = False++-------------------------------+-- define-fun+-------------------------------++-- We define a function safe-mod, which forces the denominator of mod to be positive.++safeModSymb :: Symbol+safeModSymb = "safe-mod"++safeModDecl :: Cmd+safeModDecl =+ SmtCmd+ . DefineFun safeModSymb [SortedVar "x" intSort, SortedVar "y" intSort] intSort+ $ TermCall (ISymb "mod")+ [ TermIdent (ISymb "x")+ , TermCall (ISymb "+") [TermLit (LitNum 1), TermCall (ISymb "abs") [TermIdent (ISymb "y")]]+ ]++-- We define a function clamp, which forces (Constant sort) to fall only in a fixed range+clampIntSymb :: Symbol+clampIntSymb = clampSymb "int"++clampIntDecl :: Integer -> Cmd+clampIntDecl = clampDecl clampIntSymb intSort++clampDoubleSymb :: Symbol+clampDoubleSymb = clampSymb "double"++clampDoubleDecl :: Integer -> Cmd+clampDoubleDecl = clampDecl clampDoubleSymb doubleSort++clampSymb :: Symbol -> Symbol+clampSymb = (++) "clamp-"++clampDecl :: Symbol -> Sort -> Integer -> Cmd+clampDecl fn srt mx =+ SmtCmd+ . DefineFun fn [SortedVar "x" srt] srt+ $ TermCall (ISymb "ite")+ [ TermCall (ISymb "<") [TermLit $ LitNum mx, TermIdent (ISymb "x")]+ , TermLit $ LitNum mx+ , TermCall (ISymb "ite")+ [ TermCall (ISymb "<") [TermIdent (ISymb "x"), TermLit $ LitNum 0]+ , TermLit $ LitNum 0+ , TermIdent (ISymb "x")+ ]+ ]++clampUpper :: Num a => a+clampUpper = 5++-------------------------------+-- Grammar+-------------------------------++type GrammarGen = [SortedVar] -> SortedVar -> TypesToSorts -> GrammarDef++regGrammar :: GrammarGen+regGrammar = grammar intRuleList doubleRuleList++extGrammar :: GrammarGen+extGrammar = grammar extIntRuleList extDoubleRuleList++grammar :: [GTerm] -- Int Rules+ -> [GTerm] -- Double Rules+ -> GrammarGen+grammar intRules doubleRules arg_sort_vars ret_sorted_var@(SortedVar _ (IdentSort (ISymb ret_srt_symb))) sorts =+ let+ sorted_vars = arg_sort_vars ++ [ret_sorted_var]++ rel_to_ret =+ case ret_srt_symb of+ "Bool" -> arg_sort_vars+ _ -> maybe [ret_sorted_var] meas_names $ lookupSortInfoBySort ret_srt_symb sorts++ sorts' = filterToSorts (map (\(SortedVar _ s) -> sortSymb s) sorted_vars) sorts++ gramNames = zip (map (\i -> "G" ++ show i) ([0..] :: [Integer])) (allSortNames sorts')+ grams = map (\(g, s_symb) -> (g, IdentSort . ISymb $ s_symb)) gramNames+ sortsToGN = HM.fromList $ map swap gramNames++ irl = GroupedRuleList "I" intSort+ (intRules ++ addSelectors sortsToGN intSort sorts')++ clamp_int = GroupedRuleList "IClamp" intSort [GBfTerm $ BfIdentifierBfs (ISymb clampIntSymb) [BfIdentifier (ISymb "IConst")]]++ const_int = GroupedRuleList "IConst" intSort [GConstant intSort]+ + (bool_int, decl_int, grl_int) =+ adjustTypeUsage rel_to_ret+ intSort+ boolIntArgRuleList + [SortedVar "I" intSort, SortedVar "IClamp" intSort, SortedVar "IConst" intSort]+ [ ("I", intRules, addSelectors sortsToGN intSort sorts')+ , ("IClamp", [GBfTerm $ BfIdentifierBfs (ISymb clampIntSymb) [BfIdentifier (ISymb "IConst")]], [])+ , ("IConst", [GConstant intSort], []) ]++ (bool_double, decl_double, grl_double) =+ adjustTypeUsage rel_to_ret+ doubleSort+ boolDoubleArgRuleList + [SortedVar "D" doubleSort, SortedVar "DClamp" doubleSort, SortedVar "DConst" doubleSort]+ [ ("D", doubleRules, addSelectors sortsToGN doubleSort sorts')+ , ("DClamp", [GBfTerm $ BfIdentifierBfs (ISymb clampDoubleSymb) [BfIdentifier (ISymb "DConst")]], [])+ , ("DConst", [GConstant doubleSort], []) ]++ bool_rl = boolTrueRuleList ++ if not (null bool_int) || not (null bool_double)+ then boolOpRuleList+ else []+ brl = GroupedRuleList "B" boolSort+ (bool_rl ++ bool_int ++ bool_double+ ++ addSelectors sortsToGN boolSort sorts')++ grm = GrammarDef+ ([ SortedVar "B" boolSort ]+ ++ decl_int+ ++ decl_double+ ++ map (uncurry SortedVar) grams)+ ([ brl ]+ ++ grl_int+ ++ grl_double+ ++ map (uncurry dtGroupRuleList) grams)+ in+ forceVarInGrammar ret_sorted_var arg_sort_vars grm+ where+ sortSymb (IdentSort (ISymb s)) = s+ sortSymb _ = error "grammar: sortSymb"++-- | Including doubles/ints in the grammar increases CVC4s runtime, and is not+-- needed if there are no variables of the given type, or selectors that return+-- the given type. This function checks if any variables/selectors exists,+-- and either returns the needed grammar elements if they do, or returns+-- empty lists if they do not.+adjustTypeUsage :: [SortedVar] -- ^ The function parameters+ -> Sort -- ^ The type under consideration+ -> [GTerm] -- ^ A set of terminals relating the given type to Bool+ -> [SortedVar] -- ^ Declarations for the terminals for the given type+ -> [(Symbol, [GTerm], [GTerm])] -- ^ The symbols, set(s) of default+ -- terminals, and sets of selector terminals+ -- for the given type+ -> ( [GTerm] -- ^ The set of terminals to add to add to Bool+ , [SortedVar] -- ^ Declarations for the terminals for the+ -- given type to add to the grammar+ , [GroupedRuleList] -- ^ The GRL(s) to add to the grammar+ )+adjustTypeUsage params srt bool_trms decls type_trms =+ let+ param_typs = filter (\(SortedVar _ s) -> s == srt) params+ sels = concatMap (\(_, _, sel) -> sel) type_trms++ type_grl = map (\(s, def, sel) -> GroupedRuleList s srt (def ++ sel)) type_trms+ in+ if param_typs /= [] -- || sels /= []+ then (bool_trms, decls, type_grl)+ else ([], [], [])++-- For some reason, CVC4 seems better at handling * when both sides are intBf,+-- instead of one side being intConstBf+extIntRuleList :: [GTerm]+extIntRuleList = intRuleList ++ + [ GBfTerm $ BfIdentifierBfs (ISymb "*") [intBf, intBf]+ , GBfTerm $ BfIdentifierBfs (ISymb safeModSymb) [intBf, intConstBf]+ ]++intRuleList :: [GTerm]+intRuleList =+ [ GVariable intSort+ , GBfTerm $ BfIdentifier (ISymb "IClamp") -- , GConstant intSort+ , GBfTerm $ BfIdentifierBfs (ISymb "+") [intBf, intBf]+ , GBfTerm $ BfIdentifierBfs (ISymb "-") [intBf, intBf]+ ]+ -- ++ [GBfTerm . BfLiteral . LitNum $ x | x <- [0..0]]++extDoubleRuleList :: [GTerm]+extDoubleRuleList = doubleRuleList ++ [GBfTerm $ BfIdentifierBfs (ISymb "*") [doubleConstBf, doubleBf]]++doubleRuleList :: [GTerm]+doubleRuleList =+ [ GVariable doubleSort+ , GBfTerm $ BfIdentifier (ISymb "DClamp") -- GConstant doubleSort+ , GBfTerm $ BfIdentifierBfs (ISymb "+") [doubleBf, doubleBf]+ , GBfTerm $ BfIdentifierBfs (ISymb "-") [doubleBf, doubleBf]+ ]+ -- ++ [GBfTerm . BfLiteral . LitNum $ x | x <- [0..0]]++boolRuleList :: [GTerm]+boolRuleList = boolDefRuleList ++ boolIntArgRuleList ++ boolDoubleArgRuleList++boolDefRuleList :: [GTerm]+boolDefRuleList =+ boolTrueRuleList ++ boolOpRuleList++boolTrueRuleList :: [GTerm]+boolTrueRuleList =+ [+ -- (GConstant boolSort) is significantly slower than just enumerating the bools+ -- , GConstant boolSort+ GBfTerm $ BfLiteral (LitBool True)+ ]++boolOpRuleList :: [GTerm]+boolOpRuleList =+ [ GVariable boolSort++ , GBfTerm $ BfIdentifierBfs (ISymb "=>") [boolBf, boolBf]+ , GBfTerm $ BfIdentifierBfs (ISymb "and") [boolBf, boolBf]+ -- , GBfTerm $ BfIdentifierBfs (ISymb "or") [boolBf, boolBf]+ , GBfTerm $ BfIdentifierBfs (ISymb "not") [boolBf]+ ]++boolIntArgRuleList :: [GTerm]+boolIntArgRuleList =+ [ GBfTerm $ BfIdentifierBfs (ISymb "=") [intBf, intBf]+ , GBfTerm $ BfIdentifierBfs (ISymb "<") [intBf, intBf]+ , GBfTerm $ BfIdentifierBfs (ISymb "<=") [intBf, intBf]+ ]++boolDoubleArgRuleList :: [GTerm]+boolDoubleArgRuleList =+ [ GBfTerm $ BfIdentifierBfs (ISymb "=") [doubleBf, doubleBf]+ , GBfTerm $ BfIdentifierBfs (ISymb "<") [doubleBf, doubleBf]+ , GBfTerm $ BfIdentifierBfs (ISymb "<=") [doubleBf, doubleBf]+ ]++elimHigherOrderArgs :: FuncConstraint -> FuncConstraint+elimHigherOrderArgs fc =+ let+ cons = constraint fc+ as = arguments cons+ as' = filter (not . isTyFun . typeOf) as+ in+ fc { constraint = cons { arguments = as' }}++dtGroupRuleList :: Symbol -> Sort -> GroupedRuleList+dtGroupRuleList symb srt = GroupedRuleList symb srt [GVariable srt]++intBf :: BfTerm+intBf = BfIdentifier (ISymb "I")++intConstBf :: BfTerm+intConstBf = BfIdentifier (ISymb "IConst")++doubleBf :: BfTerm+doubleBf = BfIdentifier (ISymb "D")++doubleConstBf :: BfTerm+doubleConstBf = BfIdentifier (ISymb "DConst")++boolBf :: BfTerm+boolBf = BfIdentifier (ISymb "B")++intSort :: Sort+intSort = IdentSort (ISymb "Int")++doubleSort :: Sort+doubleSort = IdentSort (ISymb "Real")++boolSort :: Sort+boolSort = IdentSort (ISymb "Bool")+++charSort :: Sort+charSort = IdentSort (ISymb "String")++relArgs :: TypeClasses -> [Type] -> FuncConstraint -> FuncConstraint+relArgs tc ts fc =+ let+ cons = constraint fc+ as = filter (relArg tc) $ arguments cons+ ts_as = zip ts as+ as' = map snd $ filter (relTy . fst) ts_as+ in+ fc { constraint = cons { arguments = as' }}++relArg :: TypeClasses -> G2.Expr -> Bool+relArg tc e = (not . isTypeClass tc . typeOf $ e) && (not . isType $ e)+ where+ isType (Type _) = True+ isType _ = False++type ArgTys = [Type]+type RetType = Type+type PolyTypes = [Type]++generateRelTypes :: TypeClasses -> G2.Expr -> (ArgTys, RetType, PolyTypes)+generateRelTypes tc e =+ let+ ty_e = PresType $ inTyForAlls (typeOf e)+ arg_ty_c = filter (not . isTYPE)+ . filter (not . isTypeClass tc)+ $ argumentTypes ty_e+ ret_ty_c = returnType ty_e++ ex_ty_c = concatMap unTyApp $ ret_ty_c:arg_ty_c+ in+ (arg_ty_c, ret_ty_c, ex_ty_c)++-- | Is the given type usable by SyGuS?+relTy :: Type -> Bool+relTy (TyVar _) = False+relTy (TyFun _ _) = False+relTy _ = True+++-------------------------------+-- Constraints+-------------------------------++-- | Constraints expresessed as "anded" terms+data TermConstraint = TC { pos_term :: Bool, tc_violated :: Violated, param_ret_connector :: Symbol, param_terms :: [Term], ret_terms :: [Term] }+ deriving (Show, Read)++modifyParamTC :: ([Term] -> [Term]) -> TermConstraint -> TermConstraint+modifyParamTC f tc = tc { param_terms = f (param_terms tc) }++modifyRetTC :: ([Term] -> [Term]) -> TermConstraint -> TermConstraint+modifyRetTC f tc = tc { ret_terms = f (ret_terms tc) }++-- | Convert constraints. Measures cause us to lose information about the data, so after+-- conversion we can have a constraint both postively and negatively. We know that the postive+-- constraint corresponds to an actual execution, so we keep that one, adnd drop the negative constraint.++generateConstraints :: TypesToSorts -> MeasureExs -> [RefNamePolyBound] -> RefNamePolyBound -> [Type] -> Type -> [FuncConstraint] -> [Cmd]+generateConstraints sorts meas_ex arg_poly_names ret_poly_names arg_tys ret_ty fcs = + let+ cons = map (termConstraints sorts meas_ex arg_poly_names ret_poly_names arg_tys ret_ty) fcs+ cons' = cons -- filterPosAndNegConstraints cons+ cons'' = map termConstraintToConstraint cons'++ exists_args = concatMap (\(pn, ars) -> existentialConstraints sorts meas_ex pn (init ars) (last ars)) + $ zip arg_poly_names (filter (not . null) $ inits arg_tys)+ exists_ret = existentialConstraints sorts meas_ex ret_poly_names arg_tys ret_ty+ in+ {- exists_args ++ exists_ret ++ -} cons''++-- | Prevents any refinements from being set to "False" (or equivalent, i.e. 0 < 0)+existentialConstraints :: TypesToSorts -> MeasureExs -> RefNamePolyBound -> [Type] -> Type -> [Cmd]+existentialConstraints sorts meas_ex poly_names arg_tys ret_ty =+ let+ rt_bound = extractTypePolyBound ret_ty+ ns_rt = zipPB rt_bound poly_names+ in+ mapMaybe (fmap Constraint . uncurry (existentialTerms sorts meas_ex arg_tys)) $ extractValues ns_rt+++existentialTerms :: TypesToSorts -> MeasureExs -> [Type] -> Type -> String -> Maybe Term+existentialTerms _ _ _ (TyVar _) _ = Nothing+existentialTerms sorts meas_ex arg_tys ret_ty fn =+ let+ ar_vs = map (\(i, t) -> ("arg" ++ show i, typeToSort sorts t)) $ zip [0..] (arg_tys)+ srt_v = ("e_ret", typeToSort sorts ret_ty)+ in+ Just . TermExists (map (uncurry SortedVar) $ srt_v:ar_vs)+ $ TermCall (ISymb fn) (map (TermIdent . ISymb . fst) ar_vs ++ [TermIdent (ISymb "e_ret")])++termConstraints :: TypesToSorts -> MeasureExs -> [RefNamePolyBound] -> RefNamePolyBound -> [Type] -> Type -> FuncConstraint -> TermConstraint+termConstraints sorts meas_ex arg_poly_names ret_poly_names arg_tys ret_ty (FC { polarity = p+ , violated = v+ , bool_rel = br+ , constraint = fc }) =+ TC { pos_term = p == Pos+ , tc_violated = v+ , param_ret_connector = if br == BRAnd then "and" else "=>"+ , param_terms = funcParamTerms sorts meas_ex arg_poly_names arg_tys (arguments fc)+ , ret_terms = funcCallRetTerm sorts meas_ex ret_poly_names arg_tys ret_ty (arguments fc) (returns fc) }++-- When polymorphic arguments are instantiated with values, we use those as+-- arguments for the polymorphic refinement functions. However, even when they+-- do not have values, we still want to enforce that (for some value) the polymorphic+-- refinement function is true. Thus, given arguments a_1, ..., a_n, we need to add+-- an expression of the form:+-- exists x . r(a_1, ..., a_n, x)++data ValOrExistential v = Val v | Existential++funcParamTerms :: TypesToSorts -> MeasureExs -> [RefNamePolyBound] -> [Type] -> [G2.Expr] -> [Term]+funcParamTerms sorts meas_ex poly_names arg_tys ars =+ let+ inits_arg_tys = filter (not . null) $ inits arg_tys+ init_ars = filter (not . null) $ inits ars+ in+ concatMap (\(pn, at, as) ->+ funcCallTerm sorts meas_ex pn (init at) (last at) (init as) (last as)+ )+ $ zip3 poly_names inits_arg_tys init_ars++funcCallRetTerm :: TypesToSorts -> MeasureExs -> RefNamePolyBound -> [Type] -> Type -> [G2.Expr] -> G2.Expr -> [Term]+funcCallRetTerm _ _ _ _ _ _ (Prim Error _) = [TermLit $ LitBool True]+funcCallRetTerm sorts meas_ex poly_names arg_tys ret_ty ars r = funcCallTerm sorts meas_ex poly_names arg_tys ret_ty ars r++funcCallTerm :: TypesToSorts -> MeasureExs -> RefNamePolyBound -> [Type] -> Type -> [G2.Expr] -> G2.Expr -> [Term]+funcCallTerm sorts meas_ex poly_names arg_tys ret_ty ars r =+ let+ r_bound = extractExprPolyBoundWithRoot r+ rt_bound = extractTypePolyBound ret_ty+ ns_r_bound = zip3PB r_bound rt_bound poly_names+ ns_r_bound' = concatMap expand1 (extractValues ns_r_bound)+ in+ mapMaybe (\(r, rt, n) -> funcCallTerm' sorts meas_ex arg_tys ars r rt n) $ ns_r_bound' -- r+ where+ expand1 :: ([a], b, c) -> [(ValOrExistential a, b, c)]+ expand1 ([], b, c) = [(Existential, b, c)]+ expand1 (as, b, c) = map (\a -> (Val a, b, c)) as ++funcCallTerm' :: TypesToSorts -> MeasureExs -> [Type] -> [G2.Expr] -> ValOrExistential G2.Expr -> Type -> String -> Maybe Term+funcCallTerm' sorts meas_ex arg_tys ars r ret_ty fn+ | Val r' <- r+ , relTy ret_ty =+ let+ trm_ret = exprToTerm sorts meas_ex ret_ty r'+ in+ Just $ TermCall (ISymb fn) (trm_ars ++ [trm_ret])+ | Existential <- r+ , relTy ret_ty =+ let+ srt_v = SortedVar "e_ret" $ typeToSort sorts ret_ty+ in+ Just . TermExists [srt_v] $ TermCall (ISymb fn) (trm_ars ++ [TermIdent (ISymb "e_ret")])+ | otherwise = Nothing+ where+ trm_ars = map (uncurry (exprToTerm sorts meas_ex)) (zip arg_tys ars)++exprToTerm :: TypesToSorts -> MeasureExs -> Type -> G2.Expr -> Term+exprToTerm _ _ (TyCon (Name "Bool" _ _ _) _) (Data (DataCon (Name n _ _ _) _))+ | "True" <- n = TermLit $ LitBool True+ | "False" <- n =TermLit $ LitBool False+exprToTerm _ _ (TyCon (Name n _ _ _) _) (App _ (Lit l))+ | n == "Int"+ || n == "Float"+ || n == "Double"+ || n == "Char" = litToTerm l+exprToTerm _ _ _ (Lit l) = litToTerm l+exprToTerm sorts meas_ex t e = exprToDTTerm sorts meas_ex t e+exprToTerm _ _ _ e = error $ "exprToTerm: Unhandled Expr " ++ show e++litToTerm :: G2.Lit -> Term+litToTerm (LitInt i) = TermLit (LitNum i)+litToTerm (LitDouble d) = TermCall (ISymb "/") [ TermLit . LitNum $ numerator d+ , TermLit . LitNum $ denominator d]+litToTerm (LitChar c) = TermLit (LitStr [c])+litToTerm _ = error "litToTerm: Unhandled Lit"++exprToDTTerm :: TypesToSorts -> MeasureExs -> Type -> G2.Expr -> Term+exprToDTTerm sorts meas_ex t e =+ case lookupSort t sorts of+ Just si+ | not . null $ meas_names si ->+ TermCall (ISymb (dt_name si)) $ map (measVal sorts meas_ex e) (meas_names si)+ | otherwise -> TermIdent (ISymb (dt_name si))+ Nothing -> error $ "exprToDTTerm: No sort found" ++ "\nsorts = " ++ show sorts ++ "\nt = " ++ show t ++ "\ne = " ++ show e++filterPosAndNegConstraints :: [TermConstraint] -> [TermConstraint]+filterPosAndNegConstraints ts =+ let+ tre = concatMap ret_terms $ filter isForcedRet ts+ in+ filter (\t -> (not . null $ ret_terms t) || param_ret_connector t == "=>" || tc_violated t == Pre)+ $ map (\t -> if pos_term t || param_ret_connector t == "=>" then t else modifyRetTC (filter (not . flip elem tre)) t) ts+ where+ -- Does ths post-condition HAVE to hold?+ isForcedRet t = pos_term t && param_ret_connector t == "and"++termConstraintToConstraint :: TermConstraint -> Cmd+termConstraintToConstraint (TC p v pr_con param_ts ret_ts) =+ let+ param_tc = case param_ts of+ [] -> TermLit (LitBool True)+ _ -> TermCall (ISymb "and") param_ts+ ret_tc = case ret_ts of+ [] -> TermLit (LitBool True) + _ -> TermCall (ISymb "and") ret_ts+ ret_tc' = case p of+ True -> ret_tc+ False -> TermCall (ISymb "not") [ret_tc]+ tc = TermCall (ISymb pr_con) [param_tc, ret_tc']+ in+ Constraint tc++typeToSort :: TypesToSorts -> Type -> Sort+typeToSort _ (TyCon (Name n _ _ _) _) + | n == "Int" = intSort+ | n == "Double" = doubleSort+ | n == "Bool" = boolSort+ | n == "Char" = charSort+typeToSort sm t+ | Just si <- lookupSort t sm = IdentSort (ISymb $ sort_name si)+typeToSort sm t = error $ "Unknown Type\n" ++ show t ++ "\nsm = " ++ show sm++-------------------------------+-- Measures+-------------------------------++measVal :: TypesToSorts -> MeasureExs -> G2.Expr -> SortedVar -> Term+measVal sorts meas_ex e (SortedVar mn _) =+ let+ meas_n = strToName mn+ in+ case HM.lookup e meas_ex of+ Just meas_out+ | Just (_, v) <- find (\(n', _) -> nameOcc meas_n == nameOcc n') meas_out -> exprToTerm sorts meas_ex (typeOf v) v+ Nothing -> error $ "measVal: Expr not found\nmeas_ex = " ++ show meas_ex ++ "\ne = " ++ show e++newtype TypesToSorts = TypesToSorts { types_to_sorts :: [(Type, SortInfo)] }+ deriving (Show, Read)++data SortInfo = SortInfo { sort_name :: Symbol+ , dt_name :: Symbol+ , meas_names :: [SortedVar]}+ deriving (Show, Read)++typesToSort :: Measures -> MeasureExs -> [Type] -> TypesToSorts+typesToSort meas meas_ex ty_c =+ let+ rel_ty_c = filter relTy ty_c++ rel_ty_c' = nubBy (\t1 t2 -> t1 .::. t2) rel_ty_c+ dt_ts = filter (not . isPrimTy) rel_ty_c' ++ ns = concatMap (map fst) . HM.elems $ meas_ex+ applic_meas = map (applicableMeasures meas) dt_ts+ applic_meas' = map (filter (\m -> m `elem` ns)) applic_meas+ meas_ids = map (map (\n -> Id n (returnType (case E.lookup n meas of+ Just e -> e+ Nothing -> error "sygusCall: No type found")))) applic_meas'++ meas_ids' = filterNonPrimMeasure meas_ids++ ts_applic_meas = zip dt_ts meas_ids'+ in+ typesToSort' ts_applic_meas+ +isPrimTy :: Type -> Bool +isPrimTy (TyCon (Name "Int" _ _ _) _) = True+isPrimTy (TyCon (Name "Double" _ _ _) _) = True+isPrimTy (TyCon (Name "Bool" _ _ _) _) = True+isPrimTy _ = False++typesToSort' :: [(Type, [Id])] -> TypesToSorts+typesToSort' ts =+ let+ ts_s = map (\(i, (t, ns)) -> typesToSort'' i t ns) $ zip [0..] ts+ in+ TypesToSorts ts_s++typesToSort'' :: Int -> Type -> [Id] -> (Type, SortInfo)+typesToSort'' i t ns =+ let+ srt = "Sort_" ++ show i+ dt = "DT_" ++ show i+ sel_svs = map (\is@(Id (Name n m _ _) _) -> SortedVar+ (nameToStr (Name n m i Nothing)) (typeToSort (TypesToSorts [])+ (typeOf is))+ ) ns+ in+ (t, SortInfo { sort_name = srt, dt_name = dt, meas_names = sel_svs })++lookupSort :: Type -> TypesToSorts -> Maybe SortInfo+lookupSort t (TypesToSorts sorts) =+ let+ sis = filter (\(t', _) -> PresType t .:: t') sorts+ min_sis = filter (\(t', _) -> all (\(t'', _) -> PresType t' .:: t'') sis) sis+ in+ case min_sis of+ [(_, si)] -> Just si+ [] -> Nothing+ _ -> error $ "t = " ++ show t ++ "\nmin_sis = " ++ show min_sis++ -- = fmap (snd) . find (\(t', _) -> PresType t .:: t') . types_to_sorts++lookupSortInfoBySort :: Symbol -> TypesToSorts -> Maybe SortInfo+lookupSortInfoBySort symb (TypesToSorts ts) = find (\s -> symb == sort_name s) $ map snd ts++sortsToDeclareDTs :: TypesToSorts -> [Cmd]+sortsToDeclareDTs = map (sortToDeclareDT) . map snd . types_to_sorts++sortToDeclareDT :: SortInfo -> Cmd+sortToDeclareDT (SortInfo {sort_name = srt, dt_name = dtn, meas_names = sels}) =+ SmtCmd . DeclareDatatype srt $ DTDec [DTConsDec dtn sels]++filterNonPrimMeasure :: [[Id]] -> [[Id]]+filterNonPrimMeasure = map (filter isPrimMeasure)++isPrimMeasure :: Id -> Bool+isPrimMeasure = isPrimTy . typeOf++allSorts :: TypesToSorts -> [Sort]+allSorts = map (IdentSort . ISymb) . allSortNames++allSortNames :: TypesToSorts -> [Symbol]+allSortNames = map (sort_name . snd) . types_to_sorts++addSelectors :: HM.HashMap Symbol String -> Sort -> TypesToSorts -> [GTerm]+addSelectors grams s =+ concatMap (\si ->+ case HM.lookup (sort_name si) grams of + Just gn -> mapMaybe (addSelector gn s) (meas_names si)+ Nothing -> error "addSelectors: Grammar name not found") . map snd . types_to_sorts++addSelector :: Symbol -> Sort -> SortedVar -> Maybe GTerm+addSelector gn s (SortedVar ident vs)+ | s == vs = Just . GBfTerm $ BfIdentifierBfs (ISymb ident) [BfIdentifier (ISymb gn)]+ | otherwise = Nothing++filterToSorts :: [Symbol] -> TypesToSorts -> TypesToSorts+filterToSorts xs (TypesToSorts sorts) =+ TypesToSorts $ filter (\(_, s) -> any (sort_name s ==) xs) sorts++-------------------------------+-- Enforcing return value use+-------------------------------++-- Adjusts a grammar to force using a given GTerm++forceVarInGrammar :: SortedVar -- ^ The variable to force+ -> [SortedVar] -- ^ All other variables+ -> GrammarDef+ -> GrammarDef+forceVarInGrammar var params (GrammarDef sv grls) =+ let+ prod_srt = mapMaybe (\grl@(GroupedRuleList grl_symb srt' _) ->+ if any (flip canProduceVar grl) (var:params)+ then Just grl_symb+ else Nothing ) grls++ reach = gramSymbReachableFrom prod_srt grls++ sv_reach = concatMap (grammarDefSortedVars reach) sv++ (sv_final, grl_final) = elimNonTermGRL var (forceVarInGRLList var reach grls) sv_reach+ in+ GrammarDef sv_final grl_final++forceVarInGRLList :: SortedVar -> [Symbol] -> [GroupedRuleList] -> [GroupedRuleList]+forceVarInGRLList var reach grls =+ let+ fv_map = HM.fromList $ map (\n -> (toBf n, toBf $ forcedVarSymb n)) reach++ in+ concatMap (forceVarInGRL var reach fv_map) grls+ where+ toBf = BfIdentifier . ISymb++forceVarInGRL :: SortedVar -> [Symbol] -> HM.HashMap BfTerm BfTerm -> GroupedRuleList -> [GroupedRuleList]+forceVarInGRL (SortedVar sv_symb sv_srt) reach fv_map grl@(GroupedRuleList grl_symb grl_srt gtrms)+ | grl_symb `elem` reach =+ let+ bf_var = BfIdentifier (ISymb sv_symb)+ fv_gtrms' = if sv_srt == grl_srt+ then GBfTerm bf_var:(filter (not . isClamp) $ elimVariable fv_gtrms)+ else filter (not . isClamp) $ elimVariable fv_gtrms+ in+ [GroupedRuleList fv_symb grl_srt fv_gtrms', grl]+ | otherwise = [grl]+ where+ fv_symb = forcedVarSymb grl_symb+ fv_gtrms = substOnceGTerms fv_map gtrms+++forcedVarSymb :: Symbol -> Symbol+forcedVarSymb = ("fv_" ++)++elimVariable :: [GTerm] -> [GTerm]+elimVariable = filter (\t -> case t of+ GVariable _ -> False+ _ -> True)++isClamp :: GTerm -> Bool+isClamp (GBfTerm (BfIdentifier (ISymb "IClamp"))) = True+isClamp (GBfTerm (BfIdentifier (ISymb "DClamp"))) = True+isClamp _ = False++-----------------------------------------------------++elimNonTermGRL :: SortedVar -> [GroupedRuleList] -> [SortedVar] -> ([SortedVar], [GroupedRuleList])+elimNonTermGRL (SortedVar sv_n _) grls sv =+ let+ has_term = hasTermFix (HS.singleton sv_n) grls++ sv' = filter (\(SortedVar n _) -> n `elem` has_term) sv+ grls' = map (elimRules has_term)+ $ filter (\(GroupedRuleList n _ _) -> n `elem` has_term) grls+ in+ trace "-----"+ (sv', grls')++hasTermFix :: HS.HashSet Symbol -> [GroupedRuleList] -> [Symbol]+hasTermFix ht grl =+ let+ ht' = HS.fromList+ . map (\(GroupedRuleList n _ _) -> n)+ $ filter (hasTermGRL ht) grl+++ ht_all = HS.union ht ht'+ in+ if ht == ht_all then HS.toList ht_all else hasTermFix ht_all grl++hasTermGRL :: HS.HashSet Symbol -> GroupedRuleList -> Bool+hasTermGRL ht (GroupedRuleList n _ r) = n `HS.member` ht || any (hasTermGTerm ht) r++hasTermGTerm :: HS.HashSet Symbol -> GTerm -> Bool+hasTermGTerm _ (GConstant _) = True+hasTermGTerm _ (GVariable _) = True+hasTermGTerm ht (GBfTerm bft) = hasTermBfTerm ht bft++hasTermBfTerm :: HS.HashSet Symbol -> BfTerm -> Bool+hasTermBfTerm ht (BfIdentifier (ISymb i)) = i `HS.member` ht+hasTermBfTerm _ (BfLiteral _) = True+hasTermBfTerm ht (BfIdentifierBfs _ bfs) = all (hasTermBfTerm ht) bfs++-----------------------------------------------------++-- elimEmptyGRL :: [GroupedRuleList] -> [GroupedRuleList]+-- elimEmptyGRL grl =+-- let+-- emp_grl = map (\(GroupedRuleList n _ _) -> n)+-- $ filter (\(GroupedRuleList _ _ r) -> null r) grl++-- in+-- filter (\(GroupedRuleList _ _ r) -> not $ null r) $ map (elimRules emp_grl) grl++elimRules :: [Symbol] -> GroupedRuleList -> GroupedRuleList+elimRules grls (GroupedRuleList symb srt r) =+ GroupedRuleList symb srt $ filter (elimRules' grls) r++elimRules' :: [Symbol] -> GTerm -> Bool+elimRules' _ (GConstant _) = True+elimRules' _ (GVariable _) = True+elimRules' grls (GBfTerm bft) = elimRulesBfT grls bft++elimRulesBfT :: [Symbol] -> BfTerm -> Bool+elimRulesBfT grls (BfIdentifier (ISymb i)) = i `elem` grls+elimRulesBfT _ (BfLiteral _) = True+elimRulesBfT grls (BfIdentifierBfs _ bfs) = all (elimRulesBfT grls) bfs++-----------------------------------------------------++grammarDefSortedVars :: [Symbol] -> SortedVar -> [SortedVar]+grammarDefSortedVars symbs sv@(SortedVar n srt)+ | n `elem` symbs = [SortedVar (forcedVarSymb n) srt, sv]+ | otherwise = [sv]++-- Can a GroupedRuleList produce a given variable?++canProduceVar :: SortedVar -> GroupedRuleList -> Bool+canProduceVar var@(SortedVar symb sv_srt) (GroupedRuleList _ grl_srt gtrms)+ | sv_srt == grl_srt = any (canProduceVarGTerm var) gtrms+ | otherwise = False++canProduceVarGTerm :: SortedVar -> GTerm -> Bool+canProduceVarGTerm (SortedVar _ sv_srt) (GVariable gv_srt) = sv_srt == gv_srt+canProduceVarGTerm (SortedVar s _) (GBfTerm (BfIdentifier (ISymb is))) = s == is+canProduceVarGTerm s (GBfTerm (BfIdentifierBfs _ bfs)) = any (canProduceVarGTerm s) $ map GBfTerm bfs+canProduceVarGTerm _ (GBfTerm (BfLiteral _)) = False+canProduceVarGTerm _ (GConstant _) = False+canProduceVarGTerm _ t = error $ "Unhandled term" ++ show t++-- Reachability checks++gramSymbReachableFrom :: [Symbol] -> [GroupedRuleList] -> [Symbol]+gramSymbReachableFrom = gramSymbReachableFrom' HS.empty++gramSymbReachableFrom' :: HS.HashSet Symbol -> [Symbol] -> [GroupedRuleList] -> [Symbol]+gramSymbReachableFrom' searched [] _ = HS.toList searched+gramSymbReachableFrom' searched (x:xs) grls+ | x `HS.member` searched = gramSymbReachableFrom' searched xs grls+ | otherwise =+ let+ contains_x = map (\(GroupedRuleList s _ _) -> s)+ $ filter (containsSymbol x) grls+ in+ gramSymbReachableFrom' (HS.insert x searched) (contains_x ++ xs) grls++containsSymbol :: Symbol -> GroupedRuleList -> Bool+containsSymbol symb (GroupedRuleList _ _ gtrms) = any (containsSymbolGTerm symb) gtrms++containsSymbolGTerm :: Symbol -> GTerm -> Bool+containsSymbolGTerm symb (GBfTerm bf) = containsSymbolBfTerm symb bf+containsSymbolGTerm _ _ = False++containsSymbolBfTerm :: Symbol -> BfTerm -> Bool+containsSymbolBfTerm symb (BfIdentifier ident) = containsSymbolIdent symb ident+containsSymbolBfTerm symb (BfIdentifierBfs ident bfs) =+ containsSymbolIdent symb ident || any (containsSymbolBfTerm symb) bfs+containsSymbolBfTerm _ (BfLiteral _) = False++containsSymbolIdent :: Symbol -> Identifier -> Bool+containsSymbolIdent symb (ISymb symb') = symb == symb'+containsSymbolIdent symb _ = False++-- Substitution functions++substOnceGRL :: HM.HashMap BfTerm BfTerm -> GroupedRuleList -> GroupedRuleList+substOnceGRL m (GroupedRuleList symb srt gtrms) =+ GroupedRuleList symb srt $ substOnceGTerms m gtrms++substOnceGTerms :: HM.HashMap BfTerm BfTerm -> [GTerm] -> [GTerm]+substOnceGTerms m = concatMap (substOnceGTerm m)++substOnceGTerm :: HM.HashMap BfTerm BfTerm -> GTerm -> [GTerm]+substOnceGTerm m (GBfTerm bf) = map GBfTerm $ substOnceBfTerm m bf+substOnceGTerm _ gt = [gt]++substOnceBfTerm :: HM.HashMap BfTerm BfTerm -> BfTerm -> [BfTerm]+substOnceBfTerm m (BfIdentifierBfs c bfs) = elimRedundant . map (BfIdentifierBfs c) $ substsOnces m bfs+substOnceBfTerm _ bf = [bf]++substOnceTerm :: HM.HashMap Term Term -> Term -> [Term]+substOnceTerm m (TermCall c ts) = map (TermCall c) $ substsOnces m ts+substOnceTerm _ t = [t]++elimRedundant :: [BfTerm] -> [BfTerm]+elimRedundant (b@(BfIdentifierBfs (ISymb s) [b1, b2]):xs) =+ let+ xs' = if isCommutative s+ then delete (BfIdentifierBfs (ISymb s) [b2, b1]) xs+ else xs+ in+ b:elimRedundant xs'+elimRedundant (x:xs) = x:elimRedundant xs+elimRedundant [] = []++isCommutative :: Symbol -> Bool+isCommutative "and" = True+isCommutative "=" = True+isCommutative "+" = True+isCommutative _ = False++-- | Given:+-- * A mapping of list element to be replaced, to new elements+-- * A list, xs+-- returns a list of new lists. Each new list is xs, but with exactly one+-- occurence of an old element replaced by the corresponding new element.+substsOnces :: (Eq a, Hashable a) => HM.HashMap a a -> [a] -> [[a]]+substsOnces m = substsOnces' m []++substsOnces' :: (Eq a, Hashable a) => HM.HashMap a a -> [a] -> [a] -> [[a]]+substsOnces' m rv [] = []+substsOnces' m rv (x:xs)+ | Just new <- HM.lookup x m = (reverse rv ++ new:xs):rst+ | otherwise = rst+ where+ rst = substsOnces' m (x:rv) xs++-------------------------------+-- Converting to refinement+-------------------------------++stripUnsat :: String -> String+stripUnsat ('u':'n':'s':'a':'t':xs) = xs+stripUnsat xs = xs++refToQualifiers :: SpecType -> [RefNamePolyBound] -> RefNamePolyBound -> [Cmd] -> MeasureSymbols -> LH.TCEmb TyCon -> [Qualifier]+refToQualifiers st arg_pb ret_pb cmds meas_sym tycons =+ let+ arg_termsPB = map (defineFunsPB cmds) arg_pb+ ret_termsPB = defineFunsPB cmds ret_pb+ + lh_e = refToLHExpr' st arg_termsPB ret_termsPB meas_sym+ in+ map (uncurry (refToQualifier tycons)) (concatMap extractValues lh_e)++refToQualifier :: LH.TCEmb TyCon -> [(LH.Symbol, SpecType)] -> LH.Expr -> Qualifier+refToQualifier tycons params e =+ Q { qName = "G2"+ , qParams = map (mkParam tycons) (last params:init params)+ , qBody = e+ , qPos = LH.dummyPos "G2" }++mkParam :: LH.TCEmb TyCon -> (LH.Symbol, SpecType) -> QualParam+mkParam tycons (symb, st) =+ QP { qpSym = symb, qpPat = PatNone, qpSort = funcHead $ rTypeSort tycons st }+ where+ funcHead (LH.FFunc h _) = h+ funcHead s = s++refToLHExpr :: SpecType -> [RefNamePolyBound] -> RefNamePolyBound -> [Cmd] -> MeasureSymbols -> [PolyBound LH.Expr]+refToLHExpr st arg_pb ret_pb cmds meas_sym =+ let+ arg_termsPB = map (defineFunsPB cmds) arg_pb+ ret_termsPB = defineFunsPB cmds ret_pb+ + lh_e = refToLHExpr' st arg_termsPB ret_termsPB meas_sym+ in+ map (mapPB snd) lh_e++defineFunsPB :: [Cmd] -> RefNamePolyBound -> PolyBound ([SortedVar], Term)+defineFunsPB cmds = mapPB (defineFunsPB' cmds)++defineFunsPB' :: [Cmd] -> String -> ([SortedVar], Term)+defineFunsPB' cmds fn+ | Just (SmtCmd (DefineFun _ ars _ trm)) <- find (\(SmtCmd (DefineFun n _ _ _)) -> n == fn) cmds =+ (ars, trm)+ | otherwise = ([], TermLit (LitBool True))++-- | Shift all terms up as much as possible. This avoids expressions being nested more deeply-+-- and thus (in G2) checked more frequently- than needed.+shiftPB :: PolyBound ([SortedVar], Term) -> PolyBound ([SortedVar], Term)+shiftPB pb =+ let+ pb' = shiftPB' pb+ in+ if pb == pb' then pb else shiftPB pb'++shiftPB' :: PolyBound ([SortedVar], Term) -> PolyBound ([SortedVar], Term)+shiftPB' (PolyBound svt@(sv, t) svts) =+ let+ (shift, leave) =+ partition+ (\(PolyBound (sv', t') _) ->+ let+ t_syms = termSymbols t'+ in+ case sv' of+ [] -> False+ _ -> let SortedVar s _ = (last sv') in s `notElem` t_syms) svts++ sv_new = nub $ sv ++ concatMap (\(PolyBound (sv', _) _) -> sv') shift+ t_new =+ case shift of+ [] -> t+ _ -> TermCall (ISymb "and") $ t:map (\(PolyBound (_, t') _) -> t') shift++ shift_new = map (\(PolyBound _ pb) -> PolyBound ([], TermLit (LitBool True)) pb) shift+ in+ PolyBound (sv_new, t_new) (shift_new ++ leave)++refToLHExpr' :: SpecType+ -> [PolyBound ([SortedVar], Term)] -- ^ Arguments+ -> PolyBound ([SortedVar], Term) -- ^ Returns+ -> MeasureSymbols+ -> [PolyBound ([(LH.Symbol, SpecType)], LH.Expr)]+refToLHExpr' st sygus_args sygus_ret meas_sym =+ let+ pieces = specTypePieces st++ -- This is a bit of a dirty hack. The relArgs function drops typeclasses,+ -- so that we don't have to deal with them in the SyGuS solver. But we still+ -- gather the bindings for the typeclasses with specTypeSymbols.+ -- Fortunately, the typeclasses are always the first arguments in the list,+ -- so we can simply take the correct number of arguments from the end of the list.+ -- Then, we fill up the front of the returned PolyBound list with true+ rel_pieces_len = length sygus_args + 1+ tc_num = length pieces - rel_pieces_len+ tc_pb_exprs = map (\st -> PolyBound ([(specTypeSymbol st, st)], PTrue) []) $ take tc_num pieces+ last_pieces = reverse . take rel_pieces_len $ reverse pieces++ sygus_all = sygus_args ++ [sygus_ret]+ sygus_all_inits = filter (not . null) $ inits sygus_all+ pieces_inits = filter (not . null) $ inits last_pieces++ pb_expr = map (uncurry (refToLHExpr'' meas_sym)) $ zip sygus_all_inits pieces_inits+ in+ tc_pb_exprs ++ pb_expr+++refToLHExpr'' :: MeasureSymbols -> [PolyBound ([SortedVar], Term)] -> [SpecType] -> PolyBound ([(LH.Symbol, SpecType)], LH.Expr)+refToLHExpr'' meas_sym sygus_in st =+ let+ sygus_args = map headValue $ init sygus_in+ sygus_ret = last sygus_in++ st_args = map (\st -> (specTypeSymbol st, st)) $ init st+ st_ret = last st++ st_ret_pb = specTypeRAppPiecesInFunc st_ret+ in+ mapPB (\(st, (sv, t)) -> refToLHExpr''' meas_sym (st_args ++ [(specTypeSymbol st, st)]) sv t) $ zipPB st_ret_pb sygus_ret++refToLHExpr''' :: MeasureSymbols -> [(LH.Symbol, SpecType)] -> [SortedVar] -> Term -> ([(LH.Symbol, SpecType)], LH.Expr)+refToLHExpr''' meas_sym symbs_st ars trm =+ let+ ars' = map (\(SortedVar sym _) -> sym) ars++ symbs = map fst symbs_st++ symbsArgs = M.fromList $ zip ars' symbs+ in+ (symbs_st, termToLHExpr meas_sym symbsArgs trm)++termToLHExpr :: MeasureSymbols -> M.Map Sy.Symbol LH.Symbol -> Term -> LH.Expr+termToLHExpr _ m_args (TermIdent (ISymb v)) =+ case M.lookup v m_args of+ Just v' -> EVar v'+ Nothing -> error "termToLHExpr: Variable not found"+termToLHExpr _ _ (TermLit l) = litToLHConstant l+termToLHExpr meas_sym@(MeasureSymbols meas_sym') m_args (TermCall (ISymb v) ts)+ -- Measures+ | Just meas <- find (\meas' -> Just (symbolName meas') == fmap zeroName (maybe_StrToName v)) meas_sym' =+ foldl' EApp (EVar meas) $ map (termToLHExpr meas_sym m_args) ts+ -- Clamped numbers+ | clampIntSymb == v+ , [TermLit l] <- ts = clampedInt l+ | clampDoubleSymb == v+ , [TermCall (ISymb "/") [t1, t2]] <- ts = clampedDouble t1 t2+ | clampDoubleSymb == v+ , [t] <- ts = clampedDouble t (TermLit $ LitNum 1)+ -- EBin+ | "+" <- v+ , [t1, t2] <- ts = EBin LH.Plus (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ | "-" <- v+ , [t1] <- ts = ENeg (termToLHExpr meas_sym m_args t1)+ | "-" <- v+ , [t1, t2] <- ts = EBin LH.Minus (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ | "*" <- v+ , [t1, t2] <- ts = EBin LH.Times (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ | "/" <- v+ , [t1, t2] <- ts+ , Just n1 <- getInteger t1+ , Just n2 <- getInteger t2 = ECon . LHF.R $ fromRational (n1 % n2)+ | "mod" <- v+ , [t1, t2] <- ts = EBin LH.Mod (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ -- Special handling for safe-mod. We enforce via the grammar that the denominator is an Integer+ | "safe-mod" <- v+ , [t1, t2] <- ts+ , TermLit (LitNum n) <- t2 = EBin LH.Mod (termToLHExpr meas_sym m_args t1) (ECon (I ((abs n) + 1)))+ -- More EBin...+ | "and" <- v = PAnd $ map (termToLHExpr meas_sym m_args) ts+ | "or" <- v = POr $ map (termToLHExpr meas_sym m_args) ts+ | "not" <- v, [t1] <- ts = PNot (termToLHExpr meas_sym m_args t1)+ | "=>" <- v+ , [t1, t2] <- ts = PImp (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ -- PAtom+ | "=" <- v+ , [t1, t2] <- ts = PAtom LH.Eq (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ | ">" <- v + , [t1, t2] <- ts = PAtom LH.Gt (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ | ">=" <- v + , [t1, t2] <- ts = PAtom LH.Ge (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ | "<" <- v + , [t1, t2] <- ts = PAtom LH.Lt (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ | "<=" <- v + , [t1, t2] <- ts = PAtom LH.Le (termToLHExpr meas_sym m_args t1) (termToLHExpr meas_sym m_args t2)+ -- More PAtom...+termToLHExpr meas_sym@(MeasureSymbols meas_sym') m_args (TermCall (ISymb v) ts) =+ error $ "v = " ++ show v ++ "\nts = " ++ show ts ++ "\nmaybe_StrToName v = " ++ show (maybe_StrToName v) ++ "\nmeas_syms' = " ++ show (map symbolName meas_sym')+termToLHExpr (_) _ t = error $ "termToLHExpr meas_sym m_args: unhandled " ++ show t++getInteger :: Term -> Maybe Integer+getInteger (TermLit (LitNum n)) = Just n+getInteger (TermCall (ISymb "-") [TermLit (LitNum n)]) = Just (- n)+getInteger _ = Nothing++zeroName :: Name -> Name+zeroName (Name n m _ l) = Name n m 0 l++litToLHConstant :: Sy.Lit -> LH.Expr+litToLHConstant (LitNum n) = ECon (I n)+litToLHConstant (LitBool b) = if b then PTrue else PFalse+litToLHConstant l = error $ "litToLHConstant: Unhandled literal " ++ show l++clampedInt :: Sy.Lit -> LH.Expr+clampedInt (LitNum n)+ | n < 0 = ECon (LHF.I 0)+ | n > clampUpper = ECon (LHF.I clampUpper)+ | otherwise = ECon (LHF.I n)+clampedInt _ = error $ "clampedInt: Unhandled literals"++clampedDouble :: Term -> Term -> LH.Expr+clampedDouble t1 t2+ | n < 0 = ECon (LHF.R 0)+ | n > clampUpper = ECon (LHF.R clampUpper)+ | otherwise = ECon (LHF.R n)+ where+ d1 = termToInteger t1+ d2 = termToInteger t2++ n = fromInteger d1 / fromInteger d2+clampedDouble _ _ = error $ "clampedDouble: Unhandled literals"++termToInteger :: Term -> Integer+termToInteger (TermLit (LitNum d)) = d+termToInteger (TermCall (ISymb "-") [t]) = - (termToInteger t)++-------------------++specTypeNestedSymbol :: SpecType -> LH.Symbol+specTypeNestedSymbol (RFun { rt_in = i }) = specTypeNestedSymbol i+specTypeNestedSymbol st = specTypeSymbol st++specTypeSymbol :: SpecType -> LH.Symbol+specTypeSymbol (RFun { rt_bind = b }) = b+specTypeSymbol rapp@(RApp { rt_reft = ref }) = reftSymbol $ ur_reft ref+specTypeSymbol (RVar { rt_reft = ref }) = reftSymbol $ ur_reft ref+specTypeSymbol _ = error $ "specTypeSymbol: SpecType not handled"++specTypePieces :: SpecType -> [SpecType]+specTypePieces st = specTypePieces' [] st++specTypePieces' :: [SpecType] -> SpecType -> [SpecType]+specTypePieces' sts rfun@(RFun { rt_in = i, rt_out = out }) =+ case i of+ RVar {} -> specTypePieces' sts out+ RFun {} -> specTypePieces' sts out+ _ -> specTypePieces' (rfun:sts) out+specTypePieces' sts rapp@(RApp {}) = reverse (rapp:sts)+specTypePieces' sts rvar@(RVar {}) = reverse (rvar:sts)+specTypePieces' sts (RAllT { rt_ty = out }) = specTypePieces' sts out++specTypeRAppPiecesInFunc :: SpecType -> PolyBound SpecType+specTypeRAppPiecesInFunc (RFun {rt_in = i}) = specTypeRAppPiecesInFunc i+specTypeRAppPiecesInFunc st = specTypeRAppPieces st++specTypeRAppPieces :: SpecType -> PolyBound SpecType+specTypeRAppPieces rapp@(RApp { rt_reft = ref, rt_args = ars }) =+ PolyBound rapp $ map specTypeRAppPieces ars+specTypeRAppPieces rvar@(RVar {}) = PolyBound rvar []+specTypeRAppPieces r = error $ "specTypeRAppPieces: Unexpected SpecType" ++ "\n" ++ show r++-------------------++reftSymbol :: Reft -> LH.Symbol+reftSymbol = fst . unpackReft++unpackReft :: Reft -> (LH.Symbol, LH.Expr) +unpackReft = coerce++-- | Collects all the symbols from a term+termSymbols :: Term -> [Symbol]+termSymbols (TermIdent i) = identifierSymbols i+termSymbols (TermLit _) = []+termSymbols (TermCall i ts) = identifierSymbols i ++ concatMap termSymbols ts+termSymbols (TermExists sv t) = map svSymbol sv ++ termSymbols t+termSymbols (TermForAll sv t) = map svSymbol sv ++ termSymbols t+termSymbols (TermLet vb t) = concatMap vbSymbols vb ++ termSymbols t++identifierSymbols :: Identifier -> [Symbol]+identifierSymbols (ISymb s) = [s]+identifierSymbol (Indexed s inds) = s:mapMaybe indexSymbol inds++indexSymbol :: Index -> Maybe Symbol+indexSymbol (IndSymb s) = Just s+indexSymbol _ = Nothing++svSymbol :: SortedVar -> Symbol+svSymbol (SortedVar s _) = s++vbSymbols :: VarBinding -> [Symbol]+vbSymbols (VarBinding s t) = s:termSymbols t++-------------------------------+-- Calling SyGuS+-------------------------------++runCVC4 :: InferenceConfig -> String -> IO (Either SomeException [Cmd])+runCVC4 infconfig sygus =+ try (+ withSystemTempFile ("cvc4_input.sy")+ (\fp h -> do+ hPutStr h sygus+ -- We call hFlush to prevent hPutStr from buffering+ hFlush h++ toCommandOSX <- findExecutable "gtimeout" + let toCommand = case toCommandOSX of+ Just c -> c -- Mac+ Nothing -> "timeout" -- Linux++ sol <- P.readProcess toCommand ([show (timeout_sygus infconfig), "cvc4", fp, "--lang=sygus2"]) ""++ let sol' = case stripPrefix "unsat" sol of { Just s -> s; Nothing -> error "runCVC4: non-unsat result" }++ return . parse . lexSygus $ sol')+ )++runCVC4StreamSolutions :: InferenceConfig -> Int -> String -> IO (Either SomeException [Cmd])+runCVC4StreamSolutions infconfig grouped sygus =+ try (+ withSystemTempFile ("cvc4_input.sy")+ (\fp h -> do+ hPutStr h sygus+ -- We call hFlush to prevent hPutStr from buffering+ hFlush h++ timeout <- timeOutCommand++ -- --no-sygus-fair-max searches for functions that minimize the sum of the sizes of all functions+ (inp, outp, errp, _) <- P.runInteractiveCommand+ $ timeout ++ " " ++ show (timeout_sygus infconfig)+ ++ " cvc4 " ++ fp ++ " --lang=sygus2 --sygus-stream --no-sygus-fair-max"++ lnes <- checkIfSolution grouped outp++ hClose inp+ hClose outp+ hClose errp++ return lnes+ )+ )++checkIfSolution :: Int -> Handle -> IO [Cmd]+checkIfSolution grouped h = do+ sol <- getSolution grouped h+ let sol' = concatMap (parse . lexSygus) $ sol+ if all (\c -> rInCmd c || noVarInCmd c) sol' then return sol' else checkIfSolution grouped h ++getSolution :: Int -> Handle -> IO [String]+getSolution 0 _ = return []+getSolution !n h = do+ lne <- hGetLine h+ lnes <- getSolution (n - 1) h+ return $ lne:lnes++rInCmd :: Cmd -> Bool+rInCmd (SmtCmd (DefineFun _ _ _ t)) = rInTerm t+rInCmd _ = False++rInTerm :: Term -> Bool+rInTerm (TermIdent (ISymb n)) = n == "r"+rInTerm (TermIdent _) = False+rInTerm (TermLit _) = False+rInTerm (TermCall _ ts) = any rInTerm ts+rInTerm (TermExists _ t) = rInTerm t+rInTerm (TermForAll _ t) = rInTerm t+rInTerm (TermLet vs t) = any (\(VarBinding _ t') -> rInTerm t') vs || rInTerm t ++noVarInCmd :: Cmd -> Bool+noVarInCmd (SmtCmd (DefineFun _ _ _ t)) = noVarInTerm t+noVarInCmd _ = False++noVarInTerm :: Term -> Bool+noVarInTerm (TermIdent _) = False+noVarInTerm (TermLit _) = True+noVarInTerm (TermCall _ ts) = all noVarInTerm ts+noVarInTerm (TermExists _ t) = noVarInTerm t+noVarInTerm (TermForAll _ t) = noVarInTerm t+noVarInTerm (TermLet vs t) = all (\(VarBinding _ t') -> noVarInTerm t') vs && noVarInTerm t ++runCVC4Stream :: Int -> String -> IO (Either SomeException String)+runCVC4Stream max_size sygus =+ try (+ withSystemTempFile ("cvc4_input.sy")+ (\fp h -> do+ hPutStr h sygus+ -- We call hFlush to prevent hPutStr from buffering+ hFlush h++ (inp, outp, errp, _) <- P.runInteractiveCommand+ $ "cvc4 " ++ fp ++ " --lang=sygus2 --sygus-stream --sygus-abort-size=" ++ show max_size++ lnes <- readLines outp []++ hClose inp+ hClose outp+ hClose errp++ return lnes+ )+ )++readLines :: Handle -> [String] -> IO String+readLines h lnes = do+ b <- hIsEOF h+ if b+ then return . concat . reverse $ lnes+ else do+ lne <- hGetLine h+ if "(error" `isInfixOf` lne+ then readLines h lnes+ else readLines h (lne:lnes)++timeOutCommand :: IO String+timeOutCommand = do+ cmdMacOS <- findExecutable "gtimeout"+ case cmdMacOS of+ Just c -> return c+ Nothing -> return "timeout"+-}
+ src/G2/Liquid/Inference/Sygus/SimplifySygus.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE LambdaCase #-}++module G2.Liquid.Inference.Sygus.SimplifySygus ( EliminatedSimple+ , elimSimpleDTs+ , restoreSimpleDTs ++ , elimRedundantAnds+ , splitAnds+ , simplifyImpliesLHS+ , simplifyNegatedAnds++ , EliminatedTrivTrue+ , simplifyToTrue+ , restoreSimplifiedToTrue++ , elimNegatedExistential+ , simplifyImpliesExistentials) where++import Sygus.Syntax++import Data.List+import qualified Data.HashMap.Lazy as M+import Data.Maybe+import qualified Data.Set as S++-- | Maps a tuple of a (1) function name and (2) function param to selector calls and variables+-- with ADTs sorts+data EliminatedSimple = EliminatedSimple { func_args :: M.HashMap Symbol [SortedVar]+ , vars_to_terms :: M.HashMap (Symbol, Symbol) Term }++emptyES :: EliminatedSimple+emptyES = EliminatedSimple M.empty M.empty++insertArgsES :: Symbol -> [SortedVar] -> EliminatedSimple -> EliminatedSimple+insertArgsES fn sv es = es { func_args = M.insert fn sv (func_args es) }++insertTermES :: (Symbol, Symbol) -> Term -> EliminatedSimple -> EliminatedSimple+insertTermES fn_p t es = es { vars_to_terms = M.insert fn_p t (vars_to_terms es) }++lookupArgsES :: Symbol -> EliminatedSimple -> Maybe [SortedVar]+lookupArgsES fn = M.lookup fn . func_args++lookupTermES :: (Symbol, Symbol) -> EliminatedSimple -> Maybe Term+lookupTermES fn_p = M.lookup fn_p . vars_to_terms++selectorToVar :: Symbol -> Symbol -> EliminatedSimple -> Maybe Symbol+selectorToVar fn tn =+ fmap (\((_, v), _) -> v)+ . listToMaybe+ . filter (\((fn', _), t) ->+ case t of+ TermCall (ISymb tn') _ -> fn == fn' && tn == tn'+ _ -> False+ )+ . M.toList+ . vars_to_terms++-----------------------------------------++-- | We define a simple datatype as a datatype that exists only as a wrapper on primitive datatypes+-- This function takes a SyGuS problem containing simple datatypes, and eliminates them.+-- It also returns a mapping, which can be used by `restoreSimpleDTs`, to bring back those datatypes+-- in a solution.+elimSimpleDTs :: [Cmd] -> (EliminatedSimple, [Cmd])+elimSimpleDTs cmds =+ let+ simple_srts = getSimpleSorts cmds+ in+ mapAccumL (elimSimpleDTs' simple_srts) emptyES+ $ filter (not . droppableDTDecl simple_srts) cmds++elimSimpleDTs' :: M.HashMap Symbol (Symbol, [SortedVar]) -> EliminatedSimple -> Cmd -> (EliminatedSimple, Cmd)+elimSimpleDTs' simple_srts es (Constraint t) = (es, Constraint $ elimSimpleDTsTerms simple_srts t)+elimSimpleDTs' _ _ (InvConstraint _ _ _ _) = error "elimSimpleDTs': InvConstraint unsupported"+elimSimpleDTs' simple_srts es (SynthFun fn sv rs (Just gd)) =+ let+ (es', sv') = mapAccumL (elimSimpleDTsSVs fn simple_srts) es sv+ es'' = insertArgsES fn sv es'+ sv'' = concat sv'++ gd' = adjustSimpleInGrammar simple_srts fn es' gd+ in+ (es'', SynthFun fn sv'' rs (Just gd'))+elimSimpleDTs' _ es cmd = (es, cmd)++elimSimpleDTsSVs :: Symbol -> M.HashMap Symbol (Symbol, [SortedVar]) -> EliminatedSimple -> SortedVar -> (EliminatedSimple, [SortedVar])+elimSimpleDTsSVs fn simple_srts es sv@(SortedVar symb srt)+ | IdentSort (ISymb isrt) <- srt+ , Just (_, params) <- M.lookup isrt simple_srts =+ let+ new_sv = map (\(SortedVar n i) -> SortedVar (symb ++ "__" ++ n) i) params+ es' = foldr (\(SortedVar n _) -> insertTermES (fn, symb ++ "__" ++ n) (TermCall (ISymb n) [TermIdent (ISymb symb)])) es params+ in+ (es', new_sv)+ | otherwise = (es, [sv])++elimSimpleDTsTerms :: M.HashMap Symbol (Symbol, [SortedVar]) -> Term -> Term+elimSimpleDTsTerms _ t@(TermIdent _) = t+elimSimpleDTsTerms _ t@(TermLit _) = t+elimSimpleDTsTerms simple_srts (TermCall i ts) =+ swapToIdent . TermCall i $ concatMap (elimSimpleDTsList simple_srts) ts+elimSimpleDTsTerms simple_srts (TermExists sv t) =+ let+ (es, out_as) = mapAccumL+ (\els (SortedVar n srt) ->+ case M.lookup (sortSymb srt) simple_srts of+ Just (_, as) ->+ let+ new_as = map (\(SortedVar s srt') -> SortedVar ("new__" ++ s) srt') as+ els' = insertArgsES n new_as els+ in+ (els', new_as)+ Nothing -> (els, [SortedVar n srt])) emptyES sv+ in+ case concat out_as of+ [] -> elimExistentials es t'+ out_as' -> TermExists out_as' $ elimExistentials es t'+ where+ t' = elimSimpleDTsTerms simple_srts t+elimSimpleDTsTerms _ t = error $ "elimSimpleDTsTerms: Unhandled term " ++ show t++sortSymb :: Sort -> Symbol+sortSymb (IdentSort (ISymb symb)) = symb+sortSymb (IdentSortSort (ISymb symb) _) = symb++elimSimpleDTsList :: M.HashMap Symbol (Symbol, [SortedVar]) -> Term -> [Term]+elimSimpleDTsList simple_srts t@(TermIdent (ISymb s))+ | s `S.member` getSimpleDTs simple_srts = []+ | otherwise = [t]+elimSimpleDTsList _ t@(TermLit _) = [t]+elimSimpleDTsList simple_srts (TermCall (ISymb s) ts)+ | s `S.member` getSimpleDTs simple_srts = ts+ | otherwise = [swapToIdent . TermCall (ISymb s) $ concatMap (elimSimpleDTsList simple_srts) ts]+elimSimpleDTsList simple_srts te@(TermExists _ _) = [elimSimpleDTsTerms simple_srts te]+elimSimpleDTsList _ t = error $ "elimSimpleDTsList: Unhandled term " ++ show t++elimExistentials :: EliminatedSimple -> Term -> Term+elimExistentials _ t@(TermIdent _) = t+elimExistentials _ t@(TermLit _) = t+elimExistentials es (TermCall i ts) =+ swapToIdent . TermCall i $ concatMap (elimExistentialsList es) ts+elimExistentials _ t = error $ "elimExistentials: Unhandled term " ++ show t++elimExistentialsList :: EliminatedSimple -> Term -> [Term]+elimExistentialsList es t@(TermIdent (ISymb s)) =+ case lookupArgsES s es of+ Just as -> map (\(SortedVar i _) -> TermIdent $ ISymb i) as+ Nothing -> [t]+elimExistentialsList _ t@(TermLit _) = [t]+elimExistentialsList es (TermCall i@(ISymb s) ts)+ | Just _ <- lookupArgsES s es = ts+ | otherwise = [swapToIdent . TermCall i $ map (elimExistentials es) ts]+elimExistentialsList _ t = error $ "elimExistentialsList: Unhandled term " ++ show t++swapToIdent :: Term -> Term+swapToIdent (TermCall i []) = TermIdent i+swapToIdent t = t++adjustSimpleInGrammar :: M.HashMap Symbol (Symbol, [SortedVar]) -> Symbol -> EliminatedSimple -> GrammarDef -> GrammarDef+adjustSimpleInGrammar simple_srts fn es (GrammarDef sv grl) =+ GrammarDef (filter (not . simpleGrammarDecls simple_srts) sv)+ . filter (not . simpleProdGRL simple_srts) $ map (adjustSimpleInGRL fn es) grl++simpleGrammarDecls :: M.HashMap Symbol (Symbol, [SortedVar]) -> SortedVar -> Bool+simpleGrammarDecls simple_srts (SortedVar _ (IdentSort (ISymb s))) = s `M.member` simple_srts++simpleProdGRL :: M.HashMap Symbol (Symbol, [SortedVar]) -> GroupedRuleList -> Bool+simpleProdGRL simple_srts (GroupedRuleList _ (IdentSort (ISymb s)) _) = s `M.member` simple_srts++adjustSimpleInGRL :: Symbol -> EliminatedSimple -> GroupedRuleList -> GroupedRuleList+adjustSimpleInGRL fn es (GroupedRuleList symb srt gtrm) =+ GroupedRuleList symb srt $ map (adjustSimpleInGTerms fn es) gtrm++adjustSimpleInGTerms :: Symbol -> EliminatedSimple -> GTerm -> GTerm+adjustSimpleInGTerms fn es (GBfTerm (BfIdentifierBfs (ISymb s) _))+ | Just v <- selectorToVar fn s es = GBfTerm $ BfIdentifier (ISymb v)+adjustSimpleInGTerms _ _ gt = gt+++-----------------------------------------+droppableDTDecl :: M.HashMap Symbol (Symbol, [SortedVar]) -> Cmd -> Bool+droppableDTDecl simple_srts (SmtCmd (DeclareDatatype symb _)) = symb `M.member` simple_srts+droppableDTDecl _ _ = False++-----------------------------------------++-- Maps Sorts with single data constructors to+-- (1) the data constructor name+-- (2) the data constructor arguments.+getSimpleSorts :: [Cmd] -> M.HashMap Symbol (Symbol, [SortedVar])+getSimpleSorts =+ M.fromList+ . concatMap (\case+ SmtCmd (DeclareDatatype s dtdec)+ | Just dti <- isSimpleDT dtdec -> [(s, dti)]+ SmtCmd (DeclareDatatypes _ _) -> error "getEliminatedSimple: declareDatatypes not supported"+ _ -> [])++getSimpleDTs :: M.HashMap Symbol (Symbol, [SortedVar]) -> S.Set Symbol+getSimpleDTs = S.fromList . map fst . M.elems++isSimpleDT :: DTDec -> Maybe (Symbol, [SortedVar])+isSimpleDT (DTDec [DTConsDec dtn sv])+ | all isPrimitiveSV sv = Just (dtn, sv)+isSimpleDT _ = Nothing++isPrimitiveSV :: SortedVar -> Bool+isPrimitiveSV (SortedVar _ (IdentSort (ISymb i))) = i == "Int" || i == "Real" || i == "Bool"+isPrimitiveSV _ = False++-----------------------------------------++-- | Given information about eliminated simple ADTs, restore a solution+restoreSimpleDTs :: EliminatedSimple -> [Cmd] -> [Cmd]+restoreSimpleDTs es = map (restoreSimpleDTs' es)++restoreSimpleDTs' :: EliminatedSimple -> Cmd -> Cmd+restoreSimpleDTs' es (SmtCmd cmd) = SmtCmd $ restoreSimpleDTsSMT es cmd+restoreSimpleDTs' _ _ = error "restoreSimpleDTs: Cmd not supported"++restoreSimpleDTsSMT :: EliminatedSimple -> SmtCmd -> SmtCmd+restoreSimpleDTsSMT es (DefineFun fn sv srt t) =+ let+ sv' = maybe sv id (lookupArgsES fn es)+ in+ DefineFun fn sv' srt $ restoreSimpleDTsTerm es fn t+restoreSimpleDTsSMT _ _ = error "restoreSimpleDTsSMT: Cmd not supported"++restoreSimpleDTsTerm :: EliminatedSimple -> Symbol -> Term -> Term+restoreSimpleDTsTerm es fn t@(TermIdent i)+ | ISymb s <- i+ , Just t' <- lookupTermES (fn, s) es = t'+ | otherwise = t+restoreSimpleDTsTerm es fn (TermCall i ts) = TermCall i $ map (restoreSimpleDTsTerm es fn) ts+restoreSimpleDTsTerm es fn (TermExists sv t) = TermExists sv $ restoreSimpleDTsTerm es fn t+restoreSimpleDTsTerm es fn (TermForAll sv t) = TermForAll sv $ restoreSimpleDTsTerm es fn t+restoreSimpleDTsTerm _ _ (TermLet _ _ ) = error "restoreSimpleDTsTerm: Term not supported"+restoreSimpleDTsTerm _ _ t = t++-----------------------------------------+-- Rewrites to remove redundant Ands++elimRedundantAnds :: [Cmd] -> [Cmd]+elimRedundantAnds = map elimRedundantAnds'++elimRedundantAnds' :: Cmd -> Cmd+elimRedundantAnds' (Constraint t) = Constraint $ elimRedAndsTerm t+elimRedundantAnds' cmd = cmd++elimRedAndsTerm :: Term -> Term+elimRedAndsTerm (TermCall (ISymb "and") ts) =+ TermCall (ISymb "and") $ concatMap inlineAnds ts+elimRedAndsTerm t = t++inlineAnds :: Term -> [Term]+inlineAnds (TermCall (ISymb "and") ts) = concatMap inlineAnds ts+inlineAnds t = [t]++-----------------------------------------+-- Split up anded terms into separate constraints++splitAnds :: [Cmd] -> [Cmd]+splitAnds = concatMap splitAnds'++splitAnds' :: Cmd -> [Cmd]+splitAnds' (Constraint t) = splitAndsTerm t+splitAnds' cmd = [cmd]++splitAndsTerm :: Term -> [Cmd]+splitAndsTerm (TermCall (ISymb "and") ts) = map Constraint ts+splitAndsTerm t = [Constraint t]++-----------------------------------------+-- Simplify by eliminatng any functions from the LHS of an implies that must be true++simplifyImpliesLHS :: [Cmd] -> [Cmd]+simplifyImpliesLHS cmd =+ let+ true_trms = mapMaybe getTrueTerm cmd+ in+ map (simplifyImpliesLHS' true_trms) cmd++simplifyImpliesLHS' :: [Term] -> Cmd -> Cmd+simplifyImpliesLHS' ts (Constraint t) = Constraint $ simplifyImpliesLHSTerm ts t+simplifyImpliesLHS' _ cmd = cmd++simplifyImpliesLHSTerm :: [Term] -> Term -> Term+simplifyImpliesLHSTerm ts (TermCall (ISymb "=>") [lhs, rhs]) =+ case simplifyImpliesLHSTerm' ts lhs of+ Just lhs' -> TermCall (ISymb "=>") [lhs', rhs]+ Nothing -> rhs+simplifyImpliesLHSTerm _ t = t++simplifyImpliesLHSTerm' :: [Term] -> Term -> Maybe Term+simplifyImpliesLHSTerm' ts (TermCall (ISymb "and") and_ts) =+ case mapMaybe (simplifyImpliesLHSTerm' ts) and_ts of+ [] -> Just . TermLit $ LitBool True+ and_ts' -> Just $ TermCall (ISymb "and") and_ts'+simplifyImpliesLHSTerm' ts t = if t `elem` ts then Nothing else Just t++getTrueTerm :: Cmd -> Maybe Term+getTrueTerm (Constraint t) = Just t+getTrueTerm _ = Nothing++-----------------------------------------+-- Simplify by eliminatng any functions from a not-ed and that must be true++simplifyNegatedAnds :: [Cmd] -> [Cmd]+simplifyNegatedAnds cmd =+ let+ true_trms = mapMaybe getTrueTerm cmd+ in+ map (simplifyNegatedAnds' true_trms) cmd++simplifyNegatedAnds' :: [Term] -> Cmd -> Cmd+simplifyNegatedAnds' ts (Constraint t) = Constraint $ simplifyNegatedAndsTerms ts t+simplifyNegatedAnds' _ cmd = cmd++simplifyNegatedAndsTerms :: [Term] -> Term -> Term+simplifyNegatedAndsTerms ts (TermCall (ISymb "not") [t]) =+ TermCall (ISymb "not") $ [simplifyNegatedAndsInNot ts t]+simplifyNegatedAndsTerms ts tc@(TermCall (ISymb "=>") [t, t'])+ | t == TermLit (LitBool True) = simplifyNegatedAndsTerms ts t'+ | otherwise = tc+simplifyNegatedAndsTerms _ t = t++simplifyNegatedAndsInNot :: [Term] -> Term -> Term+simplifyNegatedAndsInNot ts (TermCall (ISymb "and") ts') =+ case filter (`notElem` ts) ts' of+ [] -> TermLit (LitBool True)+ new_ts -> TermCall (ISymb "and") new_ts+simplifyNegatedAndsInNot _ t = t++-----------------------------------------+-- Identify functions that can simply be rewritten to true, use `restoreSimplifiedToTrue`+-- to ensure all functions still appear in the returned solution++newtype EliminatedTrivTrue = EliminatedTrivTrue [Cmd]++simplifyToTrue :: [Cmd] -> (EliminatedTrivTrue, [Cmd])+simplifyToTrue cmds =+ let+ synth_funs = mapMaybe getSynthFuns cmds+ may_need_false = concatMap mayNeedToBeFalse cmds++ synth_set_true = filter (\(n, _, _) -> n `notElem` may_need_false) synth_funs+ synth_set_true' = map (\(n, _, _) -> n) synth_set_true++ -- Set up EliminatedTrivTrue+ tre = TermLit (LitBool True)+ triv_def = map (\(n, ar, r) -> SmtCmd $ DefineFun n ar r tre) synth_set_true+ in+ (EliminatedTrivTrue triv_def, filter (not . mustBeTrue synth_set_true') cmds)++getSynthFuns :: Cmd -> Maybe (Symbol, [SortedVar], Sort)+getSynthFuns (SynthFun n ars ret _) = Just (n, ars, ret)+getSynthFuns _ = Nothing++mayNeedToBeFalse :: Cmd -> [Symbol]+mayNeedToBeFalse (Constraint t) = mayNeedToBeFalseTerm t+mayNeedToBeFalse _ = []++mustBeTrue :: [Symbol] -> Cmd -> Bool+mustBeTrue symbs (SynthFun n _ _ _) = n `elem` symbs+mustBeTrue symbs (Constraint (TermIdent (ISymb s))) = s `elem` symbs+mustBeTrue symbs (Constraint (TermCall (ISymb s) _)) = s `elem` symbs+mustBeTrue _ _ = False++-- If a function is called directly in a constraint, it must be true, but if+-- it is nested in an implies or a not, it may need to be false+mayNeedToBeFalseTerm :: Term -> [Symbol]+mayNeedToBeFalseTerm (TermIdent _) = []+mayNeedToBeFalseTerm (TermLit _) = []+mayNeedToBeFalseTerm (TermCall _ ts) = concatMap mayNeedToBeFalseTerm' ts+mayNeedToBeFalseTerm (TermExists _ t) = mayNeedToBeFalseTerm' t -- Could this just be (mayNeedToBeFalseTerm t)?+mayNeedToBeFalseTerm _ = error "mayNeedToBeFalseTerm: unhandled term" ++mayNeedToBeFalseTerm' :: Term -> [Symbol]+mayNeedToBeFalseTerm' (TermIdent (ISymb s)) = [s]+mayNeedToBeFalseTerm' (TermLit _) = []+mayNeedToBeFalseTerm' (TermCall (ISymb s) ts) = s:concatMap mayNeedToBeFalseTerm' ts+mayNeedToBeFalseTerm' (TermExists _ t) = mayNeedToBeFalseTerm' t+mayNeedToBeFalseTerm' _ = error "mayNeedToBeFalseTerm': unhandled term" ++restoreSimplifiedToTrue :: EliminatedTrivTrue -> [Cmd] -> [Cmd]+restoreSimplifiedToTrue (EliminatedTrivTrue el_cmds) = (++) el_cmds+++-----------------------------------------+-- Elimiantes negated existentials. This simplification actually does NOT keep exactly the same problem.+-- However, in practice, we never benefit from negated existentials when synthesizing a refinement type.++elimNegatedExistential :: [Cmd] -> [Cmd]+elimNegatedExistential = map elimNegatedExistential'++elimNegatedExistential' :: Cmd -> Cmd+elimNegatedExistential' (Constraint t) = Constraint $ elimNegatedExistentialTerm t+elimNegatedExistential' cmd = cmd++elimNegatedExistentialTerm :: Term -> Term+elimNegatedExistentialTerm (TermCall (ISymb "not") [t]) =+ case elimNegatedExistentialTerm' t of+ Nothing -> TermLit (LitBool True)+ Just t' -> TermCall (ISymb "not") [t']+elimNegatedExistentialTerm (TermCall i ts) = TermCall i $ map elimNegatedExistentialTerm ts+elimNegatedExistentialTerm t = t++elimNegatedExistentialTerm' :: Term -> Maybe Term+elimNegatedExistentialTerm' (TermExists _ _) = Nothing+elimNegatedExistentialTerm' (TermCall (ISymb "and") ts) = + case mapMaybe elimNegatedExistentialTerm' ts of+ [] -> Just $ TermLit (LitBool True)+ ts' -> Just $ TermCall (ISymb "and") ts'+elimNegatedExistentialTerm' t = Just t++-----------------------------------------+-- Simplify by eliminatng any existentials from an implies that must be true.+-- This simplification actually does NOT keep exactly the same problem.+-- However, in practice, we never benefit from negated existentials on the LHS of an implies.++simplifyImpliesExistentials :: [Cmd] -> [Cmd]+simplifyImpliesExistentials cmd =+ map simplifyImpliesExistentials' cmd++simplifyImpliesExistentials' :: Cmd -> Cmd+simplifyImpliesExistentials' (Constraint t) = Constraint $ simplifyImpliesExistentialsTerm t+simplifyImpliesExistentials' cmd = cmd++simplifyImpliesExistentialsTerm :: Term -> Term+simplifyImpliesExistentialsTerm (TermCall (ISymb "=>") [lhs, rhs]) =+ TermCall (ISymb "=>") [simplifyImpliesExistentialsTerm' lhs, rhs]+simplifyImpliesExistentialsTerm t = t++simplifyImpliesExistentialsTerm' :: Term -> Term+simplifyImpliesExistentialsTerm' (TermCall (ISymb "and") and_ts) =+ case map simplifyImpliesExistentialsTerm' and_ts of+ [] -> TermLit $ LitBool True+ and_ts' -> TermCall (ISymb "and") and_ts'+simplifyImpliesExistentialsTerm' (TermExists _ _) = TermLit $ LitBool True+simplifyImpliesExistentialsTerm' t = t
+ src/G2/Liquid/Inference/Sygus/SpecInfo.hs view
@@ -0,0 +1,620 @@+{-# LANGUAGE OverloadedStrings #-}++module G2.Liquid.Inference.Sygus.SpecInfo where++import G2.Language as G2+import qualified G2.Language.ExprEnv as E+import G2.Liquid.Conversion+import G2.Liquid.Helpers+import G2.Liquid.Types hiding (SP)+import G2.Liquid.Inference.Config+import G2.Liquid.Inference.FuncConstraint+import G2.Liquid.Inference.G2Calls+import G2.Liquid.Inference.GeneratedSpecs+import G2.Liquid.Inference.PolyRef+import G2.Liquid.Inference.UnionPoly+import G2.Solver as Solver++import Language.Haskell.Liquid.Types as LH hiding (SP, ms, isBool)+import Language.Fixpoint.Types.Refinements as LH hiding (pAnd, pOr)+import qualified Language.Fixpoint.Types as LH++import Control.Monad+import qualified Control.Monad.State.Lazy as SM+import Data.Coerce+import qualified Data.HashMap.Lazy as HM+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Text as T+import Data.Semigroup (Semigroup (..))++type NMExprEnv = HM.HashMap (T.Text, Maybe T.Text) G2.Expr++-- A list of functions that still must have specifications synthesized at a lower level+type ToBeNames = [Name]++-- A list of functions to synthesize a the current level+type ToSynthNames = [Name]+++data Forms = LIA { -- LIA formulas+ c_active :: SMTName++ , c_op_branch1 :: SMTName+ , c_op_branch2 :: SMTName++ , b0 :: SMTName+ , ars_coeffs :: [SMTName]+ , rets_coeffs :: [SMTName] }+ | Set { c_active :: SMTName+ , c_op_branch1 :: SMTName+ , c_op_branch2 :: SMTName++ , int_sing_set_bools_lhs :: [[SMTName]]+ , int_sing_set_bools_rhs :: [[SMTName]]++ , ars_bools_lhs :: [[SMTName]]+ , rets_bools_lhs :: [[SMTName]]++ , ars_bools_rhs :: [[SMTName]]+ , rets_bools_rhs :: [[SMTName]]+ }+ | BoolForm { c_active :: SMTName+ , c_op_branch1 :: SMTName+ , c_op_branch2 :: SMTName++ , ars_bools :: [SMTName]+ , rets_bools :: [SMTName]++ , forms :: [Forms]+ }+ deriving Show++coeffs :: Forms -> [SMTName]+coeffs cf@(LIA {}) = b0 cf:ars_coeffs cf ++ rets_coeffs cf+coeffs (Set {}) = []+coeffs cf@(BoolForm {}) = concatMap coeffs (forms cf)++coeffsNoB :: Forms -> [SMTName]+coeffsNoB cf@(LIA {}) = ars_coeffs cf ++ rets_coeffs cf+coeffsNoB (Set {}) = []+coeffsNoB cf@(BoolForm {}) = concatMap coeffsNoB (forms cf)++setBools :: Forms -> [SMTName]+setBools (LIA {}) = []+setBools s@(Set {}) =+ concat $ int_sing_set_bools_lhs s ++ int_sing_set_bools_rhs s ++ ars_bools_lhs s ++ rets_bools_lhs s ++ ars_bools_rhs s ++ rets_bools_rhs s+setBools cf@(BoolForm {}) = concatMap setBools (forms cf)++boolBools :: Forms -> [SMTName]+boolBools (LIA {}) = []+boolBools (Set {}) = []+boolBools cf@(BoolForm {}) = ars_bools cf ++ rets_bools cf ++ concatMap boolBools (forms cf)+++type Clause = (SMTName, [Forms])+type CNF = [Clause]++data SpecInfo = SI { s_max_coeff :: Integer++ -- A function that is used to record the value of the function at known points,+ -- i.e. points that occur in the FuncConstraints+ , s_known_pre :: FixedSpec+ , s_known_post :: FixedSpec++ -- A function specification that must be synthesized in the future, at a lower level+ , s_to_be_pre :: ToBeSpec+ , s_to_be_post :: ToBeSpec++ -- Functions that capture the pre and post condition.+ -- We have one precondition function per argument+ , s_syn_pre :: [PolyBound SynthSpec]+ , s_syn_post :: PolyBound SynthSpec++ , s_type_pre :: [Type]+ , s_type_post :: Type++ , s_status :: Status }+ deriving (Show)++s_known_pre_name :: SpecInfo -> SMTName+s_known_pre_name = fs_name . s_known_pre++s_known_post_name :: SpecInfo -> SMTName+s_known_post_name = fs_name . s_known_post++s_to_be_pre_name :: SpecInfo -> SMTName+s_to_be_pre_name = tb_name . s_to_be_pre++s_to_be_post_name :: SpecInfo -> SMTName+s_to_be_post_name = tb_name . s_to_be_post++data FixedSpec = FixedSpec { fs_name :: SMTName+ , fs_args :: [SpecArg] }+ deriving (Show)++data ToBeSpec = ToBeSpec { tb_name :: SMTName+ , tb_args :: [SpecArg] }+ deriving (Show)++data SynthSpec = SynthSpec { sy_name :: SMTName+ , sy_args :: [SpecArg]+ , sy_rets :: [SpecArg]+ , sy_coeffs :: CNF }+ deriving (Show)++sy_args_and_ret :: SynthSpec -> [SpecArg]+sy_args_and_ret si = sy_args si ++ sy_rets si++int_sy_args :: SynthSpec -> [SpecArg]+int_sy_args = filter (\a -> smt_sort a == SortInt) . sy_args++int_sy_rets :: SynthSpec -> [SpecArg]+int_sy_rets = filter (\a -> smt_sort a == SortInt) . sy_rets++set_sy_args :: SynthSpec -> [SpecArg]+set_sy_args = filter (isSet . smt_sort) . sy_args++set_sy_rets :: SynthSpec -> [SpecArg]+set_sy_rets = filter (isSet . smt_sort) . sy_rets++bool_sy_args :: SynthSpec -> [SpecArg]+bool_sy_args = filter (\a -> smt_sort a == SortBool) . sy_args++bool_sy_rets :: SynthSpec -> [SpecArg]+bool_sy_rets = filter (\a -> smt_sort a == SortBool) . sy_rets++isSet :: Sort -> Bool+isSet (SortArray _ _) = True+isSet _ = False++int_sy_args_and_ret :: SynthSpec -> [SpecArg]+int_sy_args_and_ret si = int_sy_args si ++ int_sy_rets si++set_sy_args_and_ret :: SynthSpec -> [SpecArg]+set_sy_args_and_ret si = set_sy_args si ++ set_sy_rets si++bool_sy_args_and_ret :: SynthSpec -> [SpecArg]+bool_sy_args_and_ret si = bool_sy_args si ++ bool_sy_rets si++all_sy_args_and_ret :: SynthSpec -> [SpecArg]+all_sy_args_and_ret si = int_sy_args_and_ret si ++ set_sy_args_and_ret si ++ bool_sy_args_and_ret si++data SpecArg = SpecArg { lh_rep :: LH.Expr+ , smt_var :: SMTName+ , smt_sort :: Sort}+ deriving (Show)++data Status = Synth -- ^ A specification should be synthesized+ | ToBeSynthed -- ^ The specification will be synthesized at some lower level+ | Known -- ^ The specification is completely fixed+ deriving (Eq, Show)++buildNMExprEnv :: ExprEnv -> NMExprEnv+buildNMExprEnv = HM.fromList . map (\(n, e) -> ((nameOcc n, nameModule n), e)) . E.toExprList++buildSpecInfo :: (InfConfigM m, ProgresserM m) =>+ NMExprEnv+ -> TypeEnv+ -> TypeClasses+ -> Measures+ -> [GhcInfo]+ -> FuncConstraints+ -> UnionedTypes+ -> ToBeNames+ -> ToSynthNames+ -> m (M.Map Name SpecInfo)+buildSpecInfo eenv tenv tc meas ghci fc ut to_be_ns ns_synth = do+ -- Compensate for zeroed out names in FuncConstraints+ let ns_synth' = map zeroOutName ns_synth++ -- Figure out what the other functions relevant to the current spec are+ let all_calls = concatMap allCallNames $ toListFC fc+ non_ns = filter (`notElem` ns_synth') all_calls++ -- Form tuples of:+ -- (1) Func Names+ -- (2) Function Argument Types+ -- (3) Function Known Types+ -- to be used in forming SpecInfo's+ let ns_aty_rty = map (relNameTypePairs eenv) ns_synth'++ other_aty_rty = map (relNameTypePairs eenv) non_ns+ to_be_ns' = map zeroOutName to_be_ns+ (to_be_ns_aty_rty, known_ns_aty_rty) = L.partition (\(n, _) -> n `elem` to_be_ns') other_aty_rty+++ si <- foldM (\m (n, (at, rt)) -> do+ s <- buildSI tenv tc meas ut Synth ghci n at rt+ return $ M.insert n s m) M.empty ns_aty_rty+ si' <- foldM (\m (n, (at, rt)) -> do+ s <- buildSI tenv tc meas ut ToBeSynthed ghci n at rt+ return $ M.insert n s m) si to_be_ns_aty_rty+ si'' <- foldM (\m (n, (at, rt)) -> do+ s <- buildSI tenv tc meas ut Known ghci n at rt+ return $ M.insert n s m) si' known_ns_aty_rty++ inf_con <- infConfigM++ let si''' = if use_invs inf_con+ then allCondsKnown . conflateLoopNames . elimSyArgs $ si''+ else si''++ return si'''+ where+ zeroOutName (Name n m _ l) = Name n m 0 l++relNameTypePairs :: NMExprEnv -> Name -> (Name, ([Type], Type))+relNameTypePairs eenv n =+ case HM.lookup (nameOcc n, nameModule n) eenv of+ Just e' -> (n, generateRelTypesFromExpr e')+ Nothing -> error $ "synthesize: No expr found"++generateRelTypesFromExpr :: G2.Expr -> ([Type], Type)+generateRelTypesFromExpr = generateRelTypes . inTyForAlls . typeOf++generateRelTypes :: Type -> ([Type], Type)+generateRelTypes t =+ let+ ty_e = PresType t+ arg_ty_c = filter (not . isTYPE)+ . filter (notLH)+ $ argumentTypes ty_e+ ret_ty_c = returnType ty_e+ in+ (arg_ty_c, ret_ty_c)++------------------------------------+-- Building SpecInfos+------------------------------------++buildSI :: (InfConfigM m, ProgresserM m) => TypeEnv -> TypeClasses -> Measures -> UnionedTypes -> Status -> [GhcInfo] -> Name -> [Type] -> Type -> m SpecInfo+buildSI tenv tc meas uts stat ghci f aty rty = do+ let smt_f = nameToStr f+ fspec = case genSpec ghci f of+ Just spec' -> spec'+ _ -> error $ "synthesize: No spec found for " ++ show f++ (outer_ars_pb, ret_pb) <- argsAndRetFromSpec tenv tc ghci meas [] aty rty fspec+ let outer_ars = map fst outer_ars_pb+ ret_v = headValue ret_pb++ arg_ns = zipWith (\a i -> a { smt_var = "x_" ++ show i } ) (concat outer_ars) ([1..] :: [Integer])+ ret_ns = zipWith (\r i -> r { smt_var = "x_r_" ++ show i }) (aar_r ret_v) ([1..] :: [Integer])++ let ut = case lookupUT f uts of+ Just _ut -> _ut+ Nothing -> error $ "buildSI: Missing UnionedType " ++ show f+ (ut_a, ut_r) = generateRelTypes ut+ ut_a' = reverse . take (length outer_ars_pb) $ reverse ut_a+ -- smt_names = assignNamesAndArgCount ut+ smt_names = assignNamesAndArgCount $ mkTyFun (ut_a' ++ [ut_r])++ pre_specs =+ zipWith3 (\ars_pb ut_ar i ->+ let+ ut_pb = extractTypeAppAndFuncPolyBound ut_ar++ ars = map fst (init ars_pb)+ r_pb = snd (last ars_pb)+ in+ mapPB (\(AAndR { aar_a = ex_a, aar_r = rets }, t, j) ->+ case unTyApp t of+ TyVar (Id ut_n _):_ ->+ let+ (nme, count) = fromMaybe+ ("_synth_pre_filler_" ++ show i ++ "_" ++ show j, 0)+ (HM.lookup ut_n smt_names)+ in+ SynthSpec { sy_name = smt_f ++ "_spec" ++ nme+ , sy_args = zipWith (\a k -> a { smt_var = "x_" ++ show k}) (concat (take count ars) ++ ex_a) ([1..] :: [Integer])+ , sy_rets = zipWith (\r k -> r { smt_var = "x_r_" ++ show k}) rets ([1..] :: [Integer])+ , sy_coeffs = []}+ TyFun _ _:_ ->+ SynthSpec { sy_name = smt_f ++ "_synth_pre_filler_" ++ show i ++ "_" ++ show j+ , sy_args = []+ , sy_rets = []+ , sy_coeffs = []}+ _ -> error "buildSI: unsupported Type"+ ) $ zip3PB r_pb ut_pb (uniqueIds r_pb)+ ) (filter (not . null) $ L.inits outer_ars_pb) ut_a' ([1..] :: [Integer])++ return+ SI { s_max_coeff = 0+ , s_known_pre = FixedSpec { fs_name = smt_f ++ "_known_pre"+ , fs_args = arg_ns }+ , s_known_post = FixedSpec { fs_name = smt_f ++ "_known_post"+ , fs_args = arg_ns ++ ret_ns }+ , s_to_be_pre = ToBeSpec { tb_name = smt_f ++ "_to_be_pre"+ , tb_args = arg_ns }+ , s_to_be_post = ToBeSpec { tb_name = smt_f ++ "_to_be_post"+ , tb_args = arg_ns ++ ret_ns }+ , s_syn_pre = pre_specs+ , s_syn_post = mkSynSpecPB smt_f outer_ars (mapPB aar_r ret_pb) smt_names ut_r++ , s_type_pre = aty+ , s_type_post = rty++ , s_status = stat }++data ArgsAndRet = AAndR { aar_a :: [SpecArg], aar_r :: [SpecArg] } deriving Show++instance Semigroup ArgsAndRet where+ AAndR { aar_a = a1, aar_r = r1 } <> AAndR { aar_a = a2, aar_r = r2 } = AAndR { aar_a = a1 <> a2, aar_r = r1 <> r2 }++instance Monoid ArgsAndRet where+ mempty = AAndR { aar_a = [], aar_r = [] }++argsAndRetFromSpec :: (InfConfigM m, ProgresserM m) => TypeEnv -> TypeClasses -> [GhcInfo] -> Measures -> [([SpecArg], PolyBound ArgsAndRet)] -> [Type] -> Type -> SpecType+ -> m ([([SpecArg], PolyBound ArgsAndRet)], PolyBound ArgsAndRet)+argsAndRetFromSpec tenv tc ghci meas ars ts rty (RAllT { rt_ty = out }) =+ argsAndRetFromSpec tenv tc ghci meas ars ts rty out+argsAndRetFromSpec tenv tc ghci meas ars (t:ts) rty (RFun { rt_in = rfun@(RFun {}), rt_out = out}) = do+ let (ts', rty') = generateRelTypes t+ (f_ars, f_ret) <- argsAndRetFromSpec tenv tc ghci meas ars ts' rty' rfun+ let f_ret_list = case f_ret of+ PolyBound (AAndR { aar_a = [], aar_r = [] }) [] -> []+ _ -> [f_ret]+ f_ars_sa = map fst f_ars+ f_ars' = zipWith (\sa pb -> mapPB (AAndR (concat sa)) pb) (L.inits f_ars_sa) (map (mapPB aar_r) $ map snd f_ars ++ f_ret_list)+ argsAndRetFromSpec tenv tc ghci meas (([], PolyBound mempty f_ars'):ars) ts rty out+argsAndRetFromSpec tenv tc ghci meas ars (t:ts) rty rfun@(RFun { rt_in = i, rt_out = out}) = do+ (m_out_symb, sa) <- mkSpecArgPB ghci tenv meas t rfun+ let out_symb = case m_out_symb of+ Just os -> os+ Nothing -> error "argsAndRetFromSpec: out_symb is Nothing"+ case i of+ RVar {} -> argsAndRetFromSpec tenv tc ghci meas ars ts rty out+ RFun {} -> argsAndRetFromSpec tenv tc ghci meas ars ts rty out+ _ -> argsAndRetFromSpec tenv tc ghci meas ((out_symb, sa):ars) ts rty out+argsAndRetFromSpec tenv _ ghci meas ars _ rty rapp@(RApp {}) = do+ (_, sa) <- mkSpecArgPB ghci tenv meas rty rapp+ return (reverse ars, sa)+argsAndRetFromSpec tenv _ ghci meas ars _ rty rvar@(RVar {}) = do+ (_, sa) <- mkSpecArgPB ghci tenv meas rty rvar+ return (reverse ars, sa)+argsAndRetFromSpec _ _ _ _ _ [] _ st@(RFun {}) = error $ "argsAndRetFromSpec: RFun with empty type list " ++ show st+argsAndRetFromSpec _ _ _ _ _ _ _ st = error $ "argsAndRetFromSpec: unhandled SpecType " ++ show st++mkSpecArgPB :: (InfConfigM m, ProgresserM m) => [GhcInfo] -> TypeEnv -> Measures -> Type -> SpecType -> m (Maybe [SpecArg], PolyBound ArgsAndRet)+mkSpecArgPB ghci tenv meas t st = do+ MaxSize mx_meas <- maxSynthFormSizeM+ let t_pb = extractTypePolyBound t++ sy_pb = specTypeSymbolPB st+ in_sy_pb = mapPB inner sy_pb++ t_sy_pb = filterPBByType snd $ zipPB in_sy_pb t_pb+ t_sy_pb' = case t_sy_pb of+ Just pb -> pb+ Nothing -> PolyBound (inner $ headValue sy_pb, t) []++ out_symb = outer $ headValue sy_pb+ out_spec_arg = fmap (\os -> mkSpecArg (fromInteger mx_meas) ghci tenv meas os t) out_symb++ return (out_spec_arg, mapPB (ret . uncurry (mkSpecArg (fromInteger mx_meas) ghci tenv meas)) t_sy_pb')+++mkSpecArg :: Int -> [GhcInfo] -> TypeEnv -> Measures -> LH.Symbol -> Type -> [SpecArg]+mkSpecArg mx_meas ghci tenv meas symb t =+ let+ srt = typeToSort t+ in+ case srt of+ Just srt' ->+ [SpecArg { lh_rep = EVar symb+ , smt_var = "tbd"+ , smt_sort = srt' }]+ Nothing ->+ let+ app_meas = applicableMeasuresType mx_meas tenv meas t+ app_meas' = L.sortBy (\(n1, _) (n2, _) -> compare n1 n2) app_meas+ in+ mapMaybe+ (\(mn, (at, rt)) ->+ let vm = t `specializes` at in+ case vm of+ Just vm' ->+ let++ rt' = applyTypeMap vm' rt+ in+ fmap (\srt' ->+ let+ lh_mn = map (getLHMeasureName ghci) mn+ in+ SpecArg { lh_rep = foldr EApp (EVar symb) $ map EVar lh_mn+ , smt_var = "tbd"+ , smt_sort = srt'}) $ typeToSort rt'+ Nothing -> Nothing) app_meas'++ret :: [SpecArg] -> ArgsAndRet+ret sa = AAndR { aar_a = [], aar_r = sa }++mkSynSpecPB :: String -> [[SpecArg]] -> PolyBound [SpecArg] -> HM.HashMap Name (SMTName, Int) -> Type -> PolyBound SynthSpec+mkSynSpecPB smt_f ars pb_sa smt_names ut =+ let+ ut_pb = extractTypePolyBound ut+ in+ mapPB (\(sa, t, ui) ->+ let+ TyVar (Id ut_n _):_ = unTyApp t+ (nme, count) = fromMaybe+ ("_synth_post_filler", 0)+ (HM.lookup ut_n smt_names)+ arg_ns = zipWith (\a i -> a { smt_var = "x_" ++ show i } ) (concat . take count $ ars) ([1..] :: [Integer])+ ret_ns = map (\(r, i) -> r { smt_var = "x_r_" ++ show ui ++ "_" ++ show i }) $ zip sa ([1..] :: [Integer])+ in+ SynthSpec { sy_name = smt_f ++ "_spec" ++ nme -- smt_f ++ show ui+ , sy_args = arg_ns+ , sy_rets = ret_ns+ , sy_coeffs = [] }+ )+ $ zip3PB pb_sa ut_pb (uniqueIds pb_sa)++filterPBByType :: (v -> Type) -> PolyBound v -> Maybe (PolyBound v)+filterPBByType f = filterPB (\(PolyBound v _) ->+ let+ t = f v+ in+ not (isTyVar t))++assignNamesAndArgCount :: Type -> HM.HashMap Name (SMTName, Int)+assignNamesAndArgCount t = SM.evalState (assignNamesAndArgCount' 0 HM.empty t) 0++assignNamesAndArgCount' :: Int -> HM.HashMap Name (SMTName, Int) -> Type -> SM.State Int (HM.HashMap Name (SMTName, Int))+assignNamesAndArgCount' ar_count hm (TyVar (Id n k))+ | Nothing <- HM.lookup n hm = do+ pos <- SM.get+ SM.modify' (+ 1)+ return $ HM.insert n ("_synth_" ++ show ar_count ++ "_" ++ show pos, ar_count) hm+ | otherwise = return hm+assignNamesAndArgCount' ar_count hm (TyFun t1 t2) = do+ hm' <- assignNamesAndArgCount' ar_count hm t1+ assignNamesAndArgCount' (ar_count + 1) hm' t2+assignNamesAndArgCount' ar_count hm (TyApp t1 t2) = do+ hm' <- assignNamesAndArgCount' ar_count hm t1+ assignNamesAndArgCount' ar_count hm' t2+assignNamesAndArgCount' ar_count hm (TyForAll _ t) = assignNamesAndArgCount' ar_count hm t+assignNamesAndArgCount' _ hm _ = return hm++----------------------------------------------------------------------------+-- Manipulate Evals+----------------------------------------------------------------------------++-- We assign a unique id to each function call, and use these as the arguments+-- to the known functions, rather than somehow using the arguments directly.+-- This means we can get away with needing only a single known function+-- for the pre, and a single known function for the post, as opposed+-- to needing individual known functions/function calls for polymorphic refinements.+assignIds :: Evals Bool -> Evals (Integer, Bool)+assignIds = snd . mapAccumLEvals (\i b -> (i + 1, (i, b))) 0++----------------------------------------------------------------------------+-- Manipulate SpecTypes+----------------------------------------------------------------------------++data SymbolPair = SP { inner :: LH.Symbol, outer :: Maybe LH.Symbol }++specTypeSymbolPB :: SpecType -> PolyBound SymbolPair+specTypeSymbolPB (RFun { rt_bind = b, rt_in = i }) =+ case specTypeSymbolPB i of+ PolyBound sp ps -> PolyBound (sp { outer = Just b}) ps+specTypeSymbolPB (RApp { rt_reft = ref, rt_args = ars }) =+ PolyBound (SP { inner = reftSymbol $ ur_reft ref, outer = Nothing}) $ map specTypeSymbolPB ars+specTypeSymbolPB (RVar {rt_reft = ref}) =+ PolyBound (SP { inner = reftSymbol $ ur_reft ref, outer = Nothing }) []+specTypeSymbolPB r = error $ "specTypeSymbolPB: Unexpected SpecType" ++ "\n" ++ show r++reftSymbol :: Reft -> LH.Symbol+reftSymbol = fst . unpackReft++unpackReft :: Reft -> (LH.Symbol, LH.Expr)+unpackReft = coerce++----------------------------------------------------------------------------+-- Invariant configuration+----------------------------------------------------------------------------++elimPolyArgSpecs :: M.Map a SpecInfo -> M.Map a SpecInfo+elimPolyArgSpecs = M.map elimPolyArgSpecs'++elimPolyArgSpecs' :: SpecInfo -> SpecInfo+elimPolyArgSpecs' si = si { s_syn_pre = map (\(PolyBound a _) -> PolyBound a []) (s_syn_pre si)+ , s_syn_post = (\(PolyBound a _) -> PolyBound a []) (s_syn_post si)}++elimSyArgs :: M.Map Name SpecInfo -> M.Map Name SpecInfo+elimSyArgs = M.mapWithKey (\n si -> if specialFunction n then elimSyArgs' si else si)++elimSyArgs' :: SpecInfo -> SpecInfo+elimSyArgs' si = si { s_syn_pre = map (mapPB dropNonDirectInt) (s_syn_pre si)+ , s_syn_post = mapPB dropNonDirectInt (s_syn_post si)}++dropNonDirectInt :: SynthSpec -> SynthSpec+dropNonDirectInt sy = sy { sy_args = filter dropNonDirectInt' (sy_args sy) }++dropNonDirectInt' :: SpecArg -> Bool+dropNonDirectInt' sy =+ case lh_rep sy of+ EVar {} -> True+ _ -> False++specialFunction :: Name -> Bool+specialFunction (Name n _ _ _) | T.take 4 n == "loop" = True+ | T.take 5 n == "while" = True+ | T.take 5 n == "breakWhile" = True+ | otherwise = False++conflateLoopNames :: M.Map a SpecInfo -> M.Map a SpecInfo+conflateLoopNames = M.map conflateLoopNames'++conflateLoopNames' :: SpecInfo -> SpecInfo+conflateLoopNames' si@(SI { s_syn_pre = pb_sy_pre@(_:_)+ , s_syn_post = pb_post@(PolyBound sy_post _) })+ | take 4 (sy_name sy_post) == "loop" =+ let+ pb_pre = last pb_sy_pre+ in+ si { s_syn_pre = init pb_sy_pre ++ [conflateLoopNames'' pb_pre pb_post] }+conflateLoopNames' si = si++conflateLoopNames'' :: PolyBound SynthSpec -> PolyBound SynthSpec -> PolyBound SynthSpec+conflateLoopNames'' pb1 = mapPB (\(sy1, sy2) -> sy1 { sy_name = sy_name sy2} ) . zipPB pb1++allCondsKnown :: M.Map a SpecInfo -> M.Map a SpecInfo+allCondsKnown = M.map allCondsKnown'++allCondsKnown' :: SpecInfo -> SpecInfo+allCondsKnown' si@(SI { s_syn_post = (PolyBound sy_post _) })+ | take 4 (sy_name sy_post) == "cond" = si { s_status = Known }+allCondsKnown' si = si++----------------------------------------------------------------------------++typeToSort :: Type -> Maybe Sort+typeToSort (TyApp (TyCon (Name n _ _ _) _) t)+ | n == "Set"+ , Just s <- typeToSort t = Just (SortArray s SortBool)+typeToSort (TyCon (Name n _ _ _) _)+ | n == "Int" = Just SortInt+ | n == "Bool" = Just SortBool+typeToSort _ = Nothing++getLHMeasureName :: [GhcInfo] -> Name -> LH.Symbol+getLHMeasureName ghci (Name n m _ l) =+ let+ MeasureSymbols meas_symb = measureSymbols ghci+ zn = Name n m 0 l+ in+ case L.find (\meas -> symbolName meas == zn) meas_symb of+ Just meas -> meas+ Nothing -> error "getLHMeasureName: unhandled measure"++applicableMeasuresType :: Int -> TypeEnv -> Measures -> Type -> [([Name], (Type, Type))]+applicableMeasuresType mx_meas tenv meas t =+ HM.toList . HM.map (\es -> case filter notLH . anonArgumentTypes $ last es of+ [at]+ | Just (rt, _) <- chainReturnType t es -> (at, rt)+ _ -> error $ "applicableMeasuresType: too many arguments" ++ "\n" ++ show es)+ $ applicableMeasures mx_meas tenv meas t++applicableMeasures :: Int -> TypeEnv -> Measures -> Type -> HM.HashMap [Name] [G2.Expr]+applicableMeasures mx_meas tenv meas t =+ HM.fromList . map unzip+ . filter repFstSnd+ . filter (maybe False (isJust . typeToSort . fst) . chainReturnType t . map snd)+ $ formMeasureComps mx_meas tenv t meas++-- LiquidHaskell includes measures to extract from tuples of various sizes.+-- It includes redundant pairs (fst and x_Tuple21) and (snd and x_Tuple22).+-- Including both measures slows down the synthesis, so we eliminates+-- chains involving x_Tuple21 and x_Tuple22.+repFstSnd :: [(Name, a)] -> Bool+repFstSnd = all (\(Name n _ _ _) -> n /= "x_Tuple21" && n /= "x_Tuple22") . map fst++notLH :: Type -> Bool+notLH ty+ | TyCon (Name n _ _ _) _ <- tyAppCenter ty = n /= "lh"+ | otherwise = True+
+ src/G2/Liquid/Inference/Sygus/Sygus.hs view
@@ -0,0 +1,417 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module G2.Liquid.Inference.Sygus.Sygus where++import G2.Language as G2+import G2.Liquid.Interface+import G2.Liquid.Types+import G2.Liquid.Inference.Config+import G2.Liquid.Inference.FuncConstraint+import G2.Liquid.Inference.G2Calls+import G2.Liquid.Inference.PolyRef+import G2.Liquid.Inference.UnionPoly+import G2.Liquid.Inference.Sygus.FCConverter+import G2.Liquid.Inference.Sygus.SpecInfo+import G2.Solver as Solver++import Sygus.LexSygus+import Sygus.ParseSygus+import Sygus.Print+import Sygus.Syntax as Sy++import Control.Monad.IO.Class +import Data.Hashable+import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HS+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Data.Ratio+import qualified Data.Text as T++import Language.Haskell.Liquid.Types as LH hiding (SP, ms, isBool)++generateSygusProblem :: (InfConfigM m, ProgresserM m, MonadIO m) =>+ [GhcInfo]+ -> LiquidReadyState+ -> Evals Bool+ -> MeasureExs+ -> FuncConstraints+ -> UnionedTypes+ -> ToBeNames+ -> ToSynthNames+ -> m [Cmd]+generateSygusProblem ghci lrs evals meas_ex fc ut to_be_ns ns_synth = do+ -- Figure out the type of each of the functions we need to synthesize+ let eenv = buildNMExprEnv $ expr_env . state $ lr_state lrs+ tenv = type_env . state $ lr_state lrs+ tc = type_classes . state $ lr_state lrs+ meas = lrsMeasures ghci lrs++ si <- buildSpecInfo eenv tenv tc meas ghci fc ut to_be_ns ns_synth++ let grammar = buildGrammars si++ let eval_ids = assignIds evals+ to_be_consts = createToBeConsts si eval_ids+ constraints <- constraintsToSygus eenv tenv meas meas_ex eval_ids si fc++ let cmds = [ SmtCmd (Sy.SetLogic "ALL")] ++ to_be_consts ++ grammar ++ constraints ++ [CheckSynth]++ liftIO $ putStrLn "-------------\nSyGuS\n"+ liftIO . putStrLn . T.unpack . printSygus $ cmds+ liftIO $ putStrLn "-------------"++ return cmds++-------------------------------+-- Grammar+-------------------------------++buildGrammars :: M.Map Name SpecInfo -> [Cmd]+buildGrammars =+ concatMap buildGrammars' . M.elems . M.filter (\si -> s_status si == Synth)++buildGrammars' :: SpecInfo -> [Cmd]+buildGrammars' si =+ map buildGrammars'' $ extractValues (s_syn_post si) ++ concatMap extractValues (s_syn_pre si)++buildGrammars'' :: SynthSpec -> Cmd+buildGrammars'' sy_spec =+ SynthFun (sy_name sy_spec)+ (map buildGramArgs $ sy_args_and_ret sy_spec)+ (IdentSort (ISymb "Bool"))+ . Just $ buildGrammar sy_spec++buildGramArgs :: SpecArg -> SortedVar+buildGramArgs sa = SortedVar (smt_var sa) (smtSortToSygusSort $ smt_sort sa)++buildGrammar :: SynthSpec -> GrammarDef+buildGrammar sy_spec =+ -- forceVarInGrammar (buildGramArgs $ sy_rets sy_spec)+ -- (map buildGramArgs $ sy_args sy_spec)+ (buildGrammar' sy_spec)++buildGrammar' :: SynthSpec -> GrammarDef+buildGrammar' sy_spec =+ GrammarDef + [ SortedVar "B" (IdentSort (ISymb "Bool"))+ , SortedVar "IConst" (IdentSort (ISymb "Int"))+ , SortedVar "I" (IdentSort (ISymb "Int"))]+ [ GroupedRuleList "B" (IdentSort (ISymb "Bool"))+ [ GVariable (IdentSort (ISymb "Bool"))+ , GConstant (IdentSort (ISymb "Bool"))+ , GBfTerm (BfIdentifierBfs (ISymb "=") [BfIdentifier (ISymb "I"), BfIdentifier (ISymb "I")])+ , GBfTerm (BfIdentifierBfs (ISymb ">") [BfIdentifier (ISymb "I"), BfIdentifier (ISymb "I")])+ , GBfTerm (BfIdentifierBfs (ISymb ">=") [BfIdentifier (ISymb "I"), BfIdentifier (ISymb "I")])+ ]+ , GroupedRuleList "IConst" (IdentSort (ISymb "Int"))+ [ GConstant (IdentSort (ISymb "Int")) ]+ , GroupedRuleList "I" (IdentSort (ISymb "Int"))+ [ GVariable (IdentSort (ISymb "Int"))+ , GConstant (IdentSort (ISymb "Int"))+ , GBfTerm (BfIdentifierBfs (ISymb "+") [BfIdentifier (ISymb "I"), BfIdentifier (ISymb "I")])+ , GBfTerm (BfIdentifierBfs (ISymb "*") [BfIdentifier (ISymb "IConst"), BfIdentifier (ISymb "I")])+ ]+ ]++-------------------------------+-- Constraints+-------------------------------++constraintsToSygus :: (InfConfigM m, ProgresserM m) =>+ NMExprEnv+ -> TypeEnv+ -> Measures+ -> MeasureExs+ -> Evals (Integer, Bool)+ -> M.Map Name SpecInfo+ -> FuncConstraints+ -> m [Cmd]+constraintsToSygus eenv tenv meas meas_ex evals si fc =+ return . map Constraint =<<+ convertConstraints + convertExprToTerm+ (ifNotNull mkSygusAnd (TermLit (LitBool True)))+ (ifNotNull mkSygusOr (TermLit (LitBool False)))+ mkSygusNot+ mkSygusImplies+ (\s -> TermCall (ISymb s))+ (\_ _ -> TermLit . LitBool)+ (\n i b ->+ if b then+ TermIdent (ISymb $ n ++ "__SYGUS_INT__" ++ show i)+ else TermLit (LitBool False))+ eenv tenv meas meas_ex evals si fc+ where+ ifNotNull _ def [] = def+ ifNotNull f _ xs = f xs++ mkSygusAnd = TermCall (ISymb "and") + mkSygusOr = TermCall (ISymb "or") + mkSygusNot t = TermCall (ISymb "not") [t]+ mkSygusImplies t1 t2 = TermCall (ISymb "=>") [t1, t2]++convertExprToTerm :: G2.Expr -> Term+convertExprToTerm (Data (DataCon (Name n _ _ _) _))+ | "True" <- n = TermLit $ LitBool True+ | "False" <- n =TermLit $ LitBool False+convertExprToTerm (Lit l) = litToTerm l+convertExprToTerm e = error $ "convertExprToTerm: Unhandled Expr " ++ show e++litToTerm :: G2.Lit -> Term+litToTerm (LitInt i) = TermLit (LitNum i)+litToTerm (LitDouble d) = TermCall (ISymb "/") [ TermLit . LitNum $ numerator d+ , TermLit . LitNum $ denominator d]+litToTerm (LitChar c) = TermLit (LitStr [c])+litToTerm _ = error "litToTerm: Unhandled Lit"++createToBeConsts :: M.Map Name SpecInfo -> Evals (Integer, Bool) -> [Cmd]+createToBeConsts si ev =+ let si' = M.mapKeys zeroOutName si in+ createToBeConsts' s_to_be_pre_name si' (pre_evals ev)+ ++ createToBeConsts' s_to_be_post_name si' (post_evals ev)+ where+ zeroOutName (Name n m _ l) = Name n m 0 l+++createToBeConsts' :: (SpecInfo -> SMTName) -> M.Map Name SpecInfo -> FCEvals ((Integer, Bool)) -> [Cmd]+createToBeConsts' f si = mapMaybe (createToBeConsts'' f si)+ . concatMap (\(n, es) -> map (n,) es)+ . HM.toList+ . HM.map HM.elems++createToBeConsts'' :: (SpecInfo -> SMTName) -> M.Map Name SpecInfo -> (Name, (Integer, Bool)) -> Maybe Cmd+createToBeConsts'' f si (n, (i, _))+ | Just si' <- M.lookup n si+ , s_status si' == ToBeSynthed =+ Just $ DeclareVar (f si' ++ "__SYGUS_INT__" ++ show i) (IdentSort (ISymb "Bool"))+ | otherwise = Nothing++-------------------------------+-- Sorts+-------------------------------++smtSortToSygusSort :: Solver.Sort -> Sy.Sort+smtSortToSygusSort SortBool = IdentSort (ISymb "Bool")+smtSortToSygusSort SortInt = IdentSort (ISymb "Int")+smtSortToSygusSort s = error $ "smtSortToSygusSort: unsupported sort" ++ "\n" ++ show s++-------------------------------+-- Enforcing return value use+-------------------------------++-- Adjusts a grammar to force using a given GTerm++forceVarInGrammar :: SortedVar -- ^ The variable to force+ -> [SortedVar] -- ^ All other variables+ -> GrammarDef+ -> GrammarDef+forceVarInGrammar vr params (GrammarDef sv grls) =+ let+ prod_srt = mapMaybe (\grl@(GroupedRuleList grl_symb _ _) ->+ if any (flip canProduceVar grl) (vr:params)+ then Just grl_symb+ else Nothing ) grls++ reach = gramSymbReachableFrom prod_srt grls++ sv_reach = concatMap (grammarDefSortedVars reach) sv++ (sv_final, grl_final) = elimNonTermGRL vr (forceVarInGRLList vr reach grls) sv_reach+ in+ GrammarDef sv_final grl_final++forceVarInGRLList :: SortedVar -> [Symbol] -> [GroupedRuleList] -> [GroupedRuleList]+forceVarInGRLList vr reach grls =+ let+ fv_map = HM.fromList $ map (\n -> (toBf n, toBf $ forcedVarSymb n)) reach++ in+ concatMap (forceVarInGRL vr reach fv_map) grls+ where+ toBf = BfIdentifier . ISymb++forceVarInGRL :: SortedVar -> [Symbol] -> HM.HashMap BfTerm BfTerm -> GroupedRuleList -> [GroupedRuleList]+forceVarInGRL (SortedVar sv_symb sv_srt) reach fv_map grl@(GroupedRuleList grl_symb grl_srt gtrms)+ | grl_symb `elem` reach =+ let+ bf_var = BfIdentifier (ISymb sv_symb)+ fv_gtrms' = if sv_srt == grl_srt+ then GBfTerm bf_var:(filter (not . isClamp) $ elimVariable fv_gtrms)+ else filter (not . isClamp) $ elimVariable fv_gtrms+ in+ [GroupedRuleList fv_symb grl_srt fv_gtrms', grl]+ | otherwise = [grl]+ where+ fv_symb = forcedVarSymb grl_symb+ fv_gtrms = substOnceGTerms fv_map gtrms+++forcedVarSymb :: Symbol -> Symbol+forcedVarSymb = ("fv_" ++)++elimVariable :: [GTerm] -> [GTerm]+elimVariable = filter (\t -> case t of+ GVariable _ -> False+ _ -> True)++elimNonTermGRL :: SortedVar -> [GroupedRuleList] -> [SortedVar] -> ([SortedVar], [GroupedRuleList])+elimNonTermGRL (SortedVar sv_n _) grls sv =+ let+ has_term = hasTermFix (HS.singleton sv_n) grls++ sv' = filter (\(SortedVar n _) -> n `elem` has_term) sv+ grls' = map (elimRules has_term)+ $ filter (\(GroupedRuleList n _ _) -> n `elem` has_term) grls+ in+ (sv', grls')++hasTermFix :: HS.HashSet Symbol -> [GroupedRuleList] -> [Symbol]+hasTermFix ht grl =+ let+ ht' = HS.fromList+ . map (\(GroupedRuleList n _ _) -> n)+ $ filter (hasTermGRL ht) grl+++ ht_all = HS.union ht ht'+ in+ if ht == ht_all then HS.toList ht_all else hasTermFix ht_all grl++hasTermGRL :: HS.HashSet Symbol -> GroupedRuleList -> Bool+hasTermGRL ht (GroupedRuleList n _ r) = n `HS.member` ht || any (hasTermGTerm ht) r++hasTermGTerm :: HS.HashSet Symbol -> GTerm -> Bool+hasTermGTerm _ (GConstant _) = True+hasTermGTerm _ (GVariable _) = True+hasTermGTerm ht (GBfTerm bft) = hasTermBfTerm ht bft++hasTermBfTerm :: HS.HashSet Symbol -> BfTerm -> Bool+hasTermBfTerm ht (BfIdentifier (ISymb i)) = i `HS.member` ht+hasTermBfTerm _ (BfLiteral _) = True+hasTermBfTerm ht (BfIdentifierBfs _ bfs) = all (hasTermBfTerm ht) bfs++isClamp :: GTerm -> Bool+isClamp (GBfTerm (BfIdentifier (ISymb "IClamp"))) = True+isClamp (GBfTerm (BfIdentifier (ISymb "DClamp"))) = True+isClamp _ = False++elimRules :: [Symbol] -> GroupedRuleList -> GroupedRuleList+elimRules grls (GroupedRuleList symb srt r) =+ GroupedRuleList symb srt $ filter (elimRules' grls) r++elimRules' :: [Symbol] -> GTerm -> Bool+elimRules' _ (GConstant _) = True+elimRules' _ (GVariable _) = True+elimRules' grls (GBfTerm bft) = elimRulesBfT grls bft++elimRulesBfT :: [Symbol] -> BfTerm -> Bool+elimRulesBfT grls (BfIdentifier (ISymb i)) = i `elem` grls+elimRulesBfT _ (BfLiteral _) = True+elimRulesBfT grls (BfIdentifierBfs _ bfs) = all (elimRulesBfT grls) bfs++-----------------------------------------------------++-- Substitution functions++substOnceGTerms :: HM.HashMap BfTerm BfTerm -> [GTerm] -> [GTerm]+substOnceGTerms m = concatMap (substOnceGTerm m)++substOnceGTerm :: HM.HashMap BfTerm BfTerm -> GTerm -> [GTerm]+substOnceGTerm m (GBfTerm bf) = map GBfTerm $ substOnceBfTerm m bf+substOnceGTerm _ gt = [gt]++substOnceBfTerm :: HM.HashMap BfTerm BfTerm -> BfTerm -> [BfTerm]+substOnceBfTerm m (BfIdentifierBfs c bfs) = elimRedundant . map (BfIdentifierBfs c) $ substsOnces m bfs+substOnceBfTerm _ bf = [bf]++elimRedundant :: [BfTerm] -> [BfTerm]+elimRedundant (b@(BfIdentifierBfs (ISymb s) [b1, b2]):xs) =+ let+ xs' = if isCommutative s+ then delete (BfIdentifierBfs (ISymb s) [b2, b1]) xs+ else xs+ in+ b:elimRedundant xs'+elimRedundant (x:xs) = x:elimRedundant xs+elimRedundant [] = []++isCommutative :: Symbol -> Bool+isCommutative "and" = True+isCommutative "=" = True+isCommutative "+" = True+isCommutative _ = False++-- | Given:+-- * A mapping of list element to be replaced, to new elements+-- * A list, xs+-- returns a list of new lists. Each new list is xs, but with exactly one+-- occurence of an old element replaced by the corresponding new element.+substsOnces :: (Eq a, Hashable a) => HM.HashMap a a -> [a] -> [[a]]+substsOnces m = substsOnces' m []++substsOnces' :: (Eq a, Hashable a) => HM.HashMap a a -> [a] -> [a] -> [[a]]+substsOnces' _ _ [] = []+substsOnces' m rv (x:xs)+ | Just new <- HM.lookup x m = (reverse rv ++ new:xs):rst+ | otherwise = rst+ where+ rst = substsOnces' m (x:rv) xs++-----------------------------------------------------++grammarDefSortedVars :: [Symbol] -> SortedVar -> [SortedVar]+grammarDefSortedVars symbs sv@(SortedVar n srt)+ | n `elem` symbs = [SortedVar (forcedVarSymb n) srt, sv]+ | otherwise = [sv]++canProduceVar :: SortedVar -> GroupedRuleList -> Bool+canProduceVar vr@(SortedVar _ sv_srt) (GroupedRuleList _ grl_srt gtrms)+ | sv_srt == grl_srt = any (canProduceVarGTerm vr) gtrms+ | otherwise = False++canProduceVarGTerm :: SortedVar -> GTerm -> Bool+canProduceVarGTerm (SortedVar _ sv_srt) (GVariable gv_srt) = sv_srt == gv_srt+canProduceVarGTerm (SortedVar s _) (GBfTerm (BfIdentifier (ISymb is))) = s == is+canProduceVarGTerm s (GBfTerm (BfIdentifierBfs _ bfs)) = any (canProduceVarGTerm s) $ map GBfTerm bfs+canProduceVarGTerm _ (GBfTerm (BfLiteral _)) = False+canProduceVarGTerm _ (GConstant _) = False+canProduceVarGTerm _ t = error $ "Unhandled term" ++ show t++-----------------------------------------------------++-- Reachability checks++gramSymbReachableFrom :: [Symbol] -> [GroupedRuleList] -> [Symbol]+gramSymbReachableFrom = gramSymbReachableFrom' HS.empty++gramSymbReachableFrom' :: HS.HashSet Symbol -> [Symbol] -> [GroupedRuleList] -> [Symbol]+gramSymbReachableFrom' searched [] _ = HS.toList searched+gramSymbReachableFrom' searched (x:xs) grls+ | x `HS.member` searched = gramSymbReachableFrom' searched xs grls+ | otherwise =+ let+ contains_x = map (\(GroupedRuleList s _ _) -> s)+ $ filter (containsSymbol x) grls+ in+ gramSymbReachableFrom' (HS.insert x searched) (contains_x ++ xs) grls++containsSymbol :: Symbol -> GroupedRuleList -> Bool+containsSymbol symb (GroupedRuleList _ _ gtrms) = any (containsSymbolGTerm symb) gtrms++containsSymbolGTerm :: Symbol -> GTerm -> Bool+containsSymbolGTerm symb (GBfTerm bf) = containsSymbolBfTerm symb bf+containsSymbolGTerm _ _ = False++containsSymbolBfTerm :: Symbol -> BfTerm -> Bool+containsSymbolBfTerm symb (BfIdentifier ident) = containsSymbolIdent symb ident+containsSymbolBfTerm symb (BfIdentifierBfs ident bfs) =+ containsSymbolIdent symb ident || any (containsSymbolBfTerm symb) bfs+containsSymbolBfTerm _ (BfLiteral _) = False++containsSymbolIdent :: Symbol -> Identifier -> Bool+containsSymbolIdent symb (ISymb symb') = symb == symb'+containsSymbolIdent _ _ = False+
+ src/G2/Liquid/Inference/Sygus/UnsatCoreElim.hs view
@@ -0,0 +1,36 @@+module G2.Liquid.Inference.Sygus.UnsatCoreElim (unsatCoreElim) where++import Sygus.Syntax++import Data.Maybe++-- | Eliminates negative constraints that would lead to an unsat core+unsatCoreElim :: [Cmd] -> [Cmd]+unsatCoreElim cmds =+ let+ true_terms = mapMaybe getTrueTerm cmds+ in+ mapMaybe (unsatCoreElim' true_terms) cmds++unsatCoreElim' :: [Term] -> Cmd -> Maybe Cmd+unsatCoreElim' ts cmd@(Constraint t) =+ if mustBeFalse ts t then Nothing else Just cmd+unsatCoreElim' _ cmd = Just cmd++mustBeFalse :: [Term] -> Term -> Bool+mustBeFalse ts (TermCall (ISymb "=>") [t1, t2]) =+ mustBeTrue ts t1 && mustBeFalse ts t2+mustBeFalse ts (TermCall (ISymb "not") [t1]) = mustBeTrue ts t1+mustBeFalse ts (TermCall (ISymb "and") and_ts) = any (mustBeFalse ts) and_ts+mustBeFalse _ (TermLit (LitBool False)) = True+mustBeFalse _ _ = False++mustBeTrue :: [Term] -> Term -> Bool+mustBeTrue ts (TermCall (ISymb "=>") [t1, t2]) = mustBeFalse ts t1 || mustBeTrue ts t2+mustBeTrue ts (TermCall (ISymb "and") and_ts) = all (mustBeTrue ts) and_ts+mustBeTrue _ (TermLit (LitBool True)) = True+mustBeTrue ts t = t `elem` ts++getTrueTerm :: Cmd -> Maybe Term+getTrueTerm (Constraint t) = Just t+getTrueTerm _ = Nothing
+ src/G2/Liquid/Inference/UnionPoly.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}++module G2.Liquid.Inference.UnionPoly (UnionedTypes, sharedTyConsEE, lookupUT) where++import qualified G2.Data.UFMap as UF+import qualified G2.Data.UnionFind as UFind+import G2.Language+import qualified G2.Language.ExprEnv as E+import G2.Language.Monad.AST+import G2.Language.Monad.Naming+import G2.Language.Monad.Support++import Control.Monad+import qualified Data.HashMap.Lazy as HM+import Data.Maybe+import qualified Data.Text as T++newtype UnionedTypes = UT (HM.HashMap Name Type) deriving Show++lookupUT :: Name -> UnionedTypes -> Maybe Type+lookupUT (Name n m _ l) (UT ut) = HM.lookup (Name n m 0 l) ut++sharedTyConsEE :: [Name] -> ExprEnv -> UnionedTypes+sharedTyConsEE ns eenv = fst $ runNamingM (sharedTyConsEE' ns eenv) (mkNameGen eenv)++sharedTyConsEE' :: [Name] -> ExprEnv -> NameGenM UnionedTypes+sharedTyConsEE' ns eenv = do+ let f_eenv = E.filterWithKey (\n _ -> n `elem` ns) eenv+ typeOf_eenv = E.map' typeOf f_eenv+ tys <- mapM assignTyConNames typeOf_eenv++ let rep_eenv = E.map (repVars tys) f_eenv+ rep_eenv' = elimTypes rep_eenv+ -- We want to try and be clever with passed in functions/lamdas to unify types when required,+ -- but we can do too much if we unify non-function types or inner lambdas.+ -- This is very much a heuristic.+ rep_eenv'' <- E.mapM (scrambleNonFuncLams >=> scrambleNonFuncLets)+ . substLams+ . adjustLetTypes+ =<< E.mapM (assignTyConNames >=> elimTyForAll) rep_eenv'++ let union_poly = mconcat . map UF.joinedKeys . HM.elems+ . E.map' (fromMaybe UF.empty . checkType)+ $ rep_eenv''++ union_tys = fmap (renameFromUnion union_poly) tys++ return . UT $ HM.mapKeys (\(Name n m _ l) -> Name n m 0 l) union_tys++g2UnionNameText :: T.Text+g2UnionNameText = "__G2__UNION__NAME__"++freshG2UnionName :: NameGenM Name+freshG2UnionName = freshSeededStringN g2UnionNameText++isG2UnionName :: Name -> Bool+isG2UnionName (Name n Nothing _ Nothing) = n == g2UnionNameText+isG2UnionName _ = False++assignTyConNames :: ASTContainerM m Type => m -> NameGenM m+assignTyConNames = modifyASTsM assignTyConNames'++assignTyConNames' :: Type -> NameGenM Type+assignTyConNames' (TyCon _ k) = do+ n <- freshG2UnionName+ return (TyVar (Id n k))+assignTyConNames' t = return t ++repVars :: HM.HashMap Name Type -> Expr -> Expr+repVars tys = modifyASTs (repVars' tys)+ +repVars' :: HM.HashMap Name Type -> Expr -> Expr+repVars' tys (Var (Id n _)) | Just t <- HM.lookup n tys = Var (Id n t)+repVars' _ e = e++elimTyForAll :: ASTContainerM m Type => m -> NameGenM m+elimTyForAll = modifyASTsM elimTyForAll'++elimTyForAll' :: Type -> NameGenM Type+elimTyForAll' (TyForAll (Id n _) t) = do+ n' <- freshSeededNameN n+ elimTyForAll' (rename n n' t)+elimTyForAll' t = return t++elimTypes :: ASTContainer m Expr => m -> m+elimTypes = modifyASTs elimTypes'++elimTypes' :: Expr -> Expr+elimTypes' (Lam TypeL _ e) = elimTypes' e+elimTypes' (App e (Type _)) = elimTypes' e+elimTypes' e = e++adjustLetTypes :: ASTContainer m Expr => m -> m+adjustLetTypes = modifyASTs adjustLetTypes'++adjustLetTypes' :: Expr -> Expr+adjustLetTypes' (Let ie e) =+ let+ ie' = map (\(Id n _, le) -> (Id n (typeOf le), le)) ie+ f ((i_old, _), (i_new, _)) fe = modifyASTs (repVar (idName i_old) (Var i_new)) fe+ in+ foldr f (Let ie' e) (zip ie ie')+adjustLetTypes' e = e++substLams :: ASTContainer m Expr => m -> m+substLams = modifyASTs substLams'++substLams' :: Expr -> Expr+substLams' (Lam use i e) = Lam use i $ modifyASTs (repVar (idName i) (Var i)) e+substLams' e = e++scrambleNonFuncLams :: Expr -> NameGenM Expr+scrambleNonFuncLams (Lam u i@(Id n t) e) | not $ isTyFun t = do+ Lam u i <$> (scrambleNonFuncLamLetIds n =<< scrambleNonFuncLams e)+scrambleNonFuncLams (Lam u i e) = Lam u i <$> scrambleNonFuncLams e+scrambleNonFuncLams e = return e++scrambleNonFuncLets :: ASTContainerM m Expr => m -> NameGenM m+scrambleNonFuncLets = modifyASTsM scrambleNonFuncLets'++scrambleNonFuncLets' :: Expr -> NameGenM Expr+scrambleNonFuncLets' (Let b e) = do+ let b' = map idName . filter (not . isTyFun . typeOf) . map fst $ b+ foldM (flip scrambleNonFuncLamLetIds) (Let b e) b'+scrambleNonFuncLets' e = return e++scrambleNonFuncLamLetIds :: Name -> Expr -> NameGenM Expr+scrambleNonFuncLamLetIds n = modifyASTsM (scrambleNonFuncLamLetIds' n)++scrambleNonFuncLamLetIds' :: Name -> Expr -> NameGenM Expr+scrambleNonFuncLamLetIds' n (Var (Id vn t)) | n == vn = Var . Id n <$> scrambleNonFuncLamLetsType t+scrambleNonFuncLamLetIds' _ e = return e++scrambleNonFuncLamLetsType :: Type -> NameGenM Type+scrambleNonFuncLamLetsType = modifyASTsM scrambleNonFuncLamLetsType'++scrambleNonFuncLamLetsType' :: Type -> NameGenM Type+scrambleNonFuncLamLetsType' (TyVar (Id n t)) | isG2UnionName n = do+ new_n <- freshG2UnionName+ return . TyVar $ Id new_n t+scrambleNonFuncLamLetsType' t = return t+++repVar :: Name -> Expr -> Expr -> Expr+repVar old new (Var (Id n _)) | n == old = new+repVar _ _ re = re++renameFromUnion :: UFind.UnionFind Name -> Type -> Type+renameFromUnion uf = modifyASTs (renameFromUnion' uf )++renameFromUnion' :: UFind.UnionFind Name -> Type -> Type+renameFromUnion' uf (TyVar (Id n k)) = TyVar (Id (UFind.find n uf) k)+renameFromUnion' _ t = t
+ src/G2/Liquid/Inference/Verify.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++module G2.Liquid.Inference.Verify ( VerifyResult (..)+ , verifyVarToName+ , tryToVerifyOnly+ , checkGSCorrect+ , verify+ , ghcInfos+ , defLHConfig+ , tryToVerify) where++import qualified G2.Language.Syntax as G2+import G2.Liquid.Helpers+import G2.Liquid.Types+import G2.Liquid.Inference.Config+import G2.Liquid.Inference.GeneratedSpecs++import Data.Maybe+import GHC+#if MIN_VERSION_liquidhaskell(0,8,10)+import Language.Haskell.Liquid.Types+ hiding (TargetInfo (..), TargetSrc (..), TargetSpec (..), GhcSrc (..), GhcSpec (..))+#else+import Language.Haskell.Liquid.Types+#endif+import Language.Haskell.Liquid.UX.CmdLine+import Text.PrettyPrint.HughesPJ++#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+import GHC.Core+import GHC.Types.Var as V+import GHC.Driver.Types++import Liquid.GHC.Interface+import Liquid.GHC.Misc+#else+import CoreSyn+import HscTypes (SourceError)+import Var as V++import Language.Haskell.Liquid.GHC.Interface+import Language.Haskell.Liquid.GHC.Misc (showCBs, ignoreCoreBinds)+#endif++---------------------------------------------------------------------------+---------------------------------------------------------------------------+-- Copied from LiquidHaskell (because checkMany not exported)+import Control.Monad (when)+import Control.Monad.IO.Class +import qualified Control.Exception as Ex+import Language.Haskell.Liquid.UX.Tidy+import Language.Haskell.Liquid.Constraint.Generate+import Language.Haskell.Liquid.Constraint.ToFixpoint+import Language.Haskell.Liquid.Constraint.Types+import Language.Haskell.Liquid.Misc+import Language.Fixpoint.Solver+import qualified Language.Fixpoint.Types as F+import qualified Language.Fixpoint.Types.Errors as F (FixResult (..))++#if MIN_VERSION_liquidhaskell(0,8,6)+import qualified Language.Haskell.Liquid.Termination.Structural as ST+import qualified Data.HashSet as S+#else+import Language.Haskell.Liquid.GHC.Misc (showCBs)+#endif++-- For Show instance of Cinfo+import Language.Haskell.Liquid.Liquid ()++---------------------------------------------------------------------------+---------------------------------------------------------------------------++import qualified Language.Haskell.Liquid.UX.DiffCheck as DC++data VerifyResult v = Safe+ | Crash [(Integer, Cinfo)] String+ | Unsafe [v]+ deriving Show++verifyVarToName :: VerifyResult V.Var -> VerifyResult G2.Name+verifyVarToName Safe = Safe+verifyVarToName (Crash ic s) = Crash ic s+verifyVarToName (Unsafe v) = Unsafe (map varToName v)++-- Tries to verify the assertions, specifically for the set of functions,+-- that we care about. If that fails, removes any synthesized+-- assertions/assumptions on the failing functions.+tryHardToVerifyIgnoring :: (InfConfigM m, MonadIO m)+ => [GhcInfo]+ -> GeneratedSpecs+ -> [G2.Name]+ -> m (Either [G2.Name] GeneratedSpecs)+tryHardToVerifyIgnoring ghci gs ignore = do+ lhconfig <- lhConfigM+ infconfig <- infConfigM+ liftIO $ do+ let merged_ghci = addSpecsToGhcInfos ghci gs++ putStrLn "---\nVerify"+ putStrLn "gsAsmSigs"+ mapM_ (print . getAssumedSigs) merged_ghci+ putStrLn "gsTySigs"+ mapM_ (print . getTySigs) merged_ghci+ putStrLn "---\nEnd Verify"++ res <- return . verifyVarToName =<< verify infconfig lhconfig merged_ghci+ putStrLn "res"+ case res of+ Unsafe ns+ | f_ns <- filterIgnoring ns+ , f_ns /= [] -> do+ putStrLn $ "filtered = " ++ show ns+ let f_gs = filterOutAssertSpecs f_ns gs+ f_merged_ghci = addSpecsToGhcInfos ghci f_gs++ filtered_res <- return . verifyVarToName =<<+ verify infconfig lhconfig f_merged_ghci+ case filtered_res of+ Unsafe _ -> return $ Left f_ns+ Safe -> do+ liftIO . putStrLn $ "Safe 2 after " ++ show ns + return $ Right f_gs+ Crash ci err -> error $ "Crash\n" ++ show ci ++ "\n" ++ err+ | otherwise -> do+ putStrLn $ "safe ignoring ns = " ++ show ns+ return $ Right gs+ Safe -> do+ liftIO $ putStrLn "Safe 1"+ return $ Right gs+ Crash ci err -> error $ "Crash\n" ++ show ci ++ "\n" ++ err+ where+ ignore' = map (\(G2.Name n m _ _) -> (n, m)) ignore+ filterIgnoring = filter (\(G2.Name n m _ _) -> (n, m) `notElem` ignore')++tryToVerifyOnly :: (InfConfigM m, MonadIO m) => [GhcInfo] -> [G2.Name] -> m (VerifyResult G2.Name)+tryToVerifyOnly ghci ns = do+ res <- tryToVerify ghci+ case res of+ Safe -> return Safe+ Unsafe unsafe ->+ case filter (\n -> toOccMod n `elem` ns_nm) unsafe of+ [] -> return Safe+ unsafe' -> do+ return $ Unsafe unsafe'+ x -> error (show x)+ where+ ns_nm = map toOccMod ns+ toOccMod (G2.Name n m _ _) = (n, m)++tryToVerify :: (InfConfigM m, MonadIO m) => [GhcInfo] -> m (VerifyResult G2.Name)+tryToVerify ghci = do+ lhconfig <- lhConfigM+ infconfig <- infConfigM++ liftIO $ do+ putStrLn "-------------------------------"+ putStrLn "-------------------------------"+ putStrLn "tryToVerify"+ mapM (print . getTySigs) ghci+ putStrLn "-------------------------------"+ putStrLn "-------------------------------"++ return . verifyVarToName =<< liftIO (verify infconfig lhconfig ghci)++-- | Confirm that we have actually found exactly the needed specs+checkGSCorrect :: InferenceConfig -> Config -> [GhcInfo] -> GeneratedSpecs -> IO (VerifyResult V.Var)+checkGSCorrect infconfig lhconfig ghci gs+ | nullAssumeGS gs = do+ let merged_ghci = addSpecsToGhcInfos ghci $ switchAssumesToAsserts gs+ verify infconfig lhconfig merged_ghci+ | otherwise = error "Non-null assumes."++verify :: InferenceConfig -> Config -> [GhcInfo] -> IO (VerifyResult V.Var)+verify infconfig cfg ghci = do+ r <- verify' infconfig cfg ghci+ case F.resStatus r of+#if MIN_VERSION_liquidhaskell(0,9,0)+ F.Safe _ -> return Safe+ F.Crash ci err -> return $ Crash (map fst ci) err+ F.Unsafe _ bad -> do+ putStrLn $ "bad var = " ++ show (map (ci_var . snd) bad)+ putStrLn $ "bad loc = " ++ show (map (ci_loc . snd) bad)+ return . Unsafe . catMaybes $ map (ci_var . snd) bad+#elif MIN_VERSION_liquidhaskell(0,8,10)+ F.Safe _ -> return Safe+ F.Crash ci err -> return $ Crash ci err+ F.Unsafe _ bad -> do+ putStrLn $ "bad var = " ++ show (map (ci_var . snd) bad)+ putStrLn $ "bad loc = " ++ show (map (ci_loc . snd) bad)+ return . Unsafe . catMaybes $ map (ci_var . snd) bad+#else+ F.Safe -> return Safe+ F.Crash ci err -> return $ Crash ci err+ F.Unsafe bad -> do+ putStrLn $ "bad var = " ++ show (map (ci_var . snd) bad)+ putStrLn $ "bad loc = " ++ show (map (ci_loc . snd) bad)+ return . Unsafe . catMaybes $ map (ci_var . snd) bad+#endif+++verify' :: InferenceConfig -> Config -> [GhcInfo] -> IO (F.Result (Integer, Cinfo))+verify' infconfig cfg ghci = checkMany infconfig cfg mempty ghci++ghcInfos :: Maybe HscEnv -> Config -> [FilePath] -> IO [GhcInfo]+ghcInfos me cfg fp = do+#if MIN_VERSION_liquidhaskell(0,8,10)+ (ghci, _) <- getTargetInfos me cfg fp+#else+ (ghci, _) <- getGhcInfos me cfg fp+#endif+ return ghci++defLHConfig :: [FilePath] -> IO Config+defLHConfig proj = do+ config <- getOpts []+ return config { idirs = idirs config ++ proj+ , files = files config+ , ghcOptions = ["-v"]}++---------------------------------------------------------------------------+---------------------------------------------------------------------------+-- Copied from LiquidHaskell (because checkMany not exported)+checkMany :: InferenceConfig -> Config -> F.Result (Integer, Cinfo) -> [GhcInfo] -> IO (F.Result (Integer, Cinfo))+--------------------------------------------------------------------------------+checkMany infconfig cfg d (g:gs) = do+ d' <- checkOne infconfig cfg g+ checkMany infconfig cfg (d `mappend` d') gs++checkMany _ _ d [] =+ return d++--------------------------------------------------------------------------------+checkOne :: InferenceConfig -> Config -> GhcInfo -> IO (F.Result (Integer, Cinfo))+--------------------------------------------------------------------------------+checkOne infconfig cfg g = do+ z <- actOrDie $ liquidOne infconfig g+ case z of+ Left e -> undefined+ Right r -> return r+++actOrDie :: IO a -> IO (Either ErrorResult a)+actOrDie act =+ (Right <$> act)+ `Ex.catch` (\(e :: SourceError) -> handle e)+ `Ex.catch` (\(e :: Error) -> handle e)+ `Ex.catch` (\(e :: UserError) -> handle e)+ `Ex.catch` (\(e :: [Error]) -> handle e)++handle :: (Result a) => a -> IO (Either ErrorResult b)+handle = return . Left . result++--------------------------------------------------------------------------------+liquidOne :: InferenceConfig -> GhcInfo -> IO (F.Result (Integer, Cinfo))+--------------------------------------------------------------------------------+liquidOne infconfig info = do+ -- whenNormal $ donePhase Loud "Extracted Core using GHC"+ let cfg = getConfig info+#if MIN_VERSION_liquidhaskell(0,8,6)+ let tgt = giTarget (giSrc info)+ let cbs' = giCbs (giSrc info)+#else+ let tgt = target info+ -- whenLoud $ do putStrLn $ showpp info+ -- putStrLn "*************** Original CoreBinds ***************************"+ -- putStrLn $ render $ pprintCBs (cbs info)+ let cbs' = cbs info -- scopeTr (cbs info)+#endif+ -- whenNormal $ donePhase Loud "Transformed Core"+ -- whenLoud $ do donePhase Loud "transformRecExpr"+ -- putStrLn "*************** Transform Rec Expr CoreBinds *****************"+ -- putStrLn $ showCBs (untidyCore cfg) cbs'+ -- putStrLn $ render $ pprintCBs cbs'+ -- putStrLn $ showPpr cbs'+ edcs <- newPrune cfg cbs' tgt info+ liquidQueries infconfig cfg tgt info edcs++#if MIN_VERSION_liquidhaskell(0,8,6)+newPrune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Either [CoreBind] [DC.DiffCheck])+newPrune cfg cbs tgt info+ | not (null vs) = return . Right $ [DC.thin cbs sp vs]+ | timeBinds cfg = return . Right $ [DC.thin cbs sp [v] | v <- exportedVars (giSrc info) ]+ | diffcheck cfg = maybeEither cbs <$> DC.slice tgt cbs sp+ | otherwise = return $ Left (ignoreCoreBinds ignores cbs)+ where+ ignores = gsIgnoreVars (gsVars sp)+ vs = gsTgtVars (gsVars sp)+ sp = giSpec info++exportedVars :: GhcSrc -> [V.Var]+exportedVars src = filter (isExportedVar src) (giDefVars src)+#else+newPrune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Either [CoreBind] [DC.DiffCheck])+newPrune cfg cbs tgt info+ | not (null vs) = return . Right $ [DC.thin cbs sp vs]+ | timeBinds cfg = return . Right $ [DC.thin cbs sp [v] | v <- exportedVars info ]+ | diffcheck cfg = maybeEither cbs <$> DC.slice tgt cbs sp+ | otherwise = return (Left cbs)+ where+ vs = gsTgtVars sp+ sp = spec info++ignoreCoreBinds :: [V.Var] -> [CoreBind] -> [CoreBind]+ignoreCoreBinds vs cbs + | null vs = cbs + | otherwise = concatMap go cbs+ where+ go :: CoreBind -> [CoreBind]+ go b@(NonRec x _) + | x `elem` vs = [] + | otherwise = [b] + go (Rec xes) = [Rec (filter ((`notElem` vs) . fst) xes)]+#endif++-- topLevelBinders :: GhcSpec -> [Var]+-- topLevelBinders = map fst . tySigs++maybeEither :: a -> Maybe b -> Either a [b]+maybeEither d Nothing = Left d+maybeEither _ (Just x) = Right [x]++liquidQueries :: InferenceConfig -> Config -> FilePath -> GhcInfo -> Either [CoreBind] [DC.DiffCheck] -> IO (F.Result (Integer, Cinfo))+liquidQueries infconfig cfg tgt info (Left cbs')+ = liquidQuery infconfig cfg tgt info (Left cbs')+liquidQueries infconfig cfg tgt info (Right dcs)+ = mconcat <$> mapM (liquidQuery infconfig cfg tgt info . Right) dcs++liquidQuery :: InferenceConfig -> Config -> FilePath -> GhcInfo -> Either [CoreBind] DC.DiffCheck -> IO (F.Result (Integer, Cinfo))+#if MIN_VERSION_liquidhaskell(0,8,6)+liquidQuery infconfig cfg tgt info edc = do+ let names = either (const Nothing) (Just . map show . DC.checkedVars) edc+ let oldOut = either (const mempty) DC.oldOutput edc+ let info1 = either (const info) (\z -> info {giSpec = DC.newSpec z}) edc+ let cbs'' = either id DC.newBinds edc+ let info2 = info1 { giSrc = (giSrc info1) {giCbs = cbs''}}+ let info3 = updGhcInfoTermVars info2 + let cgi = {-# SCC "generateConstraints" #-} generateConstraints $! info3 + when False (dumpCs cgi)+ -- whenLoud $ mapM_ putStrLn [ "****************** CGInfo ********************"+ -- , render (pprint cgi) ]+ timedAction names $ solveCs infconfig cfg tgt cgi info3 names++updGhcInfoTermVars :: GhcInfo -> GhcInfo +updGhcInfoTermVars i = updInfo i (ST.terminationVars i) + where + updInfo info vs = info { giSpec = updSpec (giSpec info) vs }+ updSpec sp vs = sp { gsTerm = updSpTerm (gsTerm sp) vs }+ updSpTerm gsT vs = gsT { gsNonStTerm = S.fromList vs } +#else+liquidQuery infconfig cfg tgt info edc = do+ when False (dumpCs cgi)+ timedAction names $ solveCs infconfig cfg tgt cgi info' names+ where+ cgi = {-# SCC "generateConstraints" #-} generateConstraints $! info' {cbs = cbs''}+ cbs'' = either id DC.newBinds edc+ info' = either (const info) (\z -> info {spec = DC.newSpec z}) edc+ names = either (const Nothing) (Just . map show . DC.checkedVars) edc+ oldOut = either (const mempty) DC.oldOutput edc+#endif+++dumpCs :: CGInfo -> IO ()+dumpCs cgi = do+ putStrLn "***************************** SubCs *******************************"+ putStrLn $ render $ pprintMany (hsCs cgi)+ putStrLn "***************************** FixCs *******************************"+ putStrLn $ render $ pprintMany (fixCs cgi)+ putStrLn "***************************** WfCs ********************************"+ putStrLn $ render $ pprintMany (hsWfs cgi)++pprintMany :: (PPrint a) => [a] -> Doc+pprintMany xs = vcat [ F.pprint x $+$ text " " | x <- xs ]++-- instance Show Cinfo where+-- show = show . F.toFix++solveCs :: InferenceConfig -> Config -> FilePath -> CGInfo -> GhcInfo -> Maybe [String] -> IO (F.Result (Integer, Cinfo))+solveCs infconfig cfg tgt cgi info names = do+ finfo <- cgInfoFInfo info cgi+ -- We only want qualifiers we have found with G2 Inference, so we have to force the correct set here+ let finfo' = finfo { F.quals = (getQualifiers $ info) ++ if keep_quals infconfig then F.quals finfo else [] }+#if MIN_VERSION_liquid_fixpoint(0,9,0)+ fres@(F.Result r sol _ _) <- solve (fixConfig tgt cfg) finfo'+#else+ fres@(F.Result r sol _) <- solve (fixConfig tgt cfg) finfo'+#endif+ -- let resErr = applySolution sol . cinfoError . snd <$> r+ -- resModel_ <- fmap (e2u cfg sol) <$> getModels info cfg resErr+ -- let resModel = resModel_ `addErrors` (e2u cfg sol <$> logErrors cgi)+ -- let out0 = mkOutput cfg resModel sol (annotMap cgi)+ -- out1 = out0 { o_vars = names }+ -- { o_result = resModel }+ -- DC.saveResult tgt out1+ -- exitWithResult cfg [tgt] out1++ return fres+++-- e2u :: Config -> F.FixSolution -> Error -> UserError+-- e2u cfg s = fmap F.pprint . tidyError cfg s+
src/G2/Liquid/Interface.hs view
@@ -1,13 +1,47 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} -module G2.Liquid.Interface where+module G2.Liquid.Interface ( LiquidData (..)+ , LiquidReadyState+ , lr_state+ , lr_binding+ , lrsMeasures+ , Abstracted (..)+ , AbstractedInfo (..)+ , findCounterExamples+ + , runLHG2+ , onlyMinimalStates+ , cleanupResults + , runLHCore+ , liquidStateWithCall+ , liquidStateWithCall'+ , liquidStateFromSimpleStateWithCall+ , liquidStateFromSimpleStateWithCall'++ , cleanReadyState+ , fromLiquidNoCleaning+ , createLiquidReadyState+ , processLiquidReadyState+ , processLiquidReadyStateWithCall+ , extractWithoutSpecs++ , processLiquidReadyStateCleaning++ , reqNames++ , lhStateToCE+ , printLHOut+ , printCE) where+ import G2.Config.Config import G2.Translation import G2.Interface import G2.Language as Lang+import G2.Language.KnownValues as KV import qualified G2.Language.ExprEnv as E import G2.Execution@@ -17,36 +51,40 @@ import G2.Liquid.AddCFBranch import G2.Liquid.AddLHTC import G2.Liquid.AddOrdToNum+import G2.Liquid.AddTyVars+import G2.Liquid.Config import G2.Liquid.Conversion import G2.Liquid.ConvertCurrExpr+import G2.Liquid.Helpers import G2.Liquid.LHReducers import G2.Liquid.Measures+import G2.Liquid.MkLHVals+import G2.Liquid.G2Calls import G2.Liquid.Simplify import G2.Liquid.SpecialAsserts import G2.Liquid.TCGen+import G2.Liquid.TCValues import G2.Liquid.Types+import G2.Liquid.TyVarBags import G2.Solver hiding (solve) import G2.Lib.Printers -import qualified Language.Haskell.Liquid.GHC.Interface as LHI-import Language.Haskell.Liquid.Types hiding (Config, cls, names)-import qualified Language.Haskell.Liquid.Types.PrettyPrint as PPR-import Language.Haskell.Liquid.UX.CmdLine-import qualified Language.Haskell.Liquid.UX.Config as LHC--import qualified Language.Fixpoint.Types.PrettyPrint as FPP+import Language.Haskell.Liquid.Types hiding (Config, cls, names, measures)+import Language.Haskell.Liquid.UX.CmdLine hiding (config) import Control.Exception+import Control.Monad.Extra+import Control.Monad.IO.Class+import qualified Control.Monad.State as SM import Data.List+import qualified Data.HashSet as S+import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.IO as TI -import qualified GHC as GHC-import Var--import G2.Language.KnownValues+import G2.Language.Monad data LHReturn = LHReturn { calledFunc :: FuncInfo , violating :: Maybe FuncInfo@@ -59,59 +97,216 @@ -- | findCounterExamples -- Given (several) LH sources, and a string specifying a function name, -- attempt to find counterexamples to the functions liquid type-findCounterExamples :: [FilePath] -> [FilePath] -> T.Text -> [FilePath] -> [FilePath] -> Config -> IO (([ExecRes [FuncCall]], Bindings), Lang.Id)-findCounterExamples proj fp entry libs lhlibs config = do+findCounterExamples :: [FilePath] -> [FilePath] -> T.Text -> Config -> LHConfig -> IO (([ExecRes AbstractedInfo], Bindings), Lang.Id)+findCounterExamples proj fp entry config lhconfig = do let config' = config { mode = Liquid } lh_config <- getOpts [] - ghc_cg <- try $ getGHCInfos lh_config proj fp lhlibs :: IO (Either SomeException [LHOutput])+ ghci <- try $ getGHCInfos lh_config proj fp :: IO (Either SomeException [GhcInfo]) - let ghc_cg' = case ghc_cg of+ let ghci' = case ghci of Right g_c -> g_c Left e -> error $ "ERROR OCCURRED IN LIQUIDHASKELL\n" ++ show e - tgt_trans <- translateLoaded proj fp libs (simplTranslationConfig { simpl = False }) config'+ tgt_trans <- translateLoaded proj fp (simplTranslationConfig { simpl = False }) config' - runLHCore entry tgt_trans ghc_cg' config'+ runLHCore entry tgt_trans ghci' config' lhconfig -runLHCore :: T.Text -> (Maybe T.Text, ExtractedG2)- -> [LHOutput]- -> Config- -> IO (([ExecRes [FuncCall]], Bindings), Lang.Id)-runLHCore entry (mb_modname, exg2) ghci_cg config = do- let (init_state, ifi, bindings) = initState exg2 True entry mb_modname (mkCurrExpr Nothing Nothing) config- let (init_state', bindings') = (markAndSweepPreserving (reqNames init_state) init_state bindings)- let cleaned_state = init_state' { type_env = type_env init_state } +runLHCore :: T.Text+ -> (Maybe T.Text, ExtractedG2)+ -> [GhcInfo]+ -> Config+ -> LHConfig+ -> IO (([ExecRes AbstractedInfo], Bindings), Lang.Id)+runLHCore entry (mb_modname, exg2) ghci config lhconfig = do+ LiquidData { ls_state = final_st+ , ls_bindings = bindings+ , ls_id = ifi+ , ls_counterfactual_name = cfn+ , ls_memconfig = pres_names } <- liquidStateWithCall entry (mb_modname, exg2) ghci config lhconfig mempty - let (no_part_state@(State {expr_env = np_eenv})) = cleaned_state- let np_ng = name_gen bindings'+ SomeSolver solver <- initSolver config+ let simplifier = IdSimplifier - let renme = E.keys np_eenv -- \\ nub (Lang.names (type_classes no_part_state))- let ((meenv, mkv, mtc, minst), ng') = doRenames renme np_ng - (np_eenv, known_values no_part_state, type_classes no_part_state, higher_order_inst bindings')+ let (red, hal, ord) = lhReducerHalterOrderer config lhconfig solver simplifier entry mb_modname cfn final_st+ (exec_res, final_bindings) <- SM.evalStateT (runLHG2 config red hal ord solver simplifier pres_names ifi final_st bindings) (mkPrettyGuide ())++ close solver++ return ((exec_res, final_bindings), ifi)++{-# INLINE liquidStateWithCall #-}+liquidStateWithCall :: T.Text -> (Maybe T.Text, ExtractedG2)+ -> [GhcInfo]+ -> Config+ -> LHConfig+ -> MemConfig+ -> IO LiquidData+liquidStateWithCall entry (mb_modname, exg2) ghci config lhconfig memconfig =+ liquidStateWithCall' entry (mb_modname, exg2) ghci config lhconfig memconfig (mkCurrExpr Nothing Nothing) mkArgTys++{-# INLINE liquidStateWithCall' #-}+liquidStateWithCall' :: T.Text -> (Maybe T.Text, ExtractedG2)+ -> [GhcInfo]+ -> Config+ -> LHConfig+ -> MemConfig+ -> (Lang.Id -> MkCurrExpr)+ -> (Lang.Expr -> MkArgTypes)+ -> IO LiquidData+liquidStateWithCall' entry (mb_m, exg2) ghci config lhconfig memconfig mkCurr argTys = do+ let simp_s = initSimpleState exg2+ liquidStateFromSimpleStateWithCall' simp_s ghci entry mb_m config lhconfig memconfig mkCurr argTys++{-# INLINE liquidStateFromSimpleStateWithCall #-}+liquidStateFromSimpleStateWithCall :: SimpleState+ -> [GhcInfo]+ -> T.Text+ -> Maybe T.Text+ -> Config+ -> LHConfig+ -> MemConfig+ -> IO LiquidData+liquidStateFromSimpleStateWithCall simp_s ghci entry mb_m config lhconfig memconfig =+ liquidStateFromSimpleStateWithCall' simp_s ghci entry mb_m config lhconfig memconfig (mkCurrExpr Nothing Nothing) mkArgTys++{-# INLINE liquidStateFromSimpleStateWithCall' #-}+liquidStateFromSimpleStateWithCall' :: SimpleState+ -> [GhcInfo]+ -> T.Text+ -> Maybe T.Text+ -> Config+ -> LHConfig+ -> MemConfig+ -> (Lang.Id -> MkCurrExpr)+ -> (Lang.Expr -> MkArgTypes)+ -> IO LiquidData+liquidStateFromSimpleStateWithCall' simp_s ghci entry mb_m config lhconfig memconfig mkCurr argTys = do+ let (simp_s', ph_tyvars) = if add_tyvars lhconfig+ then fmap Just $ addTyVarsEEnvTEnv simp_s+ else (simp_s, Nothing)+ (s, i, bindings') = initStateFromSimpleStateWithCall simp_s' True entry mb_m mkCurr argTys config - let ng_bindings = bindings' {name_gen = ng'}+ fromLiquidReadyState s i bindings' ghci ph_tyvars lhconfig memconfig - let ng_state = no_part_state {track = []}+{-# INLINE fromLiquidReadyState #-}+fromLiquidReadyState :: State ()+ -> Lang.Id+ -> Bindings+ -> [GhcInfo]+ -> Maybe PhantomTyVars+ -> LHConfig+ -> MemConfig+ -> IO LiquidData+fromLiquidReadyState init_state ifi bindings ghci ph_tyvars lhconfig memconfig = do+ let (init_state', bindings') = (markAndSweepPreserving (reqNames init_state `mappend` memconfig) init_state bindings)+ cleaned_state = init_state' { type_env = type_env init_state } + fromLiquidNoCleaning cleaned_state ifi bindings' ghci ph_tyvars lhconfig memconfig - let (lh_state, lh_bindings) = createLHState meenv mkv ng_state ng_bindings+data LiquidReadyState = LiquidReadyState { lr_state :: LHState+ , lr_binding :: Bindings+ , lr_known_values :: KnownValues+ , lr_type_classes :: TypeClasses+ , lr_higher_ord_insts :: S.HashSet Name } - let (cfn, (merged_state, bindings'')) = runLHStateM (initializeLH ghci_cg ifi lh_bindings) lh_state lh_bindings+data LiquidData = LiquidData { ls_state :: State LHTracker+ , ls_bindings :: Bindings+ , ls_id :: Lang.Id+ , ls_counterfactual_name :: CounterfactualName+ , ls_counterfactual_funcs :: S.HashSet Name+ , ls_measures :: Measures+ , ls_assumptions :: Assumptions+ , ls_posts :: Posts+ , ls_tcv :: TCValues+ , ls_memconfig :: MemConfig } - let tcv = tcvalues merged_state- let merged_state' = deconsLHState merged_state+cleanReadyState :: LiquidReadyState -> MemConfig -> LiquidReadyState+cleanReadyState lrs@(LiquidReadyState { lr_state = lhs@(LHState { state = s }), lr_binding = b }) memconfig =+ let+ (s', b') = (markAndSweepPreserving (reqNames s `mappend` memconfig) s b)+ s'' = s' { type_env = type_env s }+ in+ lrs { lr_state = lhs { state = s'' }, lr_binding = b' } - let pres_names = reqNames merged_state' ++ names tcv ++ names mkv+fromLiquidNoCleaning :: State ()+ -> Lang.Id+ -> Bindings+ -> [GhcInfo]+ -> Maybe PhantomTyVars+ -> LHConfig+ -> MemConfig+ -> IO LiquidData+fromLiquidNoCleaning init_state ifi bindings ghci ph_tyvars lhconfig memconfig = do+ let lrs = createLiquidReadyState init_state bindings ghci ph_tyvars lhconfig+ processLiquidReadyState lrs ifi ghci lhconfig memconfig - let annm = annots merged_state+createLiquidReadyState :: State () -> Bindings -> [GhcInfo] -> Maybe PhantomTyVars -> LHConfig -> LiquidReadyState+createLiquidReadyState s bindings ghci ph_tyvars lhconfig =+ let+ np_ng = name_gen bindings - let track_state = merged_state' {track = LHTracker { abstract_calls = []- , last_var = Nothing- , annotations = annm} }+ (meenv, mkv, mtc, minst, mexported, ng') = mkLHVals s (higher_order_inst bindings) (exported_funcs bindings) np_ng - SomeSolver con <- initSolver config+ s' = s { track = [] }+ bindings' = bindings { exported_funcs = mexported ++ exported_funcs bindings, name_gen = ng' } + (lh_state, lh_bindings) = createLHState meenv mkv mtc s' bindings'++ (data_state, data_bindings) = execLHStateM (initializeLHData ghci ph_tyvars lhconfig) lh_state lh_bindings+ in+ LiquidReadyState { lr_state = data_state+ , lr_binding = data_bindings+ , lr_known_values = mkv+ , lr_type_classes = mtc+ , lr_higher_ord_insts = minst } -- (mkv, mtc, minst, data_state, data_bindings)++processLiquidReadyStateCleaning :: LiquidReadyState -> Lang.Id -> [GhcInfo] -> LHConfig -> MemConfig -> IO LiquidData+processLiquidReadyStateCleaning lrs ifi ghci lhconfig memconfig =+ let+ lrs' = cleanReadyState lrs memconfig+ in+ processLiquidReadyState lrs' ifi ghci lhconfig memconfig++processLiquidReadyState :: LiquidReadyState -> Lang.Id -> [GhcInfo] -> LHConfig -> MemConfig -> IO LiquidData+processLiquidReadyState lrs@(LiquidReadyState { lr_state = lh_state+ , lr_binding = lh_bindings }) ifi ghci lhconfig memconfig = do+ let ((cfn, mc, cff), (merged_state, bindings')) = runLHStateM (initializeLHSpecs (counterfactual lhconfig) ghci ifi lh_bindings) lh_state lh_bindings+ lrs' = lrs { lr_state = merged_state, lr_binding = bindings'}++ lhs <- extractWithoutSpecs lrs' ifi ghci memconfig+ + let lh_s = if only_top lhconfig+ then elimNonTop (S.insert (idName mc) cff) (ls_state lhs)+ else ls_state lhs++ return $ lhs { ls_state = lh_s+ , ls_id = mc+ , ls_counterfactual_name = cfn+ , ls_counterfactual_funcs = cff }++extractWithoutSpecs :: LiquidReadyState -> Lang.Id -> [GhcInfo] -> MemConfig -> IO LiquidData+extractWithoutSpecs lrs@(LiquidReadyState { lr_state = s+ , lr_binding = bindings+ , lr_known_values = mkv+ , lr_type_classes = mtc+ , lr_higher_ord_insts = minst}) ifi ghci memconfig = do+ let (lh_s, bindings') = execLHStateM (return ()) s bindings+ let bindings'' = bindings' { higher_order_inst = minst }++ let tcv = tcvalues lh_s+ let lh_s' = deconsLHState lh_s++ let annm = annots lh_s+ pres_names = addSearchNames (namesList tcv ++ namesList mkv) $ reqNames lh_s'+ pres_names' = addSearchNames (namesList annm) pres_names++ let track_state = lh_s' {track = LHTracker { abstract_calls = []+ , last_var = Nothing+ , annotations = annm+ , all_calls = []+ , higher_order_calls = [] } }+ -- We replace certain function name lists in the final State with names -- mapping into the measures from the LHState. These functions do not -- need to be passed the LH typeclass, so this ensures use of Names from@@ -119,188 +314,291 @@ -- for the LH typeclass. let final_st = track_state { known_values = mkv , type_classes = unionTypeClasses mtc (type_classes track_state)}- let bindings''' = bindings'' { higher_order_inst = minst }- -- let bindings''' = bindings'' + let real_meas = lrsMeasures ghci lrs - let tr_ng = mkNameGen ()- let state_name = Name "state" Nothing 0 Nothing - let (limHalt, limOrd) = limitByAccepted (cut_off config)+ return $ LiquidData { ls_state = final_st+ , ls_bindings = bindings''+ , ls_id = ifi+ , ls_counterfactual_name = error "No counterfactual name"+ , ls_counterfactual_funcs = error "No counterfactual funcs"+ , ls_measures = real_meas+ , ls_assumptions = assumptions lh_s+ , ls_posts = posts lh_s+ , ls_tcv = tcv+ , ls_memconfig = pres_names' `mappend` memconfig } - (ret, final_bindings) <- if higherOrderSolver config == AllFuncs- then runG2WithSomes- (SomeReducer NonRedPCRed- <~| (case logStates config of- Just fp -> SomeReducer (StdRed con :<~| LHRed cfn :<~ Logger fp)- Nothing -> SomeReducer (StdRed con :<~| LHRed cfn)))- (SomeHalter- (MaxOutputsHalter (maxOutputs config)- :<~> ZeroHalter (steps config)- :<~> LHAbsHalter entry mb_modname (expr_env init_state)- :<~> limHalt- :<~> SwitchEveryNHalter (switch_after config)- :<~> AcceptHalter))- (SomeOrderer limOrd)- con (pres_names ++ names annm) final_st bindings''' - else runG2WithSomes- (SomeReducer (NonRedPCRed :<~| TaggerRed state_name tr_ng)- <~| (case logStates config of- Just fp -> SomeReducer (StdRed con :<~| LHRed cfn :<~ Logger fp)- Nothing -> SomeReducer (StdRed con :<~| LHRed cfn)))- (SomeHalter- (DiscardIfAcceptedTag state_name- :<~> MaxOutputsHalter (maxOutputs config)- :<~> ZeroHalter (steps config)- :<~> LHAbsHalter entry mb_modname (expr_env init_state)- :<~> limHalt- :<~> SwitchEveryNHalter (switch_after config)- :<~> AcceptHalter))- (SomeOrderer limOrd)- con (pres_names ++ names annm) final_st bindings'''- - -- We filter the returned states to only those with the minimal number of abstracted functions- let mi = case length ret of+lrsMeasures :: [GhcInfo] -> LiquidReadyState -> Measures+lrsMeasures ghci lrs = + let+ meas_names = measureNames ghci+ meas_nameOcc = map (\(Name n md _ _) -> (n, md)) $ map symbolName meas_names++ real_meas = E.filterWithKey (\(Name n md i _) _ -> + (n, md) `elem` meas_nameOcc && i == 0) . measures $ lr_state lrs+ in+ real_meas++processLiquidReadyStateWithCall :: LiquidReadyState -> [GhcInfo] -> T.Text -> Maybe T.Text -> Config -> LHConfig -> MemConfig -> IO LiquidData+processLiquidReadyStateWithCall lrs@(LiquidReadyState { lr_state = lhs@(LHState { state = s })+ , lr_binding = bindings})+ ghci f m_mod config lhconfig memconfig = do++ let (ie, _) = case findFunc f m_mod (expr_env s) of+ Left ie' -> ie'+ Right errs -> error errs++ (ce, is, f_i, ng') = mkCurrExpr Nothing Nothing ie (type_classes s) (name_gen bindings)+ (expr_env s) (type_env s) (deepseq_walkers bindings) (known_values s) config++ lhs' = lhs { state = s { expr_env = foldr E.insertSymbolic (expr_env s) is+ , curr_expr = CurrExpr Evaluate ce }+ }+ (lhs'', bindings') = execLHStateM (addLHTCCurrExpr) lhs' (bindings { name_gen = ng' })++ lrs' = lrs { lr_state = lhs''+ , lr_binding = bindings' { fixed_inputs = f_i+ , input_names = map idName is+ }+ }++ processLiquidReadyStateCleaning lrs' ie ghci lhconfig memconfig++runLHG2 :: (MonadIO m, Solver solver, Simplifier simplifier)+ => Config+ -> SomeReducer m LHTracker+ -> SomeHalter m LHTracker+ -> SomeOrderer m LHTracker+ -> solver+ -> simplifier+ -> MemConfig+ -> Lang.Id+ -> State LHTracker+ -> Bindings+ -> m ([ExecRes AbstractedInfo], Bindings)+runLHG2 config red hal ord solver simplifier pres_names init_id final_st bindings = do+ let only_abs_st = addTicksToDeepSeqCases (deepseq_walkers bindings) final_st+ (ret, final_bindings) <- runG2WithSomes red hal ord solver simplifier pres_names only_abs_st bindings++ let ret' = onlyMinimalStates ret++ cleanupResults solver simplifier config init_id final_st final_bindings ret'++onlyMinimalStates :: [ExecRes LHTracker] -> [ExecRes LHTracker]+onlyMinimalStates ers =+ let+ mi = case length ers of 0 -> 0- _ -> minimum $ map (\(ExecRes {final_state = s}) -> length $ abstract_calls $ track s) ret- let ret' = filter (\(ExecRes {final_state = s}) -> mi == (length $ abstract_calls $ track s)) ret+ _ -> minimum $ map (\(ExecRes {final_state = s}) -> abstractCallsNum s) ers+ in+ filter (\(ExecRes {final_state = s}) -> mi == (abstractCallsNum s)) ers - let exec_res = map (\(ExecRes { final_state = s- , conc_args = es- , conc_out = e- , violated = ais}) ->- (ExecRes { final_state = s {track = map (subVarFuncCall (model s) (expr_env s) (type_classes s)) $ abstract_calls $ track s}- , conc_args = es- , conc_out = e- , violated = ais})) ret'+cleanupResults :: (MonadIO m, Solver solver, Simplifier simplifier) =>+ solver+ -> simplifier+ -> Config+ -> Lang.Id+ -> State LHTracker+ -> Bindings+ -> [ExecRes LHTracker]+ -> m ([ExecRes AbstractedInfo], Bindings)+cleanupResults solver simplifier config init_id init_state bindings ers = do+ let ers2 = map (\er -> er { final_state = putSymbolicExistentialInstInExprEnv (final_state er) }) ers+ ers3 = map (\er -> if fmap funcName (violated er) == Just initiallyCalledFuncName+ then er { violated = Nothing }+ else er) ers2 - -- mapM (\(s, _, _, _) -> putStrLn . pprExecStateStr $ s) states- -- mapM (\(_, es, e, ais) -> do print es; print e; print ais) states+ (bindings', ers4) <- liftIO $ mapAccumM (reduceCalls runG2WithSomes solver simplifier config) bindings ers3+ ers5 <- liftIO $ mapM (checkAbstracted runG2WithSomes solver simplifier config init_id bindings') ers4+ let ers6 = + map (\er@(ExecRes { final_state = s }) ->+ (er { final_state =+ s {track = + mapAbstractedInfoFCs (subVarFuncCall True (model s) (expr_env init_state) (type_classes s))+ $ track s+ }+ })) ers5+ return (ers6, bindings') - close con+lhReducerHalterOrderer :: (MonadIO m, Solver solver, Simplifier simplifier)+ => Config+ -> LHConfig+ -> solver+ -> simplifier+ -> T.Text+ -> Maybe T.Text+ -> CounterfactualName+ -> State t+ -> ( SomeReducer (SM.StateT PrettyGuide m) LHTracker+ , SomeHalter (SM.StateT PrettyGuide m) LHTracker+ , SomeOrderer (SM.StateT PrettyGuide m) LHTracker)+lhReducerHalterOrderer config lhconfig solver simplifier entry mb_modname cfn st =+ let - return ((exec_res, final_bindings), ifi)+ share = sharing config -initializeLH :: [LHOutput] -> Lang.Id -> Bindings -> LHStateM Lang.Name-initializeLH ghci_cg ifi bindings = do- let ghcInfos = map ghcI ghci_cg+ state_name = Name "state" Nothing 0 Nothing - addLHTC- addOrdToNum+ abs_ret_name = Name "abs_ret" Nothing 0 Nothing - let lh_measures = measureSpecs ghcInfos- createMeasures lh_measures+ non_red = nonRedPCRed .|. nonRedPCRedConst - let specs = funcSpecs ghcInfos- mergeLHSpecState specs+ m_logger = fmap SomeReducer $ getLogger config - addSpecialAsserts- addTrueAsserts ifi+ lh_std_red = existentialInstRed :== NoProgress .--> lhRed cfn :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier+ opt_logger_red = case m_logger of+ Just logger -> logger .~> lh_std_red+ Nothing -> lh_std_red+ in+ if higherOrderSolver config == AllFuncs then+ (opt_logger_red .== Finished .-->+ (taggerRed abs_ret_name :== Finished --> nonRedAbstractReturnsRed) .== Finished .-->+ SomeReducer non_red+ , SomeHalter+ (maxOutputsHalter (maxOutputs config)+ <~> zeroHalter (steps config)+ <~> lhAbsHalter entry mb_modname (expr_env st)+ <~> lhLimitByAcceptedHalter (cut_off lhconfig)+ <~> switchEveryNHalter (switch_after lhconfig)+ <~> lhAcceptIfViolatedHalter)+ , SomeOrderer lhLimitByAcceptedOrderer)+ else+ (opt_logger_red .== Finished .-->+ ((taggerRed state_name :== Finished --> non_red)) .== Finished .-->+ (taggerRed abs_ret_name :== Finished --> nonRedAbstractReturnsRed)+ , SomeHalter+ (discardIfAcceptedTagHalter state_name+ <~> discardIfAcceptedTagHalter abs_ret_name+ <~> maxOutputsHalter (maxOutputs config)+ <~> zeroHalter (steps config)+ <~> lhAbsHalter entry mb_modname (expr_env st)+ <~> lhLimitByAcceptedHalter (cut_off lhconfig)+ <~> switchEveryNHalter (switch_after lhconfig)+ <~> lhAcceptIfViolatedHalter)+ , SomeOrderer lhLimitByAcceptedOrderer) - -- getAnnotations ghci_cg+initializeLHData :: [GhcInfo] -> Maybe PhantomTyVars -> LHConfig -> LHStateM ()+initializeLHData ghcInfos m_ph_tyvars config = do+ addLHTC+ addOrdToNum - -- The simplification works less well on some of the Core generated by convertCurrExpr,- -- so we apply the simplification first- simplify+ addErrorAssumes config - ns <- convertCurrExpr ifi bindings+ let lh_measures = measureSpecs ghcInfos - cfn <- addCounterfactualBranch ns+ meenv <- measuresM+ nt <- return . M.fromList =<< mapMaybeM measureTypeMappings lh_measures+ fil_meenv <- filterMeasures' meenv (M.keys nt) - return cfn+ createMeasures lh_measures -getGHCInfos :: LHC.Config -> [FilePath] -> [FilePath] -> [FilePath] -> IO [LHOutput]-getGHCInfos config proj fp lhlibs = do- let config' = config {idirs = idirs config ++ proj ++ lhlibs- , files = files config ++ lhlibs- , ghcOptions = ["-v"]}+ case m_ph_tyvars of+ Just ph_tyvars -> addTyVarsMeasures ph_tyvars+ Nothing -> return () - -- GhcInfo- (ghci, _) <- LHI.getGhcInfos Nothing config' fp+ meenv' <- measuresM+ putMeasuresM (fil_meenv `E.union` meenv') - mapM (getGHCInfos' config') ghci+-- | Returns the name of the Tick on the counterfactual branches, and the names+-- of all functions with counterfactual branches+initializeLHSpecs :: Counterfactual -> [GhcInfo] -> Lang.Id -> Bindings -> LHStateM (Lang.Name, Lang.Id, S.HashSet Lang.Name)+initializeLHSpecs counter ghcInfos ifi bindings = do+ let specs = funcSpecs ghcInfos+ mergeLHSpecState specs + addSpecialAsserts+ addTrueAsserts (idName ifi) -getGHCInfos' :: LHC.Config -> GhcInfo -> IO LHOutput-getGHCInfos' config ghci = do- -- CGInfo- -- let cgi = generateConstraints ghci+ -- Most of the simplification works less well on some of the Core generated by convertCurrExpr,+ -- so we apply the simplification first. However, we do want to stamp out as much redundancy+ -- from convertCurrExpr as we can, so we do further simplificiation after+ simplify+ (main_call, ns) <- convertCurrExpr ifi bindings+ furtherSimplifyCurrExpr - -- finfo <- cgInfoFInfo ghci cgi- -- F.Result _ sol _ <- solve (fixConfig "LH_FILEPATH" config) finfo+ (cfn, ns') <- case counter of+ Counterfactual cf_mods ->+ return . (,ns) =<< addCounterfactualBranch cf_mods ns+ NotCounterfactual -> return (Name "" Nothing 0 Nothing, []) - return (LHOutput {ghcI = ghci, cgI = undefined {- cgi -}, solution = undefined {- sol -} })- -funcSpecs :: [GhcInfo] -> [(Var, LocSpecType)]-funcSpecs fs = concatMap (gsTySigs . spec) fs -- Functions asserted in LH- ++ concatMap (gsAsmSigs . spec) fs -- Functions assumed in LH+ mapME (return . flattenLets) -measureSpecs :: [GhcInfo] -> [Measure SpecType GHC.DataCon]-measureSpecs = concatMap (gsMeasures . spec)+ return (cfn, main_call, S.fromList ns') -reqNames :: State t -> [Name]+reqNames :: State t -> MemConfig reqNames (State { expr_env = eenv+ , type_env = tenv , type_classes = tc- , known_values = kv}) = - Lang.names [ mkGe eenv- , mkGt eenv- , mkEq eenv- , mkNeq eenv- , mkLt eenv- , mkLe eenv- , mkAnd eenv- , mkOr eenv- , mkNot eenv- , mkPlus eenv- , mkMinus eenv- , mkMult eenv- -- , mkDiv eenv- , mkMod eenv- , mkNegate eenv- , mkImplies eenv- , mkIff eenv- , mkFromInteger eenv- -- , mkToInteger eenv- ]- ++- Lang.names - (M.filterWithKey - (\k _ -> k == eqTC kv || k == numTC kv || k == ordTC kv || k == integralTC kv || k == structEqTC kv) - (toMap tc)- )+ , known_values = kv}) =+ let ns = Lang.namesList+ [ mkGe kv eenv+ , mkGt kv eenv+ , mkEq kv eenv+ , mkNeq kv eenv+ , mkLt kv eenv+ , mkLe kv eenv+ , mkAnd kv eenv+ , mkOr kv eenv+ , mkNot kv eenv+ , mkPlus kv eenv+ , mkMinus kv eenv+ , mkMult kv eenv+ -- , mkDiv kv eenv+ , mkMod kv eenv+ , mkNegate kv eenv+ , mkImplies kv eenv+ , mkIff kv eenv+ , mkFromInteger kv eenv+ -- , mkToInteger kv eenv -pprint :: (Var, LocSpecType) -> IO ()-pprint (v, r) = do- let i = mkIdUnsafe v+ , mkJust kv tenv+ , mkNothing kv tenv - let doc = PPR.rtypeDoc FPP.Full $ val r- putStrLn $ show i- putStrLn $ show doc+ , mkUnit kv tenv -printLHOut :: Lang.Id -> [ExecRes [FuncCall]] -> IO ()-printLHOut entry = printParsedLHOut . parseLHOut entry+ , mkIntegralExtactReal kv+ , mkRealExtractNum kv + ]+ +++ Lang.namesList + (HM.filterWithKey + (\k _ -> k == eqTC kv || k == numTC kv || k == ordTC kv || k == integralTC kv || k == fractionalTC kv) + (toMap tc)+ )+ +++ Lang.namesList (filter (\(Name _ m _ _) -> m == Just "Data.Set.Internal") (E.keys eenv))+ in+ MemConfig { search_names = ns+ , pres_func = pf }+ where+ pf _ (Bindings { deepseq_walkers = dsw }) a =+ S.fromList . map idName . M.elems $ M.filterWithKey (\n _ -> n `S.member` a) dsw -printParsedLHOut :: [LHReturn] -> IO ()-printParsedLHOut [] = return ()+printLHOut :: Lang.Id -> [ExecRes AbstractedInfo] -> IO ()+printLHOut entry =+ mapM_ (\lhr -> do printParsedLHOut lhr; putStrLn "") . map (parseLHOut entry)++printCE :: State t -> [CounterExample] -> IO ()+printCE s =+ mapM_ (\lhr -> do printParsedLHOut lhr; putStrLn "") . map (counterExampleToLHReturn s)++printParsedLHOut :: LHReturn -> IO () printParsedLHOut (LHReturn { calledFunc = FuncInfo {func = f, funcArgs = call, funcReturn = output} , violating = Nothing- , abstracted = abstr} : xs) = do+ , abstracted = abstr}) = do putStrLn "The call" TI.putStrLn $ call `T.append` " = " `T.append` output TI.putStrLn $ "violates " `T.append` f `T.append` "'s refinement type" printAbs abstr- putStrLn ""- printParsedLHOut xs printParsedLHOut (LHReturn { calledFunc = FuncInfo {funcArgs = call, funcReturn = output} , violating = Just (FuncInfo {func = f, funcArgs = call', funcReturn = output'})- , abstracted = abstr } : xs) = do+ , abstracted = abstr }) = do TI.putStrLn $ call `T.append` " = " `T.append` output putStrLn "makes a call to" TI.putStrLn $ call' `T.append` " = " `T.append` output' TI.putStrLn $ "violating " `T.append` f `T.append` "'s refinement type" printAbs abstr- putStrLn ""- printParsedLHOut xs printAbs :: [FuncInfo] -> IO () printAbs fi = do@@ -324,31 +622,54 @@ printFuncInfo (FuncInfo {funcArgs = call, funcReturn = output}) = TI.putStrLn $ call `T.append` " = " `T.append` output -parseLHOut :: Lang.Id -> [ExecRes [FuncCall]] -> [LHReturn]-parseLHOut _ [] = []-parseLHOut entry ((ExecRes { final_state = s- , conc_args = inArg- , conc_out = ex- , violated = ais}):xs) =- let - tl = parseLHOut entry xs- funcCall = T.pack $ mkCleanExprHaskell s - . foldl (\a a' -> App a a') (Var entry) $ inArg- funcOut = T.pack $ mkCleanExprHaskell s $ ex-- called = FuncInfo {func = nameOcc $ idName entry, funcArgs = funcCall, funcReturn = funcOut}+parseLHOut :: Lang.Id -> ExecRes AbstractedInfo -> LHReturn+parseLHOut entry (ExecRes { final_state = s+ , conc_args = inArg+ , conc_out = ex+ , violated = ais}) =+ let+ called = funcCallToFuncInfo (printHaskell s)+ $ FuncCall { funcName = idName entry, arguments = inArg, returns = ex} viFunc = fmap (parseLHFuncTuple s) ais - abstr = map (parseLHFuncTuple s) $ track s+ abstr = map (parseLHFuncTuple s) . map abstract . abs_calls $ track s in LHReturn { calledFunc = called- , violating = if called `sameFuncNameArgs` viFunc then Nothing else viFunc- , abstracted = abstr} : tl+ , violating = viFunc+ , abstracted = abstr} -sameFuncNameArgs :: FuncInfo -> Maybe FuncInfo -> Bool-sameFuncNameArgs _ Nothing = False-sameFuncNameArgs (FuncInfo {func = f1, funcArgs = fa1}) (Just (FuncInfo {func = f2, funcArgs = fa2})) = f1 == f2 && fa1 == fa2+counterExampleToLHReturn :: State t -> CounterExample -> LHReturn+counterExampleToLHReturn s (DirectCounter fc abstr _) =+ let+ called = funcCallToFuncInfo (printHaskell s) . abstract $ fc+ abstr' = map (funcCallToFuncInfo (printHaskell s) . abstract) abstr+ in+ LHReturn { calledFunc = called+ , violating = Nothing+ , abstracted = abstr'}+counterExampleToLHReturn s (CallsCounter fc viol_fc abstr _) =+ let+ called = funcCallToFuncInfo (printHaskell s) . abstract $ fc+ viol_called = funcCallToFuncInfo (printHaskell s) . abstract $ viol_fc+ abstr' = map (funcCallToFuncInfo (printHaskell s) . abstract) abstr+ in+ LHReturn { calledFunc = called+ , violating = Just viol_called+ , abstracted = abstr'} +funcCallToFuncInfo :: (Expr -> T.Text) -> FuncCall -> FuncInfo+funcCallToFuncInfo t (FuncCall { funcName = f, arguments = inArg, returns = ret }) =+ let+ funcCall = t . foldl (\a a' -> App a a') (Var (Id f TyUnknown)) $ inArg+ funcOut = t ret+ in+ FuncInfo {func = nameOcc f, funcArgs = funcCall, funcReturn = funcOut}++lhStateToCE :: ExecRes AbstractedInfo -> CounterExample+lhStateToCE (ExecRes { final_state = State { track = t } })+ | Just c <- abs_violated t = CallsCounter (init_call t) c (abs_calls t) (ai_higher_order_calls t)+ | otherwise = DirectCounter (init_call t) (abs_calls t) (ai_higher_order_calls t)+ parseLHFuncTuple :: State t -> FuncCall -> FuncInfo parseLHFuncTuple s (FuncCall {funcName = n, arguments = ars, returns = out}) = let@@ -357,5 +678,5 @@ Nothing -> error $ "Unknown type for abstracted function " ++ show n in FuncInfo { func = nameOcc n- , funcArgs = T.pack $ mkCleanExprHaskell s (foldl' App (Var (Id n t)) ars)- , funcReturn = T.pack $ mkCleanExprHaskell s out }+ , funcArgs = printHaskell s (foldl' App (Var (Id n t)) ars)+ , funcReturn = printHaskell s out }
src/G2/Liquid/LHReducers.hs view
@@ -1,27 +1,54 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -module G2.Liquid.LHReducers ( LHRed (..)- , LHLimitByAcceptedHalter- , LHLimitByAcceptedOrderer- , LHAbsHalter (..)+module G2.Liquid.LHReducers ( lhRed+ , allCallsRed+ , higherOrderCallsRed+ , redArbErrors+ , nonRedAbstractReturnsRed++ , lhAcceptIfViolatedHalter+ , lhSWHNFHalter+ , lhLimitByAcceptedOrderer+ , lhLimitByAcceptedHalter+ , lhAbsHalter+ , lhMaxOutputsHalter , LHTracker (..)- , lhReduce- , initialTrack - , limitByAccepted) where+ , lhStdTimerHalter+ , lhTimerHalter + , abstractCallsNum+ , minAbstractCalls++ , lhReduce+ , initialTrack) where++import G2.Execution.NormalForms import G2.Execution.Reducer import G2.Execution.Rules import G2.Language+import qualified G2.Language.Stack as Stck import qualified G2.Language.ExprEnv as E import G2.Liquid.Annotations+import G2.Liquid.Conversion+import G2.Liquid.Helpers+import G2.Liquid.SpecialAsserts -import Data.Monoid+import Control.Monad.IO.Class +import qualified Data.HashSet as S+import Data.List+import Data.List.Extra+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid hiding ((<>))+import Data.Ord import Data.Semigroup import qualified Data.Text as T+import Data.Time.Clock -- lhReduce -- When reducing for LH, we change the rule for evaluating Var f.@@ -42,12 +69,17 @@ -- only the information that LH also knows (that is, the information in the -- refinment type.) lhReduce :: Name -> State LHTracker -> Maybe (Rule, [State LHTracker])-lhReduce cfn s@(State { curr_expr = CurrExpr Evaluate (Tick (NamedLoc tn) e@(Assume fc _ _))- , track = tr@(LHTracker { abstract_calls = abs_c } )})+lhReduce cfn s@(State { curr_expr = CurrExpr Evaluate (Tick (NamedLoc tn) e@(Assume (Just fc) _ _))+ , track = tr@(LHTracker { abstract_calls = abs_c })+ , exec_stack = stck}) | cfn == tn =+ let+ stck' = if arguments fc == [] then Stck.filter (\f -> f /= UpdateFrame (funcName fc)) stck else stck+ in Just ( RuleOther , [s { curr_expr = CurrExpr Evaluate e- , track = tr { abstract_calls = maybe abs_c (:abs_c) fc }}])+ , track = tr { abstract_calls = fc:abs_c }+ , exec_stack = stck' }]) | otherwise = Nothing lhReduce _ _ = Nothing@@ -62,7 +94,7 @@ initialTrack eenv (App e e') = initialTrack eenv e + initialTrack eenv e' initialTrack eenv (Lam _ _ e) = initialTrack eenv e initialTrack eenv (Let b e) = initialTrack eenv e + (getSum $ evalContainedASTs (Sum . initialTrack eenv) b)-initialTrack eenv (Case e _ a) = initialTrack eenv e + (getMax $ evalContainedASTs (Max . initialTrack eenv) a)+initialTrack eenv (Case e _ _ a) = initialTrack eenv e + (getMax $ evalContainedASTs (Max . initialTrack eenv) a) initialTrack eenv (Cast e _) = initialTrack eenv e initialTrack eenv (Assume _ _ e) = initialTrack eenv e initialTrack eenv (Assert _ _ e) = initialTrack eenv e@@ -70,50 +102,109 @@ data LHTracker = LHTracker { abstract_calls :: [FuncCall] , last_var :: Maybe Name- , annotations :: AnnotMap } deriving (Eq, Show)+ , annotations :: AnnotMap + , all_calls :: [FuncCall]+ , higher_order_calls :: [FuncCall] } deriving (Eq, Show)++minAbstractCalls :: [State LHTracker] -> Int+minAbstractCalls xs =+ minimum $ 10000000000:mapMaybe (\s -> case true_assert s of+ True -> Just $ abstractCallsNum s+ False -> Nothing ) xs++abstractCallsNum :: State LHTracker -> Int+abstractCallsNum = length . abstract_calls . track+ instance Named LHTracker where- names (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns}) = - names abs_c ++ names n ++ names anns+ names (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns, all_calls = ac, higher_order_calls = hc}) = + names abs_c <> names n <> names anns <> names ac <> names hc - rename old new (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns}) =+ rename old new (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns, all_calls = ac, higher_order_calls = hc}) = LHTracker { abstract_calls = rename old new abs_c , last_var = rename old new n- , annotations = rename old new anns }+ , annotations = rename old new anns+ , all_calls = rename old new ac+ , higher_order_calls = rename old new hc } - renames hm (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns}) =+ renames hm (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns, all_calls = ac, higher_order_calls = hc}) = LHTracker { abstract_calls = renames hm abs_c , last_var = renames hm n- , annotations = renames hm anns }+ , annotations = renames hm anns+ , all_calls = renames hm ac+ , higher_order_calls = renames hm hc } instance ASTContainer LHTracker Expr where- containedASTs (LHTracker {abstract_calls = abs_c, annotations = anns}) =- containedASTs abs_c ++ containedASTs anns- modifyContainedASTs f lht@(LHTracker {abstract_calls = abs_c, annotations = anns}) =- lht {abstract_calls = modifyContainedASTs f abs_c, annotations = modifyContainedASTs f anns}+ containedASTs (LHTracker {abstract_calls = abs_c, annotations = anns, all_calls = ac, higher_order_calls = hc}) =+ containedASTs abs_c ++ containedASTs anns ++ containedASTs ac ++ containedASTs hc+ modifyContainedASTs f lht@(LHTracker {abstract_calls = abs_c, annotations = anns, all_calls = ac, higher_order_calls = hc}) =+ lht { abstract_calls = modifyContainedASTs f abs_c+ , annotations = modifyContainedASTs f anns+ , all_calls = modifyContainedASTs f ac+ , higher_order_calls = modifyContainedASTs f hc} instance ASTContainer LHTracker Type where- containedASTs (LHTracker {abstract_calls = abs_c, annotations = anns}) = containedASTs abs_c ++ containedASTs anns- modifyContainedASTs f lht@(LHTracker {abstract_calls = abs_c, annotations = anns}) =- lht {abstract_calls = modifyContainedASTs f abs_c, annotations = modifyContainedASTs f anns}+ containedASTs (LHTracker {abstract_calls = abs_c, annotations = anns, all_calls = ac, higher_order_calls = hc}) =+ containedASTs abs_c ++ containedASTs anns ++ containedASTs ac ++ containedASTs hc+ modifyContainedASTs f lht@(LHTracker {abstract_calls = abs_c, annotations = anns, all_calls = ac, higher_order_calls = hc}) =+ lht {abstract_calls = modifyContainedASTs f abs_c+ , annotations = modifyContainedASTs f anns+ , all_calls = modifyContainedASTs f ac+ , higher_order_calls = modifyContainedASTs f hc } -data LHRed = LHRed Name+{-# INLINE lhRed #-}+lhRed :: Monad m => Name -> Reducer m () LHTracker+lhRed cfn = mkSimpleReducer (const ()) rr+ where+ rr _ s b = do+ case lhReduce cfn s of+ Just (_, s') -> + return $ ( InProgress+ , zip s' (repeat ()), b)+ Nothing -> return (Finished, [(s, ())], b) -instance Reducer LHRed () LHTracker where- initReducer _ _ = ()+{-# INLINE allCallsRed #-}+allCallsRed :: Monad m => Reducer m () LHTracker+allCallsRed = mkSimpleReducer (const ()) rr+ where+ rr _ s@(State { curr_expr = CurrExpr Evaluate (Assert (Just fc) _ _) }) b =+ let+ lht = (track s) { all_calls = fc:all_calls (track s) }+ in+ return $ (Finished, [(s { track = lht } , ())], b)+ rr _ s b = return $ (Finished, [(s, ())], b) - redRules lhr@(LHRed cfn) _ s b = do- case lhReduce cfn s of- Just (_, s') -> - return $ ( InProgress- , zip s' (repeat ()), b, lhr)- Nothing -> return (Finished, [(s, ())], b, lhr)+{-# INLINE higherOrderCallsRed #-}+higherOrderCallsRed :: Monad m => Reducer m () LHTracker+higherOrderCallsRed = mkSimpleReducer (const ()) rr+ where+ rr _ s@(State { curr_expr = CurrExpr Evaluate (Tick (NamedLoc nl) (Assume (Just fc) _ _)) }) b | nl == higherOrderTickName=+ let+ lht = (track s) { higher_order_calls = fc:higher_order_calls (track s) }+ in+ return $ (Finished, [(s { track = lht } , ())], b)+ rr _ s@(State { curr_expr = CurrExpr Evaluate (Tick (NamedLoc nl) (Assume (Just fc) _ real_assert@(Assert _ _ _))) }) b | nl == higherOrderTickName=+ let+ lht = (track s) { higher_order_calls = fc:higher_order_calls (track s) }+ in+ return $ (Finished, [(s { curr_expr = CurrExpr Evaluate real_assert+ , track = lht } , ())], b)+ rr _ s b = return $ (Finished, [(s, ())], b) -limitByAccepted :: Int -> (LHLimitByAcceptedHalter, LHLimitByAcceptedOrderer)-limitByAccepted i = (LHLimitByAcceptedHalter i, LHLimitByAcceptedOrderer i)+{-# INLINE redArbErrors #-}+redArbErrors :: Monad m => Reducer m () t+redArbErrors = mkSimpleReducer (const ()) rr+ where+ rr _ s@(State { curr_expr = CurrExpr er (Tick tick (Let [(_, Type t)] _)) }) b + | tick == arbErrorTickish =+ let+ (arb, _) = arbValue t (type_env s) (arb_value_gen b)+ in+ return (InProgress, [(s { curr_expr = CurrExpr er arb }, ())], b)+ rr _ s b = return (Finished, [(s, ())], b) --- LHLimitByAcceptedHalter and LHLimitByAcceptedOrderer should always be used--- together.+-- LHLimitByAcceptedHalter should always be used+-- with LHLimitByAcceptedOrderer. -- LHLimitByAcceptedHalter is parameterized by a cutoff, `c`. -- It allows execution of a state only if -- (1) No counterexamples have been found@@ -129,40 +220,30 @@ -- least steps, we only restart a State with too many steps once EVERY state has too -- many steps. --- | Halt if we go `n` steps past another, already accepted state -data LHLimitByAcceptedHalter = LHLimitByAcceptedHalter Int--instance Halter LHLimitByAcceptedHalter (Maybe Int) LHTracker where- initHalt _ _ = Nothing-- -- If we start trying to execute a state with more than the maximal number- -- of rules applied, we throw it away.- discardOnStart (LHLimitByAcceptedHalter co) (Just v) _ s = num_steps s > v + co- discardOnStart _ Nothing _ _ = False+-- | Halt if we go `n` steps past another, already accepted state+lhLimitByAcceptedHalter :: Monad m => Int -> Halter m (Maybe Int) LHTracker+lhLimitByAcceptedHalter co =+ (mkSimpleHalter (const Nothing) update stop (\hv _ _ _ -> hv)) { discardOnStart = discard }+ where+ -- If we start trying to execute a state with more than the maximal number+ -- of rules applied, we throw it away.+ discard (Just v) _ s = num_steps s > v + co+ discard Nothing _ _ = False - -- Find all accepted states with the (current) minimal number of abstracted functions- -- Then, get the minimal number of steps taken by one of those states- updatePerStateHalt _ _ (Processed { accepted = []}) _ = Nothing- updatePerStateHalt _ _ (Processed { accepted = acc@(_:_)}) _ =- Just . minimum . map num_steps- $ allMin (length . abstract_calls . track) acc- - stopRed _ Nothing _ _ = Continue- stopRed (LHLimitByAcceptedHalter co) (Just nAcc) _ s =- if num_steps s > nAcc + co then Switch else Continue- - stepHalter _ hv _ _ _ = hv+ -- Find all accepted states with the (current) minimal number of abstracted functions+ -- Then, get the minimal number of steps taken by one of those states+ update _ (Processed { accepted = []}) _ = Nothing+ update _ (Processed { accepted = acc@(_:_)}) _ =+ Just . minimum . map num_steps+ $ allMin (length . abstract_calls . track) acc+ + stop Nothing _ _ = return Continue+ stop (Just nAcc) _ s =+ return $ if num_steps s > nAcc + co then Switch else Continue -- | Runs the state that had the fewest number of rules applied.-data LHLimitByAcceptedOrderer = LHLimitByAcceptedOrderer Int- -instance Orderer LHLimitByAcceptedOrderer () Int LHTracker where- initPerStateOrder _ _ = ()-- orderStates _ _ = num_steps-- updateSelected _ _ _ _ = ()-+lhLimitByAcceptedOrderer :: Monad m => Orderer m () Int t+lhLimitByAcceptedOrderer = mkSimpleOrderer (const ()) (\_ _ -> return . num_steps ) (\_ _ -> return ()) allMin :: Ord b => (a -> b) -> [a] -> [a] allMin f xs =@@ -172,21 +253,136 @@ filter (\s -> minT == (f s)) xs -- | Halt if we abstract more calls than some other already accepted state-data LHAbsHalter = LHAbsHalter T.Text (Maybe T.Text) ExprEnv+{-# INLINE lhAbsHalter #-}+lhAbsHalter :: Monad m => T.Text -> Maybe T.Text -> ExprEnv -> Halter m Int LHTracker+lhAbsHalter entry modn eenv = mkSimpleHalter initial update stop step+ where+ -- We initialize the maximal number of abstracted variables,+ -- to the number of variables in the entry function+ initial _ =+ let + fe = case E.occLookup entry modn eenv of+ Just e -> e+ Nothing -> error $ "initOrder: Bad function passed\n" ++ show entry ++ " " ++ show modn+ in+ initialTrack eenv fe -instance Halter LHAbsHalter Int LHTracker where- -- We initialize the maximal number of abstracted variables,- -- to the number of variables in the entry function- initHalt (LHAbsHalter entry modn eenv) _ =- let - fe = case E.occLookup entry modn eenv of- Just e -> e- Nothing -> error $ "initOrder: Bad function passed\n" ++ show entry ++ show modn- in- initialTrack eenv fe+ update ii (Processed {accepted = acc}) _ =+ minimum $ ii:mapMaybe (\s -> case true_assert s of+ True -> Just . length . abstract_calls . track $ s+ False -> Nothing) acc - updatePerStateHalt _ ii (Processed {accepted = acc}) _ = minimum $ ii:map (length . abstract_calls . track) acc+ stop hv _ s =+ return $ if length (abstract_calls $ track s) > hv+ then Discard+ else Continue - stopRed _ hv _ s = if length (abstract_calls $ track s) > hv then Discard else Continue+ step hv _ _ _ = hv - stepHalter _ hv _ _ _ = hv+{-# INLINE lhMaxOutputsHalter #-}+lhMaxOutputsHalter :: Monad m => Int -> Halter m Int LHTracker+lhMaxOutputsHalter mx = (mkSimpleHalter+ (const mx)+ (\hv _ _ -> hv)+ (\_ _ _ -> return Continue)+ (\hv _ _ _ -> hv)) { discardOnStart = discard}+ where+ discard m (Processed { accepted = acc }) _ = length acc' >= m+ where+ min_abs = minAbstractCalls acc+ acc' = filter (\s -> abstractCallsNum s == min_abs) acc++{-# INLINE lhStdTimerHalter #-}+lhStdTimerHalter :: (MonadIO m, MonadIO m_run) => NominalDiffTime -> m (Halter m_run Int t)+lhStdTimerHalter ms = lhTimerHalter ms 10++{-# INLINE lhTimerHalter #-}+lhTimerHalter :: (MonadIO m, MonadIO m_run) => NominalDiffTime -> Int -> m (Halter m_run Int t)+lhTimerHalter ms ce = do+ curr <- liftIO $ getCurrentTime+ return $ mkSimpleHalter (const 0)+ (\_ _ _ -> 0)+ (stop curr)+ step+ where+ stop it v (Processed { accepted = acc }) _+ | v == 0+ , any true_assert acc = do+ curr <- liftIO $ getCurrentTime+ let t_diff = diffUTCTime curr it++ if t_diff > ms+ then return Discard+ else return Continue+ | otherwise = return Continue++ step v _ _ _+ | v >= ce = 0+ | otherwise = v + 1++-- | Reduces any non-SWHNF values being returned by an abstracted function+{-# INLINE nonRedAbstractReturnsRed #-}+nonRedAbstractReturnsRed :: Monad m => Reducer m () LHTracker+nonRedAbstractReturnsRed =+ mkSimpleReducer (const ())+ nonRedAbstractReturnsRedStep++nonRedAbstractReturnsRedStep :: Monad m => RedRules m () LHTracker+nonRedAbstractReturnsRedStep _ + s@(State { expr_env = eenv+ , curr_expr = cexpr+ , exec_stack = stck+ , track = LHTracker { abstract_calls = afs }+ , true_assert = True })+ b@(Bindings { deepseq_walkers = ds})+ | Just af <- firstJust (absRetToRed eenv ds) afs = do+ let stck' = Stck.push (CurrExprFrame NoAction cexpr) stck+ cexpr' = CurrExpr Evaluate af++ let s' = s { curr_expr = cexpr'+ , exec_stack = stck'+ }++ return (InProgress, [(s', ())], b)+ | otherwise = do+ return (Finished, [(s, ())], b)+nonRedAbstractReturnsRedStep _ s b = return (Finished, [(s, ())], b)++absRetToRed :: ExprEnv -> Walkers -> FuncCall -> Maybe Expr+absRetToRed eenv ds (FuncCall { returns = r })+ | not . normalForm eenv $ r+ , Just strict_e <- mkStrict_maybe ds r =+ Just $ fillLHDictArgs ds strict_e + | otherwise = Nothing++-- | Accepts a state when it is in SWHNF, true_assert is true,+-- and all abstracted functions have reduced returns.+-- Discards it if in SWHNF and true_assert is false+lhAcceptIfViolatedHalter :: Monad m => Halter m () LHTracker+lhAcceptIfViolatedHalter = mkSimpleHalter (const ()) (\_ _ _ -> ()) stop (\_ _ _ _ -> ())+ where+ stop _ _ s =+ let+ eenv = expr_env s+ abs_calls = abstract_calls (track s)+ in+ case isExecValueForm s of+ True + | true_assert s+ , all (normalForm eenv . returns) abs_calls -> return Accept+ | true_assert s -> return Continue+ | otherwise -> return Discard+ False -> return Continue++lhSWHNFHalter :: Monad m => Halter m () LHTracker+lhSWHNFHalter = mkSimpleHalter (const ()) (\_ _ _ -> ()) stop (\_ _ _ _ -> ())+ where+ stop _ _ s =+ let+ eenv = expr_env s+ abs_calls = abstract_calls (track s)+ in+ case isExecValueForm s && all (normalForm eenv . returns) abs_calls of+ True -> return Accept+ False -> return Continue+
src/G2/Liquid/Measures.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -module G2.Liquid.Measures (Measures, createMeasures) where+module G2.Liquid.Measures (Measures, createMeasures, filterMeasures', measureTypeMappings) where import G2.Language import qualified G2.Language.ExprEnv as E@@ -13,7 +14,7 @@ import Control.Monad.Extra -import qualified Data.Map as M+import Data.List import Data.Maybe import qualified GHC as GHC @@ -23,9 +24,11 @@ -- This is required to find all measures that are written in comments. createMeasures :: [Measure SpecType GHC.DataCon] -> LHStateM () createMeasures meas = do- nt <- return . M.fromList =<< mapMaybeM measureTypeMappings meas+ nt <- return . HM.fromList =<< mapMaybeM measureTypeMappings meas meas' <- mapMaybeM (convertMeasure nt) =<< filterM allTypesKnown meas + filterMeasures (HM.keys nt)+ meenv <- measuresM let eenvk = E.keys meenv mvNames = filter (flip notElem eenvk) $ varNames meas'@@ -35,13 +38,35 @@ return () +-- | We remove any names covered by the Measures found by LH from the Measures we already have+-- to prevent using the wrong measures later+filterMeasures :: [Name] -> LHStateM ()+filterMeasures nt = do+ pre_meenv <- measuresM+ fil_meenv <- filterMeasures' pre_meenv nt+ putMeasuresM fil_meenv++filterMeasures' :: Measures -> [Name] -> LHStateM Measures+filterMeasures' pre_meenv nt = do+ let ns = map (\(Name n m _ _) -> (n, m)) nt+ fil_meenv = E.filterWithKey (\(Name n m _ _) _ -> (n, m) `notElem` ns) pre_meenv+ return fil_meenv+ allTypesKnown :: Measure SpecType GHC.DataCon -> LHStateM Bool+#if MIN_VERSION_liquidhaskell(0,8,6)+allTypesKnown (M {msSort = srt}) = do+#else allTypesKnown (M {sort = srt}) = do+#endif st <- specTypeToType srt return $ isJust st measureTypeMappings :: Measure SpecType GHC.DataCon -> LHStateM (Maybe (Name, Type))+#if MIN_VERSION_liquidhaskell(0,8,6)+measureTypeMappings (M {msName = n, msSort = srt}) = do+#else measureTypeMappings (M {name = n, sort = srt}) = do+#endif st <- specTypeToType srt lh <- lhTCM @@ -61,7 +86,11 @@ mapInTyForAlls (\t' -> foldr TyFun t' lhD) t convertMeasure :: BoundTypes -> Measure SpecType GHC.DataCon -> LHStateM (Maybe (Name, Expr))+#if MIN_VERSION_liquidhaskell(0,8,6)+convertMeasure bt (M {msName = n, msSort = srt, msEqns = eq}) = do+#else convertMeasure bt (M {name = n, sort = srt, eqns = eq}) = do+#endif let n' = symbolName $ val n st <- specTypeToType srt@@ -78,12 +107,15 @@ stArgs = anonArgumentTypes . PresType $ fromJust st stRet = fmap (returnType . PresType) st - lam_i <- freshIdN (head stArgs)+ lam_i <- mapM freshIdN stArgs cb <- freshIdN (head stArgs) - alts <- mapMaybeM (convertDefs stArgs stRet (M.fromList as_t) bt) eq+ alts <- mapMaybeM (convertDefs stArgs stRet (HM.fromList as_t) bt) eq+ fls <- mkFalseE+ let defTy = maybe TyUnknown (returnType . PresType) st+ defAlt = Alt Default $ Assume Nothing fls (Prim Undefined defTy) - let e = mkLams as' (Lam TermL lam_i $ Case (Var lam_i) cb alts) + let e = mkLams (as' ++ map (TermL,) lam_i) $ Case (Var (head lam_i)) cb defTy (defAlt:alts) case st of -- [1] Just _ -> return $ Just (n', e)@@ -96,14 +128,12 @@ convertDefs :: [Type] -> Maybe Type -> LHDictMap -> BoundTypes -> Def SpecType GHC.DataCon -> LHStateM (Maybe Alt) convertDefs [l_t] ret m bt (Def { ctor = dc, body = b, binds = bds}) | TyCon _ _ <- tyAppCenter l_t- , st_t <- tyAppArgs l_t = do+ , st_t <- tyAppArgs l_t+ , dc' <- mkDataUnsafe dc = do tenv <- typeEnv- let (DataCon n t) = mkData HM.empty HM.empty dc- (TyCon tn _) = tyAppCenter $ returnType $ PresType t- dc' = getDataConNameMod tenv tn n- + let -- See [1] below, we only evaluate this if Just- dc''@(DataCon _ dct) = fromJust dc'+ dc''@(DataCon _ dct) = fixNamesDC tenv dc' bnds = tyForAllBindings $ PresType dct dctarg = anonArgumentTypes $ PresType dct @@ -116,20 +146,49 @@ let is = map (uncurry Id) nt - e <- mkExprFromBody ret m (M.union bt $ M.fromList nt) b+ e <- mkExprFromBody ret m (HM.union bt $ HM.fromList nt) b - case dc' of- Just _ -> return $ Just $ Alt (DataAlt dc'' is) e -- [1]- Nothing -> return Nothing+ return $ Just $ Alt (DataAlt dc'' is) e -- [1]+ | otherwise = return Nothing convertDefs _ _ _ _ _ = error "convertDefs: Unhandled Type List" +fixNamesDC :: TypeEnv -> DataCon -> DataCon+fixNamesDC tenv (DataCon n t) =+ let+ (TyCon tn _) = tyAppCenter $ returnType $ PresType t+ in+ case getDataConNameMod tenv tn n of+ Just (DataCon dcn _) -> DataCon dcn (fixNamesType tenv t)+ Nothing -> error "fixNamesDC: Bad DC"++fixNamesType :: TypeEnv -> Type -> Type+fixNamesType tenv = modify (fixNamesType' tenv)++fixNamesType' :: TypeEnv -> Type -> Type+fixNamesType' tenv (TyCon n k) =+ case getTypeNameMod tenv n of+ Just n' -> TyCon n' k+ Nothing -> error "fixNamesType: Bad Type"+fixNamesType' _ t = t++getTypeNameMod :: TypeEnv -> Name -> Maybe Name+getTypeNameMod tenv (Name n m _ _) = find (\(Name n' m' _ _) -> n == n' && m == m') $ HM.keys tenv+ mkExprFromBody :: Maybe Type -> LHDictMap -> BoundTypes -> Body -> LHStateM Expr mkExprFromBody ret m bt (E e) = convertLHExpr (mkDictMaps m) bt ret e mkExprFromBody ret m bt (P e) = convertLHExpr (mkDictMaps m) bt ret e-mkExprFromBody _ _ _ _ = error "mkExprFromBody: Unhandled Body"+mkExprFromBody ret m bt (R s e) = do+ let s_nm = symbolName s+ t = maybe (error "mkExprFromBody: ret type unknown") id ret+ i = Id s_nm t + bt' = HM.insert s_nm t bt+ g2_e <- convertLHExpr (mkDictMaps m) bt' ret e+ return . Let [(i, SymGen SNoLog t)] . Assume Nothing g2_e $ Var i + mkDictMaps :: LHDictMap -> DictMaps mkDictMaps ldm = DictMaps { lh_dicts = ldm- , num_dicts = M.empty- , integral_dicts = M.empty- , ord_dicts = M.empty}+ , num_dicts = HM.empty+ , integral_dicts = HM.empty+ , fractional_dicts = HM.empty+ , ord_dicts = HM.empty}
+ src/G2/Liquid/MkLHVals.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}++module G2.Liquid.MkLHVals (mkLHVals) where++import G2.Language as Lang+import G2.Language.KnownValues+import qualified G2.Language.ExprEnv as E++import qualified Data.HashSet as S+import qualified Data.Text as T++mkLHVals :: State t+ -> S.HashSet Name+ -> [Name]+ -> NameGen+ -> (ExprEnv, KnownValues, TypeClasses, S.HashSet Name, [Name], NameGen)+mkLHVals (State { expr_env = eenv+ , type_env = tenv+ , known_values = kv+ , type_classes = tc }) inst exported ng =+ let+ renme = E.keys eenv+ ((meenv, mkv, mtc, minst, mexported), ng') = doRenames renme ng (eenv, kv, tc, inst, exported)++ (newMod, meenv', ng'') = symGenIfZero (modFunc mkv) meenv tenv mkv mtc ng'+ in+ (meenv', mkv { modFunc = newMod } , mtc, minst, mexported, ng'')++symGenIfZero :: Name -> ExprEnv -> TypeEnv -> KnownValues -> TypeClasses -> NameGen -> (Name, ExprEnv, NameGen)+symGenIfZero n eenv tenv kv tc ng =+ case E.lookup n eenv of+ Just e ->+ let+ (newN, ng') = freshSeededString ("symGen" `T.append` nameOcc n) ng+ (e', ng'') = symGenIfZero' e eenv tenv kv tc ng'+ in+ (newN, E.insert newN e' eenv, ng'')+ Nothing -> error "symGenIfZero: Name not found"++symGenIfZero' :: Expr -> ExprEnv -> TypeEnv -> KnownValues -> TypeClasses -> NameGen -> (Expr, NameGen)+symGenIfZero' e eenv tenv kv tc ng =+ let+ (ars, ng') = argTyToLamUseIds (spArgumentTypes e) ng++ class_ty = case ars of+ (TypeL, c_ty):_ -> c_ty+ _ -> error "symGenIfZero: Type not found"+ snd_int = haveType (TyVar class_ty) (map snd ars) !! 1++ int_tcs_m = tcWithNameMap (integralTC kv) (map snd ars)+ int_tc = case typeClassInst tc int_tcs_m (integralTC kv) (TyVar class_ty) of+ Just int_tc' -> int_tc'+ Nothing -> error "symGenIfZero: Typeclass dictionary not found"++ type_expr = Type (TyVar class_ty)+ num_dict = App + (App+ (mkRealExtractNum kv)+ type_expr+ )+ (App + (App+ (mkIntegralExtactReal kv)+ type_expr+ )+ int_tc+ )+ eq_dict =+ App+ (App+ (mkOrdExtractEq kv)+ type_expr+ )+ (App + (App+ (mkRealExtractOrd kv)+ type_expr+ )+ (App + (App+ (mkIntegralExtactReal kv)+ type_expr+ )+ int_tc+ )+ )+ zero = App (mkDCInteger kv tenv) (Lit (LitInt 0))+ zero_con = mkApp [mkFromInteger kv eenv, type_expr, num_dict, zero]+ eq = mkApp [ Var (Id (eqFunc kv) TyUnknown)+ , type_expr+ , eq_dict+ , Var snd_int+ , zero_con]++ (i, ng'') = freshId (Lang.tyBool kv) ng'++ trueDC = mkDCTrue kv tenv++ ret_t = returnType e++ e' = mkLams ars+ $ Case eq i ret_t+ [ Alt Default (mkApp (e:map (Var . snd) ars))+ , Alt (DataAlt trueDC []) (SymGen SNoLog ret_t)]+ in+ (e', ng'')++haveType :: Type -> [Id] -> [Id]+haveType t = filter (\e -> typeOf e == t)++argTyToLamUseIds :: [ArgType] -> NameGen -> ([(LamUse, Id)], NameGen)+argTyToLamUseIds =+ mapNG (\ar_ty ng ->+ case ar_ty of+ NamedType i -> ((TypeL, i), ng)+ AnonType t ->+ let+ (n, ng') = freshName ng+ in+ ((TermL, Id n t), ng'))
src/G2/Liquid/Simplify.hs view
@@ -1,20 +1,42 @@ {-# Language FlexibleContexts #-}+{-# Language OverloadedStrings #-} -module G2.Liquid.Simplify ( simplify ) where+module G2.Liquid.Simplify ( simplify+ , furtherSimplifyCurrExpr ) where import G2.Language+import qualified G2.Language.ExprEnv as E+import qualified G2.Language.Simplification as GSimp import G2.Language.Monad import G2.Liquid.Types +import qualified Data.HashSet as HS+import Data.Monoid ((<>))+import qualified Data.Text as T+ -- | The LH translation generates certain redundant Expr's over and over again. -- Here we stamp them out. simplify :: LHStateM () simplify = do+ removeRedundantAsserts simplifyExprEnv mapCurrExpr simplifyExpr mapAssumptionsM simplifyExpr mapAnnotsExpr simplifyExpr + in_eenv <- inlineEnv+ in_case_env <- inlineInCaseEnv+ mapAssumptionsM (return . GSimp.simplifyExprs in_eenv in_case_env)+ mapPostM (return . GSimp.simplifyExprs in_eenv in_case_env)+ mapE (GSimp.simplifyExprs in_eenv in_case_env)+ mapMeasuresM (return . GSimp.simplifyExprs in_eenv in_case_env)++furtherSimplifyCurrExpr :: LHStateM ()+furtherSimplifyCurrExpr = do+ in_eenv <- inlineEnv+ in_case_env <- inlineInCaseEnv+ mapCurrExpr (return . GSimp.simplifyExprs in_eenv in_case_env)+ simplifyExprEnv :: LHStateM () simplifyExprEnv = mapME simplifyExpr @@ -85,3 +107,94 @@ fixM f e = do e' <- f e if e == e' then return e else fixM f e'+++-- | Asserts in the default numerical classes just reflect the actual function definition directly,+-- so we can remove them to save some time.+removeRedundantAsserts :: LHStateM ()+removeRedundantAsserts = mapWithKeyME removeRedundantAsserts'++removeRedundantAsserts' :: Name -> Expr -> LHStateM Expr+removeRedundantAsserts' (Name n m _ _) e+ | (n, m) `HS.member` specFuncs = return $ elimAsserts e+ | otherwise = return e++-- | Environments for inlining+inlineEnv :: LHStateM ExprEnv+inlineEnv = do+ tcv <- tcValuesM+ lh_tc_n <- lhTCM+ lhnum_tc_n <- lhNumTCM++ g2_int <- tyIntT+ lh_int_tc <- measureClassDictExpr lh_tc_n g2_int+ num_int_tc <- regTCClassDictExpr lhnum_tc_n g2_int++ eenv <- exprEnv+ meas <- measuresM+ let lh_ns = names tcv <> names lh_int_tc <> names num_int_tc+ eenv' = E.filterWithKey (\n _ -> n `elem` lh_ns) $ E.union eenv meas+ return eenv'++inlineInCaseEnv :: LHStateM ExprEnv+inlineInCaseEnv = do+ tc <- typeClasses+ lh_tc_n <- lhTCM+ lh_num <- lhNumTCM+ let all_lh_tc = lookupTCDicts lh_tc_n tc+ all_num_tc = lookupTCDicts lh_num tc++ eenv <- exprEnv+ meas <- measuresM+ let lh_ns = names all_lh_tc <> names all_num_tc+ eenv' = E.filterWithKey (\n _ -> n `elem` lh_ns) $ E.union eenv meas+ return eenv'++measureClassDictExpr :: Name -> Type -> LHStateM (Maybe Expr)+measureClassDictExpr = classDictExpr lookupMeasureM lookupTCDictTC++regTCClassDictExpr :: Name -> Type -> LHStateM (Maybe Expr)+regTCClassDictExpr = classDictExpr lookupE lookupTCDictTC++classDictExpr :: (Name -> LHStateM (Maybe Expr))+ -> (Name -> Type -> LHStateM (Maybe Id))+ -> Name+ -> Type+ -> LHStateM (Maybe Expr)+classDictExpr look_ex look_tc n t = do+ i <- look_tc n t+ case i of+ Just i' -> look_ex (idName i')+ Nothing -> return Nothing++specFuncs :: HS.HashSet (T.Text, Maybe T.Text)+specFuncs = HS.fromList [ ("+", Just "GHC.Num")+ , ("-", Just "GHC.Num")+ , ("*", Just "GHC.Num")+ , ("negate", Just "GHC.Num")+ , ("abs", Just "GHC.Num")+ , ("signum", Just "GHC.Num")+ , ("fromInteger", Just "GHC.Num")++ , ("quot", Just "GHC.Real")+ , ("rem", Just "GHC.Real")+ , ("div", Just "GHC.Real")+ , ("mod", Just "GHC.Real")+ , ("quotRem", Just "GHC.Real")+ , ("divMod", Just "GHC.Real")+ , ("toInteger", Just "GHC.Real")++ , ("==", Just "GHC.Classes")+ , ("/=", Just "GHC.Classes")++ , ("<", Just "GHC.Classes")+ , ("<=", Just "GHC.Classes")+ , (">", Just "GHC.Classes")+ , (">=", Just "GHC.Classes")++ , ("I#", Just "GHC.Types")+ , ("True", Just "GHC.Types")+ , ("False", Just "GHC.Types")++ , ("$", Just "GHC.Base")]+
src/G2/Liquid/SpecialAsserts.hs view
@@ -1,11 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+ module G2.Liquid.SpecialAsserts ( addSpecialAsserts- , addTrueAsserts) where+ , addTrueAsserts+ , addTrueAssertsAll+ , addErrorAssumes+ , arbErrorTickish+ , assumeErrorTickish) where +import G2.Liquid.Config import G2.Language import qualified G2.Language.KnownValues as KV import G2.Language.Monad import G2.Liquid.Types +import qualified Data.HashSet as S+import qualified Data.Text as T++import Debug.Trace+ -- | Adds an assert of false to the function called when a pattern match fails addSpecialAsserts :: LHStateM () addSpecialAsserts = do@@ -27,9 +39,9 @@ -- excluding certain functions (namely dicts) that we never want to abstract -- Furthermore, expands all Lambdas as much as possible, so that we get all the arguments -- for the assertion. -addTrueAsserts :: Id -> LHStateM ()-addTrueAsserts i = do- ns <- return . maybe [] varNames =<< lookupE (idName i)+addTrueAsserts :: ExState s m => Name -> m ()+addTrueAsserts n = do+ ns <- return . maybe [] varNames =<< lookupE n tc <- return . tcDicts =<< typeClasses let tc' = map idName tc@@ -37,21 +49,88 @@ mapWithKeyME (addTrueAsserts' ns') -addTrueAsserts' :: [Name] -> Name -> Expr -> LHStateM Expr+addTrueAsserts' :: ExState s m => [Name] -> Name -> Expr -> m Expr addTrueAsserts' ns n e- | n `elem` ns =- insertInLamsE (\is e' ->- case e' of- Let [(_, _)] (Assert _ _ _) -> return e'- _ -> do- true <- mkTrueE- r <- freshIdN (typeOf e')+ | n `elem` ns = addTrueAssert'' n e+ | otherwise = return e - let fc = FuncCall { funcName = n- , arguments = map Var is- , returns = (Var r)}- e'' = Let [(r, e')] $ Assert (Just fc) true (Var r)+addTrueAssert'' :: ExState s m => Name -> Expr -> m Expr +addTrueAssert'' n e = do+ insertInLamsE (\is e' ->+ case e' of+ Let [(_, _)] (Assert _ _ _) -> return e'+ _ -> do+ true <- mkTrueE+ r <- freshIdN (returnType e') - return e''- ) =<< etaExpandToE (numArgs e) e- | otherwise = return e+ more_is <- tyBindings e'++ let fc = FuncCall { funcName = n+ , arguments = map Var $ is ++ map snd more_is+ , returns = (Var r)}+ e'' = mkLams more_is $ Let [(r, mkApp $ e':map (Var . snd) more_is)] $ Assert (Just fc) true (Var r)++ return e''+ ) =<< etaExpandToE (numArgs e) e++tyBindings :: (ExState s m, Typed t) => t -> m [(LamUse, Id)]+tyBindings t = do+ let at = spArgumentTypes t+ fn <- freshNamesN (length at)+ return $ tyBindings' fn at++tyBindings' :: [Name] -> [ArgType] -> [(LamUse, Id)]+tyBindings' _ [] = []+tyBindings' ns (NamedType i:ts) = (TypeL, i):tyBindings' ns ts+tyBindings' (n:ns) (AnonType t:ts) = (TermL, Id n t):tyBindings' ns ts+tyBindings' [] _ = error "Name list exhausted in tyBindings'"++addTrueAssertsAll :: ExState s m => m ()+addTrueAssertsAll = mapWithKeyME (addTrueAssert'')++--- [BlockErrors]+-- | Blocks calling error in the functions specified in the block_errors_in in+-- the Config, by wrapping the errors in Assume False.+addErrorAssumes :: LHConfig -> LHStateM ()+addErrorAssumes config = do+ kv <- knownValues+ mapWithKeyME (addErrorAssumes' (block_errors_method config) (block_errors_in config) kv)+ lh_kv <- lhKnownValuesM+ mapMeasuresWithKeyM (addErrorAssumes' (block_errors_method config) (block_errors_in config) lh_kv)++addErrorAssumes' :: BlockErrorsMethod -> S.HashSet (T.Text, Maybe T.Text) -> KnownValues -> Name -> Expr -> LHStateM Expr+addErrorAssumes' be ns kv (Name n m _ _) e = do+ if (n, m) `S.member` ns then addErrorAssumes'' be kv (typeOf e) e else return e++addErrorAssumes'' :: BlockErrorsMethod -> KnownValues -> Type -> Expr -> LHStateM Expr+addErrorAssumes'' be kv _ v@(Var (Id n t))+ | KV.isErrorFunc kv n + , be == AssumeBlock = do+ flse <- mkFalseE+ return $ Assume Nothing (Tick assumeErrorTickish flse) v+ | KV.isErrorFunc kv n+ , be == ArbBlock = do+ d <- freshSeededStringN "d"+ let ast = spArgumentTypes $ PresType t+ rt = returnType $ PresType t++ lam_it = map (\as -> case as of+ AnonType at -> (TermL, Id d at)+ NamedType i -> (TypeL, i)) ast+ fr_n <- trace ("ast = " ++ show ast ++ "\nrt = " ++ show rt) freshSeededStringN "t"+ + flse <- mkFalseE++ return . mkLams lam_it+ . Assume Nothing (Tick assumeErrorTickish flse) + . Tick arbErrorTickish+ $ Let [(Id fr_n TYPE, Type rt)] v+addErrorAssumes'' be kv (TyForAll _ t) (Lam u i e) = return . Lam u i =<< modifyChildrenM (addErrorAssumes'' be kv t) e+addErrorAssumes'' be kv (TyFun _ t) (Lam u i e) = return . Lam u i =<< modifyChildrenM (addErrorAssumes'' be kv t) e+addErrorAssumes'' be kv t e = modifyChildrenM (addErrorAssumes'' be kv t) e++arbErrorTickish :: Tickish+arbErrorTickish = NamedLoc (Name "arb_error" Nothing 0 Nothing)++assumeErrorTickish :: Tickish+assumeErrorTickish = NamedLoc (Name "library_error" Nothing 0 Nothing)
src/G2/Liquid/TCGen.hs view
@@ -10,26 +10,26 @@ import G2.Liquid.Types import Data.Foldable-import qualified Data.Map as M+import qualified Data.HashMap.Lazy as HM import qualified Data.Text as T -- | Creates an LHState. This involves building a TCValue, and -- creating the new LH TC which checks equality, and has a function to -- check refinements of polymorphic types-createLHState :: Measures -> KnownValues -> State [FuncCall] -> Bindings -> (LHState, Bindings)-createLHState meenv mkv s b =+createLHState :: Measures -> KnownValues -> TypeClasses -> State [FuncCall] -> Bindings -> (LHState, Bindings)+createLHState meenv mkv mtc s b = let- (tcv, (s', b')) = runStateM (createTCValues mkv) s b+ (tcv, (s', b')) = runStateM (createTCValues mkv (type_env s)) s b - lh_s = consLHState s' meenv tcv+ lh_s = consLHState s' meenv mkv mtc tcv in execLHStateM (do createLHTCFuncs createExtractors) lh_s b' -createTCValues :: KnownValues -> StateM [FuncCall] TCValues-createTCValues kv = do+createTCValues :: KnownValues -> TypeEnv -> StateM [FuncCall] TCValues+createTCValues kv tenv = do lhTCN <- freshSeededStringN "lh" lhEqN <- freshSeededStringN "lhEq" lhNeN <- freshSeededStringN "lhNe"@@ -41,6 +41,7 @@ lhPPN <- freshSeededStringN "lhPP" lhNuOr <- freshSeededStringN "lhNuOr"+ lhOrdN <- freshSeededStringN "lhOrd" let tcv = (TCValues { lhTC = lhTCN , lhNumTC = KV.numTC kv @@ -61,21 +62,34 @@ , lhMod = KV.modFunc kv , lhFromInteger = KV.fromIntegerFunc kv , lhToInteger = KV.toIntegerFunc kv++ , lhFromRational = KV.fromRationalFunc kv++ , lhToRatioFunc = KV.toRatioFunc kv+ , lhNumOrd = lhNuOr , lhAnd = KV.andFunc kv , lhOr = KV.orFunc kv+ , lhNot = KV.notFunc kv - , lhPP = lhPPN })+ , lhImplies = KV.impliesFunc kv+ , lhIff = KV.iffFunc kv + , lhPP = lhPPN++ , lhOrd = lhOrdN++ , lhSet = nameModMatch (Name "Set" (Just "Data.Set.Internal") 0 Nothing) tenv})+ return tcv type PredFunc = LHDictMap -> Name -> AlgDataTy -> DataCon -> [Id] -> LHStateM [Alt] createLHTCFuncs :: LHStateM () createLHTCFuncs = do- lhm <- mapM (uncurry initalizeLHTC) . M.toList =<< typeEnv- let lhm' = M.fromList lhm+ lhm <- mapM (uncurry initalizeLHTC) . HM.toList =<< typeEnv+ let lhm' = HM.fromList lhm -- createLHTCFuncs' relies on the standard TypeClass lookup functions to get access to -- LH Dicts. So it is important that, before calling it, we set up the TypeClass correctly@@ -90,11 +104,11 @@ tc <- typeClasses tcn <- lhTCM tci <- freshIdN TYPE- let tc' = insertClass tcn (Class { insts = lhtc, typ_ids = [tci] }) tc+ let tc' = insertClass tcn (Class { insts = lhtc, typ_ids = [tci], superclasses = [] }) tc putTypeClasses tc' -- Now, we do the work of actually generating all the code/functions for the typeclass- mapM_ (uncurry (createLHTCFuncs' lhm')) . M.toList =<< typeEnv+ mapM_ (uncurry (createLHTCFuncs' lhm')) . HM.toList =<< typeEnv initalizeLHTC :: Name -> AlgDataTy -> LHStateM (Name, Id) initalizeLHTC n adt = do@@ -109,12 +123,12 @@ let ct = foldl' TyApp (TyCon n TYPE) $ map TyVar bi let t = (TyApp - (TyCon lh TYPE) + (TyCon lh (TyFun TYPE TYPE)) ct ) let t' = foldr TyFun t $ map (TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) bi- let t'' = foldr TyForAll t' $ map NamedTyBndr bi+ let t'' = foldr TyForAll t' bi return t'' lhName :: T.Text -> Name -> LHStateM Name@@ -150,6 +164,15 @@ pp <- lhPPFunc n adt insertMeasureM ppN pp + -- We also put the Ord typeclass into the LH TC, if it exists.+ ord <- ordTCM+ ordDict <- lookupTCDictTC ord (TyCon n TyUnknown)+ ordE <- case ordDict of+ Just i -> return (Var i)+ _ -> do+ flse <- mkFalseE+ return (Assume Nothing flse (Prim Undefined TyUnknown))+ -- We define a function to get the LH Dict for this type -- It takes and passes on the type arguments, and the LH Dicts for those -- type arguments@@ -167,15 +190,15 @@ , (leN, (typeOf le)) , (gtN, (typeOf gt)) , (geN, (typeOf ge))- , (ppN, (typeOf pp)) ]- let fs' = map (\f -> mkApp $ f:bt ++ lhdv) fs+ , (ppN, (typeOf pp))]+ let fs' = map (\f -> mkApp $ f:bt ++ lhdv) fs ++ [ordE] lhdct <- lhDCType let e = mkApp $ Data (DataCon lh lhdct):fs' let e' = foldr (Lam TermL) e lhd let e'' = foldr (Lam TypeL) e' bi - let fn = M.lookup n lhm+ let fn = HM.lookup n lhm case fn of Just fn' -> do@@ -210,9 +233,12 @@ taab --ge (TyFun TyUnknown- (TyApp - (TyCon lh TYPE) - (TyVar n)+ (TyFun+ TyUnknown+ (TyApp + (TyCon lh (TyFun TYPE TYPE)) + (TyVar n)+ ) ) ) )@@ -232,12 +258,12 @@ let bi = bound_ids adt lh <- lhTCM- lhbi <- mapM (freshIdN . TyApp (TyCon lh TYPE) . TyVar) bi+ lhbi <- mapM (freshIdN . TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) bi d1 <- freshIdN (TyCon n TYPE) d2 <- freshIdN (TyCon n TYPE) - let m = M.fromList $ zip (map idName bi) lhbi+ let m = HM.fromList $ zip (map idName bi) lhbi e <- mkFirstCase cf m d1 d2 n adt let e' = mkLams (map (TypeL,) bi ++ map (TermL,) lhbi ++ [(TermL, d1), (TermL, d2)]) e@@ -247,10 +273,12 @@ mkFirstCase :: PredFunc -> LHDictMap -> Id -> Id -> Name -> AlgDataTy -> LHStateM Expr mkFirstCase f ldm d1 d2 n adt@(DataTyCon { data_cons = dcs }) = do caseB <- freshIdN (typeOf d1)- return . Case (Var d1) caseB =<< mapM (mkFirstCase' f ldm d2 n adt) dcs+ boolT <- tyBoolT+ return . Case (Var d1) caseB boolT =<< mapM (mkFirstCase' f ldm d2 n adt) dcs mkFirstCase f ldm d1 d2 n adt@(NewTyCon { data_con = dc }) = do caseB <- freshIdN (typeOf d1)- return . Case (Var d1) caseB . (:[]) =<< mkFirstCase' f ldm d2 n adt dc+ boolT <- tyBoolT+ return . Case (Var d1) caseB boolT . (:[]) =<< mkFirstCase' f ldm d2 n adt dc mkFirstCase _ _ _ _ _ _ = error "mkFirstCase: Unsupported AlgDataTy" mkFirstCase' :: PredFunc -> LHDictMap -> Id -> Name -> AlgDataTy -> DataCon -> LHStateM Alt@@ -265,8 +293,10 @@ alts <- f ldm n adt dc ba1 - return $ Case (Var d2) caseB alts+ boolT <- tyBoolT + return $ Case (Var d2) caseB boolT alts+ lhEqFunc :: PredFunc lhEqFunc ldm _ _ dc ba1 = do ba2 <- freshIdsN $ anonArgumentTypes dc@@ -289,8 +319,8 @@ i <- freshIdN TYPE b <- tyBoolT - let lhv = App (Var $ Id lhe (TyForAll (NamedTyBndr i) (TyFun (TyVar i) (TyFun (TyVar i) b)))) (Type t) lhd <- lhTCDict' ldm t+ let lhv = App (Var $ Id lhe (TyForAll i (TyFun (typeOf lhd) (TyFun (TyVar i) (TyFun (TyVar i) b))))) (Type t) return $ foldl' App (App lhv lhd) [Var i1, Var i2] @@ -302,7 +332,7 @@ lhd <- lhTCDict' ldm t - let lhv = App (Var (Id lhe (TyForAll (NamedTyBndr i) (TyFun (TyVar i) (TyFun (TyVar i) b))))) (Type t)+ let lhv = App (Var (Id lhe (TyForAll i (TyFun (typeOf lhd) (TyFun (TyVar i) (TyFun (TyVar i) b)))))) (Type t) return $ App (App (App lhv lhd) (Var i1)) (Var i2) | TyFun _ _ <- t = mkTrueE@@ -333,12 +363,14 @@ trueDC <- mkDCTrueM falseDC <- mkDCFalseM + tBool <- tyBoolT+ pr <- mapM (uncurry (eqLHFuncCall ldm)) $ zip ba1 ba2 let pr' = foldr (\e -> App (App an e)) true pr b <- freshIdN =<< tyBoolT- let pr'' = Case pr' b [ Alt (DataAlt trueDC []) false- , Alt (DataAlt falseDC []) true ]+ let pr'' = Case pr' b tBool [ Alt (DataAlt trueDC []) false+ , Alt (DataAlt falseDC []) true ] return [ Alt Default false , Alt (DataAlt dc ba2) pr''] @@ -367,7 +399,7 @@ let bi = bound_ids adt lh <- lhTCM- lhbi <- mapM (freshIdN . TyApp (TyCon lh TYPE) . TyVar) bi+ lhbi <- mapM (freshIdN . TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) bi d1 <- freshIdN (TyCon n TYPE) d2 <- freshIdN (TyCon n TYPE)@@ -382,6 +414,7 @@ mkOrdCases :: Primitive -> KnownValues -> Id -> Id -> Name -> AlgDataTy -> LHStateM Expr mkOrdCases pr kv i1 i2 n (DataTyCon { data_cons = [dc]}) | n == KV.tyInt kv = mkPrimOrdCases pr TyLitInt i1 i2 dc+ | n == KV.tyInteger kv = mkPrimOrdCases pr TyLitInt i1 i2 dc | n == KV.tyFloat kv = mkPrimOrdCases pr TyLitFloat i1 i2 dc | n == KV.tyDouble kv = mkPrimOrdCases pr TyLitDouble i1 i2 dc | otherwise = mkTrueE@@ -404,38 +437,46 @@ ) (Var b2) - let c2 = Case (Var i2) i2' [Alt (DataAlt dc [b2]) eq]+ let c2 = Case (Var i2) i2' b [Alt (DataAlt dc [b2]) eq] - return $ Case (Var i1) i1' [Alt (DataAlt dc [b1]) c2]+ return $ Case (Var i1) i1' b [Alt (DataAlt dc [b1]) c2] lhPPFunc :: Name -> AlgDataTy -> LHStateM Expr lhPPFunc n adt = do let bi = bound_ids adt lh <- lhTCM- lhbi <- mapM (freshIdN . TyApp (TyCon lh TYPE) . TyVar) bi+ lhbi <- mapM (freshIdN . TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) bi b <- tyBoolT fs <- mapM (\v -> freshIdN (TyFun (TyVar v) b)) bi - d <- freshIdN (TyCon n TYPE)+ let k = foldr (const (TyApp TYPE)) TYPE bi+ t = foldl' TyApp (TyCon n k) (map TyVar bi)+ d <- freshIdN t -- (TyCon n TYPE) - let lhm = M.fromList $ zip (map idName bi) lhbi- let fnm = M.fromList $ zip (map idName bi) fs+ let lhm = HM.fromList $ zip (map idName bi) lhbi+ let fnm = HM.fromList $ zip (map idName bi) fs e <- lhPPCase lhm fnm adt d let e' = mkLams (map (TypeL,) bi ++ map (TermL,) lhbi ++ map (TermL,) fs ++ [(TermL, d)]) e return e' -type PPFuncMap = M.Map Name Id+type PPFuncMap = HM.HashMap Name Id lhPPCase :: LHDictMap -> PPFuncMap -> AlgDataTy -> Id -> LHStateM Expr-lhPPCase lhm fnm adt i = do+lhPPCase lhm fnm (DataTyCon { data_cons = dcs }) i = do ci <- freshIdN (typeOf i)+ tBool <- tyBoolT - return . Case (Var i) ci =<< mapM (lhPPAlt lhm fnm) (dataCon adt)+ return . Case (Var i) ci tBool =<< mapM (lhPPAlt lhm fnm) dcs+lhPPCase lhm fnm (NewTyCon { rep_type = rt }) i = do+ pp <- lhPPCall lhm fnm rt+ let c = Cast (Var i) (typeOf i :~ rt)+ return $ App pp c + lhPPAlt :: LHDictMap -> PPFuncMap -> DataCon -> LHStateM Alt lhPPAlt lhm fnm dc = do ba <- freshIdsN $ anonArgumentTypes dc@@ -464,13 +505,21 @@ return . mkApp $ lhv:[Type t, dict] ++ undefs -- ++ [Var i] | TyVar (Id n _) <- t- , Just f <- M.lookup n fnm = return $ Var f -- App (Var f) (Var i)+ , Just f <- HM.lookup n fnm = return $ Var f -- App (Var f) (Var i) | TyVar _ <- tyAppCenter t = do i <- freshIdN t return . Lam TermL i =<< mkTrueE | TyFun _ _ <- t = do- i <- freshIdN t- return . Lam TermL i =<< mkTrueE+ let ts = anonArgumentTypes $ PresType t+ rt = returnType $ PresType t+ let_is <- freshIdsN ts+ bind_i <- freshIdN t+ let bind_app = mkApp $ Var bind_i:map Var let_is+ pp <- lhPPCall lhm fnm rt+ let pp_app = App pp bind_app+ return . Lam TermL bind_i $ Let (zip let_is $ map (SymGen SNoLog) ts) pp_app+ -- i <- freshIdN t+ -- return . Lam TermL i =<< mkTrueE | TyForAll _ _ <- t = do i <- freshIdN t return . Lam TermL i =<< mkTrueE@@ -495,8 +544,10 @@ ne <- lhNeM pp <- lhPPM - createExtractors' lh [eq, ne, lt, le, gt, ge, pp]+ ord <- lhOrdM + createExtractors' lh [eq, ne, lt, le, gt, ge, pp, ord]+ createExtractors' :: Name -> [Name] -> LHStateM () createExtractors' lh ns = mapM_ (uncurry (createExtractors'' lh (length ns))) $ zip [0..] ns @@ -506,18 +557,19 @@ bi <- freshIdsN $ replicate i TyUnknown - li <- freshIdN (TyCon lh (TyApp TYPE TYPE)) - ci <- freshIdN (TyCon lh (TyApp TYPE TYPE))+ li <- freshIdN (TyCon lh (TyFun TYPE TYPE)) + ci <- freshIdN (TyCon lh (TyFun TYPE TYPE)) b <- freshIdN TYPE let d = DataCon lh (TyForAll - (NamedTyBndr b) + b (TyFun (TyVar b) - (TyApp (TyCon lh (TyApp TYPE TYPE)) (TyVar b))+ (TyApp (TyCon lh (TyFun TYPE TYPE)) (TyVar b)) ) )- let c = Case (Var li) ci [Alt (DataAlt d bi) (Var $ bi !! j)]+ let vi = bi !! j+ c = Case (Var li) ci (typeOf vi) [Alt (DataAlt d bi) (Var vi)] let e = Lam TypeL a $ Lam TermL li c insertMeasureM n e
src/G2/Liquid/TCValues.hs view
@@ -3,11 +3,15 @@ import G2.Language.Naming import G2.Language.Syntax +import Data.Monoid ((<>))+import qualified Data.Sequence as S+ -- | Stores variable names that are used in the LH encoding. -- There are two reasons a name might exist: -- (1) It corresponds to something that only makes sense in the context of LH -- (i.e. the LH typeclass)--- (2) It is a copy of a function that normally exists, but that copy has no assertion added. +-- (2) It is a copy of a function that normally exists, but that copy has no assertion added.+-- (3) We only care about the specific name in LH code (the Set data type) data TCValues = TCValues { lhTC :: Name , lhNumTC :: Name , lhOrdTC :: Name@@ -26,18 +30,33 @@ , lhDiv :: Name , lhNegate :: Name , lhMod :: Name+ , lhFromInteger :: Name , lhToInteger :: Name + , lhFromRational :: Name++ , lhToRatioFunc :: Name+ , lhNumOrd :: Name , lhAnd :: Name , lhOr :: Name+ , lhNot :: Name - , lhPP :: Name } deriving (Eq, Show, Read)+ , lhImplies :: Name+ , lhIff :: Name + , lhPP :: Name++ , lhOrd :: Name++ , lhSet :: Maybe Name } deriving (Eq, Show, Read)+ instance Named TCValues where- names tcv = [ lhTC tcv+ names tcv = + S.fromList+ [ lhTC tcv , lhNumTC tcv , lhOrdTC tcv , lhEq tcv@@ -55,14 +74,26 @@ , lhNegate tcv , lhMod tcv , lhFromInteger tcv+ , lhToInteger tcv++ , lhFromRational tcv++ , lhToRatioFunc tcv+ , lhNumOrd tcv , lhAnd tcv , lhOr tcv+ , lhNot tcv - , lhPP tcv]+ , lhImplies tcv+ , lhIff tcv + , lhPP tcv++ , lhOrd tcv] <> maybe S.empty (S.singleton) (lhSet tcv)+ rename old new tcv = TCValues { lhTC = rename old new $ lhTC tcv , lhNumTC = rename old new $ lhNumTC tcv , lhOrdTC = rename old new $ lhOrdTC tcv@@ -80,11 +111,25 @@ , lhDiv = rename old new $ lhDiv tcv , lhNegate = rename old new $ lhNegate tcv , lhMod = rename old new $ lhMod tcv+ , lhFromInteger = rename old new $ lhFromInteger tcv , lhToInteger = rename old new $ lhToInteger tcv++ , lhFromRational = rename old new $ lhFromRational tcv+ + , lhToRatioFunc = rename old new $ lhToRatioFunc tcv+ , lhNumOrd = rename old new $ lhNumOrd tcv , lhAnd = rename old new $ lhAnd tcv , lhOr = rename old new $ lhOr tcv+ , lhNot = rename old new $ lhNot tcv - , lhPP = rename old new $ lhPP tcv }+ , lhImplies = rename old new $ lhImplies tcv+ , lhIff = rename old new $ lhIff tcv++ , lhPP = rename old new $ lhPP tcv++ , lhOrd = rename old new $ lhOrd tcv++ , lhSet = rename old new $ lhSet tcv }
+ src/G2/Liquid/TyVarBags.hs view
@@ -0,0 +1,426 @@+-- This module creates IR functions to extract an arbitrary (non-deterministic)+-- value of type a_i from a type of the form T a_1 ... a_n. If there are no+-- values with type a_i, the function calls `Assume False`.++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module G2.Liquid.TyVarBags ( TyVarBags+ , InstFuncs+ , existentialInstRed+ , createBagAndInstFuncs++ , extractTyVarCall+ , wrapExtractCalls+ , instTyVarCall++ , existentialInstId+ , postSeqExistentialInstId+ , putExistentialInstInExprEnv+ , putSymbolicExistentialInstInExprEnv+ , addTicksToDeepSeqCases) where++import G2.Execution.Reducer+import G2.Language+import qualified G2.Language.ExprEnv as E+import G2.Language.Monad+import qualified G2.Language.Stack as Stck+import G2.Liquid.Types++import Control.Monad+import qualified Data.HashSet as S+import qualified Data.HashMap.Lazy as HM+import qualified Data.Map.Lazy as M+import qualified Data.Text as T++-- | The bag and instantiation functions rely on each other, so we have to make them together+createBagAndInstFuncs :: [Name] -- ^ Which types do we need bag functions for?+ -> [Name] -- ^ Which types do we need instantiation functions for?+ -> LHStateM ()+createBagAndInstFuncs bag_func_ns inst_func_ns = do+ tenv <- typeEnv+ + let bag_func_ns' = relNames tenv S.empty bag_func_ns+ bag_tenv = HM.filterWithKey (\n _ -> n `S.member` bag_func_ns') tenv+ bag_names <- assignBagFuncNames bag_tenv+ setTyVarBags bag_names++ let inst_func_ns' = relNames tenv S.empty inst_func_ns+ inst_tenv = HM.filterWithKey (\n _ -> n `S.member` inst_func_ns') tenv+ inst_names <- assignInstFuncNames inst_tenv+ setInstFuncs inst_names++ createBagFuncs bag_names bag_tenv+ createInstFuncs inst_names inst_tenv++relNames :: TypeEnv -> S.HashSet Name -> [Name] -> S.HashSet Name+relNames _ rel [] = rel+relNames tenv rel (n:ns) =+ if S.member n rel+ then relNames tenv rel ns+ else relNames tenv (S.insert n rel) ns'+ where+ ns' = case HM.lookup n tenv of+ Nothing -> ns+ Just r -> namesList r ++ ns++createBagFuncs :: TyVarBags -- ^ Which types do we need bag functions for?+ -> TypeEnv+ -> LHStateM ()+createBagFuncs func_names tenv = do+ mapM_ (uncurry (createBagFunc func_names)) (HM.toList tenv)++-- | Creates a mapping of type names to bag creation function names +assignBagFuncNames :: ExState s m => TypeEnv -> m TyVarBags+assignBagFuncNames tenv =+ return . M.fromList+ =<< mapM+ (\(n@(Name n' m _ _), adt) -> do+ let dc = head (dataCon adt)+ bi = bound_ids adt+ mkName i = Name (n' `T.append` "_create_bag_" `T.append` (T.pack . show $ i)) m 0 Nothing++ fn <- mapM+ (\(i, tbi) -> do+ n_fn <- freshSeededNameN (mkName i)+ let t = foldr (\ntb -> TyForAll ntb)+ (TyFun (returnType dc) (TyVar tbi)) bi+ return $ Id n_fn t)+ $ zip [0 :: Int ..] bi+ return (n, fn)+ ) (HM.toList tenv)++createBagFunc :: TyVarBags -> Name -> AlgDataTy -> LHStateM ()+createBagFunc func_names tn adt+ | Just fs <- M.lookup tn func_names =+ mapM_ (uncurry (createBagFunc' func_names tn adt)) $ zip fs (bound_ids adt)+ | otherwise = error "createBagFunc: type not found"++createBagFunc' :: TyVarBags+ -> Name+ -> AlgDataTy+ -> Id -- ^ The Id of the function to create+ -> Id -- ^ The Id of the TyVar to extract+ -> LHStateM ()+createBagFunc' func_names tn adt fn tyvar_id = do+ bi <- freshIdsN $ map (const TYPE) (bound_ids adt)+ adt_i <- freshIdN $ mkFullAppedTyCon tn (map TyVar bi) TYPE++ cse <- createBagFuncCase func_names adt_i tyvar_id bi adt+ let e = mkLams (map (TypeL,) bi) $ Lam TermL adt_i cse++ insertE (idName fn) e++-- | Examines the passed `Id` adt_i, which is the ADT to extract the tyvar tyvar_id from,+-- and constructs an expression to actually nondeterministically extract a tyvar_id.+createBagFuncCase :: TyVarBags+ -> Id+ -> Id+ -> [Id]+ -> AlgDataTy+ -> LHStateM Expr+createBagFuncCase func_names adt_i tyvar_id bi (DataTyCon { bound_ids = adt_bi+ , data_cons = dc }) = do+ bindee <- freshIdN (typeOf adt_i)+ let ty_map = zip adt_bi (map TyVar bi)+ alts <- mapM (createBagFuncCaseAlt func_names tyvar_id ty_map) dc+ + return $ Case (Var adt_i) bindee (typeOf $ head alts) alts+createBagFuncCase func_names adt_i tyvar_id bi (NewTyCon { bound_ids = adt_bi+ , rep_type = rt }) = do+ let rt' = foldr (uncurry retype) rt $ zip adt_bi (map TyVar bi)+ cst = Cast (Var adt_i) (typeOf adt_i :~ rt')+ clls <- extractTyVarCall func_names todo_emp tyvar_id cst+ wrapExtractCalls clls+createBagFuncCase _ _ _ _ (TypeSynonym {}) =+ error "creatBagFuncCase: TypeSynonyms unsupported"++createBagFuncCaseAlt :: TyVarBags -> Id -> [(Id, Type)] -> DataCon -> LHStateM Alt+createBagFuncCaseAlt func_names tyvar_id ty_map dc = do+ let at = anonArgumentTypes dc+ is <- freshIdsN at+ let is' = foldr (uncurry retype) is ty_map+ tyvar_id' = maybe tyvar_id id $ tyVarId =<< lookup tyvar_id ty_map+ es <- return . concat =<< mapM (extractTyVarCall func_names todo_emp tyvar_id' . Var) is'+ case null es of+ True -> do + flse <- mkFalseE+ return $ Alt (DataAlt dc is') + (Assume Nothing flse (Prim Undefined (TyVar tyvar_id)))+ False -> return $ Alt (DataAlt dc is') (NonDet es)+ where+ tyVarId (TyVar i) = Just i+ tyVarId _ = Nothing++todo_emp :: [a]+todo_emp = []++-- | Creates a set of expressions to get all TyVars i out of an+-- expression e. +extractTyVarCall :: TyVarBags+ -> [(Id, Id)] -- ^ Mapping of TyVar Ids to Functions to create those TyVars+ -> Id + -> Expr + -> LHStateM [Expr]+extractTyVarCall func_names is_fs i e + | TyVar i' <- t+ , i == i' = return [e]+ | TyCon n tc_t:ts <- unTyApp t+ , Just fn <- M.lookup n func_names = do+ let is = anonArgumentTypes (PresType tc_t)+ ty_ars = map Type $ take (length is) ts+ nds = map (\f -> App (mkApp (Var f:ty_ars)) e) fn+ nds' <- mapM (extractTyVarCall func_names is_fs i) nds+ return (concat nds')+ | TyFun _ _ <- t = do+ let ars_ty = anonArgumentTypes $ PresType t+ tvs = tyVarIds . returnType $ PresType t++ inst_fs <- getInstFuncs+ inst_ars <- mapM (instTyVarCall' inst_fs is_fs) ars_ty+ let call_f = mkApp $ e:inst_ars++ cll <- if i `elem` tvs then extractTyVarCall func_names is_fs i call_f else return []+ return cll+ | otherwise = return []+ where+ t = typeOf e++wrapExtractCalls :: ExState s m => [Expr] -> m Expr+wrapExtractCalls clls = do+ case null clls of+ True -> do+ -- flse <- mkFalseE+ return (Var existentialInstId)+ False -> return $ NonDet clls++-- | Creates functions to, for each type (T a_1 ... a_n), create a nondeterministic value.+-- Each a_1 ... a_n has an associated function, allowing the caller to decide how to instantiate+-- these values. +createInstFuncs :: InstFuncs -- ^ Which types do we need instantiation functions for?+ -> TypeEnv+ -> LHStateM ()+createInstFuncs func_names tenv = do+ mapM_ (uncurry (createInstFunc func_names)) (HM.toList tenv)++-- | Creates a mapping of type names to instantatiation function names +assignInstFuncNames :: ExState s m => TypeEnv -> m InstFuncs+assignInstFuncNames tenv =+ return . M.fromList+ =<< mapM+ (\(tn@(Name n m _ _), adt) -> do+ let bi = bound_ids adt+ fn <- freshSeededNameN (Name (n `T.append` "_inst_") m 0 Nothing)++ let adt_i = mkFullAppedTyCon tn (map TyVar bi) TYPE+ let t = foldr (\ntb -> TyForAll ntb)+ (foldr (\i -> TyFun (TyVar i)) adt_i bi) bi++ return (tn, Id fn t)+ ) (HM.toList tenv)++createInstFunc :: InstFuncs -> Name -> AlgDataTy -> LHStateM ()+createInstFunc func_names tn adt+ | Just fn <- M.lookup tn func_names = do+ bi <- freshIdsN $ map (const TYPE) (bound_ids adt)+ inst_fs <- freshIdsN $ map TyVar bi++ cse <- createInstFunc' func_names (zip bi inst_fs) adt+ let e = mkLams (map (TypeL,) bi) $ mkLams (map (TermL,) inst_fs) cse++ insertE (idName fn) e+ | otherwise = error "createInstFunc: type not found"++createInstFunc' :: InstFuncs -> [(Id, Id)] -> AlgDataTy -> LHStateM Expr+createInstFunc' func_names is_fs (DataTyCon { data_cons = dcs }) = do+ dc' <- mapM (\dc -> do+ let apped_dc = mkApp (Data dc:map (Type . TyVar . fst) is_fs)+ ars_ty = anonArgumentTypes dc++ is_fs' = zipWith (\i (_, f) -> (i, f)) (leadingTyForAllBindings dc) is_fs++ ars <- mapM (instTyVarCall' func_names is_fs') ars_ty+ bnds <- mapM freshIdN ars_ty+ let vrs = map Var bnds++ let e = mkApp $ apped_dc:vrs+ e' <- foldM wrapPrimsInCase e vrs+ return $ Let (zip bnds ars) e') dcs+ return (NonDet dc')+createInstFunc' _ _ (NewTyCon { rep_type = _ }) = do+ -- rt_val <- instTyVarCall' func_names is_fs rt+ return $ Cast undefined undefined+createInstFunc' _ _ _ = error "createInstFunc': unhandled datatype"++-- | Creates an instTyVarCall function call to create an expression of type t with appropriate TyVars+instTyVarCall :: ExState s m =>+ InstFuncs+ -> [(Id, Id)] -- ^ Mapping of TyVar Ids to Functions to create those TyVars+ -> Type+ -> m Expr+instTyVarCall func_names is_fs t = do+ tUnit <- tyUnitT+ ui <- freshIdN tUnit+ cll <- instTyVarCall' func_names is_fs t + return $ Lam TermL ui cll++instTyVarCall' :: ExState s m =>+ InstFuncs+ -> [(Id, Id)] -- ^ Mapping of TyVar Ids to Functions to create those TyVars+ -> Type+ -> m Expr+instTyVarCall' func_names is_fs t + | TyVar i <- t+ , Just f <- lookup i is_fs = do+ return $ Var f+ | TyVar i <- t = do+ flse <- mkFalseE+ return . Assume Nothing flse . Prim Undefined $ TyVar i++ | TyCon n tc_t:ts <- unTyApp t+ , Just fn <- M.lookup n func_names = do+ let tyc_is = anonArgumentTypes (PresType tc_t)+ ty_ts = take (length tyc_is) ts++ ty_ars = map Type ty_ts+ func_ars <- mapM (\t' -> case t' of+ TyVar i+ | Just i' <- lookup i is_fs -> return (Var i')+ _ -> do+ cll <- instTyVarCall' func_names is_fs t'+ return cll) ty_ts+ let_ids <- freshIdsN $ map typeOf func_ars+ let bnds = zip let_ids func_ars++ return . Let bnds . mkApp $ Var fn:ty_ars ++ map Var let_ids+ | otherwise = do+ let tfa = leadingTyForAllBindings $ PresType t+ tfa_is = zipWith (\i1 (i2, _) -> (i1, TyVar i2)) tfa is_fs++ rt = foldr (uncurry retype) (returnType $ PresType t) tfa_is+ return $ SymGen SNoLog rt++-- | Primitive operation function calls do not force evaluation of the+-- underlying primitive value- the assumption is that this is already a literal+-- or a symbolic value. Thus, if we have a SymGen being passed to a primitive+-- operation, our rules will not know how to handle it.+-- Thus, we wrap SymGen's of primitive types in case statements.+wrapPrimsInCase :: ExState s m => Expr -> Expr -> m Expr+wrapPrimsInCase e e'+ | isPrimType t = do+ i <- freshIdN t+ return $ Case e' i (typeOf e) [Alt Default e]+ | otherwise = return e+ where+ t = typeOf e'++----------------------------------------+-- Existential Inst++-- Suppose a function returns a value with a polymorphic type, without taking+-- any of those types as arguments. This is common with functions that return+-- the "empty" case of data structures, such as Data.Map.empty.+-- In this case, we instantiate with an "existential" value,+-- that basically says some value may exist, but we do not know specifically what it is++existentialInstId :: Id+existentialInstId = Id (Name "EXISTENTIAL_INST_NAME" Nothing 0 Nothing) TyUnknown++postSeqExistentialInstId :: Id+postSeqExistentialInstId = Id (Name "POST_SEQ_EXISTENTIAL_INST_NAME" Nothing 0 Nothing) TyUnknown+++-- | Place this in a Tick in the first Alt of a Case, to treat the case normally,+-- even if the existential Id is in the bindee+existentialCaseName :: Name+existentialCaseName = Name "EXISTENTIAL_CASE_NAME" Nothing 0 Nothing++putExistentialInstInExprEnv :: State t -> State t+putExistentialInstInExprEnv s@(State { expr_env = eenv }) =+ s { expr_env = E.insert+ (idName existentialInstId)+ (Var existentialInstId)+ eenv }++putSymbolicExistentialInstInExprEnv :: State t -> State t+putSymbolicExistentialInstInExprEnv s@(State { expr_env = eenv }) =+ s { expr_env = E.insertSymbolic+ existentialInstId+ eenv+ }++{-# INLINE existentialInstRed #-}+existentialInstRed :: Monad m => Reducer m () t+existentialInstRed = mkSimpleReducer (const ()) existInstRedRules++existInstRedRules :: Monad m => RedRules m () t+existInstRedRules rv s@(State { expr_env = eenv+ , curr_expr = CurrExpr Evaluate e })+ b@(Bindings { name_gen = ng })+ | Var i <- e+ , i == existentialInstId =+ let+ s' = s { expr_env = E.insertSymbolic i eenv+ , curr_expr = CurrExpr Return e }+ in+ return (InProgress, [(s', rv)], b)+ | Case (Var i) bnd _ ([Alt (DataAlt _ params) (Tick (NamedLoc n) ae)]) <- e+ , i == existentialInstId+ , n == existentialCaseName =+ let+ (n_bnd, ng') = freshSeededName (idName bnd) ng+ (n_params, ng'') = freshSeededNames (map idName params) ng'++ eenv' = E.insertSymbolic postSeqExistentialInstId eenv+ eenv'' = foldr (\en -> E.insert en (Var existentialInstId)) eenv' n_params+ n_e = rename (idName bnd) n_bnd $ foldr (uncurry rename) ae (zip (map idName params) n_params)+ in + return ( InProgress+ , [(s { expr_env = eenv''+ , curr_expr = CurrExpr Evaluate n_e }, rv)]+ , b { name_gen = ng'' })+ | Case (Var i) _ _ ([Alt _ (Tick (NamedLoc n) ae)]) <- e+ , i == existentialInstId+ , n == existentialCaseName =+ let+ eenv' = E.insertSymbolic postSeqExistentialInstId eenv+ in + return ( InProgress+ , [(s { expr_env = eenv'+ , curr_expr = CurrExpr Evaluate ae }, rv)]+ , b)+ | Case (Var i) _ _ _ <- e+ , i == existentialInstId =+ let+ s' = s { curr_expr = CurrExpr Return (Var i) }+ in+ return (InProgress, [(s', rv)], b)+existInstRedRules rv s@(State { curr_expr = CurrExpr Return e+ , exec_stack = stck }) b++ | Just (AssumeFrame _, stck') <- Stck.pop stck+ , Var i <- e+ , i == existentialInstId =+ return (InProgress, [(s { exec_stack = stck' }, rv)], b)+ | Just (AssertFrame _ _, stck') <- Stck.pop stck+ , Var i <- e+ , i == existentialInstId =+ return (InProgress, [(s { exec_stack = stck' }, rv)], b)+existInstRedRules rv s b = return (NoProgress, [(s, rv)], b)++addTicksToDeepSeqCases :: Walkers -> State t -> State t+addTicksToDeepSeqCases w s@(State { expr_env = eenv }) =+ s { expr_env = foldr addTicksToDeepSeqCases' eenv (map idName $ M.elems w)}++addTicksToDeepSeqCases' :: Name -> ExprEnv -> ExprEnv+addTicksToDeepSeqCases' n eenv =+ case E.lookup n eenv of+ Just e -> E.insert n (modify addTicksToDeepSeqCases'' e) eenv+ Nothing -> eenv++addTicksToDeepSeqCases'' :: Expr -> Expr+addTicksToDeepSeqCases'' (Case e i t (Alt am ae:as)) =+ Case e i t $ Alt am (Tick (NamedLoc existentialCaseName) ae):as+addTicksToDeepSeqCases'' e = e
src/G2/Liquid/Types.hs view
@@ -1,63 +1,113 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-} module G2.Liquid.Types ( LHOutput (..)- , Measures- , LHState (..)- , LHStateM (..)- , ExState (..)- , AnnotMap (..)- , consLHState- , deconsLHState- , measuresM- , assumptionsM- , annotsM- , runLHStateM- , evalLHStateM- , execLHStateM- , lookupMeasure- , lookupMeasureM- , insertMeasureM- , mapMeasuresM- , lookupAssumptionM- , insertAssumptionM- , mapAssumptionsM- , lookupAnnotM- , insertAnnotM- , mapAnnotsExpr- , andM- , orM- , notM- , iffM- , lhTCM- , lhOrdTCM- , lhEqM- , lhNeM- , lhLtM- , lhLeM- , lhGtM- , lhGeM- , lhLtE- , lhLeE- , lhGtE- , lhGeE+ , CounterExample (..)+ , HigherOrderFuncCall+ , Measures+ , LHState (..)+ , LHStateM (..)+ , NamingM (..)+ , ExState (..)+ , AnnotMap (..)+ , Abstracted (..)+ , AbstractedInfo (..)+ , Assumptions+ , Posts+ , TyVarBags+ , InstFuncs - , lhPlusM- , lhMinusM- , lhTimesM- , lhDivM- , lhNegateM- , lhModM- , lhFromIntegerM- , lhToIntegerM- , lhNumOrdM+ -- For compatibility with new LH versions+#if MIN_VERSION_liquidhaskell(0,8,10)+ , GhcInfo, GhcSrc, GhcSpec+ , pattern GI, giSpec, giSrc+ , pattern SP, gsSig, gsData, gsQual, gsVars, gsTerm+ , pattern Src, giTarget, giCbs, giDefVars+#endif - , lhAndE- , lhOrE- - , lhPPM ) where+ , tcValuesM + , mapAbstractedFCs+ , mapAbstractedInfoFCs+ , consLHState+ , deconsLHState+ , measuresM+ , lhKnownValuesM+ , lhRenamedTCM+ , assumptionsM+ , postsM+ , annotsM+ , tyVarBagsM+ , runLHStateM+ , evalLHStateM+ , execLHStateM+ , lookupMeasure+ , lookupMeasureM+ , insertMeasureM+ , mapMeasuresM+ , mapMeasuresWithKeyM+ , putMeasuresM+ , lookupAssumptionM+ , insertAssumptionM+ , mapAssumptionsM+ , lookupPostM+ , insertPostM+ , mapPostM+ , lookupAnnotM+ , insertAnnotM+ , mapAnnotsExpr+ , lookupRenamedTCDict+ , insertTyVarBags+ , lookupTyVarBags+ , setTyVarBags+ , getTyVarBags+ , insertInstFuncs+ , lookupInstFuncs+ , setInstFuncs+ , getInstFuncs++ , andM+ , orM+ , notM+ , iffM+ , lhTCM+ , lhOrdTCM+ , lhEqM+ , lhNeM+ , lhLtM+ , lhLeM+ , lhGtM+ , lhGeM+ , lhLtE+ , lhLeE+ , lhGtE+ , lhGeE++ , lhPlusM+ , lhMinusM+ , lhTimesM+ , lhDivM+ , lhNegateM+ , lhModM+ , lhFromIntegerM+ , lhToIntegerM++ , lhFromRationalM++ , lhToRatioFuncM+ + , lhNumTCM+ , lhNumOrdM++ , lhAndE+ , lhOrE+ + , lhPPM+ , lhOrdM ) where+ import Data.Coerce import qualified Data.HashMap.Lazy as HM import Data.List@@ -69,25 +119,180 @@ import qualified G2.Language.ExprEnv as E import qualified G2.Language.KnownValues as KV import G2.Language.Monad+import G2.Language.TypeClasses import G2.Liquid.TCValues -import Language.Haskell.Liquid.Types+#if MIN_VERSION_liquidhaskell(0,8,10)+import qualified Language.Haskell.Liquid.Types as LT (TargetInfo (..), TargetSrc (..), TargetSpec (..))+#else+import Language.Haskell.Liquid.Types (GhcInfo)+#endif+ import Language.Haskell.Liquid.Constraint.Types import Language.Fixpoint.Types.Constraints +import Data.Monoid ((<>))++-- LiquidHaskell renamed these types.+-- This preserves compatibility with the old version of LiquidHaskell, and the new versions of LiquidHaskell.+#if MIN_VERSION_liquidhaskell(0,8,10)+type GhcInfo = LT.TargetInfo+type GhcSrc = LT.TargetSrc+type GhcSpec= LT.TargetSpec++pattern GI{giSrc,giSpec} = LT.TargetInfo giSrc giSpec+++pattern Src+ { giIncDir+ , giTarget+ , giTargetMod+ , giCbs+ , gsTcs+ , gsCls+ , giDerVars+ , giImpVars+ , giDefVars+ , giUseVars+ , gsExports+ , gsFiTcs+ , gsFiDcs+ , gsPrimTcs+ , gsQualImps+ , gsAllImps+ , gsTyThings+ } = LT.TargetSrc giIncDir giTarget giTargetMod giCbs gsTcs gsCls giDerVars giImpVars+ giDefVars giUseVars gsExports gsFiTcs gsFiDcs gsPrimTcs gsQualImps+ gsAllImps gsTyThings+++++pattern SP + { gsSig+ , gsQual+ , gsData+ , gsName+ , gsVars+ , gsTerm+ , gsRefl+ , gsLaws+ , gsImps + , gsConfig + } = LT.TargetSpec gsSig gsQual gsData gsName gsVars gsTerm gsRefl gsLaws gsImps gsConfig ++#endif+ data LHOutput = LHOutput { ghcI :: GhcInfo , cgI :: CGInfo , solution :: FixSolution } +type HigherOrderFuncCall = L.FuncCall++data CounterExample = DirectCounter Abstracted+ [Abstracted]+ [HigherOrderFuncCall] -- ^ Symbolic higher order functions evaluated while creating the counterexample + | CallsCounter Abstracted -- ^ The caller, abstracted result+ Abstracted -- ^ The callee+ [Abstracted]+ [HigherOrderFuncCall] -- ^ Symbolic higher order functions evaluated while creating the counterexample+ deriving (Eq, Show, Read)+ type Measures = L.ExprEnv -type Assumptions = M.Map L.Name L.Expr+-- | Assumptions include:+-- (1) a list of `(LamUse, Id)` used to refer to the expression arguments in the assumption+-- (2) assumptions to wrap individual arguments (in particular, higher order arguments).+-- (3) an assumption regarding the whole expression,+type Assumptions = M.Map L.Name ([(L.LamUse, L.Id)], [Maybe L.Expr], L.Expr)+type Posts = M.Map L.Name L.Expr newtype AnnotMap = AM { unAnnotMap :: HM.HashMap L.Span [(Maybe T.Text, L.Expr)] } deriving (Eq, Show, Read) +-- Abstracted values+data Abstracted = Abstracted { abstract :: L.FuncCall+ , real :: L.FuncCall+ , hits_lib_err_in_real :: Bool+ , func_calls_in_real :: [L.FuncCall] }+ deriving (Eq, Show, Read)++data AbstractedInfo = AbstractedInfo { init_call :: Abstracted+ , abs_violated :: Maybe Abstracted+ , abs_calls :: [Abstracted]+ , ai_all_calls :: [L.FuncCall]++ , ai_higher_order_calls :: [L.FuncCall] }+ deriving (Eq, Show, Read)++mapAbstractedFCs :: (L.FuncCall -> L.FuncCall) -> Abstracted -> Abstracted+mapAbstractedFCs f (Abstracted { abstract = a+ , real = r+ , hits_lib_err_in_real = err+ , func_calls_in_real = fcr }) =+ Abstracted { abstract = f a+ , real = f r+ , hits_lib_err_in_real = err+ , func_calls_in_real = map f fcr}++mapAbstractedInfoFCs :: (L.FuncCall -> L.FuncCall) -> AbstractedInfo -> AbstractedInfo+mapAbstractedInfoFCs f (AbstractedInfo { init_call = ic, abs_violated = av, abs_calls = ac, ai_all_calls= allc, ai_higher_order_calls = a_higher}) =+ AbstractedInfo { init_call = mapAbstractedFCs f ic+ , abs_violated = fmap (mapAbstractedFCs f) av+ , abs_calls = map (mapAbstractedFCs f) ac+ , ai_all_calls = map f allc+ , ai_higher_order_calls = map f a_higher }++instance L.ASTContainer Abstracted L.Expr where+ containedASTs ab = L.containedASTs (abstract ab) ++ L.containedASTs (real ab)+ modifyContainedASTs f (Abstracted { abstract = a+ , real = r+ , hits_lib_err_in_real = err+ , func_calls_in_real = fcir }) =+ Abstracted { abstract = L.modifyContainedASTs f a+ , real = L.modifyContainedASTs f r+ , hits_lib_err_in_real = err+ , func_calls_in_real = L.modifyContainedASTs f fcir}++instance L.ASTContainer Abstracted L.Type where+ containedASTs ab = L.containedASTs (abstract ab) ++ L.containedASTs (real ab)+ modifyContainedASTs f (Abstracted { abstract = a+ , real = r+ , hits_lib_err_in_real = err+ , func_calls_in_real = fcir }) =+ Abstracted { abstract = L.modifyContainedASTs f a+ , real = L.modifyContainedASTs f r+ , hits_lib_err_in_real = err+ , func_calls_in_real = L.modifyContainedASTs f fcir }++instance L.Named Abstracted where+ names a = L.names (abstract a) <> L.names (real a) <> L.names (func_calls_in_real a)+ rename old new a = a { abstract = L.rename old new (abstract a)+ , real = L.rename old new (real a)+ , func_calls_in_real = L.rename old new (func_calls_in_real a) }+ renames hm a = a { abstract = L.renames hm (abstract a)+ , real = L.renames hm (real a)+ , func_calls_in_real = L.renames hm (func_calls_in_real a) }++instance L.Named AbstractedInfo where+ names a = L.names (init_call a) <> L.names (abs_violated a) <> L.names (abs_calls a) <> L.names (ai_all_calls a) <> L.names (ai_higher_order_calls a)+ rename old new a = AbstractedInfo { init_call = L.rename old new (init_call a)+ , abs_violated = L.rename old new (abs_violated a)+ , abs_calls = L.rename old new (abs_calls a)+ , ai_all_calls = L.rename old new (ai_all_calls a)+ , ai_higher_order_calls = L.rename old new (ai_higher_order_calls a) }+ renames hm a = AbstractedInfo { init_call = L.renames hm (init_call a)+ , abs_violated = L.renames hm (abs_violated a)+ , abs_calls = L.renames hm (abs_calls a)+ , ai_all_calls = L.renames hm (ai_all_calls a)+ , ai_higher_order_calls = L.renames hm (ai_higher_order_calls a) }++-- | See G2.Liquid.TyVarBags+type TyVarBags = M.Map L.Name [L.Id]+type InstFuncs = M.Map L.Name L.Id+ -- [LHState] -- measures is an extra expression environment, used to build Assertions. -- This distinction between functions for code, and functions for asserts is important because@@ -105,18 +310,28 @@ -- LiquidHaskell ASTs data LHState = LHState { state :: L.State [L.FuncCall] , measures :: Measures+ , lh_known_values :: KV.KnownValues+ , lh_tcs :: L.TypeClasses , tcvalues :: TCValues , assumptions :: Assumptions+ , posts :: Posts , annots :: AnnotMap+ , tyvar_bags :: TyVarBags+ , inst_funcs :: InstFuncs } deriving (Eq, Show, Read) -consLHState :: L.State [L.FuncCall] -> Measures -> TCValues -> LHState-consLHState s meas tcv =+consLHState :: L.State [L.FuncCall] -> Measures -> KV.KnownValues -> L.TypeClasses -> TCValues -> LHState+consLHState s meas kv tc tcv = LHState { state = s , measures = meas+ , lh_known_values = kv+ , lh_tcs = tc , tcvalues = tcv , assumptions = M.empty- , annots = AM HM.empty }+ , posts = M.empty+ , annots = AM HM.empty+ , tyvar_bags = M.empty+ , inst_funcs = M.empty } deconsLHState :: LHState -> L.State [L.FuncCall] deconsLHState (LHState { state = s@@ -128,31 +343,54 @@ (lh_s, _) <- SM.get return $ measures lh_s +lhKnownValuesM :: LHStateM KV.KnownValues+lhKnownValuesM = do+ (lh_s, _) <- SM.get+ return $ lh_known_values lh_s++lhRenamedTCM :: LHStateM L.TypeClasses+lhRenamedTCM = do+ (lh_s, _) <- SM.get+ return $ lh_tcs lh_s+ assumptionsM :: LHStateM Assumptions assumptionsM = do (lh_s, _) <- SM.get return $ assumptions lh_s +postsM :: LHStateM Posts+postsM = do+ (lh_s, _) <- SM.get+ return $ posts lh_s+ annotsM :: LHStateM AnnotMap annotsM = do (lh_s, _) <- SM.get return $ annots lh_s +tyVarBagsM :: LHStateM TyVarBags+tyVarBagsM = do+ (lh_s, _) <- SM.get+ return $ tyvar_bags lh_s++ newtype LHStateM a = LHStateM { unSM :: (SM.State (LHState, L.Bindings) a) } deriving (Applicative, Functor, Monad) instance SM.MonadState (LHState, L.Bindings) LHStateM where state f = LHStateM (SM.state f) -instance ExState (LHState, L.Bindings) LHStateM where+instance NamingM (LHState, L.Bindings) LHStateM where+ nameGen = readRecord $ L.name_gen . snd+ putNameGen = rep_name_genM++instance ExprEnvM (LHState, L.Bindings) LHStateM where exprEnv = readRecord $ expr_env . fst putExprEnv = rep_expr_envM +instance ExState (LHState, L.Bindings) LHStateM where typeEnv = readRecord $ type_env . fst putTypeEnv = rep_type_envM - nameGen = readRecord $ L.name_gen . snd- putNameGen = rep_name_genM- knownValues = readRecord $ known_values . fst putKnownValues = rep_known_valuesM @@ -166,6 +404,9 @@ inputNames = readRecord $ L.input_names . snd fixedInputs = readRecord $ L.fixed_inputs . snd + pathConds = readRecord $ path_conds . fst+ putPathConds = rep_path_condsM+ runLHStateM :: LHStateM a -> LHState -> L.Bindings -> (a, (LHState, L.Bindings)) runLHStateM (LHStateM s) lh_s b = SM.runState s (lh_s, b) @@ -235,6 +476,16 @@ let s' = s {L.type_classes = tc} SM.put $ (lh_s {state = s'}, b) +path_conds :: LHState -> L.PathConds+path_conds = liftState L.path_conds++rep_path_condsM :: L.PathConds -> LHStateM ()+rep_path_condsM ce = do+ (lh_s, b) <- SM.get+ let s = state lh_s+ let s' = s {L.path_conds = ce}+ SM.put $ (lh_s {state = s'}, b)+ liftLHState :: (LHState -> a) -> LHStateM a liftLHState f = do (lh_s, _) <- SM.get@@ -259,10 +510,21 @@ meas' <- E.mapM f meas SM.put $ (s { measures = meas' }, b) -lookupAssumptionM :: L.Name -> LHStateM (Maybe L.Expr)+mapMeasuresWithKeyM :: (L.Name -> L.Expr -> LHStateM L.Expr) -> LHStateM ()+mapMeasuresWithKeyM f = do+ (s@(LHState { measures = meas }), b) <- SM.get+ meas' <- E.mapWithKeyM f meas+ SM.put $ (s { measures = meas' }, b)++putMeasuresM :: Measures -> LHStateM ()+putMeasuresM meas = do+ (s, b) <- SM.get+ SM.put $ (s { measures = meas }, b)++lookupAssumptionM :: L.Name -> LHStateM (Maybe ([(L.LamUse, L.Id)], [Maybe L.Expr], L.Expr)) lookupAssumptionM n = liftLHState (M.lookup n . assumptions) -insertAssumptionM :: L.Name -> L.Expr -> LHStateM ()+insertAssumptionM :: L.Name -> ([(L.LamUse, L.Id)], [Maybe L.Expr], L.Expr) -> LHStateM () insertAssumptionM n e = do (lh_s, b) <- SM.get let assumpt = assumptions lh_s@@ -272,9 +534,25 @@ mapAssumptionsM :: (L.Expr -> LHStateM L.Expr) -> LHStateM () mapAssumptionsM f = do (s@(LHState { assumptions = assumpt }), b) <- SM.get- assumpt' <- mapM f assumpt+ assumpt' <- mapM (modifyContainedASTsM f) assumpt SM.put $ (s { assumptions = assumpt' },b) +lookupPostM :: L.Name -> LHStateM (Maybe L.Expr)+lookupPostM n = liftLHState (M.lookup n . posts)++insertPostM :: L.Name -> L.Expr -> LHStateM ()+insertPostM n e = do+ (lh_s, b) <- SM.get+ let pst = posts lh_s+ let pst' = M.insert n e pst+ SM.put $ (lh_s {posts = pst'}, b)++mapPostM :: (L.Expr -> LHStateM L.Expr) -> LHStateM ()+mapPostM f = do+ (s@(LHState { posts = pst }), b) <- SM.get+ pst' <- mapM f pst+ SM.put $ (s { posts = pst' },b)+ insertAnnotM :: L.Span -> Maybe T.Text -> L.Expr -> LHStateM () insertAnnotM spn t e = do (s@(LHState { annots = an }),b) <- SM.get@@ -297,34 +575,84 @@ annots' <- modifyContainedASTsM f (annots lh_s) SM.put $ (lh_s {annots = annots'}, b) +lookupRenamedTCDict :: L.Name -> L.Type -> LHStateM (Maybe L.Id)+lookupRenamedTCDict n t = do+ tc <- lhRenamedTCM+ return $ lookupTCDict tc n t++insertTyVarBags :: L.Name -> [L.Id] -> LHStateM ()+insertTyVarBags n is = do+ (lh_s, b) <- SM.get+ let tyvar_bags' = M.insert n is (tyvar_bags lh_s)+ SM.put $ (lh_s {tyvar_bags = tyvar_bags'}, b)++lookupTyVarBags :: L.Name -> LHStateM (Maybe [L.Id])+lookupTyVarBags n = do+ (lh_s, _) <- SM.get+ return $ M.lookup n (tyvar_bags lh_s)++setTyVarBags :: TyVarBags -> LHStateM ()+setTyVarBags m = do+ (lh_s, b) <- SM.get+ SM.put (lh_s {tyvar_bags = m}, b)++getTyVarBags :: LHStateM TyVarBags+getTyVarBags = return . tyvar_bags . fst =<< SM.get++insertInstFuncs :: L.Name -> L.Id -> LHStateM ()+insertInstFuncs n i = do+ (lh_s, b) <- SM.get+ let inst_funcs' = M.insert n i (inst_funcs lh_s)+ SM.put $ (lh_s {inst_funcs = inst_funcs'}, b)++lookupInstFuncs :: L.Name -> LHStateM (Maybe L.Id)+lookupInstFuncs n = do+ (lh_s, _) <- SM.get+ return $ M.lookup n (inst_funcs lh_s)++setInstFuncs :: M.Map L.Name L.Id -> LHStateM ()+setInstFuncs m = do+ (lh_s, b) <- SM.get+ SM.put (lh_s {inst_funcs = m}, b)++getInstFuncs :: LHStateM InstFuncs+getInstFuncs = return . inst_funcs . fst =<< SM.get+ -- | andM -- The version of 'and' in the measures andM :: LHStateM L.Expr andM = do m <- measuresM- return (L.mkAnd m)+ n <- lhAndM+ return (m E.! n) -- | orM -- The version of 'or' in the measures orM :: LHStateM L.Expr orM = do m <- measuresM- return (L.mkOr m)+ n <- lhOrM+ return (m E.! n) -- | notM -- The version of 'not' in the measures notM :: LHStateM L.Expr notM = do m <- measuresM- return (L.mkNot m)+ n <- lhNotM+ return (m E.! n) -- | iffM -- The version of 'iff' in the measures iffM :: LHStateM L.Expr iffM = do m <- measuresM- return (L.mkIff m)+ n <- lhIffM+ return (m E.! n) +tcValuesM :: LHStateM TCValues+tcValuesM = liftTCValues id+ liftTCValues :: (TCValues -> a) -> LHStateM a liftTCValues f = do (lh_s, _) <- SM.get@@ -357,20 +685,28 @@ lhGeM :: LHStateM L.Name lhGeM = liftTCValues lhGe +lhAndM :: LHStateM L.Name+lhAndM = liftTCValues lhAnd++lhOrM :: LHStateM L.Name+lhOrM = liftTCValues lhOr++lhNotM :: LHStateM L.Name+lhNotM = liftTCValues lhNot++lhIffM :: LHStateM L.Name+lhIffM = liftTCValues lhIff+ binT :: LHStateM L.Type binT = do a <- freshIdN L.TYPE let tva = L.TyVar a- ord <- lhOrdTCM lh <- lhTCM bool <- tyBoolT - let ord' = L.TyCon ord L.TYPE- let lh' = L.TyCon lh L.TYPE+ let lh' = L.TyCon lh (L.TyFun L.TYPE L.TYPE) - return $ L.TyForAll (L.NamedTyBndr a) - (L.TyFun- ord'+ return $ L.TyForAll a (L.TyFun lh' (L.TyFun@@ -381,7 +717,6 @@ ) ) )- ) lhLtE :: LHStateM L.Id lhLtE = do@@ -435,7 +770,7 @@ let num' = L.TyCon num L.TYPE - return $ L.TyForAll (L.NamedTyBndr a) + return $ L.TyForAll a (L.TyFun num' (L.TyFun@@ -444,6 +779,30 @@ ) ) +lhToRatioFuncM :: LHStateM L.Id+lhToRatioFuncM = do+ n <- liftTCValues lhToRatioFunc+ return . L.Id n =<< ratioFuncT ++ratioFuncT :: LHStateM L.Type+ratioFuncT = do+ a <- freshIdN L.TYPE+ let tva = L.TyVar a+ integral <- return . KV.integralTC =<< knownValues++ let integral' = L.TyCon integral L.TYPE++ return $ L.TyForAll a+ (L.TyFun+ integral'+ (L.TyFun+ tva+ (L.TyFun+ tva+ L.TyUnknown)+ )+ )+ lhToIntegerM :: LHStateM L.Id lhToIntegerM = do n <- liftTCValues lhToInteger@@ -458,7 +817,7 @@ let integral' = L.TyCon integral L.TYPE - return $ L.TyForAll (L.NamedTyBndr a) + return $ L.TyForAll a (L.TyFun integral' (L.TyFun@@ -466,6 +825,31 @@ integerT ) )+++lhFromRationalM :: LHStateM L.Id+lhFromRationalM = do+ n <- liftTCValues lhFromRational+ return . L.Id n =<< fractionalT++fractionalT :: LHStateM L.Type+fractionalT = do+ a <- freshIdN L.TYPE+ let tva = L.TyVar a+ fractional <- return . KV.fractionalTC =<< knownValues+ rationalT <- tyRationalT++ let fractional' = L.TyCon fractional L.TYPE++ return $ L.TyForAll a+ (L.TyFun+ fractional'+ (L.TyFun+ rationalT+ tva+ )+ )+ lhNumOrdM :: LHStateM L.Id lhNumOrdM = do num <- lhNumTCM@@ -479,6 +863,9 @@ lhPPM :: LHStateM L.Name lhPPM = liftTCValues lhPP++lhOrdM :: LHStateM L.Name+lhOrdM = liftTCValues lhOrd lhAndE :: LHStateM L.Expr lhAndE = do
+ src/G2/Nebula.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE CPP, FlexibleContexts #-}++module G2.Nebula (plugin) where++#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+import GHC.Plugins+#else+import GhcPlugins+#endif++import G2.Config+import G2.Equiv.Config+import G2.Equiv.Verifier+import qualified G2.Initialization.Types as IT+import G2.Interface+import G2.Language as L+import qualified G2.Language.ExprEnv as E+import qualified G2.Solver as S+import G2.Translation++import Data.IORef+import System.IO.Unsafe+import Data.List+import qualified Data.Text as T+import Options.Applicative++-- | During symbolic execution, we need to know definitions, types, etc.+-- from previously compiled modules. We also need to avoid reusing the same+-- names. We use `compiledModules` to store both previously compiled modules+-- and existing Expression/Type Name maps.+compiledModules :: IORef (Maybe (ExtractedG2, NameMap, TypeNameMap))+compiledModules = unsafePerformIO $ newIORef Nothing+{-# NOINLINE compiledModules #-}++plugin :: Plugin+plugin = defaultPlugin { installCoreToDos = install }++install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+install cmd_lne todo = do+ env <- getHscEnv+ let pr_nebula_config = getNebulaConfigPlugin cmd_lne+ (entry, nebula_config) <- liftIO $ handleParseResult pr_nebula_config+ return $ CoreDoPluginPass "Nebula" (nebulaPluginPass entry nebula_config env):todo++nebulaPluginPass :: Maybe String -> NebulaConfig -> HscEnv -> ModGuts -> CoreM ModGuts+nebulaPluginPass m_entry nebula_config env modguts = do+ _ <- liftIO $ nebulaPluginPass' m_entry nebula_config env modguts+ return modguts++nebulaPluginPass' :: Maybe String -> NebulaConfig -> HscEnv -> ModGuts -> IO ()+nebulaPluginPass' m_entry nebula_config env modguts = do+ config <- getConfigDirect+ -- We want simpl to be False so the simplifier does not run, because+ -- this plugin get's inserted into the simplifier. Thus, running the implifier+ -- results in an infinite loop.+ let tconfig = (simplTranslationConfig {simpl = False, load_rewrite_rules = True, hpc_ticks = False})+ ems = EnvModSumModGuts env [] [modguts]++ prev_comp <- readIORef compiledModules+ (prev_exg2, prev_nm, prev_tnm) <- case prev_comp of+ Just prev -> return prev+ Nothing -> translateBase tconfig config [] Nothing++ (new_nm, new_tm, exg2) <- hskToG2ViaEMS tconfig ems prev_nm prev_tnm++ let merged_exg2 = mergeExtractedG2s [exg2, prev_exg2]+ injected_exg2 = specialInject merged_exg2+ writeIORef compiledModules $ Just (merged_exg2, new_nm, new_tm)++ let simp_state = initSimpleState injected_exg2++ (init_state, bindings) = initStateFromSimpleState simp_state Nothing False+ (\_ ng _ _ _ _ _ -> (Prim Undefined TyBottom, [], [], ng))+ (E.higherOrderExprs . IT.expr_env)+ config+ + let total = []+ case m_entry of+ Just entry -> do+ let tentry = T.pack entry+ let rule = find (\r -> tentry == L.ru_name r) (rewrite_rules bindings)+ rule' = case rule of+ Just r -> r+ Nothing -> error "not found"+ _ <- checkRulePrinting config nebula_config init_state bindings total rule'+ return ()+ Nothing -> do+ let mod_name = T.pack . moduleNameString . moduleName . mg_module $ modguts+ mapM_ (checkRulePrinting config nebula_config init_state bindings total)+ $ filter (\r -> L.ru_module r == mod_name) (rewrite_rules bindings)++checkRulePrinting :: (ASTContainer t L.Type, ASTContainer t L.Expr) => Config+ -> NebulaConfig+ -> State t+ -> Bindings+ -> [T.Text] -- ^ names of forall'd variables required to be total+ -> RewriteRule+ -> IO (S.Result () () ())+checkRulePrinting config nebula_config init_state bindings total rule = do+ let rule_name = T.unpack $ L.ru_name rule+ nebula_config' = case log_rule nebula_config of+ Just n -> if n == rule_name then nebula_config+ else nebula_config {log_states = NoLog}+ Nothing -> nebula_config+ putStrLn $ "Log-rule nebula config = " ++ show (log_rule nebula_config)+ putStrLn $ "Checking " ++ rule_name+ res <- checkRule config nebula_config' init_state bindings total rule + case res of+ S.SAT _ -> putStrLn $ rule_name ++ " - counterexample found"+ S.UNSAT _ -> putStrLn $ rule_name ++ " - verified"+ S.Unknown _ _ -> putStrLn $ rule_name ++ " - unknown result"+ return res+
src/G2/Postprocessing/Interface.hs view
@@ -5,6 +5,6 @@ import G2.Language import G2.Postprocessing.NameSwitcher -runPostprocessing :: (ASTContainer m Expr, Named m) => Bindings -> m -> m+runPostprocessing :: Named m => Bindings -> m -> m runPostprocessing b = switchNames b
src/G2/Preprocessing/AdjustTypes.hs view
@@ -36,14 +36,14 @@ -- ) -- We remove $unpackCString, and convert the LitString to a list unpackString :: ASTContainer t Expr => State t -> State t-unpackString s@(State {type_env = tenv, known_values = kv}) = modifyASTsFix (unpackString' tenv kv) s+unpackString s@(State {type_env = tenv, known_values = kv}) = modifyASTs (unpackString' tenv kv) s unpackString' :: TypeEnv -> KnownValues -> Expr -> Expr-unpackString' _ _ (App (Var (Id (Name "unpackCString#" _ _ _) _)) e) = e+unpackString' tenv kv (App (Var (Id (Name "unpackCString#" _ _ _) _)) e) = unpackString' tenv kv e unpackString' tenv kv (Lit (LitString s)) = let- cns = mkCons kv tenv- em = mkEmpty kv tenv+ cns = App (mkCons kv tenv) (Type (tyChar kv))+ em = App (mkEmpty kv tenv) (Type (tyChar kv)) char = mkDCChar kv tenv in
src/G2/Preprocessing/NameCleaner.hs view
@@ -14,8 +14,10 @@ , cleanNamesFromList , allowedStartSymbols , allowedSymbol+ , cleanName ) where +import Data.Foldable import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as S import qualified Data.Text as T@@ -51,7 +53,7 @@ cleanNames :: (ASTContainer t Expr, ASTContainer t Type, Named t) => State t -> CleanedNames -> NameGen -> (State t, CleanedNames, NameGen) cleanNames s cl_names ng = (renames hns s, cl_names', ng') where- (ns, ng') = createNamePairs ng . filter (not . allowedName) $ allNames s+ (ns, ng') = createNamePairs ng . filter (not . allowedName) . map idName . E.symbolicIds $ expr_env s -- ++ altIds s hns = HM.fromList ns cl_names' = foldr (\(old, new) -> HM.insert new old) cl_names (HM.toList hns) @@ -59,13 +61,13 @@ cleanNames' :: Named n => NameGen -> n -> (n, NameGen) cleanNames' ng n = (renames hns n, ng') where- (ns, ng') = createNamePairs ng . filter (not . allowedName) $ names n+ (ns, ng') = createNamePairs ng . filter (not . allowedName) . toList $ names n hns = HM.fromList ns cleanNamesFromList :: Named n => NameGen -> [Name] -> n -> (n, NameGen) cleanNamesFromList ng ns n = (renames hns n, ng') where- (ns', ng') = createNamePairs ng . filter (not . allowedName) $ names ns+ (ns', ng') = createNamePairs ng . filter (not . allowedName) . toList $ names ns hns = HM.fromList ns' createNamePairs :: NameGen -> [Name] -> ([(Name, Name)], NameGen)@@ -73,18 +75,23 @@ where go :: NameGen -> [(Name, Name)] -> [Name] -> ([(Name, Name)], NameGen) go ng rns [] = (rns, ng)- go ng rns (name@(Name n m i l):ns) =+ go ng rns (name:ns) = let- n' = T.filter (\x -> x `S.member` allowedSymbol) n- m' = fmap (T.filter $ \x -> x `S.member` allowedSymbol) m-- -- No reserved symbols start with a $, so this ensures both uniqueness- -- and starting with an allowed symbol- n'' = "$" `T.append` n'-- (new_name, ng') = freshSeededName (Name n'' m' i l) ng+ name' = cleanName name+ (new_name, ng') = freshSeededName name' ng in go ng' ((name, new_name):rns) ns -allNames :: (ASTContainer t Expr, ASTContainer t Type, Named t) => State t -> [Name]-allNames s = exprNames s ++ E.keys (expr_env s)+cleanName :: Name -> Name+cleanName nm@(Name n m i l)+ | allowedName nm = nm+ | otherwise = + let+ n' = T.filter (\x -> x `S.member` allowedSymbol) n+ m' = fmap (T.filter $ \x -> x `S.member` allowedSymbol) m++ -- No reserved symbols start with a $, so this ensures both uniqueness+ -- and starting with an allowed symbol+ n'' = "$" `T.append` n'+ in+ Name n'' m' i l
src/G2/QuasiQuotes/FloodConsts.hs view
@@ -16,7 +16,8 @@ floodConstantsChecking ne s = case floodConstants ne s of Just s' ->- if all (pathCondMaybeSatisfiable (known_values s')) (PC.toList $ path_conds s')+ if all (pathCondMaybeSatisfiable (type_env s') (known_values s'))+ (PC.toList $ path_conds s') then Just s' else Nothing Nothing -> Nothing@@ -57,16 +58,14 @@ -- Attempts to determine if a PathCond is satisfiable. A return value of False -- means the PathCond is definitely unsatisfiable. A return value of True means -- the PathCond may or may not be satisfiable. -pathCondMaybeSatisfiable :: KnownValues -> PathCond -> Bool-pathCondMaybeSatisfiable _ (AltCond l1 (Lit l2) b) = (l1 == l2) == b-pathCondMaybeSatisfiable _ (AltCond _ _ _) = True-pathCondMaybeSatisfiable kv (ExtCond e b) =+pathCondMaybeSatisfiable :: TypeEnv -> KnownValues -> PathCond -> Bool+pathCondMaybeSatisfiable _ _ (AltCond l1 (Lit l2) b) = (l1 == l2) == b+pathCondMaybeSatisfiable _ _ (AltCond _ _ _) = True+pathCondMaybeSatisfiable tenv kv (ExtCond e b) = let- r = evalPrims kv e+ r = evalPrims tenv kv e tr = mkBool kv True fal = mkBool kv False in if (r == tr && not b) || (r == fal && b) then False else True-pathCondMaybeSatisfiable _ (ConsCond dc1 (Data dc2) b) = (dc1 == dc2) == b-pathCondMaybeSatisfiable _ (PCExists _) = True
src/G2/QuasiQuotes/G2Rep.hs view
@@ -1,4 +1,3 @@--- Hides the warnings about deriving {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}
src/G2/QuasiQuotes/Internals/G2Rep.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}@@ -53,23 +54,43 @@ , genG2UnRep (length tvs) cs , genG2Type tyConName]] where+#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+ apply t (PlainTV name _) = appT t (varT name)+ apply t (KindedTV name _ _) = appT t (varT name)++ mkCxt (PlainTV name _) = conT ''G2Rep `appT` varT name+ mkCxt (KindedTV name _ _) = conT ''G2Rep `appT` varT name+#else apply t (PlainTV name) = appT t (varT name) apply t (KindedTV name _) = appT t (varT name) mkCxt (PlainTV name) = conT ''G2Rep `appT` varT name mkCxt (KindedTV name _) = conT ''G2Rep `appT` varT name+#endif +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+genG2Rep :: TH.Name -> [TyVarBndr ()] -> [Con] -> Q Dec+#else genG2Rep :: TH.Name -> [TyVarBndr] -> [Con] -> Q Dec+#endif genG2Rep tyConName tvs cs = funD 'g2Rep (map (genG2RepClause tyConName tvs) cs) +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+genG2RepClause :: TH.Name -> [TyVarBndr ()] -> Con -> Q Clause+#else genG2RepClause :: TH.Name -> [TyVarBndr] -> Con -> Q Clause+#endif genG2RepClause tyConName tvs (NormalC name fieldTypes) = genG2RepClause' tyConName tvs name fieldTypes genG2RepClause tyConName tvs (InfixC st1 n st2) = genG2RepClause' tyConName tvs n [st1, st2] genG2RepClause _ _ con = error $ "genG2RepClause: Unhandled case." ++ show con +#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+genG2RepClause' :: TH.Name -> [TyVarBndr ()] -> TH.Name -> [StrictType] -> Q Clause+#else genG2RepClause' :: TH.Name -> [TyVarBndr] -> TH.Name -> [StrictType] -> Q Clause+#endif genG2RepClause' tyConName tvs dcNme fieldTypes = do tenv <- newName "tenv_rep" cleaned <- newName "cleaned"@@ -85,7 +106,8 @@ `appE` litE (integerL $ toInteger $ length fieldTypes) `appE` qqNameToQExp qqTyConName `appE` qqNameToQExp qqName- `appE` (varE 'qqMap `appE` varE cleaned `appE` varE tenv)+ `appE` (varE 'qqMap `appE` varE cleaned `appE` [|HM.keys $(varE tenv)|])+ `appE` (varE 'qqMap `appE` varE cleaned `appE` [|map dcName . concatMap dataCon . HM.elems $ $(varE tenv)|]) `appE` varE tenv) tys = map (\tyv -> conE 'Type@@ -100,8 +122,13 @@ clause pats body [] where+#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+ tyVBToType (PlainTV name _) = varT name+ tyVBToType (KindedTV name _ _) = varT name+#else tyVBToType (PlainTV name) = varT name tyVBToType (KindedTV name _) = varT name+#endif -- | Looks up a `DataCon` with the given type and data constructor name. -- Falls back to creating a data constructor from scratch, if the data constructor@@ -110,17 +137,16 @@ -- available when the QuasiQuoter is compiled qqDataConLookupFallBack :: Int -- The number of TyVars -> Int -- The number of arguments- -> QQName -> QQName -> QQMap -> TypeEnv -> DataCon-qqDataConLookupFallBack tyv_n arg_n qqtn qqdc qqm tenv- | Just dc <- qqDataConLookup qqtn qqdc qqm tenv = dc+ -> QQName -> QQName -> QQMap -> QQMap -> TypeEnv -> DataCon+qqDataConLookupFallBack tyv_n arg_n qqtn qqdc type_nm_qqm dc_nm_qqm tenv+ | Just dc <- qqDataConLookup qqtn qqdc type_nm_qqm dc_nm_qqm tenv = dc | otherwise = let n = G2.Name "unknown" Nothing 0 Nothing i = Id n TYPE - ntb = NamedTyBndr i t = mkTyFun $ replicate (arg_n + 1) (TyCon n TYPE)- t' = foldr TyForAll t (replicate tyv_n ntb)+ t' = foldr TyForAll t (replicate tyv_n i) in DataCon (qqNameToName0 qqdc) t' @@ -165,9 +191,9 @@ let guardRet = return (guardPat, ret) clause pats (guardedB [guardRet]) []- fnt -> do+ fnt@(fnt_h:_) -> do tenv <- newName "tenv_unrep"- let pats = varP tenv:[varP expr]+ let pats = if usesTEnvUnRep (snd fnt_h) then varP tenv:[varP expr] else wildP:[varP expr] ret <- appsE $ conE dcNme:map (newFieldUnRep tenv) fnt let guardRet = return (guardPat, ret)@@ -179,7 +205,7 @@ expr <- newName "expr" let pats = [wildP, varP expr] - clause pats (normalB [|error $ "Unhandled case in g2UnRep" ++ show $(varE expr) |]) []+ clause pats (normalB [|error $ "Unhandled case in g2UnRep " ++ show $(varE expr) |]) [] newFieldUnRep :: TH.Name -> (TH.Name, StrictType) -> Q Exp newFieldUnRep _ (x, (_, ConT n))@@ -193,6 +219,12 @@ newFieldUnRep tenv (x, _) = do varE 'g2UnRep `appE` varE tenv `appE` varE x +usesTEnvUnRep :: StrictType -> Bool+usesTEnvUnRep (_, ConT n) =+ let nb = nameBase n in+ not (nb == "Int#" || nb == "Float#" || nb == "Double#" || nb == "Char#")+usesTEnvUnRep _ = True+ genG2Type :: TH.Name -> Q Dec genG2Type tyConName = funD 'g2Type [genG2TypeClause tyConName] @@ -232,7 +264,7 @@ intPrimFromLit (Lit (LitInt x)) = case fromInteger x of I# x' -> x'-intPrimFromLit _ = error "intPrimFromLit: Unhandled Expr"+intPrimFromLit e = error $ "intPrimFromLit: Unhandled Expr" ++ show e floatPrimFromLit :: G2.Expr -> Float# floatPrimFromLit (Lit (LitFloat x)) =
src/G2/QuasiQuotes/Parser.hs view
@@ -36,7 +36,7 @@ symbVarRegex = mkRegex $ "[?][(]" ++ paddedIdRs ++ "::[^!?|]*" lamDividerRegex :: Regex-lamDividerRegex = mkRegex $ "->" ++ whiteSpaceRs ++ "[?]"+lamDividerRegex = mkRegex $ "->" ++ whiteSpaceRs ++ "*" ++ "[?]" dividerRegex :: Regex dividerRegex = mkRegex $ "[" ++ bar ++ "]"
src/G2/QuasiQuotes/QuasiQuotes.hs view
@@ -11,9 +11,11 @@ import G2.Execution.Interface import G2.Execution.Memory import G2.Execution.Reducer+import G2.Execution.Rules import G2.Initialization.MkCurrExpr import G2.Interface import G2.Language as G2+import qualified G2.Language.PathConds as PC import qualified G2.Language.Typing as Ty import G2.Solver import G2.Translation.Cabal.Cabal@@ -26,11 +28,15 @@ import G2.QuasiQuotes.Parser import qualified Control.Concurrent.Lock as Lock+import Control.Monad.IO.Class import Data.Data+import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HM import Data.List import qualified Data.Map as M import Data.Maybe+import qualified Data.Sequence as Seq import Data.IORef import qualified Data.Text as T @@ -54,6 +60,7 @@ -- aquired/released by each quasiquoter's compilation oneByOne :: IORef Lock.Lock oneByOne = unsafePerformIO $ newIORef =<< Lock.new+{-# NOINLINE oneByOne #-} acquireIORefLock :: IO () acquireIORefLock = do@@ -82,8 +89,8 @@ -- Get names for the lambdas for the regular inputs exG2 <- parseHaskellQ' qext config <- runIO qqConfig- let (init_s, _, init_b) = initState' exG2 (T.pack functionName) (Just $ T.pack moduleName)- (mkCurrExpr Nothing Nothing) config+ let (init_s, init_b) = initStateWithCall' exG2 (T.pack functionName) (Just $ T.pack moduleName)+ (mkCurrExpr Nothing Nothing) (mkArgTys) config runIO $ releaseIORefLock @@ -98,7 +105,7 @@ Completed xs b -> do case elimUnusedCompleted xs b of (xs'@(s:_), b') -> do- let xs'' = listE $ map (moveOutTypeEnvState tenv_name) xs'+ let xs'' = listE $ map (moveOutStatePieces tenv_name) xs' xs''' = addCompRegVarPasses (varE state_name) tenv_name cleaned_names_name ns (inputIds s b') b' @@ -118,13 +125,13 @@ in return (foldr (\n -> lamE [n]) [| return (Nothing :: Maybe $(tup_t)) |] ns_pat , [| return [] :: IO [State ()] |]- , M.empty+ , HM.empty , b') NonCompleted s b -> do let (s', b') = elimUnusedNonCompleted s b - s'' = moveOutTypeEnvState tenv_name s'+ s'' = moveOutStatePieces tenv_name s' s''' = addedNonCompRegVarBinds (varE state_name) tenv_name cleaned_names_name ns (inputIds s' b') b' @@ -140,7 +147,7 @@ let tenv_exp = liftDataT tenv `sigE` [t| TypeEnv |]- bindings_exp = liftDataT (bindings_final { name_gen = mkNameGen ()})+ bindings_exp = liftDataT bindings_final letE [ valD (varP state_name) (normalB state_exp) [] , valD (varP tenv_name) (normalB tenv_exp) []@@ -150,10 +157,15 @@ liftDataT :: Data a => a -> Q Exp liftDataT = dataToExpQ (\a -> case liftText <$> cast a of je@(Just _) -> je- Nothing -> liftLoc <$> cast a)+ Nothing -> case liftLoc <$> cast a of+ jl@(Just _) -> jl+ Nothing -> liftMaybeSpan <$> cast a) where liftText txt = appE (varE 'T.pack) (stringE (T.unpack txt)) liftLoc (G2.Loc l c f) = conE 'G2.Loc `appE` intE l `appE` intE c `appE` stringE f+ + liftMaybeSpan :: Maybe Span -> Q Exp+ liftMaybeSpan _ = conE 'Nothing intE i = [| i |] parseHaskellQ' :: QuotedExtract-> Q ExtractedG2@@ -189,8 +201,8 @@ projs <- cabalSrcDirs cabal' config <- qqConfig - translateLoaded projs [filepath] []- simplTranslationConfig+ translateLoaded projs [filepath]+ (simplTranslationConfig { interpreter = True }) config) return exG2 where@@ -220,11 +232,12 @@ runIO $ do let (s', b') = addAssume s b - SomeSolver con <- initSolverInfinite config- case qqRedHaltOrd con of+ SomeSolver solver <- initSolverInfinite config+ let simplifier = IdSimplifier+ case qqRedHaltOrd config solver simplifier of (SomeReducer red, SomeHalter hal, SomeOrderer ord) -> do- let (s'', b'') = runG2Pre [] s' b'- hal' = hal :<~> ZeroHalter 2000 :<~> LemmingsHalter+ let (s'', b'') = runG2Pre emptyMemConfig s' b'+ hal' = hal <~> zeroHalter 2000 <~> lemmingsHalter (xs, b''') <- runExecutionToProcessed red hal' ord s'' b'' case xs of@@ -239,14 +252,15 @@ _ = False -- | As soon as one States has been discarded, discard all States-data LemmingsHalter = LemmingsHalter--instance Halter LemmingsHalter () t where- initHalt _ _ = ()- updatePerStateHalt _ _ _ _ = ()- discardOnStart _ _ pr _ = not . null . discarded $ pr- stopRed _ _ _ _ = Continue- stepHalter _ _ _ _ _ = ()+lemmingsHalter :: Monad m => Halter m () t+lemmingsHalter =+ (mkSimpleHalter+ (const ())+ (\_ _ _ -> ())+ (\_ _ _ -> return Continue)+ (\_ _ _ _ -> ())) { discardOnStart = discard }+ where+ discard _ pr _ = not . null . discarded $ pr fileName :: String fileName = "THTemp.hs"@@ -257,19 +271,18 @@ functionName :: String functionName = "g2Expr" -qqRedHaltOrd :: Solver conv => conv -> (SomeReducer (), SomeHalter (), SomeOrderer ())-qqRedHaltOrd conv =+qqRedHaltOrd :: (MonadIO m, Solver solver, Simplifier simplifier) => Config -> solver -> simplifier -> (SomeReducer m (), SomeHalter m (), SomeOrderer m ())+qqRedHaltOrd config solver simplifier = let- tr_ng = mkNameGen ()+ share = sharing config+ state_name = G2.Name "state" Nothing 0 Nothing in- ( SomeReducer- (NonRedPCRed :<~| TaggerRed state_name tr_ng)- <~| (SomeReducer (StdRed conv))+ ( taggerRed state_name :== Finished .--> nonRedPCRed :== Finished --> stdRed share retReplaceSymbFuncVar solver simplifier , SomeHalter- (DiscardIfAcceptedTag state_name - :<~> AcceptHalter)- , SomeOrderer NextOrderer)+ (discardIfAcceptedTagHalter state_name + <~> acceptIfViolatedHalter)+ , SomeOrderer nextOrderer) addAssume :: State t -> Bindings -> (State t, Bindings) addAssume s@(State { curr_expr = CurrExpr er e }) b@(Bindings { name_gen = ng }) =@@ -283,13 +296,45 @@ type CleanedNamesName = TH.Name -- We have the TypeEnv separately from the state, and it is a waste to lift it to TH twice.--- This avoids having to do that-moveOutTypeEnvState :: Data t => TypeEnvName -> State t -> Q Exp-moveOutTypeEnvState tenv_name s = do- let s' = s { type_env = M.empty }- s_exp = liftDataT s'- [| $(s_exp) { type_env = $(varE tenv_name) } |]+-- Further, we cannot directly apply Data to the PathConds, since they use and IORef+moveOutStatePieces :: Data t => TypeEnvName -> State t -> Q Exp+moveOutStatePieces tenv_name s = do+ let -- s' = s { type_env = M.empty, path_conds = undefined }+ -- s_exp = liftDataT s' + expr_env_exp = liftDataT (expr_env s)+ curr_expr_exp = liftDataT (curr_expr s)+ non_red_path_conds_exp = liftDataT (non_red_path_conds s)+ true_assert_exp = liftDataT (true_assert s)+ assert_ids_exp = liftDataT (assert_ids s)+ type_classes_exp = liftDataT (type_classes s)+ exec_stack_exp = liftDataT (exec_stack s)+ model_exp = liftDataT (model s)+ known_values_exp = liftDataT (known_values s)+ rules_exp = liftDataT (rules s)+ num_steps_exp = liftDataT (num_steps s)+ tags_exp = liftDataT (tags s)+ track_exp = liftDataT (track s)++ pc_exp = liftDataT . PC.toList $ path_conds s++ [| State { expr_env = $(expr_env_exp)+ , type_env = $(varE tenv_name)+ , curr_expr = $(curr_expr_exp)+ , path_conds = PC.fromList $(pc_exp)+ , non_red_path_conds = $(non_red_path_conds_exp)+ , true_assert = $(true_assert_exp) + , assert_ids = $(assert_ids_exp)+ , type_classes = $(type_classes_exp)+ , exec_stack = $(exec_stack_exp)+ , model = $(model_exp)+ , known_values = $(known_values_exp)+ , rules = $(rules_exp)+ , num_steps = $(num_steps_exp)+ , tags = $(tags_exp) + , sym_gens = Seq.empty+ , track = $(track_exp) } |]+ -- Returns an Q Exp represeting a [(Name, Expr)] list regVarBindings :: [TH.Name] -> TypeEnvName -> CleanedNamesName -> InputIds -> Bindings -> Q Exp regVarBindings ns tenv_name cleaned_name is (Bindings { input_names = ins, cleaned_names = cleaned }) = do@@ -331,7 +376,7 @@ elimUnusedCompleted xs b = let b' = b { deepseq_walkers = M.empty- , higher_order_inst = [] }+ , higher_order_inst = HS.empty } xs' = map (\s -> s { type_classes = initTypeClasses [] , rules = [] }) xs@@ -343,7 +388,7 @@ elimUnusedNonCompleted s b = let b' = b { deepseq_walkers = M.empty- , higher_order_inst = [] }+ , higher_order_inst = HS.empty } s' = s { type_classes = initTypeClasses [] , rules = [] } in@@ -353,16 +398,15 @@ type StateListExp = Q Exp type BindingsExp = Q Exp -data ErrorHalter = ErrorHalter--instance Halter ErrorHalter () t where- initHalt _ _ = ()- updatePerStateHalt _ _ _ _ = ()-- stopRed _ _ _ (State { curr_expr = CurrExpr _ (G2.Prim Error _)}) = Discard- stopRed _ _ _ _ = Continue-- stepHalter _ _ _ _ _ = ()+errorHalter :: Monad m => Halter m () t+errorHalter = mkSimpleHalter+ (const ())+ (\_ _ _ -> ())+ stop+ (\_ _ _ _ -> ())+ where+ stop _ _ (State { curr_expr = CurrExpr _ (G2.Prim Error _)}) = return Discard+ stop _ _ _ = return Continue executeAndSolveStates :: StateExp -> BindingsExp -> Q Exp executeAndSolveStates s b = do@@ -371,20 +415,13 @@ executeAndSolveStates' :: Bindings -> State () -> IO (Maybe (ExecRes ())) executeAndSolveStates' b s = do config <- qqConfig- SomeSolver con <- initSolverInfinite config- case qqRedHaltOrd con of+ SomeSolver solver <- initSolverInfinite config+ let simplifier = IdSimplifier+ case qqRedHaltOrd config solver simplifier of (SomeReducer red, SomeHalter hal, _) -> do- -- let hal' = hal :<~> ErrorHalter- -- :<~> MaxOutputsHalter (Just 1)- -- :<~> BranchAdjSwitchEveryNHalter 2000 20- -- :<~> SwitchEveryNHalter 2000- let hal' = hal :<~> ErrorHalter :<~> VarLookupLimit 3 :<~> MaxOutputsHalter (Just 1)- -- (res, _) <- runG2Post red hal' PickLeastUsedOrderer con s b- -- (res, _) <- runG2Post (red :<~ Logger "qq") hal' ((IncrAfterN 2000 SymbolicADTOrderer)- -- :<-> BucketSizeOrderer 6) con s b- (res, _) <- runG2Post (red) hal' ((IncrAfterN 2000 ADTHeightOrderer)- :<-> BucketSizeOrderer 6) con s b- -- (res, _) <- runG2Post (red) hal' (BucketSizeOrderer 3) con s b+ let hal' = hal <~> errorHalter <~> varLookupLimitHalter 3 <~> maxOutputsHalter (Just 1)+ ord = incrAfterN 2000 (adtHeightOrderer 0 Nothing) <-> bucketSizeOrderer 6+ (res, _) <- runG2Post red hal' ord solver simplifier s b case res of exec_res:_ -> return $ Just exec_res@@ -400,20 +437,22 @@ , ASTContainer t G2.Type) => Bindings -> [State t] -> IO (Maybe (ExecRes t)) solveStates' b xs = do config <- qqConfig- SomeSolver con <- initSolverInfinite config- solveStates'' con b xs+ SomeSolver solver <- initSolverInfinite config+ let simplifier = IdSimplifier+ solveStates'' solver simplifier b xs solveStates'' :: ( Named t , ASTContainer t Expr , ASTContainer t G2.Type- , Solver sol) => sol -> Bindings -> [State t] -> IO (Maybe (ExecRes t))-solveStates'' _ _ [] =return Nothing-solveStates'' sol b (s:xs) = do- m_ex_res <- runG2Solving sol b s+ , Solver solver+ , Simplifier simplifier) => solver -> simplifier -> Bindings -> [State t] -> IO (Maybe (ExecRes t))+solveStates'' _ _ _ [] = return Nothing+solveStates'' sol simplifier b (s:xs) = do+ m_ex_res <- runG2Solving sol simplifier b s case m_ex_res of Just _ -> do return m_ex_res- Nothing -> solveStates'' sol b xs+ Nothing -> solveStates'' sol simplifier b xs -- | Get the values of the symbolic arguments, and returns them in a tuple extractArgs :: InputIds -> CleanedNames -> TypeEnvName -> Q Exp -> Q Exp@@ -424,15 +463,19 @@ Just r' -> return . Just . $(toSymbArgsTuple in_ids cleaned tenv) $ conc_args r' Nothing -> return Nothing |] --- | Returns a function to turn the first (length of InputIds) elements of a list into a tuple+-- | If (length of InputIds) is greater than 1, returns a function to turn the first (length of InputIds) elements of+-- a list into a tuple.+-- Otherwise, simply returns the singular value directly. toSymbArgsTuple :: InputIds -> CleanedNames -> TypeEnvName -> Q Exp toSymbArgsTuple in_ids cleaned tenv_name = do+ let mkTup = if length in_ids > 1 then tupE else head lst <- newName "lst" lamE [varP lst]- (tupE $ map (\(i, n) -> [| g2UnRep $(varE tenv_name) ($(varE lst) !! n) :: $(toTHType cleaned (Ty.typeOf i)) |]) $ zip in_ids ([0..] :: [Int]))+ (mkTup $ map (\(i, n) -> [| g2UnRep $(varE tenv_name) ($(varE lst) !! n) :: $(toTHType cleaned (Ty.typeOf i)) |]) $ zip in_ids ([0..] :: [Int])) qqConfig :: IO Config qqConfig = do homedir <- getHomeDirectory- return $ mkConfig homedir [] M.empty+ let config = mkConfigDirect homedir [] M.empty+ return $ config { extraDefaultMods = [homedir ++ "/.g2/G2Stubs/src/G2/QuasiQuotes/G2Rep.hs"] }
src/G2/QuasiQuotes/Support.hs view
@@ -25,9 +25,9 @@ import GHC.Generics (Generic) import Data.Data+import Data.Foldable import Data.Hashable import qualified Data.HashMap.Lazy as HM-import qualified Data.Map as M import qualified Data.Text as T data QQName = QQName T.Text (Maybe T.Text)@@ -40,7 +40,7 @@ qqMap :: Named n => CleanedNames -> n -> QQMap qqMap cn n = let- ns = names n+ ns = toList $ names n in HM.fromList $ zip (map (nameToQQName . renames cn) ns) ns @@ -56,19 +56,20 @@ qqNameToName0 (QQName n m) = Name n m 0 Nothing qqAlgDataTyLookup :: QQName -> QQMap -> TypeEnv -> Maybe AlgDataTy-qqAlgDataTyLookup qqn qqm tenv = flip M.lookup tenv =<< HM.lookup qqn qqm+qqAlgDataTyLookup qqn qqm tenv = flip HM.lookup tenv =<< HM.lookup qqn qqm -qqDataConLookup :: QQName -> QQName -> QQMap -> TypeEnv -> Maybe DataCon-qqDataConLookup qqtn qqdcn qqm tenv- | Just adt <- qqAlgDataTyLookup qqtn qqm tenv- , Just dcn <- HM.lookup qqdcn qqm = dataConWithName adt dcn+qqDataConLookup :: QQName -> QQName -> QQMap -> QQMap -> TypeEnv -> Maybe DataCon+qqDataConLookup qqtn qqdcn type_nm_qqm dc_nm_qqm tenv+ | Just adt <- qqAlgDataTyLookup qqtn type_nm_qqm tenv+ , Just dcn <- HM.lookup qqdcn dc_nm_qqm = dataConWithName adt dcn | otherwise = Nothing toTHType :: CleanedNames -> G2.Type -> Q TH.Type toTHType cleaned (TyFun t1 t2) = appT (appT arrowT $ toTHType cleaned t1) (toTHType cleaned t2) toTHType cleaned (TyApp t1 t2) = appT (toTHType cleaned t1) (toTHType cleaned t2) toTHType cleaned t@(TyCon n _)- | nameOcc (renames cleaned n) == "[]" = listT+ | nameOcc (renames cleaned n) == "List" = listT -- GHC 9.6 on+ | nameOcc (renames cleaned n) == "[]" = listT -- pre GHC 9.6 | Just i <- tupleNum . nameOcc $ renames cleaned n = tupleT i | otherwise = do tn <- lookupTypeName . T.unpack . nameOcc $ renames cleaned n
src/G2/Solver.hs view
@@ -1,18 +1,22 @@ -- | Solver -- Export module for G2.Solver. module G2.Solver- ( module G2.Solver.ADTSolver,+ ( module G2.Solver.ADTNumericalSolver, module G2.Solver.Converters, module G2.Solver.Language, module G2.Solver.Interface,+ module G2.Solver.Maximize, module G2.Solver.ParseSMT,+ module G2.Solver.Simplifier, module G2.Solver.SMT2, module G2.Solver.Solver ) where -import G2.Solver.ADTSolver+import G2.Solver.ADTNumericalSolver import G2.Solver.Converters import G2.Solver.Language import G2.Solver.Interface+import G2.Solver.Maximize import G2.Solver.ParseSMT+import G2.Solver.Simplifier import G2.Solver.SMT2 import G2.Solver.Solver
+ src/G2/Solver/ADTNumericalSolver.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module G2.Solver.ADTNumericalSolver ( ADTNumericalSolver (..)+ , adtNumericalSolFinite+ , adtNumericalSolInfinite) where++import G2.Language.ArbValueGen+import G2.Language.Support+import G2.Language.Syntax+import qualified G2.Language.PathConds as PC+import G2.Solver.Solver++-- | Converts constraints about ADTs to numerical constraints before sending them to other solvers+data ADTNumericalSolver solver = ADTNumericalSolver ArbValueFunc solver++adtNumericalSolFinite :: solver -> ADTNumericalSolver solver+adtNumericalSolFinite = ADTNumericalSolver arbValue++adtNumericalSolInfinite :: solver -> ADTNumericalSolver solver+adtNumericalSolInfinite = ADTNumericalSolver arbValueInfinite++instance Solver solver => Solver (ADTNumericalSolver solver) where+ check (ADTNumericalSolver _ sol) s pc = return . fst =<< checkConsistency (Tr sol) s pc+ solve (ADTNumericalSolver avf sol) s b is pc = do+ (r, _) <- solve' avf (Tr sol) s b is pc+ return r+ close (ADTNumericalSolver _ s) = close s++instance TrSolver solver => TrSolver (ADTNumericalSolver solver) where+ checkTr (ADTNumericalSolver avf sol) s pc = do+ (r, sol') <- checkConsistency sol s pc+ return (r, ADTNumericalSolver avf sol')+ solveTr (ADTNumericalSolver avf sol) s b is pc = do+ (r, sol') <- solve' avf sol s b is pc+ return (r, ADTNumericalSolver avf sol')+ closeTr (ADTNumericalSolver _ s) = closeTr s++checkConsistency :: TrSolver solver => solver -> State t -> PathConds -> IO (Result () () (), solver)+checkConsistency solver s pc+ | PC.null pc = return (SAT (), solver)+ | otherwise = do+ checkTr solver s pc++solve' :: TrSolver solver => ArbValueFunc -> solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () (), solver)+solve' _ sol s b is pc = do+ solveTr sol s b is pc
− src/G2/Solver/ADTSolver.hs
@@ -1,206 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}--module G2.Solver.ADTSolver ( ADTSolver (..)- , adtSolverFinite- , adtSolverInfinite- , checkConsistency- , findConsistent) where--import G2.Language.ArbValueGen-import G2.Language.Casts-import G2.Language.Expr-import qualified G2.Language.ExprEnv as E-import G2.Language.Naming-import G2.Language.Support-import G2.Language.Syntax-import G2.Language.PathConds hiding (map, filter, null)-import qualified G2.Language.PathConds as PC-import G2.Language.Typing-import G2.Solver.Solver--import Data.List-import qualified Data.Map as M-import Data.Maybe-import Prelude hiding (null)-import qualified Prelude as Pre-import Data.Tuple--data ADTSolver = ADTSolver ArbValueFunc--adtSolverFinite :: ADTSolver-adtSolverFinite = ADTSolver arbValue--adtSolverInfinite :: ADTSolver-adtSolverInfinite = ADTSolver arbValueInfinite--instance Solver ADTSolver where- check _ s = return .checkConsistency (known_values s) (expr_env s) (type_env s)- solve (ADTSolver avf) s b is = solveADTs avf s b (nub is) ---- | Attempts to detemine if the given PathConds are consistent.--- Returns Just True if they are, Just False if they are not,--- and Nothing if it can't decide.-checkConsistency :: KnownValues -> ExprEnv -> TypeEnv -> PathConds -> Result-checkConsistency kv eenv tenv pc- | all PC.isPCExists $ PC.toList pc = SAT- | otherwise =- maybe (Unknown "Non-ADT path constraints") - (\me -> if not (Pre.null me) then SAT else UNSAT) - $ findConsistent kv eenv tenv $ PC.filter (not . PC.isPCExists) pc---- | Attempts to find expressions (Data d) or (Coercion (Data d), (t1 :~ t2)) consistent with the given path--- constraints. Returns Just [...] if it can determine [...] are consistent.--- Just [] means there are no consistent Expr. Nothing nmeans it could not be--- determined if there were any consistent data constructors.--- In practice, the result should always be Just [...] if all the path conds--- are about ADTs.-findConsistent :: KnownValues -> ExprEnv -> TypeEnv -> PathConds -> Maybe [Expr]-findConsistent kv eenv tenv = fmap fst . findConsistent' kv eenv tenv--head' :: [a] -> Maybe a-head' (x:_) = Just x-head' _ = Nothing--findConsistent' :: KnownValues -> ExprEnv -> TypeEnv -> PathConds -> Maybe ([Expr], [(Id, Type)])-findConsistent' kv eenv tenv pc =- let- pc' = unsafeElimCast $ toList pc-- -- Adding Coercions- pcNT = fmap (pcInCastType tenv) . head' $ toList pc- cons = findConsistent'' kv tenv eenv pc'- in- case cons of- Just (cons', bi) ->- let- cons'' = simplifyCasts . map (castReturnType $ fromJust pcNT) $ cons'- in- -- We can't use the ADT solver when we have a Boolean, because the RHS of the- -- DataAlt might be a primitive.- if any isExtCond pc' || pcNT == Just (tyBool kv) then Nothing else Just (cons'', bi)- Nothing -> Nothing--findConsistent'' :: KnownValues -> TypeEnv -> ExprEnv -> [PathCond] -> Maybe ([Expr], [(Id, Type)])-findConsistent'' kv tenv eenv pc =- let- is = nub . map (\(Id n t') -> Id n (typeStripCastType tenv t')) $ concatMap (varIdsInPC kv) pc-- t = pcVarType tenv pc- cons = maybe Nothing (flip getCastedAlgDataTy tenv) t- - in- case (cons, is) of - (Just (DataTyCon _ dc, bi), [i]) ->- let- dc' = case E.lookup (idName i) eenv of- Just e- | Data spec_dc:_ <- unApp e -> [spec_dc]- _ -> dc- -- cons' = fmap (map Data) $ findConsistent''' dc' pc- in- maybe Nothing (Just . (, bi)) cons'- _ -> Nothing--findConsistent''' :: [DataCon] -> [PathCond] -> Maybe [DataCon]-findConsistent''' dcs ((ConsCond dc _ True):pc) =- findConsistent''' (filter ((==) (dcName dc) . dcName) dcs) pc-findConsistent''' dcs ((ConsCond dc _ False):pc) =- findConsistent''' (filter ((/=) (dcName dc) . dcName) dcs) pc--- findConsistent''' dcs (PCExists _:pc) = findConsistent''' dcs pc-findConsistent''' dcs [] = Just dcs-findConsistent''' _ _ = Nothing--solveADTs :: ArbValueFunc -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model)-solveADTs avf s@(State { expr_env = eenv, model = m }) b [Id n t] pc- | not $ E.isSymbolic n eenv- , Just e <- E.lookup n eenv = return (SAT, Just . liftCasts $ M.insert n e m )- -- We can't use the ADT solver when we have a Boolean, because the RHS of the- -- DataAlt might be a primitive.- | TyCon tn k <- tyAppCenter t- , ts <- tyAppArgs t- , t /= tyBool (known_values s) =- do- let (r, s', _) = addADTs avf n tn ts k s b (PC.filter (not . isPCExists) pc)-- case r of- SAT -> return (r, Just . liftCasts $ model s')- r' -> return (r', Nothing)-solveADTs _ _ _ _ _ = return (Unknown "Unhandled path constraints in ADTSolver", Nothing)---- | Determines an ADT based on the path conds. The path conds form a witness.--- In particular, refer to findConsistent in Solver/ADTSolver.hs-addADTs :: ArbValueFunc -> Name -> Name -> [Type] -> Kind -> State t -> Bindings -> PathConds -> (Result, State t, Bindings)-addADTs avf n tn ts k s b pc- | PC.null pc =- let- (bse, av) = avf (mkTyApp (TyCon tn k:ts)) (type_env s) (arb_value_gen b)- m' = M.singleton n bse- in- (SAT, (s {model = M.union m' (model s)}), (b {arb_value_gen = av}))- | Just (dcs@(fdc:_), bi) <- findConsistent' (known_values s) (expr_env s) (type_env s) pc =- let - eenv = expr_env s- ts2 = map snd bi- -- We map names over the arguments of a DataCon, to make sure we have the correct- -- number of undefined's.- ts'' = case exprInCasts fdc of- Data (DataCon _ ts') -> anonArgumentTypes $ PresType ts'- _ -> [] -- [Name "b" Nothing 0 Nothing]-- (ns, _) = childrenNames n (map (const $ Name "a" Nothing 0 Nothing) ts'') (name_gen b)-- (av, vs) = mapAccumL (\av_ (n', t') -> - case E.lookup n' eenv of- Just e -> (av_, e)- Nothing -> swap $ avf t' (type_env s) av_) (arb_value_gen b) $ zip ns ts''- - dc = mkApp $ fdc:map Type ts2 ++ vs-- m = M.insert n dc (model s)- in- case not . Pre.null $ dcs of- True -> (SAT, s { model = M.union m (model s) }, b { arb_value_gen = av })- False -> (UNSAT, s, b)- | otherwise = (UNSAT, s, b)---- Various helper functions--isExtCond :: PathCond -> Bool-isExtCond (ExtCond _ _) = True-isExtCond _ = False--pcVarType :: TypeEnv -> [PathCond] -> Maybe Type-pcVarType tenv (AltCond _ (Var (Id _ t)) _:pc) = pcVarType' t tenv pc-pcVarType tenv (ConsCond _ (Var (Id _ t)) _:pc) = pcVarType' t tenv pc-pcVarType _ _ = Nothing--pcVarType' :: Type -> TypeEnv -> [PathCond] -> Maybe Type-pcVarType' t tenv (AltCond _ (Var (Id _ t')) _:pc) =- if t == t' then pcVarType' t tenv pc else Nothing-pcVarType' t tenv (ConsCond _ (Var (Id _ t')) _:pc) =- if t == t' then pcVarType' t tenv pc else Nothing-pcVarType' n _ [] = Just n-pcVarType' _ _ _ = Nothing--pcInCastType :: TypeEnv -> PathCond -> Type-pcInCastType _ (AltCond _ e _) = typeInCasts e-pcInCastType _ (ExtCond e _) = typeInCasts e-pcInCastType _ (ConsCond _ e _) = typeInCasts e-pcInCastType tenv (PCExists (Id _ t)) = typeStripCastType tenv t--castReturnType :: Type -> Expr -> Expr-castReturnType t e =- let- te = typeOf e- tr = replaceReturnType te t- in- Cast e (te :~ tr)--replaceReturnType :: Type -> Type -> Type-replaceReturnType (TyForAll b t) r = TyForAll b $ replaceReturnType t r-replaceReturnType (TyFun t1 t2@(TyFun _ _)) r = TyFun t1 $ replaceReturnType t2 r-replaceReturnType (TyFun t _) r = TyFun t r-replaceReturnType _ r = r
src/G2/Solver/Converters.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -11,21 +12,30 @@ -- (3) SMTASTs/Sorts to Exprs/Types module G2.Solver.Converters ( toSMTHeaders- , toSolver+ , toSolverText , exprToSMT --WOULD BE NICE NOT TO EXPORT THIS , typeToSMT --WOULD BE NICE NOT TO EXPORT THIS , toSolverAST --WOULD BE NICE NOT TO EXPORT THIS+ , sortName , smtastToExpr , modelAsExpr++ , addHeaders+ , checkConstraintsPC+ , checkModelPC , checkConstraints- , checkModel+ , solveConstraints+ , constraintsToModelOrUnsatCore+ , constraintsToModelOrUnsatCoreNoReset , SMTConverter (..) ) where -import Data.List+import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HS import qualified Data.Map as M-import Data.Maybe import Data.Monoid+import Data.Ratio import qualified Data.Text as T+import qualified Text.Builder as TB import G2.Language hiding (Assert, vars) import qualified G2.Language.ExprEnv as E@@ -36,122 +46,101 @@ -- | Used to describe the specific output format required by various solvers -- By defining these functions, we can automatically convert from the SMTHeader and SMTAST -- datatypes, to a form understandable by the solver.-class Solver con => SMTConverter con ast out io | con -> ast, con -> out, con -> io where- getIO :: con -> io+class Solver con => SMTConverter con where closeIO :: con -> IO () - empty :: con -> out- merge :: con -> out -> out -> out-- checkSat :: con -> io -> out -> IO Result- checkSatGetModel :: con -> io -> out -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result, Maybe SMTModel)- checkSatGetModelGetExpr :: con -> io -> out -> [SMTHeader] -> [(SMTName, Sort)] -> ExprEnv -> CurrExpr -> IO (Result, Maybe SMTModel, Maybe Expr)-- assert :: con -> ast -> out- varDecl :: con -> SMTName -> ast -> out- setLogic :: con -> Logic -> out+ reset :: con -> IO () - (.>=) :: con -> ast -> ast -> ast- (.>) :: con -> ast -> ast -> ast- (.=) :: con -> ast -> ast -> ast- (./=) :: con -> ast -> ast -> ast- (.<) :: con -> ast -> ast -> ast- (.<=) :: con -> ast -> ast -> ast+ checkSatInstr :: con -> IO ()+ maybeCheckSatResult :: con -> IO (Maybe (Result () () ())) - (.&&) :: con -> ast -> ast -> ast- (.||) :: con -> ast -> ast -> ast- (.!) :: con -> ast -> ast- (.=>) :: con -> ast -> ast -> ast- (.<=>) :: con -> ast -> ast -> ast+ getModelInstrResult :: con -> [(SMTName, Sort)] -> IO SMTModel+ getUnsatCoreInstrResult :: con -> IO UnsatCore - (.+) :: con -> ast -> ast -> ast- (.-) :: con -> ast -> ast -> ast- (.*) :: con -> ast -> ast -> ast- (./) :: con -> ast -> ast -> ast- smtQuot :: con -> ast -> ast -> ast- smtModulo :: con -> ast -> ast -> ast- smtSqrt :: con -> ast -> ast- neg :: con -> ast -> ast- strLen :: con -> ast -> ast- itor :: con -> ast -> ast+ setProduceUnsatCores :: con -> IO () - ite :: con -> ast -> ast -> ast -> ast+ addFormula :: con -> [SMTHeader] -> IO () - --values- int :: con -> Integer -> ast- float :: con -> Rational -> ast- double :: con -> Rational -> ast- char :: con -> Char -> ast- bool :: con -> Bool -> ast- cons :: con -> SMTName -> [ast] -> Sort -> ast- var :: con -> SMTName -> ast -> ast+ checkSatNoReset :: con -> [SMTHeader] -> IO (Result () () ())+ checkSatGetModelOrUnsatCoreNoReset :: con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel UnsatCore ()) - --sorts- sortInt :: con -> ast- sortFloat :: con -> ast- sortDouble :: con -> ast- sortChar :: con -> ast- sortBool :: con -> ast+ checkSat :: con -> [SMTHeader] -> IO (Result () () ())+ checkSat con headers = do+ reset con+ checkSatNoReset con headers+ checkSatGetModel :: con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel () ())+ checkSatGetModelOrUnsatCore :: con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel UnsatCore ())+ checkSatGetModelOrUnsatCore con out get = do+ reset con+ setProduceUnsatCores con+ checkSatGetModelOrUnsatCoreNoReset con out get - varName :: con -> SMTName -> Sort -> ast+ -- Incremental+ push :: con -> IO ()+ pop :: con -> IO () --- | Checks if the path constraints are satisfiable-checkConstraints :: SMTConverter con ast out io => con -> PathConds -> IO Result-checkConstraints con pc = do- let pc' = unsafeElimCast pc+addHeaders :: SMTConverter con => con -> [SMTHeader] -> IO ()+addHeaders = addFormula - let headers = toSMTHeaders pc'- let formula = toSolver con headers+checkConstraintsPC :: SMTConverter con => con -> PathConds -> IO (Result () () ())+checkConstraintsPC con pc = do+ let headers = toSMTHeaders pc+ checkConstraints con headers - checkSat con (getIO con) formula+checkConstraints :: SMTConverter con => con -> [SMTHeader] -> IO (Result () () ())+checkConstraints = checkSat -- | Checks if the constraints are satisfiable, and returns a model if they are-checkModel :: SMTConverter con ast out io => ArbValueFunc -> con -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model)-checkModel avf con s b is pc = return . fmap liftCasts =<< checkModel' avf con s b is pc+checkModelPC :: SMTConverter con => ArbValueFunc -> con -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () ())+checkModelPC avf con s b is pc = return . liftCasts =<< checkModel' avf con s b is pc -- | We split based on whether we are evaluating a ADT or a literal. -- ADTs can be solved using our efficient addADTs, while literals require -- calling an SMT solver.-checkModel' :: SMTConverter con ast out io => ArbValueFunc -> con -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model)+checkModel' :: SMTConverter con => ArbValueFunc -> con -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () ()) checkModel' _ _ s _ [] _ = do- return (SAT, Just $ model s)+ return (SAT $ model s) checkModel' avf con s b (i:is) pc- | (idName i) `M.member` (model s) = checkModel' avf con s b is pc+ | (idName i) `HM.member` (model s) = checkModel' avf con s b is pc | otherwise = do (m, av) <- getModelVal avf con s b i pc case m of- Just m' -> checkModel' avf con (s {model = M.union m' (model s)}) (b {arb_value_gen = av}) is pc- Nothing -> return (UNSAT, Nothing)+ SAT m' -> checkModel' avf con (s {model = HM.union m' (model s)}) (b {arb_value_gen = av}) is pc+ r -> return r -getModelVal :: SMTConverter con ast out io => ArbValueFunc -> con -> State t -> Bindings -> Id -> PathConds -> IO (Maybe Model, ArbValueGen)-getModelVal avf con s b (Id n _) pc = do- let (Just (Var (Id n' t))) = E.lookup n (expr_env s)+getModelVal :: SMTConverter con => ArbValueFunc -> con -> State t -> Bindings -> Id -> PathConds -> IO (Result Model () (), ArbValueGen)+getModelVal avf con (State { expr_env = eenv, type_env = tenv, known_values = kv }) b (Id n _) pc = do+ let (Just (Var (Id n' t))) = E.lookup n eenv case PC.null pc of True -> let- (e, av) = avf t (type_env s) (arb_value_gen b)+ (e, av) = avf t tenv (arb_value_gen b) in- return (Just $ M.singleton n' e, av) + return (SAT $ HM.singleton n' e, av) False -> do- m <- checkNumericConstraints con pc+ m <- solveNumericConstraintsPC con kv tenv pc return (m, arb_value_gen b) -checkNumericConstraints :: SMTConverter con ast out io => con -> PathConds -> IO (Maybe Model)-checkNumericConstraints con pc = do+solveNumericConstraintsPC :: SMTConverter con => con -> KnownValues -> TypeEnv -> PathConds -> IO (Result Model () ())+solveNumericConstraintsPC con kv tenv pc = do let headers = toSMTHeaders pc- let formula = toSolver con headers+ let vs = map (\(n', srt) -> (nameToStr n', srt)) . HS.toList . pcVars $ pc - let vs = map (\(n', srt) -> (nameToStr n', srt)) . pcVars $ PC.toList pc+ m <- solveConstraints con headers vs+ case m of+ SAT m' -> return . SAT $ modelAsExpr kv tenv m'+ UNSAT () -> return $ UNSAT ()+ Unknown s () -> return $ Unknown s () - let io = getIO con- (_, m) <- checkSatGetModel con io formula headers vs+solveConstraints :: SMTConverter con => con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel () ())+solveConstraints con headers vs = checkSatGetModel con headers vs - let m' = fmap modelAsExpr m+constraintsToModelOrUnsatCore :: SMTConverter con => con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel UnsatCore ())+constraintsToModelOrUnsatCore = checkSatGetModelOrUnsatCore - case m' of- Just m'' -> return $ Just m''- Nothing -> return Nothing+constraintsToModelOrUnsatCoreNoReset :: SMTConverter con => con -> [SMTHeader] -> [(SMTName, Sort)] -> IO (Result SMTModel UnsatCore ())+constraintsToModelOrUnsatCoreNoReset = checkSatGetModelOrUnsatCoreNoReset -- | Here we convert from a State, to an SMTHeader. This SMTHeader can later -- be given to an SMT solver by using toSolver.@@ -163,11 +152,11 @@ toSMTHeaders = addSetLogic . toSMTHeaders' toSMTHeaders' :: PathConds -> [SMTHeader]-toSMTHeaders' pc = +toSMTHeaders' pc = let pc' = PC.toList pc- in- nub (pcVarDecls pc')+ in + (pcVarDecls pc) ++ (pathConsToSMTHeaders pc') @@ -181,13 +170,15 @@ nia = isNIA xs nra = isNRA xs nira = isNIRA xs+ uflia = isUFLIA xs sl = if lia then SetLogic QF_LIA else if lra then SetLogic QF_LRA else if lira then SetLogic QF_LIRA else if nia then SetLogic QF_NIA else if nra then SetLogic QF_NRA else - if nira then SetLogic QF_NIRA else SetLogic ALL+ if nira then SetLogic QF_NIRA else+ if uflia then SetLogic QF_UFLIA else SetLogic ALL in sl:xs @@ -197,6 +188,7 @@ isNIA' :: SMTAST -> All isNIA' (_ :* _) = All True isNIA' (_ :/ _) = All True+isNIA' (_ `Modulo` _) = All True isNIA' s = isLIA' s isLIA :: (ASTContainer m SMTAST) => m -> Bool@@ -278,13 +270,21 @@ isNIRA' (ItoR _) = All True isNIRA' s = All $ getAll (isNIA' s) || getAll (isNRA' s) +isUFLIA :: (ASTContainer m SMTAST) => m -> Bool+isUFLIA = getAll . evalASTs isUFLIA'++isUFLIA' :: SMTAST -> All+isUFLIA' (Func _ xs) = mconcat $ map isUFLIA' xs+isUFLIA' s = isLIA' s+ isCore' :: SMTAST -> All isCore' (_ := _) = All True-isCore' (_ :&& _) = All True-isCore' (_ :|| _) = All True+isCore' (SmtAnd _) = All True+isCore' (SmtOr _) = All True isCore' ((:!) _) = All True isCore' (_ :=> _) = All True isCore' (_ :<=> _) = All True+isCore' (Func _ _) = All True isCore' (VBool _) = All True isCore' (V _ s) = All $ isCoreSort s isCore' _ = All False@@ -296,32 +296,34 @@ ------------------------------------------------------------------------------- pathConsToSMTHeaders :: [PathCond] -> [SMTHeader]-pathConsToSMTHeaders = map Assert . mapMaybe pathConsToSMT+pathConsToSMTHeaders = map pathConsToSMT -pathConsToSMT :: PathCond -> Maybe SMTAST-pathConsToSMT (AltCond l e b) =+pathConsToSMT :: PathCond -> SMTHeader+pathConsToSMT (MinimizePC e) = Minimize $ exprToSMT e+pathConsToSMT (SoftPC pc) = AssertSoft (pathConsToSMT' pc) Nothing+pathConsToSMT pc = Assert (pathConsToSMT' pc) ++pathConsToSMT' :: PathCond -> SMTAST+pathConsToSMT' (AltCond l e b) = let exprSMT = exprToSMT e altSMT = altToSMT l e in- Just $ if b then exprSMT := altSMT else (:!) (exprSMT := altSMT) -pathConsToSMT (ExtCond e b) =- let- exprSMT = exprToSMT e- in- Just $ if b then exprSMT else (:!) exprSMT-pathConsToSMT (ConsCond (DataCon (Name "True" _ _ _) _) e b) =+ if b then exprSMT := altSMT else (:!) (exprSMT := altSMT) +pathConsToSMT' (ExtCond e b) = let exprSMT = exprToSMT e in- Just $ if b then exprSMT else (:!) exprSMT-pathConsToSMT (ConsCond (DataCon (Name "False" _ _ _) _) e b) =+ if b then exprSMT else (:!) exprSMT+pathConsToSMT' (AssumePC (Id n t) num pc) = let- exprSMT = exprToSMT e+ idSMT = V (nameToStr n) (typeToSMT t) -- exprToSMT (Var i)+ intSMT = VInt $ toInteger num -- exprToSMT (Lit (LitInt $ toInteger num))+ pcSMT = map (pathConsToSMT' . PC.unhashedPC) $ HS.toList pc in- Just $ if b then (:!) $ exprSMT else exprSMT-pathConsToSMT (ConsCond (DataCon _ _) _ _) = error "Non-bool DataCon in pathConsToSMT"-pathConsToSMT (PCExists _) = Nothing+ (idSMT := intSMT) :=> SmtAnd pcSMT+pathConsToSMT' (MinimizePC _) = error "pathConsToSMT': unsupported nesting of MinimizePC."+pathConsToSMT' (SoftPC _) = error "pathConsToSMT': unsupported nesting of SoftPC." exprToSMT :: Expr -> SMTAST exprToSMT (Var (Id n t)) = V (nameToStr n) (typeToSMT t)@@ -365,15 +367,20 @@ funcToSMT1Prim :: Primitive -> Expr -> SMTAST funcToSMT1Prim Negate a = Neg (exprToSMT a)+funcToSMT1Prim Abs e = AbsSMT (exprToSMT e) funcToSMT1Prim SqRt e = SqrtSMT (exprToSMT e) funcToSMT1Prim Not e = (:!) (exprToSMT e) funcToSMT1Prim IntToFloat e = ItoR (exprToSMT e) funcToSMT1Prim IntToDouble e = ItoR (exprToSMT e)+funcToSMT1Prim IntToString e = FromInt (exprToSMT e)+funcToSMT1Prim Chr e = FromCode (exprToSMT e)+funcToSMT1Prim OrdChar e = ToCode (exprToSMT e)+funcToSMT1Prim StrLen e = StrLenSMT (exprToSMT e) funcToSMT1Prim err _ = error $ "funcToSMT1Prim: invalid Primitive " ++ show err funcToSMT2Prim :: Primitive -> Expr -> Expr -> SMTAST-funcToSMT2Prim And a1 a2 = exprToSMT a1 :&& exprToSMT a2-funcToSMT2Prim Or a1 a2 = exprToSMT a1 :|| exprToSMT a2+funcToSMT2Prim And a1 a2 = SmtAnd [exprToSMT a1, exprToSMT a2]+funcToSMT2Prim Or a1 a2 = SmtOr [exprToSMT a1, exprToSMT a2] funcToSMT2Prim Implies a1 a2 = exprToSMT a1 :=> exprToSMT a2 funcToSMT2Prim Iff a1 a2 = exprToSMT a1 :<=> exprToSMT a2 funcToSMT2Prim Ge a1 a2 = exprToSMT a1 :>= exprToSMT a2@@ -388,6 +395,9 @@ funcToSMT2Prim Div a1 a2 = exprToSMT a1 :/ exprToSMT a2 funcToSMT2Prim Quot a1 a2 = exprToSMT a1 `QuotSMT` exprToSMT a2 funcToSMT2Prim Mod a1 a2 = exprToSMT a1 `Modulo` exprToSMT a2+funcToSMT2Prim Rem a1 a2 = exprToSMT a1 :- ((exprToSMT a1 `QuotSMT` exprToSMT a2) :* exprToSMT a2) -- TODO: more efficient encoding?+funcToSMT2Prim RationalToDouble a1 a2 = exprToSMT a1 :/ exprToSMT a2+funcToSMT2Prim StrAppend a1 a2 = exprToSMT a1 :++ exprToSMT a2 funcToSMT2Prim op lhs rhs = error $ "funcToSMT2Prim: invalid case with (op, lhs, rhs): " ++ show (op, lhs, rhs) altToSMT :: Lit -> Expr -> SMTAST@@ -397,31 +407,21 @@ altToSMT (LitChar c) _ = VChar c altToSMT am _ = error $ "Unhandled " ++ show am -createVarDecls :: [(Name, Sort)] -> [SMTHeader]-createVarDecls [] = []-createVarDecls ((n,SortChar):xs) =+createUniqVarDecls :: [(Name, Sort)] -> [SMTHeader]+createUniqVarDecls [] = []+createUniqVarDecls ((n,SortChar):xs) = let- lenAssert = Assert $ StrLen (V (nameToStr n) SortChar) := VInt 1+ lenAssert = Assert $ StrLenSMT (V (nameToStr n) SortChar) := VInt 1 in- VarDecl (nameToStr n) SortChar:lenAssert:createVarDecls xs-createVarDecls ((n,s):xs) = VarDecl (nameToStr n) s:createVarDecls xs+ VarDecl (nameToBuilder n) SortChar:lenAssert:createUniqVarDecls xs+createUniqVarDecls ((n,s):xs) = VarDecl (nameToBuilder n) s:createUniqVarDecls xs -pcVarDecls :: [PathCond] -> [SMTHeader]-pcVarDecls = createVarDecls . pcVars+pcVarDecls :: PathConds -> [SMTHeader]+pcVarDecls = createUniqVarDecls . HS.toList . pcVars -- Get's all variable required for a list of `PathCond` -pcVars :: [PathCond] -> [(Name, Sort)]-pcVars [] = []-pcVars (PCExists i:xs) = idToNameSort i : pcVars xs-pcVars (AltCond _ e _:xs) = vars e ++ pcVars xs-pcVars (p:xs)= vars p ++ pcVars xs--vars :: (ASTContainer m Expr) => m -> [(Name, Sort)]-vars = evalASTs vars'- where- vars' :: Expr -> [(Name, Sort)]- vars' (Var i) = [idToNameSort i]- vars' _ = []+pcVars :: PathConds -> HS.HashSet (Name, Sort)+pcVars = HS.map idToNameSort . PC.allIds idToNameSort :: Id -> (Name, Sort) idToNameSort (Id n t) = (n, typeToSMT t)@@ -435,75 +435,176 @@ typeToSMT TyLitFloat = SortFloat typeToSMT TyLitChar = SortChar typeToSMT (TyCon (Name "Bool" _ _ _) _) = SortBool-typeToSMT (TyForAll (AnonTyBndr _) t) = typeToSMT t+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+typeToSMT (TyApp (TyCon (Name "List" _ _ _) _) (TyCon (Name "Char" _ _ _) _)) = SortString+#else+typeToSMT (TyApp (TyCon (Name "[]" _ _ _) _) (TyCon (Name "Char" _ _ _) _)) = SortString+#endif typeToSMT t = error $ "Unsupported type in typeToSMT: " ++ show t -toSolver :: SMTConverter con ast out io => con -> [SMTHeader] -> out-toSolver con [] = empty con-toSolver con (Assert ast:xs) = - merge con (assert con $ toSolverAST con ast) (toSolver con xs)-toSolver con (VarDecl n s:xs) = merge con (toSolverVarDecl con n s) (toSolver con xs)-toSolver con (SetLogic lgc:xs) = merge con (toSolverSetLogic con lgc) (toSolver con xs)+merge :: TB.Builder -> TB.Builder -> TB.Builder+merge x y = x <> "\n" <> y -toSolverAST :: SMTConverter con ast out io => con -> SMTAST -> ast-toSolverAST con (x :>= y) = (.>=) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x :> y) = (.>) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x := y) = (.=) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x :/= y) = (./=) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x :< y) = (.<) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x :<= y) = (.<=) con (toSolverAST con x) (toSolverAST con y)+comment :: String -> TB.Builder+comment s = "; " <> TB.string s -toSolverAST con (x :&& y) = (.&&) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x :|| y) = (.||) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con ((:!) x) = (.!) con $ toSolverAST con x-toSolverAST con (x :=> y) = (.=>) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x :<=> y) = (.<=>) con (toSolverAST con x) (toSolverAST con y)+assertSoftSolver :: TB.Builder -> Maybe T.Text -> TB.Builder+assertSoftSolver ast Nothing = function1 "assert-soft" ast+assertSoftSolver ast (Just lab) = "(assert-soft " <> ast <> " :id " <> TB.text lab <> ")" -toSolverAST con (x :+ y) = (.+) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x :- y) = (.-) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x :* y) = (.*) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x :/ y) = (./) con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x `QuotSMT` y) = smtQuot con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (x `Modulo` y) = smtModulo con (toSolverAST con x) (toSolverAST con y)-toSolverAST con (SqrtSMT x) = smtSqrt con $ toSolverAST con x-toSolverAST con (Neg x) = neg con $ toSolverAST con x-toSolverAST con (StrLen x) = strLen con $ toSolverAST con x-toSolverAST con (ItoR x) = itor con $ toSolverAST con x+defineFun :: String -> [(String, Sort)] -> Sort -> SMTAST -> TB.Builder+defineFun fn ars ret body =+ "(define-fun " <> (TB.string fn) <> " ("+ <> TB.intercalate " " (map (\(n, s) -> "(" <> TB.string n <> " " <> sortName s <> ")") ars) <> ")"+ <> " (" <> sortName ret <> ") " <> toSolverAST body <> ")" -toSolverAST con (Ite x y z) =- ite con (toSolverAST con x) (toSolverAST con y) (toSolverAST con z)+declareFun :: String -> [Sort] -> Sort -> TB.Builder+declareFun fn ars ret =+ "(declare-fun " <> TB.string fn <> " ("+ <> TB.intercalate " " (map sortName ars) <> ")"+ <> " (" <> sortName ret <> "))" -toSolverAST con (VInt i) = int con i-toSolverAST con (VFloat f) = float con f-toSolverAST con (VDouble i) = double con i-toSolverAST con (VChar c) = char con c-toSolverAST con (VBool b) = bool con b-toSolverAST con (V n s) = varName con n s-toSolverAST _ ast = error $ "toSolverAST: invalid SMTAST: " ++ show ast+toSolverText :: [SMTHeader] -> TB.Builder+toSolverText [] = ""+toSolverText (Assert ast:xs) = + merge (function1 "assert" $ toSolverAST ast) (toSolverText xs)+toSolverText (AssertSoft ast lab:xs) = + merge (assertSoftSolver (toSolverAST ast) lab) (toSolverText xs)+toSolverText (Minimize ast:xs) =+ merge (function1 "minimize" $ toSolverAST ast) (toSolverText xs)+toSolverText (DefineFun f ars ret body:xs) =+ merge (defineFun f ars ret body) (toSolverText xs)+toSolverText (DeclareFun f ars ret:xs) =+ merge (declareFun f ars ret) (toSolverText xs)+toSolverText (VarDecl n s:xs) = merge (toSolverVarDecl n s) (toSolverText xs)+toSolverText (SetLogic lgc:xs) = merge (toSolverSetLogic lgc) (toSolverText xs)+toSolverText (Comment c:xs) = merge (comment c) (toSolverText xs) -toSolverVarDecl :: SMTConverter con ast out io => con -> SMTName -> Sort -> out-toSolverVarDecl con n s = varDecl con n (sortName con s)+toSolverAST :: SMTAST -> TB.Builder+toSolverAST (x :>= y) = function2 ">=" (toSolverAST x) (toSolverAST y)+toSolverAST (x :> y) = function2 ">" (toSolverAST x) (toSolverAST y)+toSolverAST (x := y) = function2 "=" (toSolverAST x) (toSolverAST y)+toSolverAST (x :/= y) = function1 "not" $ function2 "=" (toSolverAST x) (toSolverAST y)+toSolverAST (x :< y) = function2 "<" (toSolverAST x) (toSolverAST y)+toSolverAST (x :<= y) = function2 "<=" (toSolverAST x) (toSolverAST y) -sortName :: SMTConverter con ast out io => con -> Sort -> ast-sortName con SortInt = sortInt con-sortName con SortFloat = sortFloat con-sortName con SortDouble = sortDouble con-sortName con SortChar = sortChar con-sortName con SortBool = sortBool con+toSolverAST (SmtAnd []) = "true"+toSolverAST (SmtAnd [x]) = toSolverAST x+toSolverAST (SmtAnd xs) = functionList "and" $ map (toSolverAST) xs+toSolverAST (SmtOr []) = "false"+toSolverAST (SmtOr [x]) = toSolverAST x+toSolverAST (SmtOr xs) = functionList "or" $ map (toSolverAST) xs -toSolverSetLogic :: SMTConverter con ast out io => con -> Logic -> out-toSolverSetLogic = setLogic+toSolverAST ((:!) x) = function1 "not" $ toSolverAST x+toSolverAST (x :=> y) = function2 "=>" (toSolverAST x) (toSolverAST y)+toSolverAST (x :<=> y) = function2 "=" (toSolverAST x) (toSolverAST y) +toSolverAST (x :+ y) = function2 "+" (toSolverAST x) (toSolverAST y)+toSolverAST (x :- y) = function2 "-" (toSolverAST x) (toSolverAST y)+toSolverAST (x :* y) = function2 "*" (toSolverAST x) (toSolverAST y)+toSolverAST (x :/ y) = function2 "/" (toSolverAST x) (toSolverAST y)+toSolverAST (x `QuotSMT` y) = function2 "div" (toSolverAST x) (toSolverAST y)+toSolverAST (x `Modulo` y) = function2 "mod" (toSolverAST x) (toSolverAST y)+toSolverAST (AbsSMT x) = "(abs " <> toSolverAST x <> ")"+toSolverAST (SqrtSMT x) = "(^ " <> toSolverAST x <> " 0.5)"+toSolverAST (Neg x) = function1 "-" $ toSolverAST x++toSolverAST (ArrayConst v indS valS) =+ let+ sort_arr = "(Array " <> sortName indS <> " " <> sortName valS <> ")"+ in+ "((as const " <> sort_arr <> ") " <> (toSolverAST v) <> ")"++toSolverAST (ArraySelect arr ind) =+ function2 "select" (toSolverAST arr) (toSolverAST ind)++toSolverAST (ArrayStore arr ind val) =+ function3 "store" (toSolverAST arr) (toSolverAST ind) (toSolverAST val)++toSolverAST (Func n xs) = smtFunc n $ map (toSolverAST) xs++toSolverAST (x :++ y) = function2 "str.++" (toSolverAST x) (toSolverAST y)+toSolverAST (FromInt x) = function1 "str.from_int" $ toSolverAST x+toSolverAST (StrLenSMT x) = function1 "str.len" $ toSolverAST x+toSolverAST (ItoR x) = function1 "to_real" $ toSolverAST x++toSolverAST (Ite x y z) =+ function3 "ite" (toSolverAST x) (toSolverAST y) (toSolverAST z)++toSolverAST (FromCode chr) = function1 "str.from_code" (toSolverAST chr)+toSolverAST (ToCode chr) = function1 "str.to_code" (toSolverAST chr)++toSolverAST (VInt i) = if i >= 0 then showText i else "(- " <> showText (abs i) <> ")"+toSolverAST (VFloat f) = "(/ " <> showText (numerator f) <> " " <> showText (denominator f) <> ")"+toSolverAST (VDouble d) = "(/ " <> showText (numerator d) <> " " <> showText (denominator d) <> ")"+toSolverAST (VChar c) = "\"" <> TB.string [c] <> "\""+toSolverAST (VBool b) = if b then "true" else "false"+toSolverAST (V n _) = TB.string n++toSolverAST (Named x n) = "(! " <> toSolverAST x <> " :named " <> TB.string n <> ")"++toSolverAST ast = error $ "toSolverAST: invalid SMTAST: " ++ show ast++smtFunc :: String -> [TB.Builder] -> TB.Builder+smtFunc n [] = TB.string n+smtFunc n xs = "(" <> TB.string n <> " " <> TB.intercalate " " xs <> ")"++{-# INLINE showText #-}+showText :: Show a => a -> TB.Builder+showText = TB.string . show++functionList :: TB.Builder -> [TB.Builder] -> TB.Builder+functionList f xs = "(" <> f <> " " <> (TB.intercalate " " xs) <> ")" ++function1 :: TB.Builder -> TB.Builder -> TB.Builder+function1 f a = "(" <> f <> " " <> a <> ")"++{-# INLINE function2 #-}+function2 :: TB.Builder -> TB.Builder -> TB.Builder -> TB.Builder+function2 f a b = "(" <> f <> " " <> a <> " " <> b <> ")"++function3 :: TB.Builder -> TB.Builder -> TB.Builder -> TB.Builder -> TB.Builder+function3 f a b c = "(" <> f <> " " <> a <> " " <> b <> " " <> c <> ")"++toSolverVarDecl :: SMTNameBldr -> Sort -> TB.Builder+toSolverVarDecl n s = "(declare-const " <> n <> " " <> sortName s <> ")"++sortName :: Sort -> TB.Builder+sortName SortInt = "Int"+sortName SortFloat = "Real"+sortName SortDouble = "Real"+sortName SortString = "String"+sortName SortChar = "String"+sortName SortBool = "Bool"+sortName (SortArray ind val) = "(Array " <> sortName ind <> " " <> sortName val <> ")"+sortName _ = error "sortName: unsupported Sort"++toSolverSetLogic :: Logic -> TB.Builder+toSolverSetLogic lgc =+ let+ s = case lgc of+ QF_LIA -> "QF_LIA"+ QF_LRA -> "QF_LRA"+ QF_LIRA -> "QF_LIRA"+ QF_NIA -> "QF_NIA"+ QF_NRA -> "QF_NRA"+ QF_NIRA -> "QF_NIRA"+ QF_UFLIA -> "QF_UFLIA"+ _ -> "ALL"+ in+ "(set-logic " <> s <> ")"+ -- | Converts an `SMTAST` to an `Expr`.-smtastToExpr :: SMTAST -> Expr-smtastToExpr (VInt i) = (Lit $ LitInt i)-smtastToExpr (VFloat f) = (Lit $ LitFloat f)-smtastToExpr (VDouble d) = (Lit $ LitDouble d)-smtastToExpr (VBool b) =- Data (DataCon (Name (T.pack $ show b) Nothing 0 Nothing) (TyCon (Name "Bool" Nothing 0 Nothing) TYPE))-smtastToExpr (VChar c) = Lit $ LitChar c-smtastToExpr (V n s) = Var $ Id (strToName n) (sortToType s)-smtastToExpr _ = error "Conversion of this SMTAST to an Expr not supported."+smtastToExpr :: KnownValues -> TypeEnv -> SMTAST -> Expr+smtastToExpr _ _ (VInt i) = (Lit $ LitInt i)+smtastToExpr _ _ (VFloat f) = (Lit $ LitFloat f)+smtastToExpr _ _ (VDouble d) = (Lit $ LitDouble d)+smtastToExpr kv _ (VBool True) = mkTrue kv+smtastToExpr kv _ (VBool False) = mkFalse kv+smtastToExpr kv tenv (VString cs) = mkG2List kv tenv (tyChar kv) $ map (App (mkDCChar kv tenv) . Lit . LitChar) cs+smtastToExpr _ _ (VChar c) = Lit $ LitChar c+smtastToExpr _ _ (V n s) = Var $ Id (certainStrToName n) (sortToType s)+smtastToExpr _ _ _ = error "Conversion of this SMTAST to an Expr not supported." -- | Converts a `Sort` to an `Type`. sortToType :: Sort -> Type@@ -512,7 +613,14 @@ sortToType (SortDouble) = TyLitDouble sortToType (SortChar) = TyLitChar sortToType (SortBool) = TyCon (Name "Bool" Nothing 0 Nothing) TYPE+sortToType _ = error "Conversion of this Sort to a Type not supported." -- | Coverts an `SMTModel` to a `Model`.-modelAsExpr :: SMTModel -> Model-modelAsExpr = M.mapKeys strToName . M.map smtastToExpr+modelAsExpr :: KnownValues -> TypeEnv ->SMTModel -> Model+modelAsExpr kv tenv = HM.fromList . M.toList . M.mapKeys strToName . M.map (smtastToExpr kv tenv)++certainStrToName :: String -> Name+certainStrToName s =+ case maybe_StrToName s of+ Just n -> n+ Nothing -> Name (T.pack s) Nothing 0 Nothing
src/G2/Solver/Interface.hs view
@@ -15,75 +15,94 @@ import G2.Solver.Converters import G2.Solver.Solver -import Data.Maybe (mapMaybe)-import qualified Data.Map as M+import Data.Function+import qualified Data.List as L+import Data.Maybe (mapMaybe, isJust, fromJust)+import qualified Data.HashMap.Lazy as HM+import qualified Data.Sequence as S -subModel :: State t -> Bindings -> ([Expr], Expr, Maybe FuncCall)+subModel :: State t -> Bindings -> ([Expr], Expr, Maybe FuncCall, S.Seq Expr) subModel (State { expr_env = eenv , curr_expr = CurrExpr _ cexpr , assert_ids = ais , type_classes = tc- , model = m}) + , model = m+ , sym_gens = gens }) (Bindings {input_names = inputNames}) = let- ais' = fmap (subVarFuncCall m eenv tc) ais+ ais' = fmap (subVarFuncCall True m eenv tc) ais - -- We do not inline Lambdas, because higher order function arguments+ -- We do not inline all Lambdas, because higher order function arguments -- get preinserted into the model. -- See [Higher-Order Model] in G2.Execution.Reducers- is = mapMaybe (\n -> case E.lookup n eenv of+ is = mapMaybe toVars inputNames+ gs = fmap fromJust . S.filter isJust $ fmap toVars gens+ + sv = subVar False m eenv tc (is, cexpr, ais', gs)+ in+ untilEq (simplifyLams . pushCaseAppArgIn) sv+ where+ toVars n = case E.lookup n eenv of Just e@(Lam _ _ _) -> Just . Var $ Id n (typeOf e) Just e -> Just e- Nothing -> Nothing) inputNames- in- filterTC tc $ subVar m eenv tc (is, cexpr, ais')+ Nothing -> Nothing -subVarFuncCall :: Model -> ExprEnv -> TypeClasses -> FuncCall -> FuncCall-subVarFuncCall em eenv tc fc@(FuncCall {arguments = ars}) =- subVar em eenv tc $ fc {arguments = filter (not . isTC tc) ars}+ untilEq f x = let x' = f x in if x == x' then x' else untilEq f x' -subVar :: (ASTContainer m Expr) => Model -> ExprEnv -> TypeClasses -> m -> m-subVar em eenv tc = modifyContainedASTs (subVar' em eenv tc []) . filterTC tc+subVarFuncCall :: Bool -> Model -> ExprEnv -> TypeClasses -> FuncCall -> FuncCall+subVarFuncCall inLam em eenv tc fc@(FuncCall {arguments = ars}) =+ subVar inLam em eenv tc $ fc {arguments = filter (not . isTC tc) ars} -subVar' :: Model -> ExprEnv -> TypeClasses -> [Id] -> Expr -> Expr-subVar' em eenv tc is v@(Var i@(Id n _))+subVar :: (ASTContainer m Expr) => Bool -> Model -> ExprEnv -> TypeClasses -> m -> m+subVar inLam em eenv tc = modifyContainedASTs (subVar' inLam em eenv tc [])++subVar' :: Bool -> Model -> ExprEnv -> TypeClasses -> [Id] -> Expr -> Expr+subVar' inLam em eenv tc is v@(Var i@(Id n _)) | i `notElem` is- , Just e <- M.lookup n em =- subVar' em eenv tc (i:is) $ filterTC tc e+ , Just e <- HM.lookup n em =+ subVar' inLam em eenv tc (i:is) e | i `notElem` is , Just e <- E.lookup n eenv- , (isExprValueForm eenv e && notLam e) || isApp e || isVar e =- subVar' em eenv tc (i:is) $ filterTC tc e+ -- We want to inline a lambda only if inLam is true (we want to inline all lambdas),+ -- or if it's module is Nothing (and its name is likely uninteresting/unknown to the user)+ , (isExprValueForm eenv e && (notLam e || inLam || nameModule n == Nothing)) || isApp e || isVar e || isLitCase e =+ subVar' inLam em eenv tc (i:is) e | otherwise = v-subVar' em eenv tc is e = modifyChildren (subVar' em eenv tc is) e--notLam :: Expr -> Bool-notLam (Lam _ _ _) = False-notLam _ = True+subVar' inLam mdl eenv tc is cse@(Case e _ _ as) =+ case subVar' inLam mdl eenv tc is e of+ Lit l+ | Just (Alt _ ae) <- L.find (\(Alt (LitAlt l') _) -> l == l') as ->+ subVar' inLam mdl eenv tc is ae+ _ -> modifyChildren (subVar' inLam mdl eenv tc is) cse+subVar' inLam em eenv tc is e = modifyChildren (subVar' inLam em eenv tc is) e isApp :: Expr -> Bool isApp (App _ _) = True isApp _ = False +notLam :: Expr -> Bool+notLam (Lam _ _ _) = False+notLam _ = True+ isVar :: Expr -> Bool isVar (Var _) = True isVar _ = False -filterTC :: ASTContainer m Expr => TypeClasses -> m -> m-filterTC tc = modifyASTs (filterTC' tc)--filterTC' :: TypeClasses -> Expr -> Expr-filterTC' tc a@(App e e') =- case tcCenter tc $ typeOf e' of- True -> filterTC' tc e - False -> a-filterTC' _ e = e--tcCenter :: TypeClasses -> Type -> Bool-tcCenter tc (TyCon n _) = isTypeClassNamed n tc-tcCenter tc (TyFun t _) = tcCenter tc t-tcCenter _ _ = False+isLitCase :: Expr -> Bool+isLitCase (Case e _ _ _) = isPrimType (typeOf e)+isLitCase _ = False isTC :: TypeClasses -> Expr -> Bool isTC tc (Var (Id _ (TyCon n _))) = isTypeClassNamed n tc isTC _ _ = False++-- | Rewrites a case statement returning a function type, and applied to a variable argument,+-- so that the variable argument is moved into each branch of the case statement.+-- This composes with `simplifyLams` to get better simplication for symbolic function concretizations.+pushCaseAppArgIn :: ASTContainer c Expr => c -> c+pushCaseAppArgIn = modifyASTs pushCaseAppArgIn'++pushCaseAppArgIn' :: Expr -> Expr+pushCaseAppArgIn' (App (Case scrut bind t as) v@(Var _)) =+ Case scrut bind t $ map (\(Alt am e) -> Alt am (App e v) ) as+pushCaseAppArgIn' e = e
src/G2/Solver/Language.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveGeneric #-} module G2.Solver.Language ( module G2.Solver.Language@@ -12,59 +13,91 @@ import G2.Language.AST import G2.Solver.Solver +import GHC.Generics (Generic)+import Data.Hashable+import qualified Data.HashSet as HS import qualified Data.Map as M+import Text.Builder+import qualified Data.Text as T +type SMTNameBldr = Builder type SMTName = String --- | These define the two kinds of top level calls we give to the SMT solver.--- An assertion says the given SMTAST is true--- A sort decl declares a new sort.-data SMTHeader = Assert SMTAST- | VarDecl SMTName Sort+-- | These define the kinds of top level calls we give to the SMT solver.+data SMTHeader = Assert !SMTAST+ | AssertSoft !SMTAST (Maybe T.Text)+ | Minimize !SMTAST+ | DefineFun SMTName [(SMTName, Sort)] Sort !SMTAST+ | DeclareFun SMTName [Sort] Sort+ | VarDecl SMTNameBldr Sort | SetLogic Logic- deriving (Show, Eq)+ | Comment String+ deriving (Show) -- | Various logics supported by (some) SMT solvers -data Logic = ALL | QF_LIA | QF_LRA | QF_NIA | QF_NRA | QF_LIRA | QF_NIRA deriving (Show, Eq)+data Logic = ALL+ | QF_LIA+ | QF_LRA+ | QF_NIA+ | QF_NRA+ | QF_LIRA+ | QF_NIRA+ | QF_UFLIA + deriving (Show, Eq) -- | These correspond to first order logic, arithmetic operators, and variables, as supported by an SMT Solver -- Its use should be confined to interactions with G2.SMT.* -data SMTAST = (:>=) SMTAST SMTAST- | (:>) SMTAST SMTAST- | (:=) SMTAST SMTAST- | (:/=) SMTAST SMTAST- | (:<) SMTAST SMTAST- | (:<=) SMTAST SMTAST+data SMTAST = (:>=) !SMTAST !SMTAST+ | (:>) !SMTAST !SMTAST+ | (:=) !SMTAST !SMTAST+ | (:/=) !SMTAST !SMTAST+ | (:<) !SMTAST !SMTAST+ | (:<=) !SMTAST !SMTAST - | (:&&) SMTAST SMTAST- | (:||) SMTAST SMTAST- | (:!) SMTAST- | (:=>) SMTAST SMTAST- | (:<=>) SMTAST SMTAST+ | SmtAnd ![SMTAST]+ | SmtOr ![SMTAST]+ | (:!) !SMTAST+ | (:=>) !SMTAST !SMTAST+ | (:<=>) !SMTAST !SMTAST - | (:+) SMTAST SMTAST- | (:-) SMTAST SMTAST -- ^ Subtraction- | (:*) SMTAST SMTAST- | (:/) SMTAST SMTAST- | SqrtSMT SMTAST- | QuotSMT SMTAST SMTAST- | Modulo SMTAST SMTAST- | Neg SMTAST -- ^ Unary negation+ | (:+) !SMTAST !SMTAST+ | (:-) !SMTAST !SMTAST -- ^ Subtraction+ | (:*) !SMTAST !SMTAST+ | (:/) !SMTAST !SMTAST+ | AbsSMT !SMTAST+ | SqrtSMT !SMTAST+ | QuotSMT !SMTAST !SMTAST+ | Modulo !SMTAST !SMTAST+ | Neg !SMTAST -- ^ Unary negation - | StrLen SMTAST+ | ArrayConst !SMTAST Sort Sort+ | ArrayStore !SMTAST !SMTAST !SMTAST+ | ArraySelect !SMTAST !SMTAST - | Ite SMTAST SMTAST SMTAST- | SLet (SMTName, SMTAST) SMTAST+ | Func SMTName ![SMTAST] -- ^ Interpreted function + | (:++) !SMTAST !SMTAST -- ^ String append+ | FromInt !SMTAST -- ^ Convert Ints to Strings+ | StrLenSMT !SMTAST++ | Ite !SMTAST !SMTAST !SMTAST+ | SLet (SMTName, SMTAST) !SMTAST++ | FromCode !SMTAST+ | ToCode !SMTAST+ | VInt Integer | VFloat Rational | VDouble Rational | VChar Char+ | VString String | VBool Bool | V SMTName Sort - | ItoR SMTAST -- ^ Integer to real conversion+ | ItoR !SMTAST -- ^ Integer to real conversion++ | Named !SMTAST SMTName -- ^ Name a piece of the SMTAST, allowing it to be returned in unsat cores deriving (Show, Eq) -- | Every `SMTAST` has a `Sort`@@ -72,14 +105,64 @@ | SortFloat | SortDouble | SortChar+ | SortString | SortBool- deriving (Show, Eq)+ | SortArray Sort Sort+ | SortFunc [Sort] Sort+ deriving (Show, Eq, Ord, Generic) -isSat :: Result -> Bool-isSat SAT = True+instance Hashable Sort++(.=.) :: SMTAST -> SMTAST -> SMTAST+x .=. y+ | x == y = VBool True+ | otherwise = x := y++(.&&.) :: SMTAST -> SMTAST -> SMTAST+(VBool True) .&&. x = x+x .&&. (VBool True) = x+(VBool False) .&&. _ = VBool False+_ .&&. (VBool False) = VBool False+x .&&. y = SmtAnd [x, y]++(.||.) :: SMTAST -> SMTAST -> SMTAST+(VBool True) .||. _ = VBool True+_ .||. (VBool True) = VBool True+(VBool False) .||. x = x+x .||. (VBool False) = x+x .||. y = SmtOr [x, y]++mkSMTAnd :: [SMTAST] -> SMTAST+mkSMTAnd = SmtAnd++mkSMTOr :: [SMTAST] -> SMTAST+mkSMTOr = SmtOr++isSat :: Result m u um -> Bool+isSat (SAT _) = True isSat _ = False +mkSMTEmptyArray :: Sort -> Sort -> SMTAST+mkSMTEmptyArray = ArrayConst (VBool False)++mkSMTUniversalArray :: Sort -> Sort -> SMTAST+mkSMTUniversalArray = ArrayConst (VBool True)++mkSMTUnion :: SMTAST -> SMTAST -> SMTAST+mkSMTUnion s1 s2 = Func "union" [s1, s2]++mkSMTIntersection :: SMTAST -> SMTAST -> SMTAST+mkSMTIntersection s1 s2 = Func "intersection" [s1, s2]++mkSMTSingleton :: SMTAST -> Sort -> Sort -> SMTAST+mkSMTSingleton mem srt srt2 =+ ArrayStore (ArrayConst (VBool False) srt srt2) mem (VBool True)++mkSMTIsSubsetOf :: SMTAST -> SMTAST -> SMTAST+mkSMTIsSubsetOf s1 s2 = Func "subset" [s1, s2]+ type SMTModel = M.Map SMTName SMTAST+type UnsatCore = HS.HashSet SMTName instance AST SMTAST where children (x :>= y) = [x, y]@@ -89,8 +172,8 @@ children (x :< y) = [x, y] children (x :<= y) = [x, y] - children (x :&& y) = [x, y]- children (x :|| y) = [x, y]+ children (SmtAnd xs) = xs+ children (SmtOr xs) = xs children ((:!) x) = [x] children (x :=> y) = [x, y] children (x :<=> y) = [x, y]@@ -104,6 +187,9 @@ children (Ite x x' x'') = [x, x', x''] children (SLet (_, x) x') = [x, x'] + children (FromCode x) = [x]+ children (ToCode x) = [x]+ children _ = [] modifyChildren f (x :>= y) = f x :>= f y@@ -113,8 +199,8 @@ modifyChildren f (x :< y) = f x :< f y modifyChildren f (x :<= y) = f x :<= f y - modifyChildren f (x :&& y) = f x :&& f y- modifyChildren f (x :|| y) = f x :|| f y+ modifyChildren f (SmtAnd xs) = SmtAnd (map f xs)+ modifyChildren f (SmtOr xs) = SmtOr (map f xs) modifyChildren f ((:!) x) = (:!) (f x) modifyChildren f (x :=> y) = f x :=> f y @@ -124,6 +210,9 @@ modifyChildren f (x :/ y) = f x :/ f y modifyChildren f (Neg x) = Neg (f x) + modifyChildren f (FromCode x) = FromCode (f x)+ modifyChildren f (ToCode x) = ToCode (f x)+ modifyChildren f (Ite x x' x'') = Ite (f x) (f x') (f x'') modifyChildren f (SLet (n, x) x') = SLet (n, f x) (f x') @@ -134,11 +223,19 @@ modifyChildren _ s = s +-- | DefineFun SMTName [(SMTName, Sort)] Sort !SMTAST+ instance ASTContainer SMTHeader SMTAST where containedASTs (Assert a) = [a]+ containedASTs (AssertSoft a _) = [a]+ containedASTs (Minimize a) = [a]+ containedASTs (DefineFun _ _ _ a) = [a] containedASTs _ = [] modifyContainedASTs f (Assert a) = Assert (f a)+ modifyContainedASTs f (AssertSoft a lbl) = AssertSoft (f a) lbl+ modifyContainedASTs f (Minimize a) = Minimize (f a)+ modifyContainedASTs f (DefineFun n ars r a) = DefineFun n ars r (f a) modifyContainedASTs _ s = s instance ASTContainer SMTAST Sort where@@ -148,3 +245,11 @@ modifyContainedASTs f (V n s) = V n (modify f s) modifyContainedASTs f x = modify (modifyContainedASTs f) x +sortOf :: SMTAST -> Sort+sortOf (VInt _) = SortInt+sortOf (VFloat _) = SortFloat+sortOf (VDouble _) = SortDouble+sortOf (VString _) = SortString+sortOf (VChar _) = SortChar +sortOf (VBool _) = SortBool+sortOf _ = error "sortOf: Unhandled SMTAST"
+ src/G2/Solver/Maximize.hs view
@@ -0,0 +1,161 @@+module G2.Solver.Maximize ( MaximizeSolver+ , mkMaximizeSolver) where++import G2.Solver.Converters+import G2.Solver.Language+import G2.Solver.Solver++import Control.Concurrent+import Data.IORef+import Data.List as L+import qualified Data.Map as M+import Text.Builder++data MaximizeSolver con = MaxSolver (MVar ThreadId) (MVar (Result () () ())) (IORef [SMTHeader]) con++mkMaximizeSolver :: SMTConverter con => con -> IO (MaximizeSolver con)+mkMaximizeSolver con = do+ thread_mvar <- newEmptyMVar+ res_mvar <- newEmptyMVar+ headers_io_ref <- newIORef []+ return $ MaxSolver thread_mvar res_mvar headers_io_ref con++instance SMTConverter con => Solver (MaximizeSolver con) where+ check solver _ pc = checkConstraintsPC solver pc+ solve (MaxSolver _ _ _ con) = solve con+ close = closeIO++instance SMTConverter con => SMTConverter (MaximizeSolver con) where+ closeIO (MaxSolver thread_ioref _ _ con) = do+ maybe (return ()) killThread =<< tryReadMVar thread_ioref+ closeIO con++ reset (MaxSolver thread_mvar res_mvar headers_io_ref con) = do+ maybe (return ()) killThread =<< tryReadMVar thread_mvar+ _ <- tryTakeMVar thread_mvar+ _ <- tryTakeMVar res_mvar+ writeIORef headers_io_ref []+ reset con++ checkSatInstr (MaxSolver thread_mvar res_mvar headers_io_ref con) = do+ maybe (return ()) killThread =<< tryReadMVar thread_mvar+ added <- readIORef headers_io_ref+ thread <- forkIO (do+ res <- solveSoftAsserts con added+ definitelyPutMVar res_mvar res)+ definitelyPutMVar thread_mvar thread+ return ()++ maybeCheckSatResult (MaxSolver _ res_ioref _ _) = tryReadMVar res_ioref++ getModelInstrResult (MaxSolver _ _ _ con) = getModelInstrResult con+ getUnsatCoreInstrResult (MaxSolver _ _ _ con) = getUnsatCoreInstrResult con++ setProduceUnsatCores (MaxSolver _ _ _ con) = setProduceUnsatCores con++ addFormula (MaxSolver _ _ headers_io_ref _) form = modifyIORef' headers_io_ref (form ++)++ checkSatGetModelOrUnsatCoreNoReset (MaxSolver _ _ headers_io_ref con) headers vs = do+ added <- readIORef headers_io_ref+ res <- solveSoftAsserts con (added ++ headers)+ case res of+ SAT _ -> do+ mdl <- getModelInstrResult con vs+ return (SAT mdl)+ UNSAT _ -> do+ uc <- getUnsatCoreInstrResult con+ return (UNSAT uc)+ Unknown err _ -> return (Unknown err ())++ -- We don't need to produce a model, because this resets, so we can just ignore all soft assertions+ checkSat max_solver@(MaxSolver _ _ _ con) headers = do+ reset max_solver+ checkSat con $ filter (\h -> case h of AssertSoft _ _ -> False; _ -> True) headers++ checkSatGetModel con@(MaxSolver _ _ _ _) headers vs = do+ reset con+ res <- solveSoftAsserts con headers+ case res of+ SAT _ -> do+ mdl <- getModelInstrResult con vs+ return (SAT mdl)+ UNSAT _ -> return (UNSAT ())+ Unknown err _ -> return (Unknown err ())++ push (MaxSolver _ _ _ con) = push con+ pop (MaxSolver _ _ _ con) = pop con++solveSoftAsserts :: SMTConverter con => con -> [SMTHeader] -> IO (Result () () ())+solveSoftAsserts con headers = do+ let (soft_asserts, other_headers) =+ partition (\h -> case h of AssertSoft _ _ -> True; _ -> False) $ elimSetLogic headers+ set_logic = getSetLogic headers+ soft_assert_sum =+ foldr (:+) (VInt 0)+ $ map (\(AssertSoft assrt _) -> Ite assrt (VInt 1) (VInt 0)) soft_asserts+ new_assert = Assert $ V totalVarName SortInt := soft_assert_sum+ var_decl = VarDecl (string totalVarName) SortInt+ setProduceUnsatCores con+ addHeaders con (set_logic ++ var_decl:other_headers ++ [new_assert])+ solveSoftAsserts' con Nothing 0 0 (genericLength soft_asserts)++type Minimum = Integer+type Maximum = Integer++solveSoftAsserts' :: SMTConverter con =>+ con+ -> Maybe SMTModel+ -> Int+ -> Minimum+ -> Maximum+ -> IO (Result () () ())+solveSoftAsserts' con mb_mdl fresh min_ max_ = do+ let (target_q, target_r) = (min_ + max_) `quotRem` 2+ target = target_q + target_r+ target_assert = Assert $ V totalVarName SortInt :>= VInt target++ putStrLn $ "min = " ++ show min_ ++ ", max = " ++ show max_ ++ ", target = " ++ show target+ push con+ res <- constraintsToModelOrUnsatCoreNoReset con [target_assert] [(totalVarName, SortInt)]+ case res of+ SAT mdl | Just (VInt new_min_) <- m_new_min+ , new_min_ == max_ -> return $ SAT ()+ | Just (VInt new_min_) <- m_new_min -> do+ -- If we are increasing the minimum depth, we do NOT want to remove+ -- our previous limit assertion, so that if we later get a model, that+ -- limit assertion is still in place.+ solveSoftAsserts' con (Just mdl) (fresh + 1) (new_min_ + 1) max_+ -- Should be unreachable because totalVarName should always be in the model+ | otherwise -> error "solveSoftAsserts': Impossible case"+ where+ m_new_min = M.lookup totalVarName mdl+ UNSAT _ | target == 0 -> return $ UNSAT ()+ | min_ == max_ -> do+ pop con+ -- get-model is only valid after a check-sat call that returns sat,+ -- so we must ensure that the last check-sat did indeed return sat.+ _ <- checkSatNoReset con []+ return $ SAT ()+ -- Should be unreachable, because if min_ is not 0, we have found a model.+ -- But if min_ == max_ == 0, target == 0, and we hit the first case.+ | min_ == max_ -> error "solveSoftAsserts': Impossible case"+ | otherwise -> do+ pop con+ solveSoftAsserts' con mb_mdl (fresh + 1) min_ (target - 1)+ Unknown err _ -> return $ Unknown err ()++definitelyPutMVar :: MVar a -> a -> IO ()+definitelyPutMVar mvar a = do+ r <- tryPutMVar mvar a+ case r of+ True -> return ()+ False -> modifyMVar_ mvar (\_ -> return a)++totalVarName :: SMTName+totalVarName = "solveSoftAsserts_SUM_VAR"++getSetLogic :: [SMTHeader] -> [SMTHeader]+getSetLogic = filter (\h -> case h of SetLogic _ -> True; _ -> False)++elimSetLogic :: [SMTHeader] -> [SMTHeader]+elimSetLogic = filter (\h -> case h of SetLogic _ -> False; _ -> True)
src/G2/Solver/ParseSMT.hs view
@@ -148,19 +148,30 @@ stringExpr :: Parser SMTAST stringExpr = do _ <- char '"'- str <- stringExpr'+ str <- many stringExpr' _ <- char '"'- return (VChar str)+ return (VString str) stringExpr' :: Parser Char stringExpr' = do- try parseHex <|> choice (alphaNum:char '\\':map char ident)+ try parseHex <|> try parseUni <|> choice (alphaNum:char '\\':char ' ':map char ident) parseHex :: Parser Char parseHex = do _ <- char '\\' _ <- char 'x' str <- many (choice . map char $ ['0'..'9'] ++ ['a'..'f'])+ case readHex str of+ [(c, _)] -> return $ chr c+ _ -> error $ "stringExpr': Bad string"++parseUni :: Parser Char+parseUni = do+ _ <- char '\\'+ _ <- char 'u'+ _ <- char '{'+ str <- many (choice . map char $ ['0'..'9'] ++ ['a'..'f'])+ _ <- char '}' case readHex str of [(c, _)] -> return $ chr c _ -> error $ "stringExpr': Bad string"
src/G2/Solver/SMT2.hs view
@@ -1,6 +1,7 @@ -- | This defines an SMTConverter for the SMT2 language -- It provides methods to construct formulas, as well as feed them to an external solver +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -9,24 +10,28 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} -module G2.Solver.SMT2 where+module G2.Solver.SMT2 ( Z3+ , CVC4+ , SomeSMTSolver (..)+ , getZ3+ , getSMT+ , getSMTAV) where import G2.Config.Config import G2.Language.ArbValueGen-import G2.Language.Expr-import G2.Language.Support-import G2.Language.Syntax hiding (Assert)-import G2.Language.Typing import G2.Solver.Language import G2.Solver.ParseSMT import G2.Solver.Solver import G2.Solver.Converters --It would be nice to not import this... import Control.Exception.Base (evaluate)-import Data.List import Data.List.Utils (countElem)+import qualified Data.HashSet as HS import qualified Data.Map as M-import Data.Ratio+import Data.Semigroup+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Text.Builder as TB import System.IO import System.Process @@ -34,279 +39,246 @@ data CVC4 = CVC4 ArbValueFunc (Handle, Handle, ProcessHandle) data SomeSMTSolver where- SomeSMTSolver :: forall con ast out io - . SMTConverter con ast out io => con -> SomeSMTSolver+ SomeSMTSolver :: forall con+ . SMTConverter con => con -> SomeSMTSolver instance Solver Z3 where- check solver _ pc = checkConstraints solver pc- solve con@(Z3 avf _) = checkModel avf con+ check solver _ pc = checkConstraintsPC solver pc+ solve con@(Z3 avf _) = checkModelPC avf con close = closeIO instance Solver CVC4 where- check solver _ pc = checkConstraints solver pc- solve con@(CVC4 avf _) = checkModel avf con+ check solver _ pc = checkConstraintsPC solver pc+ solve con@(CVC4 avf _) = checkModelPC avf con close = closeIO -instance SMTConverter Z3 String String (Handle, Handle, ProcessHandle) where- getIO (Z3 _ hhp) = hhp- closeIO (Z3 _ (h_in, _, _)) = hPutStr h_in "(exit)"+getIOZ3 :: Z3 -> (Handle, Handle, ProcessHandle)+getIOZ3 (Z3 _ hhp) = hhp - empty _ = "" - merge _ = (++)+instance SMTConverter Z3 where+ closeIO (Z3 _ (h_in, h_out, ph)) = do+#if MIN_VERSION_process(1,6,4)+ cleanupProcess (Just h_in, Just h_out, Nothing, ph)+#else+ T.hPutStrLn h_in "(exit)"+ _ <- waitForProcess ph+ hClose h_in+ hClose h_out+#endif - checkSat _ (h_in, h_out, _) formula = do+ reset con = do+ let (h_in, _, _) = getIOZ3 con+ T.hPutStr h_in "(reset)"++ checkSatInstr con = do+ let (h_in, _, _) = getIOZ3 con+ T.hPutStrLn h_in "(check-sat)"++ maybeCheckSatResult con = do+ let (_, h_out, _) = getIOZ3 con+ r <- hReady h_out+ case r of+ True -> return . Just =<< checkSatReadResult h_out+ False -> return Nothing++ getModelInstrResult con vs = do+ let (h_in, h_out, _) = getIOZ3 con+ mdl <- getModelZ3 h_in h_out vs+ -- putStrLn "======"+ -- putStrLn (show mdl)+ let m = parseModel mdl+ -- putStrLn $ "m = " ++ show m+ -- putStrLn "======"+ return m++ getUnsatCoreInstrResult con = do+ let (h_in, h_out, _) = getIOZ3 con+ uc <- getUnsatCoreZ3 h_in h_out+ return (HS.fromList uc)++ setProduceUnsatCores con = do+ let (h_in, _, _) = getIOZ3 con+ T.hPutStrLn h_in "(set-option :produce-unsat-cores true)"++ addFormula con form = do+ let (h_in, _, _) = getIOZ3 con+ T.hPutStrLn h_in (TB.run $ toSolverText form)++ checkSatNoReset con formula = do+ let (h_in, h_out, _) = getIOZ3 con -- putStrLn "checkSat"- -- putStrLn formula - setUpFormulaZ3 h_in formula+ T.hPutStrLn h_in (TB.run $ toSolverText formula) r <- checkSat' h_in h_out + -- T.putStrLn (TB.run $ toSolverText formula) -- putStrLn $ show r return r - checkSatGetModel _ (h_in, h_out, _) formula _ vs = do- setUpFormulaZ3 h_in formula+ checkSatGetModel con formula vs = do+ let (h_in, h_out, _) = getIOZ3 con+ setUpFormulaZ3 h_in (TB.run $ toSolverText formula) -- putStrLn "\n\n checkSatGetModel"- -- putStrLn formula+ -- T.putStrLn (TB.run $ toSolverText formula) r <- checkSat' h_in h_out -- putStrLn $ "r = " ++ show r- if r == SAT then do- mdl <- getModelZ3 h_in h_out vs- -- putStrLn "======"- -- putStrLn (show mdl)- let m = parseModel mdl- -- putStrLn $ "m = " ++ show m- -- putStrLn "======"- return (r, Just m)- else do- return (r, Nothing)+ case r of+ SAT () -> do+ mdl <- getModelZ3 h_in h_out vs+ -- putStrLn "======"+ -- putStrLn (show mdl)+ let m = parseModel mdl+ -- putStrLn $ "m = " ++ show m+ -- putStrLn "======"+ return $ SAT m+ UNSAT () -> return $ UNSAT ()+ Unknown s _ -> return $ Unknown s () - checkSatGetModelGetExpr con (h_in, h_out, _) formula _ vs eenv (CurrExpr _ e) = do- setUpFormulaZ3 h_in formula- -- putStrLn "\n\n checkSatGetModelGetExpr"- -- putStrLn formula+ checkSatGetModelOrUnsatCoreNoReset con formula vs = do+ let (h_in, h_out, _) = getIOZ3 con+ let formula' = TB.run $ toSolverText formula+ T.putStrLn "\n\n checkSatGetModelOrUnsatCore"+ T.putStrLn formula'++ T.hPutStr h_in formula' r <- checkSat' h_in h_out -- putStrLn $ "r = " ++ show r- if r == SAT then do+ if r == SAT () then do mdl <- getModelZ3 h_in h_out vs -- putStrLn "======"- -- putStrLn formula- -- putStrLn ""+ -- putStrLn $ "r = " ++ show r+ -- putStrLn $ "mdl = " ++ show mdl -- putStrLn (show mdl)- -- putStrLn "======" let m = parseModel mdl-- expr <- solveExpr h_in h_out con eenv e- -- putStrLn (show expr)- return (r, Just m, Just expr)+ -- putStrLn $ "m = " ++ show m+ -- putStrLn "======"+ return (SAT m)+ else if r == UNSAT () then do+ uc <- getUnsatCoreZ3 h_in h_out+ return (UNSAT $ HS.fromList uc) else do- return (r, Nothing, Nothing)-- assert _ = function1 "assert"- - varDecl _ n s = "(declare-const " ++ n ++ " " ++ s ++ ")"- - setLogic _ lgc =- let - s = case lgc of- QF_LIA -> "QF_LIA"- QF_LRA -> "QF_LRA"- QF_LIRA -> "QF_LIRA"- QF_NIA -> "QF_NIA"- QF_NRA -> "QF_NRA"- QF_NIRA -> "QF_NIRA"- _ -> "ALL"- in- case lgc of- ALL -> ""- _ -> "(set-logic " ++ s ++ ")"+ return (Unknown "" ()) - (.>=) _ = function2 ">="- (.>) _ = function2 ">"- (.=) _ = function2 "="- (./=) _ x = function1 "not" . function2 "=" x- (.<=) _ = function2 "<="- (.<) _ = function2 "<"+ push con = do+ let (h_in, _, _) = getIOZ3 con+ T.hPutStrLn h_in "(push)" - (.&&) _ = function2 "and"- (.||) _ = function2 "or"- (.!) _ = function1 "not"- (.=>) _ = function2 "=>"- (.<=>) _ = function2 "="+ pop con = do+ let (h_in, _, _) = getIOZ3 con+ T.hPutStrLn h_in "(pop)" - (.+) _ = function2 "+"- (.-) _ = function2 "-"- (.*) _ = function2 "*"- (./) _ = function2 "/"- smtQuot _ = function2 "div"- smtModulo _ = function2 "mod"- smtSqrt _ x = "(^ " ++ x ++ " 0.5)" - neg _ = function1 "-"- strLen _ = function1 "str.len"+getIOCVC4 :: CVC4 -> (Handle, Handle, ProcessHandle)+getIOCVC4 (CVC4 _ hhp) = hhp - itor _ = function1 "to_real"+instance SMTConverter CVC4 where+ closeIO (CVC4 _ (h_in, h_out, ph)) = do+ hPutStrLn h_in "(exit)"+ _ <- waitForProcess ph+ hClose h_in+ hClose h_out + reset con = do+ let (h_in, _, _) = getIOCVC4 con+ T.hPutStr h_in "(reset)" - ite _ = function3 "ite"+ checkSatInstr con = do+ let (h_in, _, _) = getIOCVC4 con+ T.hPutStrLn h_in "(check-sat)" - int _ x = if x >= 0 then show x else "(- " ++ show (abs x) ++ ")"- float _ r = - "(/ " ++ show (numerator r) ++ " " ++ show (denominator r) ++ ")"- double _ r =- "(/ " ++ show (numerator r) ++ " " ++ show (denominator r) ++ ")"- char _ c = '"':c:'"':[]- bool _ b = if b then "true" else "false"- var _ n = function1 n+ maybeCheckSatResult con = do+ let (_, h_out, _) = getIOCVC4 con+ r <- hReady h_out+ case r of+ True -> return . Just =<< checkSatReadResult h_out+ False -> return Nothing - sortInt _ = "Int"- sortFloat _ = "Real"- sortDouble _ = "Real"- sortChar _ = "String"- sortBool _ = "Bool"+ getModelInstrResult con vs = do+ let (h_in, h_out, _) = getIOCVC4 con+ mdl <- getModelCVC4 h_in h_out vs+ -- putStrLn "======"+ -- putStrLn (show mdl)+ let m = parseModel mdl+ -- putStrLn $ "m = " ++ show m+ -- putStrLn "======"+ return m - cons _ n asts _ =- if asts /= [] then- "(" ++ n ++ " " ++ (intercalate " " asts) ++ ")" - else- n- varName _ n _ = n+ getUnsatCoreInstrResult con = do+ let (h_in, h_out, _) = getIOCVC4 con+ uc <- getUnsatCoreCVC4 h_in h_out+ return (HS.fromList uc) -instance SMTConverter CVC4 String String (Handle, Handle, ProcessHandle) where- getIO (CVC4 _ hhp) = hhp- closeIO (CVC4 _ (h_in, _, _)) = hPutStr h_in "(exit)"+ setProduceUnsatCores _ = return () - empty _ = "" - merge _ = (++)+ addFormula con form = do+ let (h_in, _, _) = getIOCVC4 con+ T.hPutStrLn h_in (TB.run $ toSolverText form) - checkSat _ (h_in, h_out, _) formula = do+ checkSatNoReset con formula = do+ let (h_in, h_out, _) = getIOCVC4 con -- putStrLn "checkSat"+ -- let formula = run formulaBldr+ -- T.putStrLn (TB.run formula) -- putStrLn formula - setUpFormulaCVC4 h_in formula+ T.hPutStrLn h_in (TB.run $ toSolverText formula) r <- checkSat' h_in h_out -- putStrLn $ show r return r - checkSatGetModel _ (h_in, h_out, _) formula _ vs = do- setUpFormulaCVC4 h_in formula+ checkSatGetModel con formula vs = do+ let (h_in, h_out, _) = getIOCVC4 con+ setUpFormulaCVC4 h_in (TB.run $ toSolverText formula) -- putStrLn "\n\n checkSatGetModel" -- putStrLn formula r <- checkSat' h_in h_out -- putStrLn $ "r = " ++ show r- if r == SAT then do- mdl <- getModelCVC4 h_in h_out vs- -- putStrLn "======"- -- putStrLn (show mdl)- let m = parseModel mdl- -- putStrLn $ "m = " ++ show m- -- putStrLn "======"- return (r, Just m)- else do- return (r, Nothing)+ case r of+ SAT _ -> do+ mdl <- getModelCVC4 h_in h_out vs+ -- putStrLn "======"+ -- putStrLn (show mdl)+ let m = parseModel mdl+ -- putStrLn $ "m = " ++ show m+ -- putStrLn "======"+ return (SAT m)+ UNSAT _ -> return $ UNSAT ()+ Unknown s _ -> return $ Unknown s () - checkSatGetModelGetExpr con (h_in, h_out, _) formula _ vs eenv (CurrExpr _ e) = do- setUpFormulaCVC4 h_in formula- -- putStrLn "\n\n checkSatGetModelGetExpr"- -- putStrLn formula+ checkSatGetModelOrUnsatCoreNoReset con formula vs = do+ let (h_in, h_out, _) = getIOCVC4 con+ let formula' = TB.run $ toSolverText formula+ T.putStrLn "\n\n checkSatGetModelOrUnsatCore"+ T.putStrLn formula'++ T.hPutStr h_in formula' r <- checkSat' h_in h_out- -- putStrLn $ "r = " ++ show r- if r == SAT then do+ putStrLn $ "r = " ++ show r+ if r == SAT () then do mdl <- getModelCVC4 h_in h_out vs -- putStrLn "======"- -- putStrLn formula- -- putStrLn ""+ -- putStrLn $ "r = " ++ show r+ -- putStrLn $ "mdl = " ++ show mdl -- putStrLn (show mdl)- -- putStrLn "======" let m = parseModel mdl-- expr <- solveExpr h_in h_out con eenv e- -- putStrLn (show expr)- return (r, Just m, Just expr)+ -- putStrLn $ "m = " ++ show m+ -- putStrLn "======"+ return (SAT m)+ else if r == UNSAT () then do+ uc <- getUnsatCoreCVC4 h_in h_out+ return (UNSAT $ HS.fromList uc) else do- return (r, Nothing, Nothing)-- assert _ = function1 "assert"- - varDecl _ n s = "(declare-const " ++ n ++ " " ++ s ++ ")"- - setLogic _ lgc =- let - s = case lgc of- QF_LIA -> "QF_LIA"- QF_LRA -> "QF_LRA"- QF_LIRA -> "QF_LIRA"- QF_NIA -> "QF_NIA"- QF_NRA -> "QF_NRA"- QF_NIRA -> "QF_NIRA"- _ -> "ALL"- in- case lgc of- ALL -> ""- _ -> "(set-logic " ++ s ++ ")"-- (.>=) _ = function2 ">="- (.>) _ = function2 ">"- (.=) _ = function2 "="- (./=) _ = \x -> function1 "not" . function2 "=" x- (.<=) _ = function2 "<="- (.<) _ = function2 "<"-- (.&&) _ = function2 "and"- (.||) _ = function2 "or"- (.!) _ = function1 "not"- (.=>) _ = function2 "=>"- (.<=>) _ = function2 "="-- (.+) _ = function2 "+"- (.-) _ = function2 "-"- (.*) _ = function2 "*"- (./) _ = function2 "/"- smtQuot _ = function2 "div"- smtModulo _ = function2 "mod"- smtSqrt _ x = "(^ " ++ x ++ " 0.5)" - neg _ = function1 "-"- strLen _ = function1 "str.len"-- itor _ = function1 "to_real"-- ite _ = function3 "ite"-- int _ x = if x >= 0 then show x else "(- " ++ show (abs x) ++ ")"- float _ r = - "(/ " ++ show (numerator r) ++ " " ++ show (denominator r) ++ ")"- double _ r =- "(/ " ++ show (numerator r) ++ " " ++ show (denominator r) ++ ")"- char _ c = '"':c:'"':[]- bool _ b = if b then "true" else "false"- var _ n = function1 n-- sortInt _ = "Int"- sortFloat _ = "Real"- sortDouble _ = "Real"- sortChar _ = "String"- sortBool _ = "Bool"-- cons _ n asts _ =- if asts /= [] then- "(" ++ n ++ " " ++ (intercalate " " asts) ++ ")" - else- n- varName _ n _ = n--functionList :: String -> [String] -> String-functionList f xs = "(" ++ f ++ " " ++ (intercalate " " xs) ++ ")" --function1 :: String -> String -> String-function1 f a = "(" ++ f ++ " " ++ a ++ ")"+ return (Unknown "" ()) -function2 :: String -> String -> String -> String-function2 f a b = "(" ++ f ++ " " ++ a ++ " " ++ b ++ ")"+ push con = do+ let (h_in, _, _) = getIOCVC4 con+ T.hPutStrLn h_in "(push)" -function3 :: String -> String -> String -> String -> String-function3 f a b c = "(" ++ f ++ " " ++ a ++ " " ++ b ++ " " ++ c ++ ")"+ pop con = do+ let (h_in, _, _) = getIOCVC4 con+ T.hPutStrLn h_in "(pop)" -- | getProcessHandles -- Ideally, this function should be called only once, and the same Handles should be used@@ -329,15 +301,18 @@ return (h_in, h_out, p) +getZ3 :: Int -> IO Z3+getZ3 time_out = do+ hhp@(h_in, _, _) <- getZ3ProcessHandles time_out+ hPutStr h_in "(set-option :pp.decimal true)"+ return $ Z3 arbValue hhp+ getSMT :: Config -> IO SomeSMTSolver getSMT = getSMTAV arbValue -getSMTInfinite :: Config -> IO SomeSMTSolver-getSMTInfinite = getSMTAV arbValueInfinite- getSMTAV :: ArbValueFunc -> Config -> IO SomeSMTSolver getSMTAV avf (Config {smt = ConZ3}) = do- hhp@(h_in, _, _) <- getZ3ProcessHandles+ hhp@(h_in, _, _) <- getZ3ProcessHandles 10000 hPutStr h_in "(set-option :pp.decimal true)" return $ SomeSMTSolver (Z3 avf hhp) getSMTAV avf (Config {smt = ConCVC4}) = do@@ -349,45 +324,46 @@ -- returned handles to interact with Z3 -- Ideally, this function should be called only once, and the same Handles should be used -- in all future calls-getZ3ProcessHandles :: IO (Handle, Handle, ProcessHandle)-getZ3ProcessHandles = getProcessHandles $ proc "z3" ["-smt2", "-in"]+getZ3ProcessHandles :: Int -> IO (Handle, Handle, ProcessHandle)+getZ3ProcessHandles time_out = getProcessHandles $ proc "z3" ["-smt2", "-in", "-t:" ++ show time_out] getCVC4ProcessHandles :: IO (Handle, Handle, ProcessHandle)-getCVC4ProcessHandles = getProcessHandles $ proc "cvc4" ["--lang", "smt2.6", "--produce-models"]+getCVC4ProcessHandles = getProcessHandles $ proc "cvc4" ["--lang", "smt2.6", "--produce-models", "--produce-unsat-cores"] -- | setUpFormulaZ3 -- Writes a function to Z3-setUpFormulaZ3 :: Handle -> String -> IO ()+setUpFormulaZ3 :: Handle -> T.Text -> IO () setUpFormulaZ3 h_in form = do- hPutStr h_in "(reset)"- hPutStr h_in form+ T.hPutStr h_in "(reset)"+ T.hPutStr h_in form -setUpFormulaCVC4 :: Handle -> String -> IO ()+setUpFormulaCVC4 :: Handle -> T.Text -> IO () setUpFormulaCVC4 h_in form = do- hPutStr h_in "(reset)"+ T.hPutStr h_in "(reset)" -- hPutStr h_in "(set-logic ALL)\n"- hPutStr h_in form+ T.hPutStr h_in form -- Checks if a formula, previously written by setUp formula, is SAT-checkSat' :: Handle -> Handle -> IO Result+checkSat' :: Handle -> Handle -> IO (Result () () ()) checkSat' h_in h_out = do hPutStr h_in "(check-sat)\n" - r <- hWaitForInput h_out (-1)- if r then do- out <- hGetLine h_out- -- putStrLn $ "Z3 out: " ++ out- _ <- evaluate (length out)+ _ <- hWaitForInput h_out (-1)+ checkSatReadResult h_out - if out == "sat" then- return SAT- else if out == "unsat" then- return UNSAT- else- return (Unknown out)- else do- return (Unknown "")+checkSatReadResult :: Handle -> IO (Result () () ())+checkSatReadResult h_out = do+ out <- hGetLine h_out+ -- putStrLn $ "Z3 out: " ++ out+ _ <- evaluate (length out) + if out == "sat" then+ return $ SAT ()+ else if out == "unsat" then+ return $ UNSAT ()+ else+ return (Unknown out ())+ parseModel :: [(SMTName, String, Sort)] -> SMTModel parseModel = foldr (\(n, s) -> M.insert n s) M.empty . map (\(n, str, s) -> (n, parseToSMTAST str s))@@ -396,8 +372,10 @@ parseToSMTAST str s = correctTypes s . parseGetValues $ str where correctTypes :: Sort -> SMTAST -> SMTAST- correctTypes (SortFloat) (VDouble r) = VFloat r- correctTypes (SortDouble) (VFloat r) = VDouble r+ correctTypes SortFloat (VDouble r) = VFloat r+ correctTypes SortDouble (VFloat r) = VDouble r+ correctTypes SortChar (VString [c]) = VChar c+ correctTypes SortChar (VString _) = error "Invalid Char from parseToSMTAST" correctTypes _ a = a getModelZ3 :: Handle -> Handle -> [(SMTName, Sort)] -> IO [(SMTName, String, Sort)]@@ -414,6 +392,37 @@ return . (:) (n, out, s) =<< getModel' nss +getUnsatCoreZ3 :: Handle -> Handle -> IO [SMTName]+getUnsatCoreZ3 h_in h_out = do+ hPutStr h_in "(get-unsat-core)\n"+ _ <- hWaitForInput h_out (-1)+ out <- hGetLine h_out + putStrLn $ "unsat-core = " ++ out+ let out' = tail . init $ out -- drop opening and closing parens++ case words out' of+ "error":_ -> error "getUnsatCoreZ3: Error producing unsat core"+ w -> return w++getUnsatCoreCVC4 :: Handle -> Handle -> IO [SMTName]+getUnsatCoreCVC4 h_in h_out = do+ hPutStr h_in "(get-unsat-core)\n"+ _ <- hWaitForInput h_out (-1)+ -- Read in the opening bracket+ _ <- hGetLine h_out+ out <- getCore+ putStrLn $ "unsat-core = " ++ show out++ return out+ where+ getCore = do+ _ <- hWaitForInput h_out (-1)+ core <- hGetLine h_out+ putStrLn $ "getCore " ++ show core+ case core of+ ")" -> return []+ _ -> return . (:) core =<< getCore+ getModelCVC4 :: Handle -> Handle -> [(SMTName, Sort)] -> IO [(SMTName, String, Sort)] getModelCVC4 h_in h_out ns = do getModel' ns@@ -444,27 +453,3 @@ else do out' <- getLinesMatchParens' h_out n' return $ out ++ out'--solveExpr :: SMTConverter con [Char] out io => Handle -> Handle -> con -> ExprEnv -> Expr -> IO Expr-solveExpr h_in h_out con eenv e = do- let vs = symbVars eenv e- vs' <- solveExpr' h_in h_out con vs- let vs'' = map smtastToExpr vs'- - return $ foldr (uncurry replaceASTs) e (zip vs vs'')--solveExpr' :: SMTConverter con [Char] out io => Handle -> Handle -> con -> [Expr] -> IO [SMTAST]-solveExpr' _ _ _ [] = return []-solveExpr' h_in h_out con (v:vs) = do- v' <- solveExpr'' h_in h_out con v- vs' <- solveExpr' h_in h_out con vs- return (v':vs')--solveExpr'' :: SMTConverter con [Char] out io => Handle -> Handle -> con -> Expr -> IO SMTAST-solveExpr'' h_in h_out con e = do- let smte = toSolverAST con $ exprToSMT e- hPutStr h_in ("(eval " ++ smte ++ " :completion)\n")- out <- getLinesMatchParens h_out- _ <- evaluate (length out)-- return $ parseToSMTAST out (typeToSMT . typeOf $ e)
+ src/G2/Solver/Simplifier.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}++module G2.Solver.Simplifier ( Simplifier (..)+ , IdSimplifier (..)) where++import G2.Language++class Simplifier simplifier where+ -- | Simplifies a PC, by converting it to a form that is easier for the Solver's to handle+ simplifyPC :: forall t . simplifier -> State t -> PathCond -> (State t, [PathCond])++ {-# INLINE simplifyPCs #-}+ simplifyPCs :: forall t. simplifier -> State t -> PathCond -> PathConds -> PathConds+ simplifyPCs _ _ _ = id++ -- | Reverses the affect of simplification in the model, if needed.+ reverseSimplification :: forall t . simplifier -> State t -> Bindings -> Model -> Model++-- | A simplifier that does no simplification+data IdSimplifier = IdSimplifier++instance Simplifier IdSimplifier where+ simplifyPC _ s pc = (s, [pc])+ reverseSimplification _ _ _ m = m
src/G2/Solver/Solver.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -13,27 +14,28 @@ , groupRelatedFinite , groupRelatedInfinite , CombineSolvers (..)- , UndefinedHigherOrder (..)) where+ , UndefinedHigherOrder (..)+ , UnknownSolver (..)) where import G2.Language import qualified G2.Language.PathConds as PC import Data.List-import qualified Data.Map as M+import qualified Data.HashMap.Lazy as HM -- | The result of a Solver query-data Result = SAT- | UNSAT- | Unknown String- deriving (Show, Eq)+data Result m u um = SAT m+ | UNSAT u+ | Unknown String um+ deriving (Show, Eq) -- | Defines an interface to interact with Solvers class Solver solver where -- | Checks if the given `PathConds` are satisfiable.- check :: forall t . solver -> State t -> PathConds -> IO Result+ check :: forall t . solver -> State t -> PathConds -> IO (Result () () ()) -- | Checks if the given `PathConds` are satisfiable, and, if yes, gives a `Model` -- The model must contain, at a minimum, a value for each passed `Id`- solve :: forall t . solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model)+ solve :: forall t . solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () ()) -- | Cleans up when the solver is no longer needed. Default implementation -- does nothing@@ -47,12 +49,12 @@ class TrSolver solver where -- | Checks if the given `PathConds` are satisfiable. -- Allows modifying the solver, to track some state.- checkTr :: forall t . solver -> State t -> PathConds -> IO (Result, solver)+ checkTr :: forall t . solver -> State t -> PathConds -> IO (Result () () (), solver) -- | Checks if the given `PathConds` are satisfiable, and, if yes, gives a `Model` -- The model must contain, at a minimum, a value for each passed `Id` -- Allows modifying the solver, to track some state.- solveTr :: forall t . solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model, solver)+ solveTr :: forall t . solver -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () (), solver) -- | Cleans up when the solver is no longer needed. Default implementation -- does nothing@@ -64,7 +66,7 @@ instance Solver solver => TrSolver (Tr solver) where checkTr (Tr sol) s pc = return . (, Tr sol) =<< check sol s pc- solveTr (Tr sol) s b is pc = return . (\(r, m) -> (r, m, Tr sol)) =<< solve sol s b is pc+ solveTr (Tr sol) s b is pc = return . (\r -> (r, Tr sol)) =<< solve sol s b is pc closeTr = close . unTr data SomeSolver where@@ -84,26 +86,26 @@ groupRelatedInfinite :: a -> GroupRelated a groupRelatedInfinite = GroupRelated arbValueInfinite -checkRelated :: TrSolver a => a -> State t -> PathConds -> IO (Result, a)+checkRelated :: TrSolver a => a -> State t -> PathConds -> IO (Result () () (), a) checkRelated solver s pc =- checkRelated' solver s $ PC.relatedSets (known_values s) pc+ checkRelated' solver s $ PC.relatedSets pc -checkRelated' :: TrSolver a => a -> State t -> [PathConds] -> IO (Result, a)-checkRelated' sol _ [] = return (SAT, sol)+checkRelated' :: TrSolver a => a -> State t -> [PathConds] -> IO (Result () () (), a)+checkRelated' sol _ [] = return (SAT (), sol) checkRelated' sol s (p:ps) = do (c, sol') <- checkTr sol s p case c of- SAT -> checkRelated' sol' s ps+ SAT _ -> checkRelated' sol' s ps r -> return (r, sol') -solveRelated :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model, a)+solveRelated :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () (), a) solveRelated avf sol s b is pc = do- solveRelated' avf sol s b M.empty is $ PC.relatedSets (known_values s) pc+ solveRelated' avf sol s b HM.empty is $ PC.relatedSets pc -solveRelated' :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> Model -> [Id] -> [PathConds] -> IO (Result, Maybe Model, a)+solveRelated' :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> Model -> [Id] -> [PathConds] -> IO (Result Model () (), a) solveRelated' avf sol s b m is [] = let - is' = filter (\i -> idName i `M.notMember` m) is+ is' = filter (\i -> not $ idName i `HM.member` m) is (_, nv) = mapAccumL (\av_ (Id n t) ->@@ -113,21 +115,21 @@ (v, (n, av_')) ) (arb_value_gen b) is' - m' = foldr (\(n, v) -> M.insert n v) m nv+ m' = foldr (\(n, v) -> HM.insert n v) m nv in- return (SAT, Just m', sol)+ return (SAT m', sol) solveRelated' avf sol s b m is (p:ps) = do- let is' = concat $ PC.map (PC.varIdsInPC (known_values s)) p+ let is' = concat $ PC.map' PC.varIdsInPC p let is'' = ids p rm <- solveTr sol s b is' p case rm of- (SAT, Just m', sol') -> solveRelated' avf sol' s b (M.union m m') (is ++ is'') ps+ (SAT m', sol') -> solveRelated' avf sol' s b (HM.union m m') (is ++ is'') ps rm' -> return rm' instance Solver solver => Solver (GroupRelated solver) where check (GroupRelated _ sol) s pc = return . fst =<< checkRelated (Tr sol) s pc solve (GroupRelated avf sol) s b is pc =- return . (\(r, m, _) -> (r, m)) =<< solveRelated avf (Tr sol) s b is pc+ return . (\(r, _) -> r) =<< solveRelated avf (Tr sol) s b is pc close (GroupRelated _ s) = close s instance TrSolver solver => TrSolver (GroupRelated solver) where@@ -135,8 +137,8 @@ (r, sol') <- checkRelated sol s pc return (r, GroupRelated avf sol') solveTr (GroupRelated avf sol) s b is pc = do- (r, m, sol') <- solveRelated avf sol s b is pc- return (r, m, GroupRelated avf sol')+ (r, sol') <- solveRelated avf sol s b is pc+ return (r, GroupRelated avf sol') closeTr (GroupRelated _ s) = closeTr s -- | Allows solvers to be combined, to exploit different solvers abilities@@ -144,54 +146,54 @@ data CombineSolvers a b = a :<? b -- ^ a :<? b - Try solver b. If it returns Unknown, try solver a | a :?> b -- ^ a :>? b - Try solver a. If it returns Unknown, try solver b -checkWithEither :: (TrSolver a, TrSolver b) => a -> b -> State t -> PathConds -> IO (Result, CombineSolvers a b)+checkWithEither :: (TrSolver a, TrSolver b) => a -> b -> State t -> PathConds -> IO (Result () () (), CombineSolvers a b) checkWithEither a b s pc = do (ra, a') <- checkTr a s pc case ra of- SAT -> return (SAT, a' :?> b)- UNSAT -> return (UNSAT, a' :?> b)- Unknown ua -> do+ SAT _ -> return (ra, a' :?> b)+ UNSAT _ -> return (ra, a' :?> b)+ Unknown ua _ -> do (rb, b') <- checkTr b s pc case rb of- Unknown ub -> return $ (Unknown $ ua ++ ",\n" ++ ub, a' :?> b')+ Unknown ub _ -> return $ (Unknown (ua ++ ",\n" ++ ub) (), a' :?> b') rb' -> return (rb', a' :?> b') -solveWithEither :: (TrSolver a, TrSolver b) => a -> b -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe Model, CombineSolvers a b)+solveWithEither :: (TrSolver a, TrSolver b) => a -> b -> State t -> Bindings -> [Id] -> PathConds -> IO (Result Model () (), CombineSolvers a b) solveWithEither a b s binds is pc = do ra <- solveTr a s binds is pc case ra of- (SAT, m, a') -> return (SAT, m, a' :?> b)- (UNSAT, m, a') -> return (UNSAT, m, a' :?> b)- (Unknown ua, _, a') -> do+ (SAT m, a') -> return (SAT m, a' :?> b)+ (UNSAT u, a') -> return (UNSAT u, a' :?> b)+ (Unknown ua _, a') -> do rb <- solveTr b s binds is pc case rb of- (Unknown ub, _, b') -> return $ (Unknown $ ua ++ ",\n" ++ ub, Nothing, a' :?> b')- (r, m, b') -> return (r, m, a' :?> b')+ (Unknown ub (), b') -> return $ (Unknown (ua ++ ",\n" ++ ub) (), a' :?> b')+ (r, b') -> return (r, a' :?> b') -- | Fills in unused higher order functions with undefined data UndefinedHigherOrder = UndefinedHigherOrder instance Solver UndefinedHigherOrder where- check _ s pc =+ check _ _ pc = let- f = concatMap (PC.varIdsInPC (known_values s)) $ PC.toList pc+ f = concatMap PC.varIdsInPC $ PC.toList pc in case f of- [Id _ (TyFun _ _)] -> return SAT- _ -> return $ Unknown "UndefinedHigherOrder"+ [Id _ (TyFun _ _)] -> return $ SAT ()+ _ -> return $ Unknown "UndefinedHigherOrder" () solve _ _ _ [i@(Id _ (TyFun _ _))] _ =- return (SAT, Just $ M.singleton (idName i) (Prim Undefined TyBottom))- solve _ _ _ _ _ = return (Unknown "UndefinedHigherOrder", Nothing)+ return $ SAT (HM.singleton (idName i) (Prim Undefined TyBottom))+ solve _ _ _ _ _ = return (Unknown "UndefinedHigherOrder" ()) instance (Solver a, Solver b) => Solver (CombineSolvers a b) where check (a :<? b) s pc = return . fst =<< checkWithEither (Tr b) (Tr a) s pc check (a :?> b) s pc = return . fst =<< checkWithEither (Tr a) (Tr b) s pc solve (a :<? b) s binds is pc =- return . (\(r, m, _) -> (r, m)) =<< solveWithEither (Tr b) (Tr a) s binds is pc+ return . (\(r, _) -> r) =<< solveWithEither (Tr b) (Tr a) s binds is pc solve (a :?> b) s binds is pc =- return . (\(r, m, _) -> (r, m)) =<< solveWithEither (Tr a) (Tr b) s binds is pc+ return . (\(r, _) -> r) =<< solveWithEither (Tr a) (Tr b) s binds is pc close (a :<? b) = do close a@@ -209,10 +211,10 @@ checkTr (a :?> b) s pc = checkWithEither a b s pc solveTr (a :<? b) s binds is pc = do- (r, m, sol') <- solveWithEither b a s binds is pc+ (r, sol') <- solveWithEither b a s binds is pc case sol' of- b' :?> a' -> return (r, m, a' :<? b')- b' :<? a' -> return (r, m, a' :?> b')+ b' :?> a' -> return (r, a' :<? b')+ b' :<? a' -> return (r, a' :?> b') solveTr (a :?> b) s binds is pc = solveWithEither a b s binds is pc closeTr (a :<? b) = do@@ -221,3 +223,23 @@ closeTr (a :?> b) = do closeTr a closeTr b++instance (ASTContainer m e, ASTContainer u e) => ASTContainer (Result m u um) e where+ containedASTs (SAT m) = containedASTs m+ containedASTs (UNSAT u) = containedASTs u+ containedASTs (Unknown _ _) = []++ modifyContainedASTs f (SAT m) = SAT (modifyContainedASTs f m)+ modifyContainedASTs f (UNSAT u) = UNSAT (modifyContainedASTs f u)+ modifyContainedASTs _ u@(Unknown _ _) = u++-- A solver that returns unknown on all but the most trivial (empty) PCs+data UnknownSolver = UnknownSolver++instance Solver UnknownSolver where+ check _ _ pc+ | PC.null pc = return (SAT ())+ | otherwise = return (Unknown "unknown" ())+ solve _ _ _ _ pc+ | PC.null pc = return (SAT HM.empty)+ | otherwise = return (Unknown "unknown" ())
src/G2/Translation/Cabal/Cabal.hs view
@@ -1,8 +1,21 @@+{-# LANGUAGE CPP #-}+ module G2.Translation.Cabal.Cabal (cabalSrcDirs) where import Distribution.PackageDescription++#if MIN_VERSION_Cabal(3,8,0)+import Distribution.Simple.PackageDescription+#elif MIN_VERSION_Cabal(2,2,0)+import Distribution.PackageDescription.Parsec+#else import Distribution.PackageDescription.Parse+#endif+ import Distribution.Verbosity+#if MIN_VERSION_Cabal(3,6,0)+import Distribution.Utils.Path ( getSymbolicPath )+#endif -- | Takes the filepath to a Cabal file, and returns a list of FilePaths to red -- from.@@ -14,8 +27,11 @@ genericPackageDescriptionSrcDirs :: GenericPackageDescription -> [FilePath] genericPackageDescriptionSrcDirs (GenericPackageDescription { condLibrary = cl- , condExecutables = ce }) = do- maybe [] (condTreeSrcDirs libSrcDirs) cl ++ concatMap (condTreeSrcDirs execSrcDirs . snd) ce+ , condExecutables = ce+ , condTestSuites = ts }) = do+ maybe [] (condTreeSrcDirs libSrcDirs) cl+ ++ concatMap (condTreeSrcDirs execSrcDirs . snd) ce+ ++ concatMap (condTreeSrcDirs testSrcDirs . snd) ts condTreeSrcDirs :: (a -> [FilePath]) -> CondTree v c a -> [FilePath] condTreeSrcDirs f (CondNode { condTreeData = t }) = f t@@ -26,5 +42,12 @@ execSrcDirs :: Executable -> [FilePath] execSrcDirs = buildInfoSrcDirs . buildInfo +testSrcDirs :: TestSuite -> [FilePath]+testSrcDirs = buildInfoSrcDirs . testBuildInfo+ buildInfoSrcDirs :: BuildInfo -> [FilePath]+#if MIN_VERSION_Cabal(3,6,0)+buildInfoSrcDirs (BuildInfo { hsSourceDirs = sd }) = map getSymbolicPath sd+#else buildInfoSrcDirs (BuildInfo { hsSourceDirs = sd }) = sd+#endif
+ src/G2/Translation/GHC.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE CPP #-}++#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)++module G2.Translation.GHC ( module GHC+ , module GHC.Core+ , module GHC.Core.Class+ , module GHC.Core.Coercion+ , module GHC.Core.DataCon+ , module GHC.Core.InstEnv+ , module GHC.Core.TyCo.Rep+ , module GHC.Core.TyCon+ , module GHC.Data.FastString+ , module GHC.Data.Pair+ , module GHC.Driver.Main+ , module GHC.Driver.Session+ , module GHC.Iface.Tidy+ , module GHC.Paths+ , module GHC.Types.Avail+ , module GHC.Types.Id.Info+ , module GHC.Types.Literal+ , module GHC.Types.Name+ , module GHC.Types.SrcLoc+ , module GHC.Types.Unique+ , module GHC.Types.Var+ , module GHC.Unit.Types+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+ , module GHC.Platform.Ways+ , module GHC.Types.Tickish+ , module GHC.Types.TypeEnv+ , module GHC.Unit.Module.Deps+ , module GHC.Unit.Module.ModDetails+ , module GHC.Unit.Module.ModGuts++ , HscTarget+#else+ , module GHC.Driver.Types+ , module GHC.Driver.Ways+#endif+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+ , module GHC.Driver.Config.Tidy+#endif+ ) where++import GHC+import GHC.Core ( Alt (..)+ , AltCon (..)+ , Bind (..)+ , CoreAlt+ , CoreBind+ , CoreExpr+ , CoreProgram+ , CoreRule (..)+ , Expr (..)++#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+#else+ , Tickish (..)+#endif++ , bindersOf)+import GHC.Core.Class (classAllSelIds, className, classSCTheta, classTyVars)+import GHC.Core.Coercion+import GHC.Core.DataCon+import GHC.Core.InstEnv+import GHC.Core.TyCo.Rep+import GHC.Core.TyCon+import GHC.Data.FastString+import GHC.Data.Pair+import GHC.Driver.Main+import GHC.Driver.Session+import GHC.Iface.Tidy+import GHC.Paths+import GHC.Types.Avail+import GHC.Types.Id.Info+import GHC.Types.Literal+import GHC.Types.Name hiding (varName)+import GHC.Types.SrcLoc+import GHC.Types.Unique+import GHC.Types.Var+import GHC.Unit.Types++#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import GHC.Driver.Config.Tidy+#endif++#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+import GHC.Platform.Ways+import GHC.Types.Tickish+import GHC.Types.TypeEnv+import GHC.Unit.Module.Deps+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts++type HscTarget = Backend+#else+import GHC.Driver.Types+import GHC.Driver.Ways+#endif+++#else++module G2.Translation.GHC ( module Avail+ , module Class+ , module Coercion+ , module CoreSyn+ , module DataCon+ , module DynFlags+ , module FastString+ , module GHC+ , module GHC.Paths+ , module HscMain+ , module HscTypes+ , module IdInfo+ , module InstEnv+ , module Literal+ , module Name+ , module Pair+ , module SrcLoc+ , module TidyPgm+ , module TyCon+ , module TyCoRep+ , module Unique+ , module Var) where++import Avail+import Class (classAllSelIds, className, classSCTheta, classTyVars)+import Coercion+import CoreSyn+import DataCon+import DynFlags+import FastString+import GHC hiding (AnnKeywordId (..), AnnExpr' (..))+import GHC.Paths+import HscMain+import HscTypes+import IdInfo+import InstEnv+import Literal+import Name hiding (varName)+import Pair+import SrcLoc+import TidyPgm+import TyCon+import TyCoRep+import Unique+import Var++#endif
src/G2/Translation/Haskell.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} -- | Haskell Translation module G2.Translation.Haskell@@ -10,14 +12,15 @@ , hskToG2ViaCgGutsFromFile , mkCgGutsClosure , mkModDetailsClosure+ , mkModGutsClosure++ , EnvModSumModGuts (..)+ , envModSumModGutsFromFile+ , hskToG2ViaEMS+ , envModSumModGutsImports+ , mergeExtractedG2s- , mkIOString- , prim_list- , mkRawCore- , rawDump , mkExpr- , mkId- , mkIdUnsafe , mkName , mkTyConName , mkData@@ -28,38 +31,21 @@ , readAllExtractedG2s , mergeFileExtractedG2s , findCabal+ + , mkIdUnsafe+ , mkTyConNameUnsafe+ , mkDataUnsafe ) where -import qualified G2.Language.TypeEnv as G2 (AlgDataTy (..), ProgramType)+import qualified G2.Language.TypeEnv as G2 (AlgDataTy (..)) import qualified G2.Language.Syntax as G2 -- import qualified G2.Language.Typing as G2 import qualified G2.Translation.TransTypes as G2 -import Avail-import qualified Class as C-import Coercion-import CoreSyn-import DataCon-import DynFlags-import FastString-import GHC-import GHC.Paths-import HscMain-import HscTypes-import IdInfo-import InstEnv-import Literal-import Name-import Outputable-import Pair-import SrcLoc-import TidyPgm-import TyCon-import TyCoRep-import Unique-import Var as V+import G2.Translation.GHC import Control.Monad+import qualified Control.Monad.State.Lazy as SM import qualified Data.Array as A import qualified Data.ByteString.Char8 as C@@ -86,69 +72,90 @@ -> G2.Type mkG2TyCon n ts k = mkG2TyApp $ G2.TyCon n k:ts --mkIOString :: (Outputable a) => a -> IO String-mkIOString obj = runGhc (Just libdir) $ do- dflags <- getSessionDynFlags- return (showPpr dflags obj)--mkRawCore :: FilePath -> IO CoreModule-mkRawCore fp = runGhc (Just libdir) $ do- _ <- setSessionDynFlags =<< getSessionDynFlags- -- compileToCoreModule fp- compileToCoreSimplified fp--rawDump :: FilePath -> IO ()-rawDump fp = do- core <- mkRawCore fp- str <- mkIOString core- putStrLn str-- equivMods :: HM.HashMap T.Text T.Text equivMods = HM.fromList- [ ("GHC.Classes2", "GHC.Classes")+ [ ("GHC.BaseMonad", "GHC.Base")+ , ("GHC.Classes2", "GHC.Classes") , ("GHC.Types2", "GHC.Types") , ("GHC.Integer2", "GHC.Integer")+#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+ , ("GHC.Integer.Type2", "GHC.Num.Integer")+#else , ("GHC.Integer.Type2", "GHC.Integer.Type")+#endif , ("GHC.Prim2", "GHC.Prim")+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+ , ("GHC.Tuple2", "GHC.Tuple.Prim")+#else , ("GHC.Tuple2", "GHC.Tuple")+#endif , ("GHC.Magic2", "GHC.Magic") , ("GHC.CString2", "GHC.CString") , ("Data.Map.Base", "Data.Map")] --loadProj :: Maybe HscTarget -> [FilePath] -> [FilePath] -> [GeneralFlag] -> G2.TranslationConfig -> Ghc SuccessFlag+loadProj :: Maybe HscTarget -> [FilePath] -> [FilePath] -> [GeneralFlag] -> G2.TranslationConfig -> Ghc SuccessFlag loadProj hsc proj src gflags tr_con = do beta_flags <- getSessionDynFlags- let gen_flags = gflags+ let gen_flags = if G2.hpc_ticks tr_con then Opt_Hpc:gflags else gflags let init_beta_flags = gopt_unset beta_flags Opt_StaticArgumentTransformation let beta_flags' = foldl' gopt_set init_beta_flags gen_flags- let dflags = beta_flags' { -- Profiling fails to load a profiler friendly version of the base- -- without this special casing for hscTarget, but we can't use HscInterpreted when we have certain unboxed types+ let dflags = beta_flags' {+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+ backend = case hsc of+ Just hsc' -> hsc'+ _ -> backend beta_flags'+#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+ backend = if hostIsProfiled + then Interpreter+ else case hsc of+ Just hsc' -> hsc'+ _ -> backend beta_flags'+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+ hscTarget = if hostIsProfiled + then HscInterpreted+ else case hsc of+ Just hsc' -> hsc'+ _ -> hscTarget beta_flags'++#else hscTarget = if rtsIsProfiled then HscInterpreted else case hsc of Just hsc' -> hsc' _ -> hscTarget beta_flags'+#endif+#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)+ -- Profiling gives warnings without this special case+ , targetWays_ = if hostIsProfiled then addWay WayProf (targetWays_ beta_flags') else targetWays_ beta_flags'+#endif , ghcLink = LinkInMemory , ghcMode = CompManager- , includePaths = proj ++ includePaths beta_flags'+ , importPaths = proj ++ importPaths beta_flags' , simplPhases = if G2.simpl tr_con then simplPhases beta_flags' else 0 , maxSimplIterations = if G2.simpl tr_con then maxSimplIterations beta_flags' else 0 , hpcDir = head proj} + dflags' = setIncludePaths proj dflags - _ <- setSessionDynFlags dflags+ _ <- setSessionDynFlags dflags'+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+ targets <- mapM (\s -> guessTarget s Nothing Nothing) src+#else targets <- mapM (flip guessTarget Nothing) src+#endif _ <- setTargets targets load LoadAllTargets -+setIncludePaths :: [FilePath] -> DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ < 806+setIncludePaths proj dflags = dflags { includePaths = proj ++ includePaths dflags }+#else+setIncludePaths proj dflags = dflags { includePaths = addQuoteInclude (includePaths dflags) proj }+#endif -- Compilation pipeline with CgGuts hskToG2ViaCgGutsFromFile :: Maybe HscTarget@@ -159,23 +166,29 @@ -> G2.TranslationConfig -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) hskToG2ViaCgGutsFromFile hsc proj src nm tm tr_con = do- closures <- mkCgGutsModDetailsClosuresFromFile hsc proj src tr_con- return $ hskToG2ViaCgGuts nm tm closures tr_con+ ems <- envModSumModGutsFromFile hsc proj src tr_con+ hskToG2ViaEMS tr_con ems nm tm +hskToG2ViaEMS :: G2.TranslationConfig+ -> EnvModSumModGuts+ -> G2.NameMap+ -> G2.TypeNameMap+ -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)+hskToG2ViaEMS tr_con (EnvModSumModGuts env _ modgutss) nm tm = do+ closures <- mkCgGutsModDetailsClosures tr_con env modgutss+ let (ex_g2, (nm', tm')) = SM.runState (hskToG2ViaCgGuts closures tr_con) (nm, tm)+ return (nm', tm', ex_g2) -hskToG2ViaCgGuts :: G2.NameMap- -> G2.TypeNameMap- -> [(G2.CgGutsClosure, G2.ModDetailsClosure)]- -> G2.TranslationConfig- -> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)-hskToG2ViaCgGuts nm tm pairs tr_con = do- let (nm2, tm2, exg2s) = foldr (\(c, m) (nm', tm', exs) ->- let mgcc = cgGutsModDetailsClosureToModGutsClosure c m in- let (nm'', tm'', g2) = modGutsClosureToG2 nm' tm' mgcc tr_con in- (nm'', tm'', g2 : exs))- (nm, tm, [])- pairs in- (nm2, tm2, mergeExtractedG2s exg2s)+hskToG2ViaCgGuts :: [(G2.CgGutsClosure, G2.ModDetailsClosure)]+ -> G2.TranslationConfig+ -> G2.NamesM G2.ExtractedG2+hskToG2ViaCgGuts pairs tr_con = do+ exg2s <- mapM (\(c, m) -> do+ let mgcc = cgGutsModDetailsClosureToModGutsClosure c m+ g2 <- modGutsClosureToG2 mgcc tr_con+ return g2)+ pairs+ return $ mergeExtractedG2s exg2s cgGutsModDetailsClosureToModGutsClosure :: G2.CgGutsClosure -> G2.ModDetailsClosure -> G2.ModGutsClosure@@ -193,47 +206,90 @@ } -mkCgGutsModDetailsClosuresFromFile :: Maybe HscTarget- -> [FilePath]- -> [FilePath]- -> G2.TranslationConfig - -> IO [(G2.CgGutsClosure, G2.ModDetailsClosure)]-mkCgGutsModDetailsClosuresFromFile hsc proj src tr_con = do- (env, modgutss) <- runGhc (Just libdir) $ do+data EnvModSumModGuts = EnvModSumModGuts HscEnv [ModSummary] [ModGuts]++envModSumModGutsFromFile :: Maybe HscTarget+ -> [FilePath]+ -> [FilePath]+ -> G2.TranslationConfig+ -> IO EnvModSumModGuts+envModSumModGutsFromFile hsc proj src tr_con =+ runGhc (Just libdir) $ do _ <- loadProj hsc proj src [] tr_con env <- getSession mod_graph <- getModuleGraph- parsed_mods <- mapM parseModule mod_graph++ let msums = convertModuleGraph mod_graph+ parsed_mods <- mapM parseModule msums typed_mods <- mapM typecheckModule parsed_mods desug_mods <- mapM desugarModule typed_mods- return (env, map coreModule desug_mods)+ return . EnvModSumModGuts env msums $ map coreModule desug_mods +envModSumModGutsImports :: EnvModSumModGuts -> [String]+envModSumModGutsImports (EnvModSumModGuts _ ms _) = concatMap (map (\(_, L _ m) -> moduleNameString m) . ms_textual_imps) ms++-- | Extract information from GHC into a form that G2 can process.+mkCgGutsModDetailsClosures :: G2.TranslationConfig -> HscEnv -> [ModGuts] -> IO [( G2.CgGutsClosure, G2.ModDetailsClosure)]+#if __GLASGOW_HASKELL__ < 806+mkCgGutsModDetailsClosures tr_con env modgutss = do simplgutss <- mapM (if G2.simpl tr_con then hscSimplify env else return . id) modgutss tidys <- mapM (tidyProgram env) simplgutss- let pairs = map (\((cg, md), mg) -> (mkCgGutsClosure (mg_binds mg) cg, mkModDetailsClosure (mg_deps mg) md)) $ zip tidys simplgutss+ let pairs = map (\((cg, md), mg) -> ( mkCgGutsClosure (mg_binds mg) cg md+ , mkModDetailsClosure (mg_deps mg) md)) $ zip tidys simplgutss return pairs+#else+mkCgGutsModDetailsClosures tr_con env modgutss = do+ simplgutss <- mapM (if G2.simpl tr_con then hscSimplify env [] else return . id) modgutss --- | The core program in the CgGuts does not include local rules after tidying.--- As such, we pass in the CoreProgram from the ModGuts-mkCgGutsClosure :: CoreProgram -> CgGuts -> G2.CgGutsClosure-mkCgGutsClosure bndrs cgguts =+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+ tidy_opts <- initTidyOpts env+ tidys <- mapM (tidyProgram tidy_opts) simplgutss+#else+ tidys <- mapM (tidyProgram env) simplgutss+#endif++ let pairs = map (\((cg, md), mg) -> ( mkCgGutsClosure (mg_binds mg) cg md+ , mkModDetailsClosure (mg_deps mg) md)) $ zip tidys simplgutss+ return pairs+#endif++-- | Extract information from GHC into a form that G2 can process.+mkCgGutsClosure :: CoreProgram -> CgGuts -> ModDetails -> G2.CgGutsClosure+mkCgGutsClosure binds cgguts md =+ let+ binds_rules = concatMap ruleInfoRules+ . map ruleInfo+ . map idInfo + . concatMap bindersOf $ binds+ in G2.CgGutsClosure { G2.cgcc_mod_name = Just $ moduleNameString $ moduleName $ cg_module cgguts , G2.cgcc_binds = cg_binds cgguts , G2.cgcc_breaks = cg_modBreaks cgguts , G2.cgcc_tycons = cg_tycons cgguts- , G2.cgcc_rules = concatMap ruleInfoRules . map ruleInfo . map idInfo - . concatMap bindersOf $ bndrs }+ -- Getting all rules is complicated by GHC's build process. GHC goes through a "tidying"+ -- process, which performs various transformation on the Core code. Unfortunately:+ -- 1) The core program in the CgGuts does not include rules after tidying.+ -- 2) The ModDetails does not include all rules after tidying.+ -- 3) Names of functions in rules in the original CoreProgram may have been changed by bindings+ -- (in which case it seems like those rules ARE in the ModDetails.)+ -- We can't just take the rules from the ModDetails, because some are eliminated during tidying.+ -- But we can't just take the rules from the original CoreProgram, because they might have function/variables+ -- names that no longer exist.+ -- As such, we keep:+ -- 1) Rules from the ModDetails+ -- 2) Rules from the CoreProgram, IF a rule with the same name is not in ModDetails+ , G2.cgcc_rules = nubBy (\r1 r2 -> ru_name r1 == ru_name r2) (md_rules md ++ binds_rules) } mkModDetailsClosure :: Dependencies -> ModDetails -> G2.ModDetailsClosure mkModDetailsClosure deps moddet = G2.ModDetailsClosure- { G2.mdcc_cls_insts = md_insts moddet+ { G2.mdcc_cls_insts = getClsInst moddet , G2.mdcc_type_env = md_types moddet , G2.mdcc_exports = exportedNames moddet- , G2.mdcc_deps = map (moduleNameString . fst) $ dep_mods deps+ , G2.mdcc_deps = getModuleNames deps } @@ -248,65 +304,54 @@ -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) hskToG2ViaModGutsFromFile hsc proj src nm tm tr_con = do closures <- mkModGutsClosuresFromFile hsc proj src tr_con- return $ hskToG2ViaModGuts nm tm closures tr_con+ let (ex_g2, (nm', tm')) = SM.runState (hskToG2ViaModGuts closures tr_con) (nm, tm)+ return (nm', tm', ex_g2) -hskToG2ViaModGuts :: G2.NameMap- -> G2.TypeNameMap- -> [G2.ModGutsClosure]- -> G2.TranslationConfig- -> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)-hskToG2ViaModGuts nm tm modgutss tr_con =- let (nm2, tm2, exg2s) = foldr (\m (nm', tm', cls) ->- let (nm'', tm'', mc) = modGutsClosureToG2 nm' tm' m tr_con in- (nm'', tm'', mc : cls))- (nm, tm, [])- modgutss in- (nm2, tm2, mergeExtractedG2s exg2s)---+hskToG2ViaModGuts :: [G2.ModGutsClosure]+ -> G2.TranslationConfig+ -> G2.NamesM G2.ExtractedG2+hskToG2ViaModGuts modgutss tr_con = do+ exg2s <- mapM (\m -> modGutsClosureToG2 m tr_con) modgutss+ return $ mergeExtractedG2s exg2s -modGutsClosureToG2 :: G2.NameMap- -> G2.TypeNameMap- -> G2.ModGutsClosure- -> G2.TranslationConfig- -> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)-modGutsClosureToG2 nm tm mgcc tr_con =- let breaks = G2.mgcc_breaks mgcc in+modGutsClosureToG2 :: G2.ModGutsClosure+ -> G2.TranslationConfig+ -> G2.NamesM G2.ExtractedG2+modGutsClosureToG2 mgcc tr_con = do+ let breaks = G2.mgcc_breaks mgcc -- Do the binds- let (nm2, binds) = foldr (\b (nm', bs) ->- let (nm'', bs') = mkBinds nm' tm breaks b in- (nm'', bs ++ bs'))- (nm, [])- (G2.mgcc_binds mgcc) in+ binds <- foldM (\bs b -> do+ bs' <- mkBinds breaks b+ return $ bs `HM.union` bs')+ HM.empty+ (G2.mgcc_binds mgcc) -- Do the tycons- let raw_tycons = G2.mgcc_tycons mgcc ++ typeEnvTyCons (G2.mgcc_type_env mgcc) in- let (nm3, tm2, tycons) = foldr (\tc (nm', tm', tcs) ->- let ((nm'', tm''), mb_t) = mkTyCon nm' tm' tc in- (nm'', tm'', maybeToList mb_t ++ tcs))- (nm2, tm, [])- raw_tycons in+ let raw_tycons = G2.mgcc_tycons mgcc ++ typeEnvTyCons (G2.mgcc_type_env mgcc)+ tycons <- foldM (\tcs tc -> do+ (n, mb_t) <- mkTyCon tc+ return $ maybe tcs (\t -> HM.insert n t tcs) mb_t)+ HM.empty+ raw_tycons -- Do the class- let classes = map (mkClass tm2) $ G2.mgcc_cls_insts mgcc in+ classes <- mapM mkClass $ G2.mgcc_cls_insts mgcc -- Do the rules- let rules = if G2.load_rewrite_rules tr_con- then mapMaybe (mkRewriteRule nm3 tm2 breaks) $ G2.mgcc_rules mgcc- else [] in+ rules <- if G2.load_rewrite_rules tr_con+ then mapM (mkRewriteRule breaks) $ G2.mgcc_rules mgcc+ else return [] -- Do the exports- let exports = G2.mgcc_exports mgcc in- let deps = fmap T.pack $ G2.mgcc_deps mgcc in- (nm3, tm2,- G2.ExtractedG2- { G2.exg2_mod_names = maybeToList $ fmap T.pack $ G2.mgcc_mod_name mgcc- , G2.exg2_binds = binds- , G2.exg2_tycons = tycons- , G2.exg2_classes = classes- , G2.exg2_exports = exports- , G2.exg2_deps = deps- , G2.exg2_rules = rules })+ let exports = G2.mgcc_exports mgcc+ let deps = fmap T.pack $ G2.mgcc_deps mgcc+ return (G2.ExtractedG2+ { G2.exg2_mod_names = [fmap T.pack $ G2.mgcc_mod_name mgcc]+ , G2.exg2_binds = binds+ , G2.exg2_tycons = tycons+ , G2.exg2_classes = classes+ , G2.exg2_exports = exports+ , G2.exg2_deps = deps+ , G2.exg2_rules = catMaybes rules }) mkModGutsClosuresFromFile :: Maybe HscTarget@@ -320,37 +365,75 @@ env <- getSession mod_graph <- getModuleGraph- parsed_mods <- mapM parseModule mod_graph++ let msums = convertModuleGraph mod_graph+ parsed_mods <- mapM parseModule msums+ typed_mods <- mapM typecheckModule parsed_mods desug_mods <- mapM desugarModule typed_mods return (env, map coreModule desug_mods) if G2.simpl tr_con then do- simpls <- mapM (hscSimplify env) modgutss- closures <- mapM (mkModGutsClosure env) simpls- return closures+ simpls <- mapM (hscSimplifyC env) modgutss+ mapM (mkModGutsClosure env) simpls else do- closures <- mapM (mkModGutsClosure env) modgutss- return closures+ mapM (mkModGutsClosure env) modgutss +{-# INLINE convertModuleGraph #-}+convertModuleGraph :: ModuleGraph -> [ModSummary]+#if __GLASGOW_HASKELL__ < 806+convertModuleGraph = id+#else+convertModuleGraph = mgModSummaries+#endif++{-# INLINE hscSimplifyC #-}+hscSimplifyC :: HscEnv -> ModGuts -> IO ModGuts+#if __GLASGOW_HASKELL__ < 806+hscSimplifyC = hscSimplify+#else+hscSimplifyC env = hscSimplify env []+#endif++ -- This one will need to do the Tidy program stuff mkModGutsClosure :: HscEnv -> ModGuts -> IO G2.ModGutsClosure mkModGutsClosure env modguts = do+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+ tidy_opts <- initTidyOpts env+ (cgguts, moddets) <- tidyProgram tidy_opts modguts+#else (cgguts, moddets) <- tidyProgram env modguts+#endif return G2.ModGutsClosure { G2.mgcc_mod_name = Just $ moduleNameString $ moduleName $ cg_module cgguts , G2.mgcc_binds = cg_binds cgguts , G2.mgcc_tycons = cg_tycons cgguts , G2.mgcc_breaks = cg_modBreaks cgguts- , G2.mgcc_cls_insts = md_insts moddets+ , G2.mgcc_cls_insts = getClsInst moddets , G2.mgcc_type_env = md_types moddets , G2.mgcc_exports = exportedNames moddets- , G2.mgcc_deps = map (moduleNameString . fst) $ dep_mods $ mg_deps modguts+ , G2.mgcc_deps = getModuleNames $ mg_deps modguts , G2.mgcc_rules = mg_rules modguts } +getClsInst :: ModDetails -> [ClsInst]+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+getClsInst = instEnvElts . md_insts+#else+getClsInst = md_insts+#endif +getModuleNames :: Dependencies -> [String]+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+getModuleNames = map moduleNameString . dep_sig_mods+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+getModuleNames = map (moduleNameString . gwib_mod) . dep_mods+#else+getModuleNames = map (moduleNameString . fst) . dep_mods+#endif+ -- Merging, order matters! mergeExtractedG2s :: [G2.ExtractedG2] -> G2.ExtractedG2 mergeExtractedG2s [] = G2.emptyExtractedG2@@ -358,8 +441,8 @@ let g2' = mergeExtractedG2s g2s in G2.ExtractedG2 { G2.exg2_mod_names = G2.exg2_mod_names g2 ++ G2.exg2_mod_names g2' -- order matters- , G2.exg2_binds = G2.exg2_binds g2 ++ G2.exg2_binds g2'- , G2.exg2_tycons = G2.exg2_tycons g2 ++ G2.exg2_tycons g2'+ , G2.exg2_binds = G2.exg2_binds g2 `HM.union` G2.exg2_binds g2'+ , G2.exg2_tycons = G2.exg2_tycons g2 `HM.union` G2.exg2_tycons g2' , G2.exg2_classes = G2.exg2_classes g2 ++ G2.exg2_classes g2' , G2.exg2_exports = G2.exg2_exports g2 ++ G2.exg2_exports g2' , G2.exg2_deps = G2.exg2_deps g2 ++ G2.exg2_deps g2'@@ -368,40 +451,49 @@ ---------------- -- Translating the individual components in CoreSyn, etc into G2 Core -mkBinds :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreBind -> (G2.NameMap, [(G2.Id, G2.Expr)])-mkBinds nm tm mb (NonRec var expr) = - let- (i, nm') = mkIdUpdatingNM var nm tm- in- (nm', [(i, mkExpr nm' tm mb expr)])-mkBinds nm tm mb (Rec ves) =- mapAccumR (\nm' (v, e) ->- let- (i, nm'') = mkIdUpdatingNM v nm' tm- in- (nm'', (i, mkExpr nm'' tm mb e))- ) nm ves+mkBinds :: Maybe ModBreaks -> CoreBind -> G2.NamesM (HM.HashMap G2.Name G2.Expr)+mkBinds mb (NonRec var expr) = do+ i <- mkIdLookup var+ e <- mkExpr mb expr+ return $ HM.singleton (G2.idName i) e+mkBinds mb (Rec ves) =+ return . HM.fromList =<<+ mapM (\(v, expr) -> do+ i <- mkIdLookup v+ e <- mkExpr mb expr+ return (G2.idName i, e)) ves -mkExpr :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreExpr -> G2.Expr-mkExpr nm tm _ (Var var) = G2.Var (mkIdLookup var nm tm)-mkExpr _ _ _ (Lit lit) = G2.Lit (mkLit lit)-mkExpr nm tm mb (App fxpr axpr) = G2.App (mkExpr nm tm mb fxpr) (mkExpr nm tm mb axpr)-mkExpr nm tm mb (Lam var expr) = G2.Lam (mkLamUse var) (mkId tm var) (mkExpr nm tm mb expr)-mkExpr nm tm mb (Let bnd expr) = G2.Let (mkBind nm tm mb bnd) (mkExpr nm tm mb expr)-mkExpr nm tm mb (Case mxpr var _ alts) = G2.Case (mkExpr nm tm mb mxpr) (mkId tm var) (mkAlts nm tm mb alts)-mkExpr nm tm mb (Cast expr c) = G2.Cast (mkExpr nm tm mb expr) (mkCoercion tm c)-mkExpr _ tm _ (Coercion c) = G2.Coercion (mkCoercion tm c)-mkExpr nm tm mb (Tick t expr) =+mkExpr :: Maybe ModBreaks -> CoreExpr -> G2.NamesM G2.Expr+mkExpr _ (Var var) = return . G2.Var =<< mkIdLookup var+mkExpr _ (Lit lit) = return $ G2.Lit (mkLit lit)+mkExpr mb (App fxpr axpr) = liftM2 G2.App (mkExpr mb fxpr) (mkExpr mb axpr)+mkExpr mb (Lam var expr) = liftM2 (G2.Lam (mkLamUse var)) (valId var) (mkExpr mb expr)+mkExpr mb (Let bnd expr) = liftM2 G2.Let (mkBind mb bnd) (mkExpr mb expr)+mkExpr mb (Case mxpr var t alts) = do+ bindee <- mkExpr mb mxpr+ binder <- valId var+ ty <- mkType t+ as <- mkAlts mb alts+ return $ G2.Case bindee binder ty as+mkExpr mb (Cast expr c) = liftM2 G2.Cast (mkExpr mb expr) (mkCoercion c)+mkExpr _ (Coercion c) = liftM G2.Coercion (mkCoercion c)+mkExpr mb (Tick t expr) = case createTickish mb t of- Just t' -> G2.Tick t' $ mkExpr nm tm mb expr- Nothing -> mkExpr nm tm mb expr-mkExpr _ tm _ (Type ty) = G2.Type (mkType tm ty)+ Just t' -> return . G2.Tick t' =<< mkExpr mb expr+ Nothing -> mkExpr mb expr+mkExpr _ (Type ty) = liftM G2.Type (mkType ty) +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+createTickish :: Maybe ModBreaks -> GenTickish i -> Maybe G2.Tickish+#else createTickish :: Maybe ModBreaks -> Tickish i -> Maybe G2.Tickish+#endif createTickish (Just mb) (Breakpoint {breakpointId = bid}) = case mkSpan $ modBreaks_locs mb A.! bid of Just s -> Just $ G2.Breakpoint $ s Nothing -> Nothing+createTickish _ (HpcTick { tickModule = md, tickId = i}) =+ Just . G2.HpcTick i . T.pack . moduleNameString $ moduleName md createTickish _ _ = Nothing mkLamUse :: Id -> G2.LamUse@@ -409,30 +501,17 @@ | isTyVar v = G2.TypeL | otherwise = G2.TermL -mkId :: G2.TypeNameMap -> Id -> G2.Id-mkId tm vid = G2.Id ((mkName . V.varName) vid) ((mkType tm . varType) vid)---- Makes an Id, not respecting UniqueIds-mkIdUnsafe :: Id -> G2.Id-mkIdUnsafe vid = G2.Id ((mkName . V.varName) vid) (mkType HM.empty . varType $ vid)--mkIdLookup :: Id -> G2.NameMap -> G2.TypeNameMap -> G2.Id-mkIdLookup i nm tm =- let- n = mkNameLookup (V.varName i) nm- t = mkType tm . varType $ i- in- G2.Id n t+valId :: Id -> G2.NamesM G2.Id+valId vid = liftM2 G2.Id (valNameLookup . varName $ vid) (mkType . varType $ vid) -mkIdUpdatingNM :: Id -> G2.NameMap -> G2.TypeNameMap -> (G2.Id, G2.NameMap)-mkIdUpdatingNM vid nm tm =- let- n@(G2.Name n' m _ _) = flip mkNameLookup nm . V.varName $ vid- i = G2.Id n ((mkType tm . varType) vid)+typeId :: Id -> G2.NamesM G2.Id+typeId vid = liftM2 G2.Id (typeNameLookup . varName $ vid) (mkType . varType $ vid) - nm' = HM.insert (n', m) n nm- in- (i, nm')+mkIdLookup :: Id -> G2.NamesM G2.Id+mkIdLookup i = do+ n <- valNameLookup (varName i)+ t <- mkType . varType $ i+ return $ G2.Id n t mkName :: Name -> G2.Name mkName name = G2.Name occ mdl unq sp@@ -445,15 +524,29 @@ sp = mkSpan $ getSrcSpan name -mkNameLookup :: Name -> G2.NameMap -> G2.Name-mkNameLookup name nm =+valNameLookup :: Name -> G2.NamesM G2.Name+valNameLookup n = do+ (nm, tm) <- SM.get+ (n', nm') <- nameLookup nm n+ SM.put (nm', tm)+ return n'++typeNameLookup :: Name -> G2.NamesM G2.Name+typeNameLookup n = do+ (nm, tm) <- SM.get+ (n', tm') <- nameLookup tm n+ SM.put (nm, tm')+ return n'++nameLookup :: HM.HashMap (T.Text, Maybe T.Text) G2.Name -> Name -> G2.NamesM (G2.Name, HM.HashMap (T.Text, Maybe T.Text) G2.Name)+nameLookup nm name = do -- We only lookup in the G2.NameMap if the Module name is not Nothing -- Internally, a module may use multiple variables with the same name and a module Nothing- case mdl of- Nothing -> G2.Name occ mdl unq sp- _ -> case HM.lookup (occ, mdl) nm of- Just (G2.Name n' m i _) -> G2.Name n' m i sp- Nothing -> G2.Name occ mdl unq sp+ return $ case mdl of+ Nothing -> (G2.Name occ mdl unq sp, nm)+ _ -> case HM.lookup (occ, mdl) nm of+ Just (G2.Name n' m i _) -> (G2.Name n' m i sp, nm)+ Nothing -> let n = G2.Name occ mdl unq sp in (n, HM.insert (occ, mdl) n nm) where occ = T.pack . occNameString . nameOccName $ name unq = getKey . nameUnique $ name@@ -464,7 +557,11 @@ sp = mkSpan $ getSrcSpan name mkSpan :: SrcSpan -> Maybe G2.Span+#if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0)+mkSpan (RealSrcSpan s _) = Just $ mkRealSpan s+#else mkSpan (RealSrcSpan s) = Just $ mkRealSpan s+#endif mkSpan _ = Nothing mkRealSpan :: RealSrcSpan -> G2.Span@@ -489,179 +586,242 @@ Nothing -> Just m mkLit :: Literal -> G2.Lit+#if __GLASGOW_HASKELL__ < 808 mkLit (MachChar chr) = G2.LitChar chr mkLit (MachStr bstr) = G2.LitString (C.unpack bstr)+#else+mkLit (LitChar chr) = G2.LitChar chr+mkLit (LitString bstr) = G2.LitString (C.unpack bstr)+#endif++#if __GLASGOW_HASKELL__ < 806 mkLit (MachInt i) = G2.LitInt (fromInteger i) mkLit (MachInt64 i) = G2.LitInt (fromInteger i) mkLit (MachWord i) = G2.LitInt (fromInteger i) mkLit (MachWord64 i) = G2.LitInt (fromInteger i)+mkLit (LitInteger i _) = G2.LitInteger (fromInteger i)+#elif __GLASGOW_HASKELL__ <= 810+mkLit (LitNumber LitNumInteger i _) = G2.LitInteger (fromInteger i)+mkLit (LitNumber LitNumNatural i _) = G2.LitInteger (fromInteger i)+mkLit (LitNumber LitNumInt i _) = G2.LitInt (fromInteger i)+mkLit (LitNumber LitNumInt64 i _) = G2.LitInt (fromInteger i)+mkLit (LitNumber LitNumWord i _) = G2.LitInt (fromInteger i)+mkLit (LitNumber LitNumWord64 i _) = G2.LitInt (fromInteger i)+#elif __GLASGOW_HASKELL__ <= 902+mkLit (LitNumber LitNumInteger i) = G2.LitInteger (fromInteger i)+mkLit (LitNumber LitNumNatural i) = G2.LitInteger (fromInteger i)+mkLit (LitNumber LitNumInt i) = G2.LitInt (fromInteger i)+mkLit (LitNumber LitNumInt64 i) = G2.LitInt (fromInteger i)+mkLit (LitNumber LitNumWord i) = G2.LitInt (fromInteger i)+mkLit (LitNumber LitNumWord64 i) = G2.LitInt (fromInteger i)+#else+mkLit (LitNumber LitNumInt i) = G2.LitInt (fromInteger i)+mkLit (LitNumber LitNumInt64 i) = G2.LitInt (fromInteger i)+mkLit (LitNumber LitNumWord i) = G2.LitInt (fromInteger i)+mkLit (LitNumber LitNumWord64 i) = G2.LitInt (fromInteger i)+#endif++#if __GLASGOW_HASKELL__ < 808 mkLit (MachFloat rat) = G2.LitFloat rat mkLit (MachDouble rat) = G2.LitDouble rat-mkLit (LitInteger i _) = G2.LitInteger (fromInteger i)+#else+mkLit (LitFloat rat) = G2.LitFloat rat+mkLit (LitDouble rat) = G2.LitDouble rat+#endif mkLit _ = error "mkLit: unhandled Lit" -- mkLit (MachNullAddr) = error "mkLit: MachNullAddr" -- mkLit (MachLabel _ _ _ ) = error "mkLit: MachLabel" -mkBind :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreBind -> [(G2.Id, G2.Expr)]-mkBind nm tm mb (NonRec var expr) = [(mkId tm var, mkExpr nm tm mb expr)]-mkBind nm tm mb (Rec ves) = map (\(v, e) -> (mkId tm v, mkExpr nm tm mb e)) ves+mkBind :: Maybe ModBreaks -> CoreBind -> G2.NamesM [(G2.Id, G2.Expr)]+mkBind mb (NonRec var expr) = do+ i <- valId var+ e <- mkExpr mb expr+ return [(i, e)]+mkBind mb (Rec ves) = mapM (\(v, e) -> do i <- valId v+ e' <- mkExpr mb e+ return (i, e')) ves -mkAlts :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> [CoreAlt] -> [G2.Alt]-mkAlts nm tm mb = map (mkAlt nm tm mb)+mkAlts :: Maybe ModBreaks -> [CoreAlt] -> G2.NamesM [G2.Alt]+mkAlts mb = mapM (mkAlt mb) -mkAlt :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreAlt -> G2.Alt-mkAlt nm tm mb (acon, prms, expr) = G2.Alt (mkAltMatch nm tm acon prms) (mkExpr nm tm mb expr)+mkAlt :: Maybe ModBreaks -> CoreAlt -> G2.NamesM G2.Alt+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+mkAlt mb (Alt acon prms expr) = liftM2 G2.Alt (mkAltMatch acon prms) (mkExpr mb expr)+#else+mkAlt mb (acon, prms, expr) = liftM2 G2.Alt (mkAltMatch acon prms) (mkExpr mb expr)+#endif -mkAltMatch :: G2.NameMap -> G2.TypeNameMap -> AltCon -> [Var] -> G2.AltMatch-mkAltMatch nm tm (DataAlt dcon) params = G2.DataAlt (mkData nm tm dcon) (map (mkId tm) params)-mkAltMatch _ _ (LitAlt lit) _ = G2.LitAlt (mkLit lit)-mkAltMatch _ _ (DEFAULT) _ = G2.Default+mkAltMatch :: AltCon -> [Var] -> G2.NamesM G2.AltMatch+mkAltMatch (DataAlt dcon) params = liftM2 G2.DataAlt (mkData dcon) (mapM valId params)+mkAltMatch (LitAlt lit) _ = return $ G2.LitAlt (mkLit lit)+mkAltMatch DEFAULT _ = return G2.Default -mkType :: G2.TypeNameMap -> Type -> G2.Type-mkType tm (TyVarTy v) = G2.TyVar $ mkId tm v-mkType tm (AppTy t1 t2) = G2.TyApp (mkType tm t1) (mkType tm t2)-mkType tm (FunTy t1 t2) = G2.TyFun (mkType tm t1) (mkType tm t2)-mkType tm (ForAllTy b ty) = G2.TyForAll (mkTyBinder tm b) (mkType tm ty)-mkType _ (LitTy _) = G2.TyBottom--- mkType _ (CastTy _ _) = error "mkType: CastTy"-mkType _ (CastTy _ _) = G2.TyUnknown-mkType _ (CoercionTy _) = G2.TyUnknown--- mkType _ (CoercionTy _) = error "mkType: Coercion"-mkType tm (TyConApp tc ts)+mkType :: Type -> G2.NamesM G2.Type+mkType (TyVarTy v) = liftM G2.TyVar $ typeId v+mkType (AppTy t1 t2) = liftM2 G2.TyApp (mkType t1) (mkType t2)+#if __GLASGOW_HASKELL__ < 808+mkType (FunTy t1 t2) = liftM2 G2.TyFun (mkType t1) (mkType t2)+#elif __GLASGOW_HASKELL__ <= 810+mkType (FunTy _ t1 t2) = liftM2 G2.TyFun (mkType t1) (mkType t2)+#else+mkType (FunTy _ _ t1 t2) = liftM2 G2.TyFun (mkType t1) (mkType t2)+#endif+mkType (ForAllTy b ty) = liftM2 G2.TyForAll (mkTyBinder b) (mkType ty)+mkType (LitTy _) = return G2.TyBottom+-- mkType (CastTy _ _) = error "mkType: CastTy"+mkType (CastTy _ _) = return G2.TyUnknown+mkType (CoercionTy _) = return G2.TyUnknown+-- mkType (CoercionTy _) = error "mkType: Coercion"+mkType (TyConApp tc ts)+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+#else | isFunTyCon tc , length ts == 2 = case ts of- (t1:t2:[]) -> G2.TyFun (mkType tm t1) (mkType tm t2)+ [t1, t2] -> liftM2 G2.TyFun (mkType t1) (mkType t2) _ -> error "mkType: non-arity 2 FunTyCon from GHC"- | G2.Name n _ _ _ <- mkName $ tyConName tc- , n == "TYPE" = G2.TYPE- | otherwise = mkG2TyCon (mkTyConName tm tc) (map (mkType tm) ts) (mkType tm $ tyConKind tc) +#endif+ | G2.Name "Type" _ _ _ <- mkName $ tyConName tc = return G2.TYPE+ | G2.Name "TYPE" _ _ _ <- mkName $ tyConName tc = return G2.TYPE+ | G2.Name "->" _ _ _ <- mkName $ tyConName tc+ , [_, _, t1, t2] <- ts = liftM2 G2.TyFun (mkType t1) (mkType t2)+ | otherwise = liftM3 mkG2TyCon (mkTyConName tc) (mapM mkType ts) (mkType $ tyConKind tc) -mkTyCon :: G2.NameMap -> G2.TypeNameMap -> TyCon -> ((G2.NameMap, G2.TypeNameMap), Maybe G2.ProgramType)-mkTyCon nm tm t = case dcs of- Just dcs' -> ((nm'', tm''), Just (n, dcs'))- Nothing -> ((nm'', tm''), Nothing)- where- n@(G2.Name n' m _ _) = flip mkNameLookup tm . tyConName $ t- tm' = HM.insert (n', m) n tm+mkTyCon :: TyCon -> G2.NamesM (G2.Name, Maybe G2.AlgDataTy)+mkTyCon t = do+ n@(G2.Name n' m _ _) <- typeNameLookup . tyConName $ t - nm' = foldr (uncurry HM.insert) nm- $ map (\n_@(G2.Name n'_ m_ _ _) -> ((n'_, m_), n_)) - $ map (flip mkNameLookup nm . dataConName) $ visibleDataCons (algTyConRhs t)+ (nm, tm) <- SM.get+ let tm' = HM.insert (n', m) n tm+ + dc_names <- mapM (valNameLookup . dataConName) $ visibleDataCons (algTyConRhs t)+ let nm' = foldr (uncurry HM.insert) nm+ . map (\n_@(G2.Name n'_ m_ _ _) -> ((n'_, m_), n_)) + $ dc_names - bv = map (mkId tm) $ tyConTyVars t+ bv <- mapM typeId $ tyConTyVars t - (nm'', tm'', dcs, dcsf) =+ dcs <- case isAlgTyCon t of - True -> case algTyConRhs t of- DataTyCon { data_cons = dc } -> - ( nm'- , tm'- , Just $ G2.DataTyCon bv $ map (mkData nm' tm) dc- , Just $ map (mkId tm'' . dataConWorkId) dc)+ True -> do+ SM.put (nm', tm')+ case algTyConRhs t of+ DataTyCon { data_cons = dc } -> do+ dcs <- mapM mkData dc+ return . Just $ G2.DataTyCon bv dcs NewTyCon { data_con = dc- , nt_rhs = rhst} -> - ( nm'- , tm'- , Just $ G2.NewTyCon { G2.bound_ids = bv- , G2.data_con = mkData nm' tm dc- , G2.rep_type = mkType tm rhst}- , Just $ [(mkId tm'' . dataConWorkId) dc])+ , nt_rhs = rhst} -> do+ dc' <- mkData dc+ t' <- mkType rhst+ return .+ Just $ G2.NewTyCon { G2.bound_ids = bv+ , G2.data_con = dc'+ , G2.rep_type = t'} AbstractTyCon {} -> error "Unhandled TyCon AbstractTyCon" -- TupleTyCon {} -> error "Unhandled TyCon TupleTyCon"- TupleTyCon { data_con = dc } ->- ( nm'- , tm'- , Just $ G2.DataTyCon bv $ [mkData nm' tm dc]- , Nothing)+ TupleTyCon { data_con = dc } -> do+ dc' <- mkData dc+ return . Just $ G2.DataTyCon bv $ [dc'] SumTyCon {} -> error "Unhandled TyCon SumTyCon" False -> case isTypeSynonymTyCon t of- True -> - let- (tv, st) = fromJust $ synTyConDefn_maybe t- st' = mkType tm st- tv' = map (mkId tm) tv- in- (nm, tm', Just $ G2.TypeSynonym { G2.bound_ids = tv'- , G2.synonym_of = st'}, Nothing)- False -> (nm, tm, Nothing, Nothing)- -- dcs = if isDataTyCon t then map mkData . data_cons . algTyConRhs $ t else []+ True -> do+ SM.put (nm, tm')+ let (tv, st) = fromJust $ synTyConDefn_maybe t+ st' <- mkType st+ tv' <- mapM typeId tv+ return . Just $ G2.TypeSynonym { G2.bound_ids = tv'+ , G2.synonym_of = st'}+ False -> return Nothing -mkTyConName :: G2.TypeNameMap -> TyCon -> G2.Name-mkTyConName tm tc =- let- n@(G2.Name n' m _ l) = mkName $ tyConName tc- in- case HM.lookup (n', m) tm of- Just (G2.Name n'' m' i _) -> G2.Name n'' m' i l- Nothing -> n+ case dcs of+ Just dcs' -> return (n, Just dcs')+ Nothing -> return (n, Nothing) -mkData :: G2.NameMap -> G2.TypeNameMap -> DataCon -> G2.DataCon-mkData nm tm datacon = G2.DataCon name ty- where- name = mkDataName nm datacon- ty = (mkType tm . dataConRepType) datacon+mkTyConName :: TyCon -> G2.NamesM G2.Name+mkTyConName tc = typeNameLookup (tyConName tc) -mkDataName :: G2.NameMap -> DataCon -> G2.Name-mkDataName nm datacon = (flip mkNameLookup nm . dataConName) datacon+mkData :: DataCon -> G2.NamesM G2.DataCon+mkData datacon = do+ name <- mkDataName datacon+ ty <- (mkType . dataConRepType) datacon+ return $ G2.DataCon name ty -mkTyBinder :: G2.TypeNameMap -> TyVarBinder -> G2.TyBinder-mkTyBinder tm (TvBndr v _) = G2.NamedTyBndr (mkId tm v)+mkDataName :: DataCon -> G2.NamesM G2.Name+mkDataName datacon = valNameLookup . dataConName $ datacon -prim_list :: [String]-prim_list = [">=", ">", "==", "/=", "<=", "<",- "&&", "||", "not",- "+", "-", "*", "/", "implies", "negate", "error", "iff" ]+mkTyBinder :: TyVarBinder -> G2.NamesM G2.Id+#if __GLASGOW_HASKELL__ < 808+mkTyBinder (TvBndr v _) = typeId v+#else+mkTyBinder (Bndr v _) = typeId v+#endif +mkCoercion :: Coercion -> G2.NamesM G2.Coercion+mkCoercion c = do+ let (Pair t1 t2) = coercionKind c+ t1' <- mkType t1+ t2' <- mkType t2+ return $ t1' G2.:~ t2' -mkCoercion :: G2.TypeNameMap -> Coercion -> G2.Coercion-mkCoercion tm c =- let- k = fmap (mkType tm) $ coercionKind c- in- (pFst k) G2.:~ (pSnd k)+mkClass :: ClsInst -> G2.NamesM (G2.Name, G2.Id, [G2.Id], [(G2.Type, G2.Id)])+mkClass (ClsInst { is_cls = c, is_dfun = dfun }) = do+ class_name <- typeNameLookup . className $ c+ i <- valId dfun+ tyvars <- mapM typeId $ classTyVars c -mkClass :: G2.TypeNameMap -> ClsInst -> (G2.Name, G2.Id, [G2.Id])-mkClass tm (ClsInst { is_cls = c, is_dfun = dfun }) = - (flip mkNameLookup tm . C.className $ c, mkId tm dfun, map (mkId tm) $ C.classTyVars c)+ sctheta <- mapM mkType $ classSCTheta c+ sel_ids <- mapM mkIdLookup $ classAllSelIds c+ let sctheta_selids = zip sctheta sel_ids+ return ( class_name+ , i+ , tyvars+ , sctheta_selids) -mkRewriteRule :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreRule -> Maybe G2.RewriteRule-mkRewriteRule nm tm breaks (Rule { ru_name = n- , ru_fn = fn- , ru_rough = rough- , ru_bndrs = bndrs- , ru_args = args- , ru_rhs = rhs }) =- let- r = G2.RewriteRule { G2.ru_name = T.pack $ unpackFS n- , G2.ru_head = mkNameLookup fn nm- , G2.ru_rough = map (fmap (flip mkNameLookup nm)) rough- , G2.ru_bndrs = map (mkId tm) bndrs- , G2.ru_args = map (mkExpr nm tm breaks) args- , G2.ru_rhs = mkExpr nm tm breaks rhs }- in- Just r-mkRewriteRule _ _ _ _ = Nothing+mkRewriteRule :: Maybe ModBreaks -> CoreRule -> G2.NamesM (Maybe G2.RewriteRule)+mkRewriteRule breaks (Rule { ru_name = n+ , ru_origin = mdl+ , ru_fn = fn+ , ru_rough = rough+ , ru_bndrs = bndrs+ , ru_args = args+ , ru_rhs = rhs }) = do+ head_name <- valNameLookup fn+ rough' <- mapM (maybe (return Nothing) (\nm -> return . Just =<< valNameLookup nm)) rough+ bndrs' <- mapM valId bndrs+ args' <- mapM (mkExpr breaks) args+ rhs' <- mkExpr breaks rhs+ let r = G2.RewriteRule { G2.ru_name = T.pack $ unpackFS n+ , G2.ru_module = T.pack . moduleNameString $ moduleName mdl+ , G2.ru_head = head_name+ , G2.ru_rough = rough'+ , G2.ru_bndrs = bndrs'+ , G2.ru_args = args'+ , G2.ru_rhs = rhs' }+ return $ Just r+mkRewriteRule _ _ = return Nothing exportedNames :: ModDetails -> [G2.ExportedName] exportedNames = concatMap availInfoNames . md_exports availInfoNames :: AvailInfo -> [G2.ExportedName]+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+availInfoNames (Avail n) = [greNameToName n]+availInfoNames (AvailTC n ns) = mkName n:map greNameToName ns++greNameToName :: GreName -> G2.Name+greNameToName (NormalGreName n) = mkName n+greNameToName (FieldGreName fl) = mkName $ flSelector fl+#else availInfoNames (Avail n) = [mkName n] availInfoNames (AvailTC n ns _) = mkName n:map mkName ns+#endif -- | absVarLoc' -- Switches all file paths in Var namesand Ticks to be absolute-absVarLoc :: G2.Program -> IO G2.Program-absVarLoc = - mapM - (mapM (\(i, e) -> do - e' <- absVarLoc' e- return (i, e')- )- )-+absVarLoc :: HM.HashMap G2.Name G2.Expr -> IO (HM.HashMap G2.Name G2.Expr)+absVarLoc = mapM absVarLoc'+ absVarLoc' :: G2.Expr -> IO G2.Expr absVarLoc' (G2.Var (G2.Id (G2.Name n m i (Just s)) t)) = do return $ G2.Var $ G2.Id (G2.Name n m i (Just $ s)) t@@ -677,10 +837,10 @@ ) b e' <- absVarLoc' e return $ G2.Let b' e'-absVarLoc' (G2.Case e i as) = do+absVarLoc' (G2.Case e i t as) = do e' <- absVarLoc' e as' <- mapM (\(G2.Alt a ae) -> return . G2.Alt a =<< absVarLoc' ae) as- return $ G2.Case e' i as'+ return $ G2.Case e' i t as' absVarLoc' (G2.Cast e c) = do e' <- absVarLoc' e return $ G2.Cast e' c@@ -783,6 +943,7 @@ [] -> return $ takeDirectory absTgt dirContainsCabal :: FilePath -> IO Bool+dirContainsCabal "" = return False dirContainsCabal dir = do exists <- doesDirectoryExist dir if exists then do@@ -796,3 +957,23 @@ dir <- guessProj fp files <- listDirectory dir return $ find (\f -> ".cabal" `isSuffixOf` f) files++-------------------------------------------------------------------------------+-- Unsafe construction+-------------------------------------------------------------------------------++mkUnsafe :: G2.NamesM a -> a+mkUnsafe nms = SM.evalState nms (HM.empty, HM.empty)++-- | Makes an Id, not respecting uniques+mkIdUnsafe :: Id -> G2.Id+mkIdUnsafe vid = + mkUnsafe (liftM2 G2.Id (return . mkName . varName $ vid) (mkType . varType $ vid))++-- | Makes a TyCon, not respecting uniques+mkTyConNameUnsafe :: TyCon -> G2.Name+mkTyConNameUnsafe tc = mkUnsafe (mkTyConName tc)++-- | Makes a Data, not respecting uniques+mkDataUnsafe :: DataCon -> G2.DataCon+mkDataUnsafe dc = mkUnsafe (mkData dc)
src/G2/Translation/HaskellCheck.hs view
@@ -1,8 +1,7 @@ module G2.Translation.HaskellCheck ( validateStates , runHPC) where -import DynFlags-import GHC hiding (Name)+import GHC hiding (Name, entry) import GHC.Paths import Data.Either@@ -22,28 +21,61 @@ import System.Process +import Control.Monad.IO.Class+ validateStates :: [FilePath] -> [FilePath] -> String -> String -> [String] -> [GeneralFlag] -> [ExecRes t] -> IO Bool-validateStates proj src modN entry chAll ghflags in_out = do- return . all id =<< mapM (runCheck proj src modN entry chAll ghflags) in_out+validateStates proj src modN entry chAll gflags in_out = do+ return . all id =<< runGhc (Just libdir) (do+ loadToCheck proj src modN gflags+ mapM (runCheck modN entry chAll) in_out) -- Compile with GHC, and check that the output we got is correct for the input-runCheck :: [FilePath] -> [FilePath] -> String -> String -> [String] -> [GeneralFlag] -> ExecRes t -> IO Bool-runCheck proj src modN entry chAll gflags (ExecRes {final_state = s, conc_args = ars, conc_out = out}) = do- (v, chAllR) <- runGhc (Just libdir) (runCheck' proj src modN entry chAll gflags s ars out)+runCheck :: String -> String -> [String] -> ExecRes t -> Ghc Bool+runCheck modN entry chAll (ExecRes {final_state = s, conc_args = ars, conc_out = out}) = do+ (v, chAllR) <- runCheck' modN entry chAll s ars out - v' <- unsafeCoerce v :: IO (Either SomeException Bool)- let outStr = mkCleanExprHaskell s out+ v' <- liftIO $ (unsafeCoerce v :: IO (Either SomeException Bool))+ let outStr = T.unpack $ printHaskell s out let v'' = case v' of Left _ -> outStr == "error" Right b -> b && outStr /= "error" - chAllR' <- unsafeCoerce chAllR :: IO [Either SomeException Bool]+ chAllR' <- liftIO $ (unsafeCoerce chAllR :: IO [Either SomeException Bool]) let chAllR'' = rights chAllR' return $ v'' && and chAllR'' -runCheck' :: [FilePath] -> [FilePath] -> String -> String -> [String] -> [GeneralFlag] -> State t -> [Expr] -> Expr -> Ghc (HValue, [HValue])-runCheck' proj src modN entry chAll gflags s ars out = do+runCheck' :: String -> String -> [String] -> State t -> [Expr] -> Expr -> Ghc (HValue, [HValue])+runCheck' modN entry chAll s ars out = do+ let Left (v, _) = findFunc (T.pack entry) (Just $ T.pack modN) (expr_env s)+ let e = mkApp $ Var v:ars+ let pg = updatePrettyGuide (exprNames e)+ . updatePrettyGuide (exprNames out)+ $ mkPrettyGuide $ varIds v+ let arsStr = T.unpack $ printHaskellPG pg s e+ let outStr = T.unpack $ printHaskellPG pg s out++ let arsType = T.unpack $ mkTypeHaskell (typeOf e)+ outType = T.unpack $ mkTypeHaskell (typeOf out)++ let chck = case outStr == "error" of+ False -> "try (evaluate (" ++ arsStr ++ " == " ++ "("+ ++ outStr ++ " :: " ++ outType ++ ")" ++ ")) :: IO (Either SomeException Bool)"+ True -> "try (evaluate ( (" ++ arsStr ++ " :: " ++ arsType +++ ") == " ++ arsStr ++ ")) :: IO (Either SomeException Bool)"++ v' <- compileExpr chck++ let chArgs = ars ++ [out] + let chAllStr = map (\f -> T.unpack $ printHaskellPG pg s $ mkApp ((simpVar $ T.pack f):chArgs)) chAll+ let chAllStr' = map (\str -> "try (evaluate (" ++ str ++ ")) :: IO (Either SomeException Bool)") chAllStr++ chAllR <- mapM compileExpr chAllStr'++ return $ (v', chAllR)++loadToCheck :: [FilePath] -> [FilePath] -> String -> [GeneralFlag] -> Ghc ()+loadToCheck proj src modN gflags = do _ <- loadProj Nothing proj src gflags simplTranslationConfig let prN = mkModuleName "Prelude"@@ -52,28 +84,16 @@ let exN = mkModuleName "Control.Exception" let exImD = simpleImportDecl exN - let mdN = mkModuleName modN- let imD = simpleImportDecl mdN-- setContext [IIDecl prImD, IIDecl exImD, IIDecl imD]-- let Left (v, _) = findFunc (T.pack entry) (Just $ T.pack modN) (expr_env s)- let e = mkApp $ Var v:ars- let arsStr = mkCleanExprHaskell s e- let outStr = mkCleanExprHaskell s out- let chck = case outStr == "error" of- False -> "try (evaluate (" ++ arsStr ++ " == " ++ outStr ++ ")) :: IO (Either SomeException Bool)"- True -> "try (evaluate (" ++ arsStr ++ " == " ++ arsStr ++ ")) :: IO (Either SomeException Bool)"-- v' <- compileExpr chck+ let coerceN = mkModuleName "Data.Coerce"+ let coerceImD = simpleImportDecl coerceN - let chArgs = ars ++ [out] - let chAllStr = map (\f -> mkCleanExprHaskell s $ mkApp ((simpVar $ T.pack f):chArgs)) chAll- let chAllStr' = map (\str -> "try (evaluate (" ++ str ++ ")) :: IO (Either SomeException Bool)") chAllStr+ let charN = mkModuleName "Data.Char"+ let charD = simpleImportDecl charN - chAllR <- mapM compileExpr chAllStr'+ let mdN = mkModuleName modN+ let imD = simpleImportDecl mdN - return $ (v', chAllR)+ setContext [IIDecl prImD, IIDecl exImD, IIDecl coerceImD, IIDecl imD, IIDecl charD] simpVar :: T.Text -> Expr simpVar s = Var (Id (Name s Nothing 0 Nothing) TyBottom)@@ -108,7 +128,7 @@ -- putStrLn mainFunc toCall :: String -> State t -> [Expr] -> Expr -> String-toCall entry s ars _ = mkCleanExprHaskell s $ mkApp ((simpVar $ T.pack entry):ars)+toCall entry s ars _ = T.unpack . printHaskell s $ mkApp ((simpVar $ T.pack entry):ars) removeModule :: String -> String -> String removeModule modN s =
src/G2/Translation/InjectSpecials.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module G2.Translation.InjectSpecials ( specialTypes@@ -14,8 +14,8 @@ _MAX_TUPLE :: Int _MAX_TUPLE = 62 -specialTypes :: [ProgramType]-specialTypes = map (uncurry specialTypes') specials+specialTypes :: HM.HashMap Name AlgDataTy+specialTypes = HM.fromList $ map (uncurry specialTypes') specials ++ mkPrimTuples _MAX_TUPLE specialTypes' :: (T.Text, Maybe T.Text, [Name]) -> [(T.Text, Maybe T.Text, [Type])] -> (Name, AlgDataTy) specialTypes' (n, m, ns) dcn = @@ -31,22 +31,25 @@ tv = map (TyVar . flip Id TYPE) ns t = foldr (TyFun) (mkFullAppedTyCon tn tv TYPE) ts- t' = foldr (\n' -> TyForAll (NamedTyBndr (Id n' TYPE))) t ns+ t' = foldr (\n' -> TyForAll (Id n' TYPE)) t ns in DataCon (Name n m 0 Nothing) t' specialTypeNames :: HM.HashMap (T.Text, Maybe T.Text) Name-specialTypeNames = HM.fromList $ map (\(n, m, _) -> ((n, m), Name n m 0 Nothing)) specialTypeNames'+specialTypeNames = -- HM.fromList $ map (\(n, m, _) -> ((n, m), Name n m 0 Nothing)) specialTypeNames'+ HM.fromList . map (\nm@(Name n m _ _) -> ((n, m), nm)) $ HM.keys specialTypes specialConstructors :: HM.HashMap (T.Text, Maybe T.Text) Name specialConstructors =- HM.fromList $ map (\nm@(n, m) -> (nm, Name n m 0 Nothing)) specialConstructors'+ -- GHC 9.4 on use different constructors than our base for Integers, so we add a special mapping+ -- for those constructor (via `integerConstructor` to adjust Names accordingly)+ HM.fromList $ integerConstructor:map (\(DataCon nm@(Name n m _ _) _)-> ((n, m), nm)) specialConstructors' -specialTypeNames' :: [(T.Text, Maybe T.Text, [Name])]-specialTypeNames' = map fst specials+integerConstructor :: ((T.Text, Maybe T.Text), Name)+integerConstructor = (("IS", Just "GHC.Num.Integer"), Name "Z#" (Just "GHC.Num.Integer") 0 Nothing) -specialConstructors' :: [(T.Text, Maybe T.Text)]-specialConstructors' = map (\(n, m, _) -> (n, m)) $ concatMap snd specials+specialConstructors' :: [DataCon]+specialConstructors' = concatMap data_cons $ HM.elems specialTypes -- map (\(n, m, _) -> (n, m)) $ concatMap snd specials aName :: Name aName = Name "a" Nothing 0 Nothing@@ -54,33 +57,44 @@ aTyVar :: Type aTyVar = TyVar (Id aName TYPE) +listTypeStr :: T.Text+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+listTypeStr = "List"+#else+listTypeStr = "[]"+#endif+ listName :: Name-listName = Name "[]" (Just "GHC.Types") 0 Nothing+listName = Name listTypeStr (Just "GHC.Types") 0 Nothing specials :: [((T.Text, Maybe T.Text, [Name]), [(T.Text, Maybe T.Text, [Type])])]-specials = [ (( "[]"+specials =+ [ (( listTypeStr , Just "GHC.Types", [aName]) , [ ("[]", Just "GHC.Types", []) , (":", Just "GHC.Types", [aTyVar, mkFullAppedTyCon listName [aTyVar] TYPE])] )- -- , (("Int", Just "GHC.Types"), [("I#", Just "GHC.Types", [TyLitInt])]) -- , (("Float", Just "GHC.Types"), [("F#", Just "GHC.Types", [TyLitFloat])]) -- , (("Double", Just "GHC.Types"), [("D#", Just "GHC.Types", [TyLitDouble])]) -- , (("Char", Just "GHC.Types"), [("C#", Just "GHC.Types", [TyLitChar])]) -- , (("String", Just "GHC.Types"), []) - , (("Bool", Just "GHC.Types", []), [ ("True", Just "GHC.Types", [])- , ("False", Just "GHC.Types", [])])+ , (("Bool", Just "GHC.Types", []), [ ("False", Just "GHC.Types", [])+ , ("True", Just "GHC.Types", [])]) -- , (("Ordering", Just "GHC.Types"), [ ("EQ", Just "GHC.Types", []) -- , ("LT", Just "GHC.Types", []) -- , ("GT", Just "GHC.Types", [])]) ] +++#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+ mkTuples "(" ")" (Just "GHC.Tuple.Prim") _MAX_TUPLE+#else mkTuples "(" ")" (Just "GHC.Tuple") _MAX_TUPLE- ++- mkTuples "(#" "#)" (Just "GHC.Prim") _MAX_TUPLE+#endif+ -- +++ -- mkTuples "(#" "#)" (Just "GHC.Prim") _MAX_TUPLE mkTuples :: T.Text -> T.Text -> Maybe T.Text -> Int -> [((T.Text, Maybe T.Text, [Name]), [(T.Text, Maybe T.Text, [Type])])]@@ -94,3 +108,34 @@ in -- ((s, m, []), [(s, m, [])]) : mkTuples (n - 1) ((s, m, ns), [(s, m, tv)]) : mkTuples ls rs m (n - 1)++mkPrimTuples :: Int -> [(Name, AlgDataTy)]+mkPrimTuples k =+ let+ dcn = mkPrimTuples' k+ in+ map (\(n, m, ns, dc) -> + let+ tn = Name n m 0 Nothing+ in+ (tn, DataTyCon {bound_ids = map (flip Id TYPE) ns, data_cons = [dc]})) dcn++mkPrimTuples' :: Int -> [(T.Text, Maybe T.Text, [Name], DataCon)]+mkPrimTuples' n | n < 0 = []+ | otherwise =+ let+ s = "(#" `T.append` T.pack (replicate n ',') `T.append` "#)"+ m = Just "GHC.Prim"+ tn = Name s m 0 Nothing++ ns = if n == 0 then [] else map (\i -> Name "a" m i Nothing) [0..n]+ rt_ns = if n == 0 then [] else map (\i -> Name "rt_" m i Nothing) [0..n]+ tv = map (TyVar . flip Id TYPE) ns++ t = foldr (TyFun) (mkFullAppedTyCon tn tv TYPE) tv+ t' = foldr (\n' -> TyForAll (Id n' TYPE)) t ns+ t'' = foldr (\n' -> TyForAll (Id n' TYPE)) t' rt_ns+ dc = DataCon (Name s m 0 Nothing) t''+ in+ -- ((s, m, []), [(s, m, [])]) : mkTuples (n - 1)+ (s, m, rt_ns ++ ns, dc) : mkPrimTuples' (n - 1)
src/G2/Translation/Interface.hs view
@@ -1,138 +1,133 @@-module G2.Translation.Interface ( translateLoaded- , translateLoadedD ) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} -import DynFlags+module G2.Translation.Interface ( translateBase+ , translateLoaded+ , specialInject ) where +import Control.Monad.Extra+import qualified Data.HashMap.Lazy as HM import Data.List import Data.Maybe import qualified Data.Text as T+import System.Directory import G2.Config-import G2.Language+import G2.Language as G2+import G2.Translation.GHC import G2.Translation.Haskell import G2.Translation.InjectSpecials import G2.Translation.PrimInject import G2.Translation.TransTypes - translateBase :: TranslationConfig -> Config+ -> [FilePath] -> Maybe HscTarget -> IO (ExtractedG2, NameMap, TypeNameMap)-translateBase tr_con config hsc = do+translateBase tr_con config extra hsc = do -- For base we have the advantage of knowing apriori the structure -- So we can list the (proj, file) pairings let base_inc = baseInclude config- let bases = base config-- translateLibPairs specialConstructors specialTypeNames tr_con config emptyExtractedG2 hsc base_inc bases+ let bases = nub $ base config ++ extra + (base_exg2, b_nm, b_tnm) <- translateLibPairs specialConstructors specialTypeNames tr_con emptyExtractedG2 hsc base_inc bases -translateLibs :: NameMap- -> TypeNameMap- -> TranslationConfig- -> Config- -> Maybe HscTarget- -> [FilePath]- -> IO (ExtractedG2, NameMap, TypeNameMap)-translateLibs nm tm tr_con config hsc fs = do- -- If we are not given anything, then we have to guess the project- let inc = map (dropWhileEnd (/= '/')) fs- translateLibPairs nm tm tr_con config emptyExtractedG2 hsc inc fs+ let base_prog = exg2_binds base_exg2+ base_tys = exg2_tycons base_exg2 + let base_tys' = base_tys `HM.union` specialTypes+ let base_prog' = addPrimsToBase base_tys' base_prog+ return (base_exg2 { exg2_binds = base_prog', exg2_tycons = base_tys' }, b_nm, b_tnm) translateLibPairs :: NameMap -> TypeNameMap -> TranslationConfig- -> Config -> ExtractedG2 -> Maybe HscTarget -> [IncludePath] -> [FilePath] -> IO (ExtractedG2, NameMap, TypeNameMap)-translateLibPairs nm tnm _ _ exg2 _ _ [] = return (exg2, nm, tnm)-translateLibPairs nm tnm tr_con config exg2 hsc inc_paths (f: fs) = do+translateLibPairs nm tnm _ exg2 _ _ [] = return (exg2, nm, tnm)+translateLibPairs nm tnm tr_con exg2 hsc inc_paths (f: fs) = do (new_nm, new_tnm, exg2') <- hskToG2ViaCgGutsFromFile hsc inc_paths [f] nm tnm tr_con- translateLibPairs new_nm new_tnm tr_con config (mergeExtractedG2s [exg2, exg2']) hsc inc_paths fs+ translateLibPairs new_nm new_tnm tr_con (mergeExtractedG2s [exg2, exg2']) hsc inc_paths fs +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+selectBackend :: TranslationConfig -> Maybe Backend+selectBackend tr | interpreter tr = Just interpreterBackend+selectBackend _ = Just noBackend+#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+selectBackend :: TranslationConfig -> Maybe Backend+selectBackend tr | interpreter tr = Just Interpreter+selectBackend _ = Just NoBackend+#else+selectBackend :: TranslationConfig -> Maybe HscTarget+selectBackend tr | interpreter tr = Just HscInterpreted+selectBackend _ = Just HscNothing+#endif+ translateLoaded :: [FilePath] -> [FilePath]- -> [FilePath] -> TranslationConfig -> Config -> IO (Maybe T.Text, ExtractedG2)-translateLoaded proj src libs tr_con config = do- (base_exg2, b_nm, b_tnm) <- translateBase tr_con config Nothing- let base_prog = [exg2_binds base_exg2]- base_tys = exg2_tycons base_exg2- b_exp = exg2_exports base_exg2--- (lib_transs, lib_nm, lib_tnm) <- translateLibs b_nm b_tnm tr_con config (Just HscInterpreted) libs- let lib_exp = exg2_exports lib_transs-- let base_tys' = base_tys ++ specialTypes- let base_prog' = addPrimsToBase base_tys' base_prog- let base_trans' = base_exg2 { exg2_binds = concat base_prog', exg2_tycons = base_tys' }-- let merged_lib = mergeExtractedG2s ([base_trans', lib_transs])-- -- Now the stuff with the actual target+translateLoaded proj src tr_con config = do+ let tr_con' = tr_con { hpc_ticks = hpc config || search_strat config == Subpath }+ -- Stuff with the actual target let def_proj = extraDefaultInclude config- def_src = extraDefaultMods config- (_, _, exg2) <- hskToG2ViaCgGutsFromFile (Just HscInterpreted) (def_proj ++ proj) (def_src ++ src) lib_nm lib_tnm tr_con- let mb_modname = listToMaybe . drop (length def_src) $ exg2_mod_names exg2- let h_exp = exg2_exports exg2+ tar_ems <- envModSumModGutsFromFile (selectBackend tr_con') (def_proj ++ proj) src tr_con' + let imports = envModSumModGutsImports tar_ems+ extra_imp <- return . catMaybes =<< mapM (findImports (baseInclude config)) imports - let merged_exg2 = mergeExtractedG2s [exg2, merged_lib]- merged_prog = [exg2_binds merged_exg2]- merged_tys = exg2_tycons merged_exg2- merged_cls = exg2_classes merged_exg2+ -- Stuff with the base library+ (base_exg2, b_nm, b_tnm) <- translateBase tr_con' config extra_imp Nothing - -- final injection phase- let (near_final_prog, final_tys) = primInject $ dataInject merged_prog merged_tys+ -- Now the stuff with the actual target+ (f_nm, f_tm, exg2) <- hskToG2ViaEMS tr_con' tar_ems b_nm b_tnm+ let mb_modname = head $ exg2_mod_names exg2+ let exg2' = adjustMkSymbolicPrim f_nm exg2 - let final_merged_cls = primInject merged_cls+ let merged_exg2 = mergeExtractedG2s [exg2', base_exg2]+ let injected_exg2@ExtractedG2 { exg2_binds = near_final_prog } = specialInject merged_exg2 final_prog <- absVarLoc near_final_prog - let final_exg2 = merged_exg2 { exg2_binds = concat final_prog- , exg2_tycons = final_tys- , exg2_classes = final_merged_cls- , exg2_exports = b_exp ++ lib_exp ++ h_exp}+ let final_exg2 = injected_exg2 { exg2_binds = final_prog } return (mb_modname, final_exg2) -translateLoadedD :: [FilePath]- -> [FilePath]- -> [FilePath]- -> TranslationConfig- -> IO (Maybe T.Text, Program, [ProgramType], [(Name, Id, [Id])], [Name])-translateLoadedD proj src libs tr_con = do- -- Read the extracted libs and merge them- -- Recall that each of these files comes with NameMap and TypeNameMap- (nm, tnm, libs_g2) <- mapM readFileExtractedG2 libs >>= return . mergeFileExtractedG2s-- -- Now do the target file- (nm2, tnm2, tgt_g2) <- hskToG2ViaCgGutsFromFile (Just HscInterpreted) proj src nm tnm tr_con-- -- Combine the library g2 and extracted g2s- -- Also do absVarLoc!- let almost_g2 = mergeExtractedG2s [libs_g2, tgt_g2]- let almost_prog = [exg2_binds almost_g2]-- -- Inject the primitive stuff- let final_classes = primInject $ exg2_classes almost_g2- let (pre_prog, final_tycons) = primInject $ dataInject almost_prog $ exg2_tycons almost_g2-- final_prog <- absVarLoc pre_prog-- let name = listToMaybe $ exg2_mod_names tgt_g2- let exports = exg2_exports almost_g2+adjustMkSymbolicPrim :: NameMap -> ExtractedG2 -> ExtractedG2+adjustMkSymbolicPrim nm exg2@(ExtractedG2 { exg2_binds = binds}) =+ let+ a = Id (Name "a" Nothing 0 Nothing) TYPE+ m_sym_n = HM.lookup ("symgen", Just "G2.Symbolic") nm+ symgen_e = G2.Lam TypeL a (SymGen SLog $ TyVar a)+ in+ case m_sym_n of+ Just sym_n -> exg2 { exg2_binds = HM.insert sym_n symgen_e binds }+ Nothing -> exg2 - return (name,- final_prog,- final_tycons,- final_classes,- exports)+specialInject :: ExtractedG2 -> ExtractedG2+specialInject exg2 =+ let+ prog = exg2_binds exg2+ tys = exg2_tycons exg2+ rules = exg2_rules exg2+ cls = exg2_classes exg2+ + (prog', tys', rules') = primInject $ dataInject (prog, tys, rules) tys+ cls' = primInject cls+ in+ exg2 { exg2_binds = prog'+ , exg2_tycons = tys'+ , exg2_rules = rules'+ , exg2_classes = cls' } +findImports :: [FilePath] -> FilePath -> IO (Maybe FilePath)+findImports roots fp = do+ let fp' = map (\c -> if c == '.' then '/' else c) fp+ mr <- findM (\r -> doesFileExist $ r ++ fp' ++ ".hs") roots+ case mr of+ Just r -> return . Just $ r ++ fp' ++ ".hs"+ Nothing -> return Nothing
src/G2/Translation/PrimInject.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP, FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | Primitive inejction into the environment@@ -16,6 +16,7 @@ import G2.Language.Typing import G2.Language.TypeEnv +import qualified Data.HashMap.Lazy as HM import Data.List import qualified Data.Text as T @@ -31,12 +32,12 @@ primInjectT (TyCon (Name "Char#" _ _ _) _) = TyLitChar primInjectT t = t -dataInject :: Program -> [ProgramType] -> (Program, [ProgramType])+dataInject :: (ASTContainer t Expr) => t -> HM.HashMap Name AlgDataTy -> t dataInject prog progTy = let- dcNames = concatMap (\(_, dc) -> map conName (dataCon dc)) $ progTy+ dcNames = concatMap (map conName . dataCon) $ progTy in- (modifyASTs (dataInject' dcNames) prog, progTy)+ modifyASTs (dataInject' dcNames) prog -- TODO: Polymorphic types? dataInject' :: [(Name, [Type])] -> Expr -> Expr@@ -49,74 +50,130 @@ conName :: DataCon -> (Name, [Type]) conName (DataCon n t) = (n, anonArgumentTypes $ t) -primDefs :: [ProgramType] -> [(T.Text, Expr)]-primDefs pt = case boolName pt of- Just n -> primDefs' n- Nothing -> error "Bool type not found"+primDefs :: HM.HashMap Name AlgDataTy -> [(T.Text, Expr)]+primDefs pt = case (boolName pt, charName pt, listName pt) of+ (Just b, Just c, Just l) -> primDefs' b c l+ _ -> error "primDefs: Required types not found" -primDefs' :: Name -> [(T.Text, Expr)]-primDefs' b = [ ("==#", Prim Eq $ tyIntIntBool b)- , ("/=#", Prim Neq $ tyIntIntBool b)+primDefs' :: Name -> Name -> Name -> [(T.Text, Expr)]+primDefs' b c l =+ [ ("$==#", Prim Eq $ tyIntIntBool b)+ , ("$/=#", Prim Neq $ tyIntIntBool b) , ("+#", Prim Plus tyIntIntInt) , ("*#", Prim Mult tyIntIntInt) , ("-#", Prim Minus tyIntIntInt) , ("negateInt#", Prim Negate tyIntInt)- , ("<=#", Prim Le $ tyIntIntBool b)- , ("<#", Prim Lt $ tyIntIntBool b)- , (">#", Prim Gt $ tyIntIntBool b)- , (">=#", Prim Ge $ tyIntIntBool b)+ , ("$<=#", Prim Le $ tyIntIntBool b)+ , ("$<#", Prim Lt $ tyIntIntBool b)+ , ("$>#", Prim Gt $ tyIntIntBool b)+ , ("$>=#", Prim Ge $ tyIntIntBool b) , ("divInt#", Prim Quot tyIntIntInt) , ("modInt#", Prim Mod tyIntIntInt) , ("quotInt#", Prim Quot tyIntIntInt)- , ("remInt#", Prim Mod tyIntIntInt)+ , ("remInt#", Prim Rem tyIntIntInt) - , ("==##", Prim Eq $ tyDoubleDoubleBool b)- , ("/=##", Prim Neq $ tyDoubleDoubleBool b)+ , ("$==##", Prim Eq $ tyDoubleDoubleBool b)+ , ("$/=##", Prim Neq $ tyDoubleDoubleBool b) , ("+##", Prim Plus tyDoubleDoubleDouble) , ("*##", Prim Mult tyDoubleDoubleDouble) , ("-##", Prim Minus tyDoubleDoubleDouble) , ("negateDouble#", Prim Negate tyDoubleDouble) , ("sqrtDouble#", Prim SqRt tyDoubleDoubleDouble)- , ("<=##", Prim Le $ tyDoubleDoubleBool b)- , ("<##", Prim Lt $ tyDoubleDoubleBool b)- , (">##", Prim Gt $ tyDoubleDoubleBool b)- , (">=##", Prim Ge $ tyDoubleDoubleBool b)+ , ("/##", Prim Div tyDoubleDoubleDouble)+ , ("$<=##", Prim Le $ tyDoubleDoubleBool b)+ , ("$<##", Prim Lt $ tyDoubleDoubleBool b)+ , ("$>##", Prim Gt $ tyDoubleDoubleBool b)+ , ("$>=##", Prim Ge $ tyDoubleDoubleBool b) , ("plusFloat#", Prim Plus tyFloatFloatFloat) , ("timesFloat#", Prim Mult tyFloatFloatFloat) , ("minusFloat#", Prim Minus tyFloatFloatFloat) , ("negateFloat#", Prim Negate tyFloatFloat) , ("sqrtFloat#", Prim SqRt tyFloatFloatFloat)- , ("/##", Prim Div tyFloatFloatFloat) , ("divideFloat#", Prim Div tyFloatFloatFloat)- , ("eqFloat#", Prim Eq $ tyFloatFloatBool b)- , ("neqFloat#", Prim Neq $ tyFloatFloatBool b)- , ("leFloat#", Prim Le $ tyFloatFloatBool b)- , ("ltFloat#", Prim Lt $ tyFloatFloatBool b)- , ("gtFloat#", Prim Gt $ tyFloatFloatBool b)- , ("geFloat#", Prim Ge $ tyFloatFloatBool b)+ , ("smtEqFloat#", Prim Eq $ tyFloatFloatBool b)+ , ("smtNeFloat#", Prim Neq $ tyFloatFloatBool b)+ , ("smtLeFloat#", Prim Le $ tyFloatFloatBool b)+ , ("smtLtFloat#", Prim Lt $ tyFloatFloatBool b)+ , ("smtGtFloat#", Prim Gt $ tyFloatFloatBool b)+ , ("smtGeFloat#", Prim Ge $ tyFloatFloatBool b) , ("quotInteger#", Prim Quot tyIntIntInt)+ , ("remInteger#", Prim Rem tyIntIntInt) - , ("eqChar#", Prim Eq $ tyCharCharBool b )- , ("neChar#", Prim Neq $ tyCharCharBool b )+ , ("chr#", Prim Chr $ tyIntCharBool b )+ , ("ord#", Prim OrdChar $ tyCharIntBool b )+ , ("smtEqChar#", Prim Eq $ tyCharCharBool b )+ , ("smtNeChar#", Prim Neq $ tyCharCharBool b )+ , ("smtEqChar#", Prim Eq $ tyCharCharBool b )+ , ("gtChar#", Prim Gt $ tyCharCharBool b )+ , ("geChar#", Prim Ge $ tyCharCharBool b )+ , ("ltChar#", Prim Lt $ tyCharCharBool b )+ , ("leChar#", Prim Le $ tyCharCharBool b )+ , ("wgencat#", Prim WGenCat $ tyIntInt ) , ("float2Int#", Prim ToInt (TyFun TyLitFloat TyLitInt)) , ("int2Float#", Prim IntToFloat (TyFun TyLitInt TyLitFloat)) , ("fromIntToFloat", Prim IntToFloat (TyFun TyLitInt TyLitFloat)) , ("double2Int#", Prim ToInt (TyFun TyLitDouble TyLitInt)) , ("int2Double#", Prim IntToDouble (TyFun TyLitInt TyLitDouble))+ , ("rationalToDouble#", Prim RationalToDouble (TyFun TyLitInt $ TyFun TyLitInt TyLitDouble)) , ("fromIntToDouble", Prim IntToDouble (TyFun TyLitInt TyLitDouble)) + -- TODO: G2 doesn't currently draw a distinction between Integers and Words+ , ("integerToWord#", Lam TermL (x TyLitInt) (Var (x TyLitInt)))+ , ("plusWord#", Prim Plus tyIntIntInt)+ , ("minusWord#", Prim Minus tyIntIntInt)+ , ("timesWord#", Prim Mult tyIntIntInt)+ , ("eqWord#", Prim Eq $ tyIntIntBool b)+ , ("neWord#", Prim Neq $ tyIntIntBool b)+ , ("gtWord#", Prim Gt $ tyIntIntBool b)+ , ("geWord#", Prim Ge $ tyIntIntBool b)+ , ("ltWord#", Prim Lt $ tyIntIntBool b)+ , ("leWord#", Prim Le $ tyIntIntBool b)++ , ("dataToTag##", Prim DataToTag (TyForAll a (TyFun (TyVar a) TyLitInt)))+ , ("tagToEnum#", + Lam TypeL a+ . Lam TermL (y tyvarA)+ $ Case (Var (y tyvarA)) (binder tyvarA) tyvarA + [ Alt Default+ $ App+ (App+ (Prim TagToEnum (TyForAll a (TyFun TyLitInt tyvarA)))+ (Var a))+ (Var $ y tyvarA)++ ])++ , ("intToString#", Prim IntToString (TyFun TyLitInt (TyApp (TyCon l (TyFun TYPE TYPE)) (TyCon c TYPE))))+ , ("absentErr", Prim Error TyBottom) , ("error", Prim Error TyBottom) , ("errorWithoutStackTrace", Prim Error TyBottom) , ("divZeroError", Prim Error TyBottom)+ , ("overflowError", Prim Error TyBottom) , ("patError", Prim Error TyBottom) , ("succError", Prim Error TyBottom) , ("toEnumError", Prim Error TyBottom)- , ("undefined", Prim Error TyBottom)]+ , ("ratioZeroDenominatorError", Prim Error TyBottom)+ , ("undefined", Prim Error TyBottom) ] +a :: Id+a = Id (Name "a" Nothing 0 Nothing) TYPE++tyvarA :: Type+tyvarA = TyVar a++x :: Type -> Id+x = Id (Name "x" Nothing 0 Nothing)++y :: Type -> Id+y = Id (Name "y" Nothing 0 Nothing)++binder :: Type -> Id+binder = Id (Name "b" Nothing 0 Nothing)+ tyIntInt :: Type tyIntInt = TyFun TyLitInt TyLitInt @@ -144,27 +201,42 @@ tyFloatFloatFloat :: Type tyFloatFloatFloat = TyFun TyLitFloat $ TyFun TyLitFloat TyLitFloat +tyIntCharBool :: Name -> Type+tyIntCharBool n = TyFun TyLitInt $ TyFun TyLitChar (TyCon n TYPE)++tyCharIntBool :: Name -> Type+tyCharIntBool n = TyFun TyLitChar $ TyFun TyLitInt (TyCon n TYPE)+ tyCharCharBool :: Name -> Type tyCharCharBool n = TyFun TyLitChar $ TyFun TyLitChar (TyCon n TYPE) -boolName :: [ProgramType] -> Maybe Name-boolName = find ((==) "Bool" . nameOcc) . map fst+boolName :: HM.HashMap Name AlgDataTy -> Maybe Name+boolName = find ((==) "Bool" . nameOcc) . HM.keys -replaceFromPD :: [ProgramType] -> Id -> Expr -> (Id, Expr)-replaceFromPD pt i@(Id n _) e =+charName :: HM.HashMap Name AlgDataTy -> Maybe Name+charName = find ((==) "Char" . nameOcc) . HM.keys++listName :: HM.HashMap Name AlgDataTy -> Maybe Name+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+listName = find ((==) "List" . nameOcc) . HM.keys+#else+listName = find ((==) "[]" . nameOcc) . HM.keys+#endif++replaceFromPD :: HM.HashMap Name AlgDataTy -> Name -> Expr -> Expr+replaceFromPD pt n e = let e' = fmap snd $ find ((==) (nameOcc n) . fst) (primDefs pt) in- (i, maybe e id e')-+ maybe e id e' -addPrimsToBase :: [ProgramType] -> Program -> Program-addPrimsToBase pt prims = map (map (uncurry (replaceFromPD pt))) prims+addPrimsToBase :: HM.HashMap Name AlgDataTy -> HM.HashMap Name Expr -> HM.HashMap Name Expr+addPrimsToBase pt prims = HM.mapWithKey (replaceFromPD pt) prims -mergeProgs :: Program -> Program -> Program-mergeProgs prog prims = prog ++ prims+mergeProgs :: HM.HashMap Name Expr -> HM.HashMap Name Expr -> HM.HashMap Name Expr+mergeProgs prog prims = prog `HM.union` prims -- The prog is used to change the names of types in the prog' and primTys-mergeProgTys :: [ProgramType] -> [ProgramType] -> [ProgramType]+mergeProgTys :: [(Name, AlgDataTy)] -> [(Name, AlgDataTy)] -> [(Name, AlgDataTy)] mergeProgTys progTys primTys = progTys ++ primTys
src/G2/Translation/TransTypes.hs view
@@ -1,11 +1,10 @@ module G2.Translation.TransTypes where -import CoreSyn--- import GHC-import HscTypes-import InstEnv-import TyCon+import Control.Monad.Identity+import qualified Control.Monad.State.Lazy as SM +import G2.Translation.GHC+ import qualified Data.HashMap.Lazy as HM import qualified Data.Text as T @@ -16,16 +15,22 @@ type TypeNameMap = HM.HashMap (T.Text, Maybe T.Text) G2.Name +type Names = (NameMap, TypeNameMap)+type NamesT m a = SM.StateT Names m a+type NamesM a = NamesT Identity a+ type ExportedName = G2.Name data TranslationConfig = TranslationConfig { simpl :: Bool+ , interpreter :: Bool , load_rewrite_rules :: Bool+ , hpc_ticks :: Bool } simplTranslationConfig :: TranslationConfig-simplTranslationConfig = TranslationConfig { simpl = True, load_rewrite_rules = False }+simplTranslationConfig = TranslationConfig { simpl = True, interpreter = False, load_rewrite_rules = False, hpc_ticks = False } data ModGutsClosure = ModGutsClosure { mgcc_mod_name :: Maybe String@@ -91,10 +96,10 @@ data ExtractedG2 = ExtractedG2- { exg2_mod_names :: [T.Text]- , exg2_binds :: [(G2.Id, G2.Expr)]- , exg2_tycons :: [G2.ProgramType]- , exg2_classes :: [(G2.Name, G2.Id, [G2.Id])]+ { exg2_mod_names :: [Maybe T.Text]+ , exg2_binds :: HM.HashMap G2.Name G2.Expr+ , exg2_tycons :: HM.HashMap G2.Name G2.AlgDataTy+ , exg2_classes :: [(G2.Name, G2.Id, [G2.Id], [(G2.Type, G2.Id)])] , exg2_exports :: [ExportedName] , exg2_deps :: [T.Text] , exg2_rules :: ![G2.RewriteRule]@@ -104,8 +109,8 @@ emptyExtractedG2 = ExtractedG2 { exg2_mod_names = []- , exg2_binds = []- , exg2_tycons = []+ , exg2_binds = HM.empty+ , exg2_tycons = HM.empty , exg2_classes = [] , exg2_exports = [] , exg2_deps = []
tests/DefuncTest.hs view
@@ -33,51 +33,5 @@ -- Defunc2 -add1D2 :: Expr-add1D2 = Var (Id (Name "add1" (Just "Defunc2") 0 Nothing) tyIntS)--sub1D2 :: Expr-sub1D2 = Var (Id (Name "sub1" (Just "Defunc2") 0 Nothing) tyIntS)--squareD2 :: Expr-squareD2 = Var (Id (Name "square" (Just "Defunc2") 0 Nothing) tyIntS) --iListI :: Expr-iListI = Data $ DataCon (Name "I" (Just "Defunc2") 0 Nothing) (TyCon (Name "IList" (Just "Defunc2") 0 Nothing) TYPE)--iListNil :: Expr-iListNil = Data $ DataCon (Name "INil" (Just "Defunc2") 0 Nothing) (TyCon (Name "IList" (Just "Defunc2") 0 Nothing) TYPE)--fListF :: Expr-fListF = Data $ DataCon (Name "F" (Just "Defunc2") 0 Nothing) (TyCon (Name "FList" (Just "Defunc2") 0 Nothing) TYPE)--fListNil :: Expr-fListNil = Data $ DataCon (Name "FNil" (Just "Defunc2") 0 Nothing) (TyCon (Name "FList" (Just "Defunc2") 0 Nothing) TYPE)--add1Def :: Integer -> Integer-add1Def x = x + 1--sub1Def :: Integer -> Integer-sub1Def x = x - 1--squareDef :: Integer -> Integer-squareDef x = x * x--defunc2Check :: [Expr] -> Bool-defunc2Check [flist, llist, llist'] = defunc2Check' flist llist llist'-defunc2Check _ = False--defunc2Check' :: Expr -> Expr -> Expr -> Bool-defunc2Check' (App (App _ f) fs) - (App (App _ (Lit (LitInt i))) is)- (App (App _ (Lit (LitInt i'))) is') = defunc2Check'' f i i' && defunc2Check' fs is is'-defunc2Check' _ _ _ = True--defunc2Check'' :: Expr -> Integer -> Integer -> Bool-defunc2Check'' (Var (Id (Name "add1" _ _ _) _)) i i' = add1Def i == i'-defunc2Check'' (Var (Id (Name "sub1" _ _ _) _)) i i' = sub1Def i == i'-defunc2Check'' (Var (Id (Name "square" _ _ _) _)) i i' = squareDef i == i'-defunc2Check'' _ _ _ = False- tyIntS :: Type tyIntS = TyCon (Name "Int" Nothing 0 Nothing) TYPE
tests/Expr.hs view
@@ -8,11 +8,8 @@ import Test.Tasty import Test.Tasty.HUnit -exprTests :: IO TestTree-exprTests = return exprTests'--exprTests' :: TestTree-exprTests' =+exprTests :: TestTree+exprTests = testGroup "Expr" [ testCase "Eta Expand To" $ assertBool "Eta Expand To failed" etaExpandTo1 , testCase "Eta Expand To" $ assertBool "Eta Expand To failed" etaExpandTo2
tests/GetNthTest.hs view
@@ -8,13 +8,6 @@ data CList a = Cons a (CList a) | Nil -data Peano = Succ Peano | Zero--getNth :: CList Integer -> Integer -> Integer-getNth (Cons x _) 0 = x -getNth (Cons _ xs) n = getNth xs (n - 1)-getNth _ _ = -1- getNthErr :: CList a -> Integer -> Maybe a getNthErr (Cons x _) 0 = Just x getNthErr (Cons _ xs) n = getNthErr xs (n - 1)@@ -40,62 +33,6 @@ Cons e (toCListGenType y) toCListGenType _ = Nil -cListLength :: CList a -> Integer-cListLength (Cons _ xs) = 1 + cListLength xs-cListLength Nil = 0--getNthTest :: [Expr] -> Bool-getNthTest [cl, i, a] = getIntB i $ \i' -> getIntB a $ \a' -> getNth (toCList cl) i' == a'-getNthTest _ = False--getNthErrTest :: [Expr] -> Bool-getNthErrTest [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListType cl) i' == Nothing-getNthErrTest [cl, i, a] = getIntB i $ \i' -> getIntB a $ \a' -> getNthErr (toCListType cl) i' == Just a'-getNthErrTest _ = False--getNthErrGenTest :: [Expr] -> Bool-getNthErrGenTest [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListGenType cl) i' == Nothing-getNthErrGenTest [cl, i, e] =- case getInt i Nothing $ \i' -> getNthErr (toCListGenType cl) i' of- Just e' -> e' `eqIgT` e- Nothing -> False-getNthErrGenTest _ = False--getNthErrGenTest' :: [Expr] -> Bool-getNthErrGenTest' [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListGenType cl) i' == Nothing-getNthErrGenTest' [cl, i, e] =- case getInt i Nothing $ \i' -> getNthErr (toCListGenType cl) i' of- Just e' -> e' `eqIgT` e- Nothing -> False-getNthErrGenTest' _ = False--getNthErrGenTest2 :: [Expr] -> Bool-getNthErrGenTest2 [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListGenType cl) i' == Nothing-getNthErrGenTest2 [cl, i, e] =- case getInt i Nothing $ \i' -> getNthErr (toCListGenType cl) i' of- Just e' -> e' `eqIgT` e- Nothing -> False-getNthErrGenTest2 _ = False--getNthErrGenTest2' :: [Expr] -> Bool-getNthErrGenTest2' [cl, i, Prim Error _] = getIntB i $ \i' -> getNthErr (toCListGenType cl) i' == Nothing-getNthErrGenTest2' [cl, i, e] =- case getInt i Nothing $ \i' -> getNthErr (toCListGenType cl) i' of- Just e' -> e' `eqIgT` e- Nothing -> False-getNthErrGenTest2' _ = False--elimType :: (ASTContainer m Expr) => m -> m-elimType = modifyASTs elimType'--elimType' :: Expr -> Expr-elimType' (App e (Type _)) = e-elimType' e = e- getNthErrors :: [Expr] -> Bool getNthErrors [cl, App _ (Lit (LitInt i)), Prim Error _] = getNthErr (toCListGen cl) i == Nothing getNthErrors _ = False--cfmapTest :: [Expr] -> Bool-cfmapTest [_, e, e'] = cListLength (toCListGenType e) == cListLength (toCListGenType e') || isError e'-cfmapTest _ = False
tests/InputOutputTest.hs view
@@ -1,103 +1,106 @@ {-# LANGUAGE OverloadedStrings #-} module InputOutputTest ( checkInputOutput- , checkInputOutputLH ) where+ , checkInputOutputs+ , checkInputOutputsTemplate+ , checkInputOutputsNonRedTemp ) where import Test.Tasty import Test.Tasty.HUnit import Control.Exception+import Data.IORef+import qualified Data.Map.Lazy as M+import Data.Maybe import qualified Data.Text as T import System.FilePath+import System.IO.Unsafe import G2.Config import G2.Initialization.MkCurrExpr import G2.Interface import G2.Language-import G2.Liquid.Interface import G2.Translation import Reqs import TestUtils -checkInputOutput :: FilePath -> String -> String -> Int -> Int -> [Reqs String] -> IO TestTree-checkInputOutput src md entry stps i req = checkInputOutputWithConfig [src] md entry i req (mkConfigTest {steps = stps})+checkInputOutput :: FilePath -> String -> Int -> [Reqs String] -> TestTree+checkInputOutput src entry stps req = do+ checkInputOutput' mkConfigTestIO src [(entry, stps, req)] -checkInputOutputWithConfig :: [FilePath] -> String -> String -> Int -> [Reqs String] -> Config -> IO TestTree-checkInputOutputWithConfig src md entry i req config = do- r <- doTimeout (timeLimit config) $ checkInputOutput' src md entry i req config+checkInputOutputs :: FilePath -> [(String, Int, [Reqs String])] -> TestTree+checkInputOutputs src tests = do+ checkInputOutput' mkConfigTestIO src tests - let (b, e) = case r of- Nothing -> (False, "\nTimeout")- Just (Left e') -> (False, "\n" ++ show e')- Just (Right (b', _)) -> (b', "")+checkInputOutputsTemplate :: FilePath -> [(String, Int, [Reqs String])] -> TestTree+checkInputOutputsTemplate src tests = do+ checkInputOutput'+ (do config <- mkConfigTestIO; return (config { higherOrderSolver = SymbolicFunc }))+ src+ tests - return . testCase (show src) $ assertBool ("Input/Output for file " ++ show src ++ " failed on function " ++ entry ++ "." ++ e) b +checkInputOutputsNonRedTemp :: FilePath -> [(String, Int, [Reqs String])] -> TestTree+checkInputOutputsNonRedTemp src tests = do+ checkInputOutput'+ (do config <- mkConfigTestIO; return (config { higherOrderSolver = SymbolicFuncTemplate }))+ src+ tests -checkInputOutput' :: [FilePath] - -> String - -> String - -> Int - -> [Reqs String] - -> Config - -> IO (Either SomeException (Bool, [ExecRes ()]))-checkInputOutput' src md entry i req config = try (checkInputOutput'' src md entry i req config)+checkInputOutput' :: IO Config+ -> FilePath+ -> [(String, Int, [Reqs String])]+ -> TestTree+checkInputOutput' io_config src tests = do+ let proj = takeDirectory src+ + withResource+ (do + config <- io_config+ translateLoaded [proj] [src] simplTranslationConfig config+ )+ (\_ -> return ())+ $ \loadedExG2 -> + testGroup+ src+ $ map (\test@(entry, _, _) -> do+ testCase (src ++ " " ++ entry) ( do+ (mb_modname, exg2) <- loadedExG2+ config <- io_config+ r <- doTimeout (timeLimit config)+ (try (checkInputOutput'' [src] exg2 mb_modname config test)+ :: IO (Either SomeException (Bool, [ExecRes ()])))+ let (b, e) = case r of+ Nothing -> (False, "\nTimeout")+ Just (Left e') -> (False, "\n" ++ show e')+ Just (Right (b', _)) -> (b', "") -checkInputOutput'' :: [FilePath] - -> String - -> String - -> Int - -> [Reqs String] + assertBool ("Input/Output for file " ++ show src ++ " failed on function " ++ entry ++ "." ++ e) b + )+ ) tests++checkInputOutput'' :: [FilePath]+ -> ExtractedG2+ -> Maybe T.Text -> Config + -> (String, Int, [Reqs String]) -> IO (Bool, [ExecRes ()])-checkInputOutput'' src md entry i req config = do- let proj = map takeDirectory src- (mb_modname, exg2) <- translateLoaded proj src [] simplTranslationConfig config-- let (init_state, _, bindings) = initState exg2 False (T.pack entry) mb_modname (mkCurrExpr Nothing Nothing) config- putStrLn "test"+checkInputOutput'' src exg2 mb_modname config (entry, stps, req) = do+ let config' = config { steps = stps }+ (init_state, bindings) = initStateWithCall exg2 False (T.pack entry) mb_modname (mkCurrExpr Nothing Nothing) mkArgTys config' - (r, _) <- runG2WithConfig init_state config bindings+ (r, _) <- runG2WithConfig mb_modname init_state config' bindings let chAll = checkExprAll req- mr <- validateStates proj src md entry chAll [] r- let io = map (\(ExecRes { conc_args = i', conc_out = o}) -> i' ++ [o]) r+ let proj = map takeDirectory src+ mr <- validateStates proj src (T.unpack $ fromJust mb_modname) entry chAll [] r+ let io = map (\(ExecRes { conc_args = i, conc_out = o}) -> i ++ [o]) r - let chEx = checkExprInOutCount io i req+ let chEx = checkExprInOutCount io req return $ (mr && chEx, r) ------------ -checkInputOutputLH :: [FilePath] -> [FilePath] -> String -> String -> Int -> Int -> [Reqs String] -> IO TestTree-checkInputOutputLH proj src md entry stps i req = checkInputOutputLHWithConfig proj src md entry i req (mkConfigTest {steps = stps})--checkInputOutputLHWithConfig :: [FilePath] -> [FilePath] -> String -> String -> Int -> [Reqs String] -> Config -> IO TestTree-checkInputOutputLHWithConfig proj src md entry i req config = do- r <- doTimeout (timeLimit config) $ checkInputOutputLH' proj src md entry i req config-- let b = case r of- Just (Right b') -> b'- _ -> False-- return . testCase (show src) $ assertBool ("Input/Output for file " ++ show src ++ " failed on function " ++ entry ++ ".") b--checkInputOutputLH' :: [FilePath] -> [FilePath] -> String -> String -> Int -> [Reqs String] -> Config -> IO (Either SomeException Bool)-checkInputOutputLH' proj src md entry i req config = try (checkInputOutputLH'' proj src md entry i req config)--checkInputOutputLH'' :: [FilePath] -> [FilePath] -> String -> String -> Int -> [Reqs String] -> Config -> IO Bool-checkInputOutputLH'' proj src md entry i req config = do- ((r, _), _) <- findCounterExamples proj src (T.pack entry) [] [] config-- let chAll = checkExprAll req-- mr <- validateStates proj src md entry chAll [] r- let io = map (\(ExecRes { conc_args = i', conc_out = o}) -> i' ++ [o]) r-- let chEx = checkExprInOutCount io i req- return $ mr && chEx--------------- -- | Checks conditions on given expressions checkExprAll :: [Reqs String] -> [String] checkExprAll reqList = [f | RForAll f <- reqList]@@ -105,13 +108,11 @@ checkExprExists :: [Reqs String] -> [String] checkExprExists reqList = [f | RExists f <- reqList] -checkExprInOutCount :: [[Expr]] -> Int -> [Reqs c] -> Bool-checkExprInOutCount exprs i reqList =+checkExprInOutCount :: [[Expr]] -> [Reqs c] -> Bool+checkExprInOutCount exprs reqList = let checkAtLeast = and . map ((>=) (length exprs)) $ [x | AtLeast x <- reqList] checkAtMost = and . map ((<=) (length exprs)) $ [x | AtMost x <- reqList] checkExactly = and . map ((==) (length exprs)) $ [x | Exactly x <- reqList]-- checkArgCount = and . map ((==) i . length) $ exprs in- checkAtLeast && checkAtMost && checkExactly && checkArgCount+ checkAtLeast && checkAtMost && checkExactly
tests/Reqs.hs view
@@ -1,6 +1,6 @@ module Reqs ( Reqs (..)- , checkExprGen- , checkAbsLHExprGen ) where+ , TestErrors (..)+ , checkExprGen ) where import G2.Language @@ -17,52 +17,34 @@ | AtMost Int | Exactly Int -data TestErrors = BadArgCount+data TestErrors = BadArgCount [Int] | TooMany | TooFew | NotExactly | ArgsForAllFailed- | ArgsExistFailed deriving (Show)+ | ArgsExistFailed + | Time deriving (Show) -- | Checks conditions on given expressions-checkExprGen :: [[Expr]] -> Int -> [Reqs ([Expr] -> Bool)] -> Bool-checkExprGen exprs i reqList =- let- argChecksAll = and . map (\f -> all (givenLengthCheck i f) exprs) $ [f | RForAll f <- reqList]- argChecksEx = and . map (\f -> any (givenLengthCheck i f) exprs) $ [f | RExists f <- reqList]- checkL = null $ checkLengths exprs i reqList- in- argChecksAll && argChecksEx && checkL--givenLengthCheck :: Int -> ([Expr] -> Bool) -> [Expr] -> Bool-givenLengthCheck i f e = if length e == i then f e else False--checkAbsLHExprGen :: [(State [FuncCall], [Expr], Expr)] -> Int -> [Reqs ([Expr] -> Expr -> [FuncCall] -> Bool)] -> [TestErrors] -checkAbsLHExprGen exprs i reqList =+checkExprGen :: [[Expr]] -> [Reqs ([Expr] -> Bool)] -> [TestErrors]+checkExprGen exprs reqList = let- argChecksAll =- if and . map (\f -> all (\(s, es, e) -> lhGivenLengthCheck i f es e (track s)) exprs) $ [f | RForAll f <- reqList]- then []- else [ArgsForAllFailed]- argChecksEx =- if and . map (\f -> any (\(s, es, e) -> lhGivenLengthCheck i f es e (track s)) exprs) $ [f | RExists f <- reqList]- then []- else [ArgsExistFailed]- checkL = checkLengths (map (\(_, e, _) -> e) exprs) i reqList+ argChecksAll = if and . map (\f -> all f exprs) $ [f | RForAll f <- reqList]+ then []+ else [ArgsForAllFailed]+ argChecksEx = if and . map (\f -> any f exprs) $ [f | RExists f <- reqList]+ then []+ else [ArgsExistFailed]+ checkL = checkLengths exprs reqList in argChecksAll ++ argChecksEx ++ checkL -lhGivenLengthCheck :: Int -> ([Expr] -> Expr -> [FuncCall] -> Bool) -> [Expr] -> Expr -> [FuncCall] -> Bool-lhGivenLengthCheck i f es e fc = if length es == i then f es e fc else False--checkLengths :: [[Expr]] -> Int -> [Reqs c] -> [TestErrors]-checkLengths exprs i reqList =+checkLengths :: [[Expr]] -> [Reqs c] -> [TestErrors]+checkLengths exprs reqList = let checkAtLeast = if and . map ((>=) (length exprs)) $ [x | AtLeast x <- reqList] then [] else [TooFew] checkAtMost = if and . map ((<=) (length exprs)) $ [x | AtMost x <- reqList] then [] else [TooMany] checkExactly = if and . map ((==) (length exprs)) $ [x | Exactly x <- reqList] then [] else [NotExactly]-- checkArgCount = if and . map ((==) i . length) $ exprs then [] else [BadArgCount] in- checkAtLeast ++ checkAtMost ++ checkExactly ++ checkArgCount+ checkAtLeast ++ checkAtMost ++ checkExactly
+ tests/RewriteVerify/RewriteVerifyTest.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE FlexibleContexts #-}++module RewriteVerify.RewriteVerifyTest ( rewriteTests ) where++import qualified Data.Map as M+import Data.Maybe+import qualified Data.Text as T++import G2.Config+import G2.Interface+import G2.Language+import G2.Translation++import G2.Equiv.Config+import G2.Equiv.Verifier+import G2.Equiv.Summary++import Data.List++import qualified G2.Solver as S++import Test.Tasty+import Test.Tasty.HUnit++findRule :: [RewriteRule] -> String -> RewriteRule+findRule rule_list rule_name =+ let tentry = T.pack rule_name+ rule = find (\r -> tentry == ru_name r) rule_list+ in case rule of+ Just r -> r+ Nothing -> error $ "not found " ++ show rule_name++acceptRule :: (ASTContainer t Type, ASTContainer t Expr) => Config -> State t -> Bindings -> RewriteRule -> IO Bool+acceptRule config init_state bindings rule = do+ res <- checkRule config nebulaConfig init_state bindings [] rule+ return (case res of+ S.SAT _ -> error "Satisfiable"+ S.UNSAT _ -> True+ _ -> error "Failed to Produce a Result")++rejectRule :: (ASTContainer t Type, ASTContainer t Expr) => Config -> State t -> Bindings -> RewriteRule -> IO Bool+rejectRule config init_state bindings rule = do+ res <- checkRule config nebulaConfig init_state bindings [] rule+ return (case res of+ S.SAT _ -> True+ S.UNSAT _ -> error "Unsatisfiable"+ _ -> error "Failed to Produce a Result")++nebulaConfig :: NebulaConfig+nebulaConfig = NC { limit = 20+ , num_lemmas = 2+ , print_summary = SM False False False+ , use_labeled_errors = UseLabeledErrors+ , log_states = NoLog+ , log_rule = Nothing+ , symbolic_unmapped = False+ , sync = False}++good_names :: [String]+good_names = [ "addOneCommutative"+ , "doubleNegative"+ , "maybeForceZero"+ , "maxWithSelf"+ , "addOneJust"+ , "justJust" ]++good_src :: String+good_src = "tests/RewriteVerify/Correct/SimpleCorrect.hs"++bad_names :: [String]+bad_names = [ "badMaybeForce"+ , "badNegation"+ , "badMax"+ , "badMaxLeft"+ , "badJust"+ , "badTuple"+ , "badFF" ]++bad_src :: String+bad_src = "tests/RewriteVerify/Incorrect/SimpleIncorrect.hs"++coinduction_good_names :: [String]+coinduction_good_names = [ --"forceIdempotent"+ "dropNoRecursion"+ , "mapTake"+ , "takeIdempotent"+ --, "doubleReverse"+ , "doubleMap"+ , "mapIterate" ]++coinduction_good_src :: String+coinduction_good_src = "tests/RewriteVerify/Correct/CoinductionCorrect.hs"++coinduction_bad_names :: [String]+coinduction_bad_names = [ "forceDoesNothing"+ , "badDropSum"+ , "doubleTake"+ , "badDoubleReverse" ]++coinduction_bad_src :: String+coinduction_bad_src = "tests/RewriteVerify/Incorrect/CoinductionIncorrect.hs"++higher_good_names :: [String]+higher_good_names = [ "doubleMap"+ , "mapIterate"+ , "mapTake"+ , "mapFilter" ]++higher_good_src :: String+higher_good_src = "tests/RewriteVerify/Correct/HigherOrderCorrect.hs"++higher_bad_names :: [String]+higher_bad_names = [ "direct"+ , "symFuncInfExpr"+ , "symFuncPoly"+ , "symFuncNat" ]++higher_bad_src :: String+higher_bad_src = "tests/RewriteVerify/Incorrect/HigherOrderIncorrect.hs"++tree_good_names :: [String]+tree_good_names = [ -- "doubleTree"+ -- "doubleTreeOriginal"+ "doubleMapTree" ]++tree_good_src :: String+tree_good_src = "tests/RewriteVerify/Correct/TreeCorrect.hs"++tree_bad_names :: [String]+tree_bad_names = [ "badSize"+ , "treeMapBackward" ]++tree_bad_src :: String+tree_bad_src = "tests/RewriteVerify/Incorrect/TreeIncorrect.hs"++multi_lemma_good_names :: [String]+multi_lemma_good_names = [ "p55Z"+ , "p55nil"+ , "p55Znil"+ , "p80Z"+ , "p80nil"+ , "p80Znil" ]++multi_lemma_good_src :: String+multi_lemma_good_src = "tests/RewriteVerify/Correct/Zeno.hs"++empty_config :: IO Config+empty_config = getConfigDirect++rvTest :: (Config -> State () -> Bindings -> RewriteRule -> IO Bool) ->+ String -> [String] -> TestTree+rvTest check src rule_names =+ withResource+ (do+ proj <- guessProj src+ config <- empty_config+ initialStateNoStartFunc [proj] [src]+ (simplTranslationConfig {simpl = True, load_rewrite_rules = True})+ config+ )+ (\_ -> return ())+ (\isb -> testGroup ("Rules " ++ src)+ $ map (\rule_name -> testCase ("Rule " ++ rule_name) $ do+ (init_state, bindings) <- isb+ config <- empty_config+ let rule = findRule (rewrite_rules bindings) rule_name+ r <- doTimeout 180 $ check config init_state bindings rule+ case r of+ Nothing -> error "TIMEOUT"+ Just r' | r' -> return ()+ | otherwise -> error "test failed") rule_names)++rewriteVerifyTestsGood :: TestTree+rewriteVerifyTestsGood =+ rvTest acceptRule good_src good_names++rewriteVerifyTestsBad :: TestTree+rewriteVerifyTestsBad =+ rvTest rejectRule bad_src bad_names++coinductionTestsGood :: TestTree+coinductionTestsGood =+ rvTest acceptRule coinduction_good_src coinduction_good_names++coinductionTestsBad :: TestTree+coinductionTestsBad =+ rvTest rejectRule coinduction_bad_src coinduction_bad_names++higherOrderTestsGood :: TestTree+higherOrderTestsGood =+ rvTest acceptRule higher_good_src higher_good_names++higherOrderTestsBad :: TestTree+higherOrderTestsBad =+ rvTest rejectRule higher_bad_src higher_bad_names++treeTestsGood :: TestTree+treeTestsGood =+ rvTest acceptRule tree_good_src tree_good_names++treeTestsBad :: TestTree+treeTestsBad =+ rvTest rejectRule tree_bad_src tree_bad_names++typeSymsTestsGood :: TestTree+typeSymsTestsGood =+ rvTest acceptRule "tests/RewriteVerify/Correct/TypeSyms.hs" ["parBuffer"]++multiLemmaTestsGood :: TestTree+multiLemmaTestsGood =+ rvTest acceptRule multi_lemma_good_src multi_lemma_good_names++rewriteTests :: TestTree+rewriteTests = testGroup "Rewrite Tests"+ [ rewriteVerifyTestsGood+ , rewriteVerifyTestsBad+ , coinductionTestsGood+ , coinductionTestsBad+ , higherOrderTestsGood+ , higherOrderTestsBad+ , treeTestsGood+ , treeTestsBad+ , typeSymsTestsGood+ , multiLemmaTestsGood+ ]++
+ tests/Simplifications.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++module Simplifications (simplificationTests) where++import G2.Language.Simplification+import G2.Language.Syntax++import Test.Tasty+import Test.Tasty.HUnit++simplificationTests :: TestTree+simplificationTests =+ testGroup "Simplifications" [+ testCase "AppLamSimplification" (assertBool "Substituting two variables" simplifyAppLambdasTest1)+ , testCase "AppLamSimplification" (assertBool "Substituting two variables" simplifyAppLambdasTest2)+ , testCase "AppLamSimplification" (assertBool "Substituting a tyvar" simplifyTyVar1)+ ]+++simplifyAppLambdasTest1 :: Bool+simplifyAppLambdasTest1 =+ let+ le = Lam TermL id1 + . Lam TermL id2+ $ App (Var id1) (Var id2)+ e = App (App le (Var id3)) (Var id4)+ in+ simplifyAppLambdas e == App (Var id3) (Var id4)+++simplifyAppLambdasTest2 :: Bool+simplifyAppLambdasTest2 =+ let+ le = Lam TermL id1 + $ (App (Lam TermL id2 (Var id2)) (Var id1))+ e = App le (Var id3)+ in+ simplifyAppLambdas e == Var id3++simplifyTyVar1 :: Bool+simplifyTyVar1 =+ let+ tyvar_id1 = Id (Name "tv_1" Nothing 0 Nothing) TYPE+ tyvar_id2 = Id (Name "tv_2" Nothing 0 Nothing) TYPE++ v_n = Name "v" Nothing 0 Nothing+ v_id1 = Id v_n (TyVar tyvar_id1)+ v_id2 = Id v_n (TyVar tyvar_id2)++ le = Lam TypeL tyvar_id1 (Var v_id1)+ e = App le (Var tyvar_id2)+ in+ simplifyAppLambdas e == Var v_id2+++id1 :: Id+id1 = Id (Name "a" Nothing 0 Nothing) TyUnknown++id2 :: Id+id2 = Id (Name "b" Nothing 0 Nothing) TyUnknown++id3 :: Id+id3 = Id (Name "c" Nothing 0 Nothing) TyUnknown++id4 :: Id+id4 = Id (Name "d" Nothing 0 Nothing) TyUnknown
tests/Test.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}@@ -5,7 +6,7 @@ module Main where import Test.Tasty-import Test.Tasty.HUnit+import Test.Tasty.HUnit ( testCase, assertBool, assertFailure ) import Test.Tasty.Options import Test.Tasty.Runners @@ -13,7 +14,6 @@ import G2.Interface import G2.Language as G2-import G2.Liquid.Interface import Control.Exception import Data.Maybe@@ -30,12 +30,20 @@ import DefuncTest import CaseTest import Expr+import Simplifications import Typing+import UnionFindTests+import UFMapTests +import RewriteVerify.RewriteVerifyTest+import G2.Translation+ import InputOutputTest import Reqs import TestUtils +import qualified Data.Map.Lazy as M+ -- Run with no arguments for default test cases. -- All default test cases should pass. -- Run with flag '--test-options="todo yes"' to run test cases corresponding to to-be-fixed bugs.@@ -49,432 +57,417 @@ [ Option (Proxy :: Proxy ToDo) ] (\_ _ -> Just (\_ -> return (\_ -> return False))) ])- =<< if todo then todoTests else tests+ (if todo then todoTests else tests) -tests :: IO TestTree-tests = return . testGroup "Tests"- =<< sequence [- sampleTests- , liquidTests+tests :: TestTree+tests = testGroup "Tests"+ [ sampleTests , testFileTests+ , extensionTests , baseTests , primTests+ , ioTests , exprTests , typingTests+ , simplificationTests+ , ufMapQuickcheck+ , unionFindQuickcheck+ , rewriteTests ] timeout :: Timeout timeout = mkTimeout 1 -- Test based on examples that are also good for demos-sampleTests :: IO TestTree-sampleTests =- return . testGroup "Samples"- =<< sequence [- checkExpr "tests/Samples/Peano.hs" 900 Nothing (Just "equalsFour") "add" 3 [RForAll $ not . peano_4_out, AtLeast 10]- , checkExpr "tests/Samples/Peano.hs" 900 (Just "fstIsEvenAddToFour") (Just "fstIsTwo") "add" 3 [RExists peano_0_4, RExists peano_4_0, Exactly 2]- , checkExpr "tests/Samples/Peano.hs" 1200 (Just "multiplyToFour") (Just "equalsFour") "add" 3 [RExists peano_1_4_5, RExists peano_4_1_5, Exactly 2]- , checkExpr "tests/Samples/Peano.hs" 750 (Just "eqEachOtherAndAddTo4") Nothing "add" 3 [RForAll peano_2_2, Exactly 1]- , checkExpr "tests/Samples/Peano.hs" 600 (Just "equalsFour") Nothing "add" 3 [RExists peano_0_4, RExists peano_1_3, RExists peano_2_2, RExists peano_3_1, RExists peano_4_0, Exactly 5]- , checkExpr "tests/Samples/Peano.hs" 750 (Just "equalsFour") Nothing "multiply" 3 [RExists peano_1_4, RExists peano_2_2, RExists peano_4_1, Exactly 3]-- , checkExpr "tests/Samples/HigherOrderMath.hs" 800 (Just "isTrue0") Nothing "notNegativeAt0NegativeAt1" 2 [RExists negativeSquareRes, AtLeast 1]- , checkExpr "tests/Samples/HigherOrderMath.hs" 600 (Just "isTrue1") Nothing "fixed" 3 [RExists abs2NonNeg, RExists squareRes, RExists fourthPowerRes, RForAll allabs2NonNeg, AtLeast 4]- , checkExpr "tests/Samples/HigherOrderMath.hs" 600 Nothing Nothing "fixed" 3 [RExists abs2NonNeg, RExists squareRes, RExists fourthPowerRes, AtLeast 4]- , checkExpr "tests/Samples/HigherOrderMath.hs" 600 (Just "isTrue2") Nothing "sameFloatArgLarger" 3 [RExists addRes, RExists subRes, AtLeast 2]- , checkExpr "tests/Samples/HigherOrderMath.hs" 600 Nothing Nothing "functionSatisfies" 4 [RExists functionSatisfiesRes, AtLeast 1]- , checkExpr "tests/Samples/HigherOrderMath.hs" 1000 Nothing Nothing "approxSqrt" 3 [AtLeast 2]- -- The below test fails because Z3 returns unknown.- -- , checkExpr "tests/Samples/HigherOrderMath.hs" 1200 (Just "isTrue2") Nothing "sameFloatArgLarger" 2 [RExists approxSqrtRes, RExists pythagoreanRes, AtLeast 2]- - , checkExpr "tests/Samples/McCarthy91.hs" 1000 (Just "lessThan91") Nothing "mccarthy" 2 [RForAll (\[App _ (Lit (LitInt x)), _] -> x <= 100), AtLeast 1]- , checkExpr "tests/Samples/McCarthy91.hs" 400 (Just "greaterThan10Less") Nothing "mccarthy" 2 [RForAll (\[App _ (Lit (LitInt x)), _] -> x > 100), AtLeast 1]- , checkExpr "tests/Samples/McCarthy91.hs" 1000 (Just "lessThanNot91") Nothing "mccarthy" 2 [Exactly 0]- , checkExpr "tests/Samples/McCarthy91.hs" 1000 (Just "greaterThanNot10Less") Nothing "mccarthy" 2 [Exactly 0]-- , checkExpr "tests/Samples/GetNth.hs" 600 Nothing Nothing "getNth" 3 [AtLeast 10, RForAll getNthTest]- , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthInt" 3 [AtLeast 10, RForAll getNthErrTest]- , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthX" 3 [AtLeast 10, RForAll getNthErrGenTest]- , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthPeano" 3 [AtLeast 10, RForAll getNthErrGenTest] -- 533- , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthCListInt" 3 [AtLeast 10, RForAll getNthErrGenTest2']- , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "getNthCListX" 3 [AtLeast 10, RForAll getNthErrGenTest2]- , checkExpr "tests/Samples/GetNthPoly.hs" 1000 Nothing Nothing "getNth" 4 [AtLeast 10]-- , checkExpr "tests/Samples/GetNthPoly.hs" 1000 Nothing Nothing "cfmapInt" 3 [AtLeast 10, RForAll cfmapTest]- , checkExpr "tests/Samples/GetNthPoly.hs" 1600 Nothing Nothing "cfmapIntX" 3 [AtLeast 10, RForAll cfmapTest]- , checkExpr "tests/Samples/GetNthPoly.hs" 600 Nothing Nothing "cfmapIntCListInt" 3 [AtLeast 2, RForAll cfmapTest]-- , checkExprReaches "tests/Samples/GetNthErr.hs" 800 Nothing Nothing (Just "error") "getNth" 3 [AtLeast 8, RForAll errors]-- , checkExpr "tests/Samples/FoldlUses.hs" 1600 Nothing Nothing "sum" 2 [AtLeast 3]- , checkExpr "tests/Samples/FoldlUses.hs" 1000 Nothing Nothing "dotProd" 3 [AtLeast 3]-- , checkExpr "tests/Samples/FoldlUsesPoly.hs" 600 Nothing Nothing "sumMinAndMax" 5 [AtLeast 10]- , checkExpr "tests/Samples/FoldlUsesPoly.hs" 400 Nothing Nothing "maxes" 7 [AtLeast 10]- , checkExpr "tests/Samples/FoldlUsesPoly.hs" 400 Nothing Nothing "switchInt" 2 [AtLeast 1]- , checkExpr "tests/Samples/FoldlUsesPoly.hs" 400 Nothing Nothing "getInInt" 2 [AtLeast 1]- , checkExpr "tests/Samples/FoldlUsesPoly.hs" 400 Nothing Nothing "switchP" 6 [AtLeast 1]- ]+sampleTests :: TestTree+sampleTests = testGroup "Samples"+ [+ checkExprAssert "tests/Samples/Peano.hs" 900 (Just "equalsFour") "add"+ [RForAll $ not . peano_4_out, AtLeast 10]+ , checkExprAssumeAssert "tests/Samples/Peano.hs" 900 (Just "fstIsEvenAddToFour") (Just "fstIsTwo") "add"+ [RExists peano_0_4, RExists peano_4_0, Exactly 2]+ , checkExprAssumeAssert "tests/Samples/Peano.hs" 1200 (Just "multiplyToFour") (Just "equalsFour") "add"+ [RExists peano_1_4_5, RExists peano_4_1_5, Exactly 2]+ , checkExprAssumeAssert "tests/Samples/Peano.hs" 750 (Just "eqEachOtherAndAddTo4") Nothing "add"+ [RForAll peano_2_2, Exactly 1]+ , checkExprAssumeAssert "tests/Samples/Peano.hs" 600 (Just "equalsFour") Nothing "add"+ [ RExists peano_0_4+ , RExists peano_1_3+ , RExists peano_2_2+ , RExists peano_3_1+ , RExists peano_4_0+ , Exactly 5]+ , checkExprAssumeAssert "tests/Samples/Peano.hs" 750 (Just "equalsFour") Nothing "multiply"+ [ RExists peano_1_4+ , RExists peano_2_2+ , RExists peano_4_1+ , Exactly 3] -liquidTests :: IO TestTree-liquidTests = - return . testGroup "Liquid"- =<< sequence [- checkLiquid "tests/Liquid/SimpleMath.hs" "abs2" 2000 2 [RForAll (\[x, y] -> isDouble x ((==) 0) && isDouble y ((==) 0)), Exactly 1]- , checkLiquid "tests/Liquid/SimpleMath.hs" "add" 800 3 - [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > z' || y' > z'), AtLeast 1]- , checkLiquid "tests/Liquid/SimpleMath.hs" "subToPos" 1000 3 - [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > 0 && x' >= y' && z' <= 0), AtLeast 1]- , checkLiquidWithNoCutOff "tests/Liquid/SimpleMath.hs" "fib" 4000 2- [RForAll (\[x, y] -> isInt x $ \x' -> isInt y $ \y' -> x' > y'), AtLeast 3]- , checkLiquidWithNoCutOff "tests/Liquid/SimpleMath.hs" "fib'" 6000 2- [RForAll (\[x, y] -> isInt x $ \x' -> isInt y $ \y' -> x' > y'), AtLeast 3]- , checkLiquid "tests/Liquid/SimpleMath.hs" "xSqPlusYSq" 1000 3 - [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' + y' >= z'), AtLeast 1]+ , checkExprAssume "tests/Samples/HigherOrderMath.hs" 800 (Just "isTrue0") "notNegativeAt0NegativeAt1"+ [RExists negativeSquareRes, AtLeast 1]+ , checkExprAssume "tests/Samples/HigherOrderMath.hs" 600 (Just "isTrue1") "fixed"+ [ RExists abs2NonNeg+ , RExists squareRes+ , RExists fourthPowerRes+ , RForAll allabs2NonNeg+ , AtLeast 4]+ , checkExpr "tests/Samples/HigherOrderMath.hs" 600 "fixed" [ RExists abs2NonNeg+ , RExists squareRes+ , RExists fourthPowerRes+ , AtLeast 4]+ , checkExprAssumeAssert "tests/Samples/HigherOrderMath.hs" 600 (Just "isTrue2") Nothing "sameFloatArgLarger"+ [ RExists addRes+ , RExists subRes+ , AtLeast 2]+ , checkExpr "tests/Samples/HigherOrderMath.hs" 600 "functionSatisfies" [RExists functionSatisfiesRes, AtLeast 1]+ , checkExpr "tests/Samples/HigherOrderMath.hs" 1000 "approxSqrt" [AtLeast 2]+ -- The below test fails because Z3 returns unknown.+ -- , checkExprAssume "tests/Samples/HigherOrderMath.hs" 1200 (Just "isTrue2") "sameFloatArgLarger" 2+ -- [ RExists approxSqrtRes+ -- , RExists pythagoreanRes+ -- , AtLeast 2]+ + , checkExprAssumeAssert "tests/Samples/McCarthy91.hs" 1000 (Just "lessThan91") Nothing "mccarthy"+ [ RForAll (\[App _ (Lit (LitInt x)), _] -> x <= 100)+ , AtLeast 1]+ , checkExprAssumeAssert "tests/Samples/McCarthy91.hs" 400 (Just "greaterThan10Less") Nothing "mccarthy"+ [ RForAll (\[App _ (Lit (LitInt x)), _] -> x > 100)+ , AtLeast 1]+ , checkExprAssumeAssert "tests/Samples/McCarthy91.hs" 1000 (Just "lessThanNot91") Nothing "mccarthy" [Exactly 0]+ , checkExprAssumeAssert "tests/Samples/McCarthy91.hs" 1000 (Just "greaterThanNot10Less") Nothing "mccarthy"+ [Exactly 0] - , checkLiquid "tests/Liquid/SimplePoly.hs" "snd2Int" 800 3 [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' /= y' && y' == z'), Exactly 1]- , checkLiquid "tests/Liquid/SimplePoly.hs" "sumPair" 800 2 [AtLeast 1, RForAll (\[App (App _ x) y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > z' || y' > z')]- , checkLiquid "tests/Liquid/SimplePoly.hs" "switchInt" 600 2 [Exactly 1, RForAll (\[App (App _ x) _, App (App _ _) y] -> getIntB x $ \ x' -> getIntB y $ \ y' -> x' == y')]+ , checkInputOutput "tests/Samples/GetNth.hs" "getNth" 600 [AtLeast 10]+ , checkInputOutputs "tests/Samples/GetNthPoly.hs" [ ("getNthInt", 600, [AtLeast 10])+ , ("getNthX", 600, [AtLeast 10])+ , ("getNthPeano", 600, [AtLeast 10])+ , ("getNthCListInt", 600, [AtLeast 10])+ , ("getNthCListX", 600, [AtLeast 10])+ , ("getNth", 1000, [AtLeast 10]) - , checkLiquid "tests/Liquid/Peano.hs" "add" 1400 3 [RForAll (\[x, y, _] -> x `eqIgT` zeroPeano || y `eqIgT` zeroPeano), AtLeast 5]- , checkLiquid "tests/Liquid/Peano.hs" "fromInt" 600 2 [RForAll (\[x, y] -> isInt x (\x' -> x' == 0) && y `eqIgT` zeroPeano), AtLeast 1]+ , ("cfmapInt", 1000, [AtLeast 10])+ , ("cfmapIntX", 1600, [AtLeast 10])+ , ("cfmapIntCListInt", 600, [AtLeast 2]) ] - , checkLiquidWithNoCutOff "tests/Liquid/GetNth.hs" "getNthInt" 2700 3 [AtLeast 3, RForAll getNthErrors]- , checkLiquidWithCutOff "tests/Liquid/GetNth.hs" "sumC" 2000 1000 2 [AtLeast 3, RForAll (\[_, y] -> isInt y $ (==) 0)]- , checkLiquidWithNoCutOff "tests/Liquid/GetNth.hs" "getNth" 2700 4 [AtLeast 3]- , checkLiquidWithCutOff "tests/Liquid/GetNth.hs" "sumCList" 2000 1000 4 [AtLeast 3]+ , checkExprReaches "tests/Samples/GetNthErr.hs" 800 Nothing Nothing (Just "error") "getNth"+ [AtLeast 8, RForAll errors] - , checkLiquid "tests/Liquid/DataRefTest.hs" "addMaybe" 1000 3 - [AtLeast 1, RForAll (\[_, y, z] -> isInt y $ \y' -> appNthArgIs z (\z' -> isInt z' $ \z'' -> z'' <= y') 2)]- , checkLiquid "tests/Liquid/DataRefTest.hs" "addMaybe2" 2000 3- [AtLeast 1, RForAll (\[x, _, _] -> appNthArgIs x (\x' -> isInt x' $ \x'' -> x'' >= 0) 2)- , RForAll (\[_, y, z] -> isInt y $ \y' -> appNthArgIs z (\z' -> isInt z' $ \z'' -> z'' <= y') 2)]- , checkLiquid "tests/Liquid/DataRefTest.hs" "getLeftInts" 2000 2 - [AtLeast 1, RForAll (\[x, _] -> dcInAppHasName "Right" x 3)]- , checkLiquid "tests/Liquid/DataRefTest.hs" "sumSameInts" 2000 3 - [AtLeast 1, RForAll (\[x, y, _] -> dcInAppHasName "Right" x 3 && dcInAppHasName "Left" y 3)]- , checkLiquid "tests/Liquid/DataRefTest.hs" "sub1" 1200 4 [AtLeast 1]+ , checkInputOutputs "tests/Samples/FoldlUses.hs" [ ("sum_foldl", 1600, [AtLeast 3])+ , ("dotProd", 1000, [AtLeast 3]) ] - , checkLiquid "tests/Liquid/NumOrd.hs" "subTuple" 1200 3 [AtLeast 1]+ , checkInputOutputs "tests/Samples/FoldlUsesPoly.hs" [ ("sumMinAndMax", 600, [AtLeast 10])+ , ("maxes", 400, [AtLeast 10])+ , ("switchInt", 400, [AtLeast 1])+ , ("getInInt", 400, [AtLeast 1])+ , ("switchP", 400, [AtLeast 1]) ] - , checkLiquid "tests/Liquid/CommentMeasures.hs" "d" 1000 2 [AtLeast 1]- , checkLiquid "tests/Liquid/CommentMeasures.hs" "unpackCP'" 100000 2 [Exactly 0]- , checkLiquid "tests/Liquid/CommentMeasures.hs" "unpackBool" 1000 2 [AtLeast 1, RForAll (\[_, r] -> getBoolB r (== False))]- , checkLiquid "tests/Liquid/CommentMeasures.hs" "sumSameOneOfs" 100000 3 [Exactly 0]- , checkLiquid "tests/Liquid/CommentMeasures.hs" "gets2As" 2000 3 - [AtLeast 1, RExists (\[x, y, _] -> buriedDCName "B" x && buriedDCName "B" y)]- , checkLiquid "tests/Liquid/CommentMeasures.hs" "gets2As'" 1000 3 - [AtLeast 1, RExists (\[x, y, _] -> buriedDCName "A" x && buriedDCName "B" y)- , RExists (\[x, y, _] -> buriedDCName "B" x && buriedDCName "A" y)]- , checkLiquid "tests/Liquid/CommentMeasures.hs" "ge4gt5" 1000 2 - [AtLeast 1, RForAll (\[x, y] -> appNth x 1 $ \x' -> isInt x' $ \x'' -> isInt y $ \y' -> x'' == 4 && y' == 5)]+ , checkInputOutput "tests/Samples/NQueens.hs" "allQueensSafe" 2000 [AtLeast 14] - , checkLiquid "tests/Liquid/ConcatList.hs" "concat2" 800 3 [AtLeast 2]- , checkLiquid "tests/Liquid/ConcatList.hs" "concat3" 800 3 [AtLeast 2]- , checkLiquid "tests/Liquid/ConcatList.hs" "concat5" 1600 3 [AtLeast 1]+ ] - , checkLiquidWithConfig "tests/Liquid/Tests/Group3.lhs" "f" 1 (mkConfigTestWithMap {steps = 2200}) [AtLeast 1]+-- Tests that are intended to ensure a specific feature works, but that are not neccessarily interesting beyond that+testFileTests :: TestTree+testFileTests = testGroup "TestFiles"+ [+ checkExpr "tests/TestFiles/IfTest.hs" 400 "f"+ [ RForAll (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y)), App _ (Lit (LitInt r))] -> + if x == y then r == x + y else r == y)+ , AtLeast 2] - , checkLiquid "tests/Liquid/Nonused.hs" "g" 2000 1 [AtLeast 1]+ , checkExprAssert "tests/TestFiles/AssumeAssert.hs" 400 (Just "assertGt5") "outShouldBeGt5" [Exactly 0]+ , checkExprAssert "tests/TestFiles/AssumeAssert.hs" 400 (Just "assertGt5") "outShouldBeGe5" [AtLeast 1]+ , checkExprAssumeAssert "tests/TestFiles/AssumeAssert.hs" 400+ (Just "assumeGt5") (Just "assertGt5") "outShouldBeGt5" [Exactly 0]+ , checkExprAssumeAssert "tests/TestFiles/AssumeAssert.hs" 400+ (Just "assumeGt5") (Just "assertGt5") "outShouldBeGe5" [Exactly 0] - -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f1" 2000 3 [Exactly 0]- -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f2" 2000 3 [AtLeast 4, RForAll (\[_, x, y] -> x == y)]- -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f3" 2000 3 [Exactly 0]- -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f4" 2000 3 [AtLeast 4, RForAll (\[_, x, _] -> isInt x $ \x' -> x' == 0)]- -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f5" 2000 3 [Exactly 0]- -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f6" 2000 3 [AtLeast 10]- -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f7" 2000 3 [AtLeast 10, RForAll (\[x, _, y] -> isInt x $ \x' -> isInt y $ \y' -> x' == y')]- -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "f8" 2000 3 [AtLeast 10]- -- , checkLiquid "tests/Liquid/HigherOrderRef.hs" "callf" 2000 3 [AtLeast 1]+ , checkInputOutputs "tests/TestFiles/Char.hs" [ ("char", 400, [Exactly 2]) ] - -- , checkLiquid "tests/Liquid/Error/Error1.hs" "f" 600 2 [AtLeast 1]- , checkLiquid "tests/Liquid/Error/Error2.hs" "f1" 2000 4 [AtLeast 1]- , checkLiquid "tests/Liquid/ZipWith.lhs" "distance" 1000 4 [AtLeast 3]+ , checkExpr "tests/TestFiles/CheckSq.hs" 400 "checkSq"+ [AtLeast 2, RExists (\[x, _] -> isInt x (\x' -> x' == 3 || x' == -3))] - , checkLiquid "tests/Liquid/HigherOrder2.hs" "f" 2000 2 [Exactly 0]- , checkLiquid "tests/Liquid/HigherOrder2.hs" "h" 2000 2 [AtLeast 1]+ , checkExpr "tests/TestFiles/Defunc1.hs" 400 "f"+ [RExists defunc1Add1, RExists defunc1Multiply2, RExists defuncB, AtLeast 3]+ , checkInputOutputs "tests/TestFiles/Defunc1.hs" [ ("x", 400, [AtLeast 1])+ , ("mapYInt", 600, [AtLeast 1])+ , ("makeMoney", 600, [AtLeast 2])+ , ("compZZ", 1600, [AtLeast 2])+ , ("compZZ2", 1600, [AtLeast 2]) ] - , checkLiquid "tests/Liquid/Ordering.hs" "oneOrOther" 1000 2 [Exactly 0]+ , checkInputOutput "tests/TestFiles/Defunc2.hs" "funcMap" 400 [AtLeast 30] - , checkLiquid "tests/Liquid/AddKV.lhs" "empty" 1000 3 [Exactly 0]+ , checkExpr "tests/TestFiles/MultCase.hs" 400 "f"+ [ RExists (\[App _ (Lit (LitInt x)), y] -> x == 2 && getBoolB y id)+ , RExists (\[App _ (Lit (LitInt x)), y] -> x == 1 && getBoolB y id)+ , RExists (\[App _ (Lit (LitInt x)), y] -> x /= 2 && x /= 1 && getBoolB y not)] - , checkLiquid "tests/Liquid/PropSize.hs" "prop_size" 2000 1 [AtLeast 1]- , checkLiquid "tests/Liquid/PropSize2.hs" "prop_size" 2000 1 [AtLeast 1]+ , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating.hs" 400 (Just "output6") Nothing "f"+ [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 6)]+ , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating2.hs" 400 (Just "output16") Nothing "f"+ [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 15)]+ , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating3.hs" 600 (Just "output32") Nothing "f"+ [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 4)]+ , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating4.hs" 400 (Just "output12") Nothing "f"+ [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 11)]+ , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating5.hs" 400 (Just "output19") Nothing "f"+ [AtLeast 1, RForAll (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y)), _] -> x + y + 1 == 19)]+ , checkExprAssumeAssert "tests/TestFiles/LetFloating/LetFloating6.hs" 400 (Just "output32") Nothing "f"+ [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 25)] - , checkLiquidWithConfig "tests/Liquid/WhereFuncs.lhs" "f" 3 (mkConfigTestWithMap {steps = 1000}) [Exactly 0]- , checkLiquidWithConfig "tests/Liquid/WhereFuncs.lhs" "g" 3 (mkConfigTestWithMap {steps = 1000}) [Exactly 0]+ , checkExpr "tests/TestFiles/TypeClass/TypeClass1.hs" 400 "f" [RExists (\[x, y] -> x == y), Exactly 1]+ , checkExpr "tests/TestFiles/TypeClass/TypeClass2.hs" 400 "f" [RExists (\[x, y] -> x == y), Exactly 1]+ , checkExpr "tests/TestFiles/TypeClass/TypeClass3.hs" 400 "f"+ [RExists (\[x, y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' + 8 == y'), Exactly 1]+ , checkExpr "tests/TestFiles/TypeClass/TypeClass4.hs" 1000 "f" [AtLeast 1] - , checkLiquid "tests/Liquid/PropConcat.lhs" "prop_concat" 1000 1 [AtLeast 1]+ , checkExprAssumeAssert "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 (Just "largeJ") Nothing "extractJ"+ [RForAll (\[x, ly@(App _ (Lit (LitInt y)))] -> appNthArgIs x (ly ==) 2 && y > 100), Exactly 1]+ , checkExprAssumeAssert "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 (Just "largeE") Nothing "extractE"+ [RForAll (\[x, ly@(App _ (Lit (LitInt y)))] -> appNthArgIs x (ly ==) 4 && y > 100), Exactly 1]+ , checkExpr "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 "changeJ"+ [RForAll (\[_, x, y] -> dcInAppHasName "J" x 2 && (dcInAppHasName "J" y 2 || isError y)), AtLeast 2] - , checkLiquid "tests/Liquid/Distance.lhs" "distance" 1000 4 [AtLeast 1]- , checkLiquid "tests/Liquid/MultModules/CallZ.lhs" "callZ" 1000 3 [AtLeast 1]- , checkAbsLiquid "tests/Liquid/AddToEven.hs" "f" 2000 1- [ AtLeast 1- , RForAll $ \[i] r [(FuncCall { funcName = Name n _ _ _, returns = fcr }) ]- -> n == "g"- && isInt i (\i' -> i' `mod` 2 == 0 &&- isInt r (\r' -> isInt fcr (\fcr' -> r' == i' + fcr')))]+ , checkExpr "tests/TestFiles/Case1.hs" 400 "f"+ [ RExists (\[App _ (Lit (LitInt x)), y] -> x < 0 && dcHasName "A" y)+ , RExists (\[App _ (Lit (LitInt x)), y] -> x >= 0 && dcHasName "C" y), Exactly 2]+ , checkExpr "tests/TestFiles/Case2.hs" 400 "f"+ [ RExists exists1+ , RExists exists2+ , RExists exists3+ , RExists exists4+ , AtLeast 4] - , checkLiquid "tests/Liquid/ListTests.lhs" "r" 1000 1 [Exactly 0]- , checkLiquid "tests/Liquid/ListTests.lhs" "prop_map" 1500 3 [AtLeast 3]- , checkLiquid "tests/Liquid/ListTests.lhs" "prop_concat_1" 1500 1 [AtLeast 1]- , checkAbsLiquid "tests/Liquid/ListTests2.lhs" "prop_map" 2000 4- [ AtLeast 3- , RForAll (\[_, _, f, _] _ [(FuncCall { funcName = Name n _ _ _, arguments = [_, _, _, _, f', _] }) ] -> n == "map" && f == f') ]- , checkAbsLiquid "tests/Liquid/ListTests2.lhs" "replicate" 2000 3- [ AtLeast 3- , RForAll (\[_, nA, aA] _ [(FuncCall { funcName = Name n _ _ _, arguments = [_, _, nA', aA'] }) ]- -> n == "replicate" && nA == nA' && aA == aA') ]- , checkAbsLiquid "tests/Liquid/ListTests2.lhs" "prop_size" 2000 0- [ AtLeast 1- , RForAll (\[] _ [(FuncCall { funcName = Name n _ _ _, returns = r }) ]- -> n == "length2" && getIntB r (/= 3)) ]+ , checkExprAssumeAssert "tests/TestFiles/Guards.hs" 400 (Just "g") Nothing "f"+ [AtLeast 1, RExists (\[dc, _] -> getBoolB dc id)] - , checkLiquid "tests/Liquid/MapReduceTest2.lhs" "mapReduce" 1500 3 [Exactly 0]+ , checkExprAssumeAssert "tests/TestFiles/Infinite.hs" 400 (Just "g") Nothing "f"+ [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x <= 100 && x /= 80)] - , checkLiquid "tests/Liquid/MeasErr.hs" "f" 1500 2 [Exactly 0]+ , checkExpr "tests/TestFiles/Strictness1.hs" 400 "f"+ [AtLeast 1, RExists (\[(App x (App _ (Lit (LitInt y))))] -> dcHasName "A" x && y == 9)] - , checkAbsLiquid "tests/Liquid/Replicate.hs" "replicate" 2000 3- [ AtLeast 1- , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "foldl") ]- , checkAbsLiquid "tests/Liquid/Replicate.hs" "r" 2000 2- [ AtLeast 1- , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "foldl") ]+ , checkExpr "tests/TestFiles/Where1.hs" 400 "f"+ [ RExists (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y))] -> x == 4 && y == 1)+ , RExists (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y))] -> x /= 4 && y == 1) ]+ + , checkInputOutputs "tests/TestFiles/Error/Error1.hs" [ ("f", 400, [AtLeast 1])+ , ("g", 400, [AtLeast 1])+ , ("f", 400, [AtLeast 1])+ , ("f", 400, [AtLeast 1])+ , ("g", 400, [AtLeast 1]) ]+ , checkInputOutputs "tests/TestFiles/Error/Undefined1.hs" [ ("undefined1", 400, [AtLeast 1])+ , ("undefined2", 400, [AtLeast 1])]+ , checkInputOutput "tests/TestFiles/Error/IrrefutError.hs" "f" 400 [AtLeast 2] - , checkAbsLiquid "tests/Liquid/AbsTypeClass.hs" "callF" 1000 1- [ AtLeast 1- , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "f") ]- , checkAbsLiquid "tests/Liquid/AbsTypeClassVerified.hs" "callF" 10000 1 [ Exactly 0 ]- ]+ , checkInputOutputs "tests/TestFiles/BadNames1.hs" [ ("abs'", 400, [Exactly 2])+ , ("xswitch", 400, [AtLeast 10]) ] --- Tests that are intended to ensure a specific feature works, but that are not neccessarily interesting beyond that-testFileTests :: IO TestTree-testFileTests = - return . testGroup "TestFiles"- =<< sequence [- checkExpr "tests/TestFiles/IfTest.hs" 400 Nothing Nothing "f" 3 [RForAll (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y)), App _ (Lit (LitInt r))] -> if x == y then r == x + y else r == y), AtLeast 2]+ , checkInputOutputs "tests/TestFiles/ListCallStack.hs" [ ("indexOf", 400, [AtLeast 2]) + , ("headOf", 400, [AtLeast 2])+ , ("tailOf", 400, [AtLeast 2])+ , ("lastOf", 400, [AtLeast 2])+ , ("initOf", 400, [AtLeast 2])+ , ("cycleOf", 400, [AtLeast 2]) ] - , checkExpr "tests/TestFiles/AssumeAssert.hs" 400 Nothing (Just "assertGt5") "outShouldBeGt5" 2 [Exactly 0]- , checkExpr "tests/TestFiles/AssumeAssert.hs" 400 Nothing (Just "assertGt5") "outShouldBeGe5" 2 [AtLeast 1]- , checkExpr "tests/TestFiles/AssumeAssert.hs" 400 (Just "assumeGt5") (Just "assertGt5") "outShouldBeGt5" 2 [Exactly 0]- , checkExpr "tests/TestFiles/AssumeAssert.hs" 400 (Just "assumeGt5") (Just "assertGt5") "outShouldBeGe5" 2 [Exactly 0]+ , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 "f"+ [Exactly 2, RExists (\[x, _, y] -> x == y), RExists (\[_, App _ x, y] -> x == y)]+ , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 "getFstXIntInt"+ [AtLeast 2, RExists (\[x, y] -> isApp x && isError y)]+ , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 "sum" [AtLeast 3, RExists (\[x, y] -> isApp x && isError y)] - , checkExpr "tests/TestFiles/CheckSq.hs" 400 Nothing Nothing "checkSq" 2 [AtLeast 2, RExists (\[x, _] -> isInt x (\x' -> x' == 3))]+ , checkExprAssumeAssert "tests/TestFiles/MultiSplit.hs" 1000 (Just "equals1") Nothing "f" [Exactly 0] - , checkExpr "tests/TestFiles/Defunc1.hs" 400 Nothing Nothing "f" 2 [RExists defunc1Add1, RExists defunc1Multiply2, RExists defuncB, AtLeast 3]- , checkExpr "tests/TestFiles/Defunc1.hs" 400 Nothing Nothing "x" 2 [AtLeast 1]- , checkExpr "tests/TestFiles/Defunc1.hs" 600 Nothing Nothing "mapYInt" 3 [AtLeast 1]- , checkExpr "tests/TestFiles/Defunc1.hs" 600 Nothing Nothing "makeMoney" 3 [AtLeast 3]- , checkExpr "tests/TestFiles/Defunc1.hs" 1600 Nothing Nothing "compZZ" 4 [AtLeast 2, RForAll (\[_, _, _, x] -> getBoolB x not)]- , checkExpr "tests/TestFiles/Defunc1.hs" 1600 Nothing Nothing "compZZ2" 4 [AtLeast 2, RForAll (\[_, _, _, x] -> getBoolB x not)]+ , checkExpr "tests/TestFiles/MatchesFunc1.hs" 400 "f"+ [RExists (\[x, y] -> getIntB x $ \x' -> getIntB y $ \y' -> y' == 6 + x'), AtLeast 1] - , checkExpr "tests/TestFiles/Defunc2.hs" 400 Nothing Nothing "funcMap" 3 [RForAll defunc2Check, AtLeast 30]+ , checkInputOutput "tests/TestFiles/Read.hs" "concRead" 20000 [Exactly 1] - , checkExpr "tests/TestFiles/MultCase.hs" 400 Nothing Nothing "f" 2- [ RExists (\[App _ (Lit (LitInt x)), y] -> x == 2 && getBoolB y id)- , RExists (\[App _ (Lit (LitInt x)), y] -> x == 1 && getBoolB y id)- , RExists (\[App _ (Lit (LitInt x)), y] -> x /= 2 && x /= 1 && getBoolB y not)]+ , checkExpr "tests/TestFiles/RecordFields1.hs" 400 "f"+ [ RExists + (\[x, y] -> appNthArgIs x notCast 0+ && appNthArgIs x (\x' -> getIntB x' $ \x'' -> getIntB y $ \y' -> x'' + 1 == y') 1)+ , Exactly 1]+ , checkExpr "tests/TestFiles/RecordFields1.hs" 400 "fCall" [RExists (\[x] -> isInt x ((==) 35)), Exactly 1]+ , checkExpr "tests/TestFiles/RecordFields1.hs" 400 "g"+ [ RExists (\[x, y] -> appNthArgIs x (dcHasName "A") 2 && appNthArgIs y (dcHasName "B") 2)+ , RExists (\[x, y] -> appNthArgIs x (dcHasName "B") 2 && appNthArgIs y (dcHasName "C") 2)+ , RExists (\[x, y] -> appNthArgIs x (dcHasName "C") 2 && appNthArgIs y (dcHasName "A") 2)+ , Exactly 3] - , checkExpr "tests/TestFiles/LetFloating/LetFloating.hs" 400 (Just "output6") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 6)]- , checkExpr "tests/TestFiles/LetFloating/LetFloating2.hs" 400 (Just "output16") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 15)]- , checkExpr "tests/TestFiles/LetFloating/LetFloating3.hs" 600 (Just "output32") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 4)]- , checkExpr "tests/TestFiles/LetFloating/LetFloating4.hs" 400 (Just "output12") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 11)]- , checkExpr "tests/TestFiles/LetFloating/LetFloating5.hs" 400 (Just "output19") Nothing "f" 3 [AtLeast 1, RForAll (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y)), _] -> x + y + 1 == 19)]- , checkExpr "tests/TestFiles/LetFloating/LetFloating6.hs" 400 (Just "output32") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x == 25)]+ , checkInputOutputs "tests/TestFiles/Deriving/DerivingSimple.hs" [ ("eq", 400, [AtLeast 2])+ , ("lt", 400, [AtLeast 2]) ]+ , checkInputOutputs "tests/TestFiles/Deriving/DerivingComp.hs" [ ("eq", 800, [AtLeast 2])+ , ("lt", 800, [AtLeast 2]) ] - , checkExpr "tests/TestFiles/TypeClass/TypeClass1.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> x == y), Exactly 1]- , checkExpr "tests/TestFiles/TypeClass/TypeClass2.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> x == y), Exactly 1]- , checkExpr "tests/TestFiles/TypeClass/TypeClass3.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' + 8 == y'), Exactly 1]- , checkExprWithConfig "tests/TestFiles/TypeClass/TypeClass4.hs" Nothing Nothing Nothing "f" 1 (mkConfigTestWithMap {steps = 1000}) [AtLeast 1]+ , checkInputOutputs "tests/TestFiles/Coercions/Age.hs" [ ("born", 400, [Exactly 1])+ , ("yearPasses", 400, [AtLeast 1])+ , ("age", 400, [AtLeast 1])+ , ("diffAge", 400, [AtLeast 1])+ , ("yearBefore", 400, [AtLeast 5])]+ , checkInputOutputs "tests/TestFiles/Coercions/NewType1.hs" [ ("add1N4", 400, [Exactly 1])+ , ("f", 400, [Exactly 1])+ , ("g", 400, [Exactly 1])+ , ("mapWInt", 400, [AtLeast 2])+ , ("appLeftFloat", 400, [AtLeast 2])+ , ("getLIntFloat", 400, [AtLeast 2])+ , ("getRIntFloat", 400, [AtLeast 2])+ , ("getCIntFloatDouble", 400, [AtLeast 2])+ , ("getRIntFloatX'", 400, [AtLeast 2])] - , checkExpr "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 (Just "largeJ") Nothing "extractJ" 2 [RForAll (\[x, ly@(App _ (Lit (LitInt y)))] -> appNthArgIs x (ly ==) 2 && y > 100), Exactly 1]- , checkExpr "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 (Just "largeE") Nothing "extractE" 2 [RForAll (\[x, ly@(App _ (Lit (LitInt y)))] -> appNthArgIs x (ly ==) 4 && y > 100), Exactly 1]- , checkExpr "tests/TestFiles/TypeClass/HKTypeClass1.hs" 400 Nothing Nothing "changeJ" 3 [RForAll (\[_, x, y] -> dcInAppHasName "J" x 2 && (dcInAppHasName "J" y 2 || isError y)), AtLeast 2]+ , checkInputOutput "tests/TestFiles/Coercions/BadCoerce.hs" "f" 400 [AtLeast 1]+ , checkInputOutput "tests/TestFiles/Expr.hs" "leadingLams" 400 [AtLeast 5] - , checkExpr "tests/TestFiles/Case1.hs" 400 Nothing Nothing "f" 2 [ RExists (\[App _ (Lit (LitInt x)), y] -> x < 0 && dcHasName "A" y)- , RExists (\[App _ (Lit (LitInt x)), y] -> x >= 0 && dcHasName "C" y), Exactly 2]- , checkExpr "tests/TestFiles/Case2.hs" 400 Nothing Nothing "f" 2 - [ RExists exists1- , RExists exists2- , RExists exists3- , RExists exists4- , AtLeast 4]+ , checkExprAssume "tests/TestFiles/Subseq.hs" 1200 (Just "assume") "subseqTest" [AtLeast 1] - , checkExpr "tests/TestFiles/Guards.hs" 400 (Just "g") Nothing "f" 2 [AtLeast 1, RExists (\[dc, _] -> getBoolB dc id)]+ , checkInputOutputs "tests/TestFiles/Strings/Strings1.hs" [ ("con", 300, [AtLeast 10])+ , ("eq", 700, [AtLeast 10])+ , ("eqGt1", 700, [AtLeast 10])+ , ("capABC", 200, [AtLeast 10])+ , ("appendEq", 500, [AtLeast 5]) ] - , checkExpr "tests/TestFiles/Infinite.hs" 400 (Just "g") Nothing "f" 2 [AtLeast 1, RExists (\[App _ (Lit (LitInt x)), _] -> x <= 100 && x /= 80)]+ , checkExpr "tests/TestFiles/Strings/Strings1.hs" 1000 "exclaimEq"+ [AtLeast 5, RExists (\[_, _, r] -> dcHasName "True" r)] - , checkExpr "tests/TestFiles/Strictness1.hs" 400 Nothing Nothing "f" 1 [AtLeast 1, RExists (\[(App x (App _ (Lit (LitInt y))))] -> dcHasName "A" x && y == 9)]+ , checkExpr "tests/TestFiles/Sets/SetInsert.hs" 700 "prop" [AtLeast 3]+ + , checkInputOutputs "tests/TestFiles/BadDC.hs" [ ("f", 400, [AtLeast 5])+ , ("g", 400, [AtLeast 3]) ] - , checkExpr "tests/TestFiles/Where1.hs" 400 Nothing Nothing "f" 2 [ RExists (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y))] -> x == 4 && y == 1)- , RExists (\[App _ (Lit (LitInt x)), App _ (Lit (LitInt y))] -> x /= 4 && y == 1) ]- - , checkExpr "tests/TestFiles/Error/Error1.hs" 400 Nothing Nothing "f" 2 [AtLeast 1, RForAll(errors)]- , checkExpr "tests/TestFiles/Error/Error1.hs" 400 Nothing Nothing "g" 2 [AtLeast 1, RForAll(errors)]- , checkExpr "tests/TestFiles/Error/Error2.hs" 400 Nothing Nothing "f" 1 [AtLeast 1, RForAll(errors)]- , checkExpr "tests/TestFiles/Error/Error3.hs" 400 Nothing Nothing "f" 2 [AtLeast 1, RForAll(errors)]- , checkExpr "tests/TestFiles/Error/Error3.hs" 400 Nothing Nothing "g" 2 [AtLeast 1, RForAll(not . errors)]- , checkExpr "tests/TestFiles/Error/Undefined1.hs" 400 Nothing Nothing "undefined1" 2 [AtLeast 1, RForAll(errors)]- , checkExpr "tests/TestFiles/Error/Undefined1.hs" 400 Nothing Nothing "undefined2" 2 [AtLeast 1, RForAll(errors)]+ , checkInputOutputsTemplate "tests/HigherOrder/HigherOrder.hs" [ ("f", 50, [AtLeast 5])+ , ("h", 100, [AtLeast 3])+ , ("assoc", 200, [AtLeast 5])+ , ("sf", 150, [AtLeast 5])+ , ("thirdOrder", 75, [AtLeast 10])+ , ("tupleTestMono", 175, [AtLeast 10])]+ , checkInputOutputsTemplate "tests/HigherOrder/PolyHigherOrder.hs" [ ("f", 50, [AtLeast 5])+ , ("h", 200, [AtLeast 3])+ , ("assoc", 200, [AtLeast 5])+ , ("sf", 150, [AtLeast 5])+ , ("tupleTest", 175, [AtLeast 8])]+ , checkInputOutputsNonRedTemp "tests/HigherOrder/HigherOrder.hs" [ ("f", 200, [Exactly 3])+ , ("h", 150, [Exactly 2])+ , ("assoc", 200, [Exactly 2])+ , ("sf", 200, [Exactly 2])+ , ("thirdOrder", 300, [Exactly 2])+ , ("thirdOrder2", 300, [Exactly 3])+ , ("tupleTestMono", 175, [Exactly 2])] + -- , checkInputOutput "tests/TestFiles/BadBool.hs" "BadBool" "f" 1400 [AtLeast 1]+ -- , checkExprAssumeAssert "tests/TestFiles/Coercions/GADT.hs" 400 Nothing Nothing "g" 2+ -- [ AtLeast 2+ -- , RExists (\[x, y] -> x == Lit (LitInt 0) && y == App (Data (PrimCon I)) (Lit (LitInt 0)))+ -- , RExists (\[x, _] -> x /= Lit (LitInt 0))]+ -- , checkExprAssumeAssert "tests/TestFiles/HigherOrderList.hs" 400 Nothing Nothing "g" [AtLeast 10] + , checkExpr "tests/TestFiles/MkSymbolic.hs" 1500 "f" [ Exactly 9 ] - , checkExpr "tests/TestFiles/BadNames1.hs" 400 Nothing Nothing "abs'" 2 [Exactly 2]- , checkExpr "tests/TestFiles/BadNames1.hs" 400 Nothing Nothing "xswitch" 2 [AtLeast 10]+ , checkInputOutputs "tests/TestFiles/Show.hs" [ ("show1", 1000, [Exactly 1])+ , ("show2", 1000, [Exactly 1])+ , ("show3", 1000, [AtLeast 3])+ , ("show4", 1000, [Exactly 2])+ , ("show5", 1300, [AtLeast 12])+ , ("checkWS", 1000, [Exactly 5]) ]+ ] - , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 Nothing Nothing "f" 3 [Exactly 2, RExists (\[x, _, y] -> x == y), RExists (\[_, App _ x, y] -> x == y)]- , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 Nothing Nothing "getFstXIntInt" 2 [AtLeast 2, RExists (\[x, y] -> isApp x && isError y)]- , checkExpr "tests/TestFiles/PolyDataTy1.hs" 400 Nothing Nothing "sum" 2 [AtLeast 3, RExists (\[x, y] -> isApp x && isError y)]+extensionTests :: TestTree+extensionTests = testGroup "Extensions"+ [+ checkInputOutputs "tests/TestFiles/Extensions/PatternSynonyms1.hs" [ ("isNineInt", 400, [AtLeast 2])+ , ("isNineInteger", 400, [AtLeast 2])+ , ("isNineFloat", 400, [AtLeast 2])+ , ("isFunc", 400, [AtLeast 2])+ , ("funcArg", 400, [AtLeast 2])+ + , ("consArrow", 400, [AtLeast 2]) ]+ , checkInputOutputs "tests/TestFiles/Extensions/ViewPatterns1.hs" [ ("shapeToNumSides", 4000, [Exactly 4]) ]+ , checkInputOutputs "tests/TestFiles/Extensions/FlexibleContexts1.hs" [ ("callF", 400, [AtLeast 2])+ , ("callF2", 400, [AtLeast 2])+ , ("callF3", 400, [AtLeast 2])+ , ("callG", 400, [AtLeast 1])+ , ("callG2", 400, [AtLeast 1]) ]+ ] - , checkExpr "tests/TestFiles/MultiSplit.hs" 1000 (Just "equals1") Nothing "f" 3 [Exactly 0]+baseTests :: TestTree+baseTests = testGroup "Base"+ [+ checkInputOutput "tests/Samples/Peano.hs" "add" 400 [AtLeast 4] - , checkExpr "tests/TestFiles/MatchesFunc1.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> getIntB x $ \x' -> getIntB y $ \y' -> y' == 6 + x'), AtLeast 1]+ , checkInputOutputs "tests/BaseTests/ListTests.hs" [ ("test", 1000, [AtLeast 1])+ , ("maxMap", 1000, [AtLeast 4])+ , ("minTest", 1000, [AtLeast 2])+ , ("foldrTest2", 1000, [AtLeast 1]) ] - , checkExpr "tests/TestFiles/RecordFields1.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> appNthArgIs x notCast 0 && appNthArgIs x (\x' -> getIntB x' $ \x'' -> getIntB y $ \y' -> x'' + 1 == y') 1), Exactly 1]- , checkExpr "tests/TestFiles/RecordFields1.hs" 400 Nothing Nothing "fCall" 1 [RExists (\[x] -> isInt x ((==) 35)), Exactly 1]- , checkExpr "tests/TestFiles/RecordFields1.hs" 400 Nothing Nothing "g" 2 [ RExists (\[x, y] -> appNthArgIs x (dcHasName "A") 2 && appNthArgIs y (dcHasName "B") 2)- , RExists (\[x, y] -> appNthArgIs x (dcHasName "B") 2 && appNthArgIs y (dcHasName "C") 2)- , RExists (\[x, y] -> appNthArgIs x (dcHasName "C") 2 && appNthArgIs y (dcHasName "A") 2)- , Exactly 3]+ , checkInputOutput "tests/BaseTests/Tuples.hs" "addTupleElems" 1000 [AtLeast 2] - , checkExpr "tests/TestFiles/Deriving/DerivingSimple.hs" 400 Nothing Nothing "eq" 3 [AtLeast 2, RForAll (\[_, _, x] -> isBool x)]- , checkExpr "tests/TestFiles/Deriving/DerivingSimple.hs" 400 Nothing Nothing "lt" 3 [AtLeast 2, RForAll (\[_, _, x] -> isBool x)]- , checkExpr "tests/TestFiles/Deriving/DerivingComp.hs" 800 Nothing Nothing "eq" 3 [AtLeast 2, RForAll (\[_, _, x] -> isBool x)]- , checkExpr "tests/TestFiles/Deriving/DerivingComp.hs" 800 Nothing Nothing "lt" 3 [AtLeast 2, RForAll (\[_, _, x] -> isBool x)]+ , checkInputOutputs "tests/BaseTests/MaybeTest.hs" [ ("headMaybeInt", 1000, [AtLeast 2])+ , ("sumN", 1000, [AtLeast 6])+ , ("lengthN", 1000, [AtLeast 6]) ] - , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "born" 1 [ Exactly 1- , RForAll (\[x] -> inCast x (\x' -> appNthArgIs x' (Lit (LitInt 0) ==) 1) (\(t1 :~ t2) -> isIntT t1 && typeNameIs t2 "Age"))]- , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "yearPasses" 2 [ AtLeast 1- , RForAll (\[x, y] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "Age")- && inCast y (const True) (\(_ :~ t2) -> typeNameIs t2 "Age") )]- , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "age" 2 [ AtLeast 1- , RForAll (\[x, y] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "Age") && isInt y (const True))]- , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "diffAge" 3 [ AtLeast 1- , RForAll (\[x, y, z] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "Age") - && inCast y (const True) (\(_ :~ t2) -> typeNameIs t2 "Age")- && inCast z (const True) (\(_ :~ t2) -> typeNameIs t2 "Years"))]- , checkExpr "tests/TestFiles/Coercions/Age.hs" 400 Nothing Nothing "yearBefore" 2 [ AtLeast 5 ]- , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "add1N4" 2 [ Exactly 1- , RForAll (\[x, y] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "N4") - && inCast y (const True) (\(_ :~ t2) -> typeNameIs t2 "N4"))]- , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "f" 2 [ Exactly 1- , RForAll (\[x, y] -> inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "NewX") && dcHasName "X" y)]- , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "g" 2 [ Exactly 1- , RForAll (\[x, y] -> dcHasName "X" x && inCast y (const True) (\(_ :~ t2) -> typeNameIs t2 "NewX"))]+ , checkInputOutput "tests/BaseTests/Other.hs" "check4VeryEasy2" 600 [AtLeast 1]+ ] - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "mapWInt" 3 [ AtLeast 2- , RForAll (\[_, x, y] -> isError y- || (inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "W") &&- inCast x (const True) (\(_ :~ t2) -> typeNameIs t2 "W"))) ]+primTests :: TestTree+primTests = testGroup "Prims"+ [+ checkInputOutputs "tests/Prim/Prim2.hs" [ ("quotI1", 1000, [AtLeast 4])+ , ("quotI2", 1000, [AtLeast 4])+ , ("remI1", 1000, [AtLeast 4])+ , ("remI2", 1000, [AtLeast 3])+ , ("remI3", 1000, [AtLeast 1])+ , ("remI4", 1000, [AtLeast 1]) - , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "appLeftFloat" 3 [ AtLeast 2- , RExists (\[_, _, y] -> inCast y (\y' -> dcInAppHasName "L" y' 3) (const True))- , RExists (\[_, _, y] -> inCast y (\y' -> dcInAppHasName "R" y' 3) (const True))]- , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "getLIntFloat" 2 [ AtLeast 2- , RExists (\[_, y] -> isInt y (const True))- , RExists (\[_, y] -> isError y)]- , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "getRIntFloat" 2 [ AtLeast 2- , RExists (\[_, y] -> isFloat y (const True))- , RExists (\[_, y] -> isError y)]- , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "getCIntFloatDouble" 2 [ AtLeast 2- , RExists (\[_, y] -> isFloat y (const True))- , RExists (\[_, y] -> isError y)]- , checkExpr "tests/TestFiles/Coercions/NewType1.hs" 400 Nothing Nothing "getRIntFloatX'" 2 [ AtLeast 2- , RExists (\[x, y] -> inCast x (\x' -> dcInAppHasName "TR" x' 4) (const True)- && isInt y (const True))- , RExists (\[_, y] -> isError y)]- , checkInputOutput "tests/TestFiles/Coercions/BadCoerce.hs" "BadCoerce" "f" 400 3 [AtLeast 1]- , checkExpr "tests/TestFiles/Expr.hs" 400 Nothing Nothing "leadingLams" 2 [AtLeast 5, RForAll (\[_, y] -> noUndefined y)]+ , ("p1List", 300000, [AtLeast 1])+ , ("p2List", 700000, [AtLeast 1]) - , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "con" 300 3 [AtLeast 10]- , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "eq" 700 3 [AtLeast 10]- , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "eqGt1" 700 3 [AtLeast 10]- , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "capABC" 150 2 [AtLeast 10]- , checkInputOutput "tests/TestFiles/Strings/Strings1.hs" "Strings1" "appendEq" 500 2 [AtLeast 5]- , checkExpr "tests/TestFiles/Strings/Strings1.hs" 1000 Nothing Nothing "exclaimEq" 3 [AtLeast 5, RExists (\[_, _, r] -> dcHasName "True" r)]- - , checkInputOutput "tests/TestFiles/BadDC.hs" "BadDC" "f" 400 2 [AtLeast 5]- , checkInputOutput "tests/TestFiles/BadDC.hs" "BadDC" "g" 400 2 [AtLeast 3]- -- , checkInputOutput "tests/TestFiles/BadBool.hs" "BadBool" "f" 1400 4 [AtLeast 1]- -- , checkExpr "tests/TestFiles/Coercions/GADT.hs" 400 Nothing Nothing "g" 2 [ AtLeast 2- -- , RExists (\[x, y] -> x == Lit (LitInt 0) && y == App (Data (PrimCon I)) (Lit (LitInt 0)))- -- , RExists (\[x, _] -> x /= Lit (LitInt 0))]- -- , checkExpr "tests/TestFiles/HigherOrderList.hs" 400 Nothing Nothing "g" 3 [AtLeast 10] - - ]+ , ("integerToFloatList", 150000, [AtLeast 1]) ] -baseTests :: IO TestTree-baseTests =- return . testGroup "Base"- =<< sequence [- checkInputOutput "tests/Samples/Peano.hs" "Peano" "add" 400 3 [AtLeast 4]- , checkInputOutput "tests/BaseTests/ListTests.hs" "ListTests" "test" 1000 2 [AtLeast 1]- , checkInputOutput "tests/BaseTests/ListTests.hs" "ListTests" "maxMap" 1000 2 [AtLeast 4]- , checkInputOutput "tests/BaseTests/ListTests.hs" "ListTests" "minTest" 1000 2 [AtLeast 2]- , checkInputOutput "tests/BaseTests/ListTests.hs" "ListTests" "foldrTest2" 1000 2 [AtLeast 1]- , checkInputOutput "tests/BaseTests/Tuples.hs" "Tuples" "addTupleElems" 1000 2 [AtLeast 2]+ , checkInputOutputs "tests/Prim/Prim3.hs" [ ("int2FloatTest", 1000, [AtLeast 1])+ , ("int2DoubleTest", 1000, [AtLeast 1]) ] - , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "sumN" 1000 4 [AtLeast 6]- , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "lengthN" 1000 5 [AtLeast 6]+ , checkInputOutputs "tests/Prim/Prim4.hs" [ ("divIntTest", 1500, [AtLeast 4])+ , ("divIntegerTest", 1500, [AtLeast 1])+ , ("divIntegerTest2", 1500, [AtLeast 4])+ , ("divFloatTest", 1500, [AtLeast 1]) ] - , checkInputOutput "tests/BaseTests/Other.hs" "Other" "check4VeryEasy2" 600 1 [AtLeast 1]- ]+ , checkInputOutputs "tests/Prim/DataTag.hs" [ ("dataToTag1", 1000, [Exactly 1])+ , ("dataToTag2", 1000, [AtLeast 1])+ , ("dataToTag3", 1000, [Exactly 5])+ , ("tagToEnum1", 1000, [AtLeast 1])+ , ("tagToEnum3", 1000, [AtLeast 4])+ , ("tagToEnum4", 1000, [AtLeast 4])+ , ("tagToEnum5", 1000, [Exactly 1])+ , ("tagToEnum6", 1000, [AtLeast 4]) ] -primTests :: IO TestTree-primTests =- return . testGroup "Prims"- =<< sequence [- checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "quotI1" 1000 3 [AtLeast 4]- , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "quotI2" 1000 3 [AtLeast 4]- , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "remI1" 1000 3 [AtLeast 4]- , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "remI2" 1000 3 [AtLeast 3]+ , checkExpr "tests/Prim/DataTag.hs" 1000 "tagToEnum2" [Exactly 1, RForAll (\[r] -> isError r)] - , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "p1List" 300000 1 [AtLeast 1]- , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "p2List" 700000 1 [AtLeast 1]- , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "integerToFloatList" 150000 1 [AtLeast 1]+ , checkInputOutputs "tests/Prim/Chr.hs" [ ("lowerLetters", 9000, [AtLeast 1])+ , ("allLetters", 20000, [AtLeast 1])+ , ("printBasedOnChr", 1500, [AtLeast 7])+ , ("printBasedOnOrd", 1500, [AtLeast 7]) ]+ ] - , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "int2FloatTest" 1000 2 [AtLeast 1]- , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "int2DoubleTest" 1000 2 [AtLeast 1]- ]+ioTests :: TestTree+ioTests = testGroup "IO"+ [+ checkInputOutput "tests/IO/UnsafePerformIO1.hs" "f" 1000 [Exactly 1]+ ] -- To Do Tests -------------- -todoTests :: IO TestTree-todoTests =- return . testGroup "To Do"- =<< sequence [- checkLiquid "tests/Liquid/TyApps.hs" "goodGet" 1000 4 [Exactly 0]- , checkLiquid "tests/Liquid/TyApps.hs" "getPosInt" 1000 4- [ AtLeast 1- , RForAll (\[_, _, (App _ x), y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' == y' && y' == 10)]- , checkLiquid "tests/Liquid/TyApps.hs" "getPos" 1000 4- [ AtLeast 1- , RExists (\[_, _, (App _ x), y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' == y' && y' == 10)]- , checkLiquid "tests/Liquid/FoldrTests.hs" "max2" 1000 2 [Exactly 0]- , checkLiquid "tests/Liquid/FoldrTests.hs" "max3" 1000 2 [Exactly 0]- , checkLiquid "tests/Liquid/SimpleAnnot.hs" "simpleF" 1000 1 [Exactly 0]- , checkLiquid "tests/Liquid/Ordering.hs" "lt" 1000 2 [AtLeast 1]- , checkLiquid "tests/Liquid/Ordering.hs" "gt" 1000 2 [AtLeast 1]- , checkLiquid "tests/Liquid/WhereFuncs2.hs" "hCalls" 1000 3 [AtLeast 1]- , checkLiquid "tests/Liquid/WhereFuncs2.hs" "i" 1000 2 [AtLeast 1]- , checkAbsLiquid "tests/Liquid/AddToEvenWhere.hs" "f" 2000 1- [ AtLeast 1- , RForAll (\[i] r [(FuncCall { funcName = Name n _ _ _, returns = r' }) ]- -> n == "g" && isInt i (\i' -> i' `mod` 2 == 0) && r == r' )]- , checkLiquid "tests/Liquid/ListTests.lhs" "concat" 1000 2 [AtLeast 3]- , checkLiquidWithConfig "tests/Liquid/MapReduceTest.lhs" "mapReduce" 2 (mkConfigTestWithMap {steps = 1500})[Exactly 0]- , checkLiquid "tests/Liquid/NearestTest.lhs" "nearest" 1500 1 [Exactly 1]-- , checkExpr "tests/TestFiles/TypeClass/TypeClass5.hs" 800 Nothing Nothing "run" 2 [AtLeast 1]- , checkExpr "tests/TestFiles/TypeClass/TypeClass5.hs" 800 Nothing Nothing "run2" 2 [AtLeast 0]- , checkInputOutput "tests/Prim/Prim2.hs" "Prim2" "sqrtList" 10000 1 [AtLeast 1]- - , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "average" 2000 5 [AtLeast 6]- , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "averageF" 2000 2 [AtLeast 6]- , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "maybeAvg" 200 4 [AtLeast 6]+todoTests :: TestTree+todoTests = testGroup "To Do"+ [+ checkExpr "tests/TestFiles/TypeClass/TypeClass5.hs" 800 "run" [AtLeast 1]+ , checkExpr "tests/TestFiles/TypeClass/TypeClass5.hs" 800 "run2" [AtLeast 0]+ , checkInputOutput "tests/Prim/Prim2.hs" "sqrtList" 10000 [AtLeast 1]+ + , checkInputOutputs "tests/BaseTests/MaybeTest.hs" [ ("average", 2000, [AtLeast 6])+ , ("averageF", 2000, [AtLeast 6])+ , ("maybeAvg", 200, [AtLeast 6])+ ] - , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "float2IntTest" 1000 2 [AtLeast 1]- , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "double2IntTest" 1000 2 [AtLeast 1]- ]+ , checkInputOutputs "tests/Prim/Prim3.hs" [ ("float2IntTest", 1000, [AtLeast 1])+ , ("double2IntTest", 1000, [AtLeast 1])]+ ] data ToDo = RunMain | RunToDo@@ -494,29 +487,106 @@ -- Generic helpers for tests ---------------------------- -checkExpr :: String -> Int -> Maybe String -> Maybe String -> String -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree-checkExpr src stps m_assume m_assert entry i reqList =- checkExprReaches src stps m_assume m_assert Nothing entry i reqList+checkExpr :: String -> Int -> String -> [Reqs ([Expr] -> Bool)] -> TestTree+checkExpr src stps entry reqList =+ checkExprReaches src stps Nothing Nothing Nothing entry reqList -checkExprReaches :: String -> Int -> Maybe String -> Maybe String -> Maybe String -> String -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree-checkExprReaches src stps m_assume m_assert m_reaches entry i reqList = do- checkExprWithConfig src m_assume m_assert m_reaches entry i (mkConfigTest {steps = stps}) reqList+checkExprAssume :: String -> Int -> Maybe String -> String -> [Reqs ([Expr] -> Bool)] -> TestTree+checkExprAssume src stps m_assume entry reqList =+ checkExprReaches src stps m_assume Nothing Nothing entry reqList -checkExprWithConfig :: String -> Maybe String -> Maybe String -> Maybe String -> String -> Int -> Config -> [Reqs ([Expr] -> Bool)] -> IO TestTree-checkExprWithConfig src m_assume m_assert m_reaches entry i config reqList = do- res <- testFile src m_assume m_assert m_reaches entry config- - let ch = case res of- Left _ -> False- Right exprs -> checkExprGen (map (\(inp, out) -> inp ++ [out]) exprs) i reqList+checkExprAssert :: String -> Int -> Maybe String -> String -> [Reqs ([Expr] -> Bool)] -> TestTree+checkExprAssert src stps m_assert entry reqList =+ checkExprReaches src stps Nothing m_assert Nothing entry reqList - return . testCase src- $ assertBool ("Assume/Assert for file " ++ src ++ - " with functions [" ++ (fromMaybe "" m_assume) ++ "] " ++- "[" ++ (fromMaybe "" m_assert) ++ "] " ++- entry ++ " failed.\n") ch+checkExprAssumeAssert :: String+ -> Int+ -> Maybe String+ -> Maybe String+ -> String+ -> [Reqs ([Expr] -> Bool)]+ -> TestTree+checkExprAssumeAssert src stps m_assume m_assert entry reqList =+ checkExprReaches src stps m_assume m_assert Nothing entry reqList++checkExprReaches :: String+ -> Int+ -> Maybe String+ -> Maybe String+ -> Maybe String+ -> String+ -> [Reqs ([Expr] -> Bool)]+ -> TestTree+checkExprReaches src stps m_assume m_assert m_reaches entry reqList = do+ checkExprWithConfig src m_assume m_assert m_reaches entry reqList+ (do+ config <- mkConfigTestIO+ return $ config {steps = stps})++checkExprWithMap :: String+ -> Int+ -> Maybe String+ -> Maybe String+ -> Maybe String+ -> String+ -> [Reqs ([Expr] -> Bool)]+ -> TestTree+checkExprWithMap src stps m_assume m_assert m_reaches entry reqList = do+ checkExprWithConfig src m_assume m_assert m_reaches entry reqList+ (do+ config <- mkConfigTestWithMapIO+ return $ config {steps = stps})++checkExprWithSet :: String+ -> Int+ -> Maybe String+ -> Maybe String+ -> Maybe String+ -> String+ -> [Reqs ([Expr] -> Bool)]+ -> TestTree+checkExprWithSet src stps m_assume m_assert m_reaches entry reqList = do+ checkExprWithConfig src m_assume m_assert m_reaches entry reqList+ (do+ config <- mkConfigTestWithSetIO+ return $ config {steps = stps})++checkExprWithConfig :: String+ -> Maybe String+ -> Maybe String+ -> Maybe String+ -> String+ -> [Reqs ([Expr] -> Bool)]+ -> IO Config+ -> TestTree+checkExprWithConfig src m_assume m_assert m_reaches entry reqList config_f = do+ testCase src (do+ config <- config_f+ res <- testFile src m_assume m_assert m_reaches entry config+ + let ch = case res of+ Left _ -> False+ Right exprs -> null $ checkExprGen (map (\(inp, out) -> inp ++ [out]) exprs) reqList+ assertBool ("Assume/Assert for file " ++ src+ ++ " with functions [" ++ (fromMaybe "" m_assume) ++ "] "+ ++ "[" ++ (fromMaybe "" m_assert) ++ "] "+ ++ entry ++ " failed.\n" ++ show res)+ ch+ )++ -- return . testCase src+ -- $ assertBool ("Assume/Assert for file " ++ src ++ + -- " with functions [" ++ (fromMaybe "" m_assume) ++ "] " +++ -- "[" ++ (fromMaybe "" m_assert) ++ "] " +++ -- entry ++ " failed.\n") ch -testFile :: String -> Maybe String -> Maybe String -> Maybe String -> String -> Config -> IO (Either SomeException [([Expr], Expr)])+testFile :: String+ -> Maybe String+ -> Maybe String+ -> Maybe String+ -> String+ -> Config+ -> IO (Either SomeException [([Expr], Expr)]) testFile src m_assume m_assert m_reaches entry config = try (testFileWithConfig src m_assume m_assert m_reaches entry config) @@ -529,73 +599,35 @@ -> IO [([Expr], Expr)] testFileWithConfig src m_assume m_assert m_reaches entry config = do let proj = takeDirectory src- r <- doTimeout (timeLimit config) $ runG2FromFile [proj] [src] [] (fmap T.pack m_assume) (fmap T.pack m_assert) (fmap T.pack m_reaches) (isJust m_assert || isJust m_reaches) (T.pack entry) config+ r <- doTimeout (timeLimit config)+ $ runG2FromFile + [proj]+ [src]+ (fmap T.pack m_assume)+ (fmap T.pack m_assert)+ (fmap T.pack m_reaches)+ (isJust m_assert || isJust m_reaches)+ (T.pack entry)+ simplTranslationConfig+ config let (states, _) = maybe (error "Timeout") fst r return $ map (\(ExecRes { conc_args = i, conc_out = o}) -> (i, o)) states -checkLiquidWithNoCutOff :: FilePath -> String -> Int -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree-checkLiquidWithNoCutOff fp entry stps i reqList =- checkLiquidWithConfig fp entry i (mkConfigTest {steps = stps, cut_off = stps}) reqList--checkLiquid :: FilePath -> String -> Int -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree-checkLiquid fp entry stps i reqList = checkLiquidWithConfig fp entry i (mkConfigTest {steps = stps}) reqList--checkLiquidWithCutOff :: FilePath -> String -> Int -> Int -> Int -> [Reqs ([Expr] -> Bool)] -> IO TestTree-checkLiquidWithCutOff fp entry stps co i reqList = checkLiquidWithConfig fp entry i (mkConfigTest {steps = stps, cut_off = co}) reqList--checkLiquidWithConfig :: FilePath -> String -> Int -> Config -> [Reqs ([Expr] -> Bool)] -> IO TestTree-checkLiquidWithConfig fp entry i config reqList = do- res <- findCounterExamples' fp (T.pack entry) [] [] config-- let (ch, r) = case res of- Nothing -> (False, Right ())- Just (Left e) -> (False, Left e)- Just (Right exprs) -> (checkExprGen- (map (\(ExecRes { conc_args = inp, conc_out = out})- -> inp ++ [out]) exprs- ) i reqList, Right ())-- return . testCase fp- $ assertBool ("Liquid test for file " ++ fp ++ - " with function " ++ entry ++ " failed.\n" ++ show r) ch--checkAbsLiquid :: FilePath -> String -> Int -> Int -> [Reqs ([Expr] -> Expr -> [FuncCall] -> Bool)] -> IO TestTree-checkAbsLiquid fp entry stps i reqList = checkAbsLiquidWithConfig fp entry i (mkConfigTest {steps = stps}) reqList--checkAbsLiquidWithConfig :: FilePath -> String -> Int -> Config -> [Reqs ([Expr] -> Expr -> [FuncCall] -> Bool)] -> IO TestTree-checkAbsLiquidWithConfig fp entry i config reqList = do- res <- findCounterExamples' fp (T.pack entry) [] [] config-- let (ch, r) = case res of- Nothing -> (False, Right [])- Just (Left e) -> (False, Left e)- Just (Right exprs) ->- let- te = checkAbsLHExprGen- (map (\(ExecRes { final_state = s, conc_args = inp, conc_out = out})- -> (s, inp, out)- ) exprs- ) i reqList- in- (null te, Right te)-- return . testCase fp- $ assertBool ("Liquid test for file " ++ fp ++ - " with function " ++ entry ++ " failed.\n" ++ show r) ch-+-- For mergeState unit tests+checkFn :: Either String Bool -> String -> IO TestTree+checkFn f testName = do+ let res = f+ case res of+ Left e -> return . testCase testName $ assertFailure e+ Right _ -> return . testCase testName $ return () -findCounterExamples' :: FilePath- -> T.Text- -> [FilePath]- -> [FilePath]- -> Config- -> IO (Maybe (Either SomeException [ExecRes [FuncCall]]))-findCounterExamples' fp entry libs lhlibs config =- let- proj = takeDirectory fp- in- doTimeout (timeLimit config) $ try (return . fst. fst =<< findCounterExamples [proj] [fp] entry libs lhlibs config)+checkFnIO :: IO (Either String Bool) -> String -> IO TestTree+checkFnIO f testName = do+ res <- f+ case res of+ Left e -> return . testCase testName $ assertFailure e+ Right _ -> return . testCase testName $ return () errors :: [Expr] -> Bool errors e =
tests/TestUtils.hs view
@@ -6,23 +6,31 @@ import Data.Monoid import qualified Data.Text as T +import System.Directory+ import G2.Config import G2.Language -mkConfigTest :: Config-mkConfigTest = (mkConfig "/whatever/" [] M.empty)- { higherOrderSolver = AllFuncs- , timeLimit = 50- , baseInclude = [ "./base-4.9.1.0/Control/Exception/"- , "./base-4.9.1.0/" ]- , base = [ "./base-4.9.1.0/Control/Exception/Base.hs"- , "./base-4.9.1.0/Prelude.hs" ]- , extraDefaultMods = [] }+mkConfigTestIO :: IO Config+mkConfigTestIO = do+ homedir <- getHomeDirectory+ return $+ (mkConfigDirect homedir [] M.empty)+ { higherOrderSolver = AllFuncs+ , timeLimit = 150+ -- , baseInclude = [ "./base-4.9.1.0/Control/Exception/"+ -- , "./base-4.9.1.0/" ]+ , base = baseSimple homedir+ , extraDefaultMods = [] } -mkConfigTestWithMap :: Config-mkConfigTestWithMap =- mkConfigTest { baseInclude = baseInclude mkConfigTest ++ ["./base-4.9.1.0/Data/Internal/"]- , base = base mkConfigTest ++ ["./base-4.9.1.0/Data/Internal/Map.hs"] }+mkConfigTestWithSetIO :: IO Config+mkConfigTestWithSetIO = mkConfigTestWithMapIO++mkConfigTestWithMapIO :: IO Config+mkConfigTestWithMapIO = do+ config <- mkConfigTestIO+ homedir <- getHomeDirectory+ return $ config { base = base config } eqIgT :: Expr -> Expr -> Bool
tests/Typing.hs view
@@ -6,14 +6,13 @@ import G2.Language +import Data.Maybe (isNothing)+ import Test.Tasty import Test.Tasty.HUnit -typingTests :: IO TestTree-typingTests = return typingTests'--typingTests' :: TestTree-typingTests' =+typingTests :: TestTree+typingTests = testGroup "Typing" [ testCase "Function application" $ assertBool "Function application failed" test1@@ -30,6 +29,7 @@ , testCase "Specializes false test 1" $ assertBool ".:: failed" specFalseTest1 , testCase "Specializes false test 2" $ assertBool ".:: failed" specFalseTest2+ , testCase "Specializes false test 3" $ assertBool ".:: failed" specFalseTest3 ] test1 :: Bool@@ -69,7 +69,7 @@ funcAppTest = typeOf (App (App idDef (Type int)) x1) == int funcTest :: Bool-funcTest = idDef .:: (TyForAll (NamedTyBndr aid) (TyFun a a))+funcTest = idDef .:: (TyForAll aid (TyFun a a)) tyAppKindTest :: Bool tyAppKindTest = typeOf (TyApp either a) == TyFun TYPE TYPE@@ -89,6 +89,16 @@ specFalseTest2 :: Bool specFalseTest2 = not $ f3 .:: typeOf f2 +specFalseTest3 :: Bool+specFalseTest3 =+ let+ c = Id (Name "c" Nothing 0 Nothing) TYPE++ t1 = TyFun (TyVar aid) (TyVar bid)+ t2 = TyFun (TyVar c) (TyVar c)+ in+ isNothing $ t1 `specializes` t2 + -- Typed Expr's x1 :: Expr x1 = Var $ Id (Name "x1" Nothing 0 Nothing) int@@ -99,16 +109,16 @@ f2 :: Expr f2 = Var $ Id (Name "f2" Nothing 0 Nothing) (TyForAll- (NamedTyBndr bid)+ bid (TyFun b b) ) f3 :: Expr f3 = Var $ Id (Name "f3" Nothing 0 Nothing) (TyForAll- (NamedTyBndr bid)+ bid (TyForAll- (NamedTyBndr aid)+ aid (TyFun b a) ) )@@ -117,7 +127,7 @@ just = Data $ DataCon (Name "Just" Nothing 0 Nothing) (TyForAll - (NamedTyBndr aid) + aid (TyFun a (TyApp maybe a)) )
+ tests/UFMapTests.hs view
@@ -0,0 +1,245 @@+module UFMapTests where++import G2.Data.UFMap++import Data.Hashable+import qualified Data.List as L+import Data.Maybe as M++import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as S++import Prelude hiding (lookup, map, null)+import qualified Prelude as P++ufMapQuickcheck :: TestTree+ufMapQuickcheck =+ testGroup "UFMap" [+ testProperty "from hashset to hashset" prop_from_hs_to_hs+ , testProperty "insert forces in list" prop_insert_forces_in_list+ , testProperty "after joining two keys, they will return the same result from lookup" join_makes_lookup_match+ , testProperty "lookup j after joining nonpresent j with some k in the map" prop_lookup_after_joining+ , testProperty "if two keys are joined in the first map, they are joined after merging that map" prop_merge_preserves_joins1+ , testProperty "if two keys are joined in the second map, they are joined after merging that map" prop_merge_preserves_joins2+ , testProperty "if a key is present in two maps being merged, in will be present in the merge" prop_merge_preserves_values+ , testProperty "if a key is present in two maps being merged, in will be present in the merge (less thorough, but simpler)" prop_merge_preserves_values_simple+ , testProperty "merge function is applied to all values from original map" prop_merge_merges_values+ , testProperty "toList . fromList preserves joins" prop_toList_fromList_joins+ , testProperty "toList . fromList preserves stored values" prop_toList_fromList_values+ , testProperty "the toList function returns a list with at least as many elements as in the simple map" prop_toList_leq_simple_map++ , testProperty "the unionWith function correctly preserves elements in the first UFMaps" prop_unionWith_preserves_values1+ , testProperty "the unionWith function correctly preserves elements in the second UFMaps" prop_unionWith_preserves_values2+ ]++prop_from_hs_to_hs :: [([Integer], Maybe Integer)] -> Property+prop_from_hs_to_hs xs =+ let+ xs_tails = L.init $ L.tails xs+ xs' = [ (ks', v) | ((ks, v):xs_tls') <- xs_tails+ , let later_ks = concat (P.map fst xs_tls')+ , let ks' = P.filter (\k -> k `notElem` later_ks) ks ]+ hs = toHS xs'+ in+ all (not . P.null . fst) xs'+ ==>+ property (hs == toSet (fromSet hs))++toHS :: (Hashable k, Eq k, Hashable v, Eq v) => [([k], Maybe v)] -> S.HashSet (S.HashSet k, Maybe v)+toHS = S.fromList . mapMaybe (\(ks, v) -> if isJust v+ then Just (S.fromList ks, v)+ else Nothing )++prop_insert_forces_in_list :: Integer -> Integer -> UFMap Integer Integer -> Property+prop_insert_forces_in_list k v ufm =+ let+ ufm' = insert k v ufm+ lst = toList ufm'+ in+ property (any (\(ks, v') -> k `elem` ks+ && case v' of+ Just v'' -> v == v''+ Nothing -> False) lst)++join_makes_lookup_match :: Fun (Integer, Integer) Integer -> Integer -> Integer -> UFMap Integer Integer -> Property+join_makes_lookup_match (Fn2 f) x y ufm =+ let+ ufm' = join f x y ufm+ in+ property (lookup x ufm' == lookup y ufm')++prop_lookup_after_joining :: Integer -> UFMap Integer Integer -> Property+prop_lookup_after_joining j ufm =+ let+ ks = keys ufm+ k = head ks+ in+ not (L.null ks) && j `notElem` ks+ ==>+ property $ lookup j (join undefined j k ufm) == lookup k ufm++prop_merge_preserves_joins1 :: Integer+ -> Integer+ -> Fun (Integer, Integer) Integer+ -> Fun (Integer, Integer, Integer) (Integer, [(Integer, Integer)])+ -> Fun (Integer, Integer) (Integer, [(Integer, Integer)])+ -> Fun (Integer, Integer) (Integer, [(Integer, Integer)])+ -> Fun (Integer, Integer) Integer+ -> Fun (Integer, Integer) Integer+ -> Fun (Integer, Integer) Integer+ -> UFMap Integer Integer+ -> UFMap Integer Integer+ -> Property+prop_merge_preserves_joins1 x y (Fn2 jf) (Fn3 fb) (Fn2 f1) (Fn2 f2) (Fn2 fj1) (Fn2 fj2) (Fn2 j) ufm1 ufm2 =+ let+ ufm1' = join jf x y ufm1+ + m_ufm = mergeJoiningWithKey fb f1 f2 fj1 fj2 j ufm1' ufm2+ in+ property (lookup x m_ufm == lookup y m_ufm)++prop_merge_preserves_joins2 :: Integer+ -> Integer+ -> Fun (Integer, Integer) Integer+ -> Fun (Integer, Integer, Integer) (Integer, [(Integer, Integer)])+ -> Fun (Integer, Integer) (Integer, [(Integer, Integer)])+ -> Fun (Integer, Integer) (Integer, [(Integer, Integer)])+ -> Fun (Integer, Integer) Integer+ -> Fun (Integer, Integer) Integer+ -> Fun (Integer, Integer) Integer+ -> UFMap Integer Integer+ -> UFMap Integer Integer+ -> Property+prop_merge_preserves_joins2 x y (Fn2 jf) (Fn3 fb) (Fn2 f1) (Fn2 f2) (Fn2 fj1) (Fn2 fj2) (Fn2 j) ufm1 ufm2 =+ let+ ufm2' = join jf x y ufm2+ + m_ufm = mergeJoiningWithKey fb f1 f2 fj1 fj2 j ufm1 ufm2'+ in+ property (lookup x m_ufm == lookup y m_ufm)++prop_merge_preserves_values :: Integer+ -> Fun (Integer, Integer, Integer) (Integer, [(Integer, Integer)])+ -> Fun (Integer, Integer) (Integer, [(Integer, Integer)])+ -> Fun (Integer, Integer) (Integer, [(Integer, Integer)])+ -> Fun (Integer, Integer) Integer+ -> Fun (Integer, Integer) Integer+ -> Fun (Integer, Integer) Integer+ -> UFMap Integer Integer+ -> UFMap Integer Integer+ -> Property+prop_merge_preserves_values x (Fn3 fb) (Fn2 f1) (Fn2 f2) (Fn2 fj1) (Fn2 fj2) (Fn2 j) ufm1 ufm2 =+ let+ m_ufm = mergeJoiningWithKey fb f1 f2 fj1 fj2 j ufm1 ufm2+ in+ isJust (lookup x ufm1) || isJust (lookup x ufm2)+ ==>+ property (isJust (lookup x m_ufm))++prop_merge_preserves_values_simple :: Integer+ -> Fun (Integer, Integer) (Integer, [(Integer, Integer)])+ -> UFMap Integer Integer+ -> UFMap Integer Integer+ -> Property+prop_merge_preserves_values_simple x (Fn2 f2) ufm1 ufm2 =+ let+ m_ufm = mergeJoiningWithKey (\_ x y -> (x + y, [])) (\_ x -> (x, [])) f2 (+) (+) (+) ufm1 ufm2+ in+ isJust (lookup x ufm1) || isJust (lookup x ufm2)+ ==>+ property (isJust (lookup x m_ufm))++prop_merge_merges_values :: Integer+ -> UFMap Integer (S.HashSet Integer)+ -> UFMap Integer (S.HashSet Integer)+ -> Property+prop_merge_merges_values x ufm1 ufm2 = + let+ m_ufm = mergeJoiningWithKey (\_ x y -> (S.union x y, []))+ (\_ x -> (x, []))+ (\_ x -> (x, []))+ S.union+ S.union+ S.union+ ufm1 ufm2+ s1 = case lookup x ufm1 of+ Just s -> s+ Nothing -> S.empty + s2 = case lookup x ufm2 of+ Just s -> s+ Nothing -> S.empty+ in+ not (S.null s1) || not (S.null s2)+ ==>+ property (s1 `isSubsetOf` (m_ufm ! x) && s2 `isSubsetOf` (m_ufm ! x))++isSubsetOf :: (Eq a, Hashable a) => S.HashSet a -> S.HashSet a -> Bool+isSubsetOf xs ys = all (\x -> x `S.member` ys) $ S.toList xs++prop_toList_fromList_joins :: Integer+ -> Integer+ -> UFMap Integer (S.HashSet Integer)+ -> Property+prop_toList_fromList_joins i1 i2 ufm =+ let+ ufm' = fromList . toList $ join S.union i1 i2 ufm+ in+ property $ find i1 ufm' == find i2 ufm'++prop_toList_fromList_values :: Integer+ -> S.HashSet Integer+ -> UFMap Integer (S.HashSet Integer)+ -> Property+prop_toList_fromList_values i hs ufm =+ let+ ufm' = fromList . toList $ insert i hs ufm+ in+ property $ lookup i ufm' == Just hs++prop_toList_leq_simple_map :: [(Integer, S.HashSet Integer)] -> UFMap Integer (S.HashSet Integer) -> Property+prop_toList_leq_simple_map els ufm =+ let+ ufm' = foldr (uncurry insert) ufm els+ in+ property $ length (toList ufm') >= HM.size (toSimpleMap ufm')++prop_unionWith_preserves_values1 :: Integer+ -> UFMap Integer (S.HashSet Integer)+ -> UFMap Integer (S.HashSet Integer)+ -> Property+prop_unionWith_preserves_values1 x ufm1 ufm2 =+ let+ union = unionWith S.union ufm1 ufm2++ s1 = case lookup x ufm1 of+ Just s -> s+ Nothing -> S.empty + s2 = case lookup x union of+ Just s -> s+ Nothing -> S.empty+ in+ not (S.null s1) || not (S.null s2) ==> property $ s1 `isSubsetOf` s2++prop_unionWith_preserves_values2 :: Integer+ -> UFMap Integer (S.HashSet Integer)+ -> UFMap Integer (S.HashSet Integer)+ -> Property+prop_unionWith_preserves_values2 x ufm1 ufm2 =+ let+ union = unionWith S.union ufm1 ufm2++ s1 = case lookup x ufm2 of+ Just s -> s+ Nothing -> S.empty + s2 = case lookup x union of+ Just s -> s+ Nothing -> S.empty+ in+ not (S.null s1) || not (S.null s2) ==> property $ s1 `isSubsetOf` s2++instance (Hashable a, Eq a, Arbitrary a) => Arbitrary (S.HashSet a) where+ arbitrary = return . S.fromList =<< arbitrary+ shrink = P.map S.fromList . shrink . S.toList
+ tests/UnionFindTests.hs view
@@ -0,0 +1,41 @@+module UnionFindTests where++import G2.Data.UnionFind++import Test.Tasty+import Test.Tasty.QuickCheck++import Prelude hiding (lookup, map, null)++unionFindQuickcheck :: TestTree+unionFindQuickcheck =+ testGroup "UnionFind" [+ testProperty "applyinf unionOfUfs preserves unions in the first UnionFind" prop_unionOfUFs_preserves_unions1+ , testProperty "applyinf unionOfUfs preserves unions in the second UnionFind" prop_unionOfUFs_preserves_unions2+ , testProperty "applyinf unionOfUfs creates new unions" prop_unionOfUFs_preserves_unions3+ ]++prop_unionOfUFs_preserves_unions1 :: Integer -> Integer -> UnionFind Integer -> UnionFind Integer -> Property+prop_unionOfUFs_preserves_unions1 x y uf1 uf2 =+ let+ uf1' = union x y uf1+ m_uf = unionOfUFs uf1' uf2+ in+ property (find x m_uf == find y m_uf)++prop_unionOfUFs_preserves_unions2 :: Integer -> Integer -> UnionFind Integer -> UnionFind Integer -> Property+prop_unionOfUFs_preserves_unions2 x y uf1 uf2 =+ let+ uf2' = union x y uf2+ m_uf = unionOfUFs uf1 uf2'+ in+ property (find x m_uf == find y m_uf)++prop_unionOfUFs_preserves_unions3 :: Integer -> Integer -> Integer -> UnionFind Integer -> UnionFind Integer -> Property+prop_unionOfUFs_preserves_unions3 x y z uf1 uf2 =+ let+ uf1' = union x y uf1+ uf2' = union y z uf2+ m_uf = unionOfUFs uf1' uf2'+ in+ property (find x m_uf == find z m_uf)
+ tests_lh/LHTest.hs view
@@ -0,0 +1,590 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Test.Tasty+import Test.Tasty.HUnit++import GetNthTest+import PeanoTest+import LHReqs+import TestUtils+import UnionPoly++import G2.Config as G2+import G2.Interface+import G2.Language+import G2.Liquid.Config+import G2.Liquid.Helpers+import G2.Liquid.Interface+import G2.Liquid.Inference.Interface+import G2.Liquid.Inference.Config+import G2.Liquid.Inference.G2Calls+import G2.Translation++import Control.Exception+import Data.Time.Clock+import Data.Either+import qualified Data.Map.Lazy as M+import qualified Data.Text as T+import System.FilePath++import G2.Liquid.Types+import qualified System.IO as T+++import Language.Haskell.Liquid.UX.CmdLine hiding (config)++-- Run with no arguments for default test cases.+-- All default test cases should pass.+-- Run with flag '--test-options="todo yes"' to run test cases corresponding to to-be-fixed bugs.+main :: IO ()+main = do+ defaultMainWithIngredients+ defaultIngredients+ tests++tests :: TestTree+tests = testGroup "All Tests"+ [ liquidTests+ , posInfTests+ , negInfTests+ , cexInfTests+ + , unionPolyTests ]++liquidTests :: TestTree+liquidTests = testGroup "Liquid" + [+ checkLiquids "tests_lh/Liquid/SimpleMath.hs"+ [ ("abs2", 2000, [RForAll (\[x, y] -> isDouble x ((==) 0) && isDouble y ((==) 0)), Exactly 1])+ , ("add", 800, [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > z' || y' > z'), AtLeast 1])+ , ("subToPos", 1000, [ RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > 0 && x' >= y' && z' <= 0), AtLeast 1])]+ , checkLiquidWithNoCutOff "tests_lh/Liquid/SimpleMath.hs" + [ ("fib", 4000, [RForAll (\[x, y] -> isInt x $ \x' -> isInt y $ \y' -> x' > y'), AtLeast 3])+ , ("fib'", 6000, [RForAll (\[x, y] -> isInt x $ \x' -> isInt y $ \y' -> x' > y'), AtLeast 3])+ , ("xSqPlusYSq", 1000 , [RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' + y' >= z'), AtLeast 1])+ ]++ , checkLiquids "tests_lh/Liquid/SimplePoly.hs"+ [ ("snd2Int", 800, [ RForAll (\[x, y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' /= y' && y' == z'), Exactly 1])+ , ("sumPair", 800, [ AtLeast 1, RForAll (\[App (App _ x) y, z] -> isInt x $ \x' -> isInt y $ \y' -> isInt z $ \z' -> x' > z' || y' > z')])+ , ("switchInt", 600, [ Exactly 1, RForAll (\[App (App _ x) _, App (App _ _) y] -> getIntB x $ \ x' -> getIntB y $ \ y' -> x' == y')]) ]++ , checkLiquids "tests_lh/Liquid/Peano.hs"+ [ ("add", 1400, [RForAll (\[x, y, _] -> x `eqIgT` zeroPeano || y `eqIgT` zeroPeano), AtLeast 5])+ , ("fromInt", 600, [RForAll (\[x, y] -> isInt x (\x' -> x' == 0) && y `eqIgT` zeroPeano), AtLeast 1])+ ]++ , checkLiquidWithNoCutOff "tests_lh/Liquid/GetNth.hs"+ [ ("getNthInt", 2700, [AtLeast 3, RForAll getNthErrors])+ , ("getNth", 2700, [AtLeast 3]) ]+ , checkLiquidWithCutOff "tests_lh/Liquid/GetNth.hs" "sumC" 2000000 1000+ [AtLeast 3, RForAll (\[_, y] -> isInt y $ (==) 0)]+ , checkLiquidWithCutOff "tests_lh/Liquid/GetNth.hs" "sumCList" 2000000 1000 [AtLeast 3]++ , checkLiquids "tests_lh/Liquid/DataRefTest.hs"+ [ ("addMaybe", 1000, [AtLeast 1, RForAll (\[_, y, z] -> isInt y $ \y' -> appNthArgIs z (\z' -> isInt z' $ \z'' -> z'' <= y') 2)])+ , ("addMaybe2", 2000, [ AtLeast 1, RForAll (\[x, _, _] -> appNthArgIs x (\x' -> isInt x' $ \x'' -> x'' >= 0) 2)+ , RForAll (\[_, y, z] -> isInt y $ \y' -> appNthArgIs z (\z' -> isInt z' $ \z'' -> z'' <= y') 2)])+ , ("getLeftInts", 2000, [AtLeast 1, RForAll (\[x, _] -> dcInAppHasName "Right" x 3)])+ , ("sumSameInts", 2000, [AtLeast 1, RForAll (\[x, y, _] -> dcInAppHasName "Right" x 3 && dcInAppHasName "Left" y 3)])+ , ("sub1", 1200, [AtLeast 1]) ]++ , checkLiquid "tests_lh/Liquid/NumOrd.hs" "subTuple" 1200 [AtLeast 1]++ , checkLiquids "tests_lh/Liquid/CommentMeasures.hs"+ [ ("d", 1000, [AtLeast 1])+ , ("unpackCP'", 100000, [Exactly 0])+ , ("unpackBool", 1000, [AtLeast 1, RForAll (\[_, r] -> getBoolB r (== False))])+ , ("sumSameOneOfs", 100000, [Exactly 0])+ , ("gets2As", 2000, [AtLeast 1, RExists (\[x, y, _] -> buriedDCName "B" x && buriedDCName "B" y)])+ , ("gets2As'", 1000, [AtLeast 1, RExists (\[x, y, _] -> buriedDCName "A" x && buriedDCName "B" y)+ , RExists (\[x, y, _] -> buriedDCName "B" x && buriedDCName "A" y)])+ , ("ge4gt5", 1000, [AtLeast 1, RForAll (\[x, y] -> appNth x 1 $ \x' -> isInt x' $ \x'' -> isInt y $ \y' -> x'' == 4 && y' == 5)])+ ]++ , checkLiquids "tests_lh/Liquid/ConcatList.hs"+ [ ("concat2", 800, [AtLeast 2])+ , ("concat3", 800, [AtLeast 2])+ , ("concat5", 1600, [AtLeast 1])]++ , checkLiquid "tests_lh/Liquid/Tests/Group3.lhs" "f" 2200 [AtLeast 1]++ , checkLiquid "tests_lh/Liquid/Nonused.hs" "g" 2000 [AtLeast 1]++ -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f1" 2000 [Exactly 0]+ -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f2" 2000 [AtLeast 4, RForAll (\[_, x, y] -> x == y)]+ -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f3" 2000 [Exactly 0]+ -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f4" 2000+ -- [AtLeast 4, RForAll (\[_, x, _] -> isInt x $ \x' -> x' == 0)]+ -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f5" 2000 [Exactly 0]+ -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f6" 2000 [AtLeast 10]+ -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f7" 2000 + -- [AtLeast 10, RForAll (\[x, _, y] -> isInt x $ \x' -> isInt y $ \y' -> x' == y')]+ -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "f8" 2000 [AtLeast 10]+ -- , checkLiquid "tests_lh/Liquid/HigherOrderRef.hs" "callf" 2000 [AtLeast 1]++ -- , checkLiquid "tests_lh/Liquid/Error/Error1.hs" "f" 600 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/Error/Error2.hs" "f1" 2000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/ZipWith.lhs" "distance" 1000 [AtLeast 3]++ , checkLiquids "tests_lh/Liquid/HigherOrder2.hs"+ [ ("f", 2000, [Exactly 0])+ , ("h", 2000, [AtLeast 1])]+ , checkLiquid "tests_lh/Liquid/HigherOrder3.hs" "m" 600 [AtLeast 1]++ , checkLiquid "tests_lh/Liquid/Ordering.hs" "oneOrOther" 1000 [Exactly 0]++ , checkLiquid "tests_lh/Liquid/AddKV.lhs" "empty" 1000 [Exactly 0]++ , checkLiquid "tests_lh/Liquid/PropSize.hs" "prop_size" 2000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/PropSize2.hs" "prop_size" 2000 [AtLeast 1]++ , checkLiquids "tests_lh/Liquid/WhereFuncs.lhs" [ ("f", 1000, [Exactly 0])+ , ("g", 1000, [Exactly 0])]++ , checkLiquid "tests_lh/Liquid/PropConcat.lhs" "prop_concat" 1000 [AtLeast 1]++ , checkLiquid "tests_lh/Liquid/Distance.lhs" "distance" 1000 [AtLeast 1]++ -- The below test generates a LiquidHaskell error with newer LiquidHaskell versions+ -- , checkLiquid "tests_lh/Liquid/MultModules/CallZ.lhs" "callZ" 1000 [AtLeast 1]++ , checkAbsLiquid "tests_lh/Liquid/AddToEven.hs" "f" 2500+ [ AtLeast 1+ , RForAll $ \[i] r [(FuncCall { funcName = Name n _ _ _, returns = fcr }) ]+ -> n == "g"+ && isInt i (\i' -> i' `mod` 2 == 0 &&+ isInt r (\r' -> isInt fcr (\fcr' -> r' == i' + fcr')))]+ , checkAbsLiquid "tests_lh/Liquid/AddToEven4.hs" "f" 2000 [ AtLeast 1]++ , checkAbsLiquid "tests_lh/Liquid/Concat.hs" "prop_concat" 1000 [ AtLeast 1]++ , checkLiquids "tests_lh/Liquid/ListTests.lhs"+ [ ("r", 1000, [Exactly 0])+ , ("prop_map", 1500, [AtLeast 3])+ , ("prop_concat_1", 1500, [AtLeast 1])+ ]+ , checkAbsLiquid "tests_lh/Liquid/ListTests2.lhs" "prop_map" 2000+ [ AtLeast 2+ , RForAll (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "map") ]+ , checkAbsLiquid "tests_lh/Liquid/ListTests2.lhs" "prop_size" 2000+ [ AtLeast 1+ , RForAll (\[] _ [(FuncCall { funcName = Name n _ _ _, returns = r }) ]+ -> n == "length2" && getIntB r (/= 3)) ]++ , checkLiquid "tests_lh/Liquid/MapReduceTest2.lhs" "mapReduce" 1500 [AtLeast 1]++ -- The below test generates a LiquidHaskell error with LiquidHaskell 8.2.2 version+ -- , checkLiquid "tests_lh/Liquid/MeasErr.hs" "f" 1500 [Exactly 0]++ , checkAbsLiquid "tests_lh/Liquid/PropRep.hs" "prop_rep" 2000+ [ AtLeast 1 ]++ , checkAbsLiquid "tests_lh/Liquid/Replicate.hs" "replicate" 2000+ [ AtLeast 1+ , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "foldl") ]+ , checkAbsLiquid "tests_lh/Liquid/Replicate.hs" "r" 2000+ [ AtLeast 1+ , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "foldl") ]++ , checkAbsLiquid "tests_lh/Liquid/AbsTypeClass.hs" "callF" 1000+ [ AtLeast 1+ , RExists (\_ _ [(FuncCall { funcName = Name n _ _ _ }) ] -> n == "f") ]+ , checkAbsLiquid "tests_lh/Liquid/AbsTypeClassVerified.hs" "callF" 10000 [ Exactly 0 ]++ , checkLiquid "tests_lh/Liquid/Tree.hs" "sumPosTree" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/Error4.hs" "extractRights" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/PostFalse.hs" "f" 2000 [AtLeast 1]++ , checkLiquid "tests_lh/Liquid/TypeSym.hs" "f" 500 []++ , checkLiquid "tests_lh/Liquid/CorrectDict.hs" "f" 2000 [AtLeast 1]++ , checkAbsLiquid "tests_lh/Liquid/ZipWith3.hs" "prop_zipWith" 400 [ AtLeast 3]++ , checkAbsLiquid "tests_lh/Liquid/Length.hs" "prop_size" 1000+ [ AtLeast 1+ , RForAll (\_ _ [ _ ] -> True)]++ , checkLiquidWithConfig "tests_lh/Liquid/NestedLength.hs" [("nested", 1000, [AtLeast 1])]+ mkConfigTestIO+ (return $ (mkLHConfigDirect [] M.empty) { add_tyvars = True })+ , checkLiquidWithConfig "tests_lh/Liquid/AddTyVars.hs"+ [ ("f", 400, [AtLeast 1])+ , ("g", 400, [AtLeast 1])+ , ("h", 400, [AtLeast 1])]+ mkConfigTestIO+ (return $ (mkLHConfigDirect [] M.empty) { add_tyvars = True })++ , checkLiquid "tests_lh/Liquid/Polymorphism/Poly1.hs" "f" 1000 [Exactly 0]+ , checkLiquid "tests_lh/Liquid/Polymorphism/Poly2.hs" "f" 600 [Exactly 0]++ , checkLiquid "tests_lh/Liquid/Sets/Sets1.hs" "prop_union_assoc" 2000 [AtLeast 2]+ , checkLiquid "tests_lh/Liquid/Sets/Sets1.hs" "prop_intersection_comm" 1000 [AtLeast 5]+ , checkLiquid "tests_lh/Liquid/Sets/Sets2.hs" "badIdList" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/Sets/Sets2.hs" "append" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/Sets/Sets3.hs" "filter" 1800 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/Sets/Sets4.hs" "isin" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/Sets/Sets5.hs" "f" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/Sets/Sets6.hs" "f" 2000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/Sets/Sets7.hs" "insertSort" 3000 [AtLeast 1]++ -- Higher Order Functions+ , checkLiquid "tests_lh/Liquid/HigherOrder/IntFuncArg.hs" "caller" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/HigherOrder/HigherOrderPre.hs" "test" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/HigherOrder/HigherOrder2.hs" "f" 2000 [Exactly 0]++ -- IO+ , checkLiquid "tests_lh/Liquid/IO/IO1.hs" "f" 1000 [Exactly 0]+ , checkLiquid "tests_lh/Liquid/IO/IO2.hs" "f" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/IO/IO3.hs" "f" 1400 [AtLeast 1]++ -- Abstract counterexamples+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly3.hs" "f" 800+ [ AtLeast 4+ , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _} ] -> n == "fil")]+ , checkLiquid "tests_lh/Liquid/Polymorphism/Poly4.hs" "f" 600 [Exactly 0]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly5.hs" "call" 600 [AtLeast 1]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly6.hs" "f" 1000+ [ AtLeast 1+ , RForAll (\_ _ [ FuncCall { returns = r } ] ->+ case r of { Prim Undefined _-> False; _ -> True})+ ]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly7.hs" "prop_f" 2000 [AtLeast 1]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly8.hs" "prop" 2000+ [ AtLeast 1+ , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "func")]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly9.hs" "prop" 2000+ [ AtLeast 1+ , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "func")]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly10.hs" "prop" 2000+ [ AtLeast 1 ]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly11.hs" "call" 700+ [ AtLeast 1+ , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "higher")]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly12.hs" "prop" 3000+ [ AtLeast 1+ , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "map")]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly13.hs" "call" 1000+ [ AtLeast 1+ , RForAll (\_ _ [ FuncCall { funcName = Name n _ _ _ } ] -> n == "f")]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly14.hs" "initCall" 1000 [ AtLeast 1]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly15.hs" "call" 1000 [ AtLeast 1]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly16.hs" "call" 1000 + [ AtLeast 1+ , RForAll (\ _ _ [ FuncCall { arguments = [_, _, ar] } ] -> case ar of Prim _ _ -> False; _ -> True )]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly17.hs" "empty2" 1000 [ AtLeast 1]+ , checkAbsLiquid "tests_lh/Liquid/Polymorphism/Poly18.hs" "f" 500 [ AtLeast 1]+ ]++posInfTests :: TestTree+posInfTests = testGroup "Tests"+ [ posTestInference "tests_lh/test_files/Pos/HigherOrder.hs"+ , posTestInference "tests_lh/test_files/Pos/HigherOrder2.hs"+ -- , posTestInferenceWithTimeOut 240 5 "tests_lh/test_files/Pos/HigherOrder3.hs"+ -- , posTestInference "tests_lh/test_files/Pos/HigherOrder4.hs"++ , posTestInference "tests_lh/test_files/Pos/Test1.hs" + , posTestInference "tests_lh/test_files/Pos/Test2.hs"+ , posTestInference "tests_lh/test_files/Pos/Test3.hs"+ , posTestInference "tests_lh/test_files/Pos/Test4.hs"+ , posTestInference "tests_lh/test_files/Pos/Test5.hs"+ , posTestInference "tests_lh/test_files/Pos/Test6.hs"+ , posTestInference "tests_lh/test_files/Pos/Test7.hs"+ , posTestInference "tests_lh/test_files/Pos/Test8.hs"+ , posTestInference "tests_lh/test_files/Pos/Test9.hs"+ , posTestInference "tests_lh/test_files/Pos/Test10.hs"+ , posTestInference "tests_lh/test_files/Pos/Test11.hs"+ , posTestInference "tests_lh/test_files/Pos/Test12.hs"+ , posTestInference "tests_lh/test_files/Pos/Test13.hs"+ , posTestInference "tests_lh/test_files/Pos/Test14.hs"+ , posTestInference "tests_lh/test_files/Pos/Test15.hs"+ , posTestInference "tests_lh/test_files/Pos/Test16.hs"+ , posTestInference "tests_lh/test_files/Pos/Test17.hs"+ , posTestInference "tests_lh/test_files/Pos/Test18.hs"+ , posTestInference "tests_lh/test_files/Pos/Test19.hs"+ , posTestInference "tests_lh/test_files/Pos/Test20.hs"+ , posTestInference "tests_lh/test_files/Pos/Test21.hs"+ , posTestInference "tests_lh/test_files/Pos/Test22.hs"+ -- , posTestInference "tests_lh/test_files/Pos/Test23.hs"+ , posTestInference "tests_lh/test_files/Pos/Test24.hs"+ , posTestInference "tests_lh/test_files/Pos/Test25.hs"+ , posTestInference "tests_lh/test_files/Pos/Test26.hs"+ , posTestInference "tests_lh/test_files/Pos/Test27.hs"+ , posTestInference "tests_lh/test_files/Pos/Test28.hs"+ , posTestInference "tests_lh/test_files/Pos/Test29.hs"+ , posTestInference "tests_lh/test_files/Pos/Test30.hs"+ , posTestInference "tests_lh/test_files/Pos/Test31.hs"+ , posTestInference "tests_lh/test_files/Pos/Test32.hs"+ , posTestInference "tests_lh/test_files/Pos/Test33.hs"+ , posTestInference "tests_lh/test_files/Pos/Test34.hs"+ , posTestInference "tests_lh/test_files/Pos/Test35.hs"+ , posTestInference "tests_lh/test_files/Pos/Test36.hs"+ , posTestInference "tests_lh/test_files/Pos/Test37.hs"+ -- , posTestInferenceWithTimeOut 240 15 "tests_lh/test_files/Pos/Test38.hs"+ , posTestInference "tests_lh/test_files/Pos/Test39.hs"+ , posTestInference "tests_lh/test_files/Pos/Test40.hs"+ , posTestInference "tests_lh/test_files/Pos/Test41.hs"+ , posTestInference "tests_lh/test_files/Pos/Test42.hs"+ , posTestInference "tests_lh/test_files/Pos/Test43.hs"+ , posTestInference "tests_lh/test_files/Pos/Test44.hs"+ , posTestInference "tests_lh/test_files/Pos/Test45.hs"+ , posTestInference "tests_lh/test_files/Pos/Test46.hs"+ , posTestInference "tests_lh/test_files/Pos/Test47.hs"+ , posTestInference "tests_lh/test_files/Pos/Test48.hs"+ , posTestInference "tests_lh/test_files/Pos/Test49.hs"+ , posTestInference "tests_lh/test_files/Pos/Test50.hs"++ , posTestInference "tests_lh/test_files/Pos/Sets1.hs"+ , posTestInference "tests_lh/test_files/Pos/Sets2.hs"+ , posTestInference "tests_lh/test_files/Pos/Sets3.hs"+ , posTestInference "tests_lh/test_files/Pos/Sets4.hs"+ , posTestInference "tests_lh/test_files/Pos/Sets5.hs"+ , posTestInference "tests_lh/test_files/Pos/Sets6.hs"+ , posTestInference "tests_lh/test_files/Pos/Sets7.hs"+ , posTestInference "tests_lh/test_files/Pos/Sets8.hs"+ , posTestInference "tests_lh/test_files/Pos/Sets9.hs"+ -- , posTestInference "tests_lh/test_files/Pos/Sets10.hs"++ , posTestInference "tests_lh/test_files/Pos/MeasComp1.hs" + , posTestInference "tests_lh/test_files/Pos/MeasComp2.hs"+ , posTestInference "tests_lh/test_files/Pos/MeasComp3.hs" ]++negInfTests :: TestTree+negInfTests = testGroup "Tests"+ [ negTestInference "tests_lh/test_files/Neg/Test1.hs"+ , negTestInference "tests_lh/test_files/Neg/Test2.hs"+ , negTestInference "tests_lh/test_files/Neg/Test3.hs"+ , negTestInference "tests_lh/test_files/Neg/Test4.hs"+ , negTestInference "tests_lh/test_files/Neg/Test5.hs"+ , negTestInference "tests_lh/test_files/Neg/Test6.hs" ]++cexInfTests :: TestTree+cexInfTests = testGroup "Tests"+ [ cexTest "tests_lh/test_files/CEx/CEx1.hs" "zipWith"+ , cexTest "tests_lh/test_files/CEx/CEx2.hs" "mapReduce"+ , cexTest "tests_lh/test_files/CEx/CEx3.hs" "kmeans1" ]++todoTests :: TestTree+todoTests = testGroup "To Do"+ [+ checkLiquid "tests_lh/Liquid/TyApps.hs" "goodGet" 1000 [Exactly 0]+ , checkLiquid "tests_lh/Liquid/TyApps.hs" "getPosInt" 1000+ [ AtLeast 1+ , RForAll (\[_, _, (App _ x), y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' == y' && y' == 10)]+ , checkLiquid "tests_lh/Liquid/TyApps.hs" "getPos" 1000+ [ AtLeast 1+ , RExists (\[_, _, (App _ x), y] -> getIntB x $ \x' -> getIntB y $ \y' -> x' == y' && y' == 10)]+ , checkLiquid "tests_lh/Liquid/FoldrTests.hs" "max2" 1000 [Exactly 0]+ , checkLiquid "tests_lh/Liquid/FoldrTests.hs" "max3" 1000 [Exactly 0]+ , checkLiquid "tests_lh/Liquid/SimpleAnnot.hs" "simpleF" 1000 [Exactly 0]+ , checkLiquid "tests_lh/Liquid/Ordering.hs" "lt" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/Ordering.hs" "gt" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/WhereFuncs2.hs" "hCalls" 1000 [AtLeast 1]+ , checkLiquid "tests_lh/Liquid/WhereFuncs2.hs" "i" 1000 [AtLeast 1]+ , checkAbsLiquid "tests_lh/Liquid/AddToEvenWhere.hs" "f" 2000+ [ AtLeast 1+ , RForAll (\[i] r [(FuncCall { funcName = Name n _ _ _, returns = r' }) ]+ -> n == "g" && isInt i (\i' -> i' `mod` 2 == 0) && r == r' )]+ , checkLiquid "tests_lh/Liquid/ListTests.lhs" "concat" 1000 [AtLeast 3]+ , checkLiquid "tests_lh/Liquid/MapReduceTest.lhs" "mapReduce" 1500+ [Exactly 0]+ , checkLiquid "tests_lh/Liquid/NearestTest.lhs" "nearest" 1500 [Exactly 1]++ , checkAbsLiquid "tests_lh/Liquid/ListTests2.lhs" "replicate" 2000+ [ AtLeast 3+ , RForAll (\[_, nA, aA] _ [(FuncCall { funcName = Name n _ _ _, arguments = [_, _, nA', aA'] }) ]+ -> n == "replicate" && nA == nA' && aA == aA') ]+ ]+-------------------------------------------------+-- CEx Gen tests+-------------------------------------------------++checkLiquidWithNoCutOff :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> TestTree+checkLiquidWithNoCutOff fp tests = do+ let lhconfig = mkLHConfigDirect [] M.empty+ checkLiquidWithConfig fp tests+ mkConfigTestIO+ (return lhconfig { cut_off = maximum $ map (\(_, stps, _) -> stps) tests })++checkLiquid :: FilePath -> String -> Int -> [Reqs ([Expr] -> Bool)] -> TestTree+checkLiquid fp entry stps req = do+ let lhconfig = mkLHConfigDirect [] M.empty+ checkLiquidWithConfig fp [(entry, stps, req)]+ mkConfigTestIO+ (return lhconfig)++checkLiquids :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> TestTree+checkLiquids fp tests = do+ let lhconfig = mkLHConfigDirect [] M.empty+ checkLiquidWithConfig fp tests+ mkConfigTestIO+ (return lhconfig)+++checkLiquidWithSet :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> TestTree+checkLiquidWithSet fp tests = do+ let lhconfig = mkLHConfigDirect [] M.empty+ checkLiquidWithConfig fp tests+ mkConfigTestWithSetIO+ (return lhconfig)++checkLiquidWithCutOff :: FilePath -> String -> Int -> Int -> [Reqs ([Expr] -> Bool)] -> TestTree+checkLiquidWithCutOff fp entry stps co reqList = do+ let lhconfig = mkLHConfigDirect [] M.empty+ checkLiquidWithConfig fp [(entry, stps, reqList)]+ mkConfigTestIO+ (return lhconfig { cut_off = co })++checkLiquidWithMap :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> TestTree+checkLiquidWithMap fp tests = do+ let lhconfig = mkLHConfigDirect [] M.empty+ checkLiquidWithConfig fp tests+ mkConfigTestWithMapIO+ (return lhconfig)++checkLiquidWithConfig :: FilePath -> [(String, Int, [Reqs ([Expr] -> Bool)])] -> IO Config -> IO LHConfig -> TestTree+checkLiquidWithConfig fp tests config_f lhconfig_f =+ withResource+ (do+ config <- config_f+ g2_lh_config <- lhconfig_f++ lh_config <- getOpts []++ let config' = config { mode = Liquid }+ let proj = takeDirectory fp++ ghci <- try $ getGHCInfos lh_config [proj] [fp] :: IO (Either SomeException [GhcInfo])+ + let ghci' = case ghci of+ Right g_c -> g_c+ Left e -> error $ "ERROR OCCURRED IN LIQUIDHASKELL\n" ++ show e++ tgt_trans <- translateLoaded [proj] [fp] (simplTranslationConfig { simpl = False }) config'++ return (tgt_trans, ghci', config', g2_lh_config)+ )+ (\_ -> return ())+ $ \loaded ->+ testGroup+ fp+ $ map (\(entry, stps, reqList) ->+ testCase (fp ++ " " ++ entry) (do+ (tgt_trans, ghci, config, lh_config) <- loaded+ let config' = config { steps = stps }+ res <- doTimeout (timeLimit config)+ $ (try (return . fst. fst =<< runLHCore (T.pack entry) tgt_trans ghci config' lh_config)+ :: IO (Either SomeException [ExecRes AbstractedInfo]))+ + let (ch, r) = case res of+ Nothing -> (False, Right [Time])+ Just (Left e) -> (False, Left e)+ Just (Right exprs) ->+ let+ r_ = checkExprGen+ (map (\(ExecRes { conc_args = inp, conc_out = out}) -> inp ++ [out]) exprs)+ reqList+ in+ (null r_, Right r_)++ assertBool ("Liquid test for file " ++ fp ++ + " with function " ++ entry ++ " failed.\n" ++ show r) ch+ )+ ) tests++checkAbsLiquid :: FilePath -> String -> Int -> [Reqs ([Expr] -> Expr -> [FuncCall] -> Bool)] -> TestTree+checkAbsLiquid fp entry stps reqList = do+ let lhconfig = mkLHConfigDirect [] M.empty+ checkAbsLiquidWithConfig fp entry reqList+ (do config <- mkConfigTestIO+ return $ config {steps = stps} )+ (return lhconfig)++checkAbsLiquidWithConfig :: FilePath+ -> String+ -> [Reqs ([Expr]+ -> Expr+ -> [FuncCall]+ -> Bool)]+ -> IO Config+ -> IO LHConfig+ -> TestTree+checkAbsLiquidWithConfig fp entry reqList config_f lhconfig_f = do+ testCase fp (do+ config <- config_f+ lhconfig <- lhconfig_f+ res <- findCounterExamples' fp (T.pack entry) config lhconfig++ let (ch, r) = case res of+ Nothing -> (False, Right [])+ Just (Left e) -> (False, Left e)+ Just (Right exprs) ->+ let+ te = checkAbsLHExprGen+ (map (\(ExecRes { final_state = s, conc_args = inp, conc_out = out})+ -> (s, inp, out)+ ) exprs+ ) reqList+ in+ (null te, Right te)++ assertBool ("Liquid test for file " ++ fp ++ + " with function " ++ entry ++ " failed.\n" ++ show r) ch+ )++findCounterExamples' :: FilePath+ -> T.Text+ -> Config+ -> LHConfig+ -> IO (Maybe (Either SomeException [ExecRes AbstractedInfo]))+findCounterExamples' fp entry config lhconfig =+ let+ proj = takeDirectory fp+ in+ doTimeout (timeLimit config)+ $ try (return . fst. fst =<< findCounterExamples [proj] [fp] entry config lhconfig)++-------------------------------------------------+-- Inference tests+-------------------------------------------------++posTestInferenceWithTimeOut :: Int -> NominalDiffTime -> FilePath -> TestTree+posTestInferenceWithTimeOut to to_se fp = do+ testCase ("Inference " ++ fp) (do+ config <- G2.getConfigDirect+ let infconfig = (mkInferenceConfigDirect []) { timeout_se = to_se }+ let lhconfig = mkLHConfigDirect [] M.empty+ res <- doTimeout to $ inferenceCheck infconfig config lhconfig [] [fp]++ assertBool ("Inference for " ++ fp ++ " failed.") $ maybe False (isRight . snd) res+ )++posTestInference :: FilePath -> TestTree+posTestInference = posTestInferenceWithTimeOut 120 5++negTestInference :: FilePath -> TestTree+negTestInference fp = do+ testCase ("Inference " ++ fp) (do+ config <- G2.getConfigDirect+ let infconfig = mkInferenceConfigDirect []+ let lhconfig = mkLHConfigDirect [] M.empty+ res <- doTimeout 90 $ inferenceCheck infconfig config lhconfig [] [fp]++ assertBool ("Inference for " ++ fp ++ " failed.") $ maybe False (isLeft . snd) res+ )++cexTest :: FilePath -> String -> TestTree+cexTest fp func =+ testCase ("Inference " ++ fp) (do+ config <- G2.getConfigDirect+ let infconfig = (mkInferenceConfigDirect []) { timeout_se = 10 }+ let lhconfig = mkLHConfigDirect [] M.empty+ res <- doTimeout 25 $ runLHInferenceAll infconfig config lhconfig (T.pack func) [] [fp]+ assertBool ("Counterexample generation for " ++ func ++ " in " ++ fp ++ " failed.") $ maybe False (not . null . fst) res+ )
+ tests_lh/UnionPoly.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}++module UnionPoly (unionPolyTests) where++import G2.Language+import qualified G2.Language.ExprEnv as E+import G2.Liquid.Inference.UnionPoly++import qualified Data.Text as T++import Test.Tasty+import Test.Tasty.HUnit++unionPolyTests :: TestTree+unionPolyTests =+ testGroup "UnionPoly"+ [+ testCase "Let unification" $ assertBool "Polymorphic unification failed with lets" letTest+ , testCase "Lambda unification 1" $ assertBool "Polymorphic unification failed with lambdas" lambdaTest1+ , testCase "Lambda unification 2" $ assertBool "Polymorphic unification failed with lambdas" lambdaTest2+ ]++letTest :: Bool+letTest =+ let+ f = defName "f"+ g = defName "g"+ eenv = letExprEnv f g+ + ut = sharedTyConsEE [f, g] eenv+ in+ case lookupUT g ut of+ Just (TyFun t1@(TyVar _) t2) -> t1 == t2 + _ -> False++letExprEnv :: Name -> Name -> ExprEnv+letExprEnv f g =+ let+ call = defName "call"+ a = defName "a"++ a_id = Id a TYPE+ a_ty = TyVar a_id++ int = defName "Int"+ int_ty = TyCon int TYPE++ g_id = Id g (TyFun int_ty int_ty)+ r_id = Id (defName "r") (TyFun int_ty int_ty)+ call_id = Id call . TyForAll a_id $ TyFun (TyFun a_ty a_ty) a_ty++ f_e = Let [(r_id, Var g_id)] . App (App (Var call_id) (Type int_ty)) $ Var r_id++ x_id = Id (defName "x") int_ty+ y_id = Id (defName "y") int_ty+ g_e = Lam TermL x_id (Var y_id)+ in+ E.fromList [(f, f_e), (g, g_e)]++lambdaTest1 :: Bool+lambdaTest1 =+ let+ f = defName "f"+ g = defName "g"+ h = defName "h"+ eenv = lambdaExprEnv1 f g h++ ut = sharedTyConsEE [f, g, h] eenv+ in+ case lookupUT h ut of+ Just (TyFun t1@(TyVar _) t2) -> t1 == t2 + _ -> False++lambdaExprEnv1 :: Name -> Name -> Name -> ExprEnv+lambdaExprEnv1 f g h =+ let+ a = defName "a"+ a_id = Id a TYPE+ a_ty = TyVar a_id++ int = defName "Int"+ int_ty = TyCon int TYPE++ g_id = Id g . TyForAll a_id $ TyFun (TyFun a_ty a_ty) a_ty+ h_id = Id h $ TyFun int_ty int_ty++ j_id = Id (defName "j") (TyFun a_ty a_ty)+ x_id = Id (defName "x") int_ty++ g_e = Lam TypeL a_id . Lam TermL j_id $ App (App (Var g_id) (Type a_ty)) (Var j_id)+ h_e = Lam TermL x_id $ Var x_id+ f_e = App (App (Var g_id) (Type int_ty)) . Lam TermL x_id $ App (Var h_id) (Var x_id)+ in+ E.fromList [(f, f_e), (g, g_e), (h, h_e)]++lambdaTest2 :: Bool+lambdaTest2 =+ let+ f = defName "f"+ g = defName "g"+ h = defName "h"+ eenv = lambdaExprEnv2 f g h++ ut = sharedTyConsEE [f, g, h] eenv+ in+ case lookupUT h ut of+ Just (TyFun t1@(TyVar _) t2) -> t1 == t2 + _ -> False++lambdaExprEnv2 :: Name -> Name -> Name -> ExprEnv+lambdaExprEnv2 f g h =+ let+ a = defName "a"+ a_id = Id a TYPE+ a_ty = TyVar a_id++ int = defName "Int"+ int_ty = TyCon int TYPE++ g_id = Id g . TyForAll a_id . TyFun (TyFun int_ty int_ty) $ TyFun (TyFun a_ty a_ty) a_ty+ h_id = Id h $ TyFun int_ty int_ty++ j_id = Id (defName "j") (TyFun int_ty int_ty)+ k_id = Id (defName "k") (TyFun a_ty a_ty)+ x_id = Id (defName "x") int_ty+ y_id = Id (defName "y") a_ty++ bind_id = Id (defName "bind") (TyForAll a_id (TyFun a_ty a_ty))++ g_e = Lam TypeL a_id+ . Lam TermL j_id+ . Lam TermL k_id $ App (App (App (Var g_id) (Type a_ty)) (Var j_id)) (Var k_id)+ h_e = Lam TermL x_id $ Var x_id+ f_e = Let [(bind_id, Lam TypeL a_id $ Lam TermL y_id (Var y_id))]+ . App (App (App (Var g_id) (Type int_ty)) (App (Var bind_id) (Type int_ty))) $ Var h_id+ in+ E.fromList [(f, f_e), (g, g_e), (h, h_e)]++defName :: T.Text -> Name+defName n = Name n Nothing 0 Nothing
+ tests_nebula_plugin/Main.hs view
@@ -0,0 +1,77 @@+module Main where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Exception+import Data.List+import System.IO+import System.Process++main :: IO ()+main = do+ defaultMainWithIngredients+ defaultIngredients+ tests++tests :: TestTree+tests = testGroup "All Tests"+ [ checkPackage "tests/RewriteVerify/PluginTests/Simple" ["add_assoc", "fg", "fg_toint"] ["f_one"]]++checkPackage :: FilePath+ -> [String] -- ^ Rules that should be verified+ -> [String] -- ^ Rules that should have counterexamples+ -> TestTree+checkPackage loc correct incorrect =+ withResource+ (buildPackage loc)+ (\_ -> return ()) $+ \io_out ->+ testGroup+ loc+ $ verifiedTests io_out correct ++ cexTests io_out incorrect++verifiedTests :: IO String -> [String] -> [TestTree]+verifiedTests io_out correct =+ map (\c -> testCase+ c+ (do+ out <- io_out+ assertBool ("Not verified") (isVerified c out && not (hasCEx c out)))+ ) correct++cexTests :: IO String -> [String] -> [TestTree]+cexTests io_out incorrect =+ map (\i -> testCase+ i+ (do+ out <- io_out+ assertBool ("No counterexample") (not (isVerified i out) && hasCEx i out))+ ) incorrect++buildPackage :: FilePath -> IO String+buildPackage loc = do+ (Nothing, Nothing, Nothing, clean_ph) <- createProcess+ $ (proc "cabal" ["clean"]) { cwd = Just loc+ , std_out = Inherit }+ waitForProcess clean_ph+ (Nothing, Nothing, Nothing, build_g2_ph) <- createProcess+ $ (proc "cabal" ["build", "g2"]) { cwd = Just loc }+ waitForProcess build_g2_ph+ (Nothing, Just stdout, Nothing, ph) <- createProcess+ $ (proc "cabal" ["build"]) { cwd = Just loc+ , std_out = CreatePipe }+ waitForProcess ph+ out <- hGetContents stdout+ _ <- evaluate (length out)+ hClose stdout+ return out++isVerified :: String -> String -> Bool+isVerified f = isSubstringOf (f ++ " - verified")++hasCEx :: String -> String -> Bool+hasCEx f = isSubstringOf (f ++ " - counterexample found")++isSubstringOf :: String -> String -> Bool+isSubstringOf = isInfixOf
+ tests_quasiquote/Arithmetics/Interpreter.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Arithmetics.Interpreter where++import Control.Monad+import Data.Data+import G2.QuasiQuotes.G2Rep++type Ident = String+type Env = [(Ident, Int)]++data AExpr = I Int | Var Ident+ | Add AExpr AExpr | Mul AExpr AExpr+ deriving (Eq, Show, Data)++$(derivingG2Rep ''AExpr)++data BExpr = Not BExpr | And BExpr BExpr | Or BExpr BExpr+ | Lt AExpr AExpr | Eq AExpr AExpr+ deriving (Eq, Show, Data)++$(derivingG2Rep ''BExpr)++type Stmts = [Stmt]+data Stmt = Assign Ident AExpr+ | If BExpr Stmts Stmts+ | While BExpr Stmts+ | Assert BExpr+ deriving (Eq, Show, Data)+ +$(derivingG2Rep ''Stmt)++type Bound = [Ident]+type Return = Ident+data Func = Func Bound Stmts Return++$(derivingG2Rep ''Func)++evalFunc :: [Int] -> Func -> Maybe Int+evalFunc is (Func b s r) =+ lookup r =<< evalStmts (zip b is) s++evalStmts :: Env -> Stmts -> Maybe Env+evalStmts = foldM evalStmt ++evalStmt :: Env -> Stmt -> Maybe Env+evalStmt env (Assign ident aexpr) =+ Just $ (ident, evalA env aexpr):env+evalStmt env (If bexpr lhs rhs) =+ if evalB env bexpr+ then evalStmts env lhs+ else evalStmts env rhs+evalStmt env (While bexpr loop) =+ if evalB env bexpr+ then evalStmts env (loop ++ [While bexpr loop])+ else Just env+evalStmt env (Assert bexpr) =+ if evalB env bexpr+ then Just env+ else Nothing++evalA :: Env -> AExpr -> Int+evalA _ (I int) = int+evalA env (Add lhs rhs) =+ evalA env lhs + evalA env rhs+evalA env (Mul lhs rhs) =+ evalA env lhs * evalA env rhs+evalA env (Var ident) =+ case lookup ident env of+ Just int -> int+ _ -> error $+ "lookup with " ++ show (ident, env)++evalB :: Env -> BExpr -> Bool+evalB env (Not bexpr) = not $ evalB env bexpr+evalB env (And lhs rhs) =+ evalB env lhs && evalB env rhs+evalB env (Or lhs rhs) =+ evalB env lhs || evalB env rhs+evalB env (Lt lhs rhs) =+ evalA env lhs < evalA env rhs+evalB env (Eq lhs rhs) =+ evalA env lhs == evalA env rhs+
+ tests_quasiquote/Arithmetics/Test.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE QuasiQuotes #-}++module Arithmetics.Test where++import Arithmetics.Interpreter+import G2.QuasiQuotes.QuasiQuotes++badProg :: Stmts+badProg =+ [+ Assign "k" (I 1),+ Assign "i" (I 0),+ -- Assign "j" (I 0),+ Assign "n" (I 5),+ While (Or (Lt (Var "i") (Var "n"))+ (Eq (Var "i") (Var "n")))+ [ Assign "i" (Add (Var "i") (I 1))+ , Assign "j" (Add (Var "j") (Var "i"))+ ],+ Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))),+ Assert (Lt (Mul (Var "n") (I 2)) (Var "z"))+ ]++productTest :: IO (Maybe (AExpr, AExpr))+productTest =+ [g2| \(a :: Int) -> ?(s1 :: AExpr)+ ?(s2 :: AExpr) |+ let env = [("x", 23), ("y", 59)] in+ let lhs = Mul (Var "x") (Var "y") in+ let rhs = Mul s1 s2 in+ evalB env (Eq lhs rhs) |] 0++envTest :: BExpr -> IO (Maybe Env)+envTest = [g2|\(b :: BExpr) -> ?(env :: Env) |+ evalB env b |]++searchBadEnv :: Stmts -> IO (Maybe Env)+searchBadEnv =+ [g2| \(stmts :: Stmts) -> ?(env :: Env) |+ evalStmts env stmts == Nothing|]++assertViolation :: Stmts -> IO (Maybe Env)+assertViolation = [g2|\(stmts :: Stmts) -> ?(env :: Env) |+ evalStmts env stmts == Nothing|]++productSumProg :: BExpr+productSumProg =+ And+ ((Eq + (Mul (Var "x") (Var "y"))+ (Add (Var "x") (Var "y"))))+ (Lt (I 0) (Var "x"))+++productSumAssertTest :: IO (Maybe Env)+productSumAssertTest = assertViolation+ [ If (Lt (I 0) (Var "x"))+ [ Assert (Not+ (Eq+ (Mul (Var "x") (Var "y"))+ (Add (Var "x") (Var "y"))+ )+ )+ ]+ []+ ]++assertViolationTest1 :: IO (Maybe Env)+assertViolationTest1 = assertViolation+ [ Assert (Lt (I 5) (I 3)) ]++-- x^2 + y^2 + z^2 < (x + y + z)^2+assertViolationTest2 :: IO (Maybe Env)+assertViolationTest2 = assertViolation+ [ Assign "v1" (Add (Var "x") (Add (Var "y") (Var "z")))+ , Assign "v1" (Mul (Var "v1") (Var "v1"))+ , Assign "v2" (Add (Mul (Var "x") (Var "x"))+ (Add (Mul (Var "y") (Var "y"))+ (Mul (Var "z") (Var "z"))))+ , Assert (Lt (Var "v2") (Var "v1"))+ ]+++assertViolationTest3 :: IO (Maybe Env)+assertViolationTest3 = assertViolation+ [+ Assign "k" (I 1),+ Assign "i" (I 0),+ Assign "j" (I 0),+ Assign "n" (I 5),+ While (Or (Lt (Var "i") (Var "n"))+ (Eq (Var "i") (Var "n")))+ [ Assign "i" (Add (Var "i") (I 1))+ , Assign "j" (Add (Var "j") (Var "i"))+ ],+ Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))),+ Assert (Lt (Mul (Var "n") (I 2)) (Var "z"))+ ]+ ++assertViolationTest4 :: IO (Maybe Env)+assertViolationTest4 = assertViolation+ [+ Assign "k" (I 1),+ Assign "i" (I 0),+ -- Assign "j" (I 0),+ Assign "n" (I 5),+ While (Or (Lt (Var "i") (Var "n"))+ (Eq (Var "i") (Var "n")))+ [ Assign "i" (Add (Var "i") (I 1))+ , Assign "j" (Add (Var "j") (Var "i"))+ ],+ Assign "z" (Add (Var "k") (Add (Var "i") (Var "j"))),+ Assert (Lt (Mul (Var "n") (I 2)) (Var "z"))+ ]+ +
+ tests_quasiquote/DeBruijn/Interpreter.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module DeBruijn.Interpreter ( Expr (..)+ , Ident+ , eval+ , app+ , lams+ , num) where++import Data.Data+import G2.QuasiQuotes.G2Rep++type Ident = Int++data Expr = Var Ident+ | Lam Expr+ | App Expr Expr+ deriving (Show, Read, Eq, Data)++$(derivingG2Rep ''Expr)++type Stack = [Expr]++eval :: Expr -> Expr+eval = eval' []++eval' :: Stack -> Expr -> Expr+eval' (e:stck) (Lam e') = eval' stck (rep 1 e e')+eval' stck (App e1 e2) = eval' (e2:stck) e1+eval' stck e = app $ e:stck++rep :: Int -> Expr -> Expr -> Expr+rep i e v@(Var j)+ | i == j = e+ | otherwise = v+rep i e (Lam e') = Lam (rep (i + 1) e e')+rep i e (App e1 e2) = App (rep i e e1) (rep i e e2)++app :: [Expr] -> Expr+app = foldl1 App++lams :: Int -> Expr -> Expr+lams n e = iterate Lam e !! n++num :: Int -> Expr+num n = Lam $ Lam $ foldr1 App (replicate n (Var 2) ++ [Var 1])
+ tests_quasiquote/DeBruijn/Test.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE QuasiQuotes #-}++module DeBruijn.Test where++import DeBruijn.Interpreter+import G2.QuasiQuotes.QuasiQuotes++import RegEx.RegEx as R++solveDeBruijn :: [([Expr], Expr)] -> IO (Maybe Expr)+solveDeBruijn =+ [g2| \(es :: [([Expr], Expr)]) -> ?(func :: Expr) |+ all (\e -> (eval (app (func:fst e))) == snd e) es |]++appFunc :: [([Expr], Expr)] -> Expr -> Bool+appFunc es func = all (\e -> (eval (app (func:fst e))) == snd e) es++idDeBruijn :: [([Expr], Expr)]+idDeBruijn = [ ([num 1], num 1)+ , ([num 2], num 2) ]++const2Example :: [([Expr], Expr)]+const2Example =+ [ ([num 1, num 2], num 1)+ , ([num 2, num 3], num 2) ] ++trueLam :: Expr+trueLam = Lam (Lam (Var 2))++falseLam :: Expr+falseLam = Lam (Lam (Var 1))++notExample :: [([Expr], Expr)]+notExample =+ [ ([trueLam], falseLam)+ , ([falseLam], trueLam) ]++orExample :: [([Expr], Expr)]+orExample =+ [ ([trueLam, trueLam], trueLam)+ , ([falseLam, falseLam], falseLam)+ , ([falseLam, trueLam], trueLam)+ , ([trueLam, falseLam], trueLam )]++andExample :: [([Expr], Expr)]+andExample =+ [ ([trueLam, trueLam], trueLam)+ , ([falseLam, falseLam], falseLam)+ , ([falseLam, trueLam], falseLam)+ , ([trueLam, falseLam], falseLam )]+++-- runDeBruijnEval :: IO ()+-- runDeBruijnEval = do+-- putStrLn "------------------------"+-- putStrLn "-- DeBruijn Eval -------"+-- timeIOActionPrint $ solveDeBruijn idDeBruijn+-- timeIOActionPrint $ solveDeBruijn const2Example+-- -- timeIOActionPrint $ solveDeBruijn notExample+-- timeIOActionPrint $ solveDeBruijn orExample+-- -- timeIOActionPrint $ solveDeBruijn andExample+-- putStrLn ""
+ tests_quasiquote/Evaluations.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE QuasiQuotes #-}++module Evaluations where++import G2.QuasiQuotes.QuasiQuotes++import DeBruijn.Interpreter as D+import RegEx.RegEx as R+++-------------------------------------------+-------------------------------------------+-- Section 5.2 (Lambda Calculus)++solveDeBruijn :: [([Expr], Expr)] -> IO (Maybe Expr)+solveDeBruijn =+ [g2| \(es :: [([Expr], Expr)]) -> ?(func :: Expr) |+ all (\e -> (eval (app (func:fst e))) == snd e) es |]++idDeBruijn :: [([D.Expr], D.Expr)]+idDeBruijn = [ ([num 1], num 1)+ , ([num 2], num 2) ]++const2Example :: [([D.Expr], D.Expr)]+const2Example =+ [ ([num 1, num 2], num 1)+ , ([num 2, num 3], num 2) ] ++trueLam :: D.Expr+trueLam = Lam (Lam (D.Var 2))++falseLam :: D.Expr+falseLam = Lam (Lam (D.Var 1))++notExample :: [([D.Expr], D.Expr)]+notExample =+ [ ([trueLam], falseLam)+ , ([falseLam], trueLam) ]++orExample :: [([D.Expr], D.Expr)]+orExample =+ [ ([trueLam, trueLam], trueLam)+ , ([falseLam, falseLam], falseLam)+ , ([falseLam, trueLam], trueLam)+ , ([trueLam, falseLam], trueLam )]++andExample :: [([D.Expr], D.Expr)]+andExample =+ [ ([trueLam, trueLam], trueLam)+ , ([falseLam, falseLam], falseLam)+ , ([falseLam, trueLam], falseLam)+ , ([trueLam, falseLam], falseLam )]+++++-------------------------------------------+-------------------------------------------++
+ tests_quasiquote/Lambda/Interpreter.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Lambda.Interpreter where++import Data.Data+import Data.List+import G2.QuasiQuotes.QuasiQuotes+import G2.QuasiQuotes.G2Rep++type Id = String++data Prim = I Int | B Bool | Fun Id+ deriving (Show, Eq, Data)++$(derivingG2Rep ''Prim)++data Expr+ = Var Id+ | Lam Id Expr+ | App Expr Expr+ | Const Prim+ deriving (Show, Eq, Data)++$(derivingG2Rep ''Expr)++type Env = [(Id, Expr)]++eval :: Env -> Expr -> Expr+eval env (Var id) =+ case lookup id env of+ Just expr -> eval env expr+ Nothing -> Const (Fun id)+eval env (App (Lam i body) arg) =+ eval ((i, arg) : env) body+eval env expr = expr+
+ tests_quasiquote/Lambda/Test.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE QuasiQuotes #-}++module Lambda.Test where++import Lambda.Interpreter+import G2.QuasiQuotes.QuasiQuotes++lambdaTest1 :: IO (Maybe Expr)+lambdaTest1 = [g2| \(x :: Int ) -> ?(symExpr :: Expr) |+ let env = [] in+ let expr = App (Lam "b" (Var "b")) symExpr in+ eval env expr == (Const (I 40)) |] 0+++lambdaTest2 :: IO (Maybe Expr)+lambdaTest2 = [g2| \(x :: Int ) -> ?(symExpr :: Expr) |+ let env = [] in+ let expr = symExpr in+ eval env expr == (Const (I 43)) |] 0
+ tests_quasiquote/Main.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE QuasiQuotes #-}++module Main where++import Test.Tasty+import Test.Tasty.HUnit++import DeBruijn.Test+import Arithmetics.Interpreter+import Arithmetics.Test+import Lambda.Test+import NQueens.Test+import RegEx.Test+import RegEx.RegEx+import Simple.SimpleTest1++import G2.Interface++import qualified Evaluations as E++tests :: TestTree+tests = testGroup "All Tests"+ [ -- simpleTests+ nqueensTests+ , arithmeticsTests+ -- , deBruijnTests+ , regexTests ]++simpleTests :: TestTree+simpleTests = testGroup "Simple"+ [ qqTestCase "Simple 1" (sd ()) af ]++nqueensTests :: TestTree+nqueensTests = testGroup "N Queens"+ [ qqTestCase "4 Queens" (queensTestN 4) (allQueensSafe 4)+ , qqTestCase "5 Queens" (queensTestN 5) (allQueensSafe 5)+ , qqTestCase "6 Queens" (queensTestN 6) (allQueensSafe 6)+ , qqTestCase "7 Queens" (queensTestN 7) (allQueensSafe 7)+ , qqTestCase "8 Queens" (queensTestN 8) (allQueensSafe 8) ]++arithmeticsTests :: TestTree+arithmeticsTests = testGroup "Arithmetic"+ [ qqTestCase "Arithmetic 1" (searchBadEnv badProg)+ (\env -> evalStmts env badProg == Nothing)+ , qqTestCase "Arithmetic 2" (envTest productSumProg) (flip evalB productSumProg)+ ]++deBruijnTests :: TestTree+deBruijnTests = testGroup "DeBruijn"+ [ qqTestCase "DeBruijn 1" (solveDeBruijn idDeBruijn) (appFunc idDeBruijn)+ , qqTestCase "DeBruijn 2" (solveDeBruijn const2Example) (appFunc const2Example)+ , qqTestCase "DeBruijn 3" (solveDeBruijn orExample) (appFunc orExample)+ ]+++regexTests :: TestTree+regexTests = testGroup "Regex"+ [ qqTestCase "Regex 1" (stringSearch regex1) (match regex1)+ , qqTestCase "Regex 2" (stringSearch regex2) (match regex2)+ , qqTestCase "Regex 3" (stringSearch regex3) (match regex3)+ , qqTestCase "Regex 4" (stringSearch regex4) (match regex4)+ ]++qqTestCase :: (Eq a, Show a) => TestName -> IO (Maybe a) -> (a -> Bool) -> TestTree+qqTestCase name io_val p = do+ testCase name (do+ val <- doTimeout 180 $ io_val+ assertBool+ ("Predicate not satisfied by " ++ show val)+ (case val of+ Just (Just val') -> p val'+ _ -> False))++-- arithmeticsTests :: IO ()+-- arithmeticsTests = do+-- putStrLn "---------------------"+-- putStrLn "arithmeticsTests ----"++-- putStrLn "-- productTest"+-- timeIOActionPrint productTest+-- putStrLn ""++-- putStrLn "-- productSumTest"+-- timeIOActionPrint productSumTest+-- putStrLn ""++-- putStrLn "-- productSumAssertTest"+-- timeIOActionPrint productSumAssertTest+-- putStrLn ""++-- putStrLn "-- assertViolationTest1"+-- timeIOActionPrint assertViolationTest1+-- putStrLn ""++-- -- Technically this is non-linear integer arithm so undecidable+-- -- putStrLn "-- assertViolationTest2"+-- -- timeIOActionPrint assertViolationTest2+-- -- putStrLn ""++-- -- About 6 secs+-- putStrLn "-- assertViolationTest3"+-- timeIOActionPrint assertViolationTest3+-- putStrLn ""++-- -- About 51 secs+-- putStrLn "-- assertViolationTest4"+-- timeIOActionPrint assertViolationTest4+-- putStrLn ""+++++-- putStrLn "---------------------\n\n"+++-- lambdaTests :: IO ()+-- lambdaTests = do+-- putStrLn "---------------------"+-- putStrLn "lambdaTests ---------"++-- putStrLn "-- lambdaTest1"+-- timeIOActionPrint lambdaTest1+-- putStrLn ""++-- putStrLn "-- lambdaTest2"+-- timeIOActionPrint lambdaTest2+-- putStrLn ""++-- putStrLn "---------------------\n\n"+-- return ()++-- debruijnTests :: IO ()+-- debruijnTests = do+-- putStrLn "---------------------"+-- putStrLn "debruijnTests -------"++-- putStrLn "-- solveDeBruijnI" -- identity+-- timeIOActionPrint $ solveDeBruijnI++-- putStrLn "-- solveDeBruijnK" -- const+-- timeIOActionPrint $ solveDeBruijnK++-- putStrLn "-- solveDeBruijnOr"+-- timeIOActionPrint $ solveDeBruijnOr++-- -- putStrLn "-- solveDeBruijnAnd"+-- -- timeIOActionPrint $ solveDeBruijnAnd++-- putStrLn "-- solveDeBruijnIte"+-- timeIOActionPrint $ solveDeBruijnIte++-- putStrLn "---------------------\n\n"+-- return ()++-- regexTests :: IO ()+-- regexTests = do+-- putStrLn "---------------------"+-- putStrLn "regexTests ----------"++-- putStrLn "-- regexTest1"+-- timeIOActionPrint regexTest1+-- putStrLn ""++-- putStrLn "-- regexTest2"+-- timeIOActionPrint regexTest2+-- putStrLn ""++-- putStrLn "---------------------\n\n"+-- return ()+++main :: IO ()+main = do+ defaultMainWithIngredients+ defaultIngredients+ tests++{-+main :: IO ()+main = do+ putStrLn "main: compiles!"++ -- arithmeticsTests+ -- lambdaTests+ -- nqueensTests+ -- debruijnTests+ -- regexTests++ nqueensTests+ runArithmeticsEval+ runDeBruijnEval+ runRegExEval++++ putStrLn "main: done"+-}++ -- print =<< queensTestN 6+ -- print =<< solveDeBruijnI+ -- print =<< solveDeBruijnK+ -- print =<< lambdaTest2+ + -- putStrLn "-- Basic Test --"+ -- r <- f 8 10+ -- print r++ -- r2 <- g 7+ -- print r2++ -- r3 <- h 11+ -- print r3+ + -- putStrLn "\n-- Bool Test --"+ -- print =<< boolTest 2+ -- print =<< boolTest 4++ -- putStrLn "\n-- maybeOrdering Test --"+ -- print =<< maybeOrderingTest (Just LT)++ -- putStrLn "\n-- Rearrange Tuples Test --"+ -- print =<< rearrangeTuples (4, 5) (-6, -4)++ -- putStrLn "\n-- Float Test --"+ -- print =<< floatTest (6.7) (9.5)++ -- putStrLn "\n-- Double Test --"+ -- print =<< doubleTest (2.2) (4.9)++ -- putStrLn "\n-- String Test --"+ -- print =<< stringTest "hiiiiiiiiiiiiiiiit!"++ -- putStrLn "\n-- Import Test --"+ -- print =<< importTest 5++ -- putStrLn "\n-- Infinite Test --"+ -- print =<< infiniteTest [5..]++ -- putStrLn "\n-- Infinite Test 2 --"+ -- print =<< infiniteTest2 [5..] 3++ -- putStrLn "\n-- Infinite Return --"+ -- ir <- infiniteReturn 8+ -- print $ fmap (headInf . tailInf) ir++-- fBad1 :: Float -> Int -> IO (Maybe Int)+-- fBad1 = [g2|(\y z -> \x ? x + 2 == y + z) :: Int -> Int -> Int -> Bool|]++-- fBad2 :: Int -> Int -> IO (Maybe Float)+-- fBad2 = [g2|(\y z -> \x ? x + 2 == y + z) :: Int -> Int -> Int -> Bool|]++-- f :: Int -> Int -> IO (Maybe Int)+-- f = [g2|\(y :: Int) (z :: Int) -> ?(x :: Int) | x + 2 == y + z|]++-- g :: Int -> IO (Maybe (Int, Int))+-- g = [g2|\(a :: Int) -> ?(x :: Int) ?(y :: Int) | x < a && a < y && y - x > 10|]++-- h :: Int -> IO (Maybe [Int])+-- h = [g2|\(total :: Int) -> ?(lst :: [Int]) | sum lst == total && length lst >= 2|]++-- boolTest :: Int -> IO (Maybe Bool)+-- boolTest = [g2|\(i ::Int) -> ?(b :: Bool) | (i == 4) == b|]++-- maybeOrderingTest :: Maybe Ordering -> IO (Maybe (Maybe Ordering))+-- maybeOrderingTest = [g2|\(m1 :: Maybe Ordering) -> ?(m2 :: Maybe Ordering) | (fmap succ m1 == m2)|]++-- rearrangeTuples :: (Int, Int) -> (Int, Int) -> IO (Maybe (Int, Int))+-- rearrangeTuples = [g2|\(ux :: (Int, Int)) (yz :: (Int, Int)) -> ?(ab :: (Int, Int)) |+-- let+-- (u, x) = ux+-- (y, z) = yz+-- (a, b) = ab+-- in+-- (a == u || a == y)+-- && (b == x || b == z) && (a + b == 0 )|]++-- floatTest :: Float -> Float -> IO (Maybe Float)+-- floatTest = [g2|\(f1 :: Float) (f2 :: Float) -> ?(f3 :: Float) | f1 < f3 && f3 < f2|]++-- doubleTest :: Double -> Double -> IO (Maybe Double)+-- doubleTest = [g2|\(d1 :: Double) (d2 :: Double) -> ?(d3 :: Double) | d1 <= d3 && d3 <= d2|]++-- stringTest :: String -> IO (Maybe String)+-- stringTest = [g2|\(str1 :: String) -> ?(str2 :: String) | str1 == str2 ++ "!"|]++-- importTest :: Int -> IO (Maybe Int)+-- importTest = [g2|\(x :: Int) -> ?(ans :: Int) | addTwo x == ans|]++-- infiniteTest :: [Int] -> IO (Maybe Int)+-- infiniteTest = [g2|\(xs :: [Int]) -> ?(x :: Int) | x == head xs|]++-- infiniteTest2 :: [Int] -> Int -> IO (Maybe [Int])+-- infiniteTest2 = [g2|\(xs :: [Int]) (t :: Int) -> ?(ys :: [Int]) | ys == take t xs|]++-- infiniteReturn :: Int -> IO (Maybe (InfList Int))+-- infiniteReturn = [g2|\(t :: Int) -> ?(ys :: InfList Int) | headInf ys == t |]
+ tests_quasiquote/NQueens/Encoding.hs view
@@ -0,0 +1,62 @@+module NQueens.Encoding where++import Data.List++type Queen = Int++indexPairs :: Int -> [(Int,Int)]+indexPairs n = [(i, j) | i <- [0..n-1], j <- [i+1..n-1]]++legal :: Int -> Queen -> Bool+legal n qs = 1 <= qs && qs <= n++queenPairSafe :: Int -> [Queen] -> (Int, Int) -> Bool+queenPairSafe n qs (i, j) =+ let qs_i = qs !! i+ qs_j = qs !! j+ in (qs_i /= qs_j)+ -- && (abs (qs_j - qs_i) /= (j - i))+ && qs_j - qs_i /= j - i+ && qs_j - qs_i /= i - j++allQueensSafe :: Int -> [Queen] -> Bool+allQueensSafe n qs =+ (n == length qs)+ && all (legal n) qs+ && (all (queenPairSafe n qs) (indexPairs n))++solveListCompN :: Int -> [Int]+solveListCompN n =+ head . filter (allQueensSafe n) $ [x | x <- mapM (const [1..n]) [1..n]]++{-+-- Gets all pairs of unique positions+pairs :: Ord a => [a] -> [(a, a)]+pairs xs = [(a, b) | a <- xs, b <- xs, a < b]++-- Checks if all elements of list are unique+allUnique :: Ord a => [a] -> Bool+allUnique xs = length xs == length (nub xs)++-- Check if two positions are safe+pairSafe :: (Queen, Queen) -> Bool+pairSafe ((x1, y1), (x2, y2)) =+ -- No same x and y value+ (x1 /= x2) && (y1 /= y2)+ -- Not on the same diagonal+ && (abs (x1 - x2) /= abs (y1 - y2))++-- Check that all queens in a list are safe+allSafe :: [Queen] -> Bool+allSafe queens = all pairSafe $ pairs queens++-- Valid Queens on an n x n board+legalQueens :: Int -> [Queen] -> Bool+legalQueens n queens =+ (length queens == n)+ && (n == length (nub queens))+ && all (\(x, y) -> 1 <= x && x <= n && 1 <= y && y <= n) queens+ -- && all (\p -> (1, 1) <= p && p <= (n, n)) queens++-}+
+ tests_quasiquote/NQueens/Test.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE QuasiQuotes #-}++module NQueens.Test (queensTestN, allQueensSafe) where++import NQueens.Encoding+import G2.QuasiQuotes.QuasiQuotes++{-+queensTestN :: Int -> IO (Maybe [Queen])+queensTestN n = [g2| \(n :: Int) -> ?(queens :: [Queen]) |+ legalQueens n queens+ && allSafe queens |] n+-}++queensTestN :: Int -> IO (Maybe [Queen])+queensTestN num = [g2| \(n :: Int) -> ?(qs :: [Queen]) |+ allQueensSafe n qs |] num++
+ tests_quasiquote/RegEx/RegEx.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module RegEx.RegEx where++import Data.Data+import G2.QuasiQuotes.G2Rep+++data RegEx = Empty | Epsilon | Atom Char+ | Star RegEx | Concat RegEx RegEx | Or RegEx RegEx+ deriving (Show, Eq, Data)++$(derivingG2Rep ''RegEx)++match :: RegEx -> String -> Bool+match Empty _ = False+match Epsilon s = null s+match (Atom x) s = s == [x]+match (Star _) [] = True+match r@(Star x) s = any (match2 x r)+ (splits [1..length s] s)+match (Concat a b) s = any (match2 a b)+ (splits [0..length s] s)+match (Or a b) s = match a s || match b s++match2 :: RegEx -> RegEx -> (String, String) -> Bool+match2 a b (sa, sb) = match a sa && match b sb++splits :: [Int] -> [a] -> [([a], [a])]+splits ns x = map (\n -> splitAt n x) ns++++
+ tests_quasiquote/RegEx/Test.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE QuasiQuotes #-}++module RegEx.Test where++import RegEx.RegEx+import G2.QuasiQuotes.QuasiQuotes++stringSearch :: RegEx -> IO (Maybe String)+stringSearch = [g2| \(r :: RegEx) -> ?(str :: String) |+ match r str |]+++-- (a + b)* c (d + (e f)*)+regex1 :: RegEx+regex1 =+ Concat (Star (Or (Atom 'a') (Atom 'b')))+ (Concat (Atom 'c')+ (Or (Atom 'd')+ (Concat (Atom 'e')+ (Atom 'f'))))++regex2 :: RegEx+regex2 = Concat (Atom 'a')+ (Concat (Atom 'b')+ (Concat (Atom 'c')+ (Concat (Atom 'd')+ (Concat (Atom 'e')+ ((Atom 'f'))))))++regex3 :: RegEx+regex3 = Or (Atom 'a')+ (Or (Atom 'b')+ (Or (Atom 'c')+ (Or (Atom 'd')+ (Or (Atom 'e')+ ((Atom 'f'))))))++regex4 :: RegEx+regex4 = Concat (Star (Atom 'a'))+ (Concat (Star (Atom 'b'))+ (Concat (Star (Atom 'c'))+ (Concat (Star (Atom 'd'))+ (Concat (Star (Atom 'e'))+ ((Star (Atom 'f')))))))
+ tests_quasiquote/Simple/Simple1.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Simple.Simple1 ( Expr (..)+ , eval+ , num1) where++import Data.Data+import G2.QuasiQuotes.G2Rep++data Expr = Var Int+ | Lam Expr+ | App Expr Expr+ deriving (Show, Read, Eq, Data)++$(derivingG2Rep ''Expr)++type Stack = [Expr]+++eval :: Stack -> Expr -> Expr+eval (e:stck) (Lam e') = eval stck (rep e e')+eval stck (App e1 e2) = eval (e2:stck) e1+eval stck e@(Var _) = foldl1 App (e:stck)++rep :: Expr -> Expr -> Expr+rep e (Var _) = e+rep e (Lam e') = Lam (rep e e')+rep e (App e1 e2) = App (rep e e1) (rep e e2)++num1 :: Expr+num1 = Lam (Var 1)
+ tests_quasiquote/Simple/SimpleTest1.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE QuasiQuotes #-}++module Simple.SimpleTest1 where++import Simple.Simple1+import G2.QuasiQuotes.QuasiQuotes++import RegEx.RegEx as R++sd :: () -> IO (Maybe Expr)+sd =+ [g2| \(e :: ()) -> ?(func :: Expr) | eval [] (App func num1) == num1 |]++af :: Expr -> Bool+af func = (eval [] (App func num1)) == num1