Feval: F-Algebras for expression evaluation

Basic Background

data Addition a = Num Int | Add a a

a

4 + 3 + 2

newtype Fix f = Fx (f (Fix f))

4 + 3 + 2

expr = Fx $ Add (Fx $ Add (Fx $ Num 4) (Fx $ Num 3)) (Fx $ Num 2)

type Algebra f a = f a -> a

unFix :: Fix f -> f (Fix f) unFix (Fx x) = x cata :: Functor f => Algebra f a -> Fix f -> a cata alg = alg . fmap (cata alg) . unFix

instance Functor Addition where fmap f (Num i) = Num i fmap f (Add x y) = Add (f x) (f y)

alg :: Algebra Addition Int alg (Num i) = i alg (Add x y) = x + y

eval :: Fix Addition -> Int eval e = cata alg e

Onto Eval

1. What happens if the evaluation fails at some point in the expression? (Consider the expression 4 + True )

) 2. How can we delay evaluation until it is applicable? (We cannot evaluate Function x -> x + 8 until we know the value applied to x)

Maybe

Nothing

Maybe

Maybe

type MAlgebra m f a = f (m a) -> m a

mcata :: Functor f => MAlgebra m f a -> Fix f -> m a mcata alg = alg . fmap (mcata alg) . unFix

{-# LANGUAGE DeriveFunctor #-}

data DumbAddition a = Num Int | Buul Bool | Add a a deriving Functor

alg :: MAlgebra Maybe DumbAddition Int alg (Num i) = Just i alg (Buul b) = Nothing alg (Add x y) = do n Maybe Int eval e = mcata alg e

{-# LANGUAGE FlexibleInstances #-}

data Iffy a b = Buul Bool | And b b | If b a a -- If b Then a Else a deriving Functor

Fix

newtype LazyFix f = Fx' (f (LazyFix f) (LazyFix f)) lazyUnFix :: LazyFix f -> f (LazyFix f) (LazyFix f) lazyUnFix (Fx' x) = x

a

Iffy

lazyCata :: Functor (f (LazyFix f)) => Algebra (f (LazyFix f)) a -> LazyFix f -> a lazyCata alg = alg . fmap (lazyCata alg) . lazyUnFix

b

Iffy

alg :: Algebra (Iffy (LazyFix Iffy)) Bool alg (Buul b) = b alg (And x y) = x && y alg (If p x y) = if p then eval x else eval y eval :: LazyFix Iffy -> Bool eval e = lazyCata alg e

lazyMCata :: Functor (f (LazyFix f)) => MAlgebra m (f (LazyFix f)) a -> LazyFix f -> m a lazyMCata alg = alg . fmap (lazyMCata alg) . lazyUnFix

Maybe

data FunBool a b = Buul Bool | Var String | And b b | Or b b | Function String a | Appl b a -- Function application deriving Functor

data RVal = RBool Bool | RFunction String (LazyFix FunBool) -- Substitute a value in for a variable substitute :: String -> LazyFix FunBool -> LazyFix FunBool -> LazyFix FunBool substitute _ _ (Fx' (Buul b)) = Fx' $ Buul b substitute s v (Fx' (Var s')) = if s' == s then v else Fx' $ Var s' substitute s v (Fx' (And x y)) = Fx' $ And (substitute s v x) (substitute s v y) substitute s v (Fx' (Or x y)) = Fx' $ Or (substitute s v x) (substitute s v y) substitute s v (Fx' (Function x p)) = if x == s then Fx' $ Function x p else Fx' $ Function x $ substitute s v p substitute s v (Fx' (Appl x y)) = Fx' $ Appl (substitute s v x) (substitute s v y) boolean_operation :: (Bool -> Bool -> Bool) -> RVal -> RVal -> Maybe RVal boolean_operation f (RBool x) (RBool y) = Just . RBool $ f x y convert :: RVal -> LazyFix FunBool convert (RBool b) = Fx' $ Buul b convert (RFunction x p) = Fx' $ Function x p apply :: RVal -> LazyFix FunBool -> Maybe RVal apply (RFunction x p) e = eval e >>= \v -> eval $ substitute x (convert v) p apply _ _ = Nothing alg :: MAlgebra Maybe (FunBool (LazyFix FunBool)) RVal alg (Buul b) = Just $ RBool b alg (Var s) = Nothing alg (And x y) = x >>= \x' -> y >>= \y' -> boolean_operation (&&) x' y' alg (Or x y) = x >>= \x' -> y >>= \y' -> boolean_operation (||) x' y' alg (Function x p) = Just $ RFunction x p alg (Appl f x) = f >>= \f' -> apply f' x eval :: LazyFix FunBool -> Maybe RVal eval e = lazyMCata alg e

Translation

eval

data SmallLanguage a = Num Int | Buul Bool | Not a | And a a | Or a a | Equal a a | LessThan a a | Function String a | Appl a a

data BiggerLanguage a = BNum Int | BBuul Bool | BNot a | BAnd a a | BOr a a | BEqual a a | BLessThan a a | BLessThanOrEqual a a | BGreaterThan a a | BGreaterThanOrEqual a a | BFunction String a | BAppl a a | BLet String a a -- Let s = a In a deriving Functor

alg :: Algebra BiggerLanguage (Fix SmallLanguage) alg (BNum i) = Fx $ Num i alg (BBuul b) = Fx $ Buul b alg (BNot b) = Fx $ Not b alg (BAnd x y) = Fx $ And x y alg (BOr x y) = Fx $ Or x y alg (BEqual x y) = Fx $ Equal x y alg (BLessThan x y) = Fx $ LessThan x y alg (BLessThanOrEqual x y) = Fx $ Or (Fx $ LessThan x y) (Fx $ Equal x y) alg (BGreaterThan x y) = Fx . Not . Fx $ Or (Fx $ LessThan x y) (Fx $ Equal x y) alg (BGreaterThanOrEqual x y) = Fx . Not . Fx $ LessThan x y alg (BFunction s p) = Fx $ Function s p alg (BAppl x y) = Fx $ Appl x y alg (BLet s x y) = Fx $ Appl (Fx $ Function s y) x

translate :: Fix BiggerLanguage -> Fix SmallLanguage translate e = cata alg e

Types Abound

Add x y

x = Int

y = Int

data AddOr a = Num Int | Buul Bool | Add a a | Or a a deriving Functor

import qualified Data.Set as Set data Type = TInt | TBool deriving (Eq, Ord) type Equation = (Type, Type) type Equations = Set.Set Equation -- Add both the equation and its reflection addEquation :: Equation -> Equations -> Equations addEquation (t, t') e = Set.insert (t, t') $ Set.insert (t', t) e doubleAdd :: Equation -> Equation -> Equations -> Equations -> Equations doubleAdd (t, t') (s, s') e e' = addEquation (t, t') $ addEquation (s, s') $ Set.union e e' type TypeAndEquations = (Type, Equations) alg :: Algebra AddOr TypeAndEquations alg (Num _) = (TInt, Set.empty) alg (Buul _) = (TBool, Set.empty) alg (Add (t, e) (t', e')) = (TInt, doubleAdd (t, TInt) (t', TInt) e e') alg (Or (t, e) (t', e')) = (TBool, doubleAdd (t, TBool) (t', TBool) e e')

TypeAndEquations

-- The boolean value in this means that the equation was not already in the set addNew :: Equation -> Equations -> (Bool, Equations) addNew eq e = if Set.member eq e then (False, e) else (True, Set.insert eq e) -- The boolean value in this means that something new has been added addTransitives :: Equations -> (Bool, Equations) addTransitives e = Set.foldr process (False, e) e where process (t, t') (b, e) = Set.foldr (addMatch t t') (b, e) e addMatch t t' (s, s') (b, e) = if s == t' then let (b', e') = addNew (t, s') e in (b || b', e') else (b, e) close :: Equations -> Equations close e = let (b, e') = addTransitives e in if b then close e' else e'

TBool = TInt

inconsistent :: Equations -> Bool inconsistent e = Set.foldr check False e where check (TInt, TBool) _ = True -- Recall that we have added all reflections check _ b = b

typecheck :: Fix AddOr -> Maybe Type typecheck a = let (t, e) = cata alg a in let e' = close e in if inconsistent e' then Nothing else Just t

Function x -> x + 5

TVar 0

x

x + 5

{TVar 0 = TInt, TInt = TInt}

TVar 0 -> TInt

TInt -> TInt

Function

x

data FunAdd a b = Num Int | Var String | Add b b | Function String a | Appl b b deriving Functor

Type

data Type = TInt | TVar Int -- Our type variable | TArrow Type Type | NotClosed deriving (Eq, Ord)

NotClosed

Function x -> y

y

import Control.Monad.State type Counter = State Int doNothing :: Counter Int doNothing = state (\i -> (i, i)) newHandle :: Counter Int newHandle = state (\i -> (i, i + 1))

import Control.Applicative -- The assignments of arguments to type variables type Hypotheses = [(String, Type)] lookupVar :: String -> Hypotheses -> Maybe Type lookupVar v h = foldr check Nothing h where check (s, t) Nothing = if s == v then Just t else Nothing check _ r = r alg :: Hypotheses -> MAlgebra Counter (FunAdd (LazyFix FunAdd)) TypeAndEquations alg _ (Num _) = (\_ -> (TInt, Set.empty)) doNothing alg h (Var s) = (\_ -> let r = lookupVar s h in case r of Nothing -> (NotClosed, Set.insert (NotClosed, NotClosed) Set.empty) Just t -> (t, Set.empty)) doNothing alg _ (Add x y) = (\(t, e) (t', e') -> (TInt, doubleAdd (t, TInt) (t', TInt) e e')) x y alg h (Function x p) = newHandle >>=

-> let v = TVar n in typecheck' ((x, v) : h) p >>= \(t, e) -> return (TArrow v t, e) alg _ (Appl x y) = (

(t, e) (t', e') -> let v = TVar n in (v, addEquation (t, TArrow t' v) (Set.union e e'))) newHandle x y typecheck' :: Hypotheses -> LazyFix FunAdd -> Counter TypeAndEquations typecheck' g e = lazyMCata (alg g) e typecheck :: LazyFix FunAdd -> Maybe Type typecheck e = let (t, e') = evalState (typecheck' [] e) 0 in let e'' = close e' in if inconsistent e'' then Nothing else Just (substitute t e'')

doubleAddNew :: Equation -> Equation -> Equations -> (Bool, Equations) doubleAddNew eq eq' e = let (b, e') = addNew eq e in let (b', e'') = addNew eq' e' in (b || b', e'') addArrows :: Equations -> (Bool, Equations) addArrows e = Set.foldr process (False, e) e where process (TArrow t t', TArrow s s') (b, e) = let (b', e') = doubleAddNew (t, s) (t', s') e in (b || b', e') close' :: Equations -> (Bool, Equations) close' e = let (b, e') = addTransitives e in let (b', e'') = addArrows e' in (b || b', e'') close :: Equations -> Equations close e = let (b, e') = close' e in if b then close e' else e' inconsistent :: Equations -> Bool inconsistent e = Set.foldr check False e where check (TInt, TArrow _ _) _ = True check (NotClosed, _) _ = True check _ b = b

-- This function chooses the best possible substitution choose :: Int -> Equations -> Equation -> Type -> Type choose _ _ _ TInt = TInt choose n e (TVar n', y) (TVar n'') = if n /= n' then TVar n'' else case y of TInt -> TInt TArrow x y -> TArrow (substitute x e) (substitute y e) TVar n' -> if n' < n then if n'' < n' then TVar n'' else TVar n' else if n'' < n then TVar n'' else TVar n choose _ _ _ r = r substitute :: Type -> Equations -> Type substitute TInt _ = TInt substitute (TVar n) e = Set.fold (choose n e) (TVar n) e substitute (TArrow x y) e = TArrow (substitute x e) (substitute y e)

Afterword

Let f x = If f = 0 Then 0 Else x + f (x - 1)

Let compare x y = If x > y Then -1 Else If x = y Then 0 Else 1 In Let combine x y = Case x Of [] -> y | (z : zs) -> Case y Of [] -> x | (w : ws) -> Let r = compare z w In If r <= 0 Then w : z : combine zs ws Else z : w : combine zs ws In Let mergesort x = Case x Of [] -> [] | (y : ys) -> Case ys Of [] -> [y] | (a : b) -> Let mergesort' x l r = Case x Of [] -> combine (mergesort l) (mergesort r) | (z : zs) -> Case zs Of [] -> combine (mergesort (z : l)) (mergesort r) | (w : ws) -> mergesort' ws (z : l) (w : r) In mergesort' x [] [] In mergesort [4, 23, -34, 3]

Please enable JavaScript to view the comments powered by Disqus.

Disqus