diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -52,7 +52,7 @@
 **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 (currently only if-then-else). Example:
+3. It extends the desugaring to handle static conditional expressions. Example:
 ```
 proc inputs -> do
   results <- processor -< inputs
diff --git a/arrowp-qq.cabal b/arrowp-qq.cabal
--- a/arrowp-qq.cabal
+++ b/arrowp-qq.cabal
@@ -1,5 +1,5 @@
 Name:           arrowp-qq
-Version:        0.2.0.1
+Version:        0.2.1
 Cabal-Version:  >= 1.20
 Build-Type:     Simple
 License:        GPL
@@ -46,7 +46,7 @@
        Build-Depends:       NoHoed
 
     Hs-Source-Dirs: src
-    Other-Modules:  ArrCode ArrSyn Utils
+    Other-Modules:  ArrCode ArrSyn NewCode SrcLocs Utils
     Default-Language:    Haskell2010
 
 executable arrowp-ext
@@ -76,23 +76,25 @@
                  examples,
                  examples/cgi,
                  examples/circuits,
-                 examples/Parser,
+                 examples/parser,
                  examples/powertrees,
                  examples/small
   main-is:             Main.hs
   other-modules:       
                        Parser,
                        ExprParser,
-                       BackStateArrow,
+                       BackstateArrow,
                        Conditional,
                        ListOps,
                        Egs,
                        Eval,
                        Eval1,
+                       GHC, 
                        Lift,
                        ListOps,
+                       Static,
                        TH.TH,
                        TH.While,
-                       TH.BackStateArrow
+                       TH.BackstateArrow
   build-depends:
     base, arrows, arrowp-qq, template-haskell
diff --git a/examples/GHC.hs b/examples/GHC.hs
new file mode 100644
--- /dev/null
+++ b/examples/GHC.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE Arrows #-}
+module GHC where
+
+import Control.Arrow
+
+ghc,trivial :: Arrow a => a inp chunk -> a chunk out -> a inp out
+trivial chunk process = proc inputs -> do
+   chunked <- chunk -< inputs
+   results <- process -< chunked
+   returnA -< results
+
+ghc chunk process =
+  arr(\inputs -> (inputs,inputs)) >>> first chunk >>> first process >>> arr fst
diff --git a/examples/Main.hs b/examples/Main.hs
--- a/examples/Main.hs
+++ b/examples/Main.hs
@@ -8,11 +8,13 @@
 import           Eval              ()
 import           Eval1             ()
 import           ExprParser        ()
+import           GHC               ()
 import           Hom               ()
 import           Lift              ()
 import           ListOps           ()
-import           TH.TH             ()
+import           Static            ()
 import           TH.BackstateArrow ()
+import           TH.TH             ()
 import           TH.While          ()
 
 
diff --git a/examples/Parser/ExprParser.lhs b/examples/Parser/ExprParser.lhs
deleted file mode 100644
--- a/examples/Parser/ExprParser.lhs
+++ /dev/null
@@ -1,91 +0,0 @@
-> {-# OPTIONS -F -pgmF arrowp-ext #-}
-> module ExprParser where
-
-> import Data.Char
-
-> import Control.Arrow
-> import Control.Arrow.Transformer.Error
-
-> import Parser
-
-Expressions
-
-> data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown | EOF
->	deriving (Show, Eq, Ord)
-
-> instance Symbol ESym where
->	eof = EOF
-
-> type ExprParser = Parser ESym String (->)
-> type ExprSym = Sym ESym String
-
-The grammar
-
-> expr :: ExprParser () Int
-> expr = proc () -> do
->		x <- term -< ()
->		expr' -< x
-
-> expr' :: ExprParser Int Int
-> expr' = proc x -> do
->		returnA -< x
->	<+> do
->		symbol Plus -< ()
->		y <- term -< ()
->		expr' -< x + y
->	<+> do
->		symbol Minus -< ()
->		y <- term -< ()
->		expr' -< x - y
-
-> term :: ExprParser () Int
-> term = proc () -> do
->		x <- factor -< ()
->		term' -< x
-
-> term' :: ExprParser Int Int
-> term' = proc x -> do
->		returnA -< x
->	<+> do
->		symbol Mult -< ()
->		y <- factor -< ()
->		term' -< x * y
->	<+> do
->		symbol Div -< ()
->		y <- factor -< ()
->		term' -< x `div` y
-
-> factor :: ExprParser () Int
-> factor = proc () -> do
->		v <- symbol Number -< ()
->		returnA -< read v::Int
->	<+> do
->		symbol Minus -< ()
->		v <- factor -< ()
->		returnA -< -v
->	<+> do
->		symbol LPar -< ()
->		v <- expr -< ()
->		symbol RPar -< ()
->		returnA -< v
-
-Lexical analysis
-
-> lexer :: String -> [ExprSym]
-> lexer [] = []
-> lexer ('(':cs) = Sym LPar "(":lexer cs
-> lexer (')':cs) = Sym RPar ")":lexer cs
-> lexer ('+':cs) = Sym Plus "+":lexer cs
-> lexer ('-':cs) = Sym Minus "-":lexer cs
-> lexer ('*':cs) = Sym Mult "*":lexer cs
-> lexer ('/':cs) = Sym Div "/":lexer cs
-> lexer (c:cs)
->	| isSpace c = lexer cs
->	| isDigit c = Sym Number (c:w):lexer cs'
->	| otherwise = Sym Unknown [c]:lexer cs
->		where (w,cs') = span isDigit cs
-
-> run parser = runError (runParser parser)
->	(\(_, err) -> error ("parse error: " ++ err)) . lexer
-
-> t = run expr
diff --git a/examples/Parser/Parser.lhs b/examples/Parser/Parser.lhs
deleted file mode 100644
--- a/examples/Parser/Parser.lhs
+++ /dev/null
@@ -1,254 +0,0 @@
-> {-# OPTIONS -F -pgmF arrowp-ext #-}
-
-LL(1) parser combinators: an arrow-ized (and greatly cut-down) version
-of those of "Deterministic, Error-Correcting Combinator Parsers", by
-Swierstra and Duponcheel.  This version uses statically constructed
-parse tables, but doesn't do error correction.
-
-> module Parser(
->	Symbol(eof), Sym(Sym),
->	Parser, symbol, runParser
-> ) where
-
-> import Control.Arrow
-> import Control.Arrow.Operations
-> import Control.Arrow.Transformer
-> import Control.Arrow.Transformer.Error
-> import Control.Arrow.Transformer.State
-> import Control.Arrow.Transformer.Static
-> import Control.Category
-> import Prelude hiding (id, (.))
-
-We require a symbol for EOF, distinguished from all existing symbols:
-
-> class (Ord s, Show s) => Symbol s where
->	eof :: s
-
-Combine a token with other information
-
-> data Sym s v = Sym s v
-
-> token (Sym s _) = s
-> value (Sym _ v) = v
-
-> instance (Show s, Show v) => Show (Sym s v) where
->	showsPrec p (Sym s v) = showParen True
->		(shows s . showString ", " . shows v)
-
-> eofSym :: Symbol s => Sym s v
-> eofSym = Sym s (error (show s ++ " has no value"))
->	where	s = eof
-
-A dynamic parser may fail or transform a list of symbols.
-
-> type DynamicParser s v a = StateArrow [Sym s v] (ErrorArrow String a)
-
-> liftDynamic :: ArrowChoice a => a b c -> DynamicParser s v a b c
-> liftDynamic f = lift (lift f)
-
-The auxilliary definitions fetchHead and advance, with their explicit
-type signatures, are needed to avoid nasty type errors.
-
-> fetchHead :: ArrowChoice a => DynamicParser s v a b (Sym s v)
-> fetchHead = proc _ -> do
->		(s:_) <- fetch -< ()
->		returnA -< s
-
-> getToken :: ArrowChoice a => DynamicParser s v a b s
-> getToken = fetchHead >>> arr token
-
-> advance :: ArrowChoice a => DynamicParser s v a b (Sym s v)
-> advance = proc _ -> do
->		(s:ss) <- fetch -< ()
->		store -< ss
->		returnA -< s
-
-The dynamic symbol parser ignores the symbol, as it will already have
-been checked by the table lookup.
-
-> unitDP :: ArrowChoice a => DynamicParser s v a b v
-> unitDP = advance >>> arr value
-
-Use the static information to construct a dynamic parser.
-
-If the table is empty, we know statically that any lookup will fail.
-
-> mkDynamic :: (Symbol s, ArrowChoice a) =>
->	Maybe (a b c) -> Table s (DynamicParser s v a b c) ->
->		DynamicParser s v a b c
-> mkDynamic Nothing t = arr id &&& getToken >>> lookupTable t err
->	where	err = proc _ -> raise -< "expected " ++ show (keys t)
-> mkDynamic (Just f) t
->	| isEmptyTable t = liftDynamic f
->	| otherwise = arr id &&& getToken >>> lookupTable t base
->	where	base = proc (b, _) -> liftDynamic f -< b
-
-If a parser arrow can recognize the empty string, it needs a function
-to transform input to output.
-
-> data Parser s v a b c = SP {
->		emptyP :: StaticMonadArrow Maybe a b c,
->		table :: Table s (DynamicParser s v a b c),
->		dynamic :: DynamicParser s v a b c
->				-- dynamic = mkDynamic empty table
->	}
-
-> mkParser :: (Symbol s, ArrowChoice a) =>
->	StaticMonadArrow Maybe a b c -> Table s (DynamicParser s v a b c) ->
->		Parser s v a b c
-> mkParser e t = SP {
->		emptyP = e,
->		table = t,
->		dynamic = mkDynamic (unwrapM e) t
->	}
-
-> symbol :: (Symbol s, ArrowChoice a) => s -> Parser s v a b v
-> symbol s = mkParser (wrapM Nothing) (unitTable s unitDP)
-
-> eofParser :: (Symbol s, ArrowChoice a) => Parser s v a b b
-> eofParser = proc x -> do
->	symbol eof -< ()
->	returnA -< x
-
-> instance (Symbol s, ArrowChoice a) => Arrow (Parser s v a) where
->	arr f = mkParser (arr f) emptyTable
->	first (SP{emptyP = e, table = t}) =
->		mkParser (first e) (fmap first t)
-
-> instance (Symbol s, ArrowChoice a) => Category (Parser s v a) where
->       id = arr id
->	~SP{emptyP = e2, table = t2, dynamic = d2} . SP{emptyP = e1, table = t1} =
->		if isEmptyTable common
->		then mkParser (e1 >>> e2) (plusTable t1' t2')
->		else error ("parse conflict (concatenation) on " ++
->				show (keys common))
->		where	common = intersectTable t1' t2'
->			t1' = fmap (>>> d2) t1
->			t2' = seqEmptyTable (unwrapM e1) t2
->			seqEmptyTable Nothing _ = emptyTable
->			seqEmptyTable (Just f) t = fmap (liftDynamic f >>>) t
-
-> instance (Symbol s, ArrowChoice a) => ArrowZero (Parser s v a) where
->	zeroArrow = mkParser (wrapM Nothing) emptyTable
-
-> instance (Symbol s, ArrowChoice a) => ArrowPlus (Parser s v a) where
->	SP{emptyP = e1, table = t1} <+> SP{emptyP = e2, table = t2} =
->		if isEmptyTable common
->		then mkParser (wrapM (plusEmpty (unwrapM e1) (unwrapM e2)))
->			      (plusTable t1 t2)
->		else error ("parse conflict (union) on " ++ show (keys common))
->		where	common = intersectTable t1 t2
->			plusEmpty Nothing e2 = e2
->			plusEmpty e1 Nothing = e1
->			plusEmpty _ _ = error "Empty-Empty"
-
-> instance (Symbol s, ArrowChoice a, ArrowLoop a) =>
->		ArrowLoop (Parser s v a) where
->	loop (SP{emptyP = e, table = t}) =
->		mkParser (wrapM (fmap loop (unwrapM e))) (fmap loop t)
-
-Run a parser on a complete input
-
-> runParser :: (Symbol s, ArrowChoice a) =>
->	Parser s v a () b -> ErrorArrow String a [Sym s v] b
-> runParser p = proc ss -> do
->			(v, _) <- rp -< ((), ss ++ [eofSym])
->			returnA -< v
->		where	rp = runState (dynamic (p >>> eofParser))
-
-general combinators
-
-> option :: ArrowPlus a => (b -> c) -> a b c -> a b c
-> option f p = arr f <+> p
-
-> many :: ArrowPlus a => a b c -> a b [c]
-> many p = option (const []) (some p)
-
-> some :: ArrowPlus a => a b c -> a b [c]
-> some p = some_p
->	where	some_p = proc b -> do
->			c <- p -< b
->			cs <- many_p -< b
->			returnA -< c:cs
->		many_p = option (const []) (some_p)
-
-A different design:
-
-> optional :: ArrowPlus a => a b b -> a b b
-> optional p = arr id <+> p
-
-> star :: ArrowPlus a => a b b -> a b b
-> star p = p' where p' = optional (p >>> p')
-
-> plus :: ArrowPlus a => a b b -> a b b
-> plus p = p' where p' = p >>> optional p'
-
-Tables.
-
-During parser construction, these are represented as lists of pairs,
-ordered by the key.  Then these are transformed into balanced search
-trees for use in parsing.
-
-> newtype Table k v = Table [(k, v)]
-
-> emptyTable :: Table k v
-> emptyTable = Table []
-
-> unitTable :: k -> v -> Table k v
-> unitTable k v = Table [(k, v)]
-
-> instance Functor (Table k) where
->	fmap f (Table kvs) = Table [(k, f v) | (k, v) <- kvs]
-
-Combine two tables.  In case of conflicts, the first takes precedence.
-
-> plusTable :: Ord k => Table k v -> Table k v -> Table k v
-> plusTable (Table t1) (Table t2) = Table (merge t1 t2)
->	where	merge [] kvs2 = kvs2
->		merge kvs1 [] = kvs1
->		merge (kvs1@(p1@(k1, _):kvs1')) (kvs2@(p2@(k2, _):kvs2')) =
->			case compare k1 k2 of
->			LT -> p1:merge kvs1' kvs2
->			EQ -> p1:merge kvs1' kvs2'
->			GT -> p2:merge kvs1 kvs2'
-
-> intersectTable :: Ord k => Table k v1 -> Table k v2 -> Table k (v1, v2)
-> intersectTable (Table t1) (Table t2) = Table (merge t1 t2)
->	where	merge [] _ = []
->		merge _ [] = []
->		merge (kvs1@((k1, v1):kvs1')) (kvs2@((k2, v2):kvs2')) =
->			case compare k1 k2 of
->			LT -> merge kvs1' kvs2
->			EQ -> (k1, (v1, v2)):merge kvs1' kvs2'
->			GT -> merge kvs1 kvs2'
-
-> isEmptyTable :: Table k v -> Bool
-> isEmptyTable (Table t) = null t
-
-> keys :: Table k v -> [k]
-> keys (Table kvs) = map fst kvs
-
-> data SearchTree k v = Empty | Node (SearchTree k v) k v (SearchTree k v)
-
-Make a balanced search tree from a table
-
-> searchTree :: Ord k => Table k v -> SearchTree k v
-> searchTree (Table kvs) = fst (mkTree (length kvs) kvs)
->	where	mkTree :: Int -> [(k,v)] -> (SearchTree k v, [(k,v)])
->		mkTree n kvs = if n == 0 then (Empty, kvs)
->			else	let	size_l = (n-1) `div` 2
->					(l, (k, v):kvs') = mkTree size_l kvs
->					(r, kvs'') = mkTree (n-1-size_l) kvs'
->				in (Node l k v r, kvs'')
-
-Construct an arrow that searches for dynamic inputs in the statically
-constructed tree of arrows.
-
-> lookupTable :: (ArrowChoice a, Ord k) =>
->	Table k (a b c) -> a (b, k) c -> a (b, k) c
-> lookupTable t def = look (searchTree t)
->	where	look Empty = def
->		look (Node l k a r) = proc (v, x) -> case compare x k of
->			LT -> look l -< (v, x)
->			EQ -> a -< v
->			GT -> look r -< (v, x)
diff --git a/examples/Static.hs b/examples/Static.hs
new file mode 100644
--- /dev/null
+++ b/examples/Static.hs
@@ -0,0 +1,36 @@
+{-# OPTIONS -F -pgmF arrowp-ext #-}
+module Static where
+
+import Control.Arrow
+
+ifEx :: Arrow a => Bool -> a inp out -> a out () -> a inp out
+ifEx outputResultsArg processor outputSink = proc inputs -> do
+  results <- processor -< inputs
+  if outputResultsArg
+    then outputSink -< results
+    else returnA -< ()
+  processor -< results
+
+ifEx' :: Arrow a => Bool -> a inp out -> a out () -> a inp out
+ifEx' outputResultsArg processor outputSink = proc inputs -> do
+  results <- processor -< inputs
+  results <- if outputResultsArg
+    then outputSink -< results
+    else returnA -< results
+  processor -< results
+
+caseEx :: Arrow a => Bool -> a inp out -> a out () -> a inp out
+caseEx outputResultsArg processor outputSink = proc inputs -> do
+  results <- processor -< inputs
+  case outputResultsArg of
+    True -> outputSink -< results
+    False -> returnA -< ()
+  processor -< results
+
+caseEx' :: Arrow a => Bool -> a inp out -> a out () -> a inp out
+caseEx' outputResultsArg processor outputSink = proc inputs -> do
+  results <- processor -< inputs
+  results <- case outputResultsArg of
+               True -> outputSink -< results
+               False -> returnA -< results
+  processor -< results
diff --git a/examples/TH/BackStateArrow.hs b/examples/TH/BackStateArrow.hs
deleted file mode 100644
--- a/examples/TH/BackStateArrow.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-module TH.BackstateArrow where
-
-import           Control.Arrow
-import           Control.Arrow.QuasiQuoter
-import           Control.Category
-import           Prelude                   hiding (id, (.))
-
--- Generalizing the backwards state transformer monad mentioned
--- in Wadler's "The Essence of Functional Programming"
-
-newtype BackStateArrow s a b c = BST (a (b,s) (c,s))
-
-instance ArrowLoop a => Category (BackStateArrow s a) where
-	BST g . BST f = BST $ [proc| (b, s) -> do
-			rec	(c, s'') <- f -< (b, s')
-				(d, s') <- g -< (c, s)
-			returnA -< (d, s'')|]
-
-instance ArrowLoop a => Arrow (BackStateArrow s a) where
-	arr f = BST [proc| (b, s) ->
-			returnA -< (f b, s)|]
-	first (BST f) = BST $ [proc| ((b, d), s) -> do
-			(c, s') <- f -< (b, s)
-			returnA -< ((c, d), s')|]
-
-instance (ArrowLoop a, ArrowChoice a) => ArrowChoice (BackStateArrow s a) where
-	left (BST f) = BST $ [proc| (x, s) ->
-		case x of
-			Left b -> do
-				(c, s') <- f -< (b, s)
-				returnA -< (Left c, s')
-			Right d ->
-				returnA -< (Right d, s) |]
-
-instance ArrowLoop a => ArrowLoop (BackStateArrow s a) where
-	loop (BST f) = BST $  [proc| (b, s) -> do
-			rec	((c, d), s') <- f -< ((b, d), s)
-			returnA -< (c, s') |]
diff --git a/examples/TH/BackstateArrow.hs b/examples/TH/BackstateArrow.hs
new file mode 100644
--- /dev/null
+++ b/examples/TH/BackstateArrow.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE QuasiQuotes #-}
+module TH.BackstateArrow where
+
+import           Control.Arrow
+import           Control.Arrow.QuasiQuoter
+import           Control.Category
+import           Prelude                   hiding (id, (.))
+
+-- Generalizing the backwards state transformer monad mentioned
+-- in Wadler's "The Essence of Functional Programming"
+
+newtype BackStateArrow s a b c = BST (a (b,s) (c,s))
+
+instance ArrowLoop a => Category (BackStateArrow s a) where
+	BST g . BST f = BST $ [proc| (b, s) -> do
+			rec	(c, s'') <- f -< (b, s')
+				(d, s') <- g -< (c, s)
+			returnA -< (d, s'')|]
+
+instance ArrowLoop a => Arrow (BackStateArrow s a) where
+	arr f = BST [proc| (b, s) ->
+			returnA -< (f b, s)|]
+	first (BST f) = BST $ [proc| ((b, d), s) -> do
+			(c, s') <- f -< (b, s)
+			returnA -< ((c, d), s')|]
+
+instance (ArrowLoop a, ArrowChoice a) => ArrowChoice (BackStateArrow s a) where
+	left (BST f) = BST $ [proc| (x, s) ->
+		case x of
+			Left b -> do
+				(c, s') <- f -< (b, s)
+				returnA -< (Left c, s')
+			Right d ->
+				returnA -< (Right d, s) |]
+
+instance ArrowLoop a => ArrowLoop (BackStateArrow s a) where
+	loop (BST f) = BST $  [proc| (b, s) -> do
+			rec	((c, d), s') <- f -< ((b, d), s)
+			returnA -< (c, s') |]
diff --git a/examples/parser/ExprParser.lhs b/examples/parser/ExprParser.lhs
new file mode 100644
--- /dev/null
+++ b/examples/parser/ExprParser.lhs
@@ -0,0 +1,91 @@
+> {-# OPTIONS -F -pgmF arrowp-ext #-}
+> module ExprParser where
+
+> import Data.Char
+
+> import Control.Arrow
+> import Control.Arrow.Transformer.Error
+
+> import Parser
+
+Expressions
+
+> data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown | EOF
+>	deriving (Show, Eq, Ord)
+
+> instance Symbol ESym where
+>	eof = EOF
+
+> type ExprParser = Parser ESym String (->)
+> type ExprSym = Sym ESym String
+
+The grammar
+
+> expr :: ExprParser () Int
+> expr = proc () -> do
+>		x <- term -< ()
+>		expr' -< x
+
+> expr' :: ExprParser Int Int
+> expr' = proc x -> do
+>		returnA -< x
+>	<+> do
+>		symbol Plus -< ()
+>		y <- term -< ()
+>		expr' -< x + y
+>	<+> do
+>		symbol Minus -< ()
+>		y <- term -< ()
+>		expr' -< x - y
+
+> term :: ExprParser () Int
+> term = proc () -> do
+>		x <- factor -< ()
+>		term' -< x
+
+> term' :: ExprParser Int Int
+> term' = proc x -> do
+>		returnA -< x
+>	<+> do
+>		symbol Mult -< ()
+>		y <- factor -< ()
+>		term' -< x * y
+>	<+> do
+>		symbol Div -< ()
+>		y <- factor -< ()
+>		term' -< x `div` y
+
+> factor :: ExprParser () Int
+> factor = proc () -> do
+>		v <- symbol Number -< ()
+>		returnA -< read v::Int
+>	<+> do
+>		symbol Minus -< ()
+>		v <- factor -< ()
+>		returnA -< -v
+>	<+> do
+>		symbol LPar -< ()
+>		v <- expr -< ()
+>		symbol RPar -< ()
+>		returnA -< v
+
+Lexical analysis
+
+> lexer :: String -> [ExprSym]
+> lexer [] = []
+> lexer ('(':cs) = Sym LPar "(":lexer cs
+> lexer (')':cs) = Sym RPar ")":lexer cs
+> lexer ('+':cs) = Sym Plus "+":lexer cs
+> lexer ('-':cs) = Sym Minus "-":lexer cs
+> lexer ('*':cs) = Sym Mult "*":lexer cs
+> lexer ('/':cs) = Sym Div "/":lexer cs
+> lexer (c:cs)
+>	| isSpace c = lexer cs
+>	| isDigit c = Sym Number (c:w):lexer cs'
+>	| otherwise = Sym Unknown [c]:lexer cs
+>		where (w,cs') = span isDigit cs
+
+> run parser = runError (runParser parser)
+>	(\(_, err) -> error ("parse error: " ++ err)) . lexer
+
+> t = run expr
diff --git a/examples/parser/Parser.lhs b/examples/parser/Parser.lhs
new file mode 100644
--- /dev/null
+++ b/examples/parser/Parser.lhs
@@ -0,0 +1,254 @@
+> {-# OPTIONS -F -pgmF arrowp-ext #-}
+
+LL(1) parser combinators: an arrow-ized (and greatly cut-down) version
+of those of "Deterministic, Error-Correcting Combinator Parsers", by
+Swierstra and Duponcheel.  This version uses statically constructed
+parse tables, but doesn't do error correction.
+
+> module Parser(
+>	Symbol(eof), Sym(Sym),
+>	Parser, symbol, runParser
+> ) where
+
+> import Control.Arrow
+> import Control.Arrow.Operations
+> import Control.Arrow.Transformer
+> import Control.Arrow.Transformer.Error
+> import Control.Arrow.Transformer.State
+> import Control.Arrow.Transformer.Static
+> import Control.Category
+> import Prelude hiding (id, (.))
+
+We require a symbol for EOF, distinguished from all existing symbols:
+
+> class (Ord s, Show s) => Symbol s where
+>	eof :: s
+
+Combine a token with other information
+
+> data Sym s v = Sym s v
+
+> token (Sym s _) = s
+> value (Sym _ v) = v
+
+> instance (Show s, Show v) => Show (Sym s v) where
+>	showsPrec p (Sym s v) = showParen True
+>		(shows s . showString ", " . shows v)
+
+> eofSym :: Symbol s => Sym s v
+> eofSym = Sym s (error (show s ++ " has no value"))
+>	where	s = eof
+
+A dynamic parser may fail or transform a list of symbols.
+
+> type DynamicParser s v a = StateArrow [Sym s v] (ErrorArrow String a)
+
+> liftDynamic :: ArrowChoice a => a b c -> DynamicParser s v a b c
+> liftDynamic f = lift (lift f)
+
+The auxilliary definitions fetchHead and advance, with their explicit
+type signatures, are needed to avoid nasty type errors.
+
+> fetchHead :: ArrowChoice a => DynamicParser s v a b (Sym s v)
+> fetchHead = proc _ -> do
+>		(s:_) <- fetch -< ()
+>		returnA -< s
+
+> getToken :: ArrowChoice a => DynamicParser s v a b s
+> getToken = fetchHead >>> arr token
+
+> advance :: ArrowChoice a => DynamicParser s v a b (Sym s v)
+> advance = proc _ -> do
+>		(s:ss) <- fetch -< ()
+>		store -< ss
+>		returnA -< s
+
+The dynamic symbol parser ignores the symbol, as it will already have
+been checked by the table lookup.
+
+> unitDP :: ArrowChoice a => DynamicParser s v a b v
+> unitDP = advance >>> arr value
+
+Use the static information to construct a dynamic parser.
+
+If the table is empty, we know statically that any lookup will fail.
+
+> mkDynamic :: (Symbol s, ArrowChoice a) =>
+>	Maybe (a b c) -> Table s (DynamicParser s v a b c) ->
+>		DynamicParser s v a b c
+> mkDynamic Nothing t = arr id &&& getToken >>> lookupTable t err
+>	where	err = proc _ -> raise -< "expected " ++ show (keys t)
+> mkDynamic (Just f) t
+>	| isEmptyTable t = liftDynamic f
+>	| otherwise = arr id &&& getToken >>> lookupTable t base
+>	where	base = proc (b, _) -> liftDynamic f -< b
+
+If a parser arrow can recognize the empty string, it needs a function
+to transform input to output.
+
+> data Parser s v a b c = SP {
+>		emptyP :: StaticMonadArrow Maybe a b c,
+>		table :: Table s (DynamicParser s v a b c),
+>		dynamic :: DynamicParser s v a b c
+>				-- dynamic = mkDynamic empty table
+>	}
+
+> mkParser :: (Symbol s, ArrowChoice a) =>
+>	StaticMonadArrow Maybe a b c -> Table s (DynamicParser s v a b c) ->
+>		Parser s v a b c
+> mkParser e t = SP {
+>		emptyP = e,
+>		table = t,
+>		dynamic = mkDynamic (unwrapM e) t
+>	}
+
+> symbol :: (Symbol s, ArrowChoice a) => s -> Parser s v a b v
+> symbol s = mkParser (wrapM Nothing) (unitTable s unitDP)
+
+> eofParser :: (Symbol s, ArrowChoice a) => Parser s v a b b
+> eofParser = proc x -> do
+>	symbol eof -< ()
+>	returnA -< x
+
+> instance (Symbol s, ArrowChoice a) => Arrow (Parser s v a) where
+>	arr f = mkParser (arr f) emptyTable
+>	first (SP{emptyP = e, table = t}) =
+>		mkParser (first e) (fmap first t)
+
+> instance (Symbol s, ArrowChoice a) => Category (Parser s v a) where
+>       id = arr id
+>	~SP{emptyP = e2, table = t2, dynamic = d2} . SP{emptyP = e1, table = t1} =
+>		if isEmptyTable common
+>		then mkParser (e1 >>> e2) (plusTable t1' t2')
+>		else error ("parse conflict (concatenation) on " ++
+>				show (keys common))
+>		where	common = intersectTable t1' t2'
+>			t1' = fmap (>>> d2) t1
+>			t2' = seqEmptyTable (unwrapM e1) t2
+>			seqEmptyTable Nothing _ = emptyTable
+>			seqEmptyTable (Just f) t = fmap (liftDynamic f >>>) t
+
+> instance (Symbol s, ArrowChoice a) => ArrowZero (Parser s v a) where
+>	zeroArrow = mkParser (wrapM Nothing) emptyTable
+
+> instance (Symbol s, ArrowChoice a) => ArrowPlus (Parser s v a) where
+>	SP{emptyP = e1, table = t1} <+> SP{emptyP = e2, table = t2} =
+>		if isEmptyTable common
+>		then mkParser (wrapM (plusEmpty (unwrapM e1) (unwrapM e2)))
+>			      (plusTable t1 t2)
+>		else error ("parse conflict (union) on " ++ show (keys common))
+>		where	common = intersectTable t1 t2
+>			plusEmpty Nothing e2 = e2
+>			plusEmpty e1 Nothing = e1
+>			plusEmpty _ _ = error "Empty-Empty"
+
+> instance (Symbol s, ArrowChoice a, ArrowLoop a) =>
+>		ArrowLoop (Parser s v a) where
+>	loop (SP{emptyP = e, table = t}) =
+>		mkParser (wrapM (fmap loop (unwrapM e))) (fmap loop t)
+
+Run a parser on a complete input
+
+> runParser :: (Symbol s, ArrowChoice a) =>
+>	Parser s v a () b -> ErrorArrow String a [Sym s v] b
+> runParser p = proc ss -> do
+>			(v, _) <- rp -< ((), ss ++ [eofSym])
+>			returnA -< v
+>		where	rp = runState (dynamic (p >>> eofParser))
+
+general combinators
+
+> option :: ArrowPlus a => (b -> c) -> a b c -> a b c
+> option f p = arr f <+> p
+
+> many :: ArrowPlus a => a b c -> a b [c]
+> many p = option (const []) (some p)
+
+> some :: ArrowPlus a => a b c -> a b [c]
+> some p = some_p
+>	where	some_p = proc b -> do
+>			c <- p -< b
+>			cs <- many_p -< b
+>			returnA -< c:cs
+>		many_p = option (const []) (some_p)
+
+A different design:
+
+> optional :: ArrowPlus a => a b b -> a b b
+> optional p = arr id <+> p
+
+> star :: ArrowPlus a => a b b -> a b b
+> star p = p' where p' = optional (p >>> p')
+
+> plus :: ArrowPlus a => a b b -> a b b
+> plus p = p' where p' = p >>> optional p'
+
+Tables.
+
+During parser construction, these are represented as lists of pairs,
+ordered by the key.  Then these are transformed into balanced search
+trees for use in parsing.
+
+> newtype Table k v = Table [(k, v)]
+
+> emptyTable :: Table k v
+> emptyTable = Table []
+
+> unitTable :: k -> v -> Table k v
+> unitTable k v = Table [(k, v)]
+
+> instance Functor (Table k) where
+>	fmap f (Table kvs) = Table [(k, f v) | (k, v) <- kvs]
+
+Combine two tables.  In case of conflicts, the first takes precedence.
+
+> plusTable :: Ord k => Table k v -> Table k v -> Table k v
+> plusTable (Table t1) (Table t2) = Table (merge t1 t2)
+>	where	merge [] kvs2 = kvs2
+>		merge kvs1 [] = kvs1
+>		merge (kvs1@(p1@(k1, _):kvs1')) (kvs2@(p2@(k2, _):kvs2')) =
+>			case compare k1 k2 of
+>			LT -> p1:merge kvs1' kvs2
+>			EQ -> p1:merge kvs1' kvs2'
+>			GT -> p2:merge kvs1 kvs2'
+
+> intersectTable :: Ord k => Table k v1 -> Table k v2 -> Table k (v1, v2)
+> intersectTable (Table t1) (Table t2) = Table (merge t1 t2)
+>	where	merge [] _ = []
+>		merge _ [] = []
+>		merge (kvs1@((k1, v1):kvs1')) (kvs2@((k2, v2):kvs2')) =
+>			case compare k1 k2 of
+>			LT -> merge kvs1' kvs2
+>			EQ -> (k1, (v1, v2)):merge kvs1' kvs2'
+>			GT -> merge kvs1 kvs2'
+
+> isEmptyTable :: Table k v -> Bool
+> isEmptyTable (Table t) = null t
+
+> keys :: Table k v -> [k]
+> keys (Table kvs) = map fst kvs
+
+> data SearchTree k v = Empty | Node (SearchTree k v) k v (SearchTree k v)
+
+Make a balanced search tree from a table
+
+> searchTree :: Ord k => Table k v -> SearchTree k v
+> searchTree (Table kvs) = fst (mkTree (length kvs) kvs)
+>	where	mkTree :: Int -> [(k,v)] -> (SearchTree k v, [(k,v)])
+>		mkTree n kvs = if n == 0 then (Empty, kvs)
+>			else	let	size_l = (n-1) `div` 2
+>					(l, (k, v):kvs') = mkTree size_l kvs
+>					(r, kvs'') = mkTree (n-1-size_l) kvs'
+>				in (Node l k v r, kvs'')
+
+Construct an arrow that searches for dynamic inputs in the statically
+constructed tree of arrows.
+
+> lookupTable :: (ArrowChoice a, Ord k) =>
+>	Table k (a b c) -> a (b, k) c -> a (b, k) c
+> lookupTable t def = look (searchTree t)
+>	where	look Empty = def
+>		look (Node l k a r) = proc (v, x) -> case compare x k of
+>			LT -> look l -< (v, x)
+>			EQ -> a -< v
+>			GT -> look r -< (v, x)
diff --git a/examples/small/BackStateArrow.hs b/examples/small/BackStateArrow.hs
deleted file mode 100644
--- a/examples/small/BackStateArrow.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{- LANGUAGE Arrows -}
-{-# OPTIONS -F -pgmF arrowp-ext #-}
-module BackstateArrow where
-
-import           Control.Arrow
-import           Control.Category
-import           Prelude          hiding (id, (.))
-
--- Generalizing the backwards state transformer monad mentioned
--- in Wadler's "The Essence of Functional Programming"
-
-newtype BackStateArrow s a b c = BST (a (b,s) (c,s))
-
-instance ArrowLoop a => Category (BackStateArrow s a) where
-	BST g . BST f = BST $ proc (b, s) -> do
-			rec	(c, s'') <- f -< (b, s')
-				(d, s') <- g -< (c, s)
-			returnA -< (d, s'')
-
-instance ArrowLoop a => Arrow (BackStateArrow s a) where
-	arr f = BST $ proc (b, s) ->
-			returnA -< (f b, s)
-	first (BST f) = BST $ proc ((b, d), s) -> do
-			(c, s') <- f -< (b, s)
-			returnA -< ((c, d), s')
-
-instance (ArrowLoop a, ArrowChoice a) => ArrowChoice (BackStateArrow s a) where
-	left (BST f) = BST $ proc (x, s) ->
-		case x of
-			Left b -> do
-				(c, s') <- f -< (b, s)
-				returnA -< (Left c, s')
-			Right d ->
-				returnA -< (Right d, s)
-
-instance ArrowLoop a => ArrowLoop (BackStateArrow s a) where
-	loop (BST f) = BST $ proc (b, s) -> do
-			rec	((c, d), s') <- f -< ((b, d), s)
-			returnA -< (c, s')
diff --git a/examples/small/BackstateArrow.hs b/examples/small/BackstateArrow.hs
new file mode 100644
--- /dev/null
+++ b/examples/small/BackstateArrow.hs
@@ -0,0 +1,39 @@
+{- LANGUAGE Arrows -}
+{-# OPTIONS -F -pgmF arrowp-ext #-}
+module BackstateArrow where
+
+import           Control.Arrow
+import           Control.Category
+import           Prelude          hiding (id, (.))
+
+-- Generalizing the backwards state transformer monad mentioned
+-- in Wadler's "The Essence of Functional Programming"
+
+newtype BackStateArrow s a b c = BST (a (b,s) (c,s))
+
+instance ArrowLoop a => Category (BackStateArrow s a) where
+	BST g . BST f = BST $ proc (b, s) -> do
+			rec	(c, s'') <- f -< (b, s')
+				(d, s') <- g -< (c, s)
+			returnA -< (d, s'')
+
+instance ArrowLoop a => Arrow (BackStateArrow s a) where
+	arr f = BST $ proc (b, s) ->
+			returnA -< (f b, s)
+	first (BST f) = BST $ proc ((b, d), s) -> do
+			(c, s') <- f -< (b, s)
+			returnA -< ((c, d), s')
+
+instance (ArrowLoop a, ArrowChoice a) => ArrowChoice (BackStateArrow s a) where
+	left (BST f) = BST $ proc (x, s) ->
+		case x of
+			Left b -> do
+				(c, s') <- f -< (b, s)
+				returnA -< (Left c, s')
+			Right d ->
+				returnA -< (Right d, s)
+
+instance ArrowLoop a => ArrowLoop (BackStateArrow s a) where
+	loop (BST f) = BST $ proc (b, s) -> do
+			rec	((c, d), s') <- f -< ((b, d), s)
+			returnA -< (c, s')
diff --git a/examples/small/Egs.hs b/examples/small/Egs.hs
--- a/examples/small/Egs.hs
+++ b/examples/small/Egs.hs
@@ -18,3 +18,13 @@
 				while p s -< x
 			else
 				returnA -< ()
+
+rightApp f = proc x -> do
+  y <- x >- f
+  () >- returnA
+  not y >- returnA
+
+identity f = proc x -> do
+  y <- f -< x
+  y' <- id -< y
+  returnA -< y
diff --git a/src/ArrCode.hs b/src/ArrCode.hs
--- a/src/ArrCode.hs
+++ b/src/ArrCode.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DeriveFunctor        #-}
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE FlexibleContexts     #-}
@@ -9,7 +11,7 @@
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 module ArrCode
-  ( Arrow
+  ( Arrow(..)
   , bind
   , anon
   , arr
@@ -19,7 +21,6 @@
   , infixOp
   , (|||)
   , first
-  , VarDecl
   , context
   , anonArgs
   , toHaskell
@@ -28,15 +29,6 @@
   , intersectTuple
   , patternTuple
   , expTuple
-  , returnA_exp
-  , arr_exp
-  , compose_op
-  , choice_op
-  , first_exp
-  , left_exp
-  , right_exp
-  , app_exp
-  , loop_exp
   , ifte
   , app
   , loop
@@ -45,70 +37,25 @@
 import           Data.Set                     (Set)
 import qualified Data.Set                     as Set
 import           Debug.Hoed.Pure
-import           Language.Haskell.Exts.Syntax hiding (Let, Tuple)
+import           Language.Haskell.Exts.Syntax hiding (Tuple)
 import qualified Language.Haskell.Exts.Syntax as H
+import           NewCode
 import           Utils
 
 data Arrow = Arrow
   { context  :: Tuple -- named input components used by the arrow
   , anonArgs :: Int     -- number of unnamed arguments
-  , code     :: Code
+  , code     :: Exp Code
   }
   deriving (Eq, Generic, Show)
 
 instance Located Arrow  where
-  type LocType Arrow = S
+  type LocType Arrow = Code
   location f (Arrow context anon code)=
-    Arrow <$> location f context <*> pure anon <*> location f code
+    Arrow context anon <$> location f code
 
 instance Observable Arrow
 
-data VarDecl a = VarDecl (Name S) a
-      deriving (Functor, Generic)
-
-instance (Located a, LocType a ~ S) => Located (VarDecl a) where
-  type LocType (VarDecl a) = S
-  location f (VarDecl n a) = VarDecl <$> location f n <*> location f a
-
--- required Undecidable instances
-deriving instance (Eq a) => Eq (VarDecl a)
-deriving instance (Show a) => Show (VarDecl a)
-
-instance Observable a => Observable (VarDecl a)
-
-data Code
-      = ReturnA                       -- returnA = arr id
-      | Arr Int (Pat S) [Binding] (Exp S)   -- arr (first^n (\p -> ... e))
-      | Compose Code [Code] Code  -- composition of 2 or more elts
-      | Op (Exp S) [Code]         -- combinator applied to arrows
-      | InfixOp Code (QOp S) Code
-      | Let [VarDecl Code] Code
-      | Ifte (Exp S) Code Code
-  deriving (Eq, Generic, Show)
-
-instance Located Code where
-  type LocType Code = S
-  location _ ReturnA = pure ReturnA
-  location f (Arr i pat bb e) =
-    Arr i <$> location f pat <*> location f bb <*> location f e
-  location f (Compose c1 cc c2) =
-    Compose <$> location f c1 <*> location f cc <*> location f c2
-  location f (Op e cc) = Op <$> location f e <*> location f cc
-  location f (InfixOp c qop c') = InfixOp <$> location f c <*> location f qop <*> location f c'
-  location f (Let vv c) = Let <$> location f vv <*> location f c
-  location f (Ifte e c1 c2) = Ifte <$> location f e <*> location f c1 <*> location f c2
-
-instance Observable Code
-
-data Binding = BindLet (Binds S) | BindCase (Pat S) (Exp S)
-  deriving (Eq,Generic, Show)
-instance Observable Binding
-
-instance Located Binding where
-  type LocType Binding = S
-  location f (BindLet b) = BindLet <$> location f b
-  location f (BindCase p e) = BindCase <$> location f p <*> location f e
-
 loop :: Arrow -> Arrow
 loop f = applyOp loop_exp [f]
 
@@ -125,15 +72,15 @@
   Arrow
   { code =
       if same p e
-        then ReturnA
-        else Arr anons p [] e
+        then ReturnA (ann e)
+        else Arr (ann e) anons (Loc <$> p) [] (Loc <$> e)
   , context = t `intersectTuple` freeVars e
   , anonArgs = anons
   }
 arrLet :: Int -> Tuple -> Pat S -> Binds S -> Exp S -> Arrow
 arrLet anons t p ds e =
   Arrow
-  { code = Arr anons p [BindLet ds] e
+  { code = Arr (ann e) anons (Loc <$> p) [BindLet (Loc <$> ds)] (Loc <$> e)
   , context = t `intersectTuple` vs
   , anonArgs = anons
   }
@@ -143,7 +90,7 @@
 ifte :: Exp S -> Arrow -> Arrow -> Arrow
 ifte c th el =
   Arrow
-  { code = Ifte c (code th) (code el)
+  { code = If (Loc$ ann c) (Loc <$> c) (code th) (code el)
   , context = context th `unionTuple` context el
   , anonArgs = 0
   }
@@ -154,15 +101,15 @@
   Arrow
   { code =
       if e == returnA_exp
-        then ReturnA
-        else Op e []
+        then ReturnA (ann e)
+        else Op (Loc <$> e) []
   , context = emptyTuple
   , anonArgs = 0
   }
 applyOp :: Exp S -> [Arrow] -> Arrow
 applyOp e as =
   Arrow
-  { code = Op e (map code as)
+  { code = Op (Loc <$> e) (map code as)
   , context = foldr (unionTuple . context) emptyTuple as
   , anonArgs = 0 -- BUG: see below
   }
@@ -170,7 +117,7 @@
 infixOp :: Arrow -> QOp S -> Arrow -> Arrow
 infixOp a1 op a2 =
   Arrow
-  { code = InfixOp (code a1) op (code a2)
+  { code = InfixApp def (code a1) (Loc <$> op) (code a2)
   , context = context a1 `unionTuple` context a2
   , anonArgs = 0 -- BUG: as above
   }
@@ -184,21 +131,21 @@
 (|||) :: Arrow -> Arrow -> Arrow
 a1 ||| a2 =
   Arrow
-  { code = InfixOp (code a1) choice_op (code a2)
+  { code = InfixApp def (code a1) (choice_op) (code a2)
   , context = context a1 `unionTuple` context a2
   , anonArgs = 0
   }
 
-compose :: Code -> Code -> Code
+compose :: Exp Code -> Exp Code -> Exp Code
 compose = observe "compose" compose'
 
-compose' :: Code -> Code -> Code
-compose' ReturnA a = a
-compose' a ReturnA = a
-compose' a1@(Arr n1 p1 ds1 e1) a2@(Arr n2 p2 ds2 e2)
+compose' :: Exp Code -> Exp Code -> Exp Code
+compose' ReturnA{} a = a
+compose' a ReturnA{} = a
+compose' a1@(Arr l1 n1 p1 ds1 e1) a2@(Arr l2 n2 p2 ds2 e2)
   | n1 /= n2 = Compose a1 [] a2 -- could do better, but can this arise?
-  | same p2 e1 = Arr n1 p1 (ds1 ++ ds2) e2
-  | otherwise = Arr n1 p1 (ds1 ++ BindCase p2 e1 : ds2) e2
+  | same p2 e1 = Arr l1 n1 p1 (ds1 ++ ds2) e2
+  | otherwise = Arr l1 n1 p1 (ds1 ++ BindCase p2 e1 : ds2) e2
 compose' (Compose f1 as1 g1) (Compose f2 as2 g2) =
   Compose f1 (as1 ++ (g1 : f2 : as2)) g2
 compose' a (Compose f bs g) = Compose (compose a f) bs g
@@ -208,33 +155,42 @@
 toHaskell :: Arrow -> Exp S
 toHaskell = rebracket1 . toHaskellCode . code
   where
-    toHaskellCode :: Code -> Exp S
-    toHaskellCode ReturnA = returnA_exp
-    toHaskellCode (Arr n p bs e) =
-      App def arr_exp (times n (Paren def . App def first_exp) body)
+    toHaskellCode :: Exp Code -> Exp S
+    toHaskellCode (ReturnA l) = const l <$> returnA_exp @ S
+    toHaskellCode (Arr l n p bs e) =
+      App l arr_exp (times n (Paren def . App def first_exp) body)
       where
-        body = Lambda def [p] (foldr addBinding e bs)
-        addBinding (BindLet ds) e = H.Let def ds e
+        body :: Exp S
+        body = Lambda def [getLoc <$> p] (foldr addBinding (getLoc <$> e) bs)
+        addBinding :: Binding -> Exp S -> Exp S
+        addBinding (BindLet ds) e = H.Let def (getLoc <$> ds) e
         addBinding (BindCase p e) e' =
-          Case def e [Alt def p (UnGuardedRhs def e') Nothing]
+          Case def (getLoc <$> e) [Alt def (getLoc <$> p) (UnGuardedRhs def e') Nothing]
     toHaskellCode (Compose f as g) =
       foldr (comp . toHaskellArg) (toHaskellArg g) (f : as)
       where
         comp f = InfixApp def f compose_op
-    toHaskellCode (Op op as) = foldl (App def) op (map (Paren def . toHaskellCode) as)
-    toHaskellCode (InfixOp a1 op a2) =
-      InfixApp def (toHaskellArg a1) op (toHaskellArg a2)
-    toHaskellCode (Let nas a) =
-      H.Let def (BDecls def $ map toHaskellDecl nas) (toHaskellCode a)
-      where
-        toHaskellDecl (VarDecl n a) =
-          PatBind def (PVar def n) (UnGuardedRhs def (toHaskellCode a)) Nothing
-    toHaskellCode (Ifte cond th el) = If def cond (toHaskellCode th) (toHaskellCode el)
-
+    toHaskellCode (Op op as) =
+      foldl (App def) (getLoc <$> op) (map (Paren def . toHaskellCode) as)
+    toHaskellCode (InfixApp (Loc l) a1 op a2) =
+      InfixApp l (toHaskellArg a1) (getLoc <$> op) (toHaskellArg a2)
+    toHaskellCode (Let (Loc l) bb a) =
+      H.Let l (getLoc <$> bb) (toHaskellCode a)
+    toHaskellCode (If (Loc l) cond th el) =
+      If l (getLoc <$> cond) (toHaskellCode th) (toHaskellCode el)
+    toHaskellCode (Case (Loc l) e alts) =
+      Case l (getLoc <$> e) (toHaskellAlt <$> alts)
+    toHaskellAlt (Alt (Loc l) pat rhs binds) =
+      Alt l (getLoc <$> pat) (toHaskellRhs rhs) (getLoc <$$> binds)
+    toHaskellRhs (UnGuardedRhs (Loc l) e) = UnGuardedRhs l (toHaskellCode e)
+    toHaskellRhs (GuardedRhss (Loc l) rhss) =
+      GuardedRhss l (toHaskellGuardedRhs <$> rhss)
+    toHaskellGuardedRhs (GuardedRhs (Loc l) stmts e) =
+      GuardedRhs l (getLoc <$$> stmts) (toHaskellCode e)
     toHaskellArg = Paren def . toHaskellCode
 
 newtype Tuple = Tuple (Set (Name S))
-  deriving (Eq,Generic,Show)
+  deriving (Eq,Generic,Monoid,Show)
 instance Observable Tuple
 
 instance Located Tuple where
diff --git a/src/ArrSyn.hs b/src/ArrSyn.hs
--- a/src/ArrSyn.hs
+++ b/src/ArrSyn.hs
@@ -11,9 +11,11 @@
   ) where
 
 import           ArrCode
+import           NewCode
 import           Utils
 
 import           Control.Monad.Trans.State
+import           Control.Monad.Trans.Writer
 import           Data.List                  (mapAccumL)
 import           Data.Map                   (Map)
 import qualified Data.Map                   as Map
@@ -56,17 +58,19 @@
 transCmd = observe "transCmd" transCmd'
 
 transCmd' :: TransState -> Pat S -> Exp S -> Arrow
-transCmd' s p (H.LeftArrApp l f e)
+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' s p (H.RightArrApp     l f e) = transCmd s p (H.LeftArrApp l e f)
-transCmd' s p (H.RightArrHighApp l f e) = transCmd s p (H.LeftArrHighApp l e f)
-transCmd' s p (H.InfixApp l c1 op c2) =
+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 l decls c) =
+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
@@ -77,9 +81,20 @@
       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) =
+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
@@ -115,13 +130,13 @@
            else e)
 transCmd' s p (H.Paren _ c) =
       transCmd s p c
-transCmd' s p (H.Do l ss) =
+transCmd' s p (H.Do _ ss) =
       transDo s p (init ss) (let Qualifier _ e = last ss in e)
-transCmd' s p (H.App l c arg) =
+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 l ps 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
@@ -153,7 +168,7 @@
       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 l pg cg:ss) c =
+transDo' s p (Generator _ pg cg:ss) c =
       if isEmptyTuple u then
         transCmd s p cg >>> transDo s' pg ss c
       else
diff --git a/src/Control/Arrow/Notation.hs b/src/Control/Arrow/Notation.hs
--- a/src/Control/Arrow/Notation.hs
+++ b/src/Control/Arrow/Notation.hs
@@ -20,4 +20,6 @@
 translateExp :: Exp SrcSpanInfo -> Exp SrcSpanInfo
 translateExp (Proc _ pat exp) =
   getSrcSpanInfo <$> ArrSyn.translate (fmap S pat) (fmap S exp)
+translateExp (RightArrApp l e f) = LeftArrApp l f e
+translateExp (RightArrHighApp l e f) = LeftArrHighApp l f e
 translateExp other = other
diff --git a/src/NewCode.hs b/src/NewCode.hs
new file mode 100644
--- /dev/null
+++ b/src/NewCode.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE PatternSynonyms    #-}
+{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE ViewPatterns       #-}
+module NewCode where
+
+import           Data.Data
+import           Data.Default
+import           Debug.Hoed.Pure
+import           GHC.Generics                  (Generic)
+import           Language.Haskell.Exts.Syntax
+import           Language.Haskell.Exts.Util
+import           SrcLocs
+#ifdef DEBUG
+import           Language.Haskell.Exts.Observe ()
+#endif
+
+-- | AST annotations to extend the Haskell AST with an arrow core language
+data Code
+  = ReturnCode S
+  | ArrCode S Int [Binding]
+  | ComposeCode
+  | OpCode
+  | Loc S
+  deriving (Eq, Data, Ord, Generic, Show)
+
+instance Default Code where
+  def = Loc def
+
+instance Observable Code
+
+getLoc :: Code -> S
+getLoc (Loc s) = s
+getLoc other   = error $ "getLoc: " ++ show other
+
+pattern ReturnA l = 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
+    Compose a bb c = List ComposeCode (a : bb ++ [c])
+
+pattern Op e args = List OpCode (e:args)
+
+split :: [c] -> (c, [c], c)
+split (h:rest@(_:_)) = (h, init rest, last rest)
+split _              = error "Compose: unreachable"
+
+data Binding = BindLet (Binds Code) | BindCase (Pat Code) (Exp Code)
+  deriving (Eq, Data, Ord, Generic, Show)
+
+instance Observable Binding
+
+instance Located Binding where
+  type LocType Binding = Code
+  location f (BindLet b)    = BindLet <$> location f b
+  location f (BindCase p e) = BindCase <$> location f p <*> location f e
diff --git a/src/SrcLocs.hs b/src/SrcLocs.hs
new file mode 100644
--- /dev/null
+++ b/src/SrcLocs.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module SrcLocs where
+
+import           Data.Data
+import           Data.Default
+import           Debug.Hoed.Pure
+import           Language.Haskell.Exts
+
+-- | The type of src code locations used by arrowp-qq
+newtype S = S {getSrcSpanInfo :: SrcSpanInfo}
+  deriving (Data, Typeable)
+instance Eq S where _ == _ = True
+instance Ord S where compare _ _ = EQ
+instance Show S where show _ = "<loc>"
+
+instance Default S where
+  def = S noSrcSpan
+
+instance Observable S where
+  observer = observeOpaque "<loc>"
+  constrain = constrainBase
diff --git a/src/Utils.hs b/src/Utils.hs
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP                 #-}
-{-# LANGUAGE DeriveDataTypeable  #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE OverloadedLists     #-}
@@ -15,7 +14,6 @@
   , freeVars
   , freeVarss
   , definedVars
-  , hidePat
   , irrPat
   , left, right
   , pair
@@ -25,13 +23,15 @@
   , app_exp
   , arr_exp
   , first_exp
-  , left_exp, right_exp
   , loop_exp
   , returnA_exp
   , choice_op
   , compose_op
   , returnCmd
   , observeSt
+  , (<$$>)
+  , traverseAlt
+  , traverseAlts
   )where
 
 import           Control.Monad
@@ -50,41 +50,41 @@
 #ifdef DEBUG
 import           Language.Haskell.Exts.Observe ()
 #endif
-
--- | The type of src code locations used by arrowp-qq
-newtype S = S {getSrcSpanInfo :: SrcSpanInfo}
-  deriving (Data, Typeable)
-instance Eq S where _ == _ = True
-instance Ord S where compare _ _ = EQ
-instance Show S where show _ = "<loc>"
-
-instance Default S where
-  def = S noSrcSpan
-
-instance Observable S where
-  observer = observeOpaque "<loc>"
-  constrain = constrainBase
+import SrcLocs
+import NewCode
 
 freeVars
-  :: (Observable a, HSE.FreeVars a, S ~ HSE.LocType a)
-  => a -> Set (Name S)
+  :: ( Observable a
+     , Observable (Set (Name code))
+     , HSE.FreeVars a
+     , code ~ HSE.LocType a
+     )
+  => a -> Set (Name code)
 freeVars = observe "freeVars" HSE.freeVars
 
 freeVarss
-  :: (Observable a, HSE.AllVars a, S ~ HSE.LocType a)
-  => a -> Set (Name S)
+  :: ( Observable a
+     , Observable (Set (Name code))
+     , HSE.AllVars a
+     , code ~ HSE.LocType a
+     )
+  => a -> Set (Name code)
 freeVarss = observe "freeVarss" (HSE.free . HSE.allVars)
 
 definedVars
-  :: (Observable a, HSE.AllVars a, S ~ HSE.LocType a)
-  => a -> Set (Name S)
+  :: ( Observable a
+     , Observable (Set (Name code))
+     , HSE.AllVars a
+     , code ~ HSE.LocType a
+     )
+  => a -> Set (Name code)
 definedVars = observe "definedVars" (HSE.bound . HSE.allVars)
 
 -- | Are a tuple pattern and an expression tuple equal ?
-same :: Pat S -> Exp S -> Bool
+same :: (Eq s, Observable(Exp s), Observable(Pat s)) => Pat s -> Exp s -> Bool
 same = observe "same" same'
 
-same' :: Pat S -> Exp S -> Bool
+same' :: (Eq s, Observable(Exp s), Observable(Pat s)) => Pat s -> Exp s -> Bool
 same' (PApp _ n1 []) (Con _ n2) = n1 == n2
 same' (PVar l n1) (Var _ n2) = UnQual l n1 == n2
 same' (PTuple _ Boxed []) y = same (PApp (ann y) (unit_con_name (ann y)) []) y
@@ -112,27 +112,27 @@
     | n `Set.member` vs = go vs p
   go _ x = x
 
-pair :: Exp S -> Exp S -> Exp S
+pair :: Exp code -> Exp code -> Exp code
 pair e1 e2 = Tuple (ann e1) Boxed [e1, e2]
 
 pairP :: Pat S -> Pat S -> Pat S
 pairP p1 p2 = PTuple (ann p1) Boxed [hidePat (definedVars p2) p1, p2]
 
-left, right :: Exp S -> Exp S
+left, right :: Default code => Exp code -> Exp code
 left  x = App (ann x) left_exp  (Paren def x)
 right x = App (ann x) right_exp (Paren def x)
 
-returnCmd :: Exp S -> Exp S
+returnCmd :: Default code => Exp code -> Exp code
 returnCmd x = LeftArrApp (ann x) returnA_exp x
 
-compose_op, choice_op :: QOp S
-returnA_exp, arr_exp, first_exp :: Exp S
-left_exp, right_exp, app_exp, loop_exp :: Exp S
-unqualId :: String -> Exp S
+compose_op, choice_op :: Default s => QOp s
+returnA_exp, arr_exp, first_exp :: Default s => Exp s
+left_exp, right_exp, app_exp, loop_exp :: Default s => Exp s
+unqualId :: Default s => String -> Exp s
 unqualId   id = Var def $ UnQual def (Ident def id)
-unqualOp :: String -> QOp S
+unqualOp :: Default s => String -> QOp s
 unqualOp id = QVarOp def $ UnQual def (Symbol def id)
-unqualCon :: String -> Exp S
+unqualCon :: Default s => String -> Exp s
 unqualCon  id = Con def $ UnQual def (Symbol def id)
 arr_exp       = unqualId "arr"
 compose_op    = unqualOp ">>>"
@@ -173,7 +173,7 @@
   observer = observeBase
 
 -- Override some AST instances for comprehension
-instance {-# OVERLAPS #-} Observable (Exp S) where
+instance {-# OVERLAPS #-} Observable (Exp Code) where
   observer = observePretty
 instance {-# OVERLAPS #-} Observable (Name S) where
   observer = observePretty
@@ -184,7 +184,7 @@
     seq lit $ send (bracket $ intercalate ";" $ fmap prettyPrint lit) (return lit) cxt
 instance {-# OVERLAPS #-} Observable (Stmt S) where
   observer = observePretty
-instance {-# OVERLAPS #-} Observable (Pat S) where
+instance {-# OVERLAPS #-} Observable (Pat Code) where
   observer = observePretty
 instance {-# OVERLAPS #-} Observable (QOp S) where
   observer = observePretty
@@ -205,3 +205,11 @@
 bracket :: [Char] -> [Char]
 between open  close s = open ++ s ++ close
 bracket = between "[" "]"
+
+(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
+(<$$>) f = fmap (fmap f)
+
+traverseAlt :: (Data s, Monad a) => (Exp s -> a(Exp s)) -> Alt s -> a(Alt s)
+traverseAlt = descendBiM
+traverseAlts :: (Data s, Monad a) => (Exp s -> a(Exp s)) -> [Alt s] -> a [Alt s]
+traverseAlts = traverse.traverseAlt