diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -34,3 +34,9 @@
 ## 1.2.0.1 -- 2021-07-03
 
 * Added Jump-Elision optimisation to the code generator.
+
+## 1.3.0.0 -- 2021-07-03
+
+* Improved the `Lam` reduction algorithm
+* Preliminary support for `if true` reduction from `item` and `const True`
+* Introduced `_if` and `ap` in `Machine.Defunc`, removed `genDefunc1`
diff --git a/parsley-core.cabal b/parsley-core.cabal
--- a/parsley-core.cabal
+++ b/parsley-core.cabal
@@ -5,7 +5,7 @@
 --                   | +------- breaking internal API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             1.2.0.1
+version:             1.3.0.0
 synopsis:            A fast parser combinator library backed by Typed Template Haskell
 description:         This package contains the internals of the @parsley@ package.
                      .
diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs
--- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs
+++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs
@@ -20,7 +20,7 @@
 import Data.ByteString                               (ByteString)
 import Data.Dependent.Map                            (DMap)
 import Data.Text                                     (Text)
-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(SAME), user)
+import Parsley.Internal.Backend.Machine.Defunc       (Defunc(SAME), user, userBool)
 import Parsley.Internal.Backend.Machine.Identifiers
 import Parsley.Internal.Backend.Machine.InputOps     (InputPrep(..), PositionOps)
 import Parsley.Internal.Backend.Machine.Instructions
diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs
--- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs
+++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs
@@ -7,7 +7,7 @@
 import Parsley.Internal.Common.Utils             (Code)
 import Parsley.Internal.Core.Lam                 (Lam, normaliseGen, normalise)
 
-import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm)
+import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm, lamTermBool)
 import qualified Parsley.Internal.Core.Lam    as Lam  (Lam(..))
 
 data Defunc a where
@@ -19,27 +19,32 @@
 user :: Core.Defunc a -> Defunc a
 user = LAM . Core.lamTerm
 
+userBool :: Core.Defunc (a -> Bool) -> Defunc (a -> Bool)
+userBool = LAM . Core.lamTermBool
+
+ap :: Defunc (a -> b) -> Defunc a -> Defunc b
+ap f x = LAM (Lam.App (unliftDefunc f) (unliftDefunc x))
+
 ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c
 ap2 f@SAME (OFFSET o1) (OFFSET o2) = LAM (Lam.Var False (apSame f o1 o2))
   where
     apSame :: forall o. Defunc (o -> o -> Bool) -> Code (Rep o) -> Code (Rep o) -> Code Bool
     apSame SAME = same (Proxy @o)
     apSame _    = undefined
-ap2 f x y = LAM (Lam.App (Lam.App (seal f) (seal x)) (seal y))
-  where
-    seal :: Defunc a -> Lam a
-    seal (LAM x) = x
-    seal x        = Lam.Var False (genDefunc x)
+ap2 f x y = ap (ap f x) y
 
+_if :: Defunc Bool -> Code a -> Code a -> Code a
+_if c t e = normaliseGen (Lam.If (unliftDefunc c) (Lam.Var False t) (Lam.Var False e))
+
+unliftDefunc :: Defunc a -> Lam a
+unliftDefunc (LAM x) = x
+unliftDefunc x       = Lam.Var False (genDefunc x)
+
 genDefunc :: Defunc a -> Code a
 genDefunc (LAM x)    = normaliseGen x
 genDefunc BOTTOM      = [||undefined||]
 genDefunc SAME        = error "Cannot materialise the same function in the regular way"
 genDefunc (OFFSET _)  = error "Cannot materialise an unboxed offset in the regular way"
-
-genDefunc1 :: Defunc (a -> b) -> Code a -> Code b
-genDefunc1 (LAM f) qx = normaliseGen (Lam.App f (Lam.Var True qx))
-genDefunc1 f qx       = [|| $$(genDefunc f) $$qx ||]
 
 pattern NormLam :: Lam a -> Defunc a
 pattern NormLam t <- LAM (normalise -> t)
diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs
--- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs
+++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs
@@ -12,7 +12,7 @@
 import Control.Monad                                  (forM, liftM2)
 import Control.Monad.Reader                           (ask, asks, local)
 import Control.Monad.ST                               (runST)
-import Parsley.Internal.Backend.Machine.Defunc        (Defunc(OFFSET), pattern FREEVAR, genDefunc, genDefunc1, ap2)
+import Parsley.Internal.Backend.Machine.Defunc        (Defunc(OFFSET), pattern FREEVAR, genDefunc, ap, ap2, _if)
 import Parsley.Internal.Backend.Machine.Identifiers   (MVar(..), ΦVar, ΣVar)
 import Parsley.Internal.Backend.Machine.InputOps      (InputDependant, PositionOps, LogOps, InputOps(InputOps))
 import Parsley.Internal.Backend.Machine.InputRep      (Rep)
@@ -96,10 +96,10 @@
      | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
      | otherwise -> trace "I have a piggy :)" $ local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
   where
-    maybeEmitCheck Nothing mk γ = sat (genDefunc1 p) mk (raise γ) γ
+    maybeEmitCheck Nothing mk γ = sat (ap p) mk (raise γ) γ
     maybeEmitCheck (Just n) mk γ =
-      --[|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (genDefunc1 p) mk [||bad||]) [||bad||] γ)||]
-      emitLengthCheck n (sat (genDefunc1 p) mk (raise γ)) (raise γ) γ
+      --[|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (ap p) mk [||bad||]) [||bad||] γ)||]
+      emitLengthCheck n (sat (ap p) mk (raise γ)) (raise γ) γ
 
 evalEmpt :: MachineMonad s o xs (Succ n) r a
 evalEmpt = return $! raise
@@ -128,11 +128,8 @@
   def
   (forM ks getMachine)
   where
-    go x (f:fs) (mk:mks) def γ = [||
-        if $$(genDefunc1 f (genDefunc x)) then $$(mk γ)
-        else $$(go x fs mks def γ)
-      ||]
-    go _ _ _ def γ = def γ
+    go x (f:fs) (mk:mks) def γ = _if (ap f x) (mk γ) (go x fs mks def γ)
+    go _ _      _        def γ = def γ
 
 evalIter :: RecBuilder o
          => MVar Void -> Machine s o '[] One Void a -> Machine s o (o : xs) n r a
diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs
--- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs
+++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs
@@ -22,7 +22,7 @@
 import Debug.Trace                                   (trace)
 import GHC.Exts                                      (Int(..), (-#))
 import Language.Haskell.TH.Syntax                    (liftTyped)
-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(OFFSET), genDefunc, pattern FREEVAR)
+import Parsley.Internal.Backend.Machine.Defunc       (Defunc(OFFSET), genDefunc, _if, pattern FREEVAR)
 import Parsley.Internal.Backend.Machine.Identifiers  (MVar, ΦVar, ΣVar)
 import Parsley.Internal.Backend.Machine.InputOps     (PositionOps(..), LogOps(..), InputOps, next, more)
 import Parsley.Internal.Backend.Machine.InputRep     (Rep{-, representationTypes-})
@@ -51,11 +51,8 @@
 type Ops o = (HandlerOps o, JoinBuilder o, RecBuilder o, PositionOps o, MarshalOps o, LogOps (Rep o))
 
 {- Input Operations -}
-sat :: (?ops :: InputOps (Rep o)) => (Code Char -> Code Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
-sat p k bad γ@Γ{..} = next input $ \c input' -> [||
-    if $$(p c) then $$(k (γ {operands = Op (FREEVAR c) operands, input = input'}))
-    else $$bad
-  ||]
+sat :: (?ops :: InputOps (Rep o)) => (Defunc Char -> Defunc Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
+sat p k bad γ@Γ{..} = next input $ \c input' -> let v = FREEVAR c in _if (p v) (k (γ {operands = Op v operands, input = input'})) bad
 
 emitLengthCheck :: forall s o xs n r a. (?ops :: InputOps (Rep o), PositionOps o) => Int -> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
 emitLengthCheck 0 good _ γ   = good γ
diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs
--- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs
+++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs
@@ -20,7 +20,7 @@
 import Data.ByteString                               (ByteString)
 import Data.Dependent.Map                            (DMap)
 import Data.Text                                     (Text)
-import Parsley.Internal.Backend.Machine.Defunc       (Defunc(SAME), user)
+import Parsley.Internal.Backend.Machine.Defunc       (Defunc(SAME), user, userBool)
 import Parsley.Internal.Backend.Machine.Identifiers
 import Parsley.Internal.Backend.Machine.InputOps     (InputPrep(..), PositionOps)
 import Parsley.Internal.Backend.Machine.InputRep     (Rep)
diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs
--- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs
+++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs
@@ -5,7 +5,7 @@
 import Parsley.Internal.Common.Utils             (Code)
 import Parsley.Internal.Core.Lam                 (Lam, normaliseGen, normalise)
 
-import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm)
+import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm, lamTermBool)
 import qualified Parsley.Internal.Core.Lam    as Lam  (Lam(..))
 
 data Defunc a where
@@ -16,21 +16,26 @@
 user :: Core.Defunc a -> Defunc a
 user = LAM . Core.lamTerm
 
+userBool :: Core.Defunc (a -> Bool) -> Defunc (a -> Bool)
+userBool = LAM . Core.lamTermBool
+
+ap :: Defunc (a -> b) -> Defunc a -> Defunc b
+ap f x = LAM (Lam.App (unliftDefunc f) (unliftDefunc x))
+
 ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c
-ap2 f x y = LAM (Lam.App (Lam.App (seal f) (seal x)) (seal y))
-  where
-    seal :: Defunc a -> Lam a
-    seal (LAM x) = x
-    seal x       = Lam.Var False (genDefunc x)
+ap2 f x y = ap (ap f x) y
 
+_if :: Defunc Bool -> Code a -> Code a -> Code a
+_if c t e = normaliseGen (Lam.If (unliftDefunc c) (Lam.Var False t) (Lam.Var False e))
+
+unliftDefunc :: Defunc a -> Lam a
+unliftDefunc (LAM x) = x
+unliftDefunc x       = Lam.Var False (genDefunc x)
+
 genDefunc :: Defunc a -> Code a
 genDefunc (LAM x) = normaliseGen x
 genDefunc BOTTOM  = [||undefined||]
 genDefunc SAME    = same
-
-genDefunc1 :: Defunc (a -> b) -> Code a -> Code b
-genDefunc1 (LAM f) qx = normaliseGen (Lam.App f (Lam.Var True qx))
-genDefunc1 f qx       = [|| $$(genDefunc f) $$qx ||]
 
 pattern NormLam :: Lam a -> Defunc a
 pattern NormLam t <- LAM (normalise -> t)
diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs
--- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs
+++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs
@@ -11,7 +11,7 @@
 import Control.Monad                                  (forM, liftM2)
 import Control.Monad.Reader                           (ask, asks, local)
 import Control.Monad.ST                               (runST)
-import Parsley.Internal.Backend.Machine.Defunc        (Defunc, pattern FREEVAR, genDefunc, genDefunc1, ap2)
+import Parsley.Internal.Backend.Machine.Defunc        (Defunc, pattern FREEVAR, genDefunc, ap, ap2, _if)
 import Parsley.Internal.Backend.Machine.Identifiers   (MVar(..), ΦVar, ΣVar)
 import Parsley.Internal.Backend.Machine.InputOps      (InputDependant(..), PositionOps, BoxOps, LogOps, InputOps(InputOps))
 import Parsley.Internal.Backend.Machine.Instructions  (Instr(..), MetaInstr(..), Access(..))
@@ -94,9 +94,9 @@
      | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
      | otherwise -> trace "I have a piggy :)" $ local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
   where
-    maybeEmitCheck Nothing mk γ = sat (genDefunc1 p) mk (raise γ) γ
+    maybeEmitCheck Nothing mk γ = sat (ap p) mk (raise γ) γ
     maybeEmitCheck (Just n) mk γ =
-      [|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (genDefunc1 p) mk [||bad||]) [||bad||] γ)||]
+      [|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (ap p) mk [||bad||]) [||bad||] γ)||]
 
 evalEmpt :: (BoxOps o, HandlerOps o) => MachineMonad s o xs (Succ n) r a
 evalEmpt = return $! raise
@@ -125,10 +125,7 @@
   def
   (forM ks getMachine)
   where
-    go x (f:fs) (mk:mks) def γ = [||
-        if $$(genDefunc1 f (genDefunc x)) then $$(mk γ)
-        else $$(go x fs mks def γ)
-      ||]
+    go x (f:fs) (mk:mks) def γ = _if (ap f x) (mk γ) (go x fs mks def γ)
     go _ _ _ def γ = def γ
 
 evalIter :: (RecBuilder o, ReturnOps o, HandlerOps o)
diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs
--- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs
+++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs
@@ -17,7 +17,7 @@
 import Data.Text                                     (Text)
 import Data.Void                                     (Void)
 import Debug.Trace                                   (trace)
-import Parsley.Internal.Backend.Machine.Defunc       (Defunc, pattern FREEVAR, genDefunc)
+import Parsley.Internal.Backend.Machine.Defunc       (Defunc, pattern FREEVAR, genDefunc, _if)
 import Parsley.Internal.Backend.Machine.Identifiers  (MVar, ΦVar, ΣVar)
 import Parsley.Internal.Backend.Machine.InputOps     (PositionOps(..), BoxOps(..), LogOps(..), InputOps, next, more)
 import Parsley.Internal.Backend.Machine.InputRep     (Unboxed, OffWith, UnpackedLazyByteString, Stream{-, representationTypes-})
@@ -38,11 +38,8 @@
 type Ops o = (LogHandler o, ContOps o, HandlerOps o, JoinBuilder o, RecBuilder o, ReturnOps o, PositionOps o, BoxOps o, LogOps o)
 
 {- Input Operations -}
-sat :: (?ops :: InputOps o) => (Code Char -> Code Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
-sat p k bad γ@Γ{..} = next input $ \c input' -> [||
-    if $$(p c) then $$(k (γ {operands = Op (FREEVAR c) operands, input = input'}))
-    else $$bad
-  ||]
+sat :: (?ops :: InputOps o) => (Defunc Char -> Defunc Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
+sat p k bad γ@Γ{..} = next input $ \c input' -> let v = FREEVAR c in _if (p v) (k (γ {operands = Op v operands, input = input'})) bad
 
 emitLengthCheck :: (?ops :: InputOps o, PositionOps o) => Int -> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
 emitLengthCheck 0 good _ γ   = good γ
diff --git a/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs b/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs
--- a/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs
+++ b/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs
@@ -5,7 +5,7 @@
 import Data.Maybe                                    (isJust)
 import Data.Set                                      (Set, elems)
 import Control.Monad.Trans                           (lift)
-import Parsley.Internal.Backend.Machine              (Defunc(SAME), user, LetBinding, makeLetBinding, Instr(..),
+import Parsley.Internal.Backend.Machine              (Defunc(SAME), user, userBool, LetBinding, makeLetBinding, Instr(..),
                                                       _Fmap, _App, _Modify, _Get, _Put, _Make, _If,
                                                       addCoins, refundCoins, drainCoins, PositionOps,
                                                       IMVar, IΦVar, IΣVar, MVar(..), ΦVar(..), ΣVar(..))
@@ -108,7 +108,7 @@
 
 shallow :: PositionOps o => Combinator (CodeGen o a) x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)
 shallow (Pure x)      m = do return $! In4 (Push (user x) m)
-shallow (Satisfy p)   m = do return $! In4 (Sat (user p) m)
+shallow (Satisfy p)   m = do return $! In4 (Sat (userBool p) m)
 shallow (pf :<*>: px) m = do pxc <- runCodeGen px (In4 (_App m)); runCodeGen pf pxc
 shallow (p :*>: q)    m = do qc <- runCodeGen q m; runCodeGen p (In4 (Pop qc))
 shallow (p :<*: q)    m = do qc <- runCodeGen q (In4 (Pop m)); runCodeGen p qc
@@ -135,7 +135,7 @@
   do (binder, φ) <- makeΦ m
      qcs <- traverse (\q -> freshΦ (runCodeGen q φ)) qs
      defc <- freshΦ (runCodeGen def φ)
-     let minc = coinsNeeded (In4 (Choices (map user fs) qcs defc))
+     let minc = coinsNeeded (In4 (Choices (map userBool fs) qcs defc))
      let defc':qcs' = map (max 0 . subtract minc . coinsNeeded >>= addCoins) (defc:qcs)
      fmap binder (runCodeGen p (In4 (Choices (map user fs) qcs' defc')))
 shallow (Let _ μ _)            m = do return $! tailCallOptimise μ m
diff --git a/src/ghc/Parsley/Internal/Core.hs b/src/ghc/Parsley/Internal/Core.hs
--- a/src/ghc/Parsley/Internal/Core.hs
+++ b/src/ghc/Parsley/Internal/Core.hs
@@ -14,6 +14,6 @@
     module Parsley.Internal.Core.InputTypes
   ) where
 
-import Parsley.Internal.Core.Defunc hiding (genDefunc, genDefunc1, genDefunc2, ap, unsafeBLACK, lamTerm, adaptLam)
+import Parsley.Internal.Core.Defunc hiding (genDefunc, genDefunc1, genDefunc2, ap, unsafeBLACK, lamTerm, lamTermBool, adaptLam)
 import Parsley.Internal.Core.InputTypes
 import Parsley.Internal.Core.Primitives (Parser, ParserOps)
diff --git a/src/ghc/Parsley/Internal/Core/Defunc.hs b/src/ghc/Parsley/Internal/Core/Defunc.hs
--- a/src/ghc/Parsley/Internal/Core/Defunc.hs
+++ b/src/ghc/Parsley/Internal/Core/Defunc.hs
@@ -1,10 +1,19 @@
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms, TypeApplications #-}
 module Parsley.Internal.Core.Defunc (module Parsley.Internal.Core.Defunc) where
 
-import Language.Haskell.TH.Syntax (Lift(..))
+--import Data.Typeable                 (Typeable, (:~:)(Refl), eqT)
+import Language.Haskell.TH.Syntax    (Lift(..))
 import Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..))
-import Parsley.Internal.Core.Lam (normaliseGen, Lam(..))
+import Parsley.Internal.Core.Lam     (normaliseGen, Lam(..))
 
+{-
+  TODO: We should support Typeable in LIFTED to be more general, but I don't want changes to
+  Defunc to impact back-compat in parsley itself. We should consider not exposing the datatype
+  anymore, but exposing smart-constructors in Parsley.Defunctionalized.
+  This will come in parsley-2.0.0.0.
+-}
+
+
 {-|
 This datatype is useful for providing an /inspectable/ representation of common Haskell functions.
 These can be provided in place of `WQ` to any combinator that requires it. The only difference is
@@ -28,7 +37,7 @@
   -- | Corresponds to the partially applied @(== x)@ for some `Defunc` value @x@
   EQ_H    :: Eq a => Defunc a -> Defunc (a -> Bool)
   -- | Represents a liftable, showable value
-  LIFTED  :: (Show a, Lift a) => a -> Defunc a
+  LIFTED  :: (Show a, Lift a{-, Typeable a-}) => a -> Defunc a
   -- | Represents the standard @(:)@ function applied to no arguments
   CONS    :: Defunc (a -> [a] -> [a])
   -- | Represents the standard @const@ function applied to no arguments
@@ -114,11 +123,20 @@
 ap :: Defunc (a -> b) -> Defunc a -> Defunc b
 ap f x = APP_H f x
 
-lamTerm :: Defunc a -> Lam a
+-- TODO: This is deprecated in favour of Typeable as of parsley 2.0.0.0
+lamTermBool :: Defunc (a -> Bool) -> Lam (a -> Bool)
+lamTermBool (APP_H CONST (LIFTED True)) = Abs (const T)
+lamTermBool (APP_H CONST (LIFTED False)) = Abs (const F)
+lamTermBool f = lamTerm f
+
+lamTerm :: forall a. Defunc a -> Lam a
 lamTerm ID = Abs id
 lamTerm COMPOSE = Abs (\f -> Abs (\g -> Abs (\x -> App f (App g x))))
 lamTerm FLIP = Abs (\f -> Abs (\x -> Abs (\y -> App (App f y) x)))
 lamTerm (APP_H f x) = App (lamTerm f) (lamTerm x)
+{-lamTerm (LIFTED b) | Just Refl <- eqT @a @Bool = case b of
+  False -> F
+  True -> T-}
 lamTerm (LIFTED x) = Var True [||x||]
 lamTerm (EQ_H x) = Abs (\y -> App (App (Var True [||(==)||]) (lamTerm x)) y)
 lamTerm CONS = Var True [||(:)||]
diff --git a/src/ghc/Parsley/Internal/Core/Lam.hs b/src/ghc/Parsley/Internal/Core/Lam.hs
--- a/src/ghc/Parsley/Internal/Core/Lam.hs
+++ b/src/ghc/Parsley/Internal/Core/Lam.hs
@@ -12,35 +12,36 @@
     F   :: Lam Bool
 
 normalise :: Lam a -> Lam a
-normalise x = reduce x
+normalise x = if normal x then x else reduce x
   where
     reduce :: Lam a -> Lam a
-    reduce x
-      | normal x = x
-      | otherwise = reduce (reduceStep x)
-
-    reduceStep :: Lam a -> Lam a
-    reduceStep (App (Abs f) x) = f x
-    reduceStep (App f x)
-      | normal f = App f (reduceStep x)
-      | otherwise = App (reduceStep f) x
-    reduceStep (If T x _) = x
-    reduceStep (If F _ y) = y
-    reduceStep x = x
+    reduce (App (Abs f) x) = case f x of
+      x | normal x -> x
+      x            -> reduce x
+    reduce (App f x) = case reduce f of
+      f@(Abs _) -> reduce (App f x)
+      f         -> App f x
+    reduce (If c x y) = case reduce c of
+      T -> x
+      F -> y
+      c -> If c x y
+    reduce x = x
 
     normal :: Lam a -> Bool
     normal (App (Abs _) _) = False
-    normal (App f x) = normal f && normal x
+    normal (App f _) = normal f
     normal (If T _ _) = False
     normal (If F _ _) = False
+    normal (If x _ _) = normal x
     normal _ = True
 
 generate :: Lam a -> Code a
 generate (Abs f)    = [||\x -> $$(normaliseGen (f (Var True [||x||])))||]
--- These have already been reduced, since we only expose `normaliseGen`
-generate (App f x)  = [||$$(generate f) $$(generate x)||]
+-- f has already been reduced, since we only expose `normaliseGen`
+generate (App f x)  = [||$$(generate f) $$(normaliseGen x)||]
 generate (Var _ x)  = x
-generate (If c t e) = [||if $$(normaliseGen c) then $$(normaliseGen t) else $$(normaliseGen e)||]
+-- c has already been reduced, since we only expose `normaliseGen`
+generate (If c t e) = [||if $$(generate c) then $$(normaliseGen t) else $$(normaliseGen e)||]
 generate (Let b i)  = [||let x = $$(normaliseGen b) in $$(normaliseGen (i (Var True [||x||])))||]
 generate T          = [||True||]
 generate F          = [||False||]