diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -2,37 +2,57 @@
 [![Stackage Nightly](http://stackage.org/package/arrowp-qq/badge/nightly)](http://stackage.org/nightly/package/arrowp-qq)
 [![Travis Build Status](https://travis-ci.org/pepeiborra/arrowp-qq.svg)](https://travis-ci.org/pepeiborra/arrowp-qq)
 
-Arrowp-qq
+arrowp-qq
 ==========
-A preprocessor for arrow notation 
-based on the arrowp preprocessor developed by Ross Paterson <ross@soi.city.ac.uk>.
+A preprocessor (aka syntax-desugarer) for arrow notation 
+based on the original `arrowp` developed by Ross Paterson <ross@soi.city.ac.uk>.
 
-Notable features include support for GHC Haskell syntax and a
-quasiquoter that can be used instead of the preprocessor.
+`arrowp-qq` extends the original `arrowp` in three dimensions:
+1. It replaces the `haskell-src` based parser with one based on `haskell-src-exts`, which handles most of GHC 8.0.2 Haskell syntax.
+2. It provides not only a preprocessor but also a quasiquoter, which is a better option in certain cases.
+3. It extends the desugaring to handle static conditional expressions. See the semantics section below for more details.
 
-Note that recent versions of GHC support this notation directly, and
-give better error messages to boot. But the translation produced by GHC
-is in some cases not as good as it could be.
+Note: `arrowp-qq` provides an enhanced superset of the original `arrowp`'s functionality. One should have no reason to install both. Considering `arrowp` no longer builds under modern versions of GHC and Cabal/Stack, `arrowp-qq` should clearly be the more optimum package to install.
 
-Status
+Both `arrowp` and `arrowp-qq` were originally developed during the days when GHC's `Arrows` extension was not fully mature--a time when `proc` syntax was not the norm. Of course, recent versions of GHC now support this notation directly, and give better error messages to boot. Unfortunately, GHC's `proc` notation desugarer is in some cases not as good as it could be. As such, `arrowp-qq`'s quasi-quoter can still be useful in producing slightly more optimized desugaring for performance-critical, arrowized applications.
+
+The modern use cases of `arrowp-qq` are as follows:
+- Viewing how your `proc` blocks (roughly) look like after desugaring for debugging/profiling purposes.
+  - Via the `arrowp` executable.
+  - NOTE: `arrowp-qq` is NOT guaranteed to produce the same desugaring as GHC (see limitations & semantics below).
+- Optimizing the performance of your `proc` blocks via smarter desugaring.
+  - Either through the `arrowp` executable OR (preferably) the provided quasiquoter.
+
+Limitations
 ------
 
 The parser cannot handle banana brackets for
 control operators in arrow notation (the **proc** keyword in the original paper), 
-due to a 
-[limitation](https://github.com/haskell-suite/haskell-src-exts/issues/45) 
-in haskell-src-exts. In order to use banana brackets, the recommendation
-is to fall back to the GHC Arrows parser. 
+due to a [limitation](https://github.com/haskell-suite/haskell-src-exts/issues/45) 
+in `haskell-src-exts`. In order to use banana brackets, the recommendation
+is to fall back to the GHC Arrows parser.
 
 Support for GHC Haskell notation inside arrow blocks is not complete, e.g.
 multi-way-if and lambda case are unlikely to work as expected. If you run into 
 one of these, please open an issue or vote for an existing one, as I plan to extend
 the support on demand.
 
-Using the `proc` quasi quoter
----------------------------
+Installation
+------------
+`arrowp-qq` is now compatible with Cabal v3's Nix-style local builds & installs:
 
+`cabal install arrowp-qq`
+
+Usage 
+-----
+### Viewing desugared `proc` syntax
+```sh
+arrowp myfile.hs | less
 ```
+### Optimization
+#### Via the `proc` quasiquoter
+
+```
 addA :: Arrow a => a b Int -> a b Int -> a b Int
 addA f g = [proc| x -> do
 		y <- f -< x
@@ -40,19 +60,17 @@
 		returnA -< y + z |]
 ```
 
-Using the **arrowp-ext** preprocessor
----------------------------------
-
+#### Via the **arrowp** preprocessor
+Add the following GHC pragma to the top of the source file:
 ```
-{-# OPTIONS -F -pgmF arrowp-ext #-}
+{-###  OPTIONS -F -pgmF arrowp ### -}
 ```
+This can be useful for preserving compatibility with vanilla `proc` notation, at the cost of flexibility; that is to say, all `proc` blocks within the source file will be desugared via `arrowp-qq`.
 
-Comparison with **arrowp**
+Desugaring Semantics
 -----------------------
-**arrowp-qq** extends the original **arrowp** in three dimensions:
-1. It replaces the `haskell-src` based parser with one based on `haskell-src-exts`, which handles most of GHC 8.0.2 Haskell syntax.
-2. It provides not only a preprocessor but also a quasiquoter, which is a better option in certain cases.
-3. It extends the desugaring to handle static conditional expressions. Example:
+### Static conditional expression optimization
+As mentioned previously, `arrowp-qq` extends the original `arrowp`'s desugaring to handle static conditional expressions. Given:
 ```
 proc inputs -> do
   results <- processor -< inputs
@@ -61,7 +79,7 @@
     else returnA -< ()
   returnA -< results
 ```
-The standard **arrowp** (and GHC) desugaring for this code is:
+The standard `arrowp` (and GHC) desugaring for this code is:
 ```
   = ((processor >>> arr (\ results -> (results, results))) >>>
        (first
@@ -79,8 +97,7 @@
           >>> arr (\ (_, results) -> results)))
 ```
 
-Comparison with **GHC**
------------------------
+### `first` call optimization
 The GHC desugarer does not do a very good job of minimizing the number of
 `first` calls inserted. In certain `Arrow` instances, this can have a material effect
 on performance. Example:
diff --git a/arrowp-qq.cabal b/arrowp-qq.cabal
--- a/arrowp-qq.cabal
+++ b/arrowp-qq.cabal
@@ -1,11 +1,11 @@
 Name:           arrowp-qq
-Version:        0.2.1.1
-Cabal-Version:  >= 1.20
+Version:        0.3.0
+Cabal-Version:  >= 2.0
 Build-Type:     Simple
 License:        GPL
 License-File:   LICENCE
 Author:         Jose Iborra <pepeiborra@gmail.com>
-Maintainer:     Jose Iborra <pepeiborra@gmail.com>
+Maintainer:     John 'Ski <riuga@tuta.io>
 Homepage:       https://github.com/pepeiborra/arrowp
 Category:       Development
 Synopsis:       A preprocessor and quasiquoter for translating arrow notation
@@ -30,43 +30,42 @@
     Exposed-Modules:     
                          Control.Arrow.Notation,
                          Control.Arrow.QuasiQuoter
-    Build-Depends: base < 5,
-                   containers,
-                   data-default,
-                   haskell-src-exts,
-                   haskell-src-exts-util >= 0.2.0,
-                   haskell-src-meta,
-                   template-haskell < 2.13, 
-                   transformers,
-                   uniplate
+    Build-Depends: base                   >= 4.7 && < 5,
+                   NoHoed                 >= 0.1.1 && < 0.2,
+                   template-haskell       >= 2.14.0 && < 2.15,
+                   containers             >= 0.6.0 && < 0.7,
+                   data-default           >= 0.7.1 && < 0.8,
+                   haskell-src-exts       >= 1.22.0 && < 1.23,
+                   transformers           >= 0.5.6 && < 0.6,
+                   haskell-src-exts-util  >= 0.2.5 && < 0.3,
+                   uniplate               >= 1.6.12 && < 1.7,
+                   haskell-src-meta       >= 0.8.5 && < 0.9
     if flag(Debug)
-       Build-Depends:       Hoed, haskell-src-exts-observe
+       Build-Depends:       Hoed > 0.3.6, haskell-src-exts-observe
        cpp-options:         -DDEBUG
     else
-       Build-Depends:       NoHoed
+       Build-Depends:       NoHoed >= 0.1.1
 
     Hs-Source-Dirs: src
     Other-Modules:  ArrCode ArrSyn NewCode SrcLocs Utils
     Default-Language:    Haskell2010
 
-executable arrowp-ext
+executable arrowp
   buildable: True
   main-is: Main.hs
   hs-source-dirs:
       app
   build-depends:
-                base >= 4.7 && < 5, 
-                arrowp-qq,
-                haskell-src-exts
+      base, haskell-src-exts, arrowp-qq
   if flag(Debug)
       Build-Depends:       Hoed
       cpp-options:         -DDEBUG
   else
       Build-Depends:       NoHoed
-
   default-language: Haskell2010
 
 test-suite examples
+  default-language: Haskell2010
   if flag(TestExamples)
      buildable: True
   else
@@ -84,7 +83,11 @@
                        Parser,
                        ExprParser,
                        BackstateArrow,
+                       ArrowContext,
+                       CGI,
                        Conditional,
+                       Circuits,
+                       Hom,
                        ListOps,
                        Egs,
                        Eval,
diff --git a/examples/Conditional.hs b/examples/Conditional.hs
--- a/examples/Conditional.hs
+++ b/examples/Conditional.hs
@@ -16,6 +16,6 @@
      else returnA -< c -- :: a (b,c) c
   returnA -< res
 
-simple :: Bool -> a b c -> a b c
+simple :: (Arrow a) => Bool -> a b c -> a b c
 simple use abc = proc b -> do
   if use then abc -< b else abc -< b
diff --git a/examples/cgi/ArrowContext.lhs b/examples/cgi/ArrowContext.lhs
new file mode 100644
--- /dev/null
+++ b/examples/cgi/ArrowContext.lhs
@@ -0,0 +1,152 @@
+> {-# LANGUAGE DatatypeContexts #-}
+> {-# LANGUAGE FlexibleContexts #-}
+> {-# LANGUAGE FlexibleInstances #-}
+> {-# LANGUAGE MultiParamTypeClasses #-}
+> {-# OPTIONS -F -pgmF arrowp-ext #-}
+
+Basic definitions from "Generalising Monads to Arrows", by John Hughes,
+but with the Arrow class split and generalized.
+
+> module ArrowContext where
+
+> import Control.Monad
+
+> infixr 5 <+>
+> infixr 3 ***
+> infixr 3 &&&
+> infixr 2 +++
+> infixr 2 |||
+> infixr 1 >>>
+
+Basic arrow definitions (s4.1)
+
+> class Arrow a where
+>	arr :: (b -> c) -> a b c
+>	(>>>) :: a b c -> a c d -> a b d
+
+> class Arrow a => ArrowContext a d where
+>	first :: a b c -> a (b,d) (c,d)
+
+> newtype Kleisli m a b = Kleisli (a -> m b)
+
+> instance Monad m => Arrow (Kleisli m) where
+>	arr f = Kleisli (return . f)
+>	(Kleisli f) >>> (Kleisli g) = Kleisli (\b -> f b >>= g)
+
+> instance Monad m => ArrowContext (Kleisli m) d where
+>	first (Kleisli f) = Kleisli (\(b,d) -> f b >>= \c -> return (c,d))
+
+> second :: ArrowContext a d => a b c -> a (d,b) (d,c)
+> second f = arr swap >>> first f >>> arr swap
+>		where	swap ~(x,y) = (y,x)
+
+> (***) :: (ArrowContext a b', ArrowContext a c) =>
+>	a b c -> a b' c' -> a (b,b') (c,c')
+> f *** g = first f >>> second g
+
+> (&&&) :: (ArrowContext a b, ArrowContext a c) =>
+>	a b c -> a b c' -> a b (c,c')
+> f &&& g = arr (\b -> (b,b)) >>> f *** g
+
+> liftA2 :: (ArrowContext a b, ArrowContext a e) =>
+>	(b -> c -> d) -> a e b -> a e c -> a e d
+> liftA2 op f g = f &&& g >>> arr (uncurry op)
+
+ArrowPlus and ArrowZero (s4.2)
+
+> class Arrow a => ArrowZero a where
+>	zeroArrow :: a b c
+
+> class ArrowZero a => ArrowPlus a where
+>	(<+>) :: a b c -> a b c -> a b c
+
+> instance MonadPlus m => ArrowZero (Kleisli m) where
+>	zeroArrow = Kleisli (\x -> mzero)
+
+> instance MonadPlus m => ArrowPlus (Kleisli m) where
+>	Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)
+
+Conditionals (s5.1)
+
+> class Arrow a => ArrowChoice a where
+>	left :: a b c -> a (Either b d) (Either c d)
+
+> instance Monad m => ArrowChoice (Kleisli m) where
+>	left (Kleisli f) = Kleisli g
+>		where	g (Left b) = f b >>= (return . Left)
+>			g (Right d) = return (Right d)
+
+> right :: ArrowChoice a => a b c -> a (Either d b) (Either d c)
+> right f = arr mirror >>> left f >>> arr mirror
+>		where	mirror (Left x) = Right x
+>			mirror (Right y) = Left y
+
+> (+++) :: ArrowChoice a => a b c -> a b' c' -> a (Either b b') (Either c c')
+> f +++ g = left f >>> right g
+
+> (|||) :: ArrowChoice a => a b d -> a c d -> a (Either b c) d
+> f ||| g = f +++ g >>> arr untag
+>		where	untag (Left x) = x
+>			untag (Right y) = y
+
+> test :: (ArrowContext a Bool, ArrowContext a b) =>
+>	a b Bool -> a b (Either b b)
+> test f = f &&& arr id >>> arr (\(b, x) -> if b then Left x else Right x)
+
+Application (s5.2)
+
+> class Arrow a => ArrowApply a where
+>	app :: a (a b c, b) c
+
+> leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)
+> leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||
+>		 (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app
+
+> instance Monad m => ArrowApply (Kleisli m) where
+>	app = Kleisli (\(Kleisli f, x) -> f x)
+
+> newtype ArrowApply a => ArrowMonad a b = ArrowMonad (a () b)
+
+> instance ArrowApply a => Functor (ArrowMonad a) where
+>   fmap = liftM
+
+> instance ArrowApply a => Applicative (ArrowMonad a) where
+>   pure = return
+>   (<*>) = ap
+
+> instance ArrowApply a => Monad (ArrowMonad a) where
+>	return x = ArrowMonad (arr (\z -> x))
+>	ArrowMonad m >>= f = ArrowMonad (m >>>
+>			arr (\x -> let ArrowMonad h = f x in (h, ())) >>>
+>			app)
+
+The ordinary function type (s7)
+
+> instance Arrow (->) where
+>	arr f = f
+>	f >>> g = g . f
+
+> instance ArrowContext (->) a where
+>	first f (x,y) = (f x, y)
+
+> instance ArrowChoice (->) where
+>	left f (Left x) = Left (f x)
+>	left f (Right y) = Right y
+
+> instance ArrowApply (->) where
+>	app (f,x) = f x
+
+Auxiliary functions used in stating laws (s7)
+
+> assoc :: ((a,b),c) -> (a,(b,c))
+> assoc ~(~(x,y),z) = (x,(y,z))
+
+> assocsum :: Either (Either a b) c -> Either a (Either b c)
+> assocsum (Left (Left x)) = Left x
+> assocsum (Left (Right y)) = Right (Left y)
+> assocsum (Right z) = Right (Right z)
+
+Another definition used by the arrow notation.
+
+> returnA :: Arrow a => a b b
+> returnA = arr id
diff --git a/examples/cgi/CGI.hs b/examples/cgi/CGI.hs
new file mode 100644
--- /dev/null
+++ b/examples/cgi/CGI.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+{-# OPTIONS -F -pgmF arrowp-ext #-}
+-- CGI library from Hughes's paper (s.10)
+
+-- This is just an exploratory formulation: it type-checks, but
+-- it doesn't actually do anything.
+
+module CGI where
+
+-- Note that this requires a special generalized version of the arrow
+-- library, with a special class for first and associates.
+
+
+import           ArrowContext
+
+data ScriptState
+	= Ask
+	| Comp (Either ScriptState ScriptState)
+	| First ScriptState String
+
+data Input a = Initial a | Resume ScriptState String
+data Output a = Final a | Suspend ScriptState String
+
+newtype CGIFunctor a b c = CGI (a (Input b) (Output c))
+
+example :: (ArrowChoice a, ArrowContext a String) => CGIFunctor a b String
+example = proc z -> do
+		q <- ask -< "What is your question?"
+		ans <- ask -< q
+		returnA -< "The answer to \"" ++ q ++ "\" is " ++ ans
+
+liftCGI :: ArrowChoice a => a b c -> CGIFunctor a b c
+liftCGI f = CGI $ proc (Initial b) -> do
+		c <- f -< b
+		returnA -< Final c
+
+ask :: ArrowChoice a => CGIFunctor a String String
+ask = CGI $ proc x -> case x of
+	Initial q -> returnA -< Suspend Ask q
+	Resume Ask a -> returnA -< Final a
+
+instance ArrowChoice a => Arrow (CGIFunctor a) where
+	arr f = CGI $ proc (Initial b) ->
+		returnA -< Final (f b)
+
+	CGI f >>> CGI g = CGI $ proc z -> case z of
+			Initial b -> enterf -< Initial                 b
+			Resume (Comp (Left s)) a -> enterf -< Resume s a
+			Resume (Comp (Right s)) a -> enterg -< Resume s a
+		where	enterf = proc x -> do
+				y <- f -< x
+				case y of
+					Final c -> enterg -< Initial c
+					Suspend s q -> returnA -<
+						Suspend (Comp (Left s)) q
+			enterg = proc x -> do
+				y <- g -< x
+				returnA -< case y of
+					Final d -> Final d
+					Suspend s q ->
+						Suspend (Comp (Right s)) q
+
+instance (ArrowChoice a, ArrowContext a d, Read d, Show d) =>
+		ArrowContext (CGIFunctor a) d where
+	first (CGI f) = CGI $ proc x -> do
+			let (b', d) = case x of
+				Initial (b, d) -> (Initial b, d)
+				Resume (First s v) a -> (Resume s a, read v)
+			c' <- f -< b'
+			returnA -< case c' of
+				Final c -> Final (c, d)
+				Suspend s q -> Suspend (First s (show d)) q
+
+
+instance ArrowChoice a => ArrowChoice (CGIFunctor a) where
+	left (CGI f) = CGI $ proc x -> case x of
+			Initial (Left b) -> enterf -< Initial  b
+			Initial (Right d) -> returnA -< Final (Right d)
+			Resume s a -> enterf -< Resume s       a
+		where	enterf = proc x -> do
+				y <- f -< x
+				case y of
+					Final c -> returnA -< Final (Left c)
+					Suspend s q -> returnA -< Suspend s q
diff --git a/examples/circuits/Circuits.lhs b/examples/circuits/Circuits.lhs
new file mode 100644
--- /dev/null
+++ b/examples/circuits/Circuits.lhs
@@ -0,0 +1,73 @@
+> {-# OPTIONS -F -pgmF arrowp-ext #-}
+
+{-# LANGUAGE Arrows #-}
+
+> module Circuits where
+
+> import Control.Arrow
+> import Control.Arrow.Transformer.Automaton
+> import Control.Arrow.Transformer.Stream
+> import Data.Monoid
+> import Data.Stream
+
+Some simple example circuits
+
+A resettable counter (first example in several Hawk papers):
+
+> counter :: ArrowCircuit a => a Bool Int
+> counter = proc reset -> do
+>	rec	output <- returnA -< if reset then 0 else next
+>		next <- delay 0 -< output+1
+>	returnA -< output
+
+Some other basic circuits from the Hawk library.
+
+flush: when reset is True, return d for n ticks, otherwise copy value.
+(a variation on the resettable counter)
+
+> flush :: ArrowCircuit a => Int -> b -> a (b, Bool) b
+> flush n d = proc (value, reset) -> do
+>	rec	count <- returnA -< if reset then n else max (next-1) 0
+>		next <- delay 0 -< count
+>	returnA -< if count > 0 then d else value
+
+latch: on each tick, return the last value for which reset was True,
+or init if there was none.
+ 
+> latch :: ArrowCircuit a => b -> a (b, Bool) b
+> latch init = proc (value, reset) -> do
+>	rec	out <- returnA -< if reset then value else last
+>		last <- delay init -< out
+>	returnA -< out
+
+Run a circuit on a partial input
+
+> partRunAutomaton ::
+>	(ArrowLoop a, ArrowApply a) => Automaton a b c -> a [b] [c]
+> partRunAutomaton f = proc xs -> do
+>	s <- (|runAutomaton (\x -> f -< x)|) (listToStream xs)
+>	returnA -< take (length xs) (streamToList s)
+
+> partRunStream :: ArrowLoop a => StreamArrow a b c -> a [b] [c]
+> partRunStream f = proc xs -> do
+>	s <- (|runStream (\x -> f -< x)|) (listToStream xs)
+>	returnA -< take (length xs) (streamToList s)
+
+Some tests using the counter
+
+> test_input = [True, False, True, False, False, True, False, True]
+
+A test of the resettable counter.
+
+> ts = partRunStream counter test_input
+
+> ta = partRunAutomaton counter test_input
+
+A step function (cf current in Lustre)
+
+> step :: ArrowCircuit a => b -> a (Either b c) b
+> step b = proc x -> do
+>		rec	last_b <- delay b -< getLeft last_b x
+>		returnA -< last_b
+>	where	getLeft _ (Left b) = b
+>		getLeft b (Right _) = b
diff --git a/examples/powertrees/Hom.lhs b/examples/powertrees/Hom.lhs
new file mode 100644
--- /dev/null
+++ b/examples/powertrees/Hom.lhs
@@ -0,0 +1,220 @@
+> {-# OPTIONS -F -pgmF arrowp-ext #-}
+
+Homogeneous (or depth-preserving) functions over perfectly balanced trees.
+
+> module Hom where
+
+> import Control.Arrow
+> import Control.Category
+> import Data.Complex
+> import Prelude hiding (id, (.))
+
+> infixr 4 :&:
+
+Consider the following non-regular type of perfectly balanced trees,
+or `powertrees' (cf Jayadev Misra's powerlists):
+
+> data Pow a = Zero a | Succ (Pow (Pair a))
+> 	deriving Show
+
+> type Pair a = (a, a)
+
+Here are some example elements:
+
+> tree0 = Zero 1
+> tree1 = Succ (Zero (1, 2))
+> tree2 = Succ (Succ (Zero ((1, 2), (3, 4))))
+> tree3 = Succ (Succ (Succ (Zero (((1, 2), (3, 4)), ((5, 6), (7, 8))))))
+
+The elements of this type have a string of constructors expressing
+a depth n as a Peano numeral, enclosing a nested pair tree of 2^n
+elements.  The type definition ensures that all elements of this type
+are perfectly balanced binary trees of this form.  (Such things arise
+in circuit design, eg Ruby, and descriptions of parallel algorithms.)
+And the type system will ensure that all legal programs preserve
+this structural invariant.
+ 
+The only problem is that the type constraint is too restrictive, rejecting
+many of the standard operations on these trees.  Typically you want to
+split a tree into two subtrees, do some processing on the subtrees and
+combine the results.  But the type system cannot discover that the two
+results are of the same depth (and thus combinable).  We need a type
+that says a function preserves depth.  Here it is:
+
+> data Hom a b = (a -> b) :&: Hom (Pair a) (Pair b)
+
+A homogeneous (or depth-preserving) function is an infinite sequence of
+functions of type Pair^n a -> Pair^n b, one for each depth n.  We can
+apply a homogeneous function to a powertree by selecting the function
+for the required depth:
+
+> apply :: Hom a b -> Pow a -> Pow b
+> apply (f :&: fs) (Zero x) = Zero (f x)
+> apply (f :&: fs) (Succ t) = Succ (apply fs t)
+
+Having defined apply, we can forget about powertrees and do all our
+programming with Hom's.  Firstly, Hom is an arrow:
+
+
+> instance Category Hom where
+>  id = id :&: id
+>  (g :&: gs) . (f :&: fs) = (g . f) :&: (fs >>> gs)
+>
+> instance Arrow Hom where
+> 	arr f = f :&: arr (f *** f)
+> 	first (f :&: fs) =
+> 		first f :&: (arr transpose >>> first fs >>> arr transpose)
+
+> transpose :: ((a,b), (c,d)) -> ((a,c), (b,d))
+> transpose ((a,b), (c,d)) = ((a,c), (b,d))
+
+arr maps f over the leaves of a powertree.
+
+The composition >>> composes sequences of functions pairwise.
+ 
+The *** operator unriffles a powertree of pairs into a pair of powertrees,
+applies the appropriate function to each and riffles the results.
+It defines a categorical product for this arrow category.
+
+When describing algorithms, one often provides a pure function for the
+base case (trees of one element) and a (usually recursive) expression
+for trees of pairs.
+
+For example, a common divide-and-conquer pattern is the butterfly, where
+one recursive call processes the odd-numbered elements and the other
+processes the even ones (cf Geraint Jones and Mary Sheeran's Ruby papers):
+
+> butterfly :: (Pair a -> Pair a) -> Hom a a
+> butterfly f = id :&: proc (x, y) -> do
+> 		x' <- butterfly f -< x
+> 		y' <- butterfly f -< y
+> 		returnA -< f (x', y')
+
+The recursive calls operate on halves of the original tree, so the
+recursion is well-defined.
+
+Some examples of butterflies:
+
+> rev :: Hom a a
+> rev = butterfly swap
+>	where	swap (x, y) = (y, x)
+
+> unriffle :: Hom (Pair a) (Pair a)
+> unriffle = butterfly transpose
+
+Batcher's sorter for bitonic sequences:
+
+> bisort :: Ord a => Hom a a
+> bisort = butterfly cmp
+> 	where	cmp (x, y) = (min x y, max x y)
+
+This can be used (with rev) as the merge phase of a merge sort.
+ 
+> sort :: Ord a => Hom a a
+> sort = id :&: proc (x, y) -> do
+>		x' <- sort -< x
+>		y' <- sort -< y
+>		yr <- rev -< y'
+>		p <- unriffle -< (x', yr)
+>		bisort2 -< p
+>	where _ :&: bisort2 = bisort
+
+Here is the scan operation, using the algorithm of Ladner and Fischer:
+
+> scan :: (a -> a -> a) -> a -> Hom a a
+> scan op b = id :&: proc (x, y) -> do
+> 		y' <- scan op b -< op x y
+> 		l <- rsh b -< y'
+> 		returnA -< (op l x, y')
+
+The auxiliary function rsh b shifts each element in the tree one place to
+the right, placing b in the now-vacant leftmost position, and discarding
+the old rightmost element:
+
+> rsh :: a -> Hom a a
+> rsh b = const b :&: proc (x, y) -> do
+> 		w <- rsh b -< y
+> 		returnA -< (w, x)
+
+Finally, here is the Fast Fourier Transform:
+
+> type C = Complex Double
+
+> fft :: Hom C C
+> fft = id :&: proc (x, y) -> do
+> 		x' <- fft -< x
+> 		y' <- fft -< y
+> 		r <- roots (-1) -< ()
+> 		let z = r*y'
+> 		unriffle -< (x' + z, x' - z)
+
+The auxiliary function roots r (where r is typically a root of unity)
+populates a tree of size n (necessarily a power of 2) with the values
+1, w, w^2, ..., w^(n-1), where w^n = r.
+
+> roots :: C -> Hom () C
+> roots r = const 1 :&: proc _ -> do
+> 		x <- roots r' -< ()
+> 		unriffle -< (x, x*r')
+>	where	r' = if imagPart s >= 0 then -s else s
+> 		s = sqrt r
+
+Miscellaneous functions:
+
+> rrot :: Hom a a
+> rrot = id :&: proc (x, y) -> do
+> 		w <- rrot -< y
+> 		returnA -< (w, x)
+
+> ilv :: Hom a a -> Hom (Pair a) (Pair a)
+> ilv f = proc (x, y) -> do
+> 		x' <- f -< x
+> 		y' <- f -< y
+> 		returnA -< (x', y')
+
+> scan' :: (a -> a -> a) -> a -> Hom a a
+> scan' op b = proc x -> do
+>		l <- rsh b -< x
+>		(id :&: ilv (scan' op b)) -< op l x
+
+> riffle :: Hom (Pair a) (Pair a)
+> riffle = id :&: proc ((x1, y1), (x2, y2)) -> do
+>		x <- riffle -< (x1, x2)
+>		y <- riffle -< (y1, y2)
+>		returnA -< (x, y)
+
+> invert :: Hom a a
+> invert = id :&: proc (x, y) -> do
+> 		x' <- invert -< x
+> 		y' <- invert -< y
+>		unriffle -< (x', y')
+
+> carryLookaheadAdder :: Hom (Bool, Bool) Bool
+> carryLookaheadAdder = proc (x, y) -> do
+>		carryOut <- rsh (Just False) -<
+>			if x == y then Just x else Nothing
+>		Just carryIn <- scan plusMaybe Nothing -< carryOut
+>		returnA -< x `xor` y `xor` carryIn
+>	where	plusMaybe x Nothing = x
+>		plusMaybe x (Just y) = Just y
+>		False `xor` b = b
+>		True `xor` b = not b
+
+Global conditional for SIMD
+
+> ifAll :: Hom a b -> Hom a b -> Hom (a, Bool) b
+> ifAll fs gs = ifAllAux snd (arr fst >>> fs) (arr fst >>> gs)
+>	where	ifAllAux :: (a -> Bool) -> Hom a b -> Hom a b -> Hom a b
+>		ifAllAux p (f :&: fs) (g :&: gs) =
+>			liftIf p f g :&: ifAllAux (liftAnd p) fs gs
+>		liftIf p f g x = if p x then f x else g x
+>		liftAnd p (x, y) = p x && p y
+
+> maybeAll :: Hom a c -> Hom (a, b) c -> Hom (a, Maybe b) c
+> maybeAll (n :&: ns) (j :&: js) =
+>	choose :&: (arr dist >>> maybeAll ns (arr transpose >>> js))
+>	where	choose (a, Nothing) = n a
+>		choose (a, Just b) = j (a, b)
+>		dist ((a1, b1), (a2, b2)) = ((a1, a2), zipMaybe b1 b2)
+>		zipMaybe (Just x) (Just y) = Just (x, y)
+>		zipMaybe _ _ = Nothing
diff --git a/src/ArrCode.hs b/src/ArrCode.hs
--- a/src/ArrCode.hs
+++ b/src/ArrCode.hs
@@ -187,7 +187,7 @@
     toHaskellArg = Paren def . toHaskellCode
 
 newtype Tuple = Tuple (Set (Name ()))
-  deriving (Eq,Generic,Monoid,Show)
+  deriving (Eq,Generic,Semigroup,Monoid,Show)
 instance Observable Tuple
 
 isEmptyTuple :: Tuple -> Bool
diff --git a/src/ArrSyn.hs b/src/ArrSyn.hs
--- a/src/ArrSyn.hs
+++ b/src/ArrSyn.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -23,6 +24,7 @@
 import           Data.Set                   (Set)
 import qualified Data.Set                   as Set
 import           Debug.Hoed.Pure
+import           Debug.Hoed.Pure.TH
 import           Language.Haskell.Exts      (Alt (..), Binds (..), Decl (..),
                                              Exp (), GuardedRhs (..),
                                              Match (..), Name, Pat (..),
@@ -30,198 +32,187 @@
 
 import qualified Language.Haskell.Exts      as H
 
+data TransState = TransState {
+      locals  :: Set (Name ()),   -- vars in scope defined in this proc
+      cmdVars :: Map (Name ()) Arrow
+  } deriving (Eq, Generic, Show)
+
+instance Observable TransState
+
 -- -----------------------------------------------------------------------------
 -- Translation to Haskell
 
 -- This is a 2-phase process:
--- - transCmd' generates an abstract arrow combinator language represented
+-- - transCmd generates an abstract arrow combinator language represented
 --   by the Arrow type, and
 -- - toHaskell turns that into Haskell.
 
-translate :: Pat S -> Exp S -> Exp S
-translate p c = H.Paren (ann c) $ toHaskell (transCmd s p' c)
-      where   (s, p') = startPattern p
-
-startPattern :: Pat S -> (TransState, Pat S)
-startPattern = observe "startPattern" startPattern'
-
-startPattern' :: Pat S -> (TransState, Pat S)
-startPattern' p =
-      (TransState {
-              locals = definedVars p,
-              cmdVars = Map.empty
-       }, p)
--- The pattern argument is often pseudo-recursively defined in terms of
--- the context part of the result of these functions.  (It's not real
--- recursion, because that part is independent of the pattern.)
-
-transCmd :: TransState -> Pat S -> Exp S -> Arrow
-transCmd = observe "transCmd" transCmd'
+obs [d|
+  startPattern :: Pat S -> (TransState, Pat S)
+  startPattern p =
+        (TransState {
+                locals = definedVars p,
+                cmdVars = Map.empty
+        }, p)
+  -- The pattern argument is often pseudo-recursively defined in terms of
+  -- the context part of the result of these functions.  (It's not real
+  -- recursion, because that part is independent of the pattern.)
 
-transCmd' :: TransState -> Pat S -> Exp S -> Arrow
-transCmd' s p (H.LeftArrApp _ f e)
-      | Set.null (freeVars f `Set.intersection` locals s) =
-              arr 0 (input s) p e >>> arrowExp f
-      | otherwise =
-              arr 0 (input s) p (pair f e) >>> app
-transCmd' s p (H.LeftArrHighApp  l f e) = transCmd s p (H.LeftArrApp l f e)
-transCmd' _ _ H.RightArrApp{} =
-  error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"
-transCmd' _ _ H.RightArrHighApp{} =
-  error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"
-transCmd' s p (H.InfixApp _ c1 op c2) =
-  infixOp (transCmd s p c1) op (transCmd s p c2)
-transCmd' s p (H.Let _ decls c) =
-      arrLet (anonArgs a) (input s) p decls' e >>> a
-      where   (s', decls') = addVars' s decls
-              (e, a) = transTrimCmd s' c
-transCmd' s p (H.If l e c1 c2)
-  | Set.null (freeVars e `Set.intersection` locals s) =
-      ifte e (transCmd s p c1) (transCmd s p c2)
-  | otherwise =
-      arr 0 (input s) p (H.If l e (left e1) (right e2)) >>> (a1 ||| a2)
-      where   (e1, a1) = transTrimCmd s c1
-              (e2, a2) = transTrimCmd s c2
-transCmd' s p (H.Case l e as)
-  | Set.null (freeVars e `Set.intersection` locals s) =
-    Arrow {
-      context = ctx,
-      anonArgs = 0,
-      code = H.Case (Loc l) (Loc <$> e) alts
-          }
-  | otherwise =
-   arr 0 (input s) p (H.Case l e as') >>> foldr1 (|||) (reverse cases)
-  where
-    (alts, ctx) = runWriter $ flip traverseAlts (Loc <$$> as) $ \exp -> do
-      let arrow = transCmd s p (getLoc <$> exp)
-      tell $ context arrow
-      return $ code arrow
-    (as', (ncases, cases)) = runState (mapM (transAlt s) as) (0, [])
-    transAlt = observeSt "transAlt" transAlt'
-    transAlt' s (Alt loc p gas decls) = do
-      let (s', p') = addVars' s p
-          (s'', decls') = addVars' s' decls
-      gas' <- transGuardedRhss s'' gas
-      return (H.Alt loc p' gas' decls')
-    transGuardedRhss = observeSt "transGuardedRhss" transGuardedRhss'
-    transGuardedRhss' s (UnGuardedRhs l c) = do
-      body <- newAlt s c
-      return (H.UnGuardedRhs l body)
-    transGuardedRhss' s (GuardedRhss l gas) = do
-      gas' <- mapM (transGuardedRhs s) gas
-      return (H.GuardedRhss l gas')
-    transGuardedRhs = observeSt "transGuardedRhs" transGuardedRhs'
-    transGuardedRhs' s (GuardedRhs loc e c) = do
-      body <- newAlt s c
-      return (H.GuardedRhs loc e body)
-    newAlt = observeSt "newAlt" newAlt'
-    newAlt' s c = do
-      let (e, a) =
-            transTrimCmd s c
-      (n, as) <- get
-      put (n + 1, a : as)
-      return (label n e)
-    label = observe "label" label'
-    label' n e =
-      times
-        n
-        right
-        (if n < ncases - 1
-           then left e
-           else e)
-transCmd' s p (H.Paren _ c) =
-      transCmd s p c
-transCmd' s p (H.Do _ ss) =
-      transDo s p (init ss) (let Qualifier _ e = last ss in e)
-transCmd' s p (H.App _ c arg) =
-      anon (-1) $
-      arr (anonArgs a) (input s) p (pair e arg) >>> a
-      where   (e, a) = transTrimCmd s c
-transCmd' s p (H.Lambda _ ps c) =
-  anon (length ps) $ bind (definedVars ps) $ transCmd s' (foldl pairP p ps') c
-  where
-    (s', ps') = addVars' s ps
-transCmd' _ _ x = error $ "Invalid parse: " ++ showSrcLoc (H.fromSrcInfo $ getSrcSpanInfo $ ann x)
- where
-  showSrcLoc :: H.SrcLoc -> String
-  showSrcLoc (H.SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col
+  transCmd :: TransState -> Pat S -> Exp S -> Arrow
+  transCmd s p (H.LeftArrApp _ f e)
+        | Set.null (freeVars f `Set.intersection` locals s) =
+                arr 0 (input s) p' e >>> arrowExp f
+        | otherwise =
+                arr 0 (input s) p' (pair f e) >>> app
+    where
+      p' = trimPat e p
 
--- transCmd' s p (CmdVar n) =
---       arr (anonArgs a) (input s) p e >>> arrowExp (H.Var () (H.UnQual () n))
---       where   Just a = Map.lookup n (cmdVars s)
---               e = expTuple (context a)
+  transCmd s p (H.LeftArrHighApp  l f e) = transCmd s p (H.LeftArrApp l f e)
+  transCmd _ _ H.RightArrApp{} =
+    error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"
+  transCmd _ _ H.RightArrHighApp{} =
+    error "assumption failed: Right arrow applications should have been desugared to left arrow applications before this point"
+  transCmd s p (H.InfixApp _ c1 op c2) =
+    infixOp (transCmd s p c1) op (transCmd s p c2)
+  transCmd s p (H.Let _ decls c) =
+    arrLet (anonArgs a) (input s) (trimPat e p) decls' e >>> a
+        where   (s', decls') = addVars s decls
+                (e, a) = transTrimCmd s' c
+  transCmd s p (H.If l e c1 c2)
+    | Set.null (freeVars e `Set.intersection` locals s) =
+        ifte e (transCmd s p c1) (transCmd s p c2)
+    | otherwise =
+        arr 0 (input s) p (H.If l e (left e1) (right e2)) >>> (a1 ||| a2)
+        where   (e1, a1) = transTrimCmd s c1
+                (e2, a2) = transTrimCmd s c2
+  transCmd s p (H.Case l e as)
+    | Set.null (freeVars e `Set.intersection` locals s) =
+      Arrow {
+        context = ctx,
+        anonArgs = 0,
+        code = H.Case (Loc l) (Loc <$> e) alts
+            }
+    | otherwise =
+    arr 0 (input s) p (H.Case l e as') >>> foldr1 (|||) (reverse cases)
+    where
+      (alts, ctx) = runWriter $ flip traverseAlts (Loc <$$> as) $ \exp -> do
+        let arrow = transCmd s p (getLoc <$> exp)
+        tell $ context arrow
+        return $ code arrow
+      (as', (ncases, cases)) = runState (mapM (transAlt s) as) (0, [])
+      transAlt = observeSt "transAlt" transAlt'
+      transAlt' s (Alt loc p gas decls) = do
+        let (s', p') = addVars s p
+            (s'', decls') = addVars s' decls
+        gas' <- transGuardedRhss s'' gas
+        return (H.Alt loc p' gas' decls')
+      transGuardedRhss = observeSt "transGuardedRhss" transGuardedRhss'
+      transGuardedRhss' s (UnGuardedRhs l c) = do
+        body <- newAlt s c
+        return (H.UnGuardedRhs l body)
+      transGuardedRhss' s (GuardedRhss l gas) = do
+        gas' <- mapM (transGuardedRhs s) gas
+        return (H.GuardedRhss l gas')
+      transGuardedRhs = observeSt "transGuardedRhs" transGuardedRhs'
+      transGuardedRhs' s (GuardedRhs loc e c) = do
+        body <- newAlt s c
+        return (H.GuardedRhs loc e body)
+      newAlt = observeSt "newAlt" newAlt'
+      newAlt' s c = do
+        let (e, a) =
+              transTrimCmd s c
+        (n, as) <- get
+        put (n + 1, a : as)
+        return (label n e)
+      label = observe "label" label'
+      label' n e =
+        times
+          n
+          right
+          (if n < ncases - 1
+            then left e
+            else e)
+  transCmd s p (H.Paren _ c) =
+        transCmd s p c
+  transCmd s p (H.Do _ ss) =
+        transDo s p (init ss) (let Qualifier _ e = last ss in e)
+  transCmd s p (H.App _ c arg) =
+        anon (-1) $
+        arr (anonArgs a) (input s) p (pair e arg) >>> a
+        where   (e, a) = transTrimCmd s c
+  transCmd s p (H.Lambda _ ps c) =
+    anon (length ps) $ bind (definedVars ps) $ transCmd s' (foldl pairP p ps') c
+    where
+      (s', ps') = addVars s ps
+  transCmd _ _ x = error $ "Invalid parse: " ++ showSrcLoc (H.fromSrcInfo $ getSrcSpanInfo $ ann x)
+   where
+    showSrcLoc :: H.SrcLoc -> String
+    showSrcLoc (H.SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col
 
--- Like TransCmd, but use the minimal input pattern.  The first component
--- of the result is the matching expression to build this input.
--- That is, the result is (e, proc p' -> c) with the minimal p' such that
+  -- transCmd s p (CmdVar n) =
+  --       arr (anonArgs a) (input s) p e >>> arrowExp (H.Var () (H.UnQual () n))
+  --       where   Just a = Map.lookup n (cmdVars s)
+  --               e = expTuple (context a)
 
--- 	proc p -> c = arr (first^n (p -> e)) >>> (proc p' -> c)
+  -- Like TransCmd, but use the minimal input pattern.  The first component
+  -- of the result is the matching expression to build this input.
+  -- That is, the result is (e, proc p' -> c) with the minimal p' such that
 
--- where n is the number of anonymous arguments taken by c.
-transTrimCmd :: TransState -> Exp S -> (Exp S, Arrow)
-transTrimCmd = observe "transTrimCmd" transTrimCmd'
-transTrimCmd' :: TransState -> Exp S -> (Exp S, Arrow)
-transTrimCmd' s c = (expTuple (context a), a)
-      where   a = transCmd s (patternTuple (context a)) c
+  -- 	proc p -> c = arr (first^n (p -> e)) >>> (proc p' -> c)
 
-transDo :: TransState -> Pat S -> [Stmt S] -> Exp S -> Arrow
-transDo = observe "transDo" transDo'
+  -- where n is the number of anonymous arguments taken by c.
+  transTrimCmd :: TransState -> Exp S -> (Exp S, Arrow)
+  transTrimCmd s c = (expTuple (context a), a)
+        where   a = transCmd s (patternTuple (context a)) c
 
-transDo' :: TransState -> Pat S -> [Stmt S] -> Exp S -> Arrow
-transDo' s p [] c =
-      transCmd s p c
-transDo' s p (Qualifier l exp : ss) c =
-  transDo' s p (Generator l (PWildCard l) exp : ss) c
-transDo' s p (Generator _ pg cg:ss) c =
-      if isEmptyTuple u then
-        transCmd s p cg >>> transDo s' pg ss c
-      else
-        arr 0 (input s) p (pair eg (expTuple u)) >>> first ag u >>> a
-      where   (s', pg') = addVars' s pg
-              a = observe "a" $ bind (definedVars pg)
-                      (transDo s' (pairP pg' (patternTuple u)) ss c)
-              u = observe "u" $ context a
-              (eg, ag) = transTrimCmd s cg
-transDo' s p (LetStmt l decls : ss) c =
-      transCmd s p (H.Let l decls (H.Do l (ss ++ [Qualifier l c])))
-transDo' s p (RecStmt l rss:ss) c =
-  bind
-    defined
-    (loop
-       (transDo
-          s'
-          (pairP p (irrPat (patternTuple feedback)))
-          rss'
-          (returnCmd (pair output (expTuple feedback)))) >>>
-     a)
-  where
-    defined = foldMap definedVars rss
-    (s', rss') = addVars' s rss
-    (output, a) = transTrimCmd s' (H.Do l (ss ++ [Qualifier l c]))
-    feedback =
-      context
-        (transDo
-           s'
-           p
-           rss'
-           (returnCmd
-              (foldr (pair . H.Var l . H.UnQual l) output (const def <$$> Set.toList defined)))) `intersectTuple`
+  transDo :: TransState -> Pat S -> [Stmt S] -> Exp S -> Arrow
+  transDo s p [] c =
+        transCmd s p c
+  transDo s p (Qualifier l exp : ss) c =
+    transDo s p (Generator l (PWildCard l) exp : ss) c
+  transDo s p (Generator _ pg cg:ss) c =
+        if isEmptyTuple u then
+          transCmd s p cg >>> transDo s' pg ss c
+        else
+          arr 0 (input s) p (pair eg (expTuple u)) >>> first ag u >>> a
+        where   (s', pg') = addVars s pg
+                a = observe "a" $ bind (definedVars pg)
+                        (transDo s' (pairP pg' (patternTuple u)) ss c)
+                u = observe "u" $ context a
+                (eg, ag) = transTrimCmd s cg
+  transDo s p (LetStmt l decls : ss) c =
+        transCmd s p (H.Let l decls (H.Do l (ss ++ [Qualifier l c])))
+  transDo s p (RecStmt l rss:ss) c =
+    bind
       defined
-
-data TransState = TransState {
-      locals  :: Set (Name ()),   -- vars in scope defined in this proc
-      cmdVars :: Map (Name ()) Arrow
-  } deriving (Eq, Generic, Show)
+      (loop
+        (transDo
+            s'
+            (pairP p (irrPat (patternTuple feedback)))
+            rss'
+            (returnCmd (pair output (expTuple feedback)))) >>>
+      a)
+    where
+      defined = foldMap definedVars rss
+      (s', rss') = addVars s rss
+      (output, a) = transTrimCmd s' (H.Do l (ss ++ [Qualifier l c]))
+      feedback =
+        context
+          (transDo
+            s'
+            p
+            rss'
+            (returnCmd
+                (foldr (pair . H.Var l . H.UnQual l) output (const def <$$> Set.toList defined)))) `intersectTuple`
+        defined
+ |]
 
-instance Observable TransState
+translate :: Pat S -> Exp S -> Exp S
+translate p c = H.Paren (ann c) $ toHaskell (transCmd s p' c)
+      where   (s, p') = startPattern p
 
 input :: TransState -> Tuple
 input s = Tuple (locals s)
-
-addVars'
-  :: (Observable a, AddVars a)
-  => TransState -> a -> (TransState, a)
-addVars' = observe "addVars" addVars
 
 class AddVars a where
       addVars :: TransState -> a -> (TransState, a)
diff --git a/src/Control/Arrow/QuasiQuoter.hs b/src/Control/Arrow/QuasiQuoter.hs
--- a/src/Control/Arrow/QuasiQuoter.hs
+++ b/src/Control/Arrow/QuasiQuoter.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Control.Arrow.QuasiQuoter
   ( proc
+  , procEx
   ) where
 
 import Control.Arrow.Notation
@@ -23,15 +24,15 @@
 --   @
 
 proc :: QuasiQuoter
-proc = QuasiQuoter
-  { quoteExp  = quote
+proc = procEx defaultParseMode{extensions = defaultExtensions}
+
+procEx :: ParseMode -> QuasiQuoter
+procEx parseMode = QuasiQuoter
+  { quoteExp  = quoteEx parseMode
   , quotePat  = error "proc: pattern quotes not supported"
   , quoteType = error "proc: type quotes not supported"
   , quoteDec  = error "proc: dec quotes not supported"
   }
-
-quote :: String -> Q Exp
-quote = quoteEx defaultParseMode { extensions = defaultExtensions }
 
 quoteEx :: ParseMode -> String -> Q Exp
 quoteEx mode inp =
diff --git a/src/NewCode.hs b/src/NewCode.hs
--- a/src/NewCode.hs
+++ b/src/NewCode.hs
@@ -34,7 +34,7 @@
 getLoc (Loc s) = s
 getLoc other   = error $ "getLoc: " ++ show other
 
-pattern ReturnA l = ExprHole (ReturnCode l)
+pattern ReturnA l = Var OpCode (Special OpCode (ExprHole (ReturnCode l)))
 pattern Arr l i pat bb e = Lambda (ArrCode l i bb) [pat] e
 pattern Compose a bb c <- List ComposeCode ( split -> (a,bb,c) )
   where
diff --git a/src/Utils.hs b/src/Utils.hs
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedLists     #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing -Wno-orphans #-}
@@ -14,6 +15,7 @@
   , freeVarss
   , definedVars
   , irrPat
+  , trimPat
   , left, right
   , pair
   , pairP
@@ -44,13 +46,14 @@
 import           Data.Set                      (Set)
 import qualified Data.Set                      as Set
 import           Debug.Hoed.Pure               hiding (Module)
+import           Debug.Hoed.Pure.TH
 import           Language.Haskell.Exts
 import qualified Language.Haskell.Exts.Util    as HSE
 #ifdef DEBUG
 import           Language.Haskell.Exts.Observe ()
 #endif
-import SrcLocs
-import NewCode
+import           NewCode
+import           SrcLocs
 
 freeVars
   :: ( Observable a
@@ -95,16 +98,25 @@
 times :: Int -> (a -> a) -> a -> a
 times n f x = iterate f x !! n
 
+-- | Hide variables that don't satisfy a predicate
+filterPat :: (Data a) => (Name a -> Bool) -> Pat a -> Pat a
+filterPat pred = transform go where
+  go p@(PVar l n)
+    | pred n = p
+    | otherwise = PWildCard l
+  go (PAsPat _ n p)
+    | not(pred n) = go p
+  go x = x
+
 -- | Hide variables from a pattern
-hidePat :: Set (Name ()) -> Pat S -> Pat S
-hidePat vs = transform (go vs) where
-  go vs p@(PVar l n)
-    | void n `Set.member` vs = PWildCard l
-    | otherwise = p
-  go vs (PAsPat _ n p)
-    | void n `Set.member` vs = go vs p
-  go _ x = x
+hidePat :: Data a => Set (Name ()) -> Pat a -> Pat a
+hidePat vs = filterPat (not . (`Set.member` vs) . void)
 
+obs [d|
+  trimPat :: Exp S -> Pat S -> Pat S
+  trimPat vs = filterPat ((`Set.member` freeVars vs) . void)
+    |]
+
 pair :: Exp code -> Exp code -> Exp code
 pair e1 e2 = Tuple (ann e1) Boxed [e1, e2]
 
@@ -168,6 +180,8 @@
 -- Override some AST instances for comprehension
 instance {-# OVERLAPS #-} Observable (Exp Code) where
   observer = observePretty
+instance {-# OVERLAPS #-} Observable (Exp S) where
+  observer = observePretty
 instance {-# OVERLAPS #-} Observable (Name S) where
   observer = observePretty
 instance {-# OVERLAPS #-} Observable (QName S) where
@@ -179,6 +193,8 @@
   observer = observePretty
 instance {-# OVERLAPS #-} Observable (Pat Code) where
   observer = observePretty
+instance {-# OVERLAPS #-} Observable (Pat S) where
+  observer = observePretty
 instance {-# OVERLAPS #-} Observable (QOp S) where
   observer = observePretty
 instance {-# OVERLAPS #-} Observable (Op S) where
@@ -188,6 +204,10 @@
 instance {-# OVERLAPS #-} Observable (Alt S) where
   observer = observePretty
 instance {-# OVERLAPS #-} Observable (Set (Name S)) where
+  constrain = constrainBase
+  observer x cxt =
+    seq x $ send (between "[" "]"$ intercalate "," $ prettyPrint <$> map void (Set.toList x)) (return x) cxt
+instance {-# OVERLAPS #-} Observable (Set (Name ())) where
   constrain = constrainBase
   observer x cxt =
     seq x $ send (between "[" "]"$ intercalate "," $ prettyPrint <$> map void (Set.toList x)) (return x) cxt