diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c)2011, Emil Axelsson
+Copyright (c) 2011-2015, Emil Axelsson
 
 All rights reserved.
 
diff --git a/benchmarks/JoiningTypes.hs b/benchmarks/JoiningTypes.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/JoiningTypes.hs
@@ -0,0 +1,234 @@
+module JoiningTypes (main) where
+
+import Criterion.Main
+import Criterion.Types
+import Language.Syntactic
+import Language.Syntactic.Functional
+
+-- Normal DSL, not joined types.
+data Expr1 t where
+  EI    :: Int  -> Expr1 (Full Int)
+  EB    :: Bool -> Expr1 (Full Bool)
+  EAdd  :: Expr1 (Int :-> Int :-> Full Int)
+  EEq   :: (Eq t) => Expr1 (t   :-> t   :-> Full Bool)
+  EIf   :: Expr1 (Bool :-> a :-> a :-> Full a)
+
+type Expr1' a = AST Expr1 (Full a)
+
+int  :: Int -> Expr1' Int
+int = Sym . EI
+
+bool :: Bool -> Expr1' Bool
+bool = Sym . EB
+
+add  :: Expr1' Int -> Expr1' Int -> Expr1' Int
+add a b = Sym EAdd :$ a :$ b
+
+eq   :: (Eq a) => Expr1' a -> Expr1' a -> Expr1' Bool
+eq a b = Sym EEq :$ a :$ b
+
+if'  :: Expr1' Bool -> Expr1' a -> Expr1' a -> Expr1' a
+if' c a b = Sym EIf :$ c :$ a :$ b
+
+instance Render Expr1 where
+  renderSym (EI n)  = "EI"
+  renderSym (EB b)  = "EB"
+  renderSym (EAdd)  = "EAdd"
+  renderSym (EEq)   = "EEq"
+  renderSym (EIf)   = "EIf"
+
+instance Equality   Expr1
+instance StringTree Expr1
+
+instance Eval Expr1 where
+  evalSym (EI n)  = n
+  evalSym (EB b)  = b
+  evalSym EAdd    = (+)
+  evalSym EEq     = (==)
+  evalSym EIf     = \c a b -> if c then a else b
+
+instance EvalEnv Expr1 env where
+  compileSym p (EI n) = compileSymDefault signature p (EI n)
+  compileSym p (EB b) = compileSymDefault signature p (EB b)
+  compileSym p EAdd   = compileSymDefault signature p EAdd
+  compileSym p EEq    = compileSymDefault signature p EEq
+  compileSym p EIf    = compileSymDefault signature p EIf
+
+-- Joined types
+data ExprI t where
+  EIJ    :: Int  -> ExprI (Full Int)
+  EAddJ  :: ExprI (Int :-> Int :-> Full Int)
+
+data ExprB t where
+  EBJ    :: Bool -> ExprB (Full Bool)
+  EEqJ   :: (Eq t) => ExprB (t   :-> t   :-> Full Bool)
+  EIfJ   :: ExprB (Bool :-> a :-> a :-> Full a)
+
+type ExprJ = ExprI :+: ExprB
+type ExprJ' a = AST ExprJ (Full a)
+
+intJ  :: Int -> ExprJ' Int
+intJ = Sym . inj . EIJ
+
+boolJ :: Bool -> ExprJ' Bool
+boolJ = Sym . inj . EBJ
+
+addJ  :: ExprJ' Int -> ExprJ' Int -> ExprJ' Int
+addJ a b = Sym (inj EAddJ) :$ a :$ b
+
+eqJ   :: (Eq a) => ExprJ' a -> ExprJ' a -> ExprJ' Bool
+eqJ a b = Sym (inj EEqJ) :$ a :$ b
+
+ifJ  :: ExprJ' Bool -> ExprJ' a -> ExprJ' a -> ExprJ' a
+ifJ c a b = Sym (inj EIfJ) :$ c :$ a :$ b
+
+instance Render ExprI where
+  renderSym (EIJ n)  = "EI"
+  renderSym (EAddJ)  = "EAdd"
+instance Render ExprB where
+  renderSym (EBJ b)  = "EB"
+  renderSym (EEqJ)   = "EEq"
+  renderSym (EIfJ)   = "EIf"
+
+instance Equality   ExprI
+instance StringTree ExprI
+instance Equality   ExprB
+instance StringTree ExprB
+
+instance Eval ExprI where
+  evalSym (EIJ n) = n
+  evalSym EAddJ   = (+)
+
+instance Eval ExprB where
+  evalSym (EBJ b) = b
+  evalSym EEqJ    = (==)
+  evalSym EIfJ    = \c a b -> if c then a else b
+
+instance EvalEnv ExprI env where
+  compileSym p (EIJ n) = compileSymDefault signature p (EIJ n)
+  compileSym p EAddJ   = compileSymDefault signature p EAddJ
+
+instance EvalEnv ExprB env where
+  compileSym p (EBJ b) = compileSymDefault signature p (EBJ b)
+  compileSym p EEqJ    = compileSymDefault signature p EEqJ
+  compileSym p EIfJ    = compileSymDefault signature p EIfJ
+
+-- Joined types (4 joins)
+
+data Expr4J1 t where
+  E4JI    :: Int  -> Expr4J1 (Full Int)
+data Expr4J2 t where
+  E4JB    :: Bool -> Expr4J2 (Full Bool)
+data Expr4J3 t where
+  E4JAdd  :: Expr4J3 (Int :-> Int :-> Full Int)
+data Expr4J4 t where
+  E4JEq   :: (Eq t) => Expr4J4 (t   :-> t   :-> Full Bool)
+data Expr4J5 t where
+  E4JIf   :: Expr4J5 (Bool :-> a :-> a :-> Full a)
+
+type Expr4J = Expr4J1 :+: Expr4J2 :+: Expr4J3 :+: Expr4J4 :+: Expr4J5
+type Expr4J' a = AST Expr4J (Full a)
+
+int4  :: Int -> Expr4J' Int
+int4 = Sym . inj . E4JI
+
+bool4 :: Bool -> Expr4J' Bool
+bool4 = Sym . inj . E4JB
+
+add4  :: Expr4J' Int -> Expr4J' Int -> Expr4J' Int
+add4 a b = Sym (inj E4JAdd) :$ a :$ b
+
+eq4   :: (Eq a) => Expr4J' a -> Expr4J' a -> Expr4J' Bool
+eq4 a b = Sym (inj E4JEq) :$ a :$ b
+
+if4  :: Expr4J' Bool -> Expr4J' a -> Expr4J' a -> Expr4J' a
+if4 c a b = Sym (inj E4JIf) :$ c :$ a :$ b
+
+instance Render Expr4J1 where
+  renderSym (E4JI n)  = "EI"
+
+instance Render Expr4J2 where
+  renderSym (E4JB b)  = "EB"
+
+instance Render Expr4J3 where
+  renderSym (E4JAdd)  = "EAdd"
+
+instance Render Expr4J4 where
+  renderSym (E4JEq)   = "EEq"
+
+instance Render Expr4J5 where
+  renderSym (E4JIf)   = "EIf"
+
+instance Equality   Expr4J1
+instance StringTree Expr4J1
+instance Equality   Expr4J2
+instance StringTree Expr4J2
+instance Equality   Expr4J3
+instance StringTree Expr4J3
+instance Equality   Expr4J5
+instance StringTree Expr4J5
+
+instance Eval Expr4J1 where
+  evalSym (E4JI n)  = n
+
+instance Eval Expr4J2 where
+  evalSym (E4JB b)  = b
+
+instance Eval Expr4J3 where
+  evalSym E4JAdd    = (+)
+
+instance Eval Expr4J4 where
+  evalSym E4JEq     = (==)
+
+instance Eval Expr4J5 where
+  evalSym E4JIf     = \c a b -> if c then a else b
+
+instance EvalEnv Expr4J1 env where
+  compileSym p (E4JI n)  = compileSymDefault signature p (E4JI n)
+
+instance EvalEnv Expr4J2 env where
+  compileSym p (E4JB b)  = compileSymDefault signature p (E4JB b)
+
+instance EvalEnv Expr4J3 env where
+  compileSym p E4JAdd    = compileSymDefault signature p E4JAdd
+
+instance EvalEnv Expr4J4 env where
+  compileSym p E4JEq     = compileSymDefault signature p E4JEq
+
+instance EvalEnv Expr4J5 env where
+  compileSym p E4JIf     = compileSymDefault signature p E4JIf
+
+-- Expressions
+syntacticExpr :: Int -> Expr1' Int
+syntacticExpr 0 = if' (eq (int 5) (int 4)) (int 5) (int 0)
+syntacticExpr n = (add (syntacticExpr (n-1)) (syntacticExpr (n-1)))
+
+syntacticExprJ :: Int -> ExprJ' Int
+syntacticExprJ 0 = ifJ (eqJ (intJ 5) (intJ 4)) (intJ 5) (intJ 0)
+syntacticExprJ n = (addJ (syntacticExprJ (n-1)) (syntacticExprJ (n-1)))
+
+syntacticExpr4J :: Int -> Expr4J' Int
+syntacticExpr4J 0 = if4 (eq4 (int4 5) (int4 4)) (int4 5) (int4 0)
+syntacticExpr4J n = (add4 (syntacticExpr4J (n-1)) (syntacticExpr4J (n-1)))
+
+main :: IO ()
+main = defaultMainWith (defaultConfig {csvFile = Just "bench-results/joiningTypes.csv"})
+         [ bgroup "eval 10" [ bench "syntactic 0 joins" $ nf evalDen (syntacticExpr 10)
+                            , bench "syntactic 1 join"  $ nf evalDen (syntacticExprJ 10)
+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 10)]
+         , bgroup "eval 15" [ bench "syntactic 0 joins" $ nf evalDen (syntacticExpr 15)
+                            , bench "syntactic 1 join"  $ nf evalDen (syntacticExprJ 15)
+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 15)]
+         , bgroup "eval 20" [ bench "syntactic 0 joins" $ nf evalDen (syntacticExpr 20)
+                            , bench "syntactic 1 join"  $ nf evalDen (syntacticExprJ 20)
+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 20)]
+         , bgroup "size 10" [ bench "syntactic 0 joins" $ nf size (syntacticExpr 10)
+                            , bench "syntactic 1 join"  $ nf size (syntacticExprJ 10)
+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 10)]
+         , bgroup "size 15" [ bench "syntactic 0 joins" $ nf size (syntacticExpr 15)
+                            , bench "syntactic 1 join"  $ nf size (syntacticExprJ 15)
+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 15)]
+         , bgroup "size 20" [ bench "syntactic 0 joins" $ nf size (syntacticExpr 20)
+                            , bench "syntactic 1 join"  $ nf size (syntacticExprJ 20)
+                            , bench "syntactic 4 joins" $ nf evalDen (syntacticExpr4J 20)]]
+
diff --git a/benchmarks/MainBenchmark.hs b/benchmarks/MainBenchmark.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/MainBenchmark.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import qualified Normal
+import qualified WithArity
+import qualified JoiningTypes
+
+main :: IO ()
+main = do
+  Normal.main
+  WithArity.main
+  JoiningTypes.main
diff --git a/benchmarks/Normal.hs b/benchmarks/Normal.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/Normal.hs
@@ -0,0 +1,127 @@
+module Normal (main) where
+
+import Criterion.Main
+import Criterion.Types
+import Language.Syntactic
+import Language.Syntactic.Functional
+
+main :: IO ()
+main = defaultMainWith (defaultConfig {csvFile = Just "bench-results/normal.csv"})
+         [ bgroup "Eval Tree 10"   [ bench "gadt"      $ nf evl (gadtExpr 10)
+                                   , bench "syntactic" $ nf evalDen (syntacticExpr 10)]
+         , bgroup "Eval Tree 15"   [ bench "gadt"      $ nf evl (gadtExpr 15)
+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 15)]
+         , bgroup "Eval Tree 20"   [ bench "gadt"      $ nf evl (gadtExpr 20)
+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 20) ]
+         , bgroup "Size Tree 10"   [ bench "gadt"      $ nf gSize (gadtExpr 10)
+                                   , bench "syntactic" $ nf size (syntacticExpr 10)]
+         , bgroup "Size Tree 15"   [ bench "gadt"      $ nf gSize (gadtExpr 15)
+                                   , bench "syntactic" $ nf size (syntacticExpr 15)]
+         , bgroup "Size Tree 20"   [ bench "gadt"      $ nf gSize (gadtExpr 20)
+                                   , bench "syntactic" $ nf size (syntacticExpr 20)]
+         , bgroup "Eval IFTree 10" [ bench "if gadt"   $ nf evl (gadtExpr 10)
+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 10)]
+         , bgroup "Eval IFTree 15" [ bench "gadt"      $ nf evl (gadtExpr 15)
+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 15)]
+         , bgroup "Eval IFTree 20" [ bench "gadt"      $ nf evl (gadtExpr 20)
+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 20) ]
+         , bgroup "Size IFTree 10" [ bench "gadt"      $ nf gSize (gadtExpr 10)
+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 10)]
+         , bgroup "Size IFTree 15" [ bench "gadt"      $ nf gSize (gadtExpr 15)
+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 15)]
+         , bgroup "Size IFTree 20" [ bench "gadt"      $ nf gSize (gadtExpr 20)
+                                   , bench "syntactic" $ nf evalDen(syntacticExpr 20) ]]
+
+-- Expressions
+gadtExpr :: Int -> Expr Int
+gadtExpr 0 = (If ((LitI 5) :== (LitI 4)) (LitI 5) (LitI 0))
+gadtExpr n = gadtExpr (n-1) :+ gadtExpr (n-1)
+
+gadtExprIf :: Int -> Expr Int
+gadtExprIf 0 = (If ((LitI 5) :== (LitI 4)) (LitI 5) (LitI 0))
+gadtExprIf n = (If (gadtExprIf (n-1) :== (LitI 0)) (gadtExprIf (n-1)) (gadtExprIf (n-1)))
+
+syntacticExpr :: Int -> ExprS' Int
+syntacticExpr 0 = if' (eq (int 5) (int 4)) (int 5) (int 0)
+syntacticExpr n = (add (syntacticExpr (n-1)) (syntacticExpr (n-1)))
+
+-- We also test an expression with several ifs so the tree has higher width.
+syntacticExprIf :: Int -> ExprS' Int
+syntacticExprIf 0 = if' (eq (int 5) (int 4)) (int 5) (int 0)
+syntacticExprIf n = if' (eq (syntacticExprIf(n-1)) (int 0)) (syntacticExprIf (n-1)) (syntacticExprIf (n-1))
+
+
+-- Comparing Syntactic with GADTs
+-- GADTs
+data Expr t where
+  LitI  :: Int                           -> Expr Int
+  LitB  :: Bool                          -> Expr Bool
+  (:+)  ::         Expr Int -> Expr Int  -> Expr Int
+  (:==) :: Eq t => Expr t   -> Expr t    -> Expr Bool
+  If    :: Expr Bool -> Expr t -> Expr t -> Expr t
+
+evl :: Expr t -> t
+evl (LitI n)     =  n
+evl (LitB b)     =  b
+evl (e1 :+ e2)   =  evl e1 +  evl e2
+evl (e1 :== e2)  =  evl e1 == evl e2
+evl (If b t e)   =  if evl b then evl t else evl e
+
+gSize :: Expr t ->  Int
+gSize (LitI n)     =  1
+gSize (LitB b)     =  1
+gSize (e1 :+ e2)   =  gSize e1 +  gSize e2
+gSize (e1 :== e2)  =  gSize e1 + gSize e2
+gSize (If b t e)   =  gSize b + gSize t +  gSize e
+
+-- Syntactic
+
+data ExprS t where
+  EI    :: Int  -> ExprS (Full Int)
+  EB    :: Bool -> ExprS (Full Bool)
+  EAdd  :: ExprS (Int :-> Int :-> Full Int)
+  EEq   :: (Eq t) => ExprS (t   :-> t   :-> Full Bool)
+  EIf   :: ExprS (Bool :-> a :-> a :-> Full a)
+
+type ExprS' a = AST ExprS (Full a)
+
+-- Smart constructors
+int  :: Int -> ExprS' Int
+int = Sym . EI
+
+bool :: Bool -> ExprS' Bool
+bool = Sym . EB
+
+add  :: ExprS' Int -> ExprS' Int -> ExprS' Int
+add a b = Sym EAdd :$ a :$ b
+
+eq   :: (Eq a) => ExprS' a -> ExprS' a -> ExprS' Bool
+eq a b = Sym EEq :$ a :$ b
+
+if'  :: ExprS' Bool -> ExprS' a -> ExprS' a -> ExprS' a
+if' c a b = Sym EIf :$ c :$ a :$ b
+
+instance Render ExprS where
+  renderSym (EI n) = "EI"
+  renderSym (EB b) = "EB"
+  renderSym EAdd   = "EAdd"
+  renderSym EEq    = "EEq"
+  renderSym EIf    = "EIf"
+
+instance Equality   ExprS
+instance StringTree ExprS
+
+instance Eval ExprS where
+  evalSym (EI n) = n
+  evalSym (EB b) = b
+  evalSym EAdd   = (+)
+  evalSym EEq    = (==)
+  evalSym EIf    = \c a b -> if c then a else b
+
+instance EvalEnv ExprS env where
+  compileSym p (EI n) = compileSymDefault signature p (EI n)
+  compileSym p (EB b) = compileSymDefault signature p (EB b)
+  compileSym p EAdd   = compileSymDefault signature p EAdd
+  compileSym p EEq    = compileSymDefault signature p EEq
+  compileSym p EIf    = compileSymDefault signature p EIf
+
diff --git a/benchmarks/WithArity.hs b/benchmarks/WithArity.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/WithArity.hs
@@ -0,0 +1,125 @@
+module WithArity (main) where
+
+import Criterion.Main
+import Criterion.Types
+import Language.Syntactic hiding (E)
+import Language.Syntactic.Functional
+
+main :: IO ()
+main = defaultMainWith (defaultConfig {csvFile = Just "bench-results/withArity.csv"})
+         [ bgroup "eval 5"  [ bench "gadt"      $ nf evl (gExpr 5)
+                            , bench "Syntactic" $ nf evalDen (sExpr 5) ]
+         , bgroup "eval 6"  [ bench "gadt"      $ nf evl (gExpr 6)
+                            , bench "Syntactic" $ nf evalDen (sExpr 6) ]
+         , bgroup "eval 7"  [ bench "gadt"      $ nf evl (gExpr 7)
+                            , bench "Syntactic" $ nf evalDen (sExpr 7) ]
+         , bgroup "size 5"  [ bench "gadt"      $ nf gSize (gExpr 5)
+                            , bench "Syntactic" $ nf size (sExpr 5) ]
+         , bgroup "size 6"  [ bench "gadt"      $ nf gSize (gExpr 6)
+                            , bench "Syntactic" $ nf size (sExpr 6) ]
+         , bgroup "size 7"  [ bench "gadt"      $ nf gSize (gExpr 7)
+                            , bench "Syntactic" $ nf size (sExpr 7) ]]
+
+-- Expressions
+gExpr :: Int -> E Int
+gExpr 0  = E0 1
+gExpr 1  = E2 (E2 (E0 1) (E0 1)) (E1 (E0 1))
+gExpr n  = E10 (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1))
+           (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1)) (gExpr (n-1))
+
+sExpr :: Int -> T' Int
+sExpr 0  = t0 1
+sExpr 1  = t2 (t2 (t0 1) (t0 1)) (t1 (t0 1))
+sExpr n  = t10 (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1))
+           (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1)) (sExpr (n-1))
+
+gSize :: E a -> Int
+gSize (E0 _) = 1
+gSize (E1 a)   = gSize a
+gSize (E2 a b) = gSize a + gSize b
+gSize (E3 a b c) = gSize a + gSize b + gSize c
+gSize (E5 a b c d e) = gSize a + gSize b + gSize c + gSize d + gSize e
+gSize (E10 a b c d e f g h i j) = gSize a + gSize b + gSize c + gSize d + gSize e +
+                                  gSize f + gSize g + gSize h + gSize i + gSize j
+
+
+-- Comparing Syntactic with GADTs
+-- GADTs
+data E a where
+  E0    :: a  -> E a
+  E1    :: E a -> E a
+  E2    :: E a -> E a -> E a
+  E3    :: E a -> E a -> E a -> E a
+  E5    :: E a -> E a -> E a -> E a -> E a -> E a
+  E10   :: E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a -> E a
+
+
+evl :: E Int -> Int
+evl (E0 n)         =  n
+evl (E1 a)         =  evl a
+evl (E2 a b)       =  evl a + evl b
+evl (E3 a b c)     =  evl a + evl b + evl c
+evl (E5 a b c d e) =  evl a + evl b + evl c + evl d + evl e
+evl (E10 a b c d e f g h i j) =
+    evl a + evl b + evl c + evl d + evl e + evl f + evl g + evl h + evl i + evl j
+
+-- Syntactic
+
+data T a where
+  T0    :: Num a =>  a  -> T (Full a)
+  T1    :: Num a =>  T (a :-> Full a)
+  T2    :: Num a =>  T (a :-> a :-> Full a)
+  T3    :: Num a =>  T (a :-> a :-> a :-> Full a)
+  T5    :: Num a =>  T (a :-> a :-> a :-> a :-> a :-> Full a)
+  T10   :: Num a =>  T (a :-> a :-> a :-> a :-> a :-> a :-> a :-> a :-> a :-> a :-> Full a)
+
+type T' a = AST T (Full a)
+
+t0  :: Num a =>  a -> T' a
+t0 = Sym . T0
+
+t1 :: Num a =>  T' a -> T' a
+t1 a = Sym T1 :$ a
+
+t2    :: Num a =>  T' a -> T' a -> T' a
+t2 a b = Sym T2 :$ a :$ b
+
+t3    :: Num a =>  T' a -> T' a -> T' a -> T' a
+t3 a b c = Sym T3 :$ a :$ b :$ c
+
+t5    :: Num a =>  T' a -> T' a -> T' a -> T' a -> T' a -> T' a
+t5 a b c d e = Sym T5 :$ a :$ b :$ c :$ d :$ e
+
+t10   :: Num a => T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a -> T' a
+t10 a b c d e f g h i j = Sym T10 :$ a :$ b :$ c :$ d :$ e :$ f :$ g :$ h :$ i:$ j
+
+instance Render T
+  where
+    renderSym (T0 a) = "T0"
+    renderSym T1     = "T1"
+    renderSym T2     = "T2"
+    renderSym T3     = "T3"
+    renderSym T5     = "T5"
+    renderSym T10    = "T10"
+
+instance Equality   T
+instance StringTree T
+
+instance Eval T
+  where
+    evalSym (T0 a) = a
+    evalSym T1     = id
+    evalSym T2     = (+)
+    evalSym T3     = \a b c -> a + b + c
+    evalSym T5     = \a b c d e -> a + b + c + d + e
+    evalSym T10    = \a b c d e f g h i j -> a + b + c + d + e + f + g + h + i + j
+
+instance EvalEnv T env
+  where
+    compileSym p (T0 a) = compileSymDefault signature p (T0 a)
+    compileSym p T1     = compileSymDefault signature p T1
+    compileSym p T2     = compileSymDefault signature p T2
+    compileSym p T3     = compileSymDefault signature p T3
+    compileSym p T5     = compileSymDefault signature p T5
+    compileSym p T10    = compileSymDefault signature p T10
+
diff --git a/examples/Monad.hs b/examples/Monad.hs
new file mode 100644
--- /dev/null
+++ b/examples/Monad.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+
+{-# OPTIONS_GHC -Wno-missing-methods #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
+
+-- | This module demonstrates monad reification.
+-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011
+-- <https://emilaxelsson.github.io/documents/persson2011generic.pdf>) for details.
+
+module Monad where
+
+
+
+import Control.Monad (replicateM_)
+import Data.Char (isDigit)
+import Data.Typeable (Typeable)
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+import Language.Syntactic.Sugar.MonadTyped ()
+
+import NanoFeldspar (Type, Arithmetic (..))
+
+
+
+type Dom = Typed (BindingT :+: MONAD IO :+: Construct :+: Arithmetic)
+
+type Exp a = ASTF Dom a
+
+type IO' a = Remon Dom IO (Exp a)
+
+getDigit :: IO' Int
+getDigit = sugarSymTyped $ Construct "getDigit" get
+  where
+    get = do
+        c <- getChar
+        if isDigit c then return (fromEnum c - fromEnum '0') else get
+
+putDigit :: Exp Int -> IO' ()
+putDigit = sugarSymTyped $ Construct "putDigit" print
+
+iter :: Typeable a => Exp Int -> IO' a -> IO' ()
+iter = sugarSymTyped $ Construct "iter" replicateM_
+
+-- | Literal
+value :: (Show a, Typeable a) => a -> Exp a
+value a = sugarSymTyped $ Construct (show a) a
+
+instance (Num a, Type a) => Num (Exp a)
+  where
+    fromInteger = value . fromInteger
+    (+)         = sugarSymTyped Add
+    (-)         = sugarSymTyped Sub
+    (*)         = sugarSymTyped Mul
+
+ex1 :: Exp Int -> IO' ()
+ex1 n = iter n $ do
+    d <- getDigit
+    putDigit (d+d)
+
+test1 = evalClosed (desugar ex1) 5
+test2 = drawAST $ desugar ex1
+
diff --git a/examples/NanoFeldspar.hs b/examples/NanoFeldspar.hs
new file mode 100644
--- /dev/null
+++ b/examples/NanoFeldspar.hs
@@ -0,0 +1,378 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
+
+-- | A minimal Feldspar core language implementation. The intention of this module is to demonstrate
+-- how to quickly make a language prototype using Syntactic.
+
+module NanoFeldspar where
+
+
+
+import Prelude hiding (max, min, not, (==), length, map, sum, zip, zipWith)
+import qualified Prelude
+
+import Data.Typeable
+
+import Language.Syntactic hiding (fold, printExpr, showAST, drawAST, writeHtmlAST)
+import qualified Language.Syntactic as Syntactic
+import Language.Syntactic.Functional
+import Language.Syntactic.Functional.Sharing
+import Language.Syntactic.Functional.Tuple
+import Language.Syntactic.Sugar.BindingTyped ()
+import Language.Syntactic.Sugar.TupleTyped ()
+import Language.Syntactic.TH
+
+
+
+--------------------------------------------------------------------------------
+-- * Types
+--------------------------------------------------------------------------------
+
+-- | Convenient class alias
+class    (Typeable a, Show a, Eq a, Ord a) => Type a
+instance (Typeable a, Show a, Eq a, Ord a) => Type a
+
+type Length = Int
+type Index  = Int
+
+
+
+--------------------------------------------------------------------------------
+-- * Abstract syntax
+--------------------------------------------------------------------------------
+
+data Arithmetic sig
+  where
+    Add :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a)
+    Sub :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a)
+    Mul :: (Type a, Num a) => Arithmetic (a :-> a :-> Full a)
+
+deriveSymbol   ''Arithmetic
+deriveEquality ''Arithmetic
+
+instance StringTree Arithmetic
+instance EvalEnv Arithmetic env
+
+instance Render Arithmetic
+  where
+    renderSym Add = "(+)"
+    renderSym Sub = "(-)"
+    renderSym Mul = "(*)"
+    renderArgs = renderArgsSmart
+
+instance Eval Arithmetic
+  where
+    evalSym Add = (+)
+    evalSym Sub = (-)
+    evalSym Mul = (*)
+
+data Parallel sig
+  where
+    Parallel :: Type a => Parallel (Length :-> (Index -> a) :-> Full [a])
+
+deriveSymbol    ''Parallel
+deriveRender id ''Parallel
+deriveEquality  ''Parallel
+
+instance StringTree Parallel
+instance EvalEnv Parallel env
+
+instance Eval Parallel
+  where
+    evalSym Parallel = \len ixf -> Prelude.map ixf [0 .. len-1]
+
+data ForLoop sig
+  where
+    ForLoop :: Type st => ForLoop (Length :-> st :-> (Index -> st -> st) :-> Full st)
+
+deriveSymbol    ''ForLoop
+deriveRender id ''ForLoop
+deriveEquality  ''ForLoop
+
+instance StringTree ForLoop
+instance EvalEnv ForLoop env
+
+instance Eval ForLoop
+  where
+    evalSym ForLoop = \len init body -> foldl (flip body) init [0 .. len-1]
+
+type FeldDomain = Typed
+    (   BindingT
+    :+: Let
+    :+: Tuple
+    :+: Arithmetic
+    :+: Parallel
+    :+: ForLoop
+    :+: Construct
+    )
+  -- `Construct` can be used to create arbitrary symbols from a name and an
+  -- evaluation function. We could have used `Construct` for all symbols, but
+  -- the problem with `Construct` is that it does not know about the arity or
+  -- type of the construct it represents, so it's easy to make mistakes, e.g.
+  -- when transforming expressions with `Construct` symbols.
+
+newtype Data a = Data { unData :: ASTF FeldDomain a }
+
+-- | Declaring 'Data' as syntactic sugar
+instance Type a => Syntactic (Data a)
+  where
+    type Domain (Data a)   = FeldDomain
+    type Internal (Data a) = a
+    desugar = unData
+    sugar   = Data
+
+-- | Specialization of the 'Syntactic' class for the Feldspar domain
+class    (Syntactic a, Domain a ~ FeldDomain, Type (Internal a)) => Syntax a
+instance (Syntactic a, Domain a ~ FeldDomain, Type (Internal a)) => Syntax a
+
+instance Type a => Show (Data a)
+  where
+    show = showExpr
+
+
+
+--------------------------------------------------------------------------------
+-- * "Backends"
+--------------------------------------------------------------------------------
+
+-- | Interface for controlling code motion
+cmInterface :: CodeMotionInterface FeldDomain
+cmInterface = defaultInterface VarT LamT sharable (const True)
+  where
+    sharable :: ASTF FeldDomain a -> ASTF FeldDomain b -> Bool
+    sharable (Sym _) _ = False
+      -- Simple expressions not shared
+    sharable (lam :$ _) _
+        | Just _ <- prLam lam = False
+      -- Lambdas not shared
+    sharable _ (lam :$ _)
+        | Just _ <- prLam lam = False
+      -- Don't place let bindings over lambdas. This ensures that function
+      -- arguments of higher-order constructs such as `Parallel` are always
+      -- lambdas.
+    sharable (sel :$ _) _
+        | Just Fst <- prj sel = False
+        | Just Snd <- prj sel = False
+      -- Tuple selection not shared
+    sharable (arrl :$ _ ) _
+        | Just (Construct "arrLen" _) <- prj arrl = False
+      -- Array length not shared
+    sharable (gix :$ _ :$ _) _
+        | Just (Construct "arrIx" _) <- prj gix = False
+      -- Array indexing not shared
+    sharable _ _ = True
+
+-- | Show the expression
+showExpr :: (Syntactic a, Domain a ~ FeldDomain) => a -> String
+showExpr = render . codeMotion cmInterface . desugar
+
+-- | Print the expression
+printExpr :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO ()
+printExpr = putStrLn . showExpr
+
+-- | Show the syntax tree using unicode art
+showAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> String
+showAST = Syntactic.showAST . codeMotion cmInterface . desugar
+
+-- | Draw the syntax tree on the terminal using unicode art
+drawAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO ()
+drawAST = putStrLn . showAST
+
+-- | Write the syntax tree to an HTML file with foldable nodes
+writeHtmlAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO ()
+writeHtmlAST =
+    Syntactic.writeHtmlAST "tree.html" . codeMotion cmInterface . desugar
+
+-- | Evaluate an expression
+eval :: (Syntactic a, Domain a ~ FeldDomain) => a -> Internal a
+eval = evalClosed . desugar
+
+
+
+--------------------------------------------------------------------------------
+-- * Front end
+--------------------------------------------------------------------------------
+
+-- | Literal
+value :: Syntax a => Internal a -> a
+value a = sugar $ injT $ Construct (show a) a
+
+false :: Data Bool
+false = value False
+
+true :: Data Bool
+true = value True
+
+-- | Force computation
+force :: Syntax a => a -> a
+force = resugar
+
+instance (Type a, Num a) => Num (Data a)
+  where
+    fromInteger = value . fromInteger
+    (+)         = sugarSymTyped Add
+    (-)         = sugarSymTyped Sub
+    (*)         = sugarSymTyped Mul
+
+-- | Explicit sharing
+share :: (Syntax a, Syntax b) => a -> (a -> b) -> b
+share = sugarSymTyped (Let "")
+
+-- | Parallel array
+parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a]
+parallel = sugarSymTyped Parallel
+
+-- | For loop
+forLoop :: Syntax st => Data Length -> st -> (Data Index -> st -> st) -> st
+forLoop = sugarSymTyped ForLoop
+
+-- | Conditional expression
+(?) :: forall a . Syntax a => Data Bool -> (a,a) -> a
+c ? (t,f) = sugarSymTyped sym c t f
+  where
+    sym :: Construct (Bool :-> Internal a :-> Internal a :-> Full (Internal a))
+    sym = Construct "cond" (\c t f -> if c then t else f)
+
+-- | Get the length of an array
+arrLen :: Type a => Data [a] -> Data Length
+arrLen = sugarSymTyped $ Construct "arrLen" Prelude.length
+
+-- | Index into an array
+arrIx :: Type a => Data [a] -> Data Index -> Data a
+arrIx = sugarSymTyped $ Construct "arrIx" eval
+  where
+    eval as i
+        | i >= len || i < 0 = error "arrIx: index out of bounds"
+        | otherwise         = as !! i
+      where
+        len = Prelude.length as
+
+not :: Data Bool -> Data Bool
+not = sugarSymTyped $ Construct "not" Prelude.not
+
+(==) :: Type a => Data a -> Data a -> Data Bool
+(==) = sugarSymTyped $ Construct "(==)" (Prelude.==)
+
+max :: Type a => Data a -> Data a -> Data a
+max = sugarSymTyped $ Construct "max" Prelude.max
+
+min :: Type a => Data a -> Data a -> Data a
+min = sugarSymTyped $ Construct "min" Prelude.min
+
+
+
+--------------------------------------------------------------------------------
+-- * Vector library
+--------------------------------------------------------------------------------
+
+data Vector a
+  where
+    Indexed :: Data Length -> (Data Index -> a) -> Vector a
+
+instance Syntax a => Syntactic (Vector a)
+  where
+    type Domain (Vector a)   = FeldDomain
+    type Internal (Vector a) = [Internal a]
+    desugar = desugar . freezeVector . map resugar
+    sugar   = map resugar . thawVector . sugar
+
+length :: Vector a -> Data Length
+length (Indexed len _) = len
+
+indexed :: Data Length -> (Data Index -> a) -> Vector a
+indexed = Indexed
+
+index :: Vector a -> Data Index -> a
+index (Indexed _ ixf) = ixf
+
+(!) :: Vector a -> Data Index -> a
+Indexed _ ixf ! i = ixf i
+
+infixl 9 !
+
+freezeVector :: Type a => Vector (Data a) -> Data [a]
+freezeVector vec = parallel (length vec) (index vec)
+
+thawVector :: Type a => Data [a] -> Vector (Data a)
+thawVector arr = Indexed (arrLen arr) (arrIx arr)
+
+zip :: Vector a -> Vector b -> Vector (a,b)
+zip a b = indexed (length a `min` length b) (\i -> (index a i, index b i))
+
+unzip :: Vector (a,b) -> (Vector a, Vector b)
+unzip ab = (indexed len (fst . index ab), indexed len (snd . index ab))
+  where
+    len = length ab
+
+permute :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)
+permute perm vec = indexed len (index vec . perm len)
+  where
+    len = length vec
+
+reverse :: Vector a -> Vector a
+reverse = permute $ \len i -> len-i-1
+
+(...) :: Data Index -> Data Index -> Vector (Data Index)
+l ... h = indexed (h-l+1) (+l)
+
+map :: (a -> b) -> Vector a -> Vector b
+map f (Indexed len ixf) = Indexed len (f . ixf)
+
+zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c
+zipWith f a b = map (uncurry f) $ zip a b
+
+fold :: Syntax b => (a -> b -> b) -> b -> Vector a -> b
+fold f b (Indexed len ixf) = forLoop len b (\i st -> f (ixf i) st)
+
+fold1 :: Syntax a => (a -> a -> a) -> Vector a -> a
+fold1 f (Indexed len ixf) = forLoop len (ixf 0) (\i st -> f (ixf i) st)
+
+sum :: (Num a, Syntax a) => Vector a -> a
+sum = fold (+) 0
+
+type Matrix a = Vector (Vector (Data a))
+
+-- | Transpose of a matrix. Assumes that the number of rows is > 0.
+transpose :: Type a => Matrix a -> Matrix a
+transpose a = indexed (length (a!0)) $ \k -> indexed (length a) $ \l -> a ! l ! k
+
+
+
+--------------------------------------------------------------------------------
+-- * Examples
+--------------------------------------------------------------------------------
+
+-- | Fibonacci function
+fib :: Data Int -> Data Int
+fib n = fst $ forLoop n (0,1) $ \_ (a,b) -> (b,a+b)
+
+-- | The span of a vector (difference between greatest and smallest element)
+spanVec :: Vector (Data Int) -> Data Int
+spanVec vec = hi-lo
+  where
+    (lo,hi) = fold (\a (l,h) -> (min a l, max a h)) (vec!0,vec!0) vec
+  -- This demonstrates how tuples interplay with sharing. Tuples are essentially
+  -- useless without sharing. This function would get two identical for loops if
+  -- it wasn't for sharing.
+
+-- | Scalar product
+scProd :: Vector (Data Float) -> Vector (Data Float) -> Data Float
+scProd a b = sum (zipWith (*) a b)
+
+forEach = flip map
+
+-- | Matrix multiplication
+matMul :: Matrix Float -> Matrix Float -> Matrix Float
+matMul a b = forEach a $ \a' ->
+               forEach (transpose b) $ \b' ->
+                 scProd a' b'
+
diff --git a/examples/NanoFeldspar/Core.hs b/examples/NanoFeldspar/Core.hs
deleted file mode 100644
--- a/examples/NanoFeldspar/Core.hs
+++ /dev/null
@@ -1,267 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns #-}
-
--- | A minimal Feldspar core language implementation. The intention of this
--- module is to demonstrate how to quickly make a language prototype using
--- syntactic.
---
--- A more realistic implementation would use custom contexts to restrict the
--- types at which constructors operate. Currently, all general constructs (such
--- as 'Literal' and 'Tuple') use a 'SimpleCtx' context, which means that the
--- types are quite unrestricted. A real implementation would also probably use
--- custom types for primitive functions, since 'Construct' is quite unsafe (uses
--- only a 'String' to distinguish between functions).
-
-module NanoFeldspar.Core where
-
-
-
-import Data.Typeable
-
-import Language.Syntactic as Syntactic
-import Language.Syntactic.Constructs.Binding
-import Language.Syntactic.Constructs.Binding.HigherOrder
-import Language.Syntactic.Constructs.Condition
-import Language.Syntactic.Constructs.Construct
-import Language.Syntactic.Constructs.Literal
-import Language.Syntactic.Constructs.Tuple
-import Language.Syntactic.Frontend.Tuple
-import Language.Syntactic.Sharing.SimpleCodeMotion
-
-
-
---------------------------------------------------------------------------------
--- * Types
---------------------------------------------------------------------------------
-
--- | Convenient class alias
-class    (Ord a, Show a, Typeable a) => Type a
-instance (Ord a, Show a, Typeable a) => Type a
-
-type Length = Int
-type Index  = Int
-
-
-
---------------------------------------------------------------------------------
--- * Parallel arrays
---------------------------------------------------------------------------------
-
-data Parallel a
-  where
-    Parallel :: Type a => Parallel (Length :-> (Index -> a) :-> Full [a])
-
-instance Constrained Parallel
-  where
-    type Sat Parallel = Type
-    exprDict Parallel = Dict
-
-instance Semantic Parallel
-  where
-    semantics Parallel = Sem
-        { semanticName = "parallel"
-        , semanticEval = \len ixf -> map ixf [0 .. len-1]
-        }
-
-semanticInstances ''Parallel
-
-instance EvalBind Parallel where evalBindSym = evalBindSymDefault
-
-instance AlphaEq dom dom dom env => AlphaEq Parallel Parallel dom env
-  where
-    alphaEqSym = alphaEqSymDefault
-
-
-
---------------------------------------------------------------------------------
--- * For loops
---------------------------------------------------------------------------------
-
-data ForLoop a
-  where
-    ForLoop :: Type st =>
-        ForLoop (Length :-> st :-> (Index -> st -> st) :-> Full st)
-
-instance Constrained ForLoop
-  where
-    type Sat ForLoop = Type
-    exprDict ForLoop = Dict
-
-instance Semantic ForLoop
-  where
-    semantics ForLoop = Sem
-        { semanticName = "forLoop"
-        , semanticEval = \len init body -> foldl (flip body) init [0 .. len-1]
-        }
-
-semanticInstances ''ForLoop
-
-instance EvalBind ForLoop where evalBindSym = evalBindSymDefault
-
-instance AlphaEq dom dom dom env => AlphaEq ForLoop ForLoop dom env
-  where
-    alphaEqSym = alphaEqSymDefault
-
-
-
---------------------------------------------------------------------------------
--- * Feldspar domain
---------------------------------------------------------------------------------
-
--- | The Feldspar domain
-type FeldDomain
-    =   Construct
-    :+: Literal
-    :+: Condition
-    :+: Tuple
-    :+: Select
-    :+: Parallel
-    :+: ForLoop
-
-type FeldSyms      = Let :+: (FeldDomain :|| Eq :| Show)
-type FeldDomainAll = HODomain FeldSyms Typeable Top
-
-newtype Data a = Data { unData :: ASTF FeldDomainAll a }
-
--- | Declaring 'Data' as syntactic sugar
-instance Type a => Syntactic (Data a)
-  where
-    type Domain (Data a)   = FeldDomainAll
-    type Internal (Data a) = a
-    desugar = unData
-    sugar   = Data
-
--- | Specialization of the 'Syntactic' class for the Feldspar domain
-class    (Syntactic a, Domain a ~ FeldDomainAll, Type (Internal a)) => Syntax a
-instance (Syntactic a, Domain a ~ FeldDomainAll, Type (Internal a)) => Syntax a
-
--- | A predicate deciding which constructs can be shared. Lambdas and literals are not shared.
-canShare :: ASTF (FODomain FeldSyms Typeable Top) a -> Maybe (Dict (Top a))
-canShare (lam :$ _)
-    | Just _ <- prjP (P::P (CLambda Top)) lam = Nothing
-canShare (prj -> Just (Literal _)) = Nothing
-canShare _  = Just Dict
-
-canShareIn :: ASTF (FODomain FeldSyms Typeable Top) a -> Bool
-canShareIn (lam :$ _)
-    | Just _ <- prjP (P::P (CLambda Top)) lam = False
-canShareIn _ = True
-
-canShareDict :: MkInjDict (FODomain FeldSyms Typeable Top)
-canShareDict = mkInjDictFO canShare canShareIn
-
-
-
---------------------------------------------------------------------------------
--- * Back ends
---------------------------------------------------------------------------------
-
--- | Show the expression
-showExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String
-showExpr = render . reifySmart (const True) canShareDict
-
--- | Print the expression
-printExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()
-printExpr = print . reifySmart (const True) canShareDict
-
--- | Show the syntax tree using Unicode art
-showAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String
-showAST = Syntactic.showAST . reifySmart (const True) canShareDict
-
--- | Draw the syntax tree on the terminal using Unicode art
-drawAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()
-drawAST = Syntactic.drawAST . reifySmart (const True) canShareDict
-
--- | Write the syntax tree to an HTML file with foldable nodes
-writeHtmlAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO ()
-writeHtmlAST = Syntactic.writeHtmlAST "tree.html" . desugar
-
--- | Evaluation
-eval :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> Internal a
-eval = evalBind . reifySmart (const True) canShareDict
-
-
-
---------------------------------------------------------------------------------
--- * Core library
---------------------------------------------------------------------------------
-
--- | Literal
-value :: Syntax a => Internal a -> a
-value = sugarSymC . Literal
-
-false :: Data Bool
-false = value False
-
-true :: Data Bool
-true = value True
-
--- | For types containing some kind of \"thunk\", this function can be used to
--- force computation
-force :: Syntax a => a -> a
-force = resugar
-
--- | Share a value using let binding
-share :: (Syntax a, Syntax b) => a -> (a -> b) -> b
-share = sugarSymC Let
-
--- | Alpha equivalence
-instance Type a => Eq (Data a)
-  where
-    Data a == Data b = alphaEq (reify a) (reify b)
-
-instance Type a => Show (Data a)
-  where
-    show (Data a) = render $ reify a
-
-instance (Type a, Num a) => Num (Data a)
-  where
-    fromInteger = value . fromInteger
-    abs         = sugarSymC $ Construct "abs" abs
-    signum      = sugarSymC $ Construct "signum" signum
-    (+)         = sugarSymC $ Construct "(+)" (+)
-    (-)         = sugarSymC $ Construct "(-)" (-)
-    (*)         = sugarSymC $ Construct "(*)" (*)
-
-(?) :: Syntax a => Data Bool -> (a,a) -> a
-cond ? (t,e) = sugarSymC Condition cond t e
-
--- | Parallel array
-parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a]
-parallel = sugarSymC Parallel
-
-forLoop :: Syntax st => Data Length -> st -> (Data Index -> st -> st) -> st
-forLoop = sugarSymC ForLoop
-
-arrLength :: Type a => Data [a] -> Data Length
-arrLength = sugarSymC $ Construct "arrLength" Prelude.length
-
--- | Array indexing
-getIx :: Type a => Data [a] -> Data Index -> Data a
-getIx = sugarSymC $ Construct "getIx" eval
-  where
-    eval as i
-        | i >= len || i < 0 = error "getIx: index out of bounds"
-        | otherwise         = as !! i
-      where
-        len = Prelude.length as
-
-not :: Data Bool -> Data Bool
-not = sugarSymC $ Construct "not" Prelude.not
-
-(==) :: Type a => Data a -> Data a -> Data Bool
-(==) = sugarSymC $ Construct "(==)" (Prelude.==)
-
-max :: Type a => Data a -> Data a -> Data a
-max = sugarSymC $ Construct "max" Prelude.max
-
-min :: Type a => Data a -> Data a -> Data a
-min = sugarSymC $ Construct "min" Prelude.min
-
diff --git a/examples/NanoFeldspar/Extra.hs b/examples/NanoFeldspar/Extra.hs
deleted file mode 100644
--- a/examples/NanoFeldspar/Extra.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module NanoFeldspar.Extra where
-
-
-
-import Control.Monad.State
-import Data.Typeable
-
-import Language.Syntactic as Syntactic
-import Language.Syntactic.Constructs.Binding
-import Language.Syntactic.Constructs.Binding.HigherOrder
-import Language.Syntactic.Constructs.Binding.Optimize
-import Language.Syntactic.Constructs.Construct
-import Language.Syntactic.Constructs.Literal
-import Language.Syntactic.Sharing.SimpleCodeMotion
-import Language.Syntactic.Sharing.Graph
-import Language.Syntactic.Sharing.ReifyHO
-
-import NanoFeldspar.Core
-
-
-
---------------------------------------------------------------------------------
--- * Graph reification
---------------------------------------------------------------------------------
-
--- | A predicate deciding which constructs can be shared. Variables, lambdas and literals are not
--- shared.
-canShare2 :: ASTF (HODomain FeldSyms Typeable Top) a -> Bool
-canShare2 (prjP (P::P (Variable :|| Top))               -> Just _) = False
-canShare2 (prjP (P::P (HOLambda FeldSyms Typeable Top)) -> Just _) = False
-canShare2 (prj -> Just (Literal _)) = False
-canShare2 _  = True
-
--- | Draw the syntax graph after common sub-expression elimination
-drawCSE :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()
-drawCSE a = do
-    (g,_) <- reifyGraph canShare2 a
-    drawASG
-      $ reindexNodesFrom0
-      $ inlineSingle
-      $ cse
-      $ g
-
--- | Draw the syntax graph after observing sharing
-drawObs :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()
-drawObs a = do
-    (g,_) <- reifyGraph canShare2 a
-    drawASG
-      $ reindexNodesFrom0
-      $ inlineSingle
-      $ g
-
-
-
---------------------------------------------------------------------------------
--- * Simplification/constant folding
---------------------------------------------------------------------------------
-
-instance Optimize ForLoop
-  where
-    optimizeSym = optimizeSymDefault
-
-instance Optimize Parallel
-  where
-    optimizeSym = optimizeSymDefault
-
-constFold :: forall a
-    .  ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) a
-    -> a
-    -> ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) a
-constFold expr a = match (\sym _ -> case sym of
-      C' (InjR (InjR (InjR (C (C' _))))) -> injC (Literal a)
-      _ -> expr
-    ) expr
-
-reifySimp :: (Syntactic a, Domain a ~ FeldDomainAll) =>
-    a -> ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) (Internal a)
-reifySimp = flip evalState 0 .
-    (   codeMotion (const True) prjDictFO canShareDict
-    .   optimize constFold
-    <=< reifyM
-    .   desugar
-    )
-
-drawSimp :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()
-drawSimp = Syntactic.drawAST . reifySimp
-
diff --git a/examples/NanoFeldspar/Test.hs b/examples/NanoFeldspar/Test.hs
deleted file mode 100644
--- a/examples/NanoFeldspar/Test.hs
+++ /dev/null
@@ -1,98 +0,0 @@
-module NanoFeldspar.Test where
-
-
-
-import Prelude hiding (length, map, (==), max, min, reverse, sum, unzip, zip, zipWith)
-
-import NanoFeldspar.Core
-import NanoFeldspar.Extra
-import NanoFeldspar.Vector
-
-
-
---------------------------------------------------------------------------------
--- Basic examples
---------------------------------------------------------------------------------
-
--- Scalar product
-scProd :: Vector (Data Float) -> Vector (Data Float) -> Data Float
-scProd a b = sum (zipWith (*) a b)
-
-forEach = flip map
-
--- Matrix multiplication
-matMul :: Matrix Float -> Matrix Float -> Matrix Float
-matMul a b = forEach a $ \a' ->
-               forEach (transpose b) $ \b' ->
-                 scProd a' b'
-
--- Note that
---
---   * `transpose` is fused with `scProd`
---   * some invariant expressions have been hoisted out of `parallel` and `forLoop` (see the
---     `Let` nodes)
-test_matMul = drawAST matMul
-
--- Parallel array
-prog1 :: Data Int -> Data Int -> Data [Int]
-prog1 a b = parallel a (\i -> min (i+3) b)
-
--- Common sub-expressions
-prog2 :: Data Int -> Data Int
-prog2 a = max (min a a) (min a a)
-
-prog3 :: Data Index -> Data Index -> Data Index
-prog3 a b = sum $ reverse (l ... u)
-  where
-    l = min a b
-    u = max a b
-
--- Invariant code hoisting
-prog4 :: Data Int -> Data [Int]
-prog4 a = parallel a (\i -> (a+a)*i)
-
--- Explicit sharing
-prog5 :: Data Index -> Data Index
-prog5 a = share (a*2,a*3) $ \(b,c) -> (b-c)*(c-b)
-
-
-
---------------------------------------------------------------------------------
--- Common sub-expression elimination and observable sharing
---------------------------------------------------------------------------------
-
-prog6 = index as 1 + sum as + sum as
-  where
-    as = map (*2) $ force (1...20)
-
-test6_1 = drawAST prog6
-  -- Draws a tree with no duplication
-
-test6_2 = drawCSE prog6
-  -- Draws a graph with no duplication
-
-test6_3 = drawObs prog6
-  -- Draws a graph with some duplication. The 'forLoop' introduced by 'sum' is
-  -- not shared, because 'sum as' is repeated twice in source code. But the
-  -- 'parallel' introduced by 'force' is shared, because 'force' only appears
-  -- once.
-
-
-
---------------------------------------------------------------------------------
--- Optimizations
---------------------------------------------------------------------------------
-
-prog7 :: Data Int -> Data Int
-prog7 a = (a==10) ? (max 5 (6+7), max 5 (6+7))
-
-test7 = drawSimp prog7
-  -- Reduced to the literal 13
-
-prog8 a = c ? (parallel 10 (+a), parallel 10 (+a))
-  where
-    c = (a*a*a*a) == 23
-
-test8 = drawSimp prog8
-  -- The condition gets pruned away
-
diff --git a/examples/NanoFeldspar/Vector.hs b/examples/NanoFeldspar/Vector.hs
deleted file mode 100644
--- a/examples/NanoFeldspar/Vector.hs
+++ /dev/null
@@ -1,99 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-
--- | A simple vector library for NanoFeldspar. The intention of this module is
--- to demonstrate how to add language features without extending the underlying
--- core language. By declaring 'Vector' as syntactic sugar, vector operations
--- can work seamlessly with the functions of the core language.
---
--- An interesting aspect of the 'Vector' interface is that the only operation
--- that produces a core language array (i.e. allocates memory) is 'freezeVector'
--- (which uses 'parallel'). This means that expressions not involving
--- 'freezeVector' are guaranteed to be fused. (Note, however, that
--- 'freezeVector' is introduced by 'desugar', which in turn is used by many
--- other functions.)
-
-module NanoFeldspar.Vector where
-
-
-
-import Prelude hiding (length, map, (==), max, min, reverse, sum, unzip, zip, zipWith)
-
-import Language.Syntactic (Syntactic (..), resugar)
-
-import NanoFeldspar.Core
-
-
-
-data Vector a
-  where
-    Indexed :: Data Length -> (Data Index -> a) -> Vector a
-
-instance Syntax a => Syntactic (Vector a)
-  where
-    type Domain (Vector a)   = FeldDomainAll
-    type Internal (Vector a) = [Internal a]
-    desugar = desugar . freezeVector . map resugar
-    sugar   = map resugar . unfreezeVector . sugar
-
-
-
-length :: Vector a -> Data Length
-length (Indexed len _) = len
-
-indexed :: Data Length -> (Data Index -> a) -> Vector a
-indexed = Indexed
-
-index :: Vector a -> Data Index -> a
-index (Indexed _ ixf) = ixf
-
-(!) :: Vector a -> Data Index -> a
-Indexed _ ixf ! i = ixf i
-
-infixl 9 !
-
-freezeVector :: Type a => Vector (Data a) -> Data [a]
-freezeVector vec = parallel (length vec) (index vec)
-
-unfreezeVector :: Type a => Data [a] -> Vector (Data a)
-unfreezeVector arr = Indexed (arrLength arr) (getIx arr)
-
-zip :: Vector a -> Vector b -> Vector (a,b)
-zip a b = indexed (length a `min` length b) (\i -> (index a i, index b i))
-
-unzip :: Vector (a,b) -> (Vector a, Vector b)
-unzip ab = (indexed len (fst . index ab), indexed len (snd . index ab))
-  where
-    len = length ab
-
-permute :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)
-permute perm vec = indexed len (index vec . perm len)
-  where
-    len = length vec
-
-reverse :: Vector a -> Vector a
-reverse = permute $ \len i -> len-i-1
-
-(...) :: Data Index -> Data Index -> Vector (Data Index)
-l ... h = indexed (h-l+1) (+l)
-
-map :: (a -> b) -> Vector a -> Vector b
-map f (Indexed len ixf) = Indexed len (f . ixf)
-
-zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c
-zipWith f a b = map (uncurry f) $ zip a b
-
-fold :: Syntax b => (a -> b -> b) -> b -> Vector a -> b
-fold f b (Indexed len ixf) = forLoop len b (\i st -> f (ixf i) st)
-
-sum :: (Num a, Syntax a) => Vector a -> a
-sum = fold (+) 0
-
-type Matrix a = Vector (Vector (Data a))
-
--- | Transpose of a matrix. Assumes that the number of rows is > 0.
-transpose :: Type a => Matrix a -> Matrix a
-transpose a = indexed (length (a!0)) $ \k -> indexed (length a) $ \l -> a ! l ! k
-
diff --git a/examples/NanoFeldsparComp.hs b/examples/NanoFeldsparComp.hs
new file mode 100644
--- /dev/null
+++ b/examples/NanoFeldsparComp.hs
@@ -0,0 +1,205 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- Note GADTs needed by GHC 7.6. In later GHCs is works with just TypeFamilies.
+
+-- | A simple compiler for NanoFeldspar
+
+module NanoFeldsparComp where
+
+
+
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+import Language.Syntactic.Functional.Sharing
+import Language.Syntactic.Functional.Tuple
+
+import NanoFeldspar hiding ((==))
+
+
+
+--------------------------------------------------------------------------------
+-- * Imperative programs
+--------------------------------------------------------------------------------
+
+type Var = String
+
+varName :: Name -> Var
+varName v = 'v' : show v
+
+varNameE :: Name -> Exp
+varNameE v = App (varName v) []
+
+data Exp = App String [Exp]
+  deriving (Eq, Show)
+
+data Stmt
+    = Assign Exp Exp
+    | If Exp Prog Prog
+    | For Exp Var Prog
+  deriving (Eq, Show)
+
+type Prog = [Stmt]
+
+viewOp :: String -> Maybe String
+viewOp op@(_:_:_)
+    | head op == '(' && last op == ')' = Just $ tail $ init op
+    | otherwise = Nothing
+
+renderExp :: Exp -> String
+renderExp (App f []) = f
+renderExp (App f@(_:_) [a,b])
+    | Just op <- viewOp f = concat ["(", renderExp a, " ", op, " ", renderExp b, ")"]
+renderExp (App f args) = "(" ++ unwords (f : Prelude.map renderExp args) ++ ")"
+
+indent :: [String] -> [String]
+indent = Prelude.map ("    " ++)
+
+renderProg :: Prog -> String
+renderProg = unlines . concatMap render
+  where
+    render (Assign l r) = [unwords [renderExp l, "=", renderExp r]]
+    render (If c t f) = concat
+        [ [unwords ["if", renderExp c]]
+        , indent (concatMap render t)
+        , ["else"]
+        , indent (concatMap render f)
+        ]
+    render (For l v body) = concat
+        [ [unwords ["for",v,"<", renderExp l]]
+        , indent (concatMap render body)
+        ]
+
+
+
+--------------------------------------------------------------------------------
+-- * Code generation
+--------------------------------------------------------------------------------
+
+type CodeGen = WriterT Prog (State Name)
+
+type Dom = BindingT
+       :+: Let
+       :+: Tuple
+       :+: Arithmetic
+       :+: Parallel
+       :+: ForLoop
+       :+: Construct
+
+fresh :: CodeGen Exp
+fresh = do
+    v <- get; put (v+1)
+    return (varNameE v)
+
+confiscate :: CodeGen Exp -> CodeGen (Exp,Prog)
+confiscate = censor (const mempty) . listen
+
+compileExp :: ASTF Dom a -> CodeGen Exp
+compileExp var
+    | Just (VarT v) <- prj var = return (varNameE v)
+compileExp (lett :$ a :$ (lam :$ body))
+    | Just (Let _)  <- prj lett
+    , Just (LamT v) <- prj lam
+    = do
+        a' <- compileExp a
+        tell [Assign (varNameE v) a']
+        compileExp body
+compileExp (par :$ len :$ (lam :$ body))
+    | Just Parallel <- prj par
+    , Just (LamT v) <- prj lam
+    = do
+        len' <- compileExp len
+        (e,body') <- confiscate $ compileExp body
+        arr <- fresh
+        let arrPos = App "(!)" [arr, varNameE v]
+        tell
+            [ For len' (varName v)
+                (  body'
+                ++ [Assign arrPos e]
+                )
+            ]
+        return arr
+compileExp (for :$ len :$ init :$ (lam1 :$ (lam2 :$ body)))
+    | Just ForLoop  <- prj for
+    , Just (LamT i) <- prj lam1
+    , Just (LamT s) <- prj lam2
+    = do
+        len'  <- compileExp len
+        init' <- compileExp init
+        (e,body') <- confiscate $ compileExp body
+        next <- fresh
+        tell
+            [ Assign (varNameE s) init'
+            , For len' (varName i)
+                (  body'
+                ++ [ Assign next e
+                   , Assign (varNameE s) next
+                   ]
+                )
+            ]
+        return next
+compileExp (cond :$ c :$ t :$ f)
+    | Just (Construct "cond" _) <- prj cond
+    = do
+        c' <- compileExp c
+        (t',tProg) <- confiscate $ compileExp t
+        (f',fProg) <- confiscate $ compileExp f
+        res <- fresh
+        tell
+            [ If c'
+                (  tProg
+                ++ [Assign res  t']
+                )
+                (  fProg
+                ++ [Assign res  f']
+                )
+            ]
+        return res
+compileExp (arrIx :$ arr :$ ix)
+    | Just (Construct "arrIx" _) <- prj arrIx = do
+        arr' <- compileExp arr
+        ix'  <- compileExp ix
+        return $ App "(!)" [arr',ix']
+-- Generic case for all other constructs
+compileExp a = simpleMatch
+  (\s as -> fmap (App (renderSym s)) $ sequence (listArgs compileExp as)) a
+
+compileTop :: ASTF Dom a -> CodeGen ()
+compileTop = go 0
+  where
+    go :: Int -> ASTF Dom a -> CodeGen ()
+    go n (lam :$ body)
+        | Just (LamT v) <- prj lam = do
+            tell [Assign (varNameE v) (App ("inp" ++ show n) [])]
+            go (n+1) body
+    go _ a = do
+        a' <- compileExp a
+        tell [Assign (App "out" []) a']
+
+
+
+compile :: (Syntactic a, Domain a ~ Typed Dom) => a -> String
+compile
+    = renderProg
+    . fst
+    . flip runState 0
+    . execWriterT
+    . compileTop
+    . mapAST (\(Typed s) -> s)
+    . codeMotion cmInterface
+    . desugar
+
+icompile :: (Syntactic a, Domain a ~ Typed Dom) => a -> IO ()
+icompile = putStrLn . compile
+
+
+
+--------------------------------------------------------------------------------
+-- * Code generation
+--------------------------------------------------------------------------------
+
+test_matMul = icompile matMul
+
diff --git a/examples/WellScoped.hs b/examples/WellScoped.hs
new file mode 100644
--- /dev/null
+++ b/examples/WellScoped.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
+
+-- | This module demonstrates the use of 'WS' terms. In particular, note that 'share' has no
+-- constraints on the type @a@ in contrast to the corresponding function in NanoFeldspar.
+--
+-- 'WS' terms can be evaluated directly using 'evalClosedWS' and they can be examined by first
+-- converting them using the function 'fromWS'.
+
+module WellScoped where
+
+
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+import Language.Syntactic.Functional.WellScoped
+
+
+
+type Exp e a = WS (Let :+: Construct) e a
+
+instance (Num a, Show a) => Num (Exp e a)
+  where
+    fromInteger i = smartWS (Construct (show i') i' :: Construct (Full a))
+      where i' = fromInteger i
+    (+) = smartWS (Construct "(+)" (+) :: Construct (a :-> a :-> Full a))
+
+share :: forall e a b .
+    Exp e a -> ((forall e' . Ext e' (a,e) => Exp e' a) -> Exp (a,e) b) -> Exp e b
+share a f = smartWS (Let "") a $ lamWS f
+
+ex1 :: Exp e (Int -> Int)
+ex1 = lamWS $ \a -> share (a + 4) $ \b -> share (a+b) $ \c -> a+b+c
+
+test1 = evalClosedWS ex1 5
+test2 = drawAST $ fromWS ex1
+
diff --git a/src/Data/DynamicAlt.hs b/src/Data/DynamicAlt.hs
deleted file mode 100644
--- a/src/Data/DynamicAlt.hs
+++ /dev/null
@@ -1,28 +0,0 @@
--- | An alternative to "Data.Dynamic" with a different constraint on 'toDyn'
-
-module Data.DynamicAlt where
-
-
-
-import Data.Dynamic ()
-import Data.Typeable
-import GHC.Prim
-import Unsafe.Coerce
-
-import Data.PolyProxy
-
-
-
-data Dynamic = Dynamic TypeRep Any
-
-toDyn :: forall a b . Typeable (a -> b) => P (a -> b) -> a -> Dynamic
-toDyn _ a = case splitTyConApp $ typeOf (undefined :: a -> b) of
-    (_,[ta,_]) -> Dynamic ta (unsafeCoerce a)
-
-fromDyn :: Typeable a => Dynamic -> Maybe a
-fromDyn (Dynamic t a)
-    | b <- unsafeCoerce a
-    , t == typeOf b
-    = Just b
-fromDyn _ = Nothing
-
diff --git a/src/Data/NestTuple.hs b/src/Data/NestTuple.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/NestTuple.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | Conversion between tuples and nested pairs
+
+module Data.NestTuple where
+
+
+
+import Data.NestTuple.TH
+
+
+
+-- | Tuples that can be converted to/from nested pairs
+class Nestable tup
+  where
+    -- | Representation as nested pairs
+    type Nested tup
+    -- | Convert to nested pairs
+    nest :: tup -> Nested tup
+    -- | Convert from nested pairs
+    unnest :: Nested tup -> tup
+
+mkNestableInstances 15
+
diff --git a/src/Data/NestTuple/TH.hs b/src/Data/NestTuple/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/NestTuple/TH.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE CPP #-}
+
+module Data.NestTuple.TH where
+
+
+
+import Language.Haskell.TH
+
+import Language.Syntactic.TH
+
+
+
+mkTupT :: [Type] -> Type
+mkTupT ts = foldl AppT (TupleT (length ts)) ts
+
+mkPairT :: Type -> Type -> Type
+mkPairT a b = foldl AppT (TupleT 2) [a,b]
+
+mkTupE :: [Exp] -> Exp
+#if __GLASGOW_HASKELL__ >= 810
+mkTupE = TupE . map Just
+#else
+mkTupE = TupE
+#endif
+
+mkPairE :: Exp -> Exp -> Exp
+mkPairE a b = mkTupE [a,b]
+
+mkPairP :: Pat -> Pat -> Pat
+mkPairP a b = TupP [a,b]
+
+data Nest a
+    = Leaf a
+    | Pair (Nest a) (Nest a)
+  deriving (Eq, Show, Functor)
+
+foldNest :: (a -> b) -> (b -> b -> b) -> Nest a -> b
+foldNest leaf pair = go
+  where
+    go (Leaf a) = leaf a
+    go (Pair a b) = pair (go a) (go b)
+
+toNest :: [a] -> Nest a
+toNest [a] = Leaf a
+toNest as  = Pair (toNest bs) (toNest cs)
+  where
+    (bs,cs) = splitAt ((length as + 1) `div` 2) as
+
+
+
+-- Make instances of the form
+--
+-- > instance Nestable (a,...,x)
+-- >   where
+-- >     type Nested (a,...,x) = (a ... x)  -- nested pairs
+-- >     nest   (a,...,x) = (a ... x)
+-- >     unnest (a ... x) = (a,...,x)
+mkNestableInstances
+    :: Int  -- ^ Max tuple width
+    -> DecsQ
+mkNestableInstances n = return $ map nestableInstance [2..n]
+  where
+    nestableInstance w = instD
+        []
+        (AppT (ConT (mkName "Nestable")) tupT)
+        [ tySynInst (mkName "Nested") [tupT] (foldNest VarT mkPairT $ toNest vars)
+        , FunD (mkName "nest")
+            [ Clause
+                [TupP (map VarP vars)]
+                (NormalB (foldNest VarE mkPairE $ toNest vars))
+                []
+            ]
+        , FunD (mkName "unnest")
+            [ Clause
+                [foldNest VarP mkPairP $ toNest vars]
+                (NormalB (mkTupE (map VarE vars)))
+                []
+            ]
+        ]
+      where
+        vars = take w varSupply
+        tupT = mkTupT $ map VarT vars
+
diff --git a/src/Data/PolyProxy.hs b/src/Data/PolyProxy.hs
deleted file mode 100644
--- a/src/Data/PolyProxy.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE PolyKinds #-}
-
--- TODO PolyKinds can be enabled globally in GHC 7.6. In 7.4, additional annotations are needed.
-
-module Data.PolyProxy where
-
-
-
--- | Kind-polymorphic proxy type
-data P a where P :: P a
-  -- Using one letter to remove line noise
-
diff --git a/src/Language/Syntactic.hs b/src/Language/Syntactic.hs
--- a/src/Language/Syntactic.hs
+++ b/src/Language/Syntactic.hs
@@ -1,29 +1,18 @@
 -- | The basic parts of the syntactic library
 
 module Language.Syntactic
-    ( module Data.PolyProxy
-    , module Language.Syntactic.Syntax
+    ( module Language.Syntactic.Syntax
     , module Language.Syntactic.Traversal
-    , module Language.Syntactic.Constraint
+    , module Language.Syntactic.Interpretation
     , module Language.Syntactic.Sugar
-    , module Language.Syntactic.Interpretation.Equality
-    , module Language.Syntactic.Interpretation.Render
-    , module Language.Syntactic.Interpretation.Evaluation
-    , module Language.Syntactic.Interpretation.Semantics
-    , module Data.Constraint
+    , module Language.Syntactic.Decoration
     ) where
 
 
 
-import Data.PolyProxy
 import Language.Syntactic.Syntax
 import Language.Syntactic.Traversal
-import Language.Syntactic.Constraint
+import Language.Syntactic.Interpretation
 import Language.Syntactic.Sugar
-import Language.Syntactic.Interpretation.Equality
-import Language.Syntactic.Interpretation.Render
-import Language.Syntactic.Interpretation.Evaluation
-import Language.Syntactic.Interpretation.Semantics
-
-import Data.Constraint (Constraint, Dict (..))
+import Language.Syntactic.Decoration
 
diff --git a/src/Language/Syntactic/Constraint.hs b/src/Language/Syntactic/Constraint.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constraint.hs
+++ /dev/null
@@ -1,396 +0,0 @@
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- TODO Only `InjectC` should be used overlapped. Move to separate module?
-
--- | Type-constrained syntax trees
-
-module Language.Syntactic.Constraint where
-
-
-
-import Data.Typeable
-
-import Data.Constraint
-
-import Data.PolyProxy
-import Language.Syntactic.Syntax
-import Language.Syntactic.Interpretation.Equality
-import Language.Syntactic.Interpretation.Render
-import Language.Syntactic.Interpretation.Evaluation
-
-
-
---------------------------------------------------------------------------------
--- * Type predicates
---------------------------------------------------------------------------------
-
--- | Intersection of type predicates
-class    (c1 a, c2 a) => (c1 :/\: c2) a
-instance (c1 a, c2 a) => (c1 :/\: c2) a
-
-infixr 5 :/\:
-
--- | Universal type predicate
-class    Top a
-instance Top a
-
-pTop :: P Top
-pTop = P
-
-pTypeable :: P Typeable
-pTypeable = P
-
--- | Evidence that the predicate @sub@ is a subset of @sup@
-type Sub sub sup = forall a . Dict (sub a) -> Dict (sup a)
-
--- | Weaken an intersection
-weakL :: Sub (c1 :/\: c2) c1
-weakL Dict = Dict
-
--- | Weaken an intersection
-weakR :: Sub (c1 :/\: c2) c2
-weakR Dict = Dict
-
--- | Subset relation on type predicates
-class (sub :: * -> Constraint) :< (sup :: * -> Constraint)
-  where
-    -- | Compute evidence that @sub@ is a subset of @sup@ (i.e. that @(sup a)@
-    -- implies @(sub a)@)
-    sub :: Sub sub sup
-
-instance p :< p
-  where
-    sub = id
-
-instance (p :/\: ps) :< p
-  where
-    sub = weakL
-
-instance (ps :< q) => ((p :/\: ps) :< q)
-  where
-    sub = sub . weakR
-
-
-
---------------------------------------------------------------------------------
--- * Constrained syntax
---------------------------------------------------------------------------------
-
--- | Constrain the result type of the expression by the given predicate
-data (:|) :: (* -> *) -> (* -> Constraint) -> (* -> *)
-  where
-    C :: pred (DenResult sig) => expr sig -> (expr :| pred) sig
-
-infixl 4 :|
-
-instance Project sub sup => Project sub (sup :| pred)
-  where
-    prj (C s) = prj s
-
-instance Equality dom => Equality (dom :| pred)
-  where
-    equal (C a) (C b) = equal a b
-    exprHash (C a)    = exprHash a
-
-instance Render dom => Render (dom :| pred)
-  where
-    renderSym (C a) = renderSym a
-    renderArgs args (C a) = renderArgs args a
-
-instance Eval dom => Eval (dom :| pred)
-  where
-    evaluate (C a) = evaluate a
-
-instance StringTree dom => StringTree (dom :| pred)
-  where
-    stringTreeSym args (C a) = stringTreeSym args a
-
-
-
--- | Constrain the result type of the expression by the given predicate
---
--- The difference between ':||' and ':|' is seen in the instances of the 'Sat'
--- type:
---
--- > type Sat (dom :|  pred) = pred :/\: Sat dom
--- > type Sat (dom :|| pred) = pred
-data (:||) :: (* -> *) -> (* -> Constraint) -> (* -> *)
-  where
-    C' :: pred (DenResult sig) => expr sig -> (expr :|| pred) sig
-
-infixl 4 :||
-
-instance Project sub sup => Project sub (sup :|| pred)
-  where
-    prj (C' s) = prj s
-
-instance Equality dom => Equality (dom :|| pred)
-  where
-    equal (C' a) (C' b) = equal a b
-    exprHash (C' a)     = exprHash a
-
-instance Render dom => Render (dom :|| pred)
-  where
-    renderSym (C' a) = renderSym a
-    renderArgs args (C' a) = renderArgs args a
-
-instance Eval dom => Eval (dom :|| pred)
-  where
-    evaluate (C' a) = evaluate a
-
-instance StringTree dom => StringTree (dom :|| pred)
-  where
-    stringTreeSym args (C' a) = stringTreeSym args a
-
-
-
--- | Expressions that constrain their result types
-class Constrained expr
-  where
-    -- | Returns a predicate that is satisfied by the result type of all
-    -- expressions of the given type (see 'exprDict').
-    type Sat expr :: * -> Constraint
-
-    -- | Compute a constraint on the result type of an expression
-    exprDict :: expr a -> Dict (Sat expr (DenResult a))
-
-instance Constrained dom => Constrained (AST dom)
-  where
-    type Sat (AST dom) = Sat dom
-    exprDict (Sym s)  = exprDict s
-    exprDict (s :$ _) = exprDict s
-
-instance Constrained (sub1 :+: sub2)
-  where
-    -- | An over-approximation of the union of @Sat sub1@ and @Sat sub2@
-    type Sat (sub1 :+: sub2) = Top
-    exprDict (InjL s) = Dict
-    exprDict (InjR s) = Dict
-
-instance Constrained dom => Constrained (dom :| pred)
-  where
-    type Sat (dom :| pred) = pred :/\: Sat dom
-    exprDict (C s) = case exprDict s of Dict -> Dict
-
-instance Constrained (dom :|| pred)
-  where
-    type Sat (dom :|| pred) = pred
-    exprDict (C' s) = Dict
-
-type ConstrainedBy expr p = (Constrained expr, Sat expr :< p)
-
--- | A version of 'exprDict' that returns a constraint for a particular
--- predicate @p@ as long as @(p :< Sat dom)@ holds
-exprDictSub :: ConstrainedBy expr p => P p -> expr a -> Dict (p (DenResult a))
-exprDictSub _ = sub . exprDict
-
--- | A version of 'exprDict' that works for domains of the form
--- @(dom1 :+: dom2)@ as long as @(Sat dom1 ~ Sat dom2)@ holds
-exprDictPlus :: (Constrained dom1, Constrained dom2, Sat dom1 ~ Sat dom2) =>
-    AST (dom1 :+: dom2) a -> Dict (Sat dom1 (DenResult a))
-exprDictPlus (s :$ _)       = exprDictPlus s
-exprDictPlus (Sym (InjL a)) = exprDict a
-exprDictPlus (Sym (InjR a)) = exprDict a
-
-
-
--- | Symbol injection (like ':<:') with constrained result types
-class (Project sub sup, Sat sup a) => InjectC sub sup a
-  where
-    injC :: (DenResult sig ~ a) => sub sig -> sup sig
-
-instance InjectC sub sup a => InjectC sub (AST sup) a
-  where
-    injC = Sym . injC
-
-instance (InjectC sub sup a, pred a) => InjectC sub (sup :| pred) a
-  where
-    injC = C . injC
-
-instance (InjectC sub sup a, pred a) => InjectC sub (sup :|| pred) a
-  where
-    injC = C' . injC
-
-instance Sat expr a => InjectC expr expr a
-  where
-    injC = id
-
-instance InjectC expr1 (expr1 :+: expr2) a
-  where
-    injC = InjL
-
-instance InjectC expr1 expr3 a => InjectC expr1 (expr2 :+: expr3) a
-  where
-    injC = InjR . injC
-
-
-
--- | Generic symbol application
---
--- 'appSymC' has any type of the form:
---
--- > appSymC :: InjectC expr (AST dom) x
--- >     => expr (a :-> b :-> ... :-> Full x)
--- >     -> (ASTF dom a -> ASTF dom b -> ... -> ASTF dom x)
-appSymC :: (ApplySym sig f dom, InjectC sym (AST dom) (DenResult sig)) => sym sig -> f
-appSymC = appSym' . injC
-
-
-
--- | Similar to ':||', but rather than constraining the whole result type, it assumes a result
--- type of the form @c a@ and constrains the @a@.
-data SubConstr1 :: (* -> *) -> (* -> *) -> (* -> Constraint) -> (* -> *)
-  where
-    SubConstr1 :: (p a, DenResult sig ~ c a) => dom sig -> SubConstr1 c dom p sig
-
-instance Constrained dom => Constrained (SubConstr1 c dom p)
-  where
-    type Sat (SubConstr1 c dom p) = Sat dom
-    exprDict (SubConstr1 s) = exprDict s
-
-instance Project sub sup => Project sub (SubConstr1 c sup p)
-  where
-    prj (SubConstr1 s) = prj s
-
-instance Equality dom => Equality (SubConstr1 c dom p)
-  where
-    equal (SubConstr1 a) (SubConstr1 b) = equal a b
-    exprHash (SubConstr1 s) = exprHash s
-
-instance Render dom => Render (SubConstr1 c dom p)
-  where
-    renderSym (SubConstr1 s) = renderSym s
-    renderArgs args (SubConstr1 s) = renderArgs args s
-
-instance StringTree dom => StringTree (SubConstr1 c dom p)
-  where
-    stringTreeSym args (SubConstr1 a) = stringTreeSym args a
-
-instance Eval dom => Eval (SubConstr1 c dom p)
-  where
-    evaluate (SubConstr1 a) = evaluate a
-
-
-
--- | Similar to 'SubConstr1', but assumes a result type of the form @c a b@ and constrains both @a@
--- and @b@.
-data SubConstr2 :: (* -> * -> *) -> (* -> *) -> (* -> Constraint) -> (* -> Constraint) -> (* -> *)
-  where
-    SubConstr2 :: (DenResult sig ~ c a b, pa a, pb b) => dom sig -> SubConstr2 c dom pa pb sig
-
-instance Constrained dom => Constrained (SubConstr2 c dom pa pb)
-  where
-    type Sat (SubConstr2 c dom pa pb) = Sat dom
-    exprDict (SubConstr2 s) = exprDict s
-
-instance Project sub sup => Project sub (SubConstr2 c sup pa pb)
-  where
-    prj (SubConstr2 s) = prj s
-
-instance Equality dom => Equality (SubConstr2 c dom pa pb)
-  where
-    equal (SubConstr2 a) (SubConstr2 b) = equal a b
-    exprHash (SubConstr2 s) = exprHash s
-
-instance Render dom => Render (SubConstr2 c dom pa pb)
-  where
-    renderSym (SubConstr2 s) = renderSym s
-    renderArgs args (SubConstr2 s) = renderArgs args s
-
-instance StringTree dom => StringTree (SubConstr2 c dom pa pb)
-  where
-    stringTreeSym args (SubConstr2 a) = stringTreeSym args a
-
-instance Eval dom => Eval (SubConstr2 c dom pa pb)
-  where
-    evaluate (SubConstr2 a) = evaluate a
-
-
-
---------------------------------------------------------------------------------
--- * Existential quantification
---------------------------------------------------------------------------------
-
--- | 'AST' with existentially quantified result type
-data ASTE :: (* -> *) -> *
-  where
-    ASTE :: ASTF dom a -> ASTE dom
-
-liftASTE
-    :: (forall a . ASTF dom a -> b)
-    -> ASTE dom
-    -> b
-liftASTE f (ASTE a) = f a
-
-liftASTE2
-    :: (forall a b . ASTF dom a -> ASTF dom b -> c)
-    -> ASTE dom -> ASTE dom -> c
-liftASTE2 f (ASTE a) (ASTE b) = f a b
-
-
-
--- | 'AST' with bounded existentially quantified result type
-data ASTB :: (* -> *) -> (* -> Constraint) -> *
-  where
-    ASTB :: p a => ASTF dom a -> ASTB dom p
-
-liftASTB
-    :: (forall a . p a => ASTF dom a -> b)
-    -> ASTB dom p
-    -> b
-liftASTB f (ASTB a) = f a
-
-liftASTB2
-    :: (forall a b . (p a, p b) => ASTF dom a -> ASTF dom b -> c)
-    -> ASTB dom p -> ASTB dom p -> c
-liftASTB2 f (ASTB a) (ASTB b) = f a b
-
-type ASTSAT dom = ASTB dom (Sat dom)
-
-
-
---------------------------------------------------------------------------------
--- * Misc.
---------------------------------------------------------------------------------
-
--- | Empty symbol type
---
--- Use-case:
---
--- > data A a
--- > data B a
--- >
--- > test :: AST (A :+: (B:||Eq) :+: Empty) a
--- > test = injC (undefined :: (B :|| Eq) a)
---
--- Without 'Empty', this would lead to an overlapping instance error due to the instances
---
--- > InjectC (B :|| Eq) (B :|| Eq) (DenResult a)
---
--- and
---
--- > InjectC sub sup a, pred a) => InjectC sub (sup :|| pred) a
-data Empty :: * -> *
-
-instance Constrained Empty
-  where
-    type Sat Empty = Top
-    exprDict = error "Not implemented: exprDict for Empty"
-
-instance Equality   Empty where equal      = error "Not implemented: equal for Empty"
-                                exprHash   = error "Not implemented: exprHash for Empty"
-instance Eval       Empty where evaluate   = error "Not implemented: equal for Empty"
-instance Render     Empty where renderSym  = error "Not implemented: renderSym for Empty"
-                                renderArgs = error "Not implemented: renderArgs for Empty"
-instance StringTree Empty
-
-
-
-universe :: ASTF dom a -> [ASTE dom]
-universe a = ASTE a : go a
-  where
-    go :: AST dom a -> [ASTE dom]
-    go (Sym s)  = []
-    go (s :$ a) = go s ++ universe a
-
diff --git a/src/Language/Syntactic/Constructs/Binding.hs b/src/Language/Syntactic/Constructs/Binding.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Binding.hs
+++ /dev/null
@@ -1,431 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-
--- | General binding constructs
-
-module Language.Syntactic.Constructs.Binding where
-
-
-
-import qualified Control.Monad.Identity as Monad
-import Control.Monad.Reader
-import Data.Ix
-import Data.Tree
-import Data.Typeable
-
-import Data.Hash
-
-import Data.PolyProxy
-import Data.DynamicAlt
-import Language.Syntactic
-import Language.Syntactic.Constructs.Condition
-import Language.Syntactic.Constructs.Construct
-import Language.Syntactic.Constructs.Decoration
-import Language.Syntactic.Constructs.Identity
-import Language.Syntactic.Constructs.Literal
-import Language.Syntactic.Constructs.Monad
-import Language.Syntactic.Constructs.Tuple
-
-
-
---------------------------------------------------------------------------------
--- * Variables
---------------------------------------------------------------------------------
-
--- | Variable identifier
-newtype VarId = VarId { varInteger :: Integer }
-  deriving (Eq, Ord, Num, Real, Integral, Enum, Ix)
-
-instance Show VarId
-  where
-    show (VarId i) = show i
-
-showVar :: VarId -> String
-showVar v = "var" ++ show v
-
-
-
--- | Variables
-data Variable a
-  where
-    Variable :: VarId -> Variable (Full a)
-
-instance Constrained Variable
-  where
-    type Sat Variable = Top
-    exprDict _ = Dict
-
--- | 'equal' does strict identifier comparison; i.e. no alpha equivalence.
---
--- 'exprHash' assigns the same hash to all variables. This is a valid
--- over-approximation that enables the following property:
---
--- @`alphaEq` a b  ==>  `exprHash` a == `exprHash` b@
-instance Equality Variable
-  where
-    equal (Variable v1) (Variable v2) = v1==v2
-    exprHash (Variable _)             = hashInt 0
-
-instance Render Variable
-  where
-    renderSym (Variable v) = showVar v
-
-instance StringTree Variable
-  where
-    stringTreeSym [] (Variable v) = Node ("var:" ++ show v) []
-
-
-
---------------------------------------------------------------------------------
--- * Lambda binding
---------------------------------------------------------------------------------
-
--- | Lambda binding
-data Lambda a
-  where
-    Lambda :: VarId -> Lambda (b :-> Full (a -> b))
-
-instance Constrained Lambda
-  where
-    type Sat Lambda = Top
-    exprDict _ = Dict
-
--- | 'equal' does strict identifier comparison; i.e. no alpha equivalence.
---
--- 'exprHash' assigns the same hash to all 'Lambda' bindings. This is a valid
--- over-approximation that enables the following property:
---
--- @`alphaEq` a b  ==>  `exprHash` a == `exprHash` b@
-instance Equality Lambda
-  where
-    equal (Lambda v1) (Lambda v2) = v1==v2
-    exprHash (Lambda _)           = hashInt 0
-
-instance Render Lambda
-  where
-    renderSym (Lambda v) = "Lambda " ++ show v
-    renderArgs [body] (Lambda v) = "(\\" ++ showVar v ++ " -> "  ++ body ++ ")"
-
-instance StringTree Lambda
-  where
-    stringTreeSym [body] (Lambda v) = Node ("Lambda " ++ show v) [body]
-
--- | Allow an existing binding to be used with a body of a different type
-reuseLambda :: Lambda (b :-> Full (a -> b)) -> Lambda (c :-> Full (a -> c))
-reuseLambda (Lambda v) = Lambda v
-
-
-
---------------------------------------------------------------------------------
--- * Let binding
---------------------------------------------------------------------------------
-
--- | Let binding
---
--- 'Let' is just an application operator with flipped argument order. The argument
--- @(a -> b)@ is preferably constructed by 'Lambda'.
-data Let a
-  where
-    Let :: Let (a :-> (a -> b) :-> Full b)
-
-instance Constrained Let
-  where
-    type Sat Let = Top
-    exprDict _ = Dict
-
-instance Equality Let
-  where
-    equal Let Let = True
-    exprHash Let  = hashInt 0
-
-instance Render Let
-  where
-    renderSym Let = "Let"
-    renderArgs []    Let = "Let"
-    renderArgs [f,a] Let = "(" ++ unwords ["letBind",f,a] ++ ")"
-
-instance StringTree Let
-  where
-    stringTreeSym [a,body] Let = case splitAt 7 node of
-        ("Lambda ", var) -> Node ("Let " ++ var) [a,body']
-        _                -> Node "Let" [a,body]
-      where
-        Node node ~[body'] = body
-        var                = drop 7 node  -- Drop the "Lambda " prefix
-
-instance Eval Let
-  where
-    evaluate Let = flip ($)
-
-
-
---------------------------------------------------------------------------------
--- * Interpretation
---------------------------------------------------------------------------------
-
--- | Should be a capture-avoiding substitution, but it is currently not correct.
---
--- Note: Variables with a different type than the new expression will be
--- silently ignored.
-subst :: forall constr dom a b
-    .  ( ConstrainedBy dom Typeable
-       , Project Lambda dom
-       , Project Variable dom
-       )
-    => VarId       -- ^ Variable to be substituted
-    -> ASTF dom a  -- ^ Expression to substitute for
-    -> ASTF dom b  -- ^ Expression to substitute in
-    -> ASTF dom b
-subst v new a = go a
-  where
-    go :: AST dom c -> AST dom c
-    go a@((prj -> Just (Lambda w)) :$ _)
-        | v==w = a  -- Capture
-    go (f :$ a) = go f :$ go a
-    go var
-        | Just (Variable w) <- prj var
-        , v==w
-        , Dict <- exprDictSub pTypeable new
-        , Dict <- exprDictSub pTypeable var
-        , Just new' <- gcast new
-        = new'
-    go a = a
-  -- TODO Make it correct (may need to alpha-convert `new` before inserting it)
-  -- TODO Should there be an error if `gcast` fails? (See note in Haddock
-  --      comment.)
-
--- | Beta-reduction of an expression. The expression to be reduced is assumed to
--- be a `Lambda`.
-betaReduce
-    :: ( ConstrainedBy dom Typeable
-       , Project Lambda dom
-       , Project Variable dom
-       )
-    => ASTF dom a         -- ^ Argument
-    -> ASTF dom (a -> b)  -- ^ Function to be reduced
-    -> ASTF dom b
-betaReduce new (lam :$ body)
-    | Just (Lambda v) <- prj lam = subst v new body
-
-
-
--- | Evaluation of expressions with variables
-class EvalBind sub
-  where
-    evalBindSym
-        :: (EvalBind dom, ConstrainedBy dom Typeable, Typeable (DenResult sig))
-        => sub sig
-        -> Args (AST dom) sig
-        -> Reader [(VarId,Dynamic)] (DenResult sig)
-  -- `(Typeable (DenResult sig))` is required because this dictionary cannot (in
-  -- general) be obtained from `sub`. It can only be obtained from `dom`, and
-  -- this is what `evalBindM` does.
-
-instance (EvalBind sub1, EvalBind sub2) => EvalBind (sub1 :+: sub2)
-  where
-    evalBindSym (InjL a) = evalBindSym a
-    evalBindSym (InjR a) = evalBindSym a
-
--- | Evaluation of possibly open expressions
-evalBindM :: (EvalBind dom, ConstrainedBy dom Typeable) =>
-    ASTF dom a -> Reader [(VarId,Dynamic)] a
-evalBindM a
-    | Dict <- exprDictSub pTypeable a
-    = liftM result $ match (\s -> liftM Full . evalBindSym s) a
-
--- | Evaluation of closed expressions
-evalBind :: (EvalBind dom, ConstrainedBy dom Typeable) => ASTF dom a -> a
-evalBind = flip runReader [] . evalBindM
-
--- | Apply a symbol denotation to a list of arguments
-appDen :: Denotation sig -> Args Monad.Identity sig -> DenResult sig
-appDen a Nil       = a
-appDen f (a :* as) = appDen (f $ result $ Monad.runIdentity a) as
-
--- | Convenient default implementation of 'evalBindSym'
-evalBindSymDefault
-    :: (Eval sub, EvalBind dom, ConstrainedBy dom Typeable)
-    => sub sig
-    -> Args (AST dom) sig
-    -> Reader [(VarId,Dynamic)] (DenResult sig)
-evalBindSymDefault sym args = do
-    args' <- mapArgsM (liftM (Monad.Identity . Full) . evalBindM) args
-    return $ appDen (evaluate sym) args'
-
-instance EvalBind dom => EvalBind (dom :| pred)
-  where
-    evalBindSym (C a) = evalBindSym a
-
-instance EvalBind dom => EvalBind (dom :|| pred)
-  where
-    evalBindSym (C' a) = evalBindSym a
-
-instance EvalBind dom => EvalBind (SubConstr1 c dom p)
-  where
-    evalBindSym (SubConstr1 a) = evalBindSym a
-
-instance EvalBind dom => EvalBind (SubConstr2 c dom pa pb)
-  where
-    evalBindSym (SubConstr2 a) = evalBindSym a
-
-instance EvalBind Empty
-  where
-    evalBindSym = error "Not implemented: evalBindSym for Empty"
-
-instance EvalBind dom => EvalBind (Decor info dom)
-  where
-    evalBindSym = evalBindSym . decorExpr
-
-instance EvalBind Identity  where evalBindSym = evalBindSymDefault
-instance EvalBind Construct where evalBindSym = evalBindSymDefault
-instance EvalBind Literal   where evalBindSym = evalBindSymDefault
-instance EvalBind Condition where evalBindSym = evalBindSymDefault
-instance EvalBind Tuple     where evalBindSym = evalBindSymDefault
-instance EvalBind Select    where evalBindSym = evalBindSymDefault
-instance EvalBind Let       where evalBindSym = evalBindSymDefault
-
-instance Monad m => EvalBind (MONAD m) where evalBindSym = evalBindSymDefault
-
-instance EvalBind Variable
-  where
-    evalBindSym (Variable v) Nil = do
-        env <- ask
-        case lookup v env of
-            Nothing -> return $ error "evalBind: evaluating free variable"
-            Just a  -> case fromDyn a of
-              Just a -> return a
-              _      -> return $ error "evalBind: internal type error"
-
-instance EvalBind Lambda
-  where
-    evalBindSym lam@(Lambda v) (body :* Nil) = do
-        env <- ask
-        return
-            $ \a -> flip runReader ((v, toDyn (funType lam) a):env)
-            $ evalBindM body
-      where
-        funType :: Lambda (b :-> Full (a -> b)) -> P (a -> b)
-        funType _ = P
-
-
-
---------------------------------------------------------------------------------
--- * Alpha equivalence
---------------------------------------------------------------------------------
-
--- | Environments containing a list of variable equivalences
-class VarEqEnv a
-  where
-    prjVarEqEnv :: a -> [(VarId,VarId)]
-    modVarEqEnv :: ([(VarId,VarId)] -> [(VarId,VarId)]) -> (a -> a)
-
-instance VarEqEnv [(VarId,VarId)]
-  where
-    prjVarEqEnv = id
-    modVarEqEnv = id
-
--- | Alpha-equivalence
-class AlphaEq sub1 sub2 dom env
-  where
-    alphaEqSym
-        :: sub1 a
-        -> Args (AST dom) a
-        -> sub2 b
-        -> Args (AST dom) b
-        -> Reader env Bool
-
-instance (AlphaEq subA1 subB1 dom env, AlphaEq subA2 subB2 dom env) =>
-    AlphaEq (subA1 :+: subA2) (subB1 :+: subB2) dom env
-  where
-    alphaEqSym (InjL a) aArgs (InjL b) bArgs = alphaEqSym a aArgs b bArgs
-    alphaEqSym (InjR a) aArgs (InjR b) bArgs = alphaEqSym a aArgs b bArgs
-    alphaEqSym _ _ _ _ = return False
-
-alphaEqM :: AlphaEq dom dom dom env =>
-    ASTF dom a -> ASTF dom b -> Reader env Bool
-alphaEqM a b = simpleMatch (alphaEqM2 b) a
-
-alphaEqM2 :: AlphaEq dom dom dom env =>
-    ASTF dom b -> dom a -> Args (AST dom) a -> Reader env Bool
-alphaEqM2 b a aArgs = simpleMatch (alphaEqSym a aArgs) b
-
--- | Alpha-equivalence on lambda expressions. Free variables are taken to be
--- equivalent if they have the same identifier.
-alphaEq :: AlphaEq dom dom dom [(VarId,VarId)] =>
-    ASTF dom a -> ASTF dom b -> Bool
-alphaEq a b = flip runReader ([] :: [(VarId,VarId)]) $ alphaEqM a b
-
-alphaEqSymDefault :: (Equality sub, AlphaEq dom dom dom env)
-    => sub a
-    -> Args (AST dom) a
-    -> sub b
-    -> Args (AST dom) b
-    -> Reader env Bool
-alphaEqSymDefault a aArgs b bArgs
-    | equal a b = alphaEqChildren a' b'
-    | otherwise = return False
-  where
-    a' = appArgs (Sym (undefined :: dom a)) aArgs
-    b' = appArgs (Sym (undefined :: dom b)) bArgs
-
-alphaEqChildren :: AlphaEq dom dom dom env =>
-    AST dom a -> AST dom b -> Reader env Bool
-alphaEqChildren (Sym _)  (Sym _)  = return True
-alphaEqChildren (f :$ a) (g :$ b) = liftM2 (&&)
-    (alphaEqChildren f g)
-    (alphaEqM a b)
-alphaEqChildren _ _ = return False
-
-instance AlphaEq sub sub dom env => AlphaEq (sub :| pred) (sub :| pred) dom env
-  where
-    alphaEqSym (C a) aArgs (C b) bArgs = alphaEqSym a aArgs b bArgs
-
-instance AlphaEq sub sub dom env => AlphaEq (sub :|| pred) (sub :|| pred) dom env
-  where
-    alphaEqSym (C' a) aArgs (C' b) bArgs = alphaEqSym a aArgs b bArgs
-
-instance AlphaEq sub sub dom env => AlphaEq (SubConstr1 c sub p) (SubConstr1 c sub p) dom env
-  where
-    alphaEqSym (SubConstr1 a) aArgs (SubConstr1 b) bArgs = alphaEqSym a aArgs b bArgs
-
-instance AlphaEq sub sub dom env =>
-    AlphaEq (SubConstr2 c sub pa pb) (SubConstr2 c sub pa pb) dom env
-  where
-    alphaEqSym (SubConstr2 a) aArgs (SubConstr2 b) bArgs = alphaEqSym a aArgs b bArgs
-
-instance AlphaEq Empty Empty dom env
-  where
-    alphaEqSym = error "Not implemented: alphaEqSym for Empty"
-
-instance AlphaEq dom dom dom env => AlphaEq Condition Condition dom env where alphaEqSym = alphaEqSymDefault
-instance AlphaEq dom dom dom env => AlphaEq Construct Construct dom env where alphaEqSym = alphaEqSymDefault
-instance AlphaEq dom dom dom env => AlphaEq Identity  Identity  dom env where alphaEqSym = alphaEqSymDefault
-instance AlphaEq dom dom dom env => AlphaEq Let       Let       dom env where alphaEqSym = alphaEqSymDefault
-instance AlphaEq dom dom dom env => AlphaEq Literal   Literal   dom env where alphaEqSym = alphaEqSymDefault
-instance AlphaEq dom dom dom env => AlphaEq Select    Select    dom env where alphaEqSym = alphaEqSymDefault
-instance AlphaEq dom dom dom env => AlphaEq Tuple     Tuple     dom env where alphaEqSym = alphaEqSymDefault
-
-instance AlphaEq sub sub dom env =>
-    AlphaEq (Decor info sub) (Decor info sub) dom env
-  where
-    alphaEqSym a aArgs b bArgs =
-        alphaEqSym (decorExpr a) aArgs (decorExpr b) bArgs
-
-instance (AlphaEq dom dom dom env, Monad m) => AlphaEq (MONAD m) (MONAD m) dom env
-  where
-    alphaEqSym = alphaEqSymDefault
-
-instance (AlphaEq dom dom dom env, VarEqEnv env) =>
-    AlphaEq Variable Variable dom env
-  where
-    alphaEqSym (Variable v1) Nil (Variable v2) Nil = do
-        env <- asks prjVarEqEnv
-        case lookup v1 env of
-          Nothing  -> return (v1==v2)   -- Free variables
-          Just v2' -> return (v2==v2')
-
-instance (AlphaEq dom dom dom env, VarEqEnv env) =>
-    AlphaEq Lambda Lambda dom env
-  where
-    alphaEqSym (Lambda v1) (body1 :* Nil) (Lambda v2) (body2 :* Nil) =
-        local (modVarEqEnv ((v1,v2):)) $ alphaEqM body1 body2
-
diff --git a/src/Language/Syntactic/Constructs/Binding/HigherOrder.hs b/src/Language/Syntactic/Constructs/Binding/HigherOrder.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Binding/HigherOrder.hs
+++ /dev/null
@@ -1,102 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- | This module provides binding constructs using higher-order syntax and a
--- function ('reify') for translating to first-order syntax. Expressions
--- constructed using the exported interface (specifically, not introducing
--- 'Variable's explicitly) are guaranteed to have well-behaved translation.
-
-module Language.Syntactic.Constructs.Binding.HigherOrder
-    ( Variable
-    , Let (..)
-    , HOLambda (..)
-    , HODomain
-    , FODomain
-    , CLambda
-    , IsHODomain (..)
-    , reifyM
-    , reifyTop
-    , reify
-    ) where
-
-
-
-import Control.Monad.State
-
-import Language.Syntactic
-import Language.Syntactic.Constructs.Binding
-
-
-
--- | Higher-order lambda binding
-data HOLambda dom p pVar a
-  where
-    HOLambda
-        :: (p a, pVar a)
-        => (ASTF (HODomain dom p pVar) a -> ASTF (HODomain dom p pVar) b)
-        -> HOLambda dom p pVar (Full (a -> b))
-
--- | Adding support for higher-order abstract syntax to a domain
-type HODomain dom p pVar = (HOLambda dom p pVar :+: (Variable :|| pVar) :+: dom) :|| p
-
--- | Equivalent to 'HODomain' (including type constraints), but using a first-order representation
--- of binding
-type FODomain dom p pVar = (CLambda pVar :+: (Variable :|| pVar) :+: dom) :|| p
-
--- | 'Lambda' with a constraint on the bound variable type
-type CLambda pVar = SubConstr2 (->) Lambda pVar Top
-
-
-
--- | An abstraction of 'HODomain'
-class IsHODomain dom p pVar | dom -> p pVar
-  where
-    lambda :: (p (a -> b), p a, pVar a) => (ASTF dom a -> ASTF dom b) -> ASTF dom (a -> b)
-
-instance IsHODomain (HODomain dom p pVar) p pVar
-  where
-    lambda = injC . HOLambda
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , IsHODomain dom p pVar
-    , p (Internal a -> Internal b)
-    , p (Internal a)
-    , pVar (Internal a)
-    ) =>
-      Syntactic (a -> b)
-  where
-    type Domain (a -> b)   = Domain a
-    type Internal (a -> b) = Internal a -> Internal b
-    desugar f = lambda (desugar . f . sugar)
-    sugar     = error "sugar not implemented for (a -> b)"
-      -- TODO An implementation of sugar would require dom to have some kind of
-      --      application. Perhaps use `Let` for this?
-
-
-
-reifyM :: forall dom p pVar a
-    . AST (HODomain dom p pVar) a -> State VarId (AST (FODomain dom p pVar) a)
-reifyM (f :$ a)            = liftM2 (:$) (reifyM f) (reifyM a)
-reifyM (Sym (C' (InjR a))) = return $ Sym $ C' $ InjR a
-reifyM (Sym (C' (InjL (HOLambda f)))) = do
-    v    <- get; put (v+1)
-    body <- reifyM $ f $ injC $ symType pVar $ C' (Variable v)
-    return $ injC (symType pLam $ SubConstr2 (Lambda v)) :$ body
-  where
-    pVar = P::P (Variable :|| pVar)
-    pLam = P::P (CLambda pVar)
-
--- | Translating expressions with higher-order binding to corresponding
--- expressions using first-order binding
-reifyTop :: AST (HODomain dom p pVar) a -> AST (FODomain dom p pVar) a
-reifyTop = flip evalState 0 . reifyM
-  -- It is assumed that there are no 'Variable' constructors (i.e. no free
-  -- variables) in the argument. This is guaranteed by the exported interface.
-
--- | Reify an n-ary syntactic function
-reify :: (Syntactic a, Domain a ~ HODomain dom p pVar) =>
-    a -> ASTF (FODomain dom p pVar) (Internal a)
-reify = reifyTop . desugar
-
diff --git a/src/Language/Syntactic/Constructs/Binding/Optimize.hs b/src/Language/Syntactic/Constructs/Binding/Optimize.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Binding/Optimize.hs
+++ /dev/null
@@ -1,145 +0,0 @@
--- | Basic optimization
-module Language.Syntactic.Constructs.Binding.Optimize where
-
--- TODO This module should live somewhere else.
-
-
-
-import Control.Monad.Writer
-import Data.Set as Set
-import Data.Typeable
-
-import Language.Syntactic
-import Language.Syntactic.Constructs.Binding
-import Language.Syntactic.Constructs.Binding.HigherOrder
-import Language.Syntactic.Constructs.Condition
-import Language.Syntactic.Constructs.Construct
-import Language.Syntactic.Constructs.Identity
-import Language.Syntactic.Constructs.Literal
-import Language.Syntactic.Constructs.Tuple
-
-
-
--- | Constant folder
---
--- Given an expression and the statically known value of that expression,
--- returns a (possibly) new expression with the same meaning as the original.
--- Typically, the result will be a 'Literal', if the relevant type constraints
--- are satisfied.
-type ConstFolder dom = forall a . ASTF dom a -> a -> ASTF dom a
-
--- | Basic optimization
-class Optimize sym
-  where
-    -- | Bottom-up optimization of an expression. The optimization performed is
-    -- up to each instance, but the intention is to provide a sensible set of
-    -- \"always-appropriate\" optimizations. The default implementation
-    -- 'optimizeSymDefault' does only constant folding. This constant folding
-    -- uses the set of free variables to know when it's static evaluation is
-    -- possible. Thus it is possible to help constant folding of other
-    -- constructs by pruning away parts of the syntax tree that are known not to
-    -- be needed. For example, by replacing (using ordinary Haskell as an
-    -- example)
-    --
-    -- > if True then a else b
-    --
-    -- with @a@, we don't need to report the free variables in @b@. This, in
-    -- turn, can lead to more constant folding higher up in the expression.
-    optimizeSym
-        :: Optimize' dom
-        => ConstFolder dom
-        -> (sym sig -> AST dom sig)
-        -> sym sig
-        -> Args (AST dom) sig
-        -> Writer (Set VarId) (ASTF dom (DenResult sig))
-
-  -- The reason for having @dom@ as a class parameter is that many instances
-  -- need to put additional constraints on @dom@.
-
-type Optimize' dom =
-    ( Optimize dom
-    , EvalBind dom
-    , AlphaEq dom dom dom [(VarId,VarId)]
-    , ConstrainedBy dom Typeable
-    )
-
-instance (Optimize sub1, Optimize sub2) => Optimize (sub1 :+: sub2)
-  where
-    optimizeSym constFold injecter (InjL a) = optimizeSym constFold (injecter . InjL) a
-    optimizeSym constFold injecter (InjR a) = optimizeSym constFold (injecter . InjR) a
-
-optimizeM :: Optimize' dom
-    => ConstFolder dom
-    -> ASTF dom a
-    -> Writer (Set VarId) (ASTF dom a)
-optimizeM constFold = matchTrans (optimizeSym constFold Sym)
-
--- | Optimize an expression
-optimize :: Optimize' dom => ConstFolder dom -> ASTF dom a -> ASTF dom a
-optimize constFold = fst . runWriter . optimizeM constFold
-
--- | Convenient default implementation of 'optimizeSym' (uses 'evalBind' to
--- partially evaluate)
-optimizeSymDefault :: Optimize' dom
-    => ConstFolder dom
-    -> (sym sig -> AST dom sig)
-    -> sym sig
-    -> Args (AST dom) sig
-    -> Writer (Set VarId) (ASTF dom (DenResult sig))
-optimizeSymDefault constFold injecter sym args = do
-    (args',vars) <- listen $ mapArgsM (optimizeM constFold) args
-    let result = appArgs (injecter sym) args'
-        value  = evalBind result
-    if Set.null vars
-      then return $ constFold result value
-      else return result
-
-instance Optimize dom => Optimize (dom :| p)
-  where
-    optimizeSym cf i (C s) args = optimizeSym cf (i . C) s args
-
-instance Optimize dom => Optimize (dom :|| p)
-  where
-    optimizeSym cf i (C' s) args = optimizeSym cf (i . C') s args
-
-instance Optimize Empty
-  where
-    optimizeSym = error "Not implemented: optimizeSym for Empty"
-
-instance Optimize dom => Optimize (SubConstr1 c dom p)
-  where
-    optimizeSym cf i (SubConstr1 s) args = optimizeSym cf (i . SubConstr1) s args
-
-instance Optimize dom => Optimize (SubConstr2 c dom pa pb)
-  where
-    optimizeSym cf i (SubConstr2 s) args = optimizeSym cf (i . SubConstr2) s args
-
-instance Optimize Identity  where optimizeSym = optimizeSymDefault
-instance Optimize Construct where optimizeSym = optimizeSymDefault
-instance Optimize Literal   where optimizeSym = optimizeSymDefault
-instance Optimize Tuple     where optimizeSym = optimizeSymDefault
-instance Optimize Select    where optimizeSym = optimizeSymDefault
-instance Optimize Let       where optimizeSym = optimizeSymDefault
-
-instance Optimize Condition
-  where
-    optimizeSym constFold injecter cond@Condition args@(c :* t :* e :* Nil)
-        | Set.null cVars = optimizeM constFold t_or_e
-        | alphaEq t e    = optimizeM constFold t
-        | otherwise      = optimizeSymDefault constFold injecter cond args
-      where
-        (c',cVars) = runWriter $ optimizeM constFold c
-        t_or_e     = if evalBind c' then t else e
-
-instance Optimize Variable
-  where
-    optimizeSym _ injecter var@(Variable v) Nil = do
-        tell (singleton v)
-        return (injecter var)
-
-instance Optimize Lambda
-  where
-    optimizeSym constFold injecter lam@(Lambda v) (body :* Nil) = do
-        body' <- censor (delete v) $ optimizeM constFold body
-        return $ injecter lam :$ body'
-
diff --git a/src/Language/Syntactic/Constructs/Condition.hs b/src/Language/Syntactic/Constructs/Condition.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Condition.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
--- | Conditional expressions
-
-module Language.Syntactic.Constructs.Condition where
-
-
-
-import Language.Syntactic
-
-
-
-data Condition sig
-  where
-    Condition :: Condition (Bool :-> a :-> a :-> Full a)
-
-instance Constrained Condition
-  where
-    type Sat Condition = Top
-    exprDict _ = Dict
-
-instance Semantic Condition
-  where
-    semantics Condition = Sem "condition" (\c t e -> if c then t else e)
-
-semanticInstances ''Condition
-
diff --git a/src/Language/Syntactic/Constructs/Construct.hs b/src/Language/Syntactic/Constructs/Construct.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Construct.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
--- | Provides a simple way to make syntactic constructs for prototyping. Note
--- that 'Construct' is quite unsafe as it only uses 'String' to distinguish
--- between different constructs. Also, 'Construct' has a very free type that
--- allows any number of arguments.
-
-module Language.Syntactic.Constructs.Construct where
-
-
-
-import Language.Syntactic
-
-
-
-data Construct sig
-  where
-    Construct :: String -> Denotation sig -> Construct sig
-
-instance Constrained Construct
-  where
-    type Sat Construct = Top
-    exprDict _ = Dict
-
-instance Semantic Construct
-  where
-    semantics (Construct name den) = Sem name den
-
-semanticInstances ''Construct
-
diff --git a/src/Language/Syntactic/Constructs/Decoration.hs b/src/Language/Syntactic/Constructs/Decoration.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Decoration.hs
+++ /dev/null
@@ -1,120 +0,0 @@
--- | Construct for decorating expressions with additional information
-
-module Language.Syntactic.Constructs.Decoration where
-
-
-
-import Data.Tree (Tree (..))
-
-import Data.Tree.View
-
-import Language.Syntactic
-
-
-
---------------------------------------------------------------------------------
--- * Decoration
---------------------------------------------------------------------------------
-
--- | Decorating symbols with additional information
---
--- One usage of 'Decor' is to decorate every node of a syntax tree. This is done
--- simply by changing
---
--- > AST dom sig
---
--- to
---
--- > AST (Decor info dom) sig
-data Decor info expr sig
-  where
-    Decor
-        :: { decorInfo :: info (DenResult sig)
-           , decorExpr :: expr sig
-           }
-        -> Decor info expr sig
-
-instance Constrained expr => Constrained (Decor info expr)
-  where
-    type Sat (Decor info expr) = Sat expr
-    exprDict (Decor _ a) = exprDict a
-
-instance Project sub sup => Project sub (Decor info sup)
-  where
-    prj = prj . decorExpr
-
-instance Equality expr => Equality (Decor info expr)
-  where
-    equal a b = decorExpr a `equal` decorExpr b
-    exprHash  = exprHash . decorExpr
-
-instance Render expr => Render (Decor info expr)
-  where
-    renderSym = renderSym . decorExpr
-    renderArgs args = renderArgs args . decorExpr
-
-instance StringTree expr => StringTree (Decor info expr)
-  where
-    stringTreeSym args = stringTreeSym args . decorExpr
-
-instance Eval expr => Eval (Decor info expr)
-  where
-    evaluate = evaluate . decorExpr
-
-
-
--- | Get the decoration of the top-level node
-getInfo :: AST (Decor info dom) sig -> info (DenResult sig)
-getInfo (Sym (Decor info _)) = info
-getInfo (f :$ _)             = getInfo f
-
--- | Update the decoration of the top-level node
-updateDecor :: forall info dom a .
-    (info a -> info a) -> ASTF (Decor info dom) a -> ASTF (Decor info dom) a
-updateDecor f = match update
-  where
-    update
-        :: (a ~ DenResult sig)
-        => Decor info dom sig
-        -> Args (AST (Decor info dom)) sig
-        -> ASTF (Decor info dom) a
-    update (Decor info a) args = appArgs (Sym sym) args
-      where
-        sym = Decor (f info) a
-
--- | Lift a function that operates on expressions with associated information to
--- operate on an 'Decor' expression. This function is convenient to use together
--- with e.g. 'queryNodeSimple' when the domain has the form
--- @(`Decor` info dom)@.
-liftDecor :: (expr s -> info (DenResult s) -> b) -> (Decor info expr s -> b)
-liftDecor f (Decor info a) = f a info
-
--- | Collect the decorations of all nodes
-collectInfo :: (forall sig . info sig -> b) -> AST (Decor info dom) sig -> [b]
-collectInfo coll (Sym (Decor info _)) = [coll info]
-collectInfo coll (f :$ a) = collectInfo coll f ++ collectInfo coll a
-
--- | Rendering of decorated syntax trees
-stringTreeDecor :: forall info dom a . (StringTree dom) =>
-    (forall a. info a -> String) -> ASTF (Decor info dom) a -> Tree String
-stringTreeDecor showInfo a = mkTree [] a
-  where
-    mkTree :: [Tree String] -> AST (Decor info dom) sig -> Tree String
-    mkTree args (Sym (Decor info expr)) = Node infoStr [stringTreeSym args expr]
-      where
-        infoStr = "<<" ++ showInfo info ++ ">>"
-    mkTree args (f :$ a) = mkTree (mkTree [] a : args) f
-
--- | Show an decorated syntax tree using ASCII art
-showDecorWith :: StringTree dom => (forall a. info a -> String) -> ASTF (Decor info dom) a -> String
-showDecorWith showInfo = showTree . stringTreeDecor showInfo
-
--- | Print an decorated syntax tree using ASCII art
-drawDecorWith :: StringTree dom => (forall a. info a -> String) -> ASTF (Decor info dom) a -> IO ()
-drawDecorWith showInfo = putStrLn . showDecorWith showInfo
-
--- | Strip decorations from an 'AST'
-stripDecor :: AST (Decor info dom) sig -> AST dom sig
-stripDecor (Sym (Decor _ a)) = Sym a
-stripDecor (f :$ a)          = stripDecor f :$ stripDecor a
-
diff --git a/src/Language/Syntactic/Constructs/Identity.hs b/src/Language/Syntactic/Constructs/Identity.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Identity.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
--- | Identity function
-
-module Language.Syntactic.Constructs.Identity where
-
-
-
-import Language.Syntactic
-
-
-
--- | Identity function
-data Identity sig
-  where
-    Id :: Identity (a :-> Full a)
-
-instance Constrained Identity
-  where
-    type Sat Identity = Top
-    exprDict _ = Dict
-
-instance Semantic Identity
-  where
-    semantics Id = Sem "id" id
-
-semanticInstances ''Identity
-
diff --git a/src/Language/Syntactic/Constructs/Literal.hs b/src/Language/Syntactic/Constructs/Literal.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Literal.hs
+++ /dev/null
@@ -1,41 +0,0 @@
--- | Literal expressions
-
-module Language.Syntactic.Constructs.Literal where
-
-
-
-import Data.Typeable
-
-import Data.Hash
-
-import Language.Syntactic
-
-
-
-data Literal sig
-  where
-    Literal :: (Eq a, Show a, Typeable a) => a -> Literal (Full a)
-
-instance Constrained Literal
-  where
-    type Sat Literal = Eq :/\: Show :/\: Typeable :/\: Top
-    exprDict (Literal _) = Dict
-
-instance Equality Literal
-  where
-    Literal a `equal` Literal b = case cast a of
-        Just a' -> a'==b
-        Nothing -> False
-
-    exprHash (Literal a) = hash (show a)
-
-instance Render Literal
-  where
-    renderSym (Literal a) = show a
-
-instance StringTree Literal
-
-instance Eval Literal
-  where
-    evaluate (Literal a) = a
-
diff --git a/src/Language/Syntactic/Constructs/Monad.hs b/src/Language/Syntactic/Constructs/Monad.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Monad.hs
+++ /dev/null
@@ -1,45 +0,0 @@
--- | Monadic constructs
---
--- This module is based on the paper
--- /Generic Monadic Constructs for Embedded Languages/ (Persson et al., IFL 2011
--- <http://www.cse.chalmers.se/~emax/documents/persson2011generic.pdf>).
-
-module Language.Syntactic.Constructs.Monad where
-
-
-
-import Control.Monad
-
-import Language.Syntactic
-
-
-
-data MONAD m sig
-  where
-    Return :: MONAD m (a    :-> Full (m a))
-    Bind   :: MONAD m (m a  :-> (a -> m b) :-> Full (m b))
-    Then   :: MONAD m (m a  :-> m b        :-> Full (m b))
-    When   :: MONAD m (Bool :-> m ()       :-> Full (m ()))
-
-instance Constrained (MONAD m)
-  where
-    type Sat (MONAD m) = Top
-    exprDict _ = Dict
-
-instance Monad m => Semantic (MONAD m)
-  where
-    semantics Return = Sem "return" return
-    semantics Bind   = Sem "bind"   (>>=)
-    semantics Then   = Sem "then"   (>>)
-    semantics When   = Sem "when"   when
-
-instance Monad m => Equality   (MONAD m) where equal      = equalDefault; exprHash = exprHashDefault
-instance Monad m => Render     (MONAD m) where renderSym  = renderSymDefault
-                                               renderArgs = renderArgsDefault
-instance Monad m => Eval       (MONAD m) where evaluate   = evaluateDefault
-instance Monad m => StringTree (MONAD m)
-
--- | Projection with explicit monad type
-prjMonad :: Project (MONAD m) sup => P m -> sup sig -> Maybe (MONAD m sig)
-prjMonad _ = prj
-
diff --git a/src/Language/Syntactic/Constructs/Tuple.hs b/src/Language/Syntactic/Constructs/Tuple.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Constructs/Tuple.hs
+++ /dev/null
@@ -1,135 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
--- | Construction and elimination of tuples in the object language
-
-module Language.Syntactic.Constructs.Tuple where
-
-
-
-import Data.Tuple.Select
-
-import Language.Syntactic
-
-
-
---------------------------------------------------------------------------------
--- * Construction
---------------------------------------------------------------------------------
-
--- | Expressions for constructing tuples
-data Tuple sig
-  where
-    Tup2 :: Tuple (a :-> b :-> Full (a,b))
-    Tup3 :: Tuple (a :-> b :-> c :-> Full (a,b,c))
-    Tup4 :: Tuple (a :-> b :-> c :-> d :-> Full (a,b,c,d))
-    Tup5 :: Tuple (a :-> b :-> c :-> d :-> e :-> Full (a,b,c,d,e))
-    Tup6 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> Full (a,b,c,d,e,f))
-    Tup7 :: Tuple (a :-> b :-> c :-> d :-> e :-> f :-> g :-> Full (a,b,c,d,e,f,g))
-
-instance Constrained Tuple
-  where
-    type Sat Tuple = Top
-    exprDict _ = Dict
-
-instance Semantic Tuple
-  where
-    semantics Tup2 = Sem "tup2" (,)
-    semantics Tup3 = Sem "tup3" (,,)
-    semantics Tup4 = Sem "tup4" (,,,)
-    semantics Tup5 = Sem "tup5" (,,,,)
-    semantics Tup6 = Sem "tup6" (,,,,,)
-    semantics Tup7 = Sem "tup7" (,,,,,,)
-
-semanticInstances ''Tuple
-
-
-
---------------------------------------------------------------------------------
--- * Projection
---------------------------------------------------------------------------------
-
--- | These families ('Sel1'' - 'Sel7'') are needed because of the problem
--- described in:
---
--- <http://emil-fp.blogspot.com/2011/08/fundeps-weaker-than-type-families.html>
-type family Sel1' a
-type instance Sel1' (a,b)           = a
-type instance Sel1' (a,b,c)         = a
-type instance Sel1' (a,b,c,d)       = a
-type instance Sel1' (a,b,c,d,e)     = a
-type instance Sel1' (a,b,c,d,e,f)   = a
-type instance Sel1' (a,b,c,d,e,f,g) = a
-
-type family Sel2' a
-type instance Sel2' (a,b)           = b
-type instance Sel2' (a,b,c)         = b
-type instance Sel2' (a,b,c,d)       = b
-type instance Sel2' (a,b,c,d,e)     = b
-type instance Sel2' (a,b,c,d,e,f)   = b
-type instance Sel2' (a,b,c,d,e,f,g) = b
-
-type family Sel3' a
-type instance Sel3' (a,b,c)         = c
-type instance Sel3' (a,b,c,d)       = c
-type instance Sel3' (a,b,c,d,e)     = c
-type instance Sel3' (a,b,c,d,e,f)   = c
-type instance Sel3' (a,b,c,d,e,f,g) = c
-
-type family Sel4' a
-type instance Sel4' (a,b,c,d)       = d
-type instance Sel4' (a,b,c,d,e)     = d
-type instance Sel4' (a,b,c,d,e,f)   = d
-type instance Sel4' (a,b,c,d,e,f,g) = d
-
-type family Sel5' a
-type instance Sel5' (a,b,c,d,e)     = e
-type instance Sel5' (a,b,c,d,e,f)   = e
-type instance Sel5' (a,b,c,d,e,f,g) = e
-
-type family Sel6' a
-type instance Sel6' (a,b,c,d,e,f)   = f
-type instance Sel6' (a,b,c,d,e,f,g) = f
-
-type family Sel7' a
-type instance Sel7' (a,b,c,d,e,f,g) = g
-
--- | Expressions for selecting elements of a tuple
-data Select a
-  where
-    Sel1 :: (Sel1 a b, Sel1' a ~ b) => Select (a :-> Full b)
-    Sel2 :: (Sel2 a b, Sel2' a ~ b) => Select (a :-> Full b)
-    Sel3 :: (Sel3 a b, Sel3' a ~ b) => Select (a :-> Full b)
-    Sel4 :: (Sel4 a b, Sel4' a ~ b) => Select (a :-> Full b)
-    Sel5 :: (Sel5 a b, Sel5' a ~ b) => Select (a :-> Full b)
-    Sel6 :: (Sel6 a b, Sel6' a ~ b) => Select (a :-> Full b)
-    Sel7 :: (Sel7 a b, Sel7' a ~ b) => Select (a :-> Full b)
-
-instance Constrained Select
-  where
-    type Sat Select = Top
-    exprDict _ = Dict
-
-instance Semantic Select
-  where
-    semantics Sel1 = Sem "sel1" sel1
-    semantics Sel2 = Sem "sel2" sel2
-    semantics Sel3 = Sem "sel3" sel3
-    semantics Sel4 = Sem "sel4" sel4
-    semantics Sel5 = Sem "sel5" sel5
-    semantics Sel6 = Sem "sel6" sel6
-    semantics Sel7 = Sem "sel7" sel7
-
-semanticInstances ''Select
-
--- | Return the selected position, e.g.
---
--- > selectPos (Sel3 poly :: Select Poly ((Int,Int,Int,Int) :-> Full Int)) = 3
-selectPos :: Select a -> Int
-selectPos Sel1 = 1
-selectPos Sel2 = 2
-selectPos Sel3 = 3
-selectPos Sel4 = 4
-selectPos Sel5 = 5
-selectPos Sel6 = 6
-selectPos Sel7 = 7
-
diff --git a/src/Language/Syntactic/Decoration.hs b/src/Language/Syntactic/Decoration.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Decoration.hs
@@ -0,0 +1,182 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef MIN_VERSION_GLASGOW_HASKELL
+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0
+#endif
+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10
+
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
+#else
+{-# LANGUAGE OverlappingInstances #-}
+#endif
+
+-- | Construct for decorating symbols or expressions with additional information
+
+module Language.Syntactic.Decoration where
+
+
+
+import Data.Tree (Tree (..))
+
+import Data.Tree.View
+
+import Language.Syntactic.Syntax
+import Language.Syntactic.Traversal
+import Language.Syntactic.Interpretation
+import Language.Syntactic.Sugar
+
+
+
+-- | Decorating symbols or expressions with additional information
+--
+-- One usage of ':&:' is to decorate every node of a syntax tree. This is done
+-- simply by changing
+--
+-- > AST sym sig
+--
+-- to
+--
+-- > AST (sym :&: info) sig
+data (expr :&: info) sig
+  where
+    (:&:)
+        :: { decorExpr :: expr sig
+           , decorInfo :: info (DenResult sig)
+           }
+        -> (expr :&: info) sig
+
+instance Symbol sym => Symbol (sym :&: info)
+  where
+    symSig = symSig . decorExpr
+
+instance (NFData1 sym, NFData1 info) => NFData1 (sym :&: info)
+  where
+    rnf1 (s :&: i) = rnf1 s `seq` rnf1 i `seq` ()
+
+instance Project sub sup => Project sub (sup :&: info)
+  where
+    prj = prj . decorExpr
+
+instance Equality expr => Equality (expr :&: info)
+  where
+    equal a b = decorExpr a `equal` decorExpr b
+    hash      = hash . decorExpr
+
+instance Render expr => Render (expr :&: info)
+  where
+    renderSym       = renderSym . decorExpr
+    renderArgs args = renderArgs args . decorExpr
+
+instance StringTree expr => StringTree (expr :&: info)
+  where
+    stringTreeSym args = stringTreeSym args . decorExpr
+
+
+
+-- | Map over a decoration
+mapDecor
+    :: (sym1 sig -> sym2 sig)
+    -> (info1 (DenResult sig) -> info2 (DenResult sig))
+    -> ((sym1 :&: info1) sig -> (sym2 :&: info2) sig)
+mapDecor fs fi (s :&: i) = fs s :&: fi i
+
+-- | Get the decoration of the top-level node
+getDecor :: AST (sym :&: info) sig -> info (DenResult sig)
+getDecor (Sym (_ :&: info)) = info
+getDecor (f :$ _)           = getDecor f
+
+-- | Update the decoration of the top-level node
+updateDecor :: forall info sym a .
+    (info a -> info a) -> ASTF (sym :&: info) a -> ASTF (sym :&: info) a
+updateDecor f = match update
+  where
+    update
+        :: (a ~ DenResult sig)
+        => (sym :&: info) sig
+        -> Args (AST (sym :&: info)) sig
+        -> ASTF (sym :&: info) a
+    update (a :&: info) args = appArgs (Sym sym) args
+      where
+        sym = a :&: (f info)
+
+-- | Lift a function that operates on expressions with associated information to
+-- operate on a ':&:' expression. This function is convenient to use together
+-- with e.g. 'queryNodeSimple' when the domain has the form @(sym `:&:` info)@.
+liftDecor :: (expr s -> info (DenResult s) -> b) -> ((expr :&: info) s -> b)
+liftDecor f (a :&: info) = f a info
+
+-- | Strip decorations from an 'AST'
+stripDecor :: AST (sym :&: info) sig -> AST sym sig
+stripDecor (Sym (a :&: _)) = Sym a
+stripDecor (f :$ a)        = stripDecor f :$ stripDecor a
+
+-- | Rendering of decorated syntax trees
+stringTreeDecor :: forall info sym a . StringTree sym =>
+    (forall a . info a -> String) -> ASTF (sym :&: info) a -> Tree String
+stringTreeDecor showInfo a = mkTree [] a
+  where
+    mkTree :: [Tree String] -> AST (sym :&: info) sig -> Tree String
+    mkTree args (Sym (expr :&: info)) = Node infoStr [stringTreeSym args expr]
+      where
+        infoStr = "<<" ++ showInfo info ++ ">>"
+    mkTree args (f :$ a) = mkTree (mkTree [] a : args) f
+
+-- | Show an decorated syntax tree using ASCII art
+showDecorWith :: StringTree sym => (forall a . info a -> String) -> ASTF (sym :&: info) a -> String
+showDecorWith showInfo = showTree . stringTreeDecor showInfo
+
+-- | Print an decorated syntax tree using ASCII art
+drawDecorWith :: StringTree sym => (forall a . info a -> String) -> ASTF (sym :&: info) a -> IO ()
+drawDecorWith showInfo = putStrLn . showDecorWith showInfo
+
+writeHtmlDecorWith :: forall info sym a. (StringTree sym)
+                   => (forall b. info b -> String) -> FilePath -> ASTF (sym :&: info) a -> IO ()
+writeHtmlDecorWith showInfo file a = writeHtmlTree Nothing file $ mkTree [] a
+  where
+    mkTree :: [Tree NodeInfo] -> AST (sym :&: info) sig -> Tree NodeInfo
+    mkTree args (f :$ a) = mkTree (mkTree [] a : args) f
+    mkTree args (Sym (expr :&: info)) =
+      Node (NodeInfo InitiallyExpanded (renderSym expr) (showInfo info)) args
+
+-- | Make a smart constructor of a symbol. 'smartSymDecor' has any type of the
+-- form:
+--
+-- > smartSymDecor :: (sub :<: AST (sup :&: info))
+-- >     => info x
+-- >     -> sub (a :-> b :-> ... :-> Full x)
+-- >     -> (ASTF sup a -> ASTF sup b -> ... -> ASTF sup x)
+smartSymDecor
+    :: ( Signature sig
+       , f              ~ SmartFun (sup :&: info) sig
+       , sig            ~ SmartSig f
+       , (sup :&: info) ~ SmartSym f
+       , sub :<: sup
+       )
+    => info (DenResult sig) -> sub sig -> f
+smartSymDecor d = smartSym' . (:&: d) . inj
+
+-- | \"Sugared\" symbol application
+--
+-- 'sugarSymDecor' has any type of the form:
+--
+-- > sugarSymDecor ::
+-- >     ( sub :<: AST (sup :&: info)
+-- >     , Syntactic a
+-- >     , Syntactic b
+-- >     , ...
+-- >     , Syntactic x
+-- >     , Domain a ~ Domain b ~ ... ~ Domain x
+-- >     ) => info (Internal x)
+-- >       -> sub (Internal a :-> Internal b :-> ... :-> Full (Internal x))
+-- >       -> (a -> b -> ... -> x)
+sugarSymDecor
+    :: ( Signature sig
+       , fi             ~ SmartFun (sup :&: info) sig
+       , sig            ~ SmartSig fi
+       , (sup :&: info) ~ SmartSym fi
+       , SyntacticN f fi
+       , sub :<: sup
+       )
+    => info (DenResult sig) -> sub sig -> f
+sugarSymDecor i = sugarN . smartSymDecor i
+
diff --git a/src/Language/Syntactic/Frontend/Monad.hs b/src/Language/Syntactic/Frontend/Monad.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Frontend/Monad.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- | Monadic constructs
---
--- This module is based on the paper
--- /Generic Monadic Constructs for Embedded Languages/ (Persson et al., IFL 2011
--- <http://www.cse.chalmers.se/~emax/documents/persson2011generic.pdf>).
-
-module Language.Syntactic.Frontend.Monad where
-
-
-
-import Control.Applicative
-import Control.Monad.Cont
-import Data.Typeable
-
-import Language.Syntactic
-import Language.Syntactic.Constructs.Binding.HigherOrder
-import Language.Syntactic.Constructs.Monad
-
-
-
--- TODO Unfortunately, this module hard-codes the use of `Typeable`. The problem is this: Say we
---      replace `Typeable` in the definition of `Mon` by a parameter `p`. Then `sugarMonad` will get
---      a constraint `p (a -> m r)`. But `r` existentially quantified and can only be constrained in
---      the definition of `Mon`. With `Typeable` this works because
---      `(Typeable1 m, Typeable a, Typeable r)` implies `Typeable (a -> m r)`.
-
--- | User interface to embedded monadic programs
-newtype Mon dom m a
-  where
-    Mon
-        :: { unMon
-              :: forall r . (Monad m, Typeable r, InjectC (MONAD m) dom (m r))
-              => Cont (ASTF dom (m r)) a
-           }
-        -> Mon dom m a
-
-deriving instance Functor (Mon dom m)
-
-instance (Monad m) => Monad (Mon dom m)
-  where
-    return a = Mon $ return a
-    ma >>= f = Mon $ unMon ma >>= unMon . f
-
-instance (Monad m, Applicative m) => Applicative (Mon dom m)
-  where
-    pure  = return
-    (<*>) = ap
-
--- | One-layer desugaring of monadic actions
-desugarMonad
-    :: ( IsHODomain dom Typeable pVar
-       , InjectC (MONAD m) dom (m a)
-       , Monad m
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
-       , Typeable m
-#else
-       , Typeable1 m
-#endif
-       , Typeable a
-       )
-    => Mon dom m (ASTF dom a) -> ASTF dom (m a)
-desugarMonad = flip runCont (sugarSymC Return) . unMon
-
--- | One-layer sugaring of monadic actions
-sugarMonad
-    :: ( IsHODomain dom Typeable pVar
-       , Monad m
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
-       , Typeable m
-#else
-       , Typeable1 m
-#endif
-       , Typeable a
-       , pVar a
-       )
-    => ASTF dom (m a) -> Mon dom m (ASTF dom a)
-sugarMonad ma = Mon $ cont $ sugarSymC Bind ma
-
-instance ( Syntactic a, Domain a ~ dom
-         , IsHODomain dom Typeable pVar
-         , InjectC (MONAD m) dom (m (Internal a))
-         , Monad m
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
-         , Typeable m
-#else
-         , Typeable1 m
-#endif
-         , Typeable (Internal a)
-         , pVar (Internal a)
-         ) =>
-           Syntactic (Mon dom m a)
-  where
-    type Domain (Mon dom m a)   = dom
-    type Internal (Mon dom m a) = m (Internal a)
-    desugar = desugarMonad . fmap desugar
-    sugar   = fmap sugar   . sugarMonad
-
diff --git a/src/Language/Syntactic/Frontend/Tuple.hs b/src/Language/Syntactic/Frontend/Tuple.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Frontend/Tuple.hs
+++ /dev/null
@@ -1,233 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-
--- | 'Syntactic' instances for Haskell tuples
-
-module Language.Syntactic.Frontend.Tuple where
-
-
-
-import Language.Syntactic
-import Language.Syntactic.Constructs.Tuple
-import Data.Tuple.Curry
-
-
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , InjectC Tuple dom
-        ( Internal a
-        , Internal b
-        )
-    , InjectC Select dom (Internal a)
-    , InjectC Select dom (Internal b)
-    ) =>
-      Syntactic (a,b)
-  where
-    type Domain (a,b) = Domain a
-    type Internal (a,b) =
-        ( Internal a
-        , Internal b
-        )
-
-    desugar = uncurryN $ sugarSymC Tup2
-    sugar a =
-        ( sugarSymC Sel1 a
-        , sugarSymC Sel2 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , InjectC Tuple dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        )
-    , InjectC Select dom (Internal a)
-    , InjectC Select dom (Internal b)
-    , InjectC Select dom (Internal c)
-    ) =>
-      Syntactic (a,b,c)
-  where
-    type Domain (a,b,c) = Domain a
-    type Internal (a,b,c) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        )
-
-    desugar = uncurryN $ sugarSymC Tup3
-    sugar a =
-        ( sugarSymC Sel1 a
-        , sugarSymC Sel2 a
-        , sugarSymC Sel3 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , Syntactic d, Domain d ~ dom
-    , InjectC Tuple dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        )
-    , InjectC Select dom (Internal a)
-    , InjectC Select dom (Internal b)
-    , InjectC Select dom (Internal c)
-    , InjectC Select dom (Internal d)
-    ) =>
-      Syntactic (a,b,c,d)
-  where
-    type Domain (a,b,c,d) = Domain a
-    type Internal (a,b,c,d) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        )
-
-    desugar = uncurryN $ sugarSymC Tup4
-    sugar a =
-        ( sugarSymC Sel1 a
-        , sugarSymC Sel2 a
-        , sugarSymC Sel3 a
-        , sugarSymC Sel4 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , Syntactic d, Domain d ~ dom
-    , Syntactic e, Domain e ~ dom
-    , InjectC Tuple dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        )
-    , InjectC Select dom (Internal a)
-    , InjectC Select dom (Internal b)
-    , InjectC Select dom (Internal c)
-    , InjectC Select dom (Internal d)
-    , InjectC Select dom (Internal e)
-    ) =>
-      Syntactic (a,b,c,d,e)
-  where
-    type Domain (a,b,c,d,e) = Domain a
-    type Internal (a,b,c,d,e) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        )
-
-    desugar = uncurryN $ sugarSymC Tup5
-    sugar a =
-        ( sugarSymC Sel1 a
-        , sugarSymC Sel2 a
-        , sugarSymC Sel3 a
-        , sugarSymC Sel4 a
-        , sugarSymC Sel5 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , Syntactic d, Domain d ~ dom
-    , Syntactic e, Domain e ~ dom
-    , Syntactic f, Domain f ~ dom
-    , InjectC Tuple dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        )
-    , InjectC Select dom (Internal a)
-    , InjectC Select dom (Internal b)
-    , InjectC Select dom (Internal c)
-    , InjectC Select dom (Internal d)
-    , InjectC Select dom (Internal e)
-    , InjectC Select dom (Internal f)
-    ) =>
-      Syntactic (a,b,c,d,e,f)
-  where
-    type Domain (a,b,c,d,e,f) = Domain a
-    type Internal (a,b,c,d,e,f) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        )
-
-    desugar = uncurryN $ sugarSymC Tup6
-    sugar a =
-        ( sugarSymC Sel1 a
-        , sugarSymC Sel2 a
-        , sugarSymC Sel3 a
-        , sugarSymC Sel4 a
-        , sugarSymC Sel5 a
-        , sugarSymC Sel6 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , Syntactic d, Domain d ~ dom
-    , Syntactic e, Domain e ~ dom
-    , Syntactic f, Domain f ~ dom
-    , Syntactic g, Domain g ~ dom
-    , InjectC Tuple dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        , Internal g
-        )
-    , InjectC Select dom (Internal a)
-    , InjectC Select dom (Internal b)
-    , InjectC Select dom (Internal c)
-    , InjectC Select dom (Internal d)
-    , InjectC Select dom (Internal e)
-    , InjectC Select dom (Internal f)
-    , InjectC Select dom (Internal g)
-    ) =>
-      Syntactic (a,b,c,d,e,f,g)
-  where
-    type Domain (a,b,c,d,e,f,g) = Domain a
-    type Internal (a,b,c,d,e,f,g) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        , Internal g
-        )
-
-    desugar = uncurryN $ sugarSymC Tup7
-    sugar a =
-        ( sugarSymC Sel1 a
-        , sugarSymC Sel2 a
-        , sugarSymC Sel3 a
-        , sugarSymC Sel4 a
-        , sugarSymC Sel5 a
-        , sugarSymC Sel6 a
-        , sugarSymC Sel7 a
-        )
-
diff --git a/src/Language/Syntactic/Frontend/TupleConstrained.hs b/src/Language/Syntactic/Frontend/TupleConstrained.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Frontend/TupleConstrained.hs
+++ /dev/null
@@ -1,330 +0,0 @@
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- | Constrained 'Syntactic' instances for Haskell tuples
-
-module Language.Syntactic.Frontend.TupleConstrained
-    ( TupleSat
-    ) where
-
-
-
-import Data.Constraint
-import Data.Tuple.Curry
-
-import Language.Syntactic
-import Language.Syntactic.Constructs.Tuple
-
-
-
--- | Type-level function computing the predicate attached to 'Tuple' or 'Select'
--- (whichever appears first) in a domain.
-class TupleSat (dom :: * -> *) (p :: * -> Constraint) | dom -> p
-
-instance TupleSat (Tuple :|| p) p
-instance TupleSat ((Tuple :|| p) :+: dom2) p
-
-instance TupleSat (Select :|| p) p
-instance TupleSat ((Select :|| p) :+: dom2) p
-
-instance TupleSat dom p => TupleSat (dom :| q) p
-instance TupleSat dom p => TupleSat (dom :|| q) p
-instance TupleSat dom2 p => TupleSat (dom1 :+: dom2) p
-
-
-
-sugarSymC' :: forall sym dom sig b c p
-    .  ( TupleSat dom p
-       , p (DenResult sig)
-       , InjectC (sym :|| p) (AST dom) (DenResult sig)
-       , ApplySym sig b dom
-       , SyntacticN c b
-       )
-    => sym sig -> c
-sugarSymC' s = sugarSymC (C' s :: (sym :|| p) sig)
-
-
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , TupleSat dom p
-    , p (Internal a, Internal b)
-    , p (Internal a)
-    , p (Internal b)
-    , InjectC (Tuple :|| p) dom
-        ( Internal a
-        , Internal b
-        )
-    , InjectC (Select :|| p) dom (Internal a)
-    , InjectC (Select :|| p) dom (Internal b)
-    ) =>
-      Syntactic (a,b)
-  where
-    type Domain (a,b) = Domain a
-    type Internal (a,b) =
-        ( Internal a
-        , Internal b
-        )
-
-    desugar = uncurryN $ sugarSymC' Tup2
-    sugar a =
-        ( sugarSymC' Sel1 a
-        , sugarSymC' Sel2 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , TupleSat dom p
-    , p ( Internal a
-        , Internal b
-        , Internal c
-        )
-    , p (Internal a)
-    , p (Internal b)
-    , p (Internal c)
-    , InjectC (Tuple :|| p) dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        )
-    , InjectC (Select :|| p) dom (Internal a)
-    , InjectC (Select :|| p) dom (Internal b)
-    , InjectC (Select :|| p) dom (Internal c)
-    ) =>
-      Syntactic (a,b,c)
-  where
-    type Domain (a,b,c) = Domain a
-    type Internal (a,b,c) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        )
-
-    desugar = uncurryN $ sugarSymC' Tup3
-    sugar a =
-        ( sugarSymC' Sel1 a
-        , sugarSymC' Sel2 a
-        , sugarSymC' Sel3 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , Syntactic d, Domain d ~ dom
-    , TupleSat dom p
-    , p ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        )
-    , p (Internal a)
-    , p (Internal b)
-    , p (Internal c)
-    , p (Internal d)
-    , InjectC (Tuple :|| p) dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        )
-    , InjectC (Select :|| p) dom (Internal a)
-    , InjectC (Select :|| p) dom (Internal b)
-    , InjectC (Select :|| p) dom (Internal c)
-    , InjectC (Select :|| p) dom (Internal d)
-    ) =>
-      Syntactic (a,b,c,d)
-  where
-    type Domain (a,b,c,d) = Domain a
-    type Internal (a,b,c,d) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        )
-
-    desugar = uncurryN $ sugarSymC' Tup4
-    sugar a =
-        ( sugarSymC' Sel1 a
-        , sugarSymC' Sel2 a
-        , sugarSymC' Sel3 a
-        , sugarSymC' Sel4 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , Syntactic d, Domain d ~ dom
-    , Syntactic e, Domain e ~ dom
-    , TupleSat dom p
-    , p ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        )
-    , p (Internal a)
-    , p (Internal b)
-    , p (Internal c)
-    , p (Internal d)
-    , p (Internal e)
-    , InjectC (Tuple :|| p) dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        )
-    , InjectC (Select :|| p) dom (Internal a)
-    , InjectC (Select :|| p) dom (Internal b)
-    , InjectC (Select :|| p) dom (Internal c)
-    , InjectC (Select :|| p) dom (Internal d)
-    , InjectC (Select :|| p) dom (Internal e)
-    ) =>
-      Syntactic (a,b,c,d,e)
-  where
-    type Domain (a,b,c,d,e) = Domain a
-    type Internal (a,b,c,d,e) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        )
-
-    desugar = uncurryN $ sugarSymC' Tup5
-    sugar a =
-        ( sugarSymC' Sel1 a
-        , sugarSymC' Sel2 a
-        , sugarSymC' Sel3 a
-        , sugarSymC' Sel4 a
-        , sugarSymC' Sel5 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , Syntactic d, Domain d ~ dom
-    , Syntactic e, Domain e ~ dom
-    , Syntactic f, Domain f ~ dom
-    , TupleSat dom p
-    , p ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        )
-    , p (Internal a)
-    , p (Internal b)
-    , p (Internal c)
-    , p (Internal d)
-    , p (Internal e)
-    , p (Internal f)
-    , InjectC (Tuple :|| p) dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        )
-    , InjectC (Select :|| p) dom (Internal a)
-    , InjectC (Select :|| p) dom (Internal b)
-    , InjectC (Select :|| p) dom (Internal c)
-    , InjectC (Select :|| p) dom (Internal d)
-    , InjectC (Select :|| p) dom (Internal e)
-    , InjectC (Select :|| p) dom (Internal f)
-    ) =>
-      Syntactic (a,b,c,d,e,f)
-  where
-    type Domain (a,b,c,d,e,f) = Domain a
-    type Internal (a,b,c,d,e,f) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        )
-
-    desugar = uncurryN $ sugarSymC' Tup6
-    sugar a =
-        ( sugarSymC' Sel1 a
-        , sugarSymC' Sel2 a
-        , sugarSymC' Sel3 a
-        , sugarSymC' Sel4 a
-        , sugarSymC' Sel5 a
-        , sugarSymC' Sel6 a
-        )
-
-instance
-    ( Syntactic a, Domain a ~ dom
-    , Syntactic b, Domain b ~ dom
-    , Syntactic c, Domain c ~ dom
-    , Syntactic d, Domain d ~ dom
-    , Syntactic e, Domain e ~ dom
-    , Syntactic f, Domain f ~ dom
-    , Syntactic g, Domain g ~ dom
-    , TupleSat dom p
-    , p ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        , Internal g
-        )
-    , p (Internal a)
-    , p (Internal b)
-    , p (Internal c)
-    , p (Internal d)
-    , p (Internal e)
-    , p (Internal f)
-    , p (Internal g)
-    , InjectC (Tuple :|| p) dom
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        , Internal g
-        )
-    , InjectC (Select :|| p) dom (Internal a)
-    , InjectC (Select :|| p) dom (Internal b)
-    , InjectC (Select :|| p) dom (Internal c)
-    , InjectC (Select :|| p) dom (Internal d)
-    , InjectC (Select :|| p) dom (Internal e)
-    , InjectC (Select :|| p) dom (Internal f)
-    , InjectC (Select :|| p) dom (Internal g)
-    ) =>
-      Syntactic (a,b,c,d,e,f,g)
-  where
-    type Domain (a,b,c,d,e,f,g) = Domain a
-    type Internal (a,b,c,d,e,f,g) =
-        ( Internal a
-        , Internal b
-        , Internal c
-        , Internal d
-        , Internal e
-        , Internal f
-        , Internal g
-        )
-
-    desugar = uncurryN $ sugarSymC' Tup7
-    sugar a =
-        ( sugarSymC' Sel1 a
-        , sugarSymC' Sel2 a
-        , sugarSymC' Sel3 a
-        , sugarSymC' Sel4 a
-        , sugarSymC' Sel5 a
-        , sugarSymC' Sel6 a
-        , sugarSymC' Sel7 a
-        )
-
diff --git a/src/Language/Syntactic/Functional.hs b/src/Language/Syntactic/Functional.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Functional.hs
@@ -0,0 +1,789 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#ifndef MIN_VERSION_GLASGOW_HASKELL
+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0
+#endif
+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10
+
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
+#else
+{-# LANGUAGE OverlappingInstances #-}
+#endif
+
+#if __GLASGOW_HASKELL__ < 708
+#define TYPEABLE Typeable1
+#else
+#define TYPEABLE Typeable
+#endif
+
+-- | Basics for implementing functional EDSLs
+
+module Language.Syntactic.Functional
+    ( -- * Syntactic constructs
+      Name (..)
+    , Literal (..)
+    , Construct (..)
+    , Binding (..)
+    , maxLam
+    , lam_template
+    , lam
+    , fromDeBruijn
+    , BindingT (..)
+    , maxLamT
+    , lamT_template
+    , lamT
+    , lamTyped
+    , BindingDomain (..)
+    , Let (..)
+    , MONAD (..)
+    , Remon (..)
+    , desugarMonad
+    , desugarMonadTyped
+      -- * Free and bound variables
+    , freeVars
+    , allVars
+    , renameUnique'
+    , renameUnique
+      -- * Alpha-equivalence
+    , AlphaEnv
+    , alphaEq'
+    , alphaEq
+      -- * Evaluation
+    , Denotation
+    , Eval (..)
+    , evalDen
+    , DenotationM
+    , liftDenotationM
+    , RunEnv
+    , EvalEnv (..)
+    , compileSymDefault
+    , evalOpen
+    , evalClosed
+    ) where
+
+
+
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
+#else
+import Control.Applicative
+#endif
+import Control.DeepSeq (NFData (..))
+import Control.Monad (liftM2)
+import Control.Monad.Cont
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Dynamic
+import Data.Kind (Type)
+import Data.List (genericIndex)
+import Data.Proxy
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Tree
+
+import Data.Hash (hashInt)
+
+import Language.Syntactic
+
+
+
+----------------------------------------------------------------------------------------------------
+-- * Syntactic constructs
+----------------------------------------------------------------------------------------------------
+
+-- | Literal
+data Literal sig
+  where
+    Literal :: Show a => a -> Literal (Full a)
+
+instance Symbol Literal
+  where
+    symSig (Literal _) = signature
+
+instance Render Literal
+  where
+    renderSym (Literal a) = show a
+
+instance Equality Literal
+instance StringTree Literal
+
+-- | Generic N-ary syntactic construct
+--
+-- 'Construct' gives a quick way to introduce a syntactic construct by giving its name and semantic
+-- function.
+data Construct sig
+  where
+    Construct :: Signature sig => String -> Denotation sig -> Construct sig
+  -- There is no `NFData1` instance for `Construct` because that would give rise
+  -- to a constraint `NFData (Denotation sig)`, which easily spreads to other
+  -- functions.
+
+instance Symbol Construct
+  where
+    symSig (Construct _ _) = signature
+
+instance Render Construct
+  where
+    renderSym (Construct name _) = name
+    renderArgs = renderArgsSmart
+
+instance Equality Construct
+  where
+    equal = equalDefault
+    hash  = hashDefault
+
+instance StringTree Construct
+
+-- | Variable name
+newtype Name = Name Integer
+  deriving (Eq, Ord, Num, Enum, Real, Integral, NFData)
+
+instance Show Name
+  where
+    show (Name n) = show n
+
+-- | Variables and binders
+data Binding sig
+  where
+    Var :: Name -> Binding (Full a)
+    Lam :: Name -> Binding (b :-> Full (a -> b))
+
+instance Symbol Binding
+  where
+    symSig (Var _) = signature
+    symSig (Lam _) = signature
+
+instance NFData1 Binding
+  where
+    rnf1 (Var v) = rnf v
+    rnf1 (Lam v) = rnf v
+
+-- | 'equal' does strict identifier comparison; i.e. no alpha equivalence.
+--
+-- 'hash' assigns the same hash to all variables and binders. This is a valid over-approximation
+-- that enables the following property:
+--
+-- @`alphaEq` a b ==> `hash` a == `hash` b@
+instance Equality Binding
+  where
+    equal (Var v1) (Var v2) = v1==v2
+    equal (Lam v1) (Lam v2) = v1==v2
+    equal _ _ = False
+
+    hash (Var _) = hashInt 0
+    hash (Lam _) = hashInt 0
+
+instance Render Binding
+  where
+    renderSym (Var v) = 'v' : show v
+    renderSym (Lam v) = "Lam v" ++ show v
+    renderArgs []     (Var v) = 'v' : show v
+    renderArgs [body] (Lam v) = "(\\" ++ ('v':show v) ++ " -> " ++ body ++ ")"
+
+instance StringTree Binding
+  where
+    stringTreeSym []     (Var v) = Node ('v' : show v) []
+    stringTreeSym [body] (Lam v) = Node ("Lam " ++ 'v' : show v) [body]
+
+-- | Get the highest name bound by the first 'Lam' binders at every path from the root. If the term
+-- has /ordered binders/ \[1\], 'maxLam' returns the highest name introduced in the whole term.
+--
+-- \[1\] Ordered binders means that the names of 'Lam' nodes are decreasing along every path from
+-- the root.
+maxLam :: (Project Binding s) => AST s a -> Name
+maxLam (Sym lam :$ _) | Just (Lam v) <- prj lam = v
+maxLam (s :$ a) = maxLam s `Prelude.max` maxLam a
+maxLam _ = 0
+
+-- | Higher-order interface for variable binding for domains based on 'Binding'
+--
+-- Assumptions:
+--
+--   * The body @f@ does not inspect its argument.
+--
+--   * Applying @f@ to a term with ordered binders results in a term with /ordered binders/ \[1\].
+--
+-- \[1\] Ordered binders means that the names of 'Lam' nodes are decreasing along every path from
+-- the root.
+--
+-- See \"Using Circular Programs for Higher-Order Syntax\"
+-- (ICFP 2013, <https://emilaxelsson.github.io/documents/axelsson2013using.pdf>).
+lam_template :: (Project Binding sym)
+    => (Name -> sym (Full a))
+         -- ^ Variable symbol constructor
+    -> (Name -> ASTF sym b -> ASTF sym (a -> b))
+         -- ^ Lambda constructor
+    -> (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)
+lam_template mkVar mkLam f = mkLam v body
+  where
+    body = f $ Sym $ mkVar v
+    v    = succ $ maxLam body
+
+-- | Higher-order interface for variable binding
+--
+-- This function is 'lamT_template' specialized to domains @sym@ satisfying
+-- @(`Binding` `:<:` sym)@.
+lam :: (Binding :<: sym) => (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)
+lam = lam_template (inj . Var) (\v a -> Sym (inj (Lam v)) :$ a)
+
+-- | Convert from a term with De Bruijn indexes to one with explicit names
+--
+-- In the argument term, variable 'Name's are treated as De Bruijn indexes, and lambda 'Name's are
+-- ignored. (Ideally, one should use a different type for De Bruijn terms.)
+fromDeBruijn :: (Binding :<: sym) => ASTF sym a -> ASTF sym a
+fromDeBruijn = go []
+  where
+    go :: (Binding :<: sym) => [Name] -> ASTF sym a -> (ASTF sym a)
+    go vs var           | Just (Var i) <- prj var = inj $ Var $ genericIndex vs i
+    go vs (lam :$ body) | Just (Lam _) <- prj lam = inj (Lam v) :$ body'
+      where
+        body' = go (v:vs) body
+        v     = succ $ maxLam body'
+          -- Same trick as in `lam`
+    go vs a = gmapT (go vs) a
+
+-- | Typed variables and binders
+data BindingT sig
+  where
+    VarT :: Typeable a => Name -> BindingT (Full a)
+    LamT :: Typeable a => Name -> BindingT (b :-> Full (a -> b))
+
+instance Symbol BindingT
+  where
+    symSig (VarT _) = signature
+    symSig (LamT _) = signature
+
+instance NFData1 BindingT
+  where
+    rnf1 (VarT v) = rnf v
+    rnf1 (LamT v) = rnf v
+
+-- | 'equal' does strict identifier comparison; i.e. no alpha equivalence.
+--
+-- 'hash' assigns the same hash to all variables and binders. This is a valid over-approximation
+-- that enables the following property:
+--
+-- @`alphaEq` a b ==> `hash` a == `hash` b@
+instance Equality BindingT
+  where
+    equal (VarT v1) (VarT v2) = v1==v2
+    equal (LamT v1) (LamT v2) = v1==v2
+    equal _ _ = False
+
+    hash (VarT _) = hashInt 0
+    hash (LamT _) = hashInt 0
+
+instance Render BindingT
+  where
+    renderSym (VarT v) = renderSym (Var v)
+    renderSym (LamT v) = renderSym (Lam v)
+    renderArgs args (VarT v) = renderArgs args (Var v)
+    renderArgs args (LamT v) = renderArgs args (Lam v)
+
+instance StringTree BindingT
+  where
+    stringTreeSym args (VarT v) = stringTreeSym args (Var v)
+    stringTreeSym args (LamT v) = stringTreeSym args (Lam v)
+
+-- | Get the highest name bound by the first 'LamT' binders at every path from the root. If the term
+-- has /ordered binders/ \[1\], 'maxLamT' returns the highest name introduced in the whole term.
+--
+-- \[1\] Ordered binders means that the names of 'LamT' nodes are decreasing along every path from
+-- the root.
+maxLamT :: Project BindingT sym => AST sym a -> Name
+maxLamT (Sym lam :$ _) | Just (LamT n :: BindingT (b :-> a)) <- prj lam = n
+maxLamT (s :$ a) = maxLamT s `Prelude.max` maxLamT a
+maxLamT _ = 0
+
+-- | Higher-order interface for variable binding
+--
+-- Assumptions:
+--
+--   * The body @f@ does not inspect its argument.
+--
+--   * Applying @f@ to a term with ordered binders results in a term with /ordered binders/ \[1\].
+--
+-- \[1\] Ordered binders means that the names of 'LamT' nodes are decreasing along every path from
+-- the root.
+--
+-- See \"Using Circular Programs for Higher-Order Syntax\"
+-- (ICFP 2013, <https://emilaxelsson.github.io/documents/axelsson2013using.pdf>).
+lamT_template :: Project BindingT sym
+    => (Name -> sym (Full a))
+         -- ^ Variable symbol constructor
+    -> (Name -> ASTF sym b -> ASTF sym (a -> b))
+         -- ^ Lambda constructor
+    -> (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)
+lamT_template mkVar mkLam f = mkLam v body
+  where
+    body = f $ Sym $ mkVar v
+    v    = succ $ maxLamT body
+
+-- | Higher-order interface for variable binding
+--
+-- This function is 'lamT_template' specialized to domains @sym@ satisfying
+-- @(`BindingT` `:<:` sym)@.
+lamT :: (BindingT :<: sym, Typeable a) =>
+    (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)
+lamT = lamT_template (inj . VarT) (\v a -> Sym (inj (LamT v)) :$ a)
+
+-- | Higher-order interface for variable binding
+--
+-- This function is 'lamT_template' specialized to domains @sym@ satisfying
+-- @(sym ~ `Typed` s, `BindingT` `:<:` s)@.
+lamTyped :: (sym ~ Typed s, BindingT :<: s, Typeable a, Typeable b) =>
+    (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)
+lamTyped = lamT_template
+    (Typed . inj . VarT)
+    (\v a -> Sym (Typed (inj (LamT v))) :$ a)
+
+-- | Domains that \"might\" include variables and binders
+class BindingDomain sym
+  where
+    prVar :: sym sig -> Maybe Name
+    prLam :: sym sig -> Maybe Name
+
+    -- | Rename a variable or a lambda (no effect for other symbols)
+    renameBind :: (Name -> Name) -> sym sig -> sym sig
+
+instance {-# OVERLAPPING #-}
+         (BindingDomain sym1, BindingDomain sym2) => BindingDomain (sym1 :+: sym2)
+  where
+    prVar (InjL s) = prVar s
+    prVar (InjR s) = prVar s
+    prLam (InjL s) = prLam s
+    prLam (InjR s) = prLam s
+    renameBind re (InjL s) = InjL $ renameBind re s
+    renameBind re (InjR s) = InjR $ renameBind re s
+
+instance {-# OVERLAPPING #-} BindingDomain sym => BindingDomain (Typed sym)
+  where
+    prVar (Typed s) = prVar s
+    prLam (Typed s) = prLam s
+    renameBind re (Typed s) = Typed $ renameBind re s
+
+instance {-# OVERLAPPING #-} BindingDomain sym => BindingDomain (sym :&: i)
+  where
+    prVar = prVar . decorExpr
+    prLam = prLam . decorExpr
+    renameBind re (s :&: d) = renameBind re s :&: d
+
+instance {-# OVERLAPPING #-} BindingDomain sym => BindingDomain (AST sym)
+  where
+    prVar (Sym s) = prVar s
+    prVar _       = Nothing
+    prLam (Sym s) = prLam s
+    prLam _       = Nothing
+    renameBind re (Sym s) = Sym $ renameBind re s
+
+instance {-# OVERLAPPING #-} BindingDomain Binding
+  where
+    prVar (Var v) = Just v
+    prLam (Lam v) = Just v
+    renameBind re (Var v) = Var $ re v
+    renameBind re (Lam v) = Lam $ re v
+
+instance {-# OVERLAPPING #-} BindingDomain BindingT
+  where
+    prVar (VarT v) = Just v
+    prLam (LamT v) = Just v
+    renameBind re (VarT v) = VarT $ re v
+    renameBind re (LamT v) = LamT $ re v
+
+instance {-# OVERLAPPABLE #-} BindingDomain sym
+  where
+    prVar _ = Nothing
+    prLam _ = Nothing
+    renameBind _ a = a
+  -- This instance seems to overlap all others on GHC 8.2.2. This leads to
+  -- failures in the test suite. Removing the instance and declaring one
+  -- instance per type solves the problem. Earlier and later GHC versions don't
+  -- have this problem, so I assume it's a bug in 8.2.
+
+-- | A symbol for let bindings
+--
+-- This symbol is just an application operator. The actual binding has to be
+-- done by a lambda that constructs the second argument.
+--
+-- The provided string is just a tag and has nothing to do with the name of the
+-- variable of the second argument (if that argument happens to be a lambda).
+-- However, a back end may use the tag to give a sensible name to the generated
+-- variable.
+--
+-- The string tag may be empty.
+data Let sig
+  where
+    Let :: String -> Let (a :-> (a -> b) :-> Full b)
+
+instance Symbol Let where symSig (Let _) = signature
+
+instance Render Let
+  where
+    renderSym (Let "") = "Let"
+    renderSym (Let nm) = "Let " ++ nm
+
+instance Equality Let
+  where
+    equal = equalDefault
+    hash  = hashDefault
+
+instance StringTree Let
+  where
+    stringTreeSym [a, Node lam [body]] letSym
+        | ("Lam",v) <- splitAt 3 lam = Node (renderSym letSym ++ v) [a,body]
+    stringTreeSym [a,f] letSym = Node (renderSym letSym) [a,f]
+
+-- | Monadic constructs
+--
+-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al., IFL 2011
+-- <https://emilaxelsson.github.io/documents/persson2011generic.pdf>).
+data MONAD m sig
+  where
+    Return :: MONAD m (a :-> Full (m a))
+    Bind   :: MONAD m (m a :-> (a -> m b) :-> Full (m b))
+
+instance Symbol (MONAD m)
+  where
+    symSig Return = signature
+    symSig Bind   = signature
+
+instance Render (MONAD m)
+  where
+    renderSym Return = "return"
+    renderSym Bind   = "(>>=)"
+    renderArgs = renderArgsSmart
+
+instance Equality (MONAD m)
+  where
+    equal = equalDefault
+    hash  = hashDefault
+
+instance StringTree (MONAD m)
+
+-- | Reifiable monad
+--
+-- See \"Generic Monadic Constructs for Embedded Languages\" (Persson et al.,
+-- IFL 2011 <https://emilaxelsson.github.io/documents/persson2011generic.pdf>).
+--
+-- It is advised to convert to/from 'Remon' using the 'Syntactic' instance
+-- provided in the modules "Language.Syntactic.Sugar.Monad" or
+-- "Language.Syntactic.Sugar.MonadT".
+newtype Remon sym m a
+  where
+    Remon
+        :: { unRemon :: forall r . Typeable r => Cont (ASTF sym (m r)) a }
+        -> Remon sym m a
+  deriving (Functor)
+  -- The `Typeable` constraint is a bit unfortunate. It's only needed when using
+  -- a `Typed` domain. Since this is probably the most common case I decided to
+  -- bake in `Typeable` here. A more flexible solution would be to parameterize
+  -- `Remon` on the constraint.
+
+  -- Note that `Remon` can be seen as a variant of the codensity monad:
+  -- <https://hackage.haskell.org/package/kan-extensions/docs/Control-Monad-Codensity.html>
+
+instance Applicative (Remon sym m)
+  where
+    pure a  = Remon $ pure a
+    f <*> a = Remon $ unRemon f <*> unRemon a
+
+instance Monad (Remon dom m)
+  where
+    return = pure
+    ma >>= f = Remon $ unRemon ma >>= \a -> unRemon (f a)
+
+-- | One-layer desugaring of monadic actions
+desugarMonad
+    :: ( MONAD m :<: sym
+       , Typeable a
+       , TYPEABLE m
+       )
+    => Remon sym m (ASTF sym a) -> ASTF sym (m a)
+desugarMonad (Remon m) = flip runCont (sugarSym Return) m
+
+-- | One-layer desugaring of monadic actions
+desugarMonadTyped
+    :: ( MONAD m :<: s
+       , sym ~ Typed s
+       , Typeable a
+       , TYPEABLE m
+       )
+    => Remon sym m (ASTF sym a) -> ASTF sym (m a)
+desugarMonadTyped (Remon m) = flip runCont (sugarSymTyped Return) m
+
+
+
+----------------------------------------------------------------------------------------------------
+-- * Free and bound variables
+----------------------------------------------------------------------------------------------------
+
+-- | Get the set of free variables in an expression
+freeVars :: BindingDomain sym => AST sym sig -> Set Name
+freeVars var
+    | Just v <- prVar var = Set.singleton v
+freeVars (lam :$ body)
+    | Just v <- prLam lam = Set.delete v (freeVars body)
+freeVars (s :$ a) = Set.union (freeVars s) (freeVars a)
+freeVars _ = Set.empty
+
+-- | Get the set of variables (free, bound and introduced by lambdas) in an
+-- expression
+allVars :: BindingDomain sym => AST sym sig -> Set Name
+allVars var
+    | Just v <- prVar var = Set.singleton v
+allVars (lam :$ body)
+    | Just v <- prLam lam = Set.insert v (allVars body)
+allVars (s :$ a) = Set.union (allVars s) (allVars a)
+allVars _ = Set.empty
+
+-- | Generate an infinite list of fresh names given a list of allocated names
+--
+-- The argument is assumed to be sorted and not contain an infinite number of adjacent names.
+freshVars :: [Name] -> [Name]
+freshVars as = go 0 as
+  where
+    go c [] = [c..]
+    go c (v:as)
+      | c < v     = c : go (c+1) (v:as)
+      | c == v    = go (c+1) as
+      | otherwise = go c as
+
+freshVar :: MonadState [Name] m => m Name
+freshVar = do
+    vs <- get
+    case vs of
+      v:vs' -> do
+        put vs'
+        return v
+
+-- | Rename the bound variables in a term
+--
+-- The free variables are left untouched. The bound variables are given unique
+-- names using as small names as possible. The first argument is a list of
+-- reserved names. Reserved names and names of free variables are not used when
+-- renaming bound variables.
+renameUnique' :: forall sym a . BindingDomain sym =>
+    [Name] -> ASTF sym a -> ASTF sym a
+renameUnique' vs a = flip evalState fs $ go Map.empty a
+  where
+    fs = freshVars $ Set.toAscList (freeVars a `Set.union` Set.fromList vs)
+
+    go :: Map Name Name -> AST sym sig -> State [Name] (AST sym sig)
+    go env var
+      | Just v <- prVar var = case Map.lookup v env of
+          Just w -> return $ renameBind (\_ -> w) var
+          _ -> return var  -- Free variable
+    go env (lam :$ body)
+      | Just v <- prLam lam = do
+          w     <- freshVar
+          body' <- go (Map.insert v w env) body
+          return $ renameBind (\_ -> w) lam :$ body'
+    go env (s :$ a) = liftM2 (:$) (go env s) (go env a)
+    go env s = return s
+
+-- | Rename the bound variables in a term
+--
+-- The free variables are left untouched. The bound variables are given unique
+-- names using as small names as possible. Names of free variables are not used
+-- when renaming bound variables.
+renameUnique :: BindingDomain sym => ASTF sym a -> ASTF sym a
+renameUnique = renameUnique' []
+
+
+
+----------------------------------------------------------------------------------------------------
+-- * Alpha-equivalence
+----------------------------------------------------------------------------------------------------
+
+-- | Environment used by 'alphaEq''
+type AlphaEnv = [(Name,Name)]
+
+alphaEq' :: (Equality sym, BindingDomain sym) => AlphaEnv -> ASTF sym a -> ASTF sym b -> Bool
+alphaEq' env var1 var2
+    | Just v1 <- prVar var1
+    , Just v2 <- prVar var2
+    = case (lookup v1 env, lookup v2 env') of
+        (Nothing, Nothing)   -> v1==v2  -- Free variables
+        (Just v2', Just v1') -> v1==v1' && v2==v2'
+        _                    -> False
+  where
+    env' = [(v2,v1) | (v1,v2) <- env]
+alphaEq' env (lam1 :$ body1) (lam2 :$ body2)
+    | Just v1 <- prLam lam1
+    , Just v2 <- prLam lam2
+    = alphaEq' ((v1,v2):env) body1 body2
+alphaEq' env a b = simpleMatch (alphaEq'' env b) a
+
+alphaEq'' :: (Equality sym, BindingDomain sym) =>
+    AlphaEnv -> ASTF sym b -> sym a -> Args (AST sym) a -> Bool
+alphaEq'' env b a aArgs = simpleMatch (alphaEq''' env a aArgs) b
+
+alphaEq''' :: (Equality sym, BindingDomain sym) =>
+    AlphaEnv -> sym a -> Args (AST sym) a -> sym b -> Args (AST sym) b -> Bool
+alphaEq''' env a aArgs b bArgs
+    | equal a b = alphaEqChildren env a' b'
+    | otherwise = False
+  where
+    a' = appArgs (Sym undefined) aArgs
+    b' = appArgs (Sym undefined) bArgs
+
+alphaEqChildren :: (Equality sym, BindingDomain sym) => AlphaEnv -> AST sym a -> AST sym b -> Bool
+alphaEqChildren _ (Sym _) (Sym _) = True
+alphaEqChildren env (s :$ a) (t :$ b) = alphaEqChildren env s t && alphaEq' env a b
+alphaEqChildren _ _ _ = False
+
+-- | Alpha-equivalence
+alphaEq :: (Equality sym, BindingDomain sym) => ASTF sym a -> ASTF sym b -> Bool
+alphaEq = alphaEq' []
+
+
+
+----------------------------------------------------------------------------------------------------
+-- * Evaluation
+----------------------------------------------------------------------------------------------------
+
+-- | Semantic function type of the given symbol signature
+type family   Denotation sig
+type instance Denotation (Full a)    = a
+type instance Denotation (a :-> sig) = a -> Denotation sig
+
+class Eval s
+  where
+    evalSym :: s sig -> Denotation sig
+
+instance (Eval s, Eval t) => Eval (s :+: t)
+  where
+    evalSym (InjL s) = evalSym s
+    evalSym (InjR s) = evalSym s
+
+instance Eval Empty
+  where
+    evalSym = error "evalSym: Empty"
+
+instance Eval sym => Eval (sym :&: info)
+  where
+    evalSym = evalSym . decorExpr
+
+instance Eval Literal
+  where
+    evalSym (Literal a) = a
+
+instance Eval Construct
+  where
+    evalSym (Construct _ d) = d
+
+instance Eval Let
+  where
+    evalSym (Let _) = flip ($)
+
+instance Monad m => Eval (MONAD m)
+  where
+    evalSym Return = return
+    evalSym Bind   = (>>=)
+
+-- | Evaluation
+evalDen :: Eval s => AST s sig -> Denotation sig
+evalDen = go
+  where
+    go :: Eval s => AST s sig -> Denotation sig
+    go (Sym s)  = evalSym s
+    go (s :$ a) = go s $ go a
+
+-- | Monadic denotation; mapping from a symbol signature
+--
+-- > a :-> b :-> Full c
+--
+-- to
+--
+-- > m a -> m b -> m c
+type family   DenotationM (m :: Type -> Type) sig
+type instance DenotationM m (Full a)    = m a
+type instance DenotationM m (a :-> sig) = m a -> DenotationM m sig
+
+-- | Lift a 'Denotation' to 'DenotationM'
+liftDenotationM :: forall m sig proxy1 proxy2 . Monad m =>
+    SigRep sig -> proxy1 m -> proxy2 sig -> Denotation sig -> DenotationM m sig
+liftDenotationM sig _ _ = help2 sig . help1 sig
+  where
+    help1 :: Monad m =>
+        SigRep sig' -> Denotation sig' -> Args (WrapFull m) sig' -> m (DenResult sig')
+    help1 SigFull f _ = return f
+    help1 (SigMore sig) f (WrapFull ma :* as) = do
+        a <- ma
+        help1 sig (f a) as
+
+    help2 :: SigRep sig' -> (Args (WrapFull m) sig' -> m (DenResult sig')) -> DenotationM m sig'
+    help2 SigFull f = f Nil
+    help2 (SigMore sig) f = \a -> help2 sig (\as -> f (WrapFull a :* as))
+
+-- | Runtime environment
+type RunEnv = [(Name, Dynamic)]
+  -- TODO Use a more efficient data structure?
+
+-- | Evaluation
+class EvalEnv sym env
+  where
+    compileSym :: proxy env -> sym sig -> DenotationM (Reader env) sig
+
+    default compileSym :: (Symbol sym, Eval sym) =>
+        proxy env -> sym sig -> DenotationM (Reader env) sig
+    compileSym p s = compileSymDefault (symSig s) p s
+
+-- | Simple implementation of `compileSym` from a 'Denotation'
+compileSymDefault :: forall proxy env sym sig . Eval sym =>
+    SigRep sig -> proxy env -> sym sig -> DenotationM (Reader env) sig
+compileSymDefault sig p s = liftDenotationM sig (Proxy :: Proxy (Reader env)) s (evalSym s)
+
+instance (EvalEnv sym1 env, EvalEnv sym2 env) => EvalEnv (sym1 :+: sym2) env
+  where
+    compileSym p (InjL s) = compileSym p s
+    compileSym p (InjR s) = compileSym p s
+
+instance EvalEnv Empty env
+  where
+    compileSym = error "compileSym: Empty"
+
+instance EvalEnv sym env => EvalEnv (Typed sym) env
+  where
+    compileSym p (Typed s) = compileSym p s
+
+instance EvalEnv sym env => EvalEnv (sym :&: info) env
+  where
+    compileSym p = compileSym p . decorExpr
+
+instance EvalEnv Literal env
+
+instance EvalEnv Construct env
+
+instance EvalEnv Let env
+
+instance Monad m => EvalEnv (MONAD m) env
+
+instance EvalEnv BindingT RunEnv
+  where
+    compileSym _ (VarT v) = reader $ \env ->
+        case lookup v env of
+          Nothing -> error $ "compileSym: Variable " ++ show v ++ " not in scope"
+          Just d  -> case fromDynamic d of
+            Nothing -> error "compileSym: type error"  -- TODO Print types
+            Just a -> a
+    compileSym _ (LamT v) = \body -> reader $ \env a -> runReader body ((v, toDyn a) : env)
+
+-- | \"Compile\" a term to a Haskell function
+compile :: EvalEnv sym env => proxy env -> AST sym sig -> DenotationM (Reader env) sig
+compile p (Sym s)  = compileSym p s
+compile p (s :$ a) = compile p s $ compile p a
+  -- This use of the term \"compile\" comes from \"Typing Dynamic Typing\" (Baars and Swierstra,
+  -- ICFP 2002, <http://doi.acm.org/10.1145/581478.581494>)
+
+-- | Evaluation of open terms
+evalOpen :: EvalEnv sym env => env -> ASTF sym a -> a
+evalOpen env a = runReader (compile Proxy a) env
+
+-- | Evaluation of closed terms where 'RunEnv' is used as the internal environment
+--
+-- (Note that there is no guarantee that the term is actually closed.)
+evalClosed :: EvalEnv sym RunEnv => ASTF sym a -> a
+evalClosed a = runReader (compile (Proxy :: Proxy RunEnv) a) []
diff --git a/src/Language/Syntactic/Functional/Sharing.hs b/src/Language/Syntactic/Functional/Sharing.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Functional/Sharing.hs
@@ -0,0 +1,321 @@
+-- | Simple code motion transformation performing common sub-expression
+-- elimination and variable hoisting. Note that the implementation is very
+-- inefficient.
+--
+-- The code is based on an implementation by Gergely Dévai.
+
+module Language.Syntactic.Functional.Sharing
+    ( -- * Interface
+      InjDict (..)
+    , CodeMotionInterface (..)
+    , defaultInterface
+    , defaultInterfaceDecor
+      -- * Code motion
+    , codeMotion
+    ) where
+
+
+
+import Control.Monad (liftM2, mplus)
+import Control.Monad.State
+import Data.Maybe (isNothing)
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Typeable
+
+import Data.Constraint (Dict (..))
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+
+
+
+--------------------------------------------------------------------------------
+-- * Interface
+--------------------------------------------------------------------------------
+
+-- | Interface for injecting binding constructs
+data InjDict sym a b = InjDict
+    { injVariable :: Name -> sym (Full a)
+        -- ^ Inject a variable
+    , injLambda   :: Name -> sym (b :-> Full (a -> b))
+        -- ^ Inject a lambda
+    , injLet      :: sym (a :-> (a -> b) :-> Full b)
+        -- ^ Inject a "let" symbol
+    }
+
+-- | Code motion interface
+data CodeMotionInterface sym = Interface
+    { mkInjDict   :: forall a b . ASTF sym a -> ASTF sym b -> Maybe (InjDict sym a b)
+        -- ^ Try to construct an 'InjDict'. The first argument is the expression
+        -- to be shared, and the second argument the expression in which it will
+        -- be shared. This function can be used to transfer information (e.g.
+        -- from static analysis) from the shared expression to the introduced
+        -- variable.
+    , castExprCM  :: forall a b . ASTF sym a -> ASTF sym b -> Maybe (ASTF sym b)
+        -- ^ Try to type cast an expression. The first argument is the
+        -- expression to cast. The second argument can be used to construct a
+        -- witness to support the casting. The resulting expression (if any)
+        -- should be equal to the first argument.
+    , hoistOver   :: forall c. ASTF sym c -> Bool
+        -- ^ Whether a sub-expression can be hoisted over the given expression
+    }
+
+-- | Default 'CodeMotionInterface' for domains of the form
+-- @`Typed` (... `:+:` `Binding` `:+:` ...)@.
+defaultInterface :: forall binding sym symT
+    .  ( binding :<: sym
+       , Let     :<: sym
+       , symT ~ Typed sym
+       )
+    => (forall a .   Typeable a => Name -> binding (Full a))
+         -- ^ Variable constructor (e.g. 'Var' or 'VarT')
+    -> (forall a b . Typeable a => Name -> binding (b :-> Full (a -> b)))
+         -- ^ Lambda constructor (e.g. 'Lam' or 'LamT')
+    -> (forall a b . ASTF symT a -> ASTF symT b -> Bool)
+         -- ^ Can the expression represented by the first argument be shared in
+         -- the second argument?
+    -> (forall a . ASTF symT a -> Bool)
+         -- ^ Can we hoist over this expression?
+    -> CodeMotionInterface symT
+defaultInterface var lam sharable hoistOver = Interface {..}
+  where
+    mkInjDict :: ASTF symT a -> ASTF symT b -> Maybe (InjDict symT a b)
+    mkInjDict a b | not (sharable a b) = Nothing
+    mkInjDict a b =
+        simpleMatch
+          (\(Typed _) _ -> simpleMatch
+            (\(Typed _) _ ->
+              let injVariable = Typed . inj . var
+                  injLambda   = Typed . inj . lam
+                  injLet      = Typed $ inj (Let "")
+              in  Just InjDict {..}
+            ) b
+          ) a
+
+    castExprCM = castExpr
+
+-- | Default 'CodeMotionInterface' for domains of the form
+-- @(... `:&:` info)@, where @info@ can be used to witness type casting
+defaultInterfaceDecor :: forall binding sym symI info
+    .  ( binding :<: sym
+       , Let     :<: sym
+       , symI ~ (sym :&: info)
+       )
+    => (forall a b . info a -> info b -> Maybe (Dict (a ~ b)))
+         -- ^ Construct a type equality witness
+    -> (forall a b . info a -> info b -> info (a -> b))
+         -- ^ Construct info for a function, given info for the argument and the
+         -- result
+    -> (forall a . info a -> Name -> binding (Full a))
+         -- ^ Variable constructor
+    -> (forall a b . info a -> info b -> Name -> binding (b :-> Full (a -> b)))
+         -- ^ Lambda constructor
+    -> (forall a b . ASTF symI a -> ASTF symI b -> Bool)
+         -- ^ Can the expression represented by the first argument be shared in
+         -- the second argument?
+    -> (forall a . ASTF symI a -> Bool)
+         -- ^ Can we hoist over this expression?
+    -> CodeMotionInterface symI
+defaultInterfaceDecor teq mkFunInfo var lam sharable hoistOver = Interface {..}
+  where
+    mkInjDict :: ASTF symI a -> ASTF symI b -> Maybe (InjDict symI a b)
+    mkInjDict a b | not (sharable a b) = Nothing
+    mkInjDict a b =
+        simpleMatch
+          (\(_ :&: aInfo) _ -> simpleMatch
+            (\(_ :&: bInfo) _ ->
+              let injVariable v = inj (var aInfo v) :&: aInfo
+                  injLambda   v = inj (lam aInfo bInfo v) :&: mkFunInfo aInfo bInfo
+                  injLet        = inj (Let "") :&: bInfo
+              in  Just InjDict {..}
+            ) b
+          ) a
+
+    castExprCM :: ASTF symI a -> ASTF symI b -> Maybe (ASTF symI b)
+    castExprCM a b =
+        simpleMatch
+          (\(_ :&: aInfo) _ -> simpleMatch
+            (\(_ :&: bInfo) _ -> case teq aInfo bInfo of
+              Just Dict -> Just a
+              _ -> Nothing
+            ) b
+          ) a
+
+
+
+--------------------------------------------------------------------------------
+-- * Code motion
+--------------------------------------------------------------------------------
+
+-- | Substituting a sub-expression. Assumes that the free variables of the
+-- replacing expression do not occur as binders in the whole expression (so that
+-- there is no risk of capturing).
+substitute :: forall sym a b
+    .  (Equality sym, BindingDomain sym)
+    => CodeMotionInterface sym
+    -> ASTF sym a  -- ^ Sub-expression to be replaced
+    -> ASTF sym a  -- ^ Replacing sub-expression
+    -> ASTF sym b  -- ^ Whole expression
+    -> ASTF sym b
+substitute iface x y a = subst a
+  where
+    fv = freeVars x
+
+    subst :: ASTF sym c -> ASTF sym c
+    subst a
+      | Just y' <- castExprCM iface y a, alphaEq x a = y'
+      | otherwise = subst' a
+
+    subst' :: AST sym c -> AST sym c
+    subst' a@(lam :$ body)
+      | Just v <- prLam lam
+      , Set.member v fv = a
+    subst' (s :$ a) = subst' s :$ subst a
+    subst' a = a
+
+  -- Note: Since `codeMotion` only uses `substitute` to replace sub-expressions
+  -- with fresh variables, the assumption above is fulfilled. However, the
+  -- matching in `subst` needs to be aware of free variables, which is why the
+  -- substitution stops when reaching a lambda that binds a variable that is
+  -- free in the expression to be replaced.
+
+-- | Count the number of occurrences of a sub-expression
+count :: forall sym a b
+    .  (Equality sym, BindingDomain sym)
+    => ASTF sym a  -- ^ Expression to count
+    -> ASTF sym b  -- ^ Expression to count in
+    -> Int
+count a b = cnt b
+  where
+    fv = freeVars a
+
+    cnt :: ASTF sym c -> Int
+    cnt c
+      | alphaEq a c = 1
+      | otherwise   = cnt' c
+
+    cnt' :: AST sym sig -> Int
+    cnt' (lam :$ body)
+      | Just v <- prLam lam
+      , Set.member v fv = 0
+          -- There can be no match under a lambda that binds a variable that is
+          -- free in `a`. This case needs to be handled in order to avoid false
+          -- matches.
+          --
+          -- Consider the following expression:
+          --
+          --     (\x -> f x) 0 + f x
+          --
+          -- The sub-expression `f x` appear twice, but `x` means different
+          -- things in the two cases.
+    cnt' (s :$ c) = cnt' s + cnt c
+    cnt' _        = 0
+
+-- | Environment for the expression in the 'choose' function
+data Env sym = Env
+    { inLambda :: Bool  -- ^ Whether the current expression is inside a lambda
+    , counter  :: EF (AST sym) -> Int
+        -- ^ Counting the number of occurrences of an expression in the
+        -- environment
+    , dependencies :: Set Name
+        -- ^ The set of variables that are not allowed to occur in the chosen
+        -- expression
+    }
+
+-- | Checks whether a sub-expression in a given environment can be lifted out
+liftable :: BindingDomain sym => Env sym -> ASTF sym a -> Bool
+liftable env a = independent && isNothing (prVar a) && heuristic
+      -- Lifting dependent expressions is semantically incorrect. Lifting
+      -- variables would cause `codeMotion` to loop.
+  where
+    independent = Set.null $ Set.intersection (freeVars a) (dependencies env)
+    heuristic   = inLambda env || (counter env (EF a) > 1)
+
+-- | A sub-expression chosen to be shared together with an evidence that it can
+-- actually be shared in the whole expression under consideration
+data Chosen sym a
+  where
+    Chosen :: InjDict sym b a -> ASTF sym b -> Chosen sym a
+
+-- | Choose a sub-expression to share
+choose :: forall sym a
+    .  (Equality sym, BindingDomain sym)
+    => CodeMotionInterface sym
+    -> ASTF sym a
+    -> Maybe (Chosen sym a)
+choose iface a = chooseEnvSub initEnv a
+  where
+    initEnv = Env
+        { inLambda     = False
+        , counter      = \(EF b) -> count b a
+        , dependencies = Set.empty
+        }
+
+    chooseEnv :: Env sym -> ASTF sym b -> Maybe (Chosen sym a)
+    chooseEnv env b
+        | liftable env b
+        , Just id <- mkInjDict iface b a
+        = Just $ Chosen id b
+    chooseEnv env b
+        | hoistOver iface b = chooseEnvSub env b
+        | otherwise         = Nothing
+
+    -- | Like 'chooseEnv', but does not consider the top expression for sharing
+    chooseEnvSub :: Env sym -> AST sym b -> Maybe (Chosen sym a)
+    chooseEnvSub env (Sym lam :$ b)
+        | Just v <- prLam lam
+        = chooseEnv (env' v) b
+      where
+        env' v = env
+            { inLambda     = True
+            , dependencies = Set.insert v (dependencies env)
+            }
+    chooseEnvSub env (s :$ b) = chooseEnvSub env s `mplus` chooseEnv env b
+    chooseEnvSub _ _ = Nothing
+
+-- If `codeMotionM` loops forever, the reason may be that `castExprCM` is
+-- broken. If `castExprCM` fails to cast even when it should, it means that
+-- we can get into situations where `substitute` returns the same expression
+-- unchanged. This in turn means that `codeMotionM` will loop, since it calls
+-- itself with `codeMotionM iface $ substitute iface b x a`.
+
+codeMotionM :: forall sym m a
+    .  ( Equality sym
+       , BindingDomain sym
+       , MonadState Name m
+       )
+    => CodeMotionInterface sym
+    -> ASTF sym a
+    -> m (ASTF sym a)
+codeMotionM iface a
+    | Just (Chosen id b) <- choose iface a = share id b
+    | otherwise = descend a
+  where
+    share :: InjDict sym b a -> ASTF sym b -> m (ASTF sym a)
+    share id b = do
+        b' <- codeMotionM iface b
+        v  <- get; put (v+1)
+        let x = Sym (injVariable id v)
+        body <- codeMotionM iface $ substitute iface b x a
+        return
+            $  Sym (injLet id)
+            :$ b'
+            :$ (Sym (injLambda id v) :$ body)
+
+    descend :: AST sym b -> m (AST sym b)
+    descend (s :$ a) = liftM2 (:$) (descend s) (codeMotionM iface a)
+    descend a        = return a
+
+-- | Perform common sub-expression elimination and variable hoisting
+codeMotion :: forall sym m a
+    .  ( Equality sym
+       , BindingDomain sym
+       )
+    => CodeMotionInterface sym
+    -> ASTF sym a
+    -> ASTF sym a
+codeMotion iface a = flip evalState maxVar $ codeMotionM iface a
+  where
+    maxVar = succ $ Set.findMax $ Set.insert 0 $ allVars a
+
diff --git a/src/Language/Syntactic/Functional/Tuple.hs b/src/Language/Syntactic/Functional/Tuple.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Functional/Tuple.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | Construction and elimination of tuples
+
+module Language.Syntactic.Functional.Tuple where
+
+
+
+import Language.Syntactic
+import Language.Syntactic.TH
+import Language.Syntactic.Functional
+
+
+
+data Tuple a
+  where
+    Pair :: Tuple (a :-> b :-> Full (a,b))
+    Fst  :: Tuple ((a,b) :-> Full a)
+    Snd  :: Tuple ((a,b) :-> Full b)
+
+deriveSymbol    ''Tuple
+deriveEquality  ''Tuple
+deriveRender id ''Tuple
+
+instance StringTree Tuple
+
+instance Eval Tuple
+  where
+    evalSym Pair = (,)
+    evalSym Fst  = fst
+    evalSym Snd  = snd
+
+instance EvalEnv Tuple env
+
diff --git a/src/Language/Syntactic/Functional/Tuple/TH.hs b/src/Language/Syntactic/Functional/Tuple/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Functional/Tuple/TH.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
+-- | Generate 'Syntactic' instances for tuples
+
+module Language.Syntactic.Functional.Tuple.TH
+  ( deriveSyntacticForTuples
+  ) where
+
+
+
+import Language.Haskell.TH
+
+import Data.NestTuple
+import Data.NestTuple.TH
+
+import Language.Syntactic ((:<:), Syntactic (..))
+import Language.Syntactic.TH
+
+
+
+-- Make instances of the form
+--
+-- > instance
+-- >     ( Syntactic a
+-- >     , ...
+-- >     , Syntactic x
+-- >
+-- >     , internalPred (Internal a)
+-- >     , ...
+-- >     , internalPred (Internal x)
+-- >
+-- >     , Tuple :<: sym
+-- >     , Domain a ~ mkDomain sym
+-- >
+-- >     , Domain a ~ Domain b
+-- >     , ...
+-- >     , Domain a ~ Domain x
+-- >     , extraConstraint
+-- >     ) =>
+-- >       Syntactic (a,...,x)
+-- >   where
+-- >     type Domain (a,...,x)   = Domain a
+-- >     type Internal (a,...,x) = (Internal a ... Internal x)  -- nested pairs
+-- >     desugar = desugar . nestTup  -- use pair instance
+-- >     sugar   = unnestTup . sugar  -- use pair instance
+--
+-- Instances will be generated for width 3 and upwards. The existence of an
+-- instance for pairs is assumed.
+deriveSyntacticForTuples
+    :: (Type -> Cxt)   -- ^ @internalPred@ (see above)
+    -> (Type -> Type)  -- ^ @mkDomain@ (see above)
+    -> Cxt             -- ^ @extraConstraint@ (see above)
+    -> Int             -- ^ Max tuple width
+    -> DecsQ
+deriveSyntacticForTuples internalPred mkDomain extraConstraint n = return $
+    map deriveSyntacticForTuple [3..n]
+  where
+    deriveSyntacticForTuple w = instD
+        ( concat
+            [ map (classPred ''Syntactic ConT . return) varsT
+            , concatMap internalPred $ map (AppT (ConT ''Internal)) varsT
+            , [classPred ''(:<:) ConT [ConT (mkName "Tuple"), VarT (mkName "sym")]]
+            , [eqPred domainA (mkDomain (VarT (mkName "sym")))]
+            , [eqPred domainA (AppT (ConT ''Domain) b)
+                | b <- tail varsT
+              ]
+            , extraConstraint
+            ]
+        )
+        (AppT (ConT ''Syntactic) tupT)
+        [ tySynInst ''Domain [tupT] domainA
+        , tySynInst ''Internal [tupT] tupTI
+        , FunD 'desugar
+            [ Clause
+                []
+                (NormalB (foldl AppE (VarE '(.)) $ map VarE [mkName "desugar", 'nest]))
+                []
+            ]
+        , FunD 'sugar
+            [ Clause
+                []
+                (NormalB (foldl AppE (VarE '(.)) $ map VarE ['unnest, mkName "sugar"]))
+                []
+            ]
+        ]
+      where
+        varsT   = map VarT $ take w varSupply
+        tupT    = foldl AppT (TupleT w) varsT
+        tupTI   = foldNest id mkPairT $ toNest $ map (AppT (ConT ''Internal)) varsT
+        domainA = AppT (ConT ''Domain) (VarT (mkName "a"))
+
diff --git a/src/Language/Syntactic/Functional/WellScoped.hs b/src/Language/Syntactic/Functional/WellScoped.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Functional/WellScoped.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#ifndef MIN_VERSION_GLASGOW_HASKELL
+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0
+#endif
+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10
+
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
+#else
+{-# LANGUAGE OverlappingInstances #-}
+#endif
+
+-- | Well-scoped terms
+
+module Language.Syntactic.Functional.WellScoped where
+
+
+
+import Control.Monad.Reader
+import Data.Proxy
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+
+
+
+-- | Environment extension
+class Ext ext orig
+  where
+    -- | Remove the extension of an environment
+    unext :: ext -> orig
+    -- | Return the amount by which an environment has been extended
+    diff :: Num a => Proxy ext -> Proxy orig -> a
+
+instance {-# OVERLAPS #-} Ext env env
+  where
+    unext = id
+    diff _ _ = 0
+
+instance {-# OVERLAPS #-} (Ext env e, ext ~ (a,env)) => Ext ext e
+  where
+    unext = unext . snd
+    diff m n = diff (fmap snd m) n + 1
+
+-- | Lookup in an extended environment
+lookEnv :: forall env a e . Ext env (a,e) => Proxy e -> Reader env a
+lookEnv _ = reader $ \env -> let (a, _ :: e) = unext env in a
+
+-- | Well-scoped variable binding
+--
+-- Well-scoped terms are introduced to be able to evaluate without type casting. The implementation
+-- is inspired by \"Typing Dynamic Typing\" (Baars and Swierstra, ICFP 2002,
+-- <http://doi.acm.org/10.1145/581478.581494>) where expressions are represented as (essentially)
+-- @`Reader` env a@ after \"compilation\". However, a major difference is that
+-- \"Typing Dynamic Typing\" starts from an untyped term, and thus needs (safe) dynamic type casting
+-- during compilation. In contrast, the denotational semantics of 'BindingWS' (the 'Eval' instance)
+-- uses no type casting.
+data BindingWS sig
+  where
+    VarWS :: Ext env (a,e) => Proxy e -> BindingWS (Full (Reader env a))
+    LamWS :: BindingWS (Reader (a,e) b :-> Full (Reader e (a -> b)))
+
+instance Symbol BindingWS
+  where
+    symSig (VarWS _) = signature
+    symSig LamWS     = signature
+
+instance NFData1 BindingWS
+  where
+    rnf1 (VarWS Proxy) = ()
+    rnf1 LamWS         = ()
+
+instance Eval BindingWS
+  where
+    evalSym (VarWS p) = lookEnv p
+    evalSym LamWS     = \f -> reader $ \e -> \a -> runReader f (a,e)
+
+-- | Higher-order interface for well-scoped variable binding
+--
+-- Inspired by Conor McBride's "I am not a number, I am a classy hack"
+-- (<http://mazzo.li/epilogue/index.html%3Fp=773.html>).
+lamWS :: forall a e sym b . (BindingWS :<: sym)
+    => ((forall env . (Ext env (a,e)) => ASTF sym (Reader env a)) -> ASTF sym (Reader (a,e) b))
+    -> ASTF sym (Reader e (a -> b))
+lamWS f = smartSym LamWS $ f $ smartSym (VarWS (Proxy :: Proxy e))
+
+-- | Evaluation of open well-scoped terms
+evalOpenWS :: Eval s => env -> ASTF s (Reader env a) -> a
+evalOpenWS e = ($ e) . runReader . evalDen
+
+-- | Evaluation of closed well-scoped terms
+evalClosedWS :: Eval s => ASTF s (Reader () a) -> a
+evalClosedWS = evalOpenWS ()
+
+-- | Mapping from a symbol signature
+--
+-- > a :-> b :-> Full c
+--
+-- to
+--
+-- > Reader env a :-> Reader env b :-> Full (Reader env c)
+type family   LiftReader env sig
+type instance LiftReader env (Full a)    = Full (Reader env a)
+type instance LiftReader env (a :-> sig) = Reader env a :-> LiftReader env sig
+
+type family UnReader a
+type instance UnReader (Reader e a) = a
+
+-- | Mapping from a symbol signature
+--
+-- > Reader e a :-> Reader e b :-> Full (Reader e c)
+--
+-- to
+--
+-- > a :-> b :-> Full c
+type family   LowerReader sig
+type instance LowerReader (Full a)    = Full (UnReader a)
+type instance LowerReader (a :-> sig) = UnReader a :-> LowerReader sig
+
+-- | Wrap a symbol to give it a 'LiftReader' signature
+data ReaderSym sym sig
+  where
+    ReaderSym
+        :: ( Signature sig
+           , Denotation (LiftReader env sig) ~ DenotationM (Reader env) sig
+           , LowerReader (LiftReader env sig) ~ sig
+           )
+        => Proxy env
+        -> sym sig
+        -> ReaderSym sym (LiftReader env sig)
+
+instance Eval sym => Eval (ReaderSym sym)
+  where
+    evalSym (ReaderSym (_ :: Proxy env) s) = liftDenotationM signature p s $ evalSym s
+      where
+        p = Proxy :: Proxy (Reader env)
+
+-- | Well-scoped 'AST'
+type WS sym env a = ASTF (BindingWS :+: ReaderSym sym) (Reader env a)
+
+-- | Convert the representation of variables and binders from 'BindingWS' to 'Binding'. The latter
+-- is easier to analyze, has a 'Render' instance, etc.
+fromWS :: WS sym env a -> ASTF (Binding :+: sym) a
+fromWS = fromDeBruijn . go
+  where
+    go :: AST (BindingWS :+: ReaderSym sym) sig -> AST (Binding :+: sym) (LowerReader sig)
+    go (Sym (InjL s@(VarWS p)))     = Sym (InjL (Var (diff (mkProxy2 s) (mkProxy1 s p))))
+      where
+        mkProxy1 = (\_ _ -> Proxy) :: BindingWS (Full (Reader e' a)) -> Proxy e -> Proxy (a,e)
+        mkProxy2 = (\_ -> Proxy)   :: BindingWS (Full (Reader e' a)) -> Proxy e'
+    go (Sym (InjL LamWS))           = Sym $ InjL $ Lam (-1) -- -1 since we're using De Bruijn
+    go (s :$ a)                     = go s :$ go a
+    go (Sym (InjR (ReaderSym _ s))) = Sym $ InjR s
+
+-- | Make a smart constructor for well-scoped terms. 'smartWS' has any type of the form:
+--
+-- > smartWS :: (sub :<: sup, bsym ~ (BindingWS :+: ReaderSym sup))
+-- >     => sub (a :-> b :-> ... :-> Full x)
+-- >     -> ASTF bsym (Reader env a) -> ASTF bsym (Reader env b) -> ... -> ASTF bsym (Reader env x)
+smartWS :: forall sig sig' bsym f sub sup env a
+    .  ( Signature sig
+       , Signature sig'
+       , sub :<: sup
+       , bsym ~ (BindingWS :+: ReaderSym sup)
+       , f    ~ SmartFun bsym sig'
+       , sig' ~ SmartSig f
+       , bsym ~ SmartSym f
+       , sig' ~ LiftReader env sig
+       , Denotation (LiftReader env sig) ~ DenotationM (Reader env) sig
+       , LowerReader (LiftReader env sig) ~ sig
+       , Reader env a ~ DenResult sig'
+       )
+    => sub sig -> f
+smartWS s = smartSym' $ InjR $ ReaderSym (Proxy :: Proxy env) $ inj s
+
diff --git a/src/Language/Syntactic/Interpretation.hs b/src/Language/Syntactic/Interpretation.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Interpretation.hs
@@ -0,0 +1,204 @@
+{-# LANGUAGE DefaultSignatures #-}
+
+-- | Equality and rendering of 'AST's
+
+module Language.Syntactic.Interpretation
+    ( -- * Equality
+      Equality (..)
+      -- * Rendering
+    , Render (..)
+    , renderArgsSmart
+    , render
+    , StringTree (..)
+    , stringTree
+    , showAST
+    , drawAST
+    , writeHtmlAST
+      -- * Default interpretation
+    , equalDefault
+    , hashDefault
+    ) where
+
+
+
+import Data.Tree (Tree (..))
+
+import Data.Hash (Hash, combine, hashInt)
+import qualified Data.Hash as Hash
+import Data.Tree.View
+
+import Language.Syntactic.Syntax
+
+
+
+----------------------------------------------------------------------------------------------------
+-- * Equality
+----------------------------------------------------------------------------------------------------
+
+-- | Higher-kinded equality
+class Equality e
+  where
+    -- | Higher-kinded equality
+    --
+    -- Comparing elements of different types is often needed when dealing with expressions with
+    -- existentially quantified sub-terms.
+    equal :: e a -> e b -> Bool
+    default equal :: Render e => e a -> e b -> Bool
+    equal = equalDefault
+
+    -- | Higher-kinded hashing. Elements that are equal according to 'equal' must result in the same
+    -- hash:
+    --
+    -- @equal a b  ==>  hash a == hash b@
+    hash :: e a -> Hash
+    default hash :: Render e => e a -> Hash
+    hash = hashDefault
+
+instance Equality sym => Equality (AST sym)
+  where
+    equal (Sym s1)   (Sym s2)   = equal s1 s2
+    equal (s1 :$ a1) (s2 :$ a2) = equal s1 s2 && equal a1 a2
+    equal _ _                   = False
+
+    hash (Sym s)  = hashInt 0 `combine` hash s
+    hash (s :$ a) = hashInt 1 `combine` hash s `combine` hash a
+
+instance Equality sym => Eq (AST sym a)
+  where
+    (==) = equal
+
+instance (Equality sym1, Equality sym2) => Equality (sym1 :+: sym2)
+  where
+    equal (InjL a) (InjL b) = equal a b
+    equal (InjR a) (InjR b) = equal a b
+    equal _ _               = False
+
+    hash (InjL a) = hashInt 0 `combine` hash a
+    hash (InjR a) = hashInt 1 `combine` hash a
+
+instance (Equality sym1, Equality sym2) => Eq ((sym1 :+: sym2) a)
+  where
+    (==) = equal
+
+instance Equality Empty
+  where
+    equal = error "equal: Empty"
+    hash  = error "hash: Empty"
+
+instance Equality sym => Equality (Typed sym)
+  where
+    equal (Typed s1) (Typed s2) = equal s1 s2
+    hash (Typed s) = hash s
+
+
+
+----------------------------------------------------------------------------------------------------
+-- * Rendering
+----------------------------------------------------------------------------------------------------
+
+-- | Render a symbol as concrete syntax. A complete instance must define at least the 'renderSym'
+-- method.
+class Render sym
+  where
+    -- | Show a symbol as a 'String'
+    renderSym :: sym sig -> String
+
+    -- | Render a symbol given a list of rendered arguments
+    renderArgs :: [String] -> sym sig -> String
+    renderArgs []   s = renderSym s
+    renderArgs args s = "(" ++ unwords (renderSym s : args) ++ ")"
+
+instance (Render sym1, Render sym2) => Render (sym1 :+: sym2)
+  where
+    renderSym (InjL s) = renderSym s
+    renderSym (InjR s) = renderSym s
+    renderArgs args (InjL s) = renderArgs args s
+    renderArgs args (InjR s) = renderArgs args s
+
+-- | Implementation of 'renderArgs' that handles infix operators
+renderArgsSmart :: Render sym => [String] -> sym a -> String
+renderArgsSmart [] sym = renderSym sym
+renderArgsSmart [a, b] sym
+    | '(' : name <- renderSym sym
+    , last name == ')'
+    , let op = init name
+    = "(" ++ unwords [a, op, b] ++ ")"
+renderArgsSmart args sym = "(" ++ unwords (renderSym sym : args) ++ ")"
+
+-- | Render an 'AST' as concrete syntax
+render :: forall sym a. Render sym => ASTF sym a -> String
+render = go []
+  where
+    go :: [String] -> AST sym sig -> String
+    go args (Sym s)  = renderArgs args s
+    go args (s :$ a) = go (render a : args) s
+
+instance Render Empty
+  where
+    renderSym  = error "renderSym: Empty"
+    renderArgs = error "renderArgs: Empty"
+
+instance Render sym => Render (Typed sym)
+  where
+    renderSym (Typed s)  = renderSym s
+    renderArgs args (Typed s) = renderArgs args s
+
+instance Render sym => Show (ASTF sym a)
+  where
+    show = render
+
+
+
+-- | Convert a symbol to a 'Tree' of strings
+class Render sym => StringTree sym
+  where
+    -- | Convert a symbol to a 'Tree' given a list of argument trees
+    stringTreeSym :: [Tree String] -> sym a -> Tree String
+    stringTreeSym args s = Node (renderSym s) args
+
+instance (StringTree sym1, StringTree sym2) => StringTree (sym1 :+: sym2)
+  where
+    stringTreeSym args (InjL s) = stringTreeSym args s
+    stringTreeSym args (InjR s) = stringTreeSym args s
+
+instance StringTree Empty
+
+instance StringTree sym => StringTree (Typed sym)
+  where
+    stringTreeSym args (Typed s) = stringTreeSym args s
+
+-- | Convert an 'AST' to a 'Tree' of strings
+stringTree :: forall sym a . StringTree sym => ASTF sym a -> Tree String
+stringTree = go []
+  where
+    go :: [Tree String] -> AST sym sig -> Tree String
+    go args (Sym s)  = stringTreeSym args s
+    go args (s :$ a) = go (stringTree a : args) s
+
+-- | Show a syntax tree using ASCII art
+showAST :: StringTree sym => ASTF sym a -> String
+showAST = showTree . stringTree
+
+-- | Print a syntax tree using ASCII art
+drawAST :: StringTree sym => ASTF sym a -> IO ()
+drawAST = putStrLn . showAST
+
+-- | Write a syntax tree to an HTML file with foldable nodes
+writeHtmlAST :: StringTree sym => FilePath -> ASTF sym a -> IO ()
+writeHtmlAST file
+    = writeHtmlTree Nothing file
+    . fmap (\n -> NodeInfo InitiallyExpanded n "") . stringTree
+
+
+
+----------------------------------------------------------------------------------------------------
+-- * Default interpretation
+----------------------------------------------------------------------------------------------------
+
+-- | Default implementation of 'equal'
+equalDefault :: Render sym => sym a -> sym b -> Bool
+equalDefault a b = renderSym a == renderSym b
+
+-- | Default implementation of 'hash'
+hashDefault :: Render sym => sym a -> Hash
+hashDefault = Hash.hash . renderSym
diff --git a/src/Language/Syntactic/Interpretation/Equality.hs b/src/Language/Syntactic/Interpretation/Equality.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Interpretation/Equality.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-module Language.Syntactic.Interpretation.Equality where
-
-
-
-import Data.Hash
-
-import Language.Syntactic.Syntax
-
-
-
--- | Equality for expressions
-class Equality expr
-  where
-    -- | Equality for expressions
-    --
-    -- Comparing expressions of different types is often needed when dealing
-    -- with expressions with existentially quantified sub-terms.
-    equal :: expr a -> expr b -> Bool
-
-    -- | Computes a 'Hash' for an expression. Expressions that are equal
-    -- according to 'equal' must result in the same hash:
-    --
-    -- @equal a b  ==>  exprHash a == exprHash b@
-    exprHash :: expr a -> Hash
-
-
-instance Equality dom => Equality (AST dom)
-  where
-    equal (Sym a)    (Sym b)    = equal a b
-    equal (s1 :$ a1) (s2 :$ a2) = equal s1 s2 && equal a1 a2
-    equal _ _                   = False
-
-    exprHash (Sym a)  = hashInt 0 `combine` exprHash a
-    exprHash (s :$ a) = hashInt 1 `combine` exprHash s `combine` exprHash a
-
-instance Equality dom => Eq (AST dom a)
-  where
-    (==) = equal
-
-instance (Equality expr1, Equality expr2) => Equality (expr1 :+: expr2)
-  where
-    equal (InjL a) (InjL b) = equal a b
-    equal (InjR a) (InjR b) = equal a b
-    equal _ _               = False
-
-    exprHash (InjL a) = hashInt 0 `combine` exprHash a
-    exprHash (InjR a) = hashInt 1 `combine` exprHash a
-
-instance (Equality expr1, Equality expr2) => Eq ((expr1 :+: expr2) a)
-  where
-    (==) = equal
-
diff --git a/src/Language/Syntactic/Interpretation/Evaluation.hs b/src/Language/Syntactic/Interpretation/Evaluation.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Interpretation/Evaluation.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module Language.Syntactic.Interpretation.Evaluation where
-
-
-
-import Language.Syntactic.Syntax
-
-
-
--- | The denotation of a symbol with the given signature
-type family   Denotation sig
-type instance Denotation (Full a)    = a
-type instance Denotation (a :-> sig) = a -> Denotation sig
-
-class Eval expr
-  where
-    -- | Evaluation of expressions
-    evaluate :: expr a -> Denotation a
-
-instance Eval dom => Eval (AST dom)
-  where
-    evaluate (Sym a)  = evaluate a
-    evaluate (s :$ a) = evaluate s $ evaluate a
-
-instance (Eval expr1, Eval expr2) => Eval (expr1 :+: expr2)
-  where
-    evaluate (InjL a) = evaluate a
-    evaluate (InjR a) = evaluate a
-
diff --git a/src/Language/Syntactic/Interpretation/Render.hs b/src/Language/Syntactic/Interpretation/Render.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Interpretation/Render.hs
+++ /dev/null
@@ -1,84 +0,0 @@
-module Language.Syntactic.Interpretation.Render
-    ( Render (..)
-    , render
-    , StringTree (..)
-    , stringTree
-    , showAST
-    , drawAST
-    , writeHtmlAST
-    ) where
-
-
-
-import Data.Tree (Tree (..))
-
-import Data.Tree.View
-
-import Language.Syntactic.Syntax
-
-
-
--- | Render a symbol as concrete syntax. A complete instance must define at least the 'renderSym'
--- method.
-class Render dom
-  where
-    -- | Show a symbol as a 'String'
-    renderSym :: dom sig -> String
-
-    -- | Render a symbol given a list of rendered arguments
-    renderArgs :: [String] -> dom sig -> String
-    renderArgs []   a = renderSym a
-    renderArgs args a = "(" ++ unwords (renderSym a : args) ++ ")"
-
-instance (Render expr1, Render expr2) => Render (expr1 :+: expr2)
-  where
-    renderSym (InjL a) = renderSym a
-    renderSym (InjR a) = renderSym a
-    renderArgs args (InjL a) = renderArgs args a
-    renderArgs args (InjR a) = renderArgs args a
-
--- | Render an expression as concrete syntax
-render :: forall dom a. Render dom => ASTF dom a -> String
-render = go []
-  where
-    go :: [String] -> AST dom sig -> String
-    go args (Sym a)  = renderArgs args a
-    go args (s :$ a) = go (render a : args) s
-
-instance Render dom => Show (ASTF dom a)
-  where
-    show = render
-
-
-
--- | Convert a symbol to a 'Tree' of strings
-class Render dom => StringTree dom
-  where
-    -- | Convert a symbol to a 'Tree' given a list of argument trees
-    stringTreeSym :: [Tree String] -> dom a -> Tree String
-    stringTreeSym args a = Node (renderSym a) args
-
-instance (StringTree dom1, StringTree dom2) => StringTree (dom1 :+: dom2)
-  where
-    stringTreeSym args (InjL a) = stringTreeSym args a
-    stringTreeSym args (InjR a) = stringTreeSym args a
-
--- | Convert an expression to a 'Tree' of strings
-stringTree :: forall dom a . StringTree dom => ASTF dom a -> Tree String
-stringTree = go []
-  where
-    go :: [Tree String] -> AST dom sig -> Tree String
-    go args (Sym a)  = stringTreeSym args a
-    go args (s :$ a) = go (stringTree a : args) s
-
--- | Show a syntax tree using ASCII art
-showAST :: StringTree dom => ASTF dom a -> String
-showAST = showTree . stringTree
-
--- | Print a syntax tree using ASCII art
-drawAST :: StringTree dom => ASTF dom a -> IO ()
-drawAST = putStrLn . showAST
-
-writeHtmlAST :: StringTree sym => FilePath -> ASTF sym a -> IO ()
-writeHtmlAST file = writeHtmlTree file . fmap (\n -> NodeInfo n "") . stringTree
-
diff --git a/src/Language/Syntactic/Interpretation/Semantics.hs b/src/Language/Syntactic/Interpretation/Semantics.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Interpretation/Semantics.hs
+++ /dev/null
@@ -1,103 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
--- | Default implementations of some interpretation functions
-
-module Language.Syntactic.Interpretation.Semantics where
-
-
-
-import Language.Haskell.TH
-import Language.Haskell.TH.Quote
-
-import Data.Hash
-
-import Language.Syntactic.Syntax
-import Language.Syntactic.Interpretation.Equality
-import Language.Syntactic.Interpretation.Render
-import Language.Syntactic.Interpretation.Evaluation
-
-
-
--- | A representation of a syntactic construct as a 'String' and an evaluation
--- function. It is not meant to be used as a syntactic symbol in an 'AST'. Its
--- only purpose is to provide the default implementations of functions like
--- `equal` via the `Semantic` class.
-data Semantics a
-  where
-    Sem
-        :: { semanticName :: String
-           , semanticEval :: Denotation a
-           }
-        -> Semantics a
-
-
-
-instance Equality Semantics
-  where
-    equal (Sem a _) (Sem b _) = a==b
-    exprHash (Sem name _)     = hash name
-
-instance Render Semantics
-  where
-    renderSym (Sem name _) = name
-    renderArgs [] (Sem name _) = name
-    renderArgs args (Sem name _)
-        | isInfix   = "(" ++ unwords [a,op,b] ++ ")"
-        | otherwise = "(" ++ unwords (name : args) ++ ")"
-      where
-        [a,b] = args
-        op    = init $ tail name
-        isInfix
-          =  not (null name)
-          && head name == '('
-          && last name == ')'
-          && length args == 2
-
-instance Eval Semantics
-  where
-    evaluate (Sem _ a) = a
-
-
-
--- | Class of expressions that can be treated as constructs
-class Semantic expr
-  where
-    semantics :: expr a -> Semantics a
-
--- | Default implementation of 'equal'
-equalDefault :: Semantic expr => expr a -> expr b -> Bool
-equalDefault a b = equal (semantics a) (semantics b)
-
--- | Default implementation of 'exprHash'
-exprHashDefault :: Semantic expr => expr a -> Hash
-exprHashDefault = exprHash . semantics
-
--- | Default implementation of 'renderSym'
-renderSymDefault :: Semantic expr => expr a -> String
-renderSymDefault = renderSym . semantics
-
--- | Default implementation of 'renderArgs'
-renderArgsDefault :: Semantic expr => [String] -> expr a -> String
-renderArgsDefault args = renderArgs args . semantics
-
--- | Default implementation of 'evaluate'
-evaluateDefault :: Semantic expr => expr a -> Denotation a
-evaluateDefault = evaluate . semantics
-
--- | Derive instances for 'Semantic' related classes
--- ('Equality', 'Render', 'StringTree', 'Eval')
-semanticInstances :: Name -> DecsQ
-semanticInstances n =
-    [d|
-        instance Equality $(typ) where
-          equal    = equalDefault
-          exprHash = exprHashDefault
-        instance Render $(typ) where
-          renderSym  = renderSymDefault
-          renderArgs = renderArgsDefault
-        instance StringTree $(typ)
-        instance Eval $(typ) where evaluate = evaluateDefault
-    |]
-  where
-    typ = conT n
-
diff --git a/src/Language/Syntactic/Sharing/Graph.hs b/src/Language/Syntactic/Sharing/Graph.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Sharing/Graph.hs
+++ /dev/null
@@ -1,337 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-
--- | Representation and manipulation of abstract syntax graphs
-
-module Language.Syntactic.Sharing.Graph where
-
-
-
-import Control.Arrow ((***))
-import Control.Monad.Reader
-import Data.Array
-import Data.Function
-import Data.List
-import Data.Typeable
-
-import Data.Hash
-
-import Language.Syntactic
-import Language.Syntactic.Constructs.Binding
-import Language.Syntactic.Sharing.Utils
-
-
-
---------------------------------------------------------------------------------
--- * Representation
---------------------------------------------------------------------------------
-
--- | Node identifier
-newtype NodeId = NodeId { nodeInteger :: Integer }
-  deriving (Eq, Ord, Num, Real, Integral, Enum, Ix)
-
-instance Show NodeId
-  where
-    show (NodeId i) = show i
-
-showNode :: NodeId -> String
-showNode n = "node:" ++ show n
-
-
-
--- | Placeholder for a syntax tree
-data Node a
-  where
-    Node :: NodeId -> Node (Full a)
-
-instance Constrained Node
-  where
-    type Sat Node = Top
-    exprDict _ = Dict
-
-instance Render Node
-  where
-    renderSym (Node a) = showNode a
-
-instance StringTree Node
-
-
-
--- | Environment for alpha-equivalence
-class NodeEqEnv dom a
-  where
-    prjNodeEqEnv :: a -> NodeEnv dom (Sat dom)
-    modNodeEqEnv :: (NodeEnv dom (Sat dom) -> NodeEnv dom (Sat dom)) -> (a -> a)
-
-type EqEnv dom p = ([(VarId,VarId)], NodeEnv dom p)
-
-type NodeEnv dom p =
-    ( Array NodeId Hash
-    , Array NodeId (ASTB dom p)
-    )
-
-instance (p ~ Sat dom) => NodeEqEnv dom (EqEnv dom p)
-  where
-    prjNodeEqEnv   = snd
-    modNodeEqEnv f = (id *** f)
-
-instance VarEqEnv (EqEnv dom p)
-  where
-    prjVarEqEnv   = fst
-    modVarEqEnv f = (f *** id)
-
-instance (AlphaEq dom dom dom env, NodeEqEnv dom env) =>
-    AlphaEq Node Node dom env
-  where
-    alphaEqSym (Node n1) Nil (Node n2) Nil
-        | n1 == n2  = return True
-        | otherwise = do
-            (hTab,nTab) :: NodeEnv dom (Sat dom) <- asks prjNodeEqEnv
-            if hTab!n1 /= hTab!n2
-              then return False
-              else case (nTab!n1, nTab!n2) of
-                  (ASTB a, ASTB b) -> alphaEqM a b
-                    -- TODO The result could be memoized in a
-                    -- @Map (NodeId,NodeId) Bool@
-
-  -- TODO With only this instance, the result will be 'False' when one argument
-  --      is a 'Node' and the other one isn't. This is not really correct since
-  --      'Node's are just meta-variables and shouldn't be part of the
-  --      comparison. But as long as equivalent expressions always have 'Node's
-  --      at the same position, it doesn't matter. This could probably be fixed
-  --      by adding two overlapping instances.
-
-
-
--- | \"Abstract Syntax Graph\"
---
--- A representation of a syntax tree with explicit sharing. An 'ASG' is valid if
--- and only if 'inlineAll' succeeds (and the 'numNodes' field is correct).
-data ASG dom a = ASG
-    { topExpression :: ASTF (NodeDomain dom) a              -- ^ Top-level expression
-    , graphNodes    :: [(NodeId, ASTSAT (NodeDomain dom))]  -- ^ Mapping from node id to sub-expression
-    , numNodes      :: NodeId                               -- ^ Total number of nodes
-    }
-
-type NodeDomain dom = (Node :+: dom) :|| Sat dom
-
-
-
--- | Show syntax graph using ASCII art
-showASG :: forall dom a. StringTree dom => ASG dom a -> String
-showASG (ASG top nodes _) =
-    unlines ((line "top" ++ showAST top) : map showNode nodes)
-  where
-    line str = "---- " ++ str ++ " " ++ rest ++ "\n"
-      where
-        rest = replicate (40 - length str) '-'
-
-    showNode :: (NodeId, ASTSAT (NodeDomain dom)) -> String
-    showNode (n, ASTB expr) = concat
-      [ line ("node:" ++ show n)
-      , showAST expr
-      ]
-
--- | Print syntax graph using ASCII art
-drawASG :: StringTree dom => ASG dom a -> IO ()
-drawASG = putStrLn . showASG
-
--- | Update the node identifiers in an 'AST' using the supplied reindexing
--- function
-reindexNodesAST ::
-    (NodeId -> NodeId) -> AST (NodeDomain dom) a -> AST (NodeDomain dom) a
-reindexNodesAST reix (Sym (C' (InjL (Node n)))) = injC $ Node $ reix n
-reindexNodesAST reix (s :$ a) = reindexNodesAST reix s :$ reindexNodesAST reix a
-reindexNodesAST reix a = a
-
--- | Reindex the nodes according to the given index mapping. The number of nodes
--- is unchanged, so if the index mapping is not 1:1, the resulting graph will
--- contain duplicates.
-reindexNodes :: (NodeId -> NodeId) -> ASG dom a -> ASG dom a
-reindexNodes reix (ASG top nodes n) = ASG top' nodes' n
-  where
-    top'   = reindexNodesAST reix top
-    nodes' =
-      [ (reix n, ASTB $ reindexNodesAST reix a)
-        | (n, ASTB a) <- nodes
-      ]
-
--- | Reindex the nodes to be in the range @[0 .. l-1]@, where @l@ is the number
--- of nodes in the graph
-reindexNodesFrom0 :: ASG dom a -> ASG dom a
-reindexNodesFrom0 graph = reindexNodes reix graph
-  where
-    reix = reindex $ map fst $ graphNodes graph
-
--- | Remove duplicate nodes from a graph. The function only looks at the
--- 'NodeId' of each node. The 'numNodes' field is updated accordingly.
-nubNodes :: ASG dom a -> ASG dom a
-nubNodes (ASG top nodes n) = ASG top nodes' n'
-  where
-    nodes' = nubBy ((==) `on` fst) nodes
-    n'     = genericLength nodes'
-
-
-
---------------------------------------------------------------------------------
--- * Folding
---------------------------------------------------------------------------------
-
--- | Pattern functor representation of an 'AST' with 'Node's
-data SyntaxPF dom a
-  where
-    AppPF  :: a -> a -> SyntaxPF dom a
-    NodePF :: NodeId -> a -> SyntaxPF dom a
-    DomPF  :: dom b -> SyntaxPF dom a
-  -- NOTE: The important constructor is 'NodePF', which makes a 'Node' appear as
-  -- any other recursive constructor.
-
-instance Functor (SyntaxPF dom)
-  where
-    fmap f (AppPF g a)  = AppPF  (f g) (f a)
-    fmap f (NodePF n a) = NodePF n (f a)
-    fmap f (DomPF a)    = DomPF a
-
-
-
--- | Folding over a graph
---
--- The user provides a function to fold a single constructor (an \"algebra\").
--- The result contains the result of folding the whole graph as well as the
--- result of each internal node, represented both as an array and an association
--- list. Each node is processed exactly once.
-foldGraph :: forall dom a b .
-    (SyntaxPF dom b -> b) -> ASG dom a -> (b, (Array NodeId b, [(NodeId,b)]))
-foldGraph alg (ASG top ns nn) = (g top, (arr,nodes))
-  where
-    nodes = [(n, g expr) | (n, ASTB expr) <- ns]
-    arr   = array (0, nn-1) nodes
-
-    g :: AST (NodeDomain dom) c -> b
-    g (h :$ a)                   = alg $ AppPF (g h) (g a)
-    g (Sym (C' (InjL (Node n)))) = alg $ NodePF n (arr!n)
-    g (Sym (C' (InjR a)))        = alg $ DomPF a
-
-
-
---------------------------------------------------------------------------------
--- * Inlining
---------------------------------------------------------------------------------
-
--- | Convert an 'ASG' to an 'AST' by inlining all nodes
-inlineAll :: forall dom a . ConstrainedBy dom Typeable =>
-    ASG dom a -> ASTF dom a
-inlineAll (ASG top nodes n) = inline top
-  where
-    nodeMap = array (0, n-1) nodes
-
-    inline :: AST (NodeDomain dom) b -> AST dom b
-    inline (s :$ a) = inline s :$ inline a
-    inline s@(Sym (C' (InjL (Node n)))) = case nodeMap ! n of
-        ASTB a
-          | Dict <- exprDictSub pTypeable s
-          , Dict <- exprDictSub pTypeable a
-          -> case gcast a of
-               Nothing -> error "inlineAll: type mismatch"
-               Just a  -> inline a
-    inline (Sym (C' (InjR a))) = Sym a
-
-
-
--- | Find the child nodes of each node in an expression. The child nodes of a
--- node @n@ are the first nodes along all paths from @n@.
-nodeChildren :: ASG dom a -> [(NodeId, [NodeId])]
-nodeChildren = map (id *** fromDList) . snd . snd . foldGraph children
-  where
-    children :: SyntaxPF dom (DList NodeId) -> DList NodeId
-    children (AppPF ns1 ns2) = ns1 . ns2
-    children (NodePF n _)    = single n
-    children _               = empty
-
--- | Count the number of occurrences of each node in an expression
-occurrences :: ASG dom a -> Array NodeId Int
-occurrences graph
-    = count (0, numNodes graph - 1)
-    $ concatMap snd
-    $ nodeChildren graph
-
--- | Inline all nodes that are not shared
-inlineSingle :: forall dom a . ConstrainedBy dom Typeable =>
-    ASG dom a -> ASG dom a
-inlineSingle graph@(ASG top nodes n) = ASG top' nodes' n'
-  where
-    nodeTab  = array (0, n-1) nodes
-    occs     = occurrences graph
-
-    top'   = inline top
-    nodes' = [(n, ASTB (inline a)) | (n, ASTB a) <- nodes, occs!n > 1]
-    n'     = genericLength nodes'
-
-    inline :: AST (NodeDomain dom) b -> AST (NodeDomain dom) b
-    inline (s :$ a) = inline s :$ inline a
-    inline s@(Sym (C' (InjL (Node n))))
-        | occs!n > 1 = injC $ Node n
-        | otherwise = case nodeTab ! n of
-            ASTB a
-              | Dict <- exprDictSub pTypeable s
-              , Dict <- exprDictSub pTypeable a
-              -> case gcast a of
-                   Nothing -> error "inlineSingle: type mismatch"
-                   Just a  -> inline a
-    inline (Sym (C' (InjR a))) = Sym $ C' $ InjR a
-
-
-
---------------------------------------------------------------------------------
--- * Sharing
---------------------------------------------------------------------------------
-
--- | Compute a table (both array and list representation) of hash values for
--- each node
-hashNodes :: Equality dom => ASG dom a -> (Array NodeId Hash, [(NodeId, Hash)])
-hashNodes = snd . foldGraph hashNode
-  where
-    hashNode (AppPF h1 h2) = hashInt 0 `combine` h1 `combine` h2
-    hashNode (NodePF _ h)  = h
-    hashNode (DomPF a)     = hashInt 1 `combine` exprHash a
-
-
-
--- | Partitions the nodes such that two nodes are in the same sub-list if and
--- only if they are alpha-equivalent.
-partitionNodes :: forall dom a
-    .  ( Equality dom
-       , AlphaEq dom dom (NodeDomain dom) (EqEnv (NodeDomain dom) (Sat dom))
-       )
-    => ASG dom a -> [[NodeId]]
-partitionNodes graph = concatMap (fullPartition nodeEq) approxPartitioning
-  where
-    nTab          = array (0, numNodes graph - 1) (graphNodes graph)
-    (hTab,hashes) = hashNodes graph
-
-    -- | An approximate partitioning of the nodes: nodes in different partitions
-    -- are guaranteed to be inequivalent, while nodes in the same partition
-    -- might be equivalent.
-    approxPartitioning
-        = map (map fst)
-        $ groupBy ((==) `on` snd)
-        $ sortBy (compare `on` snd)
-        $ hashes
-
-    nodeEq :: NodeId -> NodeId -> Bool
-    nodeEq n1 n2 = runReader
-        (liftASTB2 alphaEqM (nTab!n1) (nTab!n2))
-        (([],(hTab,nTab)) :: EqEnv (NodeDomain dom) (Sat dom))
-
-
-
--- | Common sub-expression elimination based on alpha-equivalence
-cse
-    :: ( Equality dom
-       , AlphaEq dom dom (NodeDomain dom) (EqEnv (NodeDomain dom) (Sat dom))
-       )
-    => ASG dom a -> ASG dom a
-cse graph@(ASG top nodes n) = nubNodes $ reindexNodes (reixTab!) graph
-  where
-    parts   = partitionNodes graph
-    reixTab = array (0,n-1) [(n,p) | (part,p) <- parts `zip` [0..], n <- part]
-
diff --git a/src/Language/Syntactic/Sharing/Reify.hs b/src/Language/Syntactic/Sharing/Reify.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Sharing/Reify.hs
+++ /dev/null
@@ -1,80 +0,0 @@
--- | Reifying the sharing in an 'AST'
---
--- This module is based on the paper /Type-Safe Observable Sharing in Haskell/
--- (Andy Gill, 2009, <http://dx.doi.org/10.1145/1596638.1596653>).
-
-module Language.Syntactic.Sharing.Reify
-    ( reifyGraph
-    ) where
-
-
-
-import Control.Monad.Writer
-import Data.IntMap as Map
-import Data.IORef
-import System.Mem.StableName
-
-import Language.Syntactic
-import Language.Syntactic.Sharing.Graph
-import Language.Syntactic.Sharing.StableName
-
-
-
--- | Shorthand used by 'reifyGraphM'
---
--- Writes out a list of encountered nodes and returns the top expression.
-type GraphMonad dom a = WriterT
-    [(NodeId, ASTB (NodeDomain dom) (Sat dom))]
-    IO
-    (AST (NodeDomain dom) a)
-
-
-
-reifyGraphM :: forall dom a . Constrained dom
-    => (forall a . ASTF dom a -> Bool)
-    -> IORef NodeId
-    -> IORef (History (AST dom))
-    -> ASTF dom a
-    -> GraphMonad dom (Full a)
-
-reifyGraphM canShare nSupp history = reifyNode
-  where
-    reifyNode :: ASTF dom b -> GraphMonad dom (Full b)
-    reifyNode a
-      | Dict <- exprDict a = case canShare a of
-          False -> reifyRec a
-          True | a `seq` True -> do
-            st   <- liftIO $ makeStableName a
-            hist <- liftIO $ readIORef history
-            case lookHistory hist (StName st) of
-              Just n -> return $ injC $ Node n
-              _ -> do
-                n  <- fresh nSupp
-                liftIO $ modifyIORef history $ remember (StName st) n
-                a' <- reifyRec a
-                tell [(n, ASTB a')]
-                return $ injC $ Node n
-
-    reifyRec :: Sat dom (DenResult b) => AST dom b -> GraphMonad dom b
-    reifyRec (f :$ a) = liftM2 (:$) (reifyRec f) (reifyNode a)
-    reifyRec (Sym s)  = return $ Sym $ C' $ InjR s
-
-
-
--- | Convert a syntax tree to a sharing-preserving graph
---
--- This function is not referentially transparent (hence the 'IO'). However, it
--- is well-behaved in the sense that the worst thing that could happen is that
--- sharing is lost. It is not possible to get false sharing.
-reifyGraph :: Constrained dom
-    => (forall a . ASTF dom a -> Bool)
-         -- ^ A function that decides whether a given node can be shared
-    -> ASTF dom a
-    -> IO (ASG dom a)
-reifyGraph canShare a = do
-    nSupp   <- newIORef 0
-    history <- newIORef empty
-    (a',ns) <- runWriterT $ reifyGraphM canShare nSupp history a
-    n       <- readIORef nSupp
-    return (ASG a' ns n)
-
diff --git a/src/Language/Syntactic/Sharing/ReifyHO.hs b/src/Language/Syntactic/Sharing/ReifyHO.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Sharing/ReifyHO.hs
+++ /dev/null
@@ -1,109 +0,0 @@
--- | This module is similar to "Language.Syntactic.Sharing.Reify", but operates
--- on @`AST` (`HODomain` dom p)@ rather than a general 'AST'. The reason for
--- having this module is that when using 'HODomain', it is important to do
--- simultaneous sharing analysis and 'HOLambda' reification. Obviously we cannot
--- do sharing analysis first (using
--- 'Language.Syntactic.Sharing.Reify.reifyGraph' from
--- "Language.Syntactic.Sharing.Reify"), since it needs to be able to look inside
--- 'HOLambda'. On the other hand, if we did 'HOLambda' reification first (using
--- 'reify'), we would destroy the sharing.
---
--- This module is based on the paper /Type-Safe Observable Sharing in Haskell/
--- (Andy Gill, 2009, <http://dx.doi.org/10.1145/1596638.1596653>).
-
-module Language.Syntactic.Sharing.ReifyHO
-    ( reifyGraphTop
-    , reifyGraph
-    ) where
-
-
-
-import Control.Monad.Writer
-import Data.IntMap as Map
-import Data.IORef
-import System.Mem.StableName
-
-import Language.Syntactic
-import Language.Syntactic.Constructs.Binding
-import Language.Syntactic.Constructs.Binding.HigherOrder
-import Language.Syntactic.Sharing.Graph
-import Language.Syntactic.Sharing.StableName
-import qualified Language.Syntactic.Sharing.Reify  -- For Haddock
-
-
-
--- | Shorthand used by 'reifyGraphM'
---
--- Writes out a list of encountered nodes and returns the top expression.
-type GraphMonad dom p pVar a = WriterT
-    [(NodeId, ASTB (NodeDomain (FODomain dom p pVar)) p)]
-    IO
-    (AST (NodeDomain (FODomain dom p pVar)) a)
-
-
-
-reifyGraphM :: forall dom p pVar a
-    .  (forall a . ASTF (HODomain dom p pVar) a -> Bool)
-    -> IORef VarId
-    -> IORef NodeId
-    -> IORef (History (AST (HODomain dom p pVar)))
-    -> ASTF (HODomain dom p pVar) a
-    -> GraphMonad dom p pVar (Full a)
-
-reifyGraphM canShare vSupp nSupp history = reifyNode
-  where
-    reifyNode :: ASTF (HODomain dom p pVar) b -> GraphMonad dom p pVar (Full b)
-    reifyNode a
-      | Dict <- exprDict a = case canShare a of
-          False -> reifyRec a
-          True | a `seq` True -> do
-            st   <- liftIO $ makeStableName a
-            hist <- liftIO $ readIORef history
-            case lookHistory hist (StName st) of
-              Just n -> return $ injC $ Node n
-              _ -> do
-                n  <- fresh nSupp
-                liftIO $ modifyIORef history $ remember (StName st) n
-                a' <- reifyRec a
-                tell [(n, ASTB a')]
-                return $ injC $ Node n
-
-    reifyRec :: AST (HODomain dom p pVar) b -> GraphMonad dom p pVar b
-    reifyRec (f :$ a)            = liftM2 (:$) (reifyRec f) (reifyNode a)
-    reifyRec (Sym (C' (InjR a))) = return $ Sym $ C' $ InjR $ C' $ InjR a
-    reifyRec (Sym (C' (InjL (HOLambda f)))) = do
-        v    <- fresh vSupp
-        body <- reifyNode $ f $ injC $ symType pVar $ C' (Variable v)
-        return $ injC (symType pLam $ SubConstr2 (Lambda v)) :$ body
-      where
-        pVar = P::P (Variable :|| pVar)
-        pLam = P::P (CLambda pVar)
-
-
-
--- | Convert a syntax tree to a sharing-preserving graph
-reifyGraphTop
-    :: (forall a . ASTF (HODomain dom p pVar) a -> Bool)
-    -> ASTF (HODomain dom p pVar) a
-    -> IO (ASG (FODomain dom p pVar) a, VarId)
-reifyGraphTop canShare a = do
-    vSupp   <- newIORef 0
-    nSupp   <- newIORef 0
-    history <- newIORef empty
-    (a',ns) <- runWriterT $ reifyGraphM canShare vSupp nSupp history a
-    v       <- readIORef vSupp
-    n       <- readIORef nSupp
-    return (ASG a' ns n, v)
-
--- | Reifying an n-ary syntactic function to a sharing-preserving graph
---
--- This function is not referentially transparent (hence the 'IO'). However, it
--- is well-behaved in the sense that the worst thing that could happen is that
--- sharing is lost. It is not possible to get false sharing.
-reifyGraph :: (Syntactic a, Domain a ~ HODomain dom p pVar)
-    => (forall a . ASTF (HODomain dom p pVar) a -> Bool)
-         -- ^ A function that decides whether a given node can be shared
-    -> a
-    -> IO (ASG (FODomain dom p pVar) (Internal a), VarId)
-reifyGraph canShare = reifyGraphTop canShare . desugar
-
diff --git a/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs b/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs
+++ /dev/null
@@ -1,235 +0,0 @@
--- | Simple code motion transformation performing common sub-expression elimination and variable
--- hoisting. Note that the implementation is very inefficient.
---
--- The code is based on an implementation by Gergely Dévai.
-
-module Language.Syntactic.Sharing.SimpleCodeMotion
-    ( PrjDict (..)
-    , InjDict (..)
-    , MkInjDict
-    , codeMotion
-    , prjDictFO
-    , reifySmart
-    , mkInjDictFO
-    ) where
-
-
-
-import Control.Monad.State
-import Data.Set as Set
-import Data.Typeable
-
-import Language.Syntactic
-import Language.Syntactic.Constructs.Binding
-import Language.Syntactic.Constructs.Binding.HigherOrder
-
-
-
--- | Interface for projecting binding constructs
-data PrjDict dom = PrjDict
-    { prjVariable :: forall sig . dom sig -> Maybe VarId
-    , prjLambda   :: forall sig . dom sig -> Maybe VarId
-    }
-
--- | Interface for injecting binding constructs
-data InjDict dom a b = InjDict
-    { injVariable :: VarId -> dom (Full a)
-    , injLambda   :: VarId -> dom (b :-> Full (a -> b))
-    , injLet      :: dom (a :-> (a -> b) :-> Full b)
-    }
-
--- | A function that, if possible, returns an 'InjDict' for sharing a specific sub-expression. The
--- first argument is the expression to be shared, and the second argument the expression in which it
--- will be shared.
---
--- This function makes the caller of 'codeMotion' responsible for making sure that the necessary
--- type constraints are fulfilled (otherwise 'Nothing' is returned). It also makes it possible to
--- transfer information, e.g. from the shared expression to the introduced variable.
-type MkInjDict dom = forall a b . ASTF dom a -> ASTF dom b -> Maybe (InjDict dom a b)
-
-
-
--- | Substituting a sub-expression. Assumes no variable capturing in the
--- expressions involved.
-substitute :: forall dom a b
-    .  (ConstrainedBy dom Typeable, AlphaEq dom dom dom [(VarId,VarId)])
-    => ASTF dom a  -- ^ Sub-expression to be replaced
-    -> ASTF dom a  -- ^ Replacing sub-expression
-    -> ASTF dom b  -- ^ Whole expression
-    -> ASTF dom b
-substitute x y a
-    | Dict <- exprDictSub pTypeable y
-    , Dict <- exprDictSub pTypeable a
-    , Just y' <- gcast y, alphaEq x a = y'
-    | otherwise = subst a
-  where
-    subst :: AST dom c -> AST dom c
-    subst (f :$ a) = subst f :$ substitute x y a
-    subst a = a
-
--- | Count the number of occurrences of a sub-expression
-count :: forall dom a b
-    .  AlphaEq dom dom dom [(VarId,VarId)]
-    => ASTF dom a  -- ^ Expression to count
-    -> ASTF dom b  -- ^ Expression to count in
-    -> Int
-count a b
-    | alphaEq a b = 1
-    | otherwise   = cnt b
-  where
-    cnt :: AST dom c -> Int
-    cnt (f :$ b) = cnt f + count a b
-    cnt _        = 0
-
--- | Environment for the expression in the 'choose' function
-data Env dom = Env
-    { inLambda :: Bool  -- ^ Whether the current expression is inside a lambda
-    , counter  :: ASTE dom -> Int
-        -- ^ Counting the number of occurrences of an expression in the
-        -- environment
-    , dependencies :: Set VarId
-        -- ^ The set of variables that are not allowed to occur in the chosen
-        -- expression
-    }
-
-independent :: PrjDict dom -> Env dom -> AST dom a -> Bool
-independent pd env (Sym (prjVariable pd -> Just v)) = not (v `member` dependencies env)
-independent pd env (f :$ a) = independent pd env f && independent pd env a
-independent _ _ _ = True
-
-isVariable :: PrjDict dom -> ASTF dom a -> Bool
-isVariable pd (Sym (prjVariable pd -> Just _)) = True
-isVariable pd _ = False
-
--- | Checks whether a sub-expression in a given environment can be lifted out
-liftable :: PrjDict dom -> Env dom -> ASTF dom a -> Bool
-liftable pd env a = independent pd env a && not (isVariable pd a) && heuristic
-    -- Lifting dependent expressions is semantically incorrect
-    -- Lifting variables would cause `codeMotion` to loop
-  where
-    heuristic = inLambda env || (counter env (ASTE a) > 1)
-
-
-
--- | A sub-expression chosen to be shared together with an evidence that it can actually be shared
--- in the whole expression under consideration
-data Chosen dom a
-  where
-    Chosen :: InjDict dom b a -> ASTF dom b -> Chosen dom a
-
--- | Choose a sub-expression to share
-choose :: forall dom a
-    .  AlphaEq dom dom dom [(VarId,VarId)]
-    => (forall c. ASTF dom c -> Bool)
-    -> PrjDict dom
-    -> MkInjDict dom
-    -> ASTF dom a
-    -> Maybe (Chosen dom a)
-choose hoistOver pd mkId a = chooseEnv initEnv a
-  where
-    initEnv = Env
-        { inLambda     = False
-        , counter      = \(ASTE b) -> count b a
-        , dependencies = empty
-        }
-
-    chooseEnv :: Env dom -> ASTF dom b -> Maybe (Chosen dom a)
-    chooseEnv env b
-        | liftable pd env b
-        , Just id <- mkId b a
-        = Just $ Chosen id b
-    chooseEnv env b
-        | hoistOver b = chooseEnvSub env b
-        | otherwise       = Nothing
-
-    -- | Like 'chooseEnv', but does not consider the top expression for sharing
-    chooseEnvSub :: Env dom -> AST dom b -> Maybe (Chosen dom a)
-    chooseEnvSub env (Sym lam :$ b)
-        | Just v <- prjLambda pd lam
-        = chooseEnv (env' v) b
-      where
-        env' v = env
-            { inLambda     = True
-            , dependencies = insert v (dependencies env)
-            }
-    chooseEnvSub env (s :$ b) = chooseEnvSub env s `mplus` chooseEnv env b
-    chooseEnvSub _ _ = Nothing
-
-
-
--- | Perform common sub-expression elimination and variable hoisting
-codeMotion :: forall dom a
-    .  ( ConstrainedBy dom Typeable
-       , AlphaEq dom dom dom [(VarId,VarId)]
-       )
-    => (forall c. ASTF dom c -> Bool)  -- ^ Control wether a sub-expression can be hoisted over the given expression
-    -> PrjDict dom
-    -> MkInjDict dom
-    -> ASTF dom a
-    -> State VarId (ASTF dom a)
-codeMotion hoistOver pd mkId a
-    | Just (Chosen id b) <- choose hoistOver pd mkId a = share id b
-    | otherwise = descend a
-  where
-    share :: InjDict dom b a -> ASTF dom b -> State VarId (ASTF dom a)
-    share id b = do
-        b' <- codeMotion hoistOver pd mkId b
-        v  <- get; put (v+1)
-        let x = Sym (injVariable id v)
-        body <- codeMotion hoistOver pd mkId $ substitute b x a
-        return
-            $  Sym (injLet id)
-            :$ b'
-            :$ (Sym (injLambda id v) :$ body)
-
-    descend :: AST dom b -> State VarId (AST dom b)
-    descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion hoistOver pd mkId a)
-    descend a        = return a
-
-
-
--- | A 'PrjDict' implementation for 'FODomain'
-prjDictFO :: forall dom p pVar . PrjDict (FODomain dom p pVar)
-prjDictFO = PrjDict
-    { prjVariable = fmap (\(C' (Variable v)) -> v)       . prjP (P::P (Variable :|| pVar))
-    , prjLambda   = fmap (\(SubConstr2 (Lambda v)) -> v) . prjP (P::P (CLambda pVar))
-    }
-
--- | Like 'reify' but with common sub-expression elimination and variable hoisting
-reifySmart :: forall dom p pVar a
-    .  ( AlphaEq dom dom (FODomain dom p pVar) [(VarId,VarId)]
-       , Syntactic a
-       , Domain a ~ HODomain dom p pVar
-       , p :< Typeable
-       )
-    => (forall c. ASTF (FODomain dom p pVar) c -> Bool)
-    -> MkInjDict (FODomain dom p pVar)
-    -> a
-    -> ASTF (FODomain dom p pVar) (Internal a)
-reifySmart hoistOver mkId = flip evalState 0 . (codeMotion hoistOver prjDictFO mkId <=< reifyM . desugar)
-
-
-
--- | An 'MkInjDict' implementation for 'FODomain'
---
--- The supplied function determines whether or not an expression can be shared by returning a
--- witness that the type of the expression satisfies the predicate @pVar@.
-mkInjDictFO :: forall dom pVar . (Let :<: dom)
-    => (forall a . ASTF (FODomain dom Typeable pVar) a -> Maybe (Dict (pVar a)))
-    -> (forall b . ASTF (FODomain dom Typeable pVar) b -> Bool)
-    -> MkInjDict (FODomain dom Typeable pVar)
-mkInjDictFO canShare canShareIn a b
-    | Dict <- exprDict a
-    , Dict <- exprDict b
-    , Just Dict <- canShare a
-    , canShareIn b
-    = Just $ InjDict
-        { injVariable = \v -> injC (symType pVar $ C' (Variable v))
-        , injLambda   = \v -> injC (symType pLam $ SubConstr2 (Lambda v))
-        , injLet      = C' $ inj Let
-        }
-  where
-    pVar = P::P (Variable :|| pVar)
-    pLam = P::P (CLambda pVar)
-mkInjDictFO _ _ _ _ = Nothing
-
diff --git a/src/Language/Syntactic/Sharing/StableName.hs b/src/Language/Syntactic/Sharing/StableName.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Sharing/StableName.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-module Language.Syntactic.Sharing.StableName where
-
-
-
-import Control.Monad.IO.Class
-import Data.IntMap as Map
-import Data.IORef
-import System.Mem.StableName
-import Unsafe.Coerce
-
-import Language.Syntactic
-import Language.Syntactic.Sharing.Graph
-
-
-
--- | 'StableName' of a @(c (Full a))@ with hidden result type
-data StName c
-  where
-    StName :: StableName (c (Full a)) -> StName c
-
-instance Eq (StName c)
-  where
-    StName a == StName b = a == unsafeCoerce b
-      -- This is "probably" safe according to
-      -- <http://www.haskell.org/pipermail/glasgow-haskell-users/2012-August/022758.html>
-
-      -- TODO In future, use `eqStableName`. It should be in GHC 7.8.1.
-
-hash :: StName c -> Int
-hash (StName st) = hashStableName st
-
--- | A hash table from 'StName' to 'NodeId' (with 'hash' as the hashing
--- function). I.e. it is assumed that the 'StName's at each entry all have the
--- same hash, and that this number is equal to the entry's key.
-type History c = IntMap [(StName c, NodeId)]
-
--- | Lookup a name in the history
-lookHistory :: History c -> StName c -> Maybe NodeId
-lookHistory hist st = case Map.lookup (hash st) hist of
-    Nothing   -> Nothing
-    Just list -> Prelude.lookup st list
-
--- | Insert the name into the history
-remember :: StName c -> NodeId -> History c -> History c
-remember st n hist = insertWith (++) (hash st) [(st,n)] hist
-
--- | Return a fresh identifier from the given supply
-fresh :: (Enum a, MonadIO m) => IORef a -> m a
-fresh aRef = do
-    a <- liftIO $ readIORef aRef
-    liftIO $ writeIORef aRef (succ a)
-    return a
-
diff --git a/src/Language/Syntactic/Sharing/Utils.hs b/src/Language/Syntactic/Sharing/Utils.hs
deleted file mode 100644
--- a/src/Language/Syntactic/Sharing/Utils.hs
+++ /dev/null
@@ -1,59 +0,0 @@
--- | Some utility functions used by the other modules
-
-module Language.Syntactic.Sharing.Utils where
-
-
-
-import Data.Array
-import Data.List
-
-
-
---------------------------------------------------------------------------------
--- * Difference lists
---------------------------------------------------------------------------------
-
--- | Difference list
-type DList a = [a] -> [a]
-
--- | Empty list
-empty :: DList a
-empty = id
-
--- | Singleton list
-single :: a -> DList a
-single = (:)
-
-fromDList :: DList a -> [a]
-fromDList = ($ [])
-
-
-
---------------------------------------------------------------------------------
--- * Misc.
---------------------------------------------------------------------------------
-
--- | Given a list @is@ of unique natural numbers, returns a function that maps
--- each number in @is@ to a unique number in the range @[0 .. length is-1]@. The
--- complexity is O(@maximum is@).
-reindex :: (Integral a, Ix a) => [a] -> a -> a
-reindex is = (tab!)
-  where
-    tab = array (0, maximum is) $ zip is [0..]
-
--- | Count the number of occurrences of each element in the list. The result is
--- an array mapping each element to its number of occurrences.
-count :: Ix a
-    => (a,a)  -- ^ Upper and lower bound on the elements to be counted
-    -> [a]    -- ^ Elements to be counted
-    -> Array a Int
-count bnds as = accumArray (+) 0 bnds [(n,1) | n <- as]
-
--- | Partitions the list such that two elements are in the same sub-list if and
--- only if they satisfy the equivalence check. The complexity is O(n^2).
-fullPartition :: (a -> a -> Bool) -> [a] -> [[a]]
-fullPartition eq []     = []
-fullPartition eq (a:as) = (a:as1) : fullPartition eq as2
-  where
-    (as1,as2) = partition (eq a) as
-
diff --git a/src/Language/Syntactic/Sugar.hs b/src/Language/Syntactic/Sugar.hs
--- a/src/Language/Syntactic/Sugar.hs
+++ b/src/Language/Syntactic/Sugar.hs
@@ -1,14 +1,29 @@
-{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE UndecidableInstances #-}
 
+#ifndef MIN_VERSION_GLASGOW_HASKELL
+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0
+#endif
+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10
+
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
+#else
+{-# LANGUAGE OverlappingInstances #-}
+#endif
+
 -- | \"Syntactic sugar\"
+--
+-- For details, see "Combining Deep and Shallow Embedding for EDSL"
+-- (TFP 2013, <https://emilaxelsson.github.io/documents/svenningsson2013combining.pdf>).
 
 module Language.Syntactic.Sugar where
 
 
 
+import Data.Kind (Type)
+import Data.Typeable
+
 import Language.Syntactic.Syntax
-import Language.Syntactic.Constraint
 
 
 
@@ -16,18 +31,25 @@
 -- as @a@.
 class Syntactic a
   where
-    type Domain a :: * -> *
+    type Domain a :: Type -> Type
     type Internal a
     desugar :: a -> ASTF (Domain a) (Internal a)
     sugar   :: ASTF (Domain a) (Internal a) -> a
 
-instance Syntactic (ASTF dom a)
+instance Syntactic (ASTF sym a)
   where
-    type Domain (ASTF dom a)   = dom
-    type Internal (ASTF dom a) = a
+    type Domain (ASTF sym a)   = sym
+    type Internal (ASTF sym a) = a
     desugar = id
     sugar   = id
 
+instance Syntactic (ASTFull sym a)
+  where
+    type Domain (ASTFull sym a)   = sym
+    type Internal (ASTFull sym a) = a
+    desugar = unASTFull
+    sugar   = ASTFull
+
 -- | Syntactic type casting
 resugar :: (Syntactic a, Syntactic b, Domain a ~ Domain b, Internal a ~ Internal b) => a -> b
 resugar = sugar . desugar
@@ -41,74 +63,86 @@
 -- >     , Syntactic b
 -- >     , ...
 -- >     , Syntactic x
--- >     , Domain a ~ dom
--- >     , Domain b ~ dom
+-- >     , Domain a ~ sym
+-- >     , Domain b ~ sym
 -- >     , ...
--- >     , Domain x ~ dom
+-- >     , Domain x ~ sym
 -- >     ) => (a -> b -> ... -> x)
--- >       -> (  ASTF dom (Internal a)
--- >          -> ASTF dom (Internal b)
+-- >       -> (  ASTF sym (Internal a)
+-- >          -> ASTF sym (Internal b)
 -- >          -> ...
--- >          -> ASTF dom (Internal x)
+-- >          -> ASTF sym (Internal x)
 -- >          )
 --
 -- ...and vice versa for 'sugarN'.
-class SyntacticN a internal | a -> internal
+class SyntacticN f internal | f -> internal
   where
-    desugarN :: a -> internal
-    sugarN   :: internal -> a
+    desugarN :: f -> internal
+    sugarN   :: internal -> f
 
-instance (Syntactic a, Domain a ~ dom, ia ~ AST dom (Full (Internal a))) => SyntacticN a ia
+instance {-# OVERLAPS #-}
+         (Syntactic f, Domain f ~ sym, fi ~ AST sym (Full (Internal f))) => SyntacticN f fi
   where
     desugarN = desugar
     sugarN   = sugar
 
-instance
+instance {-# OVERLAPS #-}
     ( Syntactic a
-    , Domain a ~ dom
+    , Domain a ~ sym
     , ia ~ Internal a
-    , SyntacticN b ib
+    , SyntacticN f fi
     ) =>
-      SyntacticN (a -> b) (AST dom (Full ia) -> ib)
+      SyntacticN (a -> f) (AST sym (Full ia) -> fi)
   where
     desugarN f = desugarN . f . sugar
     sugarN f   = sugarN . f . desugar
 
-
-
 -- | \"Sugared\" symbol application
 --
 -- 'sugarSym' has any type of the form:
 --
 -- > sugarSym ::
--- >     ( expr :<: AST dom
--- >     , Syntactic a dom
--- >     , Syntactic b dom
+-- >     ( sub :<: AST sup
+-- >     , Syntactic a
+-- >     , Syntactic b
 -- >     , ...
--- >     , Syntactic x dom
--- >     ) => expr (Internal a :-> Internal b :-> ... :-> Full (Internal x))
+-- >     , Syntactic x
+-- >     , Domain a ~ Domain b ~ ... ~ Domain x
+-- >     ) => sub (Internal a :-> Internal b :-> ... :-> Full (Internal x))
 -- >       -> (a -> b -> ... -> x)
-sugarSym :: (sym :<: AST dom, ApplySym sig b dom, SyntacticN c b) =>
-    sym sig -> c
-sugarSym = sugarN . appSym
+sugarSym
+    :: ( Signature sig
+       , fi  ~ SmartFun sup sig
+       , sig ~ SmartSig fi
+       , sup ~ SmartSym fi
+       , SyntacticN f fi
+       , sub :<: sup
+       )
+    => sub sig -> f
+sugarSym = sugarN . smartSym
 
 -- | \"Sugared\" symbol application
 --
--- 'sugarSymC' has any type of the form:
+-- 'sugarSymTyped' has any type of the form:
 --
--- > sugarSymC ::
--- >     ( InjectC expr (AST dom) (Internal x)
--- >     , Syntactic a dom
--- >     , Syntactic b dom
+-- > sugarSymTyped ::
+-- >     ( sub :<: AST (Typed sup)
+-- >     , Syntactic a
+-- >     , Syntactic b
 -- >     , ...
--- >     , Syntactic x dom
--- >     ) => expr (Internal a :-> Internal b :-> ... :-> Full (Internal x))
+-- >     , Syntactic x
+-- >     , Domain a ~ Domain b ~ ... ~ Domain x
+-- >     , Typeable (Internal x)
+-- >     ) => sub (Internal a :-> Internal b :-> ... :-> Full (Internal x))
 -- >       -> (a -> b -> ... -> x)
-sugarSymC
-    :: ( InjectC sym (AST dom) (DenResult sig)
-       , ApplySym sig b dom
-       , SyntacticN c b
+sugarSymTyped
+    :: ( Signature sig
+       , fi        ~ SmartFun (Typed sup) sig
+       , sig       ~ SmartSig fi
+       , Typed sup ~ SmartSym fi
+       , SyntacticN f fi
+       , sub :<: sup
+       , Typeable (DenResult sig)
        )
-    => sym sig -> c
-sugarSymC = sugarN . appSymC
-
+    => sub sig -> f
+sugarSymTyped = sugarN . smartSymTyped
diff --git a/src/Language/Syntactic/Sugar/Binding.hs b/src/Language/Syntactic/Sugar/Binding.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Sugar/Binding.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | 'Syntactic' instance for functions for domains based on 'Binding'
+
+module Language.Syntactic.Sugar.Binding where
+
+
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+
+
+
+instance
+    ( Syntactic a, Domain a ~ dom
+    , Syntactic b, Domain b ~ dom
+    , Binding :<: dom
+    ) =>
+      Syntactic (a -> b)
+  where
+    type Domain (a -> b)   = Domain a
+    type Internal (a -> b) = Internal a -> Internal b
+    desugar f = lam (desugar . f . sugar)
+    sugar     = error "sugar not implemented for (a -> b)"
+
diff --git a/src/Language/Syntactic/Sugar/BindingTyped.hs b/src/Language/Syntactic/Sugar/BindingTyped.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Sugar/BindingTyped.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | 'Syntactic' instance for functions for domains based on 'Typed' and
+-- 'BindingT'
+
+module Language.Syntactic.Sugar.BindingTyped where
+
+
+
+import Data.Typeable
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+
+
+
+instance
+    ( sym ~ Typed s
+    , Syntactic a, Domain a ~ sym
+    , Syntactic b, Domain b ~ sym
+    , BindingT :<: s
+    , Typeable (Internal a)
+    , Typeable (Internal b)
+    ) =>
+      Syntactic (a -> b)
+  where
+    type Domain (a -> b)   = Domain a
+    type Internal (a -> b) = Internal a -> Internal b
+    desugar f = lamTyped (desugar . f . sugar)
+    sugar     = error "sugar not implemented for (a -> b)"
+
diff --git a/src/Language/Syntactic/Sugar/Monad.hs b/src/Language/Syntactic/Sugar/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Sugar/Monad.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#if __GLASGOW_HASKELL__ < 708
+#define TYPEABLE Typeable1
+#else
+#define TYPEABLE Typeable
+#endif
+
+-- | 'Syntactic' instance for 'Remon' for domains based on 'Binding'
+
+module Language.Syntactic.Sugar.Monad where
+
+
+
+import Control.Monad.Cont
+import Data.Typeable
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+import Language.Syntactic.Sugar.Binding ()
+
+
+
+-- | One-layer sugaring of monadic actions
+sugarMonad :: (Binding :<: sym, MONAD m :<: sym) =>
+    ASTF sym (m a) -> Remon sym m (ASTF sym a)
+sugarMonad ma = Remon $ cont $ sugarSym Bind ma
+
+instance
+    ( Syntactic a
+    , Domain a ~ sym
+    , Binding :<: sym
+    , MONAD m :<: sym
+    , TYPEABLE m
+    , Typeable (Internal a)
+        -- The `Typeable` constraints are only needed due to the `Typeable`
+        -- constraint in `Remon`. That constraint, in turn, is only needed by
+        -- the module "Language.Syntactic.Sugar.MonadT".
+    ) =>
+      Syntactic (Remon sym m a)
+  where
+    type Domain (Remon sym m a)   = sym
+    type Internal (Remon sym m a) = m (Internal a)
+    desugar = desugarMonad . fmap desugar
+    sugar   = fmap sugar   . sugarMonad
+
diff --git a/src/Language/Syntactic/Sugar/MonadTyped.hs b/src/Language/Syntactic/Sugar/MonadTyped.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Sugar/MonadTyped.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#if __GLASGOW_HASKELL__ < 708
+#define TYPEABLE Typeable1
+#else
+#define TYPEABLE Typeable
+#endif
+
+-- | 'Syntactic' instance for 'Remon' for domains based on 'Typed' and
+-- 'BindingT'
+
+module Language.Syntactic.Sugar.MonadTyped where
+
+
+
+import Control.Monad.Cont
+import Data.Typeable
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+import Language.Syntactic.Sugar.BindingTyped ()
+
+
+
+-- | One-layer sugaring of monadic actions
+sugarMonad
+    :: ( sym ~ Typed s
+       , BindingT :<: s
+       , MONAD m  :<: s
+       , TYPEABLE m
+       , Typeable a
+       )
+    => ASTF sym (m a) -> Remon sym m (ASTF sym a)
+sugarMonad ma = Remon $ cont $ sugarSymTyped Bind ma
+
+instance
+    ( sym ~ Typed s
+    , Syntactic a, Domain a ~ sym
+    , BindingT :<: s
+    , MONAD m  :<: s
+    , TYPEABLE m
+    , Typeable (Internal a)
+    ) =>
+      Syntactic (Remon sym m a)
+  where
+    type Domain (Remon sym m a)   = sym
+    type Internal (Remon sym m a) = m (Internal a)
+    desugar = desugarMonadTyped . fmap desugar
+    sugar   = fmap sugar   . sugarMonad
+
diff --git a/src/Language/Syntactic/Sugar/Tuple.hs b/src/Language/Syntactic/Sugar/Tuple.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Sugar/Tuple.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | 'Syntactic' instances for tuples
+
+module Language.Syntactic.Sugar.Tuple where
+
+
+
+import Language.Syntactic
+import Language.Syntactic.Functional.Tuple
+import Language.Syntactic.Functional.Tuple.TH
+
+
+
+instance
+    ( Syntactic a
+    , Syntactic b
+    , Tuple :<: Domain a
+    , Domain a ~ Domain b
+    ) =>
+      Syntactic (a,b)
+  where
+    type Domain (a,b)   = Domain a
+    type Internal (a,b) = (Internal a, Internal b)
+    desugar (a,b) = inj Pair :$ desugar a :$ desugar b
+    sugar ab      = (sugar $ inj Fst :$ ab, sugar $ inj Snd :$ ab)
+
+-- `desugar` and `sugar` can be seen as applying the eta-rule for pairs.
+-- <https://mail.haskell.org/pipermail/haskell-cafe/2016-April/123639.html>
+
+deriveSyntacticForTuples (const []) id [] 15
+
diff --git a/src/Language/Syntactic/Sugar/TupleTyped.hs b/src/Language/Syntactic/Sugar/TupleTyped.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/Sugar/TupleTyped.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | 'Syntactic' instances for tuples and 'Typed' symbol domains
+
+module Language.Syntactic.Sugar.TupleTyped where
+
+
+
+import Data.Typeable
+import Language.Haskell.TH
+
+#if __GLASGOW_HASKELL__ < 710
+import Data.Orphans ()
+#endif
+
+import Language.Syntactic
+import Language.Syntactic.TH
+import Language.Syntactic.Functional.Tuple
+import Language.Syntactic.Functional.Tuple.TH
+
+
+
+instance
+    ( Syntactic a
+    , Syntactic b
+    , Typeable (Internal a)
+    , Typeable (Internal b)
+    , Tuple :<: sym
+    , Domain a ~ Typed sym
+    , Domain a ~ Domain b
+    ) =>
+      Syntactic (a,b)
+  where
+    type Domain (a,b)   = Domain a
+    type Internal (a,b) = (Internal a, Internal b)
+    desugar (a,b) = Sym (Typed $ inj Pair) :$ desugar a :$ desugar b
+    sugar ab      = (sugar $ Sym (Typed $ inj Fst) :$ ab, sugar $ Sym (Typed $ inj Snd) :$ ab)
+
+-- `desugar` and `sugar` can be seen as applying the eta-rule for pairs.
+-- <https://mail.haskell.org/pipermail/haskell-cafe/2016-April/123639.html>
+
+deriveSyntacticForTuples
+    (return . classPred ''Typeable ConT . return)
+    (AppT (ConT ''Typed))
+    []
+#if __GLASGOW_HASKELL__ < 708
+    7
+#else
+    15
+#endif
+
diff --git a/src/Language/Syntactic/Syntax.hs b/src/Language/Syntactic/Syntax.hs
--- a/src/Language/Syntactic/Syntax.hs
+++ b/src/Language/Syntactic/Syntax.hs
@@ -1,38 +1,73 @@
-{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-{-# OPTIONS_GHC -cpp #-}
+#ifndef MIN_VERSION_GLASGOW_HASKELL
+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0
+#endif
+  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10
 
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
+#else
+{-# LANGUAGE OverlappingInstances #-}
+#endif
+
 -- | Generic representation of typed syntax trees
 --
 -- For details, see: A Generic Abstract Syntax Model for Embedded Languages
--- (ICFP 2012, <http://www.cse.chalmers.se/~emax/documents/axelsson2012generic.pdf>).
+-- (ICFP 2012, <https://emilaxelsson.github.io/documents/axelsson2012generic.pdf>).
 
 module Language.Syntactic.Syntax
     ( -- * Syntax trees
       AST (..)
     , ASTF
+    , ASTFull (..)
     , Full (..)
     , (:->) (..)
-    , size
-    , ApplySym (..)
+    , SigRep (..)
+    , Signature (..)
     , DenResult
-      -- * Symbol domains
+    , Symbol (..)
+    , size
+      -- * Smart constructors
+    , SmartFun
+    , SmartSig
+    , SmartSym
+    , smartSym'
+      -- * Open symbol domains
     , (:+:) (..)
     , Project (..)
     , (:<:) (..)
-    , appSym
-      -- * Type inference
+    , smartSym
+    , smartSymTyped
+    , Empty
+      -- * Existential quantification
+    , E (..)
+    , liftE
+    , liftE2
+    , EF (..)
+    , liftEF
+    , liftEF2
+      -- * Type casting expressions
+    , Typed (..)
+    , injT
+    , castExpr
+      -- * Misc.
+    , NFData1 (..)
     , symType
     , prjP
     ) where
 
 
 
-import Control.Monad.Instances  -- Not needed in GHC 7.6
+import Control.DeepSeq (NFData (..))
+import Data.Kind (Type)
 import Data.Typeable
-
-import Data.PolyProxy
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
+#else
+import Data.Foldable (Foldable)
+import Data.Proxy  -- Needed by GHC < 7.8
+import Data.Traversable (Traversable)
+#endif
 
 
 
@@ -42,20 +77,26 @@
 
 -- | Generic abstract syntax tree, parameterized by a symbol domain
 --
--- @(`AST` dom (a `:->` b))@ represents a partially applied (or unapplied)
--- symbol, missing at least one argument, while @(`AST` dom (`Full` a))@
+-- @(`AST` sym (a `:->` b))@ represents a partially applied (or unapplied)
+-- symbol, missing at least one argument, while @(`AST` sym (`Full` a))@
 -- represents a fully applied symbol, i.e. a complete syntax tree.
-data AST dom sig
+data AST sym sig
   where
-    Sym  :: dom sig -> AST dom sig
-    (:$) :: AST dom (a :-> sig) -> AST dom (Full a) -> AST dom sig
+    Sym  :: sym sig -> AST sym sig
+    (:$) :: AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
 
 infixl 1 :$
 
 -- | Fully applied abstract syntax tree
-type ASTF dom a = AST dom (Full a)
+type ASTF sym a = AST sym (Full a)
 
-instance Functor dom => Functor (AST dom)
+-- | Fully applied abstract syntax tree
+--
+-- This type is like 'AST', but being a newtype, it is a proper type constructor
+-- that can be partially applied.
+newtype ASTFull sym a = ASTFull {unASTFull :: ASTF sym a}
+
+instance Functor sym => Functor (AST sym)
   where
     fmap f (Sym s)  = Sym (fmap f s)
     fmap f (s :$ a) = fmap (fmap f) s :$ a
@@ -70,45 +111,118 @@
 
 infixr :->
 
--- | Count the number of symbols in an expression
-size :: AST dom sig -> Int
-size (Sym _)  = 1
-size (s :$ a) = size s + size a
+-- | Witness of the arity of a symbol signature
+data SigRep sig
+  where
+    SigFull :: SigRep (Full a)
+    SigMore :: SigRep sig -> SigRep (a :-> sig)
 
--- | Class for the type-level recursion needed by 'appSym'
-class ApplySym sig f dom | sig dom -> f, f -> sig dom
+-- | Valid symbol signatures
+class Signature sig
   where
-    appSym' :: AST dom sig -> f
+    signature :: SigRep sig
 
-instance ApplySym (Full a) (ASTF dom a) dom
+instance Signature (Full a)
   where
-    appSym' = id
+    signature = SigFull
 
-instance ApplySym sig f dom => ApplySym (a :-> sig) (ASTF dom a -> f) dom
+instance Signature sig => Signature (a :-> sig)
   where
-    appSym' sym a = appSym' (sym :$ a)
+    signature = SigMore signature
 
 -- | The result type of a symbol with the given signature
 type family   DenResult sig
 type instance DenResult (Full a)    = a
 type instance DenResult (a :-> sig) = DenResult sig
 
+-- | Valid symbols to use in an 'AST'
+class Symbol sym
+  where
+    -- | Reify the signature of a symbol
+    symSig :: sym sig -> SigRep sig
 
+instance NFData1 sym => NFData (AST sym sig)
+  where
+    rnf (Sym s)  = rnf1 s
+    rnf (s :$ a) = rnf s `seq` rnf a
 
+-- | Count the number of symbols in an 'AST'
+size :: AST sym sig -> Int
+size (Sym _)  = 1
+size (s :$ a) = size s + size a
+
+
+
 --------------------------------------------------------------------------------
--- * Symbol domains
+-- * Smart constructors
 --------------------------------------------------------------------------------
 
+-- | Maps a symbol signature to the type of the corresponding smart constructor:
+--
+-- > SmartFun sym (a :-> b :-> ... :-> Full x) = ASTF sym a -> ASTF sym b -> ... -> ASTF sym x
+type family   SmartFun (sym :: Type -> Type) sig
+type instance SmartFun sym (Full a)    = ASTF sym a
+type instance SmartFun sym (a :-> sig) = ASTF sym a -> SmartFun sym sig
+
+-- | Maps a smart constructor type to the corresponding symbol signature:
+--
+-- > SmartSig (ASTF sym a -> ASTF sym b -> ... -> ASTF sym x) = a :-> b :-> ... :-> Full x
+type family   SmartSig f
+type instance SmartSig (AST sym sig)     = sig
+type instance SmartSig (ASTF sym a -> f) = a :-> SmartSig f
+
+-- | Returns the symbol in the result of a smart constructor
+type family   SmartSym f :: Type -> Type
+type instance SmartSym (AST sym sig) = sym
+type instance SmartSym (a -> f)      = SmartSym f
+
+-- | Make a smart constructor of a symbol. 'smartSym'' has any type of the form:
+--
+-- > smartSym'
+-- >     :: sym (a :-> b :-> ... :-> Full x)
+-- >     -> (ASTF sym a -> ASTF sym b -> ... -> ASTF sym x)
+smartSym' :: forall sig f sym
+    .  ( Signature sig
+       , f   ~ SmartFun sym sig
+       , sig ~ SmartSig f
+       , sym ~ SmartSym f
+       )
+    => sym sig -> f
+smartSym' s = go (signature :: SigRep sig) (Sym s)
+  where
+    go :: forall sig . SigRep sig -> AST sym sig -> SmartFun sym sig
+    go SigFull s       = s
+    go (SigMore sig) s = \a -> go sig (s :$ a)
+
+
+
+--------------------------------------------------------------------------------
+-- * Open symbol domains
+--------------------------------------------------------------------------------
+
 -- | Direct sum of two symbol domains
-data (dom1 :+: dom2) a
+data (sym1 :+: sym2) sig
   where
-    InjL :: dom1 a -> (dom1 :+: dom2) a
-    InjR :: dom2 a -> (dom1 :+: dom2) a
-  deriving (Functor)
+    InjL :: sym1 a -> (sym1 :+: sym2) a
+    InjR :: sym2 a -> (sym1 :+: sym2) a
+  deriving (Functor, Foldable, Traversable)
 
 infixr :+:
 
+instance (Symbol sym1, Symbol sym2) => Symbol (sym1 :+: sym2)
+  where
+    symSig (InjL s) = symSig s
+    symSig (InjR s) = symSig s
+
+instance (NFData1 sym1, NFData1 sym2) => NFData1 (sym1 :+: sym2)
+  where
+    rnf1 (InjL s) = rnf1 s
+    rnf1 (InjR s) = rnf1 s
+
 -- | Symbol projection
+--
+-- The class is defined for /all pairs of types/, but 'prj' can only succeed if @sup@ is of the form
+-- @(... `:+:` sub `:+:` ...)@.
 class Project sub sup
   where
     -- | Partial projection from @sup@ to @sub@
@@ -116,42 +230,45 @@
 
 instance Project sub sup => Project sub (AST sup)
   where
-    prj (Sym a) = prj a
+    prj (Sym s) = prj s
     prj _       = Nothing
 
-instance Project expr expr
+instance {-# OVERLAPS #-} Project sym sym
   where
     prj = Just
 
-instance Project expr1 (expr1 :+: expr2)
+instance {-# OVERLAPS #-} Project sym1 (sym1 :+: sym2)
   where
     prj (InjL a) = Just a
     prj _        = Nothing
 
-instance Project expr1 expr3 => Project expr1 (expr2 :+: expr3)
+instance {-# OVERLAPS #-} Project sym1 sym3 => Project sym1 (sym2 :+: sym3)
   where
     prj (InjR a) = prj a
     prj _        = Nothing
 
--- | Symbol subsumption
+
+-- | Symbol injection
+--
+-- The class includes types @sub@ and @sup@ where @sup@ is of the form @(... `:+:` sub `:+:` ...)@.
 class Project sub sup => sub :<: sup
   where
     -- | Injection from @sub@ to @sup@
     inj :: sub a -> sup a
 
-instance (sub :<: sup) => (sub :<: AST sup)
+instance {-# OVERLAPS #-} (sub :<: sup) => (sub :<: AST sup)
   where
     inj = Sym . inj
 
-instance (expr :<: expr)
+instance {-# OVERLAPS #-} (sym :<: sym)
   where
     inj = id
 
-instance (expr1 :<: (expr1 :+: expr2))
+instance {-# OVERLAPS #-} (sym1 :<: (sym1 :+: sym2))
   where
     inj = InjL
 
-instance (expr1 :<: expr3) => (expr1 :<: (expr2 :+: expr3))
+instance {-# OVERLAPS #-} (sym1 :<: sym3) => (sym1 :<: (sym2 :+: sym3))
   where
     inj = InjR . inj
 
@@ -159,27 +276,136 @@
 -- types that can be instances of the former but not the latter due to type
 -- constraints on the `a` type.
 
--- | Generic symbol application
+-- | Make a smart constructor of a symbol. 'smartSym' has any type of the form:
 --
--- 'appSym' has any type of the form:
+-- > smartSym :: (sub :<: AST sup)
+-- >     => sub (a :-> b :-> ... :-> Full x)
+-- >     -> (ASTF sup a -> ASTF sup b -> ... -> ASTF sup x)
+smartSym
+    :: ( Signature sig
+       , f   ~ SmartFun sup sig
+       , sig ~ SmartSig f
+       , sup ~ SmartSym f
+       , sub :<: sup
+       )
+    => sub sig -> f
+smartSym = smartSym' . inj
+
+-- | Make a smart constructor of a symbol. 'smartSymTyped' has any type of the
+-- form:
 --
--- > appSym :: (expr :<: AST dom)
--- >     => expr (a :-> b :-> ... :-> Full x)
--- >     -> (ASTF dom a -> ASTF dom b -> ... -> ASTF dom x)
-appSym :: (ApplySym sig f dom, sym :<: AST dom) => sym sig -> f
-appSym = appSym' . inj
+-- > smartSymTyped :: (sub :<: AST (Typed sup), Typeable x)
+-- >     => sub (a :-> b :-> ... :-> Full x)
+-- >     -> (ASTF sup a -> ASTF sup b -> ... -> ASTF sup x)
+smartSymTyped
+    :: ( Signature sig
+       , f         ~ SmartFun (Typed sup) sig
+       , sig       ~ SmartSig f
+       , Typed sup ~ SmartSym f
+       , sub :<: sup
+       , Typeable (DenResult sig)
+       )
+    => sub sig -> f
+smartSymTyped = smartSym' . Typed . inj
 
+-- | Empty symbol type
+--
+-- Can be used to make uninhabited 'AST' types. It can also be used as a terminator in co-product
+-- lists (e.g. to avoid overlapping instances):
+--
+-- > (A :+: B :+: Empty)
+data Empty :: Type -> Type
 
 
+
 --------------------------------------------------------------------------------
--- * Type inference
+-- * Existential quantification
 --------------------------------------------------------------------------------
 
+-- | Existential quantification
+data E e
+  where
+    E :: e a -> E e
+
+liftE :: (forall a . e a -> b) -> E e -> b
+liftE f (E a) = f a
+
+liftE2 :: (forall a b . e a -> e b -> c) -> E e -> E e -> c
+liftE2 f (E a) (E b) = f a b
+
+-- | Existential quantification of 'Full'-indexed type
+data EF e
+  where
+    EF :: e (Full a) -> EF e
+
+liftEF :: (forall a . e (Full a) -> b) -> EF e -> b
+liftEF f (EF a) = f a
+
+liftEF2 :: (forall a b . e (Full a) -> e (Full b) -> c) -> EF e -> EF e -> c
+liftEF2 f (EF a) (EF b) = f a b
+
+
+
+--------------------------------------------------------------------------------
+-- * Type casting expressions
+--------------------------------------------------------------------------------
+
+-- | \"Typed\" symbol. Using @`Typed` sym@ instead of @sym@ gives access to the
+-- function 'castExpr' for casting expressions.
+data Typed sym sig
+  where
+    Typed :: Typeable (DenResult sig) => sym sig -> Typed sym sig
+
+instance Project sub sup => Project sub (Typed sup)
+  where
+    prj (Typed s) = prj s
+
+-- | Inject a symbol in an 'AST' with a 'Typed' domain
+injT :: (sub :<: sup, Typeable (DenResult sig)) =>
+    sub sig -> AST (Typed sup) sig
+injT = Sym . Typed . inj
+
+-- | Type cast an expression
+castExpr :: forall sym a b
+    .  ASTF (Typed sym) a  -- ^ Expression to cast
+    -> ASTF (Typed sym) b  -- ^ Witness for typeability of result
+    -> Maybe (ASTF (Typed sym) b)
+castExpr a b = cast1 a
+  where
+    cast1 :: (DenResult sig ~ a) => AST (Typed sym) sig -> Maybe (ASTF (Typed sym) b)
+    cast1 (s :$ _) = cast1 s
+    cast1 (Sym (Typed _)) = cast2 b
+      where
+        cast2 :: (DenResult sig ~ b) => AST (Typed sym) sig -> Maybe (ASTF (Typed sym) b)
+        cast2 (s :$ _)        = cast2 s
+        cast2 (Sym (Typed _)) = gcast a
+  -- Could be simplified using `simpleMatch`, but that would give an import
+  -- cycle.
+  --
+  --     castExpr a b =
+  --       simpleMatch
+  --         (\(Typed _) _ -> simpleMatch
+  --           (\(Typed _) _ -> gcast a
+  --           ) b
+  --         ) a
+
+
+
+--------------------------------------------------------------------------------
+-- * Misc.
+--------------------------------------------------------------------------------
+
+-- | Higher-kinded version of 'NFData'
+class NFData1 c
+  where
+    -- | Force a symbol to normal form
+    rnf1 :: c a -> ()
+    rnf1 s = s `seq` ()
+
 -- | Constrain a symbol to a specific type
-symType :: P sym -> sym sig -> sym sig
+symType :: Proxy sym -> sym sig -> sym sig
 symType _ = id
 
 -- | Projection to a specific symbol type
-prjP :: Project sub sup => P sub -> sup sig -> Maybe (sub sig)
+prjP :: Project sub sup => Proxy sub -> sup sig -> Maybe (sub sig)
 prjP _ = prj
-
diff --git a/src/Language/Syntactic/TH.hs b/src/Language/Syntactic/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Syntactic/TH.hs
@@ -0,0 +1,254 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
+module Language.Syntactic.TH where
+
+
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+
+import Language.Haskell.TH
+
+import Data.Hash (hashInt, combine)
+import qualified Data.Hash as Hash
+
+import Language.Syntactic
+
+
+
+-- | Get the name and arity of a constructor
+conName :: Con -> (Name, Int)
+conName (NormalC name args) = (name, length args)
+conName (RecC name args)    = (name, length args)
+conName (InfixC _ name _)   = (name, 2)
+conName (ForallC _ _ c)     = conName c
+#if __GLASGOW_HASKELL__ >= 800
+conName (GadtC [n] as _)    = (n, length as)
+conName (RecGadtC [n] as _) = (n, length as)
+  -- I don't know what it means when a `GadtC` and `RecGadtC` don't have
+  -- singleton lists of names
+#endif
+
+-- | Description of class methods
+data Method
+    = DefaultMethod Name Name
+        -- ^ rhs = lhs
+    | MatchingMethod Name (Con -> Int -> Name -> Int -> Clause) [Clause]
+        -- ^ @MatchingMethod methodName mkClause extraClauses@
+        --
+        -- @mkClause@ takes as arguments (1) a description of the constructor,
+        -- (2) the constructor's index, (3) the constructor's name, and (4) its
+        -- arity.
+
+-- | General method for class deriving
+deriveClass
+    :: Cxt       -- ^ Instance context
+    -> Name      -- ^ Type constructor name
+    -> Type      -- ^ Class head (e.g. @Render Con@)
+    -> [Method]  -- ^ Methods
+    -> DecsQ
+deriveClass cxt ty clHead methods = do
+    Just cs <- viewDataDef <$> reify ty
+    return
+      [ instD cxt clHead $
+          [ FunD method (clauses ++ extra)
+            | MatchingMethod method mkClause extra <- methods
+            , let clauses = [ mkClause c i nm ar | (i,c) <- zip [0..] cs
+                            , let (nm,ar) = conName c
+                            ]
+          ] ++
+          [ FunD rhs [Clause [] (NormalB (VarE lhs)) []]
+            | DefaultMethod rhs lhs <- methods
+          ]
+      ]
+
+-- | General method for class deriving
+deriveClassSimple
+    :: Name      -- ^ Class name
+    -> Name      -- ^ Type constructor name
+    -> [Method]  -- ^ Methods
+    -> DecsQ
+deriveClassSimple cl ty = deriveClass [] ty (AppT (ConT cl) (ConT ty))
+
+varSupply :: [Name]
+varSupply = map mkName $ tail $ concat $ iterate step [[]]
+  where
+    step :: [String] -> [String]
+    step vars = concatMap (\c -> map (c:) vars) ['a' .. 'z']
+
+-- | Derive 'Symbol' instance for a type
+deriveSymbol
+    :: Name  -- ^ Type name
+    -> DecsQ
+deriveSymbol ty =
+    deriveClassSimple ''Symbol ty [MatchingMethod 'symSig  symSigClause []]
+  where
+    symSigClause _ _ con arity =
+      Clause [conPat con (replicate arity WildP)] (NormalB (VarE 'signature)) []
+
+-- | Derive 'Equality' instance for a type
+--
+-- > equal Con1 Con1 = True
+-- > equal (Con2 a1 ... x1) (Con2 a2 ... x2) = and [a1==a2, ... x1==x2]
+-- > equal _ _ = False
+--
+-- > hash Con1           = hashInt 0
+-- > hash (Con2 a ... x) = foldr1 combine [hashInt 1, hash a, ... hash x]
+deriveEquality
+    :: Name  -- ^ Type name
+    -> DecsQ
+deriveEquality ty = do
+    Just cs <- viewDataDef <$> reify ty
+    let equalFallThrough = if length cs > 1
+          then [Clause [WildP, WildP] (NormalB $ ConE 'False) []]
+          else []
+    deriveClassSimple ''Equality ty
+      [ MatchingMethod 'equal equalClause equalFallThrough
+      , MatchingMethod 'hash hashClause []
+      ]
+  where
+    equalClause _ _ con arity = Clause
+        [ conPat con [VarP v | v <- vs1]
+        , conPat con [VarP v | v <- vs2]
+        ]
+        (NormalB body)
+        []
+      where
+        vs1 = take arity varSupply
+        vs2 = take arity $ drop arity varSupply
+
+        body = case arity of
+          0 -> ConE 'True
+          _ -> AppE (VarE 'and)
+                 ( ListE
+                     [ InfixE (Just (VarE v1)) (VarE '(==)) (Just (VarE v2))
+                       | (v1,v2) <- zip vs1 vs2
+                     ]
+                 )
+
+    hashClause _ i con arity = Clause
+        [conPat con [VarP v | v <- vs]]
+        (NormalB body)
+        []
+      where
+        vs = take arity varSupply
+        body = case arity of
+          0 -> AppE (VarE 'hashInt) (LitE (IntegerL (toInteger i)))
+          _ -> foldl1 AppE
+                [ VarE 'foldr1
+                , VarE 'combine
+                , ListE
+                    $ AppE (VarE 'hashInt) (LitE (IntegerL (toInteger i)))
+                    : [ AppE (VarE 'Hash.hash) (VarE v)
+                        | v <- vs
+                      ]
+                ]
+
+-- | Derive 'Render' instance for a type
+--
+-- > renderSym Con1           = "Con1"
+-- > renderSym (Con2 a ... x) = concat ["(", unwords ["Con2", show a, ... show x], ")"]
+deriveRender
+    :: (String -> String)  -- ^ Constructor name modifier
+    -> Name                -- ^ Type name
+    -> DecsQ
+deriveRender modify ty =
+    deriveClassSimple ''Render ty [MatchingMethod 'renderSym renderClause []]
+  where
+    conName = modify . nameBase
+
+    renderClause _ _ con arity = Clause
+        [conPat con [VarP v | v <- take arity varSupply]]
+        (NormalB body)
+        []
+      where
+        body = case arity of
+            0 -> LitE $ StringL $ conName con
+            _ -> renderRHS con $ take arity varSupply
+
+    renderRHS :: Name -> [Name] -> Exp
+    renderRHS con args =
+      AppE (VarE 'concat)
+        ( ListE
+            [ LitE (StringL "(")
+            , AppE (VarE 'unwords)
+                (ListE (LitE (StringL (conName con)) : map showArg args))
+            , LitE (StringL ")")
+            ]
+        )
+
+    showArg :: Name -> Exp
+    showArg arg = AppE (VarE 'show) (VarE arg)
+
+
+
+--------------------------------------------------------------------------------
+-- * Portability
+--------------------------------------------------------------------------------
+
+-- Using `__GLASGOW_HASKELL__` instead of `MIN_VERSION_template_haskell`,
+-- because the latter doesn't work when the package is compiled with `-f-th`.
+
+-- | Construct an instance declaration
+instD
+    :: Cxt    -- ^ Context
+    -> Type   -- ^ Instance
+    -> [Dec]  -- ^ Methods, etc.
+    -> Dec
+#if __GLASGOW_HASKELL__ >= 800
+instD = InstanceD Nothing
+#else
+instD = InstanceD
+#endif
+
+-- | Get the constructors of a data type definition
+viewDataDef :: Info -> Maybe [Con]
+#if __GLASGOW_HASKELL__ >= 800
+viewDataDef (TyConI (DataD _ _ _ _ cs _)) = Just cs
+#else
+viewDataDef (TyConI (DataD _ _ _ cs _)) = Just cs
+#endif
+viewDataDef _ = Nothing
+
+-- | Portable method for constructing a 'Pred' of the form @(t1 ~ t2)@
+eqPred :: Type -> Type -> Pred
+#if __GLASGOW_HASKELL__ >= 710
+eqPred t1 t2 = foldl1 AppT [EqualityT,t1,t2]
+#else
+eqPred = EqualP
+#endif
+
+-- | Portable method for constructing a 'Pred' of the form @SomeClass t1 t2 ...@
+classPred
+    :: Name            -- ^ Class name
+    -> (Name -> Type)  -- ^ How to make a type for the class (typically 'ConT' or 'VarT')
+    -> [Type]          -- ^ Class arguments
+    -> Pred
+#if __GLASGOW_HASKELL__ >= 710
+classPred cl con = foldl AppT (con cl)
+#else
+classPred cl con = ClassP cl
+#endif
+
+-- | Portable method for constructing a type synonym instance
+tySynInst :: Name -> [Type] -> Type -> Dec
+#if __GLASGOW_HASKELL__ >= 808
+tySynInst t as rhs = TySynInstD $
+  TySynEqn Nothing (foldl AppT (ConT t) as) rhs
+#elif __GLASGOW_HASKELL__ >= 708
+tySynInst t as rhs = TySynInstD t (TySynEqn as rhs)
+#else
+tySynInst = TySynInstD
+#endif
+
+conPat :: Name -> [Pat] -> Pat
+#if __GLASGOW_HASKELL__ >= 902
+conPat name ps = ConP name [] ps
+#else
+conPat name ps = ConP name ps
+#endif
+
diff --git a/src/Language/Syntactic/Traversal.hs b/src/Language/Syntactic/Traversal.hs
--- a/src/Language/Syntactic/Traversal.hs
+++ b/src/Language/Syntactic/Traversal.hs
@@ -5,19 +5,21 @@
     , gmapT
     , everywhereUp
     , everywhereDown
+    , universe
     , Args (..)
     , listArgs
     , mapArgs
     , mapArgsA
     , mapArgsM
+    , foldrArgs
     , appArgs
     , listFold
     , match
-    , query
     , simpleMatch
     , fold
     , simpleFold
     , matchTrans
+    , mapAST
     , WrapFull (..)
     , toTree
     ) where
@@ -33,41 +35,49 @@
 
 -- | Map a function over all immediate sub-terms (corresponds to the function
 -- with the same name in Scrap Your Boilerplate)
-gmapT :: forall dom
-      .  (forall a . ASTF dom a -> ASTF dom a)
-      -> (forall a . ASTF dom a -> ASTF dom a)
+gmapT :: forall sym
+      .  (forall a . ASTF sym a -> ASTF sym a)
+      -> (forall a . ASTF sym a -> ASTF sym a)
 gmapT f a = go a
   where
-    go :: forall a . AST dom a -> AST dom a
+    go :: AST sym a -> AST sym a
     go (s :$ a) = go s :$ f a
     go s        = s
 
 -- | Map a function over all immediate sub-terms, collecting the results in a
 -- list (corresponds to the function with the same name in Scrap Your
 -- Boilerplate)
-gmapQ :: forall dom b
-      .  (forall a . ASTF dom a -> b)
-      -> (forall a . ASTF dom a -> [b])
+gmapQ :: forall sym b
+      .  (forall a . ASTF sym a -> b)
+      -> (forall a . ASTF sym a -> [b])
 gmapQ f a = go a
   where
-    go :: forall a . AST dom a -> [b]
+    go :: AST sym a -> [b]
     go (s :$ a) = f a : go s
     go _        = []
 
--- | Apply a transformation bottom-up over an expression (corresponds to
--- @everywhere@ in Scrap Your Boilerplate)
+-- | Apply a transformation bottom-up over an 'AST' (corresponds to @everywhere@ in Scrap Your
+-- Boilerplate)
 everywhereUp
-    :: (forall a . ASTF dom a -> ASTF dom a)
-    -> (forall a . ASTF dom a -> ASTF dom a)
+    :: (forall a . ASTF sym a -> ASTF sym a)
+    -> (forall a . ASTF sym a -> ASTF sym a)
 everywhereUp f = f . gmapT (everywhereUp f)
 
--- | Apply a transformation top-down over an expression (corresponds to
--- @everywhere'@ in Scrap Your Boilerplate)
+-- | Apply a transformation top-down over an 'AST' (corresponds to @everywhere'@ in Scrap Your
+-- Boilerplate)
 everywhereDown
-    :: (forall a . ASTF dom a -> ASTF dom a)
-    -> (forall a . ASTF dom a -> ASTF dom a)
+    :: (forall a . ASTF sym a -> ASTF sym a)
+    -> (forall a . ASTF sym a -> ASTF sym a)
 everywhereDown f = gmapT (everywhereDown f) . f
 
+-- | List all sub-terms (corresponds to @universe@ in Uniplate)
+universe :: ASTF sym a -> [EF (AST sym)]
+universe a = EF a : go a
+  where
+    go :: AST sym a -> [EF (AST sym)]
+    go (Sym s)  = []
+    go (s :$ a) = go s ++ universe a
+
 -- | List of symbol arguments
 data Args c sig
   where
@@ -76,8 +86,7 @@
 
 infixr :*
 
--- | Map a function over an 'Args' list and collect the results in an ordinary
--- list
+-- | Map a function over an 'Args' list and collect the results in an ordinary list
 listArgs :: (forall a . c (Full a) -> b) -> Args c sig -> [b]
 listArgs f Nil       = []
 listArgs f (a :* as) = f a : listArgs f as
@@ -111,71 +120,67 @@
 foldrArgs f b (a :* as) = f a (foldrArgs f b as)
 
 -- | Apply a (partially applied) symbol to a list of argument terms
-appArgs :: AST dom sig -> Args (AST dom) sig -> ASTF dom (DenResult sig)
+appArgs :: AST sym sig -> Args (AST sym) sig -> ASTF sym (DenResult sig)
 appArgs a Nil       = a
 appArgs s (a :* as) = appArgs (s :$ a) as
 
 -- | \"Pattern match\" on an 'AST' using a function that gets direct access to
 -- the top-most symbol and its sub-trees
-match :: forall dom a c
+match :: forall sym a c
     .  ( forall sig . (a ~ DenResult sig) =>
-           dom sig -> Args (AST dom) sig -> c (Full a)
+           sym sig -> Args (AST sym) sig -> c (Full a)
        )
-    -> ASTF dom a
+    -> ASTF sym a
     -> c (Full a)
 match f a = go a Nil
   where
-    go :: (a ~ DenResult sig) => AST dom sig -> Args (AST dom) sig -> c (Full a)
+    go :: (a ~ DenResult sig) => AST sym sig -> Args (AST sym) sig -> c (Full a)
     go (Sym a)  as = f a as
     go (s :$ a) as = go s (a :* as)
 
-query :: forall dom a c
-    .  ( forall sig . (a ~ DenResult sig) =>
-           dom sig -> Args (AST dom) sig -> c (Full a)
-       )
-    -> ASTF dom a
-    -> c (Full a)
-query = match
-{-# DEPRECATED query "Please use `match` instead." #-}
-
 -- | A version of 'match' with a simpler result type
-simpleMatch :: forall dom a b
-    .  (forall sig . (a ~ DenResult sig) => dom sig -> Args (AST dom) sig -> b)
-    -> ASTF dom a
+simpleMatch :: forall sym a b
+    .  (forall sig . (a ~ DenResult sig) => sym sig -> Args (AST sym) sig -> b)
+    -> ASTF sym a
     -> b
 simpleMatch f = getConst . match (\s -> Const . f s)
 
 -- | Fold an 'AST' using an 'Args' list to hold the results of sub-terms
-fold :: forall dom c
-    .  (forall sig . dom sig -> Args c sig -> c (Full (DenResult sig)))
-    -> (forall a   . ASTF dom a -> c (Full a))
+fold :: forall sym c
+    .  (forall sig . sym sig -> Args c sig -> c (Full (DenResult sig)))
+    -> (forall a   . ASTF sym a -> c (Full a))
 fold f = match (\s -> f s . mapArgs (fold f))
 
 -- | Simplified version of 'fold' for situations where all intermediate results
 -- have the same type
-simpleFold :: forall dom b
-    .  (forall sig . dom sig -> Args (Const b) sig -> b)
-    -> (forall a   . ASTF dom a                    -> b)
+simpleFold :: forall sym b
+    .  (forall sig . sym sig -> Args (Const b) sig -> b)
+    -> (forall a   . ASTF sym a                    -> b)
 simpleFold f = getConst . fold (\s -> Const . f s)
 
 -- | Fold an 'AST' using a list to hold the results of sub-terms
-listFold :: forall dom b
-    .  (forall sig . dom sig -> [b] -> b)
-    -> (forall a   . ASTF dom a     -> b)
+listFold :: forall sym b
+    .  (forall sig . sym sig -> [b] -> b)
+    -> (forall a   . ASTF sym a     -> b)
 listFold f = simpleFold (\s -> f s . listArgs getConst)
 
-newtype WrapAST c dom sig = WrapAST { unWrapAST :: c (AST dom sig) }
+newtype WrapAST c sym sig = WrapAST { unWrapAST :: c (AST sym sig) }
   -- Only used in the definition of 'matchTrans'
 
 -- | A version of 'match' where the result is a transformed syntax tree,
 -- wrapped in a type constructor @c@
-matchTrans :: forall dom dom' c a
+matchTrans :: forall sym sym' c a
     .  ( forall sig . (a ~ DenResult sig) =>
-           dom sig -> Args (AST dom) sig -> c (ASTF dom' a)
+           sym sig -> Args (AST sym) sig -> c (ASTF sym' a)
        )
-    -> ASTF dom a
-    -> c (ASTF dom' a)
+    -> ASTF sym a
+    -> c (ASTF sym' a)
 matchTrans f = unWrapAST . match (\s -> WrapAST . f s)
+
+-- | Update the symbols in an AST
+mapAST :: (forall sig' . sym1 sig' -> sym2 sig') -> AST sym1 sig -> AST sym2 sig
+mapAST f (Sym s)  = Sym (f s)
+mapAST f (s :$ a) = mapAST f s :$ mapAST f a
 
 -- | Can be used to make an arbitrary type constructor indexed by @(`Full` a)@.
 -- This is useful as the type constructor parameter of 'Args'. That is, use
diff --git a/syntactic.cabal b/syntactic.cabal
--- a/syntactic.cabal
+++ b/syntactic.cabal
@@ -1,202 +1,196 @@
 Name:           syntactic
-Version:        1.11
-Synopsis:       Generic abstract syntax, and utilities for embedded languages
-Description:    This library provides:
-                .
-                  * Generic representation and manipulation of abstract syntax
-                .
-                  * Composable AST representations (partly based on Data Types à
-                    la Carte [1])
-                .
-                  * A collection of common syntactic constructs, including
-                    variable binding constructs
+Version:        3.8.5
+Synopsis:       Generic representation and manipulation of abstract syntax
+Description:    The library provides a generic representation of type-indexed abstract syntax trees
+                (or indexed data types in general). It also permits the definition of open syntax
+                trees based on the technique in Data Types à la Carte [1].
                 .
-                  * Utilities for analyzing and transforming generic abstract
-                    syntax
+                This package does not work on GHC version 8.2, but works on many
+                earlier and later versions.
                 .
-                  * Utilities for building extensible embedded languages based
-                    on generic syntax
+                (Note that the difference between version 2.x and 3.0 is not that big. The bump to
+                3.0 was done because the modules changed namespace.)
                 .
-                For more information about the core functionality, see
+                For more information, see
                 \"A Generic Abstract Syntax Model for Embedded Languages\"
                 (ICFP 2012):
                 .
                   * Paper:
-                    <http://www.cse.chalmers.se/~emax/documents/axelsson2012generic.pdf>
+                    <https://emilaxelsson.github.io/documents/axelsson2012generic.pdf>
                 .
-                  * Slides:
-                    <http://www.cse.chalmers.se/~emax/documents/axelsson2012generic-slides.pdf>
+                  * Literal source:
+                    <https://emilaxelsson.github.io/documents/axelsson2012generic.lhs>
                 .
-                For a practical example of how to use the library, see the
-                proof-of-concept implementation Feldspar EDSL in the @examples@
-                directory. (The real Feldspar [2] is also implemented using
-                Syntactic.)
+                  * Slides:
+                    <https://emilaxelsson.github.io/documents/axelsson2012generic-slides.pdf>
                 .
-                The maturity of this library varies between different modules.
-                The core part ("Language.Syntactic") is rather stable, but many
-                of the other modules are in a much more experimental state.
+                Example EDSLs can be found in the @examples@ folder.
                 .
                 \[1\] W. Swierstra. Data Types à la Carte.
                 /Journal of Functional Programming/, 18(4):423-436, 2008,
                 <http://dx.doi.org/10.1017/S0956796808006758>.
-                .
-                \[2\] <http://hackage.haskell.org/package/feldspar-language>
 License:        BSD3
 License-file:   LICENSE
 Author:         Emil Axelsson
-Maintainer:     emax@chalmers.se
-Copyright:      Copyright (c) 2011-2014, Emil Axelsson
+Maintainer:     78emil@gmail.com
+Copyright:      Copyright (c) 2011-2015, Emil Axelsson
 Homepage:       https://github.com/emilaxelsson/syntactic
 Bug-reports:    https://github.com/emilaxelsson/syntactic/issues
+Stability:      experimental
 Category:       Language
 Build-type:     Simple
-Cabal-version:  >=1.10
-Tested-with:    GHC==7.6.1, GHC==7.4.2
+Cabal-version:  1.16
 
 extra-source-files:
   CONTRIBUTORS
-  examples/NanoFeldspar/*.hs
+  examples/*.hs
+  tests/*.hs
   tests/gold/*.txt
+  benchmarks/*.hs
 
 source-repository head
   type:     git
   location: https://github.com/emilaxelsson/syntactic
 
+flag th
+  description: Include the module Language.Syntactic.TH, which uses Template
+               Haskell
+  default:     True
+
 library
   exposed-modules:
-    Data.PolyProxy
-    Data.DynamicAlt
     Language.Syntactic
     Language.Syntactic.Syntax
     Language.Syntactic.Traversal
-    Language.Syntactic.Constraint
+    Language.Syntactic.Interpretation
     Language.Syntactic.Sugar
-    Language.Syntactic.Interpretation.Equality
-    Language.Syntactic.Interpretation.Evaluation
-    Language.Syntactic.Interpretation.Render
-    Language.Syntactic.Interpretation.Semantics
-    Language.Syntactic.Constructs.Binding
-    Language.Syntactic.Constructs.Binding.HigherOrder
-    Language.Syntactic.Constructs.Binding.Optimize
-    Language.Syntactic.Constructs.Condition
-    Language.Syntactic.Constructs.Construct
-    Language.Syntactic.Constructs.Decoration
-    Language.Syntactic.Constructs.Identity
-    Language.Syntactic.Constructs.Literal
-    Language.Syntactic.Constructs.Monad
-    Language.Syntactic.Constructs.Tuple
-    Language.Syntactic.Frontend.Monad
-    Language.Syntactic.Frontend.Tuple
-    Language.Syntactic.Frontend.TupleConstrained
-    Language.Syntactic.Sharing.SimpleCodeMotion
-    Language.Syntactic.Sharing.Utils
-    Language.Syntactic.Sharing.Graph
-    Language.Syntactic.Sharing.StableName
-    Language.Syntactic.Sharing.Reify
-    Language.Syntactic.Sharing.ReifyHO
-
-  other-modules:
+    Language.Syntactic.Decoration
+    Language.Syntactic.Functional
+    Language.Syntactic.Functional.Sharing
+    Language.Syntactic.Functional.WellScoped
+    Language.Syntactic.Sugar.Binding
+    Language.Syntactic.Sugar.BindingTyped
+    Language.Syntactic.Sugar.Monad
+    Language.Syntactic.Sugar.MonadTyped
+  if flag(th)
+    exposed-modules:
+      Data.NestTuple
+      Data.NestTuple.TH
+      Language.Syntactic.TH
+      Language.Syntactic.Functional.Tuple
+      Language.Syntactic.Functional.Tuple.TH
+      Language.Syntactic.Sugar.Tuple
+      Language.Syntactic.Sugar.TupleTyped
 
   build-depends:
-    array,
-    base >= 4 && < 4.8,
-    containers,
-    constraints,
-    data-hash,
-    ghc-prim,
-    mtl >= 2 && < 3,
-    template-haskell,
-    transformers >= 0.2,
-    tree-view,
-    tuple >= 0.2
+    base >= 4.6 && < 4.22,
+    constraints < 0.15,
+    containers < 0.9,
+    data-hash < 0.3,
+    deepseq < 1.6,
+    mtl >= 2 && < 2.4,
+    syb < 0.8,
+    tree-view >= 0.5 && < 0.6
 
+  if impl(ghc == 8.2.*)
+    build-depends: base<0
+    -- See the note to the catch-all instance of `BindingDomain`. Since this can
+    -- lead to subtle errors and non-termination in user code, we prefer not to
+    -- support GHC 8.2.
+
+  if impl(ghc < 7.10)
+    build-depends: base-orphans
+
+  if impl(ghc < 7.8)
+    build-depends: tagged
+
+  if flag(th)
+    build-depends: template-haskell
+
   hs-source-dirs: src
 
   default-language: Haskell2010
 
   default-extensions:
-    ConstraintKinds
+    DefaultSignatures
     DeriveDataTypeable
     DeriveFunctor
+    DeriveFoldable
+    DeriveTraversable
     FlexibleContexts
     FlexibleInstances
     FunctionalDependencies
     GADTs
     GeneralizedNewtypeDeriving
-    Rank2Types
+    RankNTypes
+    RecordWildCards
     ScopedTypeVariables
-    StandaloneDeriving
     TypeFamilies
     TypeOperators
-    ViewPatterns
 
   other-extensions:
-    -- Not understood by Cabal: PolyKinds
     OverlappingInstances
     UndecidableInstances
 
-test-suite NanoFeldsparEval
+test-suite examples
   type: exitcode-stdio-1.0
 
   hs-source-dirs: tests examples
 
-  main-is: NanoFeldsparEval.hs
+  main-is: Tests.hs
 
-  other-modules:
+  other-modules: AlgorithmTests
+                 Monad
+                 MonadTests
+                 NanoFeldspar
+                 NanoFeldsparComp
+                 NanoFeldsparTests
+                 SyntaxTests
+                 TH
+                 WellScoped
+                 WellScopedTests
 
   default-language: Haskell2010
 
-  default-extensions:
-    FlexibleContexts
-    FlexibleInstances
-    GADTs
-    MultiParamTypeClasses
-    ScopedTypeVariables
-    TypeFamilies
-    TypeOperators
-    UndecidableInstances
-    ViewPatterns
-
-  other-extensions:
-    TemplateHaskell
-
   build-depends:
     syntactic,
     base,
-    mtl >= 2 && < 3,
-    QuickCheck >= 2.4 && < 3,
+    containers,
+    mtl,
+    QuickCheck,
+    tagged,
     tasty,
+    tasty-hunit,
+    tasty-golden,
+    tasty-quickcheck,
     tasty-th,
-    tasty-quickcheck
+    utf8-string
 
-test-suite NanoFeldsparTree
+benchmark syntactic-bench
   type: exitcode-stdio-1.0
 
-  hs-source-dirs: tests examples
+  hs-source-dirs: benchmarks
 
-  main-is: NanoFeldsparTree.hs
+  main-is: MainBenchmark.hs
 
+  other-modules: JoiningTypes
+                 Normal
+                 WithArity
+
+  build-depends:
+    base,
+    criterion >= 1,
+    deepseq,
+    syntactic
+
   default-language: Haskell2010
 
   default-extensions:
-    FlexibleContexts
     FlexibleInstances
     GADTs
     MultiParamTypeClasses
-    ScopedTypeVariables
-    TypeFamilies
     TypeOperators
-    UndecidableInstances
-    ViewPatterns
 
   other-extensions:
     TemplateHaskell
 
-  build-depends:
-    syntactic,
-    base,
-    bytestring,
-    mtl >= 2 && < 3,
-    tasty,
-    tasty-golden,
-    utf8-string
diff --git a/tests/AlgorithmTests.hs b/tests/AlgorithmTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/AlgorithmTests.hs
@@ -0,0 +1,243 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+
+module AlgorithmTests where
+
+
+
+import Data.List
+import qualified Data.Set as Set
+import Data.Dynamic
+
+import Language.Syntactic
+import Language.Syntactic.TH
+import Language.Syntactic.Functional
+import Language.Syntactic.Functional.Sharing
+
+import Test.QuickCheck
+
+import Test.Tasty.QuickCheck
+import Test.Tasty.TH
+
+
+
+subCap :: (Num a, Ord a) => a -> a -> a
+subCap a b = max 0 (a - b)
+
+data Sym sig
+  where
+    Int   :: Int -> Sym (Full Int)
+    Neg   :: Sym (Full (Int -> Int))
+    Add   :: Sym (Full (Int -> Int -> Int))
+    App1  :: Sym ((Int -> Int) :-> Int :-> Full Int)
+    App2  :: Sym ((Int -> Int -> Int) :-> Int :-> Int :-> Full Int)
+    App3  :: Sym ((Int -> Int -> Int -> Int) :-> Int :-> Int :-> Int :-> Full Int)
+
+deriveSymbol    ''Sym
+deriveRender id ''Sym
+deriveEquality  ''Sym
+
+instance StringTree Sym
+instance EvalEnv Sym env
+
+instance Eval Sym
+  where
+    evalSym (Int i) = i
+    evalSym Neg     = negate
+    evalSym Add     = (+)
+    evalSym App1    = ($)
+    evalSym App2    = \f a b -> f a b
+    evalSym App3    = \f a b c -> f a b c
+
+type Dom = Typed (BindingT :+: Let :+: Sym)
+
+type Exp a = ASTF Dom a
+
+int :: Int -> Exp Int
+int = sugarSymTyped . Int
+
+neg :: Exp Int -> Exp Int
+neg = app1 (sugarSymTyped Neg)
+
+add :: Exp Int -> Exp Int -> Exp Int
+add = app2 (sugarSymTyped Add)
+
+app1 :: Exp (Int -> Int) -> Exp Int -> Exp Int
+app1 = sugarSymTyped App1
+
+app2 :: Exp (Int -> Int -> Int) -> Exp Int -> Exp Int -> Exp Int
+app2 = sugarSymTyped App2
+
+app3 :: Exp (Int -> Int -> Int -> Int) -> Exp Int -> Exp Int -> Exp Int -> Exp Int
+app3 = sugarSymTyped App3
+
+varr :: Name -> Exp Int
+varr = sugarSymTyped . VarT
+
+lamm :: Typeable a => Name -> Exp a -> Exp (Int -> a)
+lamm v = sugarSymTyped (LamT v)
+
+
+
+-- | Return a 'Name' not in the given list
+notIn :: [Name] -> Name
+notIn = go 0 . sort
+  where
+    go prev [] = prev+1
+    go prev (n:ns)
+        | n > prev+1 = prev+1
+        | otherwise  = go n ns
+
+-- | Generate a variable name
+genVar
+    :: Int     -- ^ Frequency for bound
+    -> Int     -- ^ Frequency for free
+    -> [Name]  -- ^ Names in scope
+    -> Gen Name
+genVar fb ff inScope = fmap fromIntegral $ frequency
+    [ (fb, elements (0:inScope))
+    , (ff, return $ notIn inScope)
+    ]
+
+genExp :: Int -> [Name] -> Gen (ASTF Dom Int)
+genExp s _ | s < 0 = error (show s)
+genExp s inScope = frequency
+    [ (1, fmap int arbitrary)
+    , (1, fmap varr $ genVar 1 1 inScope)
+    , (s, do a <- genExp (s `subCap` 1) inScope
+             return $ neg a
+      )
+    , (s, do a <- genExp (s `div` 2) inScope
+             b <- genExp (s `div` 2) inScope
+             return $ add a b
+      )
+    , (s, do f <- genExp1 (s `div` 2) inScope
+             a <- genExp (s `div` 2) inScope
+             return $ app1 f a
+      )
+    , (s, do f <- genExp2 (s `div` 3) inScope
+             a <- genExp (s `div` 3) inScope
+             b <- genExp (s `div` 3) inScope
+             return $ app2 f a b
+      )
+    , (s, do f <- genExp3 (s `div` 4) inScope
+             a <- genExp (s `div` 4) inScope
+             b <- genExp (s `div` 4) inScope
+             c <- genExp (s `div` 4) inScope
+             return $ app3 f a b c
+      )
+    ]
+
+genExp1 :: Int -> [Name] -> Gen (ASTF Dom (Int -> Int))
+genExp1 s inScope = do
+    v    <- genVar 1 2 inScope
+    body <- genExp (s `subCap` 1) (v:inScope)
+    return $ lamm v body
+
+genExp2 :: Int -> [Name] -> Gen (ASTF Dom (Int -> Int -> Int))
+genExp2 s inScope = do
+    v1   <- genVar 1 2 inScope
+    v2   <- genVar 1 2 (v1:inScope)
+    body <- genExp (s `subCap` 2) (v2:v1:inScope)
+    return $ lamm v1 $ lamm v2 body
+
+genExp3 :: Int -> [Name] -> Gen (ASTF Dom (Int -> Int -> Int -> Int))
+genExp3 s inScope = do
+    v1   <- genVar 1 2 inScope
+    v2   <- genVar 1 2 (v1:inScope)
+    v3   <- genVar 1 2 (v2:v1:inScope)
+    body <- genExp (s `subCap` 3) (v3:v2:v1:inScope)
+    return $ lamm v1 $ lamm v2 $ lamm v3 body
+
+shrinkExp :: AST Dom sig -> [AST Dom sig]
+shrinkExp s
+    | Just (Int i) <- prj s = map int $ shrink i
+shrinkExp (Sym (Typed lam) :$ body)
+    | Just (LamT v) <- prj lam = [sugarSymTyped (LamT v) b | b <- shrinkExp body]
+shrinkExp (app1 :$ f :$ a)
+    | Just App1 <- prj app1 = concat
+        [ case f of
+            lam :$ body | Just (LamT _) <- prj lam -> [body]
+            _ -> []
+        , [a]
+        , [ sugarSymTyped App1 f' a' | (f',a') <- shrink (f,a) ]
+        ]
+shrinkExp (app2 :$ f :$ a :$ b)
+    | Just App2 <- prj app2 = concat
+        [ case f of
+            lam1 :$ (lam2 :$ body)
+                | Just (LamT _) <- prj lam1
+                , Just (LamT _) <- prj lam2
+                -> [body]
+            _ -> []
+        , [a,b]
+        , [ sugarSymTyped App2 f' a' b' | (f',a',b') <- shrink (f,a,b) ]
+        ]
+shrinkExp (app3 :$ f :$ a :$ b :$ c)
+    | Just App3 <- prj app3 = concat
+        [ case f of
+            lam1 :$ (lam2 :$ (lam3 :$ body))
+                | Just (LamT _) <- prj lam1
+                , Just (LamT _) <- prj lam2
+                , Just (LamT _) <- prj lam3
+                -> [body]
+            _ -> []
+        , [a,b,c]
+        , [ sugarSymTyped App3 f' a' b' c' | (f',a',b',c') <- shrink (f,a,b,c) ]
+        ]
+shrinkExp _ = []
+
+instance Arbitrary (Exp Int)
+  where
+    arbitrary = sized $ \s -> genExp s []
+    shrink = shrinkExp
+
+instance Arbitrary (Exp (Int -> Int))
+  where
+    arbitrary = sized $ \s -> genExp1 s []
+    shrink = shrinkExp
+
+instance Arbitrary (Exp (Int -> Int -> Int))
+  where
+    arbitrary = sized $ \s -> genExp2 s []
+    shrink = shrinkExp
+
+instance Arbitrary (Exp (Int -> Int -> Int -> Int))
+  where
+    arbitrary = sized $ \s -> genExp3 s []
+    shrink = shrinkExp
+
+prop_freeVars (a :: Exp Int) = freeVars a `Set.isSubsetOf` allVars a
+
+prop_alphaEq_refl (a :: Exp Int) = alphaEq a a
+
+prop_alphaEq_rename (a :: Exp Int) = alphaEq a (renameUnique a)
+
+evalAny :: Exp Int -> Int
+evalAny a = evalOpen env a
+  where
+    fv  = freeVars a
+    env = zip (Set.toList fv) (map toDyn [(100 :: Int), 110 ..])
+
+prop_renameUnique_vars (a :: Exp Int) = freeVars a == freeVars (renameUnique a)
+prop_renameUnique_eval (a :: Exp Int) = evalAny a == evalAny (renameUnique a)
+
+cm :: Exp a -> Exp a
+cm = codeMotion $ defaultInterface VarT LamT (\_ _ -> True) (\_ -> True)
+
+prop_codeMotion_vars (a :: Exp Int) = freeVars a == freeVars (cm a)
+prop_codeMotion_eval (a :: Exp Int) = evalAny a == evalAny (cm a)
+
+prop_bug1 = prop_codeMotion_eval exp
+  where
+    exp = add
+        (app2 (lamm 0 (lamm 0 (varr 1))) (int 0) (int 0))
+        (app2 (lamm 1 (lamm 2 (varr 1))) (int 0) (int 0))
+
+
+tests = $testGroupGenerator
+
diff --git a/tests/MonadTests.hs b/tests/MonadTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/MonadTests.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module MonadTests where
+
+
+
+import Test.Tasty
+import Test.Tasty.Golden
+
+import Data.ByteString.Lazy.UTF8 (fromString)
+
+import Language.Syntactic
+import qualified Monad
+
+
+
+mkGold_ex1 = writeFile "tests/gold/ex1_Monad.txt" $ showAST $ desugar Monad.ex1
+
+tests = testGroup "MonadTests"
+    [ goldenVsString "ex1 tree" "tests/gold/ex1_Monad.txt" $ return $ fromString $ showAST $ desugar Monad.ex1
+    ]
+
+main = defaultMain tests
+
diff --git a/tests/NanoFeldsparEval.hs b/tests/NanoFeldsparEval.hs
deleted file mode 100644
--- a/tests/NanoFeldsparEval.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-import Test.Tasty
-import Test.Tasty.TH
-import Test.Tasty.QuickCheck
-
-import NanoFeldspar.Core (eval)
-import NanoFeldspar.Test
-
-
-
-prop_scProd a b = eval scProd a' b' == ref a' b'
-  where
-    a' = take 20 a
-    b' = take 20 b
-    ref a b = sum (zipWith (*) a b)
-
-prop_1 a b = eval prog1 a' b == ref a' b
-  where
-    a' = a `mod` 20
-    ref a b = [min (i+3) b | i <- [0..a-1]]
-
-prop_2 a = eval prog2 a == ref a
-  where
-    ref a = max (min a a) (min a a)
-
-prop_3 a b = eval prog3 a b' == ref a b'
-  where
-    b' = a - (b `mod` 20)
-    ref a b = sum [l .. u]
-      where
-        l = min a b
-        u = max a b
-
-prop_4 a = eval prog4 a' == ref a'
-  where
-    a' = a `mod` 20
-    ref a = [(a+a)*i | i <- [0..a-1]]
-
-prop_5 a = eval prog5 a == ref a
-  where
-    ref a = let (b,c) = (a*2,a*3) in (b-c)*(c-b)
-
-prop_6 = eval prog6 == ref
-  where
-    ref = as!!1 + sum as + sum as
-      where
-        as = map (*2) [1..20]
-
-prop_8 a = eval prog8 a == ref a
-  where
-    ref a = [a .. a+9]
-
-
-
-main = $(defaultMainGenerator)
-
diff --git a/tests/NanoFeldsparTests.hs b/tests/NanoFeldsparTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/NanoFeldsparTests.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module NanoFeldsparTests where
+
+
+
+import Control.Monad
+import Data.List
+
+import Test.QuickCheck
+import Test.Tasty
+import Test.Tasty.Golden
+import Test.Tasty.QuickCheck
+
+import Data.ByteString.Lazy.UTF8 (fromString)
+
+import Language.Syntactic
+import Language.Syntactic.Functional
+import Language.Syntactic.Functional.Sharing
+import qualified NanoFeldspar as Nano
+import qualified NanoFeldsparComp as Nano
+
+
+
+-- | Evaluate after code motion. Used to test that 'codeMotion' doesn't change
+-- semantics.
+evalCM :: (Syntactic a, Domain a ~ Nano.FeldDomain) => a -> Internal a
+evalCM = evalClosed . codeMotion Nano.cmInterface . desugar
+
+fib :: Int -> Int
+fib n = fibs !! n
+  where
+    fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
+
+prop_fib (NonNegative (Small n))   = fib n == Nano.eval Nano.fib n
+prop_fibCM (NonNegative (Small n)) = fib n == evalCM Nano.fib n
+
+spanVec :: [Int] -> Int
+spanVec as = maximum as - minimum as
+
+prop_spanVec (NonEmpty as)   = spanVec as == Nano.eval Nano.spanVec as
+prop_spanVecCM (NonEmpty as) = spanVec as == evalCM Nano.spanVec as
+
+scProd :: [Float] -> [Float] -> Float
+scProd as bs = sum $ zipWith (*) as bs
+
+prop_scProd as bs   = scProd as bs == Nano.eval Nano.scProd as bs
+prop_scProdCM as bs = scProd as bs == evalCM Nano.scProd as bs
+
+genMat :: Gen [[Float]]
+genMat = sized $ \s -> do
+    x <- liftM succ $ choose (0, s `mod` 10)
+    y <- liftM succ $ choose (0, s `mod` 10)
+    replicateM y $ vector x
+
+forEach = flip map
+
+matMul :: [[Float]] -> [[Float]] -> [[Float]]
+matMul a b = forEach a $ \a' ->
+               forEach (transpose b) $ \b' ->
+                 scProd a' b'
+
+prop_matMul =
+    forAll genMat $ \a ->
+      forAll genMat $ \b ->
+        matMul a b == Nano.eval Nano.matMul a b
+
+prop_matMulCM =
+    forAll genMat $ \a ->
+      forAll genMat $ \b ->
+        matMul a b == evalCM Nano.matMul a b
+
+alphaRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a
+alphaRename = mapAST rename
+  where
+    rename :: Nano.FeldDomain a -> Nano.FeldDomain a
+    rename (Typed s)
+        | Just (VarT v) <- prj s = Typed $ inj (VarT (v+1))
+        | Just (LamT v) <- prj s = Typed $ inj (LamT (v+1))
+        | otherwise = Typed s
+
+badRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a
+badRename = mapAST rename
+  where
+    rename :: Nano.FeldDomain a -> Nano.FeldDomain a
+    rename (Typed s)
+        | Just (VarT v) <- prj s = Typed $ inj (VarT (v+1))
+        | Just (LamT v) <- prj s = Typed $ inj (LamT (v-1))
+        | otherwise = Typed s
+
+prop_alphaEq a = alphaEq a (alphaRename a)
+
+prop_alphaEqBad a = alphaEq a (badRename a)
+
+tests = testGroup "NanoFeldsparTests"
+    [ goldenVsString "fib tree"     "tests/gold/fib.txt"     $ return $ fromString $ Nano.showAST Nano.fib
+    , goldenVsString "spanVec tree" "tests/gold/spanVec.txt" $ return $ fromString $ Nano.showAST Nano.spanVec
+    , goldenVsString "scProd tree"  "tests/gold/scProd.txt"  $ return $ fromString $ Nano.showAST Nano.scProd
+    , goldenVsString "matMul tree"  "tests/gold/matMul.txt"  $ return $ fromString $ Nano.showAST Nano.matMul
+
+    , goldenVsString "fib comp"     "tests/gold/fib.comp"     $ return $ fromString $ Nano.compile Nano.fib
+    , goldenVsString "spanVec comp" "tests/gold/spanVec.comp" $ return $ fromString $ Nano.compile Nano.spanVec
+    , goldenVsString "scProd comp"  "tests/gold/scProd.comp"  $ return $ fromString $ Nano.compile Nano.scProd
+    , goldenVsString "matMul comp"  "tests/gold/matMul.comp"  $ return $ fromString $ Nano.compile Nano.matMul
+
+    , testProperty "fib eval"     prop_fib
+    , testProperty "spanVec eval" prop_spanVec
+    , testProperty "scProd eval"  prop_scProd
+    , testProperty "matMul eval"  prop_matMul
+
+    , testProperty "fib evalCM"    prop_fibCM
+    , testProperty "scProd evalCM" prop_scProdCM
+    , testProperty "matMul evalCM" prop_matMulCM
+
+    , testProperty "alphaEq scProd"        (prop_alphaEq (desugar Nano.scProd))
+    , testProperty "alphaEq matMul"        (prop_alphaEq (desugar Nano.matMul))
+    , testProperty "alphaEq scProd matMul" (not (alphaEq (desugar Nano.scProd) (desugar Nano.matMul)))
+    , testProperty "alphaEqBad scProd"     (not (prop_alphaEqBad (desugar Nano.scProd)))
+    , testProperty "alphaEqBad matMul"     (not (prop_alphaEqBad (desugar Nano.matMul)))
+    ]
+
+main = defaultMain tests
+
diff --git a/tests/NanoFeldsparTree.hs b/tests/NanoFeldsparTree.hs
deleted file mode 100644
--- a/tests/NanoFeldsparTree.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-import Test.Tasty
-import Test.Tasty.Golden
-
-import Data.ByteString.Lazy.UTF8 (fromString)
-
-import NanoFeldspar.Core (showAST)
-import NanoFeldspar.Test
-
-
-
-mkGold_scProd = writeFile "tests/gold/scProd.txt" $ showAST scProd
-mkGold_matMul = writeFile "tests/gold/matMul.txt" $ showAST matMul
-mkGold_prog1  = writeFile "tests/gold/prog1.txt"  $ showAST prog1
-mkGold_prog2  = writeFile "tests/gold/prog2.txt"  $ showAST prog2
-mkGold_prog3  = writeFile "tests/gold/prog3.txt"  $ showAST prog3
-mkGold_prog4  = writeFile "tests/gold/prog4.txt"  $ showAST prog4
-mkGold_prog5  = writeFile "tests/gold/prog5.txt"  $ showAST prog5
-mkGold_prog6  = writeFile "tests/gold/prog6.txt"  $ showAST prog6
-mkGold_prog7  = writeFile "tests/gold/prog7.txt"  $ showAST prog7
-mkGold_prog8  = writeFile "tests/gold/prog8.txt"  $ showAST prog8
-
-tests = testGroup "TreeTests"
-    [ goldenVsString "scProd" "tests/gold/scProd.txt" $ return $ fromString $ showAST scProd
-    , goldenVsString "matMul" "tests/gold/matMul.txt" $ return $ fromString $ showAST matMul
-    , goldenVsString "prog1"  "tests/gold/prog1.txt"  $ return $ fromString $ showAST prog1
-    , goldenVsString "prog2"  "tests/gold/prog2.txt"  $ return $ fromString $ showAST prog2
-    , goldenVsString "prog3"  "tests/gold/prog3.txt"  $ return $ fromString $ showAST prog3
-    , goldenVsString "prog4"  "tests/gold/prog4.txt"  $ return $ fromString $ showAST prog4
-    , goldenVsString "prog5"  "tests/gold/prog5.txt"  $ return $ fromString $ showAST prog5
-    , goldenVsString "prog6"  "tests/gold/prog6.txt"  $ return $ fromString $ showAST prog6
-    , goldenVsString "prog7"  "tests/gold/prog7.txt"  $ return $ fromString $ showAST prog7
-    , goldenVsString "prog8"  "tests/gold/prog8.txt"  $ return $ fromString $ showAST prog8
-    ]
-
-main = defaultMain tests
-
diff --git a/tests/SyntaxTests.hs b/tests/SyntaxTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/SyntaxTests.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+module SyntaxTests where
+
+import Data.Maybe
+import Language.Syntactic
+import Language.Syntactic.TH
+import Test.Tasty
+import Test.Tasty.HUnit
+
+data A sig
+  where
+    A1 :: Int -> A (Full Int)
+    A2 :: A (Int :-> Full Int)
+
+deriving instance Eq (A sig)
+deriving instance Show (A sig)
+
+data B sig
+  where
+    B1 :: Char -> B (Full Char)
+
+deriving instance Eq (B sig)
+deriving instance Show (B sig)
+
+data C sig
+  where
+    C1 :: C (Full ())
+    C2 :: C (Int :-> Int :-> Full Int)
+
+deriving instance Eq (C sig)
+deriving instance Show (C sig)
+
+type Dom = A :+: B :+: C
+
+type Exp a = ASTF Dom a
+
+a1 :: Int -> Exp Int
+a1 = inj . A1
+
+a2 :: Exp Int -> Exp Int
+a2 a = inj A2 :$ a
+
+b1 :: Char -> Exp Char
+b1 = inj . B1
+
+c1 :: Exp ()
+c1 = inj $ C1
+
+c2 :: Exp Int -> Exp Int -> Exp Int
+c2 a b = inj C2 :$ a :$ b
+
+tests = testGroup "SyntaxTests"
+  [
+    testCase "project first domain entry 1" $ prj (a1 5)      @?= Just (A1 5)
+  , testCase "project first domain entry 2" $ prj (a2 (a1 1)) @?= (Nothing :: Maybe (A (Full Int)))
+  , testCase "project second domain entry"  $ prj (b1 'b')    @?= Just (B1 'b')
+  , testCase "project third domain entry 1" $ prj (c1)        @?= Just C1
+  , testCase "project third domain entry 2" $ prj (c2 (a1 3) (a2 (a1 9))) @?= (Nothing :: Maybe (C (Full Int)))
+  ]
diff --git a/tests/TH.hs b/tests/TH.hs
new file mode 100644
--- /dev/null
+++ b/tests/TH.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+
+module TH where
+
+
+
+import Data.List (nub)
+
+import Language.Syntactic
+import Language.Syntactic.TH
+
+
+
+data Sym sig
+  where
+    A :: Int -> Bool -> Sym (a :-> a :-> Full a)
+    B :: Sym (Full Bool)
+    C :: String -> Sym (a :-> Int :-> Full a)
+
+deriveSymbol    ''Sym
+deriveEquality  ''Sym
+deriveRender id ''Sym
+
+tests =
+    [ equal B B
+    , equal (A 5 True) (A 5 True)
+    , equal (C "syntactic") (C "syntactic")
+    , not $ equal (A 5 True) (A 6 True)
+    , not $ equal (A 5 True) (C "c")
+    , hashes == nub hashes
+    , renderSym (A 5 True) == "(A 5 True)"
+    ]
+  where
+    hashes =
+        [ hash $ A 5 True
+        , hash $ B
+        , hash $ C "a"
+        , hash $ A 6 True
+        , hash $ C "b"
+        ]
+
+main :: IO ()
+main = if and tests
+    then return ()
+    else error "TH tests failed"
+
diff --git a/tests/Tests.hs b/tests/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Tests.hs
@@ -0,0 +1,21 @@
+import Test.Tasty
+
+import qualified AlgorithmTests
+import qualified NanoFeldsparTests
+import qualified WellScopedTests
+import qualified MonadTests
+import qualified SyntaxTests
+import qualified TH
+
+tests = testGroup "AllTests"
+    [ SyntaxTests.tests
+    , AlgorithmTests.tests
+    , NanoFeldsparTests.tests
+    , WellScopedTests.tests
+    , MonadTests.tests
+    ]
+
+main = do
+    TH.main
+    defaultMain tests
+
diff --git a/tests/WellScopedTests.hs b/tests/WellScopedTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/WellScopedTests.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module WellScopedTests where
+
+
+
+import Test.Tasty
+import Test.Tasty.Golden
+import Test.Tasty.QuickCheck
+
+import Data.ByteString.Lazy.UTF8 (fromString)
+
+import Language.Syntactic
+import Language.Syntactic.Functional.WellScoped
+import qualified WellScoped as WS
+
+
+
+ex1 a = let b = a+4 in let c = a+b in a+b+c
+
+prop_ex1 a = ex1 a == evalClosedWS WS.ex1 a
+
+mkGold_ex1 = writeFile "tests/gold/ex1_WS.txt" $ showAST $ fromWS WS.ex1
+
+tests = testGroup "WellScopedTests"
+    [ goldenVsString "ex1 tree" "tests/gold/ex1_WS.txt" $ return $ fromString $ showAST $ fromWS WS.ex1
+    , testProperty   "ex1" prop_ex1
+    ]
+
+main = defaultMain tests
+
diff --git a/tests/gold/ex1_Monad.txt b/tests/gold/ex1_Monad.txt
new file mode 100644
--- /dev/null
+++ b/tests/gold/ex1_Monad.txt
@@ -0,0 +1,18 @@
+Lam v3
+ └╴(>>=)
+    ├╴iter
+    │  ├╴v3
+    │  └╴(>>=)
+    │     ├╴getDigit
+    │     └╴Lam v2
+    │        └╴(>>=)
+    │           ├╴putDigit
+    │           │  └╴(+)
+    │           │     ├╴v2
+    │           │     └╴v2
+    │           └╴Lam v1
+    │              └╴return
+    │                 └╴v1
+    └╴Lam v1
+       └╴return
+          └╴v1
diff --git a/tests/gold/ex1_WS.txt b/tests/gold/ex1_WS.txt
new file mode 100644
--- /dev/null
+++ b/tests/gold/ex1_WS.txt
@@ -0,0 +1,14 @@
+Lam v3
+ └╴Let v2
+    ├╴(+)
+    │  ├╴v3
+    │  └╴4
+    └╴Let v1
+       ├╴(+)
+       │  ├╴v3
+       │  └╴v2
+       └╴(+)
+          ├╴(+)
+          │  ├╴v3
+          │  └╴v2
+          └╴v1
diff --git a/tests/gold/fib.txt b/tests/gold/fib.txt
new file mode 100644
--- /dev/null
+++ b/tests/gold/fib.txt
@@ -0,0 +1,17 @@
+Lam v3
+ └╴Fst
+    └╴ForLoop
+       ├╴v3
+       ├╴Pair
+       │  ├╴0
+       │  └╴1
+       └╴Lam v2
+          └╴Lam v1
+             └╴Pair
+                ├╴Snd
+                │  └╴v1
+                └╴(+)
+                   ├╴Fst
+                   │  └╴v1
+                   └╴Snd
+                      └╴v1
diff --git a/tests/gold/matMul.txt b/tests/gold/matMul.txt
--- a/tests/gold/matMul.txt
+++ b/tests/gold/matMul.txt
@@ -1,44 +1,38 @@
-Lambda 0
- └╴Lambda 1
-    └╴Let 6
-       ├╴arrLength
-       │  └╴getIx
-       │     ├╴var:1
-       │     └╴0
-       └╴Let 7
-          ├╴arrLength
-          │  └╴var:1
-          └╴parallel
-             ├╴arrLength
-             │  └╴var:0
-             └╴Lambda 2
-                └╴Let 8
-                   ├╴min
-                   │  ├╴arrLength
-                   │  │  └╴getIx
-                   │  │     ├╴var:0
-                   │  │     └╴var:2
-                   │  └╴var:7
-                   └╴Let 9
-                      ├╴getIx
-                      │  ├╴var:0
-                      │  └╴var:2
-                      └╴parallel
-                         ├╴var:6
-                         └╴Lambda 3
-                            └╴forLoop
-                               ├╴var:8
-                               ├╴0.0
-                               └╴Lambda 4
-                                  └╴Lambda 5
-                                     └╴(+)
-                                        ├╴(*)
-                                        │  ├╴getIx
-                                        │  │  ├╴var:9
-                                        │  │  └╴var:4
-                                        │  └╴getIx
-                                        │     ├╴getIx
-                                        │     │  ├╴var:1
-                                        │     │  └╴var:4
-                                        │     └╴var:3
-                                        └╴var:5
+Lam v6
+ └╴Lam v5
+    └╴Parallel
+       ├╴arrLen
+       │  └╴v6
+       └╴Lam v4
+          └╴Let v7
+             ├╴min
+             │  ├╴arrLen
+             │  │  └╴arrIx
+             │  │     ├╴v6
+             │  │     └╴v4
+             │  └╴arrLen
+             │     └╴v5
+             └╴Parallel
+                ├╴arrLen
+                │  └╴arrIx
+                │     ├╴v5
+                │     └╴0
+                └╴Lam v3
+                   └╴ForLoop
+                      ├╴v7
+                      ├╴0.0
+                      └╴Lam v2
+                         └╴Lam v1
+                            └╴(+)
+                               ├╴(*)
+                               │  ├╴arrIx
+                               │  │  ├╴arrIx
+                               │  │  │  ├╴v6
+                               │  │  │  └╴v4
+                               │  │  └╴v2
+                               │  └╴arrIx
+                               │     ├╴arrIx
+                               │     │  ├╴v5
+                               │     │  └╴v2
+                               │     └╴v3
+                               └╴v1
diff --git a/tests/gold/prog1.txt b/tests/gold/prog1.txt
deleted file mode 100644
--- a/tests/gold/prog1.txt
+++ /dev/null
@@ -1,10 +0,0 @@
-Lambda 0
- └╴Lambda 1
-    └╴parallel
-       ├╴var:0
-       └╴Lambda 2
-          └╴min
-             ├╴(+)
-             │  ├╴var:2
-             │  └╴3
-             └╴var:1
diff --git a/tests/gold/prog2.txt b/tests/gold/prog2.txt
deleted file mode 100644
--- a/tests/gold/prog2.txt
+++ /dev/null
@@ -1,8 +0,0 @@
-Lambda 0
- └╴Let 1
-    ├╴min
-    │  ├╴var:0
-    │  └╴var:0
-    └╴max
-       ├╴var:1
-       └╴var:1
diff --git a/tests/gold/prog3.txt b/tests/gold/prog3.txt
deleted file mode 100644
--- a/tests/gold/prog3.txt
+++ /dev/null
@@ -1,30 +0,0 @@
-Lambda 0
- └╴Lambda 1
-    └╴Let 4
-       ├╴(+)
-       │  ├╴(-)
-       │  │  ├╴max
-       │  │  │  ├╴var:0
-       │  │  │  └╴var:1
-       │  │  └╴min
-       │  │     ├╴var:0
-       │  │     └╴var:1
-       │  └╴1
-       └╴Let 5
-          ├╴min
-          │  ├╴var:0
-          │  └╴var:1
-          └╴forLoop
-             ├╴var:4
-             ├╴0
-             └╴Lambda 2
-                └╴Lambda 3
-                   └╴(+)
-                      ├╴(+)
-                      │  ├╴(-)
-                      │  │  ├╴(-)
-                      │  │  │  ├╴var:4
-                      │  │  │  └╴var:2
-                      │  │  └╴1
-                      │  └╴var:5
-                      └╴var:3
diff --git a/tests/gold/prog4.txt b/tests/gold/prog4.txt
deleted file mode 100644
--- a/tests/gold/prog4.txt
+++ /dev/null
@@ -1,11 +0,0 @@
-Lambda 0
- └╴Let 2
-    ├╴(+)
-    │  ├╴var:0
-    │  └╴var:0
-    └╴parallel
-       ├╴var:0
-       └╴Lambda 1
-          └╴(*)
-             ├╴var:2
-             └╴var:1
diff --git a/tests/gold/prog5.txt b/tests/gold/prog5.txt
deleted file mode 100644
--- a/tests/gold/prog5.txt
+++ /dev/null
@@ -1,22 +0,0 @@
-Lambda 0
- └╴Let 1
-    ├╴tup2
-    │  ├╴(*)
-    │  │  ├╴var:0
-    │  │  └╴2
-    │  └╴(*)
-    │     ├╴var:0
-    │     └╴3
-    └╴Let 2
-       ├╴sel1
-       │  └╴var:1
-       └╴Let 3
-          ├╴sel2
-          │  └╴var:1
-          └╴(*)
-             ├╴(-)
-             │  ├╴var:2
-             │  └╴var:3
-             └╴(-)
-                ├╴var:3
-                └╴var:2
diff --git a/tests/gold/prog6.txt b/tests/gold/prog6.txt
deleted file mode 100644
--- a/tests/gold/prog6.txt
+++ /dev/null
@@ -1,34 +0,0 @@
-Let 9
- ├╴parallel
- │  ├╴(+)
- │  │  ├╴(-)
- │  │  │  ├╴20
- │  │  │  └╴1
- │  │  └╴1
- │  └╴Lambda 0
- │     └╴(+)
- │        ├╴var:0
- │        └╴1
- └╴Let 10
-    ├╴forLoop
-    │  ├╴arrLength
-    │  │  └╴var:9
-    │  ├╴0
-    │  └╴Lambda 2
-    │     └╴Lambda 3
-    │        └╴(+)
-    │           ├╴(*)
-    │           │  ├╴getIx
-    │           │  │  ├╴var:9
-    │           │  │  └╴var:2
-    │           │  └╴2
-    │           └╴var:3
-    └╴(+)
-       ├╴(+)
-       │  ├╴(*)
-       │  │  ├╴getIx
-       │  │  │  ├╴var:9
-       │  │  │  └╴1
-       │  │  └╴2
-       │  └╴var:10
-       └╴var:10
diff --git a/tests/gold/prog7.txt b/tests/gold/prog7.txt
deleted file mode 100644
--- a/tests/gold/prog7.txt
+++ /dev/null
@@ -1,13 +0,0 @@
-Lambda 0
- └╴Let 1
-    ├╴max
-    │  ├╴5
-    │  └╴(+)
-    │     ├╴6
-    │     └╴7
-    └╴condition
-       ├╴(==)
-       │  ├╴var:0
-       │  └╴10
-       ├╴var:1
-       └╴var:1
diff --git a/tests/gold/prog8.txt b/tests/gold/prog8.txt
deleted file mode 100644
--- a/tests/gold/prog8.txt
+++ /dev/null
@@ -1,20 +0,0 @@
-Lambda 0
- └╴Let 3
-    ├╴parallel
-    │  ├╴10
-    │  └╴Lambda 1
-    │     └╴(+)
-    │        ├╴var:1
-    │        └╴var:0
-    └╴condition
-       ├╴(==)
-       │  ├╴(*)
-       │  │  ├╴(*)
-       │  │  │  ├╴(*)
-       │  │  │  │  ├╴var:0
-       │  │  │  │  └╴var:0
-       │  │  │  └╴var:0
-       │  │  └╴var:0
-       │  └╴23
-       ├╴var:3
-       └╴var:3
diff --git a/tests/gold/scProd.txt b/tests/gold/scProd.txt
--- a/tests/gold/scProd.txt
+++ b/tests/gold/scProd.txt
@@ -1,20 +1,20 @@
-Lambda 0
- └╴Lambda 1
-    └╴forLoop
+Lam v4
+ └╴Lam v3
+    └╴ForLoop
        ├╴min
-       │  ├╴arrLength
-       │  │  └╴var:0
-       │  └╴arrLength
-       │     └╴var:1
+       │  ├╴arrLen
+       │  │  └╴v4
+       │  └╴arrLen
+       │     └╴v3
        ├╴0.0
-       └╴Lambda 2
-          └╴Lambda 3
+       └╴Lam v2
+          └╴Lam v1
              └╴(+)
                 ├╴(*)
-                │  ├╴getIx
-                │  │  ├╴var:0
-                │  │  └╴var:2
-                │  └╴getIx
-                │     ├╴var:1
-                │     └╴var:2
-                └╴var:3
+                │  ├╴arrIx
+                │  │  ├╴v4
+                │  │  └╴v2
+                │  └╴arrIx
+                │     ├╴v3
+                │     └╴v2
+                └╴v1
diff --git a/tests/gold/spanVec.txt b/tests/gold/spanVec.txt
new file mode 100644
--- /dev/null
+++ b/tests/gold/spanVec.txt
@@ -0,0 +1,32 @@
+Lam v3
+ └╴Let v4
+    ├╴ForLoop
+    │  ├╴arrLen
+    │  │  └╴v3
+    │  ├╴Pair
+    │  │  ├╴arrIx
+    │  │  │  ├╴v3
+    │  │  │  └╴0
+    │  │  └╴arrIx
+    │  │     ├╴v3
+    │  │     └╴0
+    │  └╴Lam v2
+    │     └╴Lam v1
+    │        └╴Pair
+    │           ├╴min
+    │           │  ├╴arrIx
+    │           │  │  ├╴v3
+    │           │  │  └╴v2
+    │           │  └╴Fst
+    │           │     └╴v1
+    │           └╴max
+    │              ├╴arrIx
+    │              │  ├╴v3
+    │              │  └╴v2
+    │              └╴Snd
+    │                 └╴v1
+    └╴(-)
+       ├╴Snd
+       │  └╴v4
+       └╴Fst
+          └╴v4