Checkpoint (with debug stuff)

src/Cryptol/TypeCheck/Solve.hs

@@ -38,6 +38,8 @@ import           Data.Set ( Set )
 import qualified Data.Set as Set
 import qualified SimpleSMT as SMT
 
+import           Text.PrettyPrint(text)
+
 -- Add additional constraints that ensure validity of type function.
 checkTypeFunction :: TFun -> [Type] -> [Prop]
 checkTypeFunction TCSub [a,b]             = [ a >== b, pFin b]
@@ -139,15 +141,36 @@ numericRight g  = case Num.exportProp (goal g) of
                     Just (p,vm)  -> Right ((g,vm), p)
                     Nothing -> Left g
 
+_testSimpGoals :: IO ()
+_testSimpGoals = Num.withSolver $ \s ->
+  do mb <- simpGoals s gs
+     case mb of
+       Just (gs1,su) ->
+          do debugBlock s "Simplified goals"
+                $ mapM_ (debugLog s . show . pp . goal) gs1
+             debugLog s (show (pp su))
+       Nothing -> debugLog s "Impossible"
+  where
+  gs = map fakeGoal [ tv 0 =#= num 5 ]
+    -- [ tv 0 =#= tInf, tMod (num 3) (tv 0) =#= num 4 ]
+
+  fakeGoal p = Goal { goalSource = undefined, goalRange = undefined, goal = p }
+  tv n = TVar (TVFree n KNum Set.empty (text "test var"))
+  num x = tNum (x :: Int)
+
 -- | Assumes that the substitution has been applied to the goals.
 simpGoals :: Num.Solver -> [Goal] -> IO (Maybe ([Goal],Subst))
 simpGoals s gs0 =
   do let (unsolvedClassCts,numCts) = solveClassCts gs0
+
          varMap = Map.unions [ vm | ((_,vm),_) <- numCts ]
          updCt prop (g,vs) = case Num.importProp varMap prop of
                                Just [g1] -> (g { goal = g1 }, vs)
-                               -- XXX: Could we get multiple gs?
-                               _         -> (g, vs)
+
+                               r -> panic "simpGoals"
+                                      [ "Unexpected import results"
+                                      , show r
+                                      ]
      case numCts of
        [] -> return $ Just (unsolvedClassCts, emptySubst)
        _  -> do mbOk <- Num.checkDefined s updCt uvs numCts

src/Cryptol/TypeCheck/Solver/CrySAT.hs

@@ -65,7 +65,9 @@ checkDefined s updCt uniVars props0 = withScope s (go Map.empty [] props0)
   where
   go knownImps done notDone =
     do (newNotDone, novelDone) <- checkDefined' s updCt notDone
+       putStrLn "Checking"
        (possible,  imps)       <- check s uniVars
+       putStrLn ("Possible: " ++ show possible)
        if not possible
          then return Nothing
          else
@@ -79,6 +81,7 @@ checkDefined s updCt uniVars props0 = withScope s (go Map.empty [] props0)
                                    )
                 else
                   do mapM_ addImpProp (Map.toList novelImps)
+                     -- Apply subst to knownImps?
                      let newImps    = Map.union novelImps knownImps
                          impDone    = map (updDone novelImps) newDone
                          impNotDone = map (updNotDone novelImps) newNotDone
@@ -114,6 +117,8 @@ checkDefined' s updCt props0 =
      go False [] [] ps
 
   where
+
+
   -- Everything is defined: keep going.
   go _    isDef []       [] = return ([], isDef)
 
@@ -278,7 +283,7 @@ withSolver :: (Solver -> IO a) -> IO a
 withSolver k =
   do logger <- SMT.newLogger
      solver <- SMT.newSolver "cvc4" ["--lang=smt2", "--incremental"]
-                                                   Nothing -- (Just logger)
+                                                   Nothing --} (Just logger)
      SMT.setLogic solver "QF_LIA"
      declared <- newIORef viEmpty
      nameSource <- newIORef 0
@@ -308,7 +313,7 @@ declareVar Solver { .. } a =
           let fin_a = smtFinName a
           _  <- SMT.declare solver fin_a SMT.tBool
           SMT.assert solver (SMT.geq e (SMT.int 0))
-          SMT.assert solver (SMT.const fin_a)     -- HMM ???
+          -- SMT.assert solver (SMT.const fin_a)     -- HMM ???
           modifyIORef' declared (viInsert a)
 
 -- | Add an assertion to the current context.
@@ -352,7 +357,8 @@ check Solver { .. } uniVars =
        SMT.Unsat   -> return (False, Map.empty)
        SMT.Unknown -> return (True, Map.empty)
        SMT.Sat     ->
-         do names <- viNames `fmap` readIORef declared
+         do putStrLn "Trying improvements"
+            names <- viNames `fmap` readIORef declared
             m     <- fmap Map.fromList (mapM getVal names)
             imps  <- toSubst `fmap` cryImproveModel solver uniVars m
 

src/Cryptol/TypeCheck/Solver/Numeric/Simplify.hs

@@ -40,7 +40,7 @@ crySimplify p = trace ("simp: " ++ show (ppProp p)) $
 
 -- | Simplify a property, if possible.
 crySimplify' :: Prop -> Prop
-crySimplify' p = fromMaybe p (crySimplifyMaybe p)
+crySimplify' p = crySimplify p -- fromMaybe p (crySimplifyMaybe p)
 
 -- | Simplify a property, if possibly.
 crySimplifyMaybe :: Prop -> Maybe Prop
@@ -346,7 +346,6 @@ cryKnownFin a isFin prop =
 
 
 
-
 -- | Negation.
 cryNot :: Prop -> Maybe Prop
 cryNot prop =