more idiomatic handling for bools

Author: Thomas Mahler

src/CCC/CatExpr.hs

@@ -108,6 +108,29 @@ instance FixCat CatExpr where
 applyF :: CatExpr z (CatExpr a b) -> CatExpr z a -> CatExpr z b
 applyF f x = Apply . fanC f x
 
+-- | Reify a Haskell Bool into a Scott-encoded selector.
+scottBool :: Bool -> CatExpr (a, a) a
+scottBool True  = Snd
+scottBool False = Fst
+
+-- | Scott-encoded NOT: swap the selector.
+scottNot :: CatExpr (a, a) a -> CatExpr (a, a) a
+scottNot Snd = Fst
+scottNot Fst = Snd
+scottNot _   = error "scottNot: expected Fst or Snd"
+
+-- | Scott-encoded AND: if a then b else FALSE.
+scottAnd :: CatExpr (a, a) a -> CatExpr (a, a) a -> CatExpr (a, a) a
+scottAnd Fst _ = Fst
+scottAnd Snd b = b
+scottAnd _   _ = error "scottAnd: expected Fst or Snd"
+
+-- | Scott-encoded OR: if a then TRUE else b.
+scottOr :: CatExpr (a, a) a -> CatExpr (a, a) a -> CatExpr (a, a) a
+scottOr Snd _ = Snd
+scottOr Fst b = b
+scottOr _   _ = error "scottOr: expected Fst or Snd"
+
 instance Eq (CatExpr a b) where
   f == g = f Prelude.== g
 

src/CCC/Interpreter.hs

@@ -18,7 +18,7 @@ module CCC.Interpreter (interp) where
 
 import           CCC.Cat     (Cartesian (fstC, sndC, dupC), Monoidal (parC),
                           NumCat (addC, mulC, subC))
-import           CCC.CatExpr (CatExpr (..))
+import           CCC.CatExpr (CatExpr (..), scottBool)
 import           CCC.Hask    ()
 
 interp :: CatExpr a b -> (a -> b)
@@ -40,12 +40,12 @@ interp Neg          = negate
 interp Mul          = mulC
 interp (Lift f)     = f
 -- Comparison operators return Scott-encoded booleans:
--- TRUE = Snd (selects second), FALSE = Fst (selects first)
-interp Eql          = \(x, y) -> if x == y then Snd else Fst
-interp Leq          = \(x, y) -> if x <= y then Snd else Fst
-interp Geq          = \(x, y) -> if x >= y then Snd else Fst
-interp Les          = \(x, y) -> if x < y then Snd else Fst
-interp Gre          = \(x, y) -> if x > y then Snd else Fst
+-- scottBool reifies Haskell Bool into CatExpr selectors (TRUE=Snd, FALSE=Fst)
+interp Eql          = scottBool . uncurry (==)
+interp Leq          = scottBool . uncurry (<=)
+interp Geq          = scottBool . uncurry (>=)
+interp Les          = scottBool . uncurry (<)
+interp Gre          = scottBool . uncurry (>)
 -- Fixpoint: step function is a CatExpr morphism, recursion stays categorical
 interp (Fix step)   = \a ->
   let rec = Fix step