Skip to content

Commit

Permalink
Fix uncurried uninterpreted function printing
Browse files Browse the repository at this point in the history
  • Loading branch information
LeventErkok committed Jan 3, 2024
1 parent 59879d3 commit c401114
Show file tree
Hide file tree
Showing 2 changed files with 12 additions and 10 deletions.
14 changes: 7 additions & 7 deletions Data/SBV/Control/Utils.hs
Original file line number Diff line number Diff line change
Expand Up @@ -663,9 +663,9 @@ instance ( SymVal a, HasKind a
-- Turn "((F (lambda ((x!1 Int)) (+ 3 (* 2 x!1)))))"
-- into something more palatable.
-- If we can't do that, we simply return the input unchanged
trimFunctionResponse :: String -> String -> Maybe [String] -> String
trimFunctionResponse resp nm mbArgs
| Just parsed <- makeHaskellFunction resp nm mbArgs
trimFunctionResponse :: String -> String -> Bool -> Maybe [String] -> String
trimFunctionResponse resp nm isCurried mbArgs
| Just parsed <- makeHaskellFunction resp nm isCurried mbArgs
= parsed
| True
= def $ case trim resp of
Expand All @@ -678,14 +678,14 @@ trimFunctionResponse resp nm mbArgs
-- | Generalization of 'Data.SBV.Control.getFunction'
getFunction :: (MonadIO m, MonadQuery m, SolverContext m, MonadSymbolic m, SymVal a, SymVal r, SMTFunction fun a r)
=> fun -> m (Either String ([(a, r)], r))
getFunction f = do ((nm, args), _) <- smtFunName f
getFunction f = do ((nm, args), isCurried) <- smtFunName f

let cmd = "(get-value (" ++ nm ++ "))"
bad = unexpected "getFunction" cmd "a function value" Nothing

r <- ask cmd

parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> do mbAssocs <- sexprToFun f (trimFunctionResponse r nm args, e)
parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> do mbAssocs <- sexprToFun f (trimFunctionResponse r nm isCurried args, e)
case mbAssocs of
Right assocs -> return $ Right assocs
Left raw -> do mbPVS <- pointWiseExtract nm (smtFunType f)
Expand Down Expand Up @@ -1019,7 +1019,7 @@ getUICVal mbi (nm, (_, _, t)) = case t of

-- | Generalization of 'Data.SBV.Control.getUIFunCVAssoc'
getUIFunCVAssoc :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> (String, (Bool, Maybe [String], SBVType)) -> m (Either String ([([CV], CV)], CV))
getUIFunCVAssoc mbi (nm, (_, mbArgs, typ)) = do
getUIFunCVAssoc mbi (nm, (isCurried, mbArgs, typ)) = do
let modelIndex = case mbi of
Nothing -> ""
Just i -> " :model_index " ++ show i
Expand All @@ -1043,7 +1043,7 @@ getUIFunCVAssoc mbi (nm, (_, mbArgs, typ)) = do
toRes = recoverKindedValue rt

-- if we fail to parse, we'll return this answer as the string
fallBack = trimFunctionResponse r nm mbArgs
fallBack = trimFunctionResponse r nm isCurried mbArgs

-- In case we end up in the pointwise scenario, boolify the result
-- as that's the only type we support here.
Expand Down
8 changes: 5 additions & 3 deletions Data/SBV/Utils/SExpr.hs
Original file line number Diff line number Diff line change
Expand Up @@ -546,11 +546,13 @@ chainAssigns chain = regroup $ partitionEithers chain
-- This isn't very fool-proof; can be confused if there are binding constructs etc.
-- Also, the generated text isn't necessarily fully Haskell acceptable.
-- But it seems to do an OK job for most common use cases.
makeHaskellFunction :: String -> String -> Maybe [String] -> Maybe String
makeHaskellFunction resp nm mbArgs
makeHaskellFunction :: String -> String -> Bool -> Maybe [String] -> Maybe String
makeHaskellFunction resp nm isCurried mbArgs
= case parseSExpr resp of
Right (EApp [EApp [ECon o, e]]) | o == nm -> do (args, bd) <- lambda e
return $ unwords (nm : args) ++ " = " ++ bd
let params | isCurried = unwords args
| True = '(' : intercalate ", " args ++ ")"
return $ nm ++ " " ++ params ++ " = " ++ bd
_ -> Nothing

where -- infinite supply of names; starting with the ones we're given
Expand Down

0 comments on commit c401114

Please sign in to comment.