Commit f86cf0cf authored by Sven Keidel's avatar Sven Keidel

extract new arrow transformers into the library

parent 4b24541f
......@@ -5,7 +5,7 @@ module Control.Arrow.Class.Fix(ArrowFix(..),ArrowFix'(..)) where
import Control.Arrow
class Arrow c => ArrowFix x y c | c -> y, c -> x where
class Arrow c => ArrowFix x y c where
fixA :: (c x y -> c x y) -> c x y
class Arrow c => ArrowFix' c y | c -> y where
......
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Class.Property where
import Control.Arrow
class Arrow c => HasProp p c where
modifyProp :: (c (x,p) p) -> c x ()
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Class.Store where
import Prelude hiding (lookup,id)
import Control.Arrow
class Arrow c => ArrowStore var val c | c -> var, c -> val where
lookup :: c var val
store :: c (var,val) ()
module Control.Arrow.Property
(module Control.Arrow.Class.Property,
module Control.Arrow.Transformer.Property
) where
import Control.Arrow.Class.Property
import Control.Arrow.Transformer.Property
module Control.Arrow.Store
(module Control.Arrow.Class.Store) where
import Control.Arrow.Class.Store
......@@ -16,6 +16,7 @@ import Control.Arrow.Class.State
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Fix
import Control.Arrow.Transformer.Reader
import Control.Category
......@@ -26,93 +27,78 @@ import Data.Hashable
import Data.Sequence (Seq,(|>))
import qualified Data.Sequence as S
data Contour l = Contour {
contour :: Seq (Hashed l),
data Contour = Contour {
contour :: Seq Label,
size :: Int,
maxSize :: Int
}
instance Show l => Show (Contour l) where
instance Show Contour where
show = show . toList
instance Eq l => Eq (Contour l) where
instance Eq Contour where
c1 == c2 = contour c1 == contour c2
instance Hashable (Contour l) where
instance Hashable Contour where
hashWithSalt s = hashWithSalt s . F.toList . contour
empty :: Int -> Contour l
empty :: Int -> Contour
empty m = Contour S.empty 0 m
push :: Hashable l => l -> Contour l -> Contour l
push l (Contour {..}) = resize (Contour (contour |> hashed l) (size + 1) maxSize)
push :: Label -> Contour -> Contour
push l (Contour {..}) = resize (Contour (contour |> l) (size + 1) maxSize)
resize :: Contour l -> Contour l
resize :: Contour -> Contour
resize cont@(Contour {..})
| size > maxSize = Contour (S.drop (size - maxSize) contour) maxSize maxSize
| otherwise = cont
toList :: Contour l -> [l]
toList = map unhashed . F.toList . contour
toList :: Contour -> [Label]
toList = F.toList . contour
newtype ContourArrow l c a b = ContourArrow (Contour l -> c a b)
newtype ContourArrow c a b = ContourArrow (ReaderArrow Contour c a b)
liftContour :: c a b -> ContourArrow l c a b
liftContour f = ContourArrow (const f)
liftContour :: Arrow c => c a b -> ContourArrow c a b
liftContour f = ContourArrow (liftReader f)
runContourArrow :: Int -> ContourArrow l c a b -> c a b
runContourArrow n (ContourArrow f) = f (empty n)
runContourArrow :: Arrow c => Int -> ContourArrow c a b -> c a b
runContourArrow n (ContourArrow (ReaderArrow f)) = (\a -> (empty n,a)) ^>> f
instance Arrow c => Category (ContourArrow l c) where
id = liftContour id
ContourArrow f . ContourArrow g = ContourArrow $ \l -> (f l . g l)
deriving instance Arrow c => Category (ContourArrow c)
deriving instance Arrow c => Arrow (ContourArrow c)
deriving instance ArrowChoice c => ArrowChoice (ContourArrow c)
deriving instance ArrowState s c => ArrowState s (ContourArrow c)
instance ArrowApply c => ArrowApply (ContourArrow c) where
app = ContourArrow $ (\(ContourArrow f,x) -> (f,x)) ^>> app
instance Arrow c => Arrow (ContourArrow l c) where
arr f = liftContour (arr f)
first (ContourArrow f) = ContourArrow (first . f)
second (ContourArrow f) = ContourArrow (second . f)
instance ArrowChoice c => ArrowChoice (ContourArrow l c) where
left (ContourArrow f) = ContourArrow (left . f)
right (ContourArrow f) = ContourArrow (right . f)
instance ArrowApply c => ArrowApply (ContourArrow l c) where
app = ContourArrow $ \l -> (\(ContourArrow f,x) -> (f l,x)) ^>> app
instance ArrowReader r c => ArrowReader r (ContourArrow l c) where
instance ArrowReader r c => ArrowReader r (ContourArrow c) where
askA = liftContour askA
localA (ContourArrow f) = ContourArrow $ \l -> (\(r,x) -> (r,x)) ^>> localA (f l)
instance ArrowState s c => ArrowState s (ContourArrow l c) where
getA = liftContour getA
putA = liftContour putA
instance ArrowFail e c => ArrowFail e (ContourArrow l c) where
failA = liftContour failA
localA (ContourArrow (ReaderArrow f)) = ContourArrow (ReaderArrow ((\(c,(r,x)) -> (r,(c,x))) ^>> localA f))
instance ArrowEnv x y env c => ArrowEnv x y env (ContourArrow l c) where
deriving instance ArrowFail e c => ArrowFail e (ContourArrow c)
instance ArrowEnv x y env c => ArrowEnv x y env (ContourArrow c) where
lookup = liftContour lookup
getEnv = liftContour getEnv
extendEnv = liftContour extendEnv
localEnv (ContourArrow f) = ContourArrow $ \l -> (\(r,x) -> (r,x)) ^>> localEnv (f l)
localEnv (ContourArrow (ReaderArrow f)) = ContourArrow (ReaderArrow ((\(c,(r,x)) -> (r,(c,x))) ^>> localEnv f))
instance (ArrowFix x y c, ArrowApply c, Label x l, Hashable l) => ArrowFix x y (ContourArrow l c) where
instance (ArrowFix x y c, ArrowApply c, HasLabel x) => ArrowFix x y (ContourArrow c) where
-- Pushes the label of the last argument on the contour.
fixA f = ContourArrow $ \l -> proc x -> fixA (unlift l . f . lift) -<< x
fixA f = ContourArrow $ ReaderArrow $ proc (c,x) -> fixA (unlift c . f . lift) -<< x
where
lift :: c x y -> ContourArrow l c x y
lift :: Arrow c => c x y -> ContourArrow c x y
lift = liftContour
unlift :: (Hashable l, Label x l, ArrowApply c) => Contour l -> ContourArrow l c x y -> c x y
unlift cont (ContourArrow f') = proc x -> do
y <- f' (push (getLabel x) cont) -<< x
unlift :: (HasLabel x, ArrowApply c) => Contour -> ContourArrow c x y -> c x y
unlift c (ContourArrow (ReaderArrow f')) = proc x -> do
y <- f' -< (push (label x) c, x)
returnA -< y
instance Arrow c => ArrowAlloc var (var,Contour l) val (ContourArrow l c) where
alloc = ContourArrow $ \l -> proc (x,_,_) -> returnA -< (x,l)
instance Arrow c => ArrowAlloc var (var,Contour) val (ContourArrow c) where
alloc = ContourArrow $ ReaderArrow $ proc (l,(x,_,_)) -> returnA -< (x,l)
deriving instance PreOrd (c x y) => PreOrd (ContourArrow l c x y)
deriving instance LowerBounded (c x y) => LowerBounded (ContourArrow l c x y)
deriving instance Complete (c x y) => Complete (ContourArrow l c x y)
deriving instance CoComplete (c x y) => CoComplete (ContourArrow l c x y)
deriving instance UpperBounded (c x y) => UpperBounded (ContourArrow l c x y)
deriving instance PreOrd (c (Contour,x) y) => PreOrd (ContourArrow c x y)
deriving instance LowerBounded (c (Contour,x) y) => LowerBounded (ContourArrow c x y)
deriving instance Complete (c (Contour,x) y) => Complete (ContourArrow c x y)
deriving instance CoComplete (c (Contour,x) y) => CoComplete (ContourArrow c x y)
deriving instance UpperBounded (c (Contour,x) y) => UpperBounded (ContourArrow c x y)
......@@ -19,7 +19,7 @@ import Control.Monad (join)
import Data.Order
newtype EitherArrow e c x y = EitherArrow { runEitherArrow :: c x (Either e y)}
newtype EitherArrow e c x y = EitherArrow { runEitherArrow :: c x (Either e y) }
liftEither :: Arrow c => c x y -> EitherArrow e c x y
liftEither f = EitherArrow (f >>> arr Right)
......
......@@ -18,30 +18,30 @@ import Debug.Trace
import Text.Printf
#endif
newtype Fix a b x y = Fix { runFix :: x -> y }
newtype Fix x y = Fix { runFix :: x -> y }
deriving (Arrow,ArrowChoice,ArrowApply)
liftFix :: (x -> y) -> Fix a b x y
liftFix :: (x -> y) -> Fix x y
liftFix = Fix
deriving instance Category (Fix a b)
deriving instance Category Fix
#ifdef TRACE
instance (Show x, Show y) => ArrowFix x y (Fix x y) where
instance (Show x, Show y) => ArrowFix x y Fix where
fixA f = Fix (\x -> let y = runFix (f (fixA f)) x in trace (printf "%s <- eval(%s)" (show y) (show x)) y)
#else
instance ArrowFix x y (Fix x y) where
instance ArrowFix x y Fix where
fixA f = Fix (runFix (f (fixA f)))
#endif
deriving instance PreOrd y => PreOrd (Fix a b x y)
deriving instance LowerBounded y => LowerBounded (Fix a b x y)
deriving instance Complete y => Complete (Fix a b x y)
deriving instance PreOrd y => PreOrd (Fix x y)
deriving instance LowerBounded y => LowerBounded (Fix x y)
deriving instance Complete y => Complete (Fix x y)
--deriving instance CoComplete y => CoComplete (Fix a b x y)
instance CoComplete y => CoComplete (Fix a b x y) where
instance CoComplete y => CoComplete (Fix x y) where
Fix f Fix g = Fix (\x -> f x g x)
--deriving instance UpperBounded y => UpperBounded (Fix a b x y)
instance UpperBounded y => UpperBounded (Fix a b x y) where
instance UpperBounded y => UpperBounded (Fix x y) where
top = Fix $ const top
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Property where
import Prelude hiding ((.))
import Control.Arrow
import Control.Arrow.Transformer.State
import Control.Arrow.Class.State
import Control.Arrow.Class.Reader
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Fix
import Control.Arrow.Class.Property
import Control.Category
newtype PropertyArrow p c x y = PropertyArrow (StateArrow p c x y)
liftProperty :: Arrow c => c x y -> PropertyArrow p c x y
liftProperty f = PropertyArrow (liftState f)
runProperty :: PropertyArrow p c x y -> c (p,x) (p,y)
runProperty (PropertyArrow (StateArrow f)) = f
instance Arrow c => HasProp p (PropertyArrow p c) where
modifyProp (PropertyArrow (StateArrow f)) =
PropertyArrow (StateArrow ((\(p,x) -> (p,(x,p))) ^>> f >>^ (\(_,p) -> (p,()))))
deriving instance Category c => Category (PropertyArrow p c)
deriving instance Arrow c => Arrow (PropertyArrow p c)
deriving instance ArrowChoice c => ArrowChoice (PropertyArrow p c)
deriving instance ArrowReader r c => ArrowReader r (PropertyArrow p c)
deriving instance ArrowFail e c => ArrowFail e (PropertyArrow p c)
instance ArrowApply c => ArrowApply (PropertyArrow p c) where
app = PropertyArrow (StateArrow (arr (\(p,(PropertyArrow (StateArrow f),b)) -> (f,(p,b))) >>> app))
instance ArrowState s c => ArrowState s (PropertyArrow p c) where
getA = liftProperty getA
putA = liftProperty putA
instance ArrowFix (p,x) (p,y) c => ArrowFix x y (PropertyArrow p c) where
fixA f = PropertyArrow (StateArrow (fixA (runProperty . f . PropertyArrow . StateArrow)))
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Store where
import Control.Category
import Control.Arrow
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Store
import Control.Arrow.Transformer.State
import Data.Store (Store)
import qualified Data.Store as S
import Data.Order
import Data.Hashable
import Text.Printf
newtype StoreArrow var val c x y = StoreArrow (StateArrow (Store var val) c x y)
liftStore :: Arrow c => c x y -> StoreArrow var val c x y
liftStore f = StoreArrow (StateArrow (second f))
instance (Show var, Eq var, Hashable var, ArrowFail String c, ArrowChoice c, Complete (c ((Store var val,val),var) (Store var val,val))) =>
ArrowStore var val (StoreArrow var val c) where
lookup =
StoreArrow $ StateArrow $ proc (s,var) -> case S.lookup var s of
Just v -> joined returnA (proc var -> failA -< printf "could not find variable" (show var)) -< ((s,v),var)
Nothing -> failA -< printf "could not find variable" (show var)
store = StoreArrow (StateArrow (arr (\(s,(x,v)) -> (S.insert x v s,()))))
deriving instance Category c => Category (StoreArrow var val c)
deriving instance Arrow c => Arrow (StoreArrow var val c)
deriving instance ArrowChoice c => ArrowChoice (StoreArrow var val c)
deriving instance ArrowReader r c => ArrowReader r (StoreArrow var val c)
instance ArrowState s c => ArrowState s (StoreArrow var val c) where
getA = liftStore getA
putA = liftStore putA
deriving instance ArrowFail e c => ArrowFail e (StoreArrow var val c)
deriving instance PreOrd (c (Store var val,x) (Store var val,y)) => PreOrd (StoreArrow var val c x y)
deriving instance Complete (c (Store var val,x) (Store var val,y)) => Complete (StoreArrow var val c x y)
deriving instance CoComplete (c (Store var val,x) (Store var val,y)) => CoComplete (StoreArrow var val c x y)
deriving instance UpperBounded (c (Store var val,x) (Store var val,y)) => UpperBounded (StoreArrow var val c x y)
deriving instance LowerBounded (c (Store var val,x) (Store var val,y)) => LowerBounded (StoreArrow var val c x y)
......@@ -93,6 +93,7 @@ zipError :: Eq e => (Error e a1, Error e a2) -> Error e (a1,a2)
zipError (Bot, Bot) = Bot
zipError (Error e1, Error e2) | e1 == e2 = Error e1
zipError (Success a1, Success a2) = Success (a1, a2)
zipError _ = error "cannot zip these error values"
mapError :: (a1 -> b1) -> (a2 -> b2) -> Error e (a1, a2) -> Error e (b1, b2)
mapError _ _ Bot = Bot
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Label where
import Data.Hashable
import Control.Monad.State
-- Retrieves label from expression.
class Label x l | x -> l where
getLabel :: x -> l
class HasLabel x where
label :: x -> Label
newtype Label = Label { labelVal :: Int }
deriving (Ord,Eq,Hashable,Num)
instance Show Label where
show (Label l) = show l
fresh :: State Label Label
fresh = state (\l -> (l,l+1))
generate :: State Label x -> x
generate m = evalState m 0
......@@ -52,7 +52,9 @@ library
Control.Arrow.Fix,
Control.Arrow.Reader,
Control.Arrow.Powerset,
Control.Arrow.Property,
Control.Arrow.State,
Control.Arrow.Store,
Control.Arrow.Try,
Control.Arrow.Utils
......@@ -65,17 +67,20 @@ library
Control.Arrow.Class.Environment,
Control.Arrow.Class.Fail,
Control.Arrow.Class.Fix,
Control.Arrow.Class.Property,
Control.Arrow.Class.Reader,
Control.Arrow.Class.State,
Control.Arrow.Class.Store,
Control.Arrow.Transformer.BoundedEnvironment,
Control.Arrow.Transformer.Contour,
Control.Arrow.Transformer.Either,
Control.Arrow.Transformer.Environment,
Control.Arrow.Transformer.FixCache,
Control.Arrow.Transformer.Fix,
Control.Arrow.Transformer.Error,
Control.Arrow.Transformer.Fix,
Control.Arrow.Transformer.FixCache,
Control.Arrow.Transformer.Powerset,
Control.Arrow.Transformer.Property,
Control.Arrow.Transformer.Reader,
Control.Arrow.Transformer.State
......
......@@ -4,28 +4,32 @@
{-# LANGUAGE DeriveGeneric #-}
module Concrete where
import Prelude
import Prelude
import Control.Arrow
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Environment
import Data.Error
import Data.Environment (Env)
import Data.Hashable
import Data.Text (Text)
import GHC.Generics
import Control.Arrow
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Environment
import Control.Monad.State
import PCF (Expr(..))
import Shared
import Data.Error
import Data.Environment (Env)
import Data.Hashable
import Data.Text (Text)
import Data.Label
import GHC.Generics
import PCF (Expr(..))
import Shared
data Closure = Closure Expr (Env Text Val) deriving (Eq,Generic)
data Val = NumVal Int | ClosureVal Closure deriving (Eq,Generic)
type Interp = Environment Text Val (ErrorArrow String (Fix (Env Text Val,Expr) (Error String Val)))
type Interp = Environment Text Val (ErrorArrow String Fix)
evalConcrete :: [(Text,Val)] -> Expr -> Error String Val
evalConcrete env e = runFix (runErrorArrow (runEnvironment eval)) (env,e)
evalConcrete :: [(Text,Val)] -> State Label Expr -> Error String Val
evalConcrete env e = runFix (runErrorArrow (runEnvironment eval)) (env,generate e)
instance IsVal Val Interp where
succ = proc x -> case x of
......
......@@ -16,6 +16,7 @@ import Control.Arrow.Fix
import Control.Arrow.Reader
import Control.Arrow.Environment
import Control.Arrow.Contour hiding (toList)
import Control.Monad.State hiding (lift)
import Data.Bounded
import Data.Environment(Env)
......@@ -51,23 +52,23 @@ instance Show Val where
instance Show Closure where
show (Closure e _) = show e
type Addr = (Text,Contour Expr)
type Addr = (Text,Contour)
type Interp =
ReaderArrow IV
(BoundedEnv Text Addr Val
(ContourArrow Expr
(ContourArrow
(ErrorArrow String
(CacheArrow (Env Text Addr,Store Addr Val,(IV,Expr))
(Error String Val)))))
evalInterval :: Int -> IV -> [(Text,Val)] -> Expr -> Error String Val
evalInterval :: Int -> IV -> [(Text,Val)] -> State Label Expr -> Error String Val
evalInterval k bound env e =
runCacheArrow
(runErrorArrow
(runContourArrow k
(runBoundedEnv
(runReaderArrow (eval :: Interp Expr Val)))))
(env,(bound,e))
(env,(bound,generate e))
instance IsVal Val Interp where
succ = proc x -> case x of
......@@ -127,8 +128,8 @@ instance Widening Val where
NumVal x NumVal y = NumVal (x y)
x y = x y
instance Label (Env Text Addr,Store (Text, Contour Expr) Val,(IV, Expr)) Expr where
getLabel (_,_,(_,e)) = e
instance HasLabel (Env Text Addr,Store (Text, Contour) Val,(IV, Expr)) where
label (_,_,(_,e)) = label e
instance Hashable Closure
instance Hashable Val
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module PCF where
import Data.Text(Text,unpack)
import Data.Hashable
import Data.Label
import Data.String
import Control.Monad.State
var :: Text -> State Label Expr
var x = Var x <$> fresh
lam :: Text -> State Label Expr -> State Label Expr
lam x e = Lam x <$> e <*> fresh
app :: State Label Expr -> State Label Expr -> State Label Expr
app e1 e2 = App <$> e1 <*> e2 <*> fresh
zero :: State Label Expr
zero = Zero <$> fresh
succ :: State Label Expr -> State Label Expr
succ e = Succ <$> e <*> fresh
pred :: State Label Expr -> State Label Expr
pred e = Pred <$> e <*> fresh
ifZero :: State Label Expr -> State Label Expr -> State Label Expr -> State Label Expr
ifZero e1 e2 e3 = IfZero <$> e1 <*> e2 <*> e3 <*> fresh
fix :: State Label Expr -> State Label Expr
fix e = Y <$> e <*> fresh
data Expr
= Var Text
| Lam Text Expr
| App Expr Expr
| Zero
| Succ Expr
| Pred Expr
| IfZero Expr Expr Expr
| Y Expr
= Var Text Label
| Lam Text Expr Label
| App Expr Expr Label
| Zero Label
| Succ Expr Label
| Pred Expr Label
| IfZero Expr Expr Expr Label
| Y Expr Label
deriving (Eq)
instance Show Expr where
showsPrec d e0 = case e0 of
Var x -> showString (unpack x)
Zero -> showString "zero"
Succ e -> showParen (d > app_prec) $ showString "succ " . showsPrec (app_prec + 1) e
Pred e -> showParen (d > app_prec) $ showString "pred " . showsPrec (app_prec + 1) e
Y e -> showParen (d > app_prec) $ showString "Y " . showsPrec (app_prec + 1) e
IfZero e1 e2 e3 -> showParen (d > app_prec)
Var x _ -> showString (unpack x)
Zero _ -> showString "zero"
Succ e _ -> showParen (d > app_prec) $ showString "succ " . showsPrec (app_prec + 1) e
Pred e _ -> showParen (d > app_prec) $ showString "pred " . showsPrec (app_prec + 1) e
Y e _ -> showParen (d > app_prec) $ showString "Y " . showsPrec (app_prec + 1) e
IfZero e1 e2 e3 _ -> showParen (d > app_prec)
$ showString "ifZero "
. showsPrec (app_prec + 1) e1
. showString " "
. showsPrec (app_prec + 1) e2
. showString " "
. showsPrec (app_prec + 1) e3
App e1 e2 -> showParen (d > app_prec)
App e1 e2 _ -> showParen (d > app_prec)
$ showsPrec (app_prec + 1) e1
. showString " "
. showsPrec (app_prec + 1) e2
Lam x e2 -> showParen (d > lam_prec)
Lam x e2 _ -> showParen (d > lam_prec)
$ showString "λ"
. showString (unpack x)
. showString ". "
......@@ -42,16 +71,26 @@ instance Show Expr where
app_prec = 10
lam_prec = 9
instance HasLabel Expr where
label e = case e of
Var _ l -> l
Lam _ _ l -> l
App _ _ l -> l
Zero l -> l
Succ _ l -> l
Pred _ l -> l
IfZero _ _ _ l -> l
Y _ l -> l
instance IsString Expr where
fromString = Var . fromString
instance IsString (State Label Expr) where
fromString = var . fromString
instance Hashable Expr where
hashWithSalt s (Var x) = s `hashWithSalt` (0::Int) `hashWithSalt` x
hashWithSalt s (Lam x e) = s `hashWithSalt` (1::Int) `hashWithSalt` x `hashWithSalt` e
hashWithSalt s (App e1 e2) = s `hashWithSalt` (2::Int) `hashWithSalt` e1 `hashWithSalt` e2
hashWithSalt s Zero = s `hashWithSalt` (3::Int)
hashWithSalt s (Succ e) = s `hashWithSalt` (4::Int) `hashWithSalt` e
hashWithSalt s (Pred e) = s `hashWithSalt` (5::Int) `hashWithSalt` e
hashWithSalt s (IfZero e1 e2 e3) = s `hashWithSalt` (6::Int) `hashWithSalt` e1 `hashWithSalt` e2 `hashWithSalt` e3
hashWithSalt s (Y e) = s `hashWithSalt` (7::Int) `hashWithSalt` e
hashWithSalt s (Var x _) = s `hashWithSalt` (0::Int) `hashWithSalt` x
hashWithSalt s (Lam x e _) = s `hashWithSalt` (1::Int) `hashWithSalt` x `hashWithSalt` e
hashWithSalt s (App e1 e2 _) = s `hashWithSalt` (2::Int) `hashWithSalt` e1 `hashWithSalt` e2
hashWithSalt s (Zero _) = s `hashWithSalt` (3::Int)
hashWithSalt s (Succ e _) = s `hashWithSalt` (4::Int) `hashWithSalt` e
hashWithSalt s (Pred e _) = s `hashWithSalt` (5::Int) `hashWithSalt` e
hashWithSalt s (IfZero e1 e2 e3 _) = s `hashWithSalt` (6::Int) `hashWithSalt` e1 `hashWithSalt` e2 `hashWithSalt` e3
hashWithSalt s (Y e _) = s `hashWithSalt` (7::Int) `hashWithSalt` e
......@@ -17,40 +17,40 @@ import Text.Printf
eval :: (ArrowChoice c, ArrowFix Expr v c