From 965dab7d47e4ce709d1a661c9c1e112153efe839 Mon Sep 17 00:00:00 2001
From: Orestis Melkonian <melkon.or@gmail.com>
Date: Tue, 6 Feb 2018 14:13:19 +0100
Subject: [PATCH] Backend: cleaning up

---
 javawlp.cabal                   |  1 +
 src/LogicIR/Backend/Z3/API.hs   | 80 +++++++++++++++------------------
 src/LogicIR/Backend/Z3/Model.hs | 33 ++++----------
 src/LogicIR/Null.hs             |  4 +-
 src/LogicIR/Parser.hs           | 24 +---------
 src/LogicIR/ParserUtils.hs      | 28 ++++++++++++
 6 files changed, 77 insertions(+), 93 deletions(-)
 create mode 100644 src/LogicIR/ParserUtils.hs

diff --git a/javawlp.cabal b/javawlp.cabal
index 9d5d226..f00c9ed 100644
--- a/javawlp.cabal
+++ b/javawlp.cabal
@@ -28,6 +28,7 @@ library
                      , LogicIR.Pretty
                      , LogicIR.Frontend.Java
                      , LogicIR.Eval
+                     , LogicIR.ParserUtils
                      -- Checker
                      , SimpleFormulaChecker
                      -- Z3
diff --git a/src/LogicIR/Backend/Z3/API.hs b/src/LogicIR/Backend/Z3/API.hs
index f26f978..4bbe333 100644
--- a/src/LogicIR/Backend/Z3/API.hs
+++ b/src/LogicIR/Backend/Z3/API.hs
@@ -23,9 +23,6 @@ equivalentTo :: LExpr -> LExpr -> IO Z3Response
 equivalentTo lexpr lexpr' = do
     let fv = freeVars2 lexpr lexpr'
     let (ast, ast') = (lExprToZ3Ast lexpr, lExprToZ3Ast lexpr')
-    asts <- showZ3AST ast
-    asts' <- showZ3AST ast'
-    -- putStrLn $ "Z3_AST1:\n" ++ asts ++ "\n\nZ3_AST2:\n" ++ asts' ++ "\n"
     res <- tryJust errorSelector $ equivalentToZ3 fv ast ast'
     case res of
       Left () -> return Timeout
@@ -37,18 +34,12 @@ equivalentTo lexpr lexpr' = do
           InvalidUsage -> Just ()
           _            -> Nothing
 
--- | Sequence tactics.
-(-->) t t' = do
-  tt <- mkTactic t
-  tt' <- mkTactic t'
-  andThenTactic tt tt'
-
 -- | Check if two Z3 AST's are equivalent.
 equivalentToZ3 :: Z3 FreeVars -> Z3 AST -> Z3 AST -> IO Z3Response
 equivalentToZ3 freeVars ast1' ast2' =
   tryZ3 $ do
+    -- Setup
     fv <- freeVars
-    -- liftIO $ putStr "FreeVars: " >> print (M.keys fv)
     ast1 <- ast1'
     ast2 <- ast2'
     astEq <- mkEq ast1 ast2
@@ -60,46 +51,43 @@ equivalentToZ3 freeVars ast1' ast2' =
     t <- "qe" --> "aig"
     a <- applyTactic t g
     asts <- getGoalFormulas =<< getApplyResultSubgoal a 0
-    -- liftIO $ putStrLn "After tactics:"
-    -- astStrs <- mapM astToString asts
-    -- forM_ astStrs (liftIO . putStrLn)
     g' <- mkAnd asts
     assert g'
 
-    -- assert astNeq
-    (r, model) <- solverCheckAndGetModel -- check in documentation
+    -- Get model
+    (r, model) <- solverCheckAndGetModel
 
-    case r of
+    response <- case r of
       Unsat -> return Equivalent
       Undef -> return Undefined
       Sat   -> do
-        let m = fromJust model
-        ms <- M.fromList <$> forM (M.toList fv) (evalAST fv m)
-        let ms' = sanitize ms
-        liftIO $ putStr "Model: " >> print ms'
-        return $ NotEquivalent ms'
-    -- solverReset
-    where evalAST :: FreeVars -> Model -> (String, AST) -> Z3 (String, ModelVal)
-          evalAST fv m (k, ast) = do
-            v <- fromJust <$> modelEval m ast True
-            sortKind <- getSort v >>= getSortKind
-            if sortKind == Z3_ARRAY_SORT then do
-              -- Retrieve array's length
-              lenName <- mkStringSymbol (k ++ "?length") >>= mkIntVar
-              f <- snd <$> evalAST fv m (k ++ "?length", lenName)
-              let len = case f of
-                    (IntVal i) -> i
-                    _ -> error "non-int length"
-              -- Iterate array "points"
-              modelVals <- forM [0..(len-1)] (\i -> do
-                indexAST <- mkInteger $ toInteger i
-                pointAST <- mkSelect v indexAST
-                snd <$> evalAST fv m ("", pointAST)
-                )
-              return (k, ManyVal modelVals)
-            else do
-              v' <- astToString v
-              return (k, fromString v' :: ModelVal)
+        ms <- M.fromList <$> forM (M.toList fv) (evalAST fv (fromJust model))
+        return $ NotEquivalent (sanitize ms)
+    solverReset
+    return response
+    where
+      -- Construct model values
+      evalAST :: FreeVars -> Model -> (String, AST) -> Z3 (String, ModelVal)
+      evalAST fv m (k, ast) = do
+        v <- fromJust <$> modelEval m ast True
+        sortKind <- getSort v >>= getSortKind
+        if sortKind == Z3_ARRAY_SORT then do
+          -- Retrieve array's length
+          lenName <- mkStringSymbol (k ++ "?length") >>= mkIntVar
+          f <- snd <$> evalAST fv m (k ++ "?length", lenName)
+          let len = case f of
+                (IntVal i) -> i
+                _ -> error "non-int length"
+          -- Iterate array "points"
+          modelVals <- forM [0..(len-1)] (\i -> do
+            indexAST <- mkInteger $ toInteger i
+            pointAST <- mkSelect v indexAST
+            snd <$> evalAST fv m ("", pointAST)
+            )
+          return (k, ManyVal modelVals)
+        else do
+          v' <- astToString v
+          return (k, fromString v' :: ModelVal)
 
 -- | Z3 try evaluation with timeout.
 tryZ3 = evalZ3With Nothing (  opt "timeout" (5000 :: Integer)
@@ -108,6 +96,12 @@ tryZ3 = evalZ3With Nothing (  opt "timeout" (5000 :: Integer)
                            +? opt "auto_config" True
                            -- +? opt "unsat_core" True
                            )
+                           
+-- | Sequence tactics.
+(-->) t t' = do
+  tt <- mkTactic t
+  tt' <- mkTactic t'
+  andThenTactic tt tt'
 
 -- | Pretty-print Z3 AST.
 showZ3AST :: Z3 AST -> IO String
diff --git a/src/LogicIR/Backend/Z3/Model.hs b/src/LogicIR/Backend/Z3/Model.hs
index 943585f..5d6e894 100644
--- a/src/LogicIR/Backend/Z3/Model.hs
+++ b/src/LogicIR/Backend/Z3/Model.hs
@@ -1,17 +1,17 @@
-{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 module LogicIR.Backend.Z3.Model where
 
 import qualified Data.Map as M
-
 import Data.String
 import Text.Parsec hiding (runP)
-import Text.Parsec.Char
 import Text.Parsec.Expr
 import Text.Parsec.Language
 import Text.Parsec.String
 import qualified Text.Parsec.Token as Tokens
 
+import LogicIR.ParserUtils
+
+-- | Data type.
 data ModelVal = BoolVal Bool
               | IntVal Integer
               | RealVal Double
@@ -21,6 +21,7 @@ data ModelVal = BoolVal Bool
 type Z3Model = M.Map String ModelVal
 emptyZ3Model = M.empty :: Z3Model
 
+-- | Pretty-printing.
 instance Show ModelVal where
   show (BoolVal b)  = show b
   show (IntVal i)   = show i
@@ -37,17 +38,7 @@ sanitize model = M.mapWithKey f model
             (IntVal i) -> i
             _ -> error "non-int length"
 
--- | Implicit conversion from strings.
-instance IsString ModelVal where
-  fromString = runP modelP
-
--- | Parser.
-runP :: Parser a -> String -> a
-runP p s =
-  case runParser (p <* eof) () "" s of
-        Left err -> error $ show err
-        Right r  -> r
-
+-- | Parsers.
 modelP :: Parser ModelVal
 modelP = try (BoolVal <$> boolP)
      <|> try (RealVal <$> realP)
@@ -74,14 +65,6 @@ indexP = Tokens.natural haskell
 boolP :: Parser Bool
 boolP = (True <$ str "true") <|> (False <$ str "false")
 
--- | Useful marcros.
-lexeme p = spaces *> p <* spaces
-str = lexeme . string
-commas l = l `sepBy` string ", "
-(<~) p s = p <* lexeme (string s)
-(~>) s p = lexeme (string s) *> p
-parens = Tokens.parens haskell
-reserved = Tokens.reservedOp haskell
-infix_ op f = Infix (reserved op >> return f) AssocLeft
-prefix op f = Prefix (reserved op >> return f)
-postfix op f = Postfix (reserved op >> return f)
+-- | Implicit conversion from strings.
+instance IsString ModelVal where
+  fromString = runP modelP
diff --git a/src/LogicIR/Null.hs b/src/LogicIR/Null.hs
index 50531df..5a1919b 100644
--- a/src/LogicIR/Null.hs
+++ b/src/LogicIR/Null.hs
@@ -1,7 +1,7 @@
 module LogicIR.Null (lExprPreprocessNull) where
 
-import           LogicIR.Expr
-import           LogicIR.Fold
+import LogicIR.Expr
+import LogicIR.Fold
 
 -- | Replace all instances of "a ==/!= null" with (!)isNull(a).
 lExprPreprocessNull :: LExpr -> LExpr
diff --git a/src/LogicIR/Parser.hs b/src/LogicIR/Parser.hs
index b14b9cf..8542432 100644
--- a/src/LogicIR/Parser.hs
+++ b/src/LogicIR/Parser.hs
@@ -1,25 +1,16 @@
-{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 module LogicIR.Parser where
 
 import Data.String
-import System.IO.Unsafe (unsafePerformIO)
 import Text.Parsec hiding (runP)
-import Text.Parsec.Char
 import Text.Parsec.Expr
 import Text.Parsec.Language
 import Text.Parsec.String
 import qualified Text.Parsec.Token as Tokens
 
+import LogicIR.ParserUtils
 import LogicIR.Expr
 
--- | Run parser.
-runP :: Parser a -> String -> a
-runP p s = unsafePerformIO $
-  case runParser (p <* eof) () "" s of
-        Left err   -> fail $ show err
-        Right lExp -> return lExp
-
 -- | Parser for logical expressions.
 exprP :: Parser LExpr
 exprP =
@@ -99,19 +90,6 @@ typeP = try (TPrim <$> primTypeP) <|> (TArray <$> arrayTypeP)
                    <|> (PReal <$ str "real")
     arrayTypeP = "[" ~> typeP <~ "]"
 
--- | Useful marcros.
-lexeme p = spaces *> p <* spaces
-str = lexeme . string
-commas l = l `sepBy` string ", "
-(<~) p s = p <* lexeme (string s)
-(~>) s p = lexeme (string s) *> p
-parens = Tokens.parens haskell
-identifier = Tokens.identifier haskell
-reserved = Tokens.reservedOp haskell
-infix_ op f = Infix (reserved op >> return f) AssocLeft
-prefix op f = Prefix (reserved op >> return f)
-postfix op f = Postfix (reserved op >> return f)
-
 -- | Implicit conversions from strings.
 instance IsString LExpr where
   fromString = runP exprP
diff --git a/src/LogicIR/ParserUtils.hs b/src/LogicIR/ParserUtils.hs
new file mode 100644
index 0000000..25a247a
--- /dev/null
+++ b/src/LogicIR/ParserUtils.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE FlexibleContexts  #-}
+module LogicIR.ParserUtils where
+
+import Text.Parsec
+import Text.Parsec.Expr
+import Text.Parsec.Language
+import Text.Parsec.String
+import qualified Text.Parsec.Token as Tokens
+
+-- | Run parser.
+runP :: Parser a -> String -> a
+runP p s =
+  case runParser (p <* eof) () "" s of
+        Left err   -> error $ show err
+        Right x -> x
+
+-- | Useful marcros.
+lexeme p = spaces *> p <* spaces
+str = lexeme . string :: String -> Parser String
+commas l = l `sepBy` string ", "
+(<~) p s = p <* lexeme (string s)
+(~>) s p = lexeme (string s) *> p
+parens = Tokens.parens haskell
+identifier = Tokens.identifier haskell
+reserved = Tokens.reservedOp haskell
+infix_ op f = Infix (reserved op >> return f) AssocLeft
+prefix op f = Prefix (reserved op >> return f)
+postfix op f = Postfix (reserved op >> return f)
-- 
GitLab