diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +G2 + +Copyright 2019. William Hallahan, Anton Xue. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ +## G2 Haskell Symbolic Execution Engine +--- +#### About +G2 performs lazy symbolic execution of Haskell programs to detect state reachability. +It is capable of generating assertion failure counterexamples and solving for higher-order functions. + +--- + +#### Dependencies +* GHC 8.2.2: https://www.haskell.org/ghc/ +* Custom Haskell Standard Library: https://github.com/AntonXue/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` + + +--- +#### Command line: + +###### Reachability: + +`cabal run G2 ./tests/Samples/Peano.hs add` + +###### LiquidHaskell: + +`cabal run G2 -- --liquid ./tests/Liquid/Peano.hs --liquid-func add` + +###### Arguments: + +* `--n` number of reduction steps to run +* `--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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import DynFlags + +import System.Environment +import System.FilePath + +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T + +import G2.Lib.Printers + +import G2.Config +import G2.Interface +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 :: [String] -> IO () +runWithArgs as = do + + let (src:entry:tail_args) = as + + 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) + (fmap T.pack m_assert) (fmap T.pack m_reaches) + (isJust m_assert || isJust m_reaches || m_retsTrue) + tentry config + + case validate config of + True -> do + r <- validateStates [proj] [src] (T.unpack $ fromJust mb_modname) entry [] [Opt_Hpc] in_out + if r then putStrLn "Validated" else putStrLn "There was an error during validation." + + -- runHPC src (T.unpack $ fromJust mb_modname) entry in_out + False -> return () + + printFuncCalls config entry_f b in_out + + return () + +printFuncCalls :: Config -> Id -> Bindings -> [ExecRes t] -> IO () +printFuncCalls config entry b = + mapM_ (\execr@(ExecRes { final_state = s}) -> do + let funcCall = mkCleanExprHaskell 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 + + putStrLn $ funcCall ++ " = " ++ funcOut) + +ppStatePiece :: Bool -> String -> String -> IO () +ppStatePiece b n res = + case b of + True -> do + putStrLn $ "---" ++ n ++ "---" + putStrLn res + putStrLn "" + False -> return () + +mIDir :: [String] -> Maybe String +mIDir a = strArg "idir" a M.empty Just Nothing + +mReturnsTrue :: [String] -> Bool +mReturnsTrue a = boolArg "returns-true" a M.empty Off + +mAssume :: [String] -> Maybe String +mAssume a = strArg "assume" a M.empty Just Nothing + +mAssert :: [String] -> Maybe String +mAssert a = strArg "assert" a M.empty Just Nothing + +mReaches :: [String] -> Maybe String +mReaches a = strArg "reaches" a M.empty Just Nothing + +mkLiquid :: [String] -> Maybe String +mkLiquid a = strArg "liquid" a M.empty Just Nothing + +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 diff --git a/g2.cabal b/g2.cabal new file mode 100644 --- /dev/null +++ b/g2.cabal @@ -0,0 +1,229 @@ +-- Initial G2.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: g2 +version: 0.1.0.0 +synopsis: Haskell symbolic execution engine. +description: A Haskell symbolic execution engine. + + For details, please see: +License: BSD3 +License-file: LICENSE +author: William Hallahan, Anton Xue +maintainer: william.hallahan@yale.edu +-- copyright: +category: Formal Methods, Symbolic Computation +build-type: Simple +extra-source-files: README.md +cabal-version: 1.24 + +source-repository head + type: git + location: https://github.com/BillHallahan/G2.git + +library + exposed-modules: + G2.Config + + , G2.Execution + , G2.Execution.Interface + , G2.Execution.Memory + , G2.Execution.NormalForms + , G2.Execution.PrimitiveEval + , G2.Execution.Reducer + , G2.Execution.Rules + , G2.Execution.RuleTypes + + , G2.Initialization.Interface + , G2.Initialization.DeepSeqWalks + , G2.Initialization.ElimTicks + , G2.Initialization.ElimTypeSynonyms + , G2.Initialization.InitVarLocs + , G2.Initialization.KnownValues + , G2.Initialization.MkCurrExpr + , G2.Initialization.StructuralEq + , G2.Initialization.Types + + , G2.Interface + + , G2.Language + , G2.Language.AlgDataTy + , G2.Language.ArbValueGen + , G2.Language.AST + , G2.Language.Casts + , G2.Language.CreateFuncs + , G2.Language.Expr + , G2.Language.ExprEnv + , G2.Language.Ids + , G2.Language.KnownValues + , G2.Language.Located + , G2.Language.Monad + , G2.Language.Monad.AST + , G2.Language.Monad.CreateFuncs + , G2.Language.Monad.Expr + , G2.Language.Monad.ExprEnv + , G2.Language.Monad.Naming + , G2.Language.Monad.Primitives + , G2.Language.Monad.Support + , G2.Language.Monad.TypeClasses + , G2.Language.Monad.TypeEnv + , G2.Language.Monad.Typing + , G2.Language.Naming + , G2.Language.PathConds + , G2.Language.Primitives + , G2.Language.Stack + , G2.Language.Support + , G2.Language.Syntax + , G2.Language.TypeClasses + , G2.Language.TypeClasses.Extra + , G2.Language.TypeClasses.TypeClasses + , G2.Language.TypeEnv + , G2.Language.Typing + + , G2.Lib.Printers + + , G2.Liquid.Interface + + , G2.Postprocessing.Interface + + , G2.Preprocessing.AdjustTypes + , G2.Preprocessing.Interface + , G2.Preprocessing.NameCleaner + + , G2.Solver + , G2.Solver.Interface + , G2.Solver.Solver + + , G2.QuasiQuotes.Internals.G2Rep + , G2.QuasiQuotes.FloodConsts + , G2.QuasiQuotes.G2Rep + , G2.QuasiQuotes.Parser + , G2.QuasiQuotes.QuasiQuotes + , G2.QuasiQuotes.Support + + , 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.Haskell + , G2.Translation.HaskellCheck + , G2.Translation.InjectSpecials + , G2.Translation.Interface + , 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 + , 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 + , 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 + , reducers >= 3.12 && < 3.13 + , regex-compat >= 0.95 && < 0.96 + , regex-base >= 0.93 && < 0.94 + , parsec >= 3.1 && < 3.2 + , process >=1 && < 1.7 + , split >= 0.2.3 && < 0.2.4 + , template-haskell == 2.12.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 + default-language: Haskell2010 + ghc-options: -Wall + -- -ddump-splices + -- -fprof-auto + -- -fexternal-interpreter -opti+RTS -opti-p + hs-source-dirs: src + +executable G2 + -- other-modules: + -- 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 + , unordered-containers >= 0.2 && < 0.3 + default-language: Haskell2010 + ghc-options: -threaded -Wall + -- -fprof-auto "-with-rtsopts=-p" + hs-source-dirs: exe + main-is: Main.hs + +executable QuasiQuote + -- other-modules: + -- other-extensions: + build-depends: g2 + , base >= 4.8 && < 5 + , time >= 1.6 && <= 1.9.3 + default-language: Haskell2010 + ghc-options: -Wall + -- -ddump-splices + -- -fprof-auto "-with-rtsopts=-p" + hs-source-dirs: quasiquote + main-is: Main.hs + +test-suite test + build-depends: g2 + , base >= 4.8 && < 5 + , containers >= 0.5 && < 0.6 + , filepath + , ghc-paths >= 0.1 && < 0.2 + , ghc + , hashable + , hpc + , tagged + , tasty >= 1.0 + , tasty-hunit >= 0.10 + , text + , time >= 1.6 + , unordered-containers + default-language: Haskell2010 + hs-source-dirs: tests + main-is: Test.hs + ghc-options: -Wall + -- -fprof-auto "-with-rtsopts=-p" + -threaded + type: exitcode-stdio-1.0 diff --git a/quasiquote/Main.hs b/quasiquote/Main.hs new file mode 100644 --- /dev/null +++ b/quasiquote/Main.hs @@ -0,0 +1,255 @@ +{-# 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 |] diff --git a/src/G2/Config.hs b/src/G2/Config.hs new file mode 100644 --- /dev/null +++ b/src/G2/Config.hs @@ -0,0 +1,5 @@ +module G2.Config ( module G2.Config.Config + , module G2.Config.Interface ) where + +import G2.Config.Config +import G2.Config.Interface diff --git a/src/G2/Config/Config.hs b/src/G2/Config/Config.hs new file mode 100644 --- /dev/null +++ b/src/G2/Config/Config.hs @@ -0,0 +1,182 @@ +module G2.Config.Config ( Mode (..) + , SMTSolver (..) + , HigherOrderSolver (..) + , IncludePath + , Config (..) + , BoolDef (..) + , mkConfig + , strArg + , boolArg) where + + +import Data.Char +import Data.List +import qualified Data.Map as M + +import System.Directory + + +data Mode = Regular | Liquid deriving (Eq, Show, Read) + +data SMTSolver = ConZ3 | ConCVC4 deriving (Eq, Show, Read) + +data HigherOrderSolver = AllFuncs + | SingleFunc deriving (Eq, Show, Read) + +type IncludePath = FilePath + +data Config = Config { + mode :: Mode + , baseInclude :: [IncludePath] + , 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 + , 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 + , 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 + , 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] +} + +-- mkConfigDef :: Config +-- mkConfigDef = mkConfig [] M.empty + +baseRoot :: IO FilePath +baseRoot = do + g2Dir <- getHomeDirectory >>= \f -> return $ f ++ "/.g2" + return $ g2Dir ++ "/base-4.9.1.0" + + +mkConfig :: String -> [String] -> M.Map String [String] -> Config +mkConfig 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 + , 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 + , 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 + , 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 = + [ 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" + ] + +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 + +smtSolverArg' :: String -> SMTSolver +smtSolverArg' "z3" = ConZ3 +smtSolverArg' "cvc4" = ConCVC4 +smtSolverArg' _ = error "Unrecognized SMT solver." + +higherOrderSolArg :: String -> HigherOrderSolver +higherOrderSolArg = higherOrderSolArg' . map toLower + +higherOrderSolArg' :: String -> HigherOrderSolver +higherOrderSolArg' "all" = AllFuncs +higherOrderSolArg' "single" = SingleFunc +higherOrderSolArg' _ = error "Unrecognized higher order solver." + +data BoolDef = On | Off deriving (Eq, Show) + +-- If the given string is on the command line, returns True +-- If --no-[str] is on the command line, returns False +-- otherwise, looks in the config file, and if there is not option there, +-- uses the default to decide +boolArg :: String -> [String] -> M.Map String [String] -> BoolDef -> Bool +boolArg s a m bd = + let + d = if bd == On then True else False + in + if "--" ++ s `elem` a + then True + else if "--no-" ++ s `elem` a + then False + else case M.lookup s m of + Just st -> strToBool st d + Nothing -> d + +strToBool :: [String] -> Bool -> Bool +strToBool [s] b + | s' == "true" = True + | s' == "1" = True + | s' == "false" = False + | s' == "0" = False + | otherwise = b + where + s' = map toLower s +strToBool _ b = b + +--Converts strings arguments to arbitrary types +strArg :: String -> [String] -> M.Map String [String] -> (String -> a) -> a -> a +strArg 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 -> strToArg st f d + Nothing -> d + +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 diff --git a/src/G2/Config/Interface.hs b/src/G2/Config/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Config/Interface.hs @@ -0,0 +1,39 @@ +module G2.Config.Interface where + +import G2.Config.Config +import G2.Config.ParseConfig + +import qualified Data.Map as M +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 + + homedir <- getHomeDirectory + case ex of + True -> do + conf <- parseConfig con + + 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) + +configExists :: FilePath -> IO Bool +configExists cn = do + ex <- doesFileExist cn + + case ex of + True -> return () + False -> putStrLn $ "Configuration file " ++ cn ++ " missing" + + return ex diff --git a/src/G2/Config/ParseConfig.hs b/src/G2/Config/ParseConfig.hs new file mode 100644 --- /dev/null +++ b/src/G2/Config/ParseConfig.hs @@ -0,0 +1,54 @@ +module G2.Config.ParseConfig (parseConfig) where + +import Text.ParserCombinators.Parsec.Language + +import Text.Parsec (Parsec) +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as Token + +import qualified Data.Map as M + +configDef :: LanguageDef st +configDef = + emptyDef { Token.commentStart = "{-" + , Token.commentEnd = "-}" + , Token.commentLine = "--" + , Token.nestedComments = False + , Token.identStart = noneOf [' ', '\t', '=', ',', '\n', '\r'] + , Token.identLetter = noneOf [' ', '\t', '=', ',', '\n', '\r'] + , Token.reservedNames = ["="]} + +configLexer :: Token.TokenParser st +configLexer = Token.makeTokenParser configDef + +identifier :: Parsec String st String +identifier = Token.identifier configLexer + +spacedComma :: Parser () +spacedComma = do + spaces + _ <- char ',' + spaces + return () + +parseSetting :: Parser (String, [String]) +parseSetting = do + key <- identifier + spaces + _ <- char '=' + spaces + val <- sepBy identifier spacedComma + return (key, val) + +parseLine :: Parser (String, [String]) +parseLine = do + kv <- parseSetting + spaces <|> eof + return kv + +parseFile :: Parser [(String, [String])] +parseFile = many parseLine + +parseConfig :: String -> IO (Either ParseError (M.Map String [String])) +parseConfig nm = + parseFromFile parseFile nm >>= return . fmap (M.fromList) diff --git a/src/G2/Execution.hs b/src/G2/Execution.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution.hs @@ -0,0 +1,14 @@ +-- | Execution +-- Export module for G2.Interanls.Execution. +module G2.Execution + ( module G2.Execution.Interface + , module G2.Execution.Reducer + , module G2.Execution.Rules + , module G2.Execution.Memory + ) where + +import G2.Execution.Interface +import G2.Execution.Reducer +import G2.Execution.Rules +import G2.Execution.Memory + diff --git a/src/G2/Execution/Interface.hs b/src/G2/Execution/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution/Interface.hs @@ -0,0 +1,21 @@ +-- | Interface +-- Module for interacting and interfacing with the symbolic execution engine. +module G2.Execution.Interface + ( runExecutionToProcessed + , runExecution + , stdReduce + ) where + +import G2.Execution.Reducer +import G2.Execution.Rules +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 = 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 r h ord s b = do + (pr, b') <- runReducer r h ord s b + return (accepted pr, b') diff --git a/src/G2/Execution/Memory.hs b/src/G2/Execution/Memory.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution/Memory.hs @@ -0,0 +1,77 @@ +module G2.Execution.Memory + ( markAndSweep + , markAndSweepIgnoringKnownValues + , markAndSweepPreserving + ) where + +import G2.Language.Syntax +import G2.Language.Support +import G2.Language.Naming +import qualified G2.Language.ExprEnv as E +import G2.Language.Typing + +import Data.List +import qualified Data.HashSet as S +import qualified Data.Map as M + + +markAndSweep :: State t -> Bindings -> (State t, Bindings) +markAndSweep s = markAndSweepPreserving [] s + +markAndSweepIgnoringKnownValues :: State t -> Bindings -> (State t, Bindings) +markAndSweepIgnoringKnownValues = markAndSweepPreserving' [] + +markAndSweepPreserving :: [Name] -> State t -> Bindings -> (State t, Bindings) +markAndSweepPreserving ns s = markAndSweepPreserving' (ns ++ names (known_values s)) s + +markAndSweepPreserving' :: [Name] -> State t -> Bindings -> (State t, Bindings) +markAndSweepPreserving' ns (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 + (state', bindings') + where + state' = state { expr_env = eenv' + , type_env = tenv' + } + bindings' = bindings { deepseq_walkers = dsw'} + + active = activeNames tenv eenv S.empty $ names cexpr ++ + names es ++ + names pc ++ + names iids ++ + higher_ord_rel ++ + ns + + isActive :: Name -> Bool + isActive = (flip S.member) active + + eenv' = E.filterWithKey (\n _ -> isActive n) eenv + tenv' = M.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 + diff --git a/src/G2/Execution/NormalForms.hs b/src/G2/Execution/NormalForms.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution/NormalForms.hs @@ -0,0 +1,46 @@ +module G2.Execution.NormalForms where + +import G2.Language +import qualified G2.Language.Stack as S +import qualified G2.Language.ExprEnv as E + +-- | 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`. +-- +-- So in this context, the following are considered NOT-value forms: +-- `Var`, only if a lookup still available in the expression environment. +-- `App`, which involves pushing the RHS onto the `Stack`, if the center is not a Prim or DataCon +-- `Let`, which involves binding the binds into the eenv +-- `Case`, which involves pattern decomposition and stuff. +isExprValueForm :: E.ExprEnv -> Expr -> Bool +isExprValueForm eenv (Var var) = + E.lookup (idName var) eenv == Nothing || E.isSymbolic (idName var) eenv +isExprValueForm eenv (App f a) = case unApp (App f a) of + (Prim _ _:xs) -> all (isExprValueForm eenv) xs + (Data _:_) -> True + ((Var _):_) -> False + _ -> False +isExprValueForm _ (Let _ _) = 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 _ (Assume _ _ _) = False +isExprValueForm _ (Assert _ _ _) = False +isExprValueForm _ _ = True + +-- | Is the execution state in a value form of some sort? This would entail: +-- * The `Stack` is empty. +-- * The `ExecCode` is in a `Return` form. +-- * We have no path conds to reduce +isExecValueForm :: State t -> Bool +isExecValueForm state | Nothing <- S.pop (exec_stack state) + , CurrExpr Return _ <- curr_expr state + , non_red_path_conds state == [] = True + | otherwise = False + + +isExecValueFormDisNonRedPC :: State t -> Bool +isExecValueFormDisNonRedPC s = isExecValueForm $ s {non_red_path_conds = []} diff --git a/src/G2/Execution/PrimitiveEval.hs b/src/G2/Execution/PrimitiveEval.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution/PrimitiveEval.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} + +module G2.Execution.PrimitiveEval (evalPrims, evalPrim) where + +import G2.Language.AST +import G2.Language.Expr +import G2.Language.Support +import G2.Language.Syntax + +evalPrims :: ASTContainer m Expr => KnownValues -> m -> m +evalPrims kv = modifyContainedASTs (evalPrims' kv . simplifyCasts) + +evalPrim :: KnownValues -> Expr -> Expr +evalPrim kv a@(App _ _) = + 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 + + +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 + +evalPrim' :: KnownValues -> [Expr] -> Expr +evalPrim' kv xs + | [Prim p _, x] <- xs + , Lit x' <- getLit x = + case evalPrim1 p x' of + Just e -> e + Nothing -> mkApp xs + + | [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 + + | otherwise = mkApp xs + +getLit :: Expr -> Expr +getLit l@(Lit _) = l +getLit x = x + +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 SqRt x = evalPrim1Floating (sqrt) x +evalPrim1 IntToFloat (LitInt x) = Just . Lit $ LitFloat (fromIntegral x) +evalPrim1 IntToDouble (LitInt x) = Just . Lit $ LitDouble (fromIntegral 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 _ 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 _ 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 _ _ _ _ = 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 + +evalPrim2Num :: (forall a . Num a => a -> a -> a) -> Lit -> Lit -> Maybe Expr +evalPrim2Num f (LitInt x) (LitInt y) = Just . Lit . LitInt $ f x y +evalPrim2Num f (LitFloat x) (LitFloat y) = Just . Lit . LitFloat $ f x y +evalPrim2Num f (LitDouble x) (LitDouble y) = Just . Lit . LitDouble $ f x y +evalPrim2Num _ _ _ = Nothing + +evalPrim2Fractional :: (forall a . Fractional a => a -> a -> a) -> Lit -> Lit -> Maybe Expr +evalPrim2Fractional f (LitFloat x) (LitFloat y) = Just . Lit . LitFloat $ f x y +evalPrim2Fractional f (LitDouble x) (LitDouble y) = Just . Lit . LitDouble $ f x y +evalPrim2Fractional _ _ _ = Nothing + +evalPrim2Integral :: (forall a . Integral a => a -> a -> a) -> Lit -> Lit -> Maybe Expr +evalPrim2Integral f (LitInt x) (LitInt y) = Just . Lit . LitInt $ f x y +evalPrim2Integral _ _ _ = Nothing + +evalPrim1Floating :: (forall a . Floating a => a -> a) -> Lit -> Maybe Expr +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 diff --git a/src/G2/Execution/Reducer.hs b/src/G2/Execution/Reducer.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution/Reducer.hs @@ -0,0 +1,933 @@ +{-# 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 diff --git a/src/G2/Execution/RuleTypes.hs b/src/G2/Execution/RuleTypes.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution/RuleTypes.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module G2.Execution.RuleTypes where + +import Data.Data (Data, Typeable) + +import G2.Language.AST +import G2.Language.Naming +import G2.Language.Syntax + +data Rule = RuleEvalVal + | RuleEvalVarNonVal Name + | RuleEvalVarVal Name + | RuleEvalUnInt + | RuleEvalApp Expr + + | RuleEvalPrimAlreadyNorm + | RuleEvalPrimToNorm + + | RuleEvalLet [Name] + + | RuleEvalCaseData [Name] + | RuleEvalCaseLit + | RuleEvalCaseDefault + | RuleEvalCaseSym + | RuleEvalCasePrim + | RuleEvalCaseNonVal + + | RuleEvalCastSplit + | RuleEvalCast + + | RuleEvalAssume + | RuleEvalAssert + + | RuleReturnEUpdateVar Name + | RuleReturnEUpdateNonVar Name + + | RuleReturnAppSWHNF + + | RuleReturnECase + + | RuleReturnCast + + | RuleReturnEApplyLamExpr [Name] + | RuleReturnEApplyLamType [Name] + | RuleReturnEApplyData + | RuleReturnEApplySym + + | RuleReturnCAssume + | RuleReturnCAssert + + | RuleIdentity + | RulePrimError + + | RuleAnnotation + + | RuleReturnAppSymbFunc + | RuleReturnReplaceSymbFunc + + | RuleNonDet + | RuleSymGen + + | RuleReturnCurrExprFr + + | RuleError + + | RuleBind + + | RuleReturn + + | RuleTick + + | RuleOther + deriving (Show, Eq, Read, Typeable, Data) + +instance AST e => ASTContainer Rule e where + containedASTs _ = [] + modifyContainedASTs _ r = r + +instance Named Rule where + names _ = [] + rename _ _ = id diff --git a/src/G2/Execution/Rules.hs b/src/G2/Execution/Rules.hs new file mode 100644 --- /dev/null +++ b/src/G2/Execution/Rules.hs @@ -0,0 +1,810 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Execution.Rules ( module G2.Execution.RuleTypes + , stdReduce + , evalVar + , evalApp + , evalLam + , retLam + , evalLet + , evalCase + , evalCast + , evalTick + , evalNonDet + , evalSymGen + , evalAssume + , evalAssert + + , isExecValueForm ) where + +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.KnownValues as KV +import qualified G2.Language.PathConds as PC +import qualified G2.Language.Stack as S +import G2.Solver hiding (Assert) + +import Control.Monad.Extra +import Data.Maybe + +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 + 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 + | 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 + 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 + | 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 + , 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) + | 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' + | Just (CastFrame c, stck') <- frstck = return $ retCastFrame s ng ce c stck' + | Just (AssumeFrame e, stck') <- frstck = do + let (r, xs, ng') = retAssumeFrame s ng ce e stck' + xs' <- mapMaybeM (reduceNewPC solver) 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 + return (r, xs', ng') + | Just (CurrExprFrame e, stck') <- frstck = do + let (r, xs) = retCurrExpr s ce e stck' + xs' <- mapMaybeM (reduceNewPC solver) 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 + + if res == SAT then + return $ Just s' + else + return Nothing + | otherwise = return $ Just s + +evalVar :: State t -> NameGen -> Id -> (Rule, [State t], NameGen) +evalVar s@(State { expr_env = eenv + , exec_stack = stck }) + 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) + | otherwise = error $ "evalVar: bad input." ++ show i + +-- | If we have a primitive operator, we are at a point where either: +-- (1) We can concretely evaluate the operator, or +-- (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 s@(State { expr_env = eenv + , 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) + | (Prim prim ty):ar <- unApp (App e1 e2) = + let + ar' = map (lookupForPrim eenv) ar + appP = mkApp (Prim prim ty : ar') + exP = evalPrims kv appP + in + ( RuleEvalPrimToNorm + , [s { curr_expr = CurrExpr Return exP }] + , ng) + | otherwise = + let + frame = ApplyFrame e2 + stck' = S.push frame stck + in + ( RuleEvalApp e2 + , [s { curr_expr = CurrExpr Evaluate e1 + , exec_stack = stck' }] + , ng) + where + findSym v@(Var (Id n _)) + | E.isSymbolic n eenv = v + | Just e <- E.lookup n eenv = findSym e + findSym _ = error "findSym: No symbolic variable" + +lookupForPrim :: ExprEnv -> Expr -> Expr +lookupForPrim eenv v@(Var (Id _ _)) = repeatedLookup eenv v +lookupForPrim eenv (App e e') = App (lookupForPrim eenv e) (lookupForPrim eenv e') +lookupForPrim _ e = e + +repeatedLookup :: ExprEnv -> Expr -> Expr +repeatedLookup eenv v@(Var (Id n _)) + | E.isSymbolic n eenv = v + | otherwise = + case E.lookup n eenv of + Just v'@(Var _) -> repeatedLookup eenv v' + Just e -> e + Nothing -> v +repeatedLookup _ e = e + +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 + Just t -> + let + e' = retype i t e + + binds = [(i, Type t)] + (eenv', e'', ng', news) = liftBinds binds eenv e' ng + in + ( 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 = + let + binds = [(i, ae)] + (eenv', e', ng', news) = liftBinds binds eenv e ng + in + ( 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 +traceType eenv (Var (Id n _)) = traceType eenv =<< E.lookup n eenv +traceType _ _ = Nothing + +evalLet :: State t -> NameGen -> Binds -> Expr -> (Rule, [State t], NameGen) +evalLet s@(State { expr_env = eenv }) + ng binds e = + let + (binds_lhs, binds_rhs) = unzip binds + + olds = map idName binds_lhs + (news, ng') = freshSeededNames olds ng + + e' = renameExprs (zip olds news) e + binds_rhs' = renameExprs (zip olds news) binds_rhs + + eenv' = E.insertExprs (zip news binds_rhs') eenv + in + (RuleEvalLet news, [s { expr_env = eenv' + , curr_expr = CurrExpr Evaluate e'}] + , ng') + +-- | Handle the Case forms of Evaluate. +evalCase :: State t -> NameGen -> Expr -> Id -> [Alt] -> (Rule, [NewPC t], NameGen) +evalCase s@(State { expr_env = eenv + , exec_stack = stck }) + ng mexpr bind 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 + , (Alt (LitAlt _) expr):_ <- matchLitAlts lit alts = + let + binds = [(bind, Lit lit)] + expr' = liftCaseBinds binds expr + in ( RuleEvalCaseLit + , [newPCEmpty $ s { expr_env = eenv + , curr_expr = CurrExpr Evaluate expr' }], ng) + + -- Is the current expression able to match a data consturctor based `Alt`? + -- If so, then we bind all the parameters to the appropriate arguments and + -- proceed with the evaluation of the `Alt`'s expression. We also make sure + -- to perform the cvar binding. + -- We unwrap the outermost cast from the mexpr. It must be being cast + -- to the DataCon type, so this is safe, and needed for our pattern matching. + -- We do not want to remove casting from any of the arguments since this could + -- mess up there types later + | (Data dcon):ar <- unApp $ exprInCasts mexpr + , (DataCon _ _) <- dcon + , ar' <- removeTypes ar eenv + , (Alt (DataAlt _ params) expr):_ <- matchDataAlts dcon alts + , length params == length ar' = + let + dbind = [(bind, mexpr)] + expr' = liftCaseBinds dbind expr + pbinds = zip params ar' + (eenv', expr'', ng', news) = liftBinds pbinds eenv expr' ng + in + ( RuleEvalCaseData news + , [newPCEmpty $ s { expr_env = eenv' + , curr_expr = CurrExpr Evaluate expr''}] + , ng') + + -- We are not able to match any constructor but don't have a symbolic variable? + -- We hit a DEFAULT instead. + -- We perform the cvar binding and proceed with the alt + -- expression. + | (Data _):_ <- unApp $ unsafeElimOuterCast mexpr + , (Alt _ expr):_ <- matchDefaultAlts alts = + let + binds = [(bind, mexpr)] + expr' = liftCaseBinds binds expr + in ( RuleEvalCaseDefault + , [newPCEmpty $ s { expr_env = eenv + , curr_expr = CurrExpr Evaluate expr' }], ng) + + -- If we are pointing to something in expr value form, that is not addressed + -- by some previous case, we handle it by branching on every `Alt`, and adding + -- path constraints. + | isExprValueForm eenv mexpr + , dalts <- dataAlts alts + , lalts <- litAlts alts + , defs <- defaultAlts alts + , (length dalts + length lalts + length defs) > 0 = + let + (cast, expr) = case mexpr of + (Cast e c) -> (Just c, e) + _ -> (Nothing, mexpr) + + (dsts_cs, ng') = case unApp $ unsafeElimOuterCast expr of + (Var i@(Id _ _)):_ -> concretizeVarExpr s ng i bind dalts cast + (Prim _ _):_ -> createExtConds s ng expr bind dalts + (Lit _):_ -> ([], ng) + (Data _):_ -> ([], ng) + _ -> error $ "unmatched expr" ++ show (unApp $ unsafeElimOuterCast mexpr) + + lsts_cs = liftSymLitAlt s mexpr bind lalts + def_sts = liftSymDefAlt s mexpr bind alts + in + (RuleEvalCaseSym, dsts_cs ++ lsts_cs ++ def_sts, 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 + -- as a `CaseFrame` along with their appropriate `ExecExprEnv`. However this + -- 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 + in ( RuleEvalCaseNonVal + , [newPCEmpty $ s { expr_env = eenv + , curr_expr = CurrExpr Evaluate mexpr + , exec_stack = S.push frame stck }], ng) + + | otherwise = error $ "reduceCase: bad case passed in\n" ++ show mexpr ++ "\n" ++ show alts + +-- | 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 (e:es) eenv = e : removeTypes es eenv +removeTypes [] _ = [] + +-- | DEFAULT `Alt`s. +matchDefaultAlts :: [Alt] -> [Alt] +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'] + +-- | Match literal constructor based `Alt`s. +matchLitAlts :: Lit -> [Alt] -> [Alt] +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 + +-- | `DataCon` `Alt`s. +dataAlts :: [Alt] -> [(DataCon, [Id], Expr)] +dataAlts alts = [(dcon, ps, aexpr) | Alt (DataAlt dcon ps) aexpr <- alts] + +-- | `Lit` `Alt`s. +litAlts :: [Alt] -> [(Lit, Expr)] +litAlts alts = [(lit, aexpr) | Alt (LitAlt lit) aexpr <- alts] + +-- | DEFAULT `Alt`s. +defaultAlts :: [Alt] -> [Alt] +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 +-- their occurrence in the aexpr to something fresh. +concretizeVarExpr :: State t -> NameGen -> Id -> Id -> [(DataCon, [Id], Expr)] -> Maybe Coercion -> ([NewPC t], NameGen) +concretizeVarExpr _ ng _ _ [] _ = ([], ng) +concretizeVarExpr s ng mexpr_id cvar (x:xs) maybeC = + (x':newPCs, ng'') + where + (x', ng') = concretizeVarExpr' s ng mexpr_id cvar x maybeC + (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 = + (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 + -- 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') + 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 + + --Update the expr environment + newIds = map (\(Id _ t, n) -> (n, Id n t)) (zip params news) + eenv' = foldr (uncurry E.insertSymbolic) eenv newIds + + (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 + + -- Apply list of types (if present) and DataCon children to DataCon + dcon'' = mkApp exprs + + -- Apply cast, in opposite direction of unsafeElimOuterCast + dcon''' = case maybeC of + (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' + + +-- | 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 + -- 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 + | otherwise = typeToExpr mexpr_t + +-- | Given a DataCon, and an (Id, Type) mapping, returns list of Expression level Type Arguments to DataCon +dconTyToExpr :: DataCon -> [(Id, Type)] -> [Expr] +dconTyToExpr (DataCon _ t) bindings = + case (getTyApps t) of + (Just tApps) -> tyAppsToExpr tApps bindings + Nothing -> [] + +createExtConds :: State t -> NameGen -> Expr -> Id -> [(DataCon, [Id], Expr)] -> ([NewPC t], NameGen) +createExtConds _ ng _ _ [] = ([], ng) +createExtConds s ng mexpr cvar (x:xs) = + (x':newPCs, ng'') + where + (x', ng') = createExtCond s ng mexpr cvar x + (newPCs, ng'') = createExtConds s ng' mexpr cvar xs + +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 + + -- Now do a round of rename for binding the cvar. + binds = [(cvar, mexpr)] + aexpr' = liftCaseBinds binds aexpr + res = s {curr_expr = CurrExpr Evaluate aexpr'} + +getBoolFromDataCon :: State t -> DataCon -> Bool +getBoolFromDataCon (State {known_values = kv}) dcon + | (DataCon dconName dconType) <- dcon + , dconType == (tyBool kv) + , dconName == (KV.dcTrue kv) = True + | (DataCon dconName dconType) <- dcon + , dconType == (tyBool kv) + , dconName == (KV.dcFalse kv) = False + | otherwise = error $ "getBoolFromDataCon: invalid DataCon passed in\n" ++ show dcon ++ "\n" + +liftSymLitAlt :: State t -> Expr -> Id -> [(Lit, Expr)] -> [NewPC t] +liftSymLitAlt s mexpr cvar = map (liftSymLitAlt' s mexpr cvar) + +-- | 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] } + where + -- Condition that was matched. + cond = AltCond lit mexpr True + -- Bind the cvar. + binds = [(cvar, Lit lit)] + aexpr' = liftCaseBinds binds aexpr + res = s { curr_expr = CurrExpr Evaluate aexpr' } + +liftSymDefAlt :: State t -> Expr -> Id -> [Alt] -> [NewPC t] +liftSymDefAlt s mexpr cvar as = + let + aexpr = defAltExpr as + in + case aexpr of + Just aexpr' -> liftSymDefAlt' s mexpr aexpr' cvar as + _ -> [] + +liftSymDefAlt' :: State t -> Expr -> Expr -> Id -> [Alt] -> [NewPC t] +liftSymDefAlt' s mexpr aexpr cvar as = + let + conds = mapMaybe (liftSymDefAltPCs mexpr) (map altMatch as) + + binds = [(cvar, mexpr)] + aexpr' = liftCaseBinds binds aexpr + in + [NewPC { state = s { curr_expr = CurrExpr Evaluate aexpr' } + , new_pcs = conds }] + +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 + +evalCast :: State t -> NameGen -> Expr -> Coercion -> (Rule, [State t], NameGen) +evalCast s@(State { exec_stack = stck }) + ng e c + | cast /= cast' = + ( RuleEvalCastSplit + , [ s { curr_expr = CurrExpr Evaluate $ simplifyCasts cast' }] + , ng') + | otherwise = + ( RuleEvalCast + , [s { curr_expr = CurrExpr Evaluate $ simplifyCasts e + , 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) +evalTick s ng _ e = (RuleTick, [ s { curr_expr = CurrExpr Evaluate e }], ng) + +evalNonDet :: State t -> NameGen -> [Expr] -> (Rule, [State t], NameGen) +evalNonDet s ng es = + let + s' = map (\e -> s { curr_expr = CurrExpr Evaluate e }) es + in + (RuleNonDet, s', ng) + +evalSymGen :: State t -> NameGen -> Type -> (Rule, [State t], NameGen) +evalSymGen s@( State { expr_env = eenv }) + ng t = + let + (n, ng') = freshSeededString "symG" ng + i = Id n t + + eenv' = E.insertSymbolic n i eenv + in + (RuleSymGen, [s { expr_env = eenv' + , curr_expr = CurrExpr Evaluate (Var i) + , symbolic_ids = i:symbolic_ids s }] + , ng') + +evalAssume :: State t -> NameGen -> Maybe FuncCall -> Expr -> Expr -> (Rule, [State t], NameGen) +evalAssume s@(State { exec_stack = stck }) ng _ e1 e2 = + let + fr = AssumeFrame e2 + stck' = S.push fr stck + in + ( RuleEvalAssume + , [ s { curr_expr = CurrExpr Evaluate e1 + , exec_stack = stck' }] + , ng) + +evalAssert :: State t -> NameGen -> Maybe FuncCall -> Expr -> Expr -> (Rule, [State t], NameGen) +evalAssert s@(State { exec_stack = stck }) ng is e1 e2 = + let + fr = AssertFrame is e2 + stck' = S.push fr stck + in + ( RuleEvalAssert + , [ s { curr_expr = CurrExpr Evaluate e1 + , exec_stack = stck' }] + , ng) + +retUpdateFrame :: State t -> NameGen -> Name -> S.Stack Frame -> (Rule, [State t], NameGen) +retUpdateFrame s@(State { expr_env = eenv + , curr_expr = CurrExpr _ e}) ng un stck + | Var i@(Id vn _) <- e = + ( RuleReturnEUpdateVar un + , [s { expr_env = E.redirect un vn eenv + , curr_expr = CurrExpr Return (Var i) + , exec_stack = stck }] + , ng) + | otherwise = + ( RuleReturnEUpdateNonVar un + , [s { expr_env = E.insert un e eenv + , exec_stack = stck }] + , ng) + +retApplyFrame :: State t -> NameGen -> Expr -> Expr -> S.Stack Frame -> (Rule, [State t], NameGen) +retApplyFrame s@(State { expr_env = eenv }) ng e1 e2 stck' + | Var (Id n _):_ <- unApp e1 + , E.isSymbolic n eenv = + ( RuleReturnEApplySym + , [s { curr_expr = CurrExpr Return (App e1 e2) + , exec_stack = stck' }], ng) + | otherwise = + ( RuleReturnEApplySym + , [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 = + ( RuleReturnECase + , [s { curr_expr = CurrExpr Evaluate (Case e i a) + , exec_stack = stck }] + , b) + +retCastFrame :: State t -> NameGen -> Expr -> Coercion -> S.Stack Frame -> (Rule, [State t], NameGen) +retCastFrame s ng e c stck = + ( RuleReturnCast + , [s { curr_expr = CurrExpr Return $ simplifyCasts $ Cast e c + , exec_stack = stck}] + , ng) + +retCurrExpr :: State t -> Expr -> CurrExpr -> S.Stack Frame -> (Rule, [NewPC t]) +retCurrExpr s e1 e2 stck = + ( RuleReturnCurrExprFr + , [NewPC { state = s { curr_expr = e2 + , exec_stack = stck} + , new_pcs = [ExtCond e1 True]}] ) + +retAssumeFrame :: State t -> NameGen -> Expr -> Expr -> S.Stack Frame -> (Rule, [NewPC t], NameGen) +retAssumeFrame s@(State {known_values = kv + , type_env = tenv}) + ng e1 e2 stck = + let + -- Create a True Bool DataCon + 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 + (newPCs, ng') = case unApp $ unsafeElimOuterCast e1 of + (Var i@(Id _ _)):_ -> concretizeExprToBool s ng i dalt e2 stck + _ -> addExtCond s ng e1 e2 True stck + in + (RuleReturnCAssume, newPCs, ng') + +retAssertFrame :: State t -> NameGen -> Expr -> Maybe (FuncCall) -> Expr -> S.Stack Frame -> (Rule, [NewPC t], NameGen) +retAssertFrame s@(State {known_values = kv + , type_env = tenv}) + ng e1 ais e2 stck = + let + -- Create True and False Bool DataCons + 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 + (newPCs, ng') = case unApp $ unsafeElimOuterCast e1 of + (Var i@(Id _ _)):_ -> concretizeExprToBool s ng i dalts e2 stck + _ -> addExtConds s ng e1 ais e2 stck + + in + (RuleReturnCAssert, newPCs, ng') + +concretizeExprToBool :: State t -> NameGen -> Id -> [DataCon] -> Expr -> S.Stack Frame -> ([NewPC t], NameGen) +concretizeExprToBool _ ng _ [] _ _ = ([], ng) +concretizeExprToBool s ng mexpr_id (x:xs) e2 stck = + (x':newPCs, ng'') + where + (x', ng') = concretizeExprToBool' s ng mexpr_id x e2 stck + (newPCs, ng'') = concretizeExprToBool s ng' mexpr_id xs e2 stck + +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' + , exec_stack = stck + , curr_expr = CurrExpr Evaluate e2 + , true_assert = assertVal} + , 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 = + ([NewPC { state = s { curr_expr = CurrExpr Evaluate e2 + , exec_stack = stck} + , new_pcs = [ExtCond e1 boolVal]}], ng) + +addExtConds :: State t -> NameGen -> Expr -> Maybe (FuncCall) -> Expr -> S.Stack Frame -> ([NewPC t], NameGen) +addExtConds s ng e1 ais e2 stck = + let + s' = s { curr_expr = CurrExpr Evaluate e2 + , exec_stack = stck} + + condt = [ExtCond e1 True] + condf = [ExtCond e1 False] + + strue = NewPC { state = s' + , new_pcs = condt } + + sfalse = NewPC { state = s' { true_assert = True + , assert_ids = ais } + , new_pcs = condf } + in + ([strue, sfalse], ng) + +-- | Inject binds into the eenv. The LHS of the [(Id, Expr)] are treated as +-- seed values for the names. +liftBinds :: [(Id, Expr)] -> E.ExprEnv -> Expr -> NameGen -> + (E.ExprEnv, Expr, NameGen, [Name]) +liftBinds binds eenv expr ngen = (eenv', expr', ngen', news) + where + (bindsLHS, bindsRHS) = unzip binds + + 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 + + eenv' = E.insertExprs (zip news (map snd binds')) eenv + +-- 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 + | 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 = + 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 + , 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] }] + , ng') + | otherwise = Nothing + +isApplyFrame :: Frame -> Bool +isApplyFrame (ApplyFrame _) = True +isApplyFrame _ = False + + diff --git a/src/G2/Initialization/DeepSeqWalks.hs b/src/G2/Initialization/DeepSeqWalks.hs new file mode 100644 --- /dev/null +++ b/src/G2/Initialization/DeepSeqWalks.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +-- This module generates functions in the expr_env that walk over the whole structure of an ADT. +-- This forces evaluation of the ADT +module G2.Initialization.DeepSeqWalks (createDeepSeqWalks) where + +import G2.Language + +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 + +type BoundName = Name + +createDeepSeqWalks :: ExprEnv -> TypeEnv -> NameGen -> (ExprEnv, NameGen, Walkers) +createDeepSeqWalks eenv tenv ng = + let + tenv' = M.toList tenv + in + createFuncs eenv ng tenv' M.empty (createDeepSeqName . fst) createDeepSeqStore (createDeepSeqExpr tenv) + +createDeepSeqName :: Name -> Name +createDeepSeqName n = Name ("walk" `T.append` nameOcc n) Nothing 0 (spanning n) + +createDeepSeqStore :: (Name, AlgDataTy) -> Name -> Walkers -> Walkers +createDeepSeqStore (n, adt) n' w = + let + bi = bound_ids adt + bn = map TyVar $ bound_ids adt + bnf = map (\b -> TyFun b b) bn + + base = TyFun (TyCon n TYPE) (TyCon n TYPE) + + t = foldr TyFun base (bn ++ bnf) + t' = foldr TyForAll t $ map NamedTyBndr bi + i = Id n' t' + in + M.insert n i w + +type RenameMap = HM.HashMap Name Name + +createDeepSeqExpr :: TypeEnv -> Walkers -> (Name, AlgDataTy) -> NameGen -> (Expr, NameGen) +createDeepSeqExpr tenv w (n, adt) ng = + let + bn = bound_ids adt + + -- Generates fresh names for TYPE variables, and walker function variables + (bn', ng') = freshNames (length bn) ng + (wbn, ng'') = freshNames (length bn) ng' + + bni = map (flip Id TYPE) bn' + wbni = map (\(b, f) -> Id f (TyFun (TyVar (Id b TYPE)) (TyVar (Id b TYPE)))) $ zip bn' wbn + + bfuncs = zip bn' wbni -- SUSPECT? bn' should be something else? + rm = HM.fromList $ zip (map idName bn) bn' + + adt' = adt --renames (HM.fromList (zip (map idName bn) bn')) adt + + (e, ng''') = createDeepSeqCase1 tenv w bfuncs n rm bn' adt' ng'' + in + (mkLams (map (TypeL,) bni ++ map (TermL,) wbni) e, ng''') + +createDeepSeqCase1 :: TypeEnv -> Walkers -> [(Name, Id)] -> Name -> RenameMap-> [BoundName] -> AlgDataTy -> NameGen -> (Expr, NameGen) +createDeepSeqCase1 tenv w ti n rm bn (DataTyCon {data_cons = dc}) ng = + let + (i, ng') = freshId (mkFullAppedTyCon n (map (TyVar . flip Id TYPE) bn) TYPE) ng + (caseB, ng'') = freshId (mkFullAppedTyCon n (map (TyVar . flip Id TYPE) bn) TYPE) ng' + + (alts, ng''') = createDeepSeqDataConCase1Alts tenv w ti n caseB rm bn ng'' dc + + c = Case (Var i) caseB alts + in + (Lam TermL i c, ng''') +createDeepSeqCase1 _ w ti n rm bn (NewTyCon {rep_type = t}) ng = + let + t' = mkFullAppedTyCon n (map (TyVar . flip Id TYPE) bn) TYPE + t'' = renames rm t + + (i, ng') = freshId t' ng + (caseB, ng'') = freshId t'' ng' + + cast = Cast (Var i) (t' :~ t'') + + e = deepSeqFuncCall w ti rm (Var caseB) + e' = Cast e (t'' :~ t') + + alt = Alt Default e' + + c = Case cast caseB [alt] + in + (Lam TermL i c, ng'') +createDeepSeqCase1 _ _ _ _ _ _ _ _ = error "createDeepSeqCase1: bad argument passed" + +createDeepSeqDataConCase1Alts :: TypeEnv -> Walkers -> [(Name, Id)] -> Name -> Id -> RenameMap -> [BoundName] -> NameGen -> [DataCon] -> ([Alt], NameGen) +createDeepSeqDataConCase1Alts _ _ _ _ _ _ _ ng [] = ([], ng) +createDeepSeqDataConCase1Alts tenv w ti n i rm bn ng (dc@(DataCon _ _):xs) = + let + ts = renames rm $ anonArgumentTypes dc + + (binds, ng') = freshIds ts ng + + dct = bindTypes rm (Data dc) + + (e, ng'') = createDeepSeqDataConCase2 tenv w ti rm binds ng' dct + alt = Alt (DataAlt dc binds) e + + (alts, ng''') = createDeepSeqDataConCase1Alts tenv w ti n i rm bn ng'' xs + in + (alt:alts, ng''') + +bindTypes :: RenameMap -> Expr -> Expr +bindTypes rm e = + let + t = tyForAllIds $ typeOf e + tb = map (Type . TyVar . renames rm) t + in + foldl' App e tb + +tyForAllIds :: Type -> [Id] +tyForAllIds (TyForAll (NamedTyBndr 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 = + let + (i', ng') = freshId rt ng + + b = deepSeqFuncCall w 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) + in + (Case bCast i' [Alt Default ae], ng'') + | otherwise = + let + (i', ng') = freshId (typeOf i) ng + + b = deepSeqFuncCall w ti rm (Var i) + + (ae, ng'') = createDeepSeqDataConCase2 tenv w ti rm is ng' (App e (Var i')) + in + (Case b i' [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 + +deepSeqFunc :: Typed t => Walkers -> [(Name, Id)] -> RenameMap -> t -> Maybe Expr +deepSeqFunc w ti rm e + | t <- typeOf e + , TyCon n _ <- tyAppCenter t + , ts <- tyAppArgs t + , Just f <- M.lookup n w = + let + as = map Type $ renames rm ts + as' = map (walkerFunc w ti rm) ts + in + Just $ foldl' App (Var f) (as ++ as') + | (TyVar (Id n _)) <- typeOf e + , Just f <- lookup n ti = + Just $ Var f + | otherwise = Nothing + +walkerFunc :: Walkers -> [(Name, Id)] -> RenameMap -> Type -> Expr +walkerFunc _ ti _ (TyVar (Id n _)) + | Just tyF <- lookup n ti = + Var tyF +walkerFunc w ti rm t + | TyCon n _ <- tyAppCenter t + , ts <- tyAppArgs t + , Just f <- M.lookup n w = + let + as = renames rm $ map Type ts + ft = renames rm $ mapMaybe (deepSeqFunc w 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 diff --git a/src/G2/Initialization/ElimTicks.hs b/src/G2/Initialization/ElimTicks.hs new file mode 100644 --- /dev/null +++ b/src/G2/Initialization/ElimTicks.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE FlexibleContexts #-} + +module G2.Initialization.ElimTicks (elimTicks) where + +import G2.Language + +elimTicks :: ASTContainer m Expr => m -> m +elimTicks = modifyASTsFix elimTicks' + +elimTicks' :: Expr -> Expr +elimTicks' (Tick _ e) = e +elimTicks' e = e diff --git a/src/G2/Initialization/ElimTypeSynonyms.hs b/src/G2/Initialization/ElimTypeSynonyms.hs new file mode 100644 --- /dev/null +++ b/src/G2/Initialization/ElimTypeSynonyms.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleContexts #-} + +module G2.Initialization.ElimTypeSynonyms ( elimTypeSyms + , elimTypeSymsTEnv) where + +import G2.Language + +import qualified Data.Map as M + +elimTypeSyms :: ASTContainer m Type => TypeEnv -> m -> m +elimTypeSyms tenv = modifyASTsFix (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 + , length ts == length is = + foldr (uncurry replaceASTs) st $ zip (map TyVar is) ts +elimTypeSyms' _ t = t + +elimTypeSymsTEnv :: TypeEnv -> TypeEnv +elimTypeSymsTEnv tenv = elimTypeSyms tenv . M.filter (not . typeSym) $ tenv + +typeSym :: AlgDataTy -> Bool +typeSym (TypeSynonym _ _) = True +typeSym _ = False diff --git a/src/G2/Initialization/InitVarLocs.hs b/src/G2/Initialization/InitVarLocs.hs new file mode 100644 --- /dev/null +++ b/src/G2/Initialization/InitVarLocs.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} + +module G2.Initialization.InitVarLocs (initVarLocs) where + +import G2.Language + +initVarLocs :: ASTContainer m Expr => m -> m +initVarLocs = modifyASTs initVarLocs' + +initVarLocs' :: Expr -> Expr +initVarLocs' (Tick (Breakpoint brs) e) + | (Var (Id (Name n m i (Just vs)) t)):xs <- unApp e = + let + s' = adjustSpanLoc brs vs + in + mkApp (Var (Id (Name n m i (Just s')) t):xs) +initVarLocs' e = e + +-- | Returns a span with the first spans +-- start location, but with the same length as the second span +adjustSpanLoc :: Span -> Span -> Span +adjustSpanLoc sp1@(Span {end = en}) sp2 = + let + re_line = (line $ end sp2) - (line $ start sp2) + re_col = (col $ end sp2) - (col $ start sp2) + + e_line = (line $ start sp1) + re_line + e_col = (col $ start sp2) + re_col + in + sp1 {end = en { line = e_line + , col = e_col} + } diff --git a/src/G2/Initialization/Interface.hs b/src/G2/Initialization/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Initialization/Interface.hs @@ -0,0 +1,31 @@ +module G2.Initialization.Interface where + +import G2.Language.Syntax +import G2.Language.Support hiding (State (..)) +import G2.Initialization.DeepSeqWalks +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 = + let + eenv2 = elimTypeSyms tenv eenv + tenv2 = elimTypeSymsTEnv tenv + tc2 = elimTypeSyms tenv tc + (eenv3, ng2, ds_walkers) = createDeepSeqWalks eenv2 tenv2 ng + + 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) diff --git a/src/G2/Initialization/KnownValues.hs b/src/G2/Initialization/KnownValues.hs new file mode 100644 --- /dev/null +++ b/src/G2/Initialization/KnownValues.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE 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.TypeEnv + +import qualified Data.Map as M +import qualified Data.Text as T + +initKnownValues :: E.ExprEnv -> TypeEnv -> KnownValues +initKnownValues eenv tenv = + KnownValues { + tyInt = typeWithStrName tenv "Int" + , dcInt = dcWithStrName tenv "Int" "I#" + + , tyFloat = typeWithStrName tenv "Float" + , dcFloat = dcWithStrName tenv "Float" "F#" + + , tyDouble = typeWithStrName tenv "Double" + , dcDouble = dcWithStrName tenv "Double" "D#" + + , tyInteger = typeWithStrName tenv "Integer" + , dcInteger = dcWithStrName tenv "Integer" "Z#" + + , tyChar = typeWithStrName tenv "Char" + , dcChar = dcWithStrName tenv "Char" "C#" + + , tyBool = typeWithStrName tenv "Bool" + , dcTrue = dcWithStrName tenv "Bool" "True" + , dcFalse = dcWithStrName tenv "Bool" "False" + + , tyList = typeWithStrName tenv "[]" + , dcCons = dcWithStrName tenv "[]" ":" + , dcEmpty = dcWithStrName tenv "[]" "[]" + + , eqTC = typeWithStrName tenv "Eq" + , numTC = typeWithStrName tenv "Num" + , ordTC = typeWithStrName tenv "Ord" + , integralTC = typeWithStrName tenv "Integral" + + , eqFunc = exprWithStrName eenv "==" + , neqFunc = exprWithStrName eenv "/=" + + , plusFunc = exprWithStrName eenv "+" + , minusFunc = exprWithStrName eenv "-" + , timesFunc = exprWithStrName eenv "*" + , divFunc = exprWithStrName eenv "/" + , negateFunc = exprWithStrName eenv "negate" + , modFunc = exprWithStrName eenv "mod" + , fromIntegerFunc = exprWithStrName eenv "fromInteger" + , toIntegerFunc = exprWithStrName eenv "toInteger" + + , geFunc = exprWithStrName eenv ">=" + , gtFunc = exprWithStrName eenv ">" + , ltFunc = exprWithStrName eenv "<" + , leFunc = exprWithStrName eenv "<=" + + , structEqTC = Name "NotDefinedYet" Nothing 0 Nothing + , structEqFunc = Name "NotDefinedYet" Nothing 0 Nothing + + , andFunc = exprWithStrName eenv "&&" + , orFunc = exprWithStrName eenv "||" + + , patErrorFunc = exprWithStrName eenv "patError" + } + +exprWithStrName :: E.ExprEnv -> T.Text -> Name +exprWithStrName eenv s = + case filter (\(Name n _ _ _) -> n == s) $ E.keys eenv of + n:_ -> n + _ -> error $ "No expr found in exprWithStrName " ++ (show $ T.unpack s) + +typeWithStrName :: TypeEnv -> T.Text -> Name +typeWithStrName tenv s = + case M.toList $ M.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 [" ++ + (show $ T.unpack ts) ++ "] [" ++ (show $ T.unpack dcs) ++ "]" + dc -> dcWithStrName' dc dcs + +dcWithStrName' :: [DataCon] -> T.Text -> Name +dcWithStrName' (DataCon n@(Name n' _ _ _) _:xs) s = + if n' == s then n else dcWithStrName' xs s +dcWithStrName' _ s = error $ "No dc found in dcWithStrName [" ++ (show $ T.unpack s) ++ "]" + diff --git a/src/G2/Initialization/MkCurrExpr.hs b/src/G2/Initialization/MkCurrExpr.hs new file mode 100644 --- /dev/null +++ b/src/G2/Initialization/MkCurrExpr.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Initialization.MkCurrExpr ( mkCurrExpr + , checkReaches + , findFunc + , instantiateArgTypes ) where + +import G2.Config +import G2.Language +import qualified G2.Language.ExprEnv as E + +import Data.List +import qualified Data.Text as T + +mkCurrExpr :: Maybe T.Text -> Maybe T.Text -> Id + -> TypeClasses -> NameGen -> ExprEnv -> Walkers + -> KnownValues -> Config -> (Expr, [Id], [Expr], NameGen) +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 + + (typsE, typs') = instantitateTypes tc kv typs + + (var_ids, is, ng') = mkInputs ng typs' + + var_ex = Var f + app_ex = foldl' App var_ex $ typsE ++ var_ids + + -- strict_app_ex = app_ex + strict_app_ex = if strict config then mkStrict walkers app_ex else app_ex + + (name, ng'') = freshName ng' + id_name = Id name (typeOf strict_app_ex) + var_name = Var id_name + + assume_ex = mkAssumeAssert (Assume Nothing) m_assume m_mod (typsE ++ var_ids) var_name var_name eenv + assert_ex = mkAssumeAssert (Assert Nothing) m_assert m_mod (typsE ++ var_ids) assume_ex var_name eenv + + retsTrue_ex = if returnsTrue config then retsTrue assert_ex else assert_ex + + let_ex = Let [(id_name, strict_app_ex)] retsTrue_ex + in + (let_ex, is, typsE, ng'') + Nothing -> error "mkCurrExpr: Bad Name" + +mkInputs :: NameGen -> [Type] -> ([Expr], [Id], NameGen) +mkInputs ng [] = ([], [], ng) +mkInputs ng (t:ts) = + let + (name, ng') = freshName ng + + i = Id name t + var_id = Var i + + (ev, ei, ng'') = mkInputs ng' ts + in + (var_id:ev, i:ei, ng'') + +mkAssumeAssert :: (Expr -> Expr -> Expr) -> Maybe T.Text -> Maybe T.Text + -> [Expr] -> Expr -> Expr -> ExprEnv -> Expr +mkAssumeAssert p (Just f) m_mod var_ids inter pre_ex eenv = + case findFunc f m_mod eenv of + Left (f', _) -> + let + app_ex = foldl' App (Var f') (var_ids ++ [pre_ex]) + in + p app_ex inter + Right s -> error s +mkAssumeAssert _ Nothing _ _ e _ _ = e + +retsTrue :: Expr -> Expr +retsTrue e = Assert Nothing e e + +findFunc :: T.Text -> Maybe T.Text -> ExprEnv -> Either (Id, Expr) String +findFunc s m_mod eenv = + let + match = E.toExprList $ E.filterWithKey (\n _ -> nameOcc n == s) eenv + in + case match of + [] -> 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. " ++ + "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) + [] -> Right $ "No function with name " ++ (T.unpack s) ++ " in module " ++ (T.unpack m) + _ -> 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 + typs = spArgumentTypes e + in + instantitateTypes tc kv typs + +instantitateTypes :: TypeClasses -> KnownValues -> [ArgType] -> ([Expr], [Type]) +instantitateTypes tc kv ts = + let + tv = map (typeNamedId) $ filter (typeNamed) 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 + + -- 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' + + ex = map (Type . snd) tv' ++ vi + tss = filter (not . isTypeClass tc) $ foldr (uncurry replaceASTs) ts' tvt + in + (ex, tss) + +-- From the given list, selects the Type to instantiate a TyVar with +pickForTyVar :: KnownValues -> [Type] -> Type +pickForTyVar kv ts + | Just t <- find ((==) (tyInt kv)) ts = t + | 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 + +checkReaches :: ExprEnv -> KnownValues -> Maybe T.Text -> Maybe T.Text -> ExprEnv +checkReaches eenv _ Nothing _ = eenv +checkReaches eenv kv (Just s) m_mod = + case findFunc s m_mod eenv of + Left (Id n _, e) -> E.insert n (Assert Nothing (mkFalse kv) e) eenv + Right err -> error err diff --git a/src/G2/Initialization/StructuralEq.hs b/src/G2/Initialization/StructuralEq.hs new file mode 100644 --- /dev/null +++ b/src/G2/Initialization/StructuralEq.hs @@ -0,0 +1,290 @@ +{-# 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 diff --git a/src/G2/Initialization/Types.hs b/src/G2/Initialization/Types.hs new file mode 100644 --- /dev/null +++ b/src/G2/Initialization/Types.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module G2.Initialization.Types ( SimpleState (..) + , SimpleStateM (..) + , runSimpleStateM + , evalSimpleStateM + , execSimpleStateM + , putKnownValues ) where + +import qualified Control.Monad.State.Lazy as SM + +import qualified G2.Language as L +import G2.Language.AST +import G2.Language.Monad +import G2.Language.Syntax + +data SimpleState = SimpleState { expr_env :: L.ExprEnv + , type_env :: L.TypeEnv + , name_gen :: L.NameGen + , known_values :: L.KnownValues + , type_classes :: L.TypeClasses + , rewrite_rules :: ![L.RewriteRule] + , exports :: [Name] } deriving (Eq, Show, Read) + +newtype SimpleStateM a = SimpleStateM { unSM :: (SM.State SimpleState a) } deriving (Applicative, Functor, Monad) + +instance SM.MonadState SimpleState SimpleStateM where + state f = SimpleStateM (SM.state f) + +instance ExState SimpleState SimpleStateM where + exprEnv = return . expr_env =<< SM.get + putExprEnv = rep_expr_envM + + 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 + + typeClasses = return . type_classes =<< SM.get + putTypeClasses = rep_type_classesM + +runSimpleStateM :: SimpleStateM a -> SimpleState -> (a, SimpleState) +runSimpleStateM (SimpleStateM s) s' = SM.runState s s' + +evalSimpleStateM :: SimpleStateM a -> SimpleState -> a +evalSimpleStateM s = fst . runSimpleStateM s + +execSimpleStateM :: SimpleStateM a -> SimpleState -> SimpleState +execSimpleStateM s = snd . runSimpleStateM s + +rep_expr_envM :: L.ExprEnv -> SimpleStateM () +rep_expr_envM eenv = do + s <- SM.get + SM.put $ s {expr_env = eenv} + +rep_type_envM :: L.TypeEnv -> SimpleStateM () +rep_type_envM tenv = do + s <- SM.get + SM.put $ s {type_env = tenv} + +rep_name_genM :: L.NameGen -> SimpleStateM () +rep_name_genM ng = do + s <- SM.get + SM.put $ s {name_gen = ng} + +rep_known_valuesM :: L.KnownValues -> SimpleStateM () +rep_known_valuesM kv = do + s <- SM.get + SM.put $ s {known_values = kv} + +rep_type_classesM :: L.TypeClasses -> SimpleStateM () +rep_type_classesM tc = do + s <- SM.get + 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) } + +instance ASTContainer SimpleState Type where + containedASTs s = containedASTs (expr_env s) ++ containedASTs (type_env s) + modifyContainedASTs f s = s { expr_env = modifyContainedASTs f (expr_env s) + , type_env = modifyContainedASTs f (type_env s) } diff --git a/src/G2/Interface.hs b/src/G2/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Interface.hs @@ -0,0 +1,5 @@ +module G2.Interface ( module G2.Interface.Interface + , module G2.Interface.OutputTypes ) where + +import G2.Interface.Interface +import G2.Interface.OutputTypes diff --git a/src/G2/Interface/Interface.hs b/src/G2/Interface/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Interface/Interface.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Interface.Interface ( doTimeout + , maybeDoTimeout + + , initState + , initState' + , initStateFromSimpleState + , initStateFromSimpleState' + , initSimpleState + + , initRedHaltOrd + , initSolver + , initSolverInfinite + + , initialStateFromFileSimple + , initialStateFromFile + + , runG2FromFile + , runG2WithConfig + , runG2WithSomes + , runG2Pre + , runG2Post + , runG2ThroughExecution + , runExecution + , runG2Solving + , runG2 + , Config) where + +import G2.Config.Config + +import G2.Language + +import G2.Initialization.Interface +import G2.Initialization.KnownValues +import G2.Initialization.MkCurrExpr +import qualified G2.Initialization.Types as IT + +import G2.Preprocessing.Interface + +import G2.Execution.Interface +import G2.Execution.Reducer +import G2.Execution.PrimitiveEval +import G2.Execution.Memory + +import G2.Interface.OutputTypes + +import G2.Translation + +import G2.Solver + +import G2.Postprocessing.Interface + +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.PathConds as PC +import qualified G2.Language.Stack as Stack + +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.Text as T + +import System.Timeout + +type AssumeFunc = T.Text +type AssertFunc = T.Text +type ReachFunc = T.Text + +type StartFunc = T.Text +type ModuleName = Maybe T.Text + +type MkCurrExpr = Id -> TypeClasses -> NameGen -> ExprEnv -> Walkers + -> KnownValues -> Config -> (Expr, [Id], [Expr], NameGen) + +doTimeout :: Int -> IO a -> IO (Maybe a) +doTimeout secs action = do + res <- timeout (secs * 1000 * 1000) action -- timeout takes micros. + case res of + Just _ -> return res + Nothing -> do + putStrLn "Timeout!" + return Nothing + +maybeDoTimeout :: Maybe Int -> IO a -> IO (Maybe a) +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 = + let + s = initSimpleState exg2 + in + initStateFromSimpleState s useAssert f m_mod mkCurr config + +initState' :: ExtractedG2 + -> StartFunc + -> ModuleName + -> MkCurrExpr + -> Config + -> (State (), Id, Bindings) +initState' exg2 sf m_mod mkCurr = + initState exg2 False sf m_mod mkCurr + +initStateFromSimpleState :: IT.SimpleState + -> Bool + -> StartFunc + -> ModuleName + -> MkCurrExpr + -> Config + -> (State (), Id, Bindings) +initStateFromSimpleState s useAssert f m_mod mkCurr 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 + 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 + in + (State { + expr_env = foldr (\i@(Id n _) -> E.insertSymbolic n i) eenv' is + , type_env = tenv' + , curr_expr = CurrExpr Evaluate ce + , path_conds = PC.fromList kv' $ map PCExists is + , 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 + , known_values = kv' + , rules = [] + , num_steps = 0 + , track = () + , 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 + , rewrite_rules = IT.rewrite_rules s + , name_gen = ng''}) + +initStateFromSimpleState' :: IT.SimpleState + -> StartFunc + -> ModuleName + -> Config + -> (State (), Id, Bindings) +initStateFromSimpleState' s sf m_mod = + initStateFromSimpleState s False sf m_mod (mkCurrExpr Nothing Nothing) + +initSimpleState :: ExtractedG2 + -> IT.SimpleState +initSimpleState (ExtractedG2 { exg2_binds = prog + , exg2_tycons = prog_typ + , exg2_classes = cls + , exg2_exports = es + , exg2_rules = rs }) = + let + eenv = mkExprEnv prog + tenv = mkTypeEnv prog_typ + tc = initTypeClasses cls + kv = initKnownValues eenv tenv + ng = mkNameGen (prog, prog_typ) + 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 } + +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 = + let + tr_ng = mkNameGen () + state_name = Name "state" Nothing 0 Nothing + 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) + +initSolver :: Config -> IO SomeSolver +initSolver = initSolver' arbValue + +initSolverInfinite :: Config -> IO SomeSolver +initSolverInfinite con = initSolver' arbValueInfinite con + +initSolver' :: ArbValueFunc -> Config -> IO SomeSolver +initSolver' avf config = do + SomeSMTSolver con <- getSMTAV avf config + let con' = GroupRelated avf (UndefinedHigherOrder :?> ADTSolver 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)) + +initialStateFromFileSimple :: [FilePath] + -> [FilePath] + -> [FilePath] + -> StartFunc + -> MkCurrExpr + -> Config + -> IO (State (), Id, Bindings) +initialStateFromFileSimple proj src libs f mkCurr config = + initialStateFromFile proj src libs Nothing False f mkCurr config + +initialStateFromFile :: [FilePath] + -> [FilePath] + -> [FilePath] + -> Maybe ReachFunc + -> Bool + -> StartFunc + -> MkCurrExpr + -> 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 + reaches_state = initCheckReaches init_s mb_modname m_reach + + return (reaches_state, ent_f, bindings) + +runG2FromFile :: [FilePath] + -> [FilePath] + -> [FilePath] + -> Maybe AssumeFunc + -> Maybe AssertFunc + -> Maybe ReachFunc + -> Bool + -> StartFunc + -> 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 + + r <- runG2WithConfig init_state config bindings + + return (r, entry_f) + +runG2WithConfig :: State () -> Config -> Bindings -> IO ([ExecRes ()], Bindings) +runG2WithConfig state config bindings = do + SomeSolver con <- initSolver config + + (in_out, bindings') <- case initRedHaltOrd con config of + (red, hal, ord) -> + runG2WithSomes red hal ord con [] state bindings + + close con + + return (in_out, bindings') + +runG2WithSomes :: ( Named t + , ASTContainer t Expr + , ASTContainer t Type + , Solver solver) + => (SomeReducer t) + -> (SomeHalter t) + -> (SomeOrderer t) + -> solver + -> [Name] + -> State t + -> Bindings + -> IO ([ExecRes t], Bindings) +runG2WithSomes red hal ord con pns state bindings = + case (red, hal, ord) of + (SomeReducer red', SomeHalter hal', SomeOrderer ord') -> + runG2 red' hal' ord' con pns 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 = + let + (swept, bindings') = markAndSweepPreserving (pns ++ names (lookupStructEqDicts kv tc)) s bindings + in + runPreprocessing swept bindings' + +runG2Post :: ( 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 + (exec_states, bindings') <- runExecution red hal ord is bindings + sol_states <- mapM (runG2Solving con bindings') exec_states + + return (catMaybes sol_states, bindings') + +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 + runExecution red hal ord is' bindings' + +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 }) + | 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' } + + let (es, e, ais) = subModel s' bindings + sm = ExecRes { final_state = s' + , conc_args = es + , conc_out = e + , violated = ais} + + let sm' = runPostprocessing bindings sm + + 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 + + | otherwise = return Nothing + +-- | Runs G2, returning both fully executed states, +-- and states that have only been partially executed. +runG2 :: ( 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 + + return (catMaybes sol_states, bindings') diff --git a/src/G2/Interface/OutputTypes.hs b/src/G2/Interface/OutputTypes.hs new file mode 100644 --- /dev/null +++ b/src/G2/Interface/OutputTypes.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module G2.Interface.OutputTypes ( ExecRes (..)) where + +import G2.Language + +-- | A fully executed State +data ExecRes t = ExecRes { final_state :: State t + , conc_args :: [Expr] + , conc_out :: Expr + , violated :: Maybe FuncCall -- ^ A violated assertion + } deriving (Show, Read) + +instance Named t => Named (ExecRes t) where + names (ExecRes { final_state = s + , conc_args = es + , conc_out = r + , violated = fc }) = + names s ++ names es ++ names r ++ names fc + + rename old new (ExecRes { final_state = s + , conc_args = es + , conc_out = r + , violated = fc }) = + ExecRes { final_state = rename old new s + , conc_args = rename old new es + , conc_out = rename old new r + , violated = rename old new fc} + + renames hm (ExecRes { final_state = s + , conc_args = es + , conc_out = r + , violated = fc }) = + ExecRes { final_state = renames hm s + , conc_args = renames hm es + , conc_out = renames hm r + , violated = renames hm fc } + +instance ASTContainer t Expr => ASTContainer (ExecRes t) Expr where + containedASTs (ExecRes { final_state = s + , conc_args = es + , conc_out = r + , violated = fc }) = + containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs fc + + modifyContainedASTs f (ExecRes { final_state = s + , conc_args = es + , conc_out = r + , violated = fc }) = + ExecRes { final_state = modifyContainedASTs f s + , conc_args = modifyContainedASTs f es + , conc_out = modifyContainedASTs f r + , violated = modifyContainedASTs f fc} + +instance ASTContainer t Type => ASTContainer (ExecRes t) Type where + containedASTs (ExecRes { final_state = s + , conc_args = es + , conc_out = r + , violated = fc }) = + containedASTs s ++ containedASTs es ++ containedASTs r ++ containedASTs fc + + modifyContainedASTs f (ExecRes { final_state = s + , conc_args = es + , conc_out = r + , violated = fc }) = + ExecRes { final_state = modifyContainedASTs f s + , conc_args = modifyContainedASTs f es + , conc_out = modifyContainedASTs f r + , violated = modifyContainedASTs f fc } diff --git a/src/G2/Language.hs b/src/G2/Language.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language.hs @@ -0,0 +1,30 @@ +-- | Language +-- Export module for G2.Language. +module G2.Language + ( module G2.Language.ArbValueGen + , module G2.Language.AST + , module G2.Language.CreateFuncs + , module G2.Language.Expr + , module G2.Language.Ids + , module G2.Language.Located + , module G2.Language.Naming + , module G2.Language.Primitives + , module G2.Language.Support + , module G2.Language.Syntax + , module G2.Language.TypeClasses + , module G2.Language.Typing + ) where + +import G2.Language.ArbValueGen +import G2.Language.AST +import G2.Language.CreateFuncs +import G2.Language.Expr +import G2.Language.Ids +import G2.Language.Located +import G2.Language.Naming +import G2.Language.Primitives +import G2.Language.Support +import G2.Language.Syntax +import G2.Language.TypeClasses +import G2.Language.Typing + diff --git a/src/G2/Language/AST.hs b/src/G2/Language/AST.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/AST.hs @@ -0,0 +1,475 @@ +-- | Defines typeclasses and functions for ease of AST manipulation. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module G2.Language.AST + ( AST (..) + , modify + , modifyMonoid + , modifyFix + , modifyContainedFix + , modifyFixMonoid + , eval + , evalMonoid + , evalChildren + , ASTContainer (..) + , modifyASTs + , modifyASTsMonoid + , modifyASTsFix + , modifyContainedASTsFix + , evalASTs + , evalASTsMonoid + , evalContainedASTs + , replaceASTs + ) where + +import G2.Language.Syntax +import G2.Language.AlgDataTy + +import Data.Hashable +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import qualified Data.Map as M +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. + modifyChildren :: (t -> t) -> t -> t + +-- | Calls the given function on the given node, and all of the descendants +-- in a recursive, top down, manner. +modify :: AST t => (t -> t) -> t -> t +modify f t = go t + where + go t' = modifyChildren go (f t') + +{-# SPECIALISE modify :: (Expr -> Expr) -> Expr -> Expr #-} +{-# SPECIALISE modify :: (Type -> Type) -> Type -> Type #-} + +-- | Similar to modify. Also passes a Monoid instance to the modify function. +-- Children have access to the mconcated results from higher in the tree +-- The head of the tree is given mempty. +modifyMonoid :: (AST t, Monoid a) => (a -> t -> (t, a)) -> t -> t +modifyMonoid f = go mempty + where + go m t = let (t', m') = f m t + ms = m `mappend` m' + in modifyChildren (go ms) t' + +-- | Runs the given function f on the node t, t until t = f t, then does the +-- same on all decendants of t recursively. +modifyFix :: (AST t, Eq t) => (t -> t) -> t -> t +modifyFix f t = go t + where + 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, t until t = f t +modifyContainedFix :: (AST t, Eq t, Show t) => (t -> t) -> t -> t +modifyContainedFix f t = let t' = f t + in if t == t' + then t' + else modifyContainedFix f t' + +-- | Combines the methods of modifyM and modifyFix. +-- Runs until t == t', but does not consider the Monoid's value. However, the +-- mappend still occurs each time an iteration is performed on a given AST. +modifyFixMonoid :: (AST t, Eq t, Monoid a) => (a -> t -> (t, a)) -> t -> t +modifyFixMonoid f = go f mempty + where + go :: (AST t, Eq t, Monoid a) => (a -> t -> (t, a)) -> a -> t -> t + go g m t = let (t', m') = g m t + ms = m `mappend` m' + in if t == t' + then modifyChildren (go g ms) t' + else go g ms t' + +-- | Recursively runs the given function on each node, top down. Uses mappend +-- to combine the results after evaluation of the entire tree. +eval :: (AST t, Monoid a) => (t -> a) -> t -> a +eval f t = go t + where + go t' = f t' `mappend` evalChildren go t' + +-- | Recursively runs the given function on each node, top down. We collect +-- information using on Monoid, and also pass another monoid that can help +-- accumulate results. +evalMonoid :: (AST t, Monoid a, Monoid b) => (b -> t -> (b, a)) -> t -> a +evalMonoid f = go f mempty + where + go :: (AST t, Monoid a, Monoid b) => (b -> t -> (b, a)) -> b -> t -> a + go g b t = let + (b', a') = g b t + b'' = b `mappend` b' + in + a' `mappend` evalChildren (go g b'') t + +-- | Evaluates all children of the given AST node with the given monoid, +-- and `mconcat`s the results +evalChildren :: (AST t, Monoid a) => (t -> a) -> t -> a +evalChildren f = mconcat . map f . children + +-- | For types that may contain ASTs, but that are not ASTs themselves. Such types +-- may include environments, State, functors, etc. +class AST t => ASTContainer c t where + -- | Gets all the ASTs that are directly contained in the container. + containedASTs :: c -> [t] + -- | Calls the function on all ASTs directly in the container. + modifyContainedASTs :: (t -> t) -> c -> c + +-- | Runs `modify` on all the ASTs in the container. +modifyASTs :: ASTContainer t e => (e -> e) -> t -> t +modifyASTs f = modifyContainedASTs (modify f) + +-- | Runs `modifyMonoid` on all the ASTs in the container. +modifyASTsMonoid :: (ASTContainer t e, Monoid a) => (a -> e -> (e,a)) -> t -> t +modifyASTsMonoid f = modifyContainedASTs (modifyMonoid f) + +-- | Runs `modifyFix` on all the ASTs in the container. +modifyASTsFix :: (ASTContainer t e, Eq e) => (e -> e) -> t -> t +modifyASTsFix f = modifyContainedASTs (modifyFix f) + +-- | Runs `modifyContainedFix` on all the ASTs in the container. +modifyContainedASTsFix :: (ASTContainer t e, Eq e, Show e) => (e -> e) -> t -> t +modifyContainedASTsFix f = modifyContainedASTs (modifyContainedFix f) + +-- | Runs `eval` on all the ASTs in the container, and uses mappend to results. +evalASTs :: (ASTContainer t e, Monoid a) => (e -> a) -> t -> a +evalASTs f = evalContainedASTs (eval f) + +-- | Runs `evalMonoid` on all the ASTs in the container, and uses mappend to results. +evalASTsMonoid :: (ASTContainer t e, Monoid a, Monoid b) => (b -> e -> (b, a)) -> t -> a +evalASTsMonoid f = evalContainedASTs (evalMonoid f) + +-- | Runs a function on all the ASTs in the container, and uses mappend to +-- combine the results. +evalContainedASTs :: (ASTContainer t e, Monoid a) => (e -> a) -> t -> a +evalContainedASTs f = mconcat . map f . containedASTs + +instance AST Expr where + children (Var _) = [] + children (Lit _) = [] + children (Prim _ _) = [] + children (Data _) = [] + 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 (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'] + + 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) + where + mapAlt :: (Expr -> Expr) -> [Alt] -> [Alt] + mapAlt g alts = map (\(Alt ac e) -> Alt ac (g e)) alts + modifyChildren f (Cast e c) = Cast (f e) c + modifyChildren f (Tick t e) = Tick t (f e) + modifyChildren f (NonDet es) = NonDet (map f es) + modifyChildren f (Assume is e e') = Assume (modifyContainedASTs f is) (f e) (f e') + modifyChildren f (Assert is e e') = Assert (modifyContainedASTs f is) (f e) (f e') + modifyChildren _ e = e + +instance AST Type where + children (TyVar i) = containedASTs i + children (TyFun tf ta) = [tf, ta] + children (TyApp tf ta) = [tf, ta] + children (TyCon _ t) = [t] + children (TyForAll b t) = containedASTs b ++ [t] + children _ = [] + + modifyChildren f (TyVar i) = TyVar $ modifyContainedASTs f i + modifyChildren f (TyFun tf ta) = TyFun (f tf) (f ta) + modifyChildren f (TyApp tf ta) = TyApp (f tf) (f ta) + modifyChildren f (TyCon b ts) = TyCon b (f ts) + modifyChildren f (TyForAll b t) = TyForAll (modifyContainedASTs f b) (f t) + modifyChildren _ t = t + +instance AST DataCon where + children _ = [] + modifyChildren _ (DataCon n ty) = DataCon n ty + +-- | Instance ASTContainer of Itself +-- 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] + + modifyContainedASTs f t = f t + +instance ASTContainer Expr Type where + containedASTs (Var i) = containedASTs i + containedASTs (Prim _ t) = [t] + containedASTs (Data dc) = containedASTs dc + 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 (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 (Assume is e e') = containedASTs is ++ containedASTs e ++ containedASTs e' + containedASTs (Assert is e e') = containedASTs is ++ containedASTs e ++ containedASTs e' + containedASTs _ = [] + + modifyContainedASTs f (Var i) = Var (modifyContainedASTs f i) + modifyContainedASTs f (Prim p t) = Prim p (f t) + modifyContainedASTs f (Data dc) = Data (modifyContainedASTs f dc) + 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 (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 (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 Id Expr where + containedASTs (Id _ _) = [] + + modifyContainedASTs _ i = i + +instance ASTContainer Id Type where + containedASTs (Id _ t) = [t] + + modifyContainedASTs f (Id n t) = Id n (f t) + +instance ASTContainer Name Expr where + containedASTs _ = [] + modifyContainedASTs _ n = n + +instance ASTContainer Name Type where + containedASTs _ = [] + modifyContainedASTs _ n = n + +instance ASTContainer Type Expr where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer DataCon Expr where + containedASTs _ = [] + modifyContainedASTs _ d = d + +instance ASTContainer DataCon Type where + containedASTs (DataCon _ t) = [t] + + modifyContainedASTs f (DataCon n t) = DataCon n (f t) + +instance ASTContainer AltMatch Expr where + containedASTs _ = [] + modifyContainedASTs _ e = e + +instance ASTContainer AltMatch Type where + containedASTs (DataAlt dc i) = containedASTs dc ++ containedASTs i + containedASTs _ = [] + + modifyContainedASTs f (DataAlt dc i) = DataAlt (modifyContainedASTs f dc) (modifyContainedASTs f i) + modifyContainedASTs _ e = e + +instance ASTContainer Alt Expr where + containedASTs (Alt _ e) = [e] + modifyContainedASTs f (Alt a e) = Alt a (f e) + +instance ASTContainer Alt Type where + containedASTs (Alt a e) = (containedASTs a) ++ (containedASTs e) + 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 + +instance ASTContainer Coercion Type where + containedASTs (t :~ t') = [t, t'] + modifyContainedASTs f (t :~ t') = f t :~ f t' + +instance ASTContainer FuncCall Expr where + containedASTs (FuncCall { arguments = as, returns = r}) = as ++ [r] + modifyContainedASTs f fc@(FuncCall { arguments = as, returns = r}) = + fc {arguments = map f as, returns = f r} + +instance ASTContainer FuncCall Type where + containedASTs (FuncCall { arguments = as, returns = r}) = containedASTs as ++ containedASTs r + modifyContainedASTs f fc@(FuncCall { arguments = as, returns = r}) = + fc {arguments = modifyContainedASTs f as, returns = modifyContainedASTs f r} + +-- 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) + + modifyContainedASTs f = fmap (modifyContainedASTs f) + +instance ASTContainer c t => ASTContainer (Maybe c) t where + containedASTs = foldMap (containedASTs) + + modifyContainedASTs f = fmap (modifyContainedASTs f) + + +instance ASTContainer c t => ASTContainer (HM.HashMap k c) t where + containedASTs = foldMap (containedASTs) + + modifyContainedASTs f = fmap (modifyContainedASTs f) + +instance ASTContainer c t => ASTContainer (M.Map k c) t where + containedASTs = foldMap (containedASTs) + + modifyContainedASTs f = fmap (modifyContainedASTs f) + +instance (ASTContainer s t, Hashable s, Eq s) => ASTContainer (HS.HashSet s) t where + containedASTs = containedASTs . HS.toList + + modifyContainedASTs f = HS.map (modifyContainedASTs f) + +instance ASTContainer () Expr where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer () Type where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance (ASTContainer c t, ASTContainer d t) => ASTContainer (c, d) t where + containedASTs (x, y) = containedASTs x ++ containedASTs y + + modifyContainedASTs f (x, y) = (modifyContainedASTs f x, modifyContainedASTs f y) + +instance + (ASTContainer c t, ASTContainer d t, ASTContainer e t) => ASTContainer (c, d, e) t where + containedASTs (x, y, z) = containedASTs x ++ containedASTs y ++ containedASTs z + + modifyContainedASTs f (x, y, z) = (modifyContainedASTs f x, modifyContainedASTs f y, modifyContainedASTs f z) + +instance + (ASTContainer c t, ASTContainer d t, ASTContainer e t, ASTContainer g t) => ASTContainer (c, d, e, g) t where + containedASTs (x, y, z, w) = containedASTs x ++ containedASTs y ++ containedASTs z ++ containedASTs w + + modifyContainedASTs f (x, y, z, w) = (modifyContainedASTs f x, modifyContainedASTs f y, modifyContainedASTs f z, modifyContainedASTs f w) + +instance + (ASTContainer c t, ASTContainer d t, ASTContainer e t, ASTContainer g t, ASTContainer h t) => ASTContainer (c, d, e, g, h) t where + containedASTs (x, y, z, w, a) = containedASTs x ++ containedASTs y ++ containedASTs z ++ containedASTs w ++ containedASTs a + + modifyContainedASTs f (x, y, z, w, a) = (modifyContainedASTs f x, modifyContainedASTs f y, modifyContainedASTs f z, modifyContainedASTs f w, modifyContainedASTs f a) + +-- | 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 + +instance ASTContainer Lit Type where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer Bool Expr where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer Bool Type where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer Char Expr where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer Char Type where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer T.Text Expr where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer T.Text Type where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer Int Expr where + containedASTs _ = [] + modifyContainedASTs _ t = t + +instance ASTContainer Int Type where + containedASTs _ = [] + modifyContainedASTs _ t = t + + +-- AlgDataTy +instance ASTContainer AlgDataTy Expr where + containedASTs _ = [] + + modifyContainedASTs _ a = a + +instance ASTContainer AlgDataTy Type where + containedASTs (DataTyCon ns dcs) = containedASTs ns ++ containedASTs dcs + containedASTs (NewTyCon ns dcs r) = containedASTs ns ++ containedASTs dcs ++ containedASTs r + containedASTs (TypeSynonym _ st) = containedASTs st + + modifyContainedASTs f (DataTyCon ns dcs) = DataTyCon (modifyContainedASTs f ns) (modifyContainedASTs f dcs) + modifyContainedASTs f (NewTyCon ns dcs rt) = NewTyCon (modifyContainedASTs f ns) (modifyContainedASTs f dcs) (modifyContainedASTs f rt) + modifyContainedASTs f (TypeSynonym is st) = TypeSynonym is (modifyContainedASTs f st) + +instance ASTContainer AlgDataTy DataCon where + containedASTs (DataTyCon _ dcs) = dcs + containedASTs (NewTyCon _ dcs _) = [dcs] + containedASTs (TypeSynonym _ _) = [] + + modifyContainedASTs f (DataTyCon ns dcs) = DataTyCon ns (modifyContainedASTs f dcs) + modifyContainedASTs f (NewTyCon ns dc rt) = NewTyCon ns (modifyContainedASTs f dc) rt + modifyContainedASTs _ st@(TypeSynonym _ _) = st + + +-- ====== -- +-- AST Helper functions +-- ====== -- + +-- | replaceASTs +-- Replaces all instances of old with new in the ASTContainer +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 + + + diff --git a/src/G2/Language/AlgDataTy.hs b/src/G2/Language/AlgDataTy.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/AlgDataTy.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module G2.Language.AlgDataTy where + +import Data.Data (Data, Typeable) + +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) + + diff --git a/src/G2/Language/ArbValueGen.hs b/src/G2/Language/ArbValueGen.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/ArbValueGen.hs @@ -0,0 +1,125 @@ +module G2.Language.ArbValueGen ( ArbValueGen + , ArbValueFunc + , arbValueInit + , arbValue + , arbValueInfinite ) 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 Data.Ord +import Data.Tuple + +arbValueInit :: ArbValueGen +arbValueInit = ArbValueGen { intGen = 0 + , floatGen = 0 + , doubleGen = 0 + , charGen = charGenInit -- See [CharGenInit] + , boolGen = True + } + +type ArbValueFunc = Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen) + +-- [CharGenInit] +-- Do NOT make this a cycle. It would simplify arbValue, but causes an infinite loop +-- when we have to output a State (in the QuasiQuoter, for example) + +charGenInit :: [Char] +charGenInit = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] + +-- | arbValue +-- 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 +-- 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 + +arbValue' :: GetADT -> Type -> TypeEnv -> ArbValueGen -> (Expr, ArbValueGen) +arbValue' getADTF 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 = + let + (e1, av') = arbValue' getADTF t1 tenv av + (e2, av'') = arbValue' getADTF t2 tenv av' + in + (App e1 e2, av'') +arbValue' _ TyLitInt _ av = + let + i = intGen av + in + (Lit (LitInt $ i), av { intGen = i + 1 }) +arbValue' _ TyLitFloat _ av = + let + f = floatGen av + in + (Lit (LitFloat $ f), av { floatGen = f + 1 }) +arbValue' _ TyLitDouble _ av = + let + d = doubleGen av + in + (Lit (LitDouble $ d), av { doubleGen = d + 1 }) +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) + +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 = + let + (e, av') = getADT tenv av adt ts + in + (cutOff [] e, av') + +cutOff :: [Name] -> Expr -> Expr +cutOff ns a@(App _ _) + | Data (DataCon n _) <- appCenter a = + case n `elem` ns 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 + + -- Finds the DataCon for adt with the least arguments + min_dc = minimumBy (comparing (length . dataConArgs)) dcs + + tyVIds = map TyVar ids + min_dc' = foldr (uncurry replaceASTs) min_dc $ zip tyVIds 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') diff --git a/src/G2/Language/Casts.hs b/src/G2/Language/Casts.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Casts.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleContexts #-} + +module G2.Language.Casts ( unsafeElimCast + , unsafeElimOuterCast + , splitCast + , simplifyCasts + , liftCasts + , exprInCasts + , typeInCasts + ) where + +import G2.Language.AST +import G2.Language.Naming +import G2.Language.Syntax +import G2.Language.Typing + +-- | 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 + +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). +-- Given any other expression, acts as the identity function +splitCast :: NameGen -> Expr -> (Expr, NameGen) +splitCast ng (Cast e ((TyFun t1 t2) :~ (TyFun t1' t2'))) = + let + (i, ng') = freshId t1 ng + + e' = Lam TermL i $ + (Cast + (App + e + (Cast (Var i) (t1 :~ t1')) + ) + (t2 :~ t2') + ) + in + (e', ng') +splitCast ng (Cast e ((TyForAll (NamedTyBndr ni) t2) :~ (TyForAll (NamedTyBndr ni') t2'))) = + let + t1 = typeOf ni + t1' = typeOf ni' + + (i, ng') = freshId t1 ng + + e' = Lam TypeL i $ + (Cast + (App + e + (Cast (Var i) (t1 :~ t1')) + ) + (t2 :~ 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 e = (e, ng) + +-- | Eliminates redundant casts. +simplifyCasts :: ASTContainer m Expr => m -> m +simplifyCasts = modifyASTsFix simplifyCasts' + +simplifyCasts' :: Expr -> Expr +simplifyCasts' e + | (Cast (Cast e' (t1 :~ _)) (_ :~ t2)) <- e + = Cast e' (t1 :~ t2) + | (Cast e' (t1 :~ t2)) <- e + , PresType t2 .:: t1 + = e' + | otherwise = e + +-- | Changes casts on functions to casts on non-functional values +-- (As much as possible) +liftCasts :: ASTContainer m Expr => m -> m +liftCasts = simplifyCasts . modifyASTsFix liftCasts' + +liftCasts' :: Expr -> Expr +liftCasts' a@(App _ _) = liftCasts'' a +liftCasts' e = e + +liftCasts'' :: Expr-> Expr +liftCasts'' (App (Cast f (TyForAll (NamedTyBndr b1) t1 :~ TyForAll (NamedTyBndr b2) t2)) e@(Type t)) = + let + t1' = retype b1 t t1 + t2' = retype b2 t t2 + in + Cast (App f e) (t1' :~ t2') +liftCasts'' (App (Cast f (TyFun _ t2 :~ TyFun _ t2')) e) = + Cast (App f e) (t2 :~ t2') +liftCasts'' a@(App e e') = + let + a' = App (liftCasts'' e) (liftCasts'' e') + in + if a == a' then a else liftCasts'' a' +liftCasts'' e = e + +-- | Extracts an `Expr` nested in one or more Casts. +exprInCasts :: Expr -> Expr +exprInCasts (Cast e _) = exprInCasts e +exprInCasts e = e + +-- | Gets the type of an `Expr`, ignoring Casts. +typeInCasts :: Expr -> Type +typeInCasts = typeOf . exprInCasts diff --git a/src/G2/Language/CreateFuncs.hs b/src/G2/Language/CreateFuncs.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/CreateFuncs.hs @@ -0,0 +1,34 @@ +module G2.Language.CreateFuncs where + +import qualified G2.Language.ExprEnv as E +import G2.Language.Naming +import G2.Language.Syntax +import G2.Language.Support + +-- | Give a list of b's, and functions to generate names and expressions from those +-- b's, generates functions and puts them in the ExprEnv +-- All b/Name pairs are also stored in some s, using the provided function +-- The function to generate the expression gets the full s of b/Name pairs +createFuncs :: ExprEnv + -> NameGen + -> [b] + -> s + -> (b -> Name) + -> (b -> Name -> s -> s) + -> (s -> b -> NameGen -> (Expr, NameGen)) + -> (ExprEnv, NameGen, s) +createFuncs eenv ng genFrom store namef storef exprf = + let + --Generate names, put them in the store + (ns, ng2) = freshSeededNames (map namef genFrom) ng + genFromNames = zip genFrom ns + + fullStore = foldr (uncurry storef) store genFromNames + + --Generate functions, put them in the expression environment + (exprfs, ng3) = mapNG (exprf fullStore) genFrom ng2 + eenv2 = foldr (uncurry E.insert) eenv (zip ns exprfs) + + in + (eenv2, ng3, fullStore) + diff --git a/src/G2/Language/Expr.hs b/src/G2/Language/Expr.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Expr.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# 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 + +import G2.Language.AST +import G2.Language.Casts +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.KnownValues as KV +import G2.Language.Naming +import G2.Language.Support +import G2.Language.Syntax +import G2.Language.Typing + +import Data.Foldable +import qualified Data.Map as M +import Data.Maybe +import Data.Semigroup + +-- | Unravels the application spine. +unApp :: Expr -> [Expr] +unApp (App f a) = unApp f ++ [a] +unApp expr = [expr] + +-- | Turns the Expr list into an Application +-- +-- @ mkApp [e1, e2, e3] == App (App e1 e2) e3@ +mkApp :: [Expr] -> Expr +mkApp [] = error "mkApp: empty list" +mkApp (e:[]) = e +mkApp (e1:e2:es) = mkApp (App e1 e2 : es) + +mkDCInt :: KnownValues -> TypeEnv -> Expr +mkDCInt kv tenv = Data . fromJust $ getDataCon tenv (KV.tyInt kv) (KV.dcInt kv) + +mkDCInteger :: KnownValues -> TypeEnv -> Expr +mkDCInteger kv tenv = Data . fromJust $ getDataCon tenv (KV.tyInteger kv) (KV.dcInteger kv) + +mkDCFloat :: KnownValues -> TypeEnv -> Expr +mkDCFloat kv tenv = Data . fromJust $ getDataCon tenv (KV.tyFloat kv) (KV.dcFloat kv) + +mkDCDouble :: KnownValues -> TypeEnv -> Expr +mkDCDouble kv tenv = Data . fromJust $ getDataCon tenv (KV.tyDouble kv) (KV.dcDouble kv) + +mkDCChar :: KnownValues -> TypeEnv -> Expr +mkDCChar kv tenv = Data . fromJust $ getDataCon tenv (KV.tyChar kv) (KV.dcChar kv) + +mkDCTrue :: KnownValues -> TypeEnv -> DataCon +mkDCTrue kv tenv = fromJust $ getDataCon tenv (KV.tyBool kv) (KV.dcTrue kv) + +mkDCFalse :: KnownValues -> TypeEnv -> DataCon +mkDCFalse kv tenv = fromJust $ getDataCon tenv (KV.tyBool kv) (KV.dcFalse kv) + +mkTrue :: KnownValues -> Expr +mkTrue kv = Data $ DataCon (KV.dcTrue kv) (TyCon (KV.tyBool kv) TYPE) + +mkFalse :: KnownValues -> Expr +mkFalse kv = Data $ DataCon (KV.dcFalse kv) (TyCon (KV.tyBool kv) TYPE) + +mkBool :: KnownValues -> Bool -> Expr +mkBool kv b = if b then mkTrue kv else mkFalse kv + +mkCons :: KnownValues -> TypeEnv -> Expr +mkCons kv tenv = Data . fromJust $ getDataCon tenv (KV.tyList kv) (KV.dcCons kv) + +mkEmpty :: KnownValues -> TypeEnv -> Expr +mkEmpty kv tenv = Data . fromJust $ getDataCon tenv (KV.tyList kv) (KV.dcEmpty kv) + +mkIdentity :: Type -> Expr +mkIdentity t = + let + x = Id (Name "x" Nothing 0 Nothing) t + in + Lam TermL x (Var x) + +getFuncCalls :: ASTContainer m Expr => m -> [Expr] +getFuncCalls = evalContainedASTs getFuncCalls' + +getFuncCalls' :: Expr -> [Expr] +getFuncCalls' a@(App e1 e2) = a:getFuncCallsRHS e1 ++ getFuncCalls' e2 +getFuncCalls' v@(Var _) = [v] +getFuncCalls' e = evalChildren getFuncCalls' e + +getFuncCallsRHS :: Expr -> [Expr] +getFuncCallsRHS (App e1 e2) = getFuncCallsRHS e1 ++ getFuncCalls' e2 +getFuncCallsRHS (Var _) = [] +getFuncCallsRHS e = getFuncCalls' e + +-- | Calls the given function on the topmost @App@ in every function application +-- in the given `Expr` +modifyAppTop :: ASTContainer m Expr => (Expr -> Expr) -> m -> m +modifyAppTop f = modifyContainedASTs (modifyAppTop' f) + +modifyAppTop' :: (Expr -> Expr) -> Expr -> Expr +modifyAppTop' f e@(App _ _) = + let + e' = f e + in + modifyAppRHS (modifyAppTop' f) e' +modifyAppTop' f e = modifyChildren f e + +modifyAppLHS :: (Expr -> Expr) -> Expr -> Expr +modifyAppLHS f (App e e') = App (f e) (modifyAppLHS f e') +modifyAppLHS _ e = e + +modifyAppRHS :: (Expr -> Expr) -> Expr -> Expr +modifyAppRHS f (App e e') = App (modifyAppRHS f e) (f e') +modifyAppRHS _ e = e + +modifyLamTop :: ASTContainer m Expr => (Expr -> Expr) -> m -> m +modifyLamTop f = modifyContainedASTs (modifyLamTop' f) + +modifyLamTop' :: (Expr -> Expr) -> Expr -> Expr +modifyLamTop' f e@(Lam _ _ _) = + let + e' = f e + in + modifyLamRHS (modifyLamTop' f) e' +modifyLamTop' f e = modifyChildren f e + +modifyLamRHS :: (Expr -> Expr) -> Expr -> Expr +modifyLamRHS f (Lam u i e) = Lam u i $ modifyLamRHS f e +modifyLamRHS f e = f e + +-- | Returns all function calls to Vars with all arguments +nonDataFunctionCalls :: ASTContainer m Expr => m -> [Expr] +nonDataFunctionCalls = filter (not . centerIsData) . getFuncCalls + +centerIsData :: Expr -> Bool +centerIsData (App e _) = centerIsData e +centerIsData (Data _) = True +centerIsData _ = False + +-- Gets the `Expr` at the center of several nested @App@s +appCenter :: Expr -> Expr +appCenter (App a _) = appCenter a +appCenter e = e + +mapArgs :: (Expr -> Expr) -> Expr -> Expr +mapArgs f (App e e') = App (mapArgs f e) (f e') +mapArgs _ e = e + +mkLams :: [(LamUse, Id)] -> Expr -> Expr +mkLams = flip (foldr (\(u, i) -> Lam u i)) + +-- | Remove all @Assert@s from the given `Expr` +elimAsserts :: ASTContainer m Expr => m -> m +elimAsserts = modifyASTs elimAsserts' + +elimAsserts' :: Expr -> Expr +elimAsserts' (Assert _ _ e) = e +elimAsserts' 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 +insertInLams f = insertInLams' f [] + +insertInLams' :: ([Id] -> Expr -> Expr) -> [Id] -> Expr -> Expr +insertInLams' f xs (Lam u i e) = Lam u i $ insertInLams' f (i:xs) e +insertInLams' f xs e = f (reverse xs) e + +maybeInsertInLams :: ([Id] -> Expr -> Maybe Expr) -> Expr -> Maybe Expr +maybeInsertInLams f = maybeInsertInLams' f [] + +maybeInsertInLams' :: ([Id] -> Expr -> Maybe Expr) -> [Id] -> Expr -> Maybe Expr +maybeInsertInLams' f xs (Lam u i e) = fmap (Lam u i) $ maybeInsertInLams' f (i:xs) e +maybeInsertInLams' f xs e = f (reverse xs) e + +-- | Returns the Expr in nested Lams +inLams :: Expr -> Expr +inLams (Lam _ _ e) = inLams e +inLams e = e + +leadingLamUsesIds :: Expr -> [(LamUse, Id)] +leadingLamUsesIds (Lam u i e) = (u, i):leadingLamUsesIds e +leadingLamUsesIds _ = [] + +leadingLamIds :: Expr -> [Id] +leadingLamIds (Lam _ i e) = i:leadingLamIds e +leadingLamIds _ = [] + +-- | Returns all Ids from Lam's at the top of the Expr +args :: Expr -> [Id] +args (Lam _ i e) = i:args e +args _ = [] + +passedArgs :: Expr -> [Expr] +passedArgs = reverse . passedArgs' + +passedArgs' :: Expr -> [Expr] +passedArgs' (App e e') = e':passedArgs' e +passedArgs' _ = [] + +--Returns all Vars in an ASTContainer +vars :: (ASTContainer m Expr) => m -> [Expr] +vars = evalASTs vars' + +vars' :: Expr -> [Expr] +vars' v@(Var _) = [v] +vars' _ = [] + +varId :: Expr -> Maybe Id +varId (Var i) = Just i +varId _ = Nothing + +symbVars :: (ASTContainer m Expr) => ExprEnv -> m -> [Expr] +symbVars eenv = filter (symbVars' eenv) . vars + +symbVars' :: ExprEnv -> Expr -> Bool +symbVars' eenv (Var (Id n _)) = E.isSymbolic n eenv +symbVars' _ _ = False + +-- | 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) + +freeVars' :: E.ExprEnv -> [Id] -> Expr -> ([Id], [Id]) +freeVars' _ _ (Let b _) = (map fst b, []) +freeVars' _ _ (Lam _ b _) = ([b], []) +freeVars' eenv bound (Var i) = + if E.member (idName i) eenv || i `elem` bound then + ([], []) + else + ([], [i]) +freeVars' _ _ _ = ([], []) + +alphaReduction :: ASTContainer m Expr => m -> m +alphaReduction = modifyASTsMonoid alphaReduction' + +alphaReduction' :: Max Int -> Expr -> (Expr, Max Int) +alphaReduction' mi l@(Lam u i@(Id (Name n m ii lo) t) e) = + let + mi' = mi + 1 + n' = Name n m (getMax mi') lo + i' = Id n' t + + e' = replaceASTs (Var i) (Var i') e + in + if ii > getMax mi then (l, mi') else (Lam u i' e', mi') +alphaReduction' m e = (e, m) + +-- | Performs beta reduction, if a Var is being applied +varBetaReduction :: ASTContainer m Expr => m -> m +varBetaReduction = modifyASTs varBetaReduction' + +varBetaReduction' :: Expr -> Expr +varBetaReduction' a@(App (Lam _ i e) (Var v)) = + if not (isTYPE . typeOf $ i) then replaceLamIds i v e else a +varBetaReduction' e = e + +replaceLamIds :: Id -> Id -> Expr -> Expr +replaceLamIds i i' v@(Var v') = if i == v' then Var i' else v +replaceLamIds i i' l@(Lam u l' e) = if i == l' then l else Lam u l' (replaceLamIds i i' e) +replaceLamIds i i' e = modifyChildren (replaceLamIds i i') e + +-- | If doing so will not change evaluation, eta expands to the given arity. +-- This function is conservative, so it may sometimes fail to determine that +-- we can perform eta expansion, even when it can. +-- However, it should NEVER eta expand something that will change evaluation. +-- +-- Eta expansion converts: +-- @ abs @ +-- to +-- @ \x -> abs x @ +-- and +-- @ \x -> (+) x @ +-- to +-- @ \x -> \y -> (+) x y @ +-- That is, it looks directly inside the outermost lambdas +-- +-- If the arity is greater than the given number, does nothing. +-- If the given number is greater than the maximal number of arguments, +-- tries to expand to the maximal number of arguments. +-- +-- This function is careful to not change +-- That is, we cannot convert: +-- @ undefined `seq` 1 @ +-- to +-- @ (\x -> undefined x) `seq` 1 @ +-- because the first will call undefined, and error, whereas the second will +-- evaluate to 1. +etaExpandTo :: ExprEnv -> NameGen -> Int -> Expr -> (Expr, NameGen) +etaExpandTo eenv ng n (Lam u i e) = + let + (e', ng') = etaExpandTo eenv ng n e + in + (Lam u i e', ng') +etaExpandTo eenv ng n e = etaExpandTo' eenv ng n e + +etaExpandTo' :: ExprEnv -> NameGen -> Int -> Expr -> (Expr, NameGen) +etaExpandTo' eenv ng n e = (addLamApps fn (typeOf e) e, ng') + where + n' = n `min` numArgs e + n'' = validN eenv M.empty n' e + + (fn, ng') = freshNames n'' ng + + -- Determines if we can eta expand the Expr, without changing semantics + -- This requires looking in variables, possibly recursively. + -- We use the map to track if recursive lookups are actually decreasing arity, + -- and prevent an infinite loop + validN :: ExprEnv -> M.Map Name Int -> Int -> Expr -> Int + validN _ _ 0 _ = n' + validN eenv' m i (Lam _ _ e') = validN eenv' m (i - 1) e' + validN eenv' m i (Var (Id v _)) + | Just i' <- M.lookup v m + , Just e' <- E.lookup v eenv' = + if i >= i' then n' - i `min` i' else validN eenv' m' i e' + | Just e' <- E.lookup v eenv' = validN eenv' m' i e' + | otherwise = n' + where + m' = M.insert v i m + validN eenv' m i (App e' _) = validN eenv' m (i + 1) e' + validN eenv' m i (Let b e') = + let + eenv'' = E.insertExprs (map (\(i', e'') -> (idName i', e'')) b) eenv' + in + validN eenv'' m i e' + validN _ _ i _ = n' - i + + 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 (ln:ns) (TyFun t t') e' = + Lam TermL (Id ln t) (App (addLamApps ns t' e') (Var (Id ln t))) + addLamApps _ _ e' = e' + + +-- | Forces the complete evaluation of an expression +mkStrict :: (ASTContainer m Expr) => Walkers -> m -> m +mkStrict w = modifyContainedASTs (mkStrict' w) + +mkStrict' :: Walkers -> Expr -> Expr +mkStrict' w e = + let + rt = returnType e + t = tyAppCenter rt + ts = tyAppArgs rt + in + case t of + (TyCon n _) -> case M.lookup n w of + Just i -> App (foldl' (App) (Var i) (map Type ts ++ map (typeToWalker w) ts)) e + Nothing -> error $ "mkStrict: failed to find walker with type: " ++ show n + _ -> error $ "No walker found in mkStrict\n e = " ++ show e ++ "\nt = " ++ show (typeOf e) ++ "\nret = " ++ show (returnType e) + +typeToWalker :: Walkers -> Type -> Expr +typeToWalker 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 w) ts) + Nothing -> error $ "typeToWalker: failed to find type: " ++ show n +typeToWalker _ t = mkIdentity t diff --git a/src/G2/Language/ExprEnv.hs b/src/G2/Language/ExprEnv.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/ExprEnv.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module G2.Language.ExprEnv + ( ExprEnv + , ConcOrSym (..) + , empty + , singleton + , fromList + , null + , size + , member + , lookup + , lookupConcOrSym + , deepLookup + , isSymbolic + , occLookup + , lookupNameMod + , insert + , insertSymbolic + , insertExprs + , redirect + , union + , (!) + , map + , map' + , mapWithKey + , mapWithKey' + , mapKeys + , mapM + , mapWithKeyM + , filter + , filterWithKey + , filterToSymbolic + , getIdFromName + , funcsOfType + , keys + , symbolicKeys + , elems + , higherOrderExprs + , toList + , toExprList + , fromExprList + ) where + +import G2.Language.AST +import G2.Language.Naming +import G2.Language.Syntax +import G2.Language.Typing + +import Prelude hiding( filter + , lookup + , map + , mapM + , null) +import qualified Prelude as Pre +import Data.Coerce +import Data.Data (Data, Typeable) +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T + +data ConcOrSym = Conc Expr + | Sym Id + +-- 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 +-- 2) Certain names are symbolic. This means they represent a symbolic variable +-- Nonsymbolic names map to an ExprObj, symbolic names to a SymObj. + +data EnvObj = ExprObj Expr + | RedirObj Name + | SymbObj Id + deriving (Show, Eq, Read, Typeable, Data) + +newtype ExprEnv = ExprEnv (M.Map Name EnvObj) + deriving (Show, Eq, Read, Typeable, Data) + +unwrapExprEnv :: ExprEnv -> M.Map Name EnvObj +unwrapExprEnv = coerce + +-- | Constructs an empty `ExprEnv` +empty :: ExprEnv +empty = ExprEnv M.empty + +-- | Constructs an `ExprEnv` with a single `Expr`. +singleton :: Name -> Expr -> ExprEnv +singleton n e = ExprEnv $ M.singleton n (ExprObj e) + +-- | Constructs an `ExprEnv` from a list of `Name` and `Expr` pairs. +fromList :: [(Name, Expr)] -> ExprEnv +fromList = ExprEnv . M.fromList . Pre.map (\(n, e) -> (n, ExprObj e)) + +-- Is the `ExprEnv` empty? +null :: ExprEnv -> Bool +null = M.null . unwrapExprEnv + +-- | Returns the number of `Expr` in the `ExprEnv`. +size :: ExprEnv -> Int +size = M.size . unwrapExprEnv + +-- | Is the given `Name` bound in the `ExprEnv`? +member :: Name -> ExprEnv -> Bool +member n = M.member n . unwrapExprEnv + +-- | Lookup the `Expr` with the given `Name`. +-- Returns `Nothing` if the `Name` is not in the `ExprEnv`. +lookup :: Name -> ExprEnv -> Maybe Expr +lookup n (ExprEnv smap) = + case M.lookup n smap of + Just (ExprObj expr) -> Just expr + Just (RedirObj redir) -> lookup redir (ExprEnv smap) + Just (SymbObj i) -> Just $ Var i + Nothing -> Nothing + +lookupConcOrSym :: Name -> ExprEnv -> Maybe ConcOrSym +lookupConcOrSym n (ExprEnv smap) = + case M.lookup n smap of + Just (ExprObj expr) -> Just $ Conc expr + Just (RedirObj redir) -> lookupConcOrSym redir (ExprEnv smap) + Just (SymbObj i) -> Just $ Sym i + Nothing -> Nothing + +-- | 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`. +deepLookup :: Name -> ExprEnv -> Maybe Expr +deepLookup n eenv = + case lookup n eenv of + Just (Var (Id n' _)) -> lookup n' eenv + r -> r + +-- | Checks if the given `Name` belongs to a symbolic variable. +isSymbolic :: Name -> ExprEnv -> Bool +isSymbolic n (ExprEnv eenv') = + case M.lookup n eenv' of + Just (SymbObj _) -> True + _ -> False + +-- TODO -- This seems kinda too much like a special case to be here... +occLookup :: T.Text -> Maybe T.Text -> ExprEnv -> Maybe Expr +occLookup n m (ExprEnv eenv) = + let ex = L.find (\(Name n' m' _ _, _) -> n == n' && (m == m' || m' == Just "PrimDefs")) -- TODO: The PrimDefs exception should not be here! + . M.toList . M.map (\(ExprObj e) -> e) . M.filter (isExprObj) $ eenv + in + fmap (\(n', e) -> Var $ Id n' (typeOf e)) ex + +lookupNameMod :: T.Text -> Maybe T.Text -> ExprEnv -> Maybe (Name, Expr) +lookupNameMod ns ms = + listToMaybe . L.filter (\(Name n m _ _, _) -> ns == n && ms == m) . toExprList + +-- | Looks up a `Name` in the `ExprEnv`. Crashes if the `Name` is not found. +(!) :: ExprEnv -> Name -> Expr +(!) env@(ExprEnv env') n = + case M.lookup n env' of + Just (RedirObj n') -> env ! n' + Just (ExprObj e) -> e + Just (SymbObj i) -> Var i + Nothing -> error $ "ExprEnv.!: Given key is not an element of the expr env" ++ show n + +-- | Inserts a new `Expr` into the `ExorEnv`, at the given `Name`. +-- If the `Name` already exists in the `ExprEnv`, the `Expr` is replaced. +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 + +insertExprs :: [(Name, Expr)] -> ExprEnv -> ExprEnv +insertExprs kvs scope = foldr (uncurry insert) scope kvs + +-- | Maps the two `Name`@s@ so that they point to the same value +redirect :: Name -> Name -> ExprEnv -> ExprEnv +redirect n n' = ExprEnv . M.insert n (RedirObj n') . unwrapExprEnv + +union :: ExprEnv -> ExprEnv -> ExprEnv +union (ExprEnv eenv) (ExprEnv eenv') = ExprEnv $ eenv `M.union` eenv' + +-- | Map a function over all `Expr` in the `ExprEnv`. +-- Will not replace symbolic variables with non-symbolic values, +-- but will rename symbolic values. +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 +map' f = mapWithKey' (\_ -> 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. +mapWithKey :: (Name -> Expr -> Expr) -> ExprEnv -> ExprEnv +mapWithKey f (ExprEnv env) = ExprEnv $ M.mapWithKey f' env + where + f' :: Name -> EnvObj -> EnvObj + f' n (ExprObj e) = ExprObj $ f n e + f' n s@(SymbObj i) = + case f n (Var i) of + Var i' -> SymbObj i' + _ -> s + f' _ n = n + +mapWithKey' :: (Name -> Expr -> a) -> ExprEnv -> M.Map Name a +mapWithKey' f = M.mapWithKey f . toExprMap + +mapKeys :: (Name -> Name) -> ExprEnv -> ExprEnv +mapKeys f = coerce . M.mapKeys f . unwrapExprEnv + +mapM :: Monad m => (Expr -> m Expr) -> ExprEnv -> m ExprEnv +mapM f eenv = return . ExprEnv =<< Pre.mapM f' (unwrapExprEnv eenv) + where + f' (ExprObj e) = return . ExprObj =<< f e + f' s@(SymbObj i) = do + e' <- f (Var i) + case e' of + Var i' -> return $ SymbObj i' + _ -> return s + f' n = return n + + +mapWithKeyM :: Monad m => (Name -> Expr -> m Expr) -> ExprEnv -> m ExprEnv +mapWithKeyM f eenv = return . ExprEnv . M.fromList =<< Pre.mapM (uncurry f') (toList eenv) + where + f' n (ExprObj e) = return . (n,) . ExprObj =<< f n e + f' n s@(SymbObj i) = do + e' <- f n (Var i) + case e' of + Var i' -> return $ (n, SymbObj i') + _ -> return (n, s) + f' n e = return (n, e) + +filter :: (Expr -> Bool) -> ExprEnv -> ExprEnv +filter p = filterWithKey (\_ -> p) + +filterWithKey :: (Name -> Expr -> Bool) -> ExprEnv -> ExprEnv +filterWithKey p env@(ExprEnv env') = ExprEnv $ M.filterWithKey p' env' + where + p' :: Name -> EnvObj -> Bool + p' n (RedirObj n') = p n (env ! n') + p' n (ExprObj e) = p n e + p' n (SymbObj i) = p n (Var i) + +-- | Returns a new `ExprEnv`, which contains only the symbolic values. +filterToSymbolic :: ExprEnv -> ExprEnv +filterToSymbolic eenv = filterWithKey (\n _ -> isSymbolic n eenv) eenv + +-- | Returns the names of all expressions with the given type in the expression environment +funcsOfType :: Type -> ExprEnv -> [Name] +funcsOfType t = keys . filter (\e -> t == typeOf e) + +keys :: ExprEnv -> [Name] +keys = M.keys . unwrapExprEnv + +symbolicKeys :: ExprEnv -> [Name] +symbolicKeys eenv = M.keys . unwrapExprEnv . filterWithKey (\n _ -> isSymbolic n eenv) $ eenv + +-- | Returns all `Expr`@s@ in the `ExprEnv` +elems :: ExprEnv -> [Expr] +elems = exprObjs . M.elems . unwrapExprEnv + +-- | Returns a list of all argument function types +higherOrderExprs :: ExprEnv -> [Type] +higherOrderExprs = concatMap (higherOrderFuncs) . elems + +toList :: ExprEnv -> [(Name, EnvObj)] +toList = M.toList . unwrapExprEnv + +-- | Creates a list of Name to Expr coorespondences +-- Loses information about names that are mapped to the same value +toExprList :: ExprEnv -> [(Name, Expr)] +toExprList env@(ExprEnv env') = + M.toList + . M.mapWithKey (\k _ -> env ! k) $ env' + +fromExprList :: [(Name, Expr)] -> ExprEnv +fromExprList = ExprEnv . M.fromList . L.map (\(n, e) -> (n, ExprObj e)) + +toExprMap :: ExprEnv -> M.Map Name Expr +toExprMap env = M.mapWithKey (\k _ -> env ! k) $ unwrapExprEnv env + +getIdFromName :: ExprEnv -> Name -> Maybe Id +getIdFromName eenv name = + case (lookup name eenv) of + Just (Var i) -> Just i + _ -> Nothing + +-- Symbolic objects will be returned by calls to eval functions, however +-- calling AST modify functions on the expressions in an ExprEnv will have +-- no effect on contained symbolic objects, unless the returned type is also a Var. +-- This is to mantain the invariant that a symbolic object is just a Var +instance ASTContainer ExprEnv Expr where + containedASTs = elems + modifyContainedASTs f = map f + +instance ASTContainer ExprEnv Type where + containedASTs = containedASTs . elems + modifyContainedASTs f = map (modifyContainedASTs f) + +instance ASTContainer EnvObj Expr where + containedASTs (ExprObj e) = [e] + containedASTs (RedirObj _) = [] + containedASTs (SymbObj i) = [Var i] + + modifyContainedASTs f (ExprObj e) = ExprObj (f e) + modifyContainedASTs f s@(SymbObj i) = + case f (Var i) of + (Var i') -> SymbObj i' + _ -> s + modifyContainedASTs _ r = r + +instance ASTContainer EnvObj Type where + containedASTs (ExprObj e) = containedASTs e + containedASTs (RedirObj _) = [] + containedASTs (SymbObj i) = containedASTs i + + modifyContainedASTs f (ExprObj e) = ExprObj (modifyContainedASTs f e) + modifyContainedASTs f (SymbObj i) = SymbObj (modifyContainedASTs f i) + modifyContainedASTs _ r = r + +instance Named ExprEnv where + names (ExprEnv eenv) = names (M.keys eenv) ++ names eenv + + rename old new = + ExprEnv + . M.mapKeys (\k -> if k == old then new else k) + . rename old new + . unwrapExprEnv + + renames hm = + ExprEnv + . M.mapKeys (renames hm) + . renames hm + . unwrapExprEnv + +instance Named EnvObj where + names (ExprObj e) = names e + names (RedirObj r) = [r] + names (SymbObj s) = names s + + rename old new (ExprObj e) = ExprObj $ rename old new e + rename old new (RedirObj r) = RedirObj $ rename old new r + rename old new (SymbObj s) = SymbObj $ rename old new s + + renames hm (ExprObj e) = ExprObj $ renames hm e + renames hm (RedirObj r) = RedirObj $ renames hm r + renames hm (SymbObj s) = SymbObj $ renames hm s + +-- Helpers for EnvObjs + +isExprObj :: EnvObj -> Bool +isExprObj (ExprObj _) = True +isExprObj _ = False + +exprObjs :: [EnvObj] -> [Expr] +exprObjs [] = [] +exprObjs (ExprObj e:xs) = e:exprObjs xs +exprObjs (SymbObj i:xs) = Var i:exprObjs xs +exprObjs (_:xs) = exprObjs xs diff --git a/src/G2/Language/Ids.hs b/src/G2/Language/Ids.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Ids.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module G2.Language.Ids where + +import G2.Language.Syntax +import G2.Language.AST + +import qualified Data.Map as M +import qualified Data.HashSet as HS + +class Ided a where + ids :: a -> [Id] + +instance Ided Id where + {-# INLINE ids #-} + ids i@(Id _ t) = i:ids t + +instance Ided Name where + {-# INLINE ids #-} + ids _ = [] + +instance Ided Expr where + ids = eval go + where + go :: Expr -> [Id] + go (Var i) = ids i + go (Prim _ t) = ids t + 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 (Type t) = ids t + go _ = [] + +instance Ided Type where + ids = eval go + where + go (TyVar i) = ids i + go (TyForAll b _) = ids b + go _ = [] + +instance Ided DataCon where + {-# INLINE ids #-} + ids (DataCon _ t) = ids t + +instance Ided AltMatch where + {-# INLINE ids #-} + 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 + +instance Ided a => Ided [a] where + {-# INLINE ids #-} + ids = foldMap ids + +instance Ided a => Ided (Maybe a) where + {-# INLINE ids #-} + ids = foldMap ids + +instance Ided a => Ided (M.Map k a) where + {-# INLINE ids #-} + ids = foldMap ids + +instance Ided s => Ided (HS.HashSet s) where + {-# INLINE ids #-} + ids = foldMap ids + +instance (Ided a, Ided b) => Ided (a, b) where + ids (a, b) = ids a ++ ids b + +instance (Ided a, Ided b, Ided c) => Ided (a, b, c) where + ids (a, b, c) = ids a ++ ids b ++ ids c diff --git a/src/G2/Language/KnownValues.hs b/src/G2/Language/KnownValues.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/KnownValues.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- 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 + +import G2.Language.Syntax +import Data.Data (Data, Typeable) + +data KnownValues = KnownValues { + tyInt :: Name + , dcInt :: Name + + , tyFloat :: Name + , dcFloat :: Name + + , tyDouble :: Name + , dcDouble :: Name + + , tyInteger :: Name + , dcInteger :: Name + + , tyChar :: Name + , dcChar :: Name + + , tyBool :: Name + , dcTrue :: Name + , dcFalse :: Name + + , tyList :: Name + , dcCons :: Name + , dcEmpty :: Name + + , eqTC :: Name + , numTC :: Name + , ordTC :: Name + , integralTC :: Name + + , eqFunc :: Name + , neqFunc :: Name + + , plusFunc :: Name + , minusFunc :: Name + , timesFunc :: Name + , divFunc :: Name + , negateFunc :: Name + , modFunc :: Name + + , fromIntegerFunc :: Name + , toIntegerFunc :: Name + + , geFunc :: Name + , gtFunc :: Name + , ltFunc :: Name + , leFunc :: Name + + , structEqTC :: Name + , structEqFunc :: Name + + , andFunc :: Name + , orFunc :: Name + + , patErrorFunc :: Name + } deriving (Show, Eq, Read, Typeable, Data) diff --git a/src/G2/Language/Located.hs b/src/G2/Language/Located.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Located.hs @@ -0,0 +1,124 @@ +module G2.Language.Located + ( Located (..) + , Spanning (..) + , Locatable (..) + , Spannable (..) + , topLeft + , bottomRight + , combineSpans + , spanLookup + , locLookup + , SpannedName(..) + ) where + +import G2.Language.Naming +import G2.Language.Syntax +import G2.Language.ExprEnv (ExprEnv) + +import Data.Hashable +import qualified Data.Map as M +import Data.Maybe + +class Located l where + loc :: l -> Maybe Loc + +class Spanning l where + spanning :: l -> Maybe Span + +instance Located Span where + loc = Just . start + +instance Located Name where + loc (Name _ _ _ s) = maybe Nothing loc s + +instance Located Id where + loc (Id n _) = loc n + +instance Spanning Name where + spanning (Name _ _ _ s) = s + +instance Spanning Id where + spanning (Id n _) = spanning n + +-- Allows equality checking and sorting by Location +newtype Locatable a = Locatable a deriving (Show) + +instance Located a => Located (Locatable a) where + loc (Locatable x) = loc x + +instance Spanning a => Spanning (Locatable a) where + spanning (Locatable x) = spanning x + +instance Located a => Eq (Locatable a) where + x == y = loc x == loc y + +instance Located a => Ord (Locatable a) where + x `compare` y = loc x `compare` loc y + +-- Allows equality checking and sorting by Span +newtype Spannable a = Spannable a deriving (Show) + +instance Located a => Located (Spannable a) where + loc (Spannable x) = loc x + +instance Spanning a => Spanning (Spannable a) where + spanning (Spannable x) = spanning x + +instance Spanning a => Eq (Spannable a) where + x == y = spanning x == spanning y + +instance Spanning a => Ord (Spannable a) where + x `compare` y = spanning x `compare` spanning y + +-- | Returns the span that begins the closest to the top, +-- or, if both columns are the same, that is leftmost +topLeft :: Span -> Span -> Span +topLeft (s1@Span {start = st1}) (s2@Span {start = st2}) + | col st1 < col st2 = s1 + | col st1 > col st2 = s2 + | line st1 < line st2 = s1 + | otherwise = s2 + +-- | Returns the span that ends the closest to the bottom, +-- or, if both columns are the same, that is rightmost +bottomRight :: Span -> Span -> Span +bottomRight (s1@Span {end = en1}) (s2@Span {end = en2}) + | col en1 < col en2 = s2 + | col en1 > col en2 = s1 + | line en1 < line en2 = s2 + | otherwise = s1 + +-- | combineSpans +-- Combines two Spans into one, that covers all the characters from both spans. +-- Assumes the files are the same. +combineSpans :: Span -> Span -> Span +combineSpans s1 s2 = + let + tl = topLeft s1 s2 + br = bottomRight s1 s2 + in + s1 {start = start tl, end = end br} + +-- | 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 + +-- | Constructs a map of Locs to Names, based on all Names in the ExprEnv +locLookup :: ExprEnv -> M.Map Loc Name +locLookup = M.mapKeys start . spanLookup + + +newtype SpannedName = SpannedName Name deriving (Show) + +instance Eq SpannedName where + (==) (SpannedName (Name occ1 mod1 unq1 sp1)) + (SpannedName (Name occ2 mod2 unq2 sp2)) = + occ1 == occ2 && mod1 == mod2 && unq1 == unq2 && sp1 == sp2 + +instance Hashable SpannedName where + hashWithSalt s (SpannedName (Name n m i l)) = + s `hashWithSalt` + n `hashWithSalt` + m `hashWithSalt` + i `hashWithSalt` l diff --git a/src/G2/Language/Monad.hs b/src/G2/Language/Monad.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad.hs @@ -0,0 +1,21 @@ +module G2.Language.Monad ( module G2.Language.Monad.AST + , module G2.Language.Monad.CreateFuncs + , module G2.Language.Monad.Expr + , module G2.Language.Monad.ExprEnv + , module G2.Language.Monad.Naming + , module G2.Language.Monad.Primitives + , module G2.Language.Monad.Support + , module G2.Language.Monad.TypeClasses + , module G2.Language.Monad.TypeEnv + , module G2.Language.Monad.Typing ) where + +import G2.Language.Monad.AST +import G2.Language.Monad.CreateFuncs +import G2.Language.Monad.Expr +import G2.Language.Monad.ExprEnv +import G2.Language.Monad.Naming +import G2.Language.Monad.Primitives +import G2.Language.Monad.Support +import G2.Language.Monad.TypeClasses +import G2.Language.Monad.TypeEnv +import G2.Language.Monad.Typing diff --git a/src/G2/Language/Monad/AST.hs b/src/G2/Language/Monad/AST.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/AST.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module G2.Language.Monad.AST where + +import G2.Language.AST +import G2.Language.Syntax + +import qualified Data.Text as T + +class AST t => ASTM t where + modifyChildrenM :: Monad m => (t -> m t) -> t -> m t + +modifyM :: (ASTM t, Monad m) => (t -> m t) -> t -> m t +modifyM f t = go t + where + go t' = modifyChildrenM go =<< f t' + +modifyFixM :: (ASTM t, Monad m, Eq t) => (t -> m t) -> t -> m t +modifyFixM f e = do + e' <- f e + if e == e' + then modifyChildrenM (modifyFixM f) e' + else modifyFixM f e' + +class (ASTM t, ASTContainer c t) => ASTContainerM c t where + modifyContainedASTsM :: Monad m => (t -> m t) -> c -> m c + +modifyASTsM :: (ASTContainerM c e, Monad m) => (e -> m e) -> c -> m c +modifyASTsM f = modifyContainedASTsM (modifyM f) + +-- | Instance ASTContainerM of Itself +-- Every ASTM is defined as an ASTContainerM of itself. Generally, functions +-- should be written using the ASTContainerM typeclass. +instance ASTM t => ASTContainerM t t where + modifyContainedASTsM f t = f t + +instance ASTM Expr where + modifyChildrenM f (App fx ax) = do + fx' <- f fx + ax' <- f ax + return $ App fx' ax' + modifyChildrenM f (Lam u b e) = return . Lam u b =<< f e + modifyChildrenM f (Let bind e) = do + bind' <- modifyContainedASTsM f bind + return . Let bind' =<< f e + modifyChildrenM f (Case m b as) = do + m' <- f m + return . Case m' b =<< modifyContainedASTsM f as + modifyChildrenM f (Cast e c) = do + e' <- f e + return $ Cast e' c + modifyChildrenM f (Tick t e) = return . Tick t =<< f e + modifyChildrenM f (NonDet es) = return . NonDet =<< mapM f es + modifyChildrenM f (Assume is e1 e2) = do + is' <- modifyContainedASTsM f is + e1' <- f e1 + e2' <- f e2 + return $ Assume is' e1' e2' + modifyChildrenM f (Assert is e1 e2) = do + is' <- modifyContainedASTsM f is + e1' <- f e1 + e2' <- f e2 + return $ Assert is' e1' e2' + modifyChildrenM _ e = return e + +instance ASTM Type where + modifyChildrenM f (TyVar i) = return . TyVar =<< modifyContainedASTsM f i + modifyChildrenM f (TyFun tf ta) = do + tf' <- f tf + ta' <- f ta + return $ TyFun tf' ta' + modifyChildrenM f (TyApp tf ta) = do + tf' <- f tf + ta' <- f ta + return $ TyApp tf' ta' + modifyChildrenM f (TyCon b ts) = + return . TyCon b =<< f ts + modifyChildrenM f (TyForAll b t) = do + b' <- modifyContainedASTsM f b + return . TyForAll b' =<< modifyChildrenM f t + modifyChildrenM _ t = return t + +instance ASTContainerM Expr Type where + modifyContainedASTsM f (Var i) = return . Var =<< modifyContainedASTsM f i + modifyContainedASTsM f (Prim p t) = return . Prim p =<< f t + modifyContainedASTsM f (Data dc) = return . Data =<< modifyContainedASTsM f dc + modifyContainedASTsM f (App fx ax) = do + fx' <- modifyContainedASTsM f fx + ax' <- modifyContainedASTsM f ax + return $ App fx' ax' + modifyContainedASTsM f (Lam u b e) = do + b' <- modifyContainedASTsM f b + e' <- modifyContainedASTsM f e + return $ Lam u b' e' + modifyContainedASTsM f (Let bnd e) = do + bnd' <- modifyContainedASTsM f bnd + e' <- modifyContainedASTsM f e + return $ Let bnd' e' + modifyContainedASTsM f (Case m i as) = do + m' <- modifyContainedASTsM f m + i' <- modifyContainedASTsM f i + as' <- modifyContainedASTsM f as + return $ Case m' i' as' + modifyContainedASTsM f (Type t) = return . Type =<< f t + modifyContainedASTsM f (Cast e c) = do + e' <- modifyContainedASTsM f e + c' <- modifyContainedASTsM f c + return $ Cast e' c' + modifyContainedASTsM f (Coercion c) = return . Coercion =<< modifyContainedASTsM f c + modifyContainedASTsM f (Tick t e) = return . Tick t =<< modifyContainedASTsM f e + modifyContainedASTsM f (NonDet es) = return . NonDet =<< modifyContainedASTsM f es + modifyContainedASTsM f (Assume is e1 e2) = do + is' <- modifyContainedASTsM f is + e1' <- modifyContainedASTsM f e1 + e2' <- modifyContainedASTsM f e2 + return $ Assume is' e1' e2' + modifyContainedASTsM f (Assert is e1 e2) = do + is' <- modifyContainedASTsM f is + e1' <- modifyContainedASTsM f e1 + e2' <- modifyContainedASTsM f e2 + return $ Assert is' e1' e2' + modifyContainedASTsM _ e = return e + +instance ASTContainerM c e => ASTContainerM [c] e where + modifyContainedASTsM f = mapM (modifyContainedASTsM f) + +instance ASTContainerM c e => ASTContainerM (Maybe c) e where + modifyContainedASTsM f = mapM (modifyContainedASTsM f) + +instance (ASTContainerM c t, ASTContainerM d t) => ASTContainerM (c, d) t where + modifyContainedASTsM f (x, y) = do + x' <- modifyContainedASTsM f x + y' <- modifyContainedASTsM f y + return (x', y') + +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 #-} + modifyContainedASTsM _ dc = return dc + +instance ASTContainerM DataCon Type where + modifyContainedASTsM f (DataCon n t) = return . DataCon n =<< f t + +instance ASTContainerM AltMatch Expr where + {-# INLINE modifyContainedASTsM #-} + modifyContainedASTsM _ am = return am + +instance ASTContainerM Alt Expr where + modifyContainedASTsM f (Alt a e) = do + e' <- modifyContainedASTsM f e + return $ Alt a e' + +instance ASTContainerM AltMatch Type where + modifyContainedASTsM f (DataAlt dc i) = do + dc' <- modifyContainedASTsM f dc + i' <- modifyContainedASTsM f i + return $ DataAlt dc' i' + modifyContainedASTsM _ am = return am + +instance ASTContainerM Alt Type where + modifyContainedASTsM f (Alt a e) = do + a' <- modifyContainedASTsM f a + e' <- modifyContainedASTsM f e + return $ Alt a' e' + +instance ASTContainerM Coercion Type where + modifyContainedASTsM f (t1 :~ t2) = do + t1' <- f t1 + t2' <- f t2 + return $ t1' :~ t2' + +instance ASTContainerM FuncCall Expr where + modifyContainedASTsM f fc@(FuncCall { arguments = as, returns = r}) = do + as' <- modifyContainedASTsM f as + r' <- modifyContainedASTsM f r + return $ fc { arguments = as', returns = r' } + +instance ASTContainerM FuncCall Type where + modifyContainedASTsM f fc@(FuncCall { arguments = as, returns = r}) = do + as' <- modifyContainedASTsM f as + r' <- modifyContainedASTsM f r + return $ fc { arguments = as', returns = r' } + +instance ASTContainerM T.Text Expr where + modifyContainedASTsM _ = return + +instance ASTContainerM T.Text Type where + modifyContainedASTsM _ = return diff --git a/src/G2/Language/Monad/CreateFuncs.hs b/src/G2/Language/Monad/CreateFuncs.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/CreateFuncs.hs @@ -0,0 +1,33 @@ +module G2.Language.Monad.CreateFuncs where + +import G2.Language.Monad.ExprEnv +import G2.Language.Monad.Naming +import G2.Language.Monad.Support +import G2.Language.Syntax + +import Control.Monad + +-- createFuncsM +-- Given a list of b's, a function to map the b's to Names +-- and a function to map those b's to Expr +-- Generates pairs of names and Expr's and put's them in the ExprEnv +-- Also returns a s, of Name/Expr pairs +createFuncsM :: ExState st m => + [b] + -> s + -> (b -> m Name) + -> (b -> Name -> s -> m s) + -> (s -> b -> m Expr) + -> m s +createFuncsM genFrom store namef storef exprf = do + ns <- freshSeededNamesN =<< mapM namef genFrom + + let genFromNames = zip genFrom ns + -- let fullStore = foldr (uncurry storef) store genFromNames + fullStore <- foldM (\s (b, n) -> storef b n s) store genFromNames + + exprfs <- mapM (exprf fullStore) genFrom + + sequence_ $ map (uncurry insertE) (zip ns exprfs) + + return fullStore diff --git a/src/G2/Language/Monad/Expr.hs b/src/G2/Language/Monad/Expr.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/Expr.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +module G2.Language.Monad.Expr ( mkDCTrueM + , mkDCFalseM + , mkDCIntE + , mkDCIntegerE + , mkDCFloatE + , mkDCDoubleE + , mkTrueE + , mkFalseE + , mkConsE + , mkEmptyE + , modifyAppTopE + , modifyLamTopE + , insertInLamsE + , etaExpandToE ) where + +import G2.Language.Expr +import G2.Language.Syntax +import G2.Language.Support + +import G2.Language.Monad.AST +import G2.Language.Monad.Support + +appKV :: ExState s m => (KnownValues -> a) -> m a +appKV f = do + kv <- knownValues + return $ f kv + +appKVTEnv :: ExState s m => (KnownValues -> TypeEnv -> a) -> m a +appKVTEnv f = do + kv <- knownValues + tenv <- typeEnv + return $ f kv tenv + +mkDCTrueM :: ExState s m => m DataCon +mkDCTrueM = appKVTEnv mkDCTrue + +mkDCFalseM :: ExState s m => m DataCon +mkDCFalseM = appKVTEnv mkDCFalse + +mkDCIntE :: ExState s m => m Expr +mkDCIntE = appKVTEnv mkDCInt + +mkDCIntegerE :: ExState s m => m Expr +mkDCIntegerE = appKVTEnv mkDCInteger + +mkDCFloatE :: ExState s m => m Expr +mkDCFloatE = appKVTEnv mkDCFloat + +mkDCDoubleE :: ExState s m => m Expr +mkDCDoubleE = appKVTEnv mkDCDouble + +mkTrueE :: ExState s m => m Expr +mkTrueE = appKV mkTrue + +mkFalseE :: ExState s m => m Expr +mkFalseE = appKV mkFalse + +mkConsE :: ExState s m => m Expr +mkConsE = appKVTEnv mkCons + +mkEmptyE :: ExState s m => m Expr +mkEmptyE = appKVTEnv mkEmpty + +modifyAppTopE :: (Monad m, ASTContainerM c Expr) => (Expr -> m Expr) -> c -> m c +modifyAppTopE f = modifyContainedASTsM (modifyAppTopE' f) + +modifyAppTopE' :: Monad m => (Expr -> m Expr) -> Expr -> m Expr +modifyAppTopE' f e@(App _ _) = modifyAppRHSE (modifyAppTopE f) =<< f e +modifyAppTopE' f e = modifyChildrenM (modifyAppTopE' f) e + +modifyAppRHSE :: Monad m => (Expr -> m Expr) -> Expr -> m Expr +modifyAppRHSE f (App e1 e2) = do + e1' <- modifyAppRHSE f e1 + e2' <- f e2 + return $ App e1' e2' +modifyAppRHSE f e = modifyChildrenM f e + +modifyLamTopE :: (Monad m, ASTContainerM c Expr) => (Expr -> m Expr) -> c -> m c +modifyLamTopE f = modifyContainedASTsM (modifyLamTopE' f) + +modifyLamTopE' :: Monad m => (Expr -> m Expr) -> Expr -> m Expr +modifyLamTopE' f e@(Lam _ _ _) = do + e' <- f e + + modifyLamRHSE (modifyLamTopE' f) e' +modifyLamTopE' f e = modifyChildrenM f e + +modifyLamRHSE :: Monad m => (Expr -> m Expr) -> Expr -> m Expr +modifyLamRHSE f (Lam u i e) = return . Lam u i =<< modifyLamRHSE f e +modifyLamRHSE f e = f e + +insertInLamsE :: ExState s m => ([Id] -> Expr -> m Expr) -> Expr -> m Expr +insertInLamsE f = insertInLamsE' f [] + +insertInLamsE' :: ExState s m => ([Id] -> Expr -> m Expr) -> [Id] -> Expr -> m Expr +insertInLamsE' f xs (Lam u i e) = return . Lam u i =<< insertInLamsE' f (i:xs) e +insertInLamsE' f xs e = f (reverse xs) e + +etaExpandToE :: ExState s m => Int -> Expr -> m Expr +etaExpandToE n e = do + eenv <- exprEnv + ng <- nameGen + + let (e', ng') = etaExpandTo eenv ng n e + + putNameGen ng' + return e' diff --git a/src/G2/Language/Monad/ExprEnv.hs b/src/G2/Language/Monad/ExprEnv.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/ExprEnv.hs @@ -0,0 +1,49 @@ +module G2.Language.Monad.ExprEnv ( memberE + , lookupE + , insertE + , mapE + , mapME + , mapWithKeyME ) where + +import G2.Language + +import qualified G2.Language.ExprEnv as E +import G2.Language.Monad.Support + +import Prelude hiding ( filter + , lookup + , map + , null) + +liftEE :: ExState s m => (ExprEnv -> a) -> m a +liftEE f = return . f =<< exprEnv + +memberE :: ExState s m => Name -> m Bool +memberE n = liftEE (E.member n) + +lookupE :: ExState s m => Name -> m (Maybe Expr) +lookupE n = liftEE (E.lookup n) + +insertE :: ExState 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 () +mapE f = do + eenv <- exprEnv + let eenv' = E.map f eenv + putExprEnv eenv' + +mapME :: ExState 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 f = do + eenv <- exprEnv + eenv' <- E.mapWithKeyM f eenv + putExprEnv eenv' diff --git a/src/G2/Language/Monad/Naming.hs b/src/G2/Language/Monad/Naming.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/Naming.hs @@ -0,0 +1,54 @@ +module G2.Language.Monad.Naming ( doRenameN + , doRenamesN + , renameAllN + , freshSeededStringN + , freshSeededStringsN + , freshSeededNameN + , freshSeededNamesN + , freshNameN + , freshNamesN + , freshIdN + , freshSeededIdN + , freshIdsN ) where + +import G2.Language + +import G2.Language.Monad.Support + +import qualified Data.Text as T + +doRenameN :: (ExState 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 ns a = withNG $ \ng -> doRenames ns ng a + +renameAllN :: (ExState s m, Named a) => a -> m a +renameAllN a = withNG (renameAll a) + +freshSeededStringN :: ExState s m => T.Text -> m Name +freshSeededStringN t = withNG (freshSeededString t) + +freshSeededStringsN :: ExState s m => [T.Text] -> m [Name] +freshSeededStringsN t = withNG (freshSeededStrings t) + +freshSeededNameN :: ExState s m => Name -> m Name +freshSeededNameN n = withNG (freshSeededName n) + +freshSeededNamesN :: ExState s m => [Name] -> m [Name] +freshSeededNamesN ns = withNG (freshSeededNames ns) + +freshNameN :: ExState s m => m Name +freshNameN = withNG (freshName) + +freshNamesN :: ExState s m => Int -> m [Name] +freshNamesN i = withNG (freshNames i) + +freshIdN :: ExState s m => Type -> m Id +freshIdN t = withNG (freshId t) + +freshSeededIdN :: (Named n, ExState s m) => n -> Type -> m Id +freshSeededIdN n t = withNG (freshSeededId n t) + +freshIdsN :: ExState s m => [Type] -> m [Id] +freshIdsN ts = withNG (freshIds ts) diff --git a/src/G2/Language/Monad/Primitives.hs b/src/G2/Language/Monad/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/Primitives.hs @@ -0,0 +1,104 @@ +module G2.Language.Monad.Primitives ( mkGeE + , mkGtE + , mkEqE + , mkNeqE + , mkLtE + , mkLeE + , mkAndE + , mkOrE + , mkNotE + , mkPlusE + , mkMinusE + , mkMultE + , mkDivE + , mkModE + , mkNegateE + , mkImpliesE + , mkIffE + , mkFromIntegerE + , mkToIntegerE + , mkEqPrimIntE + , mkEqPrimFloatE + , mkEqPrimDoubleE + , mkEqPrimCharE ) where + +import G2.Language.Primitives +import G2.Language.Syntax +import G2.Language.Support + +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 + +mkGtE :: ExState s m => m Expr +mkGtE = appExpr mkGt + +mkEqE :: ExState s m => m Expr +mkEqE = appExpr mkEq + +mkNeqE :: ExState s m => m Expr +mkNeqE = appExpr mkNeq + +mkLtE :: ExState s m => m Expr +mkLtE = appExpr mkLt + +mkLeE :: ExState s m => m Expr +mkLeE = appExpr mkLe + +mkAndE :: ExState s m => m Expr +mkAndE = appExpr mkAnd + +mkOrE :: ExState s m => m Expr +mkOrE = appExpr mkOr + +mkNotE :: ExState s m => m Expr +mkNotE = appExpr mkNot + +mkPlusE :: ExState s m => m Expr +mkPlusE = appExpr mkPlus + +mkMinusE :: ExState s m => m Expr +mkMinusE = appExpr mkMinus + +mkMultE :: ExState s m => m Expr +mkMultE = appExpr mkMult + +mkDivE :: ExState s m => m Expr +mkDivE = appExpr mkDiv + +mkModE :: ExState s m => m Expr +mkModE = appExpr mkMod + +mkNegateE :: ExState s m => m Expr +mkNegateE = appExpr mkNegate + +mkImpliesE :: ExState s m => m Expr +mkImpliesE = appExpr mkImplies + +mkIffE :: ExState s m => m Expr +mkIffE = appExpr mkIff + +mkFromIntegerE :: ExState s m => m Expr +mkFromIntegerE = appExpr mkFromInteger + +mkToIntegerE :: ExState s m => m Expr +mkToIntegerE = appExpr mkToInteger + +appKV :: ExState s m => (KnownValues -> Expr) -> m Expr +appKV f = return . f =<< knownValues + +mkEqPrimIntE :: ExState s m => m Expr +mkEqPrimIntE = appKV mkEqPrimInt + +mkEqPrimFloatE :: ExState s m => m Expr +mkEqPrimFloatE = appKV mkEqPrimFloat + +mkEqPrimDoubleE :: ExState s m => m Expr +mkEqPrimDoubleE = appKV mkEqPrimDouble + +mkEqPrimCharE :: ExState s m => m Expr +mkEqPrimCharE = appKV mkEqPrimChar diff --git a/src/G2/Language/Monad/Support.hs b/src/G2/Language/Monad/Support.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/Support.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module G2.Language.Monad.Support ( StateM + , ExState (..) + , FullState (..) + , runStateM + , readRecord + , withNG + , mapCurrExpr ) where + +import qualified Control.Monad.State.Lazy as SM + +import G2.Language.Naming +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) + +instance SM.MonadState (State t, Bindings) (StateM t) where + state f = StateM (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 + +-- | Allows access to certain basic components of a state. +class SM.MonadState s m => ExState s m | m -> s where + exprEnv :: m ExprEnv + putExprEnv :: ExprEnv -> m () + + typeEnv :: m TypeEnv + putTypeEnv :: TypeEnv -> m () + + nameGen :: m NameGen + putNameGen :: NameGen -> m () + + knownValues :: m KnownValues + putKnownValues :: KnownValues -> m () + + typeClasses :: m TypeClasses + putTypeClasses :: TypeClasses -> m () + +-- Extends `ExState`, allowing access to a more complete set of the +-- components in the `State`. +class ExState s m => FullState s m | m -> s where + currExpr :: m CurrExpr + putCurrExpr :: CurrExpr -> m () + + inputNames :: m [Name] + fixedInputs :: m [Expr] + +instance ExState (State t, Bindings) (StateM t) where + exprEnv = readRecord (\(s, _) -> expr_env s) + putExprEnv = rep_expr_envM + + 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 + currExpr = readRecord (\(s, _) -> curr_expr s) + putCurrExpr = rep_curr_exprM + + 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) + +readRecord :: SM.MonadState s m => (s -> r) -> m r +readRecord f = return . f =<< SM.get + +rep_expr_envM :: ExprEnv -> StateM t () +rep_expr_envM 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 +withNG f = do + ng <- nameGen + let (a, ng') = f ng + putNameGen ng' + return a + +rep_name_genM :: NameGen -> StateM t () +rep_name_genM ng = do + (s,b) <- SM.get + SM.put $ (s, b {name_gen = ng}) + +rep_known_valuesM :: KnownValues -> StateM t () +rep_known_valuesM 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_curr_exprM :: CurrExpr -> StateM t () +rep_curr_exprM ce = do + (s, b) <- SM.get + SM.put $ (s {curr_expr = ce}, b) + +mapCurrExpr :: FullState s m => (Expr -> m Expr) -> m () +mapCurrExpr f = do + (CurrExpr er e) <- currExpr + e' <- f e + putCurrExpr (CurrExpr er e') diff --git a/src/G2/Language/Monad/TypeClasses.hs b/src/G2/Language/Monad/TypeClasses.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/TypeClasses.hs @@ -0,0 +1,27 @@ +module G2.Language.Monad.TypeClasses ( lookupTCDictTC + , typeClassInstTC + , numTCM + , ordTCM ) where + +import qualified G2.Language.KnownValues as KV +import G2.Language.Syntax +import G2.Language.TypeClasses +import G2.Language.Monad.Support + +import qualified Data.Map as M + +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 m n t = do + tc <- typeClasses + return $ typeClassInst tc m n t + +numTCM :: FullState s m => m Name +numTCM = return . KV.numTC =<< knownValues + +ordTCM :: FullState s m => m Name +ordTCM = return . KV.ordTC =<< knownValues diff --git a/src/G2/Language/Monad/TypeEnv.hs b/src/G2/Language/Monad/TypeEnv.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/TypeEnv.hs @@ -0,0 +1,25 @@ +module G2.Language.Monad.TypeEnv ( lookupT + , insertT ) where + +import G2.Language + +import G2.Language.Monad.Support + +import qualified Data.Map as M + +import Prelude hiding( filter + , lookup + , map + , null) + +liftTE :: ExState s m => (TypeEnv -> a) -> m a +liftTE f = return . f =<< typeEnv + +lookupT :: ExState s m => Name -> m (Maybe AlgDataTy) +lookupT n = liftTE (M.lookup n) + +insertT :: ExState s m => Name -> AlgDataTy -> m () +insertT n t = do + tenv <- typeEnv + let tenv' = M.insert n t tenv + putTypeEnv tenv' diff --git a/src/G2/Language/Monad/Typing.hs b/src/G2/Language/Monad/Typing.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Monad/Typing.hs @@ -0,0 +1,32 @@ +module G2.Language.Monad.Typing ( tyIntT + , tyIntegerT + , tyDoubleT + , tyFloatT + , tyBoolT ) where + +import G2.Language.Syntax +import G2.Language.Support +import G2.Language.Typing + +import G2.Language.Monad.Support + + +appKV :: ExState s m => (KnownValues -> a) -> m a +appKV f = do + kv <- knownValues + return $ f kv + +tyIntT :: ExState s m => m Type +tyIntT = appKV tyInt + +tyIntegerT :: ExState s m => m Type +tyIntegerT = appKV tyInteger + +tyDoubleT :: ExState s m => m Type +tyDoubleT = appKV tyDouble + +tyFloatT :: ExState s m => m Type +tyFloatT = appKV tyFloat + +tyBoolT :: ExState s m => m Type +tyBoolT = appKV tyBool diff --git a/src/G2/Language/Naming.hs b/src/G2/Language/Naming.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Naming.hs @@ -0,0 +1,812 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Language.Naming + ( nameOcc + , nameModule + , nameLoc + , NameGen + , Named (names, rename, renames) + , doRename + , doRenames + , renameAll + , nameToStr + , strToName + , mkNameGen + , varIds + , varNames + , exprNames + , typeNames + + , renameExprs + , renameExpr + , renameVars + + , freshSeededString + , freshSeededStrings + + , freshName + , freshNames + , freshSeededName + , freshSeededNames + + , freshId + , freshSeededId + , freshIds + , freshVar + + , childrenNames + + , mapNG + ) where + +import G2.Language.AST +import G2.Language.KnownValues +import G2.Language.Syntax +import G2.Language.TypeEnv + +import Data.Data (Data, Typeable) +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 qualified Data.Text as T +import Data.Tuple + +nameOcc :: Name -> T.Text +nameOcc (Name occ _ _ _) = occ + +nameModule :: Name -> Maybe T.Text +nameModule (Name _ mb _ _) = mb + +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]) } + 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. +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. +-- Loses location information +strToName :: String -> Name +strToName str = + 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 + +-- | 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 + 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 + } + +-- | Returns all @Var@ Ids in an ASTContainer +varIds :: (ASTContainer m Expr) => m -> [Id] +varIds = evalASTs varIds' + +varIds' :: Expr -> [Id] +varIds' (Var i) = [i] +varIds' _ = [] + +varNames :: (ASTContainer m Expr) => m -> [Name] +varNames = map idName . varIds + +-- Returns every `Name` that appears in an `Expr`, but ignores those only in `Type`s. +exprNames :: (ASTContainer m Expr) => m -> [Name] +exprNames = evalASTs exprTopNames + +exprTopNames :: Expr -> [Name] +exprTopNames (Var var) = [idName var] +exprTopNames (Data dc) = dataConName dc +exprTopNames (Lam _ b _) = [idName b] +exprTopNames (Let kvs _) = map (idName . fst) kvs +exprTopNames (Case _ cvar as) = idName cvar : + concatMap (\(Alt am _) -> altMatchNames am) + as +exprTopNames (Assume (Just is) _ _) = [funcName is] +exprTopNames (Assert (Just is) _ _) = [funcName is] +exprTopNames _ = [] + +altMatchNames :: AltMatch -> [Name] +altMatchNames (DataAlt dc i) = dataConName dc ++ (map idName i) +altMatchNames _ = [] + +dataConName :: DataCon -> [Name] +dataConName (DataCon n _) = [n] + +typeNames :: (ASTContainer m Type) => m -> [Name] +typeNames = evalASTs typeTopNames + +typeTopNames :: Type -> [Name] +typeTopNames (TyVar i) = [idName i] +typeTopNames (TyCon n _) = [n] +typeTopNames (TyForAll (NamedTyBndr v) _) = [idName v] +typeTopNames _ = [] + +doRename :: Named a => Name -> NameGen -> a -> (a, NameGen) +doRename n ngen x = (rename n n' x, ngen') + where (n', ngen') = freshSeededName n ngen + +doRenames :: Named a => [Name] -> NameGen -> a -> (a, NameGen) +doRenames ns ng e = + let + (ns', ng') = freshSeededNames ns ng + hm = HM.fromList $ zip ns ns' + in + (renames hm e, ng') + +renameAll :: (Named a) => a -> NameGen -> (a, NameGen) +renameAll x ng = + let + old = nub $ names x + in + doRenames old ng x + +-- | Types that contain `Name`@s@ +class Named a where + names :: a -> [Name] + rename :: Name -> Name -> a -> a + renames :: HM.HashMap Name Name -> a -> a + + renames hm e = HM.foldrWithKey (\k v -> rename k v) e hm + +instance Named Name where + {-# INLINE names #-} + names n = [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 #-} + renames hm n@(Name _ _ _ l) = + case HM.lookupDefault n n hm of + Name n' m' i _ -> Name n' m' i l + +instance Named Id where + {-# INLINE names #-} + names (Id n t) = n:names t + {-# INLINE rename #-} + rename old new (Id n t) = Id (rename old new n) (rename old new t) + {-# INLINE renames #-} + renames hm (Id n t) = Id (renames hm n) (renames hm t) + +instance Named Expr where + names = eval go + where + go :: Expr -> [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 (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 (Assume is _ _) = names is + go (Assert is _ _) = names is + go _ = [] + + rename old new = modify go + where + go :: Expr -> Expr + go (Var i) = Var (rename old new i) + go (Data d) = Data (rename old new d) + go (Lam u i e) = Lam u (rename old new i) e + 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 (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 (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 + + goAlt :: Alt -> Alt + goAlt (Alt am e) = Alt (rename old new am) e + + renames hm = modify go + where + go :: Expr -> Expr + go (Var i) = Var (renames hm i) + go (Data d) = Data (renames hm d) + go (Lam u i e) = Lam u (renames hm i) e + 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 (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 (Assume is e e') = Assume (renames hm is) e e' + go (Assert is e e') = Assert (renames hm is) e e' + go e = e + + goAlt :: Alt -> Alt + 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 + +-- | Rename only the names in an `Expr` that are the `Name` of an `Id`/`Let`/`Data`/`Case` Binding. +-- Does not change Types. +renameExpr :: ASTContainer m Expr => Name -> Name -> m -> m +renameExpr old new = modifyASTs (renameExpr' old new) + +renameExpr' :: Name -> Name -> Expr -> Expr +renameExpr' old new (Var i) = Var (renameExprId old new i) +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 (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 + +-- | Renames only the @Vars@ in an `Expr`. +renameVars :: ASTContainer m Expr => Name -> Name -> m -> m +renameVars old new = modifyASTs (renameVars' old new) + +renameVars' :: Name -> Name -> Expr -> Expr +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 (Assert is e e') = Assert (fmap (rename old new) is) e e' +renameVars' _ _ e = e + + +renameExprId :: Name -> Name -> Id -> Id +renameExprId old new (Id n t) = Id (rename old new n) t + +renameExprDataCon :: Name -> Name -> DataCon -> DataCon +renameExprDataCon old new (DataCon n t) = DataCon (rename old new n) t + +renameExprAlt :: Name -> Name -> Alt -> Alt +renameExprAlt old new (Alt (DataAlt dc is) e) = + let + dc' = renameExprDataCon old new dc + is' = map (renameExprId old new) is + in + Alt (DataAlt dc' is') e +renameExprAlt _ _ a = a + +renameExprAltIds :: Name -> Name -> Alt -> Alt +renameExprAltIds old new (Alt (DataAlt dc is) e) = + let + is' = map (renameExprId old new) is + in + Alt (DataAlt dc is') e +renameExprAltIds _ _ 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 _ = [] + + 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 t = t + + renames hm = modify go + where + 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 t = t + +-- We don't want both modify and go to recurse on the Type's in TyBinders or 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 + +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 + + {-# INLINE rename #-} + rename old new (Alt am e) = Alt (rename old new am) (rename old new e) + + {-# INLINE renames #-} + renames hm (Alt am e) = Alt (renames hm am) (renames hm e) + +instance Named DataCon where + {-# INLINE names #-} + names (DataCon n t) = n:names t + + {-# INLINE rename #-} + rename old new (DataCon n t) = + DataCon (rename old new n) (rename old new t) + + {-# INLINE renames #-} + renames hm (DataCon n t) = + DataCon (renames hm n) (renames hm t) + +instance Named AltMatch where + {-# INLINE names #-} + names (DataAlt dc i) = names dc ++ names i + names _ = [] + + {-# INLINE rename #-} + rename old new (DataAlt dc i) = + DataAlt (rename old new dc) (rename old new i) + rename _ _ am = am + + {-# INLINE renames #-} + renames hm (DataAlt dc i) = + 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 + 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] + + rename _ _ bp@(Breakpoint _) = bp + rename old new (NamedLoc n) = NamedLoc $ rename old new n + + renames _ bp@(Breakpoint _) = bp + renames hm (NamedLoc n) = NamedLoc $ renames hm n + +instance Named RewriteRule where + names (RewriteRule { ru_head = h + , ru_rough = rs + , ru_bndrs = b + , ru_args = as + , ru_rhs = rhs}) = + h:names rs ++ names b ++ names as ++ names rhs + + rename old new (RewriteRule { ru_name = n + , ru_head = h + , ru_rough = rs + , ru_bndrs = b + , ru_args = as + , ru_rhs = rhs}) = + RewriteRule { ru_name = n + , ru_head = rename old new h + , ru_rough = rename old new rs + , ru_bndrs = rename old new b + , ru_args = rename old new as + , ru_rhs = rename old new rhs} + + renames hm (RewriteRule { ru_name = n + , ru_head = h + , ru_rough = rs + , ru_bndrs = b + , ru_args = as + , ru_rhs = rhs}) = + RewriteRule { ru_name = n + , ru_head = renames hm h + , ru_rough = renames hm rs + , ru_bndrs = renames hm b + , ru_args = renames hm as + , ru_rhs = renames hm rhs} + +instance Named FuncCall where + names (FuncCall {funcName = n, arguments = as, returns = r}) = n: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} ) = + FuncCall {funcName = renames hm n, arguments = renames hm as, returns = renames hm r} + + +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 + + 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) + rename old new (TypeSynonym is st) = (TypeSynonym (rename old new is) (rename old new st)) + + renames hm (DataTyCon n dc) = DataTyCon (renames hm n) (renames hm dc) + renames hm (NewTyCon n dc rt) = NewTyCon (renames hm n) (renames hm dc) (renames hm rt) + renames hm (TypeSynonym is st) = TypeSynonym (renames hm is) (renames hm st) + +instance Named KnownValues where + names (KnownValues { + dcInt = dI + , dcFloat = dF + , dcDouble = dD + , dcInteger = dI2 + , dcChar = dcCh + + , tyInt = tI + , tyFloat = tF + , tyDouble = tD + , tyInteger = tI2 + , tyChar = tCh + + , tyBool = tB + , dcTrue = dcT + , dcFalse = dcF + + , tyList = tList + , dcCons = tCons + , dcEmpty = tEmp + + , eqTC = eqT + , numTC = numT + , ordTC = ordT + , integralTC = integralT + + , eqFunc = eqF + , neqFunc = neqF + + , plusFunc = plF + , minusFunc = minusF + , timesFunc = tmsF + , divFunc = divF + , negateFunc = negF + , modFunc = modF + , fromIntegerFunc = fromIntegerF + , toIntegerFunc = toIntegerF + + , geFunc = geF + , gtFunc = gtF + , ltFunc = ltF + , leFunc = leF + + , structEqTC = seT + , structEqFunc = seF + + , andFunc = andF + , orFunc = orF + + , 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] + + rename old new (KnownValues { + dcInt = dI + , dcFloat = dF + , dcDouble = dD + , dcInteger = dI2 + , dcChar = dcCh + + , tyInt = tI + , tyFloat = tF + , tyDouble = tD + , tyInteger = tI2 + , tyChar = tCh + + , tyBool = tB + , dcTrue = dcT + , dcFalse = dcF + + , tyList = tList + , dcCons = tCons + , dcEmpty = tEmp + + , eqTC = eqT + , numTC = numT + , ordTC = ordT + , integralTC = integralT + + , eqFunc = eqF + , neqFunc = neqF + + , plusFunc = plF + , minusFunc = minusF + , timesFunc = tmsF + , divFunc = divF + , negateFunc = negF + , modFunc = modF + , fromIntegerFunc = fromIntegerF + , toIntegerFunc = toIntegerF + + , geFunc = geF + , gtFunc = gtF + , ltFunc = ltF + , leFunc = leF + + , structEqTC = seT + , structEqFunc = seF + + , andFunc = andF + , orFunc = orF + + , patErrorFunc = patE + }) = + (KnownValues { + dcInt = rename old new dI + , dcFloat = rename old new dF + , dcDouble = rename old new dD + , dcInteger = rename old new dI2 + , dcChar = rename old new dcCh + + , tyInt = rename old new tI + , tyFloat = rename old new tF + , tyDouble = rename old new tD + , tyInteger = rename old new tI2 + , tyChar = rename old new tCh + + , tyBool = rename old new tB + , dcTrue = rename old new dcT + , dcFalse = rename old new dcF + , tyList = rename old new tList + , dcCons = rename old new tCons + , dcEmpty = rename old new tEmp + + , eqTC = rename old new eqT + , numTC = rename old new numT + , ordTC = rename old new ordT + , integralTC = rename old new integralT + + , eqFunc = rename old new eqF + , neqFunc = rename old new neqF + + , plusFunc = rename old new plF + , minusFunc = rename old new minusF + , timesFunc = rename old new tmsF + , 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 + + , 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 + + , andFunc = rename old new andF + , orFunc = rename old new orF + + , patErrorFunc = rename old new patE + }) + +instance Named a => Named [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 + {-# INLINE rename #-} + rename old new = fmap (rename old new) + {-# INLINE renames #-} + renames hm = fmap (renames hm) + +instance Named a => Named (M.Map k 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 (HM.HashMap k 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 () where + {-# INLINE names #-} + names _ = [] + {-# INLINE rename #-} + rename _ _ = id + {-# INLINE renames #-} + renames _ = id + +instance (Named s, Hashable s, Eq s) => Named (HS.HashSet s) where + {-# INLINE names #-} + names = names . HS.toList + {-# INLINE rename #-} + rename old new = HS.map (rename old new) + {-# INLINE renames #-} + renames hm = HS.map (renames hm) + +instance (Named a, Named b) => Named (a, b) where + 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 + 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 + 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 + 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 Int where + {-# INLINE names #-} + names _ = [] + {-# INLINE rename #-} + rename _ _ = id + +instance Named T.Text where + {-# INLINE names #-} + names _ = [] + {-# INLINE rename #-} + rename _ _ = id + +freshSeededString :: T.Text -> NameGen -> (Name, NameGen) +freshSeededString t = freshSeededName (Name t Nothing 0 Nothing) + +freshSeededStrings :: [T.Text] -> NameGen -> ([Name], NameGen) +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) + 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' + +freshName :: NameGen -> (Name, NameGen) +freshName ngen = freshSeededName seed ngen + where + seed = Name "fs?" Nothing 0 Nothing + +freshNames :: Int -> NameGen -> ([Name], NameGen) +freshNames i ngen = freshSeededNames (replicate i (Name "fs?" Nothing 0 Nothing)) ngen + +freshId :: Type -> NameGen -> (Id, NameGen) +freshId = freshSeededId (Name "fs?" Nothing 0 Nothing) + +freshIds :: [Type] -> NameGen -> ([Id], NameGen) +freshIds ts ngen = + let + (ns, ngen') = freshNames (length ts) ngen + in + (map (uncurry Id) (zip ns ts), ngen') + +freshSeededId :: Named a => a -> Type -> NameGen -> (Id, NameGen) +freshSeededId x t ngen = + let + (n, ngen') = freshSeededName (head $ names x) ngen + in + (Id n t, ngen') + +freshVar :: Type -> NameGen -> (Expr, NameGen) +freshVar t ngen = + let + (i, ngen') = freshId t ngen + 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 [] +{-# 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') diff --git a/src/G2/Language/PathConds.hs b/src/G2/Language/PathConds.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/PathConds.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# 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 + +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 GHC.Generics (Generic) +import Data.Hashable +import qualified Data.HashSet as HS +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import Prelude hiding (map, filter, null) +import qualified Prelude as P (map) + +-- 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) + +-- | 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) + +-- | 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 + deriving (Show, Eq, Read, Generic, Typeable, Data) + +type Constraint = PathCond +type Assertion = PathCond + +instance Hashable PathCond + +{-# INLINE toMap #-} +toMap :: PathConds -> M.Map (Maybe Name) (HS.HashSet PathCond, [Name]) +toMap = coerce + +{-# INLINE empty #-} +-- | Constructs an empty `PathConds`. +empty :: PathConds +empty = PathConds M.empty + +fromList :: KV.KnownValues -> [PathCond] -> PathConds +fromList kv = coerce . foldr (insert kv) empty + +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 + +-- 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' :: (KV.KnownValues -> PathCond -> [Name]) -> KV.KnownValues -> PathCond -> PathConds -> PathConds +insert' f kv p (PathConds pcs) = + let + ns = f kv p + + (hd, insertAt) = case ns of + [] -> (Nothing, [Nothing]) + (h:_) -> (Just h, P.map Just ns) + 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') + +{-# INLINE number #-} +number :: PathConds -> Int +number = length . toList + +{-# 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 + +-- 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) = + let + epc = case M.lookup Nothing pcm of + Just v -> PathConds $ M.singleton Nothing v + Nothing -> PathConds M.empty + + ns = catMaybes $ M.keys pcm + 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')) + [] -> [] + + +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 :: KV.KnownValues -> PathCond -> [Name] +varNamesInPC kv = P.map idName . varIdsInPC kv + +{-# INLINE scc #-} +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 + +{-# INLINE toList #-} +toList :: PathConds -> [PathCond] +toList = concatMap (HS.toList . fst) . M.elems . toMap + +isPCExists :: PathCond -> Bool +isPCExists (PCExists _) = True +isPCExists _ = False + +instance ASTContainer PathConds Expr where + containedASTs = containedASTs . toMap + + modifyContainedASTs f = coerce . modifyContainedASTs f . toMap + +instance ASTContainer PathConds Type where + containedASTs = containedASTs . toMap + + modifyContainedASTs f = coerce . modifyContainedASTs f . toMap + +instance ASTContainer PathCond Expr where + containedASTs (ExtCond e _ ) = [e] + containedASTs (AltCond _ e _) = [e] + containedASTs (ConsCond _ e _) = [e] + containedASTs (PCExists _) = [] + + 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 + +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 + + 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) + +instance Named PathConds where + names (PathConds pc) = (catMaybes $ M.keys pc) ++ concatMap (\(p, n) -> names p ++ n) pc + + rename old new (PathConds pc) = + PathConds . M.mapKeys (\k -> if k == (Just old) then (Just new) else k) + $ rename old new pc + + renames hm (PathConds pc) = + PathConds . M.mapKeys (renames hm) + $ renames hm pc + +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 + + 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) + + 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) + +instance Ided PathConds where + ids = ids . toMap + +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] diff --git a/src/G2/Language/Primitives.hs b/src/G2/Language/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Primitives.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Language.Primitives 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 + +mkGt :: E.ExprEnv -> Expr +mkGt = mkPrim Gt + +mkEq :: E.ExprEnv -> Expr +mkEq = mkPrim Eq + +mkEq' :: KnownValues -> Expr +mkEq' kv = Var (Id (eqFunc kv) TyBottom) + +mkNeq :: E.ExprEnv -> Expr +mkNeq = mkPrim Neq + +mkLt :: E.ExprEnv -> Expr +mkLt = mkPrim Lt + +mkLe :: E.ExprEnv -> Expr +mkLe = mkPrim Le + +mkAnd :: E.ExprEnv -> Expr +mkAnd = mkPrim And + +mkOr :: E.ExprEnv -> Expr +mkOr = mkPrim Or + +mkNot :: E.ExprEnv -> Expr +mkNot = mkPrim Not + +mkPlus :: E.ExprEnv -> Expr +mkPlus = mkPrim Plus + +mkMinus :: E.ExprEnv -> Expr +mkMinus = mkPrim Minus + +mkMult :: E.ExprEnv -> Expr +mkMult = mkPrim Mult + +mkDiv :: E.ExprEnv -> Expr +mkDiv = mkPrim Div + +mkMod :: E.ExprEnv -> Expr +mkMod = mkPrim Mod + +mkNegate :: E.ExprEnv -> Expr +mkNegate = mkPrim Negate + +mkImplies :: E.ExprEnv -> Expr +mkImplies = mkPrim Implies + +mkIff :: E.ExprEnv -> Expr +mkIff = mkPrim Iff + +mkFromInteger :: E.ExprEnv -> Expr +mkFromInteger = mkPrim FromInteger + +mkToInteger :: E.ExprEnv -> Expr +mkToInteger = mkPrim ToInteger + +-- Primitives on primitive types +mkEqPrimType :: Type -> KnownValues -> Expr +mkEqPrimType t kv = + Prim Eq $ TyFun t (TyFun t (TyCon (KV.tyBool kv) TYPE)) + +mkEqPrimInt :: KnownValues -> Expr +mkEqPrimInt = mkEqPrimType TyLitInt + +mkEqPrimFloat :: KnownValues -> Expr +mkEqPrimFloat = mkEqPrimType TyLitFloat + +mkEqPrimDouble :: KnownValues -> Expr +mkEqPrimDouble = mkEqPrimType TyLitDouble + +mkEqPrimChar :: KnownValues -> Expr +mkEqPrimChar = mkEqPrimType TyLitChar diff --git a/src/G2/Language/Stack.hs b/src/G2/Language/Stack.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Stack.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} + +module G2.Language.Stack + ( Stack + , empty + , null + , push + , pop + , popN + , toList) where + +import Prelude hiding (null) +import Data.Data (Data, Typeable) +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) + +-- | Get an empty `Stack`. +empty :: Stack a +empty = Stack [] + +-- | Is the `Stack` empty? +null :: Stack a -> Bool +null = L.null . toList + +-- | Push a `Frame` 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 :: 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 + +instance ASTContainer a Expr => ASTContainer (Stack a) Expr where + containedASTs (Stack s) = containedASTs s + modifyContainedASTs f (Stack s) = Stack $ modifyContainedASTs f s + +instance ASTContainer a Type => ASTContainer (Stack a) Type where + containedASTs (Stack s) = containedASTs s + modifyContainedASTs f (Stack s) = Stack $ modifyContainedASTs f s + +instance Named a => Named (Stack a) where + names (Stack s) = names s + rename old new (Stack s) = Stack $ rename old new s + renames hm (Stack s) = Stack $ renames hm s diff --git a/src/G2/Language/Support.hs b/src/G2/Language/Support.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Support.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module G2.Language.Support + ( module G2.Language.AST + , module G2.Language.Support + , module G2.Language.TypeEnv + , E.ExprEnv + , PathConds + , KnownValues + , PathCond (..) + , Constraint + , Assertion + ) where + +import G2.Language.AST +import qualified G2.Language.ExprEnv as E +import G2.Language.KnownValues +import G2.Language.Naming +import G2.Language.Stack +import G2.Language.Syntax +import G2.Language.TypeClasses +import G2.Language.TypeEnv +import G2.Language.Typing +import G2.Language.PathConds hiding (map, filter) +import G2.Execution.RuleTypes + +import Data.Data (Data, Typeable) +import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet 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. +-- 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 + , path_conds :: PathConds -- ^ Path conditions, in SWHNF + , non_red_path_conds :: [Expr] -- ^ Path conditions that still need further reduction + , 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 + , track :: t + } deriving (Show, Eq, Read, Typeable, Data) + +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 + , input_names :: [Name] + , rewrite_rules :: ![RewriteRule] + , name_gen :: NameGen + } deriving (Show, Eq, Read, Typeable, Data) + +-- | The `InputIds` are a list of the variable names passed as input to the +-- function being symbolically executed +type InputIds = [Id] + +inputIds :: State t -> Bindings -> InputIds +inputIds (State { expr_env = eenv }) (Bindings { input_names = ns }) = + map (\n -> case E.lookup n eenv of + 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) + +-- | 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 +-- to check, but this makes clearer distinctions for writing the +-- evaluation code. +data EvalOrReturn = Evaluate + | Return + deriving (Show, Eq, Read, Typeable, Data) + +-- Used to map names (typically of ADTs) to corresponding autogenerated function names +type Walkers = M.Map Name Id + +-- Map new names to old ones +type CleanedNames = HM.HashMap Name Name + +data ArbValueGen = ArbValueGen { intGen :: Integer + , floatGen :: Rational + , doubleGen :: Rational + , charGen :: [Char] + , 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] + | ApplyFrame Expr + | UpdateFrame Name + | CastFrame Coercion + | CurrExprFrame CurrExpr + | AssumeFrame Expr + | AssertFrame (Maybe FuncCall) Expr + deriving (Show, Eq, Read, Typeable, Data) + +-- | 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'}) + +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) + + 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) + $ 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 = 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) + , tags = tags s } + + renames hm s = + State { expr_env = renames hm (expr_env s) + , type_env = + M.mapKeys (renames hm) + $ renames hm (type_env s) + , curr_expr = renames hm (curr_expr s) + , path_conds = renames hm (path_conds s) + , non_red_path_conds = renames hm (non_red_path_conds s) + , 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) + , tags = tags s } + +instance ASTContainer t Expr => ASTContainer (State t) Expr where + containedASTs s = (containedASTs $ type_env s) ++ + (containedASTs $ expr_env s) ++ + (containedASTs $ curr_expr s) ++ + (containedASTs $ path_conds s) ++ + (containedASTs $ assert_ids s) ++ + (containedASTs $ symbolic_ids s) ++ + (containedASTs $ exec_stack s) ++ + (containedASTs $ track 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 } + +instance ASTContainer t Type => ASTContainer (State t) Type where + containedASTs s = ((containedASTs . expr_env) s) ++ + ((containedASTs . type_env) s) ++ + ((containedASTs . curr_expr) s) ++ + ((containedASTs . path_conds) s) ++ + ((containedASTs . assert_ids) s) ++ + ((containedASTs . type_classes) s) ++ + ((containedASTs . symbolic_ids) s) ++ + ((containedASTs . exec_stack) s) ++ + (containedASTs $ track 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 + , 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 } + +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) + + rename old new b = + Bindings { fixed_inputs = rename old new (fixed_inputs b) + , deepseq_walkers = rename old new (deepseq_walkers b) + , arb_value_gen = arb_value_gen b + , cleaned_names = HM.insert new old (cleaned_names b) + , higher_order_inst = rename old new (higher_order_inst b) + , input_names = rename old new (input_names b) + , rewrite_rules = rename old new (rewrite_rules b) + , name_gen = name_gen b + } + + renames hm b = + Bindings { fixed_inputs = renames hm (fixed_inputs b) + , deepseq_walkers = renames hm (deepseq_walkers b) + , arb_value_gen = arb_value_gen b + , cleaned_names = foldr (\(old, new) -> HM.insert new old) (cleaned_names b) (HM.toList hm) + , higher_order_inst = renames hm (higher_order_inst b) + , input_names = renames hm (input_names b) + , rewrite_rules = renames hm (rewrite_rules b) + , name_gen = name_gen b + } + +instance ASTContainer Bindings Expr where + containedASTs b = (containedASTs $ fixed_inputs b) ++ (containedASTs $ input_names b) + + modifyContainedASTs f b = b { fixed_inputs = modifyContainedASTs f $ fixed_inputs b + , input_names = modifyContainedASTs f $ input_names b } + +instance ASTContainer Bindings Type where + containedASTs b = ((containedASTs . fixed_inputs) b) ++ ((containedASTs . input_names) b) + + modifyContainedASTs f b = b { fixed_inputs = (modifyContainedASTs f . fixed_inputs) b + , input_names = (modifyContainedASTs f . input_names) b } + +instance ASTContainer CurrExpr Expr where + containedASTs (CurrExpr _ e) = [e] + modifyContainedASTs f (CurrExpr er e) = CurrExpr er (f e) + +instance ASTContainer CurrExpr Type where + containedASTs (CurrExpr _ e) = containedASTs e + modifyContainedASTs f (CurrExpr er e) = CurrExpr er (modifyContainedASTs f e) + +instance ASTContainer Frame Expr where + containedASTs (CaseFrame _ a) = containedASTs a + containedASTs (ApplyFrame e) = [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 (ApplyFrame e) = ApplyFrame (f e) + modifyContainedASTs f (CurrExprFrame e) = CurrExprFrame (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 (ApplyFrame 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 (ApplyFrame e) = ApplyFrame (modifyContainedASTs f e) + modifyContainedASTs f (CurrExprFrame e) = CurrExprFrame (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 + +instance Named CurrExpr where + names (CurrExpr _ e) = names e + rename old new (CurrExpr er e) = CurrExpr er $ rename old new e + renames hm (CurrExpr er e) = CurrExpr er $ renames hm e + +instance Named Frame where + names (CaseFrame i a) = names i ++ names a + names (ApplyFrame e) = names e + names (UpdateFrame n) = [n] + names (CastFrame c) = names c + names (CurrExprFrame e) = names e + names (AssumeFrame e) = 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 (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 (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 (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 (AssumeFrame e) = AssumeFrame (renames hm e) + renames hm (AssertFrame is e) = AssertFrame (renames hm is) (renames hm e) diff --git a/src/G2/Language/Syntax.hs b/src/G2/Language/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Syntax.hs @@ -0,0 +1,289 @@ +{-# 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`. +module G2.Language.Syntax + ( module G2.Language.Syntax + ) where + +import GHC.Generics (Generic) +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] + +-- | Binds `Id`s to `Expr`s, primarily in @let@ `Expr`s +type Binds = [(Id, Expr)] + +-- | Records a location in the source code +data Loc = Loc { line :: Int + , col :: Int + , file :: String } deriving (Show, Eq, Read, Ord, Generic, Typeable, Data) + +instance Hashable Loc + +-- | Records a span in the source code. +-- +-- Invariant: +-- +-- > file start == file end +data Span = Span { start :: Loc + , end :: Loc } deriving (Show, Eq, Read, Ord, Generic, Typeable, Data) + +instance Hashable Span + +-- | A name has three pieces: an occurence name, Maybe a module name, and a Unique Id. +data Name = Name T.Text (Maybe T.Text) Int (Maybe Span) + deriving (Show, Read, Generic, Typeable, Data) + +-- | Disregards the Span +instance Eq Name where + Name n m i _ == Name n' m' i' _ = n == n' && m == m' && i == i' + +-- | Disregards the Span +instance Ord Name where + Name n m i _ `compare` Name n' m' i' _ = (n, m, i) `compare` (n', m', i') + +-- | Disregards the Span +instance Hashable Name where + hashWithSalt s (Name n m i _) = + s `hashWithSalt` + n `hashWithSalt` + m `hashWithSalt` i + +-- | Pairing of a `Name` with a `Type` +data Id = Id Name Type deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable Id + +-- | Indicates the purpose of the a Lambda binding +data LamUse = TermL -- ^ Binds at the term level + | TypeL -- ^ Binds at the type level + deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable LamUse + +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. + + 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@. + + 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 + | Lit Lit + | Prim Primitive Type + | Data DataCon + | App Expr Expr + | Lam LamUse Id Expr + | Let Binds Expr + | Case Expr Id [Alt] + | Type Type + | Cast Expr Coercion + | Coercion Coercion + | Tick Tickish Expr + | NonDet [Expr] + | SymGen Type + | Assume (Maybe FuncCall) Expr Expr + | Assert (Maybe FuncCall) Expr Expr + deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable Expr + +-- | These are known, and G2-augmented operations, over unwrapped +-- data types such as Int#, Char#, Double#, etc. +-- Generally, calls to these should actually be created using the functions in: +-- +-- "G2.Language.Primitives" +-- +-- And evaluation over literals can be peformed with the functions in: +-- +-- "G2.Execution.PrimitiveEval" +data Primitive = Ge + | Gt + | Eq + | Neq + | Lt + | Le + | And + | Or + | Not + | Implies + | Iff + | Plus + | Minus + | Mult + | Div + | DivInt + | Quot + | Mod + | Negate + | SqRt + | IntToFloat + | IntToDouble + | FromInteger + | ToInteger + | ToInt + | Error + | Undefined + | BindFunc + deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable Primitive + +-- | Literals for denoting unwrapped types such as Int#, Double#. +data Lit = LitInt Integer + | LitFloat Rational + | LitDouble Rational + | LitChar Char + | LitString String + | LitInteger Integer + deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable Lit + +-- | Data constructor. +data DataCon = DataCon Name Type deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable DataCon + +-- | AltMatches. +data AltMatch = DataAlt DataCon [Id] -- ^ Match a datacon. The number of `Id`s + -- must match the number of term arguments + -- for the datacon. + | LitAlt Lit + | Default + deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable AltMatch + +-- | `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) + +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 + +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 + | TYPE + | TyUnknown + deriving (Show, Eq, Read, Generic, Typeable, Data) + +type Kind = Type + +instance Hashable Type + +data Tickish = Breakpoint Span -- ^ A breakpoint for the GHC Debugger + | NamedLoc Name -- ^ A G2 specific tick, intended to allow, + -- in concert with a @`Reducer`@, for domain + -- specific modifications to a + -- @`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_head :: Name + , ru_rough :: [Maybe Name] + , ru_bndrs :: [Id] + , ru_args :: [Expr] + , ru_rhs :: Expr } deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable RewriteRule + +-- | Represents a function call, with it's arguments and return value as Expr +data FuncCall = FuncCall { funcName :: Name + , arguments :: [Expr] + , returns :: Expr } deriving (Show, Eq, Read, Generic, Typeable, Data) + +instance Hashable FuncCall diff --git a/src/G2/Language/TypeClasses.hs b/src/G2/Language/TypeClasses.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/TypeClasses.hs @@ -0,0 +1,5 @@ +module G2.Language.TypeClasses ( module G2.Language.TypeClasses.Extra + , module G2.Language.TypeClasses.TypeClasses ) where + +import G2.Language.TypeClasses.Extra +import G2.Language.TypeClasses.TypeClasses diff --git a/src/G2/Language/TypeClasses/Extra.hs b/src/G2/Language/TypeClasses/Extra.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/TypeClasses/Extra.hs @@ -0,0 +1,52 @@ +module G2.Language.TypeClasses.Extra ( eqTCDict + , numTCDict + , ordTCDict + , integralTCDict + , structEqTCDict + , lookupStructEqDicts + , concreteSatEq + , concreteSatStructEq + , concreteSatTC ) where + +import G2.Language.KnownValues +import G2.Language.Syntax +import G2.Language.TypeClasses.TypeClasses +import G2.Language.Typing + +import Data.List +import Data.Maybe + +eqTCDict :: KnownValues -> TypeClasses -> Type -> Maybe Id +eqTCDict kv tc t = lookupTCDict tc (eqTC kv) t + +numTCDict :: KnownValues -> TypeClasses -> Type -> Maybe Id +numTCDict kv tc t = lookupTCDict tc (numTC kv) t + +ordTCDict :: KnownValues -> TypeClasses -> Type -> Maybe Id +ordTCDict kv tc t = lookupTCDict tc (ordTC kv) t + +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) diff --git a/src/G2/Language/TypeClasses/TypeClasses.hs b/src/G2/Language/TypeClasses/TypeClasses.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/TypeClasses/TypeClasses.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module G2.Language.TypeClasses.TypeClasses ( TypeClasses + , Class (..) + , initTypeClasses + , insertClass + , unionTypeClasses + , isTypeClassNamed + , isTypeClass + , lookupTCDict + , lookupTCDicts + , tcDicts + , typeClassInst + , satisfyingTCTypes + , satisfyingTC + , toMap) where + +import G2.Language.AST +import G2.Language.KnownValues (KnownValues) +import G2.Language.Naming +import G2.Language.Syntax +import G2.Language.Typing + +import Data.Coerce +import Data.Data (Data, Typeable) +import Data.List +import qualified Data.Map as M +import Data.Maybe + +data Class = Class { insts :: [(Type, Id)], typ_ids :: [Id]} + deriving (Show, Eq, Read, Typeable, Data) + +type TCType = M.Map Name Class +newtype TypeClasses = TypeClasses TCType + deriving (Show, Eq, Read, Typeable, Data) + +initTypeClasses :: [(Name, Id, [Id])] -> TypeClasses +initTypeClasses nsi = + let + ns = map (\(n, _, i) -> (n, i)) nsi + nsi' = filter (not . null . insts . snd) + $ map (\(n, i) -> (n, Class { insts = mapMaybe (nameIdToTypeId n) nsi, typ_ids = i } )) ns + in + coerce $ M.fromList nsi' + +insertClass :: Name -> Class -> TypeClasses -> TypeClasses +insertClass n c (TypeClasses tc) = TypeClasses (M.insert n c tc) + +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, _) = + 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 _ = Nothing + +isTypeClassNamed :: Name -> TypeClasses -> Bool +isTypeClassNamed n = M.member n . (coerce :: TypeClasses -> TCType) + +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 +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 + +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 + +-- tcDicts +tcDicts :: TypeClasses -> [Id] +tcDicts = map snd . concatMap insts . M.elems . coerce + +tyConAppName :: Type -> Maybe Name +tyConAppName (TyCon n _) = Just n +tyConAppName _ = Nothing + +-- 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 tc m tcn t + | tca@(TyCon _ _) <- tyAppCenter t + , ts <- tyAppArgs t + , tcs <- map (typeClassInst tc m tcn) ts + , all (isJust) tcs = + case lookupTCDict tc tcn tca of + Just i -> Just (foldl' App (Var i) $ map Type ts ++ map fromJust tcs) + Nothing -> Nothing + | (TyVar (Id n _)) <- tyAppCenter t + , ts <- tyAppArgs t + , tcs <- map (typeClassInst tc m tcn) ts + , all (isJust) tcs = + case M.lookup n m of + Just i -> Just (foldl' App (Var i) $ map Type ts ++ map fromJust tcs) + 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] +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 + +substKind :: Id -> [Type] -> [Type] +substKind (Id _ t) ts = map (\t' -> case t' of + TyCon n _ -> TyCon n (tyFunToTyApp t) + t'' -> t'') ts + +tyFunToTyApp :: Type -> Type +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) + 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 + +toMap :: TypeClasses -> M.Map Name Class +toMap = coerce + +instance ASTContainer TypeClasses Expr where + containedASTs _ = [] + modifyContainedASTs _ = id + +instance ASTContainer TypeClasses Type where + containedASTs = containedASTs . (coerce :: TypeClasses -> TCType) + modifyContainedASTs f = + coerce . modifyContainedASTs f . (coerce :: TypeClasses -> TCType) + +instance ASTContainer Class Expr where + containedASTs _ = [] + modifyContainedASTs _ = id + +instance ASTContainer Class Type where + containedASTs = containedASTs . insts + modifyContainedASTs f c = Class { insts = modifyContainedASTs f $ insts c + , typ_ids = modifyContainedASTs f $ typ_ids c} + +instance Named TypeClasses where + names = names . (coerce :: TypeClasses -> TCType) + 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 + rename old new c = Class { insts = rename old new $ insts c + , typ_ids = rename old new $ typ_ids c } + renames hm c = Class { insts = renames hm $ insts c + , typ_ids = renames hm $ typ_ids c } diff --git a/src/G2/Language/TypeEnv.hs b/src/G2/Language/TypeEnv.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/TypeEnv.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module G2.Language.TypeEnv + ( TypeEnv + + , 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 + +import G2.Language.AST +import G2.Language.Syntax +import G2.Language.Typing +import G2.Language.AlgDataTy + +import Data.List +import qualified Data.Map as M +import Data.Maybe + +-- | 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 + +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 +argTypesTEnv :: TypeEnv -> [Type] +argTypesTEnv = concatMap (evalASTs argTypesTEnv') . M.elems + +argTypesTEnv' :: Type -> [Type] +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 + +-- 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)]) +getCastedAlgDataTy t tenv + | TyCon n _ <- tyAppCenter t + , ts <- tyAppArgs t = getCastedAlgDataTy' n ts tenv + | otherwise = Nothing + +-- TODO : CHECK CORRECTNESS OF BOUND ARGS +getCastedAlgDataTy' :: Name -> [Type] -> TypeEnv -> Maybe (AlgDataTy, [(Id, Type)]) +getCastedAlgDataTy' n ts tenv = + case M.lookup n tenv of + Just (NewTyCon {rep_type = TyCon n' _}) -> getCastedAlgDataTy' n' ts tenv + Just (NewTyCon { }) -> Nothing + (Just dc@(DataTyCon { bound_ids = bi })) -> Just (dc, zip bi ts) + _ -> Nothing + +getAlgDataTy :: Type -> TypeEnv -> Maybe (AlgDataTy, [(Id, Type)]) +getAlgDataTy t tenv + | TyCon n _ <- tyAppCenter t + , ts <- tyAppArgs t = getAlgDataTy' n ts tenv + | otherwise = Nothing + +getAlgDataTy' :: Name -> [Type] -> TypeEnv -> Maybe (AlgDataTy, [(Id, Type)]) +getAlgDataTy' n ts tenv = + case M.lookup n tenv of + Just dc@(NewTyCon {bound_ids = bi}) -> Just (dc, zip bi ts) + Just dc@(DataTyCon { bound_ids = bi }) -> Just (dc, zip bi ts) + _ -> 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 + +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' + +dataConWithNameMod :: AlgDataTy -> Name -> Maybe DataCon +dataConWithNameMod (DataTyCon _ dcs) n = listToMaybe $ filter (flip 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 diff --git a/src/G2/Language/Typing.hs b/src/G2/Language/Typing.hs new file mode 100644 --- /dev/null +++ b/src/G2/Language/Typing.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Type Checker +-- Provides type checking capabilities over G2 Language. +module G2.Language.Typing + ( Typed (..) + , PresType (..) + , tyInt + , tyInteger + , tyDouble + , tyFloat + , tyBool + , mkTyApp + , mkTyFun + , tyAppCenter + , tyAppArgs + , unTyApp + , mkTyCon + , mkFullAppedTyCon + , (.::) + , (.::.) + , specializes + , hasFuncType + , appendType + , higherOrderFuncs + , isTYPE + , isTyFun + , hasTYPE + , isTyVar + , hasTyBottom + , tyVars + , tyVarIds + , tyVarNames + , hasTyFuns + , isPolyFunc + , numArgs + , ArgType (..) + , argumentTypes + , argTypeToType + , argTypeToLamUse + , spArgumentTypes + , leadingTyForAllBindings + , tyForAllBindings + , anonArgumentTypes + , returnType + , polyIds + , splitTyForAlls + , splitTyFuns + , retype + , mapInTyForAlls + , inTyForAlls + , numTypeArgs + , typeToExpr + , getTyApps + , tyAppsToExpr + ) where + +import G2.Language.AST +import qualified G2.Language.KnownValues as KV +import G2.Language.Syntax + +import qualified Data.Map as M +import qualified Data.List as L +import Data.Monoid hiding (Alt) + +tyInt :: KV.KnownValues -> Type +tyInt kv = TyCon (KV.tyInt kv) (tyTYPE kv) + +tyInteger :: KV.KnownValues -> Type +tyInteger kv = TyCon (KV.tyInteger kv) (tyTYPE kv) + +tyDouble :: KV.KnownValues -> Type +tyDouble kv = TyCon (KV.tyDouble kv) (tyTYPE kv) + +tyFloat :: KV.KnownValues -> Type +tyFloat kv = TyCon (KV.tyFloat kv) (tyTYPE kv) + +tyBool :: KV.KnownValues -> Type +tyBool kv = TyCon (KV.tyBool kv) (tyTYPE kv) + +tyTYPE :: KV.KnownValues -> Type +tyTYPE _ = TYPE + +-- | mkTyFun +-- Turns the Expr list into an application spine +mkTyFun :: [Type] -> Type +mkTyFun [] = error "mkTyFun: empty list" +mkTyFun [t] = t +mkTyFun (t1:ts) = TyFun t1 (mkTyFun ts) + +tyAppCenter :: Type -> Type +tyAppCenter (TyApp t _) = tyAppCenter t +tyAppCenter t = t + +tyAppArgs :: Type -> [Type] +tyAppArgs (TyApp t t') = tyAppArgs t ++ [t'] +tyAppArgs _ = [] + +mkTyApp :: [Type] -> Type +mkTyApp [] = TYPE +mkTyApp (t:[]) = t +mkTyApp (t1:t2:ts) = mkTyApp (TyApp t1 t2 : ts) + +mkTyCon :: Name + -> [Type] + -> Kind + -> Type +mkTyCon n ts k = mkTyApp $ TyCon n k:ts + +-- | Makes a fully applied TyCon. +-- Since the TyCon is fully applied, we can figure out its kind based on it's +-- arguments and result kind. +mkFullAppedTyCon :: Name + -> [Type] -- ^ Type arguments + -> Kind -- ^ Result kind + -> Type +mkFullAppedTyCon n ts k = + let + tsk = mkTyFun $ map typeOf ts ++ [k] + in + mkTyApp $ TyCon n tsk:ts + +-- | unTyApp +-- Unravels the application spine. +unTyApp :: Type -> [Type] +unTyApp (TyApp t t') = unTyApp t ++ [t'] +unTyApp t = [t] + +-- | Typed typeclass. +class Typed a where + typeOf :: a -> Type + typeOf = typeOf' M.empty + + typeOf' :: M.Map Name Type -> a -> Type + +instance Typed Id where + typeOf' m (Id _ ty) = tyVarRename m ty + +instance Typed Lit where + typeOf (LitInt _) = TyLitInt + typeOf (LitFloat _) = TyLitFloat + typeOf (LitDouble _) = TyLitDouble + typeOf (LitChar _) = TyLitChar + typeOf (LitString _) = TyLitString + typeOf (LitInteger _) = TyLitInt + + typeOf' _ t = typeOf t + +instance Typed DataCon where + typeOf' _ (DataCon _ ty) = ty + +instance Typed Alt where + typeOf' m (Alt _ expr) = typeOf' m expr + +instance Typed Expr where + typeOf' m (Var v) = typeOf' m v + typeOf' m (Lit lit) = typeOf' m lit + typeOf' _ (Prim _ ty) = ty + typeOf' m (Data dcon) = typeOf' m dcon + typeOf' m a@(App _ _) = + let + as = passedArgs a + t = typeOf' m $ appCenter a + in + appTypeOf M.empty t as + typeOf' m (Lam u b e) = + case u of + TypeL -> TyForAll (NamedTyBndr 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' _ (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' m (Assert _ _ e) = typeOf' m e + typeOf' m (Assume _ _ e) = typeOf' m e + +passedArgs :: Expr -> [Expr] +passedArgs = reverse . passedArgs' + +passedArgs' :: Expr -> [Expr] +passedArgs' (App e e') = e':passedArgs' e +passedArgs' _ = [] + +appCenter :: Expr -> Expr +appCenter (App a _) = appCenter a +appCenter e = e + +appTypeOf :: M.Map Name Type -> Type -> [Expr] -> Type +appTypeOf m (TyForAll (NamedTyBndr 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 (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 _ t es = error ("appTypeOf\n" ++ show t ++ "\n" ++ show es ++ "\n\n") + +instance Typed Type where + typeOf' _ (TyVar (Id _ t)) = t + typeOf' _ (TyFun _ _) = TYPE + typeOf' m (TyApp t1 t2) = + let + ft = typeOf' m t1 + at = typeOf' m t2 + in + case (ft, at) of + ((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' _ TyLitInt = TYPE + typeOf' _ TyLitFloat = TYPE + typeOf' _ TyLitDouble = TYPE + typeOf' _ TyLitChar = TYPE + typeOf' _ TyLitString = TYPE + typeOf' _ TYPE = TYPE + typeOf' _ TyBottom = TyBottom + typeOf' _ TyUnknown = TyUnknown + +newtype PresType = PresType Type deriving (Show, Read) + +instance Typed PresType where + typeOf' _ (PresType t) = t + +-- | Retyping +-- We look to see if the type we potentially replace has a TyVar whose Id is a +-- match on the target key that we want to replace. +retype :: (ASTContainer m Type, Show m) => Id -> Type -> m -> m +retype key new e = modifyContainedASTs (retype' key new) $ e + +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 + +tyVarRename :: (ASTContainer t Type) => M.Map Name Type -> t -> t +tyVarRename m = modifyASTs (tyVarRename' m) + +tyVarRename' :: M.Map Name Type -> Type -> Type +tyVarRename' m t@(TyVar (Id n _)) = M.findWithDefault t n m +tyVarRename' _ t = t + +-- | 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 +{-# INLINE (.::) #-} + +-- | Checks if the first type is equivalent to the second type. +-- That is, @e@ has type @t1@ iff @e@ has type @t2@. +(.::.) :: Type -> Type -> Bool +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 _)) = + 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) + +hasFuncType :: (Typed t) => t -> Bool +hasFuncType t = + case typeOf t of + (TyFun _ _) -> True + (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] +higherOrderFuncs = higherOrderFuncs' . typeOf + +higherOrderFuncs' :: Type -> [Type] +higherOrderFuncs' = eval higherOrderFuncs'' + +higherOrderFuncs'' :: Type -> [Type] +higherOrderFuncs'' (TyFun t@(TyFun _ _) _) = [t] +higherOrderFuncs'' _ = [] + +isTYPE :: Type -> Bool +isTYPE TYPE = True +isTYPE (TyCon (Name "TYPE" _ _ _) _) = True +isTYPE _ = False + +hasTYPE :: Type -> Bool +hasTYPE TYPE = True +hasTYPE (TyCon (Name "TYPE" _ _ _) _) = True +hasTYPE (TyFun t t') = hasTYPE t || hasTYPE t' +hasTYPE (TyApp t t') = hasTYPE t || hasTYPE t' +hasTYPE _ = False + +isTyVar :: Type -> Bool +isTyVar (TyVar _) = True +isTyVar _ = False + +isTyFun :: Type -> Bool +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' + +tyVarIds' :: Type -> [Id] +tyVarIds' (TyVar i) = [i] +tyVarIds' _ = [] + +-- | Returns a list of all tyVars Names +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 +numArgs :: Typed t => t -> Int +numArgs = length . argumentTypes + +data ArgType = AnonType Type | NamedType Id + +-- | 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' (TyFun t1 t2) = t1:argumentTypes' t2 +argumentTypes' _ = [] + +argTypeToType :: ArgType -> Type +argTypeToType (AnonType t) = t +argTypeToType (NamedType i) = TyVar i + +argTypeToLamUse :: ArgType -> LamUse +argTypeToLamUse (AnonType _) = TermL +argTypeToLamUse (NamedType _) = TypeL + +spArgumentTypes :: Typed t => t -> [ArgType] +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' (TyFun t1 t2) = AnonType t1:spArgumentTypes' t2 +spArgumentTypes' _ = [] + +leadingTyForAllBindings :: Typed t => t -> [Id] +leadingTyForAllBindings = leadingTyForAllBindings' . typeOf + +leadingTyForAllBindings' :: Type -> [Id] +leadingTyForAllBindings' (TyForAll (NamedTyBndr 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' (TyFun t t') = tyForAllBindings' t ++ tyForAllBindings t' +tyForAllBindings' _ = [] + +anonArgumentTypes :: Typed t => t -> [Type] +anonArgumentTypes = anonArgumentTypes' . typeOf + +anonArgumentTypes' :: Type -> [Type] +anonArgumentTypes' (TyForAll _ t) = anonArgumentTypes' t +anonArgumentTypes' (TyFun t1 t2) = t1:anonArgumentTypes' t2 +anonArgumentTypes' _ = [] + +-- | Gives the return type if the given function type is fully saturated +returnType :: Typed t => t -> Type +returnType = returnType' . typeOf + +returnType' :: Type -> Type +returnType' (TyForAll _ t) = returnType' t +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) = + 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' +splitTyFuns t = [t] + +-- | Nests a new type in TyForAlls +mapInTyForAlls :: (Type -> Type) -> Type -> Type +mapInTyForAlls f (TyForAll b t) = TyForAll b $ mapInTyForAlls f t +mapInTyForAlls f t = f t + +-- | Extracts the type inside TyForAlls, recursively +inTyForAlls :: Type -> Type +inTyForAlls (TyForAll _ t) = inTyForAlls t +inTyForAlls t = t + +numTypeArgs :: Typed t => t -> Int +numTypeArgs = numTypeArgs' . typeOf + +numTypeArgs' :: Type -> Int +numTypeArgs' (TyForAll (NamedTyBndr _) t) = 1 + numTypeArgs' t +numTypeArgs' _ = 0 + +-- | Converts nested TyApps into a list of Expr-level Types +typeToExpr :: Type -> [Expr] +typeToExpr (TyApp f t) = [Type t] ++ (typeToExpr f) +typeToExpr _ = [] + +-- | Find nested tyApps, if any, in the given Type +getTyApps :: Type -> Maybe Type +getTyApps (TyForAll _ t) = getTyApps t +getTyApps (TyFun t _) = getTyApps t +getTyApps t@(TyApp _ _) = Just t +getTyApps _ = Nothing + +-- | Given sequence of nested tyApps e.g. tyApp (tyApp ...) ...), returns list of expr level Types, searching through [Id,Type] list in the process +tyAppsToExpr :: Type -> [(Id, Type)] -> [Expr] +tyAppsToExpr (TyApp t (TyVar tVarId)) bindings = exprs ++ newTyExpr + where + newTyExpr = + case (L.find (\(i, _) -> (tVarId == i)) bindings) of -- search list of (Id, Type) to find corresponding Type, and convert to expr + (Just (_, ty)) -> [Type ty] + Nothing -> [] + exprs = tyAppsToExpr t bindings +tyAppsToExpr (TyApp t1 t2) bindings = exprs ++ newTyExpr + where + newTyExpr = [Type t2] + exprs = tyAppsToExpr t1 bindings +tyAppsToExpr _ _ = [] + + diff --git a/src/G2/Lib/Printers.hs b/src/G2/Lib/Printers.hs new file mode 100644 --- /dev/null +++ b/src/G2/Lib/Printers.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Lib.Printers ( mkCleanExprHaskell + , mkUnsugaredExprHaskell + , ppExprEnv + , ppRelExprEnv + , ppCurrExpr + , ppPathConds + , ppPathCond + , pprExecStateStr + , pprExecEEnvStr) where + +import G2.Execution.Memory +import G2.Language.Expr +import qualified G2.Language.ExprEnv as E +import G2.Language.KnownValues +import G2.Language.Naming +import qualified G2.Language.PathConds as PC +import G2.Language.TypeClasses +import G2.Language.Typing +import G2.Language.Stack +import G2.Language.Syntax +import G2.Language.Support + +import Data.Char +import Data.List +import qualified Data.HashMap.Lazy as HM +import qualified Data.Map as M +import qualified Data.Text as T + +mkIdHaskell :: Id -> String +mkIdHaskell (Id n _) = mkNameHaskell n + +mkNameHaskell :: Name -> String +mkNameHaskell = T.unpack . nameOcc + +mkUnsugaredExprHaskell :: State t -> Expr -> String +mkUnsugaredExprHaskell (State {known_values = kv, type_classes = tc}) = + mkExprHaskell False kv . modifyFix (mkCleanExprHaskell' kv tc) + +mkCleanExprHaskell :: State t -> Expr -> String +mkCleanExprHaskell (State {known_values = kv, type_classes = tc}) = + mkExprHaskell True kv . modifyFix (mkCleanExprHaskell' kv tc) + +mkCleanExprHaskell' :: KnownValues -> TypeClasses -> Expr -> 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' + + | (App e' e'') <- e + , t <- typeOf e' + , isTypeClass tc t = e'' + + | (App e' e'') <- e + , t <- typeOf e'' + , isTypeClass tc t = e' + + | App e' (Type _) <- e = e' + + | otherwise = e + +mkExprHaskell :: Bool -> KnownValues -> Expr -> String +mkExprHaskell sugar kv ex = mkExprHaskell' ex 0 + 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 + + mkExprHaskell' a@(App ea@(App e1 e2) e3) i + | Data (DataCon n _) <- appCenter a + , isTuple n + , sugar = printTuple kv a + + | Data (DataCon n1 _) <- e1 + , nameOcc n1 == ":" + , sugar = + if isLitChar e2 then printString a else printList kv a + + | isInfixable e1 = + 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 + in + e2P ++ " " ++ mkExprHaskell' e1 i ++ " " ++ e3P + + | App _ _ <- e3 = mkExprHaskell' ea i ++ " (" ++ mkExprHaskell' e3 i ++ ")" + | otherwise = mkExprHaskell' ea i ++ " " ++ mkExprHaskell' e3 i + + 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" + + mkAltHaskell :: Int -> Alt -> String + mkAltHaskell i (Alt am e) = + off i ++ mkAltMatchHaskell am ++ " -> " ++ mkExprHaskell' e i + +mkAltMatchHaskell :: AltMatch -> String +mkAltMatchHaskell (DataAlt dc ids) = mkDataConHaskell dc ++ " " ++ intercalate " " (map mkIdHaskell ids) +mkAltMatchHaskell (LitAlt l) = mkLitHaskell l +mkAltMatchHaskell Default = "_" + +mkDataConHaskell :: DataCon -> String +-- Special casing for Data.Map in the modified base +mkDataConHaskell (DataCon (Name "Assocs" _ _ _) _) = "fromList" +mkDataConHaskell (DataCon n _) = mkNameHaskell n + +off :: Int -> String +off i = duplicate " " i + +printList :: KnownValues -> Expr -> String +printList kv a = "[" ++ intercalate ", " (printList' kv a) ++ "]" + +printList' :: KnownValues -> Expr -> [String] +printList' kv (App (App _ e) e') = mkExprHaskell True kv e:printList' kv e' +printList' _ _ = [] + +printString :: Expr -> String +printString a = + let + str = printString' a + in + if all isPrint str then "\"" ++ str ++ "\"" + else "[" ++ intercalate ", " (map stringToEnum str) ++ "]" + 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' _ = [] + +isTuple :: Name -> Bool +isTuple (Name n _ _ _) = T.head n == '(' && T.last n == ')' + && T.all (\c -> c == '(' || c == ')' || c == ',') n + +printTuple :: KnownValues -> Expr -> String +printTuple kv a = "(" ++ intercalate ", " (reverse $ printTuple' kv a) ++ ")" + +printTuple' :: KnownValues -> Expr -> [String] +printTuple' kv (App e e') = mkExprHaskell True kv e':printTuple' kv e +printTuple' _ _ = [] + + +isInfixable :: Expr -> Bool +isInfixable (Data (DataCon n _)) = not $ T.any isAlphaNum $ nameOcc n +isInfixable _ = False + +isApp :: Expr -> Bool +isApp (App _ _) = True +isApp _ = False + +isLitChar :: Expr -> Bool +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 + +mkPrimHaskell :: Primitive -> String +mkPrimHaskell Ge = ">=" +mkPrimHaskell Gt = ">" +mkPrimHaskell Eq = "==" +mkPrimHaskell Neq = "/=" +mkPrimHaskell Lt = "<" +mkPrimHaskell Le = "<=" +mkPrimHaskell And = "&&" +mkPrimHaskell Or = "||" +mkPrimHaskell Not = "not" +mkPrimHaskell Plus = "+" +mkPrimHaskell Minus = "-" +mkPrimHaskell Mult = "*" +mkPrimHaskell Div = "/" +mkPrimHaskell DivInt = "/" +mkPrimHaskell Quot = "quot" +mkPrimHaskell Mod = "mod" +mkPrimHaskell Negate = "-" +mkPrimHaskell SqRt = "sqrt" +mkPrimHaskell IntToFloat = "fromIntegral" +mkPrimHaskell IntToDouble = "fromIntegral" +mkPrimHaskell FromInteger = "fromInteger" +mkPrimHaskell ToInteger = "toInteger" +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." + +duplicate :: String -> Int -> String +duplicate _ 0 = "" +duplicate s n = s ++ duplicate s (n - 1) + +ppExprEnv :: State t -> String +ppExprEnv s@(State {expr_env = eenv}) = + let + eenvs = M.toList $ E.map' (mkUnsugaredExprHaskell s) eenv + in + intercalate "\n" $ map (\(n, es) -> mkNameHaskell n ++ " = " ++ es) eenvs + +-- | 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 = + let + (s', _) = markAndSweep s b + in + ppExprEnv s' + +ppCurrExpr :: State t -> String +ppCurrExpr s@(State {curr_expr = CurrExpr _ e}) = mkUnsugaredExprHaskell s e + +ppPathConds :: State t -> String +ppPathConds s@(State {path_conds = pc}) = intercalate "\n" $ PC.map (ppPathCond s) pc + +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) = + let + es = mkUnsugaredExprHaskell s e + in + if b then es else "not (" ++ es ++ ")" +ppPathCond s (ConsCond dc e b) = + let + dcs = mkDataConHaskell dc + es = mkUnsugaredExprHaskell s e + in + if b then es ++ " is " ++ dcs else es ++ " is not " ++ dcs +ppPathCond _ (PCExists i) = "Exists " ++ mkIdHaskell i + +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 ex_state b = injNewLine acc_strs + where + eenv_str = pprExecEEnvStr (expr_env ex_state) + tenv_str = pprTEnvStr (type_env ex_state) + 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) + 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) + walkers_str = show (deepseq_walkers b) + cleaned_str = pprCleanedNamesStr (cleaned_names b) + model_str = pprModelStr (model ex_state) + rules_str = intercalate "\n" $ map show (zip ([0..] :: [Integer]) $ rules ex_state) + acc_strs = [ ">>>>> [State] >>>>>>>>>>>>>>>>>>>>>" + , "----- [Code] ----------------------" + , code_str + , "----- [Stack] ---------------------" + , estk_str + , "----- [Env] -----------------------" + , eenv_str + , "----- [TEnv] -----------------------" + , tenv_str + , "----- [Names] ---------------------" + , names_str + , "----- [Input Ids] -----------------" + , input_str + , "----- [Walkers] -------------------" + , walkers_str + , "----- [Paths] ---------------------" + , paths_str + , "----- [Non Red Paths] ---------------------" + , non_red_paths_str + , "----- [True Assert] ---------------------" + , "True Assert = " ++ show (true_assert ex_state) + , "----- [Assert Ids] ---------------------" + , show (assert_ids ex_state) + , "----- [TypeClasses] ---------------------" + , tc_str + , "----- [Cleaned] -------------------" + , cleaned_str + , "----- [Model] -------------------" + , model_str + , "----- [Rules] -------------------" + , rules_str + , "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" + ] + +pprExecEEnvStr :: E.ExprEnv -> String +pprExecEEnvStr eenv = injNewLine kv_strs + where + kv_strs = map (show) $ E.toList eenv + +pprTEnvStr :: TypeEnv -> String +pprTEnvStr tenv = injNewLine kv_strs + where + kv_strs = map show $ M.toList tenv + +pprModelStr :: Model -> String +pprModelStr m = injNewLine kv_strs + where + kv_strs = map show $ M.toList m + +pprExecStackStr :: Stack Frame -> String +pprExecStackStr stk = injNewLine frame_strs + where + frame_strs = map pprExecFrameStr $ toList stk + +pprExecFrameStr :: Frame -> String +pprExecFrameStr frame = show frame + +pprExecCodeStr :: CurrExpr -> String +pprExecCodeStr code = show code + +pprExecNamesStr :: NameGen -> String +pprExecNamesStr _ = "" + +pprPathsStr :: [PathCond] -> String +pprPathsStr paths = injNewLine cond_strs + where + cond_strs = map pprPathCondStr paths + +pprTCStr :: TypeClasses -> String +pprTCStr tc = injNewLine cond_strs + where + cond_strs = map show $ M.toList $ toMap tc + +pprInputIdsStr :: InputIds -> String +pprInputIdsStr i = injNewLine id_strs + where + 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 + +pprCleanedNamesStr :: CleanedNames -> String +pprCleanedNamesStr = injNewLine . map show . HM.toList + diff --git a/src/G2/Liquid/AddCFBranch.hs b/src/G2/Liquid/AddCFBranch.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/AddCFBranch.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.AddCFBranch (addCounterfactualBranch) where + +import G2.Language +import G2.Language.Monad +import G2.Liquid.Types + +-- 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 +-- up the var, and set the curr expr to its definition. +-- (b) [StateB] The other branch introduces a new symbolic variable x_s, +-- with the same type of s, and sets the curr expr to +-- let x = x_s in Assert (a x'_1 ... x'_n x_s) x_s +-- appropriately binding x'_i to x_i in the expression environment +-- +-- This allows us to choose any value for the return type of the function. +-- In this rule, we also return a b, oldb `mappend` [(f, [x_1, ..., x_n], x)] +-- 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 + cfn <- freshSeededStringN "cf" + mapWithKeyME (addCounterfactualBranch' cfn ns) + return cfn + +addCounterfactualBranch' :: Name -> [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'' 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 + + -- 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 + + 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 + + return $ NonDet [orig_e, e'] +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 + +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'" diff --git a/src/G2/Liquid/AddLHTC.hs b/src/G2/Liquid/AddLHTC.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/AddLHTC.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.AddLHTC ( addLHTC + , addLHTCExprPasses ) where + +import G2.Language +import G2.Language.Monad +import G2.Liquid.Types + +import qualified Data.Map as M + +-- | Adds the LiquidHaskell typeclass to all functions in the ExprEnv, and to +-- the current expression. This requires: +-- 1. Adding Lambda bindings for the LH TC +-- 2. Passing the LH TC typeclass to functions +-- 3. Updating all type information +addLHTC :: LHStateM () +addLHTC = do + mapME addLHTCExprEnv + + (CurrExpr er ce) <- currExpr + ce' <- addLHTCExprPasses M.empty ce + putCurrExpr (CurrExpr er ce') + +addLHTCExprEnv :: Expr -> LHStateM Expr +addLHTCExprEnv e = do + e' <- addTypeLams e + e'' <- addTypeLamsLet e' + (e''', m) <- addLHTCExprEnvLams [] e'' + addLHTCExprEnvPasses m e''' + +-- Rewrites a type to make type lambdas explicit +-- This is needed so that addLHTCExprEnvLams can insert the LH Dict after the type correctly. +-- In generally, it's not always correct to eta-expand Haskell functions, but +-- it is fine here because the type arguments are guaranteed to not be undefined +addTypeLams :: Expr -> LHStateM Expr +addTypeLams e = + let + t = typeOf e + in + addTypeLams' t e + +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 = + return . Lam TypeL i =<< addTypeLams' t (App e (Type (TyVar i))) +addTypeLams' _ e = return e + +-- | Let bindings may be passed Type parameters, but have no type lambdas, +-- so we have to add Lambdas to Let's as well. +addTypeLamsLet :: Expr -> LHStateM Expr +addTypeLamsLet = modifyM addTypeLamsLet' + +addTypeLamsLet' :: Expr -> LHStateM Expr +addTypeLamsLet' (Let be e) = do + be' <- mapM (\(b, e') -> do + e'' <- addTypeLams e' + return (b, e'') + ) be + return (Let be' e) +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 is (Lam TypeL i e) = do + (e', m) <- addLHTCExprEnvLams (i:is) e + return (Lam TypeL i e', m) +addLHTCExprEnvLams is e = do + lh <- lhTCM + + let is' = reverse is + let is'' = map (TyApp (TyCon lh (TyApp TYPE TYPE)) . TyVar) $ is' + is''' <- freshIdsN is'' + + -- Lambdas may be nested in an Expr (for example, if the lambda is in a Let) + -- So hear we dig down, and recursively apply addLHTCExprEnvLams to any + -- nested Lambdas + (le, m') <- addLHTCExprEnvNextLams e + + let e' = foldr (Lam TermL) le is''' + + let m = M.fromList $ zip (map idName is') is''' + + return (e', M.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 (App e1 e2) = do + (e1', m1) <- addLHTCExprEnvNextLams e1 + (e2', m2) <- addLHTCExprEnvNextLams e2 + return (App e1' e2', M.union m1 m2) +addLHTCExprEnvNextLams e@(Lam TypeL _ _) = addLHTCExprEnvLams [] e +addLHTCExprEnvNextLams (Lam TermL i e) = do + (e', m) <- addLHTCExprEnvNextLams e + return (Lam TermL i e', m) +addLHTCExprEnvNextLams (Let b e) = do + (b', ms) <- return . unzip =<< mapM (\(b', be) -> do + (be', m) <- addLHTCExprEnvNextLams be + return ((b', be'), m) + ) b + (e', m) <- addLHTCExprEnvNextLams e + + return (Let b' e', foldr M.union M.empty (m:ms)) +addLHTCExprEnvNextLams (Case e i 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) +addLHTCExprEnvNextLams (Cast e c) = do + (e', m) <- addLHTCExprEnvNextLams e + return (Cast e' c, m) +addLHTCExprEnvNextLams e@(Coercion _) = return (e, M.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) +addLHTCExprEnvNextLams (Assume fc e1 e2) = do + (e1', m1) <- addLHTCExprEnvNextLams e1 + (e2', m2) <- addLHTCExprEnvNextLams e2 + return (Assume fc e1' e2', M.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) + +addLHTCExprEnvNextLamsAlt :: Alt -> LHStateM (Alt, M.Map Name Id) +addLHTCExprEnvNextLamsAlt (Alt am e) = do + (e', m) <- addLHTCExprEnvNextLams e + return (Alt am e', m) + +-- Updates each function call, so that it is passed the appropriate LH TC. +-- 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 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 m = modifyAppTopE (addLHTCExprPasses' m) + +addLHTCExprPasses' :: M.Map 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'' + +addLHTCExprPasses' _ e = return e + +addLHTCExprPasses'' :: M.Map Name Id -> [Expr] -> [Expr] -> LHStateM [Expr] +addLHTCExprPasses'' _ es [] = return $ reverse es +addLHTCExprPasses'' m es (te@(Type t):es') = do + dict <- lhTCDict m t + as <- addLHTCExprPasses'' m (dict:es) es' + return $ te:as +addLHTCExprPasses'' m es (e:es') + | Var (Id n _) <- e + , Just dict <- M.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. +-- 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 m = modifyASTsM (addLHDictToTypes' m) + +addLHDictToTypes' :: M.Map Name Id -> Expr -> LHStateM Expr +addLHDictToTypes' m (Var (Id n t)) = return . Var . Id n =<< addLHDictToTypes'' m t +addLHDictToTypes' _ e = return e + +addLHDictToTypes'' :: M.Map Name Id -> Type -> LHStateM Type +addLHDictToTypes'' m t@(TyForAll (NamedTyBndr _) _) = 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''' m is t = do + lh <- lhTCM + let is' = reverse is + let dictT = map (TyApp (TyCon lh (TyApp 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 + -- in the TyForAll's + t' <- addLHDictToTypes'' m t + + return $ foldr TyFun t' dictT + +lhTCDict :: M.Map 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) + where + -- typeClassInstTC adds any needed LH Dict arguments for us. + -- Unfortunately, the LH Dicts are then added AGAIN, by addLHTCExprEnvPasses + -- So we just drop the LH Dicts added by typeClassInstTC, and everything works out + dropAppedLH :: Expr -> Expr + dropAppedLH (App e t'@(Type _)) = App (dropAppedLH e) t' + dropAppedLH (App e _) = dropAppedLH e + dropAppedLH e = e diff --git a/src/G2/Liquid/AddOrdToNum.hs b/src/G2/Liquid/AddOrdToNum.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/AddOrdToNum.hs @@ -0,0 +1,152 @@ +-- | Adds the Ord typeclass into the Num typeclass. +-- We need this to work with refinements like: +-- +-- @ +-- {-@ sub :: Num a => {x:a | x > 0} -> {y:a | y >= 0} @-} +-- @ +-- +-- which only have a prerequisite of Num, but use Ord functions in the refinement. +-- Not all Num types have an Ord instance. However, we will only try +-- to extact it in LH refinement types, and LH only allows Num/Ord to be +-- used with Ints or Integers. So this is perfectly safe. + +module G2.Liquid.AddOrdToNum (addOrdToNum) where + +import G2.Language +import G2.Language.Monad +import G2.Liquid.Types + +-- | Adds an extra field to the Num dict, which contains the Ord +-- dict for the corresponding type. Updates all other code accordingly. +-- Of course, there might be types that have a Num instance, but no Ord +-- instance. These types dicts have the field filled in with Prim Undefined +addOrdToNum :: LHStateM () +addOrdToNum = do + tc <- typeClasses + num <- numTCM + + -- Rewrite dictionary declaration + let tcd = lookupTCDicts num tc + case tcd of + Just tcd' -> mapM_ (uncurry addOrdToNumDictDec) tcd' + Nothing -> return () + + -- Rewrite case statements + mapME addOrdToNumCase + mapMeasuresM addOrdToNumCase + + -- Rewrite the types of Num DataCons + mapME changeNumType + mapMeasuresM changeNumType + + -- Update Type Environment + changeNumTypeEnv + + -- Create a function to extract the Ord Dict + ordDictFunc + +addOrdToNumDictDec :: Type -> Id -> LHStateM () +addOrdToNumDictDec t (Id n _) = do + ord <- ordTCM + + me <- lookupE n + + case me of + Just e -> do + ordD <- lookupTCDictTC ord t + let ordD' = maybe (Prim Undefined TyBottom) Var ordD + + e' <- insertInLamsE (\_ e'' -> return (App e'' ordD')) e + + insertE 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]) + | (TyCon n ts) <- tyAppCenter t = do + num <- numTCM + ord <- ordTCM + + let ordT = mkTyApp (TyCon ord ts:tyAppArgs t) + + 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) + | otherwise = return ce +addOrdToNumCase' e = return e + +changeNumType :: Expr -> LHStateM Expr +changeNumType e = do + num <- numTCM + modifyASTsM (changeNumType' num) e + +changeNumType' :: Name -> Expr -> LHStateM Expr +changeNumType' num d@(Data dc) + | (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]) + | num == n = do + dc' <- changeNumTypeDC dc + return (Case e i [Alt (DataAlt dc' is) ae]) + | otherwise = return ce +changeNumType' _ e = return e + +changeNumTypeDC :: DataCon -> LHStateM DataCon +changeNumTypeDC (DataCon n t) = do + t' <- changeNumTypeType Nothing t + 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 i (TyFun t t') = return . TyFun t =<< changeNumTypeType i t' +changeNumTypeType i t = do + ord <- ordTCM + let ordT = TyCon ord TYPE + + case i of + Just i' -> return $ TyFun (TyApp ordT (TyVar i')) t + Nothing -> return (TyFun ordT t) + +changeNumTypeEnv :: LHStateM () +changeNumTypeEnv = do + num <- numTCM + + adt <- lookupT num + + case adt of + Just adt'@(DataTyCon {data_cons = [dc]}) -> do + dc' <- changeNumTypeDC dc + insertT num $ adt' {data_cons = [dc']} + _ -> return () + +-- Must be called after updating the TypeEnv, with changeNumTypeEnv, so that +-- the Num DataCon has it's correct type +ordDictFunc :: LHStateM () +ordDictFunc = do + num <- numTCM + let numT = TyCon num TYPE + + Just numDC <- lookupT num + let [numDC'] = dataCon numDC + + let numA = dataConArgs numDC' + + lamI <- freshIdN numT + caseI <- freshIdN numT + + binds <- freshIdsN numA + let cOrdBIs = last binds + + let e = Lam TermL lamI $ Case (Var lamI) caseI [Alt (DataAlt numDC' binds) (Var cOrdBIs)] + + (Id n _) <- lhNumOrdM + insertE n e + + return () diff --git a/src/G2/Liquid/Annotations.hs b/src/G2/Liquid/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Annotations.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.Annotations ( AnnotMap + , getAnnotations + , lookupAnnot + , lookupAnnotAtLoc) where + +import G2.Language +import G2.Language.Monad +import G2.Liquid.Conversion +import G2.Liquid.Types + +import Language.Haskell.Liquid.Liquid() +import Language.Haskell.Liquid.Constraint.Types hiding (ghcI) +import Language.Haskell.Liquid.Types hiding (Loc, names) +import Language.Haskell.Liquid.Types.RefType + +import G2.Translation.Haskell + +import qualified Data.HashMap.Lazy as HM +import Data.Hashable +import Data.List +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T + +import SrcLoc + +import Debug.Trace + +lookupAnnot :: Name -> AnnotMap -> Maybe [(Maybe T.Text, Expr)] +lookupAnnot (Name _ _ _ (Just s)) = + HM.lookup s . unAnnotMap +lookupAnnot _ = const Nothing + +lookupAnnotAtLoc :: Name -> AnnotMap -> Maybe [(Maybe T.Text, Expr)] +lookupAnnotAtLoc (Name _ _ _ (Just (Span {start = l}))) = + Just . concatMap snd . find (\(Span {start = l'}, _) -> l == l') . HM.toList . unAnnotMap +lookupAnnotAtLoc _ = const Nothing + +getAnnotations :: [LHOutput] -> LHStateM () +getAnnotations ghci_cg = do + locM <- return . locLookup =<< exprEnv + + let anna = map lhCleanAnnotMaps ghci_cg + mapM_ (annotMapToExpr locM) anna + +annotMapToExpr :: M.Map Loc Name -> AnnInfo SpecType -> LHStateM () +annotMapToExpr locM (AI st) = mapM_ (uncurry (valToExpr locM)) (HM.toList st) + +valToExpr :: M.Map Loc Name -> SrcSpan -> [(Maybe T.Text, SpecType)] -> LHStateM () +valToExpr locM srcspn = + case mkSpan srcspn of + Just spn -> mapM_ (valToExpr' locM spn) + Nothing -> return . const () + +valToExpr' :: M.Map Loc Name -> Span -> (Maybe T.Text, SpecType) -> LHStateM () +valToExpr' locM spn@(Span {start = stloc}) (n, ast) = do + e <- case M.lookup stloc locM of + Just n' -> lookupE n' + Nothing -> return Nothing + + t <- specTypeToType ast + + case (e, t) of + (Just e', Just t') -> do + let i = Id (Name "ret" Nothing 0 Nothing) t' + let ai = leadingLamUsesIds e' + dm <- dictMapFromIds (map snd ai) + + ce <- convertSpecType dm M.empty (map snd ai) (Just i) ast + let ce' = addIds ce (ai ++ [(TermL, i)]) + + insertAnnotM spn n ce' + _ -> return () + +lhCleanAnnotMaps :: LHOutput -> AnnInfo SpecType +lhCleanAnnotMaps (LHOutput {cgI = cgi, solution = sol}) = + applySolution sol $ closeAnnots $ annotMap cgi + +addIds :: Expr -> [(LamUse, Id)] -> Expr +addIds e ((u, i):is) = Lam u i $ addIds e is +-- addIds e@(Lam _ ei _) ((u, i):is) = if i == ei then e else Lam u i $ addIds e is +addIds e _ = e + +-- modeled after Language.Haskell.Liquid.UX.Annotate +closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType +closeAnnots = closeA . filterA . collapseA + +closeA :: AnnInfo (Annot b) -> AnnInfo b +closeA a@(AI m) = cf <$> a + where + cf (AnnLoc l) = case m `mlookup` l of + [(_, AnnUse t)] -> t + [(_, AnnDef t)] -> t + [(_, AnnRDf t)] -> t + _ -> error $ "malformed AnnInfo: " ++ show l + cf (AnnUse t) = t + cf (AnnDef t) = t + cf (AnnRDf t) = t + +mlookup :: (Eq k, Show k, Hashable k) => HM.HashMap k v -> k -> v +mlookup m k = fromMaybe err $ HM.lookup k m + where + err = error $ "mlookup: unknown key " ++ show k + +filterA :: AnnInfo (Annot t) -> AnnInfo (Annot t) +filterA (AI m) = AI (HM.filter ff m) + where + ff [(_, AnnLoc l)] = l `HM.member` m + ff _ = True + +collapseA :: AnnInfo (Annot t) -> AnnInfo (Annot t) +collapseA (AI m) = AI (fmap pickOneA m) + +pickOneA :: [(t, Annot t1)] -> [(t, Annot t1)] +pickOneA xas = case (rs, ds, ls, us) of + (x:_, _, _, _) -> [x] + (_, x:_, _, _) -> [x] + (_, _, _:_, _) -> trace ("Loc") [] + (_, _, _, x:_) -> [x] + + -- (_, x:_, _, _) -> [x] + -- (_, _, x:_, _) -> [x] + -- (_, _, _, x:_) -> [x] + (_, _, _, _ ) -> [ ] + where + rs = [x | x@(_, AnnRDf _) <- xas] + ds = [x | x@(_, AnnDef _) <- xas] + ls = [x | x@(_, AnnLoc _) <- xas] + us = [x | x@(_, AnnUse _) <- xas] diff --git a/src/G2/Liquid/Conversion.hs b/src/G2/Liquid/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Conversion.hs @@ -0,0 +1,687 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Liquid.Conversion ( LHDictMap + , DictMaps (..) + , BoundTypes + , mergeLHSpecState + , convertSpecType + , dictMapFromIds + , convertLHExpr + , specTypeToType + , unsafeSpecTypeToType + , symbolName + , lhTCDict') where + +import G2.Language +import qualified G2.Language.KnownValues as KV +import G2.Language.Monad +import qualified G2.Language.ExprEnv as E +import G2.Liquid.Types +import G2.Translation.Haskell + +import qualified Var as Var + +import Language.Fixpoint.Types.Names +import Language.Fixpoint.Types.Sorts +import qualified Language.Fixpoint.Types.Refinements as Ref +import Language.Fixpoint.Types.Refinements hiding (Expr, I) +import Language.Haskell.Liquid.Types + +import Data.Coerce +import Data.Foldable +import qualified Data.HashMap.Lazy as HM +import qualified Data.Map as M +import Data.Maybe +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 + +-- | A mapping of TyVar Name's, to Id's for the Num dict's +type NumDictMap = M.Map Name Id + +-- | A mapping of TyVar Name's, to Id's for the Integral dict's +type IntegralDictMap = M.Map Name Id + +-- | A mapping of TyVar Name's, to Id's for the Ord dict's +type OrdDictMap = M.Map 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 + , 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 }) = + let + dm2 = case M.lookup n1 lhd of + Just lh -> dm { lh_dicts = M.insert n2 lh lhd } + Nothing -> dm + + dm3 = case M.lookup n1 nd of + Just num -> dm2 { num_dicts = M.insert n2 num nd } + Nothing -> dm2 + + dm4 = case M.lookup n1 ind of + Just int -> dm3 { integral_dicts = M.insert n2 int ind } + Nothing -> dm3 + + dm5 = case M.lookup n1 od of + Just ord -> dm4 { ord_dicts = M.insert n2 ord od } + Nothing -> dm4 + in + dm5 + +-- | A mapping of variable names to the corresponding types +type BoundTypes = M.Map Name Type + +mergeLHSpecState :: [(Var.Var, LocSpecType)] -> LHStateM () +mergeLHSpecState = mapM_ (uncurry mergeLHSpecState') + +mergeLHSpecState' :: Var.Var -> LocSpecType -> LHStateM () +mergeLHSpecState' v lst = do + eenv <- exprEnv + let + (Id (Name n m _ _) _) = mkIdUnsafe v + g2N = E.lookupNameMod n m eenv + + case g2N of + Just (n', e) -> do + case convertVar n' of + True -> do + e' <- mergeSpecType (val lst) n' e + insertE n' e' + + assumpt <- createAssumption (val lst) e + insertAssumptionM n' assumpt + False -> return () + Nothing -> return () + +convertVar :: Name -> Bool +convertVar (Name "error" _ _ _) = False +convertVar (Name "patError" _ _ _) = False +convertVar (Name "." _ _ _) = False +convertVar _ = True + +mergeSpecType :: SpecType -> Name -> Expr -> LHStateM Expr +mergeSpecType st fn 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 + + -- 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 + + -- 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 + + let fc = FuncCall { funcName = fn + , arguments = map Var is + , returns = Var r } + let rLet = Let [(r, e')] $ Assert (Just fc) assert (Var r) + + let e''' = foldr (uncurry Lam) rLet $ zip lu is + + return e''' + +createAssumption :: SpecType -> Expr -> LHStateM Expr +createAssumption 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 + + let is' = filter (not . isTC lh . typeOf) is + dm@(DictMaps {lh_dicts = lhm}) <- dictMapFromIds is + + assume <- convertAssumeSpecType dm (M.map typeOf lhm) is' st + + return . foldr (uncurry Lam) assume $ zip lu is + + +dictMapFromIds :: [Id] -> LHStateM DictMaps +dictMapFromIds is = do + lh <- lhTCM + num <- numTCM + int <- return . KV.integralTC =<< knownValues + ord <- ordTCM + + let lhm = tcWithNameMap lh is + let nm = tcWithNameMap num is + let im = tcWithNameMap int is + let om = tcWithNameMap ord is + + return $ DictMaps { lh_dicts = lhm + , num_dicts = nm + , integral_dicts = im + , 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' + _ -> False + +argsFromArgT :: ArgType -> LHStateM Id +argsFromArgT (AnonType t) = freshIdN t +argsFromArgT (NamedType i) = return i + +convertAssumeSpecType :: DictMaps -> BoundTypes -> [Id] -> SpecType -> LHStateM Expr +convertAssumeSpecType m bt is st = do + convertSpecType 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 + + +-- | 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}) + | 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 + + 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 + t <- unsafeSpecTypeToType fin + let i' = convertSymbolT b t + + let bt' = M.insert (idName i') t bt + + e <- convertSpecType 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 + an <- lhAndE + let e'' = App (App an e) 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 + let i' = mkIdUnsafe v + + + let m' = copyIds (idName i) (idName i') m + let bt' = M.insert (idName i') (typeOf i) bt + + e <- convertSpecType 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}) + | 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 + + argsPred <- polyPredFunc 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 + +polyPredFunc :: [SpecType] -> Type -> DictMaps -> BoundTypes -> Id -> LHStateM Expr +polyPredFunc as ty m bt b = do + dict <- lhTCDict m ty + as' <- mapM (polyPredLam 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] + + lhPP <- lhPPM + + return $ mkApp $ Var (Id lhPP t):ar1:ars + +polyPredLam :: DictMaps -> BoundTypes -> SpecType -> LHStateM Expr +polyPredLam m bt rapp = do + t <- unsafeSpecTypeToType rapp + + let argT = spArgumentTypes $ PresType t + is <- mapM argsFromArgT argT + + i <- freshIdN . returnType $ PresType t + + st <- convertSpecType 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 + + let at = argumentTypes f + f_ar_t = case at of + (_:_) -> Just $ last at + _ -> Nothing + + f_ar_ts = fmap tyAppArgs f_ar_t + + 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 + + tcs <- mapM (lhTCDict m) ts + + let fw = mkApp $ f:te + + apps = mkApp $ fw:tcs ++ [argE] + + return apps + _ -> return $ App f argE +convertLHExpr m bt t (ENeg e) = do + e' <- convertLHExpr m bt t e + let t' = typeOf e' + + neg <- lhNegateM + num <- numTCM + a <- freshIdN TYPE + let tva = TyVar a + let negate' = Var $ Id neg + (TyForAll (NamedTyBndr a) + (TyFun + (TyApp (TyCon num (TyApp TYPE TYPE)) tva) + (TyFun + tva + tva + ) + ) + ) + + nDict <- numDict m t' + + return $ mkApp [ negate' + , Type t' + , nDict + , e' ] +convertLHExpr m bt t (EBin b e e') = do + (e2, e2') <- correctTypes m bt t e e' + b' <- convertBop b + + let t' = typeOf e2 + + nDict <- bopTCDict b m t' + + return $ mkApp [ b' + , Type t' + , nDict + , e2 + , 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 + an <- lhAndE + + case es' of + [] -> return $ true + [e] -> return e + _ -> return $ foldr (\e -> App (App an e)) true es' +convertLHExpr m bt _ (POr es) = do + es' <- mapM (convertLHExpr m bt Nothing) es + + false <- mkFalseE + orE <- lhOrE + + case es' of + [] -> return false + [e] -> return e + _ -> return $ foldr (\e -> App (App orE e)) false es' +convertLHExpr m bt _ (PNot e) = do + e' <- convertLHExpr m bt Nothing e + no <- mkNotE + return (App no e') +convertLHExpr m bt t (PImp e1 e2) = do + e1' <- convertLHExpr m bt t e1 + e2' <- convertLHExpr m bt t e2 + imp <- mkImpliesE + return $ mkApp [imp, e1', e2'] +convertLHExpr m bt t (PIff e1 e2) = do + e1' <- convertLHExpr m bt t e1 + e2' <- convertLHExpr m bt t e2 + iff <- iffM + return $ mkApp [iff, e1', e2'] +convertLHExpr m bt _ (PAtom brel e1 e2) = do + (e1', e2') <- correctTypes m bt Nothing e1 e2 + brel' <- convertBrel brel + + let t' = typeOf e1' + + dict <- brelTCDict m t' + + return $ mkApp [brel', Type t', dict, e1', e2'] +convertLHExpr _ _ _ e = error $ "Untranslated LH Expr " ++ (show e) + +convertBop :: Bop -> LHStateM Expr +convertBop Ref.Plus = convertBop' lhPlusM +convertBop Ref.Minus = convertBop' lhMinusM +convertBop Ref.Times = convertBop' lhTimesM +convertBop Ref.Div = convertBop' lhDivM +convertBop Ref.Mod = convertBop' lhModM +convertBop Ref.RTimes = convertBop' lhTimesM +convertBop Ref.RDiv = convertBop' lhDivM + +convertBop' :: LHStateM Name -> LHStateM Expr +convertBop' f = do + num <- numTCM + n <- f + a <- freshIdN TYPE + let tva = TyVar a + return $ Var $ Id n (TyForAll (NamedTyBndr a) + (TyFun + (TyApp (TyCon num (TyApp TYPE TYPE)) tva) + (TyFun + tva + (TyFun + tva + tva + ) + ) + ) + + ) + +-- | We often end up in the situation of having to compare some value of type a1 +-- to an instance of type Integer. This function, in order: +-- (1) Converts the value of type Integer to the type a1, if a1 is an instance +-- of Num. +-- (2) Converts the value of type a1 to Integer, if a1 is not an instance of Num +-- but is a value of type Integral +-- (3) Fails with an error. +correctTypes :: DictMaps -> BoundTypes -> Maybe Type -> Ref.Expr -> Ref.Expr -> LHStateM (Expr, Expr) +correctTypes m bt mt re re' = do + fIntgr <- lhFromIntegerM + tIntgr <- lhToIntegerM + tyI <- tyIntegerT + + e <- convertLHExpr m bt mt re + e' <- convertLHExpr m bt mt re' + + let t = typeOf e + let t' = typeOf e' + + let retT = returnType e + let retT' = returnType e' + + may_nDict <- maybeNumDict m t + may_nDict' <- maybeNumDict m t' + + may_iDict <- maybeIntegralDict m t + may_iDict' <- maybeIntegralDict m t' + + 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" + +convertSymbolT :: Symbol -> Type -> Id +convertSymbolT s = Id (symbolName s) + +reftSymbol :: Reft -> Symbol +reftSymbol = fst . unpackReft + +reftExpr :: Reft -> Ref.Expr +reftExpr = snd . unpackReft + +unpackReft :: Reft -> (Symbol, Ref.Expr) +unpackReft = coerce + +-- If possible, we split symbols at the last "." not in parenthesis, to +-- correctly set module names +symbolName :: Symbol -> Name +symbolName s = + let + t = symbolSafeText s + l = case T.null t of + True -> Just $ T.last t + False -> Nothing + + ((m, n), i) = + case l of + Just ')' -> (T.breakOnEnd ".(" t, 2) + _ -> (T.breakOnEnd "." t, 1) + + m' = T.dropEnd i m + in + case (m', n) of + (n', "") -> Name n' Nothing 0 Nothing + _ -> Name n (Just m') 0 Nothing + +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) + | otherwise = do + meas <- measuresM + tenv <- typeEnv + + if | Just (n', e) <- E.lookupNameMod n md meas -> + 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" + +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 +convertCon _ (Ref.I i) = do + dc <- mkDCIntegerE + return $ App dc (Lit . LitInt $ fromIntegral i) +convertCon _ (Ref.R d) = do + dc <- mkDCDoubleE + return $ App dc (Lit . LitDouble $ toRational d) +convertCon _ _ = error "convertCon: Unhandled case" + +unsafeSpecTypeToType :: SpecType -> LHStateM Type +unsafeSpecTypeToType st = do + t' <- specTypeToType st + case t' of + Just t'' -> return t'' + Nothing -> error $ "Unhandled SpecType" ++ show st + +specTypeToType :: SpecType -> LHStateM (Maybe Type) +specTypeToType (RVar {rt_var = (RTV v)}) = do + let i = mkIdUnsafe v + return $ Just (TyVar i) +specTypeToType (RFun {rt_in = fin, rt_out = fout}) = do + t <- specTypeToType fin + t2 <- specTypeToType fout + + case (t, t2) of + (Just t', Just t2') -> return $ Just (TyFun t' t2') + _ -> return Nothing +specTypeToType (RAllT {rt_tvbind = RTVar (RTV v) _, rt_ty = rty}) = do + let i = mkIdUnsafe v + t <- specTypeToType rty + return $ fmap (TyForAll (NamedTyBndr 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 + resT <- specTypeToType res + case (argT, resT) of + (Just argT', Just resT') -> return $ Just (TyApp argT' resT') + _ -> return Nothing +specTypeToType rty = error $ "Unmatched pattern in specTypeToType " ++ show (pprint rty) + +rTyConType :: RTyCon -> [SpecType]-> LHStateM (Maybe Type) +rTyConType rtc sts = do + tenv <- typeEnv + + let tcn = mkTyConName HM.empty . rtc_tc $ rtc + n = nameModMatch tcn tenv + + ts <- mapM specTypeToType sts + + case (not . any isNothing $ ts) of + True -> case fmap (\n' -> mkFullAppedTyCon n' (catMaybes ts) TYPE) n of + Nothing -> return $ primType tcn + t -> return t + False -> return Nothing + +primType :: Name -> Maybe Type +primType (Name "Int#" _ _ _) = Just TyLitInt +primType (Name "Float#" _ _ _) = Just TyLitFloat +primType (Name "Double#" _ _ _) = Just TyLitDouble +primType (Name "Word#" _ _ _) = Just TyLitInt +primType _ = Nothing + +sortToType :: Sort -> LHStateM Type +sortToType FInt = tyIntT +sortToType FReal = tyDoubleT +sortToType _ = error "Unhandled sort" + +convertBrel :: Brel -> LHStateM Expr +convertBrel Ref.Eq = convertBrel' lhEqM +convertBrel Ref.Ueq = convertBrel' lhEqM +convertBrel Ref.Ne = convertBrel' lhNeM +convertBrel Ref.Gt = return . Var =<< lhGtE +convertBrel Ref.Ge = return . Var =<< lhGeE +convertBrel Ref.Lt = return . Var =<< lhLtE +convertBrel Ref.Le = return . Var =<< lhLeE +convertBrel _ = error "convertBrel: Unhandled brel" + +convertBrel' :: LHStateM Name -> LHStateM Expr +convertBrel' f = do + n <- f + + a <- freshIdN TYPE + lh <- lhTCM + b <- tyBoolT + let tva = TyVar a + t = TyForAll + (NamedTyBndr a) + (TyFun + (TyCon lh TYPE) + (TyFun + tva + (TyFun tva b) + ) + ) + + return $ Var $ Id n t + +brelTCDict :: DictMaps -> Type -> LHStateM Expr +brelTCDict = lhTCDict + +bopTCDict :: Bop -> DictMaps -> Type -> LHStateM Expr +bopTCDict Ref.Mod = integralDict +bopTCDict _ = numDict + +lhTCDict :: DictMaps -> Type -> LHStateM Expr +lhTCDict m t = do + lh <- lhTCM + tc <- typeClassInstTC (lh_dicts m) lh t + case tc of + Just e -> return e + Nothing -> error $ "No lh dict " ++ show lh ++ "\n" ++ show t ++ "\n" ++ show m + +lhTCDict' :: LHDictMap -> Type -> LHStateM Expr +lhTCDict' m t = do + lh <- lhTCM + tc <- typeClassInstTC m lh t + case tc of + Just e -> return e + Nothing -> error $ "No lh dict " ++ show lh ++ "\n" ++ show t ++ "\n" ++ show m + +maybeNumDict :: DictMaps -> Type -> LHStateM (Maybe Expr) +maybeNumDict m t = do + num <- numTCM + typeClassInstTC (num_dicts m) num t + +numDict :: DictMaps -> Type -> LHStateM Expr +numDict m t = do + tc <- maybeNumDict m t + case tc of + Just e -> return e + Nothing -> error $ "No num dict \n" ++ show t ++ "\n" ++ show m + +maybeIntegralDict :: DictMaps -> Type -> LHStateM (Maybe Expr) +maybeIntegralDict m t = do + integral <- return . KV.integralTC =<< knownValues + typeClassInstTC (integral_dicts m) integral t + +integralDict :: DictMaps -> Type -> LHStateM Expr +integralDict m t = do + tc <- maybeIntegralDict m t + case tc of + Just e -> return e + Nothing -> error $ "No integral dict\n" ++ show t ++ "\n" ++ show m diff --git a/src/G2/Liquid/ConvertCurrExpr.hs b/src/G2/Liquid/ConvertCurrExpr.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/ConvertCurrExpr.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module G2.Liquid.ConvertCurrExpr (convertCurrExpr) where + +import G2.Language +import G2.Language.Monad +import qualified G2.Language.ExprEnv as E + +import G2.Liquid.Conversion +import G2.Liquid.Types + +import Control.Monad.Extra +import qualified Data.Map as M +import Data.Maybe + +convertCurrExpr :: Id -> Bindings -> LHStateM [Name] +convertCurrExpr ifi bindings = do + ifi' <- modifyInputExpr ifi + addCurrExprAssumption ifi bindings + return ifi' + +-- We create a copy of the input function which is modified to: +-- (1) Call a different copy of each of it's internal functions. +-- This allows us to only nondeterministically branch into abstract +-- counterexamples from the initial function call +-- +-- (2) Call all functions in let bindings. I.e., the following: +-- Just (f x) +-- would be changed to: +-- let fx = f x in Just fx +-- This way, if we reference the output in both the refinement and the body, +-- 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 i@(Id n _) = do + (CurrExpr er ce) <- currExpr + + e <- lookupE n + case e of + Just je -> do + (newI, ns) <- modifyInputExpr' i je + + let ce' = replaceVarWithName (idName i) (Var newI) ce + + putCurrExpr (CurrExpr er ce') + return ns + Nothing -> return [] + +-- 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' + + newI <- freshSeededIdN (idName i) (typeOf i) + insertE (idName newI) e''' + + return (newI, ns) + +rebindFuncs :: Expr -> LHStateM (Expr, [Name]) +rebindFuncs e = do + vs <- mapMaybeM (\i -> fmap (i,) <$> lookupE (idName i)) $ varIds e + nvs <- mapM (\(Id n t, _) -> freshSeededIdN n t) vs + + mapM_ (\(n, e_) -> insertE n (rewriteAssertName n e_)) $ zip (map idName nvs) (map snd vs) + + let e' = foldr (uncurry replaceASTs) e $ zip (map (Var . fst) vs) (map Var nvs) + + return (e', map idName nvs) + where + rewriteAssertName :: Name -> Expr -> Expr + rewriteAssertName n (Assert (Just fc) e1 e2) = Assert (Just $ fc {funcName = n}) e1 e2 + rewriteAssertName n e1 = modifyChildren (rewriteAssertName n) e1 + +replaceVarWithName :: Name -> Expr -> Expr -> Expr +replaceVarWithName n new = modify (replaceVarWithName' n new) + +replaceVarWithName' :: Name -> Expr -> Expr -> Expr +replaceVarWithName' n new v@(Var (Id n' _)) = if n == n' then new else v +replaceVarWithName' _ _ e = e + +-- We want to get all function calls into Let Bindings. +-- This is a bit tricky- we can't just get all calls at once, +-- stick them in a let binding, and then rewrite, because the calls may be nested. +-- So we gather them up, one by one, and rewrite as we go. +-- 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' :: Expr -> LHStateM Expr +letLiftFuncs' e + | ars <- passedArgs e + , any (\case { Var _ -> False; _ -> True }) ars = do + let c = appCenter e + is <- freshIdsN $ map typeOf ars + + return . Let (zip is ars) . mkApp $ c:map Var is + | otherwise = return 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 +addCurrExprAssumption :: Id -> Bindings -> LHStateM () +addCurrExprAssumption ifi (Bindings {fixed_inputs = fi}) = do + (CurrExpr er ce) <- currExpr + + assumpt <- lookupAssumptionM (idName ifi) + -- fi <- fixedInputs + eenv <- exprEnv + inames <- inputNames + + lh <- mapM (lhTCDict' M.empty) $ mapMaybe typeType fi + + let is = catMaybes (map (E.getIdFromName eenv) inames) + 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') + Nothing -> return () + +isType :: Expr -> Bool +isType (Type _) = True +isType _ = False + +typeType :: Expr -> Maybe Type +typeType (Type t) = Just t +typeType _ = Nothing diff --git a/src/G2/Liquid/Interface.hs b/src/G2/Liquid/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Interface.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module G2.Liquid.Interface where + +import G2.Config.Config + +import G2.Translation +import G2.Interface +import G2.Language as Lang +import qualified G2.Language.ExprEnv as E + +import G2.Execution + +import G2.Initialization.MkCurrExpr + +import G2.Liquid.AddCFBranch +import G2.Liquid.AddLHTC +import G2.Liquid.AddOrdToNum +import G2.Liquid.Conversion +import G2.Liquid.ConvertCurrExpr +import G2.Liquid.LHReducers +import G2.Liquid.Measures +import G2.Liquid.Simplify +import G2.Liquid.SpecialAsserts +import G2.Liquid.TCGen +import G2.Liquid.Types +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 Control.Exception +import Data.List +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 + +data LHReturn = LHReturn { calledFunc :: FuncInfo + , violating :: Maybe FuncInfo + , abstracted :: [FuncInfo] } deriving (Eq, Show) + +data FuncInfo = FuncInfo { func :: T.Text + , funcArgs :: T.Text + , funcReturn :: T.Text } deriving (Eq, Show) + +-- | 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 + let config' = config { mode = Liquid } + + lh_config <- getOpts [] + + ghc_cg <- try $ getGHCInfos lh_config proj fp lhlibs :: IO (Either SomeException [LHOutput]) + + let ghc_cg' = case ghc_cg 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' + + runLHCore entry tgt_trans ghc_cg' config' + +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 } + + let (no_part_state@(State {expr_env = np_eenv})) = cleaned_state + let np_ng = name_gen bindings' + + 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 ng_bindings = bindings' {name_gen = ng'} + + let ng_state = no_part_state {track = []} + + let (lh_state, lh_bindings) = createLHState meenv mkv ng_state ng_bindings + + let (cfn, (merged_state, bindings'')) = runLHStateM (initializeLH ghci_cg ifi lh_bindings) lh_state lh_bindings + + let tcv = tcvalues merged_state + let merged_state' = deconsLHState merged_state + + let pres_names = reqNames merged_state' ++ names tcv ++ names mkv + + let annm = annots merged_state + + let track_state = merged_state' {track = LHTracker { abstract_calls = [] + , last_var = Nothing + , annotations = annm} } + + SomeSolver con <- initSolver config + + -- 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 + -- these lists will work, without us having to modify all of G2 to account + -- 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 tr_ng = mkNameGen () + let state_name = Name "state" Nothing 0 Nothing + + let (limHalt, limOrd) = limitByAccepted (cut_off config) + + (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 + 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 + + 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' + + -- mapM (\(s, _, _, _) -> putStrLn . pprExecStateStr $ s) states + -- mapM (\(_, es, e, ais) -> do print es; print e; print ais) states + + close con + + return ((exec_res, final_bindings), ifi) + +initializeLH :: [LHOutput] -> Lang.Id -> Bindings -> LHStateM Lang.Name +initializeLH ghci_cg ifi bindings = do + let ghcInfos = map ghcI ghci_cg + + addLHTC + addOrdToNum + + let lh_measures = measureSpecs ghcInfos + createMeasures lh_measures + + let specs = funcSpecs ghcInfos + mergeLHSpecState specs + + addSpecialAsserts + addTrueAsserts ifi + + -- getAnnotations ghci_cg + + -- The simplification works less well on some of the Core generated by convertCurrExpr, + -- so we apply the simplification first + simplify + + ns <- convertCurrExpr ifi bindings + + cfn <- addCounterfactualBranch ns + + return cfn + +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"]} + + -- GhcInfo + (ghci, _) <- LHI.getGhcInfos Nothing config' fp + + mapM (getGHCInfos' config') ghci + + +getGHCInfos' :: LHC.Config -> GhcInfo -> IO LHOutput +getGHCInfos' config ghci = do + -- CGInfo + -- let cgi = generateConstraints ghci + + -- finfo <- cgInfoFInfo ghci cgi + -- F.Result _ sol _ <- solve (fixConfig "LH_FILEPATH" config) finfo + + 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 + +measureSpecs :: [GhcInfo] -> [Measure SpecType GHC.DataCon] +measureSpecs = concatMap (gsMeasures . spec) + +reqNames :: State t -> [Name] +reqNames (State { expr_env = eenv + , 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) + ) + +pprint :: (Var, LocSpecType) -> IO () +pprint (v, r) = do + let i = mkIdUnsafe v + + let doc = PPR.rtypeDoc FPP.Full $ val r + putStrLn $ show i + putStrLn $ show doc + +printLHOut :: Lang.Id -> [ExecRes [FuncCall]] -> IO () +printLHOut entry = printParsedLHOut . parseLHOut entry + +printParsedLHOut :: [LHReturn] -> IO () +printParsedLHOut [] = return () +printParsedLHOut (LHReturn { calledFunc = FuncInfo {func = f, funcArgs = call, funcReturn = output} + , violating = Nothing + , abstracted = abstr} : xs) = 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 + 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 + let fn = T.intercalate ", " $ map func fi + + if length fi > 0 then do + putStrLn "if" + mapM_ printFuncInfo fi + if length fi > 1 then do + TI.putStrLn $ "Strengthen the refinement types of " `T.append` + fn `T.append` " to eliminate these possibilities" + putStrLn "Abstract" + else do + TI.putStrLn $ "Strengthen the refinement type of " `T.append` + fn `T.append` " to eliminate this possibility" + putStrLn "Abstract" + else + putStrLn "Concrete" + +printFuncInfo :: FuncInfo -> IO () +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} + viFunc = fmap (parseLHFuncTuple s) ais + + abstr = map (parseLHFuncTuple s) $ track s + in + LHReturn { calledFunc = called + , violating = if called `sameFuncNameArgs` viFunc then Nothing else viFunc + , abstracted = abstr} : tl + +sameFuncNameArgs :: FuncInfo -> Maybe FuncInfo -> Bool +sameFuncNameArgs _ Nothing = False +sameFuncNameArgs (FuncInfo {func = f1, funcArgs = fa1}) (Just (FuncInfo {func = f2, funcArgs = fa2})) = f1 == f2 && fa1 == fa2 + +parseLHFuncTuple :: State t -> FuncCall -> FuncInfo +parseLHFuncTuple s (FuncCall {funcName = n, arguments = ars, returns = out}) = + let + t = case fmap typeOf $ E.lookup n (expr_env s) of + Just t' -> t' + 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 } diff --git a/src/G2/Liquid/LHReducers.hs b/src/G2/Liquid/LHReducers.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/LHReducers.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module G2.Liquid.LHReducers ( LHRed (..) + , LHLimitByAcceptedHalter + , LHLimitByAcceptedOrderer + , LHAbsHalter (..) + , LHTracker (..) + , lhReduce + , initialTrack + + , limitByAccepted) where + +import G2.Execution.Reducer +import G2.Execution.Rules +import G2.Language +import qualified G2.Language.ExprEnv as E +import G2.Liquid.Annotations + +import Data.Monoid +import Data.Semigroup +import qualified Data.Text as T + +-- lhReduce +-- When reducing for LH, we change the rule for evaluating Var f. +-- Var f can potentially split into two states. +-- (a) One state is exactly the same as the current reduce function: we lookup +-- up the var, and set the curr expr to its definition. +-- (b) [StateB] The other var is created if the definition of f is of the form: +-- lam x_1 ... lam x_n . let x = f x_1 ... x_n in Assert (a x_1 ... x_n x) x +-- +-- We introduce a new symbolic variable x_s, with the same type of s, and +-- set the curr expr to +-- let x = x_s in Assert (a x'_1 ... x'_n x_s) x_s +-- appropriately binding x'_i to x_i in the expression environment +-- +-- This allows us to choose any value for the return type of the function. +-- In this rule, we also return a b, oldb `mappend` [(f, [x_1, ..., x_n], x)] +-- This is essentially abstracting away the function definition, leaving +-- 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 } )}) + | cfn == tn = + Just ( RuleOther + , [s { curr_expr = CurrExpr Evaluate e + , track = tr { abstract_calls = maybe abs_c (:abs_c) fc }}]) + | otherwise = Nothing + +lhReduce _ _ = Nothing + +-- Counts the maximal number of Vars with names in the ExprEnv +-- that could be evaluated along any one path in the function +initialTrack :: ExprEnv -> Expr -> Int +initialTrack eenv (Var (Id n _)) = + case E.lookup n eenv of + Just _ -> 1 + Nothing -> 0 +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 (Cast e _) = initialTrack eenv e +initialTrack eenv (Assume _ _ e) = initialTrack eenv e +initialTrack eenv (Assert _ _ e) = initialTrack eenv e +initialTrack _ _ = 0 + +data LHTracker = LHTracker { abstract_calls :: [FuncCall] + , last_var :: Maybe Name + , annotations :: AnnotMap } deriving (Eq, Show) + +instance Named LHTracker where + names (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns}) = + names abs_c ++ names n ++ names anns + + rename old new (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns}) = + LHTracker { abstract_calls = rename old new abs_c + , last_var = rename old new n + , annotations = rename old new anns } + + renames hm (LHTracker {abstract_calls = abs_c, last_var = n, annotations = anns}) = + LHTracker { abstract_calls = renames hm abs_c + , last_var = renames hm n + , annotations = renames hm anns } + +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} + +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} + +data LHRed = LHRed Name + +instance Reducer LHRed () LHTracker where + initReducer _ _ = () + + 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) + +limitByAccepted :: Int -> (LHLimitByAcceptedHalter, LHLimitByAcceptedOrderer) +limitByAccepted i = (LHLimitByAcceptedHalter i, LHLimitByAcceptedOrderer i) + +-- LHLimitByAcceptedHalter and LHLimitByAcceptedOrderer should always be used +-- together. +-- LHLimitByAcceptedHalter is parameterized by a cutoff, `c`. +-- It allows execution of a state only if +-- (1) No counterexamples have been found +-- (2) The earliest the best (fewest abstracted functions) counterexample +-- was found was at reduction step n, and the state has taken fewer +-- than c + n steps +-- If either of these is violated, we switch to a new state. +-- However, if we find a better (fewer abstracted functions) counterexamples +-- with a higher, n, we want to be able to go back to that state. +-- +-- For this reason, we rely on discardOnStart to discard states that have taken +-- too many steps. Because the Orderer always chooses the State that has taken the +-- 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 + + -- 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 + +-- | 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 _ _ _ _ = () + + +allMin :: Ord b => (a -> b) -> [a] -> [a] +allMin f xs = + let + minT = minimum $ map f xs + in + 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 + +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 + + updatePerStateHalt _ ii (Processed {accepted = acc}) _ = minimum $ ii:map (length . abstract_calls . track) acc + + stopRed _ hv _ s = if length (abstract_calls $ track s) > hv then Discard else Continue + + stepHalter _ hv _ _ _ = hv diff --git a/src/G2/Liquid/Measures.hs b/src/G2/Liquid/Measures.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Measures.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module G2.Liquid.Measures (Measures, createMeasures) where + +import G2.Language +import qualified G2.Language.ExprEnv as E +import G2.Language.Monad +import G2.Liquid.Conversion +import G2.Liquid.Types +import Language.Haskell.Liquid.Types +import G2.Translation.Haskell + +import Control.Monad.Extra + +import qualified Data.Map as M +import Data.Maybe +import qualified GHC as GHC + +import qualified Data.HashMap.Lazy as HM + +-- | Creates measures from LH measure specifications. +-- 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 + meas' <- mapMaybeM (convertMeasure nt) =<< filterM allTypesKnown meas + + meenv <- measuresM + let eenvk = E.keys meenv + mvNames = filter (flip notElem eenvk) $ varNames meas' + + meenv' <- mapM (uncurry insertMeasureM) meas' + _ <- doRenamesN mvNames meenv' + + return () + +allTypesKnown :: Measure SpecType GHC.DataCon -> LHStateM Bool +allTypesKnown (M {sort = srt}) = do + st <- specTypeToType srt + return $ isJust st + +measureTypeMappings :: Measure SpecType GHC.DataCon -> LHStateM (Maybe (Name, Type)) +measureTypeMappings (M {name = n, sort = srt}) = do + st <- specTypeToType srt + lh <- lhTCM + + let t = fmap (addLHDictToType lh) st + + let n' = symbolName $ val n + + case t of + Just t' -> return $ Just (n', t') + _ -> return Nothing + +addLHDictToType :: Name -> Type -> Type +addLHDictToType lh t = + let + lhD = map (\i -> mkFullAppedTyCon lh [TyVar i] TYPE) $ tyForAllBindings $ PresType t + in + mapInTyForAlls (\t' -> foldr TyFun t' lhD) t + +convertMeasure :: BoundTypes -> Measure SpecType GHC.DataCon -> LHStateM (Maybe (Name, Expr)) +convertMeasure bt (M {name = n, sort = srt, eqns = eq}) = do + let n' = symbolName $ val n + + st <- specTypeToType srt + lh_tc <- lhTCM + + let bnds = tyForAllBindings $ PresType $ fromJust st + ds = map (\i -> Name "d" Nothing i Nothing) [1 .. length bnds] + nbnds = zip ds $ map TyVar bnds + as = map (\(d, t) -> Id d $ mkFullAppedTyCon lh_tc [t] TYPE) nbnds + as' = map (TypeL, ) bnds ++ map (TermL,) as + + as_t = map (\i -> (forType $ typeOf i, i)) as + + stArgs = anonArgumentTypes . PresType $ fromJust st + stRet = fmap (returnType . PresType) st + + lam_i <- freshIdN (head stArgs) + cb <- freshIdN (head stArgs) + + alts <- mapMaybeM (convertDefs stArgs stRet (M.fromList as_t) bt) eq + + let e = mkLams as' (Lam TermL lam_i $ Case (Var lam_i) cb alts) + + case st of -- [1] + Just _ -> return $ Just (n', e) + Nothing -> return Nothing + where + forType :: Type -> Name + forType (TyApp _ (TyVar (Id n' _))) = n' + forType _ = error "Bad type in forType" + +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 + tenv <- typeEnv + let (DataCon n t) = mkData HM.empty HM.empty dc + (TyCon tn _) = tyAppCenter $ returnType $ PresType t + dc' = getDataConNameMod tenv tn n + + -- See [1] below, we only evaluate this if Just + dc''@(DataCon _ dct) = fromJust dc' + bnds = tyForAllBindings $ PresType dct + dctarg = anonArgumentTypes $ PresType dct + + -- Adjust the tyvars in the datacon to have the same ids as those we read from LH + dctarg' = foldr (uncurry replaceASTs) dctarg $ zip (map TyVar bnds) st_t + + nt <- mapM (\((sym, t'), t'') -> do + t''' <- maybeM (return t'') unsafeSpecTypeToType (return t') + return (symbolName sym, t''')) $ zip bds dctarg' + + let is = map (uncurry Id) nt + + e <- mkExprFromBody ret m (M.union bt $ M.fromList nt) b + + case dc' of + Just _ -> return $ Just $ Alt (DataAlt dc'' is) e -- [1] + Nothing -> return Nothing +convertDefs _ _ _ _ _ = error "convertDefs: Unhandled Type List" + +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" + +mkDictMaps :: LHDictMap -> DictMaps +mkDictMaps ldm = DictMaps { lh_dicts = ldm + , num_dicts = M.empty + , integral_dicts = M.empty + , ord_dicts = M.empty} diff --git a/src/G2/Liquid/Simplify.hs b/src/G2/Liquid/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Simplify.hs @@ -0,0 +1,87 @@ +{-# Language FlexibleContexts #-} + +module G2.Liquid.Simplify ( simplify ) where + +import G2.Language +import G2.Language.Monad +import G2.Liquid.Types + +-- | The LH translation generates certain redundant Expr's over and over again. +-- Here we stamp them out. +simplify :: LHStateM () +simplify = do + simplifyExprEnv + mapCurrExpr simplifyExpr + mapAssumptionsM simplifyExpr + mapAnnotsExpr simplifyExpr + +simplifyExprEnv :: LHStateM () +simplifyExprEnv = mapME simplifyExpr + +simplifyExpr :: Expr -> LHStateM Expr +simplifyExpr = fixM simplifyExpr' + +simplifyExpr' :: Expr -> LHStateM Expr +simplifyExpr' e = simplifyTrueLams =<< simplifyAnds =<< simplifyLHPP e + +-- simplifyTrueLams +simplifyTrueLams :: Expr -> LHStateM Expr +simplifyTrueLams e = do + true <- mkTrueE + modifyASTsM (simplifyTrueLams' true) e + +simplifyTrueLams' :: Expr -> Expr -> LHStateM Expr +simplifyTrueLams' true e@(App (Lam _ _ le) _) = + if true == le then return true else return e +simplifyTrueLams' _ e = return e + +-- simplifyLHPP +simplifyLHPP :: Expr -> LHStateM Expr +simplifyLHPP e = do + true <- mkTrueE + modifyAppTopE (simplifyLHPP' true) e + +simplifyLHPP' :: Expr -> Expr -> LHStateM Expr +simplifyLHPP' true e = do + lhpp <- lhPPM + + let a = unApp e + + case a of + ((Var (Id n _)):as) -> + if n == lhpp && all (redundantLHPPArg true) as + then return true + else return e + _ -> return e + +-- Checks if an argument to a LHPP call makes that call nonredundant +-- A LHPP call is redundant if all function arguments are just (\_ -> True) +redundantLHPPArg :: Expr -> Expr -> Bool +redundantLHPPArg true (Lam _ _ e) = true == e +redundantLHPPArg _ _ = True + +-- simplifyAnds +simplifyAnds :: Expr -> LHStateM Expr +simplifyAnds e = do + andE <- lhAndE + true <- mkTrueE + modifyAppTopE (simplifyAnds' andE true) e + +simplifyAnds' :: Expr -> Expr -> Expr -> LHStateM Expr +simplifyAnds' andE true e = do + let a = unApp e + + case a of + [e1, e2, e3] + | e1 == andE + , e2 == true -> return e3 + | e1 == andE + , e3 == true -> return e2 + | otherwise -> return e + _ -> return e + +-- helpers +fixM :: (Monad m, Eq a) => (a -> m a) -> a -> m a +fixM f e = do + e' <- f e + if e == e' then return e else fixM f e' diff --git a/src/G2/Liquid/SpecialAsserts.hs b/src/G2/Liquid/SpecialAsserts.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/SpecialAsserts.hs @@ -0,0 +1,57 @@ +module G2.Liquid.SpecialAsserts ( addSpecialAsserts + , addTrueAsserts) where + +import G2.Language +import qualified G2.Language.KnownValues as KV +import G2.Language.Monad +import G2.Liquid.Types + +-- | Adds an assert of false to the function called when a pattern match fails +addSpecialAsserts :: LHStateM () +addSpecialAsserts = do + pen <- KV.patErrorFunc <$> knownValues + pe <- lookupE pen + + let e = case pe of + Just e2 -> e2 + Nothing -> Prim Undefined TyBottom + + let fc = FuncCall {funcName = pen, arguments = [], returns = Prim Undefined TyBottom} + + false <- mkFalseE + let e' = Assert (Just fc) false e + + insertE pen e' + +-- | Adds an Assert of True to any function without an assertion already, +-- 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) + tc <- return . tcDicts =<< typeClasses + + let tc' = map idName tc + ns' = filter (`notElem` tc') ns + + mapWithKeyME (addTrueAsserts' ns') + +addTrueAsserts' :: [Name] -> Name -> Expr -> LHStateM 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') + + let fc = FuncCall { funcName = n + , arguments = map Var is + , returns = (Var r)} + e'' = Let [(r, e')] $ Assert (Just fc) true (Var r) + + return e'' + ) =<< etaExpandToE (numArgs e) e + | otherwise = return e diff --git a/src/G2/Liquid/TCGen.hs b/src/G2/Liquid/TCGen.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/TCGen.hs @@ -0,0 +1,523 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module G2.Liquid.TCGen (createLHState) where + +import G2.Language +import qualified G2.Language.KnownValues as KV +import G2.Language.Monad +import G2.Liquid.Conversion +import G2.Liquid.TCValues +import G2.Liquid.Types + +import Data.Foldable +import qualified Data.Map as M +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 = + let + (tcv, (s', b')) = runStateM (createTCValues mkv) s b + + lh_s = consLHState s' meenv tcv + in + execLHStateM (do + createLHTCFuncs + createExtractors) lh_s b' + + +createTCValues :: KnownValues -> StateM [FuncCall] TCValues +createTCValues kv = do + lhTCN <- freshSeededStringN "lh" + lhEqN <- freshSeededStringN "lhEq" + lhNeN <- freshSeededStringN "lhNe" + + lhLtN <- freshSeededStringN "lhLt" + lhLeN <- freshSeededStringN "lhLe" + lhGtN <- freshSeededStringN "lhGt" + lhGeN <- freshSeededStringN "lhGe" + + lhPPN <- freshSeededStringN "lhPP" + lhNuOr <- freshSeededStringN "lhNuOr" + + let tcv = (TCValues { lhTC = lhTCN + , lhNumTC = KV.numTC kv + , lhOrdTC = KV.ordTC kv + + , lhEq = lhEqN + , lhNe = lhNeN + , lhLt = lhLtN + , lhLe = lhLeN + , lhGt = lhGtN + , lhGe = lhGeN + + , lhPlus = KV.plusFunc kv + , lhMinus = KV.minusFunc kv + , lhTimes = KV.timesFunc kv + , lhDiv = KV.divFunc kv + , lhNegate = KV.negateFunc kv + , lhMod = KV.modFunc kv + , lhFromInteger = KV.fromIntegerFunc kv + , lhToInteger = KV.toIntegerFunc kv + , lhNumOrd = lhNuOr + + , lhAnd = KV.andFunc kv + , lhOr = KV.orFunc kv + + , lhPP = lhPPN }) + + 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 + + -- 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 + lhtc <- mapM (\(n, f) -> do + adt <- lookupT n + case adt of + Just adt' -> do + let bnvK = mkTyApp $ map (const TYPE) $ bound_ids adt' + return (TyCon n bnvK, f) + Nothing -> error $ "No LH Dict name for " ++ show n) lhm + + tc <- typeClasses + tcn <- lhTCM + tci <- freshIdN TYPE + let tc' = insertClass tcn (Class { insts = lhtc, typ_ids = [tci] }) 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 + +initalizeLHTC :: Name -> AlgDataTy -> LHStateM (Name, Id) +initalizeLHTC n adt = do + lhf <- lhName "lh" n + t <- lhtcT n adt + return (n, Id lhf t) + +lhtcT :: Name -> AlgDataTy -> LHStateM Type +lhtcT n adt = do + lh <- lhTCM + let bi = bound_ids adt + let ct = foldl' TyApp (TyCon n TYPE) $ map TyVar bi + + let t = (TyApp + (TyCon lh TYPE) + ct + ) + + let t' = foldr TyFun t $ map (TyApp (TyCon lh (TyFun TYPE TYPE)) . TyVar) bi + let t'' = foldr TyForAll t' $ map NamedTyBndr bi + return t'' + +lhName :: T.Text -> Name -> LHStateM Name +lhName t (Name n m _ _) = freshSeededNameN $ Name (t `T.append` n) m 0 Nothing + +createLHTCFuncs' :: LHDictMap -> Name -> AlgDataTy -> LHStateM () +createLHTCFuncs' lhm n adt = do + eqN <- lhName "lhEq" n + eq <- createFunc lhEqFunc n adt + insertMeasureM eqN eq + + neN <- lhName "lhNe" n + ne <- createFunc lhNeFunc n adt + insertMeasureM neN ne + + ltN <- lhName "lhLt" n + lt <- createLtFunc n adt + insertMeasureM ltN lt + + leN <- lhName "lhLe" n + le <- createLeFunc n adt + insertMeasureM leN le + + gtN <- lhName "lhGt" n + gt <- createGtFunc n adt + insertMeasureM gtN gt + + geN <- lhName "lhGe" n + ge <- createGeFunc n adt + insertMeasureM geN ge + + ppN <- lhName "lhPP" n + pp <- lhPPFunc n adt + insertMeasureM ppN pp + + -- 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 + lh <- lhTCM + + let bi = bound_ids adt + let bt = map (Type . TyVar) bi + lhd <- freshIdsN (map (TyApp (TyCon lh (TyApp TYPE TYPE)) . TyVar) bi) + let lhdv = map Var lhd + + + let fs = map (\(n', t) -> Var (Id n' t)) [ (eqN, (typeOf eq)) + , (neN, (typeOf ne)) + , (ltN, (typeOf lt)) + , (leN, (typeOf le)) + , (gtN, (typeOf gt)) + , (geN, (typeOf ge)) + , (ppN, (typeOf pp)) ] + let fs' = map (\f -> mkApp $ f:bt ++ lhdv) fs + + 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 + + case fn of + Just fn' -> do + insertMeasureM (idName fn') e'' + -- let bnvK = mkTyApp $ map (const TYPE) bi + return () -- return (TyCon n bnvK, fn') + Nothing -> error $ "No LH Dict name for " ++ show n + + +lhDCType :: LHStateM Type +lhDCType = do + lh <- lhTCM + n <- freshIdN TYPE + + a <- freshSeededStringN "a" + bool <- tyBoolT + let tva = TyVar (Id a TYPE) + let taab = TyFun tva (TyFun tva bool) + + + return $ (TyFun + taab -- eq + (TyFun + taab --neq + (TyFun + taab --lt + (TyFun + taab --le + (TyFun + taab --gt + (TyFun + taab --ge + (TyFun + TyUnknown + (TyApp + (TyCon lh TYPE) + (TyVar n) + ) + ) + ) + ) + ) + ) + ) + ) + +createFunc :: PredFunc -> Name -> AlgDataTy -> LHStateM Expr +createFunc cf n adt = do + -- Our function needs the following arguments: + -- Type arguments + -- A LH typeclass for each type argument + -- Two expression of the adt type + -- We set up the needed Ids here + let bi = bound_ids adt + + lh <- lhTCM + lhbi <- mapM (freshIdN . TyApp (TyCon lh TYPE) . TyVar) bi + + d1 <- freshIdN (TyCon n TYPE) + d2 <- freshIdN (TyCon n TYPE) + + let m = M.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 + + return e' + +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 +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 +mkFirstCase _ _ _ _ _ _ = error "mkFirstCase: Unsupported AlgDataTy" + +mkFirstCase' :: PredFunc -> LHDictMap -> Id -> Name -> AlgDataTy -> DataCon -> LHStateM Alt +mkFirstCase' f ldm d2 n adt dc = do + ba <- freshIdsN $ anonArgumentTypes dc + + return . Alt (DataAlt dc ba) =<< mkSecondCase f ldm d2 n adt dc ba + +mkSecondCase :: PredFunc -> LHDictMap -> Id -> Name -> AlgDataTy -> DataCon -> [Id] -> LHStateM Expr +mkSecondCase f ldm d2 n adt dc ba1 = do + caseB <- freshIdN (typeOf dc) + + alts <- f ldm n adt dc ba1 + + return $ Case (Var d2) caseB alts + +lhEqFunc :: PredFunc +lhEqFunc ldm _ _ dc ba1 = do + ba2 <- freshIdsN $ anonArgumentTypes dc + + an <- lhAndE + true <- mkTrueE + false <- mkFalseE + + pr <- mapM (uncurry (eqLHFuncCall ldm)) $ zip ba1 ba2 + let pr' = foldr (\e -> App (App an e)) true pr + + return [ Alt Default false + , Alt (DataAlt dc ba2) pr'] + +eqLHFuncCall :: LHDictMap -> Id -> Id -> LHStateM Expr +eqLHFuncCall ldm i1 i2 + | TyCon _ _ <- tyAppCenter t = do + lhe <- lhEqM + + 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 + + return $ foldl' App (App lhv lhd) [Var i1, Var i2] + + | TyVar _ <- t = do + lhe <- lhEqM + + i <- freshIdN TYPE + b <- tyBoolT + + lhd <- lhTCDict' ldm t + + let lhv = App (Var (Id lhe (TyForAll (NamedTyBndr i) (TyFun (TyVar i) (TyFun (TyVar i) b))))) (Type t) + return $ App (App (App lhv lhd) (Var i1)) (Var i2) + + | TyFun _ _ <- t = mkTrueE + | TyApp _ _ <- t = mkTrueE + | TyForAll _ _ <- t = mkTrueE + + | t == TyLitInt + || t == TyLitDouble + || t == TyLitFloat + || t == TyLitChar = do + b <- tyBoolT + let pt = TyFun t (TyFun t b) + + return $ App (App (Prim Eq pt) (Var i1)) (Var i2) + + | otherwise = error $ "\nError in eqLHFuncCall " ++ show t ++ "\n" ++ show ldm + where + t = typeOf i1 + +lhNeFunc :: PredFunc +lhNeFunc ldm _ _ dc ba1 = do + ba2 <- freshIdsN $ anonArgumentTypes dc + + an <- lhAndE + true <- mkTrueE + false <- mkFalseE + + trueDC <- mkDCTrueM + falseDC <- mkDCFalseM + + 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 ] + + return [ Alt Default false + , Alt (DataAlt dc ba2) pr''] + +createLtFunc :: Name -> AlgDataTy -> LHStateM Expr +createLtFunc = createOrdFunc Lt + +createLeFunc :: Name -> AlgDataTy -> LHStateM Expr +createLeFunc = createOrdFunc Le + +createGtFunc :: Name -> AlgDataTy -> LHStateM Expr +createGtFunc = createOrdFunc Gt + +createGeFunc :: Name -> AlgDataTy -> LHStateM Expr +createGeFunc = createOrdFunc Ge + +-- We currently treat relations between Ints/Floats/Doubles correctly, +-- and just assume all other relations are true. +-- In LH, relations between x :: T and y :: T work by checking that +-- f x < f y +-- for all f :: T -> Int, so this could make us miss some counterexamples. +-- However, we will never generate an incorrect counterexample. +-- (i.e. it is sound but incomplete) +createOrdFunc :: Primitive -> Name -> AlgDataTy -> LHStateM Expr +createOrdFunc pr n adt = do + let bi = bound_ids adt + + lh <- lhTCM + lhbi <- mapM (freshIdN . TyApp (TyCon lh TYPE) . TyVar) bi + + d1 <- freshIdN (TyCon n TYPE) + d2 <- freshIdN (TyCon n TYPE) + + kv <- knownValues + e <- mkOrdCases pr kv d1 d2 n adt + + let e' = mkLams (map (TypeL,) bi ++ map (TermL,) lhbi ++ [(TermL, d1), (TermL, d2)]) e + + return e' + +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.tyFloat kv = mkPrimOrdCases pr TyLitFloat i1 i2 dc + | n == KV.tyDouble kv = mkPrimOrdCases pr TyLitDouble i1 i2 dc + | otherwise = mkTrueE +mkOrdCases _ _ _ _ _ _ = mkTrueE + +mkPrimOrdCases :: Primitive -> Type -> Id -> Id -> DataCon -> LHStateM Expr +mkPrimOrdCases pr t i1 i2 dc = do + i1' <- freshIdN (typeOf dc) + i2' <- freshIdN (typeOf dc) + + b1 <- freshIdN t + b2 <- freshIdN t + + b <- tyBoolT + + let eq = App + (App + (Prim pr (TyFun t (TyFun t b))) + (Var b1) + ) + (Var b2) + + let c2 = Case (Var i2) i2' [Alt (DataAlt dc [b2]) eq] + + return $ Case (Var i1) i1' [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 + + b <- tyBoolT + fs <- mapM (\v -> freshIdN (TyFun (TyVar v) b)) bi + + d <- freshIdN (TyCon n TYPE) + + let lhm = M.fromList $ zip (map idName bi) lhbi + let fnm = M.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 + +lhPPCase :: LHDictMap -> PPFuncMap -> AlgDataTy -> Id -> LHStateM Expr +lhPPCase lhm fnm adt i = do + ci <- freshIdN (typeOf i) + + return . Case (Var i) ci =<< mapM (lhPPAlt lhm fnm) (dataCon adt) + +lhPPAlt :: LHDictMap -> PPFuncMap -> DataCon -> LHStateM Alt +lhPPAlt lhm fnm dc = do + ba <- freshIdsN $ anonArgumentTypes dc + + an <- lhAndE + true <- mkTrueE + + pr <- mapM (\i -> do + pp <- lhPPCall lhm fnm (typeOf i) + return $ App pp (Var i)) ba + let pr' = foldr (\e -> App (App an e)) true pr + + return $ Alt (DataAlt dc ba) pr' + +-- This returns an Expr with a function type, of the given Type to Bool. +lhPPCall :: LHDictMap -> PPFuncMap -> Type -> LHStateM Expr +lhPPCall lhm fnm t + | TyCon _ _ <- tyAppCenter t + , ts <- tyAppArgs t = do + lhpp <- lhPPM + + let lhv = Var $ Id lhpp TyUnknown + dict <- lhTCDict' lhm t + undefs <- mapM (lhPPCall lhm fnm) ts + + 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) + | TyVar _ <- tyAppCenter t = do + i <- freshIdN t + return . Lam TermL i =<< mkTrueE + | TyFun _ _ <- t = do + i <- freshIdN t + return . Lam TermL i =<< mkTrueE + | TyForAll _ _ <- t = do + i <- freshIdN t + return . Lam TermL i =<< mkTrueE + | t == TyLitInt + || t == TyLitDouble + || t == TyLitFloat + || t == TyLitChar = do + i <- freshIdN t + return . Lam TermL i =<< mkTrueE + | otherwise = error $ "\nError in lhPPCall " ++ show t ++ "\n" ++ show lhm + +createExtractors :: LHStateM () +createExtractors = do + lh <- lhTCM + eq <- lhEqM + + lt <- lhLtM + le <- lhLeM + gt <- lhGtM + ge <- lhGeM + + ne <- lhNeM + pp <- lhPPM + + createExtractors' lh [eq, ne, lt, le, gt, ge, pp] + +createExtractors' :: Name -> [Name] -> LHStateM () +createExtractors' lh ns = mapM_ (uncurry (createExtractors'' lh (length ns))) $ zip [0..] ns + +createExtractors'' :: Name -> Int -> Int -> Name -> LHStateM () +createExtractors'' lh i j n = do + a <- freshIdN TYPE + + bi <- freshIdsN $ replicate i TyUnknown + + li <- freshIdN (TyCon lh (TyApp TYPE TYPE)) + ci <- freshIdN (TyCon lh (TyApp TYPE TYPE)) + + b <- freshIdN TYPE + let d = DataCon lh (TyForAll + (NamedTyBndr b) + (TyFun + (TyVar b) + (TyApp (TyCon lh (TyApp TYPE TYPE)) (TyVar b)) + ) + ) + let c = Case (Var li) ci [Alt (DataAlt d bi) (Var $ bi !! j)] + let e = Lam TypeL a $ Lam TermL li c + + insertMeasureM n e diff --git a/src/G2/Liquid/TCValues.hs b/src/G2/Liquid/TCValues.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/TCValues.hs @@ -0,0 +1,90 @@ +module G2.Liquid.TCValues where + +import G2.Language.Naming +import G2.Language.Syntax + +-- | 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. +data TCValues = TCValues { lhTC :: Name + , lhNumTC :: Name + , lhOrdTC :: Name + + , lhEq :: Name + , lhNe :: Name + + , lhLt :: Name + , lhLe :: Name + , lhGt :: Name + , lhGe :: Name + + , lhPlus :: Name + , lhMinus :: Name + , lhTimes :: Name + , lhDiv :: Name + , lhNegate :: Name + , lhMod :: Name + , lhFromInteger :: Name + , lhToInteger :: Name + + , lhNumOrd :: Name + + , lhAnd :: Name + , lhOr :: Name + + , lhPP :: Name } deriving (Eq, Show, Read) + +instance Named TCValues where + names tcv = [ lhTC tcv + , lhNumTC tcv + , lhOrdTC tcv + , lhEq tcv + , lhNe tcv + + , lhLe tcv + , lhLt tcv + , lhGt tcv + , lhGe tcv + + , lhPlus tcv + , lhMinus tcv + , lhTimes tcv + , lhDiv tcv + , lhNegate tcv + , lhMod tcv + , lhFromInteger tcv + , lhToInteger tcv + , lhNumOrd tcv + + , lhAnd tcv + , lhOr tcv + + , lhPP tcv] + + rename old new tcv = TCValues { lhTC = rename old new $ lhTC tcv + , lhNumTC = rename old new $ lhNumTC tcv + , lhOrdTC = rename old new $ lhOrdTC tcv + , lhEq = rename old new $ lhEq tcv + , lhNe = rename old new $ lhNe tcv + + , lhLt = rename old new $ lhLt tcv + , lhLe = rename old new $ lhLe tcv + , lhGt = rename old new $ lhGt tcv + , lhGe = rename old new $ lhGe tcv + + , lhPlus = rename old new $ lhPlus tcv + , lhMinus = rename old new $ lhMinus tcv + , lhTimes = rename old new $ lhTimes tcv + , 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 + , lhNumOrd = rename old new $ lhNumOrd tcv + + , lhAnd = rename old new $ lhAnd tcv + , lhOr = rename old new $ lhOr tcv + + , lhPP = rename old new $ lhPP tcv } diff --git a/src/G2/Liquid/Types.hs b/src/G2/Liquid/Types.hs new file mode 100644 --- /dev/null +++ b/src/G2/Liquid/Types.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +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 + + , lhPlusM + , lhMinusM + , lhTimesM + , lhDivM + , lhNegateM + , lhModM + , lhFromIntegerM + , lhToIntegerM + , lhNumOrdM + + , lhAndE + , lhOrE + + , lhPPM ) where + +import Data.Coerce +import qualified Data.HashMap.Lazy as HM +import Data.List +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Control.Monad.State.Lazy as SM + +import qualified G2.Language as L +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.KnownValues as KV +import G2.Language.Monad + +import G2.Liquid.TCValues + +import Language.Haskell.Liquid.Types +import Language.Haskell.Liquid.Constraint.Types +import Language.Fixpoint.Types.Constraints + +data LHOutput = LHOutput { ghcI :: GhcInfo + , cgI :: CGInfo + , solution :: FixSolution } + +type Measures = L.ExprEnv + +type Assumptions = M.Map L.Name L.Expr + +newtype AnnotMap = + AM { unAnnotMap :: HM.HashMap L.Span [(Maybe T.Text, L.Expr)] } + deriving (Eq, Show, Read) + +-- [LHState] +-- measures is an extra expression environment, used to build Assertions. +-- This distinction between functions for code, and functions for asserts is important because +-- Assertions should not themselves contain assertions. A measure function +-- may be used both in code and in an assertion, but should only have it's +-- refinement type added in the code +-- +-- Invariant: Internally, functions in the State ExprEnv need to have LH Dict arguments added, +-- (see addLHTCExprEnv) whereas functions in the measures should be created with the LH Dicts +-- already accounted for. + + +-- | LHState +-- Wraps a State, along with the other information needed to parse +-- LiquidHaskell ASTs +data LHState = LHState { state :: L.State [L.FuncCall] + , measures :: Measures + , tcvalues :: TCValues + , assumptions :: Assumptions + , annots :: AnnotMap + } deriving (Eq, Show, Read) + +consLHState :: L.State [L.FuncCall] -> Measures -> TCValues -> LHState +consLHState s meas tcv = + LHState { state = s + , measures = meas + , tcvalues = tcv + , assumptions = M.empty + , annots = AM HM.empty } + +deconsLHState :: LHState -> L.State [L.FuncCall] +deconsLHState (LHState { state = s + , measures = meas }) = + s { L.expr_env = E.union (L.expr_env s) meas } + +measuresM :: LHStateM Measures +measuresM = do + (lh_s, _) <- SM.get + return $ measures lh_s + +assumptionsM :: LHStateM Assumptions +assumptionsM = do + (lh_s, _) <- SM.get + return $ assumptions lh_s + +annotsM :: LHStateM AnnotMap +annotsM = do + (lh_s, _) <- SM.get + return $ annots 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 + exprEnv = readRecord $ expr_env . fst + putExprEnv = rep_expr_envM + + 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 + + typeClasses = readRecord $ type_classes . fst + putTypeClasses = rep_type_classesM + +instance FullState (LHState, L.Bindings) LHStateM where + currExpr = readRecord $ curr_expr . fst + putCurrExpr = rep_curr_exprM + + inputNames = readRecord $ L.input_names . snd + fixedInputs = readRecord $ L.fixed_inputs . snd + +runLHStateM :: LHStateM a -> LHState -> L.Bindings -> (a, (LHState, L.Bindings)) +runLHStateM (LHStateM s) lh_s b = SM.runState s (lh_s, b) + +evalLHStateM :: LHStateM a -> LHState -> L.Bindings -> a +evalLHStateM s = (\lh_s b -> fst (runLHStateM s lh_s b)) + +execLHStateM :: LHStateM a -> LHState -> L.Bindings -> (LHState, L.Bindings) +execLHStateM s = (\lh_s b -> snd (runLHStateM s lh_s b)) + +liftState :: (L.State [L.FuncCall] -> a) -> LHState -> a +liftState f = f . state + +expr_env :: LHState -> L.ExprEnv +expr_env = liftState L.expr_env + +rep_expr_envM :: L.ExprEnv -> LHStateM () +rep_expr_envM eenv = do + (lh_s, b) <- SM.get + let s = state lh_s + let s' = s {L.expr_env = eenv} + SM.put $ (lh_s {state = s'}, b) + +type_env :: LHState -> L.TypeEnv +type_env = liftState L.type_env + +rep_type_envM :: L.TypeEnv -> LHStateM () +rep_type_envM tenv = do + (lh_s, b) <- SM.get + let s = state lh_s + let s' = s {L.type_env = tenv} + SM.put $ (lh_s {state = s'}, b) + +rep_name_genM :: L.NameGen -> LHStateM () +rep_name_genM ng = do + (lh_s, b) <- SM.get + let s = state lh_s + let b' = b {L.name_gen = ng} + SM.put $ (lh_s {state = s}, b') + +known_values :: LHState -> L.KnownValues +known_values = liftState L.known_values + +rep_known_valuesM :: L.KnownValues -> LHStateM () +rep_known_valuesM kv = do + (lh_s, b) <- SM.get + let s = state lh_s + let s' = s {L.known_values = kv} + SM.put $ (lh_s {state = s'}, b) + +curr_expr :: LHState -> L.CurrExpr +curr_expr = liftState L.curr_expr + +rep_curr_exprM :: L.CurrExpr -> LHStateM () +rep_curr_exprM ce = do + (lh_s, b) <- SM.get + let s = state lh_s + let s' = s {L.curr_expr = ce} + SM.put $ (lh_s {state = s'}, b) + +type_classes :: LHState -> L.TypeClasses +type_classes = liftState L.type_classes + +rep_type_classesM :: L.TypeClasses -> LHStateM () +rep_type_classesM tc = do + (lh_s,b) <- SM.get + let s = state lh_s + let s' = s {L.type_classes = tc} + SM.put $ (lh_s {state = s'}, b) + +liftLHState :: (LHState -> a) -> LHStateM a +liftLHState f = do + (lh_s, _) <- SM.get + return (f lh_s) + +lookupMeasure :: L.Name -> LHState -> Maybe L.Expr +lookupMeasure n = E.lookup n . measures + +lookupMeasureM :: L.Name -> LHStateM (Maybe L.Expr) +lookupMeasureM n = liftLHState (lookupMeasure n) + +insertMeasureM :: L.Name -> L.Expr -> LHStateM () +insertMeasureM n e = do + (lh_s,b) <- SM.get + let meas = measures lh_s + let meas' = E.insert n e meas + SM.put $ (lh_s {measures = meas'}, b) + +mapMeasuresM :: (L.Expr -> LHStateM L.Expr) -> LHStateM () +mapMeasuresM f = do + (s@(LHState { measures = meas }), b) <- SM.get + meas' <- E.mapM f meas + SM.put $ (s { measures = meas' }, b) + +lookupAssumptionM :: L.Name -> LHStateM (Maybe L.Expr) +lookupAssumptionM n = liftLHState (M.lookup n . assumptions) + +insertAssumptionM :: L.Name -> L.Expr -> LHStateM () +insertAssumptionM n e = do + (lh_s, b) <- SM.get + let assumpt = assumptions lh_s + let assumpt' = M.insert n e assumpt + SM.put $ (lh_s {assumptions = assumpt'}, b) + +mapAssumptionsM :: (L.Expr -> LHStateM L.Expr) -> LHStateM () +mapAssumptionsM f = do + (s@(LHState { assumptions = assumpt }), b) <- SM.get + assumpt' <- mapM f assumpt + SM.put $ (s { assumptions = assumpt' },b) + +insertAnnotM :: L.Span -> Maybe T.Text -> L.Expr -> LHStateM () +insertAnnotM spn t e = do + (s@(LHState { annots = an }),b) <- SM.get + let an' = AM . HM.insertWith (++) spn [(t, e)] . unAnnotMap $ an + SM.put $ (s {annots = an'}, b) + +lookupAnnotM :: L.Name -> LHStateM (Maybe [(Maybe T.Text, L.Expr)]) +lookupAnnotM (L.Name _ _ _ (Just (L.Span {L.start = l}))) = + return . Just + . concatMap snd + . find (\(L.Span {L.start = l'}, _) -> l == l') + . HM.toList + . unAnnotMap + =<< annotsM +lookupAnnotM _ = return Nothing + +mapAnnotsExpr :: (L.Expr -> LHStateM L.Expr) -> LHStateM () +mapAnnotsExpr f = do + (lh_s, b) <- SM.get + annots' <- modifyContainedASTsM f (annots lh_s) + SM.put $ (lh_s {annots = annots'}, b) + +-- | andM +-- The version of 'and' in the measures +andM :: LHStateM L.Expr +andM = do + m <- measuresM + return (L.mkAnd m) + +-- | orM +-- The version of 'or' in the measures +orM :: LHStateM L.Expr +orM = do + m <- measuresM + return (L.mkOr m) + +-- | notM +-- The version of 'not' in the measures +notM :: LHStateM L.Expr +notM = do + m <- measuresM + return (L.mkNot m) + +-- | iffM +-- The version of 'iff' in the measures +iffM :: LHStateM L.Expr +iffM = do + m <- measuresM + return (L.mkIff m) + +liftTCValues :: (TCValues -> a) -> LHStateM a +liftTCValues f = do + (lh_s, _) <- SM.get + return (f (tcvalues lh_s)) + +lhTCM :: LHStateM L.Name +lhTCM = liftTCValues lhTC + +lhNumTCM :: LHStateM L.Name +lhNumTCM = liftTCValues lhNumTC + +lhOrdTCM :: LHStateM L.Name +lhOrdTCM = liftTCValues lhOrdTC + +lhEqM :: LHStateM L.Name +lhEqM = liftTCValues lhEq + +lhNeM :: LHStateM L.Name +lhNeM = liftTCValues lhNe + +lhLtM :: LHStateM L.Name +lhLtM = liftTCValues lhLt + +lhLeM :: LHStateM L.Name +lhLeM = liftTCValues lhLe + +lhGtM :: LHStateM L.Name +lhGtM = liftTCValues lhGt + +lhGeM :: LHStateM L.Name +lhGeM = liftTCValues lhGe + +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 + + return $ L.TyForAll (L.NamedTyBndr a) + (L.TyFun + ord' + (L.TyFun + lh' + (L.TyFun + tva + (L.TyFun + tva + bool + ) + ) + ) + ) + +lhLtE :: LHStateM L.Id +lhLtE = do + n <- liftTCValues lhLt + return . L.Id n =<< binT + +lhLeE :: LHStateM L.Id +lhLeE = do + n <- liftTCValues lhLe + return . L.Id n =<< binT + +lhGtE :: LHStateM L.Id +lhGtE = do + n <- liftTCValues lhGt + return . L.Id n =<< binT + +lhGeE :: LHStateM L.Id +lhGeE = do + n <- liftTCValues lhGe + return . L.Id n =<< binT + +lhPlusM :: LHStateM L.Name +lhPlusM = liftTCValues lhPlus + +lhMinusM :: LHStateM L.Name +lhMinusM = liftTCValues lhMinus + +lhTimesM :: LHStateM L.Name +lhTimesM = liftTCValues lhTimes + +lhDivM :: LHStateM L.Name +lhDivM = liftTCValues lhDiv + +lhNegateM :: LHStateM L.Name +lhNegateM = liftTCValues lhNegate + +lhModM :: LHStateM L.Name +lhModM = liftTCValues lhMod + +lhFromIntegerM :: LHStateM L.Id +lhFromIntegerM = do + n <- liftTCValues lhFromInteger + return . L.Id n =<< numT + +numT :: LHStateM L.Type +numT = do + a <- freshIdN L.TYPE + let tva = L.TyVar a + num <- lhNumTCM + integerT <- tyIntegerT + + let num' = L.TyCon num L.TYPE + + return $ L.TyForAll (L.NamedTyBndr a) + (L.TyFun + num' + (L.TyFun + integerT + tva + ) + ) + +lhToIntegerM :: LHStateM L.Id +lhToIntegerM = do + n <- liftTCValues lhToInteger + return . L.Id n =<< integralT + +integralT :: LHStateM L.Type +integralT = do + a <- freshIdN L.TYPE + let tva = L.TyVar a + integral <- return . KV.integralTC =<< knownValues + integerT <- tyIntegerT + + let integral' = L.TyCon integral L.TYPE + + return $ L.TyForAll (L.NamedTyBndr a) + (L.TyFun + integral' + (L.TyFun + tva + integerT + ) + ) +lhNumOrdM :: LHStateM L.Id +lhNumOrdM = do + num <- lhNumTCM + let num' = L.TyCon num L.TYPE + + ord <- lhOrdTCM + let ord' = L.TyCon ord L.TYPE + + n <- liftTCValues lhNumOrd + return $ L.Id n (L.TyFun num' ord') + +lhPPM :: LHStateM L.Name +lhPPM = liftTCValues lhPP + +lhAndE :: LHStateM L.Expr +lhAndE = do + b <- tyBoolT + + n <- liftTCValues lhAnd + return $ L.Var (L.Id n (L.TyFun b (L.TyFun b b))) + +lhOrE :: LHStateM L.Expr +lhOrE = do + b <- tyBoolT + + n <- liftTCValues lhOr + return $ L.Var (L.Id n (L.TyFun b (L.TyFun b b))) + +instance L.ASTContainer AnnotMap L.Expr where + containedASTs = map snd . concat . HM.elems . unAnnotMap + modifyContainedASTs f = AM . HM.map (L.modifyContainedASTs f) . coerce + +instance L.ASTContainer AnnotMap L.Type where + containedASTs = L.containedASTs . map snd . concat . HM.elems . unAnnotMap + modifyContainedASTs f = AM . HM.map (L.modifyContainedASTs f) . coerce + +instance ASTContainerM AnnotMap L.Expr where + modifyContainedASTsM f (AM am) = do + am' <- mapM (modifyContainedASTsM f) am + return (AM am') + +instance L.Named AnnotMap where + names = L.names . unAnnotMap + rename old new = coerce . L.rename old new . unAnnotMap + renames hm = coerce . L.renames hm . unAnnotMap diff --git a/src/G2/Postprocessing/Interface.hs b/src/G2/Postprocessing/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Postprocessing/Interface.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} + +module G2.Postprocessing.Interface (runPostprocessing) where + +import G2.Language +import G2.Postprocessing.NameSwitcher + +runPostprocessing :: (ASTContainer m Expr, Named m) => Bindings -> m -> m +runPostprocessing b = switchNames b + diff --git a/src/G2/Postprocessing/NameSwitcher.hs b/src/G2/Postprocessing/NameSwitcher.hs new file mode 100644 --- /dev/null +++ b/src/G2/Postprocessing/NameSwitcher.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} + +module G2.Postprocessing.NameSwitcher (switchNames) where + +import G2.Language + +switchNames :: Named m => Bindings -> m -> m +switchNames b e = renames (cleaned_names b) e diff --git a/src/G2/Preprocessing/AdjustTypes.hs b/src/G2/Preprocessing/AdjustTypes.hs new file mode 100644 --- /dev/null +++ b/src/G2/Preprocessing/AdjustTypes.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Preprocessing.AdjustTypes (adjustTypes) where + +import G2.Language.AST +import G2.Language + +adjustTypes :: ASTContainer t Expr => State t -> State t +adjustTypes = wrapInteger . unpackString + +-- | wrapInteger +-- GHC may represent an Integer as: +-- ((fromInteger [Dict]) LitInt) +-- Which makes it hard for us to correctly implement fromInteger in G2. +-- So we put in our Prelude: +-- data Integer = Integer Int# +-- and change ((fromInteger [Dict]) LitInteger) to: +-- ((fromInteger [Dict]) (dcInteger LitInt)) +wrapInteger :: ASTContainer t Expr => State t -> State t +wrapInteger s@(State {known_values = kv, type_env = tenv}) = modifyASTs (wrapInteger' (mkDCInteger kv tenv)) s + +wrapInteger' :: Expr -> Expr -> Expr +wrapInteger' dcIntgr (Lit (LitInteger i)) = App dcIntgr (Lit . LitInt $ fromInteger i) +wrapInteger' _ e = e + +-- | GHC may represent strings as: +-- (App +-- (Var +-- (Id +-- (Name "$unpackCString" (Just "GHC.CString") 0) +-- (TyFun (TyCon (Name "Addr#" (Just "GHC.Prim") 3674937295934324738) []) (TyCon (Name "$" (Just "GHC.Types") 0) [TyCon (Name "Char" (Just "GHC.Types") 8214565720323798834) []])) +-- ) +-- ) +-- (Lit (LitString "\"HERE\"")) +-- ) +-- 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' :: TypeEnv -> KnownValues -> Expr -> Expr +unpackString' _ _ (App (Var (Id (Name "unpackCString#" _ _ _) _)) e) = e +unpackString' tenv kv (Lit (LitString s)) = + let + cns = mkCons kv tenv + em = mkEmpty kv tenv + + char = mkDCChar kv tenv + in + foldr App em $ map (App cns . App char . Lit . LitChar) s +unpackString' _ _ e = e diff --git a/src/G2/Preprocessing/Interface.hs b/src/G2/Preprocessing/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Preprocessing/Interface.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE FlexibleContexts #-} + +module G2.Preprocessing.Interface where + +import G2.Language +import G2.Preprocessing.AdjustTypes +import G2.Preprocessing.NameCleaner + +runPreprocessing :: (ASTContainer t Expr, ASTContainer t Type, Named t) => State t -> Bindings -> (State t, Bindings) +-- runPreprocessing s b = cleanNames (adjustTypes s) b +runPreprocessing s b = (s', b {cleaned_names = cl_names', name_gen = ng'}) + where (s', cl_names', ng') = cleanNames (adjustTypes s) (cleaned_names b) (name_gen b) diff --git a/src/G2/Preprocessing/NameCleaner.hs b/src/G2/Preprocessing/NameCleaner.hs new file mode 100644 --- /dev/null +++ b/src/G2/Preprocessing/NameCleaner.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | NameCleaner +-- Adjusts all names in a state to ensure they will not cause problems in the SMT solver +-- In particular, we make sure that: +-- 1) Names contain only numbers, digits, and the 17 allowed symbols +-- 2) Names start with numbers or one of the 17 symbols, except for @ and . +-- 3) Names do not conflict with a symbol reserved by the SMT solver + +module G2.Preprocessing.NameCleaner + ( cleanNames + , cleanNames' + , cleanNamesFromList + , allowedStartSymbols + , allowedSymbol + ) where + +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as S +import qualified Data.Text as T + +import G2.Language +import qualified G2.Language.ExprEnv as E + +allowedStartSymbols :: S.HashSet Char +allowedStartSymbols = S.fromList $ + ['a'..'z'] ++ ['A'..'Z'] + ++ ['~', '!', '$', '%', '^', '&', '*' + -- We eliminate '_' so we can use '_' to seperate in string conversions + -- (see nameToStr in Naming.hs) + --, '_' + , '-', '+', '=', '<', '>', '?', '/'] + +allowedSymbol :: S.HashSet Char +allowedSymbol = allowedStartSymbols `S.union` S.fromList (['0'..'9'] ++ ['@', '.']) + +allowedName :: Name -> Bool +allowedName (Name n m _ _) = + T.all (`S.member` allowedSymbol) n + && T.all (`S.member` allowedSymbol) (maybe "" (id) m) + && (T.head n) `S.member` allowedStartSymbols + +-- Note that the list of names in cleanNames is NOT the list of all names in the State. +-- For efficiencies reasons, we aim to clean only those names that may be used +-- in the SMT formulas. For this reason, cleanNames is not defined in terms of +-- the more general cleanNames'. + +-- cleanNames :: (ASTContainer t Expr, ASTContainer t Type, Named t) => State t -> Bindings -> (State t, Bindings) +-- cleanNames s b@Bindings {name_gen = ng} = (renames hns s, b {name_gen = ng'}) +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 + hns = HM.fromList ns + cl_names' = foldr (\(old, new) -> HM.insert new old) cl_names (HM.toList hns) + + +cleanNames' :: Named n => NameGen -> n -> (n, NameGen) +cleanNames' ng n = (renames hns n, ng') + where + (ns, ng') = createNamePairs ng . filter (not . allowedName) $ 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 + hns = HM.fromList ns' + +createNamePairs :: NameGen -> [Name] -> ([(Name, Name)], NameGen) +createNamePairs ing ins = go ing [] ins + where + go :: NameGen -> [(Name, Name)] -> [Name] -> ([(Name, Name)], NameGen) + go ng rns [] = (rns, ng) + go ng rns (name@(Name n m i l):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 + 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) diff --git a/src/G2/QuasiQuotes/FloodConsts.hs b/src/G2/QuasiQuotes/FloodConsts.hs new file mode 100644 --- /dev/null +++ b/src/G2/QuasiQuotes/FloodConsts.hs @@ -0,0 +1,72 @@ +-- Tries to eliminate a symbolic variable by replacing it with a constant. + +module G2.QuasiQuotes.FloodConsts ( floodConstantsChecking + , floodConstants + , floodConstant) where + +import G2.Execution.PrimitiveEval +import G2.Language +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.PathConds as PC + +-- | Tries to eliminate a symbolic variable by replacing them with constants. +-- Returns Maybe a State, if the variables are replacable, and don't make the +-- path constraints obviously false +floodConstantsChecking :: [(Name, Expr)] -> State t -> Maybe (State t) +floodConstantsChecking ne s = + case floodConstants ne s of + Just s' -> + if all (pathCondMaybeSatisfiable (known_values s')) (PC.toList $ path_conds s') + then Just s' + else Nothing + Nothing -> Nothing + +-- | Tries to eliminate a symbolic variable by replacing them with constants. +-- Returns Maybe a State, if the variables are replacable +floodConstants :: [(Name, Expr)] -> State t -> Maybe (State t) +floodConstants ne s = foldr (\(n, e) s' -> floodConstant n e =<< s') (Just s) ne + +floodConstant :: Name -> Expr -> State t -> Maybe (State t) +floodConstant n e s + | E.isSymbolic n (expr_env s) = + case E.lookup n (expr_env s) of + Just e' -> + let + i = Id n $ typeOf e' + r_pc = replaceASTs (Var i) e (path_conds s) + in + Just (s { expr_env = E.insert n e (expr_env s) + , path_conds = r_pc }) + _ -> Nothing + | otherwise = + case E.lookup n (expr_env s) of + Just e' + | Data d:es <- unApp e + , Data d':es' <- unApp e' + , dcName d == dcName d' -> floodConstantList s (zip es es') + _ -> Nothing + +floodConstantList :: State t -> [(Expr, Expr)] -> Maybe (State t) +floodConstantList s ((e1, e2):xs) + | Var (Id n _) <- e2 = + (\s' -> floodConstantList s' xs) =<< floodConstant n e1 s + | e1 == e2 = floodConstantList s xs +floodConstantList s [] = Just s +floodConstantList _ _ = Nothing + +-- 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) = + let + r = evalPrims 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 diff --git a/src/G2/QuasiQuotes/G2Rep.hs b/src/G2/QuasiQuotes/G2Rep.hs new file mode 100644 --- /dev/null +++ b/src/G2/QuasiQuotes/G2Rep.hs @@ -0,0 +1,26 @@ +-- Hides the warnings about deriving +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module G2.QuasiQuotes.G2Rep ( G2Rep (..) + , derivingG2Rep ) where + +import G2.QuasiQuotes.Internals.G2Rep + +-- Prelude types +$(derivingG2Rep ''Bool) +$(derivingG2Rep ''Maybe) +$(derivingG2Rep ''Either) +$(derivingG2Rep ''Ordering) +$(derivingG2Rep ''Char) +$(derivingG2RepTuple 0) +$(derivingG2RepTuples 2 16) +$(derivingG2Rep ''Int) +-- $(derivingG2Rep ''Integer) +$(derivingG2Rep ''Float) +$(derivingG2Rep ''Double) +-- $(derivingG2Rep ''Rational) +-- $(derivingG2Rep ''Word) + +$(derivingG2Rep ''[]) diff --git a/src/G2/QuasiQuotes/Internals/G2Rep.hs b/src/G2/QuasiQuotes/Internals/G2Rep.hs new file mode 100644 --- /dev/null +++ b/src/G2/QuasiQuotes/Internals/G2Rep.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.QuasiQuotes.Internals.G2Rep ( G2Rep (..) + , derivingG2Rep + , derivingG2RepTuples + , derivingG2RepTuple ) where + +import G2.Language.Expr +import G2.Language.Support +import G2.Language.Syntax as G2 +import G2.QuasiQuotes.Support +import G2.Language.Typing + +import Control.Monad + +import qualified Data.HashMap.Lazy as HM +import qualified Data.Text as T + +import GHC.Exts + +import Language.Haskell.TH as TH +import Language.Haskell.TH.Syntax as TH + +class G2Rep g where + g2Rep :: TypeEnv -> CleanedNames -> g -> Expr + g2UnRep :: TypeEnv -> Expr -> g + g2Type :: TypeEnv -> CleanedNames -> g -> G2.Type + +-- Modeled after https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial +derivingG2Rep :: TH.Name -> Q [Dec] +derivingG2Rep n = do + stv <- isExtEnabled ScopedTypeVariables + case stv of + True -> return () + False -> error "derivingG2Rep: derivingG2Rep requires the language ScopedTypeVariables to be enabled" + derivingG2Rep' n + +derivingG2Rep' :: TH.Name -> Q [Dec] +derivingG2Rep' ty = do + TyConI tycon <- reify ty + + let (tyConName, tvs, cs) = case tycon of + DataD _ nm tyvs _ css _ -> (nm, tyvs, css) + NewtypeD _ nm tyvs _ c _ -> (nm, tyvs, [c]) + _ -> error "derivingG2Rep: Unsupported type" + + let instanceType = forallT [] (cxt $ map mkCxt tvs) + $ conT ''G2Rep `appT` foldl apply (conT tyConName) tvs + + sequence [instanceD (return []) instanceType [ genG2Rep tyConName tvs cs + , genG2UnRep (length tvs) cs + , genG2Type tyConName]] + where + 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 + +genG2Rep :: TH.Name -> [TyVarBndr] -> [Con] -> Q Dec +genG2Rep tyConName tvs cs = funD 'g2Rep (map (genG2RepClause tyConName tvs) cs) + +genG2RepClause :: TH.Name -> [TyVarBndr] -> Con -> Q Clause +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 + +genG2RepClause' :: TH.Name -> [TyVarBndr] -> TH.Name -> [StrictType] -> Q Clause +genG2RepClause' tyConName tvs dcNme fieldTypes = do + tenv <- newName "tenv_rep" + cleaned <- newName "cleaned" + fieldNames <- replicateM (length fieldTypes) (newName "x") + + let pats = varP tenv:varP cleaned:[conP dcNme (map varP fieldNames)] + qqTyConName = thNameToQQName tyConName + qqName = thNameToQQName dcNme + + let g2R = conE 'Data + `appE` (varE 'qqDataConLookupFallBack + `appE` litE (integerL $ toInteger $ length tvs) + `appE` litE (integerL $ toInteger $ length fieldTypes) + `appE` qqNameToQExp qqTyConName + `appE` qqNameToQExp qqName + `appE` (varE 'qqMap `appE` varE cleaned `appE` varE tenv) + `appE` varE tenv) + + tys = map (\tyv -> conE 'Type + `appE` (varE 'g2Type + `appE` varE tenv + `appE` varE cleaned + `appE` (sigE (varE 'undefined) (tyVBToType tyv))) + ) tvs + + body = normalB $ appE (varE 'mkApp) $ listE + (g2R:tys ++ map (newField tenv cleaned) (zip fieldNames fieldTypes)) + + clause pats body [] + where + tyVBToType (PlainTV name) = varT name + tyVBToType (KindedTV name _) = varT name + +-- | 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 +-- is not in the given TypeEnv. +-- We do this because the user of a QuasiQuoter may pass in types that are not +-- 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 + | 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) + in + DataCon (qqNameToName0 qqdc) t' + +newField :: TH.Name -> TH.Name -> (TH.Name, StrictType) -> Q Exp +newField _ _ (x, (_, ConT n)) + | nameBase n == "Int#" = [|Lit . LitInt . toInteger $ $(conE 'I# `appE` varE x)|] +newField _ _ (x, (_, ConT n)) + | nameBase n == "Float#" = [|Lit . LitFloat . toRational $ $(conE 'F# `appE` varE x)|] +newField _ _ (x, (_, ConT n)) + | nameBase n == "Double#" = [|Lit . LitDouble . toRational $ $(conE 'D# `appE` varE x)|] +newField _ _ (x, (_, ConT n)) + | nameBase n == "Char#" = [|Lit . LitChar $ $(conE 'C# `appE` varE x)|] +newField tenv cleaned (x, _) = do + return $ VarE 'g2Rep `AppE` VarE tenv `AppE` VarE cleaned `AppE` VarE x + +genG2UnRep :: Int -> [Con] -> Q Dec +genG2UnRep tyVarNum cs = funD 'g2UnRep (map (genG2UnRepClause tyVarNum) cs ++ [g2UnRepCatchAllClause]) + +genG2UnRepClause :: Int -> Con -> Q Clause +genG2UnRepClause tyVarNum (NormalC name fieldTypes) = + genG2UnRepClause' tyVarNum name fieldTypes +genG2UnRepClause tyVarNum (InfixC st1 n st2) = + genG2UnRepClause' tyVarNum n [st1, st2] +genG2UnRepClause _ con = error $ "genG2RepClause: Unhandled case." ++ show con + +genG2UnRepClause' :: Int -> TH.Name -> [StrictType] -> Q Clause +genG2UnRepClause' tyVarNum dcNme fieldTypes = do + expr <- newName "expr" + + fieldNames <- replicateM (length fieldTypes) (newName "x") + g2DCName <- newName "g2_dc" + let guardPat1 = listP $ [p|Data (DataCon (G2.Name $(varP g2DCName) _ _ _) _)|]:replicate tyVarNum wildP ++ map varP fieldNames + guardPat2 = [|T.unpack $(varE g2DCName) == $(litE . stringL $ nameBase dcNme) |] + + guardPat <- patG [bindS guardPat1 (varE 'unApp `appE` varE expr), noBindS guardPat2] + + case zip fieldNames fieldTypes of + [] -> do + let pats = wildP:[varP expr] + + ret <- conE dcNme + let guardRet = return (guardPat, ret) + + clause pats (guardedB [guardRet]) [] + fnt -> do + tenv <- newName "tenv_unrep" + let pats = varP tenv:[varP expr] + + ret <- appsE $ conE dcNme:map (newFieldUnRep tenv) fnt + let guardRet = return (guardPat, ret) + + clause pats (guardedB [guardRet]) [] + +g2UnRepCatchAllClause :: Q Clause +g2UnRepCatchAllClause = do + expr <- newName "expr" + let pats = [wildP, varP expr] + + clause pats (normalB [|error $ "Unhandled case in g2UnRep" ++ show $(varE expr) |]) [] + +newFieldUnRep :: TH.Name -> (TH.Name, StrictType) -> Q Exp +newFieldUnRep _ (x, (_, ConT n)) + | nameBase n == "Int#" = [| intPrimFromLit $(varE x) |] +newFieldUnRep _ (x, (_, ConT n)) + | nameBase n == "Float#" = [| floatPrimFromLit $(varE x) |] +newFieldUnRep _ (x, (_, ConT n)) + | nameBase n == "Double#" = [| doublePrimFromLit $(varE x) |] +newFieldUnRep _ (x, (_, ConT n)) + | nameBase n == "Char#" = [| charPrimFromLit $(varE x) |] +newFieldUnRep tenv (x, _) = do + varE 'g2UnRep `appE` varE tenv `appE` varE x + +genG2Type :: TH.Name -> Q Dec +genG2Type tyConName = funD 'g2Type [genG2TypeClause tyConName] + +genG2TypeClause :: TH.Name -> Q Clause +genG2TypeClause tyConName = do + tenv <- newName "tenv_type" + cleaned <- newName "cleaned" + let pats = [varP tenv, varP cleaned, wildP] + + let qqTyConName = thNameToQQName tyConName + exn = [|let + qqM = qqMap $(varE cleaned) $(varE tenv) + n = HM.lookup $(qqNameToQExp qqTyConName) qqM + in + case n of + Just tcn -> TyCon tcn TYPE + Nothing -> TyCon (G2.Name (T.pack "Unknown") Nothing 0 Nothing) TYPE|] + + clause pats (normalB exn) [] + +derivingG2RepTuples :: Int -> Int -> Q [Dec] +derivingG2RepTuples mi ma = return . concat =<< mapM derivingG2RepTuple [mi..ma] + +derivingG2RepTuple :: Int -> Q [Dec] +derivingG2RepTuple n = derivingG2Rep (tupleTypeName n) + +qqNameToQExp :: QQName -> Q Exp +qqNameToQExp (QQName n Nothing) = + conE 'QQName `appE` textToQExp n `appE` conE 'Nothing +qqNameToQExp (QQName n (Just m)) = + conE 'QQName `appE` textToQExp n `appE` (conE 'Just `appE` textToQExp m) + +textToQExp :: T.Text -> Q Exp +textToQExp t = varE 'T.pack `appE` litE (stringL (T.unpack t)) + +intPrimFromLit :: G2.Expr -> Int# +intPrimFromLit (Lit (LitInt x)) = + case fromInteger x of + I# x' -> x' +intPrimFromLit _ = error "intPrimFromLit: Unhandled Expr" + +floatPrimFromLit :: G2.Expr -> Float# +floatPrimFromLit (Lit (LitFloat x)) = + case fromRational x of + F# x' -> x' +floatPrimFromLit _ = error "floatPrimFromLit: Unhandled Expr" + +doublePrimFromLit :: G2.Expr -> Double# +doublePrimFromLit (Lit (LitDouble x)) = + case fromRational x of + D# x' -> x' +doublePrimFromLit _ = error "intPrimFromLit: Unhandled Expr" + +charPrimFromLit :: G2.Expr -> Char# +charPrimFromLit (Lit (LitChar (C# x))) = x +charPrimFromLit _ = error "charPrimFromLit: Unhandled Expr" diff --git a/src/G2/QuasiQuotes/Parser.hs b/src/G2/QuasiQuotes/Parser.hs new file mode 100644 --- /dev/null +++ b/src/G2/QuasiQuotes/Parser.hs @@ -0,0 +1,136 @@ +module G2.QuasiQuotes.Parser + ( QuotedExtract (..) + , extractQuotedData + , transformQuoted + , quotedEx2Hsk + , getConcVars + ) where + + +import Data.Array +import Data.Char +import Data.List +import Text.Regex +import Text.Regex.Base + +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace + +-------------------- +-- Regular expressions + +-- RS stands for Regex String +idRs :: String +idRs = "[A-Za-z][0-9A-Za-z_]*" + +whiteSpaceRs :: String +whiteSpaceRs = "[ \t\r\n\v\f]" + +paddedIdRs :: String +paddedIdRs = whiteSpaceRs ++ "*" ++ idRs ++ whiteSpaceRs ++ "*" + +bar :: String +bar = "|" + +symbVarRegex :: Regex +symbVarRegex = mkRegex $ "[?][(]" ++ paddedIdRs ++ "::[^!?|]*" + +lamDividerRegex :: Regex +lamDividerRegex = mkRegex $ "->" ++ whiteSpaceRs ++ "[?]" + +dividerRegex :: Regex +dividerRegex = mkRegex $ "[" ++ bar ++ "]" + +-- Output from matchAlltext +matchAllText2 :: RegexLike regex source => regex -> source -> [source] +matchAllText2 regex = map (fst . snd) . concatMap assocs . matchAllText regex + +idPairFrom2Colon :: String -> (String, String) +idPairFrom2Colon twoColonSepd = + case splitRegex (mkRegex "::") twoColonSepd of + (s1 : s2 : []) -> + case (splitRegex (mkRegex "[(]") s1, reverse $ trim s2) of + (_ : varName : [], ')' : revVarType) + -> (trim varName, "(" ++ reverse revVarType ++ ")") + _ -> error $ "idPairFromColon: incorrect decomp: " ++ show (s1, s2) + _ -> error $ "idPairFrom2Colon: incorrect string " ++ show twoColonSepd + + {- + case matchAllText2 (mkRegex idRs) twoColonSepd of + (s1 : s2 : []) -> (trim s1, trim s2) + _ -> error $ "idPairFrom2Colon: incorrect string " ++ show twoColonSepd + -} + +-- These three functions need to be fed processed strings +-- getConcVars :: String -> [(String, String)] +-- getConcVars chewed = map idPairFrom2Colon $ matchAllText2 concVarRegex chewed + +getConcVars :: String -> [(String, String)] +getConcVars = getConcVars' 0 "" + +getConcVars' :: Int -> String -> String -> [(String, String)] +getConcVars' n pr ('(':xs) + | n == 0 = getConcVars' (n + 1) pr xs + | otherwise = getConcVars' (n + 1) ('(':pr) xs +getConcVars' n pr (')':xs) + | n == 1 + , [v, t] <- splitRegex (mkRegex "::") (reverse pr) = (filter (not . isSpace) v, "(" ++ t ++ ")"):getConcVars' (n - 1) "" xs + | otherwise = getConcVars' (n - 1) (')':pr) xs +getConcVars' n pr (x:xs) + | n > 0 = getConcVars' n (x:pr) xs + | otherwise = getConcVars' n (x:pr) xs +getConcVars' _ pr [] + | [v, t] <- splitRegex (mkRegex "::") (reverse pr) = [(filter (not . isSpace) v, "(" ++ t ++ ")")] + | otherwise = [] + +getSymbVars :: String -> [(String, String)] +getSymbVars chewed = map idPairFrom2Colon $ matchAllText2 symbVarRegex chewed + +----------------------- +-- Parsing extracted stuff + +data QuotedExtract = QuotedExtract + { concVars :: [(String, String)] -- (varName, VarType) + , symbVars :: [(String, String)] -- (varName, varType) + , bodyExpr :: String + } deriving (Show, Eq) + +-- Extract the conc var-ty pairs, symb var-ty pairs, and fun body +extractQuotedData :: String -> QuotedExtract +extractQuotedData raw + | (h:raw') <- dropWhile isSpace raw + , h == '\\' = + -- First split based on the divider bar "|" + -- into variable declarations and body + case splitRegex dividerRegex raw' of + (hd : tl) -> + -- Further partiton with "-> ?" into concrete and symbolics + -- Remember that splitting will consume the initial ? + case splitRegex lamDividerRegex hd of + (concs : symbs) -> + QuotedExtract + { concVars = getConcVars concs + , symbVars = getSymbVars $ '?' : concat symbs + , bodyExpr = trim $ intercalate bar tl + } + _ -> error $ "extractQuotedData: bad text " ++ show raw + _ -> error $ "extractQuotedData: bad text " ++ show raw + | otherwise = error $ "extractQuotedData: bad text " ++ show raw + +quotedEx2Hsk :: QuotedExtract -> String +quotedEx2Hsk quoted = + let (concVs, concTs) = unzip $ concVars quoted + (symbVs, symbTs) = unzip $ symbVars quoted + bodyStr = bodyExpr quoted + typeStr = intercalate " -> " (concTs ++ symbTs ++ ["Bool"]) + concParamStr = intercalate " " concVs + symbParamStr = intercalate " " symbVs + in + "(\\ " ++ concParamStr ++ " -> " + ++ "\\ " ++ symbParamStr ++ " -> " + ++ bodyStr ++ ") :: " ++ typeStr + +------------------- +-- The one-pass function +transformQuoted :: String -> String +transformQuoted = quotedEx2Hsk . extractQuotedData diff --git a/src/G2/QuasiQuotes/QuasiQuotes.hs b/src/G2/QuasiQuotes/QuasiQuotes.hs new file mode 100644 --- /dev/null +++ b/src/G2/QuasiQuotes/QuasiQuotes.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module G2.QuasiQuotes.QuasiQuotes (g2) where + +import G2.Config +import G2.Execution.Interface +import G2.Execution.Memory +import G2.Execution.Reducer +import G2.Initialization.MkCurrExpr +import G2.Interface +import G2.Language as G2 +import qualified G2.Language.Typing as Ty +import G2.Solver +import G2.Translation.Cabal.Cabal +import G2.Translation.Haskell +import G2.Translation.Interface +import G2.Translation.TransTypes +import G2.QuasiQuotes.FloodConsts +import G2.QuasiQuotes.G2Rep +import G2.QuasiQuotes.Support +import G2.QuasiQuotes.Parser + +import qualified Control.Concurrent.Lock as Lock + +import Data.Data +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.IORef +import qualified Data.Text as T + +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax as TH +import Language.Haskell.TH.Quote + +import System.Directory +import System.IO +import System.IO.Temp +import System.IO.Unsafe + +g2 :: QuasiQuoter +g2 = QuasiQuoter { quoteExp = parseHaskellQ + , quotePat = error "g2: No QuasiQuoter for patterns." + , quoteType = error "g2: No QuasiQuoter for types." + , quoteDec = error "g2: No QuasiQuoter for declarations." } + +-- If we compile multiple G2 quasiquoters at the same time, we can get errors. +-- This is a hack to prevent that from happening. The IORef is global, and +-- aquired/released by each quasiquoter's compilation +oneByOne :: IORef Lock.Lock +oneByOne = unsafePerformIO $ newIORef =<< Lock.new + +acquireIORefLock :: IO () +acquireIORefLock = do + lock <- readIORef oneByOne + Lock.acquire lock + +releaseIORefLock :: IO () +releaseIORefLock = do + lock <- readIORef oneByOne + Lock.release lock + +parseHaskellQ :: String -> Q Exp +parseHaskellQ str = do + runIO $ acquireIORefLock + -- runIO $ putStrLn $ "CWD is: " ++ cwd + + -- Get names for the lambdas for the regular inputs + let qext = extractQuotedData str + + -- let regs = grabRegVars str + let regs = map fst $ concVars qext + + ns <- mapM newName regs + let ns_pat = map varP ns + + -- 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 + + runIO $ releaseIORefLock + + ex_out <- runExecutionQ init_s init_b config + + state_name <- newName "state" + tenv_name <- newName "tenv_parse" + cleaned_names_name <- newName "cleaned" + bindings_name <- newName "bindings" + + (ex, state_exp, tenv, bindings_final) <- case ex_out of + Completed xs b -> do + case elimUnusedCompleted xs b of + (xs'@(s:_), b') -> do + let xs'' = listE $ map (moveOutTypeEnvState tenv_name) xs' + + xs''' = addCompRegVarPasses (varE state_name) tenv_name cleaned_names_name ns (inputIds s b') b' + + b'' = b' { input_names = drop (length regs) (input_names b') } + sol = solveStates xs''' (varE bindings_name) + ars = extractArgs (inputIds s b'') (cleaned_names b'') tenv_name sol + + return (foldr (\n -> lamE [n]) ars ns_pat, xs'', type_env s, b'') + ([], _) -> + let + b' = init_b { input_names = drop (length regs) (input_names init_b) } + ts = map (toTHType (cleaned_names b') . Ty.typeOf) $ inputIds init_s b' + tup_t = case ts of + [t] -> t + _ -> foldr appT (tupleT (length ts)) ts + + in + return (foldr (\n -> lamE [n]) [| return (Nothing :: Maybe $(tup_t)) |] ns_pat + , [| return [] :: IO [State ()] |] + , M.empty + , b') + NonCompleted s b -> do + let + (s', b') = elimUnusedNonCompleted s b + + s'' = moveOutTypeEnvState tenv_name s' + + s''' = addedNonCompRegVarBinds (varE state_name) tenv_name cleaned_names_name ns (inputIds s' b') b' + + b'' = b' { input_names = drop (length regs) (input_names b') } + + sol = executeAndSolveStates s''' (varE bindings_name) + + ars = extractArgs (inputIds s b'') (cleaned_names b'') tenv_name sol + + return (foldr (\n -> lamE [n]) ars ns_pat, s'', type_env s', b'') + + -- foldr (\n -> lamE [n]) [|do putStrLn "NONCOMPLETED"; return Nothing;|] ns_pat + + + let tenv_exp = liftDataT tenv `sigE` [t| TypeEnv |] + bindings_exp = liftDataT (bindings_final { name_gen = mkNameGen ()}) + + letE [ valD (varP state_name) (normalB state_exp) [] + , valD (varP tenv_name) (normalB tenv_exp) [] + , valD (varP bindings_name) (normalB bindings_exp) [] + , valD (varP cleaned_names_name) (normalB (varE 'cleaned_names `appE` varE bindings_name)) []] ex + +liftDataT :: Data a => a -> Q Exp +liftDataT = dataToExpQ (\a -> case liftText <$> cast a of + je@(Just _) -> je + Nothing -> liftLoc <$> 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 + intE i = [| i |] + +parseHaskellQ' :: QuotedExtract-> Q ExtractedG2 +parseHaskellQ' qext = do + (ModuleInfo mods) <- reifyModule =<< thisModule + -- runIO $ mapM putStrLn =<< guessModules mods + -- runIO $ putStrLn "-----" + runIO $ parseHaskellIO mods qext + +-- | Turn the Haskell into a G2 Expr. All variables- both those that the user +-- marked to be passed into the Expr as real values, and those that the user +-- wants to solve for- are treated as symbolic here. +parseHaskellIO :: [Module] -> QuotedExtract -> IO ExtractedG2 +parseHaskellIO mods qext = do + -- cwd <- getCurrentDirectory + -- let cwd' = cwd ++ "/quasiquote/" + let hskStr = quotedEx2Hsk qext + (_, exG2) <- withSystemTempFile fileName + (\filepath handle -> do + let contents = "module " ++ moduleName ++ " where\n" + ++ intercalate "\n" modImports ++ "\n" + ++ functionName ++ " = " ++ hskStr + hPutStrLn handle contents + hFlush handle + hClose handle + + + -- We guess based on the cwd because who knows where temp + -- files will get written to. + cwd <- getCurrentDirectory + cabal <- findCabal cwd + let cabal' = maybe (error "No cabal file found") id cabal + projs <- cabalSrcDirs cabal' + config <- qqConfig + + translateLoaded projs [filepath] [] + simplTranslationConfig + config) + return exG2 + where + modImports = map ("import " ++) + . filter (`notElem` badImports) + . map (\(Module _ (ModName n)) -> n) $ mods + badImports = ["G2.QuasiQuotes.QuasiQuotes"] + + +-- allDirectories :: FilePath -> IO [FilePath] +-- allDirectories fp = do +-- all <- listDirectory fp +-- fs <- filterM doesDirectoryExist all + +-- fs' <- mapM allDirectories fs + +-- mapM makeAbsolute $ fp:fs ++ concat fs' + +-- | If a State has been completely symbolically executed (i.e. no states were +-- discarded by a Halter) we encoded it as Completed. +-- Otherwise, we encode the original State and Bindings as NonCompleted +data ExecOut = Completed [State ()] Bindings + | NonCompleted (State ()) Bindings + +runExecutionQ :: State () -> Bindings -> Config -> Q ExecOut +runExecutionQ s b config = do + runIO $ do + let (s', b') = addAssume s b + + SomeSolver con <- initSolverInfinite config + case qqRedHaltOrd con of + (SomeReducer red, SomeHalter hal, SomeOrderer ord) -> do + let (s'', b'') = runG2Pre [] s' b' + hal' = hal :<~> ZeroHalter 2000 :<~> LemmingsHalter + (xs, b''') <- runExecutionToProcessed red hal' ord s'' b'' + + case xs of + Processed { accepted = acc, discarded = [] } -> do + let acc' = filter (trueCurrExpr) acc + return $ Completed acc' b''' + _ -> do + return $ NonCompleted s'' b'' + where + trueCurrExpr (State { curr_expr = CurrExpr _ e + , known_values = kv }) = e == mkTrue kv + _ = 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 _ _ _ _ _ = () + +fileName :: String +fileName = "THTemp.hs" + +moduleName :: String +moduleName = "THTemp" + +functionName :: String +functionName = "g2Expr" + +qqRedHaltOrd :: Solver conv => conv -> (SomeReducer (), SomeHalter (), SomeOrderer ()) +qqRedHaltOrd conv = + let + tr_ng = mkNameGen () + state_name = G2.Name "state" Nothing 0 Nothing + in + ( SomeReducer + (NonRedPCRed :<~| TaggerRed state_name tr_ng) + <~| (SomeReducer (StdRed conv)) + , SomeHalter + (DiscardIfAcceptedTag state_name + :<~> AcceptHalter) + , SomeOrderer NextOrderer) + +addAssume :: State t -> Bindings -> (State t, Bindings) +addAssume s@(State { curr_expr = CurrExpr er e }) b@(Bindings { name_gen = ng }) = + let + (v, ng') = freshId (Ty.typeOf e) ng + e' = Let [(v, e)] (Assume Nothing (Var v) (Var v)) + in + (s { curr_expr = CurrExpr er e' }, b { name_gen = ng' }) + +type TypeEnvName = TH.Name +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) } |] + +-- 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 + let ns_exp = map varE ns + ty_ns_exp = map (\(n, i) -> sigE n (toTHType cleaned (Ty.typeOf i))) $ zip ns_exp is + + ins_exp = liftDataT ins + + g2Rep_exp = [| g2Rep $(varE tenv_name) $(varE cleaned_name) |] + ns_expr = map (appE g2Rep_exp) ty_ns_exp + + zip_exp = [| zip $(ins_exp) $(listE ns_expr) |] + zip_exp + +-- | Adds the appropriate number of lambda bindings to the Exp, +-- and sets up a conversion from TH Exp's to G2 Expr's. +-- The returned Exp should have a function type and return type (State t). +addCompRegVarPasses :: StateListExp -> TypeEnvName -> CleanedNamesName -> [TH.Name] -> InputIds -> Bindings -> Q Exp +addCompRegVarPasses xs_exp tenv_name cleaned_name ns in_ids b = do + + let zip_exp = regVarBindings ns tenv_name cleaned_name in_ids b + + flooded_exp = appE (varE 'mapMaybe) (appE (varE 'floodConstantsChecking) zip_exp) + + appE flooded_exp xs_exp + +addedNonCompRegVarBinds :: StateExp -> TypeEnvName -> CleanedNamesName -> [TH.Name] -> InputIds -> Bindings -> Q Exp +addedNonCompRegVarBinds state_exp tenv_name cleaned_name ns in_ids b = do + + let zip_exp = regVarBindings ns tenv_name cleaned_name in_ids b + + flooded_exp = [| case floodConstantsChecking $(zip_exp) $(state_exp) of + Just s' -> s' + Nothing -> error "addedNonCompRegVarBinds: Nothing"|] + + flooded_exp + +elimUnusedCompleted :: Named t => [State t] -> Bindings -> ([State t], Bindings) +elimUnusedCompleted xs b = + let + b' = b { deepseq_walkers = M.empty + , higher_order_inst = [] } + + xs' = map (\s -> s { type_classes = initTypeClasses [] + , rules = [] }) xs + xs'' = map (fst . flip markAndSweepIgnoringKnownValues b') xs' + in + (xs'', b') + +elimUnusedNonCompleted :: Named t => State t -> Bindings -> (State t, Bindings) +elimUnusedNonCompleted s b = + let + b' = b { deepseq_walkers = M.empty + , higher_order_inst = [] } + s' = s { type_classes = initTypeClasses [] + , rules = [] } + in + markAndSweepIgnoringKnownValues s' b' + +type StateExp = Q Exp +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 _ _ _ _ _ = () + +executeAndSolveStates :: StateExp -> BindingsExp -> Q Exp +executeAndSolveStates s b = do + varE 'executeAndSolveStates' `appE` b `appE` s + +executeAndSolveStates' :: Bindings -> State () -> IO (Maybe (ExecRes ())) +executeAndSolveStates' b s = do + config <- qqConfig + SomeSolver con <- initSolverInfinite config + case qqRedHaltOrd con 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 + + case res of + exec_res:_ -> return $ Just exec_res + _ -> return Nothing + +-- Takes an Exp representing a list of States, and returns an Exp representing an ExecRes +solveStates :: StateExp -> BindingsExp -> Q Exp +solveStates xs b = do + varE 'solveStates' `appE` b `appE` xs + +solveStates' :: ( Named t + , ASTContainer t Expr + , 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 + +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 + case m_ex_res of + Just _ -> do + return m_ex_res + Nothing -> solveStates'' sol b xs + +-- | Get the values of the symbolic arguments, and returns them in a tuple +extractArgs :: InputIds -> CleanedNames -> TypeEnvName -> Q Exp -> Q Exp +extractArgs in_ids cleaned tenv es = + [|do + r <- $(es) + case r of + 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 +toSymbArgsTuple :: InputIds -> CleanedNames -> TypeEnvName -> Q Exp +toSymbArgsTuple in_ids cleaned tenv_name = do + 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])) + +qqConfig :: IO Config +qqConfig = do + homedir <- getHomeDirectory + return $ mkConfig homedir [] M.empty diff --git a/src/G2/QuasiQuotes/Support.hs b/src/G2/QuasiQuotes/Support.hs new file mode 100644 --- /dev/null +++ b/src/G2/QuasiQuotes/Support.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Converts types with Name's to types with QQNames, since uniques in the +-- QuasiQuoter will most likely not match up with uniques from the original +-- code + +module G2.QuasiQuotes.Support ( QQName (..) + , QQMap + , qqMap + , nameToQQName + , thNameToQQName + , qqNameToName0 + + , qqAlgDataTyLookup + , qqDataConLookup + + , toTHType ) where + +import G2.Language as G2 + +import Language.Haskell.TH as TH + +import GHC.Generics (Generic) +import Data.Data +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) + deriving (Eq, Show, Read, Generic, Typeable, Data) + +instance Hashable QQName + +type QQMap = HM.HashMap QQName G2.Name + +qqMap :: Named n => CleanedNames -> n -> QQMap +qqMap cn n = + let + ns = names n + in + HM.fromList $ zip (map (nameToQQName . renames cn) ns) ns + +nameToQQName :: G2.Name -> QQName +nameToQQName (Name n m _ _) = QQName n m + +thNameToQQName :: TH.Name -> QQName +thNameToQQName n = + QQName (T.pack $ TH.nameBase n) (fmap T.pack $ TH.nameModule n) + +-- | Maps a `QQName` to a `Name` with unique 0 +qqNameToName0 :: QQName -> G2.Name +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 + +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 + | 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 + | Just i <- tupleNum . nameOcc $ renames cleaned n = tupleT i + | otherwise = do + tn <- lookupTypeName . T.unpack . nameOcc $ renames cleaned n + case tn of + Just tn' -> conT tn' + Nothing -> error $ "toTHType: Unhandled case\n" ++ show (renames cleaned t) +toTHType _ t = error $ "toTHType: Unhandled case\n" ++ show t + +tupleNum :: T.Text -> Maybe Int +tupleNum = tupleNum' 0 . T.unpack + +tupleNum' :: Int -> String -> Maybe Int +tupleNum' 0 ("()") = Just 0 +tupleNum' 0 ('(':xs) = tupleNum' 1 xs +tupleNum' !n (',':xs) = tupleNum' (1 + n) xs +tupleNum' !n ")" = Just n +tupleNum' _ _ = Nothing diff --git a/src/G2/Solver.hs b/src/G2/Solver.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver.hs @@ -0,0 +1,18 @@ +-- | Solver +-- Export module for G2.Solver. +module G2.Solver + ( module G2.Solver.ADTSolver, + module G2.Solver.Converters, + module G2.Solver.Language, + module G2.Solver.Interface, + module G2.Solver.ParseSMT, + module G2.Solver.SMT2, + module G2.Solver.Solver ) where + +import G2.Solver.ADTSolver +import G2.Solver.Converters +import G2.Solver.Language +import G2.Solver.Interface +import G2.Solver.ParseSMT +import G2.Solver.SMT2 +import G2.Solver.Solver diff --git a/src/G2/Solver/ADTSolver.hs b/src/G2/Solver/ADTSolver.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/ADTSolver.hs @@ -0,0 +1,206 @@ +{-# 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 diff --git a/src/G2/Solver/Converters.hs b/src/G2/Solver/Converters.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/Converters.hs @@ -0,0 +1,518 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This contains functions to switch from +-- (1) A State/Exprs/Types to SMTHeaders/SMTASTs/Sorts +-- (2) SMTHeaders/SMTASTs/Sorts to some SMT solver interface +-- (3) SMTASTs/Sorts to Exprs/Types +module G2.Solver.Converters + ( toSMTHeaders + , toSolver + , exprToSMT --WOULD BE NICE NOT TO EXPORT THIS + , typeToSMT --WOULD BE NICE NOT TO EXPORT THIS + , toSolverAST --WOULD BE NICE NOT TO EXPORT THIS + , smtastToExpr + , modelAsExpr + , checkConstraints + , checkModel + , SMTConverter (..) ) where + +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T + +import G2.Language hiding (Assert, vars) +import qualified G2.Language.ExprEnv as E +import qualified G2.Language.PathConds as PC +import G2.Solver.Language +import G2.Solver.Solver + +-- | 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 + 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 + + (.>=) :: con -> ast -> ast -> ast + (.>) :: con -> ast -> ast -> ast + (.=) :: con -> ast -> ast -> ast + (./=) :: con -> ast -> ast -> ast + (.<) :: con -> ast -> ast -> ast + (.<=) :: con -> ast -> ast -> ast + + (.&&) :: con -> ast -> ast -> ast + (.||) :: con -> ast -> ast -> ast + (.!) :: con -> ast -> ast + (.=>) :: con -> ast -> ast -> ast + (.<=>) :: con -> ast -> ast -> ast + + (.+) :: 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 + + ite :: con -> ast -> ast -> ast -> ast + + --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 + + --sorts + sortInt :: con -> ast + sortFloat :: con -> ast + sortDouble :: con -> ast + sortChar :: con -> ast + sortBool :: con -> ast + + varName :: con -> SMTName -> Sort -> ast + +-- | 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 + + let headers = toSMTHeaders pc' + let formula = toSolver con headers + + checkSat con (getIO con) formula + +-- | 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 + +-- | 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' _ _ s _ [] _ = do + return (SAT, Just $ model s) +checkModel' avf con s b (i:is) pc + | (idName i) `M.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) + +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) + + case PC.null pc of + True -> + let + (e, av) = avf t (type_env s) (arb_value_gen b) + in + return (Just $ M.singleton n' e, av) + False -> do + m <- checkNumericConstraints con pc + return (m, arb_value_gen b) + +checkNumericConstraints :: SMTConverter con ast out io => con -> PathConds -> IO (Maybe Model) +checkNumericConstraints con pc = do + let headers = toSMTHeaders pc + let formula = toSolver con headers + + let vs = map (\(n', srt) -> (nameToStr n', srt)) . pcVars $ PC.toList pc + + let io = getIO con + (_, m) <- checkSatGetModel con io formula headers vs + + let m' = fmap modelAsExpr m + + case m' of + Just m'' -> return $ Just m'' + Nothing -> return Nothing + +-- | Here we convert from a State, to an SMTHeader. This SMTHeader can later +-- be given to an SMT solver by using toSolver. +-- To determine the input that can be fed to a state to get the curr_expr, +-- we need only consider the types and path constraints of that state. +-- We can also pass in some other Expr Container to instantiate names from, which is +-- important if you wish to later be able to scrape variables from those Expr's +toSMTHeaders :: PathConds -> [SMTHeader] +toSMTHeaders = addSetLogic . toSMTHeaders' + +toSMTHeaders' :: PathConds -> [SMTHeader] +toSMTHeaders' pc = + let + pc' = PC.toList pc + in + nub (pcVarDecls pc') + ++ + (pathConsToSMTHeaders pc') + +-- | Determines an appropriate SetLogic command, and adds it to the headers +addSetLogic :: [SMTHeader] -> [SMTHeader] +addSetLogic xs = + let + lia = isLIA xs + lra = isLRA xs + lira = isLIRA xs + nia = isNIA xs + nra = isNRA xs + nira = isNIRA 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 + in + sl:xs + +isNIA :: (ASTContainer m SMTAST) => m -> Bool +isNIA = getAll . evalASTs isNIA' + +isNIA' :: SMTAST -> All +isNIA' (_ :* _) = All True +isNIA' (_ :/ _) = All True +isNIA' s = isLIA' s + +isLIA :: (ASTContainer m SMTAST) => m -> Bool +isLIA = getAll . evalASTs isLIA' + +isLIA' :: SMTAST -> All +isLIA' (_ :>= _) = All True +isLIA' (_ :> _) = All True +isLIA' (_ := _) = All True +isLIA' (_ :/= _) = All True +isLIA' (_ :< _) = All True +isLIA' (_ :<= _) = All True +isLIA' (_ :+ _) = All True +isLIA' (_ :- _) = All True +isLIA' (x :* y) = All $ isIntegerCoeff x || isIntegerCoeff y +isLIA' (Neg _) = All True +isLIA' (VInt _) = All True +isLIA' (V _ s) = All $ isIASort s +isLIA' s = isCore' s + +isIASort :: Sort -> Bool +isIASort SortInt = True +isIASort s = isCoreSort s + +isIntegerCoeff :: SMTAST -> Bool +isIntegerCoeff (Neg s) = isIntegerCoeff s +isIntegerCoeff (VInt _) = True +isIntegerCoeff _ = False + +isNRA :: (ASTContainer m SMTAST) => m -> Bool +isNRA = getAll . evalASTs isNRA' + +isNRA' :: SMTAST -> All +isNRA' (_ :* _) = All True +isNRA' (_ :/ _) = All True +isNRA' s = isLRA' s + +isLRA :: (ASTContainer m SMTAST) => m -> Bool +isLRA = getAll . evalASTs isLRA' + +isLRA' :: SMTAST -> All +isLRA' (_ :>= _) = All True +isLRA' (_ :> _) = All True +isLRA' (_ := _) = All True +isLRA' (_ :/= _) = All True +isLRA' (_ :< _) = All True +isLRA' (_ :<= _) = All True +isLRA' (_ :+ _) = All True +isLRA' (_ :- _) = All True +isLRA' (x :* y) = All $ isRationalCoeff x || isRationalCoeff y +isLRA' (Neg _) = All True +isLRA' (VFloat _) = All True +isLRA' (VDouble _) = All True +isLRA' (V _ s) = All $ isRASort s +isLRA' s = isCore' s + +isRASort :: Sort -> Bool +isRASort SortFloat = True +isRASort SortDouble = True +isRASort s = isCoreSort s + +isRationalCoeff :: SMTAST -> Bool +isRationalCoeff (Neg s) = isRationalCoeff s +isRationalCoeff (VFloat _) = True +isRationalCoeff (VDouble _) = True +isRationalCoeff _ = False + +isLIRA :: (ASTContainer m SMTAST) => m -> Bool +isLIRA = getAll . evalASTs isLIRA' + +isLIRA' :: SMTAST -> All +isLIRA' (ItoR _) = All True +isLIRA' s = All $ getAll (isLIA' s) || getAll (isLRA' s) + +isNIRA :: (ASTContainer m SMTAST) => m -> Bool +isNIRA = getAll . evalASTs isNIRA' + +isNIRA' :: SMTAST -> All +isNIRA' (ItoR _) = All True +isNIRA' s = All $ getAll (isNIA' s) || getAll (isNRA' s) + +isCore' :: SMTAST -> All +isCore' (_ := _) = All True +isCore' (_ :&& _) = All True +isCore' (_ :|| _) = All True +isCore' ((:!) _) = All True +isCore' (_ :=> _) = All True +isCore' (_ :<=> _) = All True +isCore' (VBool _) = All True +isCore' (V _ s) = All $ isCoreSort s +isCore' _ = All False + +isCoreSort :: Sort -> Bool +isCoreSort SortBool = True +isCoreSort _ = False + +------------------------------------------------------------------------------- + +pathConsToSMTHeaders :: [PathCond] -> [SMTHeader] +pathConsToSMTHeaders = map Assert . mapMaybe pathConsToSMT + +pathConsToSMT :: PathCond -> Maybe 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) = + let + exprSMT = exprToSMT e + in + Just $ if b then exprSMT else (:!) exprSMT +pathConsToSMT (ConsCond (DataCon (Name "False" _ _ _) _) e b) = + let + exprSMT = exprToSMT e + in + Just $ if b then (:!) $ exprSMT else exprSMT +pathConsToSMT (ConsCond (DataCon _ _) _ _) = error "Non-bool DataCon in pathConsToSMT" +pathConsToSMT (PCExists _) = Nothing + +exprToSMT :: Expr -> SMTAST +exprToSMT (Var (Id n t)) = V (nameToStr n) (typeToSMT t) +exprToSMT (Lit c) = + case c of + LitInt i -> VInt i + LitFloat f -> VFloat f + LitDouble d -> VDouble d + LitChar ch -> VChar ch + err -> error $ "exprToSMT: invalid Expr: " ++ show err +exprToSMT (Data (DataCon n (TyCon (Name "Bool" _ _ _) _))) = + case nameOcc n of + "True" -> VBool True + "False" -> VBool False + _ -> error "Invalid bool in exprToSMT" +exprToSMT (Data (DataCon n t)) = V (nameToStr n) (typeToSMT t) +exprToSMT a@(App _ _) = + let + f = getFunc a + ars = getArgs a + in + funcToSMT f ars + where + getFunc :: Expr -> Expr + getFunc v@(Var _) = v + getFunc p@(Prim _ _) = p + getFunc (App a' _) = getFunc a' + getFunc d@(Data _) = d + getFunc err = error $ "getFunc: invalid Expr: " ++ show err + + getArgs :: Expr -> [Expr] + getArgs (App a1 a2) = getArgs a1 ++ [a2] + getArgs _ = [] +exprToSMT e = error $ "exprToSMT: unhandled Expr: " ++ show e + +-- | We split based on whether the passed Expr is a function or known data constructor, or an unknown data constructor +funcToSMT :: Expr -> [Expr] -> SMTAST +funcToSMT (Prim p _) [a] = funcToSMT1Prim p a +funcToSMT (Prim p _) [a1, a2] = funcToSMT2Prim p a1 a2 +funcToSMT e l = error ("Unrecognized " ++ show e ++ " with args " ++ show l ++ " in funcToSMT") + +funcToSMT1Prim :: Primitive -> Expr -> SMTAST +funcToSMT1Prim Negate a = Neg (exprToSMT a) +funcToSMT1Prim SqRt e = SqrtSMT (exprToSMT e) +funcToSMT1Prim Not e = (:!) (exprToSMT e) +funcToSMT1Prim IntToFloat e = ItoR (exprToSMT e) +funcToSMT1Prim IntToDouble e = ItoR (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 Implies a1 a2 = exprToSMT a1 :=> exprToSMT a2 +funcToSMT2Prim Iff a1 a2 = exprToSMT a1 :<=> exprToSMT a2 +funcToSMT2Prim Ge a1 a2 = exprToSMT a1 :>= exprToSMT a2 +funcToSMT2Prim Gt a1 a2 = exprToSMT a1 :> exprToSMT a2 +funcToSMT2Prim Eq a1 a2 = exprToSMT a1 := exprToSMT a2 +funcToSMT2Prim Neq a1 a2 = exprToSMT a1 :/= exprToSMT a2 +funcToSMT2Prim Lt a1 a2 = exprToSMT a1 :< exprToSMT a2 +funcToSMT2Prim Le a1 a2 = exprToSMT a1 :<= exprToSMT a2 +funcToSMT2Prim Plus a1 a2 = exprToSMT a1 :+ exprToSMT a2 +funcToSMT2Prim Minus a1 a2 = exprToSMT a1 :- exprToSMT a2 +funcToSMT2Prim Mult a1 a2 = exprToSMT a1 :* exprToSMT a2 +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 op lhs rhs = error $ "funcToSMT2Prim: invalid case with (op, lhs, rhs): " ++ show (op, lhs, rhs) + +altToSMT :: Lit -> Expr -> SMTAST +altToSMT (LitInt i) _ = VInt i +altToSMT (LitFloat f) _ = VFloat f +altToSMT (LitDouble d) _ = VDouble d +altToSMT (LitChar c) _ = VChar c +altToSMT am _ = error $ "Unhandled " ++ show am + +createVarDecls :: [(Name, Sort)] -> [SMTHeader] +createVarDecls [] = [] +createVarDecls ((n,SortChar):xs) = + let + lenAssert = Assert $ StrLen (V (nameToStr n) SortChar) := VInt 1 + in + VarDecl (nameToStr n) SortChar:lenAssert:createVarDecls xs +createVarDecls ((n,s):xs) = VarDecl (nameToStr n) s:createVarDecls xs + +pcVarDecls :: [PathCond] -> [SMTHeader] +pcVarDecls = createVarDecls . 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' _ = [] + +idToNameSort :: Id -> (Name, Sort) +idToNameSort (Id n t) = (n, typeToSMT t) + +typeToSMT :: Type -> Sort +typeToSMT (TyFun TyLitInt _) = SortInt -- TODO: Remove this +typeToSMT (TyFun TyLitDouble _) = SortDouble -- TODO: Remove this +typeToSMT (TyFun TyLitFloat _) = SortFloat -- TODO: Remove this +typeToSMT TyLitInt = SortInt +typeToSMT TyLitDouble = SortDouble +typeToSMT TyLitFloat = SortFloat +typeToSMT TyLitChar = SortChar +typeToSMT (TyCon (Name "Bool" _ _ _) _) = SortBool +typeToSMT (TyForAll (AnonTyBndr _) t) = typeToSMT t +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) + +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) + +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) + +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 + +toSolverAST con (Ite x y z) = + ite con (toSolverAST con x) (toSolverAST con y) (toSolverAST con z) + +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 + +toSolverVarDecl :: SMTConverter con ast out io => con -> SMTName -> Sort -> out +toSolverVarDecl con n s = varDecl con n (sortName con s) + +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 + +toSolverSetLogic :: SMTConverter con ast out io => con -> Logic -> out +toSolverSetLogic = setLogic + +-- | 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." + +-- | Converts a `Sort` to an `Type`. +sortToType :: Sort -> Type +sortToType (SortInt) = TyLitInt +sortToType (SortFloat) = TyLitFloat +sortToType (SortDouble) = TyLitDouble +sortToType (SortChar) = TyLitChar +sortToType (SortBool) = TyCon (Name "Bool" Nothing 0 Nothing) TYPE + +-- | Coverts an `SMTModel` to a `Model`. +modelAsExpr :: SMTModel -> Model +modelAsExpr = M.mapKeys strToName . M.map smtastToExpr diff --git a/src/G2/Solver/Interface.hs b/src/G2/Solver/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/Interface.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module G2.Solver.Interface + ( subModel + , subVar + , subVarFuncCall + , SMTConverter (..) + , Solver (..) + ) where + +import G2.Execution.NormalForms +import G2.Language +import qualified G2.Language.ExprEnv as E +import G2.Solver.Converters +import G2.Solver.Solver + +import Data.Maybe (mapMaybe) +import qualified Data.Map as M + +subModel :: State t -> Bindings -> ([Expr], Expr, Maybe FuncCall) +subModel (State { expr_env = eenv + , curr_expr = CurrExpr _ cexpr + , assert_ids = ais + , type_classes = tc + , model = m}) + (Bindings {input_names = inputNames}) = + let + ais' = fmap (subVarFuncCall m eenv tc) ais + + -- We do not inline 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 + 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') + +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} + +subVar :: (ASTContainer m Expr) => Model -> ExprEnv -> TypeClasses -> m -> m +subVar em eenv tc = modifyContainedASTs (subVar' em eenv tc []) . filterTC tc + +subVar' :: Model -> ExprEnv -> TypeClasses -> [Id] -> Expr -> Expr +subVar' 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 + | 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 + | otherwise = v +subVar' em eenv tc is e = modifyChildren (subVar' em eenv tc is) e + +notLam :: Expr -> Bool +notLam (Lam _ _ _) = False +notLam _ = True + +isApp :: Expr -> Bool +isApp (App _ _) = True +isApp _ = False + +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 + +isTC :: TypeClasses -> Expr -> Bool +isTC tc (Var (Id _ (TyCon n _))) = isTypeClassNamed n tc +isTC _ _ = False diff --git a/src/G2/Solver/Language.hs b/src/G2/Solver/Language.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/Language.hs @@ -0,0 +1,150 @@ +-- | Language +-- Provides a language definition designed to closely resemble the SMTLIB2 language. + +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module G2.Solver.Language + ( module G2.Solver.Language + , module G2.Language.AST + , Result (..)) where + +import G2.Language.AST +import G2.Solver.Solver + +import qualified Data.Map as M + +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 + | SetLogic Logic + deriving (Show, Eq) + +-- | 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) + +-- | 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 + + | (:&&) SMTAST SMTAST + | (:||) SMTAST 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 + + | StrLen SMTAST + + | Ite SMTAST SMTAST SMTAST + | SLet (SMTName, SMTAST) SMTAST + + | VInt Integer + | VFloat Rational + | VDouble Rational + | VChar Char + | VBool Bool + + | V SMTName Sort + + | ItoR SMTAST -- ^ Integer to real conversion + deriving (Show, Eq) + +-- | Every `SMTAST` has a `Sort` +data Sort = SortInt + | SortFloat + | SortDouble + | SortChar + | SortBool + deriving (Show, Eq) + +isSat :: Result -> Bool +isSat SAT = True +isSat _ = False + +type SMTModel = M.Map SMTName SMTAST + +instance AST SMTAST where + children (x :>= y) = [x, y] + children (x :> y) = [x, y] + children (x := y) = [x, y] + children (x :/= y) = [x, y] + children (x :< y) = [x, y] + children (x :<= y) = [x, y] + + children (x :&& y) = [x, y] + children (x :|| y) = [x, y] + children ((:!) x) = [x] + children (x :=> y) = [x, y] + children (x :<=> y) = [x, y] + + children (x :+ y) = [x, y] + children (x :- y) = [x, y] + children (x :* y) = [x, y] + children (x :/ y) = [x, y] + children (Neg x) = [x] + + children (Ite x x' x'') = [x, x', x''] + children (SLet (_, x) x') = [x, x'] + + children _ = [] + + 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 (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 ((:!) x) = (:!) (f x) + 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 (x :/ y) = f x :/ f y + modifyChildren f (Neg x) = Neg (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') + + modifyChildren _ e = e + +instance AST Sort where + children _ = [] + + modifyChildren _ s = s + +instance ASTContainer SMTHeader SMTAST where + containedASTs (Assert a) = [a] + containedASTs _ = [] + + modifyContainedASTs f (Assert a) = Assert (f a) + modifyContainedASTs _ s = s + +instance ASTContainer SMTAST Sort where + containedASTs (V _ s) = [s] + containedASTs x = eval containedASTs x + + modifyContainedASTs f (V n s) = V n (modify f s) + modifyContainedASTs f x = modify (modifyContainedASTs f) x + diff --git a/src/G2/Solver/ParseSMT.hs b/src/G2/Solver/ParseSMT.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/ParseSMT.hs @@ -0,0 +1,179 @@ +module G2.Solver.ParseSMT + ( parseSMT + , parseGetValues) where + +import G2.Solver.Language + +import Data.Char +import Data.Ratio +import Numeric + +import Text.Parsec (Parsec) +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as Token + +-- This is not complete! It currently only covers the small amount of the SMT +-- language needed to parse models + +smtDef :: LanguageDef st +smtDef = + emptyDef { Token.commentStart = "" + , Token.commentEnd = "" + , Token.commentLine = ";" + , Token.nestedComments = False + , Token.identStart = letter <|> oneOf ident + , Token.identLetter = alphaNum <|> oneOf ident + , Token.reservedNames = ["as", "let", "-", "/", "\""]} + +ident :: [Char] +ident = ['~', '!', '$', '@', '%', '^', '&', '*' , '_', '-', '+', '=', '<', '>', '.', '?', '/'] + +smtLexer :: Token.TokenParser st +smtLexer = Token.makeTokenParser smtDef + +identifier :: Parsec String st String +identifier = Token.identifier smtLexer + +reserved :: String -> Parsec String st () +reserved = Token.reserved smtLexer + +integer :: Parsec String st Integer +integer = Token.integer smtLexer + +floatT :: Parsec String st Double +floatT = try (Token.float smtLexer) + +flexFloatT :: Parsec String st Double +flexFloatT = try (Token.float smtLexer) <|> return . fromInteger =<< integer + +whiteSpace :: Parsec String st () +whiteSpace = Token.whiteSpace smtLexer + +parens :: Parsec String st a -> Parsec String st a +parens = Token.parens smtLexer + +smtParser :: Parser SMTAST +smtParser = whiteSpace >> sExpr + +getValuesParser :: Parser SMTAST +getValuesParser = parens (parens (identifier >> sExpr)) + +sExpr :: Parser SMTAST +sExpr = try boolExpr <|> parens sExpr <|> letExpr <|> try doubleFloatExpr + <|> try doubleFloatExprDec <|> stringExpr <|> intExpr + +letExpr :: Parser SMTAST +letExpr = do + reserved "let" + bEx <- parens (parens identExprTuple) + ex <- sExpr + return $ SLet bEx ex + +identExprTuple :: Parser (SMTName, SMTAST) +identExprTuple = do + bind <- identifier + ex <- sExpr + return (bind, ex) + +boolExpr :: Parser SMTAST +boolExpr = do + n <- parensConsName <|> identifier + case n of + "true" -> return (VBool True) + "false" -> return (VBool False) + _ -> error $ "Bad bool expr" + +parensConsName :: Parsec String st String +parensConsName = parens parensConsName <|> consName + +consName :: Parsec String st String +consName = do + reserved "as" + ex <- identifier + _ <- parens (many1 identifier) + return ex + +intExpr :: Parser SMTAST +intExpr = do + s <- optionMaybe (reserved "-") + i <- return . fromIntegral =<< integer + case s of + Just _ -> return (VInt (-i)) + Nothing -> return (VInt i) + +doubleFloatExpr :: Parser SMTAST +doubleFloatExpr = doubleFloatExprNeg <|> doubleFloatExprRat + +doubleFloatExprNeg :: Parser SMTAST +doubleFloatExprNeg = do + _ <- reserved "-" + (VDouble r) <- parens doubleFloatExprRat + return (VDouble (-r)) + +doubleFloatExprRat :: Parser SMTAST +doubleFloatExprRat = do + s <- optionMaybe (reserved "/") + f <- flexDoubleFloat + f' <- flexDoubleFloat + let r = approxRational (f / f') (0.000001) + case s of + Just _ -> return (VDouble r) + Nothing -> return (VDouble r) + +doubleFloatExprDec :: Parser SMTAST +doubleFloatExprDec = do + r <- doubleFloat + _ <- optionMaybe (reserved "?") + return (VDouble r) + +doubleFloat :: Parser Rational +doubleFloat = do + s <- optionMaybe (reserved "-") + f <- floatT + let r = approxRational f (0.00001) + case s of + Just _ -> return (-r) + Nothing -> return r + +flexDoubleFloat :: Parser Rational +flexDoubleFloat = do + s <- optionMaybe (reserved "-") + f <- flexFloatT + let r = approxRational f (0.00001) + case s of + Just _ -> return (-r) + Nothing -> return r + +stringExpr :: Parser SMTAST +stringExpr = do + _ <- char '"' + str <- stringExpr' + _ <- char '"' + return (VChar str) + +stringExpr' :: Parser Char +stringExpr' = do + try parseHex <|> choice (alphaNum: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" + +parseSMT :: String -> SMTAST +parseSMT s = case parse smtParser s s of + Left e -> error $ "get model parser error on " ++ show e + Right r -> r + +-- | parseGetValues +-- Parse the result of a get-values call +parseGetValues :: String -> SMTAST +parseGetValues s = + case parse getValuesParser s s of + Left e -> error $ "get values parser error on " ++ show e + Right r -> r diff --git a/src/G2/Solver/SMT2.hs b/src/G2/Solver/SMT2.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/SMT2.hs @@ -0,0 +1,470 @@ +-- | This defines an SMTConverter for the SMT2 language +-- It provides methods to construct formulas, as well as feed them to an external solver + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module G2.Solver.SMT2 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.Map as M +import Data.Ratio +import System.IO +import System.Process + +data Z3 = Z3 ArbValueFunc (Handle, Handle, ProcessHandle) +data CVC4 = CVC4 ArbValueFunc (Handle, Handle, ProcessHandle) + +data SomeSMTSolver where + SomeSMTSolver :: forall con ast out io + . SMTConverter con ast out io => con -> SomeSMTSolver + +instance Solver Z3 where + check solver _ pc = checkConstraints solver pc + solve con@(Z3 avf _) = checkModel avf con + close = closeIO + +instance Solver CVC4 where + check solver _ pc = checkConstraints solver pc + solve con@(CVC4 avf _) = checkModel 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)" + + empty _ = "" + merge _ = (++) + + checkSat _ (h_in, h_out, _) formula = do + -- putStrLn "checkSat" + -- putStrLn formula + + setUpFormulaZ3 h_in formula + r <- checkSat' h_in h_out + + -- putStrLn $ show r + + return r + + checkSatGetModel _ (h_in, h_out, _) formula _ vs = do + setUpFormulaZ3 h_in formula + -- putStrLn "\n\n checkSatGetModel" + -- putStrLn 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) + + checkSatGetModelGetExpr con (h_in, h_out, _) formula _ vs eenv (CurrExpr _ e) = do + setUpFormulaZ3 h_in formula + -- putStrLn "\n\n checkSatGetModelGetExpr" + -- putStrLn 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 formula + -- putStrLn "" + -- 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) + 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 + +instance SMTConverter CVC4 String String (Handle, Handle, ProcessHandle) where + getIO (CVC4 _ hhp) = hhp + closeIO (CVC4 _ (h_in, _, _)) = hPutStr h_in "(exit)" + + empty _ = "" + merge _ = (++) + + checkSat _ (h_in, h_out, _) formula = do + -- putStrLn "checkSat" + -- putStrLn formula + + setUpFormulaCVC4 h_in formula + r <- checkSat' h_in h_out + + -- putStrLn $ show r + + return r + + checkSatGetModel _ (h_in, h_out, _) formula _ vs = do + setUpFormulaCVC4 h_in 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) + + checkSatGetModelGetExpr con (h_in, h_out, _) formula _ vs eenv (CurrExpr _ e) = do + setUpFormulaCVC4 h_in formula + -- putStrLn "\n\n checkSatGetModelGetExpr" + -- 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 formula + -- putStrLn "" + -- 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) + 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 ++ ")" + +function2 :: String -> String -> String -> String +function2 f a b = "(" ++ f ++ " " ++ a ++ " " ++ b ++ ")" + +function3 :: String -> String -> String -> String -> String +function3 f a b c = "(" ++ f ++ " " ++ a ++ " " ++ b ++ " " ++ c ++ ")" + +-- | getProcessHandles +-- Ideally, this function should be called only once, and the same Handles should be used +-- in all future calls +getProcessHandles :: CreateProcess -> IO (Handle, Handle, ProcessHandle) +getProcessHandles pr = do + (m_h_in, m_h_out, h_err, p) <- createProcess (pr) + { std_in = CreatePipe, std_out = CreatePipe } + + case h_err of + Just h_err' -> hClose h_err' + Nothing -> return () + + let (h_in, h_out) = + case (m_h_in, m_h_out) of + (Just i, Just o) -> (i, o) + _ -> error "Pipes to shell not successfully created." + + hSetBuffering h_in LineBuffering + + return (h_in, h_out, p) + +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 + hPutStr h_in "(set-option :pp.decimal true)" + return $ SomeSMTSolver (Z3 avf hhp) +getSMTAV avf (Config {smt = ConCVC4}) = do + hhp <- getCVC4ProcessHandles + return $ SomeSMTSolver (CVC4 avf hhp) + +-- | getZ3ProcessHandles +-- This calls Z3, and get's it running in command line mode. Then you can read/write on the +-- 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"] + +getCVC4ProcessHandles :: IO (Handle, Handle, ProcessHandle) +getCVC4ProcessHandles = getProcessHandles $ proc "cvc4" ["--lang", "smt2.6", "--produce-models"] + +-- | setUpFormulaZ3 +-- Writes a function to Z3 +setUpFormulaZ3 :: Handle -> String -> IO () +setUpFormulaZ3 h_in form = do + hPutStr h_in "(reset)" + hPutStr h_in form + +setUpFormulaCVC4 :: Handle -> String -> IO () +setUpFormulaCVC4 h_in form = do + hPutStr h_in "(reset)" + -- hPutStr h_in "(set-logic ALL)\n" + hPutStr h_in form + +-- Checks if a formula, previously written by setUp formula, is SAT +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) + + if out == "sat" then + return SAT + else if out == "unsat" then + return UNSAT + else + return (Unknown out) + else do + return (Unknown "") + +parseModel :: [(SMTName, String, Sort)] -> SMTModel +parseModel = foldr (\(n, s) -> M.insert n s) M.empty + . map (\(n, str, s) -> (n, parseToSMTAST str s)) + +parseToSMTAST :: String -> Sort -> SMTAST +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 _ a = a + +getModelZ3 :: Handle -> Handle -> [(SMTName, Sort)] -> IO [(SMTName, String, Sort)] +getModelZ3 h_in h_out ns = do + hPutStr h_in "(set-option :model_evaluator.completion true)\n" + getModel' ns + where + getModel' :: [(SMTName, Sort)] -> IO [(SMTName, String, Sort)] + getModel' [] = return [] + getModel' ((n, s):nss) = do + hPutStr h_in ("(get-value (" ++ n ++ "))\n") -- hPutStr h_in ("(eval " ++ n ++ " :completion)\n") + out <- getLinesMatchParens h_out + _ <- evaluate (length out) --Forces reading/avoids problems caused by laziness + + return . (:) (n, out, s) =<< getModel' nss + +getModelCVC4 :: Handle -> Handle -> [(SMTName, Sort)] -> IO [(SMTName, String, Sort)] +getModelCVC4 h_in h_out ns = do + getModel' ns + where + getModel' :: [(SMTName, Sort)] -> IO [(SMTName, String, Sort)] + getModel' [] = return [] + getModel' ((n, s):nss) = do + hPutStr h_in ("(get-value (" ++ n ++ "))\n") + out <- getLinesMatchParens h_out + _ <- evaluate (length out) --Forces reading/avoids problems caused by laziness + + return . (:) (n, out, s) =<< getModel' nss + +getLinesMatchParens :: Handle -> IO String +getLinesMatchParens h_out = getLinesMatchParens' h_out 0 + +getLinesMatchParens' :: Handle -> Int -> IO String +getLinesMatchParens' h_out n = do + out <- hGetLine h_out + _ <- evaluate (length out) + + let open = countElem '(' out + let clse = countElem ')' out + let n' = n + open - clse + + if n' == 0 then + return out + 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) diff --git a/src/G2/Solver/Solver.hs b/src/G2/Solver/Solver.hs new file mode 100644 --- /dev/null +++ b/src/G2/Solver/Solver.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +module G2.Solver.Solver ( Solver (..) + , TrSolver (..) + , Tr (..) + , SomeSolver (..) + , SomeTrSolver (..) + , Result (..) + , GroupRelated (..) + , groupRelatedFinite + , groupRelatedInfinite + , CombineSolvers (..) + , UndefinedHigherOrder (..)) where + +import G2.Language +import qualified G2.Language.PathConds as PC +import Data.List +import qualified Data.Map as M + +-- | The result of a Solver query +data Result = SAT + | UNSAT + | Unknown String + 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 + + -- | 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) + + -- | Cleans up when the solver is no longer needed. Default implementation + -- does nothing + close :: solver -> IO () + close _ = return () + +-- | Defines an interface to interact with Tracking Solvers- +-- solvers that can track some sort of state. +-- Every solver is also a tracking solver, so this is the more general type. +-- Typically, all functions should be written using TrSolver, rather than Solver. +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) + + -- | 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) + + -- | Cleans up when the solver is no longer needed. Default implementation + -- does nothing + closeTr :: solver -> IO () + closeTr _ = return () + +-- | A wrapper to turn something that is a Solver into a TrSolver +newtype Tr solver = Tr { unTr :: solver } + +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 + closeTr = close . unTr + +data SomeSolver where + SomeSolver :: forall solver + . Solver solver => solver -> SomeSolver + +data SomeTrSolver where + SomeTrSolver :: forall solver + . TrSolver solver => solver -> SomeTrSolver + +-- | Splits path constraints before sending them to the rest of the solvers +data GroupRelated a = GroupRelated ArbValueFunc a + +groupRelatedFinite :: a -> GroupRelated a +groupRelatedFinite = GroupRelated arbValue + +groupRelatedInfinite :: a -> GroupRelated a +groupRelatedInfinite = GroupRelated arbValueInfinite + +checkRelated :: TrSolver a => a -> State t -> PathConds -> IO (Result, a) +checkRelated solver s pc = + checkRelated' solver s $ PC.relatedSets (known_values s) pc + +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 + r -> return (r, sol') + +solveRelated :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> [Id] -> PathConds -> IO (Result, Maybe 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' :: TrSolver a => ArbValueFunc -> a -> State t -> Bindings -> Model -> [Id] -> [PathConds] -> IO (Result, Maybe Model, a) +solveRelated' avf sol s b m is [] = + let + is' = filter (\i -> idName i `M.notMember` m) is + + (_, nv) = mapAccumL + (\av_ (Id n t) -> + let + (av_', v) = avf t (type_env s) av_ + in + (v, (n, av_')) + ) (arb_value_gen b) is' + + m' = foldr (\(n, v) -> M.insert n v) m nv + in + return (SAT, Just 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'' = 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 + 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 + close (GroupRelated _ s) = close s + +instance TrSolver solver => TrSolver (GroupRelated solver) where + checkTr (GroupRelated avf sol) s pc = do + (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') + closeTr (GroupRelated _ s) = closeTr s + +-- | Allows solvers to be combined, to exploit different solvers abilities +-- to solve different kinds of constraints +data CombineSolvers a b = 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 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 + (rb, b') <- checkTr b s pc + case rb of + 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 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 + 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') + +-- | Fills in unused higher order functions with undefined +data UndefinedHigherOrder = UndefinedHigherOrder + +instance Solver UndefinedHigherOrder where + check _ s pc = + let + f = concatMap (PC.varIdsInPC (known_values s)) $ PC.toList pc + in + case f of + [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) + +instance (Solver a, Solver b) => Solver (CombineSolvers a b) where + check (a : b) s pc = return . fst =<< checkWithEither (Tr a) (Tr b) s pc + + solve (a : (r, m)) =<< 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 + + close (a : b) = do + close a + close b + +instance (TrSolver a, TrSolver b) => TrSolver (CombineSolvers a b) where + checkTr (a : a' -> return (r, a' : return (r, a' :?> b') + checkTr (a :?> b) s pc = checkWithEither a b s pc + + solveTr (a : a' -> return (r, m, a' : return (r, m, a' :?> b') + solveTr (a :?> b) s binds is pc = solveWithEither a b s binds is pc + + closeTr (a : b) = do + closeTr a + closeTr b diff --git a/src/G2/Translation.hs b/src/G2/Translation.hs new file mode 100644 --- /dev/null +++ b/src/G2/Translation.hs @@ -0,0 +1,16 @@ +-- | Translation +-- Export module for G2.Translation. +module G2.Translation + ( module G2.Translation.Haskell + , module G2.Translation.HaskellCheck + , module G2.Translation.Interface + , module G2.Translation.PrimInject + , module G2.Translation.TransTypes + ) where + +import G2.Translation.Haskell +import G2.Translation.HaskellCheck +import G2.Translation.PrimInject +import G2.Translation.Interface +import G2.Translation.TransTypes + diff --git a/src/G2/Translation/Cabal/Cabal.hs b/src/G2/Translation/Cabal/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/G2/Translation/Cabal/Cabal.hs @@ -0,0 +1,30 @@ +module G2.Translation.Cabal.Cabal (cabalSrcDirs) where + +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse +import Distribution.Verbosity + +-- | Takes the filepath to a Cabal file, and returns a list of FilePaths to red +-- from. +cabalSrcDirs :: FilePath -> IO [FilePath] +cabalSrcDirs fp = do + gpd <- readGenericPackageDescription silent fp + return $ genericPackageDescriptionSrcDirs gpd + +genericPackageDescriptionSrcDirs :: GenericPackageDescription -> [FilePath] +genericPackageDescriptionSrcDirs (GenericPackageDescription + { condLibrary = cl + , condExecutables = ce }) = do + maybe [] (condTreeSrcDirs libSrcDirs) cl ++ concatMap (condTreeSrcDirs execSrcDirs . snd) ce + +condTreeSrcDirs :: (a -> [FilePath]) -> CondTree v c a -> [FilePath] +condTreeSrcDirs f (CondNode { condTreeData = t }) = f t + +libSrcDirs :: Library -> [FilePath] +libSrcDirs = buildInfoSrcDirs . libBuildInfo + +execSrcDirs :: Executable -> [FilePath] +execSrcDirs = buildInfoSrcDirs . buildInfo + +buildInfoSrcDirs :: BuildInfo -> [FilePath] +buildInfoSrcDirs (BuildInfo { hsSourceDirs = sd }) = sd diff --git a/src/G2/Translation/Haskell.hs b/src/G2/Translation/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/G2/Translation/Haskell.hs @@ -0,0 +1,798 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Haskell Translation +module G2.Translation.Haskell + ( loadProj + , guessProj + , hskToG2ViaModGuts + , hskToG2ViaModGutsFromFile + , hskToG2ViaCgGuts + , hskToG2ViaCgGutsFromFile + , mkCgGutsClosure + , mkModDetailsClosure + , mergeExtractedG2s + , mkIOString + , prim_list + , mkRawCore + , rawDump + , mkExpr + , mkId + , mkIdUnsafe + , mkName + , mkTyConName + , mkData + , mkSpan + , mkRealSpan + , absVarLoc + , readFileExtractedG2 + , readAllExtractedG2s + , mergeFileExtractedG2s + , findCabal + ) where + +import qualified G2.Language.TypeEnv as G2 (AlgDataTy (..), ProgramType) +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 Control.Monad + +import qualified Data.Array as A +import qualified Data.ByteString.Char8 as C +import Data.Foldable +import Data.List +import Data.List.Split +import Data.Maybe +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import qualified Data.Text as T +import System.FilePath +import System.Directory + +-- Copying from Language.Typing so the thing we stuff into Ghc +-- does not have to rely on Language.Typing, which depends on other things. +mkG2TyApp :: [G2.Type] -> G2.Type +mkG2TyApp [] = G2.TYPE +mkG2TyApp (t:[]) = t +mkG2TyApp (t1:t2:ts) = mkG2TyApp (G2.TyApp t1 t2 : ts) + +mkG2TyCon :: G2.Name + -> [G2.Type] + -> G2.Kind + -> 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.Types2", "GHC.Types") + , ("GHC.Integer2", "GHC.Integer") + , ("GHC.Integer.Type2", "GHC.Integer.Type") + , ("GHC.Prim2", "GHC.Prim") + , ("GHC.Tuple2", "GHC.Tuple") + , ("GHC.Magic2", "GHC.Magic") + , ("GHC.CString2", "GHC.CString") + , ("Data.Map.Base", "Data.Map")] + + +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 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 + hscTarget = if rtsIsProfiled + then HscInterpreted + else case hsc of + Just hsc' -> hsc' + _ -> hscTarget beta_flags' + , 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} + + _ <- setSessionDynFlags dflags + targets <- mapM (flip guessTarget Nothing) src + _ <- setTargets targets + load LoadAllTargets + + + +-- Compilation pipeline with CgGuts +hskToG2ViaCgGutsFromFile :: Maybe HscTarget + -> [FilePath] + -> [FilePath] + -> G2.NameMap + -> G2.TypeNameMap + -> 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 + + +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) + + +cgGutsModDetailsClosureToModGutsClosure :: G2.CgGutsClosure -> G2.ModDetailsClosure -> G2.ModGutsClosure +cgGutsModDetailsClosureToModGutsClosure cg md = + G2.ModGutsClosure + { G2.mgcc_mod_name = G2.cgcc_mod_name cg + , G2.mgcc_binds = G2.cgcc_binds cg + , G2.mgcc_tycons = G2.cgcc_tycons cg + , G2.mgcc_breaks = G2.cgcc_breaks cg + , G2.mgcc_cls_insts = G2.mdcc_cls_insts md + , G2.mgcc_type_env = G2.mdcc_type_env md + , G2.mgcc_exports = G2.mdcc_exports md + , G2.mgcc_deps = G2.mdcc_deps md + , G2.mgcc_rules = G2.cgcc_rules cg + } + + +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 + _ <- loadProj hsc proj src [] tr_con + env <- getSession + + mod_graph <- getModuleGraph + parsed_mods <- mapM parseModule mod_graph + typed_mods <- mapM typecheckModule parsed_mods + desug_mods <- mapM desugarModule typed_mods + return (env, map coreModule desug_mods) + + 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 + return pairs + +-- | 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 = + 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 } + + +mkModDetailsClosure :: Dependencies -> ModDetails -> G2.ModDetailsClosure +mkModDetailsClosure deps moddet = + G2.ModDetailsClosure + { G2.mdcc_cls_insts = md_insts moddet + , G2.mdcc_type_env = md_types moddet + , G2.mdcc_exports = exportedNames moddet + , G2.mdcc_deps = map (moduleNameString . fst) $ dep_mods deps + } + + + +-- Compilation pipeline with ModGuts +hskToG2ViaModGutsFromFile :: Maybe HscTarget + -> [FilePath] + -> [FilePath] + -> G2.NameMap + -> G2.TypeNameMap + -> G2.TranslationConfig + -> 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 + + +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) + + + + +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 + -- 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 + -- 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 + -- Do the class + let classes = map (mkClass tm2) $ G2.mgcc_cls_insts mgcc in + + -- Do the rules + let rules = if G2.load_rewrite_rules tr_con + then mapMaybe (mkRewriteRule nm3 tm2 breaks) $ G2.mgcc_rules mgcc + else [] in + + -- 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 }) + + +mkModGutsClosuresFromFile :: Maybe HscTarget + -> [FilePath] + -> [FilePath] + -> G2.TranslationConfig + -> IO [G2.ModGutsClosure] +mkModGutsClosuresFromFile hsc proj src tr_con = do + (env, modgutss) <- runGhc (Just libdir) $ do + _ <- loadProj hsc proj src [] tr_con + env <- getSession + + mod_graph <- getModuleGraph + parsed_mods <- mapM parseModule mod_graph + 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 + else do + closures <- mapM (mkModGutsClosure env) modgutss + return closures + +-- This one will need to do the Tidy program stuff +mkModGutsClosure :: HscEnv -> ModGuts -> IO G2.ModGutsClosure +mkModGutsClosure env modguts = do + (cgguts, moddets) <- tidyProgram env modguts + 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_type_env = md_types moddets + , G2.mgcc_exports = exportedNames moddets + , G2.mgcc_deps = map (moduleNameString . fst) $ dep_mods $ mg_deps modguts + , G2.mgcc_rules = mg_rules modguts + } + + +-- Merging, order matters! +mergeExtractedG2s :: [G2.ExtractedG2] -> G2.ExtractedG2 +mergeExtractedG2s [] = G2.emptyExtractedG2 +mergeExtractedG2s (g2:g2s) = + 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_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' + , G2.exg2_rules = G2.exg2_rules g2 ++ G2.exg2_rules g2' } + +---------------- +-- 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 + +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) = + 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) + +createTickish :: Maybe ModBreaks -> Tickish i -> Maybe G2.Tickish +createTickish (Just mb) (Breakpoint {breakpointId = bid}) = + case mkSpan $ modBreaks_locs mb A.! bid of + Just s -> Just $ G2.Breakpoint $ s + Nothing -> Nothing +createTickish _ _ = Nothing + +mkLamUse :: Id -> G2.LamUse +mkLamUse v + | 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 + +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) + + nm' = HM.insert (n', m) n nm + in + (i, nm') + +mkName :: Name -> G2.Name +mkName name = G2.Name occ mdl unq sp + where + occ = T.pack . occNameString . nameOccName $ name + unq = (getKey . nameUnique) name + mdl = case nameModule_maybe name of + Nothing -> Nothing + Just md -> switchModule (T.pack . moduleNameString . moduleName $ md) + + sp = mkSpan $ getSrcSpan name + +mkNameLookup :: Name -> G2.NameMap -> G2.Name +mkNameLookup name nm = + -- 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 + where + occ = T.pack . occNameString . nameOccName $ name + unq = getKey . nameUnique $ name + mdl = case nameModule_maybe name of + Nothing -> Nothing + Just md -> switchModule (T.pack . moduleNameString . moduleName $ md) + + sp = mkSpan $ getSrcSpan name + +mkSpan :: SrcSpan -> Maybe G2.Span +mkSpan (RealSrcSpan s) = Just $ mkRealSpan s +mkSpan _ = Nothing + +mkRealSpan :: RealSrcSpan -> G2.Span +mkRealSpan s = + let + st = mkRealLoc $ realSrcSpanStart s + en = mkRealLoc $ realSrcSpanEnd s + in + G2.Span { G2.start = st + , G2.end = en} + +mkRealLoc :: RealSrcLoc -> G2.Loc +mkRealLoc l = + G2.Loc { G2.line = srcLocLine l + , G2.col = srcLocCol l + , G2.file = unpackFS $ srcLocFile l} + +switchModule :: T.Text -> Maybe T.Text +switchModule m = + case HM.lookup m equivMods of + Just m'' -> Just m'' + Nothing -> Just m + +mkLit :: Literal -> G2.Lit +mkLit (MachChar chr) = G2.LitChar chr +mkLit (MachStr bstr) = G2.LitString (C.unpack bstr) +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 (MachFloat rat) = G2.LitFloat rat +mkLit (MachDouble rat) = G2.LitDouble rat +mkLit (LitInteger i _) = G2.LitInteger (fromInteger i) +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 + +mkAlts :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> [CoreAlt] -> [G2.Alt] +mkAlts nm tm mb = map (mkAlt nm tm 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) + +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 + +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) + | isFunTyCon tc + , length ts == 2 = + case ts of + (t1:t2:[]) -> G2.TyFun (mkType tm t1) (mkType tm 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) + +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 + + nm' = foldr (uncurry HM.insert) nm + $ map (\n_@(G2.Name n'_ m_ _ _) -> ((n'_, m_), n_)) + $ map (flip mkNameLookup nm . dataConName) $ visibleDataCons (algTyConRhs t) + + bv = map (mkId tm) $ tyConTyVars t + + (nm'', tm'', dcs, dcsf) = + 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) + 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]) + 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) + 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 [] + +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 + +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 + +mkDataName :: G2.NameMap -> DataCon -> G2.Name +mkDataName nm datacon = (flip mkNameLookup nm . dataConName) datacon + +mkTyBinder :: G2.TypeNameMap -> TyVarBinder -> G2.TyBinder +mkTyBinder tm (TvBndr v _) = G2.NamedTyBndr (mkId tm v) + +prim_list :: [String] +prim_list = [">=", ">", "==", "/=", "<=", "<", + "&&", "||", "not", + "+", "-", "*", "/", "implies", "negate", "error", "iff" ] + + +mkCoercion :: G2.TypeNameMap -> Coercion -> G2.Coercion +mkCoercion tm c = + let + k = fmap (mkType tm) $ coercionKind c + in + (pFst k) G2.:~ (pSnd k) + +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) + + +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 + +exportedNames :: ModDetails -> [G2.ExportedName] +exportedNames = concatMap availInfoNames . md_exports + +availInfoNames :: AvailInfo -> [G2.ExportedName] +availInfoNames (Avail n) = [mkName n] +availInfoNames (AvailTC n ns _) = mkName n:map mkName ns + +-- | 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' :: 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 +absVarLoc' (G2.App e1 e2) = do + e1' <- absVarLoc' e1 + e2' <- absVarLoc' e2 + return $ G2.App e1' e2' +absVarLoc' (G2.Lam u i e) = return . G2.Lam u i =<< absVarLoc' e +absVarLoc' (G2.Let b e) = do + b' <- mapM (\(i, be) -> do + be' <- absVarLoc' be + return (i, be') + ) b + e' <- absVarLoc' e + return $ G2.Let b' e' +absVarLoc' (G2.Case e i as) = do + e' <- absVarLoc' e + as' <- mapM (\(G2.Alt a ae) -> return . G2.Alt a =<< absVarLoc' ae) as + return $ G2.Case e' i as' +absVarLoc' (G2.Cast e c) = do + e' <- absVarLoc' e + return $ G2.Cast e' c +absVarLoc' (G2.Tick (G2.Breakpoint s) e) = do + s' <- absLocSpan s + let t' = G2.Breakpoint s' + + e' <- absVarLoc' e + return $ G2.Tick t' e' +absVarLoc' (G2.Assume fc e1 e2) = do + e1' <- absVarLoc' e1 + e2' <- absVarLoc' e2 + return $ G2.Assume fc e1' e2' +absVarLoc' (G2.Assert fc e1 e2) = do + e1' <- absVarLoc' e1 + e2' <- absVarLoc' e2 + return $ G2.Assert fc e1' e2' +absVarLoc' e = return e + +absLocSpan :: G2.Span -> IO G2.Span +absLocSpan s@G2.Span {G2.start = st, G2.end = en} = do + st' <- absLoc st + en' <- absLoc en + return $ s {G2.start = st', G2.end = en'} + +absLoc :: G2.Loc -> IO G2.Loc +absLoc l@G2.Loc {G2.file = f} = do + f' <- makeAbsolute f + return $ l {G2.file = f'} + + +-- When we don't want the + + +-- Loading stuff +readFileExtractedG2 :: FilePath -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) +readFileExtractedG2 file = do + contents <- readFile file + return $ read contents + +readAllExtractedG2s :: FilePath -> FilePath -> IO [(G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)] +readAllExtractedG2s root file = go [file] HS.empty [] + where + go :: [FilePath] + -> HS.HashSet FilePath + -> [(G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)] + -> IO [(G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)] + go [] _ accum = return accum + go (tgt : todos) visited accum = + let absPath = root ++ "/" ++ tgt in + if HS.member absPath visited then + go todos visited accum + else do + (nameMap, tyNameMap, exg2) <- readFileExtractedG2 absPath + -- Dependencies are relative paths + let deps = map (\d -> (T.unpack d) ++ ".g2i") $ G2.exg2_deps exg2 + + let todos' = todos ++ deps + let visited' = HS.insert absPath visited + let accum' = accum ++ [(nameMap, tyNameMap, exg2)] + go todos' visited' accum' + + +-- Merge nm2 into nm1 +rewriteNameMap :: (T.Text, Maybe T.Text) -> G2.Name -> G2.NameMap -> G2.NameMap +rewriteNameMap key val@(G2.Name occ md _ _) nameMap = + case HM.lookup (occ, md) nameMap of + Nothing -> HM.insert key val nameMap + Just new -> HM.insert key new nameMap + +mergeNameMap :: G2.NameMap -> G2.NameMap -> G2.NameMap +mergeNameMap nm1 = foldr (\(key, name) nm1' -> rewriteNameMap key name nm1') nm1 . HM.toList + + +-- Favors earlier in the list +mergeFileExtractedG2s :: [(G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)] + -> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) +mergeFileExtractedG2s [] = (HM.empty, HM.empty, G2.emptyExtractedG2) +mergeFileExtractedG2s (ex : []) = ex +mergeFileExtractedG2s ((nm1, tnm1, ex1) : (nm2, tnm2, ex2) : exs) = + let nm' = mergeNameMap nm1 nm2 in + let tnm' = mergeNameMap tnm1 tnm2 in + let ex' = mergeExtractedG2s [ex1, ex2] in + mergeFileExtractedG2s $ (nm', tnm', ex') : exs + +-- Look for the directory that contains the first instance of a *.cabal file +guessProj :: FilePath -> IO FilePath +guessProj tgt = do + absTgt <- makeAbsolute tgt + let splits = splitOn "/" absTgt + potentialDirs <- filterM (dirContainsCabal) + $ reverse -- since we prefer looking in backtrack manner + $ map (intercalate "/") + $ inits splits + + case potentialDirs of + (d : _) -> return d + -- Unable to find a .cabal file at all, so we take the first one + -- with the file loped off. + [] -> return $ takeDirectory absTgt + +dirContainsCabal :: FilePath -> IO Bool +dirContainsCabal dir = do + exists <- doesDirectoryExist dir + if exists then do + files <- listDirectory dir + return $ any (\f -> ".cabal" `isSuffixOf` f) files + else + return $ False + +findCabal :: FilePath -> IO (Maybe FilePath) +findCabal fp = do + dir <- guessProj fp + files <- listDirectory dir + return $ find (\f -> ".cabal" `isSuffixOf` f) files diff --git a/src/G2/Translation/HaskellCheck.hs b/src/G2/Translation/HaskellCheck.hs new file mode 100644 --- /dev/null +++ b/src/G2/Translation/HaskellCheck.hs @@ -0,0 +1,118 @@ +module G2.Translation.HaskellCheck ( validateStates + , runHPC) where + +import DynFlags +import GHC hiding (Name) +import GHC.Paths + +import Data.Either +import Data.List +import qualified Data.Text as T +import Text.Regex +import Unsafe.Coerce + +import G2.Initialization.MkCurrExpr +import G2.Interface.OutputTypes +import G2.Language +import G2.Translation.Haskell +import G2.Translation.TransTypes +import G2.Lib.Printers + +import Control.Exception + +import System.Process + +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 + +-- 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) + + v' <- unsafeCoerce v :: IO (Either SomeException Bool) + let outStr = mkCleanExprHaskell s out + let v'' = case v' of + Left _ -> outStr == "error" + Right b -> b && outStr /= "error" + + chAllR' <- 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 + _ <- loadProj Nothing proj src gflags simplTranslationConfig + + let prN = mkModuleName "Prelude" + let prImD = simpleImportDecl prN + + 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 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 + + chAllR <- mapM compileExpr chAllStr' + + return $ (v', chAllR) + +simpVar :: T.Text -> Expr +simpVar s = Var (Id (Name s Nothing 0 Nothing) TyBottom) + +runHPC :: FilePath -> String -> String -> [(State t, Bindings, [Expr], Expr, Maybe FuncCall)] -> IO () +runHPC src modN entry in_out = do + let calls = map (\(s, _, i, o, _) -> toCall entry s i o) in_out + + runHPC' src modN calls + +-- Compile with GHC, and check that the output we got is correct for the input +runHPC' :: FilePath -> String -> [String] -> IO () +runHPC' src modN ars = do + srcCode <- readFile src + let srcCode' = removeModule modN srcCode + + let spces = " " + + let chck = intercalate ("\n" ++ spces) $ map (\s -> "print (" ++ s ++ ")") ars + + let mainFunc = "\n\nmain :: IO ()\nmain =do\n" ++ spces ++ chck ++ "\n" ++ spces + + let mainN = "Main_" ++ modN + + writeFile (mainN ++ ".hs") (srcCode' ++ mainFunc) + + callProcess "ghc" ["-fhpc", mainN ++ ".hs"] + callProcess ("./" ++ mainN) [] + + callProcess "hpc" ["report", mainN] + + -- putStrLn mainFunc + +toCall :: String -> State t -> [Expr] -> Expr -> String +toCall entry s ars _ = mkCleanExprHaskell s $ mkApp ((simpVar $ T.pack entry):ars) + +removeModule :: String -> String -> String +removeModule modN s = + let + r = mkRegex $ "module " ++ modN ++ " where" + in + subRegex r s "" diff --git a/src/G2/Translation/InjectSpecials.hs b/src/G2/Translation/InjectSpecials.hs new file mode 100644 --- /dev/null +++ b/src/G2/Translation/InjectSpecials.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} + +module G2.Translation.InjectSpecials + ( specialTypes + , specialTypeNames + , specialConstructors + ) where + +import qualified Data.HashMap.Lazy as HM +import qualified Data.Text as T + +import G2.Language + +_MAX_TUPLE :: Int +_MAX_TUPLE = 62 + +specialTypes :: [ProgramType] +specialTypes = map (uncurry specialTypes') specials + +specialTypes' :: (T.Text, Maybe T.Text, [Name]) -> [(T.Text, Maybe T.Text, [Type])] -> (Name, AlgDataTy) +specialTypes' (n, m, ns) dcn = + let + tn = Name n m 0 Nothing + dc = map (specialDC ns tn) dcn + in + (tn, DataTyCon {bound_ids = map (flip Id TYPE) ns, data_cons = dc}) + +specialDC :: [Name] -> Name -> (T.Text, Maybe T.Text, [Type]) -> DataCon +specialDC ns tn (n, m, ts) = + let + 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 + 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' + +specialConstructors :: HM.HashMap (T.Text, Maybe T.Text) Name +specialConstructors = + HM.fromList $ map (\nm@(n, m) -> (nm, Name n m 0 Nothing)) specialConstructors' + +specialTypeNames' :: [(T.Text, Maybe T.Text, [Name])] +specialTypeNames' = map fst specials + +specialConstructors' :: [(T.Text, Maybe T.Text)] +specialConstructors' = map (\(n, m, _) -> (n, m)) $ concatMap snd specials + +aName :: Name +aName = Name "a" Nothing 0 Nothing + +aTyVar :: Type +aTyVar = TyVar (Id aName TYPE) + +listName :: Name +listName = Name "[]" (Just "GHC.Types") 0 Nothing + +specials :: [((T.Text, Maybe T.Text, [Name]), [(T.Text, Maybe T.Text, [Type])])] +specials = [ (( "[]" + , 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", [])]) + + -- , (("Ordering", Just "GHC.Types"), [ ("EQ", Just "GHC.Types", []) + -- , ("LT", Just "GHC.Types", []) + -- , ("GT", Just "GHC.Types", [])]) + ] + ++ + mkTuples "(" ")" (Just "GHC.Tuple") _MAX_TUPLE + ++ + 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])])] +mkTuples ls rs m n | n < 0 = [] + | otherwise = + let + s = ls `T.append` T.pack (replicate n ',') `T.append` rs + + ns = if n == 0 then [] else map (\i -> Name "a" m i Nothing) [0..n] + tv = map (TyVar . flip Id TYPE) ns + in + -- ((s, m, []), [(s, m, [])]) : mkTuples (n - 1) + ((s, m, ns), [(s, m, tv)]) : mkTuples ls rs m (n - 1) diff --git a/src/G2/Translation/Interface.hs b/src/G2/Translation/Interface.hs new file mode 100644 --- /dev/null +++ b/src/G2/Translation/Interface.hs @@ -0,0 +1,138 @@ +module G2.Translation.Interface ( translateLoaded + , translateLoadedD ) where + +import DynFlags + +import Data.List +import Data.Maybe +import qualified Data.Text as T + +import G2.Config +import G2.Language +import G2.Translation.Haskell +import G2.Translation.InjectSpecials +import G2.Translation.PrimInject +import G2.Translation.TransTypes + + +translateBase :: TranslationConfig + -> Config + -> Maybe HscTarget + -> IO (ExtractedG2, NameMap, TypeNameMap) +translateBase tr_con config 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 + + +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 + + +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 + (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 + +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 + 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 + + 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 + + -- final injection phase + let (near_final_prog, final_tys) = primInject $ dataInject merged_prog merged_tys + + let final_merged_cls = primInject merged_cls + + 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} + + 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 + + return (name, + final_prog, + final_tycons, + final_classes, + exports) + diff --git a/src/G2/Translation/PrimInject.hs b/src/G2/Translation/PrimInject.hs new file mode 100644 --- /dev/null +++ b/src/G2/Translation/PrimInject.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Primitive inejction into the environment +module G2.Translation.PrimInject + ( primInject + , dataInject + , addPrimsToBase + , mergeProgs + , mergeProgTys + ) where + +import G2.Language.AST +import G2.Language.Naming +import G2.Language.Syntax +import G2.Language.Typing +import G2.Language.TypeEnv + +import Data.List +import qualified Data.Text as T + +primInject :: ASTContainer p Type => p -> p +primInject = modifyASTs primInjectT + +primInjectT :: Type -> Type +primInjectT (TyCon (Name "TYPE" (Just "GHC.Prim") _ _) _) = TYPE +primInjectT (TyCon (Name "Int#" _ _ _) _) = TyLitInt +primInjectT (TyCon (Name "Word#" _ _ _) _) = TyLitInt +primInjectT (TyCon (Name "Float#" _ _ _) _) = TyLitFloat +primInjectT (TyCon (Name "Double#" _ _ _) _) = TyLitDouble +primInjectT (TyCon (Name "Char#" _ _ _) _) = TyLitChar +primInjectT t = t + +dataInject :: Program -> [ProgramType] -> (Program, [ProgramType]) +dataInject prog progTy = + let + dcNames = concatMap (\(_, dc) -> map conName (dataCon dc)) $ progTy + in + (modifyASTs (dataInject' dcNames) prog, progTy) + +-- TODO: Polymorphic types? +dataInject' :: [(Name, [Type])] -> Expr -> Expr +dataInject' ns v@(Var (Id (Name n m _ _) t)) = + case find (\(Name n' m' _ _, _) -> n == n' && m == m') ns of + Just (n', _) -> Data (DataCon n' t) + Nothing -> v +dataInject' _ e = e + +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' :: Name -> [(T.Text, Expr)] +primDefs' b = [ ("==#", 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) + , ("divInt#", Prim Quot tyIntIntInt) + , ("modInt#", Prim Mod tyIntIntInt) + , ("quotInt#", Prim Quot tyIntIntInt) + , ("remInt#", Prim Mod tyIntIntInt) + + , ("==##", 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) + + , ("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) + + , ("quotInteger#", Prim Quot tyIntIntInt) + + , ("eqChar#", Prim Eq $ tyCharCharBool b ) + , ("neChar#", Prim Neq $ tyCharCharBool b ) + + , ("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)) + , ("fromIntToDouble", Prim IntToDouble (TyFun TyLitInt TyLitDouble)) + + , ("absentErr", Prim Error TyBottom) + , ("error", Prim Error TyBottom) + , ("errorWithoutStackTrace", Prim Error TyBottom) + , ("divZeroError", Prim Error TyBottom) + , ("patError", Prim Error TyBottom) + , ("succError", Prim Error TyBottom) + , ("toEnumError", Prim Error TyBottom) + , ("undefined", Prim Error TyBottom)] + +tyIntInt :: Type +tyIntInt = TyFun TyLitInt TyLitInt + +tyIntIntBool :: Name -> Type +tyIntIntBool n = TyFun TyLitInt $ TyFun TyLitInt (TyCon n TYPE) + +tyIntIntInt :: Type +tyIntIntInt = TyFun TyLitInt $ TyFun TyLitInt TyLitInt + +tyDoubleDouble :: Type +tyDoubleDouble = TyFun TyLitDouble TyLitDouble + +tyDoubleDoubleBool :: Name -> Type +tyDoubleDoubleBool n = TyFun TyLitDouble $ TyFun TyLitDouble (TyCon n TYPE) + +tyDoubleDoubleDouble :: Type +tyDoubleDoubleDouble = TyFun TyLitDouble $ TyFun TyLitDouble TyLitDouble + +tyFloatFloat :: Type +tyFloatFloat = TyFun TyLitFloat TyLitFloat + +tyFloatFloatBool :: Name -> Type +tyFloatFloatBool n = TyFun TyLitFloat $ TyFun TyLitFloat (TyCon n TYPE) + +tyFloatFloatFloat :: Type +tyFloatFloatFloat = TyFun TyLitFloat $ TyFun TyLitFloat TyLitFloat + +tyCharCharBool :: Name -> Type +tyCharCharBool n = TyFun TyLitChar $ TyFun TyLitChar (TyCon n TYPE) + +boolName :: [ProgramType] -> Maybe Name +boolName = find ((==) "Bool" . nameOcc) . map fst + +replaceFromPD :: [ProgramType] -> Id -> Expr -> (Id, Expr) +replaceFromPD pt i@(Id n _) e = + let + e' = fmap snd $ find ((==) (nameOcc n) . fst) (primDefs pt) + in + (i, maybe e id e') + + +addPrimsToBase :: [ProgramType] -> Program -> Program +addPrimsToBase pt prims = map (map (uncurry (replaceFromPD pt))) prims + +mergeProgs :: Program -> Program -> Program +mergeProgs prog prims = prog ++ prims + +-- The prog is used to change the names of types in the prog' and primTys +mergeProgTys :: [ProgramType] -> [ProgramType] -> [ProgramType] +mergeProgTys progTys primTys = + progTys ++ primTys diff --git a/src/G2/Translation/TransTypes.hs b/src/G2/Translation/TransTypes.hs new file mode 100644 --- /dev/null +++ b/src/G2/Translation/TransTypes.hs @@ -0,0 +1,114 @@ +module G2.Translation.TransTypes where + +import CoreSyn +-- import GHC +import HscTypes +import InstEnv +import TyCon + +import qualified Data.HashMap.Lazy as HM +import qualified Data.Text as T + +import qualified G2.Language.Syntax as G2 +import qualified G2.Language.AlgDataTy as G2 + +type NameMap = HM.HashMap (T.Text, Maybe T.Text) G2.Name + +type TypeNameMap = HM.HashMap (T.Text, Maybe T.Text) G2.Name + +type ExportedName = G2.Name + +data TranslationConfig = TranslationConfig + { + simpl :: Bool + , load_rewrite_rules :: Bool + } + +simplTranslationConfig :: TranslationConfig +simplTranslationConfig = TranslationConfig { simpl = True, load_rewrite_rules = False } + +data ModGutsClosure = ModGutsClosure + { mgcc_mod_name :: Maybe String + , mgcc_binds :: [CoreBind] + , mgcc_tycons :: [TyCon] + , mgcc_breaks :: Maybe ModBreaks + , mgcc_cls_insts :: [ClsInst] + , mgcc_type_env :: TypeEnv + , mgcc_exports :: [ExportedName] + , mgcc_deps :: [String] + , mgcc_rules :: [CoreRule] + } + + +data ModDetailsClosure = ModDetailsClosure + { mdcc_cls_insts :: [ClsInst] + , mdcc_type_env :: TypeEnv + , mdcc_exports :: [ExportedName] + , mdcc_deps :: [String] + } + +data CgGutsClosure = CgGutsClosure + { cgcc_mod_name :: Maybe String + , cgcc_binds :: [CoreBind] + , cgcc_breaks :: Maybe ModBreaks + , cgcc_tycons :: [TyCon] + , cgcc_rules :: [CoreRule] + } + + +emptyModGutsClosure :: ModGutsClosure +emptyModGutsClosure = + ModGutsClosure + { mgcc_mod_name = Nothing + , mgcc_binds = [] + , mgcc_tycons = [] + , mgcc_breaks = Nothing + , mgcc_cls_insts = [] + , mgcc_type_env = emptyTypeEnv + , mgcc_exports = [] + , mgcc_deps = [] + , mgcc_rules = [] + } + +emptyModDetailsClosure :: ModDetailsClosure +emptyModDetailsClosure = + ModDetailsClosure + { mdcc_cls_insts = [] + , mdcc_type_env = emptyTypeEnv + , mdcc_exports = [] + , mdcc_deps = [] + } + +emptyCgGutsClosure :: CgGutsClosure +emptyCgGutsClosure = + CgGutsClosure + { cgcc_mod_name = Nothing + , cgcc_binds = [] + , cgcc_breaks = Nothing + , cgcc_tycons = [] + , cgcc_rules = [] + } + + +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_exports :: [ExportedName] + , exg2_deps :: [T.Text] + , exg2_rules :: ![G2.RewriteRule] + } deriving (Eq, Show, Read) + +emptyExtractedG2 :: ExtractedG2 +emptyExtractedG2 = + ExtractedG2 + { exg2_mod_names = [] + , exg2_binds = [] + , exg2_tycons = [] + , exg2_classes = [] + , exg2_exports = [] + , exg2_deps = [] + , exg2_rules = [] } + + diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,604 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Options +import Test.Tasty.Runners + +import G2.Config + +import G2.Interface +import G2.Language as G2 +import G2.Liquid.Interface + +import Control.Exception +import Data.Maybe +import Data.Proxy +import Data.Tagged +import qualified Data.Text as T +import System.Environment +import System.FilePath +import Type.Reflection (Typeable) + +import PeanoTest +import HigherOrderMathTest +import GetNthTest +import DefuncTest +import CaseTest +import Expr +import Typing + +import InputOutputTest +import Reqs +import TestUtils + +-- 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 + as <- getArgs + let todo = "--todo" `elem` as + defaultMainWithIngredients + (defaultIngredients ++ + [TestReporter + [ Option (Proxy :: Proxy ToDo) ] + (\_ _ -> Just (\_ -> return (\_ -> return False))) + ]) + =<< if todo then todoTests else tests + +tests :: IO TestTree +tests = return . testGroup "Tests" + =<< sequence [ + sampleTests + , liquidTests + , testFileTests + , baseTests + , primTests + , exprTests + , typingTests + ] + +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] + ] + +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] + + , 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')] + + , 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] + + , 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] + + , 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] + + , checkLiquid "tests/Liquid/NumOrd.hs" "subTuple" 1200 3 [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)] + + , 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] + + , checkLiquid "tests/Liquid/Nonused.hs" "g" 2000 1 [AtLeast 1] + + -- , 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] + + -- , 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] + + , checkLiquid "tests/Liquid/HigherOrder2.hs" "f" 2000 2 [Exactly 0] + , checkLiquid "tests/Liquid/HigherOrder2.hs" "h" 2000 2 [AtLeast 1] + + , checkLiquid "tests/Liquid/Ordering.hs" "oneOrOther" 1000 2 [Exactly 0] + + , checkLiquid "tests/Liquid/AddKV.lhs" "empty" 1000 3 [Exactly 0] + + , checkLiquid "tests/Liquid/PropSize.hs" "prop_size" 2000 1 [AtLeast 1] + , checkLiquid "tests/Liquid/PropSize2.hs" "prop_size" 2000 1 [AtLeast 1] + + , checkLiquidWithConfig "tests/Liquid/WhereFuncs.lhs" "f" 3 (mkConfigTestWithMap {steps = 1000}) [Exactly 0] + , checkLiquidWithConfig "tests/Liquid/WhereFuncs.lhs" "g" 3 (mkConfigTestWithMap {steps = 1000}) [Exactly 0] + + , checkLiquid "tests/Liquid/PropConcat.lhs" "prop_concat" 1000 1 [AtLeast 1] + + , 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')))] + + , 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)) ] + + , checkLiquid "tests/Liquid/MapReduceTest2.lhs" "mapReduce" 1500 3 [Exactly 0] + + , checkLiquid "tests/Liquid/MeasErr.hs" "f" 1500 2 [Exactly 0] + + , 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") ] + + , 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 ] + ] + +-- 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] + + , 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/CheckSq.hs" 400 Nothing Nothing "checkSq" 2 [AtLeast 2, RExists (\[x, _] -> isInt x (\x' -> x' == 3))] + + , 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/Defunc2.hs" 400 Nothing Nothing "funcMap" 3 [RForAll defunc2Check, AtLeast 30] + + , 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/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)] + + , 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] + + , 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] + + , 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] + + , checkExpr "tests/TestFiles/Guards.hs" 400 (Just "g") Nothing "f" 2 [AtLeast 1, RExists (\[dc, _] -> getBoolB dc id)] + + , 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/Strictness1.hs" 400 Nothing Nothing "f" 1 [AtLeast 1, RExists (\[(App x (App _ (Lit (LitInt y))))] -> dcHasName "A" x && y == 9)] + + , 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)] + + , checkExpr "tests/TestFiles/BadNames1.hs" 400 Nothing Nothing "abs'" 2 [Exactly 2] + , checkExpr "tests/TestFiles/BadNames1.hs" 400 Nothing Nothing "xswitch" 2 [AtLeast 10] + + , 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)] + + , checkExpr "tests/TestFiles/MultiSplit.hs" 1000 (Just "equals1") Nothing "f" 3 [Exactly 0] + + , checkExpr "tests/TestFiles/MatchesFunc1.hs" 400 Nothing Nothing "f" 2 [RExists (\[x, y] -> getIntB x $ \x' -> getIntB y $ \y' -> y' == 6 + x'), 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] + + , 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)] + + , 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"))] + + , 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"))) ] + + , 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)] + + , 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] + + ] + +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] + + , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "sumN" 1000 4 [AtLeast 6] + , checkInputOutput "tests/BaseTests/MaybeTest.hs" "MaybeTest" "lengthN" 1000 5 [AtLeast 6] + + , checkInputOutput "tests/BaseTests/Other.hs" "Other" "check4VeryEasy2" 600 1 [AtLeast 1] + ] + +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] + + , 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] + + , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "int2FloatTest" 1000 2 [AtLeast 1] + , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "int2DoubleTest" 1000 2 [AtLeast 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] + + , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "float2IntTest" 1000 2 [AtLeast 1] + , checkInputOutput "tests/Prim/Prim3.hs" "Prim3" "double2IntTest" 1000 2 [AtLeast 1] + ] + +data ToDo = RunMain + | RunToDo + deriving (Eq, Typeable) + + +instance IsOption ToDo where + defaultValue = RunMain + parseValue s = + let + ws = words s + in + if "y" `elem` ws || "yes" `elem` ws then Just RunToDo else Nothing + optionName = Tagged "todo" + optionHelp = Tagged "Specifies whether to run the main, passing tests, or the todo tests." + +-- 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 + +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 + +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 + + 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 src m_assume m_assert m_reaches entry config = + try (testFileWithConfig src m_assume m_assert m_reaches entry config) + +testFileWithConfig :: String + -> Maybe String + -> Maybe String + -> Maybe String + -> String + -> Config + -> 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 + + 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 + + +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) + +errors :: [Expr] -> Bool +errors e = + case last e of + Prim Error _ -> True + _ -> False