Mutually recursive evaluator in Haskell - haskell

Update: I've added an answer that describes my final solution (hint: the single Expr data type wasn't sufficient).
I'm writing an evaluator for a little expression language, but I'm stuck on the LetRec construct.
This is the language:
type Var = String
type Binds = [(Var, Expr)]
data Expr
= Var Var
| Lam Var Expr
| App Expr Expr
| Con Int
| Sub Expr Expr
| If Expr Expr Expr
| Let Var Expr Expr
| LetRec Binds Expr
deriving (Show, Eq)
And this this the evaluator so far:
data Value
= ValInt Int
| ValFun Env Var Expr
deriving (Show, Eq)
type Env = [(Var, Value)]
eval :: Env -> Expr -> Either String Value
eval env (Var x) = maybe (throwError $ x ++ " not found")
return
(lookup x env)
eval env (Lam x e) = return $ ValFun env x e
eval env (App e1 e2) = do
v1 <- eval env e1
v2 <- eval env e2
case v1 of
ValFun env1 x e -> eval ((x, v2):env1) e
_ -> throwError "First arg to App not a function"
eval _ (Con x) = return $ ValInt x
eval env (Sub e1 e2) = do
v1 <- eval env e1
v2 <- eval env e2
case (v1, v2) of
(ValInt x, ValInt y) -> return $ ValInt (x - y)
_ -> throwError "Both args to Sub must be ints"
eval env (If p t f) = do
v1 <- eval env p
case v1 of
ValInt x -> if x /= 0
then eval env t
else eval env f
_ -> throwError "First arg of If must be an int"
eval env (Let x e1 e2) = do
v1 <- eval env e1
eval ((x, v1):env) e2
eval env (LetRec bs e) = do
env' <- evalBinds
eval env' e
where
evalBinds = mfix $ \env' -> do
env'' <- mapM (\(x, e') -> eval env' e' >>= \v -> return (x, v)) bs
return $ nub (env'' ++ env)
This is my test function I want to evaluate:
test3 :: Expr
test3 = LetRec [ ("even", Lam "x" (If (Var "x")
(Var "odd" `App` (Var "x" `Sub` Con 1))
(Con 1)
))
, ("odd", Lam "x" (If (Var "x")
(Var "even" `App` (Var "x" `Sub` Con 1))
(Con 0)
))
]
(Var "even" `App` Con 5)
EDIT:
Based on Travis' answer and Luke's comment, I've updated my code to use the MonadFix instance for the Error monad. The previous example works fine now! However, the example bellow doesn't work correctly:
test4 :: Expr
test4 = LetRec [ ("x", Con 3)
, ("y", Var "x")
]
(Con 0)
When evaluating this, the evaluator loops, and nothing happens. I'm guessing I've made something a bit too strict here, but I'm not sure what it is. Am I violating one of the MonadFix laws?

When Haskell throws a fit, that's usually an indication that you have not thought clearly about a core issue of your problem. In this case, the question is: which evaluation model do you want to use for your language? Call-by-value or call-by-need?
Your representation of environments as [(Var,Value)] suggests that you want to use call-by-value, since every Expr is evaluated to a Value right away before storing it in the environment. But letrec does not go well with that, and your second example shows!
Furthermore, note that the evaluation model of the host language (Haskell) will interfere with the evaluation model of the language you want to implement; in fact, that's what you are currently making use of for your examples: despite their purpose, your Values are not evaluated to weak head normal form.
Unless you have a clear picture of the evaluation model of your little expression language, you won't make much progress on letrec or on the error checking facilities.
Edit:
For an example specification of letrec in a call-by-value language, have a look at the Ocaml Manual. On the simplest level, they only allow right-hand sides that are lambda expressions, i.e. things that are syntactically known to be values.

Maybe I'm missing something, but doesn't the following work?
eval env (LetRec bs ex) = eval env' ex
where
env' = env ++ map (\(v, e) -> (v, eval env' e)) bs
For your updated version: What about the following approach? It works as desired on your test case, and doesn't throw away errors in LetRec expressions:
data Value
= ValInt Int
| ValFun EnvWithError Var Expr
deriving (Show, Eq)
type Env = [(Var, Value)]
type EnvWithError = [(Var, Either String Value)]
eval :: Env -> Expr -> Either String Value
eval = eval' . map (second Right)
where
eval' :: EnvWithError -> Expr -> Either String Value
eval' env (Var x) = maybe (throwError $ x ++ " not found")
(join . return)
(lookup x env)
eval' env (Lam x e) = return $ ValFun env x e
eval' env (App e1 e2) = do
v1 <- eval' env e1
v2 <- eval' env e2
case v1 of
ValFun env1 x e -> eval' ((x, Right v2):env1) e
_ -> throwError "First arg to App not a function"
eval' _ (Con x) = return $ ValInt x
eval' env (Sub e1 e2) = do
v1 <- eval' env e1
v2 <- eval' env e2
case (v1, v2) of
(ValInt x, ValInt y) -> return $ ValInt (x - y)
_ -> throwError "Both args to Sub must be ints"
eval' env (If p t f) = do
v1 <- eval' env p
case v1 of
ValInt x -> if x /= 0
then eval' env t
else eval' env f
_ -> throwError "First arg of If must be an int"
eval' env (Let x e1 e2) = do
v1 <- eval' env e1
eval' ((x, Right v1):env) e2
eval' env (LetRec bs ex) = eval' env' ex
where
env' = env ++ map (\(v, e) -> (v, eval' env' e)) bs

Answering my own question; I wanted to share the final solution I came up with.
As Heinrich correctly pointed out, I didn't really think through the impact the evaluation order has.
In a strict (call-by-value) language, an expression that is already a value (weak head normal form) is different from an expression that still needs some evaluation. Once I encoded this distinction in my data type, everything fell into place:
type Var = String
type Binds = [(Var, Val)]
data Val
= Con Int
| Lam Var Expr
deriving (Show, Eq)
data Expr
= Val Val
| Var Var
| App Expr Expr
| Sub Expr Expr
| If Expr Expr Expr
| Let Var Expr Expr
| LetRec Binds Expr
deriving (Show, Eq)
The only difference with my my original Expr data type, is that I pulled out two constructors (Con and Lam) into their own data type Val. The Expr data type has a new constructor Val, this represents the fact that a value is also a valid expression.
With values in their own data type, they can be handled separately from other expression, for example letrec bindings can only contain values, no other expressions.
This distinction is also made in other strict languages like C, where only functions and constants can be defined in global scope.
See the complete code for the updated evaluator function.

Related

Implementing alpha equivalence - Haskell

So let me define a few things:
type Name = String
data Exp = Var Name
| App Exp Exp
| Lam Name Exp
deriving (Eq,Show,Read)
I want to define alpha-equivalence, which is
alpha_eq :: Exp -> Exp -> Bool
-- The terms x and y are not alpha-equivalent, because they are not bound in a lambda abstraction
alpha_eq (Var x) (Var y) = False
alpha_eq (Lam x e1) (Lam y e2) = False
alpha_eq (App e1 e2) (App e3 e4) = False
For example Lam "x" (Var "x") and Lam "y" (Var "y") are both equivalent. However I'm both new and horrible at Haskell. Could someone give a clue of how to implement alpha_eq? One thing I thought about was to use Map Name Int so in this case I would have:
['x' -> 0] ['y' -> 0]
so in this case Map['x'] == Map['y']. But again I'm horrible at Haskell. Could you someone give me a clue how to implement it?
Yes, using a Map a correct idea (though think on what the key and value types should be; with Map Name Int you need two extra arguments instead of one). You need to add it as the argument of a helper function, I won't give the full implementation since you asked for a clue only:
alpha_eq e1 e2 = alpha_eq' e1 e2 env0 where
env0 = ???
alpha_eq' (Var x) (Var y) env = ???
alpha_eq' (Lambda x e1) (Lambda y e2) env = ???
alpha_eq' (App e1 e2) (App e3 e4) env = ???
-- you don't want to throw an error in all other cases
alpha_eq' _ _ env = ???
You could also make separate function subst :: Name -> Exp -> Exp -> Exp. Then, alpha_eq Lam-case becomes
alpha_eq :: Exp -> Exp -> Bool
...
alpha_eq (Lam x xb) (Lam y yb) = xb `alpha_eq` subst y (Var x) yb
...
Excersise: figure out other alpha_eq cases and implementation of subst.

interpret Parigot's lambda-mu calculus in Haskell

One can interpret the lambda calculus in Haskell:
data Expr = Var String | Lam String Expr | App Expr Expr
data Value a = V a | F (Value a -> Value a)
interpret :: [(String, Value a)] -> Expr -> Value a
interpret env (Var x) = case lookup x env of
Nothing -> error "undefined variable"
Just v -> v
interpret env (Lam x e) = F (\v -> interpret ((x, v):env) e)
interpret env (App e1 e2) = case interpret env e1 of
V _ -> error "not a function"
F f -> f (interpret env e2)
How could the above interpreter be extended to the lambda-mu calculus? My guess is that it should use continuations for interpreting the additional constructs in this calculus. (15) and (16) from the Bernardi&Moortgat paper are the kind of translations I expect.
It is possible since Haskell is Turing-complete, but how?
Hint: See the comment on page 197 on this research paper for the intuitive meaning of the mu binder.
Here's a mindless transliteration of the reduction rules from the paper, using #user2407038's representation (as you'll see, when I say mindless, I really do mean mindless):
{-# LANGUAGE DataKinds, KindSignatures, GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
import Control.Monad.Writer
import Control.Applicative
import Data.Monoid
data TermType = Named | Unnamed
type Var = String
type MuVar = String
data Expr (n :: TermType) where
Var :: Var -> Expr Unnamed
Lam :: Var -> Expr Unnamed -> Expr Unnamed
App :: Expr Unnamed -> Expr Unnamed -> Expr Unnamed
Freeze :: MuVar -> Expr Unnamed -> Expr Named
Mu :: MuVar -> Expr Named -> Expr Unnamed
deriving instance Show (Expr n)
substU :: Var -> Expr Unnamed -> Expr n -> Expr n
substU x e = go
where
go :: Expr n -> Expr n
go (Var y) = if y == x then e else Var y
go (Lam y e) = Lam y $ if y == x then e else go e
go (App f e) = App (go f) (go e)
go (Freeze alpha e) = Freeze alpha (go e)
go (Mu alpha u) = Mu alpha (go u)
renameN :: MuVar -> MuVar -> Expr n -> Expr n
renameN beta alpha = go
where
go :: Expr n -> Expr n
go (Var x) = Var x
go (Lam x e) = Lam x (go e)
go (App f e) = App (go f) (go e)
go (Freeze gamma e) = Freeze (if gamma == beta then alpha else gamma) (go e)
go (Mu gamma u) = Mu gamma $ if gamma == beta then u else go u
appN :: MuVar -> Expr Unnamed -> Expr n -> Expr n
appN beta v = go
where
go :: Expr n -> Expr n
go (Var x) = Var x
go (Lam x e) = Lam x (go e)
go (App f e) = App (go f) (go e)
go (Freeze alpha w) = Freeze alpha $ if alpha == beta then App (go w) v else go w
go (Mu alpha u) = Mu alpha $ if alpha /= beta then go u else u
reduceTo :: a -> Writer Any a
reduceTo x = tell (Any True) >> return x
reduce0 :: Expr n -> Writer Any (Expr n)
reduce0 (App (Lam x u) v) = reduceTo $ substU x v u
reduce0 (App (Mu beta u) v) = reduceTo $ Mu beta $ appN beta v u
reduce0 (Freeze alpha (Mu beta u)) = reduceTo $ renameN beta alpha u
reduce0 e = return e
reduce1 :: Expr n -> Writer Any (Expr n)
reduce1 (Var x) = return $ Var x
reduce1 (Lam x e) = reduce0 =<< (Lam x <$> reduce1 e)
reduce1 (App f e) = reduce0 =<< (App <$> reduce1 f <*> reduce1 e)
reduce1 (Freeze alpha e) = reduce0 =<< (Freeze alpha <$> reduce1 e)
reduce1 (Mu alpha u) = reduce0 =<< (Mu alpha <$> reduce1 u)
reduce :: Expr n -> Expr n
reduce e = case runWriter (reduce1 e) of
(e', Any changed) -> if changed then reduce e' else e
It "works" for the example from the paper: with
example 0 = App (App t (Var "x")) (Var "y")
where
t = Lam "x" $ Lam "y" $ Mu "delta" $ Freeze "phi" $ App (Var "x") (Var "y")
example n = App (example (n-1)) (Var ("z_" ++ show n))
I can reduce example n to the expected result:
*Main> reduce (example 10)
Mu "delta" (Freeze "phi" (App (Var "x") (Var "y")))
The reason I put scare quotes around "works" above is that I have no intuition about the λμ calculus so I don't know what it should do.
Note: this is only a partial answer since I'm not sure how to extend the interpreter.
This seems like a good use case for DataKinds. The Expr datatype is indexed on a type which is named or unnamed. The regular lambda constructs produce named terms only.
{-# LANGUAGE GADTs, DataKinds, KindSignatures #-}
data TermType = Named | Unnamed
type Var = String
type MuVar = String
data Expr (n :: TermType) where
Var :: Var -> Expr Unnamed
Lam :: Var -> Expr Unnamed -> Expr Unnamed
App :: Expr Unnamed -> Expr Unnamed -> Expr Unnamed
and the additional Mu and Name constructs can manipulate the TermType.
...
Name :: MuVar -> Expr Unnamed -> Expr Named
Mu :: MuVar -> Expr Named -> Expr Unnamed
How about something like the below. I don't have a good idea on how to traverse Value a, but at least I can see it evaluates example n into MuV.
import Data.Maybe
type Var = String
type MuVar = String
data Expr = Var Var
| Lam Var Expr
| App Expr Expr
| Mu MuVar MuVar Expr
deriving Show
data Value a = ConV a
| LamV (Value a -> Value a)
| MuV (Value a -> Value a)
type Env a = [(Var, Value a)]
type MuEnv a = [(MuVar, Value a -> Value a)]
varScopeErr :: Var -> Value a
varScopeErr v = error $ unwords ["Out of scope λ variable:", show v]
appErr :: Value a
appErr = error "Trying to apply a non-lambda"
muVarScopeErr :: MuVar -> (Value a -> Value a)
muVarScopeErr alpha = id
app :: Value a -> Value a -> Value a
app (LamV f) x = f x
app (MuV f) x = MuV $ \y -> f x `app` y
app _ _ = appErr
eval :: Env a -> MuEnv a -> Expr -> Value a
eval env menv (Var v) = fromMaybe (varScopeErr v) $ lookup v env
eval env menv (Lam v e) = LamV $ \x -> eval ((v, x):env) menv e
eval env menv (Mu alpha beta e) = MuV $ \u ->
let menv' = (alpha, (`app` u)):menv
wrap = fromMaybe (muVarScopeErr beta) $ lookup beta menv'
in wrap (eval env menv' e)
eval env menv (App f e) = eval env menv f `app` eval env menv e
example 0 = App (App t (Var "v")) (Var "w")
where
t = Lam "x" $ Lam "y" $ Mu "delta" "phi" $ App (Var "x") (Var "y")
example n = App (example (n-1)) (Var ("z_" ++ show n))

How to evaluate expressions in Haskell

I understand how to create and evaluate a simple data-type Expr. For example like this:
data Expr = Lit Int | Add Expr Expr | Sub Expr Expr | [...]
eval :: Expr -> Int
eval (Lit x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
So here is my question: How can I add Variables to this Expr type, which should be evaluated for its assigned value? It should look like this:
data Expr = Var Char | Lit Int | Add Expr Expr [...]
type Assignment = Char -> Int
eval :: Expr -> Assignment -> Int
How do I have to do my eval function now for (Var Char) and (Add Expr Expr)? I think I figured out the easiest, how to do it for Lit already.
eval (Lit x) _ = x
For (Var Char) I tried a lot, but I cant get an Int out of an Assignment.. Thought It would work like this:
eval (Var x) (varname number) = number
Well if you model your enviroment as
type Env = Char -> Int
Then all you have is
eval (Var c) env = env c
But this isn't really "correct". For one, what happens with unbound variables? So perhaps a more accurate type is
type Env = Char -> Maybe Int
emptyEnv = const Nothing
And now we can see whether a variable is unbound
eval (Var c) env = maybe handleUnboundCase id (env c)
And now we can use handleUnboundCase to do something like assign a default value, blow up the program, or make monkeys climb out of your ears.
The final question to ask is "how are variables bound?". If you where looking for a "let" statement like we have in Haskell, then we can use a trick known as HOAS (higher order abstract syntax).
data Exp = ... | Let Exp (Exp -> Exp)
The HOAS bit is that (Exp -> Exp). Essentially we use Haskell's name-binding to implement our languages. Now to evaluate a let expression we do
eval (Let val body) = body val
This let's us dodge Var and Assignment by relying on Haskell to resolve the variable name.
An example let statement in this style might be
Let 1 $ \x -> x + x
-- let x = 1 in x + x
The biggest downside here is that modelling mutability is a royal pain, but this was already the case when relying on the Assignment type vs a concrete map.
You need to apply your Assignment function to the variable name to get the Int:
eval (Var x) f = f x
This works because f :: Char -> Int and x:: Char, so you can just do f x to get an Int.
Pleasingly this will work across a collection of variable names.
Example
ass :: Assignment
ass 'a' = 1
ass 'b' = 2
meaning that
eval ((Add (Var 'a') (Var 'b')) ass
= eval (Var 'a') ass + eval (Var 'b') ass
= ass 'a' + ass 'b'
= 1 + 2
= 3
Pass the assignment functions through to other calls of eval
You need to keep passing the assignment function around until you get integers:
eval (Add x y) f = eval x f + eval y f
Different order?
If you're allowed to change the types, it seems more logical to me to put the assignment function first and the data second:
eval :: Assignment -> Expr -> Int
eval f (Var x) = f x
eval f (Add x y) = eval f x + eval f y
...but I guess you can think of it as a constant expression with varying variables (feels imperative)rather than a constant set of values across a range of expressions (feels like referential transparency).
I would recommend using Map from Data.Map instead. You could implement it something like
import Data.Map (Map)
import qualified Data.Map as M -- A lot of conflicts with Prelude
-- Used to map operations through Maybe
import Control.Monad (liftM2)
data Expr
= Var Char
| Lit Int
| Add Expr Expr
| Sub Expr Expr
| Mul Expr Expr
deriving (Eq, Show, Read)
type Assignment = Map Char Int
eval :: Expr -> Assignment -> Maybe Int
eval (Lit x) _ = Just x
eval (Add x y) vars = liftM2 (+) (eval x vars) (eval y vars)
eval (Sub x y) vars = liftM2 (-) (eval x vars) (eval y vars)
eval (Mul x y) vars = liftM2 (*) (eval x vars) (eval y vars)
eval (Var x) vars = M.lookup x vars
But this looks clunky, and we'd have to keep using liftM2 op every time we added an operation. Let's clean it up a bit with some helpers
(|+|), (|-|), (|*|) :: (Monad m, Num a) => m a -> m a -> m a
(|+|) = liftM2 (+)
(|-|) = liftM2 (-)
(|*|) = liftM2 (*)
infixl 6 |+|, |-|
infixl 7 |*|
eval :: Expr -> Assignment -> Maybe Int
eval (Lit x) _ = return x -- Use generic return instead of explicit Just
eval (Add x y) vars = eval x vars |+| eval y vars
eval (Sub x y) vars = eval x vars |-| eval y vars
eval (Mul x y) vars = eval x vars |*| eval y vars
eval (Var x) vars = M.lookup x vars
That's a better, but we still have to pass around the vars everywhere, this is ugly to me. Instead, we can use the ReaderT monad from the mtl package. The ReaderT monad (and the non-transformer Reader) is a very simple monad, it exposes a function ask that returns the value you pass in when it's run, where all you can do is "read" this value, and is usually used for running an application with static configuration. In this case, our "config" is an Assignment.
This is where the liftM2 operators really come in handy
-- This is a long type signature, let's make an alias
type ExprM a = ReaderT Assignment Maybe a
-- Eval still has the same signature
eval :: Expr -> Assignment -> Maybe Int
eval expr vars = runReaderT (evalM expr) vars
-- evalM is essentially our old eval function
evalM :: Expr -> ExprM Int
evalM (Lit x) = return x
evalM (Add x y) = evalM x |+| evalM y
evalM (Sub x y) = evalM x |-| evalM y
evalM (Mul x y) = evalM x |*| evalM y
evalM (Var x) = do
vars <- ask -- Get the static "configuration" that is our list of vars
lift $ M.lookup x vars
-- or just
-- evalM (Var x) = ask >>= lift . M.lookup x
The only thing that we really changed was that we have to do a bit extra whenever we encounter a Var x, and we removed the vars parameter. I think this makes evalM very elegant, since we only access the Assignment when we need it, and we don't even have to worry about failure, it's completely taken care of by the Monad instance for Maybe. There isn't a single line of error handling logic in this entire algorithm, yet it will gracefully return Nothing if a variable name is not present in the Assignment.
Also, consider if later you wanted to switch to Doubles and add division, but you also want to return an error code so you can determine if there was a divide by 0 error or a lookup error. Instead of Maybe Double, you could use Either ErrorCode Double where
data ErrorCode
= VarUndefinedError
| DivideByZeroError
deriving (Eq, Show, Read)
Then you could write this module as
data Expr
= Var Char
| Lit Double
| Add Expr Expr
| Sub Expr Expr
| Mul Expr Expr
| Div Expr Expr
deriving (Eq, Show, Read)
type Assignment = Map Char Double
data ErrorCode
= VarUndefinedError
| DivideByZeroError
deriving (Eq, Show, Read)
type ExprM a = ReaderT Assignment (Either ErrorCode) a
eval :: Expr -> Assignment -> Either ErrorCode Double
eval expr vars = runReaderT (evalM expr) vars
throw :: ErrorCode -> ExprM a
throw = lift . Left
evalM :: Expr -> ExprM Double
evalM (Lit x) = return x
evalM (Add x y) = evalM x |+| evalM y
evalM (Sub x y) = evalM x |-| evalM y
evalM (Mul x y) = evalM x |*| evalM y
evalM (Div x y) = do
x' <- evalM x
y' <- evalM y
if y' == 0
then throw DivideByZeroError
else return $ x' / y'
evalM (Var x) = do
vars <- ask
maybe (throw VarUndefinedError) return $ M.lookup x vars
Now we do have explicit error handling, but it isn't bad, and we've been able to use maybe to avoid explicitly matching on Just and Nothing.
This is a lot more information than you really need to solve this problem, I just wanted to present an alternative solution that uses the monadic properties of Maybe and Either to provide easy error handling and use ReaderT to clean up that noise of passing an Assignment argument around everywhere.

SAT solving with haskell SBV library: how to generate a predicate from a parsed string?

I want to parse a String that depicts a propositional formula and then find all models of the propositional formula with a SAT solver.
Now I can parse a propositional formula with the hatt package; see the testParse function below.
I can also run a SAT solver call with the SBV library; see the testParse function below.
Question:
How do I, at runtime, generate a value of type Predicate like myPredicate within the SBV library that represents the propositional formula I just parsed from a String? I only know how to manually type the forSome_ $ \x y z -> ... expression, but not how to write a converter function from an Expr value to a value of type Predicate.
-- cabal install sbv hatt
import Data.Logic.Propositional
import Data.SBV
-- Random test formula:
-- (x or ~z) and (y or ~z)
-- graphical depiction, see: https://www.wolframalpha.com/input/?i=%28x+or+~z%29+and+%28y+or+~z%29
testParse = parseExpr "test source" "((X | ~Z) & (Y | ~Z))"
myPredicate :: Predicate
myPredicate = forSome_ $ \x y z -> ((x :: SBool) ||| (bnot z)) &&& (y ||| (bnot z))
testSat = do
x <- allSat $ myPredicate
putStrLn $ show x
main = do
putStrLn $ show $ testParse
testSat
{-
Need a function that dynamically creates a Predicate
(as I did with the function (like "\x y z -> ..") for an arbitrary expression of type "Expr" that is parsed from String.
-}
Information that might be helpful:
Here is the link to the BitVectors.Data:
http://hackage.haskell.org/package/sbv-3.0/docs/src/Data-SBV-BitVectors-Data.html
Here is example code form Examples.Puzzles.PowerSet:
import Data.SBV
genPowerSet :: [SBool] -> SBool
genPowerSet = bAll isBool
where isBool x = x .== true ||| x .== false
powerSet :: [Word8] -> IO ()
powerSet xs = do putStrLn $ "Finding all subsets of " ++ show xs
res <- allSat $ genPowerSet `fmap` mkExistVars n
Here is the Expr data type (from hatt library):
data Expr = Variable Var
| Negation Expr
| Conjunction Expr Expr
| Disjunction Expr Expr
| Conditional Expr Expr
| Biconditional Expr Expr
deriving Eq
Working With SBV
Working with SBV requires that you follow the types and realize the Predicate is just a Symbolic SBool. After that step it is important that you investigate and discover Symbolic is a monad - yay, a monad!
Now that you you know you have a monad then anything in the haddock that is Symbolic should be trivial to combine to build any SAT you desire. For your problem you just need a simple interpreter over your AST that builds a Predicate.
Code Walk-Through
The code is all included in one continuous form below but I will step through the fun parts. The entry point is solveExpr which takes expressions and produces a SAT result:
solveExpr :: Expr -> IO AllSatResult
solveExpr e0 = allSat prd
The application of SBV's allSat to the predicate is sort of obvious. To build that predicate we need to declare an existential SBool for every variable in our expression. For now lets assume we have vs :: [String] where each string corresponds to one of the Var from the expression.
prd :: Predicate
prd = do
syms <- mapM exists vs
let env = M.fromList (zip vs syms)
interpret env e0
Notice how programming language fundamentals is sneaking in here. We now need an environment that maps the expressions variable names to the symbolic booleans used by SBV.
Next we interpret the expression to produce our Predicate. The interpret function uses the environment and just applies the SBV function that matches the intent of each constructor from hatt's Expr type.
interpret :: Env -> Expr -> Predicate
interpret env expr = do
let interp = interpret env
case expr of
Variable v -> return (envLookup v env)
Negation e -> bnot `fmap` interp e
Conjunction e1 e2 ->
do r1 <- interp e1
r2 <- interp e2
return (r1 &&& r2)
Disjunction e1 e2 ->
do r1 <- interp e1
r2 <- interp e2
return (r1 ||| r2)
Conditional e1 e2 -> error "And so on"
Biconditional e1 e2 -> error "And so on"
And that is it! The rest is just boiler-plate.
Complete Code
import Data.Logic.Propositional hiding (interpret)
import Data.SBV
import Text.Parsec.Error (ParseError)
import qualified Data.Map as M
import qualified Data.Set as Set
import Data.Foldable (foldMap)
import Control.Monad ((<=<))
testParse :: Either ParseError Expr
testParse = parseExpr "test source" "((X | ~Z) & (Y | ~Z))"
type Env = M.Map String SBool
envLookup :: Var -> Env -> SBool
envLookup (Var v) e = maybe (error $ "Var not found: " ++ show v) id
(M.lookup [v] e)
solveExpr :: Expr -> IO AllSatResult
solveExpr e0 = allSat go
where
vs :: [String]
vs = map (\(Var c) -> [c]) (variables e0)
go :: Predicate
go = do
syms <- mapM exists vs
let env = M.fromList (zip vs syms)
interpret env e0
interpret :: Env -> Expr -> Predicate
interpret env expr = do
let interp = interpret env
case expr of
Variable v -> return (envLookup v env)
Negation e -> bnot `fmap` interp e
Conjunction e1 e2 ->
do r1 <- interp e1
r2 <- interp e2
return (r1 &&& r2)
Disjunction e1 e2 ->
do r1 <- interp e1
r2 <- interp e2
return (r1 ||| r2)
Conditional e1 e2 -> error "And so on"
Biconditional e1 e2 -> error "And so on"
main :: IO ()
main = do
let expr = testParse
putStrLn $ "Solving expr: " ++ show expr
either (error . show) (print <=< solveExpr) expr
forSome_ is a member of the Provable class, so it seems it would suffice to define the instance Provable Expr. Almost all functions in SVB use Provable so this would allow you to use all of those natively Expr. First, we convert an Expr to a function which looks up variable values in a Vector. You could also use Data.Map.Map or something like that, but the environment is not changed once created and Vector gives constant time lookup:
import Data.Logic.Propositional
import Data.SBV.Bridge.CVC4
import qualified Data.Vector as V
import Control.Monad
toFunc :: Boolean a => Expr -> V.Vector a -> a
toFunc (Variable (Var x)) = \env -> env V.! (fromEnum x)
toFunc (Negation x) = \env -> bnot (toFunc x env)
toFunc (Conjunction a b) = \env -> toFunc a env &&& toFunc b env
toFunc (Disjunction a b) = \env -> toFunc a env ||| toFunc b env
toFunc (Conditional a b) = \env -> toFunc a env ==> toFunc b env
toFunc (Biconditional a b) = \env -> toFunc a env <=> toFunc b env
Provable essentially defines two functions: forAll_, forAll, forSome_, forSome. We have to generate all possible maps of variables to values and apply the function to the maps. Choosing how exactly to handle the results will be done by the Symbolic monad:
forAllExp_ :: Expr -> Symbolic SBool
forAllExp_ e = (m0 >>= f . V.accum (const id) (V.replicate (fromEnum maxV + 1) false)
where f = return . toFunc e
maxV = maximum $ map (\(Var x) -> x) (variables e)
m0 = mapM fresh (variables e)
Where fresh is a function which "quantifies" the given variable by associating it with all possible values.
fresh :: Var -> Symbolic (Int, SBool)
fresh (Var var) = forall >>= \a -> return (fromEnum var, a)
If you define one of these functions for each of the four functions you will have quite a lot of very repetitive code. So you can generalize the above as follows:
quantExp :: (String -> Symbolic SBool) -> Symbolic SBool -> [String] -> Expr -> Symbolic SBool
quantExp q q_ s e = m0 >>= f . V.accum (const id) (V.replicate (fromEnum maxV + 1) false)
where f = return . toFunc e
maxV = maximum $ map (\(Var x) -> x) (variables e)
(v0, v1) = splitAt (length s) (variables e)
m0 = zipWithM fresh (map q s) v0 >>= \r0 -> mapM (fresh q_) v1 >>= \r1 -> return (r0++r1)
fresh :: Symbolic SBool -> Var -> Symbolic (Int, SBool)
fresh q (Var var) = q >>= \a -> return (fromEnum var, a)
If it is confusing exactly what is happening, the Provable instance may suffice to explain:
instance Provable Expr where
forAll_ = quantExp forall forall_ []
forAll = quantExp forall forall_
forSome_ = quantExp exists exists_ []
forSome = quantExp exists exists_
Then your test case:
myPredicate :: Predicate
myPredicate = forSome_ $ \x y z -> ((x :: SBool) ||| (bnot z)) &&& (y ||| (bnot z))
myPredicate' :: Predicate
myPredicate' = forSome_ $ let Right a = parseExpr "test source" "((X | ~Z) & (Y | ~Z))" in a
testSat = allSat myPredicate >>= print
testSat' = allSat myPredicate >>= print

Writing a haskell program for computing denotational semantics of an imperative programming language

I am trying to write a program in Haskell to compute the denotational semantics of an imperative language program with integer variables, 1-dimensional (integer) arrays and functions. The function I am starting with is of the type:
progsem :: Prog -> State -> State
where State is the following:
type State (Name -> Int, Name -> Int -> Int)
The first part is the value of integer variables, while the second part is the value of an array variable at a particular index.
The program will have the following qualities:
progsem will return the resulting state after the program executes
functions have two parameter lists, one for integer variables, and one for array variables.
functions are call by value result
Here is the abstract syntax for the imperative language:
-- names (variables) are just strings.
type Name = String
-- a program is a series (list) of function definitions, followed by a
-- series of statements.
type Prog = ([FunDefn],[Stmt])
-- a statement is either...
data Stmt =
Assign Name Exp -- ...assignment (<name> := <exp>;)
| If BExp [Stmt] [Stmt] -- ...if-then-else (if <bexp> { <stmt>* } else { <stmt>* })
| While BExp [Stmt] -- ...or a while-loop (while <bexp> { <stmt>*> })
| Let Name Exp [Stmt] -- ...let bindings (let <name>=<exp> in { <stmt> *})
| LetArray Name Exp Exp [Stmt] -- ...let-array binding (letarray <name> [ <exp> ] := <exp> in { <stmt>* })
| Case Exp [(Int,[Stmt])] -- ...case statements
| For Name Exp Exp [Stmt] -- ...for statements
| Return Exp -- ...return statement
| ArrayAssign Name Exp Exp -- ...or array assignment (<name> [ <exp> ] := <exp>;)
deriving Show
-- an integer expression is either...
data Exp =
Add Exp Exp -- ...addition (<exp> + <exp>)
| Sub Exp Exp -- ...subtract (<exp> - <exp>)
| Mul Exp Exp -- ...multiplication (<exp> * <exp>)
| Neg Exp -- ...negation (-<exp>)
| Var Name -- ...a variable (<name>)
| LitInt Int -- ...or an integer literal (e.g. 3, 0, 42, 1999)
| FunCall Name [Exp] [Name] -- ...or a function call (<name> (<exp>,...,<exp> [; <name>,...,<name>]))
| VarArray Name Exp -- ...or an array lookup (<name> [ <exp> ])
deriving Show
-- a boolean expression is either...
data BExp =
IsEq Exp Exp -- ...test for equality (<exp> == <exp>)
| IsNEq Exp Exp -- ...test for inequality (<exp> != <exp>)
| IsGT Exp Exp -- ...test for greater-than (<exp> > <exp>)
| IsLT Exp Exp -- ...test for less-than (<exp> < <exp>)
| IsGTE Exp Exp -- ...test for greater-or-equal (<exp> >= <exp>)
| IsLTE Exp Exp -- ...test for less-or-equal (<exp> <= <exp>)
| And BExp BExp -- ...boolean and (<bexp> && <bexp>)
| Or BExp BExp -- ...boolean or (<bexp> || <bexp>)
| Not BExp -- ...boolean negation (!<bexp>)
| LitBool Bool -- ... or a boolean literal (true or false)
deriving Show
type FunDefn = (Name,[Name],[Name],[Stmt])
Now, I do not have a specific question, but I was wondering if someone could point me in the right direction on how to go about writing the semantics.
In the past I have done something similar for an imperative programming language without arrays and functions. It looked something like this:
expsem :: Exp -> State -> Int
expsem (Add e1 e2) s = (expsem e1 s) + (expsem e2 s)
expsem (Sub e1 e2) s = (expsem e1 s) - (expsem e2 s)
expsem (Mul e1 e2) s = (expsem e1 s) * (expsem e2 s)
expsem (Neg e) s = -(expsem e s)
expsem (Var x) s = s x
expsem (LitInt m) _ = m
boolsem :: BExp -> State -> Bool
boolsem (IsEq e1 e2) s = expsem e1 s == expsem e2 s
boolsem (IsNEq e1 e2) s= not(expsem e1 s == expsem e2 s)
boolsem (IsGT e1 e2) s= expsem e1 s > expsem e2 s
boolsem (IsGTE e1 e2) s= expsem e1 s >= expsem e2 s
boolsem (IsLT e1 e2) s= expsem e1 s < expsem e2 s
boolsem (IsLTE e1 e2) s= expsem e1 s <= expsem e2 s
boolsem (And b1 b2) s= boolsem b1 s && boolsem b2 s
boolsem (Or b1 b2) s= boolsem b1 s || boolsem b2 s
boolsem (Not b) s= not (boolsem b s)
boolsem (LitBool x) _= x
stmtsem :: Stmt -> State -> State
stmtsem (Assign x e) s = (\z -> if (z==x) then expsem e s else s z)
stmtsem (If b pt pf) s = if (boolsem b s) then (progsem pt s) else (progsem pf s)
stmtsem (While b p) s = if (boolsem b s) then stmtsem (While b p) (progsem p s) else s
stmtsem (Let x e p) s = s1 where
initvalx = s x
letvalx = expsem e s
snew = progsem p (tweak s x letvalx)
s1 z = if (z == x) then initvalx else snew z
tweak :: State->Name->Int->State
tweak s vr n = \y -> if vr == y then n else s y
progsem :: Prog -> State -> State
progsem smlist s0 = (foldl (\s -> \sm -> (stmtsem sm s)) (s0) ) smlist
s :: State
s "x" = 10
Where states were of the type
type State= Name -> Int
Like I said, I do not need an in depth answer, but any help/hints/pointers would be much appreciated.
I'll deviate a bit from your given code and indicate how you might start to write a monadic interpreter which encodes the evaluation semantics for an toy imperative language, much like the one you specified. You'll need a frontend AST like you have:
import Control.Monad.State
import qualified Data.Map as Map
data Expr = Var Var
| App Expr Expr
| Fun Var Expr
| Lit Ground
| If Expr Expr Expr
-- Fill in the rest
deriving (Show, Eq, Ord)
data Ground = LInt Integer
| LBool Bool
deriving (Show, Eq, Ord)
We will evaluate via a function eval into concrete Value types.
data Value = VInt Integer
| VBool Bool
| VUnit
| VAddress Int
| VClosure String Expr TermEnv
type TermEnv = Map.Map String Value
type Memory = [Value]
type Interpreter t = State Memory t
eval :: TermEnv -> Expr -> State Memory Value
eval _ (Lit (LInt k)) = return $ VInt k
eval _ (Lit (LBool k)) = return $ VBool k
eval env (Fun x body) = return (VClosure x body env)
eval env (App fun arg) = do
VClosure x body clo <- eval env fun
res <- eval env fun
args <- eval env arg
let nenv = Map.insert x args clo
eval nenv body
eval env (Var x) = case (Map.lookup x env) of
Just v -> return v
Nothing -> error "prevent this statically!"
eval env (If cond tr fl) = do
VBool br <- eval env cond
if br == True
then eval env tr
else eval env fl
-- Finish with the rest of your syntax.
programs will return the resulting state after the program executes
To run the interpreter we need to feed it two values: the binding environment of variables and the values on the heap. This will return a tuple of the resulting value and the memory state which you can then feed back to the function itself if building a REPL-like loop.
runInterpreter :: TermEnv -> Memory -> Expr -> (Value, [Value])
runInterpreter env mem x = runState (eval env x) mem
initMem = []
initTermEnv = Map.empty
Since you're writing an imperative language likely you'll want to add state and references, so you can create new AST nodes working allocating and mutating Refs. Left for you to do is to add the logic for allocating an Array as a sequence of Refs and using pointer arithmetic when indexing and assigning into it.
data Expr = -- Same as above
| Ref Expr
| Access Expr
| Assign Expr Expr
eval :: TermEnv -> Expr -> State Memory Value
...
eval env (Ref e) = do
ev <- eval env e
alloc ev
eval env (Access a) = do
VAddress i <- eval env a
readAddr i
eval env (Assign a e) = do
VAddress i <- eval env a
ev <- eval env e
updateAddr ev i
With this we'll need some helper functions for dealing with the values on the heap which are just thin wrappers around the State monad functions.
access :: Int -> Memory -> Value
access i mem = mem !! i
update :: Int -> Value -> Memory -> Memory
update addr val mem = a ++ [val] ++ b
where
(a, _:b) = splitAt addr mem
alloc :: Value -> Interpreter Value
alloc val = do
mem <- get
put $ mem ++ [val]
return $ VAddress (length mem)
readAddr :: Int -> Interpreter Value
readAddr i = do
mem <- get
return $ access i mem
updateAddr :: Value -> Int -> Interpreter Value
updateAddr val i = do
mem <- get
put $ update i val mem
return VUnit
Hope that helps get you started.

Resources