diff --git a/Bench/Bench.hs b/Bench/Bench.hs
deleted file mode 100644
--- a/Bench/Bench.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-import Criterion.Main
-
-import Control.Monad
-
-import Language.Hakaru.Distribution
-import qualified Language.Hakaru.Metropolis as MH
-import qualified Language.Hakaru.ImportanceSampler as IS
-
-giveLast :: IO [(a,b)] -> IO (a,b)
-giveLast samples = do s <- samples
-                      return $ last (take 100 s)
-
-main = defaultMain [
-   bcompare [
-     bench "is normal 10"  $ whnfIO $ giveLast (IS.sample (replicateM 10 (IS.unconditioned (normal 0 10))) [])
-   , bench "is normal 20"  $ whnfIO $ giveLast (IS.sample (replicateM 20 (IS.unconditioned (normal 0 10))) [])
-   , bench "mh normal 10"  $ whnfIO $ giveLast (MH.sample (replicateM 10 (MH.unconditioned (normal 0 10))) [])
-   , bench "mh normal 20"  $ whnfIO $ giveLast (MH.sample (replicateM 20 (MH.unconditioned (normal 0 10))) [])
-   ]
- ]
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2014, The Hakaru Team
+Copyright (c) 2017, The Hakaru Team
 
 All rights reserved.
 
diff --git a/Language/Hakaru/Arrow.hs b/Language/Hakaru/Arrow.hs
deleted file mode 100644
--- a/Language/Hakaru/Arrow.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-{-# LANGUAGE TypeOperators #-}
-module Language.Hakaru.Arrow where
-
-import Language.Hakaru.Types (Dist)
-
-type a ~~> b = a -> Dist b
diff --git a/Language/Hakaru/Distribution.hs b/Language/Hakaru/Distribution.hs
deleted file mode 100644
--- a/Language/Hakaru/Distribution.hs
+++ /dev/null
@@ -1,232 +0,0 @@
-{-# LANGUAGE RankNTypes, BangPatterns, GADTs #-}
-{-# OPTIONS -Wall #-}
-
-module Language.Hakaru.Distribution where
-
-import Control.Monad
-import Control.Monad.Primitive
-import Control.Monad.Loops
-import qualified System.Random.MWC as MWC
-import Language.Hakaru.Mixture
-import Language.Hakaru.Types
-import Data.Ix
-import Data.Maybe (fromMaybe)
-import Data.List (findIndex, foldl')
-import Numeric.SpecFunctions
-import qualified Data.Map.Strict as M
-import qualified Data.Number.LogFloat as LF
-
-mapFst :: (t -> s) -> (t, u) -> (s, u)
-mapFst f (a,b) = (f a, b)
-
-dirac :: (Eq a) => a -> Dist a
-dirac theta = Dist {logDensity = (\ (Discrete x) -> if x == theta then 0 else log 0),
-                    distSample = (\ _ -> return $ Discrete theta)}
-
-bern :: Double -> Dist Bool
-bern p = Dist {logDensity = (\ (Discrete x) -> log (if x then p else 1 - p)),
-               distSample = (\ g -> do t <- MWC.uniformR (0,1) g
-                                       return $ Discrete (t <= p))}
-
-uniform :: Double -> Double -> Dist Double
-uniform lo hi =
-    let uniformLogDensity lo' hi' x | lo' <= x && x <= hi' = log (recip (hi' - lo'))
-        uniformLogDensity _ _ _ = log 0
-    in Dist {logDensity = (\ (Lebesgue x) -> uniformLogDensity lo hi x),
-             distSample = (\ g -> liftM Lebesgue $ MWC.uniformR (lo, hi) g)}
-
-uniformD :: (Ix a, MWC.Variate a) => a -> a -> Dist a
-uniformD lo hi =
-    let uniformLogDensity lo' hi' x | lo' <= x && x <= hi' = log density
-        uniformLogDensity _ _ _ = log 0
-        density = recip (fromInteger (toInteger (rangeSize (lo,hi))))
-    in Dist {logDensity = (\ (Discrete x) -> uniformLogDensity lo hi x),
-             distSample = (\ g -> liftM Discrete $ MWC.uniformR (lo, hi) g)}
-
-marsaglia :: (MWC.Variate a, Ord a, Floating a, PrimMonad m) => PRNG m -> m (a, a)
-marsaglia g = do -- "Marsaglia polar method"
-  x <- MWC.uniformR (-1,1) g
-  y <- MWC.uniformR (-1,1) g
-  let s = x * x + y * y
-      q = sqrt ((-2) * log s / s)
-  if 1 >= s && s > 0 then return (x * q, y * q) else marsaglia g
-
-choose :: (PrimMonad m) => Mixture k -> PRNG m -> m (k, Prob)
-choose (Mixture m) g = do
-  let peak = maximum (M.elems m)
-      unMix = M.map (LF.fromLogFloat . (/peak)) m
-      total = M.foldl' (+) (0::Double) unMix
-  p <- MWC.uniformR (0, total) g
-  let f !k !v b !p0 = let p1 = p0 + v in if p <= p1 then k else b p1
-      err p0 = error ("choose: failure p0=" ++ show p0 ++
-                      " total=" ++ show total ++
-                      " size=" ++ show (M.size m))
-  return $ (M.foldrWithKey f err unMix 0, LF.logFloat total * peak)
-
-chooseIndex :: (PrimMonad m) => [Double] -> PRNG m -> m Int
-chooseIndex probs g = do
-  p <- MWC.uniform g
-  return $ fromMaybe (error ("chooseIndex: failure p=" ++ show p))
-           (findIndex (p <=) (scanl1 (+) probs))
-
-normal_rng :: (Real a, Floating a, MWC.Variate a, PrimMonad m) =>
-              a -> a -> PRNG m -> m a
-normal_rng mu sd g | sd > 0 = do (x, _) <- marsaglia g
-                                 return (mu + sd * x)
-normal_rng _ _ _ = error "normal: invalid parameters"
-
-normalLogDensity :: Floating a => a -> a -> a -> a
-normalLogDensity mu sd x = (-tau * square (x - mu)
-                            + log (tau / pi / 2)) / 2
-  where square y = y * y
-        tau = 1 / square sd
-
-normal :: Double -> Double -> Dist Double 
-normal mu sd = Dist {logDensity = normalLogDensity mu sd . fromLebesgue,
-                     distSample = (\g -> liftM Lebesgue $ normal_rng mu sd g)}
-
-categoricalLogDensity :: (Eq b, Floating a) => [(b, a)] -> b -> a
-categoricalLogDensity list x = log $ fromMaybe 0 (lookup x list)
-
-categoricalSample :: (Num b, Ord b, PrimMonad m, MWC.Variate b) =>
-    [(t,b)] -> PRNG m -> m t
-categoricalSample list g = do
-  let total = sum $ map snd list
-  p <- MWC.uniformR (0, total) g
-  let sumList = scanl1 (\acc (a, b) -> (a, b + snd(acc))) list
-      elem' = fst $ head $ filter (\(_,p0) -> p <= p0) sumList
-  return elem'
-
-categorical :: Eq a => [(a,Double)] -> Dist a
-categorical list = Dist {logDensity = categoricalLogDensity list . fromDiscrete,
-                         distSample = (\g -> liftM Discrete $ categoricalSample list g)}
-
-lnFact :: Int -> Double
-lnFact = logFactorial
-
--- Makes use of Atkinson's algorithm as described in:
--- Monte Carlo Statistical Methods pg. 55
---
--- Further discussion at:
--- http://www.johndcook.com/blog/2010/06/14/generating-poisson-random-values/
-poisson_rng :: (PrimMonad m) => Double -> PRNG m -> m Int
-poisson_rng lambda g' = make_poisson g'
-   where smu = sqrt lambda
-         b  = 0.931 + 2.53*smu
-         a  = -0.059 + 0.02483*b
-         vr = 0.9277 - 3.6224/(b - 2)
-         arep  = 1.1239 + 1.1368/(b-3.4)
-         lnlam = log lambda
-
-         make_poisson :: (PrimMonad m) => PRNG m -> m Int
-         make_poisson g = do u <- MWC.uniformR (-0.5,0.5) g
-                             v <- MWC.uniformR (0,1) g
-                             let us = 0.5 - abs u
-                                 k = floor $ (2*a / us + b)*u + lambda + 0.43
-                             case () of
-                               () | us >= 0.07 && v <= vr -> return k
-                               () | k < 0 -> make_poisson g
-                               () | us <= 0.013 && v > us -> make_poisson g
-                               () | accept_region us v k -> return k
-                               _  -> make_poisson g
-
-         accept_region :: Double -> Double -> Int -> Bool
-         accept_region us v k = log (v * arep / (a/(us*us)+b)) <=
-                                -lambda + (fromIntegral k)*lnlam - lnFact k
-
-poisson :: Double -> Dist Int
-poisson l =
-    let poissonLogDensity l' x | l' > 0 && x> 0 = (fromIntegral x)*(log l') - lnFact x - l'
-        poissonLogDensity l' x | x==0 = -l'
-        poissonLogDensity _ _ = log 0
-    in Dist {logDensity = poissonLogDensity l . fromDiscrete,
-             distSample = (\g -> liftM Discrete $ poisson_rng l g)}
-
--- Direct implementation of  "A Simple Method for Generating Gamma Variables"
--- by George Marsaglia and Wai Wan Tsang.
-gamma_rng :: (PrimMonad m) => Double -> Double -> PRNG m -> m Double
-gamma_rng shape _   _ | shape <= 0.0  = error "gamma: got a negative shape paramater"
-gamma_rng _     scl _ | scl <= 0.0  = error "gamma: got a negative scale paramater"
-gamma_rng shape scl g | shape <  1.0  = do gvar1 <- gamma_rng (shape + 1) scl g
-                                           w <- MWC.uniformR (0,1) g
-                                           return $ scl * gvar1 * (w ** recip shape)
-gamma_rng shape scl g = do
-    let d = shape - 1/3
-        c = recip $ sqrt $ 9*d
-        -- Algorithm recommends inlining normal generator
-        -- n = normal_rng 1 c
-    v <- iterateUntil (> 0.0) $ normal_rng 1 c g
-        -- (v, g2) = until (\y -> fst y > 0.0) (\ (_, g') -> normal_rng 1 c g') (n g)
-    let x = (v - 1) / c
-        sqr = x * x
-        v3 = v * v * v
-    u <- MWC.uniformR (0.0, 1.0) g
-    let accept = u < 1.0 - 0.0331*(sqr*sqr) || log u < 0.5*sqr + d*(1.0 - v3 + log v3)
-    case accept of
-      True -> return $ scl*d*v3
-      False -> gamma_rng shape scl g
-
-gammaLogDensity :: Double -> Double -> Double -> Double
-gammaLogDensity shape scl x | x>= 0 && shape > 0 && scl > 0 =
-     scl * log shape - scl * x + (shape - 1) * log x - logGamma shape
-gammaLogDensity _ _ _ = log 0
-
-gamma :: Double -> Double -> Dist Double
-gamma shape scl = Dist {logDensity = gammaLogDensity shape scl . fromLebesgue,
-                        distSample = (\g -> liftM Lebesgue $ gamma_rng shape scl g)}
-
-beta_rng :: (PrimMonad m) => Double -> Double -> PRNG m -> m Double
-beta_rng a b g | a <= 1.0 && b <= 1.0 = do
-                 u <- MWC.uniformR (0.0, 1.0) g
-                 v <- MWC.uniformR (0.0, 1.0) g
-                 let x = u ** (recip a)
-                     y = v ** (recip b)
-                 case (x+y) <= 1.0 of
-                   True -> return $ x / (x + y)
-                   False -> beta_rng a b g
-beta_rng a b g = do ga <- gamma_rng a 1 g
-                    gb <- gamma_rng b 1 g
-                    return $ ga / (ga + gb)
-
-betaLogDensity :: Double -> Double -> Double -> Double
-betaLogDensity _ _ x | x < 0 || x > 1 = error "beta: value must be between 0 and 1"
-betaLogDensity a b _ | a <= 0 || b <= 0 = error "beta: parameters must be positve" 
-betaLogDensity a b x = (logGamma (a + b)
-                        - logGamma a
-                        - logGamma b
-                        + (a - 1) * log x
-                        + (b - 1) * log (1 - x))
-
-beta :: Double -> Double -> Dist Double
-beta a b = Dist {logDensity = betaLogDensity a b . fromLebesgue,
-                 distSample = (\g -> liftM Lebesgue $ beta_rng a b g)}
-
-laplace_rng :: (PrimMonad m) => Double -> Double -> PRNG m -> m Double
-laplace_rng mu sd g = MWC.uniformR (0.0, 1.0) g >>= sample
-   where sample u = return $ case u < 0.5 of
-                               True  -> mu + sd * log (u + u)
-                               False -> mu - sd * log (2.0 - u - u)
-
-laplaceLogDensity :: Floating a => a -> a -> a -> a
-laplaceLogDensity mu sd x = - log (2 * sd) - abs (x - mu) / sd
-
-laplace :: Double -> Double -> Dist Double
-laplace mu sd = Dist {logDensity = laplaceLogDensity mu sd . fromLebesgue,
-                      distSample = (\g -> liftM Lebesgue $ laplace_rng mu sd g)}
-
--- Consider having dirichlet return Vector
--- Note: This is actually symmetric dirichlet
-dirichlet_rng :: (PrimMonad m) => Int ->  Double -> PRNG m -> m [Double]
-dirichlet_rng n' a g' = liftM normalize $ gammas g' n'
-  where gammas _ 0 = return ([], 0)
-        gammas g n = do (xs, total) <- gammas g (n-1)
-                        x <- gamma_rng a 1 g
-                        return ((x : xs), x+total)
-        normalize (b, total) = map (/ total) b
-
-dirichletLogDensity :: [Double] -> [Double] -> Double
-dirichletLogDensity a x | all (> 0) x = sum' (zipWith logTerm a x) + logGamma (sum a)
-  where sum' = foldl' (+) 0
-        logTerm b y = (b-1) * log y - logGamma b
-dirichletLogDensity _ _ = error "dirichlet: all values must be between 0 and 1"
-
diff --git a/Language/Hakaru/ImportanceSampler.hs b/Language/Hakaru/ImportanceSampler.hs
deleted file mode 100644
--- a/Language/Hakaru/ImportanceSampler.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-{-# LANGUAGE RankNTypes, NoMonomorphismRestriction, BangPatterns #-}
-{-# OPTIONS -W #-}
-
-module Language.Hakaru.ImportanceSampler where
-
--- This is an interpreter that's like Interpreter except conditioning is
--- checked at run time rather than by static types.  In other words, we allow
--- models to be compiled whose conditioned parts do not match the observation
--- inputs.  In exchange, we get to make Measure an instance of Monad, and we
--- can express models whose number of observations is unknown at compile time.
-
-import Language.Hakaru.Types
-import Language.Hakaru.Mixture (Prob, empty, point, Mixture(..))
-import Language.Hakaru.Sampler (Sampler, deterministic, smap, sbind)
-
-import qualified System.Random.MWC as MWC
-import Control.Monad.Primitive
-import Data.Monoid
-import Data.Dynamic
-import System.IO.Unsafe
-import qualified Data.Map.Strict as M
-
-import qualified Data.Number.LogFloat as LF
-
--- Conditioned sampling
-newtype Measure a = Measure { unMeasure :: [Cond] -> Sampler (a, [Cond]) }
-
-bind :: Measure a -> (a -> Measure b) -> Measure b
-bind measure continuation =
-  Measure (\conds ->
-    sbind (unMeasure measure conds)
-          (\(a,cds) -> unMeasure (continuation a) cds))
-
-instance Monad Measure where
-  return x = Measure (\conds -> deterministic (point (x,conds) 1))
-  (>>=)    = bind
-
-updateMixture :: Typeable a => Cond -> Dist a -> Sampler a
-updateMixture (Just cond) dist =
-    case fromDynamic cond of
-      Just y  -> deterministic (point (fromDensity y) density)
-          where density = LF.logToLogFloat $ logDensity dist y
-      Nothing -> error "did not get data from dynamic source"
-updateMixture Nothing     dist = \g -> do e <- distSample dist g
-                                          return $ point (fromDensity e) 1
-    
-conditioned, unconditioned :: Typeable a => Dist a -> Measure a
-conditioned   dist = Measure (\(cond:conds) -> smap (\a->(a,conds))
-                                               (updateMixture cond    dist))
-unconditioned dist = Measure (\      conds  -> smap (\a->(a,conds))
-                                               (updateMixture Nothing dist))
-
-factor :: Prob -> Measure ()
-factor p = Measure (\conds -> deterministic (point ((), conds) p))
-
-condition :: Eq b => Measure (a, b) -> b -> Measure a
-condition m b' =
-    Measure (\ conds -> 
-      sbind (unMeasure m conds)
-            (\ ((a,b), cds) ->
-                 deterministic (if b==b' then point (a,cds) 1 else empty)))
-
--- Drivers for testing
-finish :: Mixture (a, [Cond]) -> Mixture a
-finish (Mixture m) = Mixture (M.mapKeysMonotonic (\(a,[]) -> a) m)
-
-empiricalMeasure :: (PrimMonad m, Ord a) => Int -> Measure a -> [Cond] -> m (Mixture a)
-empiricalMeasure !n measure conds = do
-  gen <- MWC.create
-  go n gen empty
-    where once = unMeasure measure conds
-          go 0 _ m = return m
-          go k g m = once g >>= \result -> go (k - 1) g $! mappend m (finish result)
-
-sample :: Measure a -> [Cond] -> IO [(a, Prob)]
-sample measure conds = do
-  gen <- MWC.create
-  unsafeInterleaveIO $ sampleNext gen
-      where once = unMeasure measure conds
-            mixToTuple = head . M.toList . unMixture
-            sampleNext g = do
-              u <- once g
-              let x = mixToTuple (finish u)
-              xs <- unsafeInterleaveIO $ sampleNext g
-              return (x : xs)
- --  u <- once gen
- --  let x = mixToTuple (finish u)
- --  xs <- unsafeInterleaveIO $ sample measure conds gen
- --  return (x : xs)
- -- where once = unMeasure measure conds
- --       mixToTuple = head . M.toList . unMixture
-
-logit :: Floating a => a -> a
-logit !x = 1 / (1 + exp (- x))
diff --git a/Language/Hakaru/Lambda.hs b/Language/Hakaru/Lambda.hs
deleted file mode 100644
--- a/Language/Hakaru/Lambda.hs
+++ /dev/null
@@ -1,22 +0,0 @@
--- The lambda-calculus part of the language, which can be shared
-module Language.Hakaru.Lambda(lit, dbl, lam, app, fix, ifThenElse) where
-
-lit :: (Eq a) => a -> a
-lit = id
-
--- raw lit is a pain to use.  These are nicer
-dbl :: Double -> Double
-dbl = lit
-
-lam :: (a -> b) -> (a -> b)
-lam f = f
-
-app :: (a -> b) -> a -> b
-app f x = f x
-
-fix :: ((a -> b) -> (a -> b)) -> (a -> b)
-fix g = f where f = g f
-
-ifThenElse :: Bool -> a -> a -> a
-ifThenElse True  t _ = t
-ifThenElse False _ f = f
diff --git a/Language/Hakaru/Metropolis.hs b/Language/Hakaru/Metropolis.hs
deleted file mode 100644
--- a/Language/Hakaru/Metropolis.hs
+++ /dev/null
@@ -1,212 +0,0 @@
-{-# LANGUAGE RankNTypes, NoMonomorphismRestriction, BangPatterns,
-  DeriveDataTypeable, GADTs, ScopedTypeVariables,
-  ExistentialQuantification, StandaloneDeriving #-}
-{-# OPTIONS -Wall #-}
-
-module Language.Hakaru.Metropolis where
-
-import qualified System.Random.MWC as MWC
-import Control.Monad
-import Control.Monad.Primitive
-import Data.Dynamic
-import Data.Maybe
-import Control.Applicative
-
-import qualified Data.Map.Strict as M
-import Language.Hakaru.Types
-
-import System.IO.Unsafe
-
-{-
-
-Shortcomings of this implementation
-
-* uses parent-conditional sampling for proposal distribution
-* re-evaluates entire program at every sample
-* lacks way to block sample groups of variables
-
--}
-
-type DistVal = Dynamic
- 
-data XRP where
-  XRP :: Typeable e => (Density e, Dist e) -> XRP
-
-unXRP :: Typeable a => XRP -> Maybe (Density a, Dist a)
-unXRP (XRP (e,f)) = cast (e,f)
-
-type Visited = Bool
-type Observed = Bool
-type LL = LogLikelihood
-
--- The first component is the LogLikelihood of the trace
--- The second is the LogLikelihood of the newly introduced
--- choices. These are used to compute the acceptance ratio
-type LL2 = (LL,LL)
-
-type Subloc = Int
-type Name = [Subloc]
-data DBEntry = DBEntry {
-      xrp  :: XRP, 
-      llhd :: LL, 
-      vis  :: Visited,
-      observed :: Observed }
-type Database = M.Map Name DBEntry
-
-data SamplerState where
-  S :: { ldb :: Database, -- ldb = local database
-         -- (total likelihood, total likelihood of XRPs newly introduced)
-         llh2 :: {-# UNPACK #-} !LL2,
-         cnds :: [Cond] -- conditions left to process
-       } -> SamplerState
-
-type Sampler a = PrimMonad m => SamplerState -> PRNG m -> m (a, SamplerState)
-
-sreturn :: a -> Sampler a
-sreturn x s _ = return (x, s)
-
-sbind :: Sampler a -> (a -> Sampler b) -> Sampler b
-sbind s k = \ st g -> do (v, s') <- s st g
-                         k v s' g
-
-smap :: (a -> b) -> Sampler a -> Sampler b
-smap f s = sbind s (\a -> sreturn (f a))
-
-newtype Measure a = Measure {unMeasure :: Name -> Sampler a }
-  deriving (Typeable)
-
-return_ :: a -> Measure a
-return_ x = Measure $ \ _ -> sreturn x
-
-updateXRP :: Typeable a => Name -> Cond -> Dist a -> Sampler a
-updateXRP n obs dist' s@(S {ldb = db}) g = do
-    case M.lookup n db of
-      Just (DBEntry xd _ _ ob) ->
-          do let Just (x, _) = unXRP xd
-                 l' = logDensity dist' x
-                 d1 = M.insert n (DBEntry (XRP (x,dist')) l' True ob) db
-             return (fromDensity x,
-                     s {ldb = d1,
-                        llh2 = updateLogLikelihood (l',0) (llh2 s)})
-      Nothing ->
-          do (xnew2, l) <- case obs of
-                             Just xdnew ->
-                                 do let Just xnew = fromDynamic xdnew
-                                    return $ (xnew, logDensity dist' xnew)
-                             Nothing ->
-                                 do xnew <- distSample dist' g
-                                    return (xnew, logDensity dist' xnew)
-             let d1 = M.insert n (DBEntry (XRP (xnew2, dist')) l True (isJust obs)) db
-             return (fromDensity xnew2,
-                     s {ldb = d1,
-                        llh2 = updateLogLikelihood (l,l) (llh2 s)})
-
-updateLogLikelihood :: LL2 -> LL2 -> LL2
-updateLogLikelihood (llTotal,llFresh) (l,lf) = (llTotal+l, llFresh+lf)
-
-factor :: LL -> Measure ()
-factor l = Measure $ \ _ -> \ s _ ->
-   do let (llTotal, llFresh) = llh2 s
-      return ((), s {llh2 = (llTotal + l, llFresh)})
-
-condition :: Eq b => Measure (a, b) -> b -> Measure a
-condition (Measure m) b' = Measure $ \ n ->
-    do let comp a b s |  a /= b = s {llh2 = (log 0, 0)}
-           comp _ _ s =  s
-       sbind (m n) (\ (a, b) s _ -> return (a, comp b b' s))
-
-bind :: Measure a -> (a -> Measure b) -> Measure b
-bind (Measure m) cont = Measure $ \ n ->
-    sbind (m (0:n)) (\ a -> unMeasure (cont a) (1:n))
-
-conditioned :: Typeable a => Dist a -> Measure a
-conditioned dist = Measure $ \ n -> 
-    \s@(S {cnds = cond:conds }) ->
-        updateXRP n cond dist s{cnds = conds}
-
-unconditioned :: Typeable a => Dist a -> Measure a
-unconditioned dist = Measure $ \ n ->
-    updateXRP n Nothing dist
-
-instance Monad Measure where
-  return = return_
-  (>>=)  = bind
-
-instance Functor Measure where
-  fmap f (Measure x) = Measure $ \n -> smap f (x n)
-
-instance Applicative Measure where
-  pure = return_
-  (<*>) = app
-
-sapp :: (Sampler (a -> b)) -> Sampler a -> Sampler b
-sapp f s = \st g -> do (vf, s')  <- f st g
-                       (vs, s'') <- s s' g
-                       sreturn (vf vs) s'' g
-
-app :: Measure (a -> b) -> Measure a -> Measure b
-app (Measure f) (Measure a) = Measure $ \n -> sapp (f n) (a n)
-
-run :: Measure a -> [Cond] -> IO (a, Database, LL)
-run (Measure prog) cds = do
-  g <- MWC.create
-  (v, S d ll []) <- (prog [0]) (S M.empty (0,0) cds) g
-  return (v, d, fst ll)
-
-traceUpdate :: PrimMonad m => Measure a -> Database -> [Cond] -> PRNG m
-            -> m (a, Database, LL, LL, LL)
-traceUpdate (Measure prog) d cds g = do
-  -- let d1 = M.map (\ (x, l, _, ob) -> (x, l, False, ob)) d
-  let d1 = M.map (\ s -> s { vis = False }) d
-  (v, S d2 (llTotal, llFresh) []) <- (prog [0]) (S d1 (0,0) cds) g
-  let (d3, stale_d) = M.partition vis d2
-  let llStale = M.foldl' (\ llStale' s -> llStale' + llhd s) 0 stale_d
-  return (v, d3, llTotal, llFresh, llStale)
-
-initialStep :: Measure a -> [Cond] ->
-               PRNG IO -> IO (a, Database, LL, LL, LL)
-initialStep prog cds g = traceUpdate prog M.empty cds g
-
--- TODO: Make a way of passing user-provided proposal distributions
-resample :: PrimMonad m => Name -> Database -> Observed -> XRP -> PRNG m ->
-            m (Database, LL, LL, LL)
-resample name db ob (XRP (x, dist)) g =
-    do x' <- distSample dist g
-       let fwd = logDensity dist x'
-           rvs = logDensity dist x
-           l' = fwd
-           newEntry = DBEntry (XRP (x', dist)) l' True ob
-           db' = M.insert name newEntry db
-       return (db', l', fwd, rvs)
-
-transition :: (Typeable a) => Measure a -> [Cond]
-           -> a -> Database -> LL -> PRNG IO -> IO [a]
-transition prog cds v db ll g =
-  do let dbSize = M.size db
-         -- choose an unconditioned choice
-         (_, uncondDb) = M.partition observed db
-     choice <- MWC.uniformR (0, (M.size uncondDb) -1) g
-     let (name, (DBEntry xd _ _ ob))  = M.elemAt choice uncondDb
-     (db', _, fwd, rvs) <- resample name db ob xd g
-     (v', db2, llTotal, llFresh, llStale) <- traceUpdate prog db' cds g
-     let a = llTotal - ll
-             + rvs - fwd
-             + log (fromIntegral dbSize) - log (fromIntegral $ M.size db2)
-             + llStale - llFresh
-     u <- MWC.uniformR (0 :: Double, 1) g
-     if (log u < a) then
-         liftM ((:) v') $ unsafeInterleaveIO (transition prog cds v' db2 llTotal g)
-     else
-         liftM ((:) v) $ unsafeInterleaveIO (transition prog cds v db ll g)
-
-mcmc :: Typeable a => Measure a -> [Cond] -> IO [a]
-mcmc prog cds = do
-  g <- MWC.create
-  (v, d, llTotal, _, _) <- initialStep prog cds g
-  transition prog cds v d llTotal g
-
-sample :: Typeable a => Measure a -> [Cond] -> IO [(a, Double)]
-sample prog cds  = do 
-  g <- MWC.create
-  (v, d, llTotal, _, _) <- initialStep prog cds g
-  (transition prog cds v d llTotal g) >>= return . map (\ x -> (x,1)) 
diff --git a/Language/Hakaru/Mixture.hs b/Language/Hakaru/Mixture.hs
deleted file mode 100644
--- a/Language/Hakaru/Mixture.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# LANGUAGE RankNTypes, BangPatterns #-}
-{-# OPTIONS -W #-}
-
-module Language.Hakaru.Mixture (Prob, point, empty, scale,
-  Mixture(..), toList, mnull, mmap, cross, mode) where
-
-import Data.Monoid
-import Data.Ord (comparing)
-import Data.List (maximumBy)
-import qualified Data.Map.Strict as M
-import Data.Number.LogFloat hiding (isInfinite)
-import Text.Show (showListWith)
-import Numeric (showFFloat)
-
-type Prob = LogFloat
-
--- Mixtures (the results of importance sampling)
-
-newtype Mixture k = Mixture { unMixture :: M.Map k Prob }
-
-instance (Show k) => Show (Mixture k) where
-  showsPrec d (Mixture m) = showParen (d > 0) $
-    showString "Mixture $ fromList " . showListWith s (M.toList m)
-    where s (k,p) = showChar '('
-                  . shows k
-                  . showChar ','
-                  . (if isInfinite l || -42 < l && l < 42
-                     then showFFloat Nothing (fromLogFloat p :: Double)
-                     else showString "logToLogFloat " . showsPrec 11 l)
-                  . showChar ')'
-            where l = logFromLogFloat p :: Double
-
-instance (Ord k) => Monoid (Mixture k) where
-  mempty        = empty
-  mappend m1 m2 = Mixture (M.unionWith (+) (unMixture m1) (unMixture m2))
-  mconcat ms    = Mixture (M.unionsWith (+) (map unMixture ms))
-
-empty :: Mixture k
-empty = Mixture M.empty
-
-toList :: Mixture k -> [(k, Prob)]
-toList = M.toList . unMixture
-
-mnull :: Mixture k -> Bool
-mnull = all (0>=) . M.elems . unMixture
-
-point :: k -> Prob -> Mixture k
-point k !v = Mixture (M.singleton k v)
-
-scale :: Prob -> Mixture k -> Mixture k
-scale !v = Mixture . M.map (v *) . unMixture
-
-mmap :: (Ord k2) => (k1 -> k2) -> Mixture k1 -> Mixture k2
-mmap f = Mixture . M.mapKeysWith (+) f . unMixture
-
-cross :: (Ord k) => (k1 -> k2 -> k) -> Mixture k1 -> Mixture k2 -> Mixture k
-cross f m1 m2 = mconcat [ mmap (`f` k) (scale v m1)
-                        | (k,v) <- M.toList (unMixture m2) ]
-
-mode :: Mixture k -> (k, Prob)
-mode (Mixture m) = maximumBy (comparing snd) (M.toList m)
diff --git a/Language/Hakaru/Sampler.hs b/Language/Hakaru/Sampler.hs
deleted file mode 100644
--- a/Language/Hakaru/Sampler.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-{-# OPTIONS -W #-}
-
-module Language.Hakaru.Sampler (Sampler, deterministic, sbind, smap) where
-
-import Language.Hakaru.Mixture (Mixture, mnull, empty, scale, point)
-import Language.Hakaru.Distribution (choose)
-import Language.Hakaru.Types
-import Control.Monad.Primitive
-
--- Sampling procedures that produce one sample
-
-type Sampler a = PrimMonad m => PRNG m -> m (Mixture a)
-
-deterministic :: Mixture a -> Sampler a
-deterministic m _ = return m
-
-sbind :: Sampler a -> (a -> Sampler b) -> Sampler b
-sbind s k g = do
-  m1 <- s g
-  if mnull m1 then 
-      return empty
-  else do (a, v) <- choose m1 g
-          m2 <- k a g
-          return (scale v m2)
-
-smap :: (a -> b) -> Sampler a -> Sampler b
-smap f s = sbind s (\a -> deterministic (point (f a) 1))
diff --git a/Language/Hakaru/Symbolic.hs b/Language/Hakaru/Symbolic.hs
deleted file mode 100644
--- a/Language/Hakaru/Symbolic.hs
+++ /dev/null
@@ -1,185 +0,0 @@
-{-# LANGUAGE GADTs, TypeFamilies, ScopedTypeVariables, FlexibleContexts #-}
-{-# OPTIONS -Wall #-}
-
-module Language.Hakaru.Symbolic where
-
-import Prelude hiding (Real)
-
-data Real
-data Prob
-data Measure a
-data Dist a
-data Exact
-
-class IntComp repr where
-  int                  :: Integer -> repr Integer
-
-class BoolComp repr where
-  bool                 :: Bool -> repr Bool
-
-class RealComp repr where
-  real                 :: Rational -> repr Real
-  exp                  :: repr Real -> repr Real -> repr Real
-  sqrt, cos, sin       :: repr Real -> repr Real
-
--- polymorphic operations and integer powering
--- probably should restrict 'a' to be some kind of numeric type?
-class SymbComp repr where
-  add, minus, mul :: repr a -> repr a -> repr a
-  pow             :: repr Real -> repr Integer -> repr Real
-  scale           :: repr Integer -> repr Real -> repr Real
-
-class MeasMonad repr where
-  bind                 :: repr (Measure a) -> (repr a -> repr (Measure b)) 
-                          -> repr (Measure b)
-  ret                  :: repr a -> repr (Measure a)
-
-class Distrib repr where
-  uniform, normal :: repr Real -> repr Real -> repr (Dist Real)
-  uniformD        :: repr Integer -> repr Integer -> repr (Dist Integer)
-
-class Conditioning repr where
-  conditioned, unconditioned :: repr (Dist a) -> repr (Measure a)
-
--- Printer (to Maple)
-data Pos = Front | Back
-type VarCounter = Int
-newtype Maple a = Maple { unMaple :: Pos -> VarCounter -> String }
-
-type family MPL a
-type instance MPL Real     = Rational
-type instance MPL Integer  = Integer
-type instance MPL Bool     = Bool
-
--- if it weren't for the constraints, we could/should use Applicative
-pure :: Show (MPL a) => MPL a -> Maple a
-pure x = Maple $ \_ _ -> show x
-
-liftA1 :: (String -> String) -> Maple a -> Maple a
-liftA1 pr x = Maple $ \f h -> pr (unMaple x f h)
-
-liftA2 :: (String -> String -> String) -> Maple a -> Maple a -> Maple a
-liftA2 pr e1 e2 = Maple $ \f h -> pr (unMaple e1 f h) (unMaple e2 f h)
-
--- variant for ret
-liftA1M :: (String -> String) -> Maple a -> Maple (Measure a)
-liftA1M pr x = Maple $ \f h -> pr (unMaple x f h)
-
--- variant for pow
-liftA2aba :: (String -> String -> String) -> Maple a -> Maple b -> Maple a
-liftA2aba pr e1 e2 = Maple $ \f h -> pr (unMaple e1 f h) (unMaple e2 f h)
-
--- variant for scale
-liftA2baa :: (String -> String -> String) -> Maple b -> Maple a -> Maple a
-liftA2baa pr e1 e2 = Maple $ \f h -> pr (unMaple e1 f h) (unMaple e2 f h)
-
-mkPr :: String -> (String -> String)
-mkPr s t = s ++ "(" ++ t ++ ")"
-
-d2m :: Maple (Dist a) -> Maple (Measure a)
-d2m e = Maple $ unMaple e
-
-infixPr :: String -> (String -> String -> String)
-infixPr s a b = a ++ s ++ b
-
--- This is quite scary.  Probably a mistake.
-reify :: forall a. Read a => Pos -> VarCounter -> Maple a -> a
-reify f h e = (read (unMaple e f h) :: a)
-
-name :: String -> VarCounter -> String
-name s h = s ++ show h
-
-var :: String -> VarCounter -> Maple a
-var s h = Maple $ \_ _ -> name s h
-
-binder :: (String -> String -> Maybe String) -> 
-          (String -> String -> VarCounter -> Maybe String) ->
-          String -> 
-          Maple a -> Maple a -> Maple (Dist a)
-binder pr1 pr2 oper e1 e2 = Maple $ pr_
-  where
-    pr_ Front h = let x1 = unMaple e1 Front h
-                      x2 = unMaple e2 Front h in
-                  case (pr1 x1 x2, pr2 x1 x2 h) of
-                    (Just z, Just w)   -> z ++ " * " ++ oper ++ " (" ++ w ++ " * "
-                    (Nothing, Just w)  -> oper ++ " (" ++ w ++ " * "
-                    (Just z, Nothing)  -> z ++ " * " ++ oper ++ " ("
-                    (Nothing, Nothing) -> oper ++ " ("
-    pr_ Back h  = ", " ++ (name "x" h) ++ "=" ++ unMaple e1 Back h ++
-                  ".." ++ unMaple e2 Back h ++ ")"
-
-instance RealComp Maple where
-   -- serious problem here: all exact numbers will be printed as
-   -- floats, which will really hamper the use of Maple in any 
-   -- serious way.  This needs a rethink.
-  real  = pure
-  exp   = liftA2 $ infixPr "^"
-  sqrt  = liftA1 $ mkPr "sqrt"
-  cos   = liftA1 $ mkPr "cos"
-  sin   = liftA1 $ mkPr "sin"
-
-instance SymbComp Maple where
-  add   = liftA2    $ infixPr "+"
-  minus = liftA2    $ infixPr "-"
-  mul   = liftA2    $ infixPr "*"
-  pow   = liftA2aba $ infixPr "^"
-  scale = liftA2baa $ infixPr "*"
-
-instance IntComp Maple where
-  int  = pure
-
-instance BoolComp Maple where
-  bool  = pure
-
-instance MeasMonad Maple where
-  ret      = liftA1M $ mkPr "g"
-  bind m c = Maple $ \f h -> unMaple m Front h ++ 
-                             unMaple (c $ var "x" h) f (succ h) ++
-                             unMaple m Back h 
-
-instance Distrib Maple where
-  uniform = binder (\e1 e2 -> Just $ 
-                     show (1/((read e2 :: Rational) - (read e1 :: Rational)))) 
-                   (\_ _ _ -> Nothing) "Int"
-  uniformD = binder (\e1 e2 -> 
-                      let d = (read e2 :: Integer) - (read e1) in
-                      if d == 1 then Nothing
-                      else Just $ "(1 / " ++ show d ++ ")")
-                   (\_ _ _ -> Nothing) "Sum"
-  normal = binder (\_ _ -> Nothing) 
-                  (\e1 e2 h -> Just $ "PDF (Normal (" ++ e1 ++ ", " ++ e2 ++ "), " ++ (name "x" h) ++ ")")
-                  "Int"
-
-instance Conditioning Maple where
-  unconditioned = d2m
-  conditioned   = d2m
-
-view :: Maple a -> String
-view e = unMaple e Front 0
-
-lift :: Maple Integer -> Maple Real
-lift x = Maple $ \f h -> unMaple x f h
-
--- TEST CASES
-exp1, exp2, exp3, exp4 :: Maple (Measure Real)
-exp1 = unconditioned (uniform (real 1) (real 3)) `bind` ret
-
--- Borel's Paradox Simplified
-exp2 = unconditioned (uniformD (int 1) (int 3)) `bind` \s ->
-       unconditioned (uniform  (real (-1)) (real 1)) `bind` \x ->
-       let y = s `scale` x in ret y
-
--- Borel's Paradox
-exp3 = unconditioned (uniformD (int 1) (int 2)) `bind` \s ->
-       unconditioned (uniform  (real (-1)) (real 1)) `bind` \x ->
-       let y = (Language.Hakaru.Symbolic.sqrt ((real 1 ) `minus` 
-               (Language.Hakaru.Symbolic.pow (lift s) (int 2)))) `mul`
-               (Language.Hakaru.Symbolic.sin x) in ret y  
-
-exp4 = unconditioned (normal (real 1) (real 4)) `bind` ret
-
-test, test2, test3, test4 :: String
-test = view exp1
-test2 = view exp2
-test3 = view exp3
-test4 = view exp4
diff --git a/Language/Hakaru/Types.hs b/Language/Hakaru/Types.hs
deleted file mode 100644
--- a/Language/Hakaru/Types.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-# LANGUAGE RankNTypes, DeriveDataTypeable, StandaloneDeriving #-}
-{-# OPTIONS -W #-}
-
-module Language.Hakaru.Types where
-
-import Data.Dynamic
-import Control.Monad.Primitive
-import qualified System.Random.MWC as MWC
-
-type PRNG m = MWC.Gen (PrimState m)
-
--- Basic types for conditioning and conditioned sampler
-data Density a = Lebesgue !a | Discrete !a deriving Typeable
-type Cond = Maybe Dynamic
-
-fromDiscrete :: Density t -> t
-fromDiscrete (Discrete a) = a
-fromDiscrete _            = error "got a non-discrete sampler"
-
-fromLebesgue :: Density t -> t
-fromLebesgue (Lebesgue a) = a
-fromLebesgue  _           = error "got a discrete sampler"
-
-fromDensity :: Density t -> t
-fromDensity (Discrete a) = a
-fromDensity (Lebesgue a) = a
-
-type LogLikelihood = Double
-data Dist a = Dist {logDensity :: Density a -> LogLikelihood,
-                    distSample :: (PrimMonad m) => PRNG m -> m (Density a)}
-deriving instance Typeable1 Dist
diff --git a/Language/Hakaru/Util/Coda.hs b/Language/Hakaru/Util/Coda.hs
deleted file mode 100644
--- a/Language/Hakaru/Util/Coda.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Language.Hakaru.Util.Coda where
-
-import Statistics.Autocorrelation
-import qualified Data.Packed.Vector as V
-import qualified Data.Vector.Generic as G
-
-effectiveSampleSize :: [Double] -> Double
-effectiveSampleSize samples = n / (1 + 2*(G.sum rho))
-  where n = fromIntegral (V.dim vec)
-        vec = V.fromList samples
-        cov = autocovariance vec
-        rho = G.map (/ G.head cov) cov
-
-meanVariance :: Fractional a => [a] -> (a,a)
-meanVariance lst = (av,sigma2)
-  where
-    n   = fromIntegral $ length lst
-    av  = sum lst / n
-    sigma2 = (foldr (\x acc -> sqr (x - av) + acc) 0 lst) / (n - 1)
-    sqr x = x * x
diff --git a/Language/Hakaru/Util/Csv.hs b/Language/Hakaru/Util/Csv.hs
deleted file mode 100644
--- a/Language/Hakaru/Util/Csv.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# LANGUAGE TypeOperators #-}
-
-module Language.Hakaru.Util.Csv ((:::)((:::)), decodeFile, decodeGZipFile,
-                 decodeFileStream, decodeGZipFileStream) where
-
-import Data.Csv ( HasHeader(..), FromRecord(..), FromField(..)
-                , ToRecord(..), ToField(..), decode)
-import qualified Data.Csv.Streaming as CS (decode)
-import Codec.Compression.GZip (decompress)
-import qualified Data.Foldable as F
-import qualified Data.ByteString.Lazy as B
-import qualified Data.Vector as V
-import Control.Applicative ((<*>), (<$>))
-
-data a ::: b = a ::: b deriving (Eq, Ord, Read, Show)
-infixr 5 :::
-
-instance (FromField a, FromRecord b) => FromRecord (a ::: b) where
-  parseRecord v | V.null v  = fail "too few fields in input record"
-                | otherwise = (:::) <$> parseField (V.head v) <*> parseRecord (V.tail v)
-
-instance (ToField a, ToRecord b) => ToRecord (a ::: b) where
-  toRecord (a ::: b) = V.cons (toField a) (toRecord b)
-
-decodeBytes :: FromRecord a => B.ByteString -> [a]
-decodeBytes bs = case decode HasHeader bs of
-                   Left _ -> []
-                   Right v -> V.toList v
-
-decodeFile :: FromRecord a => FilePath -> IO [a]
-decodeFile = fmap decodeBytes . B.readFile
-
-decodeGZipFile :: FromRecord a => FilePath -> IO [a]
-decodeGZipFile = fmap (decodeBytes . decompress) . B.readFile
-
-decodeFileStream :: FromRecord a => FilePath -> IO [a]
-decodeFileStream = fmap (F.toList . CS.decode HasHeader) . B.readFile
-
-decodeGZipFileStream :: FromRecord a => FilePath -> IO [a]
-decodeGZipFileStream = fmap (F.toList . CS.decode HasHeader . decompress) . B.readFile
diff --git a/Language/Hakaru/Util/Extras.hs b/Language/Hakaru/Util/Extras.hs
deleted file mode 100644
--- a/Language/Hakaru/Util/Extras.hs
+++ /dev/null
@@ -1,79 +0,0 @@
-{-|
-  Functions on lists and sequences.
-  Some of the functions follow the style of Data.Random.Extras 
-  (from the random-extras package), but are written for use with
-  PRNGs from the "mwc-random" package rather than from the "random-fu" package.
--}
-
-module Language.Hakaru.Util.Extras where
-
-import qualified Data.Sequence as S
-import qualified System.Random.MWC as MWC
-import Data.Maybe
-import qualified Data.Foldable as F
-
-extract :: S.Seq a -> Int -> Maybe (S.Seq a, a)
-extract s i | S.null r = Nothing
-            | otherwise  = Just (a S.>< c, b)
-    where (a, r) = S.splitAt i s 
-          (b S.:< c) = S.viewl r
-
-randomExtract :: S.Seq a -> MWC.GenIO -> IO (Maybe (S.Seq a, a))
-randomExtract s g = do
-  i <- MWC.uniformR (0, S.length s - 1) g
-  return $ extract s i
-
-{-| 
-  Given a sequence, return a *sorted* sequence of
-  n randomly selected elements from *distinct positions* in the sequence
--}
-
-randomElems :: Ord a => S.Seq a -> Int -> IO (S.Seq a)
-randomElems s n = do 
-  g <- MWC.create
-  randomElemsTR S.empty s g n
-
-randomElemsTR :: Ord a => S.Seq a -> S.Seq a -> MWC.GenIO -> Int -> IO (S.Seq a)
-randomElemsTR ixs s g n
-    | n == S.length s = return $ S.unstableSort s
-    | n == 1 = do (_,i) <- fmap fromJust (randomExtract s g)
-                  return.S.unstableSort $ i S.<| ixs
-    | otherwise = do (s',i) <- fmap fromJust (randomExtract s g)
-                     (randomElemsTR $! (i S.<| ixs)) s' g (n-1)
-
-{-|
-  Chop a sequence at the given indices. 
-  Assume number of indices given < length of sequence to be chopped
--}
-
-pieces :: S.Seq a -> S.Seq Int -> [S.Seq a]
-pieces s ixs = let f (ps,r,x) y = let (p,r') = S.splitAt (y-x) r
-                                  in (p:ps,r',y)
-                   g (a,b,_) = b:a
-               in g $ F.foldl f ([],s,0) ixs
-
-{-|
-  Given n, chop a sequence at m random points
-  where m = min (length-1, n-1)
--}
-
-randomPieces :: Int -> S.Seq a -> IO [S.Seq a]
-randomPieces n s
-    | n >= l = return $ F.toList $ fmap S.singleton s
-    | otherwise = do ixs <- randomElems (S.fromList [1..l-1]) (n-1)
-                     return $ pieces s ixs
-    where l = S.length s
-
-{-|
-  > pairs [1,2,3,4]
-  [(1,2),(1,3),(1,4),(2,3),(2,4),(3,4)]
-  > pairs [1,2,4,4]
-  [(1,2),(1,4),(1,4),(2,4),(2,4),(4,4)]
--}
-
-pairs :: [a] -> [(a,a)]
-pairs [] = []
-pairs (x:xs) = (zip (repeat x) xs) ++ pairs xs
-
-l2Norm :: Floating a => [a] -> a
-l2Norm l = sqrt.sum $ zipWith (*) l l
diff --git a/Language/Hakaru/Util/Visual.hs b/Language/Hakaru/Util/Visual.hs
deleted file mode 100644
--- a/Language/Hakaru/Util/Visual.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Language.Hakaru.Util.Visual where
-
-import System.IO
-import Control.Monad
-
-import Data.Aeson
-import Data.List
-import qualified Data.Text as T
-import qualified Data.ByteString.Lazy.Char8 as B
---import qualified Data.ByteString.Char8 as BS
-
-plot :: Show a => [a] -> String -> IO ()
-plot samples filename = do
-  h <- openFile filename WriteMode
-  hPrint h samples
-  hClose h
-
-batchPrint :: Show a => Int -> [a] -> IO ()
-batchPrint n l = do
-  let batch = take n l
-  print batch
-  when (length batch == n) $ batchPrint n (drop n l)
-
-viz :: ToJSON a => Int -> [String] -> [[a]] -> IO ()
-viz n name samples = viz' n 50 0 name samples
-
-viz' :: ToJSON a => Int -> Int -> Int -> [String] -> [[a]] -> IO ()
-viz' n c cur name samples = do
-  putStrLn batch
-  when (c+cur < n) $
-       viz' n c (cur+c) name (drop c samples)
-  where
-    total = "total_samples" .= n
-    current_sample = "current_sample" .= cur
-    chunk = object (zipWith (\ name' s -> T.pack name' .= s)
-                            name
-                            (transpose $ take c samples))
-    batch = B.unpack $ encode
-            (object ["rvars" .= chunk,
-                     total,
-                     current_sample])
diff --git a/Tests/Distribution.hs b/Tests/Distribution.hs
deleted file mode 100644
--- a/Tests/Distribution.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module Tests.Distribution where
-
-import Control.Monad
-import qualified System.Random.MWC as MWC
-
-import Language.Hakaru.Types
-import Language.Hakaru.Util.Coda
-import Language.Hakaru.Distribution hiding (choose)
-
-import Test.QuickCheck
-import Test.QuickCheck.Monadic as QM
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-
-fromDiscreteToNum = fromIntegral . fromEnum . fromDiscrete
-sq x = x * x
-
-almostEqual :: (Num a, Ord a) => a -> a -> a -> Bool
-almostEqual tol x y = abs (x - y) < tol
-
-quickArg :: IO ()
-quickArg = quickCheckWith stdArgs {maxSuccess = 2000} (\ x -> almostEqual tol x x)
-  where tol :: Double
-        tol = 1e-5
-
-qtest = [testProperty "checking beta" $ QM.monadicIO betaTest,
-         testProperty "checking bern" $ QM.monadicIO bernTest]
-
-betaTest = do
-  Positive a <- QM.pick arbitrary
-  Positive b <- QM.pick arbitrary
-  g <- QM.run $ MWC.create
-  samples <- QM.run $ replicateM 1000 $ distSample (beta a b) g
-  let (mean, variance) = meanVariance (map fromLebesgue samples)
-  QM.assert $ (almostEqual tol mean     (mu  a b)) && 
-              (almostEqual tol variance (var a b))
-  where tol     = 1e-1
-        mu a b  = a / (a + b)
-        var a b = a*b / ((sq $ a + b) * (a + b + 1))
-
-bernTest = do
-   p <- QM.pick $ choose (0, 1)
-   g <- QM.run $ MWC.create
-   samples <- QM.run $ replicateM 1000 $ distSample (bern p) g
-   let (mean, variance) = meanVariance (map fromDiscreteToNum samples)
-   QM.assert $ (almostEqual tol mean     (mu  p)) && 
-               (almostEqual tol variance (var p))
-   where tol   = 1e-1
-         mu p  = p
-         var p = p*(1-p)
diff --git a/Tests/ImportanceSampler.hs b/Tests/ImportanceSampler.hs
deleted file mode 100644
--- a/Tests/ImportanceSampler.hs
+++ /dev/null
@@ -1,119 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module Tests.ImportanceSampler where
-
-import Data.Dynamic
-import Language.Hakaru.Types
-import Language.Hakaru.Lambda
-import Language.Hakaru.Distribution
-import Language.Hakaru.ImportanceSampler
-import qualified System.Random.MWC as MWC
-
--- import Test.QuickCheck.Monadic
-import Tests.Models
-
--- Some test programs in our language
-
-test_mixture :: IO ()
-test_mixture = MWC.create >>= sample prog_mixture conds >>=
-               print . take 10 >>
-               putChar '\n' >>
-               empiricalMeasure 1000 prog_mixture conds >>=
-               print
-  where conds = [Just (toDyn (Lebesgue 2 :: Density Double))]
-
-prog_dup :: Measure (Bool, Bool)
-prog_dup = do
-  let c = unconditioned (bern 0.5)
-  x <- c
-  y <- c
-  return (x,y)
-
-prog_dbn :: Measure Bool
-prog_dbn = do
-  s0 <- unconditioned (bern 0.75)
-  s1 <- unconditioned (if s0 then bern 0.75 else bern 0.25)
-  _  <- conditioned   (if s1 then bern 0.90 else bern 0.10)
-  s2 <- unconditioned (if s1 then bern 0.75 else bern 0.25)
-  _  <- conditioned   (if s2 then bern 0.90 else bern 0.10)
-  return s2
-
-test_dbn :: IO ()
-test_dbn = MWC.create >>= sample prog_dbn conds >>=
-           print . take 10 >>
-           putChar '\n' >>
-           empiricalMeasure 1000 prog_dbn conds >>=
-           print 
-  where conds = [Just (toDyn (Discrete True)),
-                 Just (toDyn (Discrete True))]
-
-prog_hmm :: Integer -> Measure Bool
-prog_hmm n = do
-  s <- unconditioned (bern 0.75) 
-  loop_hmm n s
-
-loop_hmm :: Integer -> (Bool -> Measure Bool)
-loop_hmm !numLoops s = do
-    _ <- conditioned   (if s then bern 0.90 else bern 0.10)
-    u <- unconditioned (if s then bern 0.75 else bern 0.25)
-    if (numLoops > 1) then loop_hmm (numLoops - 1) u 
-                      else return s
-
-test_hmm :: IO ()
-test_hmm = MWC.create >>= sample (prog_hmm 2) conds >>=
-           print . take 10 >>
-           putChar '\n' >>
-           empiricalMeasure 1000 (prog_hmm 2) conds >>=
-           print 
-  where conds = [Just (toDyn (Discrete True)),
-                 Just (toDyn (Discrete True))]
-
-prog_carRoadModel :: Measure (Double, Double)
-prog_carRoadModel = do
-  speed <- unconditioned (uniform 5 15)
-  let z0 = lit 0 
-  _ <- conditioned    (normal z0 1)
-  z1 <- unconditioned (normal (z0 + speed) 1)
-  _ <- conditioned    (normal z1 1)
-  z2 <- unconditioned (normal (z1 + speed) 1)	
-  _ <- conditioned    (normal z2 1)
-  z3 <- unconditioned (normal (z2 + speed) 1)	
-  _ <- conditioned    (normal z3 1)
-  z4 <- unconditioned (normal (z3 + speed) 1)	
-  return (z4, z3)
-
-test_carRoadModel :: IO ()
-test_carRoadModel = MWC.create >>= sample prog_carRoadModel conds >>=
-                    print . take 10 >>
-                    putChar '\n' >>
-                    empiricalMeasure 1000 prog_carRoadModel conds >>=
-                    print 
-  where conds = [Just (toDyn (Lebesgue 0  :: Density Double)),
-                 Just (toDyn (Lebesgue 11 :: Density Double)), 
-                 Just (toDyn (Lebesgue 19 :: Density Double)),
-                 Just (toDyn (Lebesgue 33 :: Density Double))]
-
-prog_categorical :: Measure Bool
-prog_categorical = do 
-  rain <- unconditioned (categorical [(True, 0.2), (False, 0.8)]) 
-  sprinkler <- unconditioned (if rain
-                              then bern 0.01 else bern 0.4)
-  _ <- conditioned (if rain
-                    then (if sprinkler then bern 0.99 else bern 0.8)
-	            else (if sprinkler then bern 0.90 else bern 0.1))
-  return rain
-
-test_categorical :: IO ()
-test_categorical = MWC.create >>= sample prog_categorical conds >>=
-                   print . take 10 >>
-                   putChar '\n' >>
-                   empiricalMeasure 1000 prog_categorical conds >>=
-                   print 
-  where conds = [Just (toDyn (Discrete True))]
-
-prog_multiple_conditions :: Measure Double
-prog_multiple_conditions = do
-  b <- unconditioned (beta 1 1)
-  _ <- conditioned (bern b)
-  _ <- conditioned (bern b)
-  return b
diff --git a/Tests/Metropolis.hs b/Tests/Metropolis.hs
deleted file mode 100644
--- a/Tests/Metropolis.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module Tests.Metropolis where
-
-import Data.Dynamic
-
-import Language.Hakaru.Types
-import Language.Hakaru.Lambda
-import Language.Hakaru.Metropolis
-import Language.Hakaru.Distribution (bern, normal, uniform, beta)
-
--- import Test.QuickCheck.Monadic
--- import Distribution.TestSuite.QuickCheck
-import Tests.Models
-
-test_mixture :: IO [Bool]
-test_mixture = mcmc prog_mixture [Just (toDyn (Lebesgue (-2) :: Density Double))]
-
-test_multiple_conditions :: IO [Double]
-test_multiple_conditions = do
-  mcmc prog_multiple_conditions [Just (toDyn (Discrete True)),
-                                 Just (toDyn (Discrete False))]
-
-prog_two_normals :: Measure Bool
-prog_two_normals = unconditioned (bern 0.5) `bind` \coin ->
-       ifThenElse coin (conditioned (normal 0 1))
-                       (conditioned (normal 100 1)) `bind` \_ ->
-       return coin
-
-test_two_normals :: IO [Bool]
-test_two_normals = mcmc prog_two_normals [Just (toDyn (Lebesgue 1 :: Density Double))]
-
-test_normal :: IO [Double]
-test_normal = mcmc (unconditioned (normal 1 3)) []
-
-prog_joint =  do
-  bias <- unconditioned $ beta 1 1
-  coin <- unconditioned $ bern bias
-  return (bias, coin)
-
-prog_condition = condition prog_joint True
-
-test_condition :: IO [Double]
-test_condition = mcmc prog_condition []
-
diff --git a/Tests/Models.hs b/Tests/Models.hs
deleted file mode 100644
--- a/Tests/Models.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# LANGUAGE NoMonomorphismRestriction, GADTs #-}
-module Tests.Models where
-
-import Prelude hiding (Real)
-
-import Language.Hakaru.Syntax2
-import Language.Hakaru.Lambda
-import qualified Language.Hakaru.Types as T
-
--- if we want to forgo the (D m) constraint, need to decorate the
--- program a little more.
-prog_mixture :: (Meas m, D m ~ T.Dist ) => m Bool
-prog_mixture = do
-  c <- unconditioned (bern 0.5)
-  _ <- conditioned (ifThenElse c (normal 1 1)
-                                 (uniform 0 3))
-  return c
-
-prog_multiple_conditions :: (Meas m, D m ~ T.Dist) => m Double
-prog_multiple_conditions = do
-  b <- unconditioned (beta 1 1)
-  _ <- conditioned (bern b)
-  _ <- conditioned (bern b)
-  return b
-
-
diff --git a/Tests/Tests.hs b/Tests/Tests.hs
deleted file mode 100644
--- a/Tests/Tests.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module Main where
-
-import Prelude hiding (Real)
-
-import qualified Tests.ImportanceSampler as IS
-import qualified Tests.Metropolis as MH
-import qualified Tests.Distribution as D
-
-import Language.Hakaru.Syntax2
-import Language.Hakaru.Lambda
-import qualified Language.Hakaru.Types as T
-
-import Test.Framework (defaultMain, testGroup)
-import Test.Framework.Providers.HUnit
-
-import Test.HUnit
-
-tests = [
-        testGroup "Distribution checks" D.qtest,   
-        testCase "alwaysPass" (1 @?= 1)
-        --testCase "alwaysFail" (error "Fail!")
-    ]
-
-main = defaultMain tests
diff --git a/commands/Compile.hs b/commands/Compile.hs
new file mode 100644
--- /dev/null
+++ b/commands/Compile.hs
@@ -0,0 +1,184 @@
+{-# LANGUAGE CPP,
+             OverloadedStrings,
+             PatternGuards,
+             DataKinds,
+             KindSignatures,
+             GADTs,
+             FlexibleContexts,
+             TypeOperators,
+             RankNTypes
+             #-}
+
+module Main where
+
+import qualified Language.Hakaru.Syntax.AST as T
+import           Language.Hakaru.Syntax.AST.Transforms
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.TypeCheck
+
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Types.Sing (Sing(SFun, SMeasure))
+
+import           Language.Hakaru.Pretty.Haskell
+import           Language.Hakaru.Command
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+#endif
+
+import           Data.Text                  as TxT
+import qualified Data.Text.IO               as IO
+import           Data.Maybe (fromJust)
+import           Data.Monoid ((<>))
+import           System.IO (stderr)
+import           Text.PrettyPrint    hiding ((<>))
+import qualified Options.Applicative as O
+import           System.FilePath
+
+
+data Options =
+  Options { fileIn          :: String
+          , fileOut         :: Maybe String
+          , asModule        :: Maybe String
+          , fileIn2         :: Maybe String
+          , logFloatPrelude :: Bool
+          , optimize        :: Bool
+          } deriving Show
+
+main :: IO ()
+main = do
+  opts <- parseOpts
+  case fileIn2 opts of
+    Just _  -> compileRandomWalk opts
+    Nothing -> compileHakaru opts
+
+parseOpts :: IO Options
+parseOpts = O.execParser $ O.info (O.helper <*> options)
+                         $ O.fullDesc <> O.progDesc "Compile Hakaru to Haskell"
+
+{-
+
+There is some redundancy in Compile.hs, Hakaru.hs, and HKC.hs in how we decide
+what to run given which arguments. There may be a way to unify these.
+
+-}
+
+options :: O.Parser Options
+options = Options
+  <$> O.strArgument (O.metavar "INPUT" <>
+                     O.help "Program to be compiled" )
+  <*> (O.optional $
+        O.strOption (O.metavar "FILE" <>
+                     O.short 'o' <>
+                     O.help "Optional output file name"))
+  <*> (O.optional $
+        O.strOption (O.long "as-module" <>
+                     O.short 'M' <>
+                     O.help "creates a haskell module with this name"))
+  <*> (O.optional $
+        O.strOption (O.long "transition-kernel" <>
+                     O.help "Use this program as transition kernel for running a markov chain"))
+  <*> O.switch (O.long "logfloat-prelude" <>
+                O.help "use logfloat prelude for numeric stability")
+  <*> O.switch (O.short 'O' <>
+                O.help "perform Hakaru AST optimizations")
+
+prettyProg :: (ABT T.Term abt)
+           => String
+           -> Sing a
+           -> abt '[] a
+           -> String
+prettyProg name typ ast =
+    renderStyle style
+    (    sep [text (name ++ " ::"), nest 2 (prettyType typ)]
+     $+$ sep [text (name ++ " =") , nest 2 (pretty     ast)] )
+
+compileHakaru
+    :: Options
+    -> IO ()
+compileHakaru opts = do
+    let infile = fileIn opts
+    prog <- readFromFile infile
+    case parseAndInfer prog of
+      Left err                 -> IO.hPutStrLn stderr err
+      Right (TypedAST typ ast) -> do
+        let ast' = (if optimize opts then optimizations else id) (et ast)
+        writeHkHsToFile infile (fileOut opts) . TxT.unlines $
+          header (logFloatPrelude opts) (asModule opts) ++
+          [ pack $ prettyProg "prog" typ ast' ] ++
+          (case asModule opts of
+             Nothing -> footer
+             Just _  -> [])
+  where et = expandTransformations
+
+compileRandomWalk
+    :: Options
+    -> IO ()
+compileRandomWalk opts = do
+    let f1 = fileIn opts
+        f2 = fromJust . fileIn2 $ opts
+    p1 <- readFromFile f1
+    p2 <- readFromFile f2
+    case (parseAndInfer p1, parseAndInfer p2) of
+      (Right (TypedAST typ1 ast1), Right (TypedAST typ2 ast2)) ->
+          -- TODO: Use better error messages for type mismatch
+          case (typ1, typ2) of
+            (SFun a (SMeasure b), SMeasure c)
+              | (Just Refl, Just Refl) <- (jmEq1 a b, jmEq1 b c)
+              -> writeHkHsToFile f1 (fileOut opts) . TxT.unlines $
+                   header (logFloatPrelude opts) (asModule opts) ++
+                   [ pack $ prettyProg "prog1" typ1 (expandTransformations ast1) ] ++
+                   [ pack $ prettyProg "prog2" typ2 (expandTransformations ast2) ] ++
+                   (case asModule opts of
+                      Nothing -> footerWalk
+                      Just _  -> [])
+            _ -> IO.hPutStrLn stderr "compile: programs have wrong type"
+      (Left err, _) -> IO.hPutStrLn stderr err
+      (_, Left err) -> IO.hPutStrLn stderr err
+
+writeHkHsToFile :: String -> Maybe String -> Text -> IO ()
+writeHkHsToFile inFile moutFile content =
+  let outFile =  case moutFile of
+                   Nothing -> replaceFileName inFile (takeBaseName inFile) ++ ".hs"
+                   Just x  -> x
+  in  writeToFile outFile content
+
+header :: Bool -> Maybe String -> [Text]
+header logfloats mmodule =
+  [ "{-# LANGUAGE DataKinds, NegativeLiterals #-}"
+  , TxT.unwords [ "module"
+                , case mmodule of
+                    Just m  -> pack m
+                    Nothing -> "Main"
+                , "where" ]
+  , ""
+  , if logfloats
+    then TxT.unlines [ "import           Data.Number.LogFloat (LogFloat)"
+                     , "import           Prelude hiding (product, exp, log, (**), pi)"
+                     , "import           Language.Hakaru.Runtime.LogFloatPrelude"
+                     ]
+    else TxT.unlines [ "import           Prelude hiding (product)"
+                     , "import           Language.Hakaru.Runtime.Prelude"
+                     ]
+  , "import           Language.Hakaru.Runtime.CmdLine"
+  , "import           Language.Hakaru.Types.Sing"
+  , "import qualified System.Random.MWC                as MWC"
+  , "import           Control.Monad"
+  , "import           System.Environment (getArgs)"
+  , ""
+  ]
+
+footer :: [Text]
+footer =
+    ["","main :: IO ()"
+    , TxT.concat ["main = makeMain prog =<< getArgs"]]
+
+footerWalk :: [Text]
+footerWalk =
+  [ ""
+  , "main :: IO ()"
+  , "main = do"
+  , "  g <- MWC.createSystemRandom"
+  , "  x <- prog2 g"
+  , "  iterateM_ (withPrint $ flip prog1 g) x"
+  ]
diff --git a/commands/Density.hs b/commands/Density.hs
new file mode 100644
--- /dev/null
+++ b/commands/Density.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings, DataKinds, GADTs #-}
+
+module Main where
+
+import           Language.Hakaru.Pretty.Concrete
+import           Language.Hakaru.Syntax.TypeCheck
+
+import           Language.Hakaru.Types.Sing
+import           Language.Hakaru.Disintegrate
+import           Language.Hakaru.Evaluation.ConstantPropagation
+import           Language.Hakaru.Command
+
+import           Data.Text
+import qualified Data.Text.IO as IO
+import           System.IO (stderr)
+
+import           System.Environment
+
+main :: IO ()
+main = do
+  args  <- getArgs
+  progs <- mapM readFromFile args
+  case progs of
+      [prog] -> runDensity prog
+      _      -> IO.hPutStrLn stderr "Usage: density <file>"
+
+runDensity :: Text -> IO ()
+runDensity prog =
+    case parseAndInfer prog of
+    Left  err                -> IO.hPutStrLn stderr err
+    Right (TypedAST typ ast) ->
+        case typ of
+            SMeasure _ ->
+                case determine (density ast) of
+                  Just ast' -> print . pretty $ constantPropagation ast'
+                  Nothing   -> IO.hPutStrLn stderr "No density found"
+            _               -> IO.hPutStrLn stderr "Density is only available for measure terms"
+
diff --git a/commands/Disintegrate.hs b/commands/Disintegrate.hs
new file mode 100644
--- /dev/null
+++ b/commands/Disintegrate.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE OverloadedStrings
+           , PatternGuards
+           , TypeOperators
+           , DataKinds
+           , GADTs
+           , KindSignatures
+           , FlexibleContexts
+           , RankNTypes
+           , CPP #-}
+
+module Main where
+
+import           Language.Hakaru.Pretty.Concrete
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.AST as AST
+
+import           Language.Hakaru.Types.Sing
+import           Language.Hakaru.Types.DataKind
+import           Language.Hakaru.Disintegrate
+import           Language.Hakaru.Evaluation.ConstantPropagation
+import           Language.Hakaru.Command
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+#endif
+
+import           Data.Monoid
+import           Control.Monad (when)
+import qualified Data.Text as T
+import qualified Data.Text.IO as IO
+import           System.IO (stderr)
+
+import           Options.Applicative as O
+
+data Options = Options { total   :: Bool
+                       , index   :: Int
+                       , program :: String }
+
+options :: Parser Options
+options = Options
+          <$> switch
+              ( long "total" <>
+                short 't' <>
+                help "Whether to show the total number of disintegrations" )
+          <*> option auto
+              ( long "index" <>
+                short 'i' <>
+                metavar "INDEX" <>
+                value 0 <>
+                help "The index of the desired result in the list of disintegrations (default: 0)" )
+          <*> strArgument
+              ( metavar "PROGRAM" <>
+                help "File containing program to disintegrate" )
+
+parseOpts :: IO Options
+parseOpts = execParser $ info (helper <*> options) $
+            fullDesc <>
+            progDesc "Disintegrate a Hakaru program" <>
+            header
+            "disintegrate: symbolic conditioning of probabilistic programs"
+
+main :: IO ()
+main = do
+  args  <- parseOpts
+  case args of
+    Options t i infile -> do
+      prog <- readFromFile infile
+      runDisintegrate prog t i
+
+runDisintegrate :: T.Text -> Bool -> Int -> IO ()
+runDisintegrate prog showTotal i =
+    case parseAndInfer prog of
+    Left  err      -> IO.hPutStrLn stderr err
+    Right typedAST -> go Nil1 typedAST
+    where
+      go :: List1 Variable (xs :: [Hakaru])
+         -> TypedAST (TrivialABT AST.Term)
+         -> IO ()
+      go xs (TypedAST typ ast)
+          = case typ of
+              SMeasure (SData (STyCon sym `STyApp` _ `STyApp` _) _)
+                  | Just Refl <- jmEq1 sym sSymbol_Pair
+                     -> case disintegrate ast of
+                          [] -> IO.hPutStrLn stderr
+                                "No disintegration found"
+                          rs -> when showTotal
+                                (IO.hPutStrLn stderr.T.pack $
+                                 "Number of disintegrations: " ++ show (length rs)) >>
+                                lams xs (print.pretty.constantPropagation) (rs Prelude.!! i)
+              SFun _ b ->
+                caseVarSyn ast putErrorMsg $ \t ->
+                case t of
+                  Lam_ :$ body :* End ->
+                      caseBind body $ \x e ->
+                      go (append1 xs (Cons1 x Nil1)) (TypedAST b e)
+                  _ -> putErrorMsg ast
+              _ -> putErrorMsg ast
+                   
+putErrorMsg :: (Show a) => a -> IO ()
+putErrorMsg _ = IO.hPutStrLn stderr . T.pack $
+                "Can only disintegrate (functions over) measures over pairs"
+                -- ++ "\nGiven\n" ++ show a
+
+-- | Use a list of variables to wrap lambdas around a given term
+lams :: (ABT AST.Term abt)
+     => List1 Variable (xs :: [Hakaru])
+     -> (forall b. abt '[] b -> IO ()) -> abt '[] a -> IO ()
+lams Nil1         k = k
+lams (Cons1 x xs) k = lams xs (k . lam_ x)
diff --git a/commands/HKC.hs b/commands/HKC.hs
new file mode 100644
--- /dev/null
+++ b/commands/HKC.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Main where
+
+import Language.Hakaru.Evaluation.ConstantPropagation
+import Language.Hakaru.Syntax.TypeCheck
+import Language.Hakaru.Syntax.AST.Transforms (expandTransformations)
+import Language.Hakaru.Syntax.ANF      (normalize)
+import Language.Hakaru.Syntax.CSE      (cse)
+import Language.Hakaru.Syntax.Prune    (prune)
+import Language.Hakaru.Syntax.Uniquify (uniquify)
+import Language.Hakaru.Syntax.Hoist    (hoist)
+import Language.Hakaru.Summary
+import Language.Hakaru.Command
+import Language.Hakaru.CodeGen.Wrapper
+import Language.Hakaru.CodeGen.CodeGenMonad
+import Language.Hakaru.CodeGen.AST
+import Language.Hakaru.CodeGen.Pretty
+
+import           Control.Monad.Reader
+
+import           Data.Monoid
+import           Data.Maybe (isJust)
+import           Data.Text hiding (any,map,filter,foldr)
+import qualified Data.Text.IO as IO
+import           Text.PrettyPrint (render)
+import           Options.Applicative
+import           System.IO
+import           System.Process
+import           System.Exit
+import           Prelude hiding (concat)
+
+data Options =
+ Options { debug            :: Bool
+         , optimize         :: Maybe Int
+         , summaryOpt       :: Bool
+         , make             :: Maybe String
+         , asFunc           :: Maybe String
+         , fileIn           :: String
+         , fileOut          :: Maybe String
+         , par              :: Bool -- turns on simd and sharedMem
+         , noWeightsOpt     :: Bool
+         , showProbInLogOpt :: Bool
+         , garbageCollector :: Bool
+         -- , logProbs         :: Bool
+         } deriving Show
+
+
+main :: IO ()
+main = do
+  opts <- parseOpts
+  prog <- readFromFile (fileIn opts)
+  runReaderT (compileHakaru prog) opts
+
+options :: Parser Options
+options = Options
+  <$> switch (  long "debug"
+             <> short 'D'
+             <> help "Prints Hakaru src, Hakaru AST, C AST, C src" )
+  <*> (optional $ option auto (  short 'O'
+                              <> metavar "{0,1,2}"
+                              <> help "perform Hakaru AST optimizations. optimization levels 0,1,2." ))
+  <*> switch (  long "summary"
+             <> short 'S'
+             <> help "Performs summarization optimization" )
+  <*> (optional $ strOption (  long "make"
+                            <> short 'm'
+                            <> help "Compiles generated C code with the compiler ARG"))
+  <*> (optional $ strOption (  long "as-function"
+                            <> short 'F'
+                            <> help "Compiles to a sampling C function with the name ARG" ))
+  <*> strArgument (  metavar "INPUT"
+                  <> help "Program to be compiled")
+  <*> (optional $ strOption (  short 'o'
+                            <> metavar "OUTPUT"
+                            <> help "output FILE"))
+  <*> switch (  short 'j'
+             <> help "Generates multithreaded and simd parallel programs using OpenMP directives")
+  <*> switch (  long "no-weights"
+             <> short 'w'
+             <> help "Don't print the weights")
+  <*> switch (  long "show-prob-log"
+             <> help "Shows prob types as 'exp(<log-domain-value>)' instead of '<value>'")
+  <*> switch (  long "garbage-collector"
+             <> short 'g'
+             <> help "Use Boehm Garbage Collector")
+  -- <*> switch (  long "-no-log-space-probs"
+  --            <> help "Do not log `prob` types; WARNING this is more likely to underflow.")
+
+parseOpts :: IO Options
+parseOpts = execParser $ info (helper <*> options)
+                       $ fullDesc <> progDesc "Compile Hakaru to C"
+
+compileHakaru :: Text -> ReaderT Options IO ()
+compileHakaru prog = ask >>= \config -> lift $ do
+  prog' <- parseAndInferWithDebug (debug config) prog
+  case prog' of
+    Left err -> IO.hPutStrLn stderr err
+    Right (TypedAST typ ast) -> do
+      astS <- case summaryOpt config of
+                True  -> summary (expandTransformations ast)
+                False -> return (expandTransformations ast)
+      let ast'    = TypedAST typ $ foldr id astS (abtPasses $ optimize config)
+          outPath = case fileOut config of
+                      (Just f) -> f
+                      Nothing  -> "-"
+          codeGen = wrapProgram ast'
+                                (asFunc config)
+                                (PrintConfig { noWeights     = noWeightsOpt config
+                                             , showProbInLog = showProbInLogOpt config })
+          codeGenConfig = emptyCG { sharedMem = par config
+                                  , simd      = par config
+                                  , managedMem = garbageCollector config}
+          cast    = CAST $ runCodeGenWith codeGen codeGenConfig
+          output  = pack . render . pretty $ cast
+      when (debug config) $ do
+        putErrorLn $ hrule "Hakaru Type"
+        putErrorLn . pack . show $ typ
+        putErrorLn $ hrule "Hakaru AST"
+        putErrorLn $ pack $ show ast
+        when (isJust . optimize $ config) $ do
+          putErrorLn $ hrule "Hakaru AST'"
+          putErrorLn $ pack $ show ast'
+        putErrorLn $ hrule "C AST"
+        putErrorLn $ pack $ show cast
+        putErrorLn $ hrule "Fin"
+      case make config of
+        Nothing -> writeToFile outPath output
+        Just cc -> makeFile cc (fileOut config) (unpack output) config
+
+  where hrule s = concat [ "\n<=======================| "
+                         , s
+                         ," |=======================>\n"]
+        abtPasses Nothing  = []
+        abtPasses (Just 0) = [ constantPropagation ]
+        abtPasses (Just 1) = [ constantPropagation
+                             , uniquify
+                             , prune
+                             , cse
+                             , hoist
+                             , uniquify ]
+        abtPasses (Just 2) = abtPasses (Just 1) ++ [normalize]
+
+        abtPasses _ = error "only optimization levels are 0, 1, and 2"
+
+putErrorLn :: Text -> IO ()
+putErrorLn = IO.hPutStrLn stderr
+
+
+makeFile :: String -> Maybe String -> String -> Options -> IO ()
+makeFile cc mout prog opts =
+  do let p = proc cc $ ["-pedantic"
+                       ,"-std=c99"
+                       ,"-lm"
+                       ,"-xc"
+                       ,"-"]
+                       ++ (case mout of
+                            Nothing -> []
+                            Just o  -> ["-o" ++ o])
+                       ++ (if par opts then ["-fopenmp"] else [])
+     (Just inH, _, _, pH) <- createProcess p { std_in    = CreatePipe
+                                             , std_out   = CreatePipe }
+     hPutStrLn inH prog
+     hClose inH
+     exit <- waitForProcess pH
+     case exit of
+       ExitSuccess -> return ()
+       _           -> error $ cc ++ " returned exit code: " ++ show exit
diff --git a/commands/Hakaru.hs b/commands/Hakaru.hs
new file mode 100644
--- /dev/null
+++ b/commands/Hakaru.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE OverloadedStrings
+           , PatternGuards
+           , DataKinds
+           , GADTs
+           , TypeOperators
+           #-}
+
+module Main where
+
+import           Language.Hakaru.Syntax.AST.Transforms
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Syntax.TypeCheck.Unification
+import           Language.Hakaru.Syntax.Value
+
+import           Language.Hakaru.Types.Sing
+import           Language.Hakaru.Types.DataKind
+
+import           Language.Hakaru.Sample
+import           Language.Hakaru.Pretty.Concrete
+import           Language.Hakaru.Command ( parseAndInfer'
+                                         , readFromFile', Term, Source
+                                         , sourceInput
+                                         )
+
+import           Control.Applicative   (Applicative(..), (<$>), liftA2)
+import           Control.Monad
+
+import           Data.Monoid
+import qualified Data.Text.IO as IO
+import qualified Data.Vector  as V
+import           Data.Word
+import           System.IO (stderr)
+import           Text.PrettyPrint (renderStyle, style, mode, Mode(LeftMode))
+
+import qualified Options.Applicative as O
+import qualified System.Random.MWC   as MWC
+
+data Options = Options
+  { noWeights  :: Bool
+  , seed       :: Maybe Word32
+  , transition :: Maybe String
+  , prog       :: String }
+
+options :: O.Parser Options
+options = Options
+  <$> O.switch
+      ( O.short 'w' <>
+        O.long "no-weights" <>
+        O.help "Don't print the weights" )
+  <*> O.optional (O.option O.auto
+      ( O.long "seed" <>
+        O.help "Set random seed" <>
+        O.metavar "seed"))
+  <*> O.optional (O.strOption
+      ( O.long "transition-kernel" <>
+        O.metavar "k" <>
+        O.help "Use this program as transition kernel for running a markov chain"))
+  <*> O.strArgument
+      ( O.metavar "PROGRAM" <>
+        O.help "Hakaru program to run" )
+
+parseOpts :: IO Options
+parseOpts = O.execParser $ O.info (O.helper <*> options)
+      (O.fullDesc <> O.progDesc "Run a hakaru program")
+
+main :: IO ()
+main = do
+  args   <- parseOpts
+  g      <- case seed args of
+              Nothing -> MWC.createSystemRandom
+              Just s  -> MWC.initialize (V.singleton s)
+  case transition args of
+      Nothing    -> runHakaru g (noWeights args) =<< readFromFile' (prog args)
+      Just prog2 -> do prog' <- readFromFile' (prog args)
+                       trans <- readFromFile' prog2
+                       randomWalk g trans prog'
+
+-- TODO: A better needs to be found for passing weights around
+illustrate :: Sing a -> Bool -> MWC.GenIO -> Value a -> IO ()
+illustrate (SMeasure s) weights g (VMeasure m) = do
+    x <- m (VProb 1) g
+    case x of
+      Just (samp, w) -> (if weights then id else withWeight w) (illustrate s weights g samp)
+      Nothing        -> illustrate (SMeasure s) weights g (VMeasure m)
+
+illustrate _ _ _ x = renderLn x
+
+withWeight :: Value 'HProb -> IO () -> IO ()
+withWeight w m = render w >> putStr "\t" >> m
+
+render :: Value a -> IO ()
+render = putStr . renderStyle style {mode = LeftMode} . prettyValue
+
+renderLn :: Value a -> IO ()
+renderLn = putStrLn . renderStyle style {mode = LeftMode} . prettyValue
+
+-- TODO: A better needs to be found for passing weights around
+runHakaru :: MWC.GenIO -> Bool -> Source -> IO ()
+runHakaru g weights progname = do
+    prog' <- parseAndInfer' progname
+    case prog' of
+      Left err                 -> IO.hPutStrLn stderr err
+      Right (TypedAST typ ast) -> do
+        case typ of
+          SMeasure _ -> forever (illustrate typ weights g $ run ast)
+          _          -> illustrate typ weights g $ run ast
+    where
+    run :: Term a -> Value a
+    run = runEvaluate . expandTransformations
+
+randomWalk :: MWC.GenIO -> Source -> Source -> IO ()
+randomWalk g p1 p2 = do
+    let inp = foldl1 (liftA2 (V.++)) $ map sourceInput [p1,p2]
+    p1' <- parseAndInfer' p1
+    p2' <- parseAndInfer' p2
+    case (p1', p2') of
+      (Right (TypedAST typ1 ast1), Right (TypedAST typ2 ast2)) ->
+        let check =
+              unifyFun typ1 Nothing $ \a mb ->
+              unifyMeasure mb Nothing $ \b ->
+              unifyMeasure typ2 Nothing $ \c ->
+              matchTypes a b Nothing (SFun a (SMeasure a)) typ1 $
+              matchTypes b c Nothing mb typ2 $
+              return $ iterateM_ (chain $ run ast1) (run ast2)
+        in either (IO.hPutStrLn stderr) id $
+           runTCM check inp LaxMode
+      (Left err, _) -> IO.hPutStrLn stderr err
+      (_, Left err) -> IO.hPutStrLn stderr err
+    where
+    run :: Term a -> Value a
+    run = runEvaluate . expandTransformations
+
+    chain :: Value (a ':-> b) -> Value ('HMeasure a) -> IO (Value b)
+    chain (VLam f) (VMeasure m) = do
+      Just (samp,_) <- m (VProb 1) g
+      renderLn samp
+      return (f samp)
+
+-- From monad-loops
+iterateM_ :: Monad m => (a -> m a) -> a -> m b
+iterateM_ f = g
+    where g x = f x >>= g
diff --git a/commands/HkMaple.hs b/commands/HkMaple.hs
new file mode 100644
--- /dev/null
+++ b/commands/HkMaple.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE CPP
+           , OverloadedStrings
+           , DataKinds
+           , GADTs
+           , RecordWildCards
+           , ScopedTypeVariables
+           #-}
+
+module Main where
+
+import           Language.Hakaru.Pretty.Concrete as C
+import           Language.Hakaru.Pretty.SExpression as S
+import           Language.Hakaru.Pretty.Haskell as H
+import           Language.Hakaru.Syntax.AST.Transforms
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Command (parseAndInfer', readFromFile')
+
+import           Language.Hakaru.Syntax.Rename
+import           Language.Hakaru.Maple
+
+import           Language.Hakaru.Syntax.Transform (Transform(..)
+                                                  ,someTransformations)
+import           Language.Hakaru.Syntax.IClasses (Some2(..))
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+#endif
+
+import           Data.Monoid ((<>), Monoid(..))
+import qualified Data.Text as Text
+import qualified Data.Text.Utf8 as IO
+import           System.IO (stderr)
+import           Data.List (intercalate)
+import           Text.Read (readMaybe)
+import           Control.Exception(throw)
+import qualified Options.Applicative as O
+import qualified Data.Map as M
+
+
+data Options a
+  = Options
+    { moptions      :: MapleOptions (Maybe String)
+    , no_unicode    :: Bool
+    , toExpand      :: Maybe [Some2 Transform]
+    , printer       :: String
+    , program       :: a }
+  | ListCommands
+  | PrintVersion
+
+
+parseKeyVal :: O.ReadM (String, String)
+parseKeyVal =
+  O.maybeReader $ (\str ->
+    case map Text.strip $ Text.splitOn "," str of
+      [k,v] -> return (Text.unpack k, Text.unpack v)
+      _     -> Nothing) . Text.pack
+
+options :: O.Parser (Options FilePath)
+options = (Options
+  <$> (MapleOptions <$>
+        O.option (O.maybeReader (Just . Just))
+        ( O.long "command" <>
+          O.help ("Command to send to Maple. You may enter a prefix of the command string if "
+                 ++"it uniquely identifies a command. ") <>
+          O.short 'c' <>
+          O.value Nothing )
+    <*> O.switch
+        ( O.long "debug" <>
+          O.help "Prints output that is sent to Maple." )
+    <*> O.option O.auto
+        ( O.long "timelimit" <>
+          O.help "Set Maple to timeout in N seconds." <>
+          O.showDefault <>
+          O.value 90 <>
+          O.metavar "N")
+    <*> (M.fromList <$>
+          O.many (O.option parseKeyVal
+        ( O.long "maple-opt" <>
+          O.short 'm' <>
+          O.help ( "Extra options to send to Maple\neach options is of the form KEY=VAL\n"
+                 ++"where KEY is a Maple name, and VAL is a Maple expression.")
+        )))
+    <*> pure mempty)
+  <*> O.switch
+      ( O.long "no-unicode" <>
+        O.short 'u' <>
+        O.help "Removes unicode characters from names in the Maple output.")
+  <*> O.option (O.maybeReader $ fmap (fmap Just) readMaybe)
+      ( O.short 'e' <>
+        O.long "to-expand" <>
+        O.value Nothing <>
+        O.help "Transformations to be expanded; default is all transformations" )
+  <*> O.strOption
+      ( O.short 'p' <>
+        O.long "printer" <>
+        O.value "concrete" )
+  <*> O.strArgument
+      ( O.metavar "PROGRAM" <>
+        O.help "Filename containing program to be simplified, or \"-\" to read from input." )) O.<|>
+  ( O.flag' ListCommands
+      ( O.long "list-commands" <>
+        O.help "Get list of available commands from Maple." <>
+        O.short 'l') ) O.<|>
+  ( O.flag' PrintVersion
+      ( O.long "version" <>
+        O.help "Prints the version of the Hakaru Maple library." <>
+        O.short 'v') )
+
+parseOpts :: IO (Options FilePath)
+parseOpts = O.execParser $ O.info (O.helper <*> options)
+      (O.fullDesc <> O.progDesc progDesc)
+
+progDesc :: String
+progDesc = unwords
+  ["hk-maple: invokes a Maple command on a Hakaru program. "
+  ,"Given a Hakaru program in concrete syntax and a Maple-Hakaru command,"
+  ,"typecheck the program"
+  ,"invoke the Maple command on the program and its type"
+  ,"pretty print, parse and typecheck the program resulting from Maple"
+  ]
+
+main :: IO ()
+main = parseOpts >>= runMaple
+
+runMaple :: Options FilePath -> IO ()
+runMaple ListCommands =
+  listCommands >>= \cs -> putStrLn $ "Available Hakaru Maple commands:\n\t"++ intercalate ", " cs
+
+runMaple PrintVersion = printVersion
+
+runMaple Options{..} = readFromFile' program >>= parseAndInfer' >>= \prog ->
+  case prog of
+    Left  err  -> IO.hPutStrLn stderr err
+    Right ast  -> do
+      let et = onTypedASTM $ expandTransformationsWith $
+                (maybe id someTransformations toExpand)
+                (allTransformationsWithMOpts moptions{command=()})
+      TypedAST typ ast' <-
+        (case command moptions of
+           Just c  -> sendToMaple' moptions{command=c}
+           Nothing -> return) =<< et ast
+      IO.print
+            $ (case printer of
+                 "concrete" -> C.pretty
+                 "sexpression" -> S.pretty
+                 "haskell" -> H.prettyString typ
+                 _ -> error "Invalid printer requested")
+            $ (if no_unicode then renameAST removeUnicodeChars else id)
+            $ ast'
+
+listCommands :: IO [String]
+listCommands = do
+    let toMaple_ = "use Hakaru, NewSLO in lprint(map(curry(sprintf,`%s`),NewSLO:-Commands)) end use;"
+    fromMaple <- maple toMaple_
+    maybe (throw $ MapleInterpreterException fromMaple toMaple_)
+          return
+          (readMaybe fromMaple)
+
+printVersion :: IO ()
+printVersion =
+  maple "use Hakaru, NewSLO in NewSLO:-PrintVersion() end use;" >>= putStr
diff --git a/commands/Mh.hs b/commands/Mh.hs
new file mode 100644
--- /dev/null
+++ b/commands/Mh.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE OverloadedStrings
+           , PatternGuards
+           , DataKinds
+           , GADTs
+           , KindSignatures
+           , RankNTypes
+           , TypeOperators
+           , FlexibleContexts #-}
+
+module Main where
+
+import           Language.Hakaru.Pretty.Concrete  
+import           Language.Hakaru.Syntax.TypeCheck
+
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Syntax.ABT (ABT(..), dupABT)
+import           Language.Hakaru.Syntax.AST (Term(..), Transform(..))
+import           Language.Hakaru.Syntax.AST.Transforms (expandTransformations)
+import qualified Language.Hakaru.Parser.AST as U
+import           Language.Hakaru.Command hiding (Term)
+  
+import           Data.Text
+import qualified Data.Text.IO as IO
+import           System.IO (stderr)
+
+import           System.Environment
+
+main :: IO ()
+main = do
+  args  <- getArgs
+  progs <- mapM readFromFile args
+  case progs of
+      [prog2, prog1] -> runMH prog1 prog2
+      _              -> IO.hPutStrLn stderr "Usage: mh <target> <proposal>"
+
+runMH :: Text -> Text -> IO ()
+runMH prog1 prog2 =
+    case (parseAndInfer prog1, parseAndInfer prog2) of
+      (Right (TypedAST _ ast1), Right (TypedAST _ ast2)) ->
+         either (IO.hPutStrLn stderr)
+                (elimTypedAST $ \_ -> print . pretty) $
+         runMH' ast1 ast2
+      (Left err, _) -> IO.hPutStrLn stderr err
+      (_, Left err) -> IO.hPutStrLn stderr err
+
+runMH' :: (ABT Term abt)
+       => abt '[] a
+       -> abt '[] b
+       -> Either Text (TypedAST abt)
+runMH' prop tgt =
+  let uast = syn $ U.Transform_ MCMC $
+               (Nil2, syn $ U.InjTyped $ dupABT prop) U.:*
+               (Nil2, syn $ U.InjTyped $ dupABT tgt ) U.:* U.End
+  in do TypedAST rty res <- runTCM (inferType uast) Nothing LaxMode
+        return $ TypedAST rty $ expandTransformations res
diff --git a/commands/Momiji.hs b/commands/Momiji.hs
new file mode 100644
--- /dev/null
+++ b/commands/Momiji.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings, DataKinds, GADTs #-}
+
+module Main where
+
+import qualified Language.Hakaru.Pretty.Maple as Maple
+import           Language.Hakaru.Syntax.AST.Transforms
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Command
+
+import           Data.Text
+import qualified Data.Text.Utf8 as U
+
+import           System.IO (stderr)
+
+main :: IO ()
+main = simpleCommand runPretty "momiji"
+
+runPretty :: Text -> IO ()
+runPretty prog =
+    case parseAndInfer prog of
+    Left  err              -> U.hPut stderr err
+    Right (TypedAST typ ast) -> do
+      U.putStrLnS $ Maple.pretty (expandTransformations ast)
+      U.putStrLn  $ ","
+      U.putStrLnS $ Maple.mapleType typ ""
+
diff --git a/commands/Normalize.hs b/commands/Normalize.hs
new file mode 100644
--- /dev/null
+++ b/commands/Normalize.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings, DataKinds, GADTs #-}
+
+module Main where
+
+import           Language.Hakaru.Pretty.Concrete  
+import           Language.Hakaru.Syntax.AST.Transforms
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Types.Sing
+
+import           Language.Hakaru.Expect (normalize)
+import           Language.Hakaru.Evaluation.ConstantPropagation
+import           Language.Hakaru.Command
+
+import           Data.Text
+import qualified Data.Text.IO as IO
+import           System.IO (stderr)
+
+main :: IO ()
+main = simpleCommand runNormalize "normalize" 
+
+runNormalize :: Text -> IO ()
+runNormalize prog = either (IO.hPutStrLn stderr) print $ do
+  TypedAST typ ast <- parseAndInfer prog
+  res <- normalizeUnderLams typ ast
+  return (pretty res)
+
+normalizeUnderLams :: Sing a -> Term a -> Either Text (Term a)
+normalizeUnderLams (SMeasure _) ast = Right . constantPropagation . normalize $ ast
+normalizeUnderLams (SFun _ typ) ast = underLam (normalizeUnderLams typ) ast
+normalizeUnderLams _            _   = Left "Can only normalize measures"
diff --git a/commands/Pretty.hs b/commands/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/commands/Pretty.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings
+           , DataKinds
+           , GADTs
+           , CPP
+           , RecordWildCards
+           #-}
+
+module Main where
+
+import           Language.Hakaru.Pretty.Concrete
+import           Language.Hakaru.Syntax.AST.Transforms
+import           Language.Hakaru.Syntax.Transform (Transform(..)
+                                                  ,someTransformations)
+import           Language.Hakaru.Syntax.IClasses (Some2(..))
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Command
+
+import qualified Data.Text as T 
+import qualified Data.Text.Utf8 as IO
+import           System.IO (stderr)
+import           Data.Monoid
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>), (<*>))
+#endif
+import qualified Options.Applicative as O
+
+data Options = Options
+  { printType :: Bool 
+  , program   :: FilePath 
+  , toExpand  :: [Some2 Transform]
+  }
+
+options :: O.Parser Options
+options = Options
+  <$> O.switch
+      ( O.short 't' <>
+        O.long "print-type" <>
+        O.help "Annotate the program with its type." )
+  <*> O.strArgument
+      ( O.metavar "PROGRAM" <> 
+        O.help "Filename containing program to be pretty printed, or \"-\" to read from input." ) 
+  <*> O.option O.auto
+      ( O.short 'e' <>
+        O.long "to-expand" <>
+        O.value [Some2 Expect, Some2 Observe] <>
+        O.help "Transformations to be expanded; default [Expect, Observe]" )
+
+parseOpts :: IO Options
+parseOpts = O.execParser $ O.info (O.helper <*> options)
+      (O.fullDesc <> O.progDesc "Parse, typecheck, and pretty print a Hakaru program")
+
+main :: IO ()
+main = parseOpts >>= runPretty 
+
+runPretty :: Options -> IO ()
+runPretty Options{..} = readFromFile' program >>= parseAndInfer' >>= \prog ->
+    case prog of
+    Left  err                -> IO.hPutStrLn stderr err
+    Right (TypedAST typ ast) -> IO.putStrLn . T.pack $
+      let et = expandTransformationsWith'
+                 (someTransformations toExpand haskellTransformations)
+          concreteProgram = show . pretty . et $ ast
+          withType t x = concat [ "(", x, ")"
+                                , "\n.\n"
+                                , show (prettyType 12 t)
+                                ] in
+
+      if printType then
+          withType typ concreteProgram
+      else concreteProgram
+
diff --git a/commands/PrettyInternal.hs b/commands/PrettyInternal.hs
new file mode 100644
--- /dev/null
+++ b/commands/PrettyInternal.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings, DataKinds, GADTs, CPP, RecordWildCards #-}
+
+module Main where
+
+import           Language.Hakaru.Syntax.AST.Transforms
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Command
+
+import qualified Data.Text as T
+import qualified Data.Text.Utf8 as IO
+import           System.IO (stderr)
+import           Data.Monoid
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>), (<*>))
+#endif
+import qualified Options.Applicative as O
+
+data Options = Options
+  { printType :: Bool 
+  , program   :: FilePath 
+  }
+
+options :: O.Parser Options
+options = Options
+  <$> O.switch
+      ( O.short 't' <>
+        O.long "print-type" <>
+        O.help "Print the type of the program as well." )
+  <*> O.strArgument
+      ( O.metavar "PROGRAM" <> 
+        O.help "Filename containing program to be printed, or \"-\" to read from input." ) 
+
+parseOpts :: IO Options
+parseOpts = O.execParser $ O.info (O.helper <*> options)
+      (O.fullDesc <> O.progDesc "Parse, typecheck, and print (in internal syntax) a Hakaru program")
+
+main :: IO ()
+main = parseOpts >>= runPretty 
+
+runPretty :: Options -> IO ()
+runPretty Options{..} = readFromFile' program >>= parseAndInfer' >>= \prog ->
+    case prog of
+    Left  err               -> IO.hPutStrLn stderr err
+    Right (TypedAST ty ast) -> IO.putStrLn $
+      -- TODO: prettier (than `show') printing of internal syntax
+      (if printType then \x ->
+          T.concat [ "(", x, ")"
+                   , "\n.\n" <> T.pack (show ty) ]
+       else id)
+      (T.pack $ show $ expandTransformations ast)
diff --git a/commands/Summary.hs b/commands/Summary.hs
new file mode 100644
--- /dev/null
+++ b/commands/Summary.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE CPP,
+             OverloadedStrings,
+             PatternGuards,
+             DataKinds,
+             KindSignatures,
+             GADTs,
+             FlexibleContexts,
+             TypeOperators
+             #-}
+
+module Main where
+
+import qualified Language.Hakaru.Syntax.AST as T
+import           Language.Hakaru.Syntax.AST.Transforms
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.TypeCheck
+
+import           Language.Hakaru.Types.Sing (Sing)
+
+import           Language.Hakaru.Pretty.Haskell
+import           Language.Hakaru.Command
+import           Language.Hakaru.Summary
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+#endif
+
+import           Data.Text                  as TxT
+import qualified Data.Text.IO               as IO
+import           Data.Monoid ((<>))
+import           System.IO (stderr)
+import           Text.PrettyPrint    hiding ((<>))
+import qualified Options.Applicative as O
+import           System.FilePath
+
+
+data Options =
+  Options { fileIn          :: String
+          , fileOut         :: Maybe String
+          , asModule        :: Maybe String
+          , logFloatPrelude :: Bool
+          , optimize        :: Bool
+          } deriving Show
+
+main :: IO ()
+main = do
+  opts <- parseOpts
+  compileHakaru opts
+
+parseOpts :: IO Options
+parseOpts = O.execParser $ O.info (O.helper <*> options)
+                         $ O.fullDesc <> O.progDesc "Compile Hakaru to Haskell"
+
+{-
+
+There is some redundancy in Compile.hs, Hakaru.hs, and HKC.hs in how we decide
+what to run given which arguments. There may be a way to unify these.
+
+-}
+
+options :: O.Parser Options
+options = Options
+  <$> O.strArgument (O.metavar "INPUT" <>
+                     O.help "Program to be compiled" )
+  <*> (O.optional $
+        O.strOption (O.short 'o' <>
+                     O.help "Optional output file name"))
+  <*> (O.optional $
+        O.strOption (O.long "as-module" <>
+                     O.short 'M' <>
+                     O.help "creates a haskell module with this name"))
+  <*> O.switch (O.long "logfloat-prelude" <>
+                O.help "use logfloat prelude for numeric stability")
+  <*> O.switch (O.short 'O' <>
+                O.help "perform Hakaru AST optimizations")
+
+
+
+prettyProg :: (ABT T.Term abt)
+           => String
+           -> Sing a
+           -> abt '[] a
+           -> String
+prettyProg name typ ast =
+    renderStyle style
+    (    sep [text (name ++ " ::"), nest 2 (prettyType typ)]
+     $+$ sep [text (name ++ " =") , nest 2 (pretty     ast)] )
+
+compileHakaru
+    :: Options
+    -> IO ()
+compileHakaru opts = do
+    let infile = fileIn opts
+    prog <- readFromFile infile
+    case parseAndInfer prog of
+      Left err                 -> IO.hPutStrLn stderr err
+      Right (TypedAST typ ast) -> do
+        ast' <- (if optimize opts then optimizations else id) <$> summary (et ast)
+        writeHkHsToFile infile (fileOut opts) . TxT.unlines $
+          header (logFloatPrelude opts) (asModule opts) ++
+          [ pack $ prettyProg "prog" typ ast' ] ++
+          (case asModule opts of
+             Nothing -> footer
+             Just _  -> [])
+  where et = expandTransformations
+
+writeHkHsToFile :: String -> Maybe String -> Text -> IO ()
+writeHkHsToFile inFile moutFile content =
+  let outFile =  case moutFile of
+                   Nothing -> replaceFileName inFile (takeBaseName inFile) ++ ".hs"
+                   Just x  -> x
+  in  writeToFile outFile content
+
+header :: Bool -> Maybe String -> [Text]
+header logfloats mmodule =
+  [ "{-# LANGUAGE DataKinds, NegativeLiterals #-}"
+  , TxT.unwords [ "module"
+                , case mmodule of
+                    Just m  -> pack m
+                    Nothing -> "Main"
+                , "where" ]
+  , ""
+  , if logfloats
+    then TxT.unlines [ "import           Data.Number.LogFloat (LogFloat)"
+                     , "import           Prelude hiding (product, exp, log, (**), pi)"
+                     , "import           Language.Hakaru.Runtime.LogFloatPrelude"
+                     ]
+    else TxT.unlines [ "import           Prelude hiding (product)"
+                     , "import           Language.Hakaru.Runtime.Prelude"
+                     ]
+  , "import           Language.Hakaru.Runtime.CmdLine"
+  , "import           Language.Hakaru.Types.Sing"
+  , "import qualified System.Random.MWC                as MWC"
+  , "import           Control.Monad"
+  , "import           System.Environment (getArgs)"
+  , ""
+  ]
+
+footer :: [Text]
+footer =
+    ["","main :: IO ()"
+    , TxT.concat ["main = makeMain prog =<< getArgs"]]
+
+footerWalk :: [Text]
+footerWalk =
+  [ ""
+  , "main :: IO ()"
+  , "main = do"
+  , "  g <- MWC.createSystemRandom"
+  , "  x <- prog2 g"
+  , "  iterateM_ (withPrint $ flip prog1 g) x"
+  ]
diff --git a/hakaru.cabal b/hakaru.cabal
--- a/hakaru.cabal
+++ b/hakaru.cabal
@@ -1,99 +1,429 @@
--- Initial hakaru.cabal generated by cabal init.  For further 
--- documentation, see http://haskell.org/cabal/users-guide/
+-- To understand this, see http://haskell.org/cabal/users-guide/
 
+cabal-version:       >=1.16
+build-type:          Simple
 name:                hakaru
-version:             0.1.4
-synopsis:            A probabilistic programming embedded DSL   
--- description:         
-homepage:            http://indiana.edu/~ppaml/
+version:             0.7.0
+synopsis:            A probabilistic programming language
+description:         Hakaru is a simply-typed probabilistic programming language, designed
+                     for easy specification of probabilistic models, and inference algorithms.
+homepage:            http://hakaru-dev.github.io/
 license:             BSD3
 license-file:        LICENSE
 author:              The Hakaru Team
 maintainer:          ppaml@indiana.edu
--- copyright:           
+-- copyright:
 category:            Language
-build-type:          Simple
--- extra-source-files:  
-cabal-version:       >=1.10
+-- extra-source-files:
 
-library
-  exposed-modules:     Language.Hakaru.Types,
-                       Language.Hakaru.Symbolic,
-                       Language.Hakaru.Arrow,
-                       Language.Hakaru.Mixture,
-                       Language.Hakaru.Sampler,
-                       Language.Hakaru.ImportanceSampler,
-                       Language.Hakaru.Metropolis,
-                       Language.Hakaru.Lambda,
-                       Language.Hakaru.Distribution,
-                       Language.Hakaru.Util.Csv,
-                       Language.Hakaru.Util.Extras,
-                       Language.Hakaru.Util.Visual,
-                       Language.Hakaru.Util.Coda
-  other-extensions:    RankNTypes, BangPatterns, GADTs, TypeFamilies, TypeOperators,
-                       ConstraintKinds, FlexibleContexts, NoMonomorphismRestriction,
-                       DeriveDataTypeable, ScopedTypeVariables, ExistentialQuantification,
-                       StandaloneDeriving, OverloadedStrings,
-                       FlexibleInstances, RebindableSyntax
-  build-depends:       base >=4.6 && <5.0,
-                       random >=1.0 && <1.1,
-                       transformers >=0.3 && <0.4,
-                       containers >=0.5 && <0.6,
-                       pretty >=1.1 && <1.2,
-                       logfloat >=0.12 && <0.13,
-                       hmatrix >=0.16 && <0.17,
-                       math-functions >=0.1 && <0.2,
-                       vector >=0.10 && <0.11,
-                       cassava >=0.4 && <0.5,
-                       zlib >=0.5 && <0.6,
-                       bytestring >=0.10 && <0.11,
-                       aeson >=0.7 && <0.8,
-                       text >=1.1 && <1.2,
-                       statistics >=0.11 && <0.14,
-                       parsec >=3.1 && <3.2,
-                       array >=0.4,
-                       mwc-random >=0.13 && <0.14,
-                       directory >=1.2 && <1.3,
-                       integration >= 0.2.0 && < 0.3.0,
-                       primitive >= 0.5 && < 0.6,
-                       parallel >=3.2 && <3.3,
-                       monad-loops >= 0.3.0.2
-  -- hs-source-dirs:      
-  default-language:    Haskell2010
-  ghc-options:         -Wall
+tested-with: GHC==8.10.2, GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4
 
-test-suite hakaru-test
-    type:              exitcode-stdio-1.0
-    main-is:           Tests/Tests.hs
-    other-modules:     Tests.ImportanceSampler,
-                       Tests.Models,
-                       Tests.Metropolis,
-                       Tests.Distribution
-    build-depends:     base, Cabal >= 1.10, 
-                       QuickCheck, 
-                       HUnit,
-                       test-framework,
-                       test-framework-quickcheck2,
-                       test-framework-hunit,
-                       random >=1.0 && <1.1,
-                       pretty >=1.1 && <1.2,
-                       containers >=0.5 && <0.6,
-                       logfloat >=0.12 && <0.13,
-                       math-functions >=0.1 && <0.2,
-                       statistics >=0.11 && <0.14,
-                       hmatrix >=0.16 && <0.17,
-                       vector >=0.10 && <0.11,
-                       hakaru >= 0.1.3,
-                       mwc-random >=0.13 && <0.14,
-                       primitive >= 0.5 && < 0.6,
-                       monad-loops >= 0.3.0.2
-    default-language:  Haskell2010
+----------------------------------------------------------------
+Source-Repository head
+    Type:     git
+    Location: https://github.com/hakaru-dev/hakaru
 
-benchmark bench-all
-    type:              exitcode-stdio-1.0
-    hs-source-dirs:    Bench
-    main-is:           Bench.hs
-    build-depends:     base, deepseq, ghc-prim,
-                       criterion, hakaru >= 0.1.3
-    ghc-options:       -O2
-    default-language:  Haskell2010
+----------------------------------------------------------------
+Flag traceDisintegrate
+    Default:     False
+    Description: Insert tracing code to help debug disintegration.
+
+----------------------------------------------------------------
+Library
+    Hs-Source-Dirs:    haskell
+    Default-Language:  Haskell2010
+    -- GHC-Options:       -Wall -fwarn-tabs -j6 
+
+    if flag(traceDisintegrate)
+        Cpp-Options:   -D__TRACE_DISINTEGRATE__
+
+    exposed-modules:   Language.Hakaru.Syntax.IClasses,
+                       Language.Hakaru.Syntax.ABT,
+                       Language.Hakaru.Syntax.Variable,
+                       Language.Hakaru.Syntax.Value,
+                       Language.Hakaru.Syntax.Reducer,
+                       Language.Hakaru.Syntax.Datum,
+                       Language.Hakaru.Syntax.DatumABT,
+                       Language.Hakaru.Syntax.DatumCase,
+                       Language.Hakaru.Types.DataKind,
+                       Language.Hakaru.Types.Sing,
+                       Language.Hakaru.Types.HClasses,
+                       Language.Hakaru.Types.Coercion,
+                       Language.Hakaru.Syntax.ANF,
+                       Language.Hakaru.Syntax.AST,
+                       Language.Hakaru.Syntax.AST.Eq,
+                       Language.Hakaru.Syntax.AST.Sing,
+                       Language.Hakaru.Syntax.AST.Transforms,
+                       Language.Hakaru.Syntax.CSE,
+                       Language.Hakaru.Syntax.Gensym,
+                       Language.Hakaru.Syntax.Hoist,
+                       Language.Hakaru.Syntax.Prelude,
+                       Language.Hakaru.Syntax.Prune,
+                       Language.Hakaru.Syntax.Rename,
+                       Language.Hakaru.Syntax.SArgs,
+                       Language.Hakaru.Syntax.Transform,
+                       Language.Hakaru.Syntax.TypeCheck,
+                       Language.Hakaru.Syntax.TypeCheck.TypeCheckMonad,
+                       Language.Hakaru.Syntax.TypeCheck.Unification,
+                       Language.Hakaru.Syntax.TypeOf,
+                       Language.Hakaru.Syntax.Uniquify,
+                       Language.Hakaru.Syntax.Unroll,
+                       Language.Hakaru.Parser.AST,
+                       Language.Hakaru.Parser.Maple,
+                       Language.Hakaru.Parser.Import,
+                       Language.Hakaru.Parser.Parser,
+                       Language.Hakaru.Parser.SymbolResolve,
+                       Language.Hakaru.Pretty.Haskell,
+                       Language.Hakaru.Pretty.SExpression,
+                       Language.Hakaru.Pretty.Concrete,
+                       Language.Hakaru.Pretty.Maple,
+                       Language.Hakaru.Runtime.Prelude,
+                       Language.Hakaru.Runtime.LogFloatPrelude,
+                       Language.Hakaru.Runtime.CmdLine,
+                       Language.Hakaru.Observe,
+                       Language.Hakaru.Maple,
+                       Language.Hakaru.Simplify,
+                       Language.Hakaru.Summary,
+                       Language.Hakaru.Sample,
+                       Language.Hakaru.Evaluation.Types,
+                       Language.Hakaru.Evaluation.Lazy,
+                       Language.Hakaru.Evaluation.PEvalMonad,
+                       Language.Hakaru.Evaluation.EvalMonad
+                       Language.Hakaru.Evaluation.ConstantPropagation,
+                       Language.Hakaru.Evaluation.DisintegrationMonad,
+                       Language.Hakaru.Evaluation.Coalesce,
+                       Language.Hakaru.Disintegrate,
+                       Language.Hakaru.Evaluation.ExpectMonad,
+                       Language.Hakaru.Expect,
+                       Language.Hakaru.Inference,
+                       Language.Hakaru.Repl,
+                       Language.Hakaru.Command,
+                       Language.Hakaru.CodeGen.Wrapper,
+                       Language.Hakaru.CodeGen.Flatten,
+                       Language.Hakaru.CodeGen.CodeGenMonad,
+                       Language.Hakaru.CodeGen.Types,
+                       Language.Hakaru.CodeGen.AST,
+                       Language.Hakaru.CodeGen.Pretty,
+                       Language.Hakaru.CodeGen.Libs,
+                       Data.Number.Nat,
+                       Data.Number.Natural
+                       Data.Text.Utf8
+
+    other-modules:     System.MapleSSH
+                       Text.Parsec.Indentation
+                       Text.Parsec.Indentation.Char
+                       Text.Parsec.Indentation.Token
+                       Text.Parser.Indentation.Implementation
+
+    build-tools:       alex,
+                       happy
+
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       Cabal                >= 1.16,
+                       ghc-prim             >= 0.3  && < 0.8,
+                       transformers         >= 0.3  && < 0.6,
+                       transformers-compat  >= 0.3  && < 0.7,
+                       containers           >= 0.5  && < 0.7,
+                       semigroups           >= 0.16,
+                       pretty               >= 1.1  && < 1.2,
+                       logfloat             >= 0.13 && < 0.14,
+                       math-functions       >= 0.1  && < 0.4,
+                       vector               >= 0.10,
+                       text                 >= 0.11 && < 1.3,
+                       parsec               >= 3.1  && < 3.2,
+                       mwc-random           >= 0.13 && < 0.15,
+                       directory            >= 1.2  && < 1.4,
+                       integration          >= 0.2.0 && < 0.3.0,
+                       primitive            >= 0.5  && < 0.8,
+                       process              >= 1.1  && < 2.0,
+                       HUnit                >= 1.2  && < 2.0,
+                       mtl                  >= 2.1,
+                       filepath             >= 1.1.0.2,
+                       bytestring           >= 0.9,
+                       optparse-applicative >= 0.11 && < 0.16,
+                       syb                  >= 0.6,
+                       exact-combinatorics  >= 0.2.0,
+                       repline              >= 0.4
+
+----------------------------------------------------------------
+Test-Suite system-testsuite
+    Type:              exitcode-stdio-1.0
+    Main-is:           Tests/TestSuite.hs
+    Hs-Source-Dirs:    haskell
+    Default-Language:  Haskell2010
+    -- GHC-Options:       -Wall -fwarn-tabs
+
+    other-modules:     Data.Number.Nat
+                       Data.Number.Natural
+                       Data.Text.Utf8
+                       Language.Hakaru.Command
+                       Language.Hakaru.Disintegrate
+                       Language.Hakaru.Evaluation.Coalesce
+                       Language.Hakaru.Evaluation.ConstantPropagation
+                       Language.Hakaru.Evaluation.DisintegrationMonad
+                       Language.Hakaru.Evaluation.EvalMonad
+                       Language.Hakaru.Evaluation.ExpectMonad
+                       Language.Hakaru.Evaluation.Lazy
+                       Language.Hakaru.Evaluation.PEvalMonad
+                       Language.Hakaru.Evaluation.Types
+                       Language.Hakaru.Expect
+                       Language.Hakaru.Inference
+                       Language.Hakaru.Maple
+                       Language.Hakaru.Parser.AST
+                       Language.Hakaru.Parser.Import
+                       Language.Hakaru.Parser.Maple
+                       Language.Hakaru.Parser.Parser
+                       Language.Hakaru.Parser.SymbolResolve
+                       Language.Hakaru.Pretty.Concrete
+                       Language.Hakaru.Pretty.Haskell
+                       Language.Hakaru.Pretty.Maple
+                       Language.Hakaru.Sample
+                       Language.Hakaru.Simplify
+                       Language.Hakaru.Syntax.ABT
+                       Language.Hakaru.Syntax.ANF
+                       Language.Hakaru.Syntax.AST
+                       Language.Hakaru.Syntax.AST.Eq
+                       Language.Hakaru.Syntax.AST.Transforms
+                       Language.Hakaru.Syntax.AST.Sing
+                       Language.Hakaru.Syntax.CSE
+                       Language.Hakaru.Syntax.Datum
+                       Language.Hakaru.Syntax.DatumABT
+                       Language.Hakaru.Syntax.DatumCase
+                       Language.Hakaru.Syntax.Gensym
+                       Language.Hakaru.Syntax.Hoist
+                       Language.Hakaru.Syntax.IClasses
+                       Language.Hakaru.Syntax.Prelude
+                       Language.Hakaru.Syntax.Prune
+                       Language.Hakaru.Syntax.Reducer
+                       Language.Hakaru.Syntax.SArgs
+                       Language.Hakaru.Syntax.Transform
+                       Language.Hakaru.Syntax.TypeCheck
+                       Language.Hakaru.Syntax.TypeCheck.TypeCheckMonad
+                       Language.Hakaru.Syntax.TypeCheck.Unification
+                       Language.Hakaru.Syntax.TypeOf
+                       Language.Hakaru.Syntax.Uniquify
+                       Language.Hakaru.Syntax.Unroll
+                       Language.Hakaru.Syntax.Value
+                       Language.Hakaru.Syntax.Variable
+                       Language.Hakaru.Types.Coercion
+                       Language.Hakaru.Types.DataKind
+                       Language.Hakaru.Types.HClasses
+                       Language.Hakaru.Types.Sing
+                       System.MapleSSH
+                       Tests.ASTTransforms
+                       Tests.Disintegrate
+                       Tests.Models
+                       Tests.Parser
+                       Tests.Pretty
+                       Tests.Relationships
+                       Tests.RoundTrip
+                       Tests.Sample
+                       Tests.Simplify
+                       Tests.TestTools
+                       Tests.TypeCheck
+
+    build-tools:       alex,
+                       happy
+
+    Build-Depends:     base                 >= 4.6  && < 5.0,
+                       Cabal                >= 1.16,
+                       ghc-prim             >= 0.3  && < 0.8,
+                       transformers         >= 0.3  && < 0.6,
+                       containers           >= 0.5  && < 0.7,
+                       semigroups           >= 0.16,
+                       logfloat             >= 0.13 && < 0.14,
+                       parsec               >= 3.1  && < 3.2,
+                       primitive            >= 0.5  && < 0.8,
+                       pretty               >= 1.1  && < 1.2,
+                       mwc-random           >= 0.13 && < 0.15,
+                       math-functions       >= 0.1  && < 0.4,
+                       integration          >= 0.2  && < 0.3,
+                       HUnit                >= 1.2  && < 2.0,
+                       QuickCheck           >= 2.6,
+                       process              >= 1.1  && < 2.0,
+                       mtl                  >= 2.1,
+                       vector               >= 0.10,
+                       text                 >= 0.11 && < 1.3,
+                       bytestring           >= 0.9,
+                       directory            >= 1.2  && < 1.4,
+                       optparse-applicative >= 0.11 && < 0.16,
+                       syb                  >= 0.6,
+                       filepath             >= 1.1.0.2,
+                       exact-combinatorics  >= 0.2.0
+
+----------------------------------------------------------------
+Executable hakaru
+    Main-is:           Hakaru.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-tools:       alex,
+                       happy
+
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       mwc-random           >= 0.13 && < 0.15,
+                       text                 >= 0.11 && < 1.3,
+                       pretty               >= 1.1  && < 1.2,
+                       vector               >= 0.10,
+                       optparse-applicative >= 0.11 && < 0.16,
+                       hakaru               >= 0.3
+
+----------------------------------------------------------------
+Executable compile
+    Main-is:           Compile.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       mwc-random           >= 0.13 && < 0.15,
+                       text                 >= 0.11 && < 1.3,
+                       pretty               >= 1.1  && < 1.2,
+                       filepath             >= 1.3,
+                       optparse-applicative >= 0.11 && < 0.16,
+                       hakaru               >= 0.3
+
+----------------------------------------------------------------
+Executable summary
+    Main-is:           Summary.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       mwc-random           >= 0.13 && < 0.15,
+                       text                 >= 0.11 && < 1.3,
+                       pretty               >= 1.1  && < 1.2,
+                       filepath             >= 1.3,
+                       optparse-applicative >= 0.11 && < 0.16,
+                       hakaru               >= 0.3
+
+----------------------------------------------------------------
+Executable hk-maple
+    Main-is:           HkMaple.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       mwc-random           >= 0.13 && < 0.15,
+                       text                 >= 0.11 && < 1.3,
+                       pretty               >= 1.1  && < 1.2,
+                       optparse-applicative >= 0.13 && < 0.16,
+                       containers           >= 0.5  && < 0.7,
+                       hakaru               >= 0.3
+
+----------------------------------------------------------------
+Executable density
+    Main-is:           Density.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base             >= 4.7  && < 5.0,
+                       mwc-random       >= 0.13 && < 0.15,
+                       text             >= 0.11 && < 1.3,
+                       pretty           >= 1.1  && < 1.2,
+                       hakaru           >= 0.3
+
+----------------------------------------------------------------
+Executable disintegrate
+    Main-is:           Disintegrate.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       mwc-random           >= 0.13 && < 0.15,
+                       text                 >= 0.11 && < 1.3,
+                       pretty               >= 1.1  && < 1.2,
+                       optparse-applicative >= 0.11 && < 0.16,
+                       hakaru               >= 0.3
+
+----------------------------------------------------------------
+Executable pretty
+    Main-is:           Pretty.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       text                 >= 0.11 && < 1.3,
+                       pretty               >= 1.1  && < 1.2,
+                       optparse-applicative >= 0.11 && < 0.16,
+                       hakaru               >= 0.3
+
+----------------------------------------------------------------
+Executable prettyinternal
+    Main-is:           PrettyInternal.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       text                 >= 0.11 && < 1.3,
+                       pretty               >= 1.1  && < 1.2,
+                       optparse-applicative >= 0.11 && < 0.16,
+                       hakaru               >= 0.3
+
+----------------------------------------------------------------
+Executable momiji
+    Main-is:           Momiji.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base             >= 4.7  && < 5.0,
+                       text             >= 0.11 && < 1.3,
+                       hakaru           >= 0.3
+
+----------------------------------------------------------------
+Executable normalize
+    Main-is:           Normalize.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base             >= 4.7  && < 5.0,
+                       mwc-random       >= 0.13 && < 0.15,
+                       text             >= 0.11 && < 1.3,
+                       mtl              >= 2.1,
+                       pretty           >= 1.1  && < 1.2,
+                       hakaru           >= 0.3
+
+
+----------------------------------------------------------------
+Executable hkc
+    Main-is:           HKC.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       containers           >= 0.5  && < 0.7,
+                       text                 >= 0.11 && < 1.3,
+                       mtl                  >= 2.1,
+                       optparse-applicative >= 0.11 && < 0.16,
+                       pretty               >= 1.1  && < 1.2,
+                       process              >= 1.1  && < 2.0,
+                       semigroups           >= 0.16,
+                       hakaru               >= 0.3
+
+
+----------------------------------------------------------------
+Executable mh
+    Main-is:           Mh.hs
+    Hs-Source-Dirs:    commands
+    Default-Language:  Haskell2010
+    GHC-Options:       -O2 -Wall -fwarn-tabs
+
+    build-depends:     base             >= 4.7  && < 5.0,
+                       mwc-random       >= 0.13 && < 0.15,
+                       text             >= 0.11 && < 1.3,
+                       mtl              >= 2.1,
+                       pretty           >= 1.1  && < 1.2,
+                       hakaru           >= 0.3
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Data/Number/Nat.hs b/haskell/Data/Number/Nat.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Data/Number/Nat.hs
@@ -0,0 +1,175 @@
+-- TODO: merge with the Posta version. And release them as a standalone package
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2015.12.17
+-- |
+-- Module      :  Data.Number.Nat
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  Haskell98 + CPP
+--
+-- A data type for natural numbers (aka non-negative integers).
+----------------------------------------------------------------
+module Data.Number.Nat
+    ( Nat()
+    , fromNat
+    , toNat
+    , unsafeNat
+    , MaxNat(..)
+    ) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid (Monoid(..))
+#endif
+
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Semigroup
+#endif
+
+import Data.Data (Data, Typeable)
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- | Natural numbers, with fixed-width à la 'Int'. N.B., the 'Num'
+-- instance will throw errors on subtraction, negation, and
+-- 'fromInteger' when the result is not a natural number.
+newtype Nat = Nat Int
+    deriving (Eq, Ord, Show, Data, Typeable)
+
+-- TODO: should we define our own Show instance, in order to just
+-- show the Int itself, relying on our 'fromInteger' definition to
+-- preserve cut&paste-ability? If so, then we should ensure that
+-- the Read instance is optional in whether the \"Nat\" is there
+-- or not.
+
+-- N.B., we cannot derive Read, since that would inject invalid numbers!
+instance Read Nat where
+    readsPrec d =
+        readParen (d > 10) $ \s0 -> do
+            ("Nat", s1) <- lex s0
+            (i,     s2) <- readsPrec 11 s1
+            maybe [] (\n -> [(n,s2)]) (toNat i)
+
+
+-- | Safely convert a natural number to an integer.
+fromNat :: Nat -> Int
+fromNat (Nat i) = i
+{-# INLINE fromNat #-}
+
+
+-- | Safely convert an integer to a natural number. Returns @Nothing@
+-- if the integer is negative.
+toNat :: Int -> Maybe Nat
+toNat x
+    | x < 0     = Nothing
+    | otherwise = Just (Nat x)
+{-# INLINE toNat #-}
+
+
+-- | Unsafely convert an integer to a natural number. Throws an
+-- error if the integer is negative.
+unsafeNat :: Int -> Nat
+unsafeNat x
+    | x < 0     = error _errmsg_unsafeNat
+    | otherwise = Nat x
+{-# INLINE unsafeNat #-}
+
+
+instance Num Nat where
+    Nat i + Nat j   = Nat (i + j)
+    Nat i * Nat j   = Nat (i * j)
+    Nat i - Nat j
+        | i >= j    = Nat (i - j)
+        | otherwise = error _errmsg_subtraction
+    negate _        = error _errmsg_negate
+    abs n           = n
+    signum _        = Nat 1
+    fromInteger i
+        | i >= 0 && n >= 0 = Nat n
+        | otherwise = error _errmsg_fromInteger
+        where
+        n :: Int
+        n = fromInteger i
+    {-# INLINE (+) #-}
+    {-# INLINE (*) #-}
+    {-# INLINE (-) #-}
+    {-# INLINE negate #-}
+    {-# INLINE abs #-}
+    {-# INLINE signum #-}
+    {-# INLINE fromInteger #-}
+
+instance Enum Nat where
+    succ (Nat i) = if i /= maxBound then Nat (i+1) else error _errmsg_succ
+    pred (Nat i) = if i /= 0        then Nat (i-1) else error _errmsg_pred
+    toEnum n     = if n >= 0        then Nat n     else error _errmsg_toEnum
+    fromEnum (Nat i) = i
+
+    enumFrom       (Nat i)                 = map Nat (enumFrom       i)
+    enumFromThen   (Nat i) (Nat j)         = map Nat (enumFromThen   i j)
+    enumFromTo     (Nat i)         (Nat k) = map Nat (enumFromTo     i   k)
+    enumFromThenTo (Nat i) (Nat j) (Nat k) = map Nat (enumFromThenTo i j k)
+    {-# INLINE succ #-}
+    {-# INLINE pred #-}
+    {-# INLINE toEnum #-}
+    {-# INLINE fromEnum #-}
+    {-# INLINE enumFrom #-}
+    {-# INLINE enumFromThen #-}
+    {-# INLINE enumFromTo #-}
+    {-# INLINE enumFromThenTo #-}
+
+instance Real Nat where
+    toRational (Nat i) = toRational i
+    {-# INLINE toRational #-}
+
+instance Integral Nat where
+    quot    (Nat i) (Nat j) = Nat (quot i j)
+    rem     (Nat i) (Nat j) = Nat (rem  i j)
+    quotRem (Nat i) (Nat j) = case quotRem i j of (q,r) -> (Nat q, Nat r)
+    div    = quot
+    mod    = rem
+    divMod = quotRem
+    toInteger (Nat i) = toInteger i
+    {-# INLINE quot #-}
+    {-# INLINE rem #-}
+    {-# INLINE div #-}
+    {-# INLINE mod #-}
+    {-# INLINE quotRem #-}
+    {-# INLINE divMod #-}
+    {-# INLINE toInteger #-}
+
+
+----------------------------------------------------------------
+newtype MaxNat = MaxNat { unMaxNat :: Nat }
+
+instance Semigroup MaxNat where
+    MaxNat m <> MaxNat n = MaxNat (max m n)
+
+instance Monoid MaxNat where
+    mempty  = MaxNat 0
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (<>)
+#endif
+
+----------------------------------------------------------------
+_errmsg_unsafeNat, _errmsg_subtraction, _errmsg_negate, _errmsg_fromInteger, _errmsg_succ, _errmsg_pred, _errmsg_toEnum
+    :: String
+_errmsg_unsafeNat   = "unsafeNat: negative input"
+_errmsg_subtraction = "(-)@Nat: Num is a bad abstraction"
+_errmsg_negate      = "negate@Nat: Num is a bad abstraction"
+_errmsg_fromInteger = "fromInteger@Nat: Num is a bad abstraction"
+_errmsg_succ        = "succ@Nat: No successor of the maxBound"
+_errmsg_pred        = "pred@Nat: No predecessor of zero"
+_errmsg_toEnum      = "toEnum@Nat: negative input"
+{-# NOINLINE _errmsg_unsafeNat #-}
+{-# NOINLINE _errmsg_subtraction #-}
+{-# NOINLINE _errmsg_negate #-}
+{-# NOINLINE _errmsg_fromInteger #-}
+{-# NOINLINE _errmsg_succ #-}
+{-# NOINLINE _errmsg_pred #-}
+{-# NOINLINE _errmsg_toEnum #-}
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Data/Number/Natural.hs b/haskell/Data/Number/Natural.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Data/Number/Natural.hs
@@ -0,0 +1,220 @@
+-- TODO: merge with the Posta version. And release them as a standalone package
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2015.12.17
+-- |
+-- Module      :  Data.Number.Natural
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  Haskell98 + CPP
+--
+-- A data type for natural numbers (aka non-negative integers).
+----------------------------------------------------------------
+module Data.Number.Natural
+    ( Natural()
+    , fromNatural
+    , toNatural
+    , unsafeNatural
+    , MaxNatural(..)
+    , NonNegativeRational
+    , fromNonNegativeRational
+    , toNonNegativeRational
+    , unsafeNonNegativeRational
+    ) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid (Monoid(..))
+#endif
+
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Semigroup
+#endif
+
+import Data.Ratio
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- | Natural numbers, with unbounded-width à la 'Integer'. N.B.,
+-- the 'Num' instance will throw errors on subtraction, negation,
+-- and 'fromInteger' when the result is not a natural number.
+newtype Natural = Natural Integer
+    deriving (Eq, Ord)
+
+instance Show Natural where
+    show (Natural i) = show i
+
+-- TODO: should we define our own Show instance, in order to just
+-- show the Integer itself, relying on our 'fromInteger' definition
+-- to preserve cut&paste-ability? If so, then we should ensure that
+-- the Read instance is optional in whether the \"Natural\" is there
+-- or not.
+
+-- N.B., we cannot derive Read, since that would inject invalid numbers!
+instance Read Natural where
+    readsPrec d =
+        readParen (d > 10) $ \s0 -> do
+            ("Natural", s1) <- lex s0
+            (i,         s2) <- readsPrec 11 s1
+            maybe [] (\n -> [(n,s2)]) (toNatural i)
+
+
+-- | Safely convert a natural number to an integer.
+fromNatural :: Natural -> Integer
+fromNatural (Natural i) = i
+{-# INLINE fromNatural #-}
+
+
+-- | Safely convert an integer to a natural number. Returns @Nothing@
+-- if the integer is negative.
+toNatural :: Integer -> Maybe Natural
+toNatural x
+    | x < 0     = Nothing
+    | otherwise = Just (Natural x)
+{-# INLINE toNatural #-}
+
+
+-- | Unsafely convert an integer to a natural number. Throws an
+-- error if the integer is negative.
+unsafeNatural :: Integer -> Natural
+unsafeNatural x
+    | x < 0     = error _errmsg_unsafeNatural
+    | otherwise = Natural x
+{-# INLINE unsafeNatural #-}
+
+
+instance Num Natural where
+    Natural i + Natural j   = Natural (i + j)
+    Natural i * Natural j   = Natural (i * j)
+    Natural i - Natural j
+        | i >= j    = Natural (i - j)
+        | otherwise = error _errmsg_subtraction
+    negate _        = error _errmsg_negate
+    abs n           = n
+    signum _        = Natural 1
+    fromInteger i
+        | i >= 0 && i >= 0 = Natural i
+        | otherwise = error _errmsg_fromInteger
+    {-# INLINE (+) #-}
+    {-# INLINE (*) #-}
+    {-# INLINE (-) #-}
+    {-# INLINE negate #-}
+    {-# INLINE abs #-}
+    {-# INLINE signum #-}
+    {-# INLINE fromInteger #-}
+
+instance Enum Natural where
+    succ (Natural i) = Natural (i+1)
+    pred (Natural i)
+        | i /= 0     = Natural (i-1)
+        | otherwise  = error _errmsg_pred
+    toEnum n
+        | n >= 0     = Natural (toInteger n)
+        | otherwise  = error _errmsg_toEnum
+    fromEnum (Natural i) = fromEnum i
+
+    enumFrom       (Natural i)             = map Natural (enumFrom i)
+    enumFromThen   (Natural i) (Natural j) = map Natural (enumFromThen i j)
+    enumFromTo     (Natural i) (Natural k) = map Natural (enumFromTo i k)
+    enumFromThenTo (Natural i) (Natural j) (Natural k) =
+        map Natural (enumFromThenTo i j k)
+    {-# INLINE succ #-}
+    {-# INLINE pred #-}
+    {-# INLINE toEnum #-}
+    {-# INLINE fromEnum #-}
+    {-# INLINE enumFrom #-}
+    {-# INLINE enumFromThen #-}
+    {-# INLINE enumFromTo #-}
+    {-# INLINE enumFromThenTo #-}
+
+instance Real Natural where
+    toRational (Natural i) = toRational i
+    {-# INLINE toRational #-}
+
+instance Integral Natural where
+    quot    (Natural i) (Natural j) = Natural (quot i j)
+    rem     (Natural i) (Natural j) = Natural (rem  i j)
+    quotRem (Natural i) (Natural j) =
+        case quotRem i j of
+        (q,r) -> (Natural q, Natural r)
+    div    = quot
+    mod    = rem
+    divMod = quotRem
+    toInteger (Natural i) = i
+    {-# INLINE quot #-}
+    {-# INLINE rem #-}
+    {-# INLINE div #-}
+    {-# INLINE mod #-}
+    {-# INLINE quotRem #-}
+    {-# INLINE divMod #-}
+    {-# INLINE toInteger #-}
+
+
+----------------------------------------------------------------
+newtype MaxNatural = MaxNatural { unMaxNatural :: Natural }
+
+instance Semigroup MaxNatural where
+    MaxNatural m <> MaxNatural n = MaxNatural (max m n)
+
+instance Monoid MaxNatural where
+    mempty  = MaxNatural 0
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (<>)
+#endif
+
+
+----------------------------------------------------------------
+-- TODO: come up with a more succinct name...
+type NonNegativeRational = Ratio Natural
+
+-- | Safely convert a non-negative rational to a rational.
+fromNonNegativeRational :: NonNegativeRational -> Rational
+fromNonNegativeRational x =
+    fromNatural (numerator x) % fromNatural (denominator x)
+    -- TODO: can we use @(:%)@ directly?
+{-# INLINE fromNonNegativeRational #-}
+
+
+-- | Safely convert a rational to a non-negative rational. Returns
+-- @Nothing@ if the argument is negative.
+toNonNegativeRational :: Rational -> Maybe NonNegativeRational
+toNonNegativeRational x = do
+    n <- toNatural (numerator x)
+    d <- toNatural (denominator x)
+    return (n % d)
+    -- TODO: can we use @(:%)@ directly?
+{-# INLINE toNonNegativeRational #-}
+
+
+-- | Unsafely convert a rational to a non-negative rational. Throws
+-- an error if the argument is negative.
+unsafeNonNegativeRational :: Rational -> NonNegativeRational
+unsafeNonNegativeRational x =
+    case toNonNegativeRational x of
+    Just y  -> y
+    Nothing -> error _errmsg_unsafeNonNegativeRational
+{-# INLINE unsafeNonNegativeRational #-}
+
+
+----------------------------------------------------------------
+_errmsg_unsafeNatural, _errmsg_subtraction, _errmsg_negate, _errmsg_fromInteger, _errmsg_pred, _errmsg_toEnum, _errmsg_unsafeNonNegativeRational
+    :: String
+_errmsg_unsafeNatural = "unsafeNatural: negative input"
+_errmsg_subtraction   = "(-)@Natural: Num is a bad abstraction"
+_errmsg_negate        = "negate@Natural: Num is a bad abstraction"
+_errmsg_fromInteger   = "fromInteger@Natural: Num is a bad abstraction"
+_errmsg_pred          = "pred@Natural: No predecessor of zero"
+_errmsg_toEnum        = "toEnum@Natural: negative input"
+_errmsg_unsafeNonNegativeRational = "unsafeNonNegativeRational: negative input"
+{-# NOINLINE _errmsg_unsafeNatural #-}
+{-# NOINLINE _errmsg_subtraction #-}
+{-# NOINLINE _errmsg_negate #-}
+{-# NOINLINE _errmsg_fromInteger #-}
+{-# NOINLINE _errmsg_pred #-}
+{-# NOINLINE _errmsg_toEnum #-}
+{-# NOINLINE _errmsg_unsafeNonNegativeRational #-}
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Data/Text/Utf8.hs b/haskell/Data/Text/Utf8.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Data/Text/Utf8.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE CPP, OverloadedStrings #-}
+
+module Data.Text.Utf8 where
+
+import           Prelude               hiding (putStr, putStrLn)
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+#endif
+
+import qualified Data.ByteString.Char8 as BIO 
+import qualified Data.Text             as Text
+import           Data.Text.Encoding    (decodeUtf8, encodeUtf8)
+import           System.IO (Handle)
+
+readFile :: FilePath -> IO Text.Text
+readFile f = decodeUtf8 <$> (BIO.readFile f)
+
+getContents :: IO Text.Text 
+getContents = decodeUtf8 <$> BIO.getContents
+
+putStr :: Text.Text -> IO ()
+putStr = BIO.putStr . encodeUtf8
+
+putStrLn :: Text.Text -> IO ()
+putStrLn = BIO.putStrLn . encodeUtf8
+
+writeFile :: FilePath -> Text.Text -> IO ()
+writeFile f x = BIO.writeFile f (encodeUtf8 x) 
+
+hPut :: Handle -> Text.Text -> IO ()
+hPut h x = BIO.hPut h (encodeUtf8 x) 
+
+hPutStrLn :: Handle -> Text.Text -> IO ()
+hPutStrLn h x = BIO.hPutStrLn h (encodeUtf8 x)
+
+putStrS :: String -> IO ()
+putStrS = putStr . Text.pack
+
+putStrLnS :: String -> IO ()
+putStrLnS = putStrLn . Text.pack
+
+print :: Show a => a -> IO ()
+print = BIO.putStrLn . encodeUtf8 . Text.pack . show 
+
diff --git a/haskell/Language/Hakaru/CodeGen/AST.hs b/haskell/Language/Hakaru/CodeGen/AST.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/CodeGen/AST.hs
@@ -0,0 +1,389 @@
+--------------------------------------------------------------------------------
+--                                                                 2016.09.08
+-- |
+-- Module      :  Language.Hakaru.CodeGen.AST
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  zsulliva@indiana.edu
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--   An AST for the C Family and preprocessor. Much of this was originally based
+-- on Manuel M T Chakravarty and Benedikt Hubar's "language-c" package.
+--
+-- It is an AST for the C99 standard and should compile with the -pedantic flag
+--
+--------------------------------------------------------------------------------
+
+module Language.Hakaru.CodeGen.AST
+  ( Preprocessor(..), Ident(..), CAST(..), CExtDecl(..), CFunDef(..)
+
+  -- declaration constructors
+  , CDecl(..), CDeclr(..), CDeclSpec(..), CStorageSpec(..), CTypeQual(..)
+  , CDirectDeclr(..), CTypeSpec(..), CTypeName(..), CSUSpec(..), CSUTag(..)
+  , CEnum(..), CInit(..), CPartDesig(..), CFunSpec(..), CPtrDeclr(..)
+
+  -- statements and expression constructors
+  , CStat(..), CCompoundBlockItem(..), CExpr(..), CConst(..), CUnaryOp(..)
+  , CBinaryOp(..), CAssignOp(..)
+
+  -- infix and smart constructors
+  , (.>.),(.<.),(.==.),(.!=.),(.||.),(.&&.),(.*.),(./.),(.-.),(.+.),(.=.),(.+=.)
+  , (.*=.),(.>=.),(.<=.),(...),(.->.)
+  , seqCStat
+  , indirect, address, index, intE, charE, floatE, stringE, mkCallE, mkUnaryE
+  , nullE
+
+  -- util
+  , cNameStream
+  ) where
+
+import Control.Monad (mplus)
+
+
+--------------------------------------------------------------------------------
+--                               Top Level                                    --
+--------------------------------------------------------------------------------
+
+data CAST
+  = CAST [CExtDecl]
+  deriving (Show, Eq, Ord)
+
+
+data CExtDecl
+  = CDeclExt    CDecl
+  | CFunDefExt  CFunDef
+  | CCommentExt String
+  | CPPExt      Preprocessor
+  deriving (Show, Eq, Ord)
+
+data CFunDef
+  = CFunDef [CDeclSpec] CDeclr [CDecl] CStat
+  deriving (Show, Eq, Ord)
+
+{-
+  This is currently a very rough AST for preprocessor. Preprocessor macros
+  can be inserted at the top level and at the statement level
+-}
+data Preprocessor
+  = PPDefine  String String
+  | PPInclude String
+  | PPUndef   String
+  | PPIf      String
+  | PPIfDef   String
+  | PPIfNDef  String
+  | PPElse    String
+  | PPElif    String
+  | PPEndif   String
+  | PPError   String
+  | PPPragma  [String]
+  deriving (Show, Eq, Ord)
+
+data Ident
+ = Ident String
+ deriving (Show, Eq, Ord)
+
+
+--------------------------------------------------------------------------------
+--                               C Declarations                               --
+--------------------------------------------------------------------------------
+{-
+  C Declarations provide tools for laying out memory objections.
+-}
+
+data CDecl
+  = CDecl [CDeclSpec] [(CDeclr, Maybe CInit)]
+  deriving (Show, Eq, Ord)
+
+----------------
+-- Specifiers --
+----------------
+
+-- top level specifier
+data CDeclSpec
+  = CStorageSpec CStorageSpec
+  | CTypeSpec    CTypeSpec
+  | CTypeQual    CTypeQual
+  | CFunSpec     CFunSpec
+  deriving (Show, Eq, Ord)
+
+data CStorageSpec
+  = CTypeDef
+  | CExtern
+  | CStatic
+  | CAuto
+  | CRegister
+  deriving (Show, Eq, Ord)
+
+data CTypeQual
+  = CConstQual
+  | CVolatQual
+  deriving (Show, Eq, Ord)
+
+data CFunSpec = Inline
+  deriving (Show, Eq, Ord)
+
+data CTypeSpec
+  = CVoid
+  | CChar
+  | CShort
+  | CInt
+  | CLong
+  | CFloat
+  | CDouble
+  | CSigned
+  | CUnsigned
+  | CSUType      CSUSpec
+  | CTypeDefType Ident
+  | CEnumType    CEnum
+  deriving (Show, Eq, Ord)
+
+-- CTypeName is necessary for cast operations, see C99 pp81 and pp122
+-- For now, we only need to use these casts for malloc, so this is
+-- incomplete with respect to C99
+data CTypeName
+  = CTypeName [CTypeSpec] Bool
+  deriving (Show, Eq, Ord)
+
+data CSUSpec
+  = CSUSpec CSUTag (Maybe Ident) [CDecl]
+  deriving (Show, Eq, Ord)
+
+data CSUTag
+  = CStructTag
+  | CUnionTag
+  deriving (Show, Eq, Ord)
+
+data CEnum
+  = CEnum (Maybe Ident) [(Ident, Maybe CExpr)]
+  deriving (Show, Eq, Ord)
+
+-----------------
+-- Declarators --
+-----------------
+{-
+  Declarators give us labels to point at and describe the level of indirection.
+  between a label and the underlieing memory
+
+  this is incomplete, see c99 reference p115
+-}
+
+data CDeclr
+  = CDeclr (Maybe CPtrDeclr) CDirectDeclr
+  deriving (Show, Eq, Ord)
+
+data CPtrDeclr = CPtrDeclr [CTypeQual]
+  deriving (Show, Eq, Ord)
+
+data CDirectDeclr
+  = CDDeclrIdent Ident
+  | CDDeclrArr   CDirectDeclr (Maybe CExpr)
+  | CDDeclrFun   CDirectDeclr [[CTypeSpec]]
+  | CDDeclrRec   CDeclr
+  deriving (Show, Eq, Ord)
+
+------------------
+-- Initializers --
+------------------
+{-
+  Initializers allow us to fill our objects with values right as they are
+  declared rather than as a side-effect later in the program.
+-}
+
+data CInit
+  = CInitExpr CExpr
+  | CInitList [([CPartDesig], CInit)]
+  deriving (Show, Eq, Ord)
+
+data CPartDesig
+  = CArrDesig    CExpr
+  | CMemberDesig CExpr
+  deriving (Show, Eq, Ord)
+
+--------------------------------------------------------------------------------
+--                                C Statments                                 --
+--------------------------------------------------------------------------------
+{-
+  The separation between C Statements and C Expressions is fuzzy. Here we take
+  statements as side-effecting operations sequenced by the ";" in pedantic C
+  concrete syntax. Though operators like "++" that are represented as C
+  Expressions in this AST also perform side-effects.
+-}
+
+data CStat
+  = CLabel    Ident CStat
+  | CGoto     Ident
+  | CSwitch   CExpr CStat
+  | CCase     CExpr CStat
+  | CDefault  CStat
+  | CExpr     (Maybe CExpr)
+  | CCompound [CCompoundBlockItem]
+  | CIf       CExpr CStat (Maybe CStat)
+  | CWhile    CExpr CStat Bool
+  | CFor      (Maybe CExpr) (Maybe CExpr) (Maybe CExpr) CStat
+  | CCont
+  | CBreak
+  | CReturn   (Maybe CExpr)
+  | CComment  String
+  | CPPStat   Preprocessor
+  deriving (Show, Eq, Ord)
+
+data CCompoundBlockItem
+  = CBlockStat CStat
+  | CBlockDecl CDecl
+  deriving (Show, Eq, Ord)
+
+--------------------------------------------------------------------------------
+--                                C Expressions                               --
+--------------------------------------------------------------------------------
+{-
+  See C Statments...
+-}
+
+data CExpr
+  = CComma       [CExpr]
+  | CAssign      CAssignOp CExpr CExpr
+  | CCond        CExpr CExpr CExpr
+  | CBinary      CBinaryOp CExpr CExpr
+  | CCast        CTypeName CExpr
+  | CUnary       CUnaryOp CExpr
+  | CSizeOfExpr  CExpr
+  | CSizeOfType  CTypeName
+  | CIndex       CExpr CExpr
+  | CCall        CExpr [CExpr]
+  | CMember      CExpr Ident Bool
+  | CVar         Ident
+  | CConstant    CConst
+  | CCompoundLit CDecl CInit
+  deriving (Show, Eq, Ord)
+
+
+data CAssignOp
+  = CAssignOp
+  | CMulAssOp
+  | CDivAssOp
+  | CRmdAssOp
+  | CAddAssOp
+  | CSubAssOp
+  | CShlAssOp
+  | CShrAssOp
+  | CAndAssOp
+  | CXorAssOp
+  | COrAssOp
+  deriving (Show, Eq, Ord)
+
+
+data CBinaryOp
+  = CMulOp
+  | CDivOp
+  | CRmdOp
+  | CAddOp
+  | CSubOp
+  | CShlOp
+  | CShrOp
+  | CLeOp
+  | CGrOp
+  | CLeqOp
+  | CGeqOp
+  | CEqOp
+  | CNeqOp
+  | CAndOp
+  | CXorOp
+  | COrOp
+  | CLndOp
+  | CLorOp
+  deriving (Show, Eq, Ord)
+
+
+data CUnaryOp
+  = CPreIncOp
+  | CPreDecOp
+  | CPostIncOp
+  | CPostDecOp
+  | CAdrOp
+  | CIndOp
+  | CPlusOp
+  | CMinOp
+  | CCompOp
+  | CNegOp
+  deriving (Show, Eq, Ord)
+
+
+data CConst
+  = CIntConst    Integer
+  | CCharConst   Char
+  | CFloatConst  Float
+  | CStringConst String
+  deriving (Show, Eq, Ord)
+
+
+--------------------------------------------------------------------------------
+--                      Infix and Smart Constructors                          --
+--------------------------------------------------------------------------------
+{-
+  These are helpful when building up ASTs in Haskell code. They correspond to
+  the concrete syntax of C. This is an incomplete set...
+-}
+
+seqCStat :: [CStat] -> CStat
+seqCStat = CCompound . fmap CBlockStat
+
+(.<.),(.>.),(.==.),(.!=.),(.||.),(.&&.),(.*.),(./.),(.-.),(.+.),(.=.),(.+=.),(.*=.),(.<=.),(.>=.)
+  :: CExpr -> CExpr -> CExpr
+a .<. b  = CBinary CLeOp a b
+a .>. b  = CBinary CGrOp a b
+a .==. b = CBinary CEqOp a b
+a .!=. b = CBinary CNeqOp a b
+a .||. b = CBinary CLorOp a b
+a .&&. b = CBinary CLndOp a b
+a .*. b  = CBinary CMulOp a b
+a ./. b  = CBinary CDivOp a b
+a .-. b  = CBinary CSubOp a b
+a .+. b  = CBinary CAddOp a b
+a .<=. b = CBinary CLeqOp a b
+a .>=. b = CBinary CGeqOp a b
+a .=. b  = CAssign CAssignOp a b
+a .+=. b = CAssign CAddAssOp a b
+a .*=. b = CAssign CMulAssOp a b
+
+
+indirect, address :: CExpr -> CExpr
+indirect = CUnary CIndOp
+address  = CUnary CAdrOp
+
+index :: CExpr -> CExpr -> CExpr
+index = CIndex
+
+(...),(.->.) :: CExpr -> String -> CExpr
+i ... n  = CMember i (Ident n) True
+i .->. n = CMember i (Ident n) False
+
+intE :: Integer -> CExpr
+intE = CConstant . CIntConst
+
+floatE :: Float -> CExpr
+floatE = CConstant . CFloatConst
+
+charE :: Char -> CExpr
+charE = CConstant . CCharConst
+
+stringE :: String -> CExpr
+stringE = CConstant . CStringConst
+
+mkCallE :: String -> [CExpr] -> CExpr
+mkCallE s = CCall (CVar . Ident $ s)
+
+mkUnaryE :: String -> CExpr -> CExpr
+mkUnaryE s a = mkCallE s [a]
+
+nullE :: CExpr
+nullE = CVar . Ident $ "NULL"
+
+--------------------------------------------------------------------------------
+
+cNameStream :: [String]
+cNameStream = filter (\n -> not $ elem (head n) ['0'..'9']) names
+  where base :: [Char]
+        base = ['0'..'9'] ++ ['a'..'z']
+        names = [[x] | x <- base] `mplus` (do n <- names
+                                              [n++[x] | x <- base])
diff --git a/haskell/Language/Hakaru/CodeGen/CodeGenMonad.hs b/haskell/Language/Hakaru/CodeGen/CodeGenMonad.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/CodeGen/CodeGenMonad.hs
@@ -0,0 +1,485 @@
+{-# LANGUAGE CPP,
+             BangPatterns,
+             DataKinds,
+             FlexibleContexts,
+             FlexibleInstances,
+             GADTs,
+             KindSignatures,
+             PolyKinds,
+             StandaloneDeriving,
+             TypeOperators,
+             RankNTypes        #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+----------------------------------------------------------------
+--                                                    2016.07.01
+-- |
+-- Module      :  Language.Hakaru.CodeGen.CodeGenMonad
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  zsulliva@indiana.edu
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--   This module provides a monad for C code generation as well
+-- as some useful helper functions for manipulating it
+----------------------------------------------------------------
+
+
+module Language.Hakaru.CodeGen.CodeGenMonad
+  ( CodeGen
+  , CG(..)
+  , runCodeGen
+  , runCodeGenBlock
+  , runCodeGenWith
+  , emptyCG
+
+  -- codegen effects
+  , declare
+  , declare'
+  , assign
+  , putStat
+  , putExprStat
+  , extDeclare
+  , extDeclareTypes
+
+  , funCG
+  , whenPar
+  , parDo
+  , seqDo
+
+  , reserveIdent
+  , genIdent
+  , genIdent'
+
+  -- Hakaru specific
+  , createIdent
+  , createIdent'
+  , lookupIdent
+
+  -- control mechanisms
+  , ifCG
+  , whileCG
+  , doWhileCG
+  , forCG
+  , reductionCG
+  , codeBlockCG
+
+  -- memory
+  , putMallocStat
+  ) where
+
+import Control.Monad.State.Strict
+
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid (Monoid(..))
+import Control.Applicative ((<$>))
+#endif
+
+import Language.Hakaru.Syntax.ABT hiding (var)
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.CodeGen.Types
+import Language.Hakaru.CodeGen.AST
+import Language.Hakaru.CodeGen.Libs
+
+import Data.Number.Nat (fromNat)
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Text          as T
+import qualified Data.Set           as S
+
+-- CG after "codegen", holds the state of a codegen computation
+data CG = CG
+  { freshNames    :: [String]     -- ^ fresh names for code generations
+  , reservedNames :: S.Set String -- ^ reserve names during code generations
+  , extDecls      :: [CExtDecl]   -- ^ total external declarations
+  , declarations  :: [CDecl]      -- ^ declarations in local block
+  , statements    :: [CStat]      -- ^ statements can include assignments as well as other side-effects
+  , varEnv        :: Env          -- ^ mapping between Hakaru vars and codegeneration vars
+  , managedMem    :: Bool         -- ^ garbage collected block
+  , sharedMem     :: Bool         -- ^ shared memory supported block (OpenMP)
+  , simd          :: Bool         -- ^ support single instruction multiple data instructions  (OpenMP)
+  , distributed   :: Bool         -- ^ distributed supported block
+  , logProbs      :: Bool         -- ^ true by default, but might not matter in some situations
+  }
+
+emptyCG :: CG
+emptyCG = CG cNameStream mempty mempty [] [] emptyEnv False False False False True
+
+type CodeGen = State CG
+
+runCodeGen :: CodeGen a -> ([CExtDecl],[CDecl], [CStat])
+runCodeGen m =
+  let (_, cg) = runState m emptyCG
+  in  ( reverse $ extDecls     cg
+      , reverse $ declarations cg
+      , reverse $ statements   cg )
+
+
+runCodeGenBlock :: CodeGen a -> CodeGen CStat
+runCodeGenBlock m =
+  do cg <- get
+     let (_,cg') = runState m $ cg { statements = []
+                                   , declarations = [] }
+     put $ cg' { statements   = statements cg
+               , declarations = declarations cg' ++ declarations cg
+               }
+     return . CCompound . fmap CBlockStat . reverse . statements $ cg'
+
+runCodeGenWith :: CodeGen a -> CG -> [CExtDecl]
+runCodeGenWith cg start = let (_,cg') = runState cg start in reverse $ extDecls cg'
+
+--------------------------------------------------------------------------------
+
+whenPar :: CodeGen () -> CodeGen ()
+whenPar m = (sharedMem <$> get) >>= (\b -> when b m)
+
+parDo :: CodeGen a -> CodeGen a
+parDo m = do
+  cg <- get
+  put (cg { sharedMem = True } )
+  a <- m
+  cg' <- get
+  put (cg' { sharedMem = sharedMem cg } )
+  return a
+
+seqDo :: CodeGen a -> CodeGen a
+seqDo m = do
+  cg <- get
+  put (cg { sharedMem = False } )
+  a <- m
+  cg' <- get
+  put (cg' { sharedMem = sharedMem cg } )
+  return a
+
+--------------------------------------------------------------------------------
+
+reserveIdent :: String -> CodeGen Ident
+reserveIdent s = do
+  get >>= \cg -> put $ cg { reservedNames = s `S.insert` reservedNames cg }
+  return (Ident s)
+
+
+genIdent :: CodeGen Ident
+genIdent = genIdent' ""
+
+genIdent' :: String -> CodeGen Ident
+genIdent' s =
+  do cg <- get
+     let (freshNs,name) = pullName (freshNames cg) (reservedNames cg)
+     put $ cg { freshNames = freshNs }
+     return $ Ident name
+  where pullName :: [String] -> S.Set String -> ([String],String)
+        pullName (n:names) reserved =
+          let name = s ++ "_" ++ n in
+          if S.member name reserved
+          then let (names',out) = pullName names reserved
+               in  (n:names',out)
+          else (names,name)
+        pullName _ _ = error "should not happen, names is infinite"
+
+
+
+createIdent :: Variable (a :: Hakaru) -> CodeGen Ident
+createIdent = createIdent' ""
+
+createIdent' :: String -> Variable (a :: Hakaru) -> CodeGen Ident
+createIdent' s var@(Variable name _ _) =
+  do !cg <- get
+     let ident = Ident $ concat [concatMap toAscii . T.unpack $ name
+                                ,"_",s,"_",head $ freshNames cg ]
+         env'  = updateEnv var ident (varEnv cg)
+     put $! cg { freshNames = tail $ freshNames cg
+               , varEnv     = env' }
+     return ident
+  where toAscii c = let num = fromEnum c in
+                    if num < 48 || num > 122
+                    then "u" ++ (show num)
+                    else [c]
+
+lookupIdent :: Variable (a :: Hakaru) -> CodeGen Ident
+lookupIdent var =
+  do !cg <- get
+     let !env = varEnv cg
+     case lookupVar var env of
+       Nothing -> error $ "lookupIdent: var not found --" ++ show var
+       Just i  -> return i
+
+-- | types like SData and SMeasure are impure in that they will produce extra
+--   code in the CodeGenMonad while literal types SReal, SInt, SNat, and SProb
+--   do not
+declare :: Sing (a :: Hakaru) -> Ident -> CodeGen ()
+declare SInt  = declare' . typeDeclaration SInt
+declare SNat  = declare' . typeDeclaration SNat
+declare SProb = declare' . typeDeclaration SProb
+declare SReal = declare' . typeDeclaration SReal
+declare m@(SMeasure t) = \i ->
+  extDeclareTypes m >> (declare' $ mdataDeclaration t i)
+
+declare a@(SArray t) = \i ->
+  extDeclareTypes a >> (declare' $ arrayDeclaration t i)
+
+declare d@(SData _ _)  = \i ->
+  extDeclareTypes d >> (declare' $ datumDeclaration d i)
+
+declare f@(SFun _ _) = \_ ->
+  extDeclareTypes f >> return ()
+  -- this currently avoids declaration if the type is a lambda, this is hacky
+
+-- | for types that contain subtypes we need to recursively traverse them and
+--   build up a list of external type declarations.
+--   For example: Measure (Array Nat) will need to have structures for arrays
+--   declared before the top level type
+extDeclareTypes :: Sing (a :: Hakaru) -> CodeGen ()
+extDeclareTypes SInt          = return ()
+extDeclareTypes SNat          = return ()
+extDeclareTypes SReal         = return ()
+extDeclareTypes SProb         = return ()
+extDeclareTypes (SMeasure i)  = extDeclareTypes i >> extDeclare (mdataStruct i)
+extDeclareTypes (SArray i)    = extDeclareTypes i >> extDeclare (arrayStruct i)
+extDeclareTypes (SFun x y)    = extDeclareTypes x >> extDeclareTypes y
+extDeclareTypes d@(SData _ i) = extDeclDatum i    >> extDeclare (datumStruct d)
+  where extDeclDatum :: Sing (a :: [[HakaruFun]]) -> CodeGen ()
+        extDeclDatum SVoid       = return ()
+        extDeclDatum (SPlus p s) = extDeclDatum s >> datumProdTypes p
+
+        datumProdTypes :: Sing (a :: [HakaruFun]) -> CodeGen ()
+        datumProdTypes SDone     = return ()
+        datumProdTypes (SEt x p) = datumProdTypes p >> datumPrimTypes x
+
+        datumPrimTypes :: Sing (a :: HakaruFun) -> CodeGen ()
+        datumPrimTypes SIdent     = return ()
+        datumPrimTypes (SKonst s) = extDeclareTypes s
+
+declare' :: CDecl -> CodeGen ()
+declare' d = do cg <- get
+                put $ cg { declarations = d:(declarations cg) }
+
+putStat :: CStat -> CodeGen ()
+putStat s = do cg <- get
+               put $ cg { statements = s:(statements cg) }
+
+putExprStat :: CExpr -> CodeGen ()
+putExprStat = putStat . CExpr . Just
+
+assign :: Ident -> CExpr -> CodeGen ()
+assign ident e = putStat . CExpr . Just $ (CVar ident .=. e)
+
+
+extDeclare :: CExtDecl -> CodeGen ()
+extDeclare d = do cg <- get
+                  let extds = extDecls cg
+                      extds' = if elem d extds
+                               then extds
+                               else d:extds
+                  put $ cg { extDecls = extds' }
+
+---------
+-- ENV --
+---------
+
+newtype Env = Env (IM.IntMap Ident)
+  deriving Show
+
+emptyEnv :: Env
+emptyEnv = Env IM.empty
+
+updateEnv :: Variable (a :: Hakaru) -> Ident -> Env -> Env
+updateEnv (Variable _ nat _) ident (Env env) =
+  Env $! IM.insert (fromNat nat) ident env
+
+lookupVar :: Variable (a :: Hakaru) -> Env -> Maybe Ident
+lookupVar (Variable _ nat _) (Env env) =
+  IM.lookup (fromNat nat) env
+
+--------------------------------------------------------------------------------
+--                      Control Flow and Code Blocks                          --
+--------------------------------------------------------------------------------
+{-
+Monadic operations funCG, ifCG, whileCG, forCG, reductionCG, and codeBlockCG all
+generate compound C statements (several declarations and statements surrounded
+by '{' '}'). It is important that these code blocks float external functions and
+imports to the top of the generated C file AND keep a set of the variable
+declarations local to the block of code.
+-}
+
+funCG :: [CTypeSpec] -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()
+funCG ts ident args m =
+  do cg <- get
+     let (_,cg') = runState m $ cg { statements   = []
+                                   , declarations = []
+                                   , freshNames   = cNameStream }
+     let decls = reverse . declarations $ cg'
+         stmts = reverse . statements   $ cg'
+     -- reset local statements and declarations
+     put $ cg' { statements   = statements cg
+               , declarations = declarations cg
+               , freshNames   = freshNames cg }
+     extDeclare . CFunDefExt $
+       CFunDef (fmap CTypeSpec ts)
+               (CDeclr Nothing (CDDeclrIdent ident))
+               args
+               (CCompound ((fmap CBlockDecl decls) ++ (fmap CBlockStat stmts)))
+
+ifCG :: CExpr -> CodeGen () -> CodeGen () -> CodeGen ()
+ifCG bE m1 m2 =
+  do cg <- get
+     let (_,cg') = runState m1 $ cg { statements   = []
+                                    , declarations = [] }
+         (_,cg'') = runState m2 $ cg' { statements   = []
+                                      , declarations = [] }
+         thnBlock =  (fmap CBlockDecl (reverse $ declarations cg'))
+                  ++ (fmap CBlockStat (reverse $ statements cg'))
+         elsBlock =  (fmap CBlockDecl (reverse $ declarations cg'')
+                  ++ (fmap CBlockStat (reverse $ statements cg'')))
+     put $ cg'' { statements = statements cg
+                , declarations = declarations cg }
+     putStat $ CIf bE
+                   (CCompound thnBlock)
+                   (case elsBlock of
+                      [] -> Nothing
+                      _  -> Just . CCompound $ elsBlock)
+
+whileCG' :: Bool -> CExpr -> CodeGen () -> CodeGen ()
+whileCG' isDoWhile bE m =
+  do cg <- get
+     let (_,cg') = runState m $ cg { statements = []
+                                   , declarations = [] }
+     put $ cg' { statements = statements cg
+               , declarations = declarations cg }
+     putStat $ CWhile bE
+                      (CCompound $ (fmap CBlockDecl (reverse $ declarations cg')
+                                ++ (fmap CBlockStat (reverse $ statements cg'))))
+                      isDoWhile
+whileCG :: CExpr -> CodeGen () -> CodeGen ()
+whileCG = whileCG' False
+
+doWhileCG :: CExpr -> CodeGen () -> CodeGen ()
+doWhileCG = whileCG' True
+
+-- forCG and reductionCG both create C for loops, their difference lies in the
+-- parallel code they generate
+forCG
+  :: CExpr
+  -> CExpr
+  -> CExpr
+  -> CodeGen ()
+  -> CodeGen ()
+forCG iter cond inc body =
+  do cg <- get
+     let (_,cg') = runState body $ cg { statements = []
+                                      , declarations = []
+                                      , sharedMem = False }
+     put $ cg' { statements   = statements cg
+               , declarations = declarations cg
+               , sharedMem    = sharedMem cg } -- only use pragmas at the top level
+     whenPar . putStat . CPPStat . ompToPP $ OMP (Parallel [For])
+     putStat $ CFor (Just iter)
+                    (Just cond)
+                    (Just inc)
+                    (CCompound $  (fmap CBlockDecl (reverse $ declarations cg')
+                               ++ (fmap CBlockStat (reverse $ statements cg'))))
+
+{-
+The operation for a reduction is either a builtin binary op (which is a built
+in OpenMP reducer),
+
+OR, it must be specified for a given Hakaru type. This will generate fuctions
+for the monoidal operations mempty and mappend, use these to generate OpenMP
+reduction declarations, and then outfit a for loop with the pragma calling the
+reduction.
+-}
+reductionCG
+  :: Either CBinaryOp
+            ( Sing (a :: Hakaru)             -- type of reduction sections
+            , CExpr -> CodeGen ()            -- monoidal unit
+            , CExpr -> CExpr -> CodeGen () ) -- monoidal multiplication
+  -> CExpr       -- accumulator var
+  -> CExpr       -- iteration var
+  -> CExpr       -- iteration condition
+  -> CExpr       -- iteration increment
+  -> CodeGen ()  -- body of the loop
+  -> CodeGen ()
+reductionCG op acc iter cond inc body =
+  do cg <- get
+     let (_,cg') = runState body $ cg { statements   = []
+                                      , declarations = []
+                                      , sharedMem    = False } -- only use pragmas at the top level
+     put $ cg' { statements   = statements cg
+               , declarations = declarations cg
+               , sharedMem    = sharedMem cg }
+     whenPar $
+       case op of
+         Left binop ->
+           putStat . CPPStat . ompToPP $
+             OMP (Parallel [For,Reduction (Left binop) [acc]])
+         Right (typ,unit,mul) ->
+           do { redId <- declareReductionCG typ unit mul
+              ; putStat . CPPStat . ompToPP $
+                  OMP (Parallel [For,Reduction (Right redId) [acc]]) }
+     putStat $ CFor (Just iter)
+                    (Just cond)
+                    (Just inc)
+                    (CCompound $  (fmap CBlockDecl (reverse $ declarations cg')
+                               ++ (fmap CBlockStat (reverse $ statements cg'))))
+
+-- given a monoid for a Hakaru type, generate the appropriate openMP reduction
+-- declaration and return its unique identifier
+declareReductionCG
+  :: Sing (a :: Hakaru)
+  -> (CExpr -> CodeGen ())
+  -> (CExpr -> CExpr -> CodeGen ())
+  -> CodeGen Ident
+declareReductionCG typ unit mul =
+  do redId <- genIdent' "red"
+     unitId <- genIdent' "unit"
+     mulId <- genIdent' "mul"
+     let declType = typePtrDeclaration typ
+
+     inId <- genIdent' "in"
+     funCG [CVoid] unitId [declType inId] $
+       unit . CVar $ inId
+
+     outId <- genIdent' "out"
+     in2Id <- genIdent' "in"
+     funCG [CVoid] mulId [declType outId,declType in2Id] $
+         mul (CVar outId) (CVar in2Id)
+
+     let typ' = case buildType typ of
+                  (x:_) -> x
+                  _ -> error $ "buildType{" ++ (show typ) ++ "}"
+     putStat . CPPStat . ompToPP $
+       OMP (DeclareRed redId
+                       typ'
+                       (CCall (CVar mulId)
+                              (fmap (address . CVar . Ident)
+                                    ["omp_in","omp_out"]))
+                       (CCall (CVar unitId)
+                              [address . CVar . Ident $ "omp_priv"]))
+     return redId
+
+
+-- not control flow, but like these it creates a block with local variables
+codeBlockCG :: CodeGen () -> CodeGen ()
+codeBlockCG body =
+  do cg <- get
+     let (_,cg') = runState body $ cg { statements = []
+                                      , declarations = [] }
+     put $ cg' { statements = statements cg
+               , declarations = declarations cg }
+     putStat $ (CCompound $  (fmap CBlockDecl (reverse $ declarations cg')
+                          ++ (fmap CBlockStat (reverse $ statements cg'))))
+
+
+
+--------------------------------------------------------------------------------
+-- ^ Takes a cexpression for the location and size and a hakaru type, and
+--   generates a statement for allocating the memory
+putMallocStat :: CExpr -> CExpr -> Sing (a :: Hakaru) -> CodeGen ()
+putMallocStat loc size typ = do
+  isManagedMem <- managedMem <$> get
+  let malloc' = if isManagedMem then gcMalloc else mallocE
+      typ' = buildType typ
+  putExprStat $   loc
+              .=. ( CCast (CTypeName typ' True)
+                  $ malloc' (size .*. (CSizeOfType (CTypeName typ' False))))
diff --git a/haskell/Language/Hakaru/CodeGen/Flatten.hs b/haskell/Language/Hakaru/CodeGen/Flatten.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/CodeGen/Flatten.hs
@@ -0,0 +1,1600 @@
+{-# LANGUAGE CPP,
+             BangPatterns,
+             DataKinds,
+             FlexibleContexts,
+             GADTs,
+             KindSignatures,
+             ScopedTypeVariables,
+             RankNTypes,
+             TypeOperators #-}
+
+----------------------------------------------------------------
+--                                                    2016.06.23
+-- |
+-- Module      :  Language.Hakaru.CodeGen.Flatten
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  zsulliva@indiana.edu
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--   Flatten takes Hakaru ABTs and C vars and returns a CStatement
+-- assigning the var to the flattened ABT.
+--
+----------------------------------------------------------------
+
+
+module Language.Hakaru.CodeGen.Flatten
+  ( flattenABT
+  , flattenVar
+  , flattenTerm
+  , flattenWithName
+  , flattenWithName'
+  , localVar
+  , localVar'
+  , opComment
+  ) where
+
+import Language.Hakaru.CodeGen.CodeGenMonad
+import Language.Hakaru.CodeGen.AST
+import Language.Hakaru.CodeGen.Libs
+import Language.Hakaru.CodeGen.Types
+
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.Datum hiding (Ident)
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.IClasses
+import qualified Language.Hakaru.Syntax.Prelude as HKP
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Types.Sing
+
+import           Control.Monad.State.Strict
+import           Data.Number.Natural
+import           Data.Ratio
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Sequence      as S
+import qualified Data.Foldable      as F
+import qualified Data.Traversable   as T
+
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative (pure)
+import           Control.Monad (replicateM)
+import           Data.Functor
+import           Data.Monoid        hiding (Product,Sum)
+#endif
+
+
+opComment :: String -> CStat
+opComment opStr = CComment $ concat [space," ",opStr," ",space]
+  where size  = (50 - (length opStr)) `div` 2 - 8
+        space = replicate size '-'
+
+--------------------------------------------------------------------------------
+--                                 Top Level                                  --
+--------------------------------------------------------------------------------
+{-
+
+flattening an ABT will produce a continuation that takes a CExpr representing
+a location where the value of the ABT should be stored. Return type of the
+the continuation is CodeGen Bool, where the computed bool is whether or not
+there is a Reject inside the ABT. Therefore it is only needed when computing
+mochastic values
+
+-}
+
+localVar :: Sing (a :: Hakaru) -> CodeGen CExpr
+localVar typ = localVar' typ ""
+
+localVar' :: Sing (a :: Hakaru) -> String -> CodeGen CExpr
+localVar' typ s =
+  do eId <- genIdent' s
+     declare typ eId
+     return (CVar eId)
+
+
+flattenWithName'
+  :: ABT Term abt
+  => abt '[] a
+  -> String
+  -> CodeGen CExpr
+flattenWithName' abt hint = do
+  ident <- genIdent' hint
+  declare (typeOf abt) ident
+  let cvar = CVar ident
+  flattenABT abt cvar
+  return cvar
+
+flattenWithName
+  :: ABT Term abt
+  => abt '[] a
+  -> CodeGen CExpr
+flattenWithName abt = flattenWithName' abt ""
+
+flattenABT
+  :: ABT Term abt
+  => abt '[] a
+  -> (CExpr -> CodeGen ())
+flattenABT abt = caseVarSyn abt flattenVar flattenTerm
+
+-- note that variables will find their values in the state of the CodeGen monad
+flattenVar
+  :: Variable (a :: Hakaru)
+  -> (CExpr -> CodeGen ())
+flattenVar v = \loc ->
+  do v' <- CVar <$> lookupIdent v
+     putExprStat $ loc .=. v'
+
+flattenTerm
+  :: ABT Term abt
+  => Term abt a
+  -> (CExpr -> CodeGen ())
+-- SCon can contain mochastic terms
+flattenTerm (x :$ ys)         = flattenSCon x ys
+
+flattenTerm (NaryOp_ t s)     = flattenNAryOp t s
+flattenTerm (Literal_ x)      = flattenLit x
+flattenTerm (Empty_ _)        = error "TODO: flattenTerm{Empty}"
+
+flattenTerm (Datum_ d)        = flattenDatum d
+flattenTerm (Case_ c bs)      = flattenCase c bs
+
+flattenTerm (Bucket b e rs)   = flattenBucket b e rs
+
+flattenTerm (Array_ s e)      = flattenArray s e
+flattenTerm (ArrayLiteral_ s) = flattenArrayLiteral s
+
+
+---------------------
+-- Mochastic Terms --
+---------------------
+flattenTerm (Superpose_ wes)  = flattenSuperpose wes
+flattenTerm (Reject_ _)       = \loc -> putExprStat (mdataWeight loc .=. (intE 0))
+
+
+--------------------------------------------------------------------------------
+--                                  SCon                                      --
+--------------------------------------------------------------------------------
+
+flattenSCon
+  :: ( ABT Term abt )
+  => SCon args a
+  -> SArgs abt args
+  -> (CExpr -> CodeGen ())
+
+flattenSCon Let_ =
+  \(expr :* body :* End) ->
+    \loc -> do
+      caseBind body $ \v@(Variable _ _ typ) body'->
+        do ident <- createIdent v
+           declare typ ident
+           flattenABT expr (CVar ident)
+           flattenABT body' loc
+
+-- Lambdas produce functions and then return a function label exprssion
+flattenSCon Lam_ =
+  \(body :* End) ->
+    \loc ->
+      coalesceLambda body $ \args body' ->
+        let freevars = fromVarSet . freeVars $ body'
+            retTyp   = typeOf body'
+        in do { -- create code block and closure structure
+                args' <- sequence . foldMap11 argDecl $ args
+              ; envId <- genIdent' "env"
+              ; fnId  <- genIdent' "fn"
+              ; closDataId@(Ident clos_n) <- genIdent' "clos_data"
+              ; extDeclare (closureStructure freevars args closDataId retTyp)
+              ; funCG (buildType retTyp)
+                      fnId
+                      ((buildDeclaration (callStruct clos_n) envId):args') $
+                  do { putStat (opComment "Begin Unpack Closure")
+                       -- need to re-declare variables in functions scope
+                     ; mapM_ (\(SomeVariable v@(Variable _ _ typ)) ->
+                               lookupIdent v >>= declare typ)
+                             freevars
+                     ; unpackClosure (CVar envId) cNameStream freevars
+                     ; putStat (opComment "End Unpack Closure")
+                     ; x <- flattenWithName body'
+                     ; putStat . CReturn . Just $ x }
+
+                -- create the closure object
+              ; closureId <- genIdent' "closure"
+              ; declare' . buildDeclaration (callStruct clos_n) $ closureId
+              ; putStat (opComment "Begin Pack Closure")
+              ; putExprStat $ ((CVar closureId) ... "_code_ptr") .=. (address (CVar fnId))
+              ; packClosure (CVar closureId) cNameStream freevars
+              ; putStat (opComment "End Pack Closure")
+              ; putExprStat $ loc .=. (CVar closureId) }
+
+  where -- collapses nested lambdas of one argument to lambdas that take a list
+        -- arguments
+        coalesceLambda
+          :: ( ABT Term abt )
+          => abt '[x] a
+          -> (forall (ys :: [Hakaru]) b. List1 Variable ys -> abt '[] b -> r)
+          -> r
+        coalesceLambda abt k =
+          caseBind abt $ \v abt' ->
+            caseVarSyn abt' (const (k (Cons1 v Nil1) abt')) $ \term ->
+              case term of
+                (Lam_ :$ body :* End) ->
+                  coalesceLambda body $ \vars abt'' -> k (Cons1 v vars) abt''
+                _ -> k (Cons1 v Nil1) abt'
+
+        argDecl :: Variable (a :: Hakaru) -> [CodeGen CDecl]
+        argDecl v@(Variable _ _ typ) =
+          [do { ident <- createIdent v ; return (typeDeclaration typ ident) }]
+
+        -- captures the environment variables in closure object
+        packClosure, unpackClosure
+          :: CExpr
+          -> [String]
+          -> [SomeVariable (KindOf (a :: Hakaru))]
+          -> CodeGen ()
+        packClosure _ _      [] = return ()
+        packClosure c (n:ns) ((SomeVariable a):as) =
+          do { a' <- CVar <$> lookupIdent a
+             ; putExprStat $ c ... n .=. a'
+             ; packClosure c ns as }
+        packClosure _ _ _ = error "this isn't possible"
+
+        unpackClosure _ _      [] = return ()
+        unpackClosure c (n:ns) ((SomeVariable a):as) =
+          do { a' <- CVar <$> lookupIdent a
+             ; putExprStat $ a' .=. c ... n
+             ; unpackClosure c ns as }
+        unpackClosure _ _ _ = error "this isn't possible"
+
+flattenSCon App_  =
+ \(fun :* arg :* End) ->
+   \loc ->
+     do { closE <- flattenWithName' fun "closure"
+        ; paramE <- flattenWithName' arg "param"
+        ; putExprStat $ loc .=. CCall (indirect (closE ... "_code_ptr"))
+                                      [closE,paramE] }
+
+flattenSCon (PrimOp_ op) = flattenPrimOp op
+
+flattenSCon (ArrayOp_ op) = flattenArrayOp op
+
+flattenSCon (Summate _ sr) =
+  \(lo :* hi :* body :* End) ->
+    \loc ->
+      let  semiTyp = sing_HSemiring sr in
+        do loE <- flattenWithName' lo "lo"
+           hiE <- flattenWithName' hi "hi"
+
+           putStat $ opComment "Begin Summate"
+
+           case semiTyp of
+             -- special prob branch
+             SProb -> do
+               summateArrId <- genIdent' "summate_arr"
+               declare (SArray SProb) summateArrId
+               let summateArrE = CVar summateArrId
+               putExprStat $ arraySize summateArrE .=. (hiE .-. loE)
+               putExprStat $ arrayData summateArrE
+                     .=. (castToPtrOf [CDouble]
+                           (mallocE ((arraySize summateArrE) .*.
+                                    (CSizeOfType (CTypeName [CDouble] False)))))
+               lseSummateArrayCG body summateArrE loc
+               putExprStat $ freeE (arrayData summateArrE)
+
+             _ ->
+               caseBind body $ \v body' -> do
+                 iterI <- createIdent v
+                 declare SNat iterI
+
+                 accI <- genIdent' "acc"
+                 declare semiTyp accI
+                 assign accI (case semiTyp of
+                                SReal -> floatE 0
+                                _     -> intE 0)
+
+                 let accVar  = CVar accI
+                     iterVar = CVar iterI
+
+                 reductionCG (Left CAddOp)
+                             accVar
+                             (iterVar .=. loE)
+                             (iterVar .<. hiE)
+                             (CUnary CPostIncOp iterVar) $
+                   (putExprStat . (accVar .+=.) =<< flattenWithName body')
+                 putExprStat $ loc .=. accVar
+
+           putStat $ opComment "End Summate"
+
+
+
+flattenSCon (Product _ sr) =
+  \(lo :* hi :* body :* End) ->
+    \loc ->
+      let  semiTyp = sing_HSemiring sr in
+        do loE <- flattenWithName' lo "lo"
+           hiE <- flattenWithName' hi "hi"
+
+           putStat $ opComment "Begin Product"
+
+           case semiTyp of
+           -- special prob branch
+             SProb -> kahanSummationCG body loE hiE loc
+
+             _ ->
+               caseBind body $ \v body' -> do
+                 iterI <- createIdent v
+                 declare SNat iterI
+
+                 accI <- genIdent' "acc"
+                 declare semiTyp accI
+                 assign accI (case semiTyp of
+                                SReal -> floatE 1
+                                _     -> intE 1)
+
+                 let accVar  = CVar accI
+                     iterVar = CVar iterI
+
+                 reductionCG (Left CMulOp)
+                             accVar
+                             (iterVar .=. loE)
+                             (iterVar .<. hiE)
+                             (CUnary CPostIncOp iterVar) $
+                    (putExprStat . (accVar .*=.) =<< flattenWithName body')
+                 putExprStat (loc .=. accVar)
+           putStat $ opComment "End Product"
+
+
+--------------------
+-- SCon Coercions --
+--------------------
+{- Helpers found by searching "Coercion Helpers" -}
+
+flattenSCon (CoerceTo_ ctyp) =
+  \(e :* End) ->
+    \loc ->
+      do eE <- flattenWithName e
+         cE <- coerceToCG ctyp eE
+         putExprStat $ loc .=. cE
+
+flattenSCon (UnsafeFrom_ ctyp) =
+  \(e :* End) ->
+    \loc ->
+      do eE <- flattenWithName e
+         cE <- coerceFromCG ctyp eE
+         putExprStat $ loc .=. cE
+
+-----------------------------------
+-- SCons in the Stochastic Monad --
+-----------------------------------
+
+flattenSCon (MeasureOp_ op) = flattenMeasureOp op
+
+flattenSCon Dirac           =
+  \(e :* End) ->
+    \loc ->
+      do sE <- flattenWithName' e "samp"
+         putExprStat $ mdataWeight loc .=. (floatE 0)
+         putExprStat $ mdataSample loc .=. sE
+
+flattenSCon MBind           =
+  \(ma :* b :* End) ->
+    \loc ->
+      caseBind b $ \v@(Variable _ _ typ) mb ->
+        do -- first
+           mE <- flattenWithName' ma "m"
+
+           -- assign that sample to var
+           vId <- createIdent v
+           declare typ vId
+           assign vId (mdataSample mE)
+           flattenABT mb loc
+           putExprStat $ mdataWeight loc .+=. (mdataWeight mE)
+
+-- for now plats make use of a global sample
+flattenSCon Plate           =
+  \(size :* b :* End) ->
+    \loc ->
+      caseBind b $ \v body ->
+        do sizeE <- flattenWithName' size "s"
+           isMM <- managedMem <$> get
+           when (not isMM) (error "plate will leak memory without the '-g' flag and boehm-gc")
+           putExprStat $ (arraySize . mdataSample $ loc) .=. sizeE
+           putMallocStat (arrayData . mdataSample $ loc) sizeE (typeOf body)
+
+           weightId <- genIdent' "w"
+           declare SProb weightId
+           let weightE = CVar weightId
+           assign weightId (floatE 0)
+
+           itId <- createIdent v
+           declare SNat itId
+           let itE = CVar itId
+               currInd  = index (arrayData . mdataSample $ loc) itE
+
+           sampId <- genIdent' "samp"
+           declare (typeOf $ body) sampId
+           let sampE = CVar sampId
+
+           reductionCG (Left CAddOp)
+                       weightE
+                       (itE .=. (intE 0))
+                       (itE .<. sizeE)
+                       (CUnary CPostIncOp itE)
+                       (do flattenABT body sampE
+                           putExprStat (currInd .=. (mdataSample sampE))
+                           putExprStat (weightE .+=. (mdataWeight sampE)))
+
+           putExprStat $ mdataWeight loc .=. weightE
+
+-----------------------------------
+-- SCon's that arent implemented --
+-----------------------------------
+
+flattenSCon x               = \_ -> \_ -> error $ "TODO: flattenSCon: " ++ show x
+
+
+
+--------------------------------------------------------------------------------
+--                                 NaryOps                                    --
+--------------------------------------------------------------------------------
+
+flattenNAryOp :: ABT Term abt
+              => NaryOp a
+              -> S.Seq (abt '[] a)
+              -> (CExpr -> CodeGen ())
+flattenNAryOp op args =
+  \loc ->
+    do es <- T.mapM flattenWithName args
+       case op of
+         And -> boolNaryOp op es loc
+         Or  -> boolNaryOp op es loc
+         Xor -> boolNaryOp op es loc
+         Iff -> boolNaryOp op es loc
+         (Sum HSemiring_Prob) -> logSumExpCG es loc
+         _ -> let opE = F.foldr (binaryOp op) (S.index es 0) (S.drop 1 es)
+              in  putExprStat (loc .=. opE)
+
+  where boolNaryOp op' es' loc' =
+          let indexOf x = CMember x (Ident "index") True
+              es''      = fmap indexOf es'
+              expr      = F.foldr (binaryOp op')
+                                  (S.index es'' 0)
+                                  (S.drop 1 es'')
+          in  putExprStat ((indexOf loc') .=. expr)
+
+
+--------------------------------------------------------------------------------
+--                                  Literals                                  --
+--------------------------------------------------------------------------------
+
+flattenLit
+  :: Literal a
+  -> (CExpr -> CodeGen ())
+flattenLit lit =
+  \loc ->
+    case lit of
+      (LNat x)  -> putExprStat $ loc .=. (intE $ fromIntegral x)
+      (LInt x)  -> putExprStat $ loc .=. (intE x)
+      (LReal x) -> putExprStat $ loc .=. (floatE $ fromRational x)
+      (LProb x) -> let rat = fromNonNegativeRational x
+                       x'  = (fromIntegral $ numerator rat)
+                           / (fromIntegral $ denominator rat)
+                       xE  = log1pE (floatE x' .-. intE 1)
+                   in putExprStat (loc .=. xE)
+
+--------------------------------------------------------------------------------
+--                                Array and ArrayOps                          --
+--------------------------------------------------------------------------------
+
+
+flattenArray
+  :: (ABT Term abt)
+  => (abt '[] 'HNat)
+  -> (abt '[ 'HNat ] a)
+  -> (CExpr -> CodeGen ())
+flattenArray arity body =
+  \loc ->
+    caseBind body $ \v body' -> do
+      let arityE = arraySize loc
+          dataE  = arrayData loc
+          typ    = typeOf body'
+
+      flattenABT arity arityE
+
+      isManagedMem <- managedMem <$> get
+      let malloc' = if isManagedMem then gcMalloc else mallocE
+      putExprStat $   dataE
+                  .=. (CCast (CTypeName (buildType typ) True)
+                             (malloc' (arityE .*. (CSizeOfType (CTypeName (buildType typ) False)))))
+
+      itId  <- createIdent v
+      declare SNat itId
+      let itE     = CVar itId
+          currInd = index dataE itE
+
+      putStat $ opComment "Begin Array"
+      forCG (itE .=. (intE 0))
+            (itE .<. arityE)
+            (CUnary CPostIncOp itE)
+            (flattenABT body' currInd)
+      putStat $ opComment "End Array"
+
+flattenArrayLiteral
+  :: ( ABT Term abt )
+  => [abt '[] a]
+  -> (CExpr -> CodeGen ())
+flattenArrayLiteral es =
+  \loc -> do
+    arrId <- genIdent
+    isManagedMem <- managedMem <$> get
+    let arity = fromIntegral . length $ es
+        typ   = typeOf . head $ es
+        arrE = CVar arrId
+        malloc' = if isManagedMem then gcMalloc else mallocE
+
+    declare (SArray typ) arrId
+    putExprStat $   (arrayData arrE)
+                .=. (CCast (CTypeName (buildType typ) True)
+                           (malloc' ((intE arity) .*. (CSizeOfType (CTypeName (buildType typ) False)))))
+
+    putExprStat $ arraySize arrE .=. (intE arity)
+    sequence_ . snd $ foldl (\(i,acc) e -> (succ i,(assignIndex e i arrE):acc))
+                            (0,[])
+                            es
+    putExprStat $ loc .=. arrE
+  where assignIndex
+          :: ( ABT Term abt )
+          => abt '[] a
+          -> Integer
+          -> (CExpr -> CodeGen ())
+        assignIndex e i loc = do
+          eE <- flattenWithName e
+          putExprStat $ indirect ((arrayData loc) .+. (intE i)) .=. eE
+
+--------------
+-- ArrayOps --
+--------------
+
+flattenArrayOp
+  :: ( ABT Term abt
+     , typs ~ UnLCs args
+     , args ~ LCs typs
+     )
+  => ArrayOp typs a
+  -> SArgs abt args
+  -> (CExpr -> CodeGen ())
+
+
+flattenArrayOp (Index _)  =
+  \(arr :* ind :* End) ->
+    \loc ->
+      do indE <- flattenWithName ind
+         arrE <- flattenWithName arr
+         let valE = index (CMember arrE (Ident "data") True) indE
+         putExprStat (loc .=. valE)
+
+flattenArrayOp (Size _)   =
+  \(arr :* End) ->
+    \loc ->
+      do arrE <- flattenWithName arr
+         putExprStat (loc .=. (CMember arrE (Ident "size") True))
+
+flattenArrayOp (Reduce _) = error "TODO: flattenArrayOp"
+  -- \(fun :* base :* arr :* End) ->
+  -- do funE  <- flattenABT fun
+  --    baseE <- flattenABT base
+  --    arrE  <- flattenABT arr
+  --    accI  <- genIdent' "acc"
+  --    iterI <- genIdent' "iter"
+
+  --    let sizeE = CMember arrE (Ident "size") True
+  --        iterE = CVar iterI
+  --        accE  = CVar accI
+  --        cond  = iterE .<. sizeE
+  --        inc   = CUnary CPostIncOp iterE
+
+  --    declare (typeOf base) accI
+  --    declare SInt iterI
+  --    assign accI baseE
+  --    forCG (iterE .=. (intE 0)) cond inc $
+  --      assign accI $ CCall funE [accE]
+
+  --    return accE
+
+--------------------------------------------------------------------------------
+--                              Bucket and Reducers                           --
+--------------------------------------------------------------------------------
+{- Declarations for buckets -
+  since we will have some product of monoids we need unique names for each one.
+
+  Ex:
+    bucket i from 0 to 100:
+      fanout(add(\_ -> 1),add(\_ -> 2))
+
+  we will need to keep track of two ints:
+
+  int x;
+  int y;
+  for (i = 0; i < 100; i++) {
+    x += 1;
+    y += 2;
+  }
+
+  Summary objects are nested pairs, e.g. pair(nat,pair(real,array(nat)))
+-}
+
+flattenBucket
+  :: (ABT Term abt)
+  => abt '[] 'HNat
+  -> abt '[] 'HNat
+  -> Reducer abt '[] a
+  -> (CExpr -> CodeGen ())
+flattenBucket lo hi red = \loc -> do
+    putStat $ opComment "Begin Bucket"
+    loE <- flattenWithName' lo "lo"
+    hiE <- flattenWithName' hi "hi"
+    itId <- genIdent' "it"
+    declare SNat itId
+    let itE = CVar itId
+    initRed red loc
+    isPar <- sharedMem <$> get
+    -- declare special functions for combining threads. This doesn't completely
+    -- work now, because these need to capture free variables.
+    reductionCG (Right ( typeOfReducer red
+                       , \e -> seqDo (  initRed red (indirect e)
+                                     >> putStat (CReturn Nothing))
+                       , \a b -> seqDo (  mulRed red (indirect a) (indirect b)
+                                       >> putStat (CReturn Nothing))))
+                loc
+                (itE .=. loE)
+                (itE .<. hiE)
+                (CUnary CPostIncOp itE)
+                (accumRed isPar red itE loc)
+    putStat $ opComment "End Bucket"
+
+  where initRed
+          :: (ABT Term abt)
+          => Reducer abt xs a
+          -> (CExpr -> CodeGen ())
+        initRed mr = \loc ->
+          case mr of
+            (Red_Fanout mr1 mr2) -> initRed mr1 (datumFst loc)
+                                 >> initRed mr2 (datumSnd loc)
+            (Red_Split _ mr1 mr2) -> initRed mr1 (datumFst loc)
+                                  >> initRed mr2 (datumSnd loc)
+            (Red_Index s _ body) ->
+              let (vs,s') = caseBinds s
+                  btyp     = typeOfReducer body in
+                do sequence_ . foldMap11
+                     (\v' -> case v' of
+                       (Variable _ _ typ') ->
+                         [declare typ' =<< createIdent v'])
+                     $ vs
+                   sE <- flattenWithName' s' "red_size"
+                   putExprStat $ arraySize loc .=. sE
+                   putMallocStat (arrayData loc) sE btyp
+                   itId  <- genIdent
+                   declare SNat itId
+                   let itE = CVar itId
+                   forCG (itE .=. (intE 0))
+                         (itE .<. sE)
+                         (CUnary CPostIncOp itE)
+                         (initRed body (index (arrayData loc) itE))
+            Red_Nop -> return ()
+            (Red_Add sr _) ->
+              putExprStat $ loc .=. (addMonoidIdentity . sing_HSemiring $ sr)
+
+        accumRed
+          :: (ABT Term abt)
+          => Bool
+          -> Reducer abt xs a
+          -> CExpr
+          -> (CExpr -> CodeGen ())
+        accumRed isPar mr itE = \loc ->
+          case mr of
+            (Red_Index _ a body) ->
+              caseBind a $ \v@(Variable _ _ typ) a' ->
+                let (vs,a'') = caseBinds a' in
+                  do vId <- createIdent v
+                     declare typ vId
+                     putExprStat $ (CVar vId) .=. itE
+                     sequence_ . foldMap11
+                       (\v' -> case v' of
+                         (Variable _ _ typ') ->
+                           [declare typ' =<< createIdent v'])
+                       $ vs
+                     aE <- flattenWithName' a'' "index"
+                     accumRed isPar body itE (index (arrayData loc) aE)
+            (Red_Fanout mr1 mr2) -> accumRed isPar mr1 itE (datumFst loc)
+                                 >> accumRed isPar mr2 itE (datumSnd loc)
+            (Red_Split b mr1 mr2) ->
+              caseBind b $ \v@(Variable _ _ typ) b' ->
+                let (vs,b'') = caseBinds b' in
+                  do vId <- createIdent v
+                     declare typ vId
+                     putExprStat $ (CVar vId) .=. itE
+                     sequence_ . foldMap11
+                       (\v' -> case v' of
+                         (Variable _ _ typ') ->
+                           [declare typ' =<< createIdent v'])
+                       $ vs
+                     bE <- flattenWithName' b'' "cond"
+                     ifCG (bE ... "index" .==. (intE 0))
+                          (accumRed isPar mr1 itE (datumFst loc))
+                          (accumRed isPar mr2 itE (datumSnd loc))
+            Red_Nop -> return ()
+            (Red_Add sr e) ->
+              caseBind e $ \v@(Variable _ _ typ) e' ->
+                let (vs,e'') = caseBinds e' in
+                  do vId <- createIdent v
+                     declare typ vId
+                     putExprStat $ (CVar vId) .=. itE
+                     sequence_ . foldMap11
+                       (\v' -> case v' of
+                         (Variable _ _ typ') ->
+                           [declare typ' =<< createIdent v'])
+                       $ vs
+                     eE <- flattenWithName e''
+                     -- when isPar $  putStat . CPPStat . ompToPP $ OMP Critical
+                     case sing_HSemiring sr of
+                       SProb -> logSumExpCG (S.fromList [loc,eE]) loc
+                       _ -> putExprStat $ loc .+=. eE
+
+        mulRed
+          :: (ABT Term abt)
+          => Reducer abt xs a
+          -> (CExpr -> CExpr -> CodeGen ())
+        mulRed mr outp inp =
+          case mr of
+             (Red_Index _ _ mr') ->
+               do itE <- localVar SNat
+                  forCG (itE .=. (intE 0))
+                        (itE .<. (intE 0))
+                        (CUnary CPostIncOp itE)
+                        (mulRed mr'
+                                (index (arrayData outp) itE)
+                                (index (arrayData inp) itE))
+             (Red_Fanout mr1 mr2) -> mulRed mr1 (datumFst outp) (datumFst inp)
+                                  >> mulRed mr2 (datumFst outp) (datumFst inp)
+             (Red_Split _ mr1 mr2) -> mulRed mr1 (datumFst outp) (datumFst inp)
+                                   >> mulRed mr2 (datumFst outp) (datumFst inp)
+             Red_Nop -> return ()
+             (Red_Add _ _) -> putExprStat $ outp .+=. inp
+
+addMonoidIdentity :: Sing (a :: Hakaru) -> CExpr
+addMonoidIdentity s =
+  case s of
+    SNat  -> intE 0
+    SInt  -> intE 0
+    SReal -> floatE 0
+    SProb -> logE (floatE 0)
+    SArray x -> addMonoidIdentity x
+    x -> error $ "addMonoidIdentity{" ++ show x ++ "}"
+
+--------------------------------------------------------------------------------
+--                                 Datum and Case                             --
+--------------------------------------------------------------------------------
+{-
+
+Datum are sums of products of types. This maps to a C structure. flattenDatum
+will produce a literal of some datum type. This will also produce a global
+struct representing that datum which will be needed for the C compiler.
+
+-}
+
+
+flattenDatum
+  :: (ABT Term abt)
+  => Datum (abt '[]) (HData' a)
+  -> (CExpr -> CodeGen ())
+flattenDatum (Datum _ typ code) =
+  \loc ->
+    do extDeclareTypes typ
+       assignDatum code loc
+
+assignDatum
+  :: (ABT Term abt)
+  => DatumCode xss (abt '[]) c
+  -> CExpr
+  -> CodeGen ()
+assignDatum code ident =
+  let ind       = getIndex code
+      indExpr = CMember ident (Ident "index") True
+  in  do putExprStat (indExpr .=. (intE ind))
+         sequence_ $ assignSum code ident
+  where getIndex :: DatumCode xss b c -> Integer
+        getIndex (Inl _)    = 0
+        getIndex (Inr rest) = succ (getIndex rest)
+
+assignSum
+  :: (ABT Term abt)
+  => DatumCode xs (abt '[]) c
+  -> CExpr
+  -> [CodeGen ()]
+assignSum code ident = fst $ runState (assignSum' code ident) cNameStream
+
+assignSum'
+  :: (ABT Term abt)
+  => DatumCode xs (abt '[]) c
+  -> CExpr
+  -> State [String] [CodeGen ()]
+assignSum' (Inr rest) topIdent =
+  do names <- get
+     put (tail names)
+     assignSum' rest topIdent
+assignSum' (Inl prod) topIdent =
+  do name <- head <$> get
+     return $ assignProd prod topIdent (CVar . Ident $ name)
+
+assignProd
+  :: (ABT Term abt)
+  => DatumStruct xs (abt '[]) c
+  -> CExpr
+  -> CExpr
+  -> [CodeGen ()]
+assignProd dstruct topIdent sumIdent =
+  fst $ runState (assignProd' dstruct topIdent sumIdent) cNameStream
+
+assignProd'
+  :: (ABT Term abt)
+  => DatumStruct xs (abt '[]) c
+  -> CExpr
+  -> CExpr
+  -> State [String] [CodeGen ()]
+assignProd' Done _ _ = return []
+assignProd' (Et (Konst d) rest) topIdent (CVar sumIdent) =
+  do names <- get
+     put (tail names)
+     let varName  = CMember (CMember (CMember topIdent
+                                              (Ident "sum")
+                                              True)
+                                     sumIdent
+                                     True)
+                            (Ident (head names))
+                            True
+     rest' <- assignProd' rest topIdent (CVar sumIdent)
+     return $ [flattenABT d varName] ++ rest'
+
+assignProd' _ _ _  = error $ "TODO: assignProd Ident"
+
+
+----------
+-- Case --
+----------
+
+-- currently we can only match on boolean values
+flattenCase
+  :: forall abt a b
+  .  (ABT Term abt)
+  => abt '[] a
+  -> [Branch a abt b]
+  -> (CExpr -> CodeGen ())
+
+flattenCase c [ Branch (PDatum _ (PInl PDone))        trueB
+              , Branch (PDatum _ (PInr (PInl PDone))) falseB ] =
+  \loc ->
+    do cE <- flattenWithName c
+       ifCG ((cE ... "index") .==. (intE 0))
+            (flattenABT trueB  loc)
+            (flattenABT falseB loc)
+
+flattenCase e [ Branch (PDatum _ (PInl (PEt (PKonst PVar)
+                                            (PEt (PKonst PVar)
+                                                 PDone)))) b
+              ]
+  = \loc -> do
+    eE <- flattenWithName e
+    caseBind b $ \vfst@(Variable _ _ fstTyp) b' ->
+      caseBind b' $ \vsnd@(Variable _ _ sndTyp) b'' -> do
+        fstId <- createIdent vfst
+        sndId <- createIdent vsnd
+        declare fstTyp fstId
+        declare sndTyp sndId
+        putExprStat $ (CVar fstId) .=. (datumFst eE)
+        putExprStat $ (CVar sndId) .=. (datumSnd eE)
+        flattenABT b'' loc
+
+flattenCase e _ = error $ "TODO: flattenCase{" ++ show (typeOf e) ++ "}"
+
+
+--------------------------------------------------------------------------------
+--                                     PrimOp                                 --
+--------------------------------------------------------------------------------
+
+flattenPrimOp
+  :: ( ABT Term abt
+     , typs ~ UnLCs args
+     , args ~ LCs typs)
+  => PrimOp typs a
+  -> SArgs abt args
+  -> (CExpr -> CodeGen ())
+
+
+flattenPrimOp Pi =
+  \End ->
+    \loc -> let piE = log1pE ((CVar . Ident $ "M_PI") .-. (intE 1)) in
+      putExprStat (loc .=. piE)
+
+flattenPrimOp Not =
+  \(a :* End) ->
+    \loc ->
+      do aE <- flattenWithName a
+         bId <- genIdent
+         declare (typeOf a) bId
+         let bE = CVar bId
+         putExprStat $ datumIndex bE .=. (CCond (datumIndex aE .==. (intE 1))
+                                               (intE 0)
+                                               (intE 1))
+         putExprStat $ loc .=. bE
+
+flattenPrimOp RealPow =
+  \(base :* power :* End) ->
+    \loc ->
+      do baseE <- flattenWithName base
+         powerE <- flattenWithName power
+         let realPow = CCall (CVar . Ident $ "pow")
+                             [ expm1E baseE .+. (intE 1), powerE]
+         putExprStat $ loc .=. (log1pE (realPow .-. (intE 1)))
+
+flattenPrimOp (NatPow baseTyp) =
+  \(base :* power :* End) ->
+    \loc ->
+      let sBase = sing_HSemiring baseTyp in
+      do baseId <- genIdent
+         declare sBase baseId
+         let baseE = CVar baseId
+         flattenABT base baseE
+         powerE <- flattenWithName power
+         let powerOf x y = CCall (CVar . Ident $ "pow") [x,y]
+             value = case sBase of
+                       SProb -> log1pE $ (powerOf (expm1E baseE .+. (intE 1)) powerE)
+                                  .-. (intE 1)
+                       _     -> powerOf baseE powerE
+         putExprStat $ loc .=. value
+
+flattenPrimOp (NatRoot baseTyp) =
+  \(base :* root :* End) ->
+    \loc ->
+      let sBase = sing_HRadical baseTyp in
+      do baseId <- genIdent
+         declare sBase baseId
+         let baseE = CVar baseId
+         flattenABT base baseE
+         rootE <- flattenWithName root
+         let powerOf x y = CCall (CVar . Ident $ "pow") [x,y]
+             recipE = (floatE 1) ./. rootE
+             value = case sBase of
+                       SProb -> log1pE $ (powerOf (expm1E baseE .+. (intE 1)) recipE)
+                                      .-. (intE 1)
+                       _     -> powerOf baseE recipE
+         putExprStat $ loc .=. value
+
+flattenPrimOp (Recip t) =
+  \(a :* End) ->
+    \loc ->
+      do aE <- flattenWithName a
+         case t of
+           HFractional_Real -> putExprStat $ loc .=. ((intE 1) ./. aE)
+           HFractional_Prob -> putExprStat $ loc .=. (CUnary CMinOp aE)
+
+-- | exp : real -> prob, because of this we can just turn it into a prob without taking
+--   its log, which would give us an exp in the log-domain
+flattenPrimOp Exp = \(a :* End) -> flattenABT a
+
+flattenPrimOp (Equal _) =
+  \(a :* b :* End) ->
+    \loc ->
+      do aE <- flattenWithName a
+         bE <- flattenWithName b
+
+         -- special case for booleans
+         let aE' = case (typeOf a) of
+                     (SData _ (SPlus SDone (SPlus SDone SVoid))) -> (CMember aE (Ident "index") True)
+                     _ -> aE
+         let bE' = case (typeOf b) of
+                     (SData _ (SPlus SDone (SPlus SDone SVoid))) -> (CMember bE (Ident "index") True)
+                     _ -> bE
+
+         putExprStat $   (CMember loc (Ident "index") True)
+                     .=. (CCond (aE' .==. bE') (intE 0) (intE 1))
+
+
+flattenPrimOp (Less _) =
+  \(a :* b :* End) ->
+    \loc ->
+      do aE <- flattenWithName a
+         bE <- flattenWithName b
+         putExprStat $ (CMember loc (Ident "index") True)
+                     .=. (CCond (aE .<. bE) (intE 0) (intE 1))
+
+flattenPrimOp (Negate _) =
+ \(a :* End) ->
+   \loc ->
+     do aE <- flattenWithName a
+        putExprStat $ loc .=. (CUnary CMinOp $ aE)
+
+flattenPrimOp Choose = \(_ :* _ :* End) -> error $ "TODO: flattenPrimOp: choose"
+
+flattenPrimOp t  = \_ -> error $ "TODO: flattenPrimOp: " ++ show t
+
+
+--------------------------------------------------------------------------------
+--                           MeasureOps and Superpose                         --
+--------------------------------------------------------------------------------
+
+{-
+
+The sections contains operations in the stochastic monad. See also
+(Dirac, MBind, and Plate) found in SCon. Also see Reject found at the top level.
+
+Remember in the C runtime. Measures are housed in a measure function, which
+takes an `struct mdata` location. The MeasureOp attempts to store a value at
+that location and returns 0 if it fails and 1 if it succeeds in that task.
+
+The functions uniformCG, normalCG, and gammaCG are primitives that will generate
+functions and call them (similar to logSumExpCG). The reduce code size and make
+samplers a little more readable.
+
+TODO: add inline pragmas to uniformCG, normalCG, and gammaCG
+-}
+
+uniformFun :: CFunDef
+uniformFun = CFunDef (CTypeSpec <$> retTyp)
+                     (CDeclr Nothing (CDDeclrIdent funcId))
+                     [typeDeclaration SReal loId
+                     ,typeDeclaration SReal hiId]
+                     (CCompound . concat
+                     $ [ CBlockDecl <$> [declMD]
+                       , CBlockStat <$> comment ++ [assW,assS,CReturn . Just $ mE]]
+                     )
+  where r          = castTo [CDouble] randE
+        rMax       = castTo [CDouble] (CVar . Ident $ "RAND_MAX")
+        retTyp     = buildType (SMeasure SReal)
+        (mId,mE)   = let ident = Ident "mdata" in (ident,CVar ident)
+        (loId,loE) = let ident = Ident "lo" in (ident,CVar ident)
+        (hiId,hiE) = let ident = Ident "hi" in (ident,CVar ident)
+        value      = (loE .+. ((r ./. rMax) .*. (hiE .-. loE)))
+        comment = fmap CComment
+          ["uniform :: real -> real -> *(mdata real) -> ()"
+          ,"------------------------------------------------"]
+        declMD     = buildDeclaration (head retTyp) mId
+        assW       = CExpr . Just $ mdataWeight mE .=. (floatE 0)
+        assS       = CExpr . Just $ mdataSample mE .=. value
+        funcId     = Ident "uniform"
+
+
+uniformCG :: CExpr -> CExpr -> (CExpr -> CodeGen ())
+uniformCG aE bE =
+  \loc -> do
+    uId <- reserveIdent "uniform"
+    extDeclareTypes (SMeasure SReal)
+    extDeclare . CFunDefExt $ uniformFun
+    putExprStat $ loc .=. CCall (CVar uId) [aE,bE]
+
+
+{-
+  This is very cryptic, but I assure you it is only building an AST for the
+  Marsaglia Polar Method
+-}
+
+normalFun :: CFunDef
+normalFun = CFunDef (CTypeSpec <$> retTyp)
+                    (CDeclr Nothing (CDDeclrIdent (Ident "normal")))
+                    [typeDeclaration SReal aId
+                    ,typeDeclaration SProb bId ]
+                    ( CCompound . concat
+                    $ [[CBlockDecl declMD],comment,decls,stmts])
+
+  where r      = castTo [CDouble] randE
+        rMax   = castTo [CDouble] (CVar . Ident $ "RAND_MAX")
+        retTyp = buildType (SMeasure SReal)
+        (aId,aE) = let ident = Ident "a" in (ident,CVar ident)
+        (bId,bE) = let ident = Ident "b" in (ident,CVar ident)
+        (qId,qE) = let ident = Ident "q" in (ident,CVar ident)
+        (uId,uE) = let ident = Ident "u" in (ident,CVar ident)
+        (vId,vE) = let ident = Ident "v" in (ident,CVar ident)
+        (rId,rE) = let ident = Ident "r" in (ident,CVar ident)
+        (mId,mE) = let ident = Ident "mdata" in (ident,CVar ident)
+        declMD     = buildDeclaration (head retTyp) mId
+        draw xE = CExpr . Just $ xE .=. (((r ./. rMax) .*. (floatE 2)) .-. (floatE 1))
+        body = seqCStat [draw uE
+                        ,draw vE
+                        ,CExpr . Just $ qE .=. ((uE .*. uE) .+. (vE .*. vE))]
+        polar = CWhile (qE .>. (floatE 1)) body True
+        setR  = CExpr . Just $ rE .=. (sqrtE (((CUnary CMinOp (floatE 2)) .*. logE qE) ./. qE))
+        finalValue = aE .+. (uE .*. rE .*. bE)
+        comment = fmap (CBlockStat . CComment)
+          ["normal :: real -> real -> *(mdata real) -> ()"
+          ,"Marsaglia Polar Method"
+          ,"-----------------------------------------------"]
+        decls = (CBlockDecl . typeDeclaration SReal) <$> [uId,vId,qId,rId]
+        stmts = CBlockStat <$> [polar,setR, assW, assS,CReturn . Just $ mE]
+        assW = CExpr . Just $ mdataWeight mE .=. (floatE 0)
+        assS = CExpr . Just $ mdataSample mE .=. finalValue
+
+
+normalCG :: CExpr -> CExpr -> (CExpr -> CodeGen ())
+normalCG aE bE =
+  \loc -> do
+    nId <- reserveIdent "normal"
+    extDeclareTypes (SMeasure SReal)
+    extDeclare . CFunDefExt $ normalFun
+    putExprStat $ loc .=. (CCall (CVar nId) [aE,bE])
+
+{-
+  This method is from Marsaglia and Tsang "a simple method for generating gamma variables"
+-}
+gammaFun :: CFunDef
+gammaFun = CFunDef (CTypeSpec <$> retTyp)
+                   (CDeclr Nothing (CDDeclrIdent (Ident "gamma")))
+                   [typeDeclaration SProb aId
+                   ,typeDeclaration SProb bId]
+                    ( CCompound . concat
+                    $ [[CBlockDecl declMD],comment,decls,stmts])
+  where (aId,aE) = let ident = Ident "a" in (ident,CVar ident)
+        (bId,bE) = let ident = Ident "b" in (ident,CVar ident)
+        (cId,cE) = let ident = Ident "c" in (ident,CVar ident)
+        (dId,dE) = let ident = Ident "d" in (ident,CVar ident)
+        (xId,xE) = let ident = Ident "x" in (ident,CVar ident)
+        (vId,vE) = let ident = Ident "v" in (ident,CVar ident)
+        (uId,uE) = let ident = Ident "u" in (ident,CVar ident)
+        (mId,mE) = let ident = Ident "mdata" in (ident,CVar ident)
+        retTyp = buildType (SMeasure SProb)
+        declMD     = buildDeclaration (head retTyp) mId
+        comment = fmap (CBlockStat . CComment)
+          ["gamma :: real -> prob -> *(mdata prob) -> ()"
+          ,"Marsaglia and Tsang 'a simple method for generating gamma variables'"
+          ,"--------------------------------------------------------------------"]
+        decls = fmap CBlockDecl $ (fmap (typeDeclaration SReal) [dId,cId,vId])
+                               ++ (fmap (typeDeclaration (SMeasure SReal)) [uId,xId])
+        stmts = fmap CBlockStat $ [assD,assC,outerWhile]
+        xS = mdataSample xE
+        uS = mdataSample uE
+        assD = CExpr . Just $ dE .=. (aE .-. ((floatE 1) ./. (floatE 3)))
+        assC = CExpr . Just $ cE .=. ((floatE 1) ./. (sqrtE ((floatE 9) .*. dE)))
+        outerWhile = CWhile (intE 1) (seqCStat [innerWhile,assV,assU,exit]) False
+        innerWhile = CWhile (vE .<=. (floatE 0)) (seqCStat [assX,assVIn]) True
+        assX = CExpr . Just $ xE .=. (CCall (CVar . Ident $ "normal") [(floatE 0),(floatE 1)])
+        assVIn = CExpr . Just $ vE .=. ((floatE 1) .+. (cE .*. xS))
+        assV = CExpr . Just $ vE .=. (vE .*. vE .*. vE)
+        assU = CExpr . Just $ uE .=. (CCall (CVar . Ident $ "uniform") [(floatE 0),(floatE 1)])
+        exitC1 = uS .<. ((floatE 1) .-. ((floatE 0.331 .*. (xS .*. xS) .*. (xS .*. xS))))
+        exitC2 = (logE uS) .<. (((floatE 0.5) .*. (xS .*. xS)) .+. (dE .*. ((floatE 1.0) .-. vE .+. (logE vE))))
+        assW = CExpr . Just $ mdataWeight mE .=. (floatE 0)
+        assS = CExpr . Just $ mdataSample mE .=. (logE (dE .*. vE)) .+. bE
+        exit = CIf (exitC1 .||. exitC2) (seqCStat [assW,assS,CReturn . Just $ mE]) Nothing
+
+
+gammaCG :: CExpr -> CExpr -> (CExpr -> CodeGen ())
+gammaCG aE bE =
+  \loc -> do
+     extDeclareTypes (SMeasure SReal)
+     reserveIdent "uniform"
+     reserveIdent "normal"
+     gId <- reserveIdent "gamma"
+     mapM_ (extDeclare . CFunDefExt) [uniformFun,normalFun,gammaFun]
+     putExprStat $ loc .=. (CCall (CVar gId) [aE,bE])
+
+
+flattenMeasureOp
+  :: forall abt typs args a .
+     ( ABT Term abt
+     , typs ~ UnLCs args
+     , args ~ LCs typs )
+  => MeasureOp typs a
+  -> SArgs abt args
+  -> (CExpr -> CodeGen ())
+
+
+flattenMeasureOp Uniform =
+  \(a :* b :* End) ->
+    \loc ->
+      do aE <- flattenWithName a
+         bE <- flattenWithName b
+         uniformCG aE bE loc
+
+
+flattenMeasureOp Normal  =
+  \(a :* b :* End) ->
+    \loc ->
+      do aE <- flattenWithName a
+         bE <- flattenWithName b
+         normalCG aE (expE bE) loc
+
+flattenMeasureOp Poisson =
+  \(lam :* End) ->
+    \loc ->
+      do lamE <- flattenWithName lam
+         lId <- genIdent' "l"
+         kId <- genIdent' "k"
+         pId <- genIdent' "p"
+         declare SProb lId
+         declare SNat  kId
+         declare SProb pId
+         let (lE:kE:pE:[]) = fmap CVar [lId,kId,pId]
+         putExprStat $ lE .=. (expE (CUnary CMinOp $ expE lamE))
+         putExprStat $ kE .=. (intE 0)
+         putExprStat $ pE .=. (floatE 1)
+         doWhileCG (pE .>. lE) $
+           do uId <- genIdent' "u"
+              declare (SMeasure SReal) uId
+              let uE = CVar uId
+              uniformCG (intE 0) (intE 1) uE
+              putExprStat $ pE .*=. (mdataSample uE)
+              putExprStat $ kE .+=. (intE 1)
+
+         putExprStat $ mdataWeight loc .=. (intE 0)
+         putExprStat $ mdataSample loc .=. (kE .-. (intE 1))
+
+flattenMeasureOp Gamma =
+  \(a :* b :* End) ->
+    \loc ->
+      do aE <- flattenWithName a
+         bE <- flattenWithName b
+         gammaCG (expE aE) bE loc
+
+
+flattenMeasureOp Beta =
+  \(a :* b :* End) -> flattenABT (HKP.beta'' a b)
+
+
+-- I ran into a bug here where sometime I recieved a location by reference and
+-- others by value. Since measureOps assign a sample to mdata that they have a
+-- reference to, we should enforce that when passing around mdata it is by
+-- reference
+flattenMeasureOp Categorical = \(arr :* End) ->
+  \loc ->
+    do arrE <- flattenWithName arr
+
+       itId <- genIdent' "it"
+       declare SNat itId
+       let itE = CVar itId
+
+       -- Accumulator for the total probability of the input array
+       wSumId <- genIdent' "ws"
+       declare SProb wSumId
+       let wSumE = CVar wSumId
+       assign wSumId (logE (intE 0))
+
+       -- Accumulator for the max value in the input array
+       wMaxId <- genIdent' "max"
+       declare SProb wMaxId
+       let wMaxE = CVar wMaxId
+       assign wMaxId (logE (floatE 0))
+
+       let currE = index (arrayData arrE) itE
+
+       seqDo $ do
+         -- Calculate the maximum value of the input array
+         -- And calculate the total weight
+         forCG (itE .=. (intE 0))
+               (itE .<. (arraySize arrE))
+               (CUnary CPostIncOp itE) $ do
+           ifCG (wMaxE .<. currE)
+                (putExprStat $ wMaxE .=. currE)
+                (return ())
+           logSumExpCG (S.fromList [wSumE, currE]) wSumE
+         putExprStat $ wSumE .=. (wSumE .-. wMaxE)
+
+         -- draw number from uniform(0, weightSum)
+         rId <- genIdent' "r"
+         declare SReal rId
+         let r    = castTo [CDouble] randE
+             rMax = castTo [CDouble] (CVar . Ident $ "RAND_MAX")
+             rE = CVar rId
+         assign rId (logE (r ./. rMax) .+. wSumE)
+
+         assign wSumId (logE (intE 0))
+         assign itId (intE 0)
+         whileCG (intE 1) $
+           do ifCG (rE .<. wSumE)
+                   (do putExprStat $ mdataWeight loc .=. (intE 0)
+                       putExprStat $ mdataSample loc .=. (itE .-. (intE 1))
+                       putStat CBreak)
+                   (return ())
+              logSumExpCG (S.fromList [wSumE, currE .-. wMaxE]) wSumE
+              putExprStat $ CUnary CPostIncOp itE
+
+
+flattenMeasureOp x = error $ "TODO: flattenMeasureOp: " ++ show x
+
+---------------
+-- Superpose --
+---------------
+
+flattenSuperpose
+    :: (ABT Term abt)
+    => NE.NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
+    -> (CExpr -> CodeGen ())
+
+-- do we need to normalize?
+flattenSuperpose pairs =
+  let pairs' = NE.toList pairs in
+
+  if length pairs' == 1
+  then \loc -> let (w,m) = head pairs' in
+         do mE <- flattenWithName m
+            wE <- flattenWithName w
+            putExprStat $ mdataWeight loc .=. ((mdataWeight mE) .+. wE)
+            putExprStat $ mdataSample loc .=. (mdataSample mE)
+
+  else \loc ->
+         do wEs <- mapM (\(w,_) -> flattenWithName' w "w") pairs'
+
+            wSumId <- genIdent' "ws"
+            declare SProb wSumId
+            let wSumE = CVar wSumId
+            logSumExpCG (S.fromList wEs) wSumE
+
+            -- draw number from uniform(0, weightSum)
+            rId <- genIdent' "r"
+            declare SReal rId
+            let r    = castTo [CDouble] randE
+                rMax = castTo [CDouble] (CVar . Ident $ "RAND_MAX")
+                rE = CVar rId
+            assign rId ((r ./. rMax) .*. (expE wSumE))
+
+            -- an iterator for picking a measure
+            itId <- genIdent' "it"
+            declare SProb itId
+            let itE = CVar itId
+            assign itId (logE (intE 0))
+
+            -- an output measure to assign to
+            outId <- genIdent' "out"
+            declare (typeOf . snd . head $ pairs') outId
+            let outE = CVar outId
+
+            outLabel <- genIdent' "exit"
+
+            forM_ (zip wEs pairs')
+              $ \(wE,(_,m)) ->
+                  do logSumExpCG (S.fromList [itE,wE]) itE
+                     ifCG (rE .<. (expE itE))
+                          (flattenABT m outE >> putStat (CGoto outLabel))
+                          (return ())
+
+            putStat $ CLabel outLabel (CExpr Nothing)
+            putExprStat $ mdataWeight loc .=. ((mdataWeight outE) .+. wSumE)
+            putExprStat $ mdataSample loc .=. (mdataSample outE)
+
+--------------------------------------------------------------------------------
+--                           Specialized Arithmetic                           --
+--------------------------------------------------------------------------------
+
+--------------------------------------
+-- LogSumExp for NaryOp Add [SProb] --
+--------------------------------------
+{-
+
+Special for addition of probabilities we have a logSumExp. This will compute the
+sum of the probabilities safely. Just adding the exp(a . prob) would make us
+loose any of the safety from underflow that we got from storing prob in the log
+domain
+
+-}
+
+-- the tree traversal is a depth first search
+logSumExp :: S.Seq CExpr -> CExpr
+logSumExp es = mkCompTree 0 1
+
+  where lastIndex  = S.length es - 1
+
+        compIndices :: Int -> Int -> CExpr -> CExpr -> CExpr
+        compIndices i j = CCond ((S.index es i) .>. (S.index es j))
+
+        mkCompTree :: Int -> Int -> CExpr
+        mkCompTree i j
+          | j == lastIndex = compIndices i j (logSumExp' i) (logSumExp' j)
+          | otherwise      = compIndices i j
+                               (mkCompTree i (succ j))
+                               (mkCompTree j (succ j))
+
+        diffExp :: Int -> Int -> CExpr
+        diffExp a b = expm1E ((S.index es a) .-. (S.index es b))
+
+        -- given the max index, produce a logSumExp expression
+        logSumExp' :: Int -> CExpr
+        logSumExp' 0 = S.index es 0
+          .+. (log1pE $ foldr (\x acc -> diffExp x 0 .+. acc)
+                            (diffExp 1 0)
+                            [2..S.length es - 1]
+                    .+. (intE $ fromIntegral lastIndex))
+        logSumExp' i = S.index es i
+          .+. (log1pE $ foldr (\x acc -> if i == x
+                                       then acc
+                                       else diffExp x i .+. acc)
+                            (diffExp 0 i)
+                            [1..S.length es - 1]
+                    .+. (intE $ fromIntegral lastIndex))
+
+
+-- | logSumExpCG creates global functions for every n-ary logSumExp function
+-- this reduces code size
+logSumExpCG :: S.Seq CExpr -> (CExpr -> CodeGen ())
+logSumExpCG seqE =
+  let size   = S.length $ seqE
+      name   = "logSumExp" ++ (show size)
+      funcId = Ident name
+  in \loc -> do -- reset the names so that the function is the same for each arity
+       let argIds = fmap Ident (take size cNameStream)
+           decls  = fmap (typeDeclaration SProb) argIds
+           vars   = fmap CVar argIds
+       funCG [CDouble] funcId decls
+         (putStat . CReturn . Just . logSumExp . S.fromList $ vars)
+       putExprStat $ loc .=. (CCall (CVar funcId) (F.toList seqE))
+
+-------------------------------------
+-- LogSumExp for Summation of Prob --
+-------------------------------------
+{-
+For summation of SProb we need a new logSumExp function that will find the max
+of an array and then sum it in a loop
+-}
+
+lseSummateArrayCG
+  :: ( ABT Term abt )
+  => (abt '[ a ] b)
+  -> CExpr
+  -> (CExpr -> CodeGen ())
+lseSummateArrayCG body arrayE =
+  caseBind body $ \v body' ->
+    \loc -> seqDo $ do
+      maxVId <- genIdent' "maxV"
+      maxIId <- genIdent' "maxI"
+      sumId <- genIdent' "sum"
+      itId <- createIdent v
+      mapM_ (declare SProb) [maxVId,sumId]
+      mapM_ (declare SNat)  [maxIId,itId]
+      let (maxVE:maxIE:sumE:itE:[]) = fmap CVar [maxVId,maxIId,sumId,itId]
+      forCG (itE .=. intE 0)
+            (itE .<. arraySize arrayE)
+            (CUnary CPostIncOp itE)
+            (do tmpId <- genIdent
+                declare SProb tmpId
+                let tmpE = CVar tmpId
+                flattenABT body' tmpE
+                putExprStat $ derefIndex itE .=. tmpE
+                putStat $ CIf ((maxVE .<. tmpE) .||. (itE .==. (intE 0)))
+                              (seqCStat . fmap (CExpr . Just) $
+                                [ maxVE .=. tmpE
+                                , maxIE .=. itE ])
+                              Nothing)
+      putExprStat $ sumE  .=. (floatE 0) -- the sum is actually in real space
+      forCG (itE .=. intE 0)
+            (itE .<. arraySize arrayE)
+            (CUnary CPostIncOp itE)
+            (ifCG (itE .!=. maxIE)
+                  (putExprStat $ sumE .+=. (expE ((derefIndex itE) .-. (maxVE))))
+                  (return ()))
+
+      putExprStat $ loc .=. (maxVE .+. (log1pE sumE))
+
+  where derefIndex xE = index (arrayData arrayE) xE
+
+---------------------
+-- Kahan Summation --
+---------------------
+-- | given a body and a size compute the kahan summation. This should work on
+--   both probs and reals
+kahanSummationCG
+  :: ( ABT Term abt )
+  => (abt '[ a ] b)
+  -> CExpr
+  -> CExpr
+  -> (CExpr -> CodeGen ())
+kahanSummationCG body loE hiE =
+  caseBind body $ \v body' ->
+    \loc -> do
+      tId <- genIdent' "t"
+      cId <- genIdent' "c"
+      itId <- createIdent v
+      declare SNat itId
+      mapM_ (declare SProb) [tId,cId]
+      let (tE:cE:itE:[]) = fmap CVar [tId,cId,itId]
+      putExprStat $ tE .=. (floatE 0)
+      putExprStat $ cE .=. (floatE 0)
+      forCG (itE .=. loE)
+            (itE .<. hiE)
+            (CUnary CPostIncOp itE)
+            (do xId <- genIdent' "x"
+                yId <- genIdent' "y"
+                zId <- genIdent' "z"
+                mapM_ (declare SProb) [xId,yId,zId]
+                let (xE:yE:zE:[]) = fmap CVar [xId,yId,zId]
+                flattenABT body' xE
+                putExprStat $ yE .=. (xE .-. cE)
+                putExprStat $ zE .=. (tE .+. yE)
+                whenPar $ putStat . CPPStat . ompToPP $ OMP Critical
+                codeBlockCG $ do
+                  putExprStat $ cE .=.  ((zE .-. tE) .-. yE)
+                  putExprStat $ tE .=. zE)
+      putExprStat $ loc .=. tE
+
+--------------------------------------------------------------------------------
+--                            Coercion Helpers                                --
+--------------------------------------------------------------------------------
+
+coerceToCG
+  :: forall (a :: Hakaru) (b :: Hakaru)
+  .  Coercion a b
+  -> CExpr
+  -> CodeGen CExpr
+coerceToCG (CCons (Signed HRing_Int)            cs) e = nat2int e   >>= coerceToCG cs
+coerceToCG (CCons (Signed HRing_Real)           cs) e = prob2real e >>= coerceToCG cs
+coerceToCG (CCons (Continuous HContinuous_Prob) cs) e = nat2prob e  >>= coerceToCG cs
+coerceToCG (CCons (Continuous HContinuous_Real) cs) e = int2real e  >>= coerceToCG cs
+coerceToCG CNil e = return e
+
+coerceFromCG
+  :: forall (a :: Hakaru) (b :: Hakaru)
+  .  Coercion a b
+  -> CExpr
+  -> CodeGen CExpr
+coerceFromCG (CCons (Signed HRing_Int)            cs) e = int2nat e   >>= coerceFromCG cs
+coerceFromCG (CCons (Signed HRing_Real)           cs) e = real2prob e >>= coerceFromCG cs
+coerceFromCG (CCons (Continuous HContinuous_Prob) cs) e = prob2nat e  >>= coerceFromCG cs
+coerceFromCG (CCons (Continuous HContinuous_Real) cs) e = real2int e  >>= coerceFromCG cs
+coerceFromCG CNil e = return e
+
+-- safe
+nat2int,nat2prob,prob2real,int2real
+  :: CExpr -> CodeGen CExpr
+nat2int   x = return x
+nat2prob  x = do x' <- localVar' SProb "n2p"
+                 putExprStat $ x' .=. (logE x)
+                 return x'
+prob2real x = do x' <- localVar' SProb "p2r"
+                 putExprStat $ x' .=. ((expm1E x) .+. (floatE 1))
+                 return x'
+int2real  x = return (castTo [CDouble] x)
+
+-- unsafe
+{- Because of the hkc representation of reals and probs as doubles, (instead of
+   rationals). we will just silently truncate values for prob2nat and real2int
+-}
+int2nat,prob2nat,real2prob,real2int
+  :: CExpr -> CodeGen CExpr
+int2nat x =
+  do x' <- localVar' SNat "i2n"
+     ifCG (x .<. (intE 0))
+          (do putExprStat $ printfE [ stringE "error: cannot coerce negative int to nat\n" ]
+              putExprStat $ mkCallE "abort" [] )
+          (putExprStat $ x' .=. (castTo [CUnsigned, CInt] x))
+     return x'
+prob2nat x = return (castTo [CUnsigned, CInt] x)
+real2prob x =
+  do x' <- localVar' SProb "r2p"
+     ifCG (x .<. (intE 0))
+          (do putExprStat $ printfE [ stringE "error: cannot coerce negative real to prob\n" ]
+              putExprStat $ mkCallE "abort" [] )
+          (putExprStat $ x' .=. (logE x))
+     return x'
+real2int x =  return (castTo [CInt] x)
+
+--------------------------------------------------------------------------------
+--                            Parallel Helpers                                --
+--------------------------------------------------------------------------------
+{- SIMD (single instruction multiple data) OpenMP pragmas, should be applied to
+-- the inner most loop. `hasParallelTerm` checks whether a term or any of its
+-- subterms contain a parallel construct { plate, summate, product, array,
+-- bucket }.
+-}
+
+hasParallelTerm :: ( ABT Term abt ) => abt '[] a -> Bool
+hasParallelTerm abt = caseVarSyn abt (const False) hPT'
+  where hPT' :: ABT Term abt => Term abt a -> Bool
+        hPT' (_ :$ _)          = undefined
+        hPT' (NaryOp_ _ _)     = undefined
+        hPT' (Literal_ _)      = False
+        hPT' (Empty_ _)        = False
+        hPT' (Array_ _ _)      = True
+        hPT' (ArrayLiteral_ _) = False
+        hPT' (Bucket _ _ _)    = True
+        hPT' (Datum_ _)        = False
+        hPT' (Case_ _ _)       = undefined
+        hPT' (Superpose_ _)    = undefined
+        hPT' (Reject_ _)       = False
diff --git a/haskell/Language/Hakaru/CodeGen/Libs.hs b/haskell/Language/Hakaru/CodeGen/Libs.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/CodeGen/Libs.hs
@@ -0,0 +1,173 @@
+----------------------------------------------------------------
+--                                                    2016.12.20
+-- |
+-- Module      :  Language.Hakaru.CodeGen.Libraries
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  zsulliva@indiana.edu
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Bindings to common C libraries
+--
+----------------------------------------------------------------
+
+module Language.Hakaru.CodeGen.Libs
+  ( -- math.h
+    expE, expm1E, logE, log1pE, sqrtE,
+    infinityE,negInfinityE,
+
+    -- stdio.h
+    printfE, sscanfE, fopenE, fcloseE, fileT, feofE, fgetsE, rewindE,
+
+    -- stdlib.h
+    randE, srandE, mallocE, freeE,
+
+    -- Boehm Gargbage Collector
+    gcHeader, gcInit, gcMalloc,
+
+    -- OpenMP
+    openMpHeader, ompGetNumThreads, ompGetThreadNum, OMP(..), Directive(..),
+    ompToPP
+  ) where
+
+import Language.Hakaru.CodeGen.AST
+import Language.Hakaru.CodeGen.Pretty
+import Text.PrettyPrint (render)
+
+{-
+
+  As a convention to make the CExpressions standout, functions that return CExpr
+  have a suffix 'E' for instance 'printfE'
+
+-}
+
+
+--------------------------------------------------------------------------------
+--                                 Lib C                                      --
+--------------------------------------------------------------------------------
+{-
+  Here we have calls to a very small subset of functionality provided by libc.
+  In the future, we should have a standard way to add in bindings to C
+  libraries. Easily generating code for existing C libraries is one of the key
+  design goals of pedantic-c
+-}
+
+------------
+-- math.h --
+------------
+
+expE,expm1E,logE,log1pE,sqrtE :: CExpr -> CExpr
+expE   = mkUnaryE "exp"
+expm1E = mkUnaryE "expm1"
+logE   = mkUnaryE "log"
+log1pE = mkUnaryE "log1p"
+sqrtE  = mkUnaryE "sqrt"
+
+infinityE,negInfinityE :: CExpr
+infinityE    = (intE 1) ./. (intE 0)
+negInfinityE = logE (intE 0)
+
+--------------
+-- stdlib.h --
+--------------
+
+randE :: CExpr
+randE = mkCallE "rand" []
+
+srandE :: CExpr -> CExpr
+srandE e = mkCallE "srand" [e]
+
+mallocE :: CExpr -> CExpr
+mallocE = mkUnaryE "malloc"
+
+freeE :: CExpr -> CExpr
+freeE = mkUnaryE "free"
+
+--------------
+-- stdio.h --
+--------------
+
+printfE,sscanfE :: [CExpr] -> CExpr
+printfE = mkCallE "printf"
+sscanfE = mkCallE "sscanf"
+
+fopenE :: CExpr -> CExpr -> CExpr
+fopenE e0 e1 = mkCallE "fopen" [e0,e1]
+
+fcloseE,feofE,rewindE :: CExpr -> CExpr
+fcloseE e = mkCallE "fclose" [e]
+feofE e = mkCallE "feof" [e]
+rewindE e = mkCallE "rewind" [e]
+
+fgetsE :: CExpr -> CExpr -> CExpr -> CExpr
+fgetsE e0 e1 e2 = mkCallE "fgets" [e0,e1,e2]
+
+fileT :: CTypeSpec
+fileT = CTypeDefType (Ident "FILE")
+
+--------------------------------------------------------------------------------
+--                            Boehm Garbage Collector                         --
+--------------------------------------------------------------------------------
+{-
+   Currently needed for handling arrays and datum.
+
+   In the future, an intermediate language based on the region calculus will be
+   employed here.
+-}
+
+gcHeader :: Preprocessor
+gcHeader = PPInclude "gc.h"
+
+gcInit :: CExpr
+gcInit = mkCallE "GC_INIT" []
+
+gcMalloc :: CExpr -> CExpr
+gcMalloc e = mkCallE "GC_MALLOC" [e]
+
+--------------------------------------------------------------------------------
+--                                  OpenMP                                    --
+--------------------------------------------------------------------------------
+{-
+   For generating pragmas for shared memory parallelism, that is parallelism on
+   on a single process that makes use of multithreaded processors. This
+   interface is implemented in most C compilers and is accessed through pragmas
+
+   This is a subset of the the OpenMP 4.5 standard.
+-}
+
+openMpHeader :: Preprocessor
+openMpHeader = PPInclude "omp.h"
+
+ompGetNumThreads :: CExpr
+ompGetNumThreads = mkCallE "omp_get_num_threads" []
+
+ompGetThreadNum :: CExpr
+ompGetThreadNum = mkCallE "omp_get_thread_num" []
+
+data OMP = OMP Directive
+
+data Directive
+  = Parallel [Directive]
+  | For
+  | Critical
+  | Reduction (Either CBinaryOp Ident) [CExpr]
+  | DeclareRed Ident CTypeSpec CExpr CExpr
+
+ompToPP :: OMP -> Preprocessor
+ompToPP (OMP d) = PPPragma $ "omp":(showDirective d)
+  where showDirective :: Directive -> [String]
+        showDirective (Parallel ds)      = "parallel":(concatMap showDirective ds)
+        showDirective For                = ["for"]
+        showDirective Critical           = ["critical"]
+        showDirective (Reduction eop vs) =
+          let op = case eop of
+                     Left binop -> render . pretty $ binop
+                     Right (Ident s) -> s
+          in  ["reduction(",op,":",unwords . fmap (render. pretty) $ vs,")"]
+        showDirective (DeclareRed (Ident name) typ mul unit) =
+          let typ'  = render . pretty $ typ
+              mul'  = render . pretty $ mul
+              unit' = render . pretty $ unit
+          in ["declare","reduction(",name,":",typ',":",mul',") initializer ("
+             ,unit',")"]
diff --git a/haskell/Language/Hakaru/CodeGen/Pretty.hs b/haskell/Language/Hakaru/CodeGen/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/CodeGen/Pretty.hs
@@ -0,0 +1,310 @@
+--------------------------------------------------------------------------------
+--                                                                  2016.09.08
+-- |
+-- Module      :  Language.Hakaru.CodeGen.Pretty
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  zsulliva@indiana.edu
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--   A pretty printer for the CodeGen AST
+--
+--------------------------------------------------------------------------------
+
+module Language.Hakaru.CodeGen.Pretty
+  ( pretty
+  , prettyPrint
+  , Pretty
+  ) where
+
+import Prelude hiding ((<>))
+import Text.PrettyPrint
+import Language.Hakaru.CodeGen.AST
+
+prettyPrint :: Pretty a => a -> String
+prettyPrint = render . pretty
+
+class Pretty a where
+  pretty :: a -> Doc
+  prettyPrec :: Int -> a -> Doc
+
+  pretty = prettyPrec 0
+  prettyPrec _ = pretty
+
+mpretty :: Pretty a => Maybe a -> Doc
+mpretty Nothing  = empty
+mpretty (Just x) = pretty x
+
+mPrettyPrec :: Pretty a => Int -> Maybe a -> Doc
+mPrettyPrec _ Nothing  = empty
+mPrettyPrec p (Just x) = prettyPrec p x
+
+-- will compare two precs and put parens if the prec is lower
+parensPrec :: Int -> Int -> Doc -> Doc
+parensPrec x y = if x <= y then parens else id
+
+emptyText :: Doc
+emptyText = text ""
+
+instance Pretty a => Pretty (Maybe a) where
+  pretty Nothing  = empty
+  pretty (Just x) = pretty x
+
+
+--------------------------------------------------------------------------------
+--                                  Top Level                                 --
+--------------------------------------------------------------------------------
+
+instance Pretty Ident where
+  pretty (Ident i) = text i
+
+instance Pretty CAST where
+  pretty (CAST extdecls) = vcat . fmap pretty $ extdecls
+
+instance Pretty CExtDecl where
+  pretty (CDeclExt d) = emptyText $+$ pretty d <> semi
+  pretty (CFunDefExt f) = emptyText $+$ pretty f
+  pretty (CCommentExt s) = text "/*" <+> text s <+> text "*/"
+  pretty (CPPExt p) = pretty p
+
+instance Pretty CFunDef where
+  pretty (CFunDef dspecs dr ds s) =
+    ((hsep . fmap pretty $ dspecs)
+     <+> pretty dr
+     <>  (parens . hsep . punctuate comma . fmap pretty $ ds))
+    $+$ (pretty s)
+
+--------------------------------------------------------------------------------
+--                               Preprocessor                                 --
+--------------------------------------------------------------------------------
+
+instance Pretty Preprocessor where
+  pretty (PPDefine n x) = hsep . fmap text $ ["#define",n,x]
+  pretty (PPInclude s) = text "#include" <+> text "<" <> text s <> text ">"
+  pretty (PPUndef s) = text "#undef" <+> text s
+  pretty (PPIf s) = text "#if" <+> text s
+  pretty (PPIfDef s) = text "#ifdef" <+> text s
+  pretty (PPIfNDef s) = text "#ifndef" <+> text s
+  pretty (PPElse s) = text "#else" <+> text s
+  pretty (PPElif s) = text "#elif" <+> text s
+  pretty (PPEndif s) = text "#endif" <+> text s
+  pretty (PPError s) = text "#error" <+> text s
+  pretty (PPPragma ts) = space $$ text "#pragma" <+> (hsep . fmap text $ ts)
+
+
+--------------------------------------------------------------------------------
+--                             CDeclarations                                  --
+--------------------------------------------------------------------------------
+
+instance Pretty CDecl where
+  pretty (CDecl ds ps) =
+    hsep [ hsep . fmap pretty $ ds
+         , hsep . punctuate comma . fmap declarators $ ps]
+    where declarators (dr, Nothing) = pretty dr
+          declarators (dr, Just ilist) = pretty dr <+> text "=" <+> pretty ilist
+
+instance Pretty CDeclr where
+  pretty (CDeclr mp dd) =
+    mpretty mp <+> (pretty $ dd)
+
+instance Pretty CPtrDeclr where
+  pretty (CPtrDeclr ts) = text "*" <+> (hsep . fmap pretty $ ts)
+
+instance Pretty CDirectDeclr where
+  pretty (CDDeclrIdent i) = pretty i
+  pretty (CDDeclrArr dd e) = pretty dd <+> (brackets . pretty $ e)
+  pretty (CDDeclrFun dd ts) =
+    pretty dd <> (parens . hsep . punctuate comma . fmap (hsep . fmap pretty) $ ts)
+  pretty (CDDeclrRec declr) = parens . pretty $ declr
+
+
+instance Pretty CDeclSpec where
+  pretty (CStorageSpec ss) = pretty ss
+  pretty (CTypeSpec ts) = pretty ts
+  pretty (CTypeQual tq) = pretty tq
+  pretty (CFunSpec _ ) = text "inline"  -- inline is the only CFunSpec
+
+instance Pretty CStorageSpec where
+  pretty CTypeDef = text "typedef"
+  pretty CExtern = text "extern"
+  pretty CStatic = text "static"
+  pretty CAuto = text "auto"
+  pretty CRegister = text "register"
+
+instance Pretty CTypeQual where
+  pretty CConstQual = text "const"
+  pretty CVolatQual = text "volatile"
+
+instance Pretty CTypeSpec where
+  pretty CVoid = text "void"
+  pretty CChar = text "char"
+  pretty CShort = text "short"
+  pretty CInt = text "int"
+  pretty CLong = text "long"
+  pretty CFloat = text "float"
+  pretty CDouble = text "double"
+  pretty CSigned = text "signed"
+  pretty CUnsigned = text "unsigned"
+  pretty (CSUType cs) = pretty cs
+  pretty (CTypeDefType sid) = pretty sid
+  pretty (CEnumType _) = error "TODO: Pretty EnumType"
+
+instance Pretty CTypeName where
+  pretty (CTypeName tspecs pb) =
+    let ss = sep . fmap pretty $ tspecs
+    in if pb
+       then ss <+> text "*"
+       else ss
+
+instance Pretty CSUSpec where
+  pretty (CSUSpec tag mi []) =
+    pretty tag <+> mpretty mi
+  pretty (CSUSpec tag mi ds) =
+    (pretty tag <+> pretty mi)
+    $+$ (   lbrace
+        $+$ (nest 2 . sep . fmap (\d -> pretty d <> semi) $ ds)
+        $+$ rbrace )
+
+instance Pretty CSUTag where
+  pretty CStructTag = text "struct"
+  pretty CUnionTag = text "union"
+
+instance Pretty CEnum where
+  pretty (CEnum _ _) = error "TODO: Pretty Enum"
+
+instance Pretty CInit where
+  pretty (CInitExpr _) = error "TODO: Pretty Init"
+  pretty (CInitList _) = error "TODO: Pretty Init list"
+
+instance Pretty CPartDesig where
+  pretty (CArrDesig _) = error "TODO: Pretty Arr Desig"
+  pretty (CMemberDesig _) = error "TODO: Pretty Memdesig"
+
+
+--------------------------------------------------------------------------------
+--                                CStatements                                 --
+--------------------------------------------------------------------------------
+
+instance Pretty CStat where
+  pretty (CLabel lId s) = pretty lId <> colon $$ nest 2 (pretty s)
+  pretty (CGoto lId) = text "goto" <+> pretty lId <> semi
+  pretty (CSwitch e s) = text "switch" <+> pretty e <+> (parens . pretty $ s )
+  pretty (CCase e s) = text "case" <+> pretty e <> colon $$ nest 2 (pretty s)
+  pretty (CDefault s) = text "default" <> colon $$ nest 2 (pretty s)
+  pretty (CExpr me) = mpretty me <> semi
+  pretty (CCompound bs) =
+    lbrace $+$ (nest 2 . vcat . fmap pretty $ bs) $+$ rbrace
+
+  pretty (CIf ce thns (Just elss)) =
+    text "if" <+> (parens . prettyPrec (-5) $ ce)
+              $+$ (pretty thns)
+              $+$ text "else"
+              $+$ (pretty elss)
+  pretty (CIf ce thns Nothing) =
+    text "if" <+> (parens . prettyPrec (-5) $ ce) $+$ (pretty thns)
+
+  pretty (CWhile ce s b) =
+    if b
+    then text "do" $+$ pretty s $+$ (text "while" <+> (parens $ pretty ce) <> semi)
+    else (text "while" <+> (parens $ pretty ce)) $+$ (pretty s)
+
+  pretty (CFor me mce mie s) =
+    text "for"
+    <+> (parens . hsep . punctuate semi . fmap (mPrettyPrec 10) $ [me,mce,mie])
+    $$  (pretty s)
+
+  pretty CCont = text "continue" <> semi
+  pretty CBreak = text "break" <> semi
+  pretty (CReturn me) = text "return" <+> mpretty me  <> semi
+  pretty (CComment s) = text "/*" <+> text s <+> text "*/"
+  pretty (CPPStat p) = pretty p
+
+instance Pretty CCompoundBlockItem where
+  pretty (CBlockStat s) = pretty s
+  pretty (CBlockDecl d) = pretty d <> semi
+
+
+--------------------------------------------------------------------------------
+--                                CExpressions                                --
+--------------------------------------------------------------------------------
+
+instance Pretty CExpr where
+  prettyPrec _ (CComma es) = hsep . punctuate comma . fmap pretty $ es
+  prettyPrec _ (CAssign op le re) = pretty le <+> pretty op <+> pretty re
+  prettyPrec _ (CCond ce thn els) = pretty ce <+> text "?" <+> pretty thn <+> colon <+> pretty els
+  prettyPrec p (CBinary op e1 e2) =
+    parensPrec p 0 . hsep $ [pretty e1, pretty op, pretty e2]
+  prettyPrec p (CCast d e) =
+    parensPrec p (2) $ parens (pretty d) <> pretty e
+  prettyPrec p (CUnary op e) =
+    if elem op [CPostIncOp,CPostDecOp]
+    then parensPrec p (-1) $ prettyPrec (-1) e <> pretty op
+    else parens $ pretty op <> prettyPrec (-1) e
+
+  prettyPrec _ (CSizeOfExpr e) = text "sizeof" <> (parens . pretty $ e)
+  prettyPrec _ (CSizeOfType d) = text "sizeof" <> (parens . pretty $ d)
+  prettyPrec _ (CIndex arrId ie) = pretty arrId <> (brackets . pretty $ ie)
+  prettyPrec _ (CCall fune es) =
+    pretty fune <> (parens . hcat . punctuate comma . fmap pretty $ es)
+  prettyPrec _ (CMember ve memId isPtr) =
+    let op = text $ if isPtr then "." else "->"
+    in  pretty ve <> op <> pretty memId
+  prettyPrec _ (CVar varId) = pretty varId
+  prettyPrec _ (CConstant c) = pretty c
+  prettyPrec _ (CCompoundLit d ini) = parens (pretty d) <> pretty ini
+
+
+instance Pretty CAssignOp where
+  pretty CAssignOp = text "="
+  pretty CMulAssOp = text "*="
+  pretty CDivAssOp = text "/="
+  pretty CRmdAssOp = text "%="
+  pretty CAddAssOp = text "+="
+  pretty CSubAssOp = text "-="
+  pretty CShlAssOp = text "<<="
+  pretty CShrAssOp = text ">>="
+  pretty CAndAssOp = text "&="
+  pretty CXorAssOp = text "^="
+  pretty COrAssOp  = text "|="
+
+
+instance Pretty CBinaryOp where
+  pretty CMulOp = text "*"
+  pretty CDivOp = text "/"
+  pretty CRmdOp = text "%"
+  pretty CAddOp = text "+"
+  pretty CSubOp = text "-"
+  pretty CShlOp = text "<<"
+  pretty CShrOp = text ">>"
+  pretty CLeOp  = text "<"
+  pretty CGrOp  = text ">"
+  pretty CLeqOp = text "<="
+  pretty CGeqOp = text ">="
+  pretty CEqOp  = text "=="
+  pretty CNeqOp = text "!="
+  pretty CAndOp = text "&"
+  pretty CXorOp = text "^"
+  pretty COrOp  = text "|"
+  pretty CLndOp = text "&&"
+  pretty CLorOp = text "||"
+
+
+instance Pretty CUnaryOp where
+  pretty CPreIncOp  = text "++"
+  pretty CPreDecOp  = text "--"
+  pretty CPostIncOp = text "++"
+  pretty CPostDecOp = text "--"
+  pretty CAdrOp     = text "&"
+  pretty CIndOp     = text "*"
+  pretty CPlusOp    = text "+"
+  pretty CMinOp     = text "-"
+  pretty CCompOp    = text "~"
+  pretty CNegOp     = text "!"
+
+
+instance Pretty CConst where
+  pretty (CIntConst i)    = text . show $ i
+  pretty (CCharConst c)   = text . show $ c
+  pretty (CFloatConst f)  = float f
+  pretty (CStringConst s) = text . show $ s
diff --git a/haskell/Language/Hakaru/CodeGen/Types.hs b/haskell/Language/Hakaru/CodeGen/Types.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/CodeGen/Types.hs
@@ -0,0 +1,443 @@
+{-# LANGUAGE DataKinds,
+             FlexibleContexts,
+             GADTs,
+             RankNTypes,
+             KindSignatures #-}
+
+----------------------------------------------------------------
+--                                                    2016.07.11
+-- |
+-- Module      :  Language.Hakaru.CodeGen.Types
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  zsulliva@indiana.edu
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Provides tools for building C Types from Hakaru types
+--
+----------------------------------------------------------------
+
+module Language.Hakaru.CodeGen.Types
+  ( buildDeclaration
+  , buildDeclaration'
+  , buildPtrDeclaration
+
+  -- tools for building C types
+  , typeDeclaration
+  , typePtrDeclaration
+  , typeName
+
+  -- arrays
+  , arrayDeclaration
+  , arrayStruct
+  , arraySize
+  , arrayData
+  , arrayPtrSize
+  , arrayPtrData
+
+  -- mdata
+  , mdataDeclaration
+  , mdataPtrDeclaration
+  , mdataStruct
+  , mdataStruct'
+  , mdataWeight
+  , mdataSample
+  , mdataPtrWeight
+  , mdataPtrSample
+
+  -- datum
+  , datumDeclaration
+  , datumStruct
+  , datumSum
+  , datumProd
+  , datumFst
+  , datumSnd
+  , datumIndex
+
+  -- functions and closures
+  , functionDef
+  , closureStructure
+
+  , buildType
+  , castTo
+  , castToPtrOf
+  , callStruct
+  , buildStruct
+  , buildUnion
+  , binaryOp
+  ) where
+
+import Control.Monad.State
+
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.CodeGen.AST
+import Language.Hakaru.CodeGen.Libs
+
+buildDeclaration :: CTypeSpec -> Ident -> CDecl
+buildDeclaration ctyp ident =
+  CDecl [ CTypeSpec ctyp ]
+        [( CDeclr Nothing (CDDeclrIdent ident)
+         , Nothing)]
+
+buildDeclaration' :: [CTypeSpec] -> Ident -> CDecl
+buildDeclaration' specs ident =
+  CDecl (fmap CTypeSpec specs)
+        [( CDeclr Nothing (CDDeclrIdent ident)
+         , Nothing)]
+
+buildPtrDeclaration :: CTypeSpec -> Ident -> CDecl
+buildPtrDeclaration ctyp ident =
+  CDecl [ CTypeSpec ctyp ]
+        [( CDeclr (Just $ CPtrDeclr []) (CDDeclrIdent ident)
+         , Nothing)]
+
+typeDeclaration :: Sing (a :: Hakaru) -> Ident -> CDecl
+typeDeclaration typ ident =
+  CDecl (fmap CTypeSpec $ buildType typ)
+        [( CDeclr Nothing (CDDeclrIdent ident)
+         , Nothing)]
+
+typePtrDeclaration :: Sing (a :: Hakaru) -> Ident -> CDecl
+typePtrDeclaration typ ident =
+  CDecl (fmap CTypeSpec $ buildType typ)
+        [( CDeclr (Just $ CPtrDeclr [])
+                  (CDDeclrIdent ident)
+         , Nothing)]
+
+
+----------------
+-- Type Names --
+----------------
+{-
+Type names are used when constructing C structures. In most cases there is a
+unique C structure name for a Hakaru type. This is not the case for functions
+which are compiled into closures, which are unique to a certain context and
+Hakaru type.
+-}
+
+typeName :: Sing (a :: Hakaru) -> String
+typeName SInt         = "int"
+typeName SNat         = "nat"
+typeName SReal        = "real"
+typeName SProb        = "prob"
+typeName (SArray t)   = "array_" ++ typeName t
+typeName (SMeasure t) = "mdata_" ++ typeName t
+typeName f@(SFun _ _)  = error $ "typeName{SFun} doen't make sense: unknown context for {" ++ show f ++ "}"
+typeName (SData _ t)  = "dat_" ++ datumSumName t
+  where datumSumName :: Sing (a :: [[HakaruFun]]) -> String
+        datumSumName SVoid = "V"
+        datumSumName (SPlus p s) = datumProdName p ++ datumSumName s
+
+        datumProdName :: Sing (a :: [HakaruFun]) -> String
+        datumProdName SDone     = "D"
+        datumProdName (SEt x p) = datumPrimName x ++ datumProdName p
+
+        datumPrimName :: Sing (a :: HakaruFun) -> String
+        datumPrimName SIdent = "I"
+        datumPrimName (SKonst s) = "K" ++ typeName s
+
+
+
+
+--------------------------------------------------------------------------------
+--                                   Arrays                                   --
+--------------------------------------------------------------------------------
+{-
+  We represent arrays as structs with an 'unsigned int' for the size and a
+  pointer to a block of array elements.
+
+  Because arrays may point to undeclared types (such as arrays of datum), we
+  need to return a list of external declarations with our array type
+-}
+
+arrayStruct :: Sing (a :: Hakaru) -> CExtDecl
+arrayStruct t = CDeclExt (CDecl [CTypeSpec $ arrayStruct' t] [])
+
+arrayStruct' :: Sing (a :: Hakaru) -> CTypeSpec
+arrayStruct' t = aStruct
+  where aSize   = buildDeclaration' [CUnsigned,CInt] (Ident "size")
+        aData   = typePtrDeclaration t (Ident "data")
+        aStruct = buildStruct (Just . Ident . typeName . SArray $ t) [aSize,aData]
+
+
+arrayDeclaration
+  :: Sing (a :: Hakaru)
+  -> Ident
+  -> CDecl
+arrayDeclaration = buildDeclaration . callStruct . typeName . SArray
+
+
+arraySize :: CExpr -> CExpr
+arraySize e = CMember e (Ident "size") True
+
+arrayData :: CExpr -> CExpr
+arrayData e = CMember e (Ident "data") True
+
+arrayPtrSize :: CExpr -> CExpr
+arrayPtrSize e = CMember e (Ident "size") False
+
+arrayPtrData :: CExpr -> CExpr
+arrayPtrData e = CMember e (Ident "data") False
+
+
+
+--------------------------------------------------------------------------------
+--                                  Measure Data                              --
+--------------------------------------------------------------------------------
+{-
+  Measure datum are structures that will be used for sampling. We represent it
+  as a structure with a 'double' in log-domain corresponding to the weight of
+  the sample and an item of the sample type.
+-}
+
+mdataStruct :: Sing (a :: Hakaru) -> CExtDecl
+mdataStruct t = CDeclExt (CDecl [CTypeSpec $ mdataStruct' t] [])
+
+mdataStruct' :: Sing (a :: Hakaru) -> CTypeSpec
+mdataStruct' t = mdStruct
+  where weight = buildDeclaration CDouble (Ident "weight")
+        sample = typeDeclaration t (Ident "sample")
+        mdStruct = buildStruct (Just . Ident . typeName . SMeasure $ t) [weight,sample]
+
+mdataDeclaration
+  :: Sing (a :: Hakaru)
+  -> Ident
+  -> CDecl
+mdataDeclaration = buildDeclaration . callStruct . typeName . SMeasure
+
+mdataPtrDeclaration
+  :: Sing (a :: Hakaru)
+  -> Ident
+  -> CDecl
+mdataPtrDeclaration = buildPtrDeclaration . callStruct . typeName . SMeasure
+
+mdataWeight :: CExpr -> CExpr
+mdataWeight d = CMember d (Ident "weight") True
+
+mdataSample :: CExpr -> CExpr
+mdataSample d = CMember d (Ident "sample") True
+
+mdataPtrWeight :: CExpr -> CExpr
+mdataPtrWeight d = CMember d (Ident "weight") False
+
+mdataPtrSample :: CExpr -> CExpr
+mdataPtrSample d = CMember d (Ident "sample") False
+
+
+
+--------------------------------------------------------------------------------
+--                                     Datum                                  --
+--------------------------------------------------------------------------------
+{-
+  In order to successfully represent Hakaru datum (Sums of Products of Hakaru
+  types), we must have:
+
+  > unique names for a given datum so if SVoid occurs twice in a program, C will
+    be using the same structure
+
+  > C structs
+
+  > A datum may be recursive, so we will need to generate structures for all
+    subtypes as well. These subtypes will need to be declared before the datum
+    for the code to compile
+-}
+
+datumStruct :: (Sing (HData' t)) -> CExtDecl
+datumStruct dat@(SData _ typ)
+  = CDeclExt $ datumSum dat typ (Ident (typeName dat))
+
+datumDeclaration
+  :: (Sing (HData' t))
+  -> Ident
+  -> CDecl
+datumDeclaration = buildDeclaration . callStruct . typeName
+
+datumSum
+  :: Sing (HData' t)
+  -> Sing (a :: [[HakaruFun]])
+  -> Ident
+  -> CDecl
+datumSum dat funs ident =
+  let declrs = fst $ runState (datumSum' dat funs) cNameStream
+      union  = buildDeclaration (buildUnion declrs) (Ident "sum")
+      ind    = buildDeclaration CInt (Ident "index")
+      struct = buildStruct (Just ident) $ case declrs of
+                                            [] -> [ind]
+                                            _  -> [ind,union]
+  in CDecl [ CTypeSpec struct ] []
+
+datumSum'
+  :: Sing (HData' t)
+  -> Sing (a :: [[HakaruFun]])
+  -> State [String] [CDecl]
+datumSum' _ SVoid               = return []
+datumSum' dat (SPlus prod rest) =
+  do nn <- get
+     case nn of
+      name:names -> do
+       put names
+       let ident = Ident name
+           mdecl = datumProd dat prod ident
+       rest' <- datumSum' dat rest
+       case mdecl of
+         Nothing -> return rest'
+         Just d  -> return $ [d] ++ rest'
+
+datumProd
+  :: Sing (HData' t)
+  -> Sing (a :: [HakaruFun])
+  -> Ident
+  -> Maybe CDecl
+datumProd _ SDone _       = Nothing
+datumProd dat funs ident  =
+  let declrs = fst $ runState (datumProd' dat funs) cNameStream
+  in  Just $ buildDeclaration (buildStruct Nothing $ declrs) ident
+
+-- datumProd uses a store of names, which needs to match up with the names used
+-- when they are assigned as well as printed
+datumProd'
+  :: Sing (HData' t)
+  -> Sing (a :: [HakaruFun])
+  -> State [String] [CDecl]
+datumProd' _ SDone        = return []
+datumProd' dat (SEt x ps) =
+  do x'  <- datumPrim dat x
+     ps' <- datumProd' dat ps
+     return $ x' ++ ps'
+
+-- We need to pass HData in case it is some recursive type
+datumPrim
+  :: Sing (HData' t)
+  -> Sing (a :: HakaruFun)
+  -> State [String] [CDecl]
+datumPrim dat prim =
+  do nn <- get
+     case nn of
+      (name:names) -> do
+       put names
+       let ident = Ident name
+           decl  = case prim of
+                     SIdent     -> datumDeclaration dat ident
+                     (SKonst k) -> typeDeclaration k ident
+       return [decl]
+
+-- index into pair
+datumFst :: CExpr -> CExpr
+datumFst x = x ... "sum" ... "a" ... "a"
+
+datumSnd :: CExpr -> CExpr
+datumSnd x = x ... "sum" ... "a" ... "b"
+
+datumIndex :: CExpr -> CExpr
+datumIndex x = x ... "index"
+
+--------------------------------------------------------------------------------
+--                                Functions                                   --
+--------------------------------------------------------------------------------
+{-
+   This still needs some work. Currently, we use the CodeGenMonad to give us
+   a list of local declarations and statements to be used in a function. Then
+   build a function from that.
+-}
+
+functionDef
+  :: Sing (a :: Hakaru)
+  -> Ident
+  -> [CDecl]
+  -> [CDecl]
+  -> [CStat]
+  -> CFunDef
+functionDef typ ident argDecls internalDecls stmts =
+  CFunDef (fmap CTypeSpec $ buildType typ)
+          (CDeclr Nothing (CDDeclrIdent ident))
+          argDecls
+          (CCompound ((fmap CBlockDecl internalDecls)
+                   ++ (fmap CBlockStat stmts)))
+
+--------------
+-- Closures --
+--------------
+
+-- externally declare closure structure
+closureStructure
+  :: forall (a :: Hakaru) xs
+  .  [SomeVariable (KindOf a)]       -- ^ free variables
+  -> List1 Variable (xs :: [Hakaru]) -- ^ function arguments
+  -> Ident                           -- ^ identifier of function
+  -> Sing a                          -- ^ function return type
+  -> CExtDecl
+closureStructure fvs as i@(Ident name) typ = CDeclExt $
+  (CDecl [CTypeSpec $ (buildStruct (Just i) (codePtr:(declFvs cNameStream fvs)))]
+         [])
+  where declFvs _ [] = []
+        declFvs (n:ns) ((SomeVariable (Variable _ _ typ')):as') =
+          typeDeclaration typ' (Ident n) : declFvs ns as'
+        declFvc [] (_:_) = error "Ran out of identifiers but still had some types to assign"
+        codePtr = CDecl (fmap CTypeSpec . buildType $ typ)
+                        [(CDeclr Nothing
+                           (CDDeclrFun
+                             (CDDeclrRec
+                               (CDeclr (Just . CPtrDeclr $ [])
+                                       (CDDeclrIdent . Ident $ "_code_ptr")))
+                             ([callStruct name]:(varTypes as)))
+                         ,Nothing)]
+
+        varTypes :: List1 Variable (xs :: [Hakaru]) -> [[CTypeSpec]]
+        varTypes = foldMap11 (\(Variable _ _ typ') -> [buildType typ'])
+
+
+
+--------------------------------------------------------------------------------
+-- | buildType function do the work of describing how the Hakaru
+-- type will be stored in memory. Arrays needed their own
+-- declaration function for their arity
+
+buildType :: Sing (a :: Hakaru) -> [CTypeSpec]
+buildType SInt          = [CInt]
+buildType SNat          = [CUnsigned, CInt]
+buildType SProb         = [CDouble]
+buildType SReal         = [CDouble]
+buildType (SMeasure x)  = [callStruct . typeName . SMeasure $ x]
+buildType (SArray t)    = [callStruct . typeName . SArray $ t]
+buildType (SFun _ x)    = buildType $ x -- build type the function returns
+buildType d@(SData _ _) = [callStruct . typeName $ d]
+
+
+-- these mk...Decl functions are used in coersions
+castTo :: [CTypeSpec] -> CExpr -> CExpr
+castTo t = CCast (CTypeName t False)
+
+castToPtrOf :: [CTypeSpec] -> CExpr -> CExpr
+castToPtrOf t = CCast (CTypeName t True)
+
+buildStruct :: Maybe Ident -> [CDecl] -> CTypeSpec
+buildStruct mi decls =
+  CSUType (CSUSpec CStructTag mi decls)
+
+-- | callStruct will give the type spec calling a struct we have already
+--   declared externally
+callStruct :: String -> CTypeSpec
+callStruct name =
+  CSUType (CSUSpec CStructTag (Just (Ident name)) [])
+
+buildUnion :: [CDecl] -> CTypeSpec
+buildUnion decls =
+ CSUType (CSUSpec CUnionTag Nothing decls)
+
+
+binaryOp :: NaryOp a -> CExpr -> CExpr -> CExpr
+binaryOp (Sum HSemiring_Prob)  a b = CBinary CAddOp (expE a) (expE b)
+binaryOp (Prod HSemiring_Prob) a b = CBinary CAddOp a b
+binaryOp (Sum _)               a b = CBinary CAddOp a b
+binaryOp (Prod _)              a b = CBinary CMulOp a b
+-- vvv Operations on bools, keeping in mind that in Hakaru-C: 0 is true and 1 is false
+binaryOp And                   a b = CUnary CNegOp (CBinary CEqOp  a b) -- still wrong
+binaryOp Or                    a b = CBinary CAndOp a b                 -- still wrong
+binaryOp Xor                   a b = CBinary CLorOp a b                 -- still wrong
+binaryOp x _ _ = error $ "TODO: binaryOp " ++ show x
diff --git a/haskell/Language/Hakaru/CodeGen/Wrapper.hs b/haskell/Language/Hakaru/CodeGen/Wrapper.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/CodeGen/Wrapper.hs
@@ -0,0 +1,483 @@
+{-# LANGUAGE BangPatterns,
+             CPP,
+             OverloadedStrings,
+             DataKinds,
+             FlexibleContexts,
+             GADTs,
+             KindSignatures,
+             RankNTypes,
+             ScopedTypeVariables,
+             TypeOperators #-}
+
+----------------------------------------------------------------
+--                                                    2016.06.23
+-- |
+-- Module      :  Language.Hakaru.CodeGen.Wrapper
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  zsulliva@indiana.edu
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--   The purpose of the wrapper is to intelligently wrap CStatements
+-- into CFunctions and CProgroms to be printed by 'hkc'
+--
+----------------------------------------------------------------
+
+
+module Language.Hakaru.CodeGen.Wrapper
+  ( wrapProgram
+  , PrintConfig(..)
+  ) where
+
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Syntax.TypeOf (typeOf)
+import           Language.Hakaru.Types.Sing
+import           Language.Hakaru.CodeGen.CodeGenMonad
+import           Language.Hakaru.CodeGen.Flatten
+import           Language.Hakaru.CodeGen.Types
+import           Language.Hakaru.CodeGen.AST
+import           Language.Hakaru.CodeGen.Libs
+import           Language.Hakaru.Types.DataKind (Hakaru(..))
+import           Control.Monad.State.Strict
+import           Prelude            as P hiding (unlines,exp)
+
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative
+#endif
+
+
+-- | wrapProgram is the top level C codegen. Depending on the type a program
+--   will have a different construction. It will produce an effect in the
+--   CodeGenMonad that will produce a standalone C file containing the CPP
+--   includes, struct declarations, functions, and sometimes a main.
+wrapProgram
+  :: TypedAST (TrivialABT Term) -- ^ Some Hakaru ABT
+  -> Maybe String               -- ^ Maybe an output name
+  -> PrintConfig                -- ^ show weights?
+  -> CodeGen ()
+wrapProgram tast@(TypedAST typ _) mn pconfig =
+  do sequence_ . fmap (extDeclare . CPPExt) . header $ typ
+     cg <- get
+     when (managedMem cg)  $ extDeclare . CPPExt $ gcHeader
+     when (sharedMem cg)   $ extDeclare . CPPExt $ openMpHeader
+     case (tast,mn) of
+       ( TypedAST (SFun _ _) abt, Just name ) ->
+         flattenTopLambda abt =<< reserveIdent name
+
+       ( TypedAST typ' abt,       Just name ) ->
+         -- still buggy for measures
+         do mfId <- reserveIdent name
+            funCG (buildType typ') mfId [] $
+              do outE <- flattenWithName' abt "out"
+                 putStat . CReturn . Just $ outE
+
+       ( TypedAST typ'       abt, Nothing   ) ->
+         mainFunction pconfig typ' abt
+
+
+
+header :: Sing (a :: Hakaru) -> [Preprocessor]
+header (SMeasure _) = fmap PPInclude ["time.h", "stdlib.h", "stdio.h", "math.h"]
+header _            = fmap PPInclude ["stdlib.h", "stdio.h", "math.h"]
+
+
+
+--------------------------------------------------------------------------------
+--                             A Main Function                                --
+--------------------------------------------------------------------------------
+{-
+
+Create standalone C program for a Hakaru ABT. This program will also print the
+computed value to stdin.
+
+-}
+
+mainFunction
+  :: ABT Term abt
+  => PrintConfig
+  -> Sing (a :: Hakaru)    -- ^ type of program
+  -> abt '[] (a :: Hakaru) -- ^ Hakaru ABT
+  -> CodeGen ()
+
+-- when measure, compile to a sampler
+mainFunction pconfig typ@(SMeasure _) abt =
+  do mfId    <- reserveIdent "measure"
+     mainId  <- reserveIdent "main"
+     argVId <- reserveIdent "argv"
+     argCId <- reserveIdent "argc"
+     let (argCE:argVE:[]) = fmap CVar [argCId,argVId]
+     extDeclareTypes typ
+
+     -- defined a measure function that returns mdata
+     funCG (buildType typ) mfId  [] $
+       (putStat . CReturn . Just) =<< flattenWithName' abt "samp"
+
+     funCG [CInt] mainId mainArgs $
+       do isManagedMem <- managedMem <$> get
+          when isManagedMem (putExprStat gcInit)
+
+          nSamples <- parseNumSamples argCE argVE
+          seedE <- parseSeed argCE argVE
+
+          putExprStat $ mkCallE "srand" [seedE]
+
+          putStat $ opComment "Run Hakaru Sampler"
+          printCG pconfig typ (CCall (CVar mfId) []) (Just nSamples)
+          putStat . CReturn . Just $ intE 0
+
+mainFunction pconfig (SFun _ _) abt =
+  coalesceLambda abt $ \_ abt' ->
+    do resId  <- reserveIdent "result"
+       mainId <- reserveIdent "main"
+       argVId <- reserveIdent "argv"
+       argCId <- reserveIdent "argc"
+       funId  <- genIdent' "fn"
+       flattenTopLambda abt funId
+       let (resE:funE:argCE:argVE:[]) = fmap CVar [resId,funId,argCId,argVId]
+           typ' = typeOf abt'
+
+       funCG [CInt] mainId mainArgs $
+         do isManagedMem <- managedMem <$> get
+            when isManagedMem (putExprStat gcInit)
+            declare typ' resId
+
+            mns <- maybeNumSamples argCE argVE typ'
+            case typ' of
+              SMeasure _ -> do seedE <- parseSeed argCE argVE
+                               putExprStat $ mkCallE "srand" [seedE]
+              _ -> return ()
+
+            withLambdaDepth' 0 abt $ \d ->
+              let argErr 0 = ""
+                  argErr n = (argErr (pred n)) ++ "<arg" ++ show n ++ "> " in
+                ifCG (argCE .<. (intE (d+1)))
+                     (do putExprStat $ printfE
+                           [ stringE $ "Usage: %s " ++ argErr d ++ "\n"
+                           , (index argVE (intE 0)) ]
+                         putExprStat $ mkCallE "abort" [ ])
+                     (return ())
+
+            putStat $ opComment "Parse Args"
+            argEs <- foldLambdaWithIndex 1 abt $ \i (Variable _ _ t) ->
+                       do argE <- localVar' t "arg"
+                          _ <- parseCG t (index argVE (intE i)) argE
+                          return argE
+
+            case typ' of
+              SMeasure _ -> do putStat $ opComment "Run Hakaru Sampler"
+                               printCG pconfig typ' (CCall funE argEs) mns
+
+              _ -> do putStat $ opComment "Run Hakaru Program"
+                      putExprStat $ resE .=. (CCall funE argEs)
+                      putStat $ opComment "Print Result"
+                      printCG pconfig typ' resE mns
+
+            putStat . CReturn . Just $ intE 0
+
+
+  where withLambdaDepth'
+          :: ABT Term abt
+          => Integer
+          -> abt '[] a
+          -> (Integer -> CodeGen ())
+          -> CodeGen ()
+        withLambdaDepth' n abt_ k =
+          caseVarSyn abt_
+            (const (k n))
+            (\term ->
+              case term of
+                (Lam_ :$ body :* End) ->
+                  caseBind body $ \_ abt_' ->
+                    withLambdaDepth' (succ n) abt_' k
+                _ -> k n)
+
+        maybeNumSamples
+          :: CExpr -> CExpr -> Sing (a :: Hakaru) -> CodeGen (Maybe CExpr)
+        maybeNumSamples c v (SMeasure _) = Just <$> parseNumSamples c v
+        maybeNumSamples _ _ _ = return Nothing
+
+-- just a computation
+mainFunction pconfig typ abt =
+  do resId  <- reserveIdent "result"
+     mainId <- reserveIdent "main"
+     let resE  = CVar resId
+
+     funCG [CInt] mainId [] $
+       do declare typ resId
+
+          isManagedMem <- managedMem <$> get
+          when isManagedMem (putExprStat gcInit)
+
+          flattenABT abt resE
+          printCG pconfig typ resE Nothing
+          putStat . CReturn . Just $ intE 0
+
+mainArgs :: [CDecl]
+mainArgs = [ CDecl [CTypeSpec CInt]
+                   [(CDeclr Nothing (CDDeclrIdent (Ident "argc")), Nothing)]
+           , CDecl [CTypeSpec CChar]
+                   [(CDeclr (Just (CPtrDeclr []))
+                            (CDDeclrArr (CDDeclrIdent (Ident "argv")) Nothing)
+                     , Nothing)]
+           ]
+
+{- the number of samples is set to -1 by default -}
+parseNumSamples :: CExpr -> CExpr -> CodeGen CExpr
+parseNumSamples argc argv =
+  do itE <- localVar SNat
+     outE <- localVar SNat
+     putStat $ opComment "Num Samples?"
+     putExprStat $ outE .=. (intE (-1))
+     forCG (itE .=. (intE 1))
+           (itE .<. argc)
+           (CUnary CPostIncOp itE)
+           (ifCG ((index (index argv itE) (intE 0) .==. (charE '-')) .&&.
+                  (index (index argv itE) (intE 1) .==. (charE 'n')))
+                 (putExprStat $
+                   sscanfE [index argv itE,stringE "-n%d",address outE])
+                 (return ()))
+     putStat $ opComment "End Num Samples?"
+     return outE
+
+{- the randome seed is set to time(NULL) by default -}
+parseSeed :: CExpr -> CExpr -> CodeGen CExpr
+parseSeed argc argv =
+  do itE <- localVar SNat
+     outE <- localVar SNat
+     putStat $ opComment "Random Seed?"
+     putExprStat $ outE .=. (mkCallE "time" [ CVar . Ident $ "NULL"])
+     forCG (itE .=. (intE 1))
+           (itE .<. argc)
+           (CUnary CPostIncOp itE)
+           (ifCG ((index (index argv itE) (intE 0) .==. (charE '-')) .&&.
+                  (index (index argv itE) (intE 1) .==. (charE 's')))
+                 (putExprStat $
+                   sscanfE [index argv itE,stringE "-s%d",address outE])
+                 (return ()))
+     putStat $ opComment "End Random Seed?"
+     return outE
+
+
+--------------------------------------------------------------------------------
+--                               Parsing Values                               --
+--------------------------------------------------------------------------------
+
+parseCG :: Sing (a :: Hakaru) -> CExpr -> CExpr -> CodeGen CExpr
+parseCG (SArray t) from to =
+  do fpId <- genIdent' "fp"
+     buffId <- genIdent' "buff"
+     declare' $ CDecl [CTypeSpec fileT]
+                      [(CDeclr (Just (CPtrDeclr []))
+                               (CDDeclrIdent fpId)
+                               , Nothing)]
+     declare' $ CDecl [CTypeSpec CChar]
+                      [(CDeclr Nothing
+                               (CDDeclrArr (CDDeclrIdent buffId) (Just (intE 1024)))
+                               , Nothing)]
+     let fpE = CVar fpId
+         buffE = CVar buffId
+     putExprStat $ fpE .=. (fopenE from (stringE "r"))
+     itE <- localVar SNat
+     putExprStat $ itE .=. (intE 0)
+     whileCG (fgetsE buffE (intE 1024) fpE .!=. nullE)
+             (putExprStat $ CUnary CPostIncOp itE)
+     putExprStat $ arraySize to .=. itE
+     putMallocStat (arrayData to) itE t
+     putExprStat $ itE .=. (intE 0)
+     putExprStat $ rewindE fpE
+     whileCG (fgetsE buffE (intE 1024) fpE .!=. nullE)
+             (do checkE <- parseCG t buffE (index (arrayData to) itE)
+                 ifCG (checkE .==. (intE 1))
+                      (putExprStat $ CUnary CPostIncOp itE)
+                      (putExprStat $ CUnary CPostDecOp (arraySize to)))
+     putExprStat $ fcloseE fpE
+     localVar SNat
+
+parseCG t from to =
+  do checkE <- localVar SNat
+     putExprStat $ checkE .=. sscanfE [from,stringE . parseFormat $ t,address to]
+     case t of
+       SProb -> putExprStat $ to .=. logE to
+       _ -> return ()
+     return checkE
+
+parseFormat :: Sing (a :: Hakaru) -> String
+parseFormat SInt  = "%d"
+parseFormat SNat  = "%u"
+parseFormat SReal = "%lf"
+parseFormat SProb = "%lf"
+parseFormat t = error $ "parseCG{" ++ show t ++ "}: no available parsing form"
+
+
+--------------------------------------------------------------------------------
+--                               Printing Values                              --
+--------------------------------------------------------------------------------
+{-
+
+In HKC the printconfig is parsed from the command line. The default being that
+we don't show weights and probabilities are printed as normal real values.
+
+-}
+
+data PrintConfig
+  = PrintConfig { noWeights   :: Bool
+                , showProbInLog :: Bool
+                } deriving Show
+
+
+printCG
+  :: PrintConfig
+  -> Sing (a :: Hakaru) -- ^ Hakaru type to be printed
+  -> CExpr              -- ^ CExpr representing value
+  -> Maybe CExpr        -- ^ If measure type, expr for num samples
+  -> CodeGen ()
+printCG pconfig mtyp@(SMeasure typ) sampleFunc (Just numSamples) =
+  do mE <- localVar' mtyp "m"
+     itE <- localVar SNat
+     putExprStat $ itE .=. numSamples
+     whileCG (itE .!=. (intE 0)) $
+       do putExprStat $ mE .=. sampleFunc
+          case noWeights pconfig of
+            True  -> printCG pconfig typ (mdataSample mE) Nothing
+            False -> do putExprStat $
+                          printfE [ stringE (printFormat pconfig SProb "\t")
+                                  , expE (mdataWeight mE) ]
+                        printCG pconfig typ (mdataSample mE) Nothing
+          ifCG (numSamples .>=. (intE 0))
+               (putExprStat $ CUnary CPostDecOp itE)
+               (return ())
+
+printCG pconfig (SArray typ) arg Nothing =
+  do itE <- localVar' SNat "it"
+     putString "[ "
+     seqDo $
+       forCG (itE .=. (intE 0))
+             (itE .<. (arraySize arg))
+             (CUnary CPostIncOp itE)
+             (putExprStat
+             $ printfE [ stringE $ printFormat pconfig typ " "
+                       , index (arrayData arg) itE ])
+     putString "]\n"
+  where putString s = putExprStat $ printfE [stringE s]
+
+-- bool and unit
+printCG _ (SData (STyCon sym)  _) arg Nothing =
+  case ssymbolVal sym of
+    "Unit" -> putExprStat $ printfE [stringE "()\n"]
+    "Bool" -> ifCG (datumIndex arg .==. (intE 0))
+                   (putExprStat $ printfE [stringE "true\n"])
+                   (putExprStat $ printfE [stringE "false\n"])
+    _ -> error $ show sym
+
+printCG pconfig SProb arg Nothing =
+  putExprStat $ printfE
+                      [ stringE $ printFormat pconfig SProb "\n"
+                      , if showProbInLog pconfig
+                        then arg
+                        else expE arg ]
+
+printCG pconfig typ arg Nothing =
+  putExprStat $ printfE
+              [ stringE $ printFormat pconfig typ "\n"
+              , arg ]
+
+-- we should only have a number of samples if it a measure
+printCG _ _ _ (Just _) = error "this should not happen"
+
+
+printFormat :: PrintConfig -> Sing (a :: Hakaru) -> (String -> String)
+printFormat _ SInt         = \s -> "%d" ++ s
+printFormat _ SNat         = \s -> "%d" ++ s
+printFormat c SProb        = \s -> if showProbInLog c
+                                  then "exp(%.15f)" ++ s
+                                  else "%.15f" ++ s
+printFormat _ SReal        = \s -> "%.15f" ++ s
+printFormat c (SMeasure t) = if noWeights c
+                             then printFormat c t
+                             else \s -> if showProbInLog c
+                                        then "exp(%.15f) " ++ printFormat c t s
+                                        else "%.15f " ++ printFormat c t s
+printFormat c (SArray t)   = printFormat c t
+printFormat _ (SFun _ _)   = id
+printFormat _ (SData _ _)  = \s -> "TODO: printft datum" ++ s
+
+
+--------------------------------------------------------------------------------
+--                           Wrapping   Lambdas                               --
+--------------------------------------------------------------------------------
+{-
+
+Lambdas become function in C. The Hakaru ABT only allows one arguement for each
+lambda. So at the top level of a Hakaru program that is a function there may be
+several nested lambdas. In C however, we can and should coalesce these into one
+function with several arguements. This is what flattenTopLambda is for.
+
+-}
+
+
+flattenTopLambda
+  :: ABT Term abt
+  => abt '[] a
+  -> Ident
+  -> CodeGen ()
+flattenTopLambda abt name =
+    coalesceLambda abt $ \vars abt' ->
+    let varMs = foldMap11 (\v -> [mkVarDecl v =<< createIdent' "param" v]) vars
+        typ   = typeOf abt'
+    in  do argDecls <- sequence varMs
+           funCG (buildType typ) name argDecls $
+             (putStat . CReturn . Just) =<< flattenWithName' abt' "out"
+
+  -- do at top level
+  where mkVarDecl :: Variable (a :: Hakaru) -> Ident -> CodeGen CDecl
+        mkVarDecl (Variable _ _ SInt)  = return . typeDeclaration SInt
+        mkVarDecl (Variable _ _ SNat)  = return . typeDeclaration SNat
+        mkVarDecl (Variable _ _ SProb) = return . typeDeclaration SProb
+        mkVarDecl (Variable _ _ SReal) = return . typeDeclaration SReal
+        mkVarDecl (Variable _ _ (SArray t)) = \i ->
+          extDeclareTypes (SArray t) >> (return $ arrayDeclaration t i)
+
+        mkVarDecl (Variable _ _ d@(SData _ _)) = \i ->
+          extDeclareTypes d >> (return $ datumDeclaration d i)
+
+        mkVarDecl v = error $ "flattenSCon.Lam_.mkVarDecl cannot handle vars of type " ++ show v
+
+coalesceLambda
+  :: ABT Term abt
+  => abt '[] a
+  -> ( forall (ys :: [Hakaru]) b
+     . List1 Variable ys -> abt '[] b -> r)
+  -> r
+coalesceLambda abt_ k =
+  caseVarSyn abt_ (const (k Nil1 abt_)) $ \term ->
+    case term of
+      (Lam_ :$ body :* End) ->
+        caseBind body $ \v body' ->
+           coalesceLambda body' $ \vars body'' -> k (Cons1 v vars) body''
+      _ -> k Nil1 abt_
+
+foldLambdaWithIndex
+  :: ABT Term abt
+  => Integer
+  -> abt '[] a
+  -> ( forall (x :: Hakaru)
+     .  Integer
+     -> Variable x
+     -> CodeGen CExpr)
+  -> CodeGen [CExpr]
+foldLambdaWithIndex n abt_ k =
+  caseVarSyn abt_
+    (const (return []))
+    (\term ->
+      case term of
+        (Lam_ :$ body :* End) ->
+          caseBind body $ \v abt_' ->
+            (do x <- k n v
+                xs <- foldLambdaWithIndex (succ n) abt_' k
+                return (x:xs))
+        _ -> return [])
diff --git a/haskell/Language/Hakaru/Command.hs b/haskell/Language/Hakaru/Command.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Command.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , OverloadedStrings
+           , FlexibleContexts
+           #-}
+module Language.Hakaru.Command where
+
+import           Language.Hakaru.Syntax.ABT
+import qualified Language.Hakaru.Syntax.AST as T
+import           Language.Hakaru.Parser.Import (expandImports)
+import           Language.Hakaru.Parser.Parser (parseHakaru, parseHakaruWithImports)
+import           Language.Hakaru.Parser.SymbolResolve (resolveAST)
+import           Language.Hakaru.Syntax.TypeCheck
+
+import           Control.Monad.Trans.Except
+import           Control.Monad (when)
+import qualified Data.Text      as Text
+import qualified Data.Text.IO   as IO
+import qualified Data.Text.Utf8 as U
+import qualified Options.Applicative as O
+import           Data.Vector
+import           System.IO (stderr)
+import           System.Environment (getArgs)
+import           Data.Monoid ((<>),mconcat)
+import           System.FilePath (takeDirectory)
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+#endif
+
+type Term a = TrivialABT T.Term '[] a
+
+parseAndInfer :: Text.Text
+              -> Either Text.Text (TypedAST (TrivialABT T.Term))
+parseAndInfer x = parseAndInferWithMode x LaxMode
+
+parseAndInferWithMode
+  :: ABT T.Term abt
+  => Text.Text
+  -> TypeCheckMode
+  -> Either Text.Text (TypedAST abt)
+parseAndInferWithMode x mode =
+    case parseHakaru x of
+    Left  err  -> Left (Text.pack . show $ err)
+    Right past ->
+        let m = inferType (resolveAST past) in
+        runTCM m (splitLines x) mode
+
+-- The filepath from which the text came and the text itself. If the filepath is
+-- Nothing, imports are searched for in the current directory.
+data Source = Source { file :: Maybe FilePath, source :: Text.Text }
+
+sourceInput :: Source -> Maybe (Vector Text.Text)
+sourceInput = splitLines . source
+
+noFileSource :: Text.Text -> Source
+noFileSource = Source Nothing
+
+fileSource :: FilePath -> Text.Text -> Source
+fileSource = Source . Just
+
+parseAndInfer' :: Source
+               -> IO (Either Text.Text (TypedAST (TrivialABT T.Term)))
+parseAndInfer' s = parseAndInferWithMode' s LaxMode
+
+parseAndInferWithMode'
+  :: ABT T.Term abt
+  => Source
+  -> TypeCheckMode
+  -> IO (Either Text.Text (TypedAST abt))
+parseAndInferWithMode' (Source dir x) mode =
+    case parseHakaruWithImports x of
+    Left  err  -> return . Left $ Text.pack . show $ err
+    Right past -> do
+      past' <- runExceptT (expandImports (fmap takeDirectory dir) past)
+      case past' of
+        Left err     -> return . Left $ Text.pack . show $ err
+        Right past'' -> do
+          let m = inferType (resolveAST past'')
+          return (runTCM m (splitLines x) mode)
+
+parseAndInferWithDebug
+    :: Bool
+    -> Text.Text
+    -> IO (Either Text.Text (TypedAST (TrivialABT T.Term)))
+parseAndInferWithDebug debug x =
+  case parseHakaru x of
+    Left err -> return $ Left (Text.pack . show $ err)
+    Right past -> do
+      when debug $ putErrorLn $ hrule "Parsed AST"
+      when debug $ putErrorLn . Text.pack . show $ past
+      let resolved = resolveAST past
+      let inferred  = runTCM (inferType resolved) (splitLines x) LaxMode
+      when debug $ putErrorLn $ hrule "Inferred AST"
+      when debug $ putErrorLn . Text.pack . show $ inferred
+      return $ inferred
+  where hrule s = Text.concat ["\n<=======================| "
+                              ,s," |=======================>\n"]
+        putErrorLn = IO.hPutStrLn stderr
+
+
+splitLines :: Text.Text -> Maybe (Vector Text.Text)
+splitLines = Just . fromList . Text.lines
+
+readFromFile :: String -> IO Text.Text
+readFromFile "-" = U.getContents
+readFromFile x   = U.readFile x
+
+readFromFile' :: String -> IO Source
+readFromFile' x = Source (if x=="-" then Nothing else Just x) <$> readFromFile x
+
+simpleCommand :: (Text.Text -> IO ()) -> Text.Text -> IO ()
+simpleCommand k fnName = 
+  let parser = 
+        O.info (O.helper <*> opts)
+               (O.fullDesc <> O.progDesc 
+                 (mconcat["Hakaru:", Text.unpack fnName, " command"]))
+      opts = 
+        O.strArgument
+           ( O.metavar "PROGRAM" <> 
+             O.showDefault <> O.value "-" <> 
+             O.help "Filepath to Hakaru program OR \"-\"" )
+
+  in O.execParser parser >>= readFromFile >>= k 
+
+writeToFile :: String -> (Text.Text -> IO ())
+writeToFile "-" = U.putStrLn 
+writeToFile x   = U.writeFile x
diff --git a/haskell/Language/Hakaru/Disintegrate.hs b/haskell/Language/Hakaru/Disintegrate.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Disintegrate.hs
@@ -0,0 +1,1298 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , EmptyCase
+           , KindSignatures
+           , DataKinds
+           , PolyKinds
+           , TypeOperators
+           , ScopedTypeVariables
+           , Rank2Types
+           , MultiParamTypeClasses
+           , TypeSynonymInstances
+           , FlexibleInstances
+           , FlexibleContexts
+           , UndecidableInstances
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.06.29
+-- |
+-- Module      :  Language.Hakaru.Disintegrate
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Disintegration via lazy partial evaluation.
+--
+-- N.B., the forward direction of disintegration is /not/ just
+-- partial evaluation! In the version discussed in the paper we
+-- must also ensure that no heap-bound variables occur in the result,
+-- which requires using HNFs rather than WHNFs. That condition is
+-- sound, but a bit too strict; we could generalize this to handle
+-- cases where there may be heap-bound variables remaining in neutral
+-- terms, provided we (a) don't end up trying to go both forward
+-- and backward on the same variable, and (more importantly) (b)
+-- end up with the proper Jacobian. The paper version is rigged to
+-- ensure that whenever we recurse into two subexpressions (e.g.,
+-- the arguments to addition) one of them has a Jacobian of zero,
+-- thus when going from @x*y@ to @dx*y + x*dy@ one of the terms
+-- cancels out.
+--
+-- /Developer's Note:/ To help keep the code clean, we use the
+-- worker\/wrapper transform. However, due to complexities in
+-- typechecking GADTs, this often confuses GHC if you don't give
+-- just the right type signature on definitions. This confusion
+-- shows up whenever you get error messages about an \"ambiguous\"
+-- choice of 'ABT' instance, or certain types of \"couldn't match
+-- @a@ with @a1@\" error messages. To eliminate these issues we use
+-- @-XScopedTypeVariables@. In particular, the @abt@ type variable
+-- must be bound by the wrapper (i.e., the top-level definition),
+-- and the workers should just refer to that same type variable
+-- rather than quantifying over abother @abt@ type. In addition,
+-- whatever other type variables there are (e.g., the @xs@ and @a@
+-- of an @abt xs a@ argument) should be polymorphic in the workers
+-- and should /not/ reuse the other analogous type variables bound
+-- by the wrapper.
+--
+-- /Developer's Note:/ In general, we'd like to emit weights and
+-- guards \"as early as possible\"; however, determining when that
+-- actually is can be tricky. If we emit them way-too-early then
+-- we'll get hygiene errors because bindings for the variables they
+-- use have not yet been emitted. We can fix these hygiene erors
+-- by calling 'atomize', to ensure that all the necessary bindings
+-- have already been emitted. But that may still emit things too
+-- early, because emitting th variable-binding statements now means
+-- that we can't go forward\/backward on them later on; which may
+-- cause us to bot unnecessarily. One way to avoid this bot issue
+-- is to emit guards\/weights later than necessary, by actually
+-- pushing them onto the context (and then emitting them whenever
+-- we residualize the context). This guarantees we don't emit too
+-- early; but the tradeoff is we may end up generating duplicate
+-- code by emitting too late. One possible (currently unimplemented)
+-- solution to that code duplication issue is to let these statements
+-- be emitted too late, but then have a post-processing step to
+-- lift guards\/weights up as high as they can go. To avoid problems
+-- about testing programs\/expressions for equality, we can use a
+-- hash-consing trick so we keep track of the identity of guard\/weight
+-- statements, then we can simply compare those identities and only
+-- after the lifting do we replace the identity hash with the actual
+-- statement.
+----------------------------------------------------------------
+module Language.Hakaru.Disintegrate
+    ( lam_
+    -- * the Hakaru API
+    , disintegrateWithVar
+    , disintegrate, disintegrateInCtx
+    , densityWithVar
+    , density, densityInCtx
+    , observe, observeInCtx
+    , determine
+    
+    -- * Implementation details
+    , perform
+    , atomize
+    , constrainValue
+    , constrainOutcome
+    ) where
+
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor         ((<$>))
+import           Data.Foldable        (Foldable, foldMap)
+import           Data.Traversable     (Traversable)
+import           Control.Applicative  (Applicative(..))
+#endif
+import           Control.Applicative  (Alternative(..))
+import           Control.Monad        ((<=<), guard)
+import           Data.Functor.Compose (Compose(..))
+import qualified Data.Traversable     as T
+import           Data.List.NonEmpty   (NonEmpty(..))
+import qualified Data.List.NonEmpty   as L
+import qualified Data.Text            as Text
+import qualified Data.IntMap          as IM
+import           Data.Sequence        (Seq)
+import qualified Data.Sequence        as S
+import           Data.Proxy           (KProxy(..))
+import           Data.Maybe           (fromMaybe, fromJust)
+
+import Language.Hakaru.Syntax.IClasses
+import Data.Number.Natural
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import qualified Language.Hakaru.Types.Coercion as C
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.DatumCase (DatumEvaluator, MatchResult(..), matchBranches)
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.Transform (TransformCtx(..), minimalCtx)
+import Language.Hakaru.Evaluation.Types
+import Language.Hakaru.Evaluation.Lazy
+import Language.Hakaru.Evaluation.DisintegrationMonad
+import qualified Language.Hakaru.Syntax.Prelude as P
+import qualified Language.Hakaru.Expect         as E
+
+#ifdef __TRACE_DISINTEGRATE__
+import qualified Text.PrettyPrint     as PP
+import Language.Hakaru.Pretty.Haskell
+import Debug.Trace                    (trace, traceM)
+#endif
+
+
+----------------------------------------------------------------
+
+lam_ :: (ABT Term abt) => Variable a -> abt '[] b -> abt '[] (a ':-> b)
+lam_ x e = syn (Lam_ :$ bind x e :* End)
+
+
+-- | Disintegrate a measure over pairs with respect to the lebesgue
+-- measure on the first component. That is, for each measure kernel
+-- @n <- disintegrate m@ we have that @m == bindx lebesgue n@. The
+-- first two arguments give the hint and type of the lambda-bound
+-- variable in the result. If you want to automatically fill those
+-- in, then see 'disintegrate'.
+--
+-- N.B., the resulting functions from @a@ to @'HMeasure b@ are
+-- indeed measurable, thus it is safe\/appropriate to use Hakaru's
+-- @(':->)@ rather than Haskell's @(->)@.
+--
+-- BUG: Actually, disintegration is with respect to the /Borel/
+-- measure on the first component of the pair! Alas, we don't really
+-- have a clean way of describing this since we've no primitive
+-- 'MeasureOp' for Borel measures.
+--
+-- /Developer's Note:/ This function fills the role that the old
+-- @runDisintegrate@ did (as opposed to the old function called
+-- @disintegrate@). [Once people are familiar enough with the new
+-- code base and no longer recall what the old code base was doing,
+-- this note should be deleted.]
+disintegrateWithVar
+    :: (ABT Term abt)
+    => TransformCtx
+    -> Text.Text
+    -> Sing a
+    -> abt '[] ('HMeasure (HPair a b))
+    -> [abt '[] (a ':-> 'HMeasure b)]
+disintegrateWithVar ctx hint typ m =
+    let x = Variable hint (nextFreeOrBind m) typ
+    in map (lam_ x) . flip (runDisInCtx ctx) [Some2 m, Some2 (var x)] $ do
+        ab <- perform m
+#ifdef __TRACE_DISINTEGRATE__
+        ss <- getStatements
+        trace ("-- disintegrate: finished perform\n"
+            ++ show (pretty_Statements ss PP.$+$ PP.sep(prettyPrec_ 11 ab))
+            ++ "\n") $ return ()
+#endif
+        (a,b) <- emitUnpair ab
+#ifdef __TRACE_DISINTEGRATE__
+        trace ("-- disintegrate: finished emitUnpair: "
+            ++ show (pretty a, pretty b)) $ return ()
+#endif
+        constrainValue (var x) a
+#ifdef __TRACE_DISINTEGRATE__
+        ss <- getStatements
+        extras <- getExtras
+        traceM ("-- disintegrate: finished constrainValue\n"
+                ++ show (pretty_Statements ss) ++ "\n"
+                ++ show (prettyExtras extras)
+               )
+#endif
+        return b
+
+
+-- | A variant of 'disintegrateWithVar' which automatically computes
+-- the type via 'typeOf'.
+disintegrateInCtx
+    :: (ABT Term abt)
+    => TransformCtx
+    -> abt '[] ('HMeasure (HPair a b))
+    -> [abt '[] (a ':-> 'HMeasure b)]
+disintegrateInCtx ctx m =
+    disintegrateWithVar
+        ctx
+        Text.empty
+        (fst . sUnPair . sUnMeasure $ typeOf m) -- TODO: change the exception thrown form 'typeOf' so that we know it comes from here
+        m
+
+-- | A variant of 'disintegrateInCtx' which takes the context to be the minimal
+-- one. Calling this function is only really valid on top-level programs, or
+-- subprograms in which the enclosing program doesn't bind any variables.
+disintegrate
+    :: (ABT Term abt)
+    => abt '[] ('HMeasure (HPair a b))
+    -> [abt '[] (a ':-> 'HMeasure b)]
+disintegrate = disintegrateInCtx minimalCtx
+
+-- | Return the density function for a given measure. The first two
+-- arguments give the hint and type of the lambda-bound variable
+-- in the result. If you want to automatically fill those in, then
+-- see 'density'.
+--
+-- TODO: is the resulting function guaranteed to be measurable? If
+-- so, update this documentation to reflect that fact; if not, then
+-- we should make it into a Haskell function instead.
+densityWithVar
+    :: (ABT Term abt)
+    => TransformCtx
+    -> Text.Text
+    -> Sing a
+    -> abt '[] ('HMeasure a)
+    -> [abt '[] (a ':-> 'HProb)]
+densityWithVar ctx hint typ m =
+    let x = Variable hint (nextFree m `max` nextBind m) typ
+    in (lam_ x . E.total) <$> observeInCtx ctx m (var x)
+
+
+-- | A variant of 'densityWithVar' which automatically computes the
+-- type via 'typeOf'.
+densityInCtx
+    :: (ABT Term abt)
+    => TransformCtx
+    -> abt '[] ('HMeasure a)
+    -> [abt '[] (a ':-> 'HProb)]
+densityInCtx ctx m =
+    densityWithVar
+        ctx
+        Text.empty
+        (sUnMeasure $ typeOf m)
+        m
+
+density
+    :: (ABT Term abt)
+    => abt '[] ('HMeasure a)
+    -> [abt '[] (a ':-> 'HProb)]
+density = densityInCtx minimalCtx
+
+-- | Constrain a measure such that it must return the observed
+-- value. In other words, the resulting measure returns the observed
+-- value with weight according to its density in the original
+-- measure, and gives all other values weight zero.
+observeInCtx
+    :: (ABT Term abt)
+    => TransformCtx
+    -> abt '[] ('HMeasure a)
+    -> abt '[] a
+    -> [abt '[] ('HMeasure a)]
+observeInCtx ctx m x =
+    runDisInCtx ctx (constrainOutcome x m >> return x) [Some2 m, Some2 x]
+
+observe
+    :: (ABT Term abt)
+    => abt '[] ('HMeasure a)
+    -> abt '[] a
+    -> [abt '[] ('HMeasure a)]
+observe = observeInCtx minimalCtx
+
+-- | Arbitrarily choose one of the possible alternatives. In the
+-- future, this function should be replaced by a better one that
+-- takes some sort of strategy for deciding which alternative to
+-- choose.
+determine :: (ABT Term abt) => [abt '[] a] -> Maybe (abt '[] a)
+determine []    = Nothing
+determine (m:_) = Just m
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- N.B., forward disintegration is not identical to partial evaluation,
+-- as noted at the top of the file. For correctness we need to
+-- ensure the result is emissible (i.e., has no heap-bound variables).
+-- More specifically, we need to ensure emissibility in the places
+-- where we call 'emitMBind'
+evaluate_ :: (ABT Term abt) => TermEvaluator abt (Dis abt)
+evaluate_ = evaluate perform
+
+evaluateDatum :: (ABT Term abt) => DatumEvaluator (abt '[]) (Dis abt)
+evaluateDatum e = viewWhnfDatum <$> evaluate_ e
+
+-- | Simulate performing 'HMeasure' actions by simply emitting code
+-- for those actions, returning the bound variable.
+--
+-- This is the function called @(|>>)@ in the disintegration paper.
+perform :: forall abt. (ABT Term abt) => MeasureEvaluator abt (Dis abt)
+perform = \e0 ->
+#ifdef __TRACE_DISINTEGRATE__
+    getStatements >>= \ss ->
+    getExtras >>= \extras ->
+    getIndices >>= \inds ->
+    trace ("\n-- perform --\n"
+        ++ "at " ++ show (ppInds inds) ++ "\n"
+        ++ show (prettyExtras extras) ++ "\n"
+        ++ show (pretty_Statements_withTerm ss e0)
+        ++ "\n") $
+#endif
+    caseVarSyn e0 performVar performTerm
+    where
+    performTerm :: forall a. Term abt ('HMeasure a) -> Dis abt (Whnf abt a)
+    performTerm (Dirac :$ e1 :* End)       = evaluate_ e1
+    performTerm (MeasureOp_ o :$ es)       = performMeasureOp o es
+    performTerm (MBind :$ e1 :* e2 :* End) =
+        caseBind e2 $ \x e2' -> do
+            inds <- getIndices
+            push (SBind x (Thunk e1) inds) e2' >>= perform
+
+    performTerm (Plate :$ e1 :* e2 :* End) =  do
+      x1 <- pushPlate e1 e2
+      return $ fromJust (toWhnf x1)
+
+    performTerm (Superpose_ pes) = do
+        inds <- getIndices
+        if not (null inds) && L.length pes > 1 then bot else
+          emitFork_ (P.superpose . fmap ((,) P.one))
+                    (fmap (\(p,e) -> push (SWeight (Thunk p) inds) e >>= perform)
+                          pes)
+
+    -- Avoid falling through to the @performWhnf <=< evaluate_@ case
+    performTerm (Let_ :$ e1 :* e2 :* End) =
+        caseBind e2 $ \x e2' -> do
+            inds <- getIndices
+            push (SLet x (Thunk e1) inds) e2' >>= perform
+
+    -- TODO: we could optimize this by calling some @evaluateTerm@
+    -- directly, rather than calling 'syn' to rebuild @e0@ from
+    -- @t0@ and then calling 'evaluate_' (which will just use
+    -- 'caseVarSyn' to get the @t0@ back out from the @e0@).
+    performTerm t0 = do
+        w <- evaluate_ (syn t0)
+#ifdef __TRACE_DISINTEGRATE__
+        trace ("-- perform: finished evaluate, with:\n" ++ show (PP.sep(prettyPrec_ 11 w))) $ return ()
+#endif
+        performWhnf w
+
+
+    performVar :: forall a. Variable ('HMeasure a) -> Dis abt (Whnf abt a)
+    performVar = performWhnf <=< evaluateVar perform evaluate_
+
+    performWhnf
+        :: forall a. Whnf abt ('HMeasure a) -> Dis abt (Whnf abt a)
+    performWhnf (Head_   v) = perform $ fromHead v
+    performWhnf (Neutral e) = (Neutral . var) <$>
+                              (emitMBind . fromWhnf =<< atomize e)
+
+
+    -- TODO: right now we do the simplest thing. However, for better
+    -- coverage and cleaner produced code we'll need to handle each
+    -- of the ops separately. (For example, see how 'Uniform' is
+    -- handled in the old code; how it has two options for what to
+    -- do.)
+    performMeasureOp
+        :: forall typs args a
+        .  (typs ~ UnLCs args, args ~ LCs typs)
+        => MeasureOp typs a
+        -> SArgs abt args
+        -> Dis abt (Whnf abt a)
+    performMeasureOp = \o es -> nice o es <|> complete o es
+        where
+        -- Try to generate nice pretty output.
+        nice
+            :: MeasureOp typs a
+            -> SArgs abt args
+            -> Dis abt (Whnf abt a)
+        nice o es = do
+            es' <- traverse21 atomizeCore es
+            x   <- emitMBind2 $ syn (MeasureOp_ o :$ es')
+            -- return (Neutral $ var x)
+            return (Neutral x)
+
+        -- Try to be as complete as possible (i.e., 'bot' as little as
+        -- possible), no matter how ugly the output code gets.
+        complete
+            :: MeasureOp typs a
+            -> SArgs abt args
+            -> Dis abt (Whnf abt a)
+        complete Normal = \(mu :* sd :* End) -> do
+            x <- var <$> emitMBind P.lebesgue
+            pushWeight (P.densityNormal mu sd x)
+            return (Neutral x)
+        complete Uniform = \(lo :* hi :* End) -> do
+            x <- var <$> emitMBind P.lebesgue
+            pushGuard (lo P.< x P.&& x P.< hi)
+            pushWeight (P.densityUniform lo hi x)
+            return (Neutral x)
+        complete _ = \_ -> bot
+                               
+
+-- | The goal of this function is to ensure the correctness criterion
+-- that given any term to be emitted, the resulting term is
+-- semantically equivalent but contains no heap-bound variables.
+-- That correctness criterion is necessary to ensure hygiene\/scoping.
+--
+-- This particular implementation calls 'evaluate' recursively,
+-- giving us something similar to full-beta reduction. However,
+-- that is considered an implementation detail rather than part of
+-- the specification of what the function should do. Also, it's a
+-- gross hack and prolly a big part of why we keep running into
+-- infinite looping issues.
+--
+-- This name is taken from the old finally tagless code, where
+-- \"atomic\" terms are (among other things) emissible; i.e., contain
+-- no heap-bound variables.
+--
+-- BUG: this function infinitely loops in certain circumstances
+-- (namely when dealing with neutral terms)
+atomize :: (ABT Term abt) => TermEvaluator abt (Dis abt)
+atomize e =
+#ifdef __TRACE_DISINTEGRATE__
+    trace ("\n-- atomize --\n" ++ show (pretty e)) $
+#endif
+    do whnf <- evaluate_ e
+       case whnf of
+         Head_ v   -> Head_ <$> traverse21 atomizeCore v
+         Neutral e -> Neutral . unviewABT <$>
+                      traverse12 (traverse21 atomizeCore) (viewABT e)             
+
+
+-- | A variant of 'atomize' which is polymorphic in the locally
+-- bound variables @xs@ (whereas 'atomize' requires @xs ~ '[]@).
+-- We factored this out because we often want this more polymorphic
+-- variant when using our indexed @TraversableMN@ classes.
+atomizeCore :: (ABT Term abt) => abt xs a -> Dis abt (abt xs a)
+atomizeCore e =
+    -- HACK: this check for 'disjointVarSet' is sufficient to catch
+    -- the particular infinite loops we were encountering, but it
+    -- will not catch all of them. If the call to 'evaluate_' in
+    -- 'atomize' returns a neutral term which contains heap-bound
+    -- variables, then we'll still loop forever since we don't
+    -- traverse\/fmap over the top-level term constructor of neutral
+    -- terms.    
+ do xs <- getHeapVars
+    vs <- extFreeVars e
+    if disjointVarSet xs vs
+        then return e
+        else
+            let (ys, e') = caseBinds e
+            in
+#ifdef __TRACE_DISINTEGRATE__
+               trace ("\n-- atomizeCore --\n" ++ show (pretty e')) $
+#endif
+               (binds_ ys . fromWhnf) <$> atomize e'
+    where
+    -- TODO: does @IM.null . IM.intersection@ fuse correctly?
+    disjointVarSet xs ys =
+        IM.null (IM.intersection (unVarSet xs) (unVarSet ys))
+
+-- HACK: if we really want to go through with this approach, then
+-- we should memoize the set of heap-bound variables in the
+-- 'ListContext' itself rather than recomputing it every time!
+getHeapVars :: Dis abt (VarSet ('KProxy :: KProxy Hakaru))
+getHeapVars =
+    Dis $ \_ c h -> c (foldMap statementVars (statements h)) h
+
+----------------------------------------------------------------
+-- | Given an emissible term @v0@ (the first argument) and another
+-- term @e0@ (the second argument), compute the constraints such
+-- that @e0@ must evaluate to @v0@. This is the function called
+-- @(<|)@ in the disintegration paper, though notably we swap the
+-- argument order so that the \"value\" is the first argument.
+--
+-- N.B., this function assumes (and does not verify) that the first
+-- argument is emissible. So callers (including recursive calls)
+-- must guarantee this invariant, by calling 'atomize' as necessary.
+--
+-- TODO: capture the emissibility requirement on the first argument
+-- in the types, to help avoid accidentally passing the arguments
+-- in the wrong order!
+constrainValue :: (ABT Term abt) => abt '[] a -> abt '[] a -> Dis abt ()
+constrainValue v0 e0 =
+#ifdef __TRACE_DISINTEGRATE__
+    getStatements >>= \ss ->
+    getExtras >>= \extras ->
+    getIndices >>= \inds ->
+    trace ("\n-- constrainValue: " ++ show (pretty v0) ++ "\n"           
+        ++ show (pretty_Statements_withTerm ss e0) ++ "\n"
+        ++ "at " ++ show (ppInds inds) ++ "\n"
+        ++ show (prettyExtras extras) ++ "\n"
+          ) $
+#endif
+    caseVarSyn e0 (constrainVariable v0) $ \t ->
+        case t of
+        -- There's a bunch of stuff we don't even bother trying to handle
+        Empty_   _               -> error "TODO: disintegrate empty arrays"
+        Array_   n e             ->
+            caseBind e $ \x body -> do j <- freshInd n
+                                       let x'    = indVar j
+                                       body' <- extSubst x (var x') body
+                                       inds  <- getIndices
+                                       withIndices (extendIndices j inds) $
+                                                   constrainValue (v0 P.! (var x')) body'
+                                                   -- TODO use meta-index
+        ArrayLiteral_ _          -> error "TODO: disintegrate literal arrays"
+        ArrayOp_ o :$ args       -> constrainValueArrayOp v0 o args
+        Lam_  :$ _  :* End       -> error "TODO: disintegrate lambdas"
+        App_  :$ _  :* _ :* End  -> error "TODO: disintegrate lambdas"
+        Integrate :$ _ :* _ :* _ :* End ->
+            error "TODO: disintegrate integration"
+        Summate _ _ :$ _ :* _ :* _ :* End ->
+            error "TODO: disintegrate integration"
+
+
+        -- N.B., the semantically correct definition is:
+        --
+        -- > Literal_ v
+        -- >     | "dirac v has a density wrt the ambient measure" -> ...
+        -- >     | otherwise -> bot
+        --
+        -- For the case where the ambient measure is Lebesgue, dirac
+        -- doesn't have a density, so we return 'bot'. However, we
+        -- will need to generalize this when we start handling other
+        -- ambient measures.
+        Literal_ v               -> bot -- unsolvable. (kinda; see note)
+        Datum_   d               -> constrainDatum v0 d
+        Dirac :$ _ :* End        -> bot -- giving up.
+        MBind :$ _ :* _ :* End   -> bot -- giving up.
+        MeasureOp_ o :$ es       -> constrainValueMeasureOp v0 o es
+        Superpose_ pes           -> bot -- giving up.
+        Reject_ _                -> bot -- giving up.
+        Let_ :$ e1 :* e2 :* End ->
+            caseBind e2 $ \x e2' ->
+                push (SLet x (Thunk e1) []) e2' >>= constrainValue v0
+
+        CoerceTo_   c :$ e1 :* End ->
+            -- TODO: we need to insert some kind of guard that says
+            -- @v0@ is in the range of @coerceTo c@, or equivalently
+            -- that @unsafeFrom c v0@ will always succeed. We need
+            -- to emit this guard (for correctness of the generated
+            -- program) because if @v0@ isn't in the range of the
+            -- coercion, then there's no possible way the program
+            -- @e1@ could in fact be observed at @v0@. The only
+            -- question is how to perform that check; for the
+            -- 'Signed' coercions it's easy enough, but for the
+            -- 'Continuous' coercions it's not really clear.
+            constrainValue (P.unsafeFrom_ c v0) e1
+        UnsafeFrom_ c :$ e1 :* End ->
+            -- TODO: to avoid returning garbage, we'd need to place
+            -- some constraint on @e1@ so that if the original
+            -- program would've crashed due to a bad unsafe-coercion,
+            -- then we won't return a disintegrated program (since
+            -- it too should always crash). Avoiding this check is
+            -- sound (i.e., if the input program is well-formed
+            -- then the output program is a well-formed disintegration),
+            -- it just overgeneralizes.
+            constrainValue  (P.coerceTo_ c v0) e1
+        NaryOp_     o    es        -> constrainNaryOp v0 o es
+        PrimOp_     o :$ es        -> constrainPrimOp v0 o es
+
+        Transform_ t :$ _            -> error $
+          concat["constrainValue{", show t, "}"
+                ,": cannot yet disintegrate transforms; expand them first"]
+
+        Case_ e bs ->
+            -- First we try going forward on the scrutinee, to make
+            -- pretty resulting programs; but if that doesn't work
+            -- out, we fall back to just constraining the branches.
+            do  match <- matchBranches evaluateDatum e bs
+                case match of
+                    Nothing ->
+                        -- If desired, we could return the Hakaru program
+                        -- that always crashes, instead of throwing a
+                        -- Haskell error.
+                        error "constrainValue{Case_}: nothing matched!"
+                    Just GotStuck ->
+                        constrainBranches v0 e bs
+                    Just (Matched rho body) ->
+                        pushes (toVarStatements rho) body >>= constrainValue v0
+            <|> constrainBranches v0 e bs
+
+        _ :$ _ -> error "constrainValue: the impossible happened"
+
+
+-- | The default way of doing 'constrainValue' on a 'Case_' expression:
+-- by constraining each branch. To do this we rely on the fact that
+-- we're in a 'HMeasure' context (i.e., the continuation produces
+-- programs of 'HMeasure' type). For each branch we first assert the
+-- branch's pattern holds (via 'SGuard') and then call 'constrainValue'
+-- on the body of the branch; and the final program is the superposition
+-- of all these branches.
+--
+-- TODO: how can we avoid duplicating the scrutinee expression?
+-- Would pushing a 'SLet' statement before the superpose be sufficient
+-- to achieve maximal sharing?
+constrainBranches
+    :: (ABT Term abt)
+    => abt '[] a
+    -> abt '[] b
+    -> [Branch b abt a]
+    -> Dis abt ()
+constrainBranches v0 e = choose . map constrainBranch
+    where
+    constrainBranch (Branch pat body) =
+        let (vars,body') = caseBinds body
+        in push (SGuard vars pat (Thunk e) []) body'
+               >>= constrainValue v0
+
+
+constrainDatum
+    :: (ABT Term abt) => abt '[] a -> Datum (abt '[]) a -> Dis abt ()
+constrainDatum v0 d =
+    case patternOfDatum d of
+    PatternOfDatum pat es -> do
+        xs <- freshVars $ fmap11 (Hint Text.empty . typeOf) es
+        emit_ $ \body ->
+            syn $ Case_ v0
+                [ Branch pat (binds_ xs body)
+                , Branch PWild (P.reject $ (typeOf body))
+                ]
+        constrainValues xs es
+
+constrainValues
+    :: (ABT Term abt)
+    => List1 Variable  xs
+    -> List1 (abt '[]) xs
+    -> Dis abt ()
+constrainValues (Cons1 x xs) (Cons1 e es) =
+    constrainValue (var x) e >> constrainValues xs es
+constrainValues Nil1 Nil1 = return ()
+constrainValues _ _ = error "constrainValues: the impossible happened"
+
+
+data PatternOfDatum (ast :: Hakaru -> *) (a :: Hakaru) =
+    forall xs. PatternOfDatum
+        !(Pattern xs a)
+        !(List1 ast xs)
+
+-- | Given a datum, return the pattern which will match it along
+-- with the subexpressions which would be bound to patter-variables.
+patternOfDatum :: Datum ast a -> PatternOfDatum ast a
+patternOfDatum =
+    \(Datum hint _typ d) ->
+        podCode d $ \p es ->
+        PatternOfDatum (PDatum hint p) es
+    where
+    podCode
+        :: DatumCode xss ast a
+        -> (forall bs. PDatumCode xss bs a -> List1 ast bs -> r)
+        -> r
+    podCode (Inr d) k = podCode   d $ \ p es -> k (PInr p) es
+    podCode (Inl d) k = podStruct d $ \ p es -> k (PInl p) es
+
+    podStruct
+        :: DatumStruct xs ast a
+        -> (forall bs. PDatumStruct xs bs a -> List1 ast bs -> r)
+        -> r
+    podStruct (Et d1 d2) k =
+        podFun    d1 $ \p1 es1 ->
+        podStruct d2 $ \p2 es2 ->
+        k (PEt p1 p2) (es1 `append1` es2)
+    podStruct Done k = k PDone Nil1
+
+    podFun
+        :: DatumFun x ast a
+        -> (forall bs. PDatumFun x bs a -> List1 ast bs -> r)
+        -> r
+    podFun (Konst e) k = k (PKonst PVar) (Cons1 e Nil1)
+    podFun (Ident e) k = k (PIdent PVar) (Cons1 e Nil1)
+
+
+----------------------------------------------------------------
+-- | N.B., as with 'constrainValue', we assume that the first
+-- argument is emissible. So it is the caller's responsibility to
+-- ensure this (by calling 'atomize' as appropriate).
+--
+-- TODO: capture the emissibility requirement on the first argument
+-- in the types.
+constrainVariable
+    :: (ABT Term abt) => abt '[] a -> Variable a -> Dis abt ()
+constrainVariable v0 x =
+    do extras <- getExtras
+    -- If we get 'Nothing', then it turns out @x@ is a free variable.
+    -- If @x@ is a free variable, then it's a neutral term; and we
+    -- return 'bot' for neutral terms
+       maybe bot lookForLoc (lookupAssoc x extras)
+    where lookForLoc (Loc      l jxs) =
+              -- If we get 'Nothing', then it turns out @l@ is a free
+              -- location. This is an error because of the
+              -- invariant:
+              --   if there exists an 'Assoc x (Loc l _)' inside @extras@
+              --   then there must be a statement on the 'ListContext' that binds @l@
+              (maybe (freeLocError l) return =<<) . select l $ \s ->
+                  case s of
+                    SBind l' e ixs -> do
+                           Refl <- locEq l l'
+                           guard (length ixs == length jxs) -- will error otherwise
+                           Just $ do
+                             inds <- getIndices
+                             guard (jxs `permutes` inds) -- will bot otherwise
+                             e' <- apply ixs inds (fromLazy e)
+                             constrainOutcome v0 e'
+                             unsafePush (SLet l (Whnf_ (Neutral v0)) inds)
+                    SLet  l' e ixs -> do
+                           Refl <- locEq l l'
+                           guard (length ixs == length jxs) -- will error otherwise
+                           Just $ do
+                             inds <- getIndices
+                             guard (jxs `permutes` inds) -- will bot otherwise
+                             e' <- apply ixs inds (fromLazy e)
+                             constrainValue v0 e'
+                             unsafePush (SLet l (Whnf_ (Neutral v0)) inds)
+                    SWeight _ _ -> Nothing
+                    SGuard ls' pat scrutinee i -> error "TODO: constrainVariable{SGuard}"
+
+----------------------------------------------------------------
+-- | N.B., as with 'constrainValue', we assume that the first
+-- argument is emissible. So it is the caller's responsibility to
+-- ensure this (by calling 'atomize' as appropriate).
+--
+-- TODO: capture the emissibility requirement on the first argument
+-- in the types.
+constrainValueArrayOp
+    :: forall abt typs args a
+    .  (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => abt '[] a
+    -> ArrayOp typs a
+    -> SArgs abt args
+    -> Dis abt ()
+constrainValueArrayOp v0 = go
+    where
+      go :: ArrayOp typs a -> SArgs abt args -> Dis abt ()
+      go (Index  _) (e1 :* e2 :* End) = do
+        w1 <- evaluate_ e1
+        case w1 of
+          Neutral e1' -> bot
+          Head_ (WArray _ b) -> caseBind b $ \x body ->
+                                extSubst x e2 body >>= constrainValue v0
+          Head_ (WEmpty _) -> bot -- TODO: check this
+          Head_ a@(WArrayLiteral _) -> constrainValueIdxArrLit v0 e2 a
+          _ -> error "constrainValue {ArrayOp Index}: uknown whnf of array type"
+      go (Size   _) _ = error "TODO: disintegrate {ArrayOp Size}"
+      go (Reduce _) _ = error "TODO: disintegrate {ArrayOp Reduce}"
+      go _ _ = error "constrainValueArrayOp: unknown arrayOp"
+
+
+-- | Special case for [true,false] ! i, and [false, true] ! i
+-- This helps us disintegrate bern                                                    
+constrainValueIdxArrLit
+     :: forall abt a
+     .  (ABT Term abt)
+     => abt '[] a
+     -> abt '[] 'HNat
+     -> Head abt ('HArray a)
+     -> Dis abt ()
+constrainValueIdxArrLit v0 e2 = go
+    where
+      go :: Head abt ('HArray a) -> Dis abt ()
+      go (WArrayLiteral [a1,a2]) =
+          case (jmEq1 (typeOf v0) sBool) of
+            Just Refl ->
+                let constrainInd = flip constrainValue e2
+                in case (isLitBool a1, isLitBool a2) of
+                     (Just b1, Just b2)
+                         | isLitTrue b1 && isLitFalse b2 ->
+                             constrainInd $ P.if_ v0 (P.nat_ 0) (P.nat_ 1) 
+                         | isLitTrue b2 && isLitFalse b1 ->
+                             constrainInd $ P.if_ v0 (P.nat_ 1) (P.nat_ 0)
+                         | otherwise -> error "constrainValue: cannot invert (Index [b,b] i)"
+                     _ -> error "TODO: constrainValue (Index [b1,b2] i)"
+            Nothing -> error "TODO: constrainValue (Index [a1,a2] i)"
+      go (WArrayLiteral _) = bot
+      go _ = error "constrainValueIdxArrLit: unknown ArrayLiteral form"
+
+-- | Helpers for disintegrating bern             
+isLitBool :: (ABT Term abt) => abt '[] a -> Maybe (Datum (abt '[]) HBool)
+isLitBool e = caseVarSyn e (const Nothing) $ \b ->
+                  case b of
+                    Datum_ d@(Datum _ typ _) -> case (jmEq1 typ sBool) of
+                                                  Just Refl -> Just d
+                                                  Nothing   -> Nothing
+                    _ -> Nothing
+
+isLitTrue :: (ABT Term abt) => Datum (abt '[]) HBool -> Bool
+isLitTrue (Datum tdTrue sBool (Inl Done)) = True
+isLitTrue _                               = False
+
+isLitFalse :: (ABT Term abt) => Datum (abt '[]) HBool -> Bool
+isLitFalse (Datum tdFalse sBool (Inr (Inl Done))) = True
+isLitFalse _                                      = False             
+
+----------------------------------------------------------------
+-- | N.B., as with 'constrainValue', we assume that the first
+-- argument is emissible. So it is the caller's responsibility to
+-- ensure this (by calling 'atomize' as appropriate).
+--
+-- TODO: capture the emissibility requirement on the first argument
+-- in the types.
+constrainValueMeasureOp
+    :: forall abt typs args a
+    .  (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => abt '[] ('HMeasure a)
+    -> MeasureOp typs a
+    -> SArgs abt args
+    -> Dis abt ()
+constrainValueMeasureOp v0 = go
+    where
+    -- TODO: for Lebesgue and Counting we use @bot@ because that's
+    -- what the old finally-tagless code seems to have been doing.
+    -- But is that right, or should they really be @return ()@?
+    go :: MeasureOp typs a -> SArgs abt args -> Dis abt ()
+    go Lebesgue    = \(e1 :* e2 :* End) ->
+        constrainValue v0 (P.lebesgue' e1 e2)
+    go Counting    = \End               -> bot -- TODO: see note above
+    go Categorical = \(e1 :* End)       ->
+        constrainValue v0 (P.categorical e1)
+    go Uniform     = \(e1 :* e2 :* End) ->
+        constrainValue v0 (P.uniform' e1 e2)
+    go Normal      = \(e1 :* e2 :* End) ->
+        constrainValue v0 (P.normal'  e1 e2)
+    go Poisson     = \(e1 :* End)       ->
+        constrainValue v0 (P.poisson' e1)
+    go Gamma       = \(e1 :* e2 :* End) ->
+        constrainValue v0 (P.gamma'   e1 e2)
+    go Beta        = \(e1 :* e2 :* End) ->
+        constrainValue v0 (P.beta'    e1 e2)
+
+----------------------------------------------------------------
+-- | N.B., We assume that the first argument, @v0@, is already
+-- atomized. So, this must be ensured before recursing, but we can
+-- assume it's already been done by the IH.
+--
+-- N.B., we also rely on the fact that our 'HSemiring' instances
+-- are actually all /commutative/ semirings. If that ever becomes
+-- not the case, then we'll need to fix things here.
+--
+-- As written, this will do a lot of redundant work in atomizing
+-- the subterms other than the one we choose to go backward on.
+-- Because evaluation has side-effects on the heap and is heap
+-- dependent, it seems like there may not be a way around that
+-- issue. (I.e., we could use dynamic programming to efficiently
+-- build up the 'M' computations, but not to evaluate them.) Of
+-- course, really we shouldn't be relying on the structure of the
+-- program here; really we should be looking at the heap-bound
+-- variables in the term: choosing each @x@ to go backward on, treat
+-- the term as a function of @x@, atomize that function (hence going
+-- forward on the rest of the variables), and then invert it and
+-- get the Jacobian.
+--
+-- TODO: find some way to capture in the type that the first argument
+-- must be emissible.
+constrainNaryOp
+    :: (ABT Term abt)
+    => abt '[] a
+    -> NaryOp a
+    -> Seq (abt '[] a)
+    -> Dis abt ()
+constrainNaryOp v0 o =
+    case o of
+    Sum theSemi ->
+        lubSeq $ \es1 e es2 -> do
+            u <- atomize $ syn (NaryOp_ (Sum theSemi) (es1 S.>< es2))
+            v <- evaluate_ $ P.unsafeMinus_ theSemi v0 (fromWhnf u)
+            constrainValue (fromWhnf v) e
+    Prod theSemi ->
+        lubSeq $ \es1 e es2 -> do
+            u <- atomize $ syn (NaryOp_ (Prod theSemi) (es1 S.>< es2))
+            let u' = fromWhnf u -- TODO: emitLet?
+            emitWeight $ P.recip (toProb_abs theSemi u')
+            v <- evaluate_ $ P.unsafeDiv_ theSemi v0 u'
+            constrainValue (fromWhnf v) e
+    Max theOrd ->
+        chooseSeq $ \es1 e es2 -> do
+            u <- atomize $ syn (NaryOp_ (Max theOrd) (es1 S.>< es2))
+            emitGuard $ P.primOp2_ (Less theOrd) (fromWhnf u) v0
+            constrainValue v0 e
+    _ -> error $ "TODO: constrainNaryOp{" ++ show o ++ "}"
+
+
+-- TODO: if this function (or the component @toProb@ and @semiringAbs@
+-- parts) turn out to be useful elsewhere, then we should move it
+-- to the Prelude.
+toProb_abs :: (ABT Term abt) => HSemiring a -> abt '[] a -> abt '[] 'HProb
+toProb_abs HSemiring_Nat  = P.nat2prob
+toProb_abs HSemiring_Int  = P.nat2prob . P.abs_
+toProb_abs HSemiring_Prob = id
+toProb_abs HSemiring_Real = P.abs_
+
+
+-- TODO: is there any way to optimise the zippering over the Seq, a la
+-- 'S.inits' or 'S.tails'?
+-- TODO: really we want a dynamic programming
+-- approach to avoid unnecessary repetition of calling @evaluateNaryOp
+-- evaluate_@ on the two subsequences...
+lubSeq :: (Alternative m) => (Seq a -> a -> Seq a -> m b) -> Seq a -> m b
+lubSeq f = go S.empty
+    where
+    go xs ys =
+        case S.viewl ys of
+        S.EmptyL   -> empty
+        y S.:< ys' -> f xs y ys' <|> go (xs S.|> y) ys'
+
+chooseSeq :: (ABT Term abt)
+          => (Seq a -> a -> Seq a -> Dis abt b)
+          -> Seq a
+          -> Dis abt b
+chooseSeq f = choose  . go S.empty
+    where
+    go xs ys =
+        case S.viewl ys of
+        S.EmptyL   -> []
+        y S.:< ys' -> f xs y ys' : go (xs S.|> y) ys'
+
+
+----------------------------------------------------------------
+-- HACK: for a lot of these, we can't use the prelude functions
+-- because Haskell can't figure out our polymorphism, so we have
+-- to define our own versions for manually passing dictionaries
+-- around.
+--
+-- | N.B., We assume that the first argument, @v0@, is already
+-- atomized. So, this must be ensured before recursing, but we can
+-- assume it's already been done by the IH.
+--
+-- TODO: find some way to capture in the type that the first argument
+-- must be emissible.
+constrainPrimOp
+    :: forall abt typs args a
+    .  (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => abt '[] a
+    -> PrimOp typs a
+    -> SArgs abt args
+    -> Dis abt ()
+constrainPrimOp v0 = go
+    where
+    error_TODO op = error $ "TODO: constrainPrimOp{" ++ op ++"}"
+
+    go :: PrimOp typs a -> SArgs abt args -> Dis abt ()
+    go Not  = \(e1 :* End)       -> error_TODO "Not"
+    go Impl = \(e1 :* e2 :* End) -> error_TODO "Impl"
+    go Diff = \(e1 :* e2 :* End) -> error_TODO "Diff"
+    go Nand = \(e1 :* e2 :* End) -> error_TODO "Nand"
+    go Nor  = \(e1 :* e2 :* End) -> error_TODO "Nor"
+
+    go Pi = \End -> bot -- because @dirac pi@ has no density wrt lebesgue
+
+    go Sin = \(e1 :* End) -> do
+        x0 <- emitLet' v0
+        n  <- var <$> emitMBind P.counting
+        let tau_n = P.real_ 2 P.* P.fromInt n P.* P.pi -- TODO: emitLet?
+        emitGuard (P.negate P.one P.< x0 P.&& x0 P.< P.one)
+        v  <- var <$> emitSuperpose
+            [ P.dirac (tau_n P.+ P.asin x0)
+            , P.dirac (tau_n P.+ P.pi P.- P.asin x0)
+            ]
+        emitWeight
+            . P.recip
+            . P.sqrt
+            . P.unsafeProb
+            $ (P.one P.- x0 P.^ P.nat_ 2)
+        constrainValue v e1
+
+    go Cos = \(e1 :* End) -> do
+        x0 <- emitLet' v0
+        n  <- var <$> emitMBind P.counting
+        let tau_n = P.real_ 2 P.* P.fromInt n P.* P.pi
+        emitGuard (P.negate P.one P.< x0 P.&& x0 P.< P.one)
+        r  <- emitLet' (tau_n P.+ P.acos x0)
+        v  <- var <$> emitSuperpose [P.dirac r, P.dirac (r P.+ P.pi)]
+        emitWeight
+            . P.recip
+            . P.sqrt
+            . P.unsafeProb
+            $ (P.one P.- x0 P.^ P.nat_ 2)
+        constrainValue v e1
+
+    go Tan = \(e1 :* End) -> do
+        x0 <- emitLet' v0
+        n  <- var <$> emitMBind P.counting
+        r  <- emitLet' (P.fromInt n P.* P.pi P.+ P.atan x0)
+        emitWeight $ P.recip (P.one P.+ P.square x0)
+        constrainValue r e1
+
+    go Asin = \(e1 :* End) -> do
+        x0 <- emitLet' v0
+        emitWeight $ P.unsafeProb (P.cos x0)
+        -- TODO: bounds check for -pi/2 <= v0 < pi/2
+        constrainValue (P.sin x0) e1
+
+    go Acos = \(e1 :* End) -> do
+        x0 <- emitLet' v0
+        emitWeight $ P.unsafeProb (P.sin x0)
+        constrainValue (P.cos x0) e1
+
+    go Atan = \(e1 :* End) -> do
+        x0 <- emitLet' v0
+        emitWeight $ P.recip (P.unsafeProb (P.cos x0 P.^ P.nat_ 2))
+        constrainValue (P.tan x0) e1
+
+    go Sinh      = \(e1 :* End)       -> error_TODO "Sinh"
+    go Cosh      = \(e1 :* End)       -> error_TODO "Cosh"
+    go Tanh      = \(e1 :* End)       -> error_TODO "Tanh"
+    go Asinh     = \(e1 :* End)       -> error_TODO "Asinh"
+    go Acosh     = \(e1 :* End)       -> error_TODO "Acosh"
+    go Atanh     = \(e1 :* End)       -> error_TODO "Atanh"
+    go Choose    = \(e1 :* e2 :* End) -> error_TODO "Choose"
+    go Floor     = \(e1 :* End)       -> error_TODO "Floor"
+    go RealPow   = \(e1 :* e2 :* End) ->
+        -- TODO: There's a discrepancy between @(**)@ and @pow_@ in
+        -- the old code...
+        do
+            -- TODO: if @v1@ is 0 or 1 then bot. Maybe the @log v1@ in
+            -- @w@ takes care of the 0 case?
+            u <- emitLet' v0
+            -- either this from @(**)@:
+            --   emitGuard  $ P.zero P.< u
+            --   w <- atomize $ P.recip (P.abs (v0 P.* P.log v1))
+            --   emitWeight $ P.unsafeProb (fromWhnf w)
+            --   constrainValue (P.logBase v1 v0) e2
+            -- or this from @pow_@:
+            let w = P.recip (u P.* P.unsafeProb (P.abs (P.log e1)))
+            emitWeight w
+            constrainValue (P.log u P./ P.log e1) e2
+            -- end.
+        <|> do
+            -- TODO: if @v2@ is 0 then bot. Maybe the weight @w@ takes
+            -- care of this case?
+            u <- emitLet' v0
+            let ex = v0 P.** P.recip e2
+            -- either this from @(**)@:
+            --   emitGuard $ P.zero P.< u
+            --   w <- atomize $ abs (ex / (v2 * v0))
+            -- or this from @pow_@:
+            let w = P.abs (P.fromProb ex P./ (e2 P.* P.fromProb u))
+            -- end.
+            emitWeight $ P.unsafeProb w
+            constrainValue ex e1
+    go Exp = \(e1 :* End) -> do
+        x0 <- emitLet' v0
+        -- TODO: do we still want\/need the @emitGuard (0 < x0)@ which
+        -- is now equivalent to @emitGuard (0 /= x0)@ thanks to the
+        -- types?
+        emitWeight (P.recip x0)
+        constrainValue (P.log x0) e1
+
+    go Log = \(e1 :* End) -> do
+        exp_x0 <- emitLet' (P.exp v0)
+        emitWeight exp_x0
+        constrainValue exp_x0 e1
+
+    go (Infinity _)     = \End               -> error_TODO "Infinity" -- scalar0
+    go GammaFunc        = \(e1 :* End)       -> error_TODO "GammaFunc" -- scalar1
+    go BetaFunc         = \(e1 :* e2 :* End) -> error_TODO "BetaFunc" -- scalar2
+    go (Equal  theOrd)  = \(e1 :* e2 :* End) -> error_TODO "Equal"
+    go (Less   theOrd)  = \(e1 :* e2 :* End) -> error_TODO "Less"
+    go (NatPow theSemi) = \(e1 :* e2 :* End) -> error_TODO "NatPow"
+    go (Negate theRing) = \(e1 :* End) ->
+        -- TODO: figure out how to merge this implementation of @rr1
+        -- negate@ with the one in 'evaluatePrimOp' to DRY
+        -- TODO: just
+        -- emitLet the @v0@ and pass the neutral term to the recursive
+        -- call?
+        let negate_v0 = syn (PrimOp_ (Negate theRing) :$ v0 :* End)
+                -- case v0 of
+                -- Neutral e ->
+                --     Neutral $ syn (PrimOp_ (Negate theRing) :$ e :* End)
+                -- Head_ v ->
+                --     case theRing of
+                --     HRing_Int  -> Head_ . reflect . negate $ reify v
+                --     HRing_Real -> Head_ . reflect . negate $ reify v
+        in constrainValue negate_v0 e1
+
+    go (Abs theRing) = \(e1 :* End) -> do
+        let theSemi = hSemiring_HRing theRing
+            theOrd  =
+                case theRing of
+                HRing_Int  -> HOrd_Int
+                HRing_Real -> HOrd_Real
+            theEq   = hEq_HOrd theOrd
+            signed  = C.singletonCoercion (C.Signed theRing)
+            zero    = P.zero_ theSemi
+            lt      = P.primOp2_ $ Less   theOrd
+            eq      = P.primOp2_ $ Equal  theEq
+            neg     = P.primOp1_ $ Negate theRing
+
+        x0 <- emitLet' (P.coerceTo_ signed v0)
+        v  <- var <$> emitMBind
+            (P.if_ (lt zero x0)
+                (P.dirac x0 P.<|> P.dirac (neg x0))
+                (P.if_ (eq zero x0)
+                    (P.dirac zero)
+                    (P.reject . SMeasure $ typeOf zero)))
+        constrainValue v e1
+
+    go (Signum theRing) = \(e1 :* End) ->
+        case theRing of
+        HRing_Real -> bot
+        HRing_Int  -> do
+            x <- var <$> emitMBind P.counting
+            emitGuard $ P.signum x P.== v0
+            constrainValue x e1
+
+    go (Recip theFractional) = \(e1 :* End) -> do
+        x0 <- emitLet' v0
+        emitWeight
+            . P.recip
+            . P.unsafeProbFraction_ theFractional
+            -- TODO: define a dictionary-passing variant of 'P.square'
+            -- instead, to include the coercion in there explicitly...
+            $ square (hSemiring_HFractional theFractional) x0
+        constrainValue (P.primOp1_ (Recip theFractional) x0) e1
+
+    go (NatRoot theRadical) = \(e1 :* e2 :* End) ->
+        case theRadical of
+        HRadical_Prob -> do
+            x0 <- emitLet' v0
+            u2 <- fromWhnf <$> atomize e2
+            emitWeight (P.nat2prob u2 P.* x0)
+            constrainValue (x0 P.^ u2) e1
+
+    go (Erf theContinuous) = \(e1 :* End) ->
+        error "TODO: constrainPrimOp: need InvErf to disintegrate Erf"
+
+
+-- HACK: can't use @(P.^)@ because Haskell can't figure out our polymorphism
+square :: (ABT Term abt) => HSemiring a -> abt '[] a -> abt '[] a
+square theSemiring e =
+    syn (PrimOp_ (NatPow theSemiring) :$ e :* P.nat_ 2 :* End)
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: do we really want the first argument to be a term at all,
+-- or do we want something more general like patters for capturing
+-- measurable events?
+--
+-- | This is a helper function for 'constrainValue' to handle 'SBind'
+-- statements (just as the 'perform' argument to 'evaluate' is a
+-- helper for handling 'SBind' statements).
+--
+-- N.B., We assume that the first argument, @v0@, is already
+-- atomized. So, this must be ensured before recursing, but we can
+-- assume it's already been done by the IH. Technically, we con't
+-- care whether the first argument is in normal form or not, just
+-- so long as it doesn't contain any heap-bound variables.
+--
+-- This is the function called @(<<|)@ in the paper, though notably
+-- we swap the argument order.
+--
+-- TODO: find some way to capture in the type that the first argument
+-- must be emissible, to help avoid accidentally passing the arguments
+-- in the wrong order!
+--
+-- TODO: under what circumstances is @constrainOutcome x m@ different
+-- from @constrainValue x =<< perform m@? If they're always the
+-- same, then we should just use that as the definition in order
+-- to avoid repeating ourselves
+constrainOutcome
+    :: forall abt a
+    .  (ABT Term abt)
+    => abt '[] a
+    -> abt '[] ('HMeasure a)
+    -> Dis abt ()
+constrainOutcome v0 e0 =
+#ifdef __TRACE_DISINTEGRATE__
+    getExtras >>= \extras ->
+    getIndices >>= \inds ->
+    trace (
+        let s = "-- constrainOutcome"
+        in "\n" ++ s ++ ": "
+            ++ show (pretty v0)
+            ++ "\n" ++ replicate (length s) ' ' ++ ": "
+            ++ show (pretty e0) ++ "\n"
+            ++ "at " ++  show (ppInds inds) ++ "\n"
+            ++ show (prettyExtras extras)
+          ) $
+#endif
+    do  w0 <- evaluate_ e0
+        case w0 of
+            Neutral _ -> bot
+            Head_   v -> go v
+    where
+    impossible = error "constrainOutcome: the impossible happened"
+
+    go :: Head abt ('HMeasure a) -> Dis abt ()
+    go (WLiteral _)          = impossible
+    -- go (WDatum _)         = impossible
+    -- go (WEmpty _)         = impossible
+    -- go (WArray _ _)       = impossible
+    -- go (WLam _)           = impossible
+    -- go (WIntegrate _ _ _) = impossible
+    -- go (WSummate   _ _ _) = impossible
+    go (WCoerceTo   _ _)     = impossible
+    go (WUnsafeFrom _ _)     = impossible
+    go (WMeasureOp o es)     = constrainOutcomeMeasureOp v0 o es
+    go (WDirac e1)           = constrainValue v0 e1
+    go (WMBind e1 e2)        =
+        caseBind e2 $ \x e2' -> do
+            i <- getIndices
+            push (SBind x (Thunk e1) i) e2' >>= constrainOutcome v0
+    go (WPlate e1 e2)        = do
+        x' <- pushPlate e1 e2
+        constrainValue v0 x'
+
+    go (WChain e1 e2 e3)     = error "TODO: constrainOutcome{Chain}"
+    go (WReject typ)         = emit_ $ \m -> P.reject (typeOf m)
+    go (WSuperpose pes) = do
+        i <- getIndices
+        if not (null i) && L.length pes > 1 then bot else
+          emitFork_ (P.superpose . fmap ((,) P.one))
+                    (fmap (\(p,e) -> push (SWeight (Thunk p) i) e >>= constrainOutcome v0)
+                          pes)
+
+-- TODO: should this really be different from 'constrainValueMeasureOp'?
+--
+-- TODO: find some way to capture in the type that the first argument
+-- must be emissible.
+constrainOutcomeMeasureOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => abt '[] a
+    -> MeasureOp typs a
+    -> SArgs abt args
+    -> Dis abt ()
+constrainOutcomeMeasureOp v0 = go
+    where
+    go Lebesgue = \(lo :* hi :* End) -> do
+        -- TODO: optimize the cases where lo is -∞ or hi is ∞
+        v0' <- emitLet' v0
+        pushGuard (lo P.<= v0' P.&& v0' P.<= hi)
+
+    -- TODO: I think, based on Hakaru v0.2.0
+    go Counting = \End -> return ()
+
+    go Categorical = \(e1 :* End) -> do
+        -- TODO: check that v0' is < then length of e1
+        pushWeight (P.densityCategorical e1 v0)
+
+    -- Per the paper
+    go Uniform = \(lo :* hi :* End) -> do
+        v0' <- emitLet' v0
+        pushGuard (lo P.<= v0' P.&& v0' P.<= hi)
+        pushWeight (P.densityUniform lo hi v0')
+
+    -- TODO: Add fallback handling of Normal that does not atomize mu,sd.
+    -- This fallback is as if Normal were defined in terms of Lebesgue
+    -- and a density Weight.  This fallback is present in Hakaru v0.2.0
+    -- in order to disintegrate a program such as
+    --  x <~ normal(0,1)
+    --  y <~ normal(x,1)
+    --  return ((x+(y+y),x)::pair(real,real))
+    go Normal = \(mu :* sd :* End) -> do
+        -- N.B., if\/when extending this to higher dimensions, the
+        -- real equation is
+        -- @recip (sqrt (2*pi*sd^2) ^ n) *
+        --  exp (negate (norm_n (v0 - mu) ^ 2) /
+        --  (2*sd^2))@
+        -- for @Real^n@.
+        pushWeight (P.densityNormal mu sd v0)
+
+    go Poisson = \(e1 :* End) -> do
+        v0' <- emitLet' v0
+        pushGuard (P.nat_ 0 P.<= v0' P.&& P.prob_ 0 P.< e1)
+        pushWeight (P.densityPoisson e1 v0')
+
+    go Gamma = \(e1 :* e2 :* End) -> do
+        v0' <- emitLet' v0
+        pushGuard (P.prob_ 0 P.< v0' P.&&
+                   P.prob_ 0 P.< e1  P.&&
+                   P.prob_ 0 P.< e2)
+        pushWeight (P.densityGamma e1 e2 v0')
+    go Beta = \(e1 :* e2 :* End) -> do
+        v0' <- emitLet' v0
+        pushGuard (P.prob_ 0 P.<= v0' P.&&
+                   P.prob_ 1 P.>= v0' P.&&
+                   P.prob_ 0 P.< e1   P.&&
+                   P.prob_ 0 P.< e2)
+        pushWeight (P.densityBeta e1 e2 v0')
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Evaluation/Coalesce.hs b/haskell/Language/Hakaru/Evaluation/Coalesce.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Evaluation/Coalesce.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE DataKinds
+           , GADTs
+           , Rank2Types
+           , FlexibleContexts
+           #-}
+
+----------------------------------------------------------------
+--                                                    2016.07.19
+-- |
+-- Module      :  Language.Hakaru.Evaluation.Coalesce
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  zsulliva@indiana.edu
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+----------------------------------------------------------------
+
+module Language.Hakaru.Evaluation.Coalesce
+  ( coalesce )
+  where
+
+import qualified Language.Hakaru.Parser.AST as U
+import           Language.Hakaru.Syntax.ABT
+import qualified Data.Foldable              as F
+
+import Language.Hakaru.Syntax.IClasses
+
+coalesce
+    :: U.AST
+    -> U.AST
+coalesce =
+    cataABT_ alg
+    where
+    alg :: forall abt a. (ABT U.Term abt) => U.Term abt a -> abt '[] a
+    alg (U.NaryOp_ op args) = syn $ U.NaryOp_ op (coalesceNaryOp op args)
+    alg t                   = syn t
+
+coalesceNaryOp
+    :: (ABT U.Term abt)
+    => U.NaryOp
+    -> [abt '[] a]
+    -> [abt '[] a]
+coalesceNaryOp op = F.concatMap $ \ast' ->
+     caseVarSyn ast' (return . var) $ \t ->
+       case t of
+       U.NaryOp_ op' args' | op == op' -> coalesceNaryOp op args'
+       _                               -> [ast']
+
+
+type M  = MetaABT U.SourceSpan U.Term
+
+preserveMetadata
+   :: (M xs a -> M xs a)
+   -> M xs a
+   -> M xs a
+preserveMetadata f x =
+    case getMetadata x of
+      Nothing -> f x
+      Just s  -> withMetadata s (f x)
+
+cataABT_
+    :: (forall    a. U.Term M a -> M '[] a)
+    -> (forall xs a. M xs a     -> M xs  a)
+cataABT_ syn_ = start
+    where
+    start :: forall xs a. M xs a -> M xs a
+    start = preserveMetadata (loop . viewABT)
+
+    loop ::  forall xs a. View (U.Term M) xs a -> M xs a
+    loop (Syn  t)   = syn_  (fmap21 start t)
+    loop (Var  x)   = var  x
+    loop (Bind x e) = bind x (loop e)
diff --git a/haskell/Language/Hakaru/Evaluation/ConstantPropagation.hs b/haskell/Language/Hakaru/Evaluation/ConstantPropagation.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Evaluation/ConstantPropagation.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE Rank2Types                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE ViewPatterns               #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.02
+-- |
+-- Module      :  Language.Hakaru.Evaluation.ConstantPropagation
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--
+----------------------------------------------------------------
+module Language.Hakaru.Evaluation.ConstantPropagation
+    ( constantPropagation
+    ) where
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative                  (Applicative (..))
+import           Data.Functor                         ((<$>))
+#endif
+
+import           Control.Monad.Reader
+import           Data.Monoid                          (All (..))
+import           Language.Hakaru.Evaluation.EvalMonad (runPureEvaluate)
+import           Language.Hakaru.Syntax.ABT           (ABT (..), View (..))
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.IClasses      (Foldable21 (..),
+                                                       Traversable21 (..))
+import           Language.Hakaru.Syntax.Variable
+
+type Env = Assocs Literal
+
+-- The constant propagation monad. Simply threads through an environment mapping
+-- variables to known constant values.
+newtype PropM a = PropM { runPropM :: Reader Env a }
+  deriving (Functor, Applicative, Monad, MonadReader Env)
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: try evaluating certain things even if not all their immediate
+-- subterms are literals. For example:
+-- (1) evaluate beta-redexes where the argument is a literal
+-- (2) evaluate case-of-constructor if we can
+-- (3) handle identity elements for NaryOps
+-- (4) Recognize trivial cases for looping constructs:
+--     summate a b (const 0) == 0
+--     summate a b id        == b - a
+--     summate a b (const x) == x * (b - a)
+--
+-- | Perform basic constant propagation.
+constantPropagation
+  :: forall abt a . (ABT Term abt)
+  => abt '[] a
+  -> abt '[] a
+constantPropagation abt = runReader (runPropM $ constantProp' abt) emptyAssocs
+
+constantProp'
+  :: forall abt a xs . (ABT Term abt)
+  => abt xs a
+  -> PropM (abt xs a)
+constantProp' = start
+  where
+
+    start :: forall b ys . abt ys b -> PropM (abt ys b)
+    start = loop . viewABT
+
+    loop :: forall b ys . View (Term abt) ys b -> PropM (abt ys b)
+    loop (Var v)    = maybe (var v) (syn . Literal_) . lookupAssoc v <$> ask
+    loop (Syn s)    = constantPropTerm s
+    loop (Bind v b) = bind v <$> loop b
+
+isLiteral :: forall abt b ys . (ABT Term abt) => abt ys b -> Bool
+isLiteral abt = case viewABT abt of
+                  Syn (Literal_ _) -> True
+                  _                -> False
+
+isFoldable :: forall abt b . (ABT Term abt) => Term abt b -> Bool
+isFoldable = getAll . foldMap21 (All . isLiteral)
+
+getLiteral :: forall abt ys b. (ABT Term abt) => abt ys b -> Maybe (Literal b)
+getLiteral e =
+  case viewABT e of
+    Syn (Literal_ l) -> Just l
+    _                -> Nothing
+
+tryEval :: forall abt b . (ABT Term abt) => Term abt b -> abt '[] b
+tryEval term
+  | isFoldable term = runPureEvaluate (syn term)
+  | otherwise       = syn term
+
+constantPropTerm
+  :: (ABT Term abt)
+  => Term abt a
+  -> PropM (abt '[] a)
+constantPropTerm (Let_ :$ rhs :* body :* End) =
+  caseBind body $ \v body' -> do
+    rhs' <- constantProp' rhs
+    case getLiteral rhs' of
+      Just l  -> local (insertAssoc (Assoc v l)) (constantProp' body')
+      Nothing -> do
+        body'' <- constantProp' body'
+        return $ syn (Let_ :$ rhs' :* bind v body'' :* End)
+
+constantPropTerm term = tryEval <$> traverse21 constantProp' term
+
diff --git a/haskell/Language/Hakaru/Evaluation/DisintegrationMonad.hs b/haskell/Language/Hakaru/Evaluation/DisintegrationMonad.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Evaluation/DisintegrationMonad.hs
@@ -0,0 +1,1035 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , KindSignatures
+           , DataKinds
+           , PolyKinds
+           , TypeOperators
+           , Rank2Types
+           , FlexibleContexts
+           , MultiParamTypeClasses
+           , FlexibleInstances
+           , UndecidableInstances
+           , EmptyCase
+           , ScopedTypeVariables
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.24
+-- |
+-- Module      :  Language.Hakaru.Evaluation.DisintegrationMonad
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- The 'EvaluationMonad' for "Language.Hakaru.Disintegrate"
+----------------------------------------------------------------
+module Language.Hakaru.Evaluation.DisintegrationMonad
+    (
+    -- * The disintegration monad
+    -- ** List-based version
+      getStatements, putStatements
+    , ListContext(..), Ans, Dis(..), runDis, runDisInCtx
+    -- ** TODO: IntMap-based version
+    
+    -- * Operators on the disintegration monad
+    -- ** The \"zero\" and \"one\"
+    , bot
+    --, reject
+    -- ** Emitting code
+    , emit
+    , emitMBind , emitMBind2
+    , emitLet
+    , emitLet'
+    , emitUnpair
+    -- TODO: emitUneither
+    -- emitCaseWith
+    , emit_
+    , emitMBind_
+    , emitGuard
+    , emitWeight
+    , emitFork_
+    , emitSuperpose
+    , choose
+    , pushWeight
+    , pushGuard
+    -- * Overrides for original in Evaluation.Types
+    , pushPlate
+    -- * For Arrays/Plate
+    , getIndices
+    , withIndices
+    , extendIndices
+    , selectMore
+    , permutes
+    , statementInds
+    , sizeInnermostInd
+    -- * Extras
+    , Extra(..)
+    , getExtras
+    , putExtras
+    , insertExtra
+    , adjustExtra
+    , mkLoc
+    , freeLocError
+    , zipInds
+    , apply  
+#ifdef __TRACE_DISINTEGRATE__
+    , prettyExtra
+    , prettyExtras
+#endif    
+    ) where
+
+import           Prelude              hiding (id, (.))
+import           Control.Category     (Category(..))
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Monoid          (Monoid(..))
+import           Data.Functor         ((<$>))
+import           Control.Applicative  (Applicative(..))
+#endif
+import qualified Data.Set             as Set (fromList)
+import           Data.Maybe
+import qualified Data.Foldable        as F
+import qualified Data.Traversable     as T
+import           Data.List.NonEmpty   (NonEmpty(..))
+import qualified Data.List.NonEmpty   as NE
+import           Control.Applicative  (Alternative(..))
+import           Control.Monad        (MonadPlus(..),foldM,guard)
+#if __GLASGOW_HASKELL__ > 805
+import           Control.Monad.Fail
+#endif
+import           Data.Text            (Text)
+import qualified Data.Text            as Text
+import           Data.Number.Nat
+
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing    (Sing(..), sUnMeasure, sUnPair, sUnit)
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.DatumABT
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.Transform (TransformCtx(..), minimalCtx)
+import Language.Hakaru.Syntax.ABT
+import qualified Language.Hakaru.Syntax.Prelude as P
+import Language.Hakaru.Evaluation.Types
+import Language.Hakaru.Evaluation.PEvalMonad (ListContext(..))
+import Language.Hakaru.Evaluation.Lazy (reifyPair)    
+
+#ifdef __TRACE_DISINTEGRATE__
+import Debug.Trace (trace, traceM)
+import qualified Text.PrettyPrint     as PP
+import Language.Hakaru.Pretty.Haskell (ppVariable, pretty)
+#endif
+
+getStatements :: Dis abt [Statement abt Location 'Impure]
+getStatements = Dis $ \_ c h -> c (statements h) h
+
+putStatements :: [Statement abt Location 'Impure] -> Dis abt ()
+putStatements ss =
+    Dis $ \_ c (ListContext i _) extras ->
+        c () (ListContext i ss) extras
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- | Capturing substitution: 
+plug :: forall abt a xs b
+     .  (ABT Term abt)
+     => Variable a
+     -> abt '[] a
+     -> abt xs b
+     -> abt xs b
+plug x e = start
+    where
+      start :: forall xs' b' . abt xs' b' -> abt xs' b'
+      start f = loop f (viewABT f)
+      loop :: forall xs' b'. abt xs' b' -> View (Term abt) xs' b' -> abt xs' b'
+      loop _ (Syn t) = syn $! fmap21 start t
+      loop f (Var z) = case varEq x z of
+                       Just Refl -> e
+                       Nothing   -> f
+      loop f (Bind _ _) = caseBind f $ \z f' -> 
+                          bind z (loop f' (viewABT f'))
+
+-- | Perform multiple capturing substitutions
+plugs :: forall abt xs a
+      .  (ABT Term abt)
+      => Assocs (abt '[]) 
+      -> abt xs a
+      -> abt xs a
+plugs rho0 e0 = F.foldl (\e (Assoc x v) -> plug x v e) e0 (unAssocs rho0)
+
+-- | Plug a term into a context. That is, the 'statements' of the
+-- context specifies a program with a hole in it; so we plug the
+-- given term into that hole, returning the complete program.
+residualizeListContext
+    :: forall abt a
+    .  (ABT Term abt)
+    => ListContext abt 'Impure
+    -> Assocs (abt '[])
+    -> abt '[] ('HMeasure a)
+    -> abt '[] ('HMeasure a)
+residualizeListContext ss rho e0 =
+    -- N.B., we use a left fold because the head of the list of
+    -- statements is the one closest to the hole.
+#ifdef __TRACE_DISINTEGRATE__
+    trace ("e0: " ++ show (pretty e0) ++ "\n"
+          ++ show (pretty_Statements (statements ss))) $
+#endif
+    foldl step (plugs rho e0) (statements ss)
+    where    
+    step
+        :: abt '[] ('HMeasure a)
+        -> Statement abt Location 'Impure
+        -> abt '[] ('HMeasure a)
+    step e s =        
+#ifdef __TRACE_DISINTEGRATE__
+        trace ("wrapping " ++ show (ppStatement 0 s) ++ "\n"
+               ++ "around term " ++ show (pretty e)) $
+#endif  
+        case s of       
+        SBind (Location x) body _ ->
+            -- TODO: if @body@ is dirac, then treat as 'SLet'
+            syn (MBind :$ plugs rho (fromLazy body) :* bind x e :* End)
+        SLet (Location x) body _
+            | not (x `memberVarSet` freeVars e) ->
+#ifdef __TRACE_DISINTEGRATE__
+               trace ("could not find location " ++ show x ++ "\n"
+                     ++ "in term " ++ show (pretty e) ++ "\n"
+                     ++ "given rho " ++ show (prettyAssocs rho)) $
+#endif                
+                e
+            -- TODO: if used exactly once in @e@, then inline.
+            | otherwise ->
+                case getLazyVariable body of
+                Just y  -> plug x (plugs rho (var y)) e
+                Nothing ->
+                    case getLazyLiteral body of
+                    Just v  -> plug x (syn $ Literal_ v) e
+                    Nothing ->
+                        syn (Let_ :$ plugs rho (fromLazy body) :* bind x e :* End)
+        SGuard xs pat scrutinee _ ->
+            syn $ Case_ (plugs rho $ fromLazy scrutinee)
+                [ Branch pat   (binds_ (fromLocations1 xs) e)
+                , Branch PWild (P.reject $ typeOf e)
+                ]
+        SWeight body _ -> syn $ Superpose_ ((plugs rho $ fromLazy body, e) :| [])
+
+----------------------------------------------------------------
+-- An extra is a variable *use* instantiated at some list of indices.
+data Extra :: (Hakaru -> *) -> Hakaru -> * where
+     Loc :: Location a -> [ast 'HNat] -> Extra ast a
+
+extrasInds :: Extra ast a -> [ast 'HNat]
+extrasInds (Loc       _ inds) = inds
+
+selectMore :: [ast 'HNat] -> ast 'HNat -> [ast 'HNat]
+selectMore = flip (:)
+
+-- Assumption: inds has no duplicates
+permutes :: (ABT Term abt)
+         => [abt '[] 'HNat]
+         -> [Index (abt '[])]
+         -> Bool
+permutes ts inds =
+    all isJust ts' &&
+    length ts' == length inds &&
+    Set.fromList (map fromJust ts') == Set.fromList (map indVar inds)
+    where ts' = map (\t -> caseVarSyn t Just (const Nothing)) ts
+
+#ifdef __TRACE_DISINTEGRATE__
+      
+prettyExtra :: (ABT Term abt) => Extra (abt '[]) a -> PP.Doc
+prettyExtra (Loc (Location x) inds)      = PP.text "Loc" PP.<+> ppVariable x
+                                           PP.<+> ppList (map pretty inds)
+
+prettyExtras :: (ABT Term abt)
+           => Assocs (Extra (abt '[]))
+           -> PP.Doc
+prettyExtras a = PP.vcat $ map go (fromAssocs a)
+  where go (Assoc x l) = ppVariable x PP.<+>
+                         PP.text "->" PP.<+>
+                         prettyExtra l
+
+#endif                           
+
+-- In the paper we say that result must be a 'Whnf'; however, in
+-- the paper it's also always @HMeasure a@ and everything of that
+-- type is a WHNF (via 'WMeasure') so that's a trivial statement
+-- to make. If we turn it back into some sort of normal form, then
+-- it must be one preserved by 'residualizeContext'.
+--
+-- Also, we add the list in order to support "lub" without it living
+-- in the AST.
+-- TODO: really we should use LogicT...
+type Ans abt a
+  =  ListContext abt 'Impure
+  -> Assocs (Extra (abt '[]))
+  -> [abt '[] ('HMeasure a)]
+
+
+----------------------------------------------------------------
+-- TODO: defunctionalize the continuation. In particular, the only
+-- heap modifications we need are 'push' and a variant of 'update'
+-- for finding\/replacing a binding once we have the value in hand;
+-- and the only 'freshNat' modifications are to allocate new 'Nat'.
+-- We could defunctionalize the second arrow too by relying on the
+-- @Codensity (ReaderT e m) ~= StateT e (Codensity m)@ isomorphism,
+-- which makes explicit that the only thing other than 'ListContext'
+-- updates is emitting something like @[Statement]@ to serve as the
+-- beginning of the final result.
+--
+-- TODO: give this a better, more informative name!
+--
+-- N.B., This monad is used not only for both 'perform' and
+-- 'constrainOutcome', but also for 'constrainValue'.
+newtype Dis abt x =
+    Dis { unDis :: forall a. [Index (abt '[])] -> (x -> Ans abt a) -> Ans abt a }
+    -- == @Codensity (Ans abt)@, assuming 'Codensity' is poly-kinded
+    -- like it should be. If we don't want to allow continuations that
+    -- can make nondeterministic choices, then we should use the right
+    -- Kan extension itself, rather than the Codensity specialization
+    -- of it.
+
+
+-- | Run a computation in the 'Dis' monad, residualizing out all the
+-- statements in the final evaluation context. The second argument
+-- should include all the terms altered by the 'Dis' expression; this
+-- is necessary to ensure proper hygiene; for example(s):
+--
+-- > runDis (perform e) [Some2 e]
+-- > runDis (constrainOutcome e v) [Some2 e, Some2 v]
+--
+-- We use 'Some2' on the inputs because it doesn't matter what their
+-- type or locally-bound variables are, so we want to allow @f@ to
+-- contain terms with different indices.
+runDisInCtx
+    :: (ABT Term abt, F.Foldable f)
+    => TransformCtx
+    -> Dis abt (abt '[] a)
+    -> f (Some2 abt)
+    -> [abt '[] ('HMeasure a)]
+runDisInCtx ctx d es =
+    m0 [] c0 (ListContext i0 []) emptyAssocs
+    where
+    (Dis m0) = d >>= residualizeLocs
+    -- TODO: we only use dirac because 'residualizeListContext'
+    -- requires it to already be a measure; unfortunately this can
+    -- result in an extraneous @(>>= \x -> dirac x)@ redex at the end
+    -- of the program. In principle, we should be able to eliminate
+    -- that redex by changing the type of 'residualizeListContext'...
+    c0 (e,rho) ss _ = [residualizeListContext ss rho (syn(Dirac :$ e :* End))]
+                  
+    i0 = maxNextFree es `max` nextFreeVar ctx
+
+runDis
+    :: (ABT Term abt, F.Foldable f)
+    => Dis abt (abt '[] a)
+    -> f (Some2 abt)
+    -> [abt '[] ('HMeasure a)]
+runDis = runDisInCtx minimalCtx
+
+{---------------------------------------------------------------------------------- 
+ 
+ residualizeLocs does the following:
+ 1. update the heap by constructing plate/array around statements with nonempty indices
+ 2. use locations to construct terms out of var and "!" (for indexing into arrays)
+
+For example, consider the state:
+
+  list context (aka heap) =
+  l1 <- lebesgue []
+  l2 <- plate (normal 0 1) []
+  l3 <- lebesgue [i]
+  l4 <- dirac x3 []
+  l5 <- normal 0 1 [j]
+  
+  assocs (aka locs) =
+  x1 -> Loc l1 []
+  x2 -> Loc l2 []
+  x3 -> MultiLoc l3 []
+  x4 -> Loc l4 []
+  x5 -> Loc l5 [k]
+  
+Here the types of the above variables are:
+
+  l1, x1 :: Real
+  l2, x2 :: Array Real
+  l3 :: Real
+  x3 :: Array Real
+  l4, x4 :: Array Real
+  l5, x5 :: Real
+
+Then residualizeLoc does two things:
+
+1.Change the heap
+
+  list context = 
+  l1' <- lebesgue []
+  l2' <- plate (normal 0 1) []
+  l3' <- plate i (lebesgue)
+  l4' <- dirac x3
+  l5' <- plate j (normal 0 1)
+
+2.Create new association table
+
+  rho = 
+  x1 -> var l1'
+  x2 -> var l2'
+  x3 -> array i' (l3' ! i')
+  x4 -> var l4'
+  x5 -> var l5' ! k 
+
+----------------------------------------------------------------------------------}
+residualizeLocs :: forall a abt. (ABT Term abt)
+                => abt '[] a
+                -> Dis abt (abt '[] a, Assocs (abt '[]))
+residualizeLocs e = do
+  ss <- getStatements
+  (ss', newlocs) <- foldM step ([], emptyLAssocs) ss
+  rho <- convertLocs newlocs
+  putStatements (reverse ss')
+#ifdef __TRACE_DISINTEGRATE__
+  trace ("residualizeLocs: old heap:\n" ++ show (pretty_Statements ss )) $ return ()
+  trace ("residualizeLocs: new heap:\n" ++ show (pretty_Statements ss')) $ return ()
+  extras <- getExtras
+  traceM ("oldlocs:\n" ++ show (prettyExtras extras) ++ "\n")
+  traceM ("new assoc for renaming:\n" ++ show (prettyAssocs rho))
+#endif
+  return (e, rho)
+    where step (ss',newlocs) s = do (s',newlocs') <- residualizeLoc s
+                                    return (s':ss', insertLAssocs newlocs' newlocs)
+
+data Name (a :: Hakaru) = Name {nameHint :: Text, nameID :: Nat}
+
+locName :: Location a -> Name b
+locName (Location x) = Name (varHint x) (varID x)
+
+residualizeLoc :: (ABT Term abt)
+               => Statement abt Location 'Impure
+               -> Dis abt (Statement abt Location 'Impure, LAssocs Name)
+residualizeLoc s =
+    case s of
+      SBind l _ _ -> do 
+             (s', newname) <- reifyStatement s
+             return (s', singletonLAssocs l newname)
+      SLet  l _ _ -> do
+             (s', newname) <- reifyStatement s
+             return (s', singletonLAssocs l newname)
+      SWeight w inds    -> do
+             x <- freshVar Text.empty sUnit
+             let bodyW = Thunk $ P.weight (fromLazy w)
+             (s', newname) <- reifyStatement (SBind (Location x) bodyW inds)
+             return (s', singletonLAssocs (Location x) newname)
+      SGuard ls _ _ ixs
+        | null ixs  -> return (s, toLAssocs1 ls (fmap11 locName ls))
+        | otherwise -> error "undefined: case statement under an array"
+
+reifyStatement :: (ABT Term abt)
+               => Statement abt Location 'Impure
+               -> Dis abt (Statement abt Location 'Impure, Name a)
+reifyStatement s =
+    case s of
+      SBind l _    []     -> return (s, locName l)
+      SBind l body (i:is) -> do
+        let plate = Thunk . P.plateWithVar (indSize i) (indVar i)
+        x' <- freshVar (locHint l) (SArray (locType l))
+        reifyStatement (SBind (Location x') (plate $ fromLazy body) is)
+      SLet  l _    []     -> return (s, locName l)
+      SLet  l body (i:is) -> do
+        let array = Thunk . P.arrayWithVar (indSize i) (indVar i)
+        x' <- freshVar (locHint l) (SArray (locType l))
+        reifyStatement (SLet  (Location x') (array $ fromLazy body) is)
+      SWeight _    _      -> error "reifyStatement called on SWeight"
+      SGuard _ _ _ _      -> error "reifyStatement called on SGuard"
+                             
+sizeInnermostInd :: (ABT Term abt)
+                 => Location (a :: Hakaru)
+                 -> Dis abt (abt '[] 'HNat)
+sizeInnermostInd l =
+    (maybe (freeLocError l) return =<<) . select l $ \s ->
+        do guard (length (statementInds s) >= 1)
+           case s of
+             SBind l' _ ixs -> do Refl <- locEq l l'
+                                  Just $ unsafePush s >>
+                                         return (indSize (head ixs))
+             SLet  l' _ ixs -> do Refl <- locEq l l'
+                                  Just $ unsafePush s >>
+                                         return (indSize (head ixs))
+             SWeight _ _    -> Nothing
+             SGuard _ _ _ _ -> error "TODO: sizeInnermostInd{SGuard}"
+                                         
+fromName :: (ABT Term abt)
+         => Name b
+         -> Sing a
+         -> [abt '[] 'HNat]
+         -> abt '[] a
+fromName name typ []     = var $ Variable { varHint = nameHint name
+                                          , varID   = nameID name
+                                          , varType = typ }
+fromName name typ (i:is) = fromName name (SArray typ) is P.! i
+                     
+convertLocs :: (ABT Term abt)
+            => LAssocs Name
+            -> Dis abt (Assocs (abt '[]))
+convertLocs newlocs = F.foldr step emptyAssocs . fromAssocs <$> getExtras
+    where
+      build :: (ABT Term abt)
+            => Assoc (Extra (abt '[]))
+            -> Name a
+            -> Assoc (abt '[])
+      build (Assoc x extra) name =
+          Assoc x (fromName name (varType x) (extrasInds extra))
+      step assoc@(Assoc _ extra) = insertAssoc $
+          case extra of
+                 Loc      l _ -> maybe (freeLocError l)
+                                       (build assoc)
+                                       (lookupLAssoc l newlocs)
+
+freeLocError :: Location (a :: Hakaru) -> b
+freeLocError l = error $ "Found a free location " ++ show l
+
+zipInds :: (ABT Term abt)
+        => [Index (abt '[])] -> [abt '[] 'HNat] -> Assocs (abt '[])
+zipInds inds ts
+    | length inds /= length ts
+        = error "zipInds: argument lists must have the same length"
+    | otherwise = toAssocs $ zipWith Assoc (map indVar inds) ts
+
+apply :: (ABT Term abt)
+      => [Index (abt '[])]
+      -> [Index (abt '[])]
+      -> abt '[] a
+      -> Dis abt (abt '[] a)
+apply is js e = extSubsts (zipInds is (map fromIndex js)) e
+                           
+extendIndices
+    :: (ABT Term abt)
+    => Index (abt '[])
+    -> [Index (abt '[])]
+    -> [Index (abt '[])]
+-- TODO: check all Indices are unique
+extendIndices j js | j `elem` js
+                   = error ("Duplicate index between " )
+                     -- TODO finish this error message by
+                     -- defining Show for Index
+                   | otherwise
+                   = j : js
+
+-- give better name
+statementInds :: Statement abt Location p -> [Index (abt '[])]
+statementInds (SBind   _ _   i) = i
+statementInds (SLet    _ _   i) = i
+statementInds (SWeight _     i) = i
+statementInds (SGuard  _ _ _ i) = i
+statementInds (SStuff0 _     i) = i
+statementInds (SStuff1 _ _   i) = i
+
+getExtras :: (ABT Term abt)
+          => Dis abt (Assocs (Extra (abt '[])))
+getExtras = Dis $ \_ c h l -> c l h l
+
+putExtras :: (ABT Term abt)
+          => Assocs (Extra (abt '[]))
+          -> Dis abt ()
+putExtras l = Dis $ \_ c h _ -> c () h l
+
+insertExtra :: (ABT Term abt)
+            => Variable a
+            -> Extra (abt '[]) a
+            -> Dis abt ()
+insertExtra v extra = 
+  Dis $ \_ c h l -> c () h $
+    insertAssoc (Assoc v extra) l
+
+adjustExtra :: (ABT Term abt)
+            => Variable (a :: Hakaru)
+            -> (Assoc (Extra (abt '[])) -> Assoc (Extra (abt '[])))
+            -> Dis abt ()
+adjustExtra x f = do
+    extras <- getExtras
+    putExtras $ adjustAssoc x f extras
+
+mkLoc
+    :: (ABT Term abt)
+    => Text
+    -> Location (a :: Hakaru)
+    -> [abt '[] 'HNat]
+    -> Dis abt (Variable a)
+mkLoc hint l inds = do
+  x <- freshVar hint (locType l)
+  insertExtra x (Loc l inds)
+  return x
+
+mkLocs
+    :: (ABT Term abt)
+    => List1 Location (xs :: [Hakaru])
+    -> [abt '[] 'HNat]
+    -> Dis abt (List1 Variable xs)
+mkLocs Nil1         _    = return Nil1
+mkLocs (Cons1 l ls) inds = Cons1
+                           <$> mkLoc Text.empty l inds
+                           <*> mkLocs ls inds
+
+instance Functor (Dis abt) where
+    fmap f (Dis m)  = Dis $ \i c -> m i (c . f)
+
+instance Applicative (Dis abt) where
+    pure x            = Dis $ \_ c -> c x
+    Dis mf <*> Dis mx = Dis $ \i c -> mf i $ \f -> mx i $ \x -> c (f x)
+
+instance Monad (Dis abt) where
+    return      = pure
+    Dis m >>= k = Dis $ \i c -> m i $ \x -> unDis (k x) i c
+
+#if __GLASGOW_HASKELL__ > 805
+instance MonadFail (Dis abt) where
+    fail        = error
+#endif
+
+instance Alternative (Dis abt) where
+    empty           = Dis $ \_ _ _ _ -> []
+    Dis m <|> Dis n = Dis $ \i c h l -> m i c h l ++ n i c h l
+
+instance MonadPlus (Dis abt) where
+    mzero = empty -- aka "bot"
+    mplus = (<|>) -- aka "lub"
+
+instance (ABT Term abt) => EvaluationMonad abt (Dis abt) 'Impure where
+    freshNat =
+        Dis $ \_ c (ListContext n ss) ->
+            c n (ListContext (n+1) ss)
+
+    -- Note: we assume that freshLocStatement is never called on a
+    -- statement already on the heap (list context)
+    freshLocStatement s =
+        case s of
+          SWeight w e    -> return (SWeight w e, mempty)
+          SBind x body i -> do
+               x' <- freshenVar x
+               let l = Location x'
+               v  <- mkLoc (locHint l) l (map fromIndex i)
+               return (SBind l body i, singletonAssocs x v)
+          SLet  x body i -> do
+               x' <- freshenVar x
+               let l = Location x'
+               v  <- mkLoc (locHint l) l (map fromIndex i)
+               return (SLet l body i, singletonAssocs x v)
+          SGuard xs pat scrutinee i -> do
+               xs'  <- freshenVars xs
+               let ls = locations1 xs'
+               vs   <- mkLocs ls (map fromIndex i)
+               return (SGuard ls pat scrutinee i, toAssocs1 xs vs)
+
+    getIndices =  Dis $ \i c -> c i
+
+    unsafePush s =
+        Dis $ \_ c (ListContext i ss) ->
+            c () (ListContext i (s:ss))
+
+    -- N.B., the use of 'reverse' is necessary so that the order
+    -- of pushing matches that of 'pushes'
+    unsafePushes ss =
+        Dis $ \_ c (ListContext i ss') ->
+            c () (ListContext i (reverse ss ++ ss'))
+
+    select l p = loop []
+        where
+        -- TODO: use a DList to avoid reversing inside 'unsafePushes'
+        loop ss = do
+            ms <- unsafePop
+            case ms of
+                Nothing      -> do
+                    unsafePushes ss
+                    return Nothing
+                Just s ->
+                    -- Alas, @p@ will have to recheck 'isBoundBy'
+                    -- in order to grab the 'Refl' proof we erased;
+                    -- but there's nothing to be done for it.
+                    case l `isBoundBy` s >> p s of
+                    Nothing -> loop (s:ss)
+                    Just mr -> do
+                        r <- mr
+                        unsafePushes ss
+                        return (Just r)
+
+    substVar x e z = do
+      extras <- getExtras
+      let defaultResult = return (var z)
+      case (lookupAssoc z extras) of
+        Nothing                -> defaultResult
+        Just (Loc l inds)      ->
+            if any (memberVarSet x . freeVars) inds
+            then do inds' <- mapM (extSubst x e) inds
+                    var <$> mkLoc Text.empty l inds'
+            else defaultResult
+
+    extFreeVars e = do
+      extras <- getExtras
+      let fvs1 = freeVars e
+          indFVs (SomeVariable v) =
+              case (lookupAssoc v extras) of
+                Nothing -> emptyVarSet
+                Just (Loc _ is) -> foldr (unionVarSet.freeVars) emptyVarSet is
+          locVars (SomeVariable v) b =
+              case (lookupAssoc v extras) of
+                Nothing -> b
+                Just (Loc l _) -> insertVarSet (fromLocation l) b
+          fvs2 = foldr (unionVarSet.indFVs) fvs1 (fromVarSet fvs1)
+      return $ foldr locVars emptyVarSet (fromVarSet fvs2)
+
+    -- | The forward disintegrator's function for evaluating case
+    -- expressions. First we try calling 'defaultCaseEvaluator' which
+    -- will evaluate the scrutinee and select the matching branch (if
+    -- any). But that doesn't work out in general, since the scrutinee
+    -- may contain heap-bound variables. So our fallback definition
+    -- will push a 'SGuard' onto the heap and then continue evaluating
+    -- each branch (thereby duplicating the continuation, calling it
+    -- once on each branch).
+    evaluateCase evaluate_ = evaluateCase_
+        where
+          evaluateCase_ :: CaseEvaluator abt (Dis abt)
+          evaluateCase_ e bs =
+              defaultCaseEvaluator evaluate_ e bs
+              <|> evaluateBranches e bs
+
+          evaluateBranches :: CaseEvaluator abt (Dis abt)
+          evaluateBranches e = choose . map evaluateBranch
+              where
+                evaluateBranch (Branch pat body) =
+                    let (vars,body') = caseBinds body
+                    in getIndices >>= \i ->
+                        push (SGuard vars pat (Thunk e) i) body'
+                           >>= evaluate_
+
+    evaluateVar perform evaluate_ x =
+      do extras <- getExtras
+         -- If we get 'Nothing', then it turns out @x@ is a free variable
+         maybe (return $ Neutral (var x)) lookForLoc (lookupAssoc x extras)
+      where lookForLoc (Loc      l jxs) =
+              (maybe (freeLocError l) return =<<) . select l $ \s ->
+                case s of
+                SBind l' e ixs -> do
+                  Refl <- locEq l l'
+                  Just $ do
+                    w <- withIndices ixs $ perform (caseLazy e fromWhnf id)
+                    unsafePush (SLet l (Whnf_ w) ixs)
+#ifdef __TRACE_DISINTEGRATE__
+                    trace ("-- updated "
+                           ++ show (ppStatement 11 s)
+                           ++ " to "
+                           ++ show (ppStatement 11 (SLet l (Whnf_ w) ixs))
+                          ) $ return ()
+#endif
+                    extSubsts (zipInds ixs jxs) (fromWhnf w) >>= evaluate_
+                SLet  l' e ixs -> do
+                  Refl <- locEq l l'
+                  Just $ do
+                    w <- withIndices ixs $ caseLazy e return evaluate_
+                    unsafePush (SLet l (Whnf_ w) ixs)
+                    extSubsts (zipInds ixs jxs) (fromWhnf w) >>= evaluate_
+                -- This does not bind any variables, so it definitely can't match.
+                SWeight   _ _ -> Nothing
+                -- This does bind variables,
+                -- but there's no expression we can return for it
+                -- because the variables are untouchable\/abstract.
+                SGuard ls pat scrutinee i -> Just . return . Neutral $ var x  
+                 
+        
+withIndices :: [Index (abt '[])] -> Dis abt a -> Dis abt a
+withIndices inds (Dis m) = Dis $ \_ c -> m inds c
+
+-- | Not exported because we only need it for defining 'select' on 'Dis'.
+unsafePop :: Dis abt (Maybe (Statement abt Location 'Impure))
+unsafePop =
+    Dis $ \_ c h@(ListContext i ss) extras ->
+        case ss of
+        []    -> c Nothing  h extras
+        s:ss' -> c (Just s) (ListContext i ss') extras
+
+pushPlate
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> abt '[ 'HNat ] ('HMeasure a)
+    -> Dis abt (abt '[] ('HArray a))
+pushPlate n e =
+  caseBind e $ \x body -> do
+    inds <- getIndices
+    i    <- freshInd n
+    p    <- Location <$> freshVar Text.empty (sUnMeasure $ typeOf body)
+    let inds' = extendIndices i inds
+    unsafePush (SBind p (Thunk $ rename x (indVar i) body) inds')
+    v <- mkLoc Text.empty p $ map fromIndex inds'
+    return $ P.arrayWithVar n (indVar i) (var v)
+
+-- | Calls unsafePush 
+pushWeight :: (ABT Term abt) => abt '[] 'HProb -> Dis abt ()
+pushWeight w = do
+  inds <- getIndices
+  unsafePush $ SWeight (Thunk w) inds
+
+-- | Calls unsafePush 
+pushGuard :: (ABT Term abt) => abt '[] HBool -> Dis abt ()
+pushGuard b = do
+  inds <- getIndices
+  unsafePush $ SGuard Nil1 pTrue (Thunk b) inds           
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- | It is impossible to satisfy the constraints, or at least we
+-- give up on trying to do so. This function is identical to 'empty'
+-- and 'mzero' for 'Dis'; we just give it its own name since this is
+-- the name used in our papers.
+--
+-- TODO: add some sort of trace information so we can get a better
+-- idea what caused a disintegration to fail.
+bot :: (ABT Term abt) => Dis abt a
+bot = Dis $ \_ _ _ _ -> []
+
+
+-- | The empty measure is a solution to the constraints.
+-- reject :: (ABT Term abt) => Dis abt a
+-- reject = Dis $ \_ _ -> [syn (Superpose_ [])]
+
+
+-- Something essentially like this function was called @insert_@
+-- in the finally-tagless code.
+--
+-- | Emit some code that binds a variable, and return the variable
+-- thus bound. The function says what to wrap the result of the
+-- continuation with; i.e., what we're actually emitting.
+emit
+    :: (ABT Term abt)
+    => Text
+    -> Sing a
+    -> (forall r. abt '[a] ('HMeasure r) -> abt '[] ('HMeasure r))
+    -> Dis abt (Variable a)
+emit hint typ f = do
+    x <- freshVar hint typ
+    Dis $ \_ c h l -> (f . bind x) <$> c x h l
+
+-- This function was called @lift@ in the finally-tagless code.
+-- | Emit an 'MBind' (i.e., \"@m >>= \x ->@\") and return the
+-- variable thus bound (i.e., @x@).
+emitMBind :: (ABT Term abt) => abt '[] ('HMeasure a) -> Dis abt (Variable a)
+emitMBind m =
+    emit Text.empty (sUnMeasure $ typeOf m) $ \e ->
+        syn (MBind :$ m :* e :* End)
+
+emitMBind2 :: (ABT Term abt) => abt '[] ('HMeasure a) -> Dis abt (abt '[] a)
+emitMBind2 m = do
+  inds <- getIndices
+  let b = Whnf_ $ fromMaybe (error "emitMBind2: non-hnf term") (toWhnf m)
+      typ = sUnMeasure $ typeOf m
+  l <- Location <$> freshVar Text.empty typ
+  (SBind l' b' _, name) <- reifyStatement (SBind l b inds)
+  let (idx, p) = (fromName name typ (map fromIndex inds), fromLazy b')
+  Dis $ \_ c h ex ->
+      c idx h ex >>= \e ->
+      return $ syn (MBind :$ p :* bind (fromLocation l') e :* End)
+
+-- | A smart constructor for emitting let-bindings. If the input
+-- is already a variable then we just return it; otherwise we emit
+-- the let-binding. N.B., this function provides the invariant that
+-- the result is in fact a variable; whereas 'emitLet'' does not.
+emitLet :: (ABT Term abt) => abt '[] a -> Dis abt (Variable a)
+emitLet e =
+    caseVarSyn e return $ \_ ->
+        emit Text.empty (typeOf e) $ \m ->
+            syn (Let_ :$ e :* m :* End)
+
+-- | A smart constructor for emitting let-bindings. If the input
+-- is already a variable or a literal constant, then we just return
+-- it; otherwise we emit the let-binding. N.B., this function
+-- provides weaker guarantees on the type of the result; if you
+-- require the result to always be a variable, then see 'emitLet'
+-- instead.
+emitLet' :: (ABT Term abt) => abt '[] a -> Dis abt (abt '[] a)
+emitLet' e =
+    caseVarSyn e (const $ return e) $ \t ->
+        case t of
+        Literal_ _ -> return e
+        _          -> do
+            x <- emit Text.empty (typeOf e) $ \m ->
+                syn (Let_ :$ e :* m :* End)
+            return (var x)
+
+-- | A smart constructor for emitting \"unpair\". If the input
+-- argument is actually a constructor then we project out the two
+-- components; otherwise we emit the case-binding and return the
+-- two variables.
+emitUnpair
+    :: (ABT Term abt)
+    => Whnf abt (HPair a b)
+    -> Dis abt (abt '[] a, abt '[] b)
+emitUnpair (Head_   w) = return $ reifyPair w
+emitUnpair (Neutral e) = do
+    let (a,b) = sUnPair (typeOf e)
+    x <- freshVar Text.empty a
+    y <- freshVar Text.empty b
+    emitUnpair_ x y e
+
+emitUnpair_
+    :: forall abt a b
+    .  (ABT Term abt)
+    => Variable a
+    -> Variable b
+    -> abt '[] (HPair a b)
+    -> Dis abt (abt '[] a, abt '[] b)
+emitUnpair_ x y = loop
+    where
+    done :: abt '[] (HPair a b) -> Dis abt (abt '[] a, abt '[] b)
+    done e =
+#ifdef __TRACE_DISINTEGRATE__
+        trace "-- emitUnpair: done (term is not Datum_ nor Case_)" $
+#endif
+        Dis $ \_ c h l ->
+            ( syn
+            . Case_ e
+            . (:[])
+            . Branch (pPair PVar PVar)
+            . bind x
+            . bind y
+            ) <$> c (var x, var y) h l
+
+    loop :: abt '[] (HPair a b) -> Dis abt (abt '[] a, abt '[] b)
+    loop e0 =
+        caseVarSyn e0 (done . var) $ \t ->
+            case t of
+            Datum_ d   -> do
+#ifdef __TRACE_DISINTEGRATE__
+                trace "-- emitUnpair: found Datum_" $ return ()
+#endif
+                return $ reifyPair (WDatum d)
+            Case_ e bs -> do
+#ifdef __TRACE_DISINTEGRATE__
+                trace "-- emitUnpair: going under Case_" $ return ()
+#endif
+                -- TODO: we want this to duplicate the current
+                -- continuation for (the evaluation of @loop@ in)
+                -- all branches. So far our traces all end up
+                -- returning @bot@ on the first branch, and hence
+                -- @bot@ for the whole case-expression, so we can't
+                -- quite tell whether it does what is intended.
+                --
+                -- N.B., the only 'Dis'-effects in 'applyBranch'
+                -- are to freshen variables; thus this use of
+                -- 'traverse' is perfectly sound.
+                emitCaseWith loop e bs
+            _ -> done e0
+
+
+-- TODO: emitUneither
+
+
+-- This function was called @insert_@ in the old finally-tagless code.
+-- | Emit some code that doesn't bind any variables. This function
+-- provides an optimisation over using 'emit' and then discarding
+-- the generated variable.
+emit_
+    :: (ABT Term abt)
+    => (forall r. abt '[] ('HMeasure r) -> abt '[] ('HMeasure r))
+    -> Dis abt ()
+emit_ f = Dis $ \_ c h l -> f <$> c () h l
+
+
+-- | Emit an 'MBind' that discards its result (i.e., \"@m >>@\").
+-- We restrict the type of the argument to be 'HUnit' so as to avoid
+-- accidentally dropping things.
+emitMBind_ :: (ABT Term abt) => abt '[] ('HMeasure HUnit) -> Dis abt ()
+emitMBind_ m = emit_ (m P.>>)
+
+
+-- TODO: if the argument is a value, then we can evaluate the 'P.if_'
+-- immediately rather than emitting it.
+-- | Emit an assertion that the condition is true.
+emitGuard :: (ABT Term abt) => abt '[] HBool -> Dis abt ()
+emitGuard b = emit_ (P.withGuard b) -- == emit_ $ \m -> P.if_ b m P.reject
+
+-- TODO: if the argument is the literal 1, then we can avoid emitting anything.
+emitWeight :: (ABT Term abt) => abt '[] 'HProb -> Dis abt ()
+emitWeight w = emit_ (P.withWeight w)
+
+
+-- N.B., this use of 'T.traverse' is definitely correct. It's
+-- sequentializing @t [abt '[] ('HMeasure a)]@ into @[t (abt '[]
+-- ('HMeasure a))]@ by chosing one of the possibilities at each
+-- position in @t@. No heap\/context effects can escape to mess
+-- things up. In contrast, using 'T.traverse' to sequentialize @t
+-- (Dis abt a)@ as @Dis abt (t a)@ is /wrong/! Doing that would give
+-- the conjunctive semantics where we have effects from one position
+-- in @t@ escape to affect the other positions. This has to do with
+-- the general issue in partial evaluation where we need to duplicate
+-- downstream work (as we do by passing the same heap to everyone)
+-- because there's no general way to combing the resulting heaps
+-- for each branch.
+--
+-- | Run each of the elements of the traversable using the same
+-- heap and continuation for each one, then pass the results to a
+-- function for emitting code.
+emitFork_
+    :: (ABT Term abt, T.Traversable t)
+    => (forall r. t (abt '[] ('HMeasure r)) -> abt '[] ('HMeasure r))
+    -> t (Dis abt a)
+    -> Dis abt a
+emitFork_ f ms = Dis $ \i c h l -> f <$> T.traverse (\m -> unDis m i c h l) ms
+
+
+-- | Emit a 'Superpose_' of the alternatives, each with unit weight.
+emitSuperpose
+    :: (ABT Term abt)
+    => [abt '[] ('HMeasure a)]
+    -> Dis abt (Variable a)
+emitSuperpose []  = error "TODO: emitSuperpose[]"
+emitSuperpose [e] = emitMBind e
+emitSuperpose es  =
+    emitMBind . P.superpose . NE.map ((,) P.one) $ NE.fromList es
+
+
+-- | Emit a 'Superpose_' of the alternatives, each with unit weight.
+choose :: (ABT Term abt) => [Dis abt a] -> Dis abt a
+choose []  = error "TODO: choose[]"
+choose [m] = m
+choose ms  = emitFork_ (P.superpose . NE.map ((,) P.one) . NE.fromList) ms
+
+
+-- | Given some function we can call on the bodies of the branches,
+-- freshen all the pattern-bound variables and then run the function
+-- on all the branches in parallel (i.e., with the same continuation
+-- and heap) and then emit a case-analysis expression with the
+-- results of the continuations as the bodies of the branches. This
+-- function is useful for when we really do want to emit a 'Case_'
+-- expression, rather than doing the superpose of guard patterns
+-- thing that 'constrainValue' does.
+--
+-- N.B., this function assumes (and does not verify) that the second
+-- argument is emissible. So callers must guarantee this invariant,
+-- by calling 'atomize' as necessary.
+--
+-- TODO: capture the emissibility requirement on the second argument
+-- in the types.
+emitCaseWith
+    :: (ABT Term abt)
+    => (abt '[] b -> Dis abt r)
+    -> abt '[] a
+    -> [Branch a abt b]
+    -> Dis abt r
+emitCaseWith f e bs = do
+    gms <- T.for bs $ \(Branch pat body) ->
+        let (vars, body') = caseBinds body
+        in  (\vars' ->
+                let rho = toAssocs1 vars vars'
+                in  GBranch pat vars' (f $ renames rho body')
+            ) <$> freshenVars vars
+    Dis $ \i c h l ->
+        (syn . Case_ e) <$> T.for gms (\gm ->
+            fromGBranch <$> T.for gm (\m ->
+                unDis m i c h l))
+{-# INLINE emitCaseWith #-}
+
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Evaluation/EvalMonad.hs b/haskell/Language/Hakaru/Evaluation/EvalMonad.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Evaluation/EvalMonad.hs
@@ -0,0 +1,339 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , KindSignatures
+           , DataKinds
+           , Rank2Types
+           , ScopedTypeVariables
+           , MultiParamTypeClasses
+           , FlexibleContexts
+           , FlexibleInstances
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.24
+-- |
+-- Module      :  Language.Hakaru.Evaluation.EvalMonad
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--
+----------------------------------------------------------------
+module Language.Hakaru.Evaluation.EvalMonad
+    ( runPureEvaluate
+    , pureEvaluate
+
+    -- * The pure-evaluation monad
+    -- ** List-based version
+    , ListContext(..), PureAns, Eval(..), runEval
+    , residualizePureListContext
+    -- ** TODO: IntMap-based version
+    ) where
+
+import           Prelude              hiding (id, (.))
+import           Control.Category     (Category(..))
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor         ((<$>))
+import           Control.Applicative  (Applicative(..))
+#endif
+import qualified Data.Foldable        as F
+
+import Language.Hakaru.Syntax.IClasses (Some2(..))
+import Language.Hakaru.Syntax.Variable (memberVarSet)
+import Language.Hakaru.Syntax.ABT      (ABT(..), subst, maxNextFree)
+import Language.Hakaru.Syntax.DatumABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Evaluation.Types
+import Language.Hakaru.Evaluation.Lazy (evaluate)
+import Language.Hakaru.Evaluation.PEvalMonad (ListContext(..))
+
+
+-- The rest of these are just for the emit code, which isn't currently exported.
+import           Data.Text             (Text)
+import qualified Data.Text             as Text
+import qualified Data.Traversable      as T
+import Language.Hakaru.Syntax.IClasses (Functor11(..))
+import Language.Hakaru.Syntax.Variable (Variable(), toAssocs1)
+import Language.Hakaru.Syntax.ABT      (caseVarSyn, caseBinds, substs)
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing      (Sing, sUnPair)
+import Language.Hakaru.Syntax.TypeOf   (typeOf)
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Evaluation.Lazy (reifyPair)
+#ifdef __TRACE_DISINTEGRATE__
+import Debug.Trace                     (trace)
+#endif
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- | Call 'evaluate' on a term. This variant returns an @abt@ expression itself so you needn't worry about the 'Eval' monad. For the monadic-version, see 'pureEvaluate'.
+--
+-- BUG: now that we've indexed 'ListContext' by a 'Purity', does exposing the implementation details still enable clients to break our invariants?
+runPureEvaluate :: (ABT Term abt) => abt '[] a -> abt '[] a
+runPureEvaluate e = runEval (fromWhnf <$> pureEvaluate e) [Some2 e]
+
+
+-- 'evaluate' itself can never @lub@ or @bot@, as captured by the
+-- fact that it's type doesn't include 'Alternative' nor 'MonadPlus'
+-- constraints. So non-singularity of results could only come from
+-- calling @perform@. However, we will never call perform because: (a) the initial heap must be 'Pure' so we will never call @perform@ for a statement on the initial heap, and (b) 'evaluate' itself will never push impure statements so we will never call @perform@ for the statements we push either.
+--
+-- | Call 'evaluate' on a term. This variant returns something in the 'Eval' monad so you can string multiple evaluation calls together. For the non-monadic version, see 'runPureEvaluate'.
+pureEvaluate :: (ABT Term abt) => TermEvaluator abt (Eval abt)
+pureEvaluate = evaluate (brokenInvariant "perform")
+
+
+----------------------------------------------------------------
+type PureAns abt a = ListContext abt 'Pure -> abt '[] a
+
+newtype Eval abt x =
+    Eval { unEval :: forall a. (x -> PureAns abt a) -> PureAns abt a }
+
+brokenInvariant :: String -> a
+brokenInvariant loc = error (loc ++ ": Eval's invariant broken")
+
+
+-- | Run a computation in the 'Eval' monad, residualizing out all the
+-- statements in the final evaluation context. The second argument
+-- should include all the terms altered by the 'Eval' expression; this
+-- is necessary to ensure proper hygiene; for example(s):
+--
+-- > runEval (pureEvaluate e) [Some2 e]
+--
+-- We use 'Some2' on the inputs because it doesn't matter what their
+-- type or locally-bound variables are, so we want to allow @f@ to
+-- contain terms with different indices.
+runEval :: (ABT Term abt, F.Foldable f)
+    => Eval abt (abt '[] a)
+    -> f (Some2 abt)
+    -> abt '[] a
+runEval (Eval m) es =
+    m residualizePureListContext (ListContext (maxNextFree es) [])
+    
+
+residualizePureListContext
+    :: forall abt a
+    .  (ABT Term abt)
+    => abt '[] a
+    -> ListContext abt 'Pure
+    -> abt '[] a
+residualizePureListContext e0 =
+    foldl step e0 . statements
+    where
+    -- TODO: make paremetric in the purity, so we can combine 'residualizeListContext' with this function.
+    step :: abt '[] a -> Statement abt Location  'Pure -> abt '[] a
+    step e s =
+        case s of
+        SLet (Location x) body _
+            | not (x `memberVarSet` freeVars e) -> e
+            -- TODO: if used exactly once in @e@, then inline.
+            | otherwise ->
+                case getLazyVariable body of
+                Just y  -> subst x (var y) e
+                Nothing ->
+                    case getLazyLiteral body of
+                    Just v  -> subst x (syn $ Literal_ v) e
+                    Nothing ->
+                        syn (Let_ :$ fromLazy body :* bind x e :* End)
+                
+
+----------------------------------------------------------------
+instance Functor (Eval abt) where
+    fmap f (Eval m) = Eval $ \c -> m (c . f)
+
+instance Applicative (Eval abt) where
+    pure x              = Eval $ \c -> c x
+    Eval mf <*> Eval mx = Eval $ \c -> mf $ \f -> mx $ \x -> c (f x)
+
+instance Monad (Eval abt) where
+    return       = pure
+    Eval m >>= k = Eval $ \c -> m $ \x -> unEval (k x) c
+
+instance (ABT Term abt) => EvaluationMonad abt (Eval abt) 'Pure where
+    freshNat =
+        Eval $ \c (ListContext i ss) ->
+            c i (ListContext (i+1) ss)
+
+    unsafePush s =
+        Eval $ \c (ListContext i ss) ->
+            c () (ListContext i (s:ss))
+
+    -- N.B., the use of 'reverse' is necessary so that the order
+    -- of pushing matches that of 'pushes'
+    unsafePushes ss =
+        Eval $ \c (ListContext i ss') ->
+            c () (ListContext i (reverse ss ++ ss'))
+
+    select x p = loop []
+        where
+        -- TODO: use a DList to avoid reversing inside 'unsafePushes'
+        loop ss = do
+            ms <- unsafePop
+            case ms of
+                Nothing -> do
+                    unsafePushes ss
+                    return Nothing
+                Just s  ->
+                    -- Alas, @p@ will have to recheck 'isBoundBy'
+                    -- in order to grab the 'Refl' proof we erased;
+                    -- but there's nothing to be done for it.
+                    case x `isBoundBy` s >> p s of
+                    Nothing -> loop (s:ss)
+                    Just mr -> do
+                        r <- mr
+                        unsafePushes ss
+                        return (Just r)
+
+-- TODO: make parametric in the purity
+-- | Not exported because we only need it for defining 'select' on 'Eval'.
+unsafePop :: Eval abt (Maybe (Statement abt Location 'Pure))
+unsafePop =
+    Eval $ \c h@(ListContext i ss) ->
+        case ss of
+        []    -> c Nothing  h
+        s:ss' -> c (Just s) (ListContext i ss')
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- | Emit some code that binds a variable, and return the variable
+-- thus bound. The function says what to wrap the result of the
+-- continuation with; i.e., what we're actually emitting.
+emit
+    :: (ABT Term abt)
+    => Text
+    -> Sing a
+    -> (forall r. abt '[a] r -> abt '[] r)
+    -> Eval abt (Variable a)
+emit hint typ f = do
+    x <- freshVar hint typ
+    Eval $ \c h -> (f . bind x) $ c x h
+
+
+-- | A smart constructor for emitting let-bindings. If the input
+-- is already a variable then we just return it; otherwise we emit
+-- the let-binding. N.B., this function provides the invariant that
+-- the result is in fact a variable; whereas 'emitLet'' does not.
+emitLet :: (ABT Term abt) => abt '[] a -> Eval abt (Variable a)
+emitLet e =
+    caseVarSyn e return $ \_ ->
+        emit Text.empty (typeOf e) $ \f ->
+            syn (Let_ :$ e :* f :* End)
+
+-- | A smart constructor for emitting let-bindings. If the input
+-- is already a variable or a literal constant, then we just return
+-- it; otherwise we emit the let-binding. N.B., this function
+-- provides weaker guarantees on the type of the result; if you
+-- require the result to always be a variable, then see 'emitLet'
+-- instead.
+emitLet' :: (ABT Term abt) => abt '[] a -> Eval abt (abt '[] a)
+emitLet' e =
+    caseVarSyn e (const $ return e) $ \t ->
+        case t of
+        Literal_ _ -> return e
+        _          -> do
+            x <- emit Text.empty (typeOf e) $ \f ->
+                syn (Let_ :$ e :* f :* End)
+            return (var x)
+
+-- | A smart constructor for emitting \"unpair\". If the input
+-- argument is actually a constructor then we project out the two
+-- components; otherwise we emit the case-binding and return the
+-- two variables.
+emitUnpair
+    :: (ABT Term abt)
+    => Whnf abt (HPair a b)
+    -> Eval abt (abt '[] a, abt '[] b)
+emitUnpair (Head_   w) = return $ reifyPair w
+emitUnpair (Neutral e) = do
+    let (a,b) = sUnPair (typeOf e)
+    x <- freshVar Text.empty a
+    y <- freshVar Text.empty b
+    emitUnpair_ x y e
+
+emitUnpair_
+    :: forall abt a b
+    .  (ABT Term abt)
+    => Variable a
+    -> Variable b
+    -> abt '[] (HPair a b)
+    -> Eval abt (abt '[] a, abt '[] b)
+emitUnpair_ x y = loop
+    where
+    done :: abt '[] (HPair a b) -> Eval abt (abt '[] a, abt '[] b)
+    done e =
+#ifdef __TRACE_DISINTEGRATE__
+        trace "-- emitUnpair: done (term is not Datum_ nor Case_)" $
+#endif
+        Eval $ \c h ->
+            ( syn
+            . Case_ e
+            . (:[])
+            . Branch (pPair PVar PVar)
+            . bind x
+            . bind y
+            ) $ c (var x, var y) h
+
+    loop :: abt '[] (HPair a b) -> Eval abt (abt '[] a, abt '[] b)
+    loop e0 =
+        caseVarSyn e0 (done . var) $ \t ->
+            case t of
+            Datum_ d   -> do
+#ifdef __TRACE_DISINTEGRATE__
+                trace "-- emitUnpair: found Datum_" $ return ()
+#endif
+                return $ reifyPair (WDatum d)
+            Case_ e bs -> do
+#ifdef __TRACE_DISINTEGRATE__
+                trace "-- emitUnpair: going under Case_" $ return ()
+#endif
+                -- TODO: we want this to duplicate the current
+                -- continuation for (the evaluation of @loop@ in)
+                -- all branches. So far our traces all end up
+                -- returning @bot@ on the first branch, and hence
+                -- @bot@ for the whole case-expression, so we can't
+                -- quite tell whether it does what is intended.
+                --
+                -- N.B., the only 'Eval'-effects in 'applyBranch'
+                -- are to freshen variables; thus this use of
+                -- 'traverse' is perfectly sound.
+                emitCaseWith loop e bs
+            _ -> done e0
+
+-- TODO: emitUneither
+
+-- | Run each of the elements of the traversable using the same
+-- heap and continuation for each one, then pass the results to a
+-- function for emitting code.
+emitFork_
+    :: (ABT Term abt, T.Traversable t)
+    => (forall r. t (abt '[] r) -> abt '[] r)
+    -> t (Eval abt a)
+    -> Eval abt a
+emitFork_ f ms =
+    Eval $ \c h -> f $ fmap (\m -> unEval m c h) ms
+
+
+emitCaseWith
+    :: (ABT Term abt)
+    => (abt '[] b -> Eval abt r)
+    -> abt '[] a
+    -> [Branch a abt b]
+    -> Eval abt r
+emitCaseWith f e bs = do
+    gms <- T.for bs $ \(Branch pat body) ->
+        let (vars, body') = caseBinds body
+        in  (\vars' ->
+                let rho = toAssocs1 vars (fmap11 var vars')
+                in  GBranch pat vars' (f $ substs rho body')
+            ) <$> freshenVars vars
+    Eval $ \c h ->
+        syn (Case_ e
+            (map (fromGBranch . fmap (\m -> unEval m c h)) gms))
+{-# INLINE emitCaseWith #-}
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Evaluation/ExpectMonad.hs b/haskell/Language/Hakaru/Evaluation/ExpectMonad.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Evaluation/ExpectMonad.hs
@@ -0,0 +1,215 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , KindSignatures
+           , DataKinds
+           , Rank2Types
+           , ScopedTypeVariables
+           , MultiParamTypeClasses
+           , FlexibleContexts
+           , FlexibleInstances
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.24
+-- |
+-- Module      :  Language.Hakaru.Evaluation.ExpectMonad
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--
+----------------------------------------------------------------
+module Language.Hakaru.Evaluation.ExpectMonad
+    ( pureEvaluate
+    
+    -- * The expectation-evaluation monad
+    -- ** List-based version
+    , ListContext(..), ExpectAns, Expect(..), runExpect
+    , residualizeExpectListContext
+    -- ** TODO: IntMap-based version
+    
+    -- * ...
+    , emit
+    , emit_
+    ) where
+
+import           Prelude              hiding (id, (.))
+import           Control.Category     (Category(..))
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor         ((<$>))
+import           Control.Applicative  (Applicative(..))
+#endif
+import qualified Data.Foldable        as F
+
+import Language.Hakaru.Syntax.IClasses (Some2(..))
+import Language.Hakaru.Syntax.ABT      (ABT(..), caseVarSyn, subst, maxNextFreeOrBind)
+import Language.Hakaru.Syntax.Variable (memberVarSet)
+import Language.Hakaru.Syntax.AST      hiding (Expect)
+import Language.Hakaru.Syntax.Transform (TransformCtx(..))
+import Language.Hakaru.Evaluation.Types
+import Language.Hakaru.Evaluation.Lazy (evaluate)
+import Language.Hakaru.Evaluation.PEvalMonad (ListContext(..))
+
+
+-- The rest of these are just for the emit code, which isn't currently exported.
+import Data.Text                       (Text)
+import Language.Hakaru.Syntax.Variable (Variable())
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing      (Sing)
+#ifdef __TRACE_DISINTEGRATE__
+import Debug.Trace                     (trace)
+#endif
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+type ExpectAns abt = ListContext abt 'ExpectP -> abt '[] 'HProb
+
+newtype Expect abt x =
+    Expect { unExpect :: (x -> ExpectAns abt) -> ExpectAns abt }
+
+residualizeExpectListContext
+    :: forall abt
+    .  (ABT Term abt)
+    => abt '[] 'HProb
+    -> ListContext abt 'ExpectP
+    -> abt '[] 'HProb
+residualizeExpectListContext e0 =
+    foldl step e0 . statements
+    where
+    -- TODO: make paremetric in the purity, so we can combine 'residualizeListContext' with this function.
+    step :: abt '[] 'HProb -> Statement abt Location 'ExpectP -> abt '[] 'HProb
+    step e s =
+        case s of
+        SLet (Location x) body _
+            -- BUG: this trick for dropping unused let-bindings doesn't seem to work anymore... (cf., 'Tests.Expect.test4')
+            | not (x `memberVarSet` freeVars e) -> e
+            -- TODO: if used exactly once in @e@, then inline.
+            | otherwise ->
+                case getLazyVariable body of
+                Just y  -> subst x (var y) e
+                Nothing ->
+                    case getLazyLiteral body of
+                    Just v  -> subst x (syn $ Literal_ v) e
+                    Nothing ->
+                        syn (Let_ :$ fromLazy body :* bind x e :* End)
+        SStuff0    f _ -> f e
+        SStuff1 _x f _ -> f e
+
+
+pureEvaluate :: (ABT Term abt) => TermEvaluator abt (Expect abt)
+pureEvaluate = evaluate (brokenInvariant "perform")
+
+brokenInvariant :: String -> a
+brokenInvariant loc = error (loc ++ ": Expect's invariant broken")
+
+
+-- | Run a computation in the 'Expect' monad, residualizing out all
+-- the statements in the final evaluation context. The second
+-- argument should include all the terms altered by the 'Eval'
+-- expression; this is necessary to ensure proper hygiene; for
+-- example(s):
+--
+-- > runExpect (pureEvaluate e) [Some2 e]
+--
+-- We use 'Some2' on the inputs because it doesn't matter what their
+-- type or locally-bound variables are, so we want to allow @f@ to
+-- contain terms with different indices.
+runExpect
+    :: forall abt f a
+    .  (ABT Term abt, F.Foldable f)
+    => Expect abt (abt '[] a)
+    -> TransformCtx
+    -> abt '[a] 'HProb
+    -> f (Some2 abt)
+    -> abt '[] 'HProb
+runExpect (Expect m) ctx f es =
+    m c0 h0
+    where
+    i0   = maximum [nextFreeOrBind f, maxNextFreeOrBind es, nextFreeVar ctx]
+    h0   = ListContext i0 []
+    c0 e =
+        residualizeExpectListContext $
+        caseVarSyn e
+            (\x -> caseBind f $ \y f' -> subst y (var x) f')
+            (\_ -> syn (Let_ :$ e :* f :* End))
+        -- TODO: make this smarter still, to drop the let-binding entirely if it's not used in @f@.
+
+
+----------------------------------------------------------------
+instance Functor (Expect abt) where
+    fmap f (Expect m) = Expect $ \c -> m (c . f)
+
+instance Applicative (Expect abt) where
+    pure x                  = Expect $ \c -> c x
+    Expect mf <*> Expect mx = Expect $ \c -> mf $ \f -> mx $ \x -> c (f x)
+
+instance Monad (Expect abt) where
+    return         = pure
+    Expect m >>= k = Expect $ \c -> m $ \x -> unExpect (k x) c
+
+instance (ABT Term abt) => EvaluationMonad abt (Expect abt) 'ExpectP where
+    freshNat =
+        Expect $ \c (ListContext i ss) ->
+            c i (ListContext (i+1) ss)
+
+    unsafePush s =
+        Expect $ \c (ListContext i ss) ->
+            c () (ListContext i (s:ss))
+
+    -- N.B., the use of 'reverse' is necessary so that the order
+    -- of pushing matches that of 'pushes'
+    unsafePushes ss =
+        Expect $ \c (ListContext i ss') ->
+            c () (ListContext i (reverse ss ++ ss'))
+
+    select x p = loop []
+        where
+        -- TODO: use a DList to avoid reversing inside 'unsafePushes'
+        loop ss = do
+            ms <- unsafePop
+            case ms of
+                Nothing -> do
+                    unsafePushes ss
+                    return Nothing
+                Just s  ->
+                    -- Alas, @p@ will have to recheck 'isBoundBy'
+                    -- in order to grab the 'Refl' proof we erased;
+                    -- but there's nothing to be done for it.
+                    case x `isBoundBy` s >> p s of
+                    Nothing -> loop (s:ss)
+                    Just mr -> do
+                        r <- mr
+                        unsafePushes ss
+                        return (Just r)
+
+-- TODO: make paremetric in the purity
+-- | Not exported because we only need it for defining 'select' on 'Expect'.
+unsafePop :: Expect abt (Maybe (Statement abt Location 'ExpectP))
+unsafePop =
+    Expect $ \c h@(ListContext i ss) ->
+        case ss of
+        []    -> c Nothing  h
+        s:ss' -> c (Just s) (ListContext i ss')
+
+----------------------------------------------------------------
+emit
+    :: (ABT Term abt)
+    => Text
+    -> Sing a
+    -> (abt '[a] 'HProb -> abt '[] 'HProb)
+    -> Expect abt (Variable a)
+emit hint typ f = do
+    x <- freshVar hint typ
+    Expect $ \c h -> (f . bind x) $ c x h
+
+emit_
+    :: (ABT Term abt)
+    => (abt '[] 'HProb -> abt '[] 'HProb)
+    -> Expect abt ()
+emit_ f = Expect $ \c h -> f $ c () h
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Evaluation/Lazy.hs b/haskell/Language/Hakaru/Evaluation/Lazy.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Evaluation/Lazy.hs
@@ -0,0 +1,681 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , DataKinds
+           , KindSignatures
+           , MultiParamTypeClasses
+           , FunctionalDependencies
+           , ScopedTypeVariables
+           , FlexibleContexts
+           , Rank2Types
+           , TypeSynonymInstances
+           , FlexibleInstances
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.28
+-- |
+-- Module      :  Language.Hakaru.Evaluation.Lazy
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Lazy partial evaluation.
+--
+-- BUG: completely gave up on structure sharing. Need to add that
+-- back in. cf., @gvidal-lopstr07lncs.pdf@ for an approach much
+-- like my old one.
+----------------------------------------------------------------
+module Language.Hakaru.Evaluation.Lazy
+    ( evaluate
+    -- ** Helper functions
+    , evaluateNaryOp
+    , evaluatePrimOp
+    , evaluateArrayOp
+    -- ** Helpers that should really go away
+    , Interp(..), reifyPair
+    ) where
+
+import           Prelude                hiding (id, (.))
+import           Control.Category       (Category(..))
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor           ((<$>))
+#endif
+import           Control.Monad          ((<=<))
+import           Control.Monad.Identity (Identity, runIdentity)
+import           Data.Sequence          (Seq)
+import qualified Data.Sequence          as Seq
+import qualified Data.Text              as Text
+
+import Language.Hakaru.Syntax.IClasses
+import Data.Number.Nat
+import Data.Number.Natural
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.DatumCase (DatumEvaluator, MatchState(..), matchTopPattern)
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Evaluation.Types
+import qualified Language.Hakaru.Syntax.Prelude as P
+{-
+-- BUG: can't import this because of cyclic dependency
+import qualified Language.Hakaru.Expect         as E
+-}
+
+#ifdef __TRACE_DISINTEGRATE__
+import Language.Hakaru.Pretty.Haskell (pretty)
+import Debug.Trace (trace)
+#endif
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: (eventually) accept an argument dictating the evaluation
+-- strategy (HNF, WHNF, full-beta NF,...). The strategy value should
+-- probably be a family of singletons, where the type-level strategy
+-- @s@ is also an index on the 'Context' and (the renamed) 'Whnf'.
+-- That way we don't need to define a bunch of variant 'Context',
+-- 'Statement', and 'Whnf' data types; but rather can use indexing
+-- to select out subtypes of the generic versions.
+
+
+-- | Lazy partial evaluation with some given \"perform\" and
+-- \"evaluateCase\" functions. N.B., if @p ~ 'Pure@ then the
+-- \"perform\" function will never be called.
+evaluate
+    :: forall abt m p
+    .  (ABT Term abt, EvaluationMonad abt m p)
+    => MeasureEvaluator abt m
+    -> TermEvaluator    abt m
+{-# INLINE evaluate #-}
+evaluate perform = evaluate_
+    where
+    evaluateCase_ :: CaseEvaluator abt m
+    evaluateCase_ = evaluateCase evaluate_
+
+    evaluate_ :: TermEvaluator abt m
+    evaluate_ e0 =
+#ifdef __TRACE_DISINTEGRATE__
+      trace ("-- evaluate_: " ++ show (pretty e0)) $
+#endif
+      caseVarSyn e0 (evaluateVar perform evaluate_) $ \t ->
+        case t of
+        -- Things which are already WHNFs
+        Literal_ v               -> return . Head_ $ WLiteral v
+        Datum_   d               -> return . Head_ $ WDatum   d
+        Empty_   typ             -> return . Head_ $ WEmpty   typ
+        Array_   e1 e2           -> return . Head_ $ WArray e1 e2
+        ArrayLiteral_ es         -> return . Head_ $ WArrayLiteral es
+        Lam_  :$ e1 :* End       -> return . Head_ $ WLam   e1
+        Dirac :$ e1 :* End       -> return . Head_ $ WDirac e1
+        MBind :$ e1 :* e2 :* End -> return . Head_ $ WMBind e1 e2
+        Plate :$ e1 :* e2 :* End -> return . Head_ $ WPlate e1 e2
+        MeasureOp_ o :$ es       -> return . Head_ $ WMeasureOp o es
+        Superpose_ pes           -> return . Head_ $ WSuperpose pes
+        Reject_ typ              -> return . Head_ $ WReject typ
+        -- We don't bother evaluating these, even though we could...
+        Integrate :$ e1 :* e2 :* e3 :* End ->
+            return . Head_ $ WIntegrate e1 e2 e3
+        Summate _ _ :$ _ :* _ :* _ :* End ->
+            return . Neutral $ syn t
+            --return . Head_ $ WSummate   e1 e2 e3
+
+
+        -- Everything else needs some evaluation
+
+        App_ :$ e1 :* e2 :* End -> do
+            w1 <- evaluate_ e1
+            case w1 of
+                Neutral e1' -> return . Neutral $ P.app e1' e2
+                Head_   v1  -> evaluateApp v1
+            where
+            evaluateApp (WLam f)   =
+                -- call-by-name:
+                caseBind f $ \x f' -> do
+                    i <- getIndices
+                    push (SLet x (Thunk e2) i) f' >>= evaluate_
+            evaluateApp _ = error "evaluate{App_}: the impossible happened"
+
+        Let_ :$ e1 :* e2 :* End -> do
+            i <- getIndices
+            caseBind e2 $ \x e2' ->
+                push (SLet x (Thunk e1) i) e2' >>= evaluate_
+
+        CoerceTo_   c :$ e1 :* End -> coerceTo   c <$> evaluate_ e1
+        UnsafeFrom_ c :$ e1 :* End -> coerceFrom c <$> evaluate_ e1
+
+        -- TODO: will maybe clean up the code to map 'evaluate' over @es@ before calling the evaluateFooOp helpers?
+        NaryOp_  o    es -> evaluateNaryOp  evaluate_ o es
+        ArrayOp_ o :$ es -> evaluateArrayOp evaluate_ o es
+        PrimOp_  o :$ es -> evaluatePrimOp  evaluate_ o es
+
+        Transform_ tt :$ _ -> error $
+            concat ["TODO: evaluate{", show tt, "}"
+                   ,": cannot evaluate transforms; expand them first"]
+
+        Case_ e bs -> evaluateCase_ e bs
+        -- Bucket_ _ _ _ _ -> error "What oh what to do with a Bucket here?"
+
+        _ :$ _ -> error "evaluate: the impossible happened"
+
+
+----------------------------------------------------------------
+-- BUG: need to improve the types so they can capture polymorphic data types
+-- BUG: this is a **really gross** hack. If we can avoid it, we should!!!
+class Interp a a' | a -> a' where
+    reify   :: (ABT Term abt) => Head abt a -> a'
+    reflect :: (ABT Term abt) => a' -> Head abt a
+
+instance Interp 'HNat Natural where
+    reflect = WLiteral . LNat
+    reify (WLiteral (LNat n)) = n
+    reify (WCoerceTo   _ _) = error "TODO: reify{WCoerceTo}"
+    reify (WUnsafeFrom _ _) = error "TODO: reify{WUnsafeFrom}"
+
+instance Interp 'HInt Integer where
+    reflect = WLiteral . LInt
+    reify (WLiteral (LInt i)) = i
+    reify (WCoerceTo   _ _) = error "TODO: reify{WCoerceTo}"
+    reify (WUnsafeFrom _ _) = error "TODO: reify{WUnsafeFrom}"
+
+instance Interp 'HProb NonNegativeRational where
+    reflect = WLiteral . LProb
+    reify (WLiteral (LProb p)) = p
+    reify (WCoerceTo   _ _)   = error "TODO: reify{WCoerceTo}"
+    reify (WUnsafeFrom _ _)   = error "TODO: reify{WUnsafeFrom}"
+    reify (WIntegrate  _ _ _) = error "TODO: reify{WIntegrate}"
+    --reify (WSummate    _ _ _) = error "TODO: reify{WSummate}"
+
+instance Interp 'HReal Rational where
+    reflect = WLiteral . LReal
+    reify (WLiteral (LReal r)) = r
+    reify (WCoerceTo   _ _) = error "TODO: reify{WCoerceTo}"
+    reify (WUnsafeFrom _ _) = error "TODO: reify{WUnsafeFrom}"
+
+
+identifyDatum :: (ABT Term abt) => DatumEvaluator (abt '[]) Identity
+identifyDatum = return . (viewWhnfDatum <=< toWhnf)
+
+-- HACK: this requires -XTypeSynonymInstances and -XFlexibleInstances
+-- This instance does seem to work; albeit it's trivial...
+instance Interp HUnit () where
+    reflect () = WDatum dUnit
+    reify v = runIdentity $ do
+        match <- matchTopPattern identifyDatum (fromHead v) pUnit Nil1
+        case match of
+            Just (Matched_ _ss Nil1) -> return ()
+            _ -> error "reify{HUnit}: the impossible happened"
+
+-- HACK: this requires -XTypeSynonymInstances and -XFlexibleInstances
+-- This instance also seems to work...
+instance Interp HBool Bool where
+    reflect = WDatum . (\b -> if b then dTrue else dFalse)
+    reify v = runIdentity $ do
+        matchT <- matchTopPattern identifyDatum (fromHead v) pTrue Nil1
+        case matchT of
+            Just (Matched_ _ss Nil1) -> return True
+            Just GotStuck_ -> error "reify{HBool}: the impossible happened"
+            Nothing -> do
+                matchF <- matchTopPattern identifyDatum (fromHead v) pFalse Nil1
+                case matchF of
+                    Just (Matched_ _ss Nil1) -> return False
+                    _ -> error "reify{HBool}: the impossible happened"
+
+
+-- TODO: can't we just use 'viewHeadDatum' and match on that?
+reifyPair
+    :: (ABT Term abt) => Head abt (HPair a b) -> (abt '[] a, abt '[] b)
+reifyPair v =
+    let impossible = error "reifyPair: the impossible happened"
+        e0    = fromHead v
+        n     = nextFree e0
+        (a,b) = sUnPair $ typeOf e0
+        x = Variable Text.empty n       a
+        y = Variable Text.empty (1 + n) b
+
+    in runIdentity $ do
+        match <- matchTopPattern identifyDatum e0 (pPair PVar PVar) (Cons1 x (Cons1 y Nil1))
+        case match of
+            Just (Matched_ ss Nil1) ->
+                case ss [] of
+                [Assoc x' e1, Assoc y' e2] ->
+                    maybe impossible id $ do
+                        Refl <- varEq x x'
+                        Refl <- varEq y y'
+                        Just $ return (e1, e2)
+                _ -> impossible
+            _ -> impossible
+{-
+instance Interp (HPair a b) (abt '[] a, abt '[] b) where
+    reflect (a,b) = P.pair a b
+    reify = reifyPair
+
+instance Interp (HEither a b) (Either (abt '[] a) (abt '[] b)) where
+    reflect (Left  a) = P.left  a
+    reflect (Right b) = P.right b
+    reify =
+
+instance Interp (HMaybe a) (Maybe (abt '[] a)) where
+    reflect Nothing  = P.nothing
+    reflect (Just a) = P.just a
+    reify =
+
+data ListHead (a :: Hakaru)
+    = NilHead
+    | ConsHead (abt '[] a) (abt '[] (HList a)) -- modulo scoping of @abt@
+
+instance Interp (HList a) (ListHead a) where
+    reflect []     = P.nil
+    reflect (x:xs) = P.cons x xs
+    reify =
+-}
+
+
+impl, diff, nand, nor :: Bool -> Bool -> Bool
+impl x y = not x || y
+diff x y = x && not y
+nand x y = not (x && y)
+nor  x y = not (x || y)
+
+-- BUG: no Floating instance for LogFloat (nor NonNegativeRational), so can't actually use this...
+-- natRoot :: (Floating a) => a -> Nat -> a
+-- natRoot x y = x ** recip (fromIntegral (fromNat y))
+
+
+----------------------------------------------------------------
+evaluateNaryOp
+    :: (ABT Term abt, EvaluationMonad abt m p)
+    => TermEvaluator abt m
+    -> NaryOp a
+    -> Seq (abt '[] a)
+    -> m (Whnf abt a)
+evaluateNaryOp evaluate_ = \o es -> mainLoop o (evalOp o) Seq.empty es
+    where
+    -- TODO: there's got to be a more efficient way to do this...
+    mainLoop o op ws es =
+        case Seq.viewl es of
+        Seq.EmptyL   -> return $
+            case Seq.viewl ws of
+            Seq.EmptyL         -> identityElement o -- Avoid empty naryOps
+            w Seq.:< ws'
+                | Seq.null ws' -> w -- Avoid singleton naryOps
+                | otherwise    ->
+                    Neutral . syn . NaryOp_ o $ fmap fromWhnf ws
+        e Seq.:< es' -> do
+            w <- evaluate_ e
+            case matchNaryOp o w of
+                Nothing  -> mainLoop o op (snocLoop op ws w) es'
+                Just es2 -> mainLoop o op ws (es2 Seq.>< es')
+
+    snocLoop
+        :: (ABT syn abt)
+        => (Head abt a -> Head abt a -> Head abt a)
+        -> Seq (Whnf abt a)
+        -> Whnf abt a
+        -> Seq (Whnf abt a)
+    snocLoop op ws w1 =
+        -- TODO: immediately return @ws@ if @w1 == identityElement o@ (whenever identityElement is defined)
+        case Seq.viewr ws of
+        Seq.EmptyR    -> Seq.singleton w1
+        ws' Seq.:> w2 ->
+            case (w1,w2) of
+            (Head_ v1, Head_ v2) -> snocLoop op ws' (Head_ (op v1 v2))
+            _                    -> ws Seq.|> w1
+
+    matchNaryOp
+        :: (ABT Term abt)
+        => NaryOp a
+        -> Whnf abt a
+        -> Maybe (Seq (abt '[] a))
+    matchNaryOp o w =
+        case w of
+        Head_   _ -> Nothing
+        Neutral e ->
+            caseVarSyn e (const Nothing) $ \t ->
+                case t of
+                NaryOp_ o' es | o' == o -> Just es
+                _                       -> Nothing
+
+    -- TODO: move this off to Prelude.hs or somewhere...
+    identityElement :: (ABT Term abt) => NaryOp a -> Whnf abt a
+    identityElement o =
+        case o of
+        And    -> Head_ (WDatum dTrue)
+        Or     -> Head_ (WDatum dFalse)
+        Xor    -> Head_ (WDatum dFalse)
+        Iff    -> Head_ (WDatum dTrue)
+        Min  _ -> Neutral (syn (NaryOp_ o Seq.empty)) -- no identity in general (but we could do it by cases...)
+        Max  _ -> Neutral (syn (NaryOp_ o Seq.empty)) -- no identity in general (but we could do it by cases...)
+        -- TODO: figure out how to reuse 'P.zero_' and 'P.one_' here; requires converting thr @(syn . Literal_)@ into @(Head_ . WLiteral)@. Maybe we should change 'P.zero_' and 'P.one_' so they just return the 'Literal' itself rather than the @abt@?
+        Sum  HSemiring_Nat  -> Head_ (WLiteral (LNat  0))
+        Sum  HSemiring_Int  -> Head_ (WLiteral (LInt  0))
+        Sum  HSemiring_Prob -> Head_ (WLiteral (LProb 0))
+        Sum  HSemiring_Real -> Head_ (WLiteral (LReal 0))
+        Prod HSemiring_Nat  -> Head_ (WLiteral (LNat  1))
+        Prod HSemiring_Int  -> Head_ (WLiteral (LInt  1))
+        Prod HSemiring_Prob -> Head_ (WLiteral (LProb 1))
+        Prod HSemiring_Real -> Head_ (WLiteral (LReal 1))
+
+    -- | The evaluation interpretation of each NaryOp
+    evalOp
+        :: (ABT Term abt)
+        => NaryOp a
+        -> Head abt a
+        -> Head abt a
+        -> Head abt a
+    -- TODO: something more efficient\/direct if we can...
+    evalOp And      = \v1 v2 -> reflect (reify v1 && reify v2)
+    evalOp Or       = \v1 v2 -> reflect (reify v1 || reify v2)
+    evalOp Xor      = \v1 v2 -> reflect (reify v1 /= reify v2)
+    evalOp Iff      = \v1 v2 -> reflect (reify v1 == reify v2)
+    evalOp (Min  _) = error "TODO: evalOp{Min}"
+    evalOp (Max  _) = error "TODO: evalOp{Max}"
+    {-
+    evalOp (Min  _) = \v1 v2 -> reflect (reify v1 `min` reify v2)
+    evalOp (Max  _) = \v1 v2 -> reflect (reify v1 `max` reify v2)
+    evalOp (Sum  _) = \v1 v2 -> reflect (reify v1 + reify v2)
+    evalOp (Prod _) = \v1 v2 -> reflect (reify v1 * reify v2)
+    -}
+    -- HACK: this is just to have something to test. We really should reduce\/remove all this boilerplate...
+    evalOp (Sum  theSemi) =
+        \(WLiteral v1) (WLiteral v2) -> WLiteral $ evalSum  theSemi v1 v2
+    evalOp (Prod theSemi) =
+        \(WLiteral v1) (WLiteral v2) -> WLiteral $ evalProd theSemi v1 v2
+
+    -- TODO: even if only one of the arguments is a literal, if that literal is zero\/one, then we can still partially evaluate it. (As is done in the old finally-tagless code)
+    evalSum, evalProd :: HSemiring a -> Literal a -> Literal a -> Literal a
+    evalSum  HSemiring_Nat  = \(LNat  n1) (LNat  n2) -> LNat  (n1 + n2)
+    evalSum  HSemiring_Int  = \(LInt  i1) (LInt  i2) -> LInt  (i1 + i2)
+    evalSum  HSemiring_Prob = \(LProb p1) (LProb p2) -> LProb (p1 + p2)
+    evalSum  HSemiring_Real = \(LReal r1) (LReal r2) -> LReal (r1 + r2)
+    evalProd HSemiring_Nat  = \(LNat  n1) (LNat  n2) -> LNat  (n1 * n2)
+    evalProd HSemiring_Int  = \(LInt  i1) (LInt  i2) -> LInt  (i1 * i2)
+    evalProd HSemiring_Prob = \(LProb p1) (LProb p2) -> LProb (p1 * p2)
+    evalProd HSemiring_Real = \(LReal r1) (LReal r2) -> LReal (r1 * r2)
+
+
+----------------------------------------------------------------
+evaluateArrayOp
+    :: ( ABT Term abt, EvaluationMonad abt m p
+       , typs ~ UnLCs args, args ~ LCs typs)
+    => TermEvaluator abt m
+    -> ArrayOp typs a
+    -> SArgs abt args
+    -> m (Whnf abt a)
+evaluateArrayOp evaluate_ = go
+    where
+    go o@(Index _) = \(e1 :* e2 :* End) -> do
+        let -- idxCode :: abt '[] ('HArray a) -> abt '[] 'HNat -> abt '[] a
+            -- idxCode a i = Neutral $ syn (ArrayOp_ o :$ a :* i :* End)
+        w1 <- evaluate_ e1
+        case w1 of
+            Neutral e1' -> 
+                return . Neutral $ syn (ArrayOp_ o :$ e1' :* e2 :* End)
+            Head_ (WArray _ b) ->
+                caseBind b $ \x body -> extSubst x e2 body >>= evaluate_
+            Head_ (WEmpty _)   ->
+                error "TODO: evaluateArrayOp{Index}{Head_ (WEmpty _)}"
+            Head_ (WArrayLiteral arr) ->
+                do w2 <- evaluate_ e2
+                   case w2 of
+                     Head_ (WLiteral (LNat n)) -> return . Neutral $ 
+                                                  arr !! fromInteger (fromNatural n)
+                     _  -> return . Neutral $
+                           syn (ArrayOp_ o :$ fromWhnf w1 :* fromWhnf w2 :* End)
+            _ -> error "evaluateArrayOp{Index}: uknown whnf of array type"
+
+    go o@(Size _) = \(e1 :* End) -> do
+        w1 <- evaluate_ e1
+        case w1 of
+            Neutral e1' -> return . Neutral $ syn (ArrayOp_ o :$ e1' :* End)
+            Head_ (WEmpty _)    -> return . Head_ $ WLiteral (LNat 0)
+            Head_ (WArray e2 _) -> evaluate_ e2
+            Head_ (WArrayLiteral es) -> return . Head_ . WLiteral .
+                                        primCoerceFrom (Signed HRing_Int) .
+                                        LInt . toInteger $ length es
+            Head_ _ -> error "Got something odd when evaluating an array"
+
+    go (Reduce _) = \(_ :* _ :* _ :* End) ->
+        error "TODO: evaluateArrayOp{Reduce}"
+
+----------------------------------------------------------------
+-- TODO: maybe we should adjust 'Whnf' to have a third option for
+-- closed terms of the atomic\/literal types, so that we can avoid
+-- reducing them just yet. Of course, we'll have to reduce them
+-- eventually, but we can leave that for the runtime evaluation or
+-- Maple or whatever. These are called \"annotated\" terms in Fischer
+-- et al 2008 (though they allow anything to be annotated, not just
+-- closed terms of atomic type).
+evaluatePrimOp
+    :: forall abt m p typs args a
+    .  ( ABT Term abt, EvaluationMonad abt m p
+       , typs ~ UnLCs args, args ~ LCs typs)
+    => TermEvaluator abt m
+    -> PrimOp typs a
+    -> SArgs abt args
+    -> m (Whnf abt a)
+evaluatePrimOp evaluate_ = go
+    where
+    -- HACK: we don't have any way of saying these functions haven't reduced even though it's not actually a neutral term.
+    neu1 :: forall b c
+        .  (abt '[] b -> abt '[] c)
+        -> abt '[] b
+        -> m (Whnf abt c)
+    neu1 f e = (Neutral . f . fromWhnf) <$> evaluate_ e
+
+    neu2 :: forall b c d
+        .  (abt '[] b -> abt '[] c -> abt '[] d)
+        -> abt '[] b
+        -> abt '[] c   
+        -> m (Whnf abt d)
+    neu2 f e1 e2 = do e1' <- fromWhnf <$> evaluate_ e1
+                      e2' <- fromWhnf <$> evaluate_ e2
+                      return . Neutral $ f e1' e2'
+
+    rr1 :: forall b b' c c'
+        .  (Interp b b', Interp c c')
+        => (b' -> c')
+        -> (abt '[] b -> abt '[] c)
+        -> abt '[] b
+        -> m (Whnf abt c)
+    rr1 f' f e = do
+        w <- evaluate_ e
+        return $
+            case w of
+            Neutral e' -> Neutral $ f e'
+            Head_   v  -> Head_ . reflect $ f' (reify v)
+
+    rr2 :: forall b b' c c' d d'
+        .  (Interp b b', Interp c c', Interp d d')
+        => (b' -> c' -> d')
+        -> (abt '[] b -> abt '[] c -> abt '[] d)
+        -> abt '[] b
+        -> abt '[] c
+        -> m (Whnf abt d)
+    rr2 f' f e1 e2 = do
+        w1 <- evaluate_ e1
+        w2 <- evaluate_ e2
+        return $
+            case w1 of
+            Neutral e1' -> Neutral $ f e1' (fromWhnf w2)
+            Head_   v1  ->
+                case w2 of
+                Neutral e2' -> Neutral $ f (fromWhnf w1) e2'
+                Head_   v2  -> Head_ . reflect $ f' (reify v1) (reify v2)
+
+    primOp2_
+        :: forall b c d
+        .  PrimOp '[ b, c ] d -> abt '[] b -> abt '[] c -> abt '[] d
+    primOp2_ o e1 e2 = syn (PrimOp_ o :$ e1 :* e2 :* End)
+
+    -- TODO: something more efficient\/direct if we can...
+    go Not  (e1 :* End)       = rr1 not  P.not  e1
+    go Impl (e1 :* e2 :* End) = rr2 impl (primOp2_ Impl) e1 e2
+    go Diff (e1 :* e2 :* End) = rr2 diff (primOp2_ Diff) e1 e2
+    go Nand (e1 :* e2 :* End) = rr2 nand P.nand e1 e2
+    go Nor  (e1 :* e2 :* End) = rr2 nor  P.nor  e1 e2
+
+    -- HACK: we don't have a way of saying that 'Pi' (or 'Infinity',...) is in fact a head; so we're forced to call it neutral which is a lie. We should add constructor(s) to 'Head' to cover these magic constants; probably grouped together under a single constructor called something like @Constant@. Maybe should group them like that in the AST as well?
+    go Pi        End               = return $ Neutral P.pi
+
+    -- We treat trig functions as strict, thus forcing their
+    -- arguments; however, to avoid fuzz issues we don't actually
+    -- evaluate the trig functions.
+    --
+    -- HACK: we might should have some other way to make these
+    -- 'Whnf' rather than calling them neutral terms; since they
+    -- aren't, in fact, neutral!
+    go Sin       (e1 :* End)       = neu1 P.sin   e1
+    go Cos       (e1 :* End)       = neu1 P.cos   e1
+    go Tan       (e1 :* End)       = neu1 P.tan   e1
+    go Asin      (e1 :* End)       = neu1 P.asin  e1
+    go Acos      (e1 :* End)       = neu1 P.acos  e1
+    go Atan      (e1 :* End)       = neu1 P.atan  e1
+    go Sinh      (e1 :* End)       = neu1 P.sinh  e1
+    go Cosh      (e1 :* End)       = neu1 P.cosh  e1
+    go Tanh      (e1 :* End)       = neu1 P.tanh  e1
+    go Asinh     (e1 :* End)       = neu1 P.asinh e1
+    go Acosh     (e1 :* End)       = neu1 P.acosh e1
+    go Atanh     (e1 :* End)       = neu1 P.atanh e1
+    go Floor      (e1 :* End)      = neu1 P.floor e1
+
+    -- TODO: deal with how we have better types for these three ops than Haskell does...
+    -- go RealPow   (e1 :* e2 :* End) = rr2 (**) (P.**) e1 e2
+    go RealPow   (e1 :* e2 :* End) = neu2 (P.**) e1 e2
+    go Choose    (e1 :* e2 :* End) = neu2 (P.choose) e1 e2
+
+    -- HACK: these aren't actually neutral!
+    -- BUG: we should try to cancel out @(exp . log)@ and @(log . exp)@
+    go Exp       (e1 :* End)       = neu1 P.exp e1
+    go Log       (e1 :* End)       = neu1 P.log e1
+
+    -- HACK: these aren't actually neutral!
+    go (Infinity h)     End        =
+        case h of
+          HIntegrable_Nat  -> return . Neutral $ P.primOp0_ (Infinity h)
+          HIntegrable_Prob -> return $ Neutral P.infinity
+
+    go GammaFunc   (e1 :* End)            = neu1 P.gammaFunc e1
+    go BetaFunc    (e1 :* e2 :* End)      = neu2 P.betaFunc  e1 e2
+
+    go (Equal  theEq)   (e1 :* e2 :* End) = rrEqual theEq  e1 e2
+    go (Less   theOrd)  (e1 :* e2 :* End) = rrLess  theOrd e1 e2
+    go (NatPow theSemi) (e1 :* e2 :* End) =
+        case theSemi of
+        HSemiring_Nat    -> rr2 (\v1 v2 -> v1 ^ fromNatural v2) (P.^) e1 e2
+        HSemiring_Int    -> rr2 (\v1 v2 -> v1 ^ fromNatural v2) (P.^) e1 e2
+        HSemiring_Prob   -> rr2 (\v1 v2 -> v1 ^ fromNatural v2) (P.^) e1 e2
+        HSemiring_Real   -> rr2 (\v1 v2 -> v1 ^ fromNatural v2) (P.^) e1 e2
+    go (Negate theRing) (e1 :* End) =
+        case theRing of
+        HRing_Int        -> rr1 negate P.negate e1
+        HRing_Real       -> rr1 negate P.negate e1
+    go (Abs    theRing) (e1 :* End) =
+        case theRing of
+        HRing_Int        -> rr1 (unsafeNatural . abs) P.abs_ e1
+        HRing_Real       -> rr1 (unsafeNonNegativeRational  . abs) P.abs_ e1
+    go (Signum theRing) (e1 :* End) =
+        case theRing of
+        HRing_Int        -> rr1 signum P.signum e1
+        HRing_Real       -> rr1 signum P.signum e1
+    go (Recip  theFractional) (e1 :* End) =
+        case theFractional of
+        HFractional_Prob -> rr1 recip  P.recip  e1
+        HFractional_Real -> rr1 recip  P.recip  e1
+    go (NatRoot theRadical) (e1 :* e2 :* End) =
+        case theRadical of
+        HRadical_Prob -> neu2 (flip P.thRootOf) e1 e2
+    {-
+    go (NatRoot theRadical) (e1 :* e2 :* End) =
+        case theRadical of
+        HRadical_Prob -> rr2 natRoot (flip P.thRootOf) e1 e2
+    go (Erf theContinuous) (e1 :* End) =
+        case theContinuous of
+        HContinuous_Prob -> rr1 erf P.erf e1
+        HContinuous_Real -> rr1 erf P.erf e1
+    -}
+    go op _ = error $ "TODO: evaluatePrimOp{" ++ show op ++ "}"
+
+
+    rrEqual
+        :: forall b. HEq b -> abt '[] b -> abt '[] b -> m (Whnf abt HBool)
+    rrEqual theEq =
+        case theEq of
+        HEq_Nat    -> rr2 (==) (P.==)
+        HEq_Int    -> rr2 (==) (P.==)
+        HEq_Prob   -> rr2 (==) (P.==)
+        HEq_Real   -> rr2 (==) (P.==)
+        HEq_Array _ -> error "TODO: rrEqual{HEq_Array}"
+        HEq_Bool   -> rr2 (==) (P.==)
+        HEq_Unit   -> rr2 (==) (P.==)
+        HEq_Pair   aEq bEq ->
+            \e1 e2 -> do
+                w1 <- evaluate_ e1
+                w2 <- evaluate_ e2
+                case w1 of
+                    Neutral e1' ->
+                        return . Neutral
+                            $ P.primOp2_ (Equal theEq) e1' (fromWhnf w2)
+                    Head_   v1  ->
+                        case w2 of
+                        Neutral e2' ->
+                            return . Neutral
+                                $ P.primOp2_ (Equal theEq) (fromHead v1) e2'
+                        Head_ v2 -> do
+                            let (v1a, v1b) = reifyPair v1
+                            let (v2a, v2b) = reifyPair v2
+                            wa <- rrEqual aEq v1a v2a
+                            wb <- rrEqual bEq v1b v2b
+                            return $
+                                case wa of
+                                Neutral ea ->
+                                    case wb of
+                                    Neutral eb -> Neutral (ea P.&& eb)
+                                    Head_   vb
+                                        | reify vb  -> wa
+                                        | otherwise -> Head_ $ WDatum dFalse
+                                Head_ va
+                                    | reify va  -> wb
+                                    | otherwise -> Head_ $ WDatum dFalse
+
+        HEq_Either _ _ -> error "TODO: rrEqual{HEq_Either}"
+
+    rrLess
+        :: forall b. HOrd b -> abt '[] b -> abt '[] b -> m (Whnf abt HBool)
+    rrLess theOrd =
+        case theOrd of
+        HOrd_Nat    -> rr2 (<) (P.<)
+        HOrd_Int    -> rr2 (<) (P.<)
+        HOrd_Prob   -> rr2 (<) (P.<)
+        HOrd_Real   -> rr2 (<) (P.<)
+        HOrd_Array _ -> error "TODO: rrLess{HOrd_Array}"
+        HOrd_Bool   -> rr2 (<) (P.<)
+        HOrd_Unit   -> rr2 (<) (P.<)
+        HOrd_Pair _ _ ->
+            \e1 e2 -> do
+                w1 <- evaluate_ e1
+                w2 <- evaluate_ e2
+                case w1 of
+                    Neutral e1' ->
+                        return . Neutral
+                            $ P.primOp2_ (Less theOrd) e1' (fromWhnf w2)
+                    Head_   v1  ->
+                        case w2 of
+                        Neutral e2' ->
+                            return . Neutral
+                                $ P.primOp2_ (Less theOrd) (fromHead v1) e2'
+                        Head_ v2 -> do
+                            let (_, _) = reifyPair v1
+                            let (_, _) = reifyPair v2
+                            error "TODO: rrLess{HOrd_Pair}"
+                            -- BUG: The obvious recursion won't work because we need to know when the first components are equal before recursing (to implement lexicographic ordering). We really need a ternary comparison operator like 'compare'.
+        HOrd_Either _ _ -> error "TODO: rrLess{HOrd_Either}"
+
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Evaluation/PEvalMonad.hs b/haskell/Language/Hakaru/Evaluation/PEvalMonad.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Evaluation/PEvalMonad.hs
@@ -0,0 +1,662 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , KindSignatures
+           , DataKinds
+           , TypeOperators
+           , Rank2Types
+           , BangPatterns
+           , FlexibleContexts
+           , MultiParamTypeClasses
+           , FunctionalDependencies
+           , FlexibleInstances
+           , UndecidableInstances
+           , EmptyCase
+           , ScopedTypeVariables
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.24
+-- |
+-- Module      :  Language.Hakaru.Evaluation.PEvalMonad
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- A unified 'EvaluationMonad' for pure evaluation, expect, and
+-- disintegrate.
+----------------------------------------------------------------
+module Language.Hakaru.Evaluation.PEvalMonad
+    (
+    -- * The unified 'PEval' monad
+    -- ** List-based version
+      ListContext(..), PAns, PEval(..)
+    , runPureEval, runImpureEval, runExpectEval
+    -- ** TODO: IntMap-based version
+    
+    -- * Operators on the disintegration monad
+    -- ** The \"zero\" and \"one\"
+    , bot
+    --, reject
+    -- ** Emitting code
+    , emit
+    , emitMBind
+    , emitLet
+    , emitLet'
+    , emitUnpair
+    -- TODO: emitUneither
+    -- emitCaseWith
+    , emit_
+    , emitMBind_
+    , emitGuard
+    , emitWeight
+    , emitFork_
+    , emitSuperpose
+    , choose
+    ) where
+
+import           Prelude              hiding (id, (.))
+import           Control.Category     (Category(..))
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Monoid          (Monoid(..))
+import           Data.Functor         ((<$>))
+import           Control.Applicative  (Applicative(..))
+#endif
+import qualified Data.Foldable        as F
+import qualified Data.Traversable     as T
+import qualified Data.List.NonEmpty   as NE
+import           Control.Applicative  (Alternative(..))
+import           Control.Monad        (MonadPlus(..))
+import           Data.Text            (Text)
+import qualified Data.Text            as Text
+
+import Language.Hakaru.Syntax.IClasses
+import Data.Number.Nat
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing    (Sing, sUnMeasure, sUnPair)
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.DatumABT
+import qualified Language.Hakaru.Syntax.Prelude as P
+import Language.Hakaru.Evaluation.Types
+import Language.Hakaru.Evaluation.Lazy (reifyPair)
+
+#ifdef __TRACE_DISINTEGRATE__
+import Debug.Trace (trace)
+#endif
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- | An ordered collection of statements representing the context
+-- surrounding the current focus of our program transformation.
+-- That is, since some transformations work from the bottom up, we
+-- need to keep track of the statements we passed along the way
+-- when reaching for the bottom.
+--
+-- The tail of the list takes scope over the head of the list. Thus,
+-- the back\/end of the list is towards the top of the program,
+-- whereas the front of the list is towards the bottom.
+--
+-- This type was formerly called @Heap@ (presumably due to the
+-- 'Statement' type being called @Binding@) but that seems like a
+-- misnomer to me since this really has nothing to do with allocation.
+-- However, it is still like a heap inasmuch as it's a dependency
+-- graph and we may wish to change the topological sorting or remove
+-- \"garbage\" (subject to correctness criteria).
+--
+-- TODO: Figure out what to do with 'SWeight', 'SGuard', 'SStuff',
+-- etc, so that we can use an @IntMap (Statement abt)@ in order to
+-- speed up the lookup times in 'select'. (Assuming callers don't
+-- use 'unsafePush' unsafely: we can recover the order things were
+-- inserted from their 'varID' since we've freshened them all and
+-- therefore their IDs are monotonic in the insertion order.)
+data ListContext (abt :: [Hakaru] -> Hakaru -> *) (p :: Purity) =
+    ListContext
+    { nextFreshNat :: {-# UNPACK #-} !Nat
+    , statements   :: [Statement abt Location p]
+    }
+
+
+-- HACK: we can't use a type family and do @abt xs (P p a)@ because
+-- of non-injectivity. So we make this a GADT instead. Because it's
+-- a GADT, there's a bunch of ugly rewrapping required; but everything
+-- seems to work out just fine...
+data P :: Purity -> ([Hakaru] -> Hakaru -> *) -> [Hakaru] -> Hakaru -> *
+    where
+    PPure   :: !(abt xs a)             -> P 'Pure    abt xs a
+    PImpure :: !(abt xs ('HMeasure a)) -> P 'Impure  abt xs a
+    PExpect :: !(abt xs 'HProb)        -> P 'ExpectP abt xs a
+
+unPPure :: P 'Pure abt xs a -> abt xs a
+unPPure (PPure e) = e
+
+unPImpure :: P 'Impure abt xs a -> abt xs ('HMeasure a)
+unPImpure (PImpure e) = e
+
+unPExpect :: P 'ExpectP abt xs a -> abt xs 'HProb
+unPExpect (PExpect e) = e
+
+mapPPure :: (abt xs a -> abt ys b) -> P 'Pure abt xs a -> P 'Pure abt ys b
+mapPPure f (PPure e) = PPure (f e)
+
+mapPImpure
+    :: (abt xs ('HMeasure a) -> abt ys ('HMeasure b))
+    -> P 'Impure abt xs a
+    -> P 'Impure abt ys b
+mapPImpure f (PImpure e) = PImpure (f e)
+
+mapPExpect
+    :: (abt xs 'HProb -> abt ys 'HProb)
+    -> P 'ExpectP abt xs a
+    -> P 'ExpectP abt ys b
+mapPExpect f (PExpect e) = PExpect (f e)
+
+mapP
+    :: (forall a. abt xs a -> abt ys a)
+    -> P p abt xs b
+    -> P p abt ys b
+mapP f (PPure   e) = PPure   $ f e
+mapP f (PImpure e) = PImpure $ f e
+mapP f (PExpect e) = PExpect $ f e
+
+-- | Plug a term into a context. That is, the 'statements' of the
+-- context specifies a program with a hole in it; so we plug the
+-- given term into that hole, returning the complete program.
+residualizeListContext
+    :: forall abt p a
+    .  (ABT Term abt)
+    => ListContext abt p
+    -> P p abt '[] a
+    -> P p abt '[] a
+residualizeListContext =
+    -- N.B., we use a left fold because the head of the list of
+    -- statements is the one closest to the hole.
+    \ss e0 -> foldl (flip step) e0 (statements ss)
+    where
+    step
+        :: Statement abt Location p
+        -> P p abt '[] a
+        -> P p abt '[] a
+    step (SLet  (Location x) body _)  = mapP $ residualizeLet x body
+    step (SBind (Location x) body _) = mapPImpure $ \e ->
+        -- TODO: if @body@ is dirac, then treat as 'SLet'
+        syn (MBind :$ fromLazy body :* bind x e :* End)
+    step (SGuard xs pat scrutinee _) = mapPImpure $ \e ->
+        -- TODO: avoid adding the 'PWild' branch if we know @pat@ covers the type
+        syn $ Case_ (fromLazy scrutinee)
+            [ Branch pat   $ binds_ (fromLocations1 xs) e
+            , Branch PWild $ P.reject (typeOf e)
+            ]
+    step (SWeight body _) = mapPImpure $ P.withWeight (fromLazy body)
+    step (SStuff0    f _) = mapPExpect f
+    step (SStuff1 _x f _) = mapPExpect f
+
+
+-- TODO: move this to Prelude? Is there anyone else that actually needs these smarts?
+residualizeLet
+    :: (ABT Term abt) => Variable a -> Lazy abt a -> abt '[] b -> abt '[] b
+residualizeLet x body scope
+    -- Drop unused bindings
+    | not (x `memberVarSet` freeVars scope) = scope
+    -- TODO: if used exactly once in @e@, then inline.
+    | otherwise =
+        case getLazyVariable body of
+        Just y  -> subst x (var y) scope
+        Nothing ->
+            case getLazyLiteral body of
+            Just v  -> subst x (syn $ Literal_ v) scope
+            Nothing ->
+                syn (Let_ :$ fromLazy body :* bind x scope :* End)
+
+----------------------------------------------------------------
+type PAns p abt m a = ListContext abt p -> m (P p abt '[] a)
+
+
+----------------------------------------------------------------
+-- TODO: defunctionalize the continuation. In particular, the only
+-- heap modifications we need are 'push' and a variant of 'update'
+-- for finding\/replacing a binding once we have the value in hand;
+-- and the only 'freshNat' modifications are to allocate new 'Nat'.
+-- We could defunctionalize the second arrow too by relying on the
+-- @Codensity (ReaderT e m) ~= StateT e (Codensity m)@ isomorphism,
+-- which makes explicit that the only thing other than 'ListContext'
+-- updates is emitting something like @[Statement]@ to serve as the
+-- beginning of the final result.
+--
+-- | TODO: give this a better, more informative name!
+newtype PEval abt p m x =
+    PEval { unPEval :: forall a. (x -> PAns p abt m a) -> PAns p abt m a }
+    -- == Codensity (PAns p abt m)
+
+
+-- | Run an 'Impure' computation in the 'PEval' monad, residualizing
+-- out all the statements in the final evaluation context. The
+-- second argument should include all the terms altered by the
+-- 'PEval' expression; this is necessary to ensure proper hygiene;
+-- for example(s):
+--
+-- > runPEval (perform e) [Some2 e]
+-- > runPEval (constrainOutcome e v) [Some2 e, Some2 v]
+--
+-- We use 'Some2' on the inputs because it doesn't matter what their
+-- type or locally-bound variables are, so we want to allow @f@ to
+-- contain terms with different indices.
+runImpureEval
+    :: (ABT Term abt, Applicative m, F.Foldable f)
+    => PEval abt 'Impure m (abt '[] a)
+    -> f (Some2 abt)
+    -> m (abt '[] ('HMeasure a))
+runImpureEval m es =
+    unPImpure <$> unPEval m c0 h0
+    where
+    i0      = maxNextFree es -- TODO: is maxNextFreeOrBind better here?
+    h0      = ListContext i0 []
+    -- TODO: we only use dirac because 'residualizeListContext'
+    -- requires it to already be a measure; unfortunately this can
+    -- result in an extraneous @(>>= \x -> dirac x)@ redex at the
+    -- end of the program. In principle, we should be able to
+    -- eliminate that redex by changing the type of
+    -- 'residualizeListContext'...
+    c0 e ss =
+        pure
+        . residualizeListContext ss
+        . PImpure
+        $ syn(Dirac :$ e :* End)
+
+runPureEval
+    :: (ABT Term abt, Applicative m, F.Foldable f)
+    => PEval abt 'Pure m (abt '[] a)
+    -> f (Some2 abt)
+    -> m (abt '[] a)
+runPureEval m es =
+    unPPure <$> unPEval m c0 h0
+    where
+    i0      = maxNextFree es -- TODO: is maxNextFreeOrBind better here?
+    h0      = ListContext i0 []
+    c0 e ss = pure . residualizeListContext ss $ PPure e
+
+runExpectEval
+    :: (ABT Term abt, Applicative m, F.Foldable f)
+    => PEval abt 'ExpectP m (abt '[] a)
+    -> abt '[a] 'HProb
+    -> f (Some2 abt)
+    -> m (abt '[] 'HProb)
+runExpectEval m f es =
+    unPExpect <$> unPEval m c0 h0
+    where
+    i0      = nextFreeOrBind f `max` maxNextFreeOrBind es
+    h0      = ListContext i0 []
+    c0 e ss =
+        pure
+        . residualizeListContext ss
+        . PExpect
+        $ caseVarSyn e
+            (\x -> caseBind f $ \y f' -> subst y (var x) f')
+            (\_ -> syn (Let_ :$ e :* f :* End))
+        -- TODO: make this smarter still, to drop the let-binding entirely if it's not used in @f@.
+
+
+instance Functor (PEval abt p m) where
+    fmap f m = PEval $ \c -> unPEval m (c . f)
+
+instance Applicative (PEval abt p m) where
+    pure x    = PEval $ \c -> c x
+    mf <*> mx = PEval $ \c -> unPEval mf $ \f -> unPEval mx $ \x -> c (f x)
+
+instance Monad (PEval abt p m) where
+    return   = pure
+    mx >>= k = PEval $ \c -> unPEval mx $ \x -> unPEval (k x) c
+
+instance Alternative m => Alternative (PEval abt p m) where
+    empty   = PEval $ \_ _ -> empty
+    m <|> n = PEval $ \c h -> unPEval m c h <|> unPEval n c h
+
+instance Alternative m => MonadPlus (PEval abt p m) where
+    mzero = empty -- aka "bot"
+    mplus = (<|>) -- aka "lub"
+
+instance (ABT Term abt) => EvaluationMonad abt (PEval abt p m) p where
+    freshNat =
+        PEval $ \c (ListContext i ss) ->
+            c i (ListContext (i+1) ss)
+
+    unsafePush s =
+        PEval $ \c (ListContext i ss) ->
+            c () (ListContext i (s:ss))
+
+    -- N.B., the use of 'reverse' is necessary so that the order
+    -- of pushing matches that of 'pushes'
+    unsafePushes ss =
+        PEval $ \c (ListContext i ss') ->
+            c () (ListContext i (reverse ss ++ ss'))
+
+    select x p = loop []
+        where
+        -- TODO: use a DList to avoid reversing inside 'unsafePushes'
+        loop ss = do
+            ms <- unsafePop
+            case ms of
+                Nothing -> do
+                    unsafePushes ss
+                    return Nothing
+                Just s  ->
+                    -- Alas, @p@ will have to recheck 'isBoundBy'
+                    -- in order to grab the 'Refl' proof we erased;
+                    -- but there's nothing to be done for it.
+                    case x `isBoundBy` s >> p s of
+                    Nothing -> loop (s:ss) -- BUG: we only want to loop if @x@ isn't bound by @s@; if it is bound but @p@ fails (e.g., because @s@ is 'Stuff1'), then we should fail/stop (thus the return type should be @2+r@ to distinguish no-match = free vs failed-match = bound-but-inalterable)
+                    Just mr -> do
+                        r <- mr
+                        unsafePushes ss
+                        return (Just r)
+
+-- | Not exported because we only need it for defining 'select' on 'PEval'.
+unsafePop :: PEval abt p m (Maybe (Statement abt Location p))
+unsafePop =
+    PEval $ \c h@(ListContext i ss) ->
+        case ss of
+        []    -> c Nothing  h
+        s:ss' -> c (Just s) (ListContext i ss')
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- | It is impossible to satisfy the constraints, or at least we
+-- give up on trying to do so. This function is identical to 'empty'
+-- and 'mzero' for 'PEval'; we just give it its own name since this is
+-- the name used in our papers.
+--
+-- TODO: add some sort of trace information so we can get a better
+-- idea what caused a disintegration to fail.
+bot :: (ABT Term abt, Alternative m) => PEval abt p m a
+bot = empty
+
+
+{-
+-- BUG: no longer typechecks after splitting 'Reject_' out from 'Superpose_'
+-- | The empty measure is a solution to the constraints.
+reject :: (ABT Term abt) => PEval abt p m a
+reject = PEval $ \_ _ -> return . P.reject $ SMeasure sing
+-}
+
+
+-- Something essentially like this function was called @insert_@
+-- in the finally-tagless code.
+--
+-- | Emit some code that binds a variable, and return the variable
+-- thus bound. The function says what to wrap the result of the
+-- continuation with; i.e., what we're actually emitting.
+emit
+    :: (ABT Term abt, Functor m)
+    => Text
+    -> Sing a
+    -> (forall r. P p abt '[a] r -> P p abt '[] r)
+    -> PEval abt p m (Variable a)
+emit hint typ f = do
+    x <- freshVar hint typ
+    PEval $ \c h -> (f . mapP (bind x)) <$> c x h
+
+
+-- This function was called @lift@ in the finally-tagless code.
+-- | Emit an 'MBind' (i.e., \"@m >>= \x ->@\") and return the
+-- variable thus bound (i.e., @x@).
+emitMBind
+    :: (ABT Term abt, Functor m)
+    => abt '[] ('HMeasure a)
+    -> PEval abt 'Impure m (Variable a)
+emitMBind m =
+    emit Text.empty (sUnMeasure $ typeOf m) $ \(PImpure e) ->
+        PImpure $ syn (MBind :$ m :* e :* End)
+
+
+-- | A smart constructor for emitting let-bindings. If the input
+-- is already a variable then we just return it; otherwise we emit
+-- the let-binding. N.B., this function provides the invariant that
+-- the result is in fact a variable; whereas 'emitLet'' does not.
+emitLet
+    :: (ABT Term abt, Functor m) => abt '[] a -> PEval abt p m (Variable a)
+emitLet e =
+    caseVarSyn e return $ \_ ->
+        -- N.B., must use the second @($)@ here because rank-2 polymorphism
+        emit Text.empty (typeOf e) $ mapP $ \m ->
+            syn (Let_ :$ e :* m :* End)
+
+-- | A smart constructor for emitting let-bindings. If the input
+-- is already a variable or a literal constant, then we just return
+-- it; otherwise we emit the let-binding. N.B., this function
+-- provides weaker guarantees on the type of the result; if you
+-- require the result to always be a variable, then see 'emitLet'
+-- instead.
+emitLet'
+    :: (ABT Term abt, Functor m) => abt '[] a -> PEval abt p m (abt '[] a)
+emitLet' e =
+    caseVarSyn e (const $ return e) $ \t ->
+        case t of
+        Literal_ _ -> return e
+        _ -> do
+            -- N.B., must use the second @($)@ here because rank-2 polymorphism
+            x <- emit Text.empty (typeOf e) $ mapP $ \m ->
+                syn (Let_ :$ e :* m :* End)
+            return (var x)
+
+-- | A smart constructor for emitting \"unpair\". If the input
+-- argument is actually a constructor then we project out the two
+-- components; otherwise we emit the case-binding and return the
+-- two variables.
+emitUnpair
+    :: (ABT Term abt, Applicative m)
+    => Whnf abt (HPair a b)
+    -> PEval abt p m (abt '[] a, abt '[] b)
+emitUnpair (Head_   w) = return $ reifyPair w
+emitUnpair (Neutral e) = do
+    let (a,b) = sUnPair (typeOf e)
+    x <- freshVar Text.empty a
+    y <- freshVar Text.empty b
+    emitUnpair_ x y e
+
+emitUnpair_
+    :: forall abt p m a b
+    .  (ABT Term abt, Applicative m)
+    => Variable a
+    -> Variable b
+    -> abt '[] (HPair a b)
+    -> PEval abt p m (abt '[] a, abt '[] b)
+emitUnpair_ x y = loop
+    where
+    done :: abt '[] (HPair a b) -> PEval abt p m (abt '[] a, abt '[] b)
+    done e =
+#ifdef __TRACE_DISINTEGRATE__
+        trace "-- emitUnpair: done (term is not Datum_ nor Case_)" $
+#endif
+        PEval $ \c h ->
+            mapP ( syn
+            . Case_ e
+            . (:[])
+            . Branch (pPair PVar PVar)
+            . bind x
+            . bind y
+            ) <$> c (var x, var y) h
+
+    loop :: abt '[] (HPair a b) -> PEval abt p m (abt '[] a, abt '[] b)
+    loop e0 =
+        caseVarSyn e0 (done . var) $ \t ->
+            case t of
+            Datum_ d   -> do
+#ifdef __TRACE_DISINTEGRATE__
+                trace "-- emitUnpair: found Datum_" $ return ()
+#endif
+                return $ reifyPair (WDatum d)
+            Case_ e bs -> do
+#ifdef __TRACE_DISINTEGRATE__
+                trace "-- emitUnpair: going under Case_" $ return ()
+#endif
+                -- TODO: we want this to duplicate the current
+                -- continuation for (the evaluation of @loop@ in)
+                -- all branches. So far our traces all end up
+                -- returning @bot@ on the first branch, and hence
+                -- @bot@ for the whole case-expression, so we can't
+                -- quite tell whether it does what is intended.
+                --
+                -- N.B., the only 'PEval'-effects in 'applyBranch'
+                -- are to freshen variables; thus this use of
+                -- 'traverse' is perfectly sound.
+                emitCaseWith loop e bs
+            _ -> done e0
+
+
+-- TODO: emitUneither
+
+
+-- This function was called @insert_@ in the old finally-tagless code.
+-- | Emit some code that doesn't bind any variables. This function
+-- provides an optimisation over using 'emit' and then discarding
+-- the generated variable.
+emit_
+    :: (ABT Term abt, Functor m)
+    => (forall r. P p abt '[] r -> P p abt '[] r)
+    -> PEval abt p m ()
+emit_ f = PEval $ \c h -> f <$> c () h
+
+
+-- | Emit an 'MBind' that discards its result (i.e., \"@m >>@\").
+-- We restrict the type of the argument to be 'HUnit' so as to avoid
+-- accidentally dropping things.
+emitMBind_
+    :: (ABT Term abt, Functor m)
+    => abt '[] ('HMeasure HUnit)
+    -> PEval abt 'Impure m ()
+emitMBind_ m = emit_ $ mapPImpure (m P.>>)
+
+
+-- TODO: if the argument is a value, then we can evaluate the 'P.if_' immediately rather than emitting it.
+-- | Emit an assertion that the condition is true.
+emitGuard
+    :: (ABT Term abt, Functor m)
+    => abt '[] HBool
+    -> PEval abt 'Impure m ()
+emitGuard b = emit_ $ mapPImpure (P.withGuard b)
+    -- == emit_ $ \m -> P.if_ b m P.reject
+
+-- TODO: if the argument is the literal 1, then we can avoid emitting anything.
+emitWeight
+    :: (ABT Term abt, Functor m)
+    => abt '[] 'HProb
+    -> PEval abt 'Impure m ()
+emitWeight w = emit_ $ mapPImpure (P.withWeight w)
+
+
+-- N.B., this use of 'T.traverse' is definitely correct. It's
+-- sequentializing @t [abt '[] ('HMeasure a)]@ into @[t (abt '[]
+-- ('HMeasure a))]@ by chosing one of the possibilities at each
+-- position in @t@. No heap\/context effects can escape to mess
+-- things up. In contrast, using 'T.traverse' to sequentialize @t
+-- (PEval abt a)@ as @PEval abt (t a)@ is /wrong/! Doing that would give
+-- the conjunctive semantics where we have effects from one position
+-- in @t@ escape to affect the other positions. This has to do with
+-- the general issue in partial evaluation where we need to duplicate
+-- downstream work (as we do by passing the same heap to everyone)
+-- because there's no general way to combing the resulting heaps
+-- for each branch.
+--
+-- | Run each of the elements of the traversable using the same
+-- heap and continuation for each one, then pass the results to a
+-- function for emitting code.
+emitFork_
+    :: (ABT Term abt, Applicative m, T.Traversable t)
+    => (forall r. t (P p abt '[] r) -> P p abt '[] r)
+    -> t (PEval abt p m a)
+    -> PEval abt p m a
+emitFork_ f ms =
+    PEval $ \c h -> f <$> T.traverse (\m -> unPEval m c h) ms
+
+
+-- | Emit a 'Superpose_' of the alternatives, each with unit weight.
+emitSuperpose
+    :: (ABT Term abt, Functor m)
+    => [abt '[] ('HMeasure a)]
+    -> PEval abt 'Impure m (Variable a)
+emitSuperpose []  = error "BUG: emitSuperpose: can't use Prelude.superpose because it'll throw an error"
+emitSuperpose [e] = emitMBind e
+emitSuperpose es  =
+    emitMBind . P.superpose . fmap ((,) P.one) $ NE.fromList es
+
+
+-- | Emit a 'Superpose_' of the alternatives, each with unit weight.
+choose
+    :: (ABT Term abt, Applicative m)
+    => [PEval abt 'Impure m a]
+    -> PEval abt 'Impure m a
+choose []  = error "BUG: choose: can't use Prelude.superpose because it'll throw an error"
+choose [m] = m
+choose ms  =
+    emitFork_
+        (PImpure . P.superpose . fmap ((,) P.one . unPImpure) . NE.fromList)
+        ms
+
+
+-- | Given some function we can call on the bodies of the branches,
+-- freshen all the pattern-bound variables and then run the function
+-- on all the branches in parallel (i.e., with the same continuation
+-- and heap) and then emit a case-analysis expression with the
+-- results of the continuations as the bodies of the branches. This
+-- function is useful for when we really do want to emit a 'Case_'
+-- expression, rather than doing the superpose of guard patterns
+-- thing that 'constrainValue' does.
+--
+-- N.B., this function assumes (and does not verify) that the second
+-- argument is emissible. So callers must guarantee this invariant,
+-- by calling 'atomize' as necessary.
+--
+-- TODO: capture the emissibility requirement on the second argument
+-- in the types.
+emitCaseWith
+    :: (ABT Term abt, Applicative m)
+    => (abt '[] b -> PEval abt p m r)
+    -> abt '[] a
+    -> [Branch a abt b]
+    -> PEval abt p m r
+emitCaseWith f e bs = do
+    error "TODO: emitCaseWith"
+{-
+-- BUG: this doesn't typecheck with keeping @p@ polymorphic...
+    gms <- T.for bs $ \(Branch pat body) ->
+        let (vars, body') = caseBinds body
+        in  (\vars' ->
+                let rho = toAssocs vars (fmap11 var vars')
+                in  GBranch pat vars' (f $ substs rho body')
+            ) <$> freshenVars vars
+    PEval $ \c h ->
+        (syn . Case_ e) <$> T.for gms (\gm ->
+            fromGBranch <$> T.for gm (\m ->
+                unPEval m c h))
+{-# INLINE emitCaseWith #-}
+-}
+
+
+-- HACK: to get the one case we really need to work at least.
+emitCaseWith_Impure
+    :: (ABT Term abt, Applicative m)
+    => (abt '[] b -> PEval abt 'Impure m r)
+    -> abt '[] a
+    -> [Branch a abt b]
+    -> PEval abt 'Impure m r
+emitCaseWith_Impure f e bs = do
+    gms <- T.for bs $ \(Branch pat body) ->
+        let (vars, body') = caseBinds body
+        in  (\vars' ->
+                let rho = toAssocs1 vars (fmap11 var vars')
+                in  GBranch pat vars' (f $ substs rho body')
+            ) <$> freshenVars vars
+    PEval $ \c h ->
+        (PImpure . syn . Case_ e) <$> T.for gms (\gm ->
+            fromGBranch <$> T.for gm (\m ->
+                unPImpure <$> unPEval m c h))
+{-# INLINE emitCaseWith_Impure #-}
+
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Evaluation/Types.hs b/haskell/Language/Hakaru/Evaluation/Types.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Evaluation/Types.hs
@@ -0,0 +1,1140 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , KindSignatures
+           , DataKinds
+           , PolyKinds
+           , TypeOperators
+           , Rank2Types
+           , BangPatterns
+           , FlexibleContexts
+           , MultiParamTypeClasses
+           , FunctionalDependencies
+           , FlexibleInstances
+           , UndecidableInstances
+           , EmptyCase
+           , ScopedTypeVariables
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.28
+-- |
+-- Module      :  Language.Hakaru.Evaluation.Types
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- The data types for "Language.Hakaru.Evaluation.Lazy"
+--
+-- BUG: completely gave up on structure sharing. Need to add that back in.
+--
+-- TODO: once we figure out the exact API\/type of 'evaluate' and
+-- can separate it from Disintegrate.hs vs its other clients (i.e.,
+-- Sample.hs and Expect.hs), this file will prolly be broken up
+-- into Lazy.hs itself vs Disintegrate.hs
+----------------------------------------------------------------
+module Language.Hakaru.Evaluation.Types
+    (
+    -- * Terms in particular known forms\/formats
+      Head(..), fromHead, toHead, viewHeadDatum
+    , Whnf(..), fromWhnf, toWhnf, caseWhnf, viewWhnfDatum
+    , Lazy(..), fromLazy, caseLazy
+    , getLazyVariable, isLazyVariable
+    , getLazyLiteral,  isLazyLiteral
+
+    -- * Lazy partial evaluation
+    , TermEvaluator
+    , MeasureEvaluator
+    , CaseEvaluator
+    , VariableEvaluator
+    
+    -- * The monad for partial evaluation
+    , Purity(..), Statement(..), statementVars, isBoundBy
+    , Index, indVar, indSize, fromIndex
+    , Location(..), locEq, locHint, locType, locations1
+    , fromLocation, fromLocations1, freshenLoc, freshenLocs
+    , LAssoc, LAssocs , emptyLAssocs, singletonLAssocs
+    , toLAssocs1, insertLAssocs, lookupLAssoc
+#ifdef __TRACE_DISINTEGRATE__
+    , ppList
+    , ppInds
+    , ppStatement
+    , pretty_Statements
+    , pretty_Statements_withTerm
+    , prettyAssocs
+#endif
+    , EvaluationMonad(..)
+    , defaultCaseEvaluator
+    , toVarStatements
+    , extSubst
+    , extSubsts
+    , freshVar
+    , freshenVar
+    , Hint(..), freshVars
+    , freshenVars
+    , freshInd
+    {- TODO: should we expose these?
+    , freshLocStatement
+    , push_
+    -}
+    , push
+    , pushes
+    ) where
+
+import           Prelude              hiding (id, (.))
+import           Control.Category     (Category(..))
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Monoid          (Monoid(..))
+import           Data.Functor         ((<$>))
+import           Control.Applicative  (Applicative(..))
+import           Data.Traversable
+#endif
+import           Control.Arrow        ((***))
+import qualified Data.Foldable        as F
+import           Data.List.NonEmpty   (NonEmpty(..))
+import qualified Data.Text            as T
+import           Data.Text            (Text)
+import           Data.Proxy           (KProxy(..))
+
+import Language.Hakaru.Syntax.IClasses
+import Data.Number.Nat
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing    (Sing(..))
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.DatumCase (DatumEvaluator,
+                                         MatchResult(..),
+                                         matchBranches)
+import Language.Hakaru.Syntax.AST.Eq (alphaEq)
+-- import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.ABT
+import qualified Language.Hakaru.Syntax.Prelude as P
+
+#ifdef __TRACE_DISINTEGRATE__
+import qualified Text.PrettyPrint     as PP
+import Language.Hakaru.Pretty.Haskell
+import           Debug.Trace          (trace)
+#endif
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- N.B., when putting things into the context, be sure to freshen
+-- the variables as if we were allocating a new location on the
+-- heap.
+--
+-- For simplicity we don't actually distinguish between "variables"
+-- and "locations". In the old finally-tagless code we had an @s@
+-- parameter like the 'ST' monad does in order to keep track of
+-- which heap things belong to. But since we might have nested
+-- disintegration, and thus nested heaps, doing that means we'd
+-- have to do some sort of De Bruijn numbering in the @s@ parameter
+-- in order to keep track of the nested regions; and that's just
+-- too much work to bother with.
+
+
+-- TODO: for forward disintegration (which is not just partial evaluation) we really do mean proper HNFs not just WHNFs. This falls out from our needing to guarantee that heap-bound variables can't possibly escape; whence the assumption that the result of forward disintegration contains no heap-bound variables.
+--
+-- TODO: is there a way to integrate this into the actual 'Term'
+-- definition in order to reduce repetition?
+--
+-- HACK: can't use \"H\" as the prefix because that clashes with
+-- the Hakaru datakind
+--
+-- | A \"weak-head\" for the sake of 'Whnf'. N.B., this doesn't
+-- exactly correlate with the usual notion of \"weak-head\"; in
+-- particular we keep track of type annotations and coercions, and
+-- don't reduce integration\/summation. So really we should use
+-- some other name for 'Whnf'...
+data Head :: ([Hakaru] -> Hakaru -> *) -> Hakaru -> * where
+    -- Simple heads (aka, the usual stuff)
+    WLiteral :: !(Literal a) -> Head abt a
+    -- BUG: even though the 'Datum' type has a single constructor, we get a warning about not being able to UNPACK it in 'WDatum'... wtf?
+    WDatum :: !(Datum (abt '[]) (HData' t)) -> Head abt (HData' t)
+    WEmpty :: !(Sing ('HArray a)) -> Head abt ('HArray a)
+    WArray :: !(abt '[] 'HNat) -> !(abt '[ 'HNat] a) -> Head abt ('HArray a)
+    WArrayLiteral
+           :: [abt '[] a] -> Head abt ('HArray a)
+    WLam   :: !(abt '[ a ] b) -> Head abt (a ':-> b)
+
+    -- Measure heads (N.B., not simply @abt '[] ('HMeasure _)@)
+    WMeasureOp
+        :: (typs ~ UnLCs args, args ~ LCs typs)
+        => !(MeasureOp typs a)
+        -> !(SArgs abt args)
+        -> Head abt ('HMeasure a)
+    WDirac :: !(abt '[] a) -> Head abt ('HMeasure a)
+    WMBind
+        :: !(abt '[] ('HMeasure a))
+        -> !(abt '[ a ] ('HMeasure b))
+        -> Head abt ('HMeasure b)
+    WPlate
+        :: !(abt '[] 'HNat)
+        -> !(abt '[ 'HNat ] ('HMeasure a))
+        -> Head abt ('HMeasure ('HArray a))
+    WChain
+        :: !(abt '[] 'HNat)
+        -> !(abt '[] s)
+        -> !(abt '[ s ] ('HMeasure (HPair a s)))
+        -> Head abt ('HMeasure (HPair ('HArray a) s))
+    WSuperpose
+        :: !(NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a)))
+        -> Head abt ('HMeasure a)
+    WReject
+        :: !(Sing ('HMeasure a)) -> Head abt ('HMeasure a)
+
+    -- Type coercion stuff. These are transparent re head-ness; that is, they behave more like HNF than WHNF.
+    -- TODO: we prolly don't actually want\/need the coercion variants... we'd lose some proven-guarantees about cancellation, but everything should work just fine. The one issue that remains is if we have coercion of 'WIntegrate' or 'WSummate', since without the 'WCoerceTo'\/'WUnsafeFrom' constructors we'd be forced to call the coercion of an integration \"neutral\"--- even though it's not actually a neutral term!
+    WCoerceTo   :: !(Coercion a b) -> !(Head abt a) -> Head abt b
+    WUnsafeFrom :: !(Coercion a b) -> !(Head abt b) -> Head abt a
+
+    -- Other funky stuff
+    WIntegrate
+        :: !(abt '[] 'HReal)
+        -> !(abt '[] 'HReal)
+        -> !(abt '[ 'HReal ] 'HProb)
+        -> Head abt 'HProb
+    -- WSummate
+    --     :: !(abt '[] 'HReal)
+    --     -> !(abt '[] 'HReal)
+    --     -> !(abt '[ 'HInt ] 'HProb)
+    --     -> Head abt 'HProb
+
+    -- Quasi-/semi-/demi-/pseudo- normal form stuff
+    {-
+    NaryOp_ :: !(NaryOp a) -> !(Seq (abt '[] a)) -> Term abt a
+    PrimOp_
+        :: (typs ~ UnLCs args, args ~ LCs typs)
+        => !(PrimOp typs a) -> SCon args a
+    -- N.B., not 'ArrayOp_'
+    -}
+
+
+-- | Forget that something is a head.
+fromHead :: (ABT Term abt) => Head abt a -> abt '[] a
+fromHead (WLiteral    v)        = syn (Literal_ v)
+fromHead (WDatum      d)        = syn (Datum_ d)
+fromHead (WEmpty      typ)      = syn (Empty_ typ)
+fromHead (WArray      e1 e2)    = syn (Array_ e1 e2)
+fromHead (WArrayLiteral  es)    = syn (ArrayLiteral_ es)
+fromHead (WLam        e1)       = syn (Lam_ :$ e1 :* End)
+fromHead (WMeasureOp  o  es)    = syn (MeasureOp_ o :$ es)
+fromHead (WDirac      e1)       = syn (Dirac :$ e1 :* End)
+fromHead (WMBind      e1 e2)    = syn (MBind :$ e1 :* e2 :* End)
+fromHead (WPlate      e1 e2)    = syn (Plate :$ e1 :* e2 :* End)
+fromHead (WChain      e1 e2 e3) = syn (Chain :$ e1 :* e2 :* e3 :* End)
+fromHead (WSuperpose  pes)      = syn (Superpose_ pes)
+fromHead (WReject     typ)      = syn (Reject_ typ)
+fromHead (WCoerceTo   c e1)     = syn (CoerceTo_   c :$ fromHead e1 :* End)
+fromHead (WUnsafeFrom c e1)     = syn (UnsafeFrom_ c :$ fromHead e1 :* End)
+fromHead (WIntegrate  e1 e2 e3) = syn (Integrate :$ e1 :* e2 :* e3 :* End)
+--fromHead (WSummate    e1 e2 e3) = syn (Summate   :$ e1 :* e2 :* e3 :* End)
+
+
+-- | Identify terms which are already heads.
+toHead :: (ABT Term abt) => abt '[] a -> Maybe (Head abt a)
+toHead e =
+    caseVarSyn e (const Nothing) $ \t ->
+        case t of
+        Literal_     v                      -> Just $ WLiteral   v
+        Datum_       d                      -> Just $ WDatum     d
+        Empty_       typ                    -> Just $ WEmpty     typ
+        Array_       e1     e2              -> Just $ WArray     e1 e2
+        ArrayLiteral_       es              -> Just $ WArrayLiteral es
+        Lam_      :$ e1  :* End             -> Just $ WLam       e1
+        MeasureOp_   o   :$ es              -> Just $ WMeasureOp o  es
+        Dirac     :$ e1  :* End             -> Just $ WDirac     e1
+        MBind     :$ e1  :* e2 :* End       -> Just $ WMBind     e1 e2
+        Plate     :$ e1  :* e2 :* End       -> Just $ WPlate     e1 e2
+        Chain     :$ e1  :* e2 :* e3 :* End -> Just $ WChain     e1 e2 e3 
+        Superpose_   pes                    -> Just $ WSuperpose pes
+        CoerceTo_    c   :$ e1 :* End       -> WCoerceTo   c <$> toHead e1
+        UnsafeFrom_  c   :$ e1 :* End       -> WUnsafeFrom c <$> toHead e1
+        Integrate :$ e1  :* e2 :* e3 :* End -> Just $ WIntegrate e1 e2 e3
+        --Summate   :$ e1  :* e2 :* e3 :* End -> Just $ WSummate   e1 e2 e3
+        _ -> Nothing
+
+instance Functor21 Head where
+    fmap21 _ (WLiteral    v)        = WLiteral v
+    fmap21 f (WDatum      d)        = WDatum (fmap11 f d)
+    fmap21 _ (WEmpty      typ)      = WEmpty typ
+    fmap21 f (WArray      e1 e2)    = WArray (f e1) (f e2)
+    fmap21 f (WArrayLiteral  es)    = WArrayLiteral (fmap f es)
+    fmap21 f (WLam        e1)       = WLam (f e1)
+    fmap21 f (WMeasureOp  o  es)    = WMeasureOp o (fmap21 f es)
+    fmap21 f (WDirac      e1)       = WDirac (f e1)
+    fmap21 f (WMBind      e1 e2)    = WMBind (f e1) (f e2)
+    fmap21 f (WPlate      e1 e2)    = WPlate (f e1) (f e2)
+    fmap21 f (WChain      e1 e2 e3) = WChain (f e1) (f e2) (f e3)
+    fmap21 f (WSuperpose  pes)      = WSuperpose (fmap (f *** f) pes)
+    fmap21 _ (WReject     typ)      = WReject typ
+    fmap21 f (WCoerceTo   c e1)     = WCoerceTo   c (fmap21 f e1)
+    fmap21 f (WUnsafeFrom c e1)     = WUnsafeFrom c (fmap21 f e1)
+    fmap21 f (WIntegrate  e1 e2 e3) = WIntegrate (f e1) (f e2) (f e3)
+    --fmap21 f (WSummate    e1 e2 e3) = WSummate   (f e1) (f e2) (f e3)
+
+instance Foldable21 Head where
+    foldMap21 _ (WLiteral    _)        = mempty
+    foldMap21 f (WDatum      d)        = foldMap11 f d
+    foldMap21 _ (WEmpty      _)        = mempty
+    foldMap21 f (WArray      e1 e2)    = f e1 `mappend` f e2
+    foldMap21 f (WArrayLiteral  es)    = F.foldMap f es
+    foldMap21 f (WLam        e1)       = f e1
+    foldMap21 f (WMeasureOp  _  es)    = foldMap21 f es
+    foldMap21 f (WDirac      e1)       = f e1
+    foldMap21 f (WMBind      e1 e2)    = f e1 `mappend` f e2
+    foldMap21 f (WPlate      e1 e2)    = f e1 `mappend` f e2
+    foldMap21 f (WChain      e1 e2 e3) = f e1 `mappend` f e2 `mappend` f e3
+    foldMap21 f (WSuperpose  pes)      = foldMapPairs f pes
+    foldMap21 _ (WReject     _)        = mempty
+    foldMap21 f (WCoerceTo   _ e1)     = foldMap21 f e1
+    foldMap21 f (WUnsafeFrom _ e1)     = foldMap21 f e1
+    foldMap21 f (WIntegrate  e1 e2 e3) = f e1 `mappend` f e2 `mappend` f e3
+    --foldMap21 f (WSummate    e1 e2 e3) = f e1 `mappend` f e2 `mappend` f e3
+
+instance Traversable21 Head where
+    traverse21 _ (WLiteral    v)        = pure $ WLiteral v
+    traverse21 f (WDatum      d)        = WDatum <$> traverse11 f d
+    traverse21 _ (WEmpty      typ)      = pure $ WEmpty typ
+    traverse21 f (WArray      e1 e2)    = WArray <$> f e1 <*> f e2
+    traverse21 f (WArrayLiteral  es)    = WArrayLiteral <$> traverse f es
+    traverse21 f (WLam        e1)       = WLam <$> f e1
+    traverse21 f (WMeasureOp  o  es)    = WMeasureOp o <$> traverse21 f es
+    traverse21 f (WDirac      e1)       = WDirac <$> f e1
+    traverse21 f (WMBind      e1 e2)    = WMBind <$> f e1 <*> f e2
+    traverse21 f (WPlate      e1 e2)    = WPlate <$> f e1 <*> f e2
+    traverse21 f (WChain      e1 e2 e3) = WChain <$> f e1 <*> f e2 <*> f e3
+    traverse21 f (WSuperpose  pes)      = WSuperpose <$> traversePairs f pes
+    traverse21 _ (WReject     typ)      = pure $ WReject typ
+    traverse21 f (WCoerceTo   c e1)     = WCoerceTo   c <$> traverse21 f e1
+    traverse21 f (WUnsafeFrom c e1)     = WUnsafeFrom c <$> traverse21 f e1
+    traverse21 f (WIntegrate  e1 e2 e3) = WIntegrate <$> f e1 <*> f e2 <*> f e3
+    --traverse21 f (WSummate    e1 e2 e3) = WSummate   <$> f e1 <*> f e2 <*> f e3
+
+
+----------------------------------------------------------------
+-- BUG: haddock doesn't like annotations on GADT constructors. So
+-- here we'll avoid using the GADT syntax, even though it'd make
+-- the data type declaration prettier\/cleaner.
+-- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+-- | Weak head-normal forms are either heads or neutral terms (i.e.,
+-- a term whose reduction is blocked on some free variable).
+data Whnf (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
+    = Head_   !(Head abt a)
+    | Neutral !(abt '[] a)
+    -- TODO: would it be helpful to track which variable it's blocked
+    -- on? To do so we'd need 'GotStuck' to return that info...
+    --
+    -- TODO: is there some /clean/ way to ensure that the neutral term
+    -- is exactly a chain of blocked redexes? That is, we want to be
+    -- able to pull out neutral 'Case_' terms; so we want to make sure
+    -- they're not wrapped in let-bindings, coercions, etc.
+
+-- | Forget that something is a WHNF.
+fromWhnf :: (ABT Term abt) => Whnf abt a -> abt '[] a
+fromWhnf (Head_   e) = fromHead e
+fromWhnf (Neutral e) = e
+
+
+-- | Identify terms which are already heads. N.B., we make no attempt
+-- to identify neutral terms, we just massage the type of 'toHead'.
+toWhnf :: (ABT Term abt) => abt '[] a -> Maybe (Whnf abt a)
+toWhnf e = Head_ <$> toHead e
+
+-- | Case analysis on 'Whnf' as a combinator.
+caseWhnf :: Whnf abt a -> (Head abt a -> r) -> (abt '[] a -> r) -> r
+caseWhnf (Head_   e) k _ = k e
+caseWhnf (Neutral e) _ k = k e
+
+
+-- | Given some WHNF, try to extract a 'Datum' from it.
+viewWhnfDatum
+    :: (ABT Term abt)
+    => Whnf abt (HData' t)
+    -> Maybe (Datum (abt '[]) (HData' t))
+viewWhnfDatum (Head_   v) = Just $ viewHeadDatum v
+viewWhnfDatum (Neutral _) = Nothing
+    -- N.B., we always return Nothing for 'Neutral' terms because of
+    -- what 'Neutral' is supposed to mean. If we wanted to be paranoid
+    -- then we could use the following code to throw an error if
+    -- we're given a \"neutral\" term which is in fact a head
+    -- (because that indicates an error in our logic of constructing
+    -- 'Neutral' values):
+    {-
+    caseVarSyn e (const Nothing) $ \t ->
+        case t of
+        Datum_ d -> error "bad \"neutral\" value!"
+        _        -> Nothing
+    -}
+
+viewHeadDatum
+    :: (ABT Term abt)
+    => Head abt (HData' t)
+    -> Datum (abt '[]) (HData' t)
+viewHeadDatum (WDatum d) = d
+viewHeadDatum _          = error "viewHeadDatum: the impossible happened"
+
+
+-- Alas, to avoid the orphanage, this instance must live here rather than in Lazy.hs where it more conceptually belongs.
+-- TODO: better unify the two cases of Whnf
+-- HACK: this instance requires -XUndecidableInstances
+instance (ABT Term abt) => Coerce (Whnf abt) where
+    coerceTo c w =
+        case w of
+        Neutral e ->
+            Neutral . maybe (P.coerceTo_ c e) id
+                $ caseVarSyn e (const Nothing) $ \t ->
+                    case t of
+                    -- BUG: literals should never be neutral in the first place; but even if we got one, we shouldn't call it neutral after coercing it.
+                    Literal_ x          -> Just $ P.literal_ (coerceTo c x)
+                    -- UnsafeFrom_ c' :$ es' -> TODO: cancellation
+                    CoerceTo_ c' :$ es' ->
+                        case es' of
+                        e' :* End -> Just $ P.coerceTo_ (c . c') e'
+                    _ -> Nothing
+        Head_ v ->
+            case v of
+            WLiteral x      -> Head_ $ WLiteral (coerceTo c x)
+            -- WUnsafeFrom c' v' -> TODO: cancellation
+            WCoerceTo c' v' -> Head_ $ WCoerceTo (c . c') v'
+            _               -> Head_ $ WCoerceTo c v
+    
+    coerceFrom c w =
+        case w of
+        Neutral e ->
+            Neutral . maybe (P.unsafeFrom_ c e) id
+                $ caseVarSyn e (const Nothing) $ \t ->
+                    case t of
+                    -- BUG: literals should never be neutral in the first place; but even if we got one, we shouldn't call it neutral after coercing it.
+                    Literal_ x -> Just $ P.literal_ (coerceFrom c x)
+                    -- CoerceTo_ c' :$ es' -> TODO: cancellation
+                    UnsafeFrom_ c' :$ es' ->
+                        case es' of
+                        e' :* End -> Just $ P.unsafeFrom_ (c' . c) e'
+                    _ -> Nothing
+        Head_ v ->
+            case v of
+            WLiteral x        -> Head_ $ WLiteral (coerceFrom c x)
+            -- WCoerceTo c' v' -> TODO: cancellation
+            WUnsafeFrom c' v' -> Head_ $ WUnsafeFrom (c' . c) v'
+            _                 -> Head_ $ WUnsafeFrom c v
+
+
+----------------------------------------------------------------
+-- BUG: haddock doesn't like annotations on GADT constructors. So
+-- here we'll avoid using the GADT syntax, even though it'd make
+-- the data type declaration prettier\/cleaner.
+-- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+-- | Lazy terms are either thunks (i.e., any term, which we may
+-- decide to evaluate later) or are already evaluated to WHNF.
+data Lazy (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
+    = Whnf_ !(Whnf abt a)
+    | Thunk !(abt '[] a)
+
+-- | Forget whether a term has been evaluated to WHNF or not.
+fromLazy :: (ABT Term abt) => Lazy abt a -> abt '[] a
+fromLazy (Whnf_ e) = fromWhnf e
+fromLazy (Thunk e) = e
+
+-- | Case analysis on 'Lazy' as a combinator.
+caseLazy :: Lazy abt a -> (Whnf abt a -> r) -> (abt '[] a -> r) -> r
+caseLazy (Whnf_ e) k _ = k e
+caseLazy (Thunk e) _ k = k e
+
+-- | Is the lazy value a variable?
+getLazyVariable :: (ABT Term abt) => Lazy abt a -> Maybe (Variable a)
+getLazyVariable e =
+    case e of
+    Whnf_ (Head_   _)  -> Nothing
+    Whnf_ (Neutral e') -> caseVarSyn e' Just (const Nothing)
+    Thunk e'           -> caseVarSyn e' Just (const Nothing)
+
+-- | Boolean-blind variant of 'getLazyVariable'
+isLazyVariable :: (ABT Term abt) => Lazy abt a -> Bool
+isLazyVariable = maybe False (const True) . getLazyVariable
+
+
+-- | Is the lazy value a literal?
+getLazyLiteral :: (ABT Term abt) => Lazy abt a -> Maybe (Literal a)
+getLazyLiteral e =
+    case e of
+    Whnf_ (Head_ (WLiteral v)) -> Just v
+    Whnf_ _                    -> Nothing -- by construction
+    Thunk e' ->
+        caseVarSyn e' (const Nothing) $ \t ->
+            case t of
+            Literal_ v -> Just v
+            _          -> Nothing
+
+-- | Boolean-blind variant of 'getLazyLiteral'
+isLazyLiteral :: (ABT Term abt) => Lazy abt a -> Bool
+isLazyLiteral = maybe False (const True) . getLazyLiteral
+
+----------------------------------------------------------------
+
+-- | A kind for indexing 'Statement' to know whether the statement
+-- is pure (and thus can be evaluated in any ambient monad) vs
+-- impure (i.e., must be evaluated in the 'HMeasure' monad).
+--
+-- TODO: better names!
+data Purity = Pure | Impure | ExpectP
+    deriving (Eq, Read, Show)
+
+-- | A type for tracking the arrays under which the term resides
+-- This is used as a binding form when we "lift" transformations
+-- (currently only Disintegrate) to work on arrays
+data Index ast = Ind (Variable 'HNat) (ast 'HNat)
+
+instance (ABT Term abt) => Eq (Index (abt '[])) where
+    Ind i1 s1 == Ind i2 s2 = i1 == i2 && (alphaEq s1 s2)
+
+instance (ABT Term abt) => Ord (Index (abt '[])) where
+    compare (Ind i _) (Ind j _) = compare i j -- TODO check this
+
+indVar :: Index ast -> Variable 'HNat                                 
+indVar (Ind v _ ) = v
+          
+indSize :: Index ast -> ast 'HNat
+indSize (Ind _ a) = a
+
+fromIndex :: (ABT Term abt) => Index (abt '[]) -> abt '[] 'HNat
+fromIndex (Ind v _) = var v
+
+-- | Distinguish between variables and heap locations
+newtype Location (a :: k) = Location (Variable a)
+
+instance Show (Sing a) => Show (Location a) where
+    show (Location v) = show v
+
+locHint :: Location a -> Text
+locHint (Location x) = varHint x
+
+locType :: Location a -> Sing a
+locType (Location x) = varType x
+
+locEq :: (Show1 (Sing :: k -> *), JmEq1 (Sing :: k -> *))
+      => Location (a :: k)
+      -> Location (b :: k)
+      -> Maybe (TypeEq a b)
+locEq (Location a) (Location b) = varEq a b
+
+fromLocation :: Location a -> Variable a
+fromLocation (Location v) = v
+
+fromLocations1 :: List1 Location a -> List1 Variable a
+fromLocations1 = fmap11 fromLocation
+
+locations1 :: List1 Variable a -> List1 Location a
+locations1 = fmap11 Location
+
+newtype LAssoc ast = LAssoc (Assoc ast)
+newtype LAssocs ast = LAssocs (Assocs ast)
+
+emptyLAssocs :: LAssocs abt
+emptyLAssocs = LAssocs (emptyAssocs)
+    
+singletonLAssocs :: Location a -> f a -> LAssocs f
+singletonLAssocs (Location v) e = LAssocs (singletonAssocs v e)
+
+toLAssocs1 :: List1 Location xs -> List1 ast xs -> LAssocs ast
+toLAssocs1 ls es = LAssocs (toAssocs1 (fromLocations1 ls) es)
+
+insertLAssocs :: LAssocs ast -> LAssocs ast -> LAssocs ast
+insertLAssocs (LAssocs a) (LAssocs b) = LAssocs (insertAssocs a b)
+
+lookupLAssoc :: (Show1 (Sing :: k -> *), JmEq1 (Sing :: k -> *))
+             => Location (a :: k)
+             -> LAssocs ast
+             -> Maybe (ast a)
+lookupLAssoc (Location v) (LAssocs a) = lookupAssoc v a
+                                  
+-- | A single statement in some ambient monad (specified by the @p@
+-- type index). In particular, note that the the first argument to
+-- 'MBind' (or 'Let_') together with the variable bound in the
+-- second argument forms the \"statement\" (leaving out the body
+-- of the second argument, which may be part of a following statement).
+-- In addition to these binding constructs, we also include a few
+-- non-binding statements like 'SWeight'.
+--
+-- Statements are parameterized by the type of the bound element,
+-- which (if present) is either a Variable or a Location.
+-- 
+-- The semantics of this type are as follows. Let @ss :: [Statement
+-- abt v p]@ be a sequence of statements. We have @Γ@: the collection
+-- of all free variables that occur in the term expressions in @ss@,
+-- viewed as a measureable space (namely the product of the measureable
+-- spaces for each variable). And we have @Δ@: the collection of
+-- all variables bound by the statements in @ss@, also viewed as a
+-- measurable space. The semantic interpretation of @ss@ is a
+-- measurable function of type @Γ ':-> M Δ@ where @M@ is either
+-- @HMeasure@ (if @p ~ 'Impure@) or @Identity@ (if @p ~ 'Pure@).
+data Statement :: ([Hakaru] -> Hakaru -> *) -> (Hakaru -> *) -> Purity -> * where
+    -- BUG: haddock doesn't like annotations on GADT constructors. So we can't make the constructor descriptions below available to Haddock.
+    -- <https://github.com/hakaru-dev/hakaru/issues/6>
+    
+    -- A variable bound by 'MBind' to a measure expression.
+    SBind
+        :: forall abt (v :: Hakaru -> *) (a :: Hakaru)
+        .  {-# UNPACK #-} !(v a)
+        -> !(Lazy abt ('HMeasure a))
+        -> [Index (abt '[])]
+        -> Statement abt v 'Impure
+
+    -- A variable bound by 'Let_' to an expression.
+    SLet
+        :: forall abt p (v :: Hakaru -> *) (a :: Hakaru)
+        .  {-# UNPACK #-} !(v a)
+        -> !(Lazy abt a)
+        -> [Index (abt '[])]
+        -> Statement abt v p
+
+
+    -- A weight; i.e., the first component of each argument to
+    -- 'Superpose_'. This is a statement just so that we can avoid
+    -- needing to atomize the weight itself.
+    SWeight
+        :: forall abt (v :: Hakaru -> *)
+        .  !(Lazy abt 'HProb)
+        -> [Index (abt '[])]
+        -> Statement abt v 'Impure
+
+    -- A monadic guard statement. If the scrutinee matches the
+    -- pattern, then we bind the variables as usual; otherwise, we
+    -- return the empty measure. N.B., this statement type is only
+    -- for capturing constraints that some pattern matches /in a/
+    -- /monadic context/. In pure contexts we should be able to
+    -- handle case analysis without putting anything onto the heap.
+    SGuard
+        :: forall abt (v :: Hakaru -> *) (xs :: [Hakaru]) (a :: Hakaru)
+        .  !(List1 v xs)
+        -> !(Pattern xs a)
+        -> !(Lazy abt a)
+        -> [Index (abt '[])]
+        -> Statement abt v 'Impure
+
+    -- Some arbitrary pure code. This is a statement just so that we can avoid needing to atomize the stuff in the pure code.
+    --
+    -- TODO: real names for these.
+    -- TODO: generalize to use a 'VarSet' so we can collapse these
+    -- TODO: defunctionalize? These break pretty printing...
+    SStuff0
+        :: forall abt (v :: Hakaru -> *)
+        .  (abt '[] 'HProb -> abt '[] 'HProb)
+        -> [Index (abt '[])]
+        -> Statement abt v 'ExpectP
+    SStuff1
+        :: forall abt (v :: Hakaru -> *) (a :: Hakaru)
+        . {-# UNPACK #-} !(v a)
+        -> (abt '[] 'HProb -> abt '[] 'HProb)
+        -> [Index (abt '[])]
+        -> Statement abt v 'ExpectP
+
+statementVars :: Statement abt Location p -> VarSet ('KProxy :: KProxy Hakaru)
+statementVars (SBind x _ _)     = singletonVarSet (fromLocation x)
+statementVars (SLet  x _ _)     = singletonVarSet (fromLocation x)
+statementVars (SWeight _ _)     = emptyVarSet
+statementVars (SGuard xs _ _ _) = toVarSet1 (fromLocations1 xs)
+statementVars (SStuff0   _ _)   = emptyVarSet
+statementVars (SStuff1 x _ _)   = singletonVarSet (fromLocation x)
+
+-- | Is the Location bound by the statement?
+--
+-- We return @Maybe ()@ rather than @Bool@ because in our primary
+-- use case we're already in the @Maybe@ monad and so it's easier
+-- to just stick with that. If we find other situations where we'd
+-- really rather have the @Bool@, then we can easily change things
+-- and use some @boolToMaybe@ function to do the coercion wherever
+-- needed.
+isBoundBy :: Location (a :: Hakaru) -> Statement abt Location p -> Maybe ()
+x `isBoundBy` SBind  y  _ _   = const () <$> locEq x y
+x `isBoundBy` SLet   y  _ _   = const () <$> locEq x y
+_ `isBoundBy` SWeight   _ _   = Nothing
+x `isBoundBy` SGuard ys _ _ _ =
+    -- TODO: just check membership directly, rather than going through VarSet
+    if memberVarSet (fromLocation x) (toVarSet1 (fmap11 fromLocation ys))
+    then Just ()
+    else Nothing
+_ `isBoundBy` SStuff0   _ _   = Nothing
+x `isBoundBy` SStuff1 y _ _   = const () <$> locEq x y
+
+
+-- TODO: remove this CPP guard, provided we don't end up with a cyclic dependency...
+#ifdef __TRACE_DISINTEGRATE__
+instance (ABT Term abt) => Pretty (Whnf abt) where
+    prettyPrec_ p (Head_   w) = ppApply1 p "Head_" (fromHead w) -- HACK
+    prettyPrec_ p (Neutral e) = ppApply1 p "Neutral" e
+
+instance (ABT Term abt) => Pretty (Lazy abt) where
+    prettyPrec_ p (Whnf_ w) = ppFun p "Whnf_" [PP.sep (prettyPrec_ 11 w)]
+    prettyPrec_ p (Thunk e) = ppApply1 p "Thunk" e
+
+ppApply1 :: (ABT Term abt) => Int -> String -> abt '[] a -> [PP.Doc]
+ppApply1 p f e1 =
+    let d = PP.text f PP.<+> PP.nest (1 + length f) (prettyPrec 11 e1)
+    in [if p > 9 then PP.parens (PP.nest 1 d) else d]
+
+ppFun :: Int -> String -> [PP.Doc] -> [PP.Doc]
+ppFun _ f [] = [PP.text f]
+ppFun p f ds =
+    parens (p > 9) [PP.text f PP.<+> PP.nest (1 + length f) (PP.sep ds)]
+
+parens :: Bool -> [PP.Doc] -> [PP.Doc]
+parens True  ds = [PP.parens (PP.nest 1 (PP.sep ds))]
+parens False ds = ds
+
+ppList :: [PP.Doc] -> PP.Doc
+ppList = PP.sep . (:[]) . PP.brackets . PP.nest 1 . PP.fsep . PP.punctuate PP.comma
+
+ppInds :: (ABT Term abt) => [Index (abt '[])] -> PP.Doc
+ppInds = ppList . map (ppVariable . indVar)
+
+ppStatement :: (ABT Term abt) => Int -> Statement abt Location p -> PP.Doc
+ppStatement p s =
+    case s of
+    SBind (Location x) e inds ->
+        PP.sep $ ppFun p "SBind"
+            [ ppVariable x
+            , PP.sep $ prettyPrec_ 11 e
+            , ppInds inds
+            ]
+    SLet (Location x) e inds ->
+        PP.sep $ ppFun p "SLet"
+            [ ppVariable x
+            , PP.sep $ prettyPrec_ 11 e
+            , ppInds inds
+            ]
+    SWeight e inds ->
+        PP.sep $ ppFun p "SWeight"
+            [ PP.sep $ prettyPrec_ 11 e
+            , ppInds inds
+            ]
+    SGuard xs pat e inds ->
+        PP.sep $ ppFun p "SGuard"
+            [ PP.sep $ ppVariables (fromLocations1 xs)
+            , PP.sep $ prettyPrec_ 11 pat
+            , PP.sep $ prettyPrec_ 11 e
+            , ppInds inds
+            ]
+    SStuff0   _ _ ->
+        PP.sep $ ppFun p "SStuff0"
+            [ PP.text "TODO: ppStatement{SStuff0}"
+            ]
+    SStuff1 _ _ _ ->
+        PP.sep $ ppFun p "SStuff1"
+            [ PP.text "TODO: ppStatement{SStuff1}"
+            ]
+
+pretty_Statements :: (ABT Term abt) => [Statement abt Location p] -> PP.Doc
+pretty_Statements []     = PP.text "[]"
+pretty_Statements (s:ss) =
+    foldl
+        (\d s' -> d PP.$+$ PP.comma PP.<+> ppStatement 0 s')
+        (PP.text "[" PP.<+> ppStatement 0 s)
+        ss
+    PP.$+$ PP.text "]"
+
+pretty_Statements_withTerm
+    :: (ABT Term abt) => [Statement abt Location p] -> abt '[] a -> PP.Doc
+pretty_Statements_withTerm ss e =
+    pretty_Statements ss PP.$+$ pretty e
+
+prettyAssocs
+    :: (ABT Term abt)
+    => Assocs (abt '[])
+    -> PP.Doc
+prettyAssocs a = PP.vcat $ map go (fromAssocs a)
+  where go (Assoc x e) = ppVariable x PP.<+>
+                         PP.text "->" PP.<+>
+                         pretty e
+                                
+#endif
+
+
+-----------------------------------------------------------------
+-- | A function for evaluating any term to weak-head normal form.
+type TermEvaluator abt m =
+    forall a. abt '[] a -> m (Whnf abt a)
+
+-- | A function for \"performing\" an 'HMeasure' monadic action.
+-- This could mean actual random sampling, or simulated sampling
+-- by generating a new term and returning the newly bound variable,
+-- or anything else.
+type MeasureEvaluator abt m =
+    forall a. abt '[] ('HMeasure a) -> m (Whnf abt a)
+
+-- | A function for evaluating any case-expression to weak-head
+-- normal form.
+type CaseEvaluator abt m =
+    forall a b. abt '[] a -> [Branch a abt b] -> m (Whnf abt b)
+
+-- | A function for evaluating any variable to weak-head normal form.
+type VariableEvaluator abt m =
+    forall a. Variable a -> m (Whnf abt a)
+                            
+
+----------------------------------------------------------------
+-- | This class captures the monadic operations needed by the
+-- 'evaluate' function in "Language.Hakaru.Lazy".
+class (Functor m, Applicative m, Monad m, ABT Term abt)
+    => EvaluationMonad abt m p | m -> abt p
+    where
+    -- TODO: should we have a *method* for arbitrarily incrementing the stored 'nextFreshNat'; or should we only rely on it being initialized correctly? Beware correctness issues about updating the lower bound after having called 'freshNat'...
+
+    -- | Return a fresh natural number. That is, a number which is
+    -- not the 'varID' of any free variable in the expressions of
+    -- interest, and isn't a number we've returned previously.
+    freshNat :: m Nat
+
+
+    -- | Internal function for renaming the variables bound by a
+    -- statement. We return the renamed statement along with a substitution
+    -- for mapping the old variable names to their new variable names.
+    freshLocStatement
+        :: Statement abt Variable p
+        -> m (Statement abt Location p, Assocs (Variable :: Hakaru -> *))
+    freshLocStatement s =
+        case s of
+          SWeight w e    -> return (SWeight w e, mempty)
+          SBind x body i -> do
+               x' <- freshenVar x
+               return (SBind (Location x') body i, singletonAssocs x x')
+          SLet x  body i -> do
+               x' <- freshenVar x
+               return (SLet (Location x') body i, singletonAssocs x x')
+          SGuard xs pat scrutinee i -> do
+               xs' <- freshenVars xs
+               return (SGuard (locations1 xs') pat scrutinee i,
+                       toAssocs1 xs xs')
+          SStuff0   e e' -> return (SStuff0 e e', mempty)
+          SStuff1 x f i -> do
+               x' <- freshenVar x
+               return (SStuff1 (Location x') f i, singletonAssocs x x')
+
+
+    -- | Returns the current Indices. Currently, this is only
+    -- applicable to the Disintegration Monad, but could be
+    -- relevant as other partial evaluators begin to handle
+    -- Plate and Array
+    getIndices :: m [Index (abt '[])]
+    getIndices =  return []
+
+    -- | Add a statement to the top of the context. This is unsafe
+    -- because it may allow confusion between variables with the
+    -- same name but different scopes (thus, may allow variable
+    -- capture). Prefer using 'push_', 'push', or 'pushes'.
+    unsafePush :: Statement abt Location p -> m ()
+
+    -- | Call 'unsafePush' repeatedly. Is part of the class since
+    -- we may be able to do this more efficiently than actually
+    -- calling 'unsafePush' repeatedly.
+    --
+    -- N.B., this should push things in the same order as 'pushes'
+    -- does.
+    unsafePushes :: [Statement abt Location p] -> m ()
+    unsafePushes = mapM_ unsafePush
+
+    -- | Look for the statement @s@ binding the variable. If found,
+    -- then call the continuation with @s@ in the context where @s@
+    -- itself and everything @s@ (transitively)depends on is included
+    -- but everything that (transitively)depends on @s@ is excluded;
+    -- thus, the continuation may only alter the dependencies of
+    -- @s@. After the continuation returns, restore all the bindings
+    -- that were removed before calling the continuation. If no
+    -- such @s@ can be found, then return 'Nothing' without altering
+    -- the context at all.
+    --
+    -- N.B., the statement @s@ itself is popped! Thus, it is up to
+    -- the continuation to make sure to push new statements that
+    -- bind /all/ the variables bound by @s@!
+    --
+    -- TODO: pass the continuation more detail, so it can avoid
+    -- needing to be in the 'Maybe' monad due to the redundant call
+    -- to 'varEq' in the continuation. In particular, we want to
+    -- do this so that we can avoid the return type @m (Maybe (Maybe r))@
+    -- while still correctly handling statements like 'SStuff1'
+    -- which (a) do bind variables and thus should shadow bindings
+    -- further up the 'ListContext', but which (b) offer up no
+    -- expression the variable is bound to, and thus cannot be
+    -- altered by forcing etc. To do all this, we need to pass the
+    -- 'TypeEq' proof from (the 'varEq' call in) the 'isBoundBy'
+    -- call in the instance; but that means we also need some way
+    -- of tying it together with the existential variable in the
+    -- 'Statement'. Perhaps we should have an alternative statement
+    -- type which exposes the existential?
+    select
+        :: Location (a :: Hakaru)
+        -> (Statement abt Location p -> Maybe (m r))
+        -> m (Maybe r)
+
+    substVar :: Variable a -> abt '[] a
+             -> (forall b'. Variable b' -> m (abt '[] b'))
+    substVar _ _ = return . var
+
+
+    extFreeVars :: abt xs a -> m (VarSet (KindOf a))
+    extFreeVars e = return (freeVars e)
+
+
+    -- The first argument to @evaluateCase@ will be the
+    -- 'TermEvaluator' we're constructing (thus tying the knot).
+    evaluateCase :: TermEvaluator abt m -> CaseEvaluator abt m
+    {-# INLINE evaluateCase #-}
+    evaluateCase = defaultCaseEvaluator
+
+               
+    -- TODO: figure out how to abstract this so it can be reused by
+    -- 'constrainValue'. Especially the 'SBranch case of 'step'
+    -- TODO: we could speed up the case for free variables by having
+    -- the 'Context' also keep track of the largest free var. That way,
+    -- we can just check up front whether @varID x < nextFreeVarID@.
+    -- Of course, we'd have to make sure we've sufficiently renamed all
+    -- bound variables to be above @nextFreeVarID@; but then we have to
+    -- do that anyways.
+    evaluateVar :: MeasureEvaluator  abt m
+                -> TermEvaluator     abt m
+                -> VariableEvaluator abt m
+    evaluateVar perform evaluate_ = \x ->
+    -- If we get 'Nothing', then it turns out @x@ is a free variable
+      fmap (maybe (Neutral $ var x) id) . select (Location x) $ \s ->
+        case s of
+        SBind y e i -> do
+            Refl <- locEq (Location x) y
+            Just $ do
+                w <- perform $ caseLazy e fromWhnf id
+                unsafePush (SLet (Location x) (Whnf_ w) i)
+#ifdef __TRACE_DISINTEGRATE__
+                trace ("-- updated "
+                    ++ show (ppStatement 11 s)
+                    ++ " to "
+                    ++ show (ppStatement 11 (SLet (Location x) (Whnf_ w) i))
+                    ) $ return ()
+#endif
+                return w
+        SLet y e i -> do
+            Refl <- locEq (Location x) y
+            Just $ do
+                w <- caseLazy e return evaluate_
+                unsafePush (SLet (Location x) (Whnf_ w) i)
+                return w
+        -- These two don't bind any variables, so they definitely
+        -- can't match.
+        SWeight   _ _ -> Nothing
+        SStuff0   _ _ -> Nothing
+        -- These two do bind variables, but there's no expression we
+        -- can return for them because the variables are
+        -- untouchable\/abstract.
+        SStuff1 _ _ _ -> Just . return . Neutral $ var x
+        SGuard _ _ _ _ -> Just . return . Neutral $ var x
+
+
+-- | A simple 'CaseEvaluator' which uses the 'DatumEvaluator' to
+-- force the scrutinee, and if 'matchBranches' succeeds then we
+-- call the 'TermEvaluator' to continue evaluating the body of the
+-- matched branch. If we 'GotStuck' then we return a 'Neutral' term
+-- of the case expression itself (n.b, any side effects from having
+-- called the 'DatumEvaluator' will still persist when returning
+-- this neutral term). If we didn't get stuck and yet none of the
+-- branches matches, then we throw an exception.
+defaultCaseEvaluator
+    :: forall abt m p
+    .  (ABT Term abt, EvaluationMonad abt m p)
+    => TermEvaluator abt m
+    -> CaseEvaluator abt m
+{-# INLINE defaultCaseEvaluator #-}
+defaultCaseEvaluator evaluate_ = evaluateCase_
+    where
+    -- TODO: At present, whenever we residualize a case expression we'll
+    -- generate a 'Neutral' term which will, when run, repeat the work
+    -- we're doing in the evaluation here. We could eliminate this
+    -- redundancy by introducing a new variable for @e@ each time this
+    -- function is called--- if only we had some way of getting those
+    -- variables put into the right place for when we residualize the
+    -- original scrutinee...
+    --
+    -- N.B., 'DatumEvaluator' is a rank-2 type so it requires a signature
+    evaluateDatum :: DatumEvaluator (abt '[]) m
+    evaluateDatum e = viewWhnfDatum <$> evaluate_ e
+
+    evaluateCase_ :: CaseEvaluator abt m
+    evaluateCase_ e bs = do
+        match <- matchBranches evaluateDatum e bs
+        case match of
+            Nothing ->
+                -- TODO: print more info about where this error
+                -- happened
+                --
+                -- TODO: rather than throwing a Haskell error,
+                -- instead capture the possibility of failure in
+                -- the 'EvaluationMonad' monad.
+                error "defaultCaseEvaluator: non-exhaustive patterns in case!"
+            Just GotStuck ->
+                return . Neutral . syn $ Case_ e bs
+            Just (Matched ss body) ->
+                pushes (toVarStatements ss) body >>= evaluate_
+
+
+toVarStatements :: Assocs (abt '[]) -> [Statement abt Variable p]
+toVarStatements = map (\(Assoc x e) -> SLet x (Thunk e) []) .
+                  fromAssocs
+ 
+extSubst
+    :: forall abt a xs b m p. (EvaluationMonad abt m p)
+    => Variable a
+    -> abt '[] a
+    -> abt xs b
+    -> m (abt xs b)
+extSubst x e = substM x e (substVar x e)
+
+extSubsts
+    :: forall abt a xs m p. (EvaluationMonad abt m p)
+    => Assocs (abt '[])
+    -> abt xs a
+    -> m (abt xs a)
+extSubsts rho0 e0 =
+    F.foldlM (\e (Assoc x v) -> extSubst x v e) e0 (unAssocs rho0)
+
+           
+-- TODO: define a new NameSupply monad in "Language.Hakaru.Syntax.Variable" for encapsulating these four fresh(en) functions?
+
+
+-- | Given some hint and type, generate a variable with a fresh
+-- 'varID'.
+freshVar
+    :: (EvaluationMonad abt m p)
+    => Text
+    -> Sing (a :: Hakaru)
+    -> m (Variable a)
+freshVar hint typ = (\i -> Variable hint i typ) <$> freshNat
+
+
+-- TODO: move to "Language.Hakaru.Syntax.Variable" in case anyone else wants it too.
+data Hint (a :: Hakaru) = Hint {-# UNPACK #-} !Text !(Sing a)
+
+-- | Call 'freshVar' repeatedly.
+-- TODO: make this more efficient than actually calling 'freshVar'
+-- repeatedly.
+freshVars
+    :: (EvaluationMonad abt m p)
+    => List1 Hint xs
+    -> m (List1 Variable xs)
+freshVars Nil1         = return Nil1
+freshVars (Cons1 x xs) = Cons1 <$> freshVar' x <*> freshVars xs
+    where
+    freshVar' (Hint hint typ) = freshVar hint typ
+
+
+-- | Given a variable, return a new variable with the same hint and
+-- type but with a fresh 'varID'.
+freshenVar
+    :: (EvaluationMonad abt m p)
+    => Variable (a :: Hakaru)
+    -> m (Variable a)
+freshenVar x = (\i -> x{varID=i}) <$> freshNat
+
+
+-- | Call 'freshenVar' repeatedly.
+-- TODO: make this more efficient than actually calling 'freshenVar'
+-- repeatedly.
+freshenVars
+    :: (EvaluationMonad abt m p)
+    => List1 Variable (xs :: [Hakaru])
+    -> m (List1 Variable xs)
+freshenVars Nil1         = return Nil1
+freshenVars (Cons1 x xs) = Cons1 <$> freshenVar x <*> freshenVars xs
+{-
+-- TODO: get this faster version to typecheck! And once we do, move it to IClasses.hs or wherever 'List1'\/'DList1' end up
+freshenVars = go dnil1
+    where
+    go  :: (EvaluationMonad abt m p)
+        => DList1 Variable (ys :: [Hakaru])
+        -> List1  Variable (zs :: [Hakaru])
+        -> m (List1 Variable (ys ++ zs))
+    go k Nil1         = return (unDList1 k Nil1) -- for typechecking, don't use 'toList1' here.
+    go k (Cons1 x xs) = do
+        x' <- freshenVar x
+        go (k `dsnoc1` x') xs -- BUG: type error....
+-}
+
+-- | Given a size, generate a fresh Index
+freshInd :: (EvaluationMonad abt m p)
+         => abt '[] 'HNat
+         -> m (Index (abt '[]))
+freshInd s = do
+  x <- freshVar T.empty SNat
+  return $ Ind x s
+
+
+-- | Given a location, return a new Location with the same hint
+-- and type but with a fresh ID
+freshenLoc :: (EvaluationMonad abt m p)
+           => Location (a :: Hakaru) -> m (Location a)
+freshenLoc (Location x) = Location <$> freshenVar x
+
+-- | Call `freshenLoc` repeatedly
+freshenLocs :: (EvaluationMonad abt m p)
+            => List1 Location (ls :: [Hakaru])
+            -> m (List1 Location ls)
+freshenLocs Nil1         = return Nil1
+freshenLocs (Cons1 l ls) = Cons1 <$> freshenLoc l <*> freshenLocs ls
+
+                           
+
+-- | Add a statement to the top of the context, renaming any variables
+-- the statement binds and returning the substitution mapping the
+-- old variables to the new ones. This is safer than 'unsafePush'
+-- because it avoids variable confusion; but it is still somewhat
+-- unsafe since you may forget to apply the substitution to \"the
+-- rest of the term\". You almost certainly should use 'push' or
+-- 'pushes' instead.
+push_
+    :: (ABT Term abt, EvaluationMonad abt m p)
+    => Statement abt Variable p
+    -> m (Assocs (Variable :: Hakaru -> *))
+push_ s = do
+    (s',rho) <- freshLocStatement s
+    unsafePush s'
+    return rho
+
+
+-- | Push a statement onto the context, renaming variables along
+-- the way. The second argument represents \"the rest of the term\"
+-- after we've peeled the statement off; it's passed so that we can
+-- update the variable names there so that they match with the
+-- (renamed)binding statement. The third argument is the continuation
+-- for what to do with the renamed term. Rather than taking the
+-- second and third arguments we could return an 'Assocs' giving
+-- the renaming of variables; however, doing that would make it too
+-- easy to accidentally drop the substitution on the floor rather
+-- than applying it to the term before calling the continuation.
+push
+    :: (ABT Term abt, EvaluationMonad abt m p)
+    => Statement abt Variable p   -- ^ the statement to push
+    -> abt xs a          -- ^ the \"rest\" of the term
+    -- -> (abt xs a -> m r) -- ^ what to do with the renamed \"rest\"
+    -> m (abt xs a)               -- ^ the final result
+push s e = do
+    rho <- push_ s
+    return (renames rho e)
+
+
+-- | Call 'push' repeatedly. (N.B., is more efficient than actually
+-- calling 'push' repeatedly.) The head is pushed first and thus
+-- is the furthest away in the final context, whereas the tail is
+-- pushed last and is the closest in the final context.
+pushes
+    :: (ABT Term abt, EvaluationMonad abt m p)
+    => [Statement abt Variable p] -- ^ the statements to push
+    -> abt xs a          -- ^ the \"rest\" of the term
+    -- -> (abt xs a -> m r) -- ^ what to do with the renamed \"rest\"
+    -> m (abt xs a)         -- ^ the final result
+pushes ss e = do
+    -- TODO: is 'foldlM' the right one? or do we want 'foldrM'?
+    rho <- F.foldlM (\rho s -> mappend rho <$> push_ s) mempty ss
+    return (renames rho e)
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Expect.hs b/haskell/Language/Hakaru/Expect.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Expect.hs
@@ -0,0 +1,408 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , EmptyCase
+           , KindSignatures
+           , DataKinds
+           , TypeOperators
+           , NoImplicitPrelude
+           , ScopedTypeVariables
+           , FlexibleContexts
+           , ViewPatterns
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.24
+-- |
+-- Module      :  Language.Hakaru.Expect
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--
+----------------------------------------------------------------
+module Language.Hakaru.Expect
+    ( normalize
+    , total
+    , expect, expectInCtx, determineExpect
+    ) where
+
+import           Prelude               (($), (.), error, reverse, Maybe(..))
+import qualified Data.Text             as Text
+import           Data.Functor          ((<$>))
+import qualified Data.Foldable         as F
+import qualified Data.Traversable      as T
+import qualified Data.List.NonEmpty    as NE
+import           Control.Monad
+
+import Language.Hakaru.Syntax.IClasses (Some2(..), Functor11(..))
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.DatumABT
+import Language.Hakaru.Syntax.Transform (TransformCtx(..), minimalCtx)
+import Language.Hakaru.Syntax.AST               hiding (Expect)
+import qualified Language.Hakaru.Syntax.AST     as AST
+import Language.Hakaru.Syntax.TypeOf            (typeOf)
+import qualified Language.Hakaru.Syntax.Prelude as P
+import Language.Hakaru.Evaluation.Types
+import Language.Hakaru.Evaluation.ExpectMonad
+
+#ifdef __TRACE_DISINTEGRATE__
+import Prelude                          (show, (++))
+import qualified Text.PrettyPrint       as PP
+import Language.Hakaru.Pretty.Haskell   (pretty)
+import Language.Hakaru.Evaluation.Types (ppStatement)
+import Debug.Trace                      (trace)
+#endif
+
+----------------------------------------------------------------
+
+-- | Convert an arbitrary measure into a probability measure; i.e.,
+-- reweight things so that the total weight\/mass is 1.
+normalize
+    :: (ABT Term abt) => abt '[] ('HMeasure a) -> abt '[] ('HMeasure a)
+normalize m = P.withWeight (P.recip $ total m) m
+
+
+-- | Compute the total weight\/mass of a measure.
+total :: (ABT Term abt) => abt '[] ('HMeasure a) -> abt '[] 'HProb
+total m =
+    expect m . binder Text.empty (sUnMeasure $ typeOf m) $ \_ -> P.one
+
+-- TODO: is it actually a _measurable_ function from measurable-functions
+-- to probs? If so, shouldn't we also capture that in the types?
+--
+-- | Convert a measure into its integrator. N.B., the second argument
+-- is (a representation of) a measurable function from @a@ to
+-- 'HProb@. We represent it as a binding form rather than as @abt
+-- '[] (a ':-> 'HProb)@ in order to avoid introducing administrative
+-- redexes. We could, instead, have used a Haskell function @abt
+-- '[] a -> abt '[] 'HProb@ to eliminate the administrative redexes,
+-- but that would introduce other implementation difficulties we'd
+-- rather avoid.
+expect
+    :: (ABT Term abt)
+    => abt '[] ('HMeasure a)
+    -> abt '[a] 'HProb
+    -> abt '[] 'HProb
+expect = expectInCtx minimalCtx
+
+expectInCtx
+    :: (ABT Term abt)
+    => TransformCtx
+    -> abt '[] ('HMeasure a)
+    -> abt '[a] 'HProb
+    -> abt '[] 'HProb
+expectInCtx ctx e f = runExpect (expectTerm e) ctx f [Some2 e, Some2 f]
+
+-- | A helper which converts residualized `expect' to a `Nothing' instead.
+determineExpect
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> Maybe (abt '[] 'HProb)
+determineExpect e =
+  case e of
+    (viewABT -> Syn (AST.Transform_ AST.Expect :$ _)) -> Nothing
+    r -> Just r
+
+
+residualizeExpect
+    :: (ABT Term abt)
+    => abt '[] ('HMeasure a)
+    -> Expect abt (abt '[] a)
+residualizeExpect e = do
+    -- BUG: is this what we really mean? or do we actually mean the old 'emit' version?
+    x <- freshVar Text.empty (sUnMeasure $ typeOf e)
+    unsafePush (SStuff1 (Location x) (\c ->
+        syn (AST.Transform_ AST.Expect :$ e :* bind x c :* End)) [])
+    return $ var x
+{-
+residualizeExpect e = do
+    var <$> emit Text.empty (sUnMeasure $ typeOf e)
+        (\c -> syn (AST.Expect :$ e :* c :* End))
+-}
+
+-- This version checks whether the first argument is a variable or not, avoiding the extraneous let binding as appropriate. We also avoid using 'binder', which is good because it constructs the term more directly, but is bad because we make no guarantees about hygiene! We expect callers to handle that.
+-- TODO: move this elsewhere, so that 'runExpect' can use it.
+-- TODO: make even smarter so that we drop the let binding in case @f@ doesn't actually use it?
+let_ :: (ABT Term abt) => abt '[] a -> abt '[a] b -> abt '[] b
+let_ e f =
+    caseVarSyn e
+        (\x -> caseBind f $ \y f' -> subst y (var x) f')
+        (\_ -> syn (Let_ :$ e :* f :* End))
+
+    
+expectCase
+    :: (ABT Term abt)
+    => abt '[] a
+    -> [Branch a abt ('HMeasure b)]
+    -> Expect abt (abt '[] b)
+expectCase scrutinee bs = do
+    -- Get the current context and then clear it.
+    ctx <- Expect $ \c h -> c h (h {statements = []})
+    -- Emit the old "current" context.
+    Expect $ \c h -> residualizeExpectListContext (c () h) ctx
+    -- @emitCaseWith@
+    gms <- T.for bs $ \(Branch pat body) ->
+        let (vars, body') = caseBinds body
+        in  (\vars' ->
+                let rho = toAssocs1 vars (fmap11 var vars')
+                in  GBranch pat vars' (expectTerm $ substs rho body')
+            ) <$> freshenVars vars
+    Expect $ \c h ->
+        syn $ Case_ scrutinee
+            [ fromGBranch $ fmap (\m -> unExpect m c h) gm
+            | gm <- gms
+            ]
+
+----------------------------------------------------------------
+-- BUG: really rather than using 'pureEvaluate' itself, we should
+-- have our own similar version which pushes the @expect _ c@ under
+-- the branches; in lieu of allowing 'defaultCaseEvaluator' to
+-- return a 'Neutral' term. How can we get this to work right? Seems
+-- like a common problem to have since the backwards disintegrator(s)
+-- have to do it too.
+
+
+-- N.B., in the ICFP 2015 pearl paper, we took the expectation of
+-- bound variables prior to taking the expectation of their scope.
+-- E.g., @expect(let_ v e1 e2) xs c = expect e1 xs $ \x -> expect
+-- e2 (insertAssoc v x xs) c@. Whereas here, I'm being lazier and
+-- performing the expectation on variable lookup. This delayed
+-- evaluation preserves the expectation semantics (ICFP 2015, §5.6.0)
+-- whenever (1) the variable is never used (by wasted computation),
+-- or (2) used exactly once (by Tonelli's theorem); so we only need
+-- to worry if (3) the variable is used more than once, in which
+-- case we'll have to worry about whether the various integrals
+-- commute/exchange with one another. More generally, cf. Bhat et
+-- al.'s \"active variables\"
+
+-- TODO: do we want to move this to the public API of
+-- "Language.Hakaru.Evaluation.DisintegrationMonad"?
+#ifdef __TRACE_DISINTEGRATE__
+getStatements :: Expect abt [Statement abt Location 'ExpectP]
+getStatements = Expect $ \c h -> c (statements h) h
+#endif
+
+
+expectTerm
+    :: (ABT Term abt)
+    => abt '[] ('HMeasure a)
+    -> Expect abt (abt '[] a)
+expectTerm e = do
+#ifdef __TRACE_DISINTEGRATE__
+    ss <- getStatements
+    trace ("\n-- expectTerm --\n"
+        ++ show (pretty_Statements_withTerm ss e)
+        ++ "\n") $ return ()
+#endif
+    emitExpectListContext
+    w <- pureEvaluate e
+    case w of
+        -- TODO: if the neutral term is a 'Case_' then we want to go under it
+        Neutral e'              ->
+            caseVarSyn e' (residualizeExpect . var) $ \t ->
+                case t of
+                Case_ e1 bs -> expectCase e1 bs
+                _           -> residualizeExpect e'
+        Head_ (WLiteral    _)    -> error "expect: the impossible happened"
+        Head_ (WCoerceTo   _  _) -> error "expect: the impossible happened"
+        Head_ (WUnsafeFrom _  _) -> error "expect: the impossible happened"
+        Head_ (WMeasureOp o es) -> expectMeasureOp o es
+        Head_ (WDirac e1)       -> return e1
+        Head_ (WMBind e1 e2)    -> do
+            v1 <- expectTerm e1
+            expectTerm (let_ v1 e2)
+        Head_ (WPlate _ _)     -> error "TODO: expect{Plate}"
+        Head_ (WChain _ _ _)   -> error "TODO: expect{Chain}"
+        Head_ (WReject    _)   -> expectSuperpose []
+        Head_ (WSuperpose pes) -> expectSuperpose (NE.toList pes)
+
+
+-- N.B., we guarantee that each @e@ is called with the same heap
+-- @h@ and continuation @c@.
+expectSuperpose
+    :: (ABT Term abt)
+    => [(abt '[] 'HProb, abt '[] ('HMeasure a))]
+    -> Expect abt (abt '[] a)
+expectSuperpose pes = do
+#ifdef __TRACE_DISINTEGRATE__
+    ss <- getStatements
+    trace ("\n-- expectSuperpose --\n"
+        ++ show (pretty_Statements_withTerm ss (syn $ Superpose_ (NE.fromList pes)))
+        ++ "\n") $ return ()
+#endif
+    -- First, emit the current heap (so that each @p@ is emissible)
+    emitExpectListContext
+    -- Then emit the 'sum', and call the same continuation on each @e@
+    Expect $ \c h ->
+        P.sum [ p P.* unExpect (expectTerm e) c h | (p,e) <- pes]
+    -- TODO: if @pes@ is null, then automatically simplify to just 0
+    -- TODO: in the Lazy.tex paper, we guard against that interpretation being negative...
+
+emitExpectListContext :: forall abt. (ABT Term abt) => Expect abt ()
+emitExpectListContext = do
+    ss <- Expect $ \c h -> c (statements h) (h {statements = []})
+    F.traverse_ step (reverse ss) -- TODO: use composition tricks to avoid reversing @ss@
+    where
+    step :: Statement abt Location 'ExpectP -> Expect abt ()
+    step s =
+#ifdef __TRACE_DISINTEGRATE__
+        trace ("\n-- emitExpectListContext: " ++ show (ppStatement 0 s)) $
+#endif
+        case s of
+        SLet l body _ ->
+            -- TODO: be smart about dropping unused let-bindings and inlining trivial let-bindings
+            Expect $ \c h ->
+                syn (Let_ :$ fromLazy body :* bind (fromLocation l) (c () h) :* End)
+        SStuff0   f _ -> Expect $ \c h -> f (c () h)
+        SStuff1 _ f _ -> Expect $ \c h -> f (c () h)
+
+
+pushIntegrate
+    :: (ABT Term abt)
+    => abt '[] 'HReal
+    -> abt '[] 'HReal
+    -> Expect abt (Variable 'HReal)
+pushIntegrate lo hi = do
+    x <- freshVar Text.empty SReal
+    unsafePush (SStuff1 (Location x) (\c ->
+        syn (Integrate :$ lo :* hi :* bind x c :* End)) [])
+    return x
+{-
+-- BUG: we assume the arguments are emissible!
+emitIntegrate lo hi =
+    emit Text.empty SReal (\c ->
+        syn (Integrate :$ lo :* hi :* c :* End))
+-}
+
+-- Needs to be more polymorphic
+pushSummate
+    :: (ABT Term abt, HDiscrete_ a, SingI a)
+    => abt '[] a
+    -> abt '[] a
+    -> Expect abt (Variable a)
+pushSummate lo hi = do
+    x <- freshVar Text.empty sing
+    unsafePush (SStuff1 (Location x) (\c ->
+        syn (Summate hDiscrete hSemiring
+             :$ lo :* hi :* bind x c :* End)) [])
+    return x
+{-
+-- BUG: we assume the arguments are emissible!
+emitSummate lo hi =
+    emit Text.empty SInt (\c ->
+        syn (Summate :$ lo :* hi :* c :* End))
+-}
+
+-- TODO: can we / would it help to, reuse 'let_'?
+-- BUG: we assume the argument is emissible!
+pushLet :: (ABT Term abt) => abt '[] a -> Expect abt (Variable a)
+pushLet e =
+    caseVarSyn e return $ \_ -> do
+        x <- freshVar Text.empty (typeOf e)
+        unsafePush (SStuff1 (Location x) (\c ->
+            syn (Let_ :$ e :* bind x c :* End)) [])
+        return x
+{-
+emitLet e =
+    caseVarSyn e return $ \_ ->
+        emit Text.empty (typeOf e) $ \f ->
+            syn (Let_ :$ e :* f :* End)
+-}
+
+
+-- TODO: introduce HProb variants of integrate\/summate so we can avoid the need for 'unsafeProb' here
+expectMeasureOp
+    :: forall abt typs args a
+    .  (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => MeasureOp typs a
+    -> SArgs abt args
+    -> Expect abt (abt '[] a)
+expectMeasureOp Lebesgue = \(lo :* hi :* End) -> do 
+    lo' <- var <$> pushLet lo
+    hi' <- var <$> pushLet hi
+    var <$> pushIntegrate lo' hi' 
+expectMeasureOp Counting = \End ->
+    var <$> pushSummate P.negativeInfinity P.infinity
+expectMeasureOp Categorical = \(ps :* End) -> do
+    ps' <- var <$> pushLet ps
+    tot <- var <$> pushLet (P.summateV ps')
+    unsafePush (SStuff0 (\c -> P.if_ (P.zero P.< tot) c P.zero) [])
+    i <- freshVar Text.empty SNat
+    Expect $ \c h ->
+        P.summateV
+            (syn (Array_ (P.size ps') (bind i ((ps' P.! var i) P.* c (var i) h))))
+            P./ tot
+    {-
+    let_ ps $ \ps' ->
+    let_ (summateV ps') $ \tot ->
+    if_ (zero < tot)
+        (summateV (mapWithIndex (\i p -> p * inst c i) ps') / tot)
+        zero
+    -}
+expectMeasureOp Uniform = \(lo :* hi :* End) -> do
+    -- BUG: @(let_ zero $ \y -> uniform y one)@ doesn't work as desired; *drops* the @SLet y zero@ binding entirely!!
+    lo' <- var <$> pushLet lo
+    hi' <- var <$> pushLet hi
+    x   <- var <$> pushIntegrate lo' hi'
+    unsafePush (SStuff0 (\c -> P.densityUniform lo' hi' x P.* c) [])
+    return x
+    {-
+    let_ lo $ \lo' ->
+    let_ hi $ \hi' ->
+    integrate lo' hi' $ \x ->
+        densityUniform lo' hi' x * inst c x
+    -}
+expectMeasureOp Normal = \(mu :* sd :* End) -> do
+    -- HACK: for some reason w need to break apart the 'emit' and the 'emit_' or else we get a "<<loop>>" exception. Not entirely sure why, but it prolly indicates a bug somewhere.
+    x <- var <$> pushIntegrate P.negativeInfinity P.infinity
+    unsafePush (SStuff0 (\c -> P.densityNormal mu sd x P.* c) [])
+    return x
+    {-
+    \c ->
+        P.integrate P.negativeInfinity P.infinity $ \x ->
+            P.densityNormal mu sd x P.* let_ x c)
+    -}
+expectMeasureOp Poisson = \(l :* End) -> do
+    l' <- var <$> pushLet l
+    unsafePush (SStuff0 (\c -> P.if_ (P.zero P.< l') c P.zero) [])
+    x  <- var <$> pushSummate P.zero P.infinity
+    unsafePush (SStuff0 (\c -> P.densityPoisson l' x P.* c) [])
+    return x
+    {-
+    let_ l $ \l' ->
+    if_ (zero < l')
+        (summate zero infinity $ \x ->
+            let x_ = unsafeFrom_ signed x in
+            densityPoisson l' x_ * inst c x_)
+        zero
+    -}
+expectMeasureOp Gamma = \(shape :* scale :* End) -> do
+    x  <- var <$> pushIntegrate P.zero P.infinity
+    x_ <- var <$> pushLet (P.unsafeProb x) -- TODO: Or is this small enough that we'd be fine using Haskell's "let" and so duplicating the coercion of a variable however often?
+    unsafePush (SStuff0 (\c -> P.densityGamma shape scale x_ P.* c) [])
+    return x_
+    {-
+    integrate zero infinity $ \x ->
+        let x_ = unsafeProb x in
+        densityGamma shape scale x_ * inst c x_
+    -}
+expectMeasureOp Beta = \(a :* b :* End) -> do
+    x  <- var <$> pushIntegrate P.zero P.one
+    x_ <- var <$> pushLet (P.unsafeProb x) -- TODO: Or is this small enough that we'd be fine using Haskell's "let" and so duplicating the coercion of a variable however often?
+    unsafePush (SStuff0 (\c -> P.densityBeta a b x_ P.* c) [])
+    return x_
+    {-
+    integrate zero one $ \x ->
+        let x_ = unsafeProb x in
+        densityBeta a b x_ * inst c x_
+    -}
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Inference.hs b/haskell/Language/Hakaru/Inference.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Inference.hs
@@ -0,0 +1,243 @@
+{-# LANGUAGE DataKinds
+           , TypeOperators
+           , NoImplicitPrelude
+           , FlexibleContexts
+           , GADTs
+           , TypeFamilies
+           , FlexibleInstances
+           , ViewPatterns
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.21
+-- |
+-- Module      :  Language.Hakaru.Inference
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- TODO: we may want to give these longer\/more-explicit names so
+-- as to be a bit less ambiguous in the larger Haskell ecosystem.
+----------------------------------------------------------------
+module Language.Hakaru.Inference
+    ( priorAsProposal
+    , mh, mh'
+    , mcmc, mcmc'
+    , gibbsProposal
+    , slice
+    , sliceX
+    , incompleteBeta
+    , regBeta
+    , tCDF
+    , approxMh
+    , kl
+    ) where
+
+import Prelude (($), (.), error, Maybe(..), return)
+import qualified Prelude as P
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Syntax.AST (Term)
+import Language.Hakaru.Syntax.ABT (ABT, binder)
+import Language.Hakaru.Syntax.Prelude
+import Language.Hakaru.Syntax.Transform (TransformCtx(..), minimalCtx)
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Expect (expect, normalize)
+import Language.Hakaru.Disintegrate (determine
+                                    ,density, densityInCtx
+                                    ,disintegrate, disintegrateInCtx)
+import Language.Hakaru.Syntax.IClasses (TypeEq(..), JmEq1(..))
+
+import qualified Data.Text as Text
+import Control.Monad.Except (MonadError(..))
+
+import qualified Control.Applicative as P
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+priorAsProposal
+    :: (ABT Term abt, SingI a, SingI b)
+    => abt '[] ('HMeasure (HPair a b))
+    -> abt '[] (HPair a b)
+    -> abt '[] ('HMeasure (HPair a b))
+priorAsProposal p x =
+    bern (prob_ 0.5) >>= \c ->
+    p >>= \x' ->
+    dirac $
+        if_ c
+            (pair (fst x ) (snd x'))
+            (pair (fst x') (snd x ))
+
+
+-- We don't do the accept\/reject part of MCMC here, because @min@
+-- and @bern@ don't do well in @simplify@! So we'll be passing the
+-- resulting AST of 'mh' to 'simplify' before plugging that into
+-- @mcmc@; that's why 'easierRoadmapProg4' and 'easierRoadmapProg4''
+-- have different types.
+--
+-- TODO: the @a@ type should be pure (aka @a ~ Expect' a@ in the old parlance).
+-- BUG: get rid of the SingI requirements due to using 'lam'
+mh'  :: (ABT Term abt)
+     => TransformCtx
+     -> abt '[] (a ':-> 'HMeasure a)
+     -> abt '[] ('HMeasure a)
+     -> Maybe (abt '[] (a ':-> 'HMeasure (HPair a 'HProb)))
+mh' ctx proposal target =
+        let_ P.<$> (determine $ densityInCtx ctx target) P.<*> P.pure (\mu ->
+        lam' $ \old ->
+            app proposal old >>= \new ->
+            dirac $ pair' new (mu `app` {-pair-} new {-old-} / mu `app` {-pair-} old {-new-}))
+  where lam' f = lamWithVar Text.empty (sUnMeasure $ typeOf target) f
+        pair'  = pair_ (sUnMeasure $ typeOf target) SProb
+
+mh  :: (ABT Term abt)
+     => abt '[] (a ':-> 'HMeasure a)
+     -> abt '[] ('HMeasure a)
+     -> abt '[] (a ':-> 'HMeasure (HPair a 'HProb))
+mh proposal target =
+  P.maybe (error "mh: couldn't compute density") P.id $
+  mh' minimalCtx proposal target
+
+-- BUG: get rid of the SingI requirements due to using 'lam' in 'mh'
+mcmc' :: (ABT Term abt)
+      => TransformCtx
+      -> abt '[] (a ':-> 'HMeasure a)
+      -> abt '[] ('HMeasure a)
+      -> Maybe (abt '[] (a ':-> 'HMeasure a))
+mcmc' ctx proposal target =
+    let_ P.<$> mh' ctx proposal target P.<*> P.pure (\f ->
+    lamWithVar Text.empty (sUnMeasure $ typeOf target) $ \old ->
+        app f old >>= \new_ratio ->
+        new_ratio `unpair` \new ratio ->
+        bern (min (prob_ 1) ratio) >>= \accept ->
+        dirac (if_ accept new old))
+
+mcmc :: (ABT Term abt)
+     => abt '[] (a ':-> 'HMeasure a)
+     -> abt '[] ('HMeasure a)
+     -> abt '[] (a ':-> 'HMeasure a)
+mcmc proposal target =
+  P.maybe (error "mcmc: couldn't compute density") P.id $
+  mcmc' minimalCtx proposal target
+
+gibbsProposal
+    :: (ABT Term abt, SingI a, SingI b)
+    => abt '[] ('HMeasure (HPair a b))
+    -> abt '[] (HPair a b)
+    -> abt '[] ('HMeasure (HPair a b))
+gibbsProposal p xy =
+    case determine $ disintegrate p of
+    Nothing -> error "gibbsProposal: couldn't disintegrate"
+    Just q ->
+        xy `unpair` \x _y ->
+        pair x <$> normalize (q `app` x)
+
+
+-- Slice sampling can be thought of:
+--
+-- slice target x = do
+--      u  <- uniform(0, density(target, x))
+--      x' <- lebesgue
+--      condition (density(target, x') >= u) true
+--      return x'
+
+slice
+    :: (ABT Term abt)
+    => abt '[] ('HMeasure 'HReal)
+    -> abt '[] ('HReal ':-> 'HMeasure 'HReal)
+slice target =
+    case determine $ density target of
+    Nothing -> error "slice: couldn't get density"
+    Just densAt ->
+        lam $ \x ->
+        uniform (real_ 0) (fromProb $ app densAt x) >>= \u ->
+        normalize $
+        lebesgue >>= \x' ->
+        withGuard (u < (fromProb $ app densAt x')) $
+        dirac x'
+
+
+sliceX
+    :: (ABT Term abt, SingI a)
+    => abt '[] ('HMeasure a)
+    -> abt '[] ('HMeasure (HPair a 'HReal))
+sliceX target =
+    case determine $ density target of
+    Nothing -> error "sliceX: couldn't get density"
+    Just densAt ->
+        target `bindx` \x ->
+        uniform (real_ 0) (fromProb $ app densAt x)
+
+
+incompleteBeta
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] 'HProb
+incompleteBeta x a b =
+    let one' = real_ 1 in
+    integrate (real_ 0) (fromProb x) $ \t ->
+        unsafeProb t ** (fromProb a - one')
+        * unsafeProb (one' - t) ** (fromProb b - one')
+
+
+regBeta -- TODO: rename 'regularBeta'
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] 'HProb
+regBeta x a b = incompleteBeta x a b / betaFunc a b
+
+
+tCDF :: (ABT Term abt) => abt '[] 'HReal -> abt '[] 'HProb -> abt '[] 'HProb
+tCDF x v =
+    let b = regBeta (v / (unsafeProb (x*x) + v)) (v / prob_ 2) (prob_ 0.5)
+    in  unsafeProb $ real_ 1 - real_ 0.5 * fromProb b
+
+
+-- BUG: get rid of the SingI requirements due to using 'lam'
+approxMh
+    :: (ABT Term abt, SingI a)
+    => (abt '[] a -> abt '[] ('HMeasure a))
+    -> abt '[] ('HMeasure a)
+    -> [abt '[] a -> abt '[] ('HMeasure a)]
+    -> abt '[] (a ':-> 'HMeasure a)
+approxMh _ _ [] = error "TODO: approxMh for empty list"
+approxMh proposal prior (_:xs) =
+    case determine . density $ bindx prior proposal of
+    Nothing -> error "approxMh: couldn't get density"
+    Just theDensity ->
+        lam $ \old ->
+        let_ theDensity $ \mu ->
+        unsafeProb <$> uniform (real_ 0) (real_ 1) >>= \u ->
+        proposal old >>= \new ->
+        let_ (u * mu `app` pair new old / mu `app` pair old new) $ \u0 ->
+        let_ (l new new / l old old) $ \l0 ->
+        let_ (tCDF (n - real_ 1) (udif l0 u0)) $ \delta ->
+        if_ (delta < eps)
+            (if_ (u0 < l0)
+                (dirac new)
+                (dirac old))
+            (approxMh proposal prior xs `app` old)
+    where
+    n   = real_ 2000
+    eps = prob_ 0.05
+    udif lo hi = unsafeProb $ fromProb lo - fromProb hi
+    l = \_d1 _d2 -> prob_ 2 -- determine (density (\theta -> x theta))
+
+kl :: (ABT Term abt)
+   => abt '[] ('HMeasure a)
+   -> abt '[] ('HMeasure a)
+   -> Maybe (abt '[] 'HProb)
+kl p q = do
+  dp <- determine $ density p
+  dq <- determine $ density q
+  return
+    . expect p
+    . binder Text.empty (sUnMeasure $ typeOf p)
+    $ \i -> unsafeProb $ log (app dp i / app dq i)
diff --git a/haskell/Language/Hakaru/Maple.hs b/haskell/Language/Hakaru/Maple.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Maple.hs
@@ -0,0 +1,251 @@
+{-# LANGUAGE CPP
+           , FlexibleInstances
+           , FlexibleContexts
+           , DeriveDataTypeable
+           , DataKinds
+           , ScopedTypeVariables
+           , RecordWildCards
+           , ViewPatterns
+           , LambdaCase
+           , KindSignatures
+           , TypeOperators
+           , GADTs
+           , RankNTypes
+           , DeriveFunctor, DeriveFoldable, DeriveTraversable
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+-- |
+-- Module      :  Language.Hakaru.Maple 
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Take strings from Maple and interpret them in Haskell (Hakaru),
+-- in a type-safe way.
+----------------------------------------------------------------
+module Language.Hakaru.Maple
+  ( MapleException(..)
+  , MapleOptions(..)
+  , MapleCommand(MapleCommand)
+  , defaultMapleOptions
+  , sendToMaple, sendToMaple'
+  , maple
+  ) where
+
+import Control.Exception (Exception, throw)
+import Control.Monad (when)
+import Data.Typeable (Typeable)
+
+import qualified Language.Hakaru.Pretty.Maple as Maple
+
+import Language.Hakaru.Parser.Maple
+import Language.Hakaru.Parser.AST (Name)
+import Language.Hakaru.Pretty.Concrete (prettyType)
+import qualified Language.Hakaru.Parser.SymbolResolve as SR
+                  (resolveAST', fromVarSet)
+
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.TypeCheck
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.IClasses
+
+import Language.Hakaru.Evaluation.ConstantPropagation
+
+import System.MapleSSH (maple)
+import System.IO
+import Data.Text (pack)
+import qualified Data.Map as M
+import Data.List (isInfixOf, intercalate)
+import Data.Char (toLower)
+import Data.Function (on)
+
+import Data.Foldable (Foldable)
+import Data.Traversable (Traversable)
+
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid (mempty)
+#endif
+
+----------------------------------------------------------------
+data MapleException
+  = MapleInterpreterException String String
+  | MapleInputTypeMismatch String String
+  | MapleUnknownCommand String
+  | MapleAmbiguousCommand String [String]
+  | MultipleErrors [MapleException]
+      deriving Typeable
+
+instance Exception MapleException
+
+-- Maple prints errors with "cursors" (^) which point to the specific position
+-- of the error on the line above. The derived show instance doesn't preserve
+-- positioning of the cursor.
+instance Show MapleException where
+    show (MapleInterpreterException toMaple_ fromMaple) =
+        "MapleException:\n" ++ fromMaple ++
+        "\nafter sending to Maple:\n" ++ toMaple_
+    show (MapleInputTypeMismatch command ty) =
+      concat["Maple command ", command, " does not take input of type ", ty] 
+    show (MapleUnknownCommand command) = 
+      concat["Maple command ", command, " does not exist"] 
+    show (MapleAmbiguousCommand str cmds) =
+      concat [ "Ambiguous command\n"
+             , str, " could refer to any of\n"
+             , intercalate "," cmds ]
+    show (MultipleErrors es) =
+      concat $ "Multiple errors" : map (("\n\n" ++) . show) es
+
+data MapleOptions nm = MapleOptions 
+  { command   :: nm 
+  , debug     :: Bool 
+  , timelimit :: Int 
+  , extraOpts :: M.Map String String 
+  , context   :: TransformCtx
+  } deriving (Functor, Foldable, Traversable) 
+
+defaultMapleOptions :: MapleOptions () 
+defaultMapleOptions = MapleOptions
+  { command = ()    
+  , debug = False 
+  , timelimit = 90
+  , extraOpts = M.empty
+  , context = mempty }
+
+--------------------------------------------------------------------------------
+
+-- | Maple commands operate on closed terms and take a single argument, and can
+--   be applied under functions.
+data MapleCommand (i :: Hakaru) (o :: Hakaru) where
+  MapleCommand :: !(Transform '[ '( '[], i ) ] o) -> MapleCommand i o
+  UnderFun     :: !(MapleCommand i o) -> MapleCommand (x ':-> i) (x ':-> o)
+
+typeOfMapleCommand :: MapleCommand i o -> Sing i -> Sing o
+typeOfMapleCommand (MapleCommand t) i =
+  typeOfTransform t (Pw (Lift1 ()) i :* End)
+typeOfMapleCommand (UnderFun c) (SFun x i) =
+  SFun x (typeOfMapleCommand c i)
+
+newtype CommandMatcher
+   = CommandMatcher (forall i . Sing i
+                             -> Either MapleException (Some1 (MapleCommand i)))
+
+infixl 3 <-|>
+(<-|>) :: Either MapleException x
+       -> Either MapleException x
+       -> Either MapleException x
+(<-|>) (Left x) (Left y) =
+  Left $ MultipleErrors (unnest x ++ unnest y) where
+    unnest (MultipleErrors e) = concatMap unnest e
+    unnest                 e  = [e]
+(<-|>) Left{}         x  = x
+(<-|>) x@Right{}      _  = x
+
+matchUnderFun :: CommandMatcher -> CommandMatcher
+matchUnderFun (CommandMatcher k) = CommandMatcher go where
+  go :: Sing i -> Either MapleException (Some1 (MapleCommand i))
+  go ty@(SFun _ i) =
+    fmap (\(Some1 c) -> Some1 (UnderFun c)) (go i) <-|>
+    k ty
+  go ty =
+    k ty <-|>
+    Left (MapleInputTypeMismatch "x -> y" (show $ prettyType 0 ty))
+
+mapleCommands
+  :: [ (String, CommandMatcher) ]
+mapleCommands =
+  [ ("Simplify"
+    , CommandMatcher $ \_ -> return $ Some1 $ MapleCommand Simplify)
+  , ("Reparam"
+    , CommandMatcher $ \_ -> return $ Some1 $ MapleCommand Reparam)
+  , ("Summarize"
+    , CommandMatcher $ \_ -> return $ Some1 $ MapleCommand Summarize)
+  , ("Disintegrate"
+    , matchUnderFun $ CommandMatcher $ \i ->
+        case i of
+          SMeasure (SData (STyApp (STyApp
+              (STyCon (jmEq1 sSymbol_Pair -> Just Refl)) _) _) _) ->
+            return $ Some1 $ MapleCommand $ Disint InMaple
+          _ -> Left $
+                  MapleInputTypeMismatch "measure (pair (a,b))"
+                                         (show $ prettyType 0 i))
+  ]
+
+matchCommandName :: String -> Sing i
+                 -> Either MapleException (Some1 (MapleCommand i))
+matchCommandName s i =
+  case filter ((isInfixOf `on` map toLower) s . fst) mapleCommands of
+    [(_,CommandMatcher m)]
+       -> m i
+    [] -> Left $ MapleUnknownCommand s
+    cs -> Left $ MapleAmbiguousCommand s (map fst cs)
+
+nameOfMapleCommand :: MapleCommand i o -> Either MapleException String
+nameOfMapleCommand (MapleCommand t) = nm t where
+  nm :: Transform xs x -> Either MapleException String
+  nm Simplify         = Right "Simplify"
+  nm (Disint InMaple) = Right "Disintegrate"
+  nm Summarize        = Right "Summarize"
+  nm Reparam          = Right "Reparam"
+  nm tt               = Left $ MapleUnknownCommand (show tt)
+nameOfMapleCommand (UnderFun c) = nameOfMapleCommand c
+
+--------------------------------------------------------------------------------
+
+sendToMaple' 
+    :: ABT Term (abt Term) 
+    => MapleOptions String 
+    -> TypedAST (abt Term) 
+    -> IO (TypedAST (abt Term))
+sendToMaple' o@MapleOptions{..} (TypedAST typ term) = do
+  Some1 cmdT <- either throw return $ matchCommandName command typ
+  res        <- sendToMaple o{command=cmdT} term
+  return $ TypedAST (typeOf res) res
+
+sendToMaple
+    :: (ABT Term abt)
+    => MapleOptions (MapleCommand i o)
+    -> abt '[] i
+    -> IO (abt '[] o)
+sendToMaple MapleOptions{..} e = do
+  nm <- either throw return $ nameOfMapleCommand command
+  let typ_in = typeOf e
+      typ_out = typeOfMapleCommand command typ_in 
+      optStr (k,v) = concat["_",k,"=",v]
+      optsStr = 
+        intercalate "," $ 
+        map optStr $ M.assocs $ 
+        M.insert "command" nm extraOpts 
+      toMaple_ = "use Hakaru, NewSLO in timelimit("
+                 ++ show timelimit ++ ", RoundTrip("
+                 ++ Maple.pretty e ++ ", " ++ Maple.mapleType typ_in (", "
+                 ++ optsStr ++ ")) end use;")
+  when debug (hPutStrLn stderr ("Sent to Maple:\n" ++ toMaple_))
+  fromMaple <- maple toMaple_
+  case fromMaple of
+    '_':'I':'n':'e':'r':'t':_ -> do
+      when debug $ do
+        ret <- maple ("FromInert(" ++ fromMaple ++ ")")
+        hPutStrLn stderr ("Returning from Maple:\n" ++ ret)
+      either (throw  . MapleInterpreterException toMaple_)
+             (return . constantPropagation) $ do
+        past <- leftShow $ parseMaple (pack fromMaple)
+        let m = checkType typ_out
+                 (SR.resolveAST' (max (nextFreeOrBind e) (nextFreeVar context))
+                                 (getNames e) (maple2AST past))
+        leftShow $ unTCM m (freeVars e) Nothing UnsafeMode
+    _ -> throw (MapleInterpreterException toMaple_ fromMaple)
+
+leftShow :: forall b c. Show b => Either b c -> Either String c
+leftShow (Left err) = Left (show err)
+leftShow (Right x)  = Right x
+
+getNames :: ABT Term abt => abt '[] a -> [Name]
+getNames = SR.fromVarSet . freeVars
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Observe.hs b/haskell/Language/Hakaru/Observe.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Observe.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE DataKinds
+           , GADTs
+           , FlexibleContexts
+           , KindSignatures
+           , PolyKinds
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.21
+-- |
+-- Module      :  Language.Hakaru.Observe
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  ppaml@indiana.edu
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- A simpler version of the work done in 'Language.Hakaru.Disintegrate'
+--
+-- In principle, this module's functionality is entirely subsumed
+-- by the work done in Language.Hakaru.Disintegrate, so we can hope
+-- to define observe in terms of disintegrate. This is still useful
+-- as a guide to those that want something more in line with what other
+-- probabilisitc programming systems support.
+----------------------------------------------------------------
+module Language.Hakaru.Observe where
+
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Types.DataKind
+import           Language.Hakaru.Types.Sing
+import qualified Language.Hakaru.Syntax.Prelude as P
+import           Language.Hakaru.Syntax.TypeOf
+
+observe
+    :: (ABT Term abt)
+    => abt '[] ('HMeasure a)
+    -> abt '[] a 
+    -> abt '[] ('HMeasure a)
+observe m a = observeAST (LC_ m) (LC_ a)
+
+
+-- TODO: move this to ABT.hs
+freshenVarRe
+    :: ABT syn abt => Variable (a :: k) -> abt '[] (b :: k) -> Variable a
+freshenVarRe x m = x {varID = nextFree m `max` nextBind m}
+
+
+observeAST
+    :: (ABT Term abt)
+    => LC_ abt ('HMeasure a)
+    -> LC_ abt a
+    -> abt '[] ('HMeasure a)
+observeAST (LC_ m) (LC_ a) =
+    caseVarSyn m observeVar $ \ast ->
+        case ast of
+        -- TODO: Add a name supply
+        Let_ :$ e1 :* e2 :* End ->
+            caseBind e2 $ \x e2' ->
+            let x'   = freshenVarRe x m
+                e2'' = rename x x' e2'
+            in syn (Let_ :$ e1 :* bind x' (observe e2'' a) :* End)
+        --Dirac :$ e :* End -> P.if_ (e P.== a) (P.dirac a) P.reject
+        -- TODO: Add a name supply
+        MBind :$ e1 :* e2 :* End ->
+            caseBind e2 $ \x e2' ->
+            let x'   = freshenVarRe x m
+                e2'' = rename x x' e2'
+            in syn (MBind :$ e1 :* bind x' (observe e2'' a) :* End)
+        Plate :$ e1 :* e2 :* End ->
+            caseBind e2 $ \x e2' ->
+            let a' = syn (ArrayOp_ (Index (sUnMeasure $ typeOf e2'))
+                        :$ a
+                        :* var x :* End)
+            in syn (Plate :$ e1 :* bind x (observe e2' a') :* End)
+        MeasureOp_ op :$ es -> observeMeasureOp op es a
+        _ -> error "observe can only be applied to measure primitives"
+
+-- This function can't inspect a variable due to
+-- calls to subst that happens in Let_ and Bind_
+observeVar :: Variable a -> r
+observeVar = error "observe can only be applied measure primitives"
+
+observeMeasureOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => MeasureOp typs a
+    -> SArgs abt args
+    -> abt '[] a
+    -> abt '[] ('HMeasure a)
+observeMeasureOp Normal = \(mu :* sd :* End) a ->
+    P.withWeight (P.densityNormal mu sd a) (P.dirac a)
+observeMeasureOp Uniform = \(lo :* hi :* End) a ->
+    P.if_ (lo P.<= a P.&& a P.<= hi)
+        (P.withWeight (P.unsafeProb $ P.recip $ hi P.- lo) (P.dirac a))
+        (P.reject (SMeasure SReal))
+observeMeasureOp _ = error "TODO{Observe:observeMeasureOp}"
diff --git a/haskell/Language/Hakaru/Parser/AST.hs b/haskell/Language/Hakaru/Parser/AST.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Parser/AST.hs
@@ -0,0 +1,584 @@
+ {-# LANGUAGE CPP
+           , GADTs
+           , DataKinds
+           , PolyKinds
+           , ExistentialQuantification
+           , StandaloneDeriving
+           , TypeFamilies
+           , TypeOperators
+           , OverloadedStrings
+           , DeriveDataTypeable
+           , ScopedTypeVariables
+           , RankNTypes
+           , FlexibleContexts
+           , LambdaCase
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+
+module Language.Hakaru.Parser.AST where
+
+import           Prelude       hiding (replicate, unlines)
+import           Control.Arrow ((***))
+
+import qualified Data.Foldable       as F
+import qualified Data.Vector         as V
+import qualified Data.Number.Nat     as N
+import qualified Data.Number.Natural as N
+import qualified Data.List.NonEmpty  as L
+
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Syntax.ABT    hiding (Var, Bind)
+import Language.Hakaru.Syntax.AST
+    (Literal(..), MeasureOp(..), LCs(), UnLCs ())
+import qualified Language.Hakaru.Syntax.AST as T
+import Language.Hakaru.Syntax.IClasses
+
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid   (Monoid(..))
+#endif
+
+import qualified Data.Text as T
+import Text.Parsec (SourcePos)
+import Text.Parsec.Pos
+import Data.Generics hiding ((:~:)(..))
+
+-- N.B., because we're not using the ABT's trick for implementing a HOAS API, we can make the identifier strict.
+data Name = Name {-# UNPACK #-}!N.Nat {-# UNPACK #-}!T.Text
+    deriving (Read, Show, Eq, Ord, Data, Typeable)
+
+nameID :: Name -> N.Nat
+nameID (Name i _) = i
+
+hintID :: Name -> T.Text
+hintID (Name _ t) = t
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+type Name' = T.Text
+
+data Branch' a
+    = Branch'  (Pattern' Name') (AST' a)
+    | Branch'' (Pattern' Name)  (AST' a)
+    deriving (Eq, Show, Data, Typeable)
+
+data Pattern' a
+    = PVar'  a
+    | PWild'
+    | PData' (PDatum a)
+    deriving (Eq, Show, Data, Typeable)
+
+data PDatum a = DV Name' [Pattern' a]
+    deriving (Eq, Show, Data, Typeable)
+
+-- Meta stores start and end position for AST in source code
+data SourceSpan = SourceSpan !SourcePos !SourcePos
+    deriving (Eq, Show, Data, Typeable)
+
+printSourceSpan :: SourceSpan -> V.Vector T.Text -> T.Text
+printSourceSpan (SourceSpan start stop) input
+  = T.unlines (concatMap line [startLine..stopLine])
+  where
+  line :: Int -> [T.Text]
+  line i | (sourceLine start, sourceColumn start) <= (i, 1) &&
+           (i, eol) <= (sourceLine stop, sourceColumn stop)
+         = [T.empty | i == startLine] ++
+           [quote '>'] ++
+           [T.empty | i == stopLine]
+         | i == stopLine
+         = [T.empty | i == startLine] ++
+           [quote ' ',
+            marking (if i == sourceLine start then sourceColumn start else 1)
+                    (if i == sourceLine stop  then sourceColumn stop  else eol)
+                    '^']
+         | i == sourceLine start
+         = [marking (sourceColumn start) eol '.',
+            quote ' ']
+         | otherwise
+         = [quote ' ']
+    where numbering = T.pack (show i)
+          lining    = input V.! (i-1)
+          eol       = T.length lining + 1
+          quote c   = spacing (digits - T.length numbering)
+                      `T.append` numbering
+                      `T.append` T.singleton '|'
+                      `T.append` T.singleton c
+                      `T.append` lining
+  spacing k     = T.replicate k (T.singleton ' ')
+  marking l r c = spacing (digits + 1 + l)
+                  `T.append` T.replicate (max 1 (r - l)) (T.singleton c)
+  startLine     = max 1
+                $ sourceLine start
+  stopLine      = max startLine
+                $ min (V.length input)
+                $ (if sourceColumn stop == 1 then pred else id)
+                $ sourceLine stop
+  digits        = loop stopLine 1
+    where loop i res | i < 10    = res
+                     | otherwise = (loop $! div i 10) $! (res + 1)
+
+data Literal'
+    = Nat  Integer
+    | Int  Integer
+    | Prob Rational
+    | Real Rational
+    deriving (Eq, Show, Data, Typeable)
+
+data NaryOp
+    = And | Or   | Xor
+    | Iff | Min  | Max
+    | Sum | Prod
+    deriving (Eq, Show, Data, Typeable)
+
+data ArrayOp = Index_ | Size | Reduce deriving (Data, Typeable)
+
+data TypeAST'
+    = TypeVar Name'
+    | TypeApp Name'    [TypeAST']
+    | TypeFun TypeAST' TypeAST'
+    deriving (Eq, Show, Data, Typeable)
+
+data Reducer' a
+    = R_Fanout (Reducer' a) (Reducer' a)
+    | R_Index a (AST' a) (AST' a) (Reducer' a)
+    | R_Split (AST' a) (Reducer' a) (Reducer' a)
+    | R_Nop
+    | R_Add (AST' a)
+    deriving (Eq, Show, Data, Typeable)
+
+data Transform'
+    = Observe
+    | MH
+    | MCMC
+    | Disint T.TransformImpl
+    | Summarize
+    | Simplify
+    | Reparam
+    | Expect
+    deriving (Eq, Show, Data, Typeable)
+
+trFromTyped :: T.Transform as x -> Transform'
+trFromTyped = \case
+  T.Observe   -> Observe
+  T.MH        -> MH
+  T.MCMC      -> MCMC
+  T.Disint k  -> Disint k
+  T.Summarize -> Summarize
+  T.Simplify  -> Simplify
+  T.Reparam   -> Reparam
+  T.Expect    -> Expect
+
+data AST' a
+    = Var a
+    | Lam a TypeAST' (AST' a)
+    | App (AST' a) (AST' a)
+    | Let a    (AST' a) (AST' a)
+    | If  (AST' a) (AST' a) (AST' a)
+    | Ann (AST' a) TypeAST'
+    | Infinity'
+    | ULiteral Literal'
+    | NaryOp NaryOp [AST' a]
+    | Unit
+    | Pair (AST' a) (AST' a)
+    | Array a (AST' a) (AST' a)
+    | ArrayLiteral [AST' a]
+    | Index (AST' a) (AST' a)
+    | Case  (AST' a) [(Branch' a)] -- match
+    | Bind  a  (AST' a) (AST' a)
+    | Plate a  (AST' a) (AST' a)
+    | Chain a  (AST' a) (AST' a) (AST' a)
+    | Integrate a (AST' a) (AST' a) (AST' a)
+    | Summate   a (AST' a) (AST' a) (AST' a)
+    | Product   a (AST' a) (AST' a) (AST' a)
+    | Bucket    a (AST' a) (AST' a) (Reducer' a)
+    | Transform Transform' (SArgs' a)
+    | Msum  [AST' a]
+    | Data  a [a] [TypeAST'] (AST' a)
+    | WithMeta (AST' a) SourceSpan
+    deriving (Show, Data, Typeable)
+
+newtype SArgs' a = SArgs' [ ([a], AST' a) ]
+    deriving (Eq, Show, Data, Typeable)
+
+-- For backwards compatibility
+_Expect :: a -> AST' a -> AST' a -> AST' a
+_Expect v a b = Transform Expect $ SArgs' $ [ ([], a), ([v], b) ]
+
+withoutMeta :: AST' a -> AST' a
+withoutMeta (WithMeta e _) = withoutMeta e
+withoutMeta           e    =             e
+
+withoutMetaE :: forall a . Data a => AST' a -> AST' a
+withoutMetaE = everywhere (mkT (withoutMeta :: AST' a -> AST' a))
+
+instance Eq a => Eq (AST' a) where
+    (Var t)             == (Var t')                 = t    == t'
+    (Lam n  e1 e2)      == (Lam n' e1' e2')         = n    == n'  &&
+                                                      e1   == e1' &&
+                                                      e2   == e2'
+    (App    e1 e2)      == (App    e1' e2')         = e1   == e1' &&
+                                                      e2   == e2'
+    (Let n  e1 e2)      == (Let n' e1' e2')         = n    == n'  &&
+                                                      e1   == e1' &&
+                                                      e2   == e2'
+    (If  c  e1 e2)      == (If  c' e1' e2')         = c    == c'  &&
+                                                      e1   == e1' &&
+                                                      e2   == e2'
+    (Ann e typ)         == (Ann e' typ')            = e    == e'  &&
+                                                      typ  == typ'
+    Infinity'           == Infinity'                = True
+    (ULiteral v)        == (ULiteral v')            = v    == v'
+    (NaryOp op args)    == (NaryOp op' args')       = op   == op' &&
+                                                      args == args'
+    Unit                == Unit                     = True
+    (Pair  e1 e2)       == (Pair   e1' e2')         = e1   == e1' &&
+                                                      e2   == e2'
+    (Array e1 e2 e3)    == (Array  e1' e2' e3')     = e1   == e1' &&
+                                                      e2   == e2' &&
+                                                      e3   == e3'
+    (ArrayLiteral es)   == (ArrayLiteral es')       = es   == es'
+    (Index e1 e2)       == (Index  e1' e2')         = e1   == e1' &&
+                                                      e2   == e2'
+    (Case  e1 bs)       == (Case   e1' bs')         = e1   == e1' &&
+                                                      bs   == bs'
+    (Bind  e1 e2 e3)    == (Bind   e1' e2' e3')     = e1   == e1' &&
+                                                      e2   == e2' &&
+                                                      e3   == e3'
+    (Plate e1 e2 e3)    == (Plate  e1' e2' e3')     = e1   == e1' &&
+                                                      e2   == e2' &&
+                                                      e3   == e3'
+    (Chain e1 e2 e3 e4) == (Chain  e1' e2' e3' e4') = e1   == e1' &&
+                                                      e2   == e2' &&
+                                                      e3   == e3' &&
+                                                      e4   == e4'
+    (Integrate a b c d) == (Integrate  a' b' c' d') = a    == a' &&
+                                                      b    == b' &&
+                                                      c    == c' &&
+                                                      d    == d'
+    (Summate   a b c d) == (Summate    a' b' c' d') = a    == a' &&
+                                                      b    == b' &&
+                                                      c    == c' &&
+                                                      d    == d'
+    (Product   a b c d) == (Product    a' b' c' d') = a    == a' &&
+                                                      b    == b' &&
+                                                      c    == c' &&
+                                                      d    == d'
+    (Bucket    a b c d) == (Bucket     a' b' c' d') = a    == a' &&
+                                                      b    == b' &&
+                                                      c    == c' &&
+                                                      d    == d'
+    (Transform t0 es0)  == (Transform t1 es1)       = t0   == t1 &&
+                                                      es0  == es1
+    (Msum  es)          == (Msum   es')             = es   == es'
+    (Data  n ft ts e)   == (Data   n' ft' ts' e')   = n    == n'  &&
+                                                      ft   == ft' &&
+                                                      ts   == ts' &&
+                                                      e    == e'
+    (WithMeta e1 _ )    == e2                       = e1   == e2
+    e1                  == (WithMeta e2 _)          = e1   == e2
+    _                   == _                        = False
+
+data Import a = Import a
+     deriving (Eq, Show)
+data ASTWithImport' a = ASTWithImport' [Import a] (AST' a)
+     deriving (Eq, Show)
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+val :: Literal' -> Some1 Literal
+val (Nat  n) = Some1 $ LNat  (N.unsafeNatural n)
+val (Int  n) = Some1 $ LInt  n
+val (Prob n) = Some1 $ LProb (N.unsafeNonNegativeRational n)
+val (Real n) = Some1 $ LReal n
+
+data PrimOp
+    = Not | Impl | Diff   | Nand | Nor
+    | Pi
+    | Sin        | Cos    | Tan
+    | Asin       | Acos   | Atan
+    | Sinh       | Cosh   | Tanh
+    | Asinh      | Acosh  | Atanh
+    | RealPow    | Choose | NatPow
+    | Exp        | Log    | Infinity
+    | GammaFunc  | BetaFunc
+    | Equal      | Less
+    | Negate     | Recip
+    | Abs        | Signum | NatRoot | Erf
+    | Floor
+    deriving (Eq, Show)
+
+data SomeOp op where
+    SomeOp
+        :: (typs ~ UnLCs args, args ~ LCs typs)
+        => !(op typs a)
+        -> SomeOp op
+
+data SSing =
+    forall (a :: Hakaru). SSing !(Sing a)
+
+data Branch_ abt = Branch_ Pattern (abt '[] 'U)
+
+fmapBranch
+    :: (f '[] 'U -> g '[] 'U)
+    -> Branch_ f
+    -> Branch_ g
+fmapBranch f (Branch_ pat e) = Branch_ pat (f e)
+
+foldBranch
+    :: (abt '[] 'U -> m)
+    -> Branch_ abt
+    -> m
+foldBranch f (Branch_ _ e) = f e
+
+data Pattern
+    = PWild
+    | PVar Name
+    | PDatum T.Text PCode
+
+data PFun
+    = PKonst Pattern
+    | PIdent Pattern
+
+data PStruct
+    = PEt PFun PStruct
+    | PDone
+
+data PCode
+    = PInr PCode
+    | PInl PStruct
+
+infixr 7 `Et`, `PEt`
+
+data DFun abt
+    = Konst (abt '[] 'U)
+    | Ident (abt '[] 'U)
+
+data DStruct abt
+    = Et (DFun abt) (DStruct abt)
+    | Done
+
+data DCode abt
+    = Inr (DCode   abt)
+    | Inl (DStruct abt)
+
+data Datum abt = Datum T.Text (DCode abt)
+
+fmapDatum
+    :: (f '[] 'U -> g '[] 'U)
+    -> Datum f
+    -> Datum g
+fmapDatum f (Datum t dcode) = Datum t (fdcode f dcode)
+   where fdcode   f' (Inr d)    = Inr (fdcode   f' d)
+         fdcode   f' (Inl d)    = Inl (fdstruct f' d)
+         fdstruct f' (Et df ds) = Et  (fdfun    f' df)
+                                      (fdstruct f' ds)
+         fdstruct _  Done       = Done
+         fdfun    f' (Konst e)  = Konst (f' e)
+         fdfun    f' (Ident e)  = Ident (f' e)
+
+foldDatum
+    :: (Monoid m)
+    => (abt '[] 'U -> m)
+    -> Datum abt
+    -> m
+foldDatum f (Datum _ dcode) = fdcode f dcode
+   where fdcode   f' (Inr d)    = fdcode   f' d
+         fdcode   f' (Inl d)    = fdstruct f' d
+         fdstruct f' (Et df ds) = fdfun    f' df `mappend`
+                                  fdstruct f' ds
+         fdstruct _  Done       = mempty
+         fdfun    f' (Konst e)  = f' e
+         fdfun    f' (Ident e)  = f' e
+
+
+data Reducer (xs  :: [Untyped])
+             (abt :: [Untyped] -> Untyped -> *)
+             (a   :: Untyped) where
+    R_Fanout_ :: Reducer xs abt 'U
+              -> Reducer xs abt 'U
+              -> Reducer xs abt 'U
+    R_Index_  :: Variable 'U -- HACK: Shouldn't need to pass this argument
+              -> abt xs 'U
+              -> abt ( 'U ': xs) 'U
+              -> Reducer ( 'U ': xs) abt 'U
+              -> Reducer xs abt 'U
+    R_Split_  :: abt ( 'U ': xs) 'U
+              -> Reducer xs abt 'U
+              -> Reducer xs abt 'U
+              -> Reducer xs abt 'U
+    R_Nop_    :: Reducer xs abt 'U
+    R_Add_    :: abt ( 'U ': xs) 'U
+              -> Reducer xs abt 'U
+
+instance Functor21 (Reducer xs) where
+    fmap21 f (R_Fanout_ r1 r2)       = R_Fanout_ (fmap21 f r1) (fmap21 f r2)
+    fmap21 f (R_Index_  bv e1 e2 r1) = R_Index_ bv (f e1) (f e2) (fmap21 f r1)
+    fmap21 f (R_Split_  e1 r1 r2)    = R_Split_ (f e1) (fmap21 f r1) (fmap21 f r2)
+    fmap21 _ R_Nop_                  = R_Nop_
+    fmap21 f (R_Add_    e1)          = R_Add_ (f e1)
+
+instance Foldable21 (Reducer xs) where
+    foldMap21 f (R_Fanout_ r1 r2)       = foldMap21 f r1 `mappend` foldMap21 f r2
+    foldMap21 f (R_Index_  _  e1 e2 r1) =
+        f e1 `mappend` f e2 `mappend` foldMap21 f r1
+    foldMap21 f (R_Split_  e1 r1 r2)    =
+        f e1 `mappend` foldMap21 f r1 `mappend` foldMap21 f r2
+    foldMap21 _ R_Nop_                  = mempty
+    foldMap21 f (R_Add_    e1)          = f e1
+
+-- | The kind containing exactly one type.
+data Untyped = U
+    deriving (Read, Show)
+
+data instance Sing (a :: Untyped) where
+    SU :: Sing 'U
+
+instance SingI 'U where
+    sing = SU
+
+instance Show (Sing (a :: Untyped)) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance Show1 (Sing :: Untyped -> *) where
+    showsPrec1 _ SU = ("SU" ++)
+
+instance Eq (Sing (a :: Untyped)) where
+    SU == SU = True
+
+instance Eq1 (Sing :: Untyped -> *) where
+    eq1 SU SU = True
+
+instance JmEq1 (Sing :: Untyped -> *) where
+    jmEq1 SU SU = Just Refl
+
+nameToVar :: Name -> Variable 'U
+nameToVar (Name i h) = Variable h i SU
+
+data Term :: ([Untyped] -> Untyped -> *) -> Untyped -> * where
+    Lam_          :: SSing            -> abt '[ 'U ] 'U  -> Term abt 'U
+    App_          :: abt '[] 'U       -> abt '[]     'U  -> Term abt 'U
+    Let_          :: abt '[] 'U       -> abt '[ 'U ] 'U  -> Term abt 'U
+    Ann_          :: SSing            -> abt '[]     'U  -> Term abt 'U
+    CoerceTo_     :: Some2 Coercion   -> abt '[]     'U  -> Term abt 'U
+    UnsafeTo_     :: Some2 Coercion   -> abt '[]     'U  -> Term abt 'U
+    PrimOp_       :: PrimOp           -> [abt '[] 'U]    -> Term abt 'U
+    ArrayOp_      :: ArrayOp          -> [abt '[] 'U]    -> Term abt 'U
+    MeasureOp_    :: SomeOp MeasureOp -> [abt '[] 'U]    -> Term abt 'U
+    NaryOp_       :: NaryOp           -> [abt '[] 'U]    -> Term abt 'U
+    Literal_      :: Some1 Literal                       -> Term abt 'U
+    Pair_         :: abt '[] 'U       -> abt '[]     'U  -> Term abt 'U
+    Array_        :: abt '[] 'U       -> abt '[ 'U ] 'U  -> Term abt 'U
+    ArrayLiteral_ :: [abt '[] 'U]                        -> Term abt 'U
+    Datum_        :: Datum abt                           -> Term abt 'U
+    Case_         :: abt '[] 'U       -> [Branch_ abt]   -> Term abt 'U
+    Dirac_        :: abt '[] 'U                          -> Term abt 'U
+    MBind_        :: abt '[] 'U       -> abt '[ 'U ] 'U  -> Term abt 'U
+    Plate_        :: abt '[] 'U       -> abt '[ 'U ] 'U  -> Term abt 'U
+    Chain_        :: abt '[] 'U       -> abt '[]     'U  -> abt '[ 'U ] 'U -> Term abt 'U
+    Integrate_    :: abt '[] 'U       -> abt '[]     'U  -> abt '[ 'U ] 'U -> Term abt 'U
+    Summate_      :: abt '[] 'U       -> abt '[]     'U  -> abt '[ 'U ] 'U -> Term abt 'U
+    Product_      :: abt '[] 'U       -> abt '[]     'U  -> abt '[ 'U ] 'U -> Term abt 'U
+    Bucket_       :: abt '[] 'U       -> abt '[]     'U  -> Reducer xs abt 'U -> Term abt 'U
+    Transform_    :: T.Transform as x -> SArgs abt as    -> Term abt 'U
+    Superpose_    :: L.NonEmpty (abt '[] 'U, abt '[] 'U) -> Term abt 'U
+    Reject_       ::                                        Term abt 'U
+    InjTyped      :: (forall abt' . ABT T.Term abt'
+                                 => abt' '[] x)          -> Term abt 'U
+
+infixr 5 :*
+data SArgs (abt :: [Untyped] -> Untyped -> *) (as :: [([k], k)]) where
+  End :: SArgs abt '[]
+  (:*) :: !(List2 ToUntyped vars varsu, abt varsu 'U)
+       -> !(SArgs abt args)
+       -> SArgs abt ( '(vars, a) ': args)
+
+data ToUntyped (x :: k) (y :: Untyped) where
+  ToU :: ToUntyped x 'U
+
+instance Functor21 SArgs where
+    fmap21 f = \case
+      End          -> End
+      (m, a) :* as -> (m, f a) :* fmap21 f as
+
+-- TODO: instance of Traversable21 for Term
+instance Functor21 Term where
+    fmap21 f (Lam_       typ e1)    = Lam_       typ    (f e1)
+    fmap21 f (App_       e1  e2)    = App_       (f e1) (f e2)
+    fmap21 f (Let_       e1  e2)    = Let_       (f e1) (f e2)
+    fmap21 f (Ann_       typ e1)    = Ann_       typ    (f e1)
+    fmap21 f (CoerceTo_  c   e1)    = CoerceTo_  c      (f e1)
+    fmap21 f (UnsafeTo_  c   e1)    = UnsafeTo_  c      (f e1)
+    fmap21 f (PrimOp_    op  es)    = PrimOp_    op     (fmap f es)
+    fmap21 f (ArrayOp_   op  es)    = ArrayOp_   op     (fmap f es)
+    fmap21 f (MeasureOp_ op  es)    = MeasureOp_ op     (fmap f es)
+    fmap21 f (NaryOp_    op  es)    = NaryOp_    op     (fmap f es)
+    fmap21 _ (Literal_   v)         = Literal_   v
+    fmap21 f (Pair_      e1  e2)    = Pair_      (f e1) (f e2)
+    fmap21 f (Array_     e1  e2)    = Array_     (f e1) (f e2)
+    fmap21 f (ArrayLiteral_  es)    = ArrayLiteral_     (fmap f es)
+    fmap21 f (Datum_     d)         = Datum_     (fmapDatum f d)
+    fmap21 f (Case_      e1  bs)    = Case_      (f e1) (fmap (fmapBranch f) bs)
+    fmap21 f (Dirac_     e1)        = Dirac_     (f e1)
+    fmap21 f (MBind_     e1  e2)    = MBind_     (f e1) (f e2)
+    fmap21 f (Plate_     e1  e2)    = Plate_     (f e1) (f e2)
+    fmap21 f (Chain_     e1  e2 e3) = Chain_     (f e1) (f e2) (f e3)
+    fmap21 f (Integrate_ e1  e2 e3) = Integrate_ (f e1) (f e2) (f e3)
+    fmap21 f (Summate_   e1  e2 e3) = Summate_   (f e1) (f e2) (f e3)
+    fmap21 f (Product_   e1  e2 e3) = Product_   (f e1) (f e2) (f e3)
+    fmap21 f (Bucket_    e1  e2 e3) = Bucket_    (f e1) (f e2) (fmap21 f e3)
+    fmap21 f (Transform_ t as)      = Transform_ t (fmap21 f as)
+    fmap21 f (Superpose_ es)        = Superpose_ (L.map (f *** f) es)
+    fmap21 _ Reject_                = Reject_
+    fmap21 _ (InjTyped x)           = InjTyped x
+
+instance Foldable21 SArgs where
+    foldMap21 f = \case
+      End          -> mempty
+      (_, a) :* as -> f a `mappend` foldMap21 f as
+
+instance Foldable21 Term where
+    foldMap21 f (Lam_       _  e1)    = f e1
+    foldMap21 f (App_       e1 e2)    = f e1 `mappend` f e2
+    foldMap21 f (Let_       e1 e2)    = f e1 `mappend` f e2
+    foldMap21 f (Ann_       _  e1)    = f e1
+    foldMap21 f (CoerceTo_  _  e1)    = f e1
+    foldMap21 f (UnsafeTo_  _  e1)    = f e1
+    foldMap21 f (PrimOp_    _  es)    = F.foldMap f es
+    foldMap21 f (ArrayOp_   _  es)    = F.foldMap f es
+    foldMap21 f (MeasureOp_ _  es)    = F.foldMap f es
+    foldMap21 f (NaryOp_    _  es)    = F.foldMap f es
+    foldMap21 _ (Literal_   _)        = mempty
+    foldMap21 f (Pair_      e1 e2)    = f e1 `mappend` f e2
+    foldMap21 f (Array_     e1 e2)    = f e1 `mappend` f e2
+    foldMap21 f (ArrayLiteral_ es)    = F.foldMap f es
+    foldMap21 f (Datum_     d)        = foldDatum f d
+    foldMap21 f (Case_      e1 bs)    = f e1 `mappend` F.foldMap (foldBranch f) bs
+    foldMap21 f (Dirac_     e1)       = f e1
+    foldMap21 f (MBind_     e1 e2)    = f e1 `mappend` f e2
+    foldMap21 f (Plate_     e1 e2)    = f e1 `mappend` f e2
+    foldMap21 f (Chain_     e1 e2 e3) = f e1 `mappend` f e2 `mappend` f e3
+    foldMap21 f (Integrate_ e1 e2 e3) = f e1 `mappend` f e2 `mappend` f e3
+    foldMap21 f (Summate_   e1 e2 e3) = f e1 `mappend` f e2 `mappend` f e3
+    foldMap21 f (Product_   e1 e2 e3) = f e1 `mappend` f e2 `mappend` f e3
+    foldMap21 f (Bucket_    e1 e2 e3) = f e1 `mappend` f e2 `mappend` foldMap21 f e3
+    foldMap21 f (Transform_ _ es)     = foldMap21 f es
+    foldMap21 f (Superpose_ es)       = F.foldMap (\(e1,e2) -> f e1 `mappend` f e2) es
+    foldMap21 _ Reject_               = mempty
+    foldMap21 _ InjTyped{}            = mempty
+
+type U_ABT    = MetaABT SourceSpan Term
+type AST      = U_ABT '[] 'U
+type MetaTerm = Term U_ABT 'U
+type Branch   = Branch_ U_ABT
+
+type DFun_    = DFun    U_ABT
+type DStruct_ = DStruct U_ABT
+type DCode_   = DCode   U_ABT
+
+----------------------------------------------------------------
+---------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Parser/Import.hs b/haskell/Language/Hakaru/Parser/Import.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Parser/Import.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Language.Hakaru.Parser.Import (expandImports) where
+
+import           Language.Hakaru.Parser.AST
+import           Language.Hakaru.Parser.Parser (parseHakaruWithImports)
+
+import           Control.Monad.Trans.Except
+import           Control.Monad.IO.Class
+import qualified Data.Text                     as T
+import qualified Data.Text.IO                  as IO
+import           Text.Parsec
+
+replaceBody :: AST' T.Text -> AST' T.Text -> AST' T.Text
+replaceBody e1 e2 =
+    case e1 of
+      Let      x  e3 e4 -> Let x e3 (replaceBody e4 e2)
+      Ann      e3 t     -> Ann      (replaceBody e3 e2) t
+      WithMeta e3 s     -> WithMeta (replaceBody e3 e2) s
+      _                 -> e2
+
+expandImports
+    :: Maybe FilePath
+    -> ASTWithImport' T.Text
+    -> ExceptT ParseError IO (AST' T.Text)
+expandImports dir (ASTWithImport' (Import i:is) ast) = do
+    file  <- liftIO . IO.readFile . T.unpack $
+             T.concat $ maybe [] ((:["/"]) . T.pack) dir ++ [ i, ".hk" ]
+    astIm <- ExceptT . return $ parseHakaruWithImports file
+    ast'  <- expandImports dir astIm
+    expandImports dir (ASTWithImport' is (replaceBody ast' ast))
+expandImports _ (ASTWithImport' [] ast) = return ast
diff --git a/haskell/Language/Hakaru/Parser/Maple.hs b/haskell/Language/Hakaru/Parser/Maple.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Parser/Maple.hs
@@ -0,0 +1,690 @@
+{-# LANGUAGE CPP, OverloadedStrings, LambdaCase #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Language.Hakaru.Parser.Maple where
+
+import           Prelude             hiding (not, and, sum, product)
+import           Control.Monad.Identity
+import           Data.Text           (Text)
+import qualified Data.Text           as Text
+import           Data.Ratio
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor        ((<$>))
+import           Control.Applicative (Applicative(..))
+#endif
+import           Text.Parsec
+import           Text.Parsec.Text
+import qualified Text.Parsec.Token   as Token
+import           Text.Parsec.Language
+
+import           Language.Hakaru.Parser.AST hiding (Less, Equal)
+
+----------------------------------------------------------------
+
+style :: GenLanguageDef Text st Identity
+style = Token.LanguageDef
+    { Token.commentStart   = "(*"
+    , Token.commentEnd     = "*)"
+    , Token.commentLine    = "#"
+    , Token.nestedComments = True
+    , Token.identStart     = letter <|> char '_'
+    , Token.identLetter    = alphaNum <|> oneOf "_"
+    , Token.opStart        = Token.opLetter style
+    , Token.opLetter       = oneOf "+-*/<>="
+    , Token.reservedOpNames= []
+    , Token.reservedNames  = []
+    , Token.caseSensitive  = False
+    }
+
+type TokenParser a = Token.GenTokenParser Text a Identity
+
+lexer :: TokenParser ()
+lexer = Token.makeTokenParser style
+
+integer :: Parser Integer
+integer = Token.integer lexer
+
+parens :: Parser a -> Parser a
+parens = Token.parens lexer
+
+identifier :: Parser Text
+identifier = Text.pack <$> Token.identifier lexer
+
+stringLiteral :: Parser Text
+stringLiteral = Text.pack <$> Token.stringLiteral lexer
+
+comma :: Parser String
+comma = Token.comma lexer
+
+commaSep :: Parser a -> Parser [a]
+commaSep = Token.commaSep lexer
+
+symTable :: [(Text, Text)]
+symTable =
+    [ ("Gaussian",    "normal")
+    , ("BetaD",       "beta")
+    , ("GammaD",      "gamma")
+    , ("PoissonD",    "poisson")
+    , ("Weight",      "weight")
+    , ("Lebesgue",    "lebesgue")
+    , ("Counting",    "counting")
+    , ("Uniform",     "uniform")
+    , ("Ret",         "dirac")
+    , ("Categorical", "categorical")
+    , ("Geometric",   "geometric")
+    , ("Not",         "not")
+    , ("Pi",          "pi")
+    , ("ln",          "log")
+    , ("Beta",        "betaFunc")
+    , ("GAMMA",       "gammaFunc")
+    , ("csgn",        "signum")
+    -- Type symbols
+    , ("Real",        "real")
+    , ("Prob",        "prob")
+    , ("Measure",     "measure")
+    , ("Bool",        "bool")
+    ]
+
+rename :: Text -> Text
+rename x =
+    case lookup x symTable of
+    Just x' -> x'
+    Nothing -> x
+
+arg :: Parser a -> Parser [a]
+arg e = parens (commaSep e)
+
+text :: Text -> Parser Text
+text = liftM Text.pack <$> string <$> Text.unpack
+
+----------------------------------------------------------------
+-- | Grammar of Inert Expressions
+
+data NumOp = Pos | Neg
+    deriving (Eq, Show)
+
+data ArgOp
+    = Float | Power  | Rational
+    | Func  | ExpSeq | Sum_
+    | Prod_ | Less   | Equal
+    | NotEq | Not_   | And_
+    | Range | List
+    deriving (Eq, Show)
+
+data InertExpr
+    = InertName Text
+    | InertNum  NumOp Integer
+    | InertArgs ArgOp [InertExpr]
+    deriving (Eq, Show)
+
+----------------------------------------------------------------
+-- Parsing String into Inert Expression
+
+func :: Parser InertExpr
+func =
+    InertArgs
+    <$> (text "_Inert_FUNCTION" *> return Func)
+    <*> arg expr
+
+name :: Parser InertExpr
+name =
+    InertName
+    <$> (text "_Inert_NAME" *> parens stringLiteral)
+
+localname :: Parser InertExpr
+localname =
+    InertName
+    <$> (text "_Inert_LOCALNAME"
+        *> parens
+            (  stringLiteral
+            <* comma
+            <* integer))
+
+assignedname :: Parser InertExpr
+assignedname =
+    InertName
+    <$> (text "_Inert_ASSIGNEDNAME"
+        *> parens
+            (  stringLiteral
+            <* comma
+            <* stringLiteral))
+
+assignedlocalname :: Parser InertExpr
+assignedlocalname =
+    InertName
+    <$> (text "_Inert_ASSIGNEDLOCALNAME"
+        *> parens
+            (  stringLiteral
+            <* comma
+            <* stringLiteral
+            <* comma
+            <* integer))
+
+expseq :: Parser InertExpr
+expseq =
+    InertArgs
+    <$> (text "_Inert_EXPSEQ" *> return ExpSeq)
+    <*> arg expr
+
+intpos :: Parser InertExpr
+intpos =
+    InertNum
+    <$> (text "_Inert_INTPOS" *> return Pos)
+    <*> parens integer
+
+intneg :: Parser InertExpr
+intneg =
+    InertNum
+    <$> (text "_Inert_INTNEG" *> return Neg)
+    <*> fmap negate (parens integer)
+
+float :: Parser InertExpr
+float  =
+    InertArgs
+    <$> (text "_Inert_FLOAT" *> return Float)
+    <*> arg expr
+
+power :: Parser InertExpr
+power =
+    InertArgs
+    <$> (text "_Inert_POWER" *> return Power)
+    <*> arg expr
+
+range :: Parser InertExpr
+range =
+    InertArgs
+    <$> (text "_Inert_RANGE" *> return Range)
+    <*> arg expr
+
+and :: Parser InertExpr
+and =
+    InertArgs
+    <$> (text "_Inert_AND" *> return And_)
+    <*> arg expr
+
+list :: Parser InertExpr
+list =
+    InertArgs
+    <$> (text "_Inert_LIST" *> return List)
+    <*> arg expr
+
+sum :: Parser InertExpr
+sum =
+    InertArgs
+    <$> (text "_Inert_SUM" *> return Sum_)
+    <*> arg expr
+
+product :: Parser InertExpr
+product =
+    InertArgs
+    <$> (text "_Inert_PROD" *> return Prod_)
+    <*> arg expr
+
+rational :: Parser InertExpr
+rational =
+    InertArgs
+    <$> (text "_Inert_RATIONAL" *> return Rational)
+    <*> arg expr
+
+lessthan :: Parser InertExpr
+lessthan =
+    InertArgs
+    <$> (text "_Inert_LESSTHAN" *> return Less)
+    <*> arg expr
+
+not :: Parser InertExpr
+not =
+    InertArgs
+    <$> (text "_Inert_NOT" *> return Not_)
+    <*> arg expr
+
+lesseq :: Parser InertExpr
+lesseq = do
+    _ <- text "_Inert_LESSEQ"
+    args <- arg expr
+    return $ InertArgs Not_
+               [ InertArgs Less (reverse args)]
+
+equal :: Parser InertExpr
+equal =
+    InertArgs
+    <$> (text "_Inert_EQUATION" *> return Equal)
+    <*> arg expr
+
+noteq :: Parser InertExpr
+noteq =
+    InertArgs
+    <$> (text "_Inert_INEQUAT" *> return NotEq)
+    <*> arg expr
+
+expr :: Parser InertExpr
+expr =  try func
+    <|> try name
+    <|> try list
+    <|> try and
+    <|> try not
+    <|> try lessthan
+    <|> try lesseq
+    <|> try equal
+    <|> try noteq
+    <|> try assignedname
+    <|> try assignedlocalname
+    <|> try localname
+    <|> try expseq
+    <|> try intpos
+    <|> try intneg
+    <|> try range
+    <|> try power
+    <|> try sum
+    <|> try product
+    <|> try rational
+    <|> float
+
+parseMaple :: Text -> Either ParseError InertExpr
+parseMaple txt =
+    runParser (expr <* eof) () (Text.unpack txt) (Text.filter (/= '\n') txt)
+
+----------------------------------------------------------------
+-- Parsing InertExpr to AST' Text
+
+collapseNaryOp :: NaryOp -> [AST' Text] -> [AST' Text]
+collapseNaryOp op =
+    concatMap (\case
+                NaryOp op' e | op == op' ->  e
+                t                        -> [t])
+
+
+maple2AST :: InertExpr -> AST' Text
+maple2AST (InertNum Pos i)       = ULiteral $ Nat $ fromInteger i
+maple2AST (InertNum Neg i)       = ULiteral $ Int $ fromInteger i
+maple2AST (InertName "infinity") = Infinity'
+maple2AST (InertName t)          = Var (rename t)
+
+maple2AST (InertArgs Float [InertNum Pos a, InertNum _ b]) = 
+    ULiteral . Prob $ fromInteger a * (10 ^ b)
+
+maple2AST (InertArgs Float [InertNum Neg a, InertNum _ b]) = 
+    ULiteral . Real $ fromInteger a * (10 ^ b)
+
+maple2AST (InertArgs Func
+        [InertName "Let", InertArgs ExpSeq [e1, InertName x, e2]]) =
+    Let x (maple2AST e1) (maple2AST e2)
+
+maple2AST (InertArgs Func
+        [InertName "Bind", InertArgs ExpSeq [e1, InertName x, e2]]) =
+    Bind x (maple2AST e1) (maple2AST e2)
+
+maple2AST (InertArgs Func
+        [InertName "Datum", InertArgs ExpSeq [InertName h, d]]) =
+    mapleDatum2AST h d
+
+maple2AST (InertArgs Func [InertName "Counting", _]) =
+    Var "counting"
+
+maple2AST (InertArgs Func
+        [InertName "lam", InertArgs ExpSeq [InertName x, typ, e1]]) =
+    Lam x (maple2Type typ) (maple2AST e1)
+
+maple2AST (InertArgs Func
+        [InertName "app", InertArgs ExpSeq [e1, e2]]) =
+    App (maple2AST e1) (maple2AST e2)
+
+maple2AST (InertArgs Func
+        [InertName "NegativeBinomial", InertArgs ExpSeq [e1, e2]]) =
+    Bind "i" (op2 "gamma" r (recip_ $ recip_ p -. (lit $ Prob 1)))
+         (App (Var "poisson") (Var "i"))
+    where recip_     = App (Var "recip")
+          x -. y     = NaryOp Sum [x, App (Var "negate") y]
+          op2  s x y = App (App (Var s) x) y
+          lit        = ULiteral
+          r          = maple2AST e1
+          p          = maple2AST e2
+
+maple2AST (InertArgs Func
+        [InertName "Msum", InertArgs ExpSeq []]) =
+    Var "reject"
+
+maple2AST (InertArgs Func
+        [InertName "Msum", InertArgs ExpSeq es]) =
+    Msum (map maple2AST es)
+
+maple2AST (InertArgs Func
+        [InertName "ary", InertArgs ExpSeq [e1, InertName x, e2]]) =
+    Array x (maple2AST e1) (maple2AST e2)
+
+maple2AST (InertArgs Func
+        [InertName "idx", InertArgs ExpSeq [e1, e2]]) =
+    Index (maple2AST e1) (maple2AST e2)
+
+maple2AST (InertArgs Func
+        [InertName "piecewise", InertArgs ExpSeq es]) = go es where
+  go []           = error "Invalid 0-ary piecewise?"
+  go [_]          = error "Invalid 1-ary piecewise?"
+  go [e1,e2]      = If (maple2AST e1) (maple2AST e2) (ULiteral (Nat 0))
+  go [e1,e2,e3]   = If (maple2AST e1) (maple2AST e2) (maple2AST e3)
+  -- BUG! piecewise(a<b,2,a=b,1) doesn't mean piecewise(a<b,2,1) in Maple
+  go [e1,e2,_,e3] = If (maple2AST e1) (maple2AST e2) (maple2AST e3)
+  go (e1:e2:rest) = If (maple2AST e1) (maple2AST e2) (go rest)
+
+maple2AST (InertArgs Func [InertName "PARTITION"
+        ,InertArgs ExpSeq [InertArgs List [InertArgs ExpSeq es]]]) = 
+  maybe (Var "reject") id $ 
+  foldr piece2AST Nothing es 
+    where piece2AST (InertArgs Func [InertName "Piece", InertArgs ExpSeq cs]) e  
+            | [c,v] <- map maple2AST cs = Just $ maybe v (If c v) e
+          piece2AST x _ = error $ "Invalid PARTITION contents: " ++ show x
+
+maple2AST (InertArgs Func
+        [InertName "max", InertArgs ExpSeq es]) =
+    NaryOp Max (map maple2AST es)
+
+maple2AST (InertArgs Func
+        [InertName "min", InertArgs ExpSeq es]) =
+    NaryOp Min (map maple2AST es)
+
+maple2AST (InertArgs Func
+        [InertName "Ei", InertArgs ExpSeq [e1, e2]]) =
+    Integrate "t" (maple2AST e2) Infinity'
+    (NaryOp Prod [ App (Var "exp")   (App (Var "negate") (Var "t"))
+                 , App (Var "recip")
+                       (App (App (Var "^") (Var "t")) (maple2AST e1))
+                 ])
+
+maple2AST (InertArgs Func
+        [ InertName "case"
+        , InertArgs ExpSeq
+            [e1, InertArgs Func
+                [ InertName "Branches"
+                , InertArgs ExpSeq bs]]]) =
+    Case (maple2AST e1) (map branch bs)
+
+maple2AST (InertArgs Func
+        [InertName "Plate", InertArgs ExpSeq [e1, InertName x, e2]]) =
+    Plate x (maple2AST e1) (maple2AST e2)
+
+maple2AST (InertArgs Func
+        [InertName "Or", InertArgs ExpSeq es]) =
+    NaryOp Or (map maple2AST es)
+
+maple2AST (InertArgs Func
+        [InertName "And", InertArgs ExpSeq es]) =
+    NaryOp And (map maple2AST es)
+
+maple2AST (InertArgs Func
+        [ InertName "int"
+        , InertArgs ExpSeq
+           [ f
+           , InertArgs Equal
+             [ InertName x
+             , InertArgs Range [lo, hi]]]]) =
+    Integrate x (maple2AST lo) (maple2AST hi) (maple2AST f)
+
+maple2AST (InertArgs Func
+        [ InertName "Int"
+        , InertArgs ExpSeq
+           [ f
+           , InertArgs Equal
+             [ InertName x
+             , InertArgs Range [lo, hi]]]]) =
+    Integrate x (maple2AST lo) (maple2AST hi) (maple2AST f)
+
+maple2AST (InertArgs Func
+        [ InertName "SumIE"
+        , InertArgs ExpSeq
+           [ f
+           , InertArgs Equal
+             [ InertName x
+             , InertArgs Range [lo, hi]]]]) =
+    Summate x (maple2AST lo) (maple2AST hi) (maple2AST f)
+
+maple2AST (InertArgs Func
+        [ InertName "ProductIE"
+        , InertArgs ExpSeq
+           [ f
+           , InertArgs Equal
+             [ InertName x
+             , InertArgs Range [lo, hi]]]]) =
+    Product x (maple2AST lo) (maple2AST hi) (maple2AST f)
+
+maple2AST (InertArgs Func
+        [ InertName "BucketIE"
+        , InertArgs ExpSeq
+           [ f
+           , InertArgs Equal
+             [ InertName x
+             , InertArgs Range [lo, hi]]]]) =
+    Bucket x (maple2AST lo) (maple2AST hi) (maple2ReducerAST f)
+
+-- TODO: This logic should be in SymbolResolve
+maple2AST (InertArgs Func
+        [ InertName "fst"
+        , InertArgs ExpSeq [ e1 ]]) =
+    Case (maple2AST e1)
+         [ Branch' (PData' (DV "pair" [PVar' "y",PVar' "z"])) (Var "y")]
+
+-- TODO: This logic should be in SymbolResolve
+maple2AST (InertArgs Func
+        [ InertName "snd"
+        , InertArgs ExpSeq [ e1 ]]) =
+    Case (maple2AST e1)
+         [ Branch' (PData' (DV "pair" [PVar' "y",PVar' "z"])) (Var "z")]
+
+maple2AST (InertArgs Func
+        [f, InertArgs ExpSeq es]) =
+    foldl App (maple2AST f) (map maple2AST es)
+
+maple2AST (InertArgs List [InertArgs ExpSeq es]) = ArrayLiteral $ map maple2AST es
+
+maple2AST (InertArgs And_  es) = NaryOp And  (collapseNaryOp And  (map maple2AST es))
+maple2AST (InertArgs Sum_  es) = NaryOp Sum  (collapseNaryOp Sum  (map maple2AST es))
+maple2AST (InertArgs Prod_ es) = NaryOp Prod (collapseNaryOp Prod (map maple2AST es))
+
+maple2AST (InertArgs Not_ [e])  =
+    App (Var "not") (maple2AST e)
+
+maple2AST (InertArgs Less es)  =
+    foldl App (Var "less")  (map maple2AST es)
+
+-- Special case to undo the "piecewise(x=true,...)" created by our Maple code
+-- (in the Hakaru:-make_piece function), to avoid the error produced by Maple
+-- "piecewise(x,...)".  (This "=true" is also removed by NewSLO:-applyintegrand
+-- if Maple ever substitutes something for x, but that may never happen.)
+maple2AST (InertArgs Equal [e, InertName "true"]) = maple2AST e
+maple2AST (InertArgs Equal [InertName "true", e]) = maple2AST e
+
+maple2AST (InertArgs Equal es) =
+    foldl App (Var "equal") (map maple2AST es)
+
+maple2AST (InertArgs NotEq es) =
+    App (Var "not") (foldl App (Var "equal") (map maple2AST es))
+
+maple2AST (InertArgs Power [x, InertNum Pos y]) =
+    App (App (Var "^")  (maple2AST x)) (maple2AST (InertNum Pos y))
+maple2AST (InertArgs Power [x, InertNum Neg (-1)]) =
+    App (Var "recip")  (maple2AST x)
+maple2AST (InertArgs Power [x, 
+                            InertArgs Rational
+                            [InertNum Pos 1, InertNum Pos y]]) =
+    App (App (Var "natroot") (maple2AST x)) (ULiteral . Nat $ y)
+
+maple2AST (InertArgs Power [x, 
+                            InertArgs Rational
+                            [InertNum Neg (-1), InertNum Pos y]]) =
+    App (Var "recip")
+        (App (App (Var "natroot") (maple2AST x)) (ULiteral . Nat $ y))
+
+maple2AST (InertArgs Power [x, y]) =
+    App (App (Var "**") (maple2AST x)) (maple2AST y)
+maple2AST (InertArgs Rational [InertNum Pos x, InertNum Pos y]) =
+    ULiteral . Prob $ fromInteger x % fromInteger y
+maple2AST (InertArgs Rational [InertNum _ x, InertNum _ y]) =
+    ULiteral . Real $ fromInteger x % fromInteger y
+
+maple2AST x = error $ "Can't handle: " ++ show x
+
+----------------------------------------------------------------
+
+maple2ReducerAST :: InertExpr -> Reducer' Text
+maple2ReducerAST
+ (InertArgs Func
+  [ InertName "Fanout"
+  , InertArgs ExpSeq [ e1, e2 ]]) =
+  R_Fanout (maple2ReducerAST e1) (maple2ReducerAST e2)
+
+maple2ReducerAST
+ (InertArgs Func
+  [ InertName "Index"
+  , InertArgs ExpSeq [ e1, InertName x, e2, e3]]) =
+  R_Index x (maple2AST e1) (maple2AST e2) (maple2ReducerAST e3)
+
+maple2ReducerAST
+ (InertArgs Func
+  [ InertName "Split"
+  , InertArgs ExpSeq [ e1, e2, e3]]) =
+  R_Split (maple2AST e1) (maple2ReducerAST e2) (maple2ReducerAST e3)
+
+maple2ReducerAST
+ (InertArgs Func
+  [ InertName "Nop"
+  , InertArgs ExpSeq []]) = R_Nop
+
+maple2ReducerAST
+ (InertArgs Func
+  [ InertName "Add"
+  , InertArgs ExpSeq [e1]]) = R_Add (maple2AST e1)
+
+maple2ReducerAST _ = error "TODO: maple2ReducerAST, so many cases..."
+
+mapleDatum2AST :: Text -> InertExpr -> AST' Text
+mapleDatum2AST h d = case (h, maple2DCode d) of
+  ("pair", [x,y]) -> Pair x y
+  ("unit", []   ) -> Unit
+  _               -> error $ "TODO: mapleDatum2AST " ++ Text.unpack h
+    
+maple2Type :: InertExpr -> TypeAST'
+maple2Type (InertArgs Func
+            [InertName "HInt",
+             InertArgs ExpSeq
+             [InertArgs Func
+              [InertName "Bound",
+               InertArgs ExpSeq
+               [InertName ">=",InertNum Pos 0]]]])
+    = TypeVar "nat"
+maple2Type (InertArgs Func
+            [InertName "HInt",
+             InertArgs ExpSeq []])
+    = TypeVar "int"
+maple2Type (InertArgs Func
+            [InertName nm,
+             InertArgs ExpSeq
+             [InertArgs Func
+              [InertName "Bound",
+               InertArgs ExpSeq
+               [InertName ">=",InertNum Pos 0]]]])
+    | nm `elem` [ "HReal", "AlmostEveryReal" ]
+    = TypeVar "prob"
+maple2Type (InertArgs Func
+            [InertName nm,
+             InertArgs ExpSeq []])
+    | nm `elem` [ "HReal", "AlmostEveryReal" ]
+    = TypeVar "real"
+
+maple2Type (InertArgs Func
+            [InertName "HData",
+             InertArgs ExpSeq
+             [InertArgs Func
+              [InertName "DatumStruct",
+               InertArgs ExpSeq
+               [InertName "unit",
+                InertArgs List
+                [InertArgs ExpSeq []]]]]])
+     = TypeVar "unit"
+
+maple2Type (InertArgs Func
+            [InertName "HData",
+             InertArgs ExpSeq
+             [InertArgs Func
+              [InertName "DatumStruct",
+               InertArgs ExpSeq
+               [InertName "true",
+                InertArgs List
+                [InertArgs ExpSeq []]]],
+              InertArgs Func
+              [InertName "DatumStruct",
+               InertArgs ExpSeq
+               [InertName "false",
+                InertArgs List
+                [InertArgs ExpSeq []]]]]])
+     = TypeVar "bool"
+
+maple2Type (InertArgs Func
+            [InertName "HData",
+             InertArgs ExpSeq
+             [InertArgs Func
+              [InertName "DatumStruct",
+               InertArgs ExpSeq
+               [InertName "pair",
+                InertArgs List
+                [InertArgs ExpSeq
+                 [InertArgs Func
+                  [InertName "Konst",
+                   InertArgs ExpSeq [x]],
+                  InertArgs Func
+                  [InertName "Konst",
+                   InertArgs ExpSeq [y]]]]]]]])
+     = TypeApp "pair" (map maple2Type [x, y])
+
+maple2Type (InertArgs Func
+            [InertName "HArray",
+             InertArgs ExpSeq
+             [x]])
+     = TypeApp "array" [maple2Type x]
+
+maple2Type (InertArgs Func
+            [InertName "HFunction",
+             InertArgs ExpSeq
+             [x, y]])
+     = TypeFun (maple2Type x) (maple2Type y)
+
+maple2Type (InertArgs Func
+            [InertName "HMeasure",
+             InertArgs ExpSeq
+             [x]])
+     = TypeApp "measure" [maple2Type x]
+
+maple2Type x = error ("TODO: maple2Type " ++ show x)
+
+
+branch :: InertExpr -> Branch' Text
+branch (InertArgs Func
+        [InertName "Branch",
+         InertArgs ExpSeq [pat, e]]) =
+    Branch' (maple2Pattern pat) (maple2AST e)
+branch _ = error "Branch: got some ill-formed case statement back?"
+
+
+maple2Pattern :: InertExpr -> Pattern' Text
+maple2Pattern (InertName "PWild") = PWild'
+maple2Pattern (InertArgs Func
+               [InertName "PVar",
+                InertArgs ExpSeq
+                [InertName x]]) = PVar' x
+maple2Pattern (InertArgs Func
+               [InertName "PDatum",
+                InertArgs ExpSeq
+                [InertName hint, args]]) =
+    PData' (DV hint (maple2Patterns args))
+maple2Pattern e = error $ "TODO: maple2AST{pattern} " ++ show e
+
+maple2DCode :: InertExpr -> [AST' Text]
+maple2DCode (InertArgs Func [InertName "Inl", InertArgs ExpSeq [e]]) = maple2DCode e
+maple2DCode (InertArgs Func [InertName "Inr", InertArgs ExpSeq [e]]) = maple2DCode e
+maple2DCode (InertArgs Func [InertName "Et" , InertArgs ExpSeq [InertArgs Func [InertName "Konst", InertArgs ExpSeq [x]], e]]) = maple2AST x : maple2DCode e
+maple2DCode (InertName "Done") = []
+maple2DCode e = error $ "maple2DCode: " ++ show e ++ " not InertExpr of a datum"
+
+maple2Patterns :: InertExpr -> [Pattern' Text]
+maple2Patterns (InertArgs Func [InertName "PInl", InertArgs ExpSeq [e]]) = maple2Patterns e
+maple2Patterns (InertArgs Func [InertName "PInr", InertArgs ExpSeq [e]]) = maple2Patterns e
+maple2Patterns (InertArgs Func [InertName "PEt" , InertArgs ExpSeq [InertArgs Func [InertName "PKonst", InertArgs ExpSeq [x]], e]]) = maple2Pattern x : maple2Patterns e
+maple2Patterns (InertName "PDone") = []
+maple2Patterns e = error $ "maple2Patterns: " ++ show e ++ " not InertExpr of a pattern"
diff --git a/haskell/Language/Hakaru/Parser/Parser.hs b/haskell/Language/Hakaru/Parser/Parser.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Parser/Parser.hs
@@ -0,0 +1,661 @@
+{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Language.Hakaru.Parser.Parser
+    (
+      parseHakaru
+    , parseHakaruWithImports
+    , parseReplLine
+    ) where
+
+import Prelude hiding (Real)
+
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor                  ((<$>), (<$))
+import           Control.Applicative           (Applicative(..))
+#endif
+import           Data.Functor.Identity
+import           Data.Text                     (Text)
+import qualified Data.Text                     as Text
+import           Data.Ratio                    ((%))
+import           Data.Char                     (digitToInt)
+import           Text.Parsec
+import           Text.Parsec.Text              () -- instances only
+import           Text.Parsec.Indentation
+import           Text.Parsec.Indentation.Char
+import qualified Text.Parsec.Indentation.Token as ITok
+import           Text.Parsec.Expr              (Assoc(..), Operator(..))
+import qualified Text.Parsec.Token             as Tok
+
+import Language.Hakaru.Parser.AST
+import Language.Hakaru.Syntax.IClasses (Some2(..))
+import Language.Hakaru.Syntax.AST (allTransforms, transformName)
+
+ops, names :: [String]
+ops = words "^ ** * / + - .  < > <= >= == /= && || <|> -> : <~ = _"
+names = concatMap words [ "def fn"
+                        , "if else match"
+                        , "return dirac"
+                        , "integrate summate product from to"
+                        , "array plate chain of"
+                        , "r_nop r_split r_index r_fanout r_add bucket"
+                        , "import data ∞" ] ++
+        map (\(Some2 t) -> transformName t) allTransforms
+
+type ParserStream    = IndentStream (CharIndentStream Text)
+type Parser          = ParsecT     ParserStream () Identity
+type OperatorTable a = [[Operator ParserStream () Identity a]]
+
+style :: Tok.GenLanguageDef ParserStream st Identity
+style = ITok.makeIndentLanguageDef $ Tok.LanguageDef
+    { Tok.commentStart    = ""
+    , Tok.commentEnd      = ""
+    , Tok.nestedComments  = True
+    , Tok.identStart      = letter <|> char '_'
+    , Tok.identLetter     = alphaNum <|> oneOf "_'"
+    , Tok.opStart         = oneOf [ c | c:_ <- ops ]
+    , Tok.opLetter        = oneOf [ c | _:cs <- ops, c <- cs ]
+    , Tok.caseSensitive   = True
+    , Tok.commentLine     = "#"
+    , Tok.reservedOpNames = ops
+    , Tok.reservedNames   = names
+    }
+
+lexer :: Tok.GenTokenParser ParserStream () Identity
+lexer = ITok.makeTokenParser style
+
+whiteSpace :: Parser ()
+whiteSpace = Tok.whiteSpace lexer
+
+decimal :: Parser Integer
+decimal = Tok.decimal lexer
+
+decimalFloat :: Parser Literal'
+decimalFloat = do n <- decimal
+                  option (Nat n) (Prob <$> fractExponent n)
+
+fractExponent   :: Integer -> Parser Rational
+fractExponent n =  do{ fract <- fraction
+                     ; expo  <- option 1 exponent'
+                     ; return ((fromInteger n + fract)*expo)
+                     }
+                  <|>
+                  do{ expo <- exponent'
+                    ; return ((fromInteger n)*expo)
+                    }
+
+fraction        :: Parser Rational
+fraction        =  do{ d      <- try (char '.' *> digit)
+                     ; digits <- many digit <?> "fraction"
+                     ; return (foldr1 op (map (fromIntegral.digitToInt) (d:digits))
+                               / 10)
+                     }
+                  <?> "fraction"
+                    where
+                      op d f    = d + f / 10
+
+exponent'       :: Parser Rational
+exponent'       =  do{ _ <- oneOf "eE"
+                     ; f <- (negate <$ char '-') <|> (id <$ optional (char '+'))
+                     ; e <- decimal <?> "exponent"
+                     ; return (10 ^^ f e)
+                     }
+                  <?> "exponent"
+
+parens :: Parser a -> Parser a
+parens = Tok.parens lexer . localIndentation Any
+
+brackets :: Parser a -> Parser a
+brackets = Tok.brackets lexer . localIndentation Any
+
+commaSep :: Parser a -> Parser [a]
+commaSep = Tok.commaSep lexer
+
+identifier :: Parser Text
+identifier = Text.pack <$> Tok.identifier lexer
+
+reserved :: String -> Parser ()
+reserved s
+  | s `elem` names -- assertion
+  = Tok.reserved lexer s
+  | otherwise
+  = error ("Parser failed to reserve the name " ++ show s)
+
+reservedOp :: String -> Parser ()
+reservedOp s
+  | s `elem` ops -- assertion
+  = Tok.reservedOp lexer s
+  | otherwise
+  = error ("Parser failed to reserve the operator " ++ show s)
+
+app1 :: a -> AST' a -> AST' a
+app1 s x = Var s `App` x
+
+app2 :: a -> AST' a -> AST' a -> AST' a
+app2 s x y = Var s `App` x `App` y
+
+divide, sub :: AST' Text -> AST' Text -> AST' Text
+divide       (WithMeta (ULiteral (Nat   x     )) (SourceSpan s _))
+             (WithMeta (ULiteral (Nat       y )) (SourceSpan _ e))
+           = (WithMeta (ULiteral (Prob (x % y))) (SourceSpan s e))
+divide       (WithMeta (ULiteral (Nat   1     )) (SourceSpan _ _))
+             y
+           = app1 "recip" y
+divide x y = NaryOp Prod [x, app1 "recip" y]
+sub    x y = NaryOp Sum  [x, app1 "negate" y]
+
+bi :: ([a] -> b) -> a -> a -> b
+bi f x y = f [x, y]
+
+negate_rel :: (AST' Text -> AST' Text -> AST' Text)
+           -> (AST' Text -> AST' Text -> AST' Text)
+negate_rel f x y = app1 "not" (f x y)
+
+binary :: String
+       -> Assoc
+       -> (a -> a -> a)
+       -> Operator ParserStream () Identity a
+binary s a f = Infix (f <$ reservedOp s) a
+
+postfix :: Stream s m t
+        => ParsecT s u m (AST' a -> AST' a)
+        -> Operator s u m (AST' a)
+postfix p = Postfix (chainl1 p' (return (flip (.))))
+  where p' = do f <- p
+                e <- getPosition
+                return (\x -> case x of
+                  WithMeta _ (SourceSpan s _) -> WithMeta (f x) (SourceSpan s e)
+                  _                           ->           f x)
+
+sign :: Parser (AST' Text -> AST' Text)
+sign = do
+  s <- getPosition
+  (fNat, fProb, fRest)
+    <- ((id    , id    , id           ) <$ reservedOp "+") <|>
+       ((negate, negate, app1 "negate") <$ reservedOp "-")
+  let f     (WithMeta (ULiteral (Nat         x )) (SourceSpan _ e))
+          = (WithMeta (ULiteral (Int  (fNat  x))) (SourceSpan s e))
+      f     (WithMeta (ULiteral (Prob        x )) (SourceSpan _ e))
+          = (WithMeta (ULiteral (Real (fProb x))) (SourceSpan s e))
+      f x = fRest x
+  return f
+
+table :: OperatorTable (AST' Text)
+table = [ [ postfix (array_index <|> fun_call) ]
+        , [ binary "^"   AssocRight $ app2 "^"
+          , binary "**"  AssocRight $ app2 "**" ]
+        , [ binary "*"   AssocLeft  $ bi (NaryOp Prod)
+          , binary "/"   AssocLeft  $ divide ]
+        , [ Prefix sign
+          , binary "+"   AssocLeft  $ bi (NaryOp Sum)
+          , binary "-"   AssocLeft  $ sub ]
+        , [ postfix ann_expr ]
+        , [ binary "<"   AssocNone  $                     app2 "less"
+          , binary ">"   AssocNone  $              flip $ app2 "less"
+          , binary "<="  AssocNone  $ negate_rel $ flip $ app2 "less"
+          , binary ">="  AssocNone  $ negate_rel $        app2 "less"
+          , binary "=="  AssocNone  $                     app2 "equal"
+          , binary "/="  AssocNone  $ negate_rel $        app2 "equal" ]
+        , [ binary "&&"  AssocRight $ bi (NaryOp And) ]
+        , [ binary "||"  AssocRight $ bi (NaryOp Or) ]
+        , [ binary "<|>" AssocRight $ bi Msum ] ]
+
+red_expr :: Parser (Reducer' Text)
+red_expr =  red_fanout
+        <|> red_index
+        <|> red_split
+        <|> red_nop
+        <|> red_add
+
+red_fanout :: Parser (Reducer' Text)
+red_fanout = reserved "r_fanout" *>
+             (R_Fanout
+              <$> red_expr
+              <*  reservedOp "||"
+              <*> red_expr
+              )
+
+red_split :: Parser (Reducer' Text)
+red_split = reserved "r_split" *>
+             (R_Split
+              <$> expr
+              <*  reservedOp ":"
+              <*> red_expr
+              <*  reserved "else"
+              <*  reservedOp ":"
+              <*> red_expr
+              )
+
+red_index :: Parser (Reducer' Text)
+red_index = reserved "r_index" *>
+             (R_Index
+              <$> identifier
+              <*  reservedOp "="
+              <*> expr
+              <*  reserved "of"
+              <*> expr
+              <*  reservedOp ":"
+              <*> red_expr
+              )
+
+red_nop :: Parser (Reducer' Text)
+red_nop = reserved "r_nop" *> return R_Nop
+
+red_add :: Parser (Reducer' Text)
+red_add = reserved "r_add" *> (R_Add <$> expr)
+
+
+natOrProb :: Parser (AST' a)
+natOrProb = (ULiteral <$> decimalFloat) <* whiteSpace
+
+inf_ :: Parser (AST' a)
+inf_ = reserved "∞" *> return Infinity'
+
+var :: Parser (AST' Text)
+var = Var <$> identifier
+
+parenthesized :: Parser (AST' Text)
+parenthesized = f <$> parens (commaSep expr)
+  where f [] = Unit
+        f xs = foldr1 Pair xs
+
+type_var_or_app :: Parser TypeAST'
+type_var_or_app = do x <- ("array" <$ reserved "array") <|> identifier
+                     option (TypeVar x) (TypeApp x <$> parens (commaSep type_expr))
+
+type_expr :: Parser TypeAST'
+type_expr = foldr1 TypeFun <$> sepBy1 (parens type_expr <|> type_var_or_app)
+                                      (reservedOp "->")
+
+ann_expr :: Parser (AST' Text -> AST' Text)
+ann_expr = reservedOp "." *> (flip Ann <$> type_expr)
+
+pdat_expr :: Parser (PDatum Text)
+pdat_expr = DV <$> identifier <*> parens (commaSep pat_expr)
+
+pat_expr :: Parser (Pattern' Text)
+pat_expr =  try (PData' <$> pdat_expr)
+        <|> (PData' <$> (DV "pair" <$> parens (commaSep pat_expr)))
+        <|> (PWild' <$  reservedOp "_")
+        <|> (PVar'  <$> identifier)
+
+
+-- | Blocks are indicated by colons, and must be indented.
+blockOfMany :: Parser a -> Parser [a]
+blockOfMany p = do
+    reservedOp ":"
+    localIndentation Gt (many $ absoluteIndentation p)
+
+
+branch_expr :: Parser (Branch' Text)
+branch_expr = Branch' <$> pat_expr <* reservedOp ":"
+              <*> localIndentation Gt expr
+
+match_expr :: Parser (AST' Text)
+match_expr = Case <$ reserved "match" <*> expr <* reservedOp ":"
+             <*> localIndentation Ge (many (absoluteIndentation branch_expr))
+
+integrate_expr :: Parser (AST' Text)
+integrate_expr =
+    reserved "integrate"
+    *> (Integrate
+        <$> identifier
+        <*  reserved "from"
+        <*> expr
+        <*  reserved "to"
+        <*> expr
+        <*  reservedOp ":"
+        <*> expr
+        )
+
+summate_expr :: Parser (AST' Text)
+summate_expr =
+    reserved "summate"
+    *> (Summate
+        <$> identifier
+        <*  reserved "from"
+        <*> expr
+        <*  reserved "to"
+        <*> expr
+        <*  reservedOp ":"
+        <*> expr
+        )
+
+product_expr :: Parser (AST' Text)
+product_expr =
+    reserved "product"
+    *> (Product
+        <$> identifier
+        <*  reserved "from"
+        <*> expr
+        <*  reserved "to"
+        <*> expr
+        <*  reservedOp ":"
+        <*> expr
+        )
+
+transform_expr :: Parser (AST' Text)
+transform_expr = expect_expr <|> tr
+  where
+     trNm :: Parser Transform'
+     trNm = choice $
+       map (\(Some2 t) -> reserved (transformName t)
+                       *> pure (trFromTyped t))
+           allTransforms
+
+     sarg :: Parser ([Text], AST' Text)
+     sarg = (,)
+       <$> option [] (try (many1 identifier <* reservedOp ":"))
+       <*> expr
+
+     tr :: Parser (AST' Text)
+     tr =  Transform
+       <$> trNm
+       <*> (SArgs' <$> parens (commaSep sarg))
+
+     expect_expr :: Parser (AST' Text)
+     expect_expr =
+         reserved "expect"
+         *> (_Expect
+             <$> identifier
+             <*  reservedOp "<~"
+             <*> expr
+             <*  reservedOp ":"
+             <*> expr
+             )
+
+bucket_expr :: Parser (AST' Text)
+bucket_expr =
+    reserved "bucket"
+    *> (Bucket
+        <$> identifier
+        <*  reserved "from"
+        <*> expr
+        <*  reserved "to"
+        <*> expr
+        <*  reservedOp ":"
+        <*> red_expr
+        )
+
+array_expr :: Parser (AST' Text)
+array_expr =
+    reserved "array"
+    *> (Array
+        <$> identifier
+        <*  reserved "of"
+        <*> expr
+        <*  reservedOp ":"
+        <*> expr
+        )
+
+array_index :: Parser (AST' Text -> AST' Text)
+array_index = flip Index <$> brackets expr
+
+array_literal :: Parser (AST' Text)
+array_literal = ArrayLiteral <$> brackets (commaSep expr)
+
+plate_expr :: Parser (AST' Text)
+plate_expr =
+    reserved "plate"
+    *> (Plate
+        <$> identifier
+        <*  reserved "of"
+        <*> expr
+        <*  reservedOp ":"
+        <*> expr
+        )
+
+chain_expr :: Parser (AST' Text)
+chain_expr =
+    reserved "chain"
+    *> (flip . Chain
+        <$> identifier
+        <*  reserved "from"
+        <*> expr
+        <*  reserved "of"
+        <*> expr
+        <*  reservedOp ":"
+        <*> expr
+        )
+
+
+if_expr :: Parser (AST' Text)
+if_expr = If <$ reserved "if" <*> expr <* reservedOp ":" <*> expr
+             <* reserved "else"        <* reservedOp ":" <*> expr
+
+lam_expr :: Parser (AST' Text)
+lam_expr =
+    reserved "fn"
+    *>  (Lam
+        <$> identifier
+        <*> type_expr
+        <*  reservedOp ":"
+        <*> expr
+        )
+
+bind_expr :: Parser (AST' Text)
+bind_expr = localIndentation Ge
+  (absoluteIndentation (try (Bind <$> identifier <* reservedOp "<~")
+   <*> localIndentation Gt expr)
+   <*> absoluteIndentation expr)
+
+let_expr :: Parser (AST' Text)
+let_expr = localIndentation Ge
+  (absoluteIndentation (try (Let <$> identifier <* reservedOp "=")
+   <*> localIndentation Gt expr)
+   <*> absoluteIndentation expr)
+
+def_expr :: Parser (AST' Text)
+def_expr = localIndentation Ge $ do
+    absoluteIndentation (reserved "def")
+    name <- identifier
+    vars <- parens (commaSep defarg)
+    bodyTyp <- optionMaybe type_expr
+    reservedOp ":"
+    body    <- localIndentation Gt expr
+    let body' = foldr (\(var', varTyp) e -> Lam var' varTyp e) body vars
+        typ   = foldr TypeFun <$> bodyTyp <*> return (map snd vars)
+    Let name (maybe id (flip Ann) typ body')
+        <$> absoluteIndentation expr -- the \"rest\"; i.e., where the 'def' is in scope
+
+defarg :: Parser (Text, TypeAST')
+defarg = (,) <$> identifier <*> type_expr
+
+fun_call :: Parser (AST' Text -> AST' Text)
+fun_call = flip (foldl App) <$> parens (commaSep expr)
+
+return_expr :: Parser (AST' Text)
+return_expr = do
+    reserved "return" <|> reserved "dirac"
+    app1 "dirac" <$> expr
+
+term :: Parser (AST' Text)
+term =  if_expr
+    <|> lam_expr
+    <|> def_expr
+    <|> match_expr
+    <|> data_expr
+    <|> integrate_expr
+    <|> summate_expr
+    <|> product_expr
+    <|> transform_expr
+    <|> bucket_expr
+    <|> array_expr
+    <|> plate_expr
+    <|> chain_expr
+    <|> array_literal
+    <|> inf_
+    <|> natOrProb
+    <|> var
+    <|> parenthesized
+    <?> "simple expression"
+
+expr :: Parser (AST' Text)
+expr = withPos (let_expr <|>
+                bind_expr <|>
+                return_expr <|>
+                buildExpressionParser table (withPos term))
+       <?> "expression"
+
+
+indentConfig :: Text -> ParserStream
+indentConfig =
+    mkIndentStream 0 infIndentation True Ge . mkCharIndentStream
+
+parseHakaru :: Text -> Either ParseError (AST' Text)
+parseHakaru = parseAtTopLevel expr
+
+parseHakaruWithImports :: Text -> Either ParseError (ASTWithImport' Text)
+parseHakaruWithImports = parseAtTopLevel exprWithImport
+
+parseAtTopLevel :: Parser a -> Text -> Either ParseError a
+parseAtTopLevel p =
+    runParser (whiteSpace *>
+               p <* eof) () "<input>" . indentConfig
+
+withPos :: Parser (AST' a) -> Parser (AST' a)
+withPos x = do
+    s  <- getPosition
+    x' <- x
+    e  <- getPosition
+    return $ WithMeta x' (SourceSpan s e)
+
+{-
+user-defined types:
+
+data either(a,b):
+  left(a)
+  right(a)
+
+data maybe(a):
+  nothing
+  just(a)
+-}
+
+data_expr :: Parser (AST' Text)
+data_expr = do
+    reserved "data"
+    ident <- identifier
+    typvars <- parens (commaSep identifier)
+    ts <- blockOfMany type_var_or_app
+    e <- expr
+    return (Data ident typvars ts e)
+
+import_expr :: Parser (Import Text)
+import_expr =
+    reserved "import" *> (Import <$> identifier)
+
+exprWithImport :: Parser (ASTWithImport' Text)
+exprWithImport = ASTWithImport' <$> (many import_expr) <*> expr
+
+-- Parsing bindings for Hakaru Repl
+type Binding = (AST' Text.Text -> AST' Text.Text)
+
+let_parse :: Parser Binding
+let_parse = Let <$> identifier <* reservedOp "=" <*> expr
+
+bind_parse :: Parser Binding
+bind_parse = Bind <$> identifier <* reservedOp "<~" <*> expr
+
+binding_parse :: Parser Binding
+binding_parse = try let_parse <|> bind_parse
+
+bindingOrExpr :: Parser (Either Binding (AST' Text.Text))
+bindingOrExpr = Left <$> try binding_parse <|> Right <$> expr
+
+parseReplLine :: Text.Text -> Either ParseError (Either Binding (AST' Text.Text))
+parseReplLine x = parseAtTopLevel bindingOrExpr x
+
+-- | A variant of @Text.Parsec.Expr.buildExpressionParser@ (parsec-3.1.11)
+-- that behaves more restrictively when a precedence level contains both
+-- unary and binary operators.  Unary operators are only allowed on the
+-- first operand when parsing left-associatively and on the last operand
+-- when parsing right-associatively.  This restriction lets us recover the
+-- behavior of unary negation in Haskell.
+
+buildExpressionParser :: (Stream s m t)
+                      => [[Operator s u m a]]
+                      -> ParsecT s u m a
+                      -> ParsecT s u m a
+buildExpressionParser operators simpleExpr
+    = foldl (makeParser) simpleExpr operators
+    where
+      makeParser term' ops'
+        = let (rassoc,lassoc,nassoc
+               ,prefix,postfix')      = foldr splitOp ([],[],[],[],[]) ops'
+
+              rassocOp   = choice rassoc
+              lassocOp   = choice lassoc
+              nassocOp   = choice nassoc
+              prefixOp   = choice prefix  <?> ""
+              postfixOp  = choice postfix' <?> ""
+
+              ambigious assoc op= try $
+                                  do{ _ <- op
+                                    ; fail ("ambiguous use of a " ++ assoc
+                                            ++ " associative operator")
+                                    }
+
+              ambigiousRight    = ambigious "right" rassocOp
+              ambigiousLeft     = ambigious "left" lassocOp
+              ambigiousNon      = ambigious "non" nassocOp
+
+              termP      = do{ (preU, pre)   <- prefixP
+                             ; x             <- term'
+                             ; (postU, post) <- postfixP
+                             ; return (preU || postU, post (pre x))
+                             }
+
+              postfixP   = ((,) True) <$> postfixOp <|> return (False, id)
+
+              prefixP    = ((,) True) <$> prefixOp <|> return (False, id)
+
+              rassocP x  = do{ f      <- rassocOp
+                             ; (u, z) <- termP
+                             ; y      <- if u then return z else rassocP1 z
+                             ; return (f x y)
+                             }
+                           <|> ambigiousLeft
+                           <|> ambigiousNon
+                           -- <|> return x
+
+              rassocP1 x = rassocP x  <|> return x
+
+              lassocP x  = do{ f <- lassocOp
+                             ; y <- term'
+                             ; lassocP1 (f x y)
+                             }
+                           <|> ambigiousRight
+                           <|> ambigiousNon
+                           -- <|> return x
+
+              lassocP1 x = lassocP x <|> return x
+
+              nassocP x  = do{ f <- nassocOp
+                             ; y <- term'
+                             ;    ambigiousRight
+                              <|> ambigiousLeft
+                              <|> ambigiousNon
+                              <|> return (f x y)
+                             }
+                           -- <|> return x
+
+           in  do{ (u, x) <- termP
+                 ;     (if u then parserZero else rassocP x)
+                   <|>                            lassocP x
+                   <|> (if u then parserZero else nassocP x)
+                   <|>                            return  x
+                   <?> "operator"
+                 }
+
+
+      splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix')
+        = case assoc of
+            AssocNone  -> (rassoc,lassoc,op:nassoc,prefix,postfix')
+            AssocLeft  -> (rassoc,op:lassoc,nassoc,prefix,postfix')
+            AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix')
+
+      splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix')
+        = (rassoc,lassoc,nassoc,op:prefix,postfix')
+
+      splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix')
+        = (rassoc,lassoc,nassoc,prefix,op:postfix')
diff --git a/haskell/Language/Hakaru/Parser/SymbolResolve.hs b/haskell/Language/Hakaru/Parser/SymbolResolve.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Parser/SymbolResolve.hs
@@ -0,0 +1,737 @@
+{-# LANGUAGE CPP
+           , OverloadedStrings
+           , DataKinds
+           , KindSignatures
+           , GADTs
+           , LambdaCase
+           , PolyKinds
+           , RankNTypes
+           #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Language.Hakaru.Parser.SymbolResolve
+    (
+      resolveAST, resolveAST', makeName, fromVarSet
+    ) where
+
+import Data.Text hiding (concat, map, maximum, foldr1, singleton)
+#if __GLASGOW_HASKELL__ < 710
+import Data.Functor                     ((<$>))
+import Control.Applicative              ((<*>))
+#endif
+import Control.Monad.Trans.State.Strict (State, state, evalState)
+import Control.Monad (join)
+
+import qualified Data.Number.Nat                 as N
+import qualified Data.IntMap                     as IM
+import           Data.Foldable                   as F
+import           Data.Ratio
+import           Data.Proxy                      (KProxy(..))
+import           Data.List.NonEmpty              as L (NonEmpty(..), fromList)
+import           Language.Hakaru.Types.Sing
+import           Language.Hakaru.Types.Coercion
+import           Language.Hakaru.Types.DataKind  hiding (Symbol)
+import           Language.Hakaru.Types.HClasses
+import qualified Language.Hakaru.Syntax.AST      as T
+import           Language.Hakaru.Syntax.ABT      hiding (fromVarSet)
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Syntax.Variable ()
+import qualified Language.Hakaru.Parser.AST   as U
+import           Language.Hakaru.Evaluation.Coalesce (coalesce)
+import qualified Language.Hakaru.Syntax.Prelude  as P
+
+data Symbol a
+    = TLam (a -> Symbol a)
+    | TNeu a
+
+data Symbol' a
+    = TLam' ([a] -> a)
+    | TNeu' a
+
+singleton :: a -> L.NonEmpty a
+singleton x = x :| []
+
+primPat :: [(Text, Symbol' U.Pattern)]
+primPat =
+    [ ("left",    TLam' $ \ [a] ->
+        U.PDatum "left" . U.PInl $
+            U.PKonst a `U.PEt` U.PDone)
+    , ("right",   TLam' $ \ [b] ->
+        U.PDatum "right" . U.PInr . U.PInl $
+            U.PKonst b `U.PEt` U.PDone)
+    , ("true",    TNeu' . U.PDatum "true"  . U.PInl $ U.PDone)
+    , ("false",   TNeu' . U.PDatum "false" . U.PInr . U.PInl $ U.PDone)
+    , ("unit",    TNeu' . U.PDatum "unit"  . U.PInl $ U.PDone)
+    , ("pair",    TLam' $ \es -> F.foldr1 pairPat es)
+    , ("just",    TLam' $ \ [a] ->
+        U.PDatum "just" . U.PInr . U.PInl $
+            U.PKonst a `U.PEt` U.PDone)
+    , ("nothing", TLam' $ \ [] ->
+        U.PDatum "nothing" . U.PInl $ U.PDone)
+    ]
+
+pairPat :: U.Pattern -> U.Pattern -> U.Pattern
+pairPat a b =
+    U.PDatum "pair" .  U.PInl $
+    U.PKonst a `U.PEt` U.PKonst b `U.PEt` U.PDone
+
+primTypes :: [(Text, Symbol' U.SSing)]
+primTypes =
+    [ ("nat",     TNeu' $ U.SSing SNat)
+    , ("int",     TNeu' $ U.SSing SInt)
+    , ("prob",    TNeu' $ U.SSing SProb)
+    , ("real",    TNeu' $ U.SSing SReal)
+    , ("unit",    TNeu' $ U.SSing sUnit)
+    , ("bool",    TNeu' $ U.SSing sBool)
+    , ("array",   TLam' $ \ [U.SSing a] -> U.SSing $ SArray a)
+    , ("measure", TLam' $ \ [U.SSing a] -> U.SSing $ SMeasure a)
+    , ("either",  TLam' $ \ [U.SSing a, U.SSing b] -> U.SSing $ sEither a b)
+    , ("pair",    TLam' $ \ [U.SSing a, U.SSing b] -> U.SSing $ sPair a b)
+    , ("maybe",   TLam' $ \ [U.SSing a] -> U.SSing $ sMaybe a)
+    ]
+
+t2 :: (U.AST -> U.AST -> U.AST) -> Symbol U.AST
+t2 f = TLam $ \a -> TLam $ \b -> TNeu (f a b)
+
+t3 :: (U.AST -> U.AST -> U.AST -> U.AST) -> Symbol U.AST
+t3 f = TLam $ \a -> TLam $ \b -> TLam $ \c -> TNeu (f a b c)
+
+type SymbolTable = [(Text, Symbol U.AST)]
+
+primTable :: SymbolTable
+primTable =
+    [-- Datatype constructors
+     ("left",        primLeft)
+    ,("right",       primRight)
+    ,("just",        primJust)
+    ,("nothing",     primNothing)
+    ,("true",        TNeu $ true_)
+    ,("false",       TNeu $ false_)
+     -- Coercions
+    ,("int2nat",     primUnsafe cNat2Int)  -- unsafe, wrong direction
+    ,("int2real",    primCoerce cInt2Real)
+    ,("prob2real",   primCoerce cProb2Real)
+    ,("real2prob",   primUnsafe cProb2Real) -- unsafe, wrong direction
+    ,("nat2real",    primCoerce cNat2Real)
+    ,("nat2prob",    primCoerce cNat2Prob)
+    ,("nat2int",     primCoerce cNat2Int)
+     -- Measures
+    ,("lebesgue",    primMeasure2 (U.SomeOp T.Lebesgue))
+    ,("counting",    TNeu $ syn $ U.MeasureOp_ (U.SomeOp T.Counting) [])
+    ,("uniform",     primMeasure2 (U.SomeOp T.Uniform))
+    ,("normal",      primMeasure2 (U.SomeOp T.Normal))
+    ,("poisson",     primMeasure1 (U.SomeOp T.Poisson))
+    ,("gamma",       primMeasure2 (U.SomeOp T.Gamma))
+    ,("beta",        primMeasure2 (U.SomeOp T.Beta))
+    ,("categorical", primMeasure1 (U.SomeOp T.Categorical))
+    ,("factor",      primFactor)
+    ,("weight",      primWeight)
+    ,("dirac",       TLam $ TNeu . syn . U.Dirac_)
+    ,("reject",      TNeu $ syn U.Reject_)
+    -- PrimOps
+    ,("not",         primPrimOp1 U.Not)
+    ,("impl",        primPrimOp2 U.Impl)
+    ,("diff",        primPrimOp2 U.Diff)
+    ,("nand",        primPrimOp2 U.Nand)
+    ,("nor",         primPrimOp2 U.Nor)
+    ,("pi",          primPrimOp0 U.Pi)
+    ,("**",          primPrimOp2 U.RealPow)
+    ,("choose",      primPrimOp2 U.Choose)
+    ,("cos",         primPrimOp1 U.Cos)
+    ,("exp",         primPrimOp1 U.Exp)
+    ,("log",         primPrimOp1 U.Log)
+    ,("inf",         primPrimOp0 U.Infinity)
+    ,("gammaFunc",   primPrimOp1 U.GammaFunc)
+    ,("betaFunc",    primPrimOp2 U.BetaFunc)
+    ,("equal",       primPrimOp2 U.Equal)
+    ,("less",        primPrimOp2 U.Less)
+    ,("negate",      primPrimOp1 U.Negate)
+    ,("abs",         primPrimOp1 U.Abs)
+    ,("signum",      primPrimOp1 U.Signum)
+    ,("recip",       primPrimOp1 U.Recip)
+    ,("^",           primPrimOp2 U.NatPow)
+    ,("natroot",     primPrimOp2 U.NatRoot)
+    ,("sqrt",        TLam $ \x -> TNeu . syn $ U.PrimOp_ U.NatRoot [x, two])
+    ,("erf",         primPrimOp1 U.Erf)
+    ,("sin",         primPrimOp1 U.Sin)
+    ,("cos",         primPrimOp1 U.Cos)
+    ,("tan",         primPrimOp1 U.Tan)
+    ,("asin",        primPrimOp1 U.Asin)
+    ,("acos",        primPrimOp1 U.Acos)
+    ,("atan",        primPrimOp1 U.Atan)
+    ,("sinh",        primPrimOp1 U.Sinh)
+    ,("cosh",        primPrimOp1 U.Cosh)
+    ,("tanh",        primPrimOp1 U.Tanh)
+    ,("asinh",       primPrimOp1 U.Asinh)
+    ,("acosh",       primPrimOp1 U.Acosh)
+    ,("atanh",       primPrimOp1 U.Atanh)
+    ,("floor",       primPrimOp1 U.Floor)
+    -- ArrayOps
+    ,("size",        TLam $ \x -> TNeu . syn $ U.ArrayOp_ U.Size [x])
+    ,("reduce",      t3 $ \x y z -> syn $ U.ArrayOp_ U.Reduce [x, y, z])
+    -- NaryOps
+    ,("xor",         t2 $ \x y -> syn $ U.NaryOp_ U.Xor [x, y])
+    ,("iff",         t2 $ \x y -> syn $ U.NaryOp_ U.Iff [x, y])
+    ,("min",         t2 $ \x y -> syn $ U.NaryOp_ U.Min [x, y])
+    ,("max",         t2 $ \x y -> syn $ U.NaryOp_ U.Max [x, y])
+
+    -- Macros
+    ,("weibull",     TNeu $ syn $ U.InjTyped $
+                     P.lam $ \x -> P.lam $ \y -> P.weibull x y)
+    ]
+
+primPrimOp0, primPrimOp1, primPrimOp2 :: U.PrimOp -> Symbol U.AST
+primPrimOp0 a = TNeu . syn $ U.PrimOp_ a []
+primPrimOp1 a = TLam $ \x -> TNeu . syn $ U.PrimOp_ a [x]
+primPrimOp2 a = t2 $ \x y ->        syn $ U.PrimOp_ a [x, y]
+
+primMeasure1 :: U.SomeOp T.MeasureOp -> Symbol U.AST
+primMeasure1 m = TLam $ \x -> TNeu . syn $ U.MeasureOp_ m [x]
+
+primMeasure2 :: U.SomeOp T.MeasureOp -> Symbol U.AST
+primMeasure2 m = t2 $ \x y -> syn $ U.MeasureOp_ m [x, y]
+
+primCoerce :: Coercion a b -> Symbol U.AST
+primCoerce c = TLam $ TNeu . syn . U.CoerceTo_  (Some2 c)
+
+primUnsafe :: Coercion a b -> Symbol U.AST
+primUnsafe c = TLam $ TNeu . syn . U.UnsafeTo_  (Some2 c)
+
+cProb2Real :: Coercion 'HProb 'HReal
+cProb2Real = signed
+
+cNat2Prob :: Coercion 'HNat 'HProb
+cNat2Prob = continuous
+
+cNat2Int  :: Coercion 'HNat 'HInt
+cNat2Int  = signed
+
+cInt2Real  :: Coercion 'HInt 'HReal
+cInt2Real  = continuous
+
+cNat2Real :: Coercion 'HNat 'HReal
+cNat2Real = CCons (Signed HRing_Int) continuous
+
+unit_ :: U.AST
+unit_ =
+    syn $ U.Ann_ (U.SSing sUnit)
+                 (syn $ U.Datum_ (U.Datum "unit" . U.Inl $ U.Done))
+
+true_, false_ :: U.AST
+true_  =
+    syn $ U.Ann_ (U.SSing sBool)
+                 (syn $ U.Datum_ . U.Datum "true"  . U.Inl $ U.Done)
+
+false_ =
+    syn $ U.Ann_ (U.SSing sBool)
+                 (syn $ U.Datum_ . U.Datum "false" . U.Inr . U.Inl $ U.Done)
+
+unsafeFrom_ :: U.AST -> U.AST
+unsafeFrom_ = syn . U.UnsafeTo_ (Some2 $ CCons (Signed HRing_Real) CNil)
+
+primLeft, primRight :: Symbol U.AST
+primLeft =
+    TLam $ TNeu . syn . U.Datum_ .
+        U.Datum "left" . U.Inl . (`U.Et` U.Done) . U.Konst
+primRight =
+    TLam $ TNeu . syn . U.Datum_ .
+        U.Datum "right" . U.Inr . U.Inl . (`U.Et` U.Done) . U.Konst
+
+primJust, primNothing :: Symbol U.AST
+primJust =
+    TLam $ TNeu . syn . U.Datum_ .
+        U.Datum "just" . U.Inr . U.Inl . (`U.Et` U.Done) . U.Konst
+primNothing =
+    TNeu . syn . U.Datum_ .
+        U.Datum "nothing" . U.Inl $ U.Done
+
+primWeight, primFactor :: Symbol U.AST
+primWeight = t2 $ \w m -> syn $ U.Superpose_ (singleton (w, m))
+primFactor = TLam $ \w -> TNeu . syn . U.Superpose_ $
+              singleton (w, syn $ U.Dirac_ unit_)
+
+two :: U.AST
+two = syn . U.Literal_ . U.val . U.Nat $ 2
+
+gensym :: Text -> State Int U.Name
+gensym s = state $ \i -> (U.Name (N.unsafeNat i) s, i + 1)
+
+mkSym  :: U.Name -> Symbol U.AST
+mkSym (U.Name i t) = TNeu $ var (Variable t i U.SU)
+
+insertSymbol :: U.Name -> SymbolTable -> SymbolTable
+insertSymbol n@(U.Name _ name) sym = (name, mkSym n) : sym
+
+insertSymbols :: [U.Name] -> SymbolTable -> SymbolTable
+insertSymbols []     sym = sym
+insertSymbols (n:ns) sym = insertSymbols ns (insertSymbol n sym)
+
+
+resolveBinder
+    :: SymbolTable
+    -> Text
+    -> U.AST' Text
+    -> U.AST' Text
+    -> (Symbol U.AST
+        -> U.AST' (Symbol U.AST)
+        -> U.AST' (Symbol U.AST)
+        -> U.AST' (Symbol U.AST))
+    -> State Int (U.AST' (Symbol U.AST))
+resolveBinder symbols name e1 e2 f = do
+    name' <- gensym name
+    f (mkSym name')
+        <$> symbolResolution symbols e1
+        <*> symbolResolution (insertSymbol name' symbols) e2
+
+resolveTransform
+    :: SymbolTable
+    -> U.Transform'
+    -> U.SArgs' Text
+    -> State Int (U.AST' (Symbol U.AST))
+resolveTransform symbols tr (U.SArgs' es) =
+    U.Transform tr . U.SArgs' <$> mapM go es where
+      go :: ([Text], U.AST' Text)
+         -> State Int ([Symbol U.AST], U.AST' (Symbol U.AST))
+      go (nms,x) = do
+        nms' <- mapM gensym nms
+        (,) (map mkSym nms') <$>
+            symbolResolution (insertSymbols nms' symbols) x
+
+-- TODO: clean up by merging the @Reader (SymbolTable)@ and @State Int@ monads
+-- | Figure out symbols and types.
+symbolResolution
+    :: SymbolTable
+    -> U.AST' Text
+    -> State Int (U.AST' (Symbol U.AST))
+symbolResolution symbols ast =
+    case ast of
+    U.Var name ->
+        case lookup name symbols of
+        Nothing -> (U.Var . mkSym) <$> gensym name
+        Just a  -> return $ U.Var a
+
+    U.Lam name typ x -> do
+        name' <- gensym name
+        U.Lam (mkSym name') typ
+            <$> symbolResolution (insertSymbol name' symbols) x
+
+    U.App f x -> U.App
+        <$> symbolResolution symbols f
+        <*> symbolResolution symbols x
+
+    U.Let name e1 e2    -> resolveBinder symbols name e1 e2 U.Let
+    U.If e1 e2 e3       -> U.If
+        <$> symbolResolution symbols e1
+        <*> symbolResolution symbols e2
+        <*> symbolResolution symbols e3
+
+    U.Ann e typ         -> (`U.Ann` typ) <$> symbolResolution symbols e
+    U.Infinity'         -> return $ U.Infinity'
+    U.ULiteral v        -> return $ U.ULiteral v
+
+    U.Integrate  name e1 e2 e3 -> do
+        name' <- gensym name
+        U.Integrate (mkSym name')
+            <$> symbolResolution symbols e1
+            <*> symbolResolution symbols e2
+            <*> symbolResolution (insertSymbol name' symbols) e3
+
+    U.Summate    name e1 e2 e3 -> do
+        name' <- gensym name
+        U.Summate (mkSym name')
+            <$> symbolResolution symbols e1
+            <*> symbolResolution symbols e2
+            <*> symbolResolution (insertSymbol name' symbols) e3
+
+    U.Product    name e1 e2 e3 -> do
+        name' <- gensym name
+        U.Product (mkSym name')
+            <$> symbolResolution symbols e1
+            <*> symbolResolution symbols e2
+            <*> symbolResolution (insertSymbol name' symbols) e3
+
+    U.Bucket     name e1 e2 e3 -> do
+        name' <- gensym name
+        U.Bucket (mkSym name')
+            <$> symbolResolution symbols e1
+            <*> symbolResolution symbols e2
+            <*> symbolResolutionReducer (insertSymbol name' symbols) e3
+
+    U.NaryOp op es      -> U.NaryOp op
+        <$> mapM (symbolResolution symbols) es
+
+    U.Unit              -> return $ U.Unit
+    U.Pair e1 e2        -> U.Pair
+        <$> symbolResolution symbols e1
+        <*> symbolResolution symbols e2
+
+    U.Array name e1 e2  -> resolveBinder symbols name e1 e2 U.Array
+
+    U.ArrayLiteral es   -> U.ArrayLiteral <$> mapM (symbolResolution symbols) es
+
+    U.Index a i -> U.Index
+        <$> symbolResolution symbols a
+        <*> symbolResolution symbols i
+
+    U.Case e1 bs -> U.Case
+        <$> symbolResolution symbols e1
+        <*> mapM (symbolResolveBranch symbols) bs
+
+    U.Bind   name e1 e2    -> resolveBinder symbols name e1 e2 U.Bind
+    U.Plate  name e1 e2    -> resolveBinder symbols name e1 e2 U.Plate
+    U.Transform tr es      -> resolveTransform symbols tr es
+    U.Chain  name e1 e2 e3 -> do
+        name' <- gensym name
+        U.Chain (mkSym name')
+            <$> symbolResolution symbols e1
+            <*> symbolResolution symbols e2
+            <*> symbolResolution (insertSymbol name' symbols) e3
+
+    U.Msum es -> U.Msum <$> mapM (symbolResolution symbols) es
+
+    U.Data name tvars typ e -> error $ ("TODO: symbolResolution{U.Data} " ++
+                                        show name  ++ " with " ++
+                                        show tvars ++ ":" ++ show typ)
+    U.WithMeta a meta -> U.WithMeta
+        <$> symbolResolution symbols a
+        <*> return meta
+
+symbolResolutionReducer
+    :: SymbolTable
+    -> U.Reducer' Text
+    -> State Int (U.Reducer' (Symbol U.AST))
+symbolResolutionReducer symbols ast =
+    case ast of
+    U.R_Fanout e1 e2        -> U.R_Fanout
+                               <$> symbolResolutionReducer symbols e1
+                               <*> symbolResolutionReducer symbols e2
+
+    U.R_Index name e1 e2 e3 -> do
+      name' <- gensym name
+      U.R_Index (mkSym name')
+           <$> symbolResolution symbols e1
+           <*> symbolResolution symbols e2
+           <*> symbolResolutionReducer (insertSymbol name' symbols) e3
+    U.R_Split e1 e2 e3      -> U.R_Split
+                               <$> symbolResolution symbols e1
+                               <*> symbolResolutionReducer symbols e2
+                               <*> symbolResolutionReducer symbols e3
+    U.R_Nop                 -> return U.R_Nop
+    U.R_Add   e1            -> U.R_Add <$> symbolResolution symbols e1
+
+
+symbolResolveBranch
+    :: SymbolTable
+    -> U.Branch' Text
+    -> State Int (U.Branch' (Symbol U.AST))
+symbolResolveBranch symbols (U.Branch' pat ast) = do
+    (pat', names) <- symbolResolvePat pat
+    ast' <- symbolResolution (insertSymbols names symbols) ast
+    return $ U.Branch'' pat' ast'
+symbolResolveBranch _ _ =
+    error "TODO: symbolResolveBranch{U.Branch''}"
+
+
+symbolResolvePat
+    :: U.Pattern' Text
+    -> State Int (U.Pattern' U.Name, [U.Name])
+symbolResolvePat (U.PVar' "true") =
+    return (U.PData' (U.DV "true" []), [])
+symbolResolvePat (U.PVar' "false") =
+    return (U.PData' (U.DV "false" []), [])
+symbolResolvePat (U.PVar' name)  = do
+    name' <- gensym name
+    return (U.PVar' name', [name'])
+symbolResolvePat U.PWild' =
+    return (U.PWild', [])
+symbolResolvePat (U.PData' (U.DV name args)) = do
+    args' <- mapM symbolResolvePat args
+    let (args'', names) = unzip args'
+    return $ (U.PData' (U.DV name args''), F.concat names)
+
+
+-- | Make AST and give unique names for variables.
+--
+-- The logic here is to do normalization by evaluation for our
+-- primitives. App inspects its first argument to see if it should
+-- do something special. Otherwise App behaves as normal.
+normAST :: U.AST' (Symbol U.AST) -> U.AST' (Symbol U.AST)
+normAST ast =
+    case ast of
+    U.Var a           -> U.Var a
+    U.Lam name typ f  -> U.Lam name typ (normAST f)
+    U.App f x ->
+        let x' = normAST x
+            f' = normAST f in
+        case U.withoutMeta f' of
+        U.Var (TLam f)      -> U.Var $ f (makeAST x')
+        _                   -> U.App f' x'
+
+    U.Let name e1 e2          -> U.Let name (normAST e1) (normAST e2)
+    U.If e1 e2 e3             -> U.If (normAST e1) (normAST e2) (normAST e3)
+    U.Ann e typ1              -> U.Ann (normAST e) typ1
+    U.Infinity'               -> U.Infinity'
+    U.Integrate name e1 e2 e3 -> U.Integrate name (normAST e1) (normAST e2) (normAST e3)
+    U.Summate   name e1 e2 e3 -> U.Summate   name (normAST e1) (normAST e2) (normAST e3)
+    U.Product   name e1 e2 e3 -> U.Product   name (normAST e1) (normAST e2) (normAST e3)
+    U.Bucket    name e1 e2 e3 -> U.Bucket    name (normAST e1) (normAST e2) (redNorm e3)
+    U.ULiteral v              -> U.ULiteral v
+    U.NaryOp op es            -> U.NaryOp op (map normAST es)
+    U.Unit                    -> U.Unit
+    U.Pair e1 e2              -> U.Pair (normAST e1) (normAST e2)
+    U.Array  name e1 e2       -> U.Array name (normAST e1) (normAST e2)
+    U.ArrayLiteral   es       -> U.ArrayLiteral (map normAST es)
+    U.Index       e1 e2       -> U.Index (normAST e1) (normAST e2)
+    U.Case        e1 e2       -> U.Case  (normAST e1) (map branchNorm e2)
+    U.Bind   name e1 e2       -> U.Bind   name (normAST e1) (normAST e2)
+    U.Plate  name e1 e2       -> U.Plate  name (normAST e1) (normAST e2)
+    U.Chain  name e1 e2 e3    -> U.Chain  name (normAST e1) (normAST e2) (normAST e3)
+    U.Transform tr es         -> U.Transform tr (normSArgs es)
+    U.Msum es                 -> U.Msum (map normAST es)
+    U.Data name tvars typs e  -> U.Data name tvars typs e
+     -- do we need to norm here? what if we try to define `true` which is already a constructor
+    U.WithMeta a meta         -> U.WithMeta (normAST a) meta
+
+normSArgs :: U.SArgs' (Symbol U.AST) -> U.SArgs' (Symbol U.AST)
+normSArgs (U.SArgs' es) = U.SArgs' $ map (fmap normAST) es
+
+branchNorm :: U.Branch' (Symbol U.AST) -> U.Branch' (Symbol U.AST)
+branchNorm (U.Branch'  pat e2') = U.Branch'  pat (normAST e2')
+branchNorm (U.Branch'' pat e2') = U.Branch'' pat (normAST e2')
+
+redNorm :: U.Reducer' (Symbol U.AST) -> U.Reducer' (Symbol U.AST)
+redNorm ast =
+    case ast of
+     U.R_Fanout e1 e2         ->
+         U.R_Fanout (redNorm e1) (redNorm e2)
+     U.R_Index  name e1 e2 e3 ->
+         U.R_Index name (normAST e1) (normAST e2) (redNorm e3)
+     U.R_Split e1 e2 e3       ->
+         U.R_Split (normAST e1) (redNorm e2) (redNorm e3)
+     U.R_Nop                  -> U.R_Nop
+     U.R_Add   e1             -> U.R_Add (normAST e1)
+
+collapseSuperposes :: [U.AST] -> U.AST
+collapseSuperposes es = syn $ U.Superpose_ (fromList $ F.concatMap go es)
+    where
+    go :: U.AST -> [(U.AST, U.AST)]
+    go e = caseVarSyn e (\x -> [(prob_ 1, var x)]) $ \t ->
+              case t of
+              U.Superpose_ es' -> F.toList es'
+              _                -> [(prob_ 1, e)]
+
+    prob_ :: Ratio Integer -> U.AST
+    prob_ = syn . U.Literal_ . U.val . U.Prob
+
+makeType :: U.TypeAST' -> U.SSing
+makeType (U.TypeVar t) =
+    case lookup t primTypes of
+    Just (TNeu' t') -> t'
+    _               -> error $ "Type " ++ show t ++ " is not a primitive"
+makeType (U.TypeFun f x) =
+    case (makeType f, makeType x) of
+    (U.SSing f', U.SSing x') -> U.SSing $ SFun f' x'
+makeType (U.TypeApp f args) =
+    case lookup f primTypes of
+    Just (TLam' f') -> f' (map makeType args)
+    _               -> error $ "Type " ++ show f ++ " is not a primitive"
+
+
+makePattern :: U.Pattern' U.Name -> U.Pattern
+makePattern U.PWild'        = U.PWild
+makePattern (U.PVar' name)  =
+    case lookup (U.hintID name) primPat of
+    Just (TLam' _)  -> error "TODO{makePattern:PVar:TLam}"
+    Just (TNeu' p') -> p'
+    Nothing         -> U.PVar name
+makePattern (U.PData' (U.DV name args)) =
+    case lookup name primPat of
+    Just (TLam' f') -> f' (map makePattern args)
+    Just (TNeu' p') -> p'
+    Nothing -> error $ "Data constructor " ++ show name ++ " not found"
+
+makeBranch :: U.Branch' (Symbol U.AST) -> U.Branch
+makeBranch (U.Branch'' pat ast) = U.Branch_ (makePattern pat) (makeAST ast)
+makeBranch (U.Branch'  _   _)   = error "branch was not symbol resolved"
+
+makeTrue, makeFalse :: U.AST' (Symbol U.AST) -> U.Branch
+makeTrue  e =
+    U.Branch_ (makePattern (U.PData' (U.DV "true"  []))) (makeAST e)
+makeFalse e =
+    U.Branch_ (makePattern (U.PData' (U.DV "false" []))) (makeAST e)
+
+makeReducerAST
+    :: Variable 'U.U
+    -> U.Reducer' (Symbol U.AST)
+    -> List1 Variable xs
+    -> U.Reducer xs U.U_ABT 'U.U
+makeReducerAST i r1 bs =
+    case r1 of
+    U.R_Fanout r2 r3       -> U.R_Fanout_
+                              (makeReducerAST i r2 bs)
+                              (makeReducerAST i r3 bs)
+    U.R_Index  b  e1 e2 r1 -> withName "U.R_Index" b $ \b' ->
+                                U.R_Index_
+                                b' -- HACK: This shouldn't be needed here
+                                (binds_ bs (makeAST e1))
+                                (bind i (binds_ bs (makeAST e2)))
+                                (makeReducerAST i r1 (Cons1 b' bs))
+    U.R_Split  e1 r2 r3    -> U.R_Split_
+                              (bind i (binds_ bs (makeAST e1)))
+                              (makeReducerAST i r2 bs)
+                              (makeReducerAST i r3 bs)
+    U.R_Nop                -> U.R_Nop_
+    U.R_Add e1             -> U.R_Add_ (bind i (binds_ bs (makeAST e1)))
+
+makeAST :: U.AST' (Symbol U.AST) -> U.AST
+makeAST ast =
+    case ast of
+    -- TODO: Add to Symbol datatype: gensymed names and types
+    -- for primitives (type for arg on lam, return type in neu)
+    U.Var (TLam _) ->
+        error "makeAST: Passed primitive with wrong number of arguments"
+    U.Var (TNeu e) -> e
+    U.Lam s typ e1 ->
+        withName "U.Lam" s $ \name ->
+            syn $ U.Lam_ (makeType typ) (bind name $ makeAST e1)
+    U.App e1 e2 ->
+        syn $ U.App_ (makeAST e1) (makeAST e2)
+    U.Let s e1 e2 ->
+        withName "U.Let" s $ \name ->
+            syn $ U.Let_ (makeAST e1) (bind name $ makeAST e2)
+    U.If e1 e2 e3 ->
+        syn $ U.Case_ (makeAST e1) [(makeTrue e2), (makeFalse e3)]
+    U.Ann e typ       -> syn $ U.Ann_ (makeType typ) (makeAST e)
+    U.Infinity'       -> syn $ U.PrimOp_ U.Infinity []
+    U.ULiteral v      -> syn $ U.Literal_  (U.val v)
+    U.NaryOp op es    -> syn $ U.NaryOp_ op (map makeAST es)
+    U.Unit            -> unit_
+    U.Pair e1 e2      -> syn $ U.Pair_ (makeAST e1) (makeAST e2)
+    U.Array s e1 e2 ->
+        withName "U.Array" s $ \name ->
+            syn $ U.Array_ (makeAST e1) (bind name $ makeAST e2)
+    U.ArrayLiteral es -> syn $ U.ArrayLiteral_ (map makeAST es)
+    U.Index e1 e2     -> syn $ U.ArrayOp_ U.Index_ [(makeAST e1), (makeAST e2)]
+    U.Case e bs       -> syn $ U.Case_ (makeAST e) (map makeBranch bs)
+    U.Bind s e1 e2 ->
+        withName "U.Bind" s $ \name ->
+            syn $ U.MBind_ (makeAST e1) (bind name $ makeAST e2)
+    U.Plate s e1 e2 ->
+        withName "U.Plate" s $ \name ->
+            syn $ U.Plate_ (makeAST e1) (bind name $ makeAST e2)
+    U.Chain s e1 e2 e3 ->
+        withName "U.Chain" s $ \name ->
+            syn $ U.Chain_ (makeAST e1) (makeAST e2) (bind name $ makeAST e3)
+    U.Integrate s e1 e2 e3 ->
+        withName "U.Integrate" s $ \name ->
+            syn $ U.Integrate_ (makeAST e1) (makeAST e2) (bind name $ makeAST e3)
+    U.Summate s e1 e2 e3 ->
+        withName "U.Summate" s $ \name ->
+            syn $ U.Summate_ (makeAST e1) (makeAST e2) (bind name $ makeAST e3)
+    U.Product s e1 e2 e3 ->
+        withName "U.Product" s $ \name ->
+            syn $ U.Product_ (makeAST e1) (makeAST e2) (bind name $ makeAST e3)
+    U.Bucket s e1 e2 e3 ->
+        withName "U.Bucket"  s $ \name ->
+            syn $ U.Bucket_ (makeAST e1) (makeAST e2) (makeReducerAST name e3 Nil1)
+    U.Transform tr es -> makeTransform tr es
+    U.Msum es -> collapseSuperposes (map makeAST es)
+    U.Data name tvars typs e -> error "TODO: makeAST{U.Data}" 
+    U.WithMeta a meta -> withMetadata meta (makeAST a)
+
+makeTransform :: U.Transform' -> U.SArgs' (Symbol U.AST) -> U.AST
+makeTransform tru esu =
+  case typedTransform tru of
+    Some2 tr ->
+      let wrongArgsErr = error $ "Wrong number of arguments passed to " ++
+                                 T.transformName tr
+          res = U.Transform_ tr <$> matchSArgs (transformArgs tr) esu
+      in maybe wrongArgsErr syn res
+
+type SVarsSpine = (List1 (Lift1 ()) :: [k] -> *)
+type SArgsSpine = (List1 (PointwiseP SVarsSpine (Lift1 ())) :: [([k],k1)] -> *)
+
+transformArgs :: T.Transform xs a -> SArgsSpine xs
+transformArgs t =
+  let arg0 = PwP Nil1 (Lift1 ())
+      arg1 = PwP (Cons1 (Lift1 ()) Nil1) (Lift1 ())
+  in case t of
+     -- TODO: can SingI be generalized to allow things which aren't `Sing's
+     -- so these right hand sides can become `sing'?
+       T.Observe   -> Cons1 arg0 $ Cons1 arg0 Nil1
+       T.MH        -> Cons1 arg0 $ Cons1 arg0 Nil1
+       T.MCMC      -> Cons1 arg0 $ Cons1 arg0 Nil1
+       T.Disint k  -> Cons1 arg0 Nil1
+       T.Summarize -> Cons1 arg0 Nil1
+       T.Simplify  -> Cons1 arg0 Nil1
+       T.Reparam   -> Cons1 arg0 Nil1
+       T.Expect    -> Cons1 arg0 $ Cons1 arg1 Nil1
+
+matchSArgs :: SArgsSpine xs -> U.SArgs' (Symbol U.AST)
+           -> Maybe (U.SArgs U.U_ABT xs)
+matchSArgs sp (U.SArgs' es) =
+  case (sp, es) of
+    ( Nil1, [] ) -> Just U.End
+    ( Cons1 (PwP vs _) sp', (vs',e0):es' )
+      -> join $ matchSVars vs vs' e0 $ \vsu e0' ->
+           (U.:*) (vsu, e0') <$> matchSArgs sp' (U.SArgs' es')
+    _ -> Nothing
+
+matchSVars :: SVarsSpine vs -> [Symbol U.AST] -> U.AST' (Symbol U.AST)
+           -> (forall vsu . List2 U.ToUntyped vs vsu
+                         -> U.U_ABT vsu 'U.U
+                         -> r)
+           -> Maybe r
+matchSVars vs nms e k =
+  case (vs, nms) of
+    (Nil1       , []     ) -> Just $ k Nil2 (makeAST e)
+    (Cons1 v vs', nm:nms') ->
+      matchSVars vs' nms' e $ \vsu e' ->
+        withName "U.SArgs" nm $ \nm' ->
+          k (Cons2 U.ToU vsu) (bind nm' e')
+    _ -> Nothing
+
+typedTransform :: U.Transform' -> Some2 T.Transform
+typedTransform = \case
+  U.Observe   -> Some2 T.Observe
+  U.MH        -> Some2 T.MH
+  U.MCMC      -> Some2 T.MCMC
+  U.Disint k  -> Some2 $ T.Disint k
+  U.Summarize -> Some2 T.Summarize
+  U.Simplify  -> Some2 T.Simplify
+  U.Reparam   -> Some2 T.Reparam
+  U.Expect    -> Some2 T.Expect
+
+withName :: String -> Symbol U.AST -> (Variable 'U.U -> r) -> r
+withName fun s k =
+    case s of
+    TNeu e -> caseVarSyn e k (error $ "makeAST: bad " ++ fun)
+    _      -> error $ "makeAST: bad " ++ fun
+
+resolveAST :: U.AST' Text -> U.AST
+resolveAST ast =
+    coalesce .
+    makeAST  .
+    normAST $
+    evalState (symbolResolution primTable ast) 0
+
+resolveAST'
+    :: N.Nat
+    -> [U.Name]
+    -> U.AST' Text
+    -> U.AST
+resolveAST' nextVar syms ast =
+    coalesce .
+    makeAST  .
+    normAST  $
+    evalState (symbolResolution
+        (insertSymbols syms primTable) ast)
+        (N.fromNat $ nextVarID_ syms)
+    where
+    nextVarID_ [] = nextVar
+    nextVarID_ xs = max nextVar . (1+) . F.maximum $ map U.nameID xs
+
+makeName :: SomeVariable ('KProxy :: KProxy Hakaru) -> U.Name
+makeName (SomeVariable (Variable hint vID _)) = U.Name vID hint
+
+fromVarSet :: VarSet ('KProxy :: KProxy Hakaru) -> [U.Name]
+fromVarSet (VarSet xs) = map makeName (IM.elems xs)
diff --git a/haskell/Language/Hakaru/Pretty/Concrete.hs b/haskell/Language/Hakaru/Pretty/Concrete.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Pretty/Concrete.hs
@@ -0,0 +1,706 @@
+{-# LANGUAGE GADTs
+           , KindSignatures
+           , DataKinds
+           , ScopedTypeVariables
+           , PatternGuards
+           , Rank2Types
+           , TypeOperators
+           , FlexibleContexts
+           , UndecidableInstances
+           , LambdaCase
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.28
+-- |
+-- Module      :  Language.Hakaru.Pretty.Concrete
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--
+----------------------------------------------------------------
+module Language.Hakaru.Pretty.Concrete
+    (
+    -- * The user-facing API
+      pretty
+    , prettyPrec
+    , prettyType
+    , prettyValue
+    , prettyT
+    , prettyTypeT, prettyTypeS
+    -- * Helper functions (semi-public internal API)
+    ) where
+
+import           Prelude            hiding ((<>))
+import           Text.PrettyPrint      (Doc, text, integer, double,
+                                        (<+>), (<>), ($$), sep, cat, fsep, vcat,
+                                        nest, parens, brackets, punctuate,
+                                        comma, colon, equals)
+import qualified Data.Foldable         as F
+import qualified Data.List.NonEmpty    as L
+import qualified Data.Text             as Text
+
+-- Because older versions of "Data.Foldable" do not export 'null' apparently...
+import qualified Data.Sequence         as Seq
+import qualified Data.Vector           as V
+import           Data.Ratio
+import qualified Data.Text             as T
+import           Control.Applicative   (Applicative(..))
+
+import           Data.Number.Natural   (fromNatural, fromNonNegativeRational)
+import           Data.Number.Nat
+import qualified Data.Number.LogFloat  as LF
+
+import Language.Hakaru.Syntax.IClasses (fmap11, foldMap11, jmEq1, TypeEq(..)
+                                       ,Foldable21(..))
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.Value
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Pretty.Haskell (Associativity(..))
+
+----------------------------------------------------------------
+-- | Pretty-print a term.
+pretty :: (ABT Term abt) => abt '[] a -> Doc
+pretty = prettyPrec 0
+
+-- | Pretty print a term as a Text
+prettyT :: (ABT Term abt) => abt '[] a -> T.Text
+prettyT = T.pack . show . pretty
+
+-- | Pretty-print a type as a Text
+prettyTypeT :: Sing (a :: Hakaru) -> T.Text
+prettyTypeT = T.pack . show . prettyType 0
+
+-- | Pretty-print a type as a String
+prettyTypeS :: Sing (a :: Hakaru) -> String
+prettyTypeS = show . prettyType 0
+
+-- | Pretty-print a term at a given precendence level.
+prettyPrec :: (ABT Term abt) => Int -> abt '[] a -> Doc
+prettyPrec p = prettyPrec_ p . LC_
+
+----------------------------------------------------------------
+class Pretty (f :: Hakaru -> *) where
+    -- | A polymorphic variant if 'prettyPrec', for internal use.
+    prettyPrec_ :: Int -> f a -> Doc
+
+mapInit :: (a -> a) -> [a] -> [a]
+mapInit f (x:xs@(_:_)) = f x : mapInit f xs
+mapInit _ xs           = xs
+
+sepByR :: String -> [Doc] -> Doc
+sepByR s = sep . mapInit (<+> text s)
+
+sepComma :: [Doc] -> Doc
+sepComma = fsep . punctuate comma
+    -- It's safe to use fsep here despite our indentation-sensitive syntax,
+    -- because commas are not a binary operator.
+
+parensIf :: Bool -> Doc -> Doc
+parensIf False = id
+parensIf True  = parens
+
+-- | Pretty-print a variable.
+ppVariable :: Variable (a :: Hakaru) -> Doc
+ppVariable x
+    | Text.null (varHint x) = text ('x' : show (fromNat (varID x))) -- We used to use '_' but...
+    | otherwise             = text (Text.unpack (varHint x))
+
+ppBinder :: (ABT Term abt) => abt xs a -> ([Doc], Doc)
+ppBinder e = go [] (viewABT e)
+    where
+    go :: (ABT Term abt) => [Doc] -> View (Term abt) xs a -> ([Doc], Doc)
+    go xs (Bind x v) = go (ppVariable x : xs) v
+    go xs (Var  x)   = (reverse xs, ppVariable x)
+    go xs (Syn  t)   = (reverse xs, pretty (syn t))
+
+ppBinderAsFun :: forall abt xs a . ABT Term abt => abt xs a -> Doc
+ppBinderAsFun e =
+  let (vars, body) = ppBinder e in
+  if null vars then body else sep [fsep vars <> colon, body]
+
+ppBinder1 :: (ABT Term abt) => abt '[x] a -> (Doc, Doc, Doc)
+ppBinder1 e = caseBind e $ \x v ->
+              (ppVariable x,
+               prettyType 0 (varType x),
+               caseVarSyn v ppVariable (pretty . syn))
+
+-- TODO: since switching to ABT2, this instance requires -XFlexibleContexts; we should fix that if we can
+-- BUG: since switching to ABT2, this instance requires -XUndecidableInstances; must be fixed!
+instance (ABT Term abt) => Pretty (LC_ abt) where
+  prettyPrec_ p (LC_ e) =
+    caseVarSyn e ppVariable $ \t ->
+        case t of
+        o :$ es      -> ppSCon p o es
+        NaryOp_ o es ->
+            if Seq.null es then identityElement o
+            else
+                case o of
+                  And    -> asOp 3 "&&" es
+                  Or     -> asOp 2 "||" es
+                  Xor    -> asFun "xor" es
+                  Iff    -> asFun "iff" es
+                  Min  _ -> asFun "min" es
+                  Max  _ -> asFun "max" es
+
+                  Sum  _ -> case F.toList es of
+                    [e1] -> prettyPrec p e1
+                    e1:es' -> parensIf (p > 6) $ sep $
+                              prettyPrec 6 e1 :
+                              map ppNaryOpSum es'
+
+                  Prod _ -> case F.toList es of
+                    [e1] -> prettyPrec p e1
+                    e1:e2:es' -> parensIf (p > 7) $ sep $
+                                 d1' :
+                                 ppNaryOpProd second e2 :
+                                 map (ppNaryOpProd False) es'
+                      where d1 = prettyPrec 7 e1
+                            (d1', second) =
+                              caseVarSyn e1 (const (d1,False)) (\t -> case t of
+                                -- Use parens to distinguish division into 1
+                                -- from recip
+                                Literal_ (LNat 1) -> (parens d1, False)
+                                Literal_ (LNat _) -> (d1, True)
+                                _                 -> (d1, False))
+
+          where identityElement :: NaryOp a -> Doc
+                identityElement And      = text "true"
+                identityElement Or       = text "false"
+                identityElement Xor      = text "false"
+                identityElement Iff      = text "true"
+                identityElement (Min  _) = error "min cannot be used with no arguments"
+                identityElement (Max  _) = error "max cannot be used with no arguments"
+                identityElement (Sum  _) = text "0"
+                identityElement (Prod _) = text "1"
+
+                asOp :: (ABT Term abt)
+                     => Int -> String -> Seq.Seq (abt '[] a) -> Doc
+                asOp p0 s = parensIf (p > p0)
+                          . sepByR s
+                          . map (prettyPrec (p0 + 1))
+                          . F.toList
+
+                asFun :: (ABT Term abt)
+                      => String -> Seq.Seq (abt '[] a) -> Doc
+                asFun   s = ($ p)
+                          . F.foldr1 (\a b p' -> ppFun p' s [a, b])
+                          . fmap (flip prettyPrec)
+
+        Literal_ v    -> prettyPrec_ p v
+        Empty_   typ  -> parensIf (p > 5) (text "[]." <+> prettyType 0 typ)
+        Array_ e1 e2  -> parensIf (p > 0) $
+            let (var, _, body) = ppBinder1 e2 in
+            sep [ sep [ text "array" <+> var
+                      , text "of" <+> pretty e1 <> colon ]
+                , body ]
+
+        ArrayLiteral_ es -> ppList $ map pretty es
+
+        Datum_ d      -> prettyPrec_ p (fmap11 LC_ d)
+        Case_  e1 [Branch (PDatum h2 _) e2, Branch (PDatum h3 _) e3]
+            | "true"  <- Text.unpack h2
+            , "false" <- Text.unpack h3
+            , ([], body2) <- ppBinder e2
+            , ([], body3) <- ppBinder e3
+            -> parensIf (p > 0) $
+               sep [ sep [ text "if" <+> pretty e1 <> colon, nest 2 body2 ]
+                   , sep [ text "else" <> colon, nest 2 body3 ] ]
+        Case_  e1 bs  -> parensIf (p > 0) $
+            sep [ text "match" <+> pretty e1 <> colon
+                , vcat (map (prettyPrec_ 0) bs) ]
+        Superpose_ pes -> case L.toList pes of
+                            [wm] -> ppWeight p wm
+                            wms  -> parensIf (p > 1)
+                                  . sepByR "<|>"
+                                  $ map (ppWeight 2) wms
+          where ppWeight p (w,m)
+                    | Syn (Literal_ (LProb 1)) <- viewABT w
+                    = prettyPrec p m
+                    | otherwise
+                    = ppApply2 p "weight" w m
+
+        Reject_ typ -> parensIf (p > 5) (text "reject." <+> prettyType 0 typ)
+
+        Bucket lo hi red -> ppFun p "rbucket"
+                            [ flip prettyPrec lo, flip prettyPrec hi
+                            , flip prettyPrec_ red ]
+
+instance ABT Term abt => Pretty (Reducer abt xs) where
+  prettyPrec_ = flip ppr where
+    ppRbinder :: abt xs1 a -> Int -> Doc
+    ppRbinder f p =
+      let (vs,b) = ppBinder f
+      in parensIf (p > 0) $ sep [ sepComma vs <> colon, b ]
+
+    ppr :: Reducer abt xs1 a -> Int -> Doc
+    ppr red p =
+      case red of
+        Red_Fanout l r  -> ppFun p "rfanout"
+                             [ ppr l
+                             , ppr r ]
+        Red_Index s k r -> ppFun p "rindex"
+                             [ ppRbinder s
+                             , ppRbinder k
+                             , ppr r ]
+        Red_Split b l r -> ppFun p "rsplit"
+                             [ ppRbinder b
+                             , ppr l
+                             , ppr r ]
+        Red_Nop         -> text "rnop"
+        Red_Add _ k     -> ppFun p "radd" [ ppRbinder k ]
+
+ppNaryOpSum
+    :: forall abt a . (ABT Term abt) => abt '[] a -> Doc
+ppNaryOpSum e =
+    caseVarSyn e (const d) $ \t ->
+        case t of
+        PrimOp_ (Negate _) :$ e1 :* End -> text "-" <+> prettyPrec 7 e1
+        _ -> d
+  where d = text "+" <+> prettyPrec 7 e
+
+ppNaryOpProd
+    :: forall abt a . (ABT Term abt) => Bool -> abt '[] a -> Doc
+ppNaryOpProd second e =
+    caseVarSyn e (const d) $ \t ->
+        case t of
+        PrimOp_ (Recip _) :$ e1 :* End ->
+            if not second then d' else
+            caseVarSyn e1 (const d') $ \t' ->
+                case t' of
+                -- Use parens to distinguish division of nats
+                -- from prob literal
+                Literal_ (LNat _) -> text "/" <+> parens (pretty e1)
+                _ -> d'
+          where d' = text "/" <+> prettyPrec 8 e1
+        _ -> d
+  where d = text "*" <+> prettyPrec 8 e
+
+-- | Pretty-print @(:$)@ nodes in the AST.
+ppSCon :: (ABT Term abt) => Int -> SCon args a -> SArgs abt args -> Doc
+ppSCon p Lam_ = \(e1 :* End) ->
+    let (var, typ, body) = ppBinder1 e1 in
+    parensIf (p > 0) $
+    sep [ text "fn" <+> var <+> typ <> colon
+        , body ]
+
+--ppSCon p App_ = \(e1 :* e2 :* End) -> ppArg e1 ++ parens True (ppArg e2)
+ppSCon p App_ = \(e1 :* e2 :* End) -> prettyApps p e1 e2
+
+ppSCon p Let_ = \(e1 :* e2 :* End) ->
+    -- TODO: generate 'def' if possible
+    let (var, _, body) = ppBinder1 e2 in
+    parensIf (p > 0) $
+    var <+> equals <+> pretty e1 $$ body
+{-
+ppSCon p (Ann_ typ) = \(e1 :* End) ->
+    parensIf (p > 5) (prettyPrec 6 e1 <> text "." <+> prettyType 0 typ)
+-}
+
+ppSCon p (PrimOp_     o) = \es          -> ppPrimOp     p o es
+ppSCon p (ArrayOp_    o) = \es          -> ppArrayOp    p o es
+ppSCon p (CoerceTo_   c) = \(e1 :* End) -> ppCoerceTo   p c e1
+ppSCon p (UnsafeFrom_ c) = \(e1 :* End) -> ppUnsafeFrom p c e1
+ppSCon p (MeasureOp_  o) = \es          -> ppMeasureOp  p o es
+ppSCon p Dirac = \(e1 :* End) ->
+    parensIf (p > 0) $
+    text "return" <+> pretty e1
+ppSCon p MBind = \(e1 :* e2 :* End) ->
+    let (var, _, body) = ppBinder1 e2 in
+    parensIf (p > 0) $
+    var <+> text "<~" <+> pretty e1 $$ body
+
+ppSCon p Plate = \(e1 :* e2 :* End) ->
+    let (var, _, body) = ppBinder1 e2 in
+    parensIf (p > 0) $
+    sep [ sep [ text "plate" <+> var
+              , text "of" <+> pretty e1 <> colon ]
+        , nest 2 body ]
+
+ppSCon p Chain = \(e1 :* e2 :* e3 :* End) ->
+    let (var, _, body) = ppBinder1 e3 in
+    parensIf (p > 0) $
+    sep [ sep [ text "chain" <+> var
+              , text "from" <+> pretty e2
+              , text "of" <+> pretty e1 <> colon ]
+        , nest 2 body ]
+
+ppSCon p Integrate = \(e1 :* e2 :* e3 :* End) ->
+    let (var, _, body) = ppBinder1 e3 in
+    parensIf (p > 0) $
+    sep [ sep [ text "integrate" <+> var
+              , text "from" <+> pretty e1
+              , text "to" <+> pretty e2 <> colon ]
+        , nest 2 body ]
+
+ppSCon p (Summate _ _) = \(e1 :* e2 :* e3 :* End) ->
+    let (var, _, body) = ppBinder1 e3 in
+    parensIf (p > 0) $
+    sep [ sep [ text "summate" <+> var
+              , text "from" <+> pretty e1
+              , text "to" <+> pretty e2 <> colon ]
+        , nest 2 body ]
+
+ppSCon p (Product _ _) = \(e1 :* e2 :* e3 :* End) ->
+    let (var, _, body) = ppBinder1 e3 in
+    parensIf (p > 0) $
+    sep [ sep [ text "product" <+> var
+              , text "from" <+> pretty e1
+              , text "to" <+> pretty e2 <> colon ]
+        , nest 2 body ]
+
+ppSCon p (Transform_ t) = ppTransform p t
+
+ppTransform :: (ABT Term abt)
+            => Int -> Transform args a
+            -> SArgs abt args -> Doc
+ppTransform p t es =
+  case t of
+    Expect ->
+      case es of
+        e1 :* e2 :* End ->
+          let (var, _, body) = ppBinder1 e2 in
+          parensIf (p > 0) $
+          sep [ text "expect" <+> var <+> text "<~" <+> pretty e1 <> colon
+              , body ]
+    _ -> ppApply p (transformName t) es
+
+ppCoerceTo :: ABT Term abt => Int -> Coercion a b -> abt '[] a -> Doc
+ppCoerceTo p c = ppApply1 p f
+    -- BUG: this may not work quite right when the coercion isn't one of the special named ones...
+    where
+    f = case c of
+          Signed HRing_Real             `CCons` CNil -> "prob2real"
+          Signed HRing_Int              `CCons` CNil -> "nat2int"
+          Continuous HContinuous_Real   `CCons` CNil -> "int2real"
+          Continuous HContinuous_Prob   `CCons` CNil -> "nat2prob"
+          Continuous HContinuous_Prob   `CCons`
+            Signed HRing_Real           `CCons` CNil -> "nat2real"
+          Signed HRing_Int              `CCons`
+            Continuous HContinuous_Real `CCons` CNil -> "nat2real"
+          _ -> "coerceTo_ (" ++ show c ++ ")"
+
+
+ppUnsafeFrom :: ABT Term abt => Int -> Coercion a b -> abt '[] b -> Doc
+ppUnsafeFrom p c = ppApply1 p f
+    -- BUG: this may not work quite right when the coercion isn't one of the special named ones...
+    where
+    f = case c of
+          Signed HRing_Real `CCons` CNil -> "real2prob"
+          Signed HRing_Int  `CCons` CNil -> "int2nat"
+          _ -> "unsafeFrom_ (" ++ show c ++ ")"
+
+
+-- | Pretty-print a type.
+prettyType :: Int -> Sing (a :: Hakaru) -> Doc
+prettyType _ SNat         = text "nat"
+prettyType _ SInt         = text "int"
+prettyType _ SProb        = text "prob"
+prettyType _ SReal        = text "real"
+prettyType p (SFun   a b) = parensIf (p > 0)
+                          $ sep [ prettyType 1 a <+> text "->"
+                                , prettyType 0 b ]
+prettyType p (SMeasure a) = ppFun p "measure" [flip prettyType a]
+prettyType p (SArray   a) = ppFun p "array" [flip prettyType a]
+prettyType p (SData (STyCon sym `STyApp` a `STyApp` b) _)
+    | Just Refl <- jmEq1 sym sSymbol_Pair
+    = ppFun p "pair" [flip prettyType a, flip prettyType b]
+    | Just Refl <- jmEq1 sym sSymbol_Either
+    = ppFun p "either" [flip prettyType a, flip prettyType b]
+prettyType p (SData (STyCon sym `STyApp` a) _)
+    | Just Refl <- jmEq1 sym sSymbol_Maybe
+    = ppFun p "maybe" [flip prettyType a]
+prettyType p (SData (STyCon sym) _)
+    | Just Refl <- jmEq1 sym sSymbol_Bool
+    = text "bool"
+    | Just Refl <- jmEq1 sym sSymbol_Unit
+    = text "unit"
+prettyType _ typ
+    = parens (text (show typ))
+
+
+-- | Pretty-print a 'PrimOp' @(:$)@ node in the AST.
+ppPrimOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => Int -> PrimOp typs a -> SArgs abt args -> Doc
+ppPrimOp p Not          (e1 :* End)
+  | Syn (PrimOp_ Less{}  :$ e2 :* e3 :* End) <- viewABT e1
+  = ppBinop "<=" 4 NonAssoc p e3 e2
+  | Syn (PrimOp_ Equal{} :$ e2 :* e3 :* End) <- viewABT e1
+  = ppBinop "/=" 4 NonAssoc p e2 e3
+  | otherwise
+  = ppApply1 p "not" e1
+ppPrimOp p Impl         (e1 :* e2 :* End) = ppApply2 p "impl" e1 e2
+ppPrimOp p Diff         (e1 :* e2 :* End) = ppApply2 p "diff" e1 e2
+ppPrimOp p Nand         (e1 :* e2 :* End) = ppApply2 p "nand" e1 e2
+ppPrimOp p Nor          (e1 :* e2 :* End) = ppApply2 p "nor" e1 e2
+ppPrimOp _ Pi           End               = text "pi"
+ppPrimOp p Sin          (e1 :* End)       = ppApply1 p "sin"   e1
+ppPrimOp p Cos          (e1 :* End)       = ppApply1 p "cos"   e1
+ppPrimOp p Tan          (e1 :* End)       = ppApply1 p "tan"   e1
+ppPrimOp p Asin         (e1 :* End)       = ppApply1 p "asin"  e1
+ppPrimOp p Acos         (e1 :* End)       = ppApply1 p "acos"  e1
+ppPrimOp p Atan         (e1 :* End)       = ppApply1 p "atan"  e1
+ppPrimOp p Sinh         (e1 :* End)       = ppApply1 p "sinh"  e1
+ppPrimOp p Cosh         (e1 :* End)       = ppApply1 p "cosh"  e1
+ppPrimOp p Tanh         (e1 :* End)       = ppApply1 p "tanh"  e1
+ppPrimOp p Asinh        (e1 :* End)       = ppApply1 p "asinh" e1
+ppPrimOp p Acosh        (e1 :* End)       = ppApply1 p "acosh" e1
+ppPrimOp p Atanh        (e1 :* End)       = ppApply1 p "atanh" e1
+ppPrimOp p RealPow      (e1 :* e2 :* End) = ppBinop "**" 8 RightAssoc p e1 e2
+ppPrimOp p Choose       (e1 :* e2 :* End) = ppApply2 p "choose" e1 e2
+ppPrimOp p Exp          (e1 :* End)       = ppApply1 p "exp"   e1
+ppPrimOp p Log          (e1 :* End)       = ppApply1 p "log"   e1
+ppPrimOp _ (Infinity _) End               = text "∞"
+ppPrimOp p GammaFunc    (e1 :* End)       = ppApply1 p "gammaFunc" e1
+ppPrimOp p BetaFunc     (e1 :* e2 :* End) = ppApply2 p "betaFunc" e1 e2
+ppPrimOp p (Equal   _)  (e1 :* e2 :* End) = ppBinop "==" 4 NonAssoc   p e1 e2
+ppPrimOp p (Less    _)  (e1 :* e2 :* End) = ppBinop "<"  4 NonAssoc   p e1 e2
+ppPrimOp p (NatPow  _)  (e1 :* e2 :* End) = ppBinop "^"  8 RightAssoc p e1 e2
+ppPrimOp p (Negate  _)  (e1 :* End)       = ppNegate p e1
+ppPrimOp p (Abs     _)  (e1 :* End)       = ppApply1  p "abs"     e1
+ppPrimOp p (Signum  _)  (e1 :* End)       = ppApply1  p "signum"  e1
+ppPrimOp p (Recip   _)  (e1 :* End)       = ppRecip p e1
+ppPrimOp p (NatRoot _)  (e1 :* e2 :* End) = ppNatRoot p e1 e2
+ppPrimOp p (Erf _)      (e1 :* End)       = ppApply1  p "erf"     e1
+ppPrimOp p Floor        (e1 :* End)       = ppApply1 p "floor"   e1
+
+ppNegate :: (ABT Term abt) => Int -> abt '[] a -> Doc
+ppNegate p e = parensIf (p > 6) $
+    caseVarSyn e (const d) $ \t ->
+        case t of
+        -- Use parens to distinguish between negation of nats/probs
+        -- from int/real literal
+        Literal_ (LNat  _) -> d'
+        Literal_ (LProb _) -> d'
+        _                  -> d
+    where d  = text "-" <> prettyPrec 7 e
+          d' = text "-" <> parens (pretty e)
+
+ppRecip :: (ABT Term abt) => Int -> abt '[] a -> Doc
+ppRecip p e = parensIf (p > 7) $
+    caseVarSyn e (const d) $ \t ->
+        case t of
+        -- Use parens to distinguish between reciprocal of nat
+        -- from prob literal
+        Literal_ (LNat _) -> d'
+        _                 -> d
+    where d  = text "1/" <+> prettyPrec 8 e
+          d' = text "1/" <+> parens (pretty e)
+
+ppNatRoot
+    :: (ABT Term abt)
+    => Int
+    -> abt '[] a
+    -> abt '[] 'HNat
+    -> Doc
+ppNatRoot p e1 e2 =
+    caseVarSyn e2 (const d) $ \t ->
+        case t of
+          Literal_ (LNat 2) -> ppApply1 p "sqrt" e1
+          _                 -> d
+    where d = ppApply2 p "natroot" e1 e2
+
+
+-- | Pretty-print a 'ArrayOp' @(:$)@ node in the AST.
+ppArrayOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => Int -> ArrayOp typs a -> SArgs abt args -> Doc
+ppArrayOp p (Index   _) = \(e1 :* e2 :* End) -> parensIf (p > 10)
+    $ cat [ prettyPrec 10 e1, nest 2 (brackets (pretty e2)) ]
+
+ppArrayOp p (Size    _) = \(e1 :* End)       -> ppApply1 p "size" e1
+ppArrayOp p (Reduce  _) = \(e1 :* e2 :* e3 :* End) ->
+    ppFun p "reduce"
+        [ flip prettyPrec e1
+        , flip prettyPrec e2
+        , flip prettyPrec e3 ]
+
+
+-- | Pretty-print a 'MeasureOp' @(:$)@ node in the AST.
+ppMeasureOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => Int -> MeasureOp typs a -> SArgs abt args -> Doc
+ppMeasureOp p Lebesgue    = \(e1 :* e2 :* End) -> ppApply2 p "lebesgue" e1 e2
+ppMeasureOp _ Counting    = \End           -> text "counting"
+ppMeasureOp p Categorical = \(e1 :* End)   -> ppApply1 p "categorical" e1
+ppMeasureOp p Uniform = \(e1 :* e2 :* End) -> ppApply2 p "uniform"     e1 e2
+ppMeasureOp p Normal  = \(e1 :* e2 :* End) -> ppApply2 p "normal"      e1 e2
+ppMeasureOp p Poisson = \(e1 :* End)       -> ppApply1 p "poisson"     e1
+ppMeasureOp p Gamma   = \(e1 :* e2 :* End) -> ppApply2 p "gamma"       e1 e2
+ppMeasureOp p Beta    = \(e1 :* e2 :* End) -> ppApply2 p "beta"        e1 e2
+
+instance Pretty Literal where
+    prettyPrec_ _ (LNat  n) = integer (fromNatural n)
+    prettyPrec_ p (LInt  i) = parensIf (p > 6) $
+        if i < 0 then text "-" <> integer (-i)
+                 else text "+" <> integer   i
+    prettyPrec_ p (LProb l) = parensIf (p > 7) $
+        cat [ integer n, text "/" <> integer d ]
+        where r = fromNonNegativeRational l
+              n = numerator   r
+              d = denominator r
+    prettyPrec_ p (LReal r) = parensIf (p > 6) $
+        if n < 0 then text "-" <> cat [ integer (-n), text "/" <> integer d ]
+                 else text "+" <> cat [ integer   n , text "/" <> integer d ]
+        where n = numerator   r
+              d = denominator r
+
+instance Pretty Value where
+    prettyPrec_ _ (VNat  n)    = integer (fromNatural n)
+    prettyPrec_ p (VInt  i)    = parensIf (p > 6) $
+        if i < 0 then integer i else text "+" <> integer i
+    prettyPrec_ _ (VProb l)    = double (LF.fromLogFloat l)
+    prettyPrec_ p (VReal r)    = parensIf (p > 6) $
+        if r < 0 then double r else text "+" <> double r
+    prettyPrec_ p (VDatum d)   = prettyPrec_ p d
+    prettyPrec_ _ (VLam _)     = text "<function>"
+    prettyPrec_ _ (VMeasure _) = text "<measure>"
+    prettyPrec_ _ (VArray a)   = ppList . V.toList $ V.map (prettyPrec_ 0) a
+
+prettyValue :: Value a -> Doc
+prettyValue = prettyPrec_ 0
+
+instance Pretty f => Pretty (Datum f) where
+    prettyPrec_ p (Datum hint _typ d)
+        | Text.null hint =
+            ppFun p "datum_"
+                [error "TODO: prettyPrec_@Datum"]
+        | otherwise =
+            case Text.unpack hint of
+            -- Special cases for certain datums
+            "pair"  -> ppTuple p (foldMap11 (\e -> [flip prettyPrec_ e]) d) 
+            "true"  -> text "true"
+            "false" -> text "false"
+            "unit"  -> text "()"
+            -- General case
+            f       -> parensIf (p > 5) $
+                       ppFun 6 f (foldMap11 (\e -> [flip prettyPrec_ e]) d)
+                       <> text "." <+> prettyType 0 _typ
+
+
+-- HACK: need to pull this out in order to get polymorphic recursion over @xs@
+ppPattern :: [Doc] -> Pattern xs a -> (Int -> Doc, [Doc])
+ppPattern vars   PWild = (const (text "_"), vars)
+ppPattern (v:vs) PVar  = (const v         , vs)
+ppPattern vars   (PDatum hint d0)
+    | Text.null hint = error "TODO: prettyPrec_@Pattern"
+    | otherwise      =
+        case Text.unpack hint of
+        -- Special cases for certain pDatums
+        "true"  -> (const (text "true" ), vars)
+        "false" -> (const (text "false"), vars)
+        "pair"  -> ppFunWithVars ppTuple
+        -- General case
+        f       -> ppFunWithVars (flip ppFun f)
+    where
+    ppFunWithVars ppHint = (flip ppHint g, vars')
+       where (g, vars') = goCode d0 vars
+
+    goCode :: PDatumCode xss vars a -> [Doc] -> ([Int -> Doc], [Doc])
+    goCode (PInr d) = goCode   d
+    goCode (PInl d) = goStruct d
+
+    goStruct :: PDatumStruct xs vars a -> [Doc] -> ([Int -> Doc], [Doc])
+    goStruct PDone       vars  = ([], vars)
+    goStruct (PEt d1 d2) vars = (gF ++ gS, vars'')
+       where (gF, vars')  = goFun d1 vars
+             (gS, vars'') = goStruct d2 vars' 
+
+    goFun :: PDatumFun x vars a -> [Doc] -> ([Int -> Doc], [Doc])
+    goFun (PKonst d) vars = ([g], vars')
+       where (g, vars') = ppPattern vars d
+    goFun (PIdent d) vars = ([g], vars')
+       where (g, vars') = ppPattern vars d
+
+
+instance (ABT Term abt) => Pretty (Branch a abt) where
+    prettyPrec_ p (Branch pat e) =
+        let (vars, body) = ppBinder e
+            (pp, []) = ppPattern vars pat
+        in sep [ pp 0 <> colon, nest 2 body ]
+
+----------------------------------------------------------------
+prettyApps :: (ABT Term abt) => Int -> abt '[] (a ':-> b) -> abt '[] a -> Doc
+prettyApps = \ p e1 e2 ->
+{- TODO: confirm not using reduceLams
+    case reduceLams e1 e2 of
+    Just e2' -> ppArg e2'
+    Nothing  ->
+-}
+      uncurry (ppApp p) (collectApps e1 [flip prettyPrec e2])
+    where
+    reduceLams
+        :: (ABT Term abt)
+        => abt '[] (a ':-> b) -> abt '[] a -> Maybe (abt '[] b)
+    reduceLams e1 e2 =
+        caseVarSyn e1 (const Nothing) $ \t ->
+            case t of
+            Lam_ :$ e1 :* End ->
+              caseBind e1 $ \x e1' ->
+                Just (subst x e2 e1')
+            _                 -> Nothing
+
+    -- collectApps makes sure f(x,y) is not printed f(x)(y)
+    collectApps
+        :: (ABT Term abt)
+        => abt '[] (a ':-> b) -> [Int -> Doc] -> (Int -> Doc, [Int -> Doc])
+    collectApps e es = 
+        caseVarSyn e (const ret) $ \t ->
+            case t of
+            App_ :$ e1 :* e2 :* End -> collectApps e1 (flip prettyPrec e2 : es)
+            _                       -> ret
+        where ret = (flip prettyPrec e, es)
+
+
+
+ppList :: [Doc] -> Doc
+ppList = brackets . sepComma
+
+ppTuple :: Int -> [Int -> Doc] -> Doc
+ppTuple _ = parens . sepComma . map ($ 0)
+
+ppApp :: Int -> (Int -> Doc) -> [Int -> Doc] -> Doc
+ppApp p f ds = parensIf (p > 10)
+             $ cat [ f 10, nest 2 (ppTuple 11 ds) ]
+
+ppFun :: Int -> String -> [Int -> Doc] -> Doc
+ppFun p = ppApp p . const . text
+
+ppApply1 :: (ABT Term abt) => Int -> String -> abt '[] a -> Doc
+ppApply1 p f e1 = ppFun p f [flip prettyPrec e1]
+
+ppApply2 :: (ABT Term abt) => Int -> String -> abt '[] a -> abt '[] b -> Doc
+ppApply2 p f e1 e2 = ppFun p f [flip prettyPrec e1, flip prettyPrec e2]
+
+ppApply :: ABT Term abt => Int -> String
+        -> SArgs abt xs -> Doc
+ppApply p f es =
+  ppFun p f $ foldMap21 (pure . const . ppBinderAsFun) es
+
+ppBinop
+    :: (ABT Term abt)
+    => String -> Int -> Associativity
+    -> Int -> abt '[] a -> abt '[] b -> Doc
+ppBinop op p0 assoc =
+    let (p1,p2,f1,f2) =
+            case assoc of
+            NonAssoc   -> (1 + p0, 1 + p0, id, (text op <+>))
+            LeftAssoc  -> (    p0, 1 + p0, id, (text op <+>))
+            RightAssoc -> (1 + p0,     p0, (<+> text op), id)
+    in \p e1 e2 ->
+        parensIf (p > p0) $ sep [ f1 (prettyPrec p1 e1)
+                                , f2 (prettyPrec p2 e2) ]
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Pretty/Haskell.hs b/haskell/Language/Hakaru/Pretty/Haskell.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Pretty/Haskell.hs
@@ -0,0 +1,648 @@
+{-# LANGUAGE GADTs
+           , OverloadedStrings
+           , KindSignatures
+           , DataKinds
+           , FlexibleContexts
+           , UndecidableInstances
+           , LambdaCase
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.02.21
+-- |
+-- Module      :  Language.Hakaru.Pretty.Haskell
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--
+----------------------------------------------------------------
+module Language.Hakaru.Pretty.Haskell
+    (
+    -- * The user-facing API
+      pretty
+    , prettyString
+    , prettyPrec
+    , prettyAssoc
+    , prettyPrecAssoc
+    , prettyType
+
+    -- * Helper functions (semi-public internal API)
+    , ppVariable
+    , ppVariables
+    , ppBinder
+    , ppCoerceTo
+    , ppUnsafeFrom
+    , ppRatio
+    , Associativity(..)
+    , ppBinop
+    , Pretty(..)
+    ) where
+import           Data.Ratio
+import           Text.PrettyPrint (Doc, (<>), (<+>))
+import qualified Text.PrettyPrint   as PP
+import qualified Data.Foldable      as F
+import qualified Data.List.NonEmpty as L
+import qualified Data.Text          as Text
+import qualified Data.Sequence      as Seq -- Because older versions of "Data.Foldable" do not export 'null' apparently...
+import           Prelude            hiding ((<>))
+
+import Data.Number.Nat                 (fromNat)
+import Data.Number.Natural             (fromNatural)
+import Language.Hakaru.Syntax.IClasses (fmap11, foldMap11, List1(..)
+                                       ,Foldable21(..))
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.ABT
+----------------------------------------------------------------
+
+-- | Pretty-print a term.
+pretty :: (ABT Term abt) => abt '[] a -> Doc
+pretty = prettyPrec 0
+
+
+prettyString :: (ABT Term abt)
+           => Sing a
+           -> abt '[] a
+           -> Doc
+prettyString typ ast =
+  PP.text $ Text.unpack (Text.unlines $ header  ++ [ Text.pack (prettyProg "prog" typ ast)])
+
+prettyProg :: (ABT Term abt)
+           => String
+           -> Sing a
+           -> abt '[] a
+           -> String
+prettyProg name typ ast =
+    PP.renderStyle PP.style
+    (    PP.sep [PP.text (name ++ " ::"), PP.nest 2 (prettyType typ)]
+     PP.$+$ PP.sep [PP.text (name ++ " =") , PP.nest 2 (pretty     ast)] )
+
+-- | Pretty-print a term at a given precendence level.
+prettyPrec :: (ABT Term abt) => Int -> abt '[] a -> Doc
+prettyPrec p = toDoc . prettyPrec_ p . LC_
+
+
+-- | Pretty-print a variable\/term association pair.
+prettyAssoc :: (ABT Term abt) => Assoc (abt '[]) -> Doc
+prettyAssoc = prettyPrecAssoc 0
+
+
+-- | Pretty-print an association at a given precendence level.
+prettyPrecAssoc :: (ABT Term abt) => Int -> Assoc (abt '[]) -> Doc
+prettyPrecAssoc p (Assoc x e) =
+    toDoc $ ppFun p "Assoc"
+        [ ppVariable x
+        , prettyPrec 11 e
+        ]
+
+
+-- | Pretty-print a Hakaru type as a Haskell type.
+prettyType :: Sing (a :: Hakaru) -> Doc
+prettyType SInt = PP.text "Int"
+prettyType SNat = PP.text "Int"
+prettyType SReal = PP.text "Double"
+prettyType SProb = PP.text "Prob"
+prettyType (SArray t) =
+  let t' = PP.nest 2 (prettyType t) in
+  PP.parens (PP.sep [PP.text "MayBoxVec", t', t'])
+prettyType (SMeasure t) =
+  PP.parens (PP.sep [PP.text "Measure", PP.nest 2 (prettyType t)])
+prettyType (SFun t1 t2) =
+  PP.parens (PP.sep [prettyType t1 <+> PP.text "->", prettyType t2])
+prettyType (SData _ (SDone `SPlus` SVoid)) =
+  PP.text "()"
+prettyType (SData _ (SDone `SPlus` SDone `SPlus` SVoid)) =
+  PP.text "Bool"
+prettyType (SData _ (SDone `SPlus` (SKonst t `SEt` SDone) `SPlus` SVoid)) =
+  PP.parens (PP.sep [PP.text "Maybe", PP.nest 2 (prettyType t)])
+prettyType (SData _ ((SKonst t1 `SEt` SDone) `SPlus`
+                     (SKonst t2 `SEt` SDone) `SPlus` SVoid)) =
+  PP.parens (PP.sep [PP.text "Either", PP.nest 2 (prettyType t1),
+                                       PP.nest 2 (prettyType t2)])
+prettyType (SData _ ((SKonst t1 `SEt` SKonst t2 `SEt` SDone) `SPlus` SVoid)) =
+  PP.parens (PP.sep [prettyType t1 <> PP.comma, prettyType t2])
+prettyType s = error ("TODO: prettyType: " ++ show s)
+
+
+----------------------------------------------------------------
+class Pretty (f :: Hakaru -> *) where
+    -- | A polymorphic variant if 'prettyPrec', for internal use.
+    prettyPrec_ :: Int -> f a -> Docs
+
+type Docs = [Doc]
+
+-- So far as I can tell from the documentation, if the input is a singleton list then the result is the same as that singleton.
+toDoc :: Docs -> Doc
+toDoc = PP.sep
+
+
+-- | Pretty-print a variable.
+ppVariable :: Variable (a :: Hakaru) -> Doc
+ppVariable x = hint <> (PP.int . fromNat . varID) x
+    where
+    hint
+        | Text.null (varHint x) = PP.char 'x' -- We used to use '_' but...
+        | otherwise             = (PP.text . Text.unpack . varHint) x
+
+-- | Pretty-print a list of variables as a list of variables. N.B., the output is not valid Haskell code since it uses the special built-in list syntax rather than using the 'List1' constructors...
+ppVariables :: List1 Variable (xs :: [Hakaru]) -> Docs
+ppVariables = ppList . go
+    where
+    go :: List1 Variable (xs :: [Hakaru]) -> Docs
+    go Nil1         = []
+    go (Cons1 x xs) = ppVariable x : go xs
+
+
+-- | Pretty-print Hakaru binders as a Haskell lambda, as per our HOAS API.
+ppBinder :: (ABT Term abt) => abt xs a -> Docs
+ppBinder e =
+    case ppViewABT e of
+    ([],  body) -> body
+    (vars,body) -> PP.char '\\' <+> PP.sep vars <+> PP.text "->" : body
+
+ppUncurryBinder :: (ABT Term abt) => abt xs a -> Docs
+ppUncurryBinder e =
+    case ppViewABT e of
+    (vars,body) -> PP.char '\\' <+> unc vars <+> PP.text "->" : body
+    where
+    unc :: [Doc] -> Doc
+    unc []     = PP.text "()"
+    unc (x:xs) = PP.parens (x <> PP.comma <> unc xs)
+
+ppViewABT :: (ABT Term abt) => abt xs a -> ([Doc], Docs)
+ppViewABT e = go [] (viewABT e)
+    where
+    go :: (ABT Term abt) => [Doc] -> View (Term abt) xs a -> ([Doc],Docs)
+    go xs (Syn  t)   = (reverse xs, prettyPrec_ 0 (LC_ (syn t)))
+    go xs (Var  x)   = (reverse xs, [ppVariable x])
+    go xs (Bind x v) =
+        -- HACK: how can we avoid calling 'unviewABT' here?
+        let x' = if True -- x `memberVarSet` freeVars (unviewABT v)
+                 then ppVariable x
+                 else PP.char '_'
+        in go (x' : xs) v
+
+
+-- TODO: since switching to ABT2, this instance requires -XFlexibleContexts; we should fix that if we can
+-- BUG: since switching to ABT2, this instance requires -XUndecidableInstances; must be fixed!
+instance (ABT Term abt) => Pretty (LC_ abt) where
+  prettyPrec_ p (LC_ e) =
+    caseVarSyn e ((:[]) . ppVariable) $ \t ->
+        case t of
+        o :$ es      -> ppSCon p o es
+        NaryOp_ o es ->
+            -- TODO: make sure these ops actually have those precedences in the Prelude!!
+            let prettyNaryOp :: NaryOp a -> (String, Int, Maybe String)
+                prettyNaryOp And  = ("&&", 3, Just "true")
+                prettyNaryOp Or   = ("||", 2, Just "false")
+                prettyNaryOp Xor  = ("`xor`", 0, Just "false")
+                -- BUG: even though 'Iff' is associative (in Boolean algebras), we should not support n-ary uses in our *surface* syntax. Because it's too easy for folks to confuse "a <=> b <=> c" with "(a <=> b) /\ (b <=> c)".
+                prettyNaryOp Iff      = ("`iff`", 0, Just "true")
+                prettyNaryOp (Min  _) = ("`min`", 5, Nothing)
+                prettyNaryOp (Max  _) = ("`max`", 5, Nothing)
+                -- TODO: pretty print @(+ negate)@ as @(-)@ and @(* recip)@ as @(/)@
+                prettyNaryOp (Sum  _) = ("+",     6, Just "zero")
+                prettyNaryOp (Prod _) = ("*",     7, Just "one")
+            in
+            let (opName,opPrec,maybeIdentity) = prettyNaryOp o in
+            if Seq.null es
+            then
+                case maybeIdentity of
+                Just identity -> [PP.text identity]
+                Nothing ->
+                    ppFun p "syn"
+                        [ toDoc $ ppFun 11 "NaryOp_"
+                            [ PP.text (showsPrec 11 o "")
+                            , PP.text "(Seq.fromList [])"
+                            ]]
+            else
+                parens (p > opPrec)
+                    . PP.punctuate (PP.space <> PP.text opName)
+                    . map (prettyPrec opPrec)
+                    $ F.toList es
+
+        Literal_ v    -> prettyPrec_ p v
+        Empty_   _    -> [PP.text "empty"]
+        Array_ e1 e2  ->
+            ppFun 11 "array"
+                [ ppArg e1 <+> PP.char '$'
+                , toDoc $ ppBinder e2
+                ]
+        ArrayLiteral_ es -> ppFun 11 "arrayLit" (ppList $ map (prettyPrec 0) es)
+        Datum_ d      -> prettyPrec_ p (fmap11 LC_ d)
+        Case_  e1 bs  ->
+            -- TODO: should we also add hints to the 'Case_' constructor to know whether it came from 'if_', 'unpair', etc?
+             ppFun p "case_"
+                 [ ppArg e1
+                 , toDoc $ ppList (map (toDoc . prettyPrec_ 0) bs)
+                 ]
+        Bucket b ee r  ->
+            ppFun p "bucket"
+            [ ppArg b
+            , ppArg ee
+            , toDoc $ parens True (prettyPrec_ p r)
+            ]
+
+        Superpose_ pes ->
+            case pes of
+            (e1,e2) L.:| [] ->
+                -- Or we could print it as @weight e1 *> e2@ excepting that has an extra redex in it compared to the AST itself.
+                ppFun 11 "pose"
+                    [ ppArg e1 <+> PP.char '$'
+                    , ppArg e2
+                    ]
+            _ ->
+                ppFun p "superpose"
+                    [ toDoc
+                    . ppList
+                    . map (\(e1,e2) -> ppTuple [pretty e1, pretty e2])
+                    $ L.toList pes
+                    ]
+
+        Reject_ _ -> [PP.text "reject"]
+
+-- | Pretty-print @(:$)@ nodes in the AST.
+ppSCon :: (ABT Term abt) => Int -> SCon args a -> SArgs abt args -> Docs
+ppSCon p Lam_ = \(e1 :* End) ->
+    parens (p > 0) $ adjustHead (PP.text "lam $" <+>) (ppBinder e1)
+ppSCon p App_ = \(e1 :* e2 :* End) -> ppBinop "`app`" 9 LeftAssoc p e1 e2 -- BUG: this puts extraneous parentheses around e2 when it's a function application...
+ppSCon p Let_ = \(e1 :* e2 :* End) ->
+    parens (p > 0) $
+        adjustHead
+            (PP.text "let_" <+> ppArg e1 <+> PP.char '$' <+>)
+            (ppBinder e2)
+{-
+ppSCon p (Ann_ typ) = \(e1 :* End) ->
+    ppFun p "ann_"
+        [ PP.text (showsPrec 11 typ "") -- TODO: make this prettier. Add hints to the singletons?
+        , ppArg e1
+        ]
+-}
+ppSCon p (PrimOp_     o) = \es          -> ppPrimOp     p o es
+ppSCon p (ArrayOp_    o) = \es          -> ppArrayOp    p o es
+ppSCon p (CoerceTo_   c) = \(e1 :* End) -> ppCoerceTo   p c e1
+ppSCon p (UnsafeFrom_ c) = \(e1 :* End) -> ppUnsafeFrom p c e1
+ppSCon p (MeasureOp_  o) = \es          -> ppMeasureOp  p o es
+ppSCon p Dirac           = \(e1 :* End) -> ppApply1 p "dirac" e1
+ppSCon p MBind = \(e1 :* e2 :* End) ->
+    parens (p > 1) $
+        adjustHead
+            (prettyPrec 1 e1 <+> PP.text ">>=" <+>)
+            (ppBinder e2)
+ppSCon p (Transform_ t) = ppTransform p t
+ppSCon p Integrate = \(e1 :* e2 :* e3 :* End) ->
+    ppFun p "integrate"
+        [ ppArg e1
+        , ppArg e2
+        , toDoc $ parens True (ppBinder e3)
+        ]
+ppSCon p (Summate _ _) = \(e1 :* e2 :* e3 :* End) ->
+    ppFun p "summate"
+        [ ppArg e1
+        , ppArg e2
+        , toDoc $ parens True (ppBinder e3)
+        ]
+
+ppSCon p (Product _ _) = \(e1 :* e2 :* e3 :* End) ->
+    ppFun p "product"
+        [ ppArg e1
+        , ppArg e2
+        , toDoc $ parens True (ppBinder e3)
+        ]
+
+ppSCon _ Plate = \(e1 :* e2 :* End) ->
+    ppFun 11 "plate"
+        [ ppArg e1 <+> PP.char '$'
+        , toDoc $ ppBinder e2
+        ]
+
+ppSCon _ Chain = \(e1 :* e2 :* e3 :* End) ->
+    ppFun 11 "chain"
+        [ ppArg e1
+        , ppArg e2 <+> PP.char '$'
+        , toDoc $ ppBinder e3
+        ]
+
+ppTransform :: (ABT Term abt)
+            => Int -> Transform args a -> SArgs abt args -> Docs
+ppTransform p t es =
+  case t of
+     Expect ->
+       case es of
+         e1 :* e2 :* End ->
+           parens (p > 0) $
+              adjustHead
+                (PP.text "expect" <+> ppArg e1 <+> PP.char '$' <+>)
+                (ppBinder e2)
+     _ -> ppApply p (transformName t) es
+
+ppCoerceTo :: ABT Term abt => Int -> Coercion a b -> abt '[] a -> Docs
+ppCoerceTo =
+    -- BUG: this may not work quite right when the coercion isn't one of the special named ones...
+    \p c e -> ppFun p (prettyShow c) [ppArg e]
+    where
+    prettyShow (CCons (Signed HRing_Real) CNil)           = "fromProb"
+    prettyShow (CCons (Signed HRing_Int)  CNil)           = "nat2int"
+    prettyShow (CCons (Continuous HContinuous_Real) CNil) = "fromInt"
+    prettyShow (CCons (Continuous HContinuous_Prob) CNil) = "nat2prob"
+    prettyShow (CCons (Continuous HContinuous_Prob)
+        (CCons (Signed HRing_Real) CNil))                 = "nat2real"
+    prettyShow (CCons (Signed HRing_Int)
+        (CCons (Continuous HContinuous_Real) CNil))       = "nat2real"
+    prettyShow c = "coerceTo_ " ++ showsPrec 11 c ""
+
+
+ppUnsafeFrom :: ABT Term abt => Int -> Coercion a b -> abt '[] b -> Docs
+ppUnsafeFrom =
+    -- BUG: this may not work quite right when the coercion isn't one of the special named ones...
+    \p c e -> ppFun p (prettyShow c) [ppArg e]
+    where
+    prettyShow (CCons (Signed HRing_Real) CNil) = "unsafeProb"
+    prettyShow (CCons (Signed HRing_Int)  CNil) = "unsafeNat"
+    prettyShow c = "unsafeFrom_ " ++ showsPrec 11 c ""
+
+
+-- | Pretty-print a 'PrimOp' @(:$)@ node in the AST.
+ppPrimOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => Int -> PrimOp typs a -> SArgs abt args -> Docs
+ppPrimOp p Not  = \(e1 :* End)       -> ppApply1 p "not" e1
+ppPrimOp p Impl = \(e1 :* e2 :* End) ->
+    -- TODO: make prettier
+    ppFun p "syn"
+        [ toDoc $ ppFun 11 "Impl"
+            [ ppArg e1
+            , ppArg e2
+            ]]
+ppPrimOp p Diff = \(e1 :* e2 :* End) ->
+    -- TODO: make prettier
+    ppFun p "syn"
+        [ toDoc $ ppFun 11 "Diff"
+            [ ppArg e1
+            , ppArg e2
+            ]]
+ppPrimOp p Nand = \(e1 :* e2 :* End)        -> ppApply2 p "nand" e1 e2 -- TODO: make infix...
+ppPrimOp p Nor  = \(e1 :* e2 :* End)        -> ppApply2 p "nor" e1 e2 -- TODO: make infix...
+ppPrimOp _ Pi        = \End                 -> [PP.text "pi"]
+ppPrimOp p Sin       = \(e1 :* End)         -> ppApply1 p "sin"   e1
+ppPrimOp p Cos       = \(e1 :* End)         -> ppApply1 p "cos"   e1
+ppPrimOp p Tan       = \(e1 :* End)         -> ppApply1 p "tan"   e1
+ppPrimOp p Asin      = \(e1 :* End)         -> ppApply1 p "asin"  e1
+ppPrimOp p Acos      = \(e1 :* End)         -> ppApply1 p "acos"  e1
+ppPrimOp p Atan      = \(e1 :* End)         -> ppApply1 p "atan"  e1
+ppPrimOp p Sinh      = \(e1 :* End)         -> ppApply1 p "sinh"  e1
+ppPrimOp p Cosh      = \(e1 :* End)         -> ppApply1 p "cosh"  e1
+ppPrimOp p Tanh      = \(e1 :* End)         -> ppApply1 p "tanh"  e1
+ppPrimOp p Asinh     = \(e1 :* End)         -> ppApply1 p "asinh" e1
+ppPrimOp p Acosh     = \(e1 :* End)         -> ppApply1 p "acosh" e1
+ppPrimOp p Atanh     = \(e1 :* End)         -> ppApply1 p "atanh" e1
+ppPrimOp p RealPow   = \(e1 :* e2 :* End)   -> ppBinop "**" 8 RightAssoc p e1 e2
+ppPrimOp p Choose    = \(e1 :* e2 :* End)   -> ppApply2 p "choose" e1 e2
+ppPrimOp p Exp       = \(e1 :* End)         -> ppApply1 p "exp"   e1
+ppPrimOp p Log       = \(e1 :* End)         -> ppApply1 p "log"   e1
+ppPrimOp _ (Infinity _)     = \End          -> [PP.text "infinity"]
+ppPrimOp p GammaFunc = \(e1 :* End)         -> ppApply1 p "gammaFunc" e1
+ppPrimOp p BetaFunc  = \(e1 :* e2 :* End)   -> ppApply2 p "betaFunc" e1 e2
+ppPrimOp p (Equal   _) = \(e1 :* e2 :* End) -> ppBinop "==" 4 NonAssoc   p e1 e2
+ppPrimOp p (Less    _) = \(e1 :* e2 :* End) -> ppBinop "<"  4 NonAssoc   p e1 e2
+ppPrimOp p (NatPow  _) = \(e1 :* e2 :* End) -> ppBinop "^"  8 RightAssoc p e1 e2
+ppPrimOp p (Negate  _) = \(e1 :* End)       -> ppApply1 p "negate" e1
+ppPrimOp p (Abs     _) = \(e1 :* End)       -> ppApply1 p "abs_"   e1
+ppPrimOp p (Signum  _) = \(e1 :* End)       -> ppApply1 p "signum" e1
+ppPrimOp p (Recip   _) = \(e1 :* End)       -> ppApply1 p "recip"  e1
+ppPrimOp p (NatRoot _) = \(e1 :* e2 :* End) ->
+    -- N.B., argument order is swapped!
+    ppBinop "`thRootOf`" 9 LeftAssoc p e2 e1
+ppPrimOp p (Erf _)     = \(e1 :* End)        -> ppApply1 p "erf"   e1
+ppPrimOp p Floor       = \(e1 :* End)        -> ppApply1 p "floor" e1
+
+
+-- | Pretty-print a 'ArrayOp' @(:$)@ node in the AST.
+ppArrayOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => Int -> ArrayOp typs a -> SArgs abt args -> Docs
+ppArrayOp p (Index   _) = \(e1 :* e2 :* End) ->
+    ppBinop "!" 9 LeftAssoc p e1 e2
+ppArrayOp p (Size    _) = \(e1 :* End) ->
+    ppApply1 p "size" e1
+ppArrayOp p (Reduce  _) = \(e1 :* e2 :* e3 :* End) ->
+    ppFun p "reduce"
+        [ ppArg e1 -- N.B., @e1@ uses lambdas rather than being a binding form!
+        , ppArg e2
+        , ppArg e3
+        ]
+
+
+-- | Pretty-print a 'MeasureOp' @(:$)@ node in the AST.
+ppMeasureOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => Int -> MeasureOp typs a -> SArgs abt args -> Docs
+ppMeasureOp p Lebesgue    = \(e1 :* e2 :* End) -> ppApply2 p "lebesgue" e1 e2
+ppMeasureOp _ Counting    = \End           -> [PP.text "counting"]
+ppMeasureOp p Categorical = \(e1 :* End)   -> ppApply1 p "categorical" e1
+ppMeasureOp p Uniform = \(e1 :* e2 :* End) -> ppApply2 p "uniform"     e1 e2
+ppMeasureOp p Normal  = \(e1 :* e2 :* End) -> ppApply2 p "normal"      e1 e2
+ppMeasureOp p Poisson = \(e1 :* End)       -> ppApply1 p "poisson"     e1
+ppMeasureOp p Gamma   = \(e1 :* e2 :* End) -> ppApply2 p "gamma"       e1 e2
+ppMeasureOp p Beta    = \(e1 :* e2 :* End) -> ppApply2 p "beta"        e1 e2
+
+instance Pretty Literal where
+    prettyPrec_ p (LNat  n) = ppFun p "nat_"  [PP.integer (fromNatural n)]
+    prettyPrec_ p (LInt  i) = ppFun p "int_"  [PP.integer i]
+    prettyPrec_ p (LProb l) = ppFun p "prob_" [ppRatio 11 l]
+    prettyPrec_ p (LReal r) = ppFun p "real_" [ppRatio 11 r]
+
+
+instance Pretty f => Pretty (Datum f) where
+    prettyPrec_ p (Datum hint _typ d)
+        | Text.null hint =
+            ppFun p "datum_"
+                [error "TODO: prettyPrec_@Datum"]
+        | otherwise =
+          ppFun p "ann_"
+            [ PP.parens . PP.text . show $ _typ
+            , PP.parens . toDoc $ ppFun p (Text.unpack hint)
+                (foldMap11 ((:[]) . toDoc . prettyPrec_ 11) d)
+            ]
+
+-- HACK: need to pull this out in order to get polymorphic recursion over @xs@
+ppPattern :: Int -> Pattern xs a -> Docs
+ppPattern _ PWild = [PP.text "PWild"]
+ppPattern _ PVar  = [PP.text "PVar"]
+ppPattern p (PDatum hint d0)
+    | Text.null hint = error "TODO: prettyPrec_@Pattern"
+    | otherwise      = ppFun p ("p" ++ Text.unpack hint) (goCode d0)
+    where
+    goCode :: PDatumCode xss vars a -> Docs
+    goCode (PInr d) = goCode   d
+    goCode (PInl d) = goStruct d
+
+    goStruct :: PDatumStruct xs vars a -> Docs
+    goStruct PDone       = []
+    goStruct (PEt d1 d2) = goFun d1 ++ goStruct d2
+
+    goFun :: PDatumFun x vars a -> Docs
+    goFun (PKonst d) = [toDoc $ ppPattern 11 d]
+    goFun (PIdent d) = [toDoc $ ppPattern 11 d]
+
+
+instance Pretty (Pattern xs) where
+    prettyPrec_ = ppPattern
+
+
+instance (ABT Term abt) => Pretty (Branch a abt) where
+    prettyPrec_ p (Branch pat e) =
+        ppFun p "branch"
+            [ toDoc $ prettyPrec_ 11 pat
+            , PP.parens . toDoc $ ppBinder e
+            -- BUG: we can't actually use the HOAS API here, since we aren't using a Prelude-defined @branch@...
+            -- HACK: don't *always* print parens; pass down the precedence to 'ppBinder' to
+            --       have them decide if they need to or not.
+            ]
+
+instance (ABT Term abt) => Pretty (Reducer abt xs) where
+    prettyPrec_ p (Red_Fanout r1 r2)  =
+        ppFun p "r_fanout"
+            [ toDoc $ prettyPrec_ 11 r1
+            , toDoc $ prettyPrec_ 11 r2
+            ]
+    prettyPrec_ p (Red_Index n o e)   =
+        ppFun p "r_index"
+            [ toDoc $ parens True $ ppUncurryBinder n
+            , toDoc $ parens True $ ppUncurryBinder o
+            , toDoc $ prettyPrec_ 11 e
+            ]
+    prettyPrec_ p (Red_Split b r1 r2) =
+        ppFun p "r_split"
+            [ toDoc $ parens True (ppUncurryBinder b)
+            , toDoc $ prettyPrec_ 11 r1
+            , toDoc $ prettyPrec_ 11 r2
+            ]
+    prettyPrec_ _ Red_Nop             =
+        [ PP.text "r_nop" ]
+    prettyPrec_ p (Red_Add _ e)       =
+        ppFun p "r_add"
+            [ toDoc $ parens True (ppUncurryBinder e)]
+
+----------------------------------------------------------------
+-- | For the \"@lam $ \x ->\n@\"  style layout.
+adjustHead :: (Doc -> Doc) -> Docs -> Docs
+adjustHead f []     = [f (toDoc [])]
+adjustHead f (d:ds) = f d : ds
+
+{- -- unused
+-- | For the \"@lam (\x ->\n\t...)@\"  style layout.
+nestTail :: Int -> Docs -> Docs
+nestTail _ []     = []
+nestTail n (d:ds) = [d, PP.nest n (toDoc ds)]
+-}
+
+parens :: Bool -> Docs -> Docs
+parens True  ds = [PP.parens (PP.nest 1 (toDoc ds))]
+parens False ds = ds
+
+ppList :: [Doc] -> Docs
+ppList = (:[]) . PP.brackets . PP.nest 1 . PP.fsep . PP.punctuate PP.comma
+
+ppTuple :: [Doc] -> Doc
+ppTuple = PP.parens . PP.sep . PP.punctuate PP.comma
+
+ppFun :: Int -> String -> [Doc] -> Docs
+ppFun _ f [] = [PP.text f]
+ppFun p f ds =
+    parens (p > 9) [PP.text f <+> PP.nest (1 + length f) (PP.sep ds)]
+
+ppArg :: (ABT Term abt) => abt '[] a -> Doc
+ppArg = prettyPrec 11
+
+ppApply1 :: (ABT Term abt) => Int -> String -> abt '[] a -> Docs
+ppApply1 p f e1 = ppFun p f [ppArg e1]
+
+ppApply2
+    :: (ABT Term abt) => Int -> String -> abt '[] a -> abt '[] b -> Docs
+ppApply2 p f e1 e2 = ppFun p f [ppArg e1, ppArg e2]
+
+ppApply
+    :: (ABT Term abt) => Int -> String -> SArgs abt as -> Docs
+ppApply p f es = ppFun p f $ foldMap21 ppBinder es
+
+-- | Something prettier than 'PP.rational'. This works correctly
+-- for both 'Rational' and 'NonNegativeRational', though it may not
+-- work for other @a@ types.
+--
+-- N.B., the resulting string assumes prefix negation and the
+-- 'Fractional' @(/)@ operator are both in scope.
+ppRatio :: (Show a, Integral a) => Int -> Ratio a -> Doc
+ppRatio p r
+    | d == 1    = ppShowS $ showsPrec p n
+    | n < 0     =
+        ppShowS
+        . showParen (p > 7)
+            $ showChar '-' -- TODO: is this guaranteed valid no matter @a@?
+            . showsPrec 8 (negate n)
+            . showChar '/'
+            . showsPrec 8 d
+    | otherwise =
+        ppShowS
+        . showParen (p > 7)
+            $ showsPrec 8 n
+            . showChar '/'
+            . showsPrec 8 d
+    where
+    d = denominator r
+    n = numerator   r
+
+    ppShowS s = PP.text (s [])
+
+    {-
+    -- TODO: we might prefer to use something like:
+    PP.cat [ppIntegral n, PP.char '/' <> ppIntegral d ]
+    where ppIntegral = PP.text . show
+    -}
+
+
+data Associativity = LeftAssoc | RightAssoc | NonAssoc
+
+ppBinop
+    :: (ABT Term abt)
+    => String -> Int -> Associativity
+    -> Int -> abt '[] a -> abt '[] b -> Docs
+ppBinop op p0 assoc =
+    let (p1,p2) =
+            case assoc of
+            LeftAssoc  -> (p0, 1 + p0)
+            RightAssoc -> (1 + p0, p0)
+            NonAssoc   -> (1 + p0, 1 + p0)
+    in \p e1 e2 ->
+        parens (p > p0)
+            [ prettyPrec p1 e1
+            , PP.text op
+                <+> prettyPrec p2 e2
+            ]
+
+header :: [Text.Text]
+header  =
+  [ "{-# LANGUAGE DataKinds, NegativeLiterals #-}"
+  , "module Prog where"
+  , ""
+  , "import           Data.Number.LogFloat (LogFloat)"
+  , "import           Prelude hiding (product, exp, log, (**), pi)"
+  , "import           Language.Hakaru.Runtime.LogFloatPrelude"
+  , "import           Language.Hakaru.Runtime.CmdLine"
+  , "import           Language.Hakaru.Types.Sing"
+  , "import qualified System.Random.MWC                as MWC"
+  , "import           Control.Monad"
+  , "import           System.Environment (getArgs)"
+  , "" ]
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Pretty/Maple.hs b/haskell/Language/Hakaru/Pretty/Maple.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Pretty/Maple.hs
@@ -0,0 +1,393 @@
+{-# LANGUAGE MultiParamTypeClasses
+           , OverloadedStrings
+           , FlexibleInstances
+           , FlexibleContexts
+           , ScopedTypeVariables
+           , CPP
+           , GADTs
+           , TypeFamilies
+           , DataKinds
+           , TypeOperators
+           #-}
+
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.28
+-- |
+-- Module      :  Language.Hakaru.Pretty.Maple
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- TODO: given as the constructed strings will just be printed,
+-- it'd reduce memory pressure a lot to replace our use of 'ShowS'
+-- with a similar builder type for 'Text.Text' (or, if the character
+-- encoding is fixed\/known, a builder type for @ByteString@).
+----------------------------------------------------------------
+module Language.Hakaru.Pretty.Maple (pretty, mapleType) where
+
+import qualified Data.Text           as Text
+import           Data.Ratio
+import           Data.Number.Nat     (fromNat)
+import           Data.Sequence       (Seq)
+import qualified Data.Foldable       as F
+import qualified Data.List.NonEmpty  as L
+import           Control.Monad.State (MonadState(..), State, runState)
+import           Data.Maybe          (isJust)
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+#endif
+
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Expect
+----------------------------------------------------------------
+
+pretty :: (ABT Term abt) => abt '[] a -> String
+pretty = ($[]) . mapleAST . LC_
+
+app1 :: (ABT Term abt) => String -> abt '[] a -> ShowS
+app1 fn x = op1 fn (arg x)
+{-# INLINE app1 #-}
+
+app2 :: (ABT Term abt) => String -> abt '[] a -> abt '[] b -> ShowS
+app2 fn x y = op2 fn (arg x) (arg y)
+{-# INLINE app2 #-}
+
+app3 :: (ABT Term abt)
+    => String -> abt '[] a -> abt '[] b -> abt '[] c -> ShowS
+app3 fn x y z = op3 fn (arg x) (arg y) (arg z)
+{-# INLINE app3 #-}
+
+appN :: (ABT Term abt, Functor f, F.Foldable f)
+    => String -> f (abt '[] a) -> ShowS
+appN fn xs = opN fn (arg <$> xs)
+{-# INLINE appN #-}
+
+op1 ::  String -> ShowS -> ShowS
+op1 fn x = showString fn . parens x
+{-# INLINE op1 #-}
+
+op2 :: String -> ShowS -> ShowS -> ShowS
+op2 fn x y = showString fn . parens (x . showString ", " . y)
+{-# INLINE op2 #-}
+
+op3 :: String -> ShowS -> ShowS -> ShowS -> ShowS
+op3 fn x y z
+    = showString fn
+    . parens
+        ( x
+        . showString ", "
+        . y
+        . showString ", "
+        . z
+        )
+{-# INLINE op3 #-}
+
+opN :: F.Foldable f => String -> f ShowS -> ShowS
+opN fn xs = showString fn . parens (commaSep xs)
+{-# INLINE opN #-}
+
+meq :: (ABT Term abt) => abt '[] a -> abt '[] b -> ShowS
+meq x y = arg x . showChar '=' . parens (arg y)
+{-# INLINE meq #-}
+
+parens :: ShowS -> ShowS
+parens a = showChar '(' . a . showChar ')'
+{-# INLINE parens #-}
+
+brackets :: ShowS -> ShowS
+brackets a = showChar '[' . a . showChar ']'
+{-# INLINE brackets #-}
+
+intercalate :: F.Foldable f => ShowS -> f ShowS -> ShowS
+intercalate sep = F.foldr1 (\a b -> a . sep . b)
+{-# INLINE intercalate #-}
+
+commaSep :: F.Foldable f => f ShowS -> ShowS
+commaSep = intercalate (showString ", ")
+{-# INLINE commaSep #-}
+
+mapleAST :: (ABT Term abt) => LC_ abt a -> ShowS
+mapleAST (LC_ e) =
+    caseVarSyn e var1 $ \t ->
+        case t of
+        o :$ es          -> mapleSCon o  es
+        NaryOp_ op es    -> mapleNary op es
+        Literal_ v       -> mapleLiteral v
+        Empty_ _         -> brackets id
+        Array_ e1 e2     ->
+            caseBind e2 $ \x e2' ->
+                app3 "ary" e1 (var x) e2'
+        ArrayLiteral_ es -> brackets (commaSep (fmap arg es))
+        Datum_ (Datum "true"  _typ (Inl Done)      ) -> showString "true"
+        Datum_ (Datum "false" _typ (Inr (Inl Done))) -> showString "false"
+        Datum_ d         -> mapleDatum d
+        Case_  e'  bs    ->
+            op2 "case" (arg e') (opN "Branches" (mapleBranch <$> bs))
+        Superpose_ pms   ->
+            opN "Msum" (uncurry (app2 "Weight") <$> L.toList pms)
+        Reject_ _        -> showString "Msum()"
+
+
+mapleLiteral :: Literal a -> ShowS
+mapleLiteral (LNat  v) = shows v
+mapleLiteral (LInt  v) = parens (shows v)
+mapleLiteral (LProb v) = showsRational v
+mapleLiteral (LReal v) = showsRational v
+
+showsRational :: (Integral a, Show a) => Ratio a -> ShowS
+showsRational a =
+    parens
+        ( shows (numerator a)
+        . showChar '/'
+        . shows (denominator a)
+        )
+
+
+var1 :: Variable (a :: Hakaru) -> ShowS
+var1 x | Text.null (varHint x) = showChar 'x' . (shows . fromNat . varID) x
+       | otherwise             = quoteName . Text.unpack . varHint $ x
+
+quoteName :: String -> ShowS
+quoteName s =
+  foldr1 (.) $ map showString
+    ["`", concatMap quoteChar s, "`"]
+      where quoteChar '`'  = "\\`"
+            quoteChar '\\' = "\\\\"
+            quoteChar c    = [c]
+
+list1vars :: List1 Variable (vars :: [Hakaru]) -> [String]
+list1vars Nil1         = []
+list1vars (Cons1 x xs) = var1 x [] : list1vars xs
+
+mapleSCon :: (ABT Term abt) => SCon args a -> SArgs abt args -> ShowS
+mapleSCon Lam_ = \(e1 :* End) ->
+    caseBind e1 $ \x e1' ->
+        op3 "lam" (var1 x) (mapleType $ varType x) (arg e1')
+mapleSCon App_ = \(e1 :* e2 :* End) -> app2 "app" e1 e2
+mapleSCon Let_ = \(e1 :* e2 :* End) ->
+    caseBind e2 $ \x e2' ->
+        op2 "eval" (arg e2') (var x `meq` e1)
+mapleSCon (CoerceTo_   _) = \(e :* End) -> arg e
+mapleSCon (UnsafeFrom_ _) = \(e :* End) -> arg e
+mapleSCon (PrimOp_    o) = \es          -> maplePrimOp    o es
+mapleSCon (ArrayOp_   o) = \es          -> mapleArrayOp   o es
+mapleSCon (MeasureOp_ o) = \es          -> mapleMeasureOp o es
+mapleSCon Dirac          = \(e1 :* End) -> app1 "Ret" e1
+mapleSCon MBind          = \(e1 :* e2 :* End) ->
+    caseBind e2 $ \x e2' ->
+        app3 "Bind"  e1 (var x) e2'
+mapleSCon Plate = \(e1 :* e2 :* End) ->
+    caseBind e2 $ \x e2' ->
+        app3 "Plate" e1 (var x) e2'
+mapleSCon Chain = \(e1 :* e2 :* e3 :* End) ->
+    error "TODO: mapleSCon{Chain}"
+mapleSCon Integrate = \(e1 :* e2 :* e3 :* End) ->
+    caseBind e3 $ \x e3' ->
+        showString "Int("
+        . arg e3'
+        . showString ", ["
+        . var1 x
+        . showChar '='
+        . arg e1
+        . showString ".."
+        . arg e2
+        . showString "])"
+mapleSCon (Summate _ _) = \(e1 :* e2 :* e3 :* End) ->
+    caseBind e3 $ \x e3' ->
+        showString "Sum("
+        . arg e3'
+        . showString ", "
+        . var1 x
+        . showChar '='
+        . arg e1
+        . showString "..("
+        . arg e2
+        . showString ")-1)"
+mapleSCon (Product _ _) = \(e1 :* e2 :* e3 :* End) ->
+    caseBind e3 $ \x e3' ->
+        showString "Product("
+        . arg e3'
+        . showString ", "
+        . var1 x
+        . showChar '='
+        . arg e1
+        . showString "..("
+        . arg e2
+        . showString ")-1)"
+
+mapleSCon (Transform_ t) = \_ -> error $
+    concat [ "mapleSCon{", show t, "}"
+           , ": Maple doesn't recognize transforms; expand them first" ]
+
+
+mapleNary :: (ABT Term abt) => NaryOp a -> Seq (abt '[] a) -> ShowS
+mapleNary And      = appN "And"
+mapleNary Or       = appN "Or"
+mapleNary (Sum  _) = parens . intercalate (showString " + ") . fmap arg
+mapleNary (Prod _) = parens . intercalate (showString " * ") . fmap arg
+mapleNary (Min _)  = appN "min"
+mapleNary (Max _)  = appN "max"
+mapleNary op       = error $ "TODO: mapleNary{" ++ show op ++ "}"
+
+
+mapleDatum :: (ABT Term abt) => Datum (abt '[]) t -> ShowS
+mapleDatum (Datum hint _ d) =
+    op2 "Datum"
+        (showString (Text.unpack hint))
+        (mapleDatumCode d)
+
+mapleDatumCode :: (ABT Term abt) => DatumCode xss (abt '[]) a -> ShowS
+mapleDatumCode (Inr d) = op1 "Inr" (mapleDatumCode   d)
+mapleDatumCode (Inl d) = op1 "Inl" (mapleDatumStruct d)
+
+mapleDatumStruct :: (ABT Term abt) => DatumStruct xs (abt '[]) a -> ShowS
+mapleDatumStruct Done       = showString "Done"
+mapleDatumStruct (Et d1 d2) =
+    op2 "Et" (mapleDatumFun d1) (mapleDatumStruct d2)
+
+mapleDatumFun :: (ABT Term abt) => DatumFun x (abt '[]) a -> ShowS
+mapleDatumFun (Konst a) = app1 "Konst" a
+mapleDatumFun (Ident a) = app1 "Ident" a
+
+
+-- TODO: if we really wanted we could create an indexed variant of
+-- 'State' to keep track of the length of the list of variables,
+-- to guarantee the two error cases can never occur.
+mapleBranch :: (ABT Term abt) => Branch a abt b -> ShowS
+mapleBranch (Branch pat e) =
+    let (vars, e')    = caseBinds e
+        (pat', vars') = runState (maplePattern pat) (list1vars vars)
+    in
+    case vars' of
+    _:_ -> error "mapleBranch: didn't use all the variable names"
+    []  -> op2 "Branch" pat' (arg e')
+
+maplePattern :: Pattern xs a -> State [String] ShowS
+maplePattern PWild = return $ showString "PWild"
+maplePattern PVar  = do
+    vs <- get
+    case vs of
+        []    -> error "maplePattern: ran out of variable names"
+        v:vs' -> do
+            put vs'
+            return $ op1 "PVar" (showString v)
+maplePattern (PDatum hint pat) =
+    op2 "PDatum" (showString $ Text.unpack hint) <$> maplePDatumCode pat
+
+maplePDatumCode :: PDatumCode xss vars a -> State [String] ShowS
+maplePDatumCode (PInr pat) = op1 "PInr" <$> maplePDatumCode pat
+maplePDatumCode (PInl pat) = op1 "PInl" <$> maplePDatumStruct pat
+
+maplePDatumStruct :: PDatumStruct xs vars a -> State [String] ShowS
+maplePDatumStruct PDone           = return $ showString "PDone"
+maplePDatumStruct (PEt pat1 pat2) =
+    op2 "PEt"
+        <$> maplePDatumFun    pat1
+        <*> maplePDatumStruct pat2
+
+maplePDatumFun :: PDatumFun x vars a -> State [String] ShowS
+maplePDatumFun (PKonst pat) = op1 "PKonst" <$> maplePattern pat
+maplePDatumFun (PIdent pat) = op1 "PIdent" <$> maplePattern pat
+
+
+arg :: (ABT Term abt) => abt '[] a -> ShowS
+arg = mapleAST . LC_
+
+
+maplePrimOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => PrimOp typs a -> SArgs abt args -> ShowS
+maplePrimOp Not              (e1 :* End)       = app1 "Not" e1
+maplePrimOp Pi               End               = showString "Pi"
+maplePrimOp Cos              (e1 :* End)       = app1 "cos" e1
+maplePrimOp Sin              (e1 :* End)       = app1 "sin" e1
+maplePrimOp RealPow          (e1 :* e2 :* End) =
+    parens (arg e1 . showString " ^ " . arg e2)
+maplePrimOp Choose           (e1 :* e2 :* End) = app2 "binomial" e1 e2
+maplePrimOp Exp              (e1 :* End)       = app1 "exp"  e1
+maplePrimOp Log              (e1 :* End)       = app1 "log"  e1
+maplePrimOp (Infinity  _)    End               = showString "infinity"
+maplePrimOp GammaFunc        (e1 :* End)       = app1 "GAMMA" e1
+maplePrimOp BetaFunc         (e1 :* e2 :* End) = app2 "Beta" e1 e2
+maplePrimOp (Equal _)        (e1 :* e2 :* End) =
+    parens (arg e1 . showString " = " . arg e2)
+maplePrimOp (Less _)         (e1 :* e2 :* End) =
+    arg e1 . showString " < " . arg e2
+maplePrimOp (NatPow _)       (e1 :* e2 :* End) =
+    parens (arg e1 . showString " ^ " . arg e2)
+maplePrimOp (Negate _)       (e1 :* End)       = parens (app1 "-" e1)
+maplePrimOp (Abs _)          (e1 :* End)       = app1 "abs"  e1
+maplePrimOp (Recip   _)      (e1 :* End)       = app1 "1/"   e1
+maplePrimOp (NatRoot _)      (e1 :* e2 :* End) = app2 "root" e1 e2
+maplePrimOp Floor            (e1 :* End)       = app1 "floor"  e1
+maplePrimOp x                _                 =
+    error $ "TODO: maplePrimOp{" ++ show x ++ "}"
+
+mapleArrayOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => ArrayOp typs a -> SArgs abt args -> ShowS
+mapleArrayOp (Index _) (e1 :* e2 :* End) = app2 "idx"  e1 e2
+mapleArrayOp (Size  _) (e1 :* End)       = app1 "size" e1
+mapleArrayOp _         _                 = error "TODO: mapleArrayOp{Reduce}"
+
+mapleMeasureOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => MeasureOp typs a -> SArgs abt args -> ShowS
+mapleMeasureOp Lebesgue    = \(e1 :* e2 :* End) -> app2 "Lebesgue" e1 e2
+mapleMeasureOp Counting    = \End               -> showString "Counting(-infinity,infinity)"
+mapleMeasureOp Categorical = \(e1 :* End)       -> app1 "Categorical" e1
+mapleMeasureOp Uniform     = \(e1 :* e2 :* End) -> app2 "Uniform"  e1 e2
+mapleMeasureOp Normal      = \(e1 :* e2 :* End) -> app2 "Gaussian" e1 e2
+mapleMeasureOp Poisson     = \(e1 :* End)       -> app1 "PoissonD" e1
+mapleMeasureOp Gamma       = \(e1 :* e2 :* End) -> app2 "GammaD"   e1 e2
+mapleMeasureOp Beta        = \(e1 :* e2 :* End) -> app2 "BetaD"    e1 e2
+
+
+----------------------------------------------------------------
+mapleType :: Sing (a :: Hakaru) -> ShowS
+mapleType SNat         = showString "HInt(Bound(`>=`,0))"
+mapleType SInt         = showString "HInt()"
+mapleType SProb        = showString "HReal(Bound(`>=`,0))"
+mapleType SReal        = showString "HReal()"
+mapleType (SFun a b)   = op2 "HFunction" (mapleType a) (mapleType b)
+mapleType (SArray a)   = op1 "HArray"    (mapleType a)
+mapleType (SMeasure a) = op1 "HMeasure"  (mapleType a)
+-- Special case pair
+mapleType (SData (STyCon c `STyApp` _ `STyApp` _) (SPlus x SVoid))
+    | isJust (jmEq1 c sSymbol_Pair)
+    = showString "HData(DatumStruct(pair,["
+    . mapleTypeDStruct x
+    . showString "]))"
+-- Special case unit
+mapleType (SData (STyCon c) (SPlus SDone SVoid))
+    | isJust (jmEq1 c sSymbol_Unit)
+    = showString "HData(DatumStruct(unit,[]))"
+-- Special case bool
+mapleType (SData (STyCon c) (SPlus SDone (SPlus SDone SVoid)))
+    | isJust (jmEq1 c sSymbol_Bool)
+    = showString "HData(DatumStruct(true,[]),DatumStruct(false,[]))"
+mapleType x = error $ "TODO: mapleType{" ++ show x ++ "}"
+
+mapleTypeDStruct :: Sing (a :: [HakaruFun]) -> ShowS
+mapleTypeDStruct SDone      = showString "NULL"
+mapleTypeDStruct (SEt x xs) =
+      mapleTypeDFun x
+    . showString ","
+    . mapleTypeDStruct xs
+
+mapleTypeDFun :: Sing (a :: HakaruFun) -> ShowS
+mapleTypeDFun (SKonst a) = op1 "Konst" (mapleType a)
+mapleTypeDFun SIdent     = showString "Ident"
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Pretty/SExpression.hs b/haskell/Language/Hakaru/Pretty/SExpression.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Pretty/SExpression.hs
@@ -0,0 +1,316 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , KindSignatures
+           , DataKinds
+           , ScopedTypeVariables
+           , PatternGuards
+           , Rank2Types
+           , TypeOperators
+           , FlexibleContexts
+           , UndecidableInstances
+           #-}
+module Language.Hakaru.Pretty.SExpression where
+
+#if __GLASGOW_HASKELL__ < 710
+import Data.Foldable (foldMap)
+import Control.Applicative ((<$>))
+#endif
+
+import Data.Ratio
+import Data.Text (Text)
+import Data.Sequence (Seq)
+
+import qualified Data.Text as Text
+import Data.Number.Nat (fromNat)
+import Data.Number.Natural (fromNonNegativeRational)
+import qualified Data.List.NonEmpty as L
+import Data.Text.IO as IO
+import Language.Hakaru.Command (parseAndInfer)
+import Language.Hakaru.Syntax.IClasses (jmEq1, TypeEq(..))
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Types.Sing
+
+import Language.Hakaru.Summary
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.AST.Transforms
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.TypeCheck
+import Language.Hakaru.Syntax.TypeOf
+import Prelude hiding ((<>))
+import Text.PrettyPrint (Doc, (<>), (<+>))
+import Text.PrettyPrint as PP
+
+pretty :: (ABT Term abt) => abt '[] a -> Doc
+pretty a =
+  PP.brackets (caseVarSyn a prettyVariable prettyTerm <+>
+               PP.colon <+> prettyType (typeOf a))
+
+prettyTerm :: (ABT Term abt) => Term abt a -> Doc
+prettyTerm (o :$ es) = PP.parens $ prettySCons o es
+prettyTerm (NaryOp_ op es) = PP.parens $ prettyNary op es
+prettyTerm (Literal_ v) = prettyLiteral v
+prettyTerm (Array_ e1 e2) =
+  PP.parens $ (PP.text "array") <+>
+  (caseBind e2 $ \x e2' ->
+                   PP.parens (prettyVariable x <+> pretty e1) <+>
+                   pretty e2')
+prettyTerm (Case_ e1 bs) =
+  PP.parens $ PP.text "match" <+> pretty e1 <+>
+  Prelude.foldl (<+>) PP.empty (prettyBranch <$> bs)
+prettyTerm (Bucket b e r) =
+  PP.parens $ ( PP.text "bucket" <+> pretty b <+> pretty e <+> prettyReducer r)
+prettyTerm (Reject_ _) = PP.parens $ PP.text "reject"
+prettyTerm (Empty_ _) = PP.parens $ PP.text "empty"
+prettyTerm (ArrayLiteral_ es) = PP.parens $ (PP.text "array-literal" <+> foldMap pretty es)
+prettyTerm (Superpose_ pes) =
+  case pes of
+    (e1,e2) L.:| [] ->
+      PP.parens $
+      (PP.text "pose" <+> pretty e1 <+> pretty e2)
+    _ ->
+      PP.parens $
+      (PP.text "superpose" <+> foldMap (\(e1,e2) -> PP.parens (pretty e1 <+> pretty e2)) (L.toList pes))
+
+-- prettyTerm (Datum_ (Datum "true" _typ (Inl Done))) = PP.text "#t"
+-- prettyTerm (Datum_ (Datum "false" _typ (Inr (Inl Done)))) = PP.text "#f"
+prettyTerm (Datum_ d) = prettyDatum d
+
+prettyDatum :: (ABT Term abt) => Datum (abt '[]) t -> Doc
+prettyDatum (Datum hint _ d) =
+  PP.parens $
+  PP.text "datum" <+>
+  (PP.text (Text.unpack hint)) <+>
+  (prettyDatumCode d)
+
+prettyDatumCode :: (ABT Term abt) => DatumCode xss (abt '[]) a -> Doc
+prettyDatumCode (Inr d) = PP.parens $ PP.text "inr" <+> (prettyDatumCode d)
+prettyDatumCode (Inl d) = PP.parens $ PP.text "inl" <+> (prettyDatumStruct d)
+
+prettyDatumStruct :: (ABT Term abt) => DatumStruct xs (abt '[]) a -> Doc
+prettyDatumStruct Done       = PP.text "done"
+prettyDatumStruct (Et d1 d2) =
+    PP.parens $ PP.text "et" <+> (prettyDatumFun d1) <+> (prettyDatumStruct d2)
+
+prettyDatumFun :: (ABT Term abt) => DatumFun x (abt '[]) a -> Doc
+prettyDatumFun (Konst a) = PP.parens $ PP.text "konst" <+> pretty a
+prettyDatumFun (Ident a) = PP.parens $ PP.text "ident" <+> pretty a
+
+
+
+prettyReducer :: (ABT Term abt) => Reducer abt xs a -> Doc
+prettyReducer (Red_Fanout red_a red_b) =
+  PP.parens (PP.text "r_fanout" <+> prettyReducer red_a <+> prettyReducer red_b)
+prettyReducer (Red_Index i red_i red_a) =
+  PP.parens (PP.text "r_index" <+> prettyViewABT i <+>
+             prettyViewABT red_i <+> prettyReducer red_a)
+prettyReducer (Red_Split i red_a red_b) =
+  PP.parens (PP.text "r_split" <+> prettyViewABT i <+>
+            prettyReducer red_a <+> prettyReducer red_b)
+prettyReducer (Red_Nop) = PP.text "r_nop"
+prettyReducer (Red_Add _ a) =
+  PP.parens (PP.text "r_add" <+> prettyViewABT a)
+
+prettyBranch :: (ABT Term abt) => Branch a abt b -> Doc
+prettyBranch (Branch pat e) =
+  PP.parens $ prettyPattern pat <+> prettyViewABT e
+
+prettyPattern :: Pattern xs a -> Doc
+prettyPattern PWild = PP.text "*"
+prettyPattern PVar = PP.text "var"
+prettyPattern (PDatum hint c) =
+  PP.parens $ PP.text "pdatum" <+> PP.text (Text.unpack hint) <+> goCode c
+goCode :: PDatumCode xss vars a -> Doc
+goCode c = PP.parens $ case c of
+  (PInr d) -> PP.text "pc_inr" <+> goCode d
+  (PInl s) -> PP.text "pc_inl" <+> goStruct s
+goStruct :: PDatumStruct xs vars a -> Doc
+goStruct s = PP.parens $ case s of
+  (PDone) -> PP.text "ps_done"
+  (PEt f s') -> PP.text "ps_et" <+> goFun f <+> goStruct s'
+goFun :: PDatumFun x vars a -> Doc
+goFun f = PP.parens $ case f of
+  (PKonst p) -> PP.text "pf_konst" <+> prettyPattern p
+  (PIdent p) -> PP.text "pf_ident" <+> prettyPattern p
+
+
+prettyViewABT :: (ABT Term abt) => abt xs a -> Doc
+prettyViewABT = prettyView . viewABT
+
+prettyView :: (ABT Term abt) => View (Term abt) xs a -> Doc
+prettyView (Bind x v) =
+  PP.parens $ PP.text "bind" <+> prettyVariable x <+> prettyView v
+prettyView (Var x) = prettyVariable x
+prettyView (Syn t) = pretty (syn t)
+
+prettyShow :: (Show a) => a -> Doc
+prettyShow = PP.text . show
+
+prettyLiteral :: Literal a -> Doc
+prettyLiteral (LNat v) = PP.parens $ PP.text "nat_" <+> prettyShow v
+prettyLiteral (LInt i) = PP.parens $ PP.text "int_" <+> prettyShow i
+prettyLiteral (LProb p) = PP.parens $ PP.text "prob_" <+> PP.rational (fromNonNegativeRational p)
+prettyLiteral (LReal p) = PP.parens $ PP.text "real_" <+> PP.rational p
+
+
+prettyRatio :: (Show a, Integral a) => Ratio a -> Doc
+prettyRatio r
+  | d == 1 = prettyShow n
+  | otherwise = PP.parens $ PP.text "/" <+> prettyShow n <+> prettyShow d
+    where
+      d = denominator r
+      n = numerator r
+
+prettyVariable :: Variable (a :: Hakaru) -> Doc
+prettyVariable x | Text.null (varHint x) = PP.text "_" <> (PP.int . fromNat .varID) x
+                 | otherwise = (PP.text . Text.unpack . varHint) x
+
+prettySCons :: (ABT Term abt) => SCon args a -> SArgs abt args -> Doc
+prettySCons Lam_ (e1 :* End) = caseBind e1 $ \x e1' ->
+  PP.text "fn" <+> prettyVariable x  <+> (prettyType $ typeOf e1')
+  <+> pretty e1'
+prettySCons (PrimOp_ o) es = prettyPrimOp o es
+prettySCons (ArrayOp_ o) es = prettyArrayOp o es
+prettySCons (CoerceTo_ o) (e1 :* End) = PP.text (pCoerce o) <+> pretty e1
+prettySCons (Summate _ _) (e1 :* e2 :* e3 :* End) =
+  caseBind e3 $ \x e3' -> PP.text "summate" <+>
+                          PP.parens (prettyVariable x <+> pretty e1 <+> pretty e2) <+>
+                          pretty e3'
+prettySCons (Product _ _) (e1 :* e2 :* e3 :* End) =
+  caseBind e3 $ \x e3' -> PP.text "product" <+>
+                          PP.parens (prettyVariable x <+> pretty e1 <+> pretty e2) <+>
+                          pretty e3'
+prettySCons App_ (e1 :* e2 :* End) = PP.text "app" <+> pretty e1 <+> pretty e2
+prettySCons Let_ (e1 :* e2 :* End) = caseBind e2 $ \x e2' ->
+  PP.text "let" <+>
+  PP.parens (prettyVariable x <+> (prettyType $ typeOf e1) <+> pretty e1)
+  <+> pretty e2'
+prettySCons (UnsafeFrom_ o) (e :* End) = PP.text (pUnsafeCoerce o) <+> pretty e
+prettySCons (MeasureOp_ o) es = prettyMeasureOp o es
+prettySCons Dirac (e1 :* End) = PP.text "dirac" <+> pretty e1
+prettySCons MBind (e1 :* e2 :* End) = PP.text "mbind" <+> pretty e1 <+> prettyViewABT e2
+prettySCons Plate (e1 :* e2 :* End) = PP.text "plate" <+> pretty e1 <+> prettyViewABT e2
+prettySCons Chain (e1 :* e2 :* e3 :* End) = PP.text "chain" <+> pretty e1 <+> pretty e2 <+> prettyViewABT e3
+prettySCons Integrate (e1 :* e2 :* e3 :* End) = PP.text "integrate" <+> pretty e1 <+> pretty e2 <+> prettyViewABT e3
+prettySCons (Transform_ t) _ = PP.text $
+     Prelude.concat [ "SCons{", show t, "}: TODO" ]
+
+prettyMeasureOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => MeasureOp typs a -> SArgs abt args -> Doc
+prettyMeasureOp Lebesgue    = \(e1 :* e2 :* End)          -> PP.text "lebesgue" <+> pretty e1 <+> pretty e2
+prettyMeasureOp Counting    = \End           -> PP.text "counting"
+prettyMeasureOp Categorical = \(e1 :* End)   -> PP.text "categorical" <+> pretty e1
+prettyMeasureOp Uniform = \(e1 :* e2 :* End) -> PP.text "uniform"     <+> pretty e1 <+> pretty e2
+prettyMeasureOp Normal  = \(e1 :* e2 :* End) -> PP.text "normal"      <+> pretty e1 <+> pretty e2
+prettyMeasureOp Poisson = \(e1 :* End)       -> PP.text "poisson"     <+> pretty e1
+prettyMeasureOp Gamma   = \(e1 :* e2 :* End) -> PP.text "gamma"       <+> pretty e1 <+> pretty e2
+prettyMeasureOp Beta    = \(e1 :* e2 :* End) -> PP.text "beta"        <+> pretty e1 <+> pretty e2
+
+pUnsafeCoerce :: Coercion a b -> String
+pUnsafeCoerce (CCons (Signed HRing_Real) CNil) = "real2prob"
+pUnsafeCoerce (CCons (Signed HRing_Int)  CNil) = "int2nat"
+pUnsafeCoerce c = "unsafeFrom_" ++ show c
+
+pCoerce :: Coercion a b -> String
+pCoerce (CCons (Signed HRing_Real) CNil)             = "prob2real"
+pCoerce (CCons (Signed HRing_Int)  CNil)             = "nat2int"
+pCoerce (CCons (Continuous HContinuous_Real) CNil)   = "int2real"
+pCoerce (CCons (Continuous HContinuous_Prob) CNil)   = "nat2prob"
+pCoerce (CCons (Continuous HContinuous_Prob)
+         (CCons (Signed HRing_Real) CNil))           = "nat2real"
+pCoerce (CCons (Signed HRing_Int)
+         (CCons (Continuous HContinuous_Real) CNil)) = "nat2real"
+pCoerce c = "coerceTo_"++show c
+
+
+prettyNary :: (ABT Term abt) => NaryOp a -> Seq (abt '[] a) -> Doc
+prettyNary And       es      = PP.text "and" <+> foldMap pretty es
+prettyNary Or        es      = PP.text "or" <+> foldMap pretty es
+prettyNary Xor       es      = PP.text "xor" <+> foldMap pretty es
+prettyNary (Sum  _)  es      = PP.text "+" <+> foldMap pretty es
+prettyNary (Prod  _) es      = PP.text "*" <+> foldMap pretty es
+prettyNary (Min  _)  es      = PP.text "min" <+> foldMap pretty es
+prettyNary (Max  _)  es      = PP.text "max" <+> foldMap pretty es
+prettyNary _         _       = error "Pretty.SExpression - prettyNary missing cases"
+
+prettyType :: Sing (a :: Hakaru) -> Doc
+prettyType SNat         = PP.text "nat"
+prettyType SInt         = PP.text "int"
+prettyType SProb        = PP.text "prob"
+prettyType SReal        = PP.text "real"
+prettyType (SArray a)   = PP.parens $ PP.text "array" <+> prettyType a
+prettyType (SMeasure a) = PP.parens $ PP.text "measure" <+> prettyType a
+prettyType (SFun a b)   = PP.parens $ prettyType a <+> PP.text "->" <+> prettyType b
+prettyType typ =
+    case typ of
+    SData (STyCon sym `STyApp` a `STyApp` b) _
+      | Just Refl <- jmEq1 sym sSymbol_Pair
+      -> PP.parens $ PP.text "pair" <+> prettyType a <+> prettyType b
+      | Just Refl <- jmEq1 sym sSymbol_Either
+      -> PP.parens $ PP.text "either" <+> prettyType a <+> prettyType b
+    SData (STyCon sym `STyApp` a) _
+      | Just Refl <- jmEq1 sym sSymbol_Maybe
+      -> PP.parens $ PP.text "maybe" <+> prettyType a
+    SData (STyCon sym) _
+      | Just Refl <- jmEq1 sym sSymbol_Bool
+      -> PP.text "bool"
+      | Just Refl <- jmEq1 sym sSymbol_Unit
+      -> PP.text "unit"
+    _ -> PP.text (showsPrec 11 typ "")
+
+prettyPrimOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => PrimOp typs a -> SArgs abt args -> Doc
+prettyPrimOp Not              (e1 :* End)       = PP.text "not" <+> pretty e1
+prettyPrimOp Pi               End               = PP.text "pi"
+prettyPrimOp Sin              (e1 :* End)       = PP.text "sin" <+> pretty e1
+prettyPrimOp Cos              (e1 :* End)       = PP.text "cos" <+> pretty e1
+prettyPrimOp Tan              (e1 :* End)       = PP.text "tan" <+> pretty e1
+prettyPrimOp RealPow          (e1 :* e2 :* End) = PP.text "realpow" <+> pretty e1 <+> pretty e2
+prettyPrimOp Choose           (e1 :* e2 :* End) = PP.text "choose" <+> pretty e1 <+> pretty e2
+prettyPrimOp Exp              (e1 :* End)       = PP.text "exp"  <+> pretty e1
+prettyPrimOp Log              (e1 :* End)       = PP.text "log"  <+> pretty e1
+prettyPrimOp (Infinity  _)    End               = PP.text "infinity"
+prettyPrimOp GammaFunc        (e1 :* End)       = PP.text "gammafunc" <+> pretty e1
+prettyPrimOp BetaFunc         (e1 :* e2 :* End) = PP.text "betafunc" <+> pretty e1 <+> pretty e2
+prettyPrimOp (Equal _)        (e1 :* e2 :* End) = PP.text "==" <+> pretty e1 <+> pretty e2
+prettyPrimOp (Less _)         (e1 :* e2 :* End) = PP.text "<" <+> pretty e1 <+> pretty e2
+prettyPrimOp (NatPow _)       (e1 :* e2 :* End) = PP.text "natpow" <+> pretty e1 <+> pretty e2
+prettyPrimOp (Negate _)       (e1 :* End)       = PP.text "negate" <+> pretty e1
+prettyPrimOp (Abs _)          (e1 :* End)       = PP.text "abs"  <+> pretty e1
+prettyPrimOp (Recip   _)      (e1 :* End)       = PP.text "recip" <+> pretty e1
+prettyPrimOp (NatRoot _)      (e1 :* e2 :* End) = PP.text "root" <+> pretty e1 <+> pretty e2
+prettyPrimOp Floor            (e1 :* End)       = PP.text "floor" <+> pretty e1
+prettyPrimOp _                _                 = error "prettyPrimop: a bunch of cases still need done!"
+
+prettyArrayOp
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => ArrayOp typs a -> SArgs abt args -> Doc
+prettyArrayOp (Index _) (e1 :* e2 :* End) = PP.text "index" <+> pretty e1 <+> pretty e2
+prettyArrayOp (Size  _) (e1 :* End)       = PP.text "size" <+> pretty e1
+prettyArrayOp (Reduce _) _                 = error "prettyArrayOp doesn't know how to print Reduce"
+
+prettyFile' :: [Char] -> [Char] -> IO ()
+prettyFile' fname outFname = do
+  fileText <- IO.readFile fname
+  prettyText <- runPretty' fileText
+  IO.writeFile outFname (Text.pack prettyText)
+  print prettyText
+
+runPretty' :: Text -> IO String
+runPretty' prog =
+    case parseAndInfer prog of
+    Left  _                -> return "err"
+    Right (TypedAST _ ast) -> do
+      summarised <- summary . expandTransformations $ ast
+      return . render . pretty $ summarised
+
+fromAst :: Either Text (TypedAST (TrivialABT Term)) -> String
+fromAst prog =
+    case prog of
+    Left  err              -> Text.unpack err
+    Right (TypedAST _ ast) -> render . pretty . expandTransformations $ ast
diff --git a/haskell/Language/Hakaru/Repl.hs b/haskell/Language/Hakaru/Repl.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Repl.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , OverloadedStrings
+           , FlexibleContexts
+           , GADTs
+           , RankNTypes
+           #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Language.Hakaru.Repl where
+
+
+import           Language.Hakaru.Types.Sing
+import           Language.Hakaru.Syntax.ABT
+import qualified Language.Hakaru.Syntax.AST as T
+import           Language.Hakaru.Syntax.AST.Transforms
+import           Language.Hakaru.Syntax.Variable ()
+import qualified Language.Hakaru.Parser.AST as U
+import           Language.Hakaru.Parser.Parser (parseHakaru, parseReplLine)
+import           Language.Hakaru.Parser.SymbolResolve (resolveAST)
+import           Language.Hakaru.Pretty.Concrete
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Sample
+import           Language.Hakaru.Syntax.Value
+
+import           Control.Monad.State.Strict (StateT, evalStateT, get, modify)
+import           Control.Monad.IO.Class
+import           Data.List (intercalate)
+import qualified Data.Text      as Text
+import qualified Data.Text.IO   as IO
+import qualified Data.Vector    as V
+import           Text.PrettyPrint (renderStyle, style, mode, Mode(LeftMode))
+import qualified System.Random.MWC as MWC
+import           System.Console.Repline
+
+type Binding = (U.AST' Text.Text -> U.AST' Text.Text)
+type ReplM = HaskelineT (StateT Binding IO)
+
+initialReplState :: Binding
+initialReplState = id
+
+extendBindings :: Binding -> Binding -> Binding
+extendBindings = flip (.)
+
+triv :: TrivialABT T.Term '[] a -> TrivialABT T.Term '[] a
+triv = id
+
+app1 :: a -> U.AST' a -> U.AST' a
+app1 s x = U.Var s `U.App` x
+       
+resolveAndInfer :: U.AST' Text.Text
+              -> Either Text.Text (TypedAST (TrivialABT T.Term))
+resolveAndInfer x = resolveAndInferWithMode x LaxMode
+
+resolveAndInferWithMode
+  :: ABT T.Term abt
+  => U.AST' Text.Text
+  -> TypeCheckMode
+  -> Either Text.Text (TypedAST abt)
+resolveAndInferWithMode x mode' =
+    let m = inferType (resolveAST x) in
+    runTCM m Nothing mode'
+
+               
+splitLines :: Text.Text -> Maybe (V.Vector Text.Text)
+splitLines = Just . V.fromList . Text.lines
+
+whenE :: MonadIO m => Either Text.Text b -> m () -> m ()
+whenE (Left  err) _ = liftIO $ IO.putStrLn err
+whenE (Right _)   m = m 
+             
+illustrate :: Sing a -> MWC.GenIO -> Value a -> IO ()
+illustrate (SMeasure s) g (VMeasure m) = do
+    x <- m (VProb 1) g
+    case x of
+      Just (samp, _) -> illustrate s g samp
+      Nothing        -> illustrate (SMeasure s) g (VMeasure m)
+
+illustrate _ _ x = renderLn x
+
+renderLn :: Value a -> IO ()
+renderLn = putStrLn . renderStyle style {mode = LeftMode} . prettyValue
+             
+runOnce :: MWC.GenIO -> U.AST' Text.Text -> IO ()
+runOnce g prog =
+  case resolveAndInfer prog of
+    Left err -> IO.putStrLn err
+    Right (TypedAST typ ast) ->
+        illustrate typ g (runEvaluate ast)
+
+type_ :: Cmd ReplM
+type_ prog =
+    case parseHakaru (Text.pack prog) of
+      Left err -> liftIO $ putStrLn (show err)
+      Right e  -> do
+        bindings <- get
+        let prog' = bindings (app1 "dirac" e)
+        case resolveAndInfer prog' of
+          Left err -> liftIO $ IO.putStrLn err
+          Right (TypedAST (SMeasure typ) _) -> liftIO $ putStrLn (prettyTypeS typ)
+          _        -> liftIO $ putStrLn "the impossible happened"
+                   
+initM :: ReplM ()
+initM = liftIO $ putStrLn introBanner
+                   
+-- Evaluation
+
+-- No Typechecking of bindings
+cmd :: MWC.GenIO -> String -> ReplM ()
+cmd g x =
+    case parseReplLine (Text.pack x) of
+      Left err         -> liftIO $ putStrLn (show err)
+      Right (Left b)   -> modify (extendBindings b) 
+      Right (Right e)  -> do
+        bindings <- get
+        let prog' = bindings (app1 "dirac" e)
+        liftIO $ runOnce g prog'
+
+
+-- Typecheck bindings before adding them
+cmd2 :: MWC.GenIO -> Cmd ReplM
+cmd2 g x =
+    case parseReplLine (Text.pack x) of
+      Left err  -> liftIO $ putStrLn (show err)
+      Right e   -> do
+        bindings <- get
+        case e of
+          Left b   -> let prog = bindings . b $ (app1 "dirac" U.Unit) in
+                      whenE (resolveAndInfer prog) (modify $ extendBindings b)
+          Right e' -> let prog = bindings (app1 "dirac" e') in
+                      liftIO $ runOnce g prog
+               
+repl :: MWC.GenIO -> IO ()
+repl g = flip evalStateT initialReplState
+        $ evalReplOpts $ ReplOpts
+         { banner           = const (pure ">>> ")
+         , command          = cmd2 g
+         , options          = opts
+         , prefix           = Just ':'
+         , multilineCommand = Nothing
+         , tabComplete      = (Word comp)
+         , initialiser      = initM
+         , finaliser        = return Exit
+         }
+
+                   
+-- Completion
+comp :: Monad m => WordCompleter m
+comp = listWordCompleter [":help", ":expand", ":hist", ":type"]
+
+-- Commands
+help :: Cmd ReplM
+help _ = liftIO $ putStrLn "Help!"
+
+expand :: Cmd ReplM
+expand prog =
+    case parseReplLine (Text.pack prog) of
+      Left err         -> liftIO $ putStrLn (show err)
+      Right (Left b)   -> modify (extendBindings b) 
+      Right (Right e)  -> do
+        bindings <- get
+        let prog' = bindings e
+        case resolveAndInfer prog' of
+          Left err -> liftIO $ IO.putStrLn err
+          Right (TypedAST _ ast) -> liftIO $ print (pretty (expandTransformations ast))
+
+
+hist :: Cmd ReplM
+hist = undefined
+
+opts :: Options ReplM
+opts = [
+    ("help", help),
+    ("expand", expand),
+    ("hist", hist),
+    ("type", type_)
+  ]
+
+introBanner :: String
+introBanner = unlines
+  ["    __  __      __",
+   "   / / / /___ _/ /______ ________  __",
+   "  / /_/ / __ `/ //_/ __ `/ ___/ / / /",
+   " / __  / /_/ / ,< / /_/ / /  / /_/ /",
+   "/_/ /_/\\__,_/_/|_|\\__,_/_/   \\__,_/"
+  ]
+
+main :: IO ()
+main = MWC.createSystemRandom >>= repl
diff --git a/haskell/Language/Hakaru/Runtime/CmdLine.hs b/haskell/Language/Hakaru/Runtime/CmdLine.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Runtime/CmdLine.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE CPP,
+             FlexibleContexts,
+             FlexibleInstances,
+             UndecidableInstances,
+             TypeFamilies #-}
+module Language.Hakaru.Runtime.CmdLine where
+
+import qualified Data.Vector.Unboxed             as U
+import qualified System.Random.MWC               as MWC
+import           Control.Monad                   (liftM, ap, forever)
+
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor
+import           Control.Applicative             (Applicative(..))
+#endif
+
+newtype Measure a = Measure { unMeasure :: MWC.GenIO -> IO (Maybe a) }
+
+instance Functor Measure where
+    fmap  = liftM
+    {-# INLINE fmap #-}
+
+instance Applicative Measure where
+    pure x = Measure $ \_ -> return (Just x)
+    {-# INLINE pure #-}
+    (<*>)  = ap
+    {-# INLINE (<*>) #-}
+
+instance Monad Measure where
+    return  = pure
+    {-# INLINE return #-}
+    m >>= f = Measure $ \g -> do
+                          Just x <- unMeasure m g
+                          unMeasure (f x) g
+    {-# INLINE (>>=) #-}
+
+makeMeasure :: (MWC.GenIO -> IO a) -> Measure a
+makeMeasure f = Measure $ \g -> Just <$> f g
+{-# INLINE makeMeasure #-}
+
+-- A class of types that can be parsed from command line arguments
+class Parseable a where
+  parse :: String -> IO a
+
+instance Parseable Int where
+  parse = return . read
+
+instance Parseable Double where
+  parse = return . read
+
+instance (U.Unbox a, Parseable a) => Parseable (U.Vector a) where
+  parse s = U.fromList <$> ((mapM parse) =<< (lines <$> readFile s))
+
+instance (Read a, Read b) => Parseable (a, b) where
+  parse = return . read
+
+{- Make main needs to recur down the function type while at the term level build
+-- up a continuation of parses and partial application of the function
+-}
+class MakeMain p where
+  makeMain :: p -> [String] -> IO ()
+
+instance {-# OVERLAPPABLE #-}
+         Show a => MakeMain a where
+  makeMain p _ = print p
+
+instance Show a => MakeMain (Measure a) where
+  makeMain p _ = MWC.createSystemRandom >>= \gen ->
+                   forever $ do
+                     ms <- unMeasure p gen
+                     case ms of
+                       Nothing -> return ()
+                       Just s  -> print s
+
+instance (Parseable a, MakeMain b)
+         => MakeMain (a -> b) where
+  makeMain p (a:as) = do a' <- parse a
+                         makeMain (p a') as
+  makeMain _ [] = error "not enough arguments"
diff --git a/haskell/Language/Hakaru/Runtime/LogFloatPrelude.hs b/haskell/Language/Hakaru/Runtime/LogFloatPrelude.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Runtime/LogFloatPrelude.hs
@@ -0,0 +1,459 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , Rank2Types
+           , DataKinds
+           , TypeFamilies
+           , FlexibleContexts
+           , UndecidableInstances
+           , LambdaCase
+           , MultiParamTypeClasses
+           , OverloadedStrings
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs -fsimpl-tick-factor=1000 -fno-warn-orphans #-}
+module Language.Hakaru.Runtime.LogFloatPrelude where
+
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor                    ((<$>))
+import           Control.Applicative             (Applicative(..))
+#endif
+import           Data.Foldable                   as F
+import qualified System.Random.MWC               as MWC
+import qualified System.Random.MWC.Distributions as MWCD
+import           Data.Number.Natural
+import           Data.Number.LogFloat            hiding (sum, product)
+import qualified Data.Number.LogFloat            as LF
+import           Data.STRef
+import qualified Data.Vector                     as V
+import qualified Data.Vector.Unboxed             as U
+import qualified Data.Vector.Generic             as G
+import qualified Data.Vector.Generic.Mutable     as M
+import           Control.Monad
+import           Control.Monad.ST
+import           Numeric.SpecFunctions           (logBeta)
+import           Prelude                         hiding (init, sum, product, exp, log, (**), pi)
+import qualified Prelude                         as P
+import           Language.Hakaru.Runtime.CmdLine (Parseable(..), Measure(..), makeMeasure)
+
+-- This Read instance really should be the logfloat package
+instance Read LogFloat where
+    readsPrec p s = [(logFloat x, r) | (x, r) <- readsPrec p s]
+
+instance Parseable LogFloat where
+  parse = return . read
+
+type family MinBoxVec (v1 :: * -> *) (v2 :: * -> *) :: * -> *
+type instance MinBoxVec V.Vector v        = V.Vector
+type instance MinBoxVec v        V.Vector = V.Vector
+type instance MinBoxVec U.Vector U.Vector = U.Vector
+
+type family MayBoxVec a :: * -> *
+type instance MayBoxVec ()           = U.Vector
+type instance MayBoxVec Int          = U.Vector
+type instance MayBoxVec Double       = U.Vector
+type instance MayBoxVec LogFloat     = U.Vector
+type instance MayBoxVec Bool         = U.Vector
+type instance MayBoxVec (U.Vector a) = V.Vector
+type instance MayBoxVec (V.Vector a) = V.Vector
+type instance MayBoxVec (a,b)        = MinBoxVec (MayBoxVec a) (MayBoxVec b)
+
+newtype instance U.MVector s LogFloat = MV_LogFloat (U.MVector s Double)
+newtype instance U.Vector    LogFloat = V_LogFloat  (U.Vector    Double)
+
+instance U.Unbox LogFloat
+
+instance M.MVector U.MVector LogFloat where
+  {-# INLINE basicLength #-}
+  {-# INLINE basicUnsafeSlice #-}
+  {-# INLINE basicOverlaps #-}
+  {-# INLINE basicUnsafeNew #-}
+#if __GLASGOW_HASKELL__ > 710
+  {-# INLINE basicInitialize #-}
+#endif
+  {-# INLINE basicUnsafeReplicate #-}
+  {-# INLINE basicUnsafeRead #-}
+  {-# INLINE basicUnsafeWrite #-}
+  {-# INLINE basicClear #-}
+  {-# INLINE basicSet #-}
+  {-# INLINE basicUnsafeCopy #-}
+  {-# INLINE basicUnsafeGrow #-}
+  basicLength (MV_LogFloat v) = M.basicLength v
+  basicUnsafeSlice i n (MV_LogFloat v) = MV_LogFloat $ M.basicUnsafeSlice i n v
+  basicOverlaps (MV_LogFloat v1) (MV_LogFloat v2) = M.basicOverlaps v1 v2
+  basicUnsafeNew n = MV_LogFloat `liftM` M.basicUnsafeNew n
+#if __GLASGOW_HASKELL__ > 710
+  basicInitialize (MV_LogFloat v) = M.basicInitialize v
+#endif
+  basicUnsafeReplicate n x = MV_LogFloat `liftM` M.basicUnsafeReplicate n (logFromLogFloat x)
+  basicUnsafeRead (MV_LogFloat v) i = logToLogFloat `liftM` M.basicUnsafeRead v i
+  basicUnsafeWrite (MV_LogFloat v) i x = M.basicUnsafeWrite v i (logFromLogFloat x)
+  basicClear (MV_LogFloat v) = M.basicClear v
+  basicSet (MV_LogFloat v) x = M.basicSet v (logFromLogFloat x)
+  basicUnsafeCopy (MV_LogFloat v1) (MV_LogFloat v2) = M.basicUnsafeCopy v1 v2
+  basicUnsafeMove (MV_LogFloat v1) (MV_LogFloat v2) = M.basicUnsafeMove v1 v2
+  basicUnsafeGrow (MV_LogFloat v) n = MV_LogFloat `liftM` M.basicUnsafeGrow v n
+
+instance G.Vector U.Vector LogFloat where
+  {-# INLINE basicUnsafeFreeze #-}
+  {-# INLINE basicUnsafeThaw #-}
+  {-# INLINE basicLength #-}
+  {-# INLINE basicUnsafeSlice #-}
+  {-# INLINE basicUnsafeIndexM #-}
+  {-# INLINE elemseq #-}
+  basicUnsafeFreeze (MV_LogFloat v) = V_LogFloat `liftM` G.basicUnsafeFreeze v
+  basicUnsafeThaw (V_LogFloat v) = MV_LogFloat `liftM` G.basicUnsafeThaw v
+  basicLength (V_LogFloat v) = G.basicLength v
+  basicUnsafeSlice i n (V_LogFloat v) = V_LogFloat $ G.basicUnsafeSlice i n v
+  basicUnsafeIndexM (V_LogFloat v) i
+                = logToLogFloat `liftM` G.basicUnsafeIndexM v i
+  basicUnsafeCopy (MV_LogFloat mv) (V_LogFloat v)
+                = G.basicUnsafeCopy mv v
+  elemseq _ x z = G.elemseq (undefined :: U.Vector a) (logFromLogFloat x) z
+
+type Prob = LogFloat
+
+lam :: (a -> b) -> a -> b
+lam = id
+{-# INLINE lam #-}
+
+app :: (a -> b) -> a -> b
+app f x = f x
+{-# INLINE app #-}
+
+let_ :: a -> (a -> b) -> b
+let_ x f = let x1 = x in f x1
+{-# INLINE let_ #-}
+
+ann_ :: a -> b -> b
+ann_ _ a = a
+{-# INLINE ann_ #-}
+
+exp :: Double -> Prob
+exp = logToLogFloat
+{-# INLINE exp #-}
+
+log :: Prob -> Double
+log = logFromLogFloat
+{-# INLINE log #-}
+
+betaFunc :: Prob -> Prob -> Prob
+betaFunc a b = exp (logBeta (fromProb a) (fromProb b))
+
+uniform :: Double -> Double -> Measure Double
+uniform lo hi = makeMeasure $ MWC.uniformR (lo, hi)
+{-# INLINE uniform #-}
+
+normal :: Double -> Prob -> Measure Double
+normal mu sd = makeMeasure $ MWCD.normal mu (fromProb sd)
+{-# INLINE normal #-}
+
+beta :: Prob -> Prob -> Measure Prob
+beta a b = makeMeasure $ \g ->
+  unsafeProb <$> MWCD.beta (fromProb a) (fromProb b) g
+{-# INLINE beta #-}
+
+gamma :: Prob -> Prob -> Measure Prob
+gamma a b = makeMeasure $ \g ->
+  unsafeProb <$> MWCD.gamma (fromProb a) (fromProb b) g
+{-# INLINE gamma #-}
+
+categorical :: MayBoxVec Prob Prob -> Measure Int
+categorical a = makeMeasure $ MWCD.categorical (U.map prep a)
+  where prep p = fromLogFloat (p / m)
+        m      = G.maximum a
+{-# INLINE categorical #-}
+
+plate :: (G.Vector (MayBoxVec a) a) =>
+         Int -> (Int -> Measure a) -> Measure (MayBoxVec a a)
+plate n f = G.generateM (fromIntegral n) $ \x ->
+             f (fromIntegral x)
+{-# INLINE plate #-}
+
+bucket :: Int -> Int -> (forall s. Reducer () s a) -> a
+bucket b e r = runST
+             $ case r of Reducer{init=initR,accum=accumR,done=doneR} -> do
+                          s' <- initR ()
+                          F.mapM_ (\i -> accumR () i s') [b .. e - 1]
+                          doneR s'
+{-# INLINE bucket #-}
+
+data Reducer xs s a =
+    forall cell.
+    Reducer { init  :: xs -> ST s cell
+            , accum :: xs -> Int -> cell -> ST s ()
+            , done  :: cell -> ST s a
+            }
+
+r_fanout :: Reducer xs s a
+         -> Reducer xs s b
+         -> Reducer xs s (a,b)
+r_fanout Reducer{init=initA,accum=accumA,done=doneA}
+         Reducer{init=initB,accum=accumB,done=doneB} = Reducer
+   { init  = \xs       -> liftM2 (,) (initA xs) (initB xs)
+   , accum = \bs i (s1, s2) ->
+             accumA bs i s1 >> accumB bs i s2
+   , done  = \(s1, s2) -> liftM2 (,) (doneA s1) (doneB s2)
+   }
+{-# INLINE r_fanout #-}
+
+r_index :: (G.Vector (MayBoxVec a) a)
+        => (xs -> Int)
+        -> ((Int, xs) -> Int)
+        -> Reducer (Int, xs) s a
+        -> Reducer xs s (MayBoxVec a a)
+r_index n f Reducer{init=initR,accum=accumR,done=doneR} = Reducer
+   { init  = \xs -> V.generateM (n xs) (\b -> initR (b, xs))
+   , accum = \bs i v ->
+             let ov = f (i, bs) in
+             accumR (ov,bs) i (v V.! ov)
+   , done  = \v -> fmap G.convert (V.mapM doneR v)
+   }
+{-# INLINE r_index #-}
+
+r_split :: ((Int, xs) -> Bool)
+        -> Reducer xs s a
+        -> Reducer xs s b
+        -> Reducer xs s (a,b)
+r_split b Reducer{init=initA,accum=accumA,done=doneA}
+          Reducer{init=initB,accum=accumB,done=doneB} = Reducer
+   { init  = \xs -> liftM2 (,) (initA xs) (initB xs)
+   , accum = \bs i (s1, s2) ->
+             if (b (i,bs)) then accumA bs i s1 else accumB bs i s2
+   , done  = \(s1, s2) -> liftM2 (,) (doneA s1) (doneB s2)
+   }
+{-# INLINE r_split #-}
+
+r_add :: Num a => ((Int, xs) -> a) -> Reducer xs s a
+r_add e = Reducer
+   { init  = \_ -> newSTRef 0
+   , accum = \bs i s ->
+             modifySTRef' s (+ (e (i,bs)))
+   , done  = readSTRef
+   }
+{-# INLINE r_add #-}
+
+r_nop :: Reducer xs s ()
+r_nop = Reducer
+   { init  = \_ -> return ()
+   , accum = \_ _ _ -> return ()
+   , done  = \_ -> return ()
+   }
+{-# INLINE r_nop #-}
+
+pair :: a -> b -> (a, b)
+pair = (,)
+{-# INLINE pair #-}
+
+true, false :: Bool
+true  = True
+false = False
+
+nothing :: Maybe a
+nothing = Nothing
+
+just :: a -> Maybe a
+just = Just
+
+left :: a -> Either a b
+left = Left
+
+right :: b -> Either a b
+right = Right
+
+unit :: ()
+unit = ()
+
+data Pattern = PVar | PWild
+newtype Branch a b =
+    Branch { extract :: a -> Maybe b }
+
+ptrue, pfalse :: a -> Branch Bool a
+ptrue  b = Branch { extract = extractBool True  b }
+pfalse b = Branch { extract = extractBool False b }
+{-# INLINE ptrue  #-}
+{-# INLINE pfalse #-}
+
+extractBool :: Bool -> a -> Bool -> Maybe a
+extractBool b a p | p == b     = Just a
+                  | otherwise  = Nothing
+{-# INLINE extractBool #-}
+
+pnothing :: b -> Branch (Maybe a) b
+pnothing b = Branch { extract = \ma -> case ma of
+                                         Nothing -> Just b
+                                         Just _  -> Nothing }
+
+pjust :: Pattern -> (a -> b) -> Branch (Maybe a) b
+pjust PVar c = Branch { extract = \ma -> case ma of
+                                           Nothing -> Nothing
+                                           Just x  -> Just (c x) }
+pjust _ _ = error "TODO: Runtime.Prelude{pjust}"
+
+pleft :: Pattern -> (a -> c) -> Branch (Either a b) c
+pleft PVar f = Branch { extract = \ma -> case ma of
+                                           Right _ -> Nothing
+                                           Left x -> Just (f x) }
+pleft _ _ = error "TODO: Runtime.Prelude{pLeft}"
+
+pright :: Pattern -> (b -> c) -> Branch (Either a b) c
+pright PVar f = Branch { extract = \ma -> case ma of
+                                            Left _ -> Nothing
+                                            Right x -> Just (f x) }
+pright _ _ = error "TODO: Runtime.Prelude{pRight}"
+
+
+ppair :: Pattern -> Pattern -> (x -> y -> b) -> Branch (x,y) b
+ppair PVar  PVar c = Branch { extract = (\(x,y) -> Just (c x y)) }
+ppair _     _    _ = error "ppair: TODO"
+
+uncase_ :: Maybe a -> a
+uncase_ (Just a) = a
+uncase_ Nothing  = error "case_: unable to match any branches"
+{-# INLINE uncase_ #-}
+
+case_ :: a -> [Branch a b] -> b
+case_ e [c1]     = uncase_ (extract c1 e)
+case_ e [c1, c2] = uncase_ (extract c1 e `mplus` extract c2 e)
+case_ e bs_      = go bs_
+  where go []     = error "case_: unable to match any branches"
+        go (b:bs) = case extract b e of
+                      Just b' -> b'
+                      Nothing -> go bs
+{-# INLINE case_ #-}
+
+branch :: (c -> Branch a b) -> c -> Branch a b
+branch pat body = pat body
+{-# INLINE branch #-}
+
+dirac :: a -> Measure a
+dirac = return
+{-# INLINE dirac #-}
+
+pose :: Prob -> Measure a -> Measure a
+pose _ a = a
+{-# INLINE pose #-}
+
+superpose :: [(Prob, Measure a)]
+          -> Measure a
+superpose pms = do
+  i <- categorical (G.fromList $ map fst pms)
+  snd (pms !! i)
+{-# INLINE superpose #-}
+
+reject :: Measure a
+reject = Measure $ \_ -> return Nothing
+
+nat_ :: Int -> Int
+nat_ = id
+
+int_ :: Int -> Int
+int_ = id
+
+unsafeNat :: Int -> Int
+unsafeNat = id
+
+nat2prob :: Int -> Prob
+nat2prob = fromIntegral
+
+fromInt  :: Int -> Double
+fromInt  = fromIntegral
+
+nat2int  :: Int -> Int
+nat2int  = id
+
+nat2real :: Int -> Double
+nat2real = fromIntegral
+
+fromProb :: Prob -> Double
+fromProb = fromLogFloat
+
+unsafeProb :: Double -> Prob
+unsafeProb = logFloat
+
+real_ :: Rational -> Double
+real_ = fromRational
+
+prob_ :: NonNegativeRational -> Prob
+prob_ = fromRational . fromNonNegativeRational
+
+infinity :: Double
+infinity = 1/0
+
+abs_ :: Num a => a -> a
+abs_ = abs
+
+(**) :: Prob -> Double -> Prob
+(**) = pow
+{-# INLINE (**) #-}
+
+pi :: Prob
+pi = unsafeProb P.pi
+{-# INLINE pi #-}
+
+thRootOf :: Int -> Prob -> Prob
+thRootOf a b = b ** (recip $ fromIntegral a)
+{-# INLINE thRootOf #-}
+
+array
+    :: (G.Vector (MayBoxVec a) a)
+    => Int
+    -> (Int -> a)
+    -> MayBoxVec a a
+array n f = G.generate (fromIntegral n) (f . fromIntegral)
+{-# INLINE array #-}
+
+arrayLit :: (G.Vector (MayBoxVec a) a) => [a] -> MayBoxVec a a
+arrayLit = G.fromList
+{-# INLINE arrayLit #-}
+
+(!) :: (G.Vector (MayBoxVec a) a) => MayBoxVec a a -> Int -> a
+a ! b = a G.! (fromIntegral b)
+{-# INLINE (!) #-}
+
+size :: (G.Vector (MayBoxVec a) a) => MayBoxVec a a -> Int
+size v = fromIntegral (G.length v)
+{-# INLINE size #-}
+
+reduce
+    :: (G.Vector (MayBoxVec a) a)
+    => (a -> a -> a)
+    -> a
+    -> MayBoxVec a a
+    -> a
+reduce f n v = G.foldr f n v
+{-# INLINE reduce #-}
+
+class Num a => Num' a where
+    product :: Int -> Int -> (Int -> a) -> a
+    product a b f = F.foldl' (\x y -> x * f y) 1 [a .. b-1]
+    {-# INLINE product #-}
+    summate :: Int -> Int -> (Int -> a) -> a
+    summate a b f = F.foldl' (\x y -> x + f y) 0 [a .. b-1]
+    {-# INLINE summate #-}
+
+instance Num' Int
+instance Num' Double
+instance Num' LogFloat where
+    product a b f = LF.product (map f [a .. b-1])
+    {-# INLINE product #-}
+    summate a b f = LF.sum     (map f [a .. b-1])
+    {-# INLINE summate #-}
+
+run :: Show a
+    => MWC.GenIO
+    -> Measure a
+    -> IO ()
+run g k = unMeasure k g >>= \case
+           Just a  -> print a
+           Nothing -> return ()
+
+iterateM_
+    :: Monad m
+    => (a -> m a)
+    -> a
+    -> m b
+iterateM_ f = g
+    where g x = f x >>= g
+
+withPrint :: Show a => (a -> IO b) -> a -> IO b
+withPrint f x = print x >> f x
diff --git a/haskell/Language/Hakaru/Runtime/Prelude.hs b/haskell/Language/Hakaru/Runtime/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Runtime/Prelude.hs
@@ -0,0 +1,373 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , DataKinds
+           , TypeFamilies
+           , FlexibleContexts
+           , UndecidableInstances
+           , LambdaCase
+           , OverloadedStrings
+           , Rank2Types
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs -fsimpl-tick-factor=1000 #-}
+module Language.Hakaru.Runtime.Prelude where
+
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor                    ((<$>))
+import           Control.Applicative             (Applicative(..))
+#endif
+import           Data.Foldable                   as F
+import qualified System.Random.MWC               as MWC
+import qualified System.Random.MWC.Distributions as MWCD
+import           Data.Number.Natural
+import           Data.STRef
+import qualified Data.Vector                     as V
+import qualified Data.Vector.Unboxed             as U
+import qualified Data.Vector.Generic             as G
+import           Control.Monad
+import           Control.Monad.ST
+import           Prelude                         hiding (product, init)
+import           Language.Hakaru.Runtime.CmdLine (Measure(..), makeMeasure)
+
+type family MinBoxVec (v1 :: * -> *) (v2 :: * -> *) :: * -> *
+type instance MinBoxVec V.Vector v        = V.Vector
+type instance MinBoxVec v        V.Vector = V.Vector
+type instance MinBoxVec U.Vector U.Vector = U.Vector
+
+type family MayBoxVec a :: * -> *
+type instance MayBoxVec ()           = U.Vector
+type instance MayBoxVec Int          = U.Vector
+type instance MayBoxVec Double       = U.Vector
+type instance MayBoxVec Bool         = U.Vector
+type instance MayBoxVec (U.Vector a) = V.Vector
+type instance MayBoxVec (V.Vector a) = V.Vector
+type instance MayBoxVec (a,b)        = MinBoxVec (MayBoxVec a) (MayBoxVec b)
+
+type Prob = Double
+
+lam :: (a -> b) -> a -> b
+lam = id
+{-# INLINE lam #-}
+
+app :: (a -> b) -> a -> b
+app f x = f x
+{-# INLINE app #-}
+
+let_ :: a -> (a -> b) -> b
+let_ x f = let x1 = x in f x1
+{-# INLINE let_ #-}
+
+ann_ :: a -> b -> b
+ann_ _ a = a
+{-# INLINE ann_ #-}
+
+uniform :: Double -> Double -> Measure Double
+uniform lo hi = makeMeasure $ MWC.uniformR (lo, hi)
+{-# INLINE uniform #-}
+
+normal :: Double -> Prob -> Measure Double
+normal mu sd = makeMeasure $ MWCD.normal mu (fromProb sd)
+{-# INLINE normal #-}
+
+beta :: Prob -> Prob -> Measure Prob
+beta a b = makeMeasure $ \g ->
+  unsafeProb <$> MWCD.beta (fromProb a) (fromProb b) g
+{-# INLINE beta #-}
+
+gamma :: Prob -> Prob -> Measure Prob
+gamma a b = makeMeasure $ \g ->
+  unsafeProb <$> MWCD.gamma (fromProb a) (fromProb b) g
+{-# INLINE gamma #-}
+
+categorical :: MayBoxVec Prob Prob -> Measure Int
+categorical a = makeMeasure $ MWCD.categorical a
+{-# INLINE categorical #-}
+
+plate :: (G.Vector (MayBoxVec a) a) =>
+         Int -> (Int -> Measure a) -> Measure (MayBoxVec a a)
+plate n f = G.generateM (fromIntegral n) $ \x ->
+             f (fromIntegral x)
+{-# INLINE plate #-}
+
+bucket :: Int -> Int -> (forall s. Reducer () s a) -> a
+bucket b e r = runST
+             $ case r of Reducer{init=initR,accum=accumR,done=doneR} -> do
+                          s' <- initR ()
+                          F.mapM_ (\i -> accumR () i s') [b .. e - 1]
+                          doneR s'
+{-# INLINE bucket #-}
+
+data Reducer xs s a =
+    forall cell.
+    Reducer { init  :: xs -> ST s cell
+            , accum :: xs -> Int -> cell -> ST s ()
+            , done  :: cell -> ST s a
+            }
+
+r_fanout :: Reducer xs s a
+         -> Reducer xs s b
+         -> Reducer xs s (a,b)
+r_fanout Reducer{init=initA,accum=accumA,done=doneA}
+         Reducer{init=initB,accum=accumB,done=doneB} = Reducer
+   { init  = \xs       -> liftM2 (,) (initA xs) (initB xs)
+   , accum = \bs i (s1, s2) ->
+             accumA bs i s1 >> accumB bs i s2
+   , done  = \(s1, s2) -> liftM2 (,) (doneA s1) (doneB s2)
+   }
+{-# INLINE r_fanout #-}
+
+r_index :: (G.Vector (MayBoxVec a) a)
+        => (xs -> Int)
+        -> ((Int, xs) -> Int)
+        -> Reducer (Int, xs) s a
+        -> Reducer xs s (MayBoxVec a a)
+r_index n f Reducer{init=initR,accum=accumR,done=doneR} = Reducer
+   { init  = \xs -> V.generateM (n xs) (\b -> initR (b, xs))
+   , accum = \bs i v ->
+             let ov = f (i, bs) in
+             accumR (ov,bs) i (v V.! ov)
+   , done  = \v -> fmap G.convert (V.mapM doneR v)
+   }
+{-# INLINE r_index #-}
+
+r_split :: ((Int, xs) -> Bool)
+        -> Reducer xs s a
+        -> Reducer xs s b
+        -> Reducer xs s (a,b)
+r_split b Reducer{init=initA,accum=accumA,done=doneA}
+          Reducer{init=initB,accum=accumB,done=doneB} = Reducer
+   { init  = \xs -> liftM2 (,) (initA xs) (initB xs)
+   , accum = \bs i (s1, s2) ->
+             if (b (i,bs)) then accumA bs i s1 else accumB bs i s2
+   , done  = \(s1, s2) -> liftM2 (,) (doneA s1) (doneB s2)
+   }
+{-# INLINE r_split #-}
+
+r_add :: Num a => ((Int, xs) -> a) -> Reducer xs s a
+r_add e = Reducer
+   { init  = \_ -> newSTRef 0
+   , accum = \bs i s ->
+             modifySTRef' s (+ (e (i,bs)))
+   , done  = readSTRef
+   }
+{-# INLINE r_add #-}
+
+r_nop :: Reducer xs s ()
+r_nop = Reducer
+   { init  = \_ -> return ()
+   , accum = \_ _ _ -> return ()
+   , done  = \_ -> return ()
+   }
+{-# INLINE r_nop #-}
+
+pair :: a -> b -> (a, b)
+pair = (,)
+{-# INLINE pair #-}
+
+true, false :: Bool
+true  = True
+false = False
+
+nothing :: Maybe a
+nothing = Nothing
+
+just :: a -> Maybe a
+just = Just
+
+left :: a -> Either a b
+left = Left
+
+right :: b -> Either a b
+right = Right
+
+unit :: ()
+unit = ()
+
+data Pattern = PVar | PWild
+newtype Branch a b =
+    Branch { extract :: a -> Maybe b }
+
+ptrue, pfalse :: a -> Branch Bool a
+ptrue  b = Branch { extract = extractBool True  b }
+pfalse b = Branch { extract = extractBool False b }
+{-# INLINE ptrue  #-}
+{-# INLINE pfalse #-}
+
+extractBool :: Bool -> a -> Bool -> Maybe a
+extractBool b a p | p == b     = Just a
+                  | otherwise  = Nothing
+{-# INLINE extractBool #-}
+
+pnothing :: b -> Branch (Maybe a) b
+pnothing b = Branch { extract = \ma -> case ma of
+                                         Nothing -> Just b
+                                         Just _  -> Nothing }
+
+pjust :: Pattern -> (a -> b) -> Branch (Maybe a) b
+pjust PVar c = Branch { extract = \ma -> case ma of
+                                           Nothing -> Nothing
+                                           Just x  -> Just (c x) }
+pjust _ _ = error "TODO: Runtime.Prelude{pjust}"
+
+pleft :: Pattern -> (a -> c) -> Branch (Either a b) c
+pleft PVar f = Branch { extract = \ma -> case ma of
+                                           Right _ -> Nothing
+                                           Left x -> Just (f x) }
+pleft _ _ = error "TODO: Runtime.Prelude{pLeft}"
+
+pright :: Pattern -> (b -> c) -> Branch (Either a b) c
+pright PVar f = Branch { extract = \ma -> case ma of
+                                            Left _ -> Nothing
+                                            Right x -> Just (f x) }
+pright _ _ = error "TODO: Runtime.Prelude{pRight}"
+
+
+ppair :: Pattern -> Pattern -> (x -> y -> b) -> Branch (x,y) b
+ppair PVar  PVar c = Branch { extract = (\(x,y) -> Just (c x y)) }
+ppair _     _    _ = error "ppair: TODO"
+
+uncase_ :: Maybe a -> a
+uncase_ (Just a) = a
+uncase_ Nothing  = error "case_: unable to match any branches"
+{-# INLINE uncase_ #-}
+
+case_ :: a -> [Branch a b] -> b
+case_ e [c1]     = uncase_ (extract c1 e)
+case_ e [c1, c2] = uncase_ (extract c1 e `mplus` extract c2 e)
+case_ e bs_      = go bs_
+  where go []     = error "case_: unable to match any branches"
+        go (b:bs) = case extract b e of
+                      Just b' -> b'
+                      Nothing -> go bs
+{-# INLINE case_ #-}
+
+branch :: (c -> Branch a b) -> c -> Branch a b
+branch pat body = pat body
+{-# INLINE branch #-}
+
+dirac :: a -> Measure a
+dirac = return
+{-# INLINE dirac #-}
+
+pose :: Prob -> Measure a -> Measure a
+pose _ a = a
+{-# INLINE pose #-}
+
+superpose :: [(Prob, Measure a)]
+          -> Measure a
+superpose pms = do
+  i <- categorical (G.fromList $ map fst pms)
+  snd (pms !! i)
+{-# INLINE superpose #-}
+
+reject :: Measure a
+reject = Measure $ \_ -> return Nothing
+
+nat_ :: Int -> Int
+nat_ = id
+
+int_ :: Int -> Int
+int_ = id
+
+unsafeNat :: Int -> Int
+unsafeNat = id
+
+nat2prob :: Int -> Prob
+nat2prob = fromIntegral
+
+fromInt  :: Int -> Double
+fromInt  = fromIntegral
+
+nat2int  :: Int -> Int
+nat2int  = id
+
+nat2real :: Int -> Double
+nat2real = fromIntegral
+
+fromProb :: Prob -> Double
+fromProb = id
+
+unsafeProb :: Double -> Prob
+unsafeProb = id
+
+real_ :: Rational -> Double
+real_ = fromRational
+
+prob_ :: NonNegativeRational -> Prob
+prob_ = fromRational . fromNonNegativeRational
+
+infinity :: Double
+infinity = 1/0
+
+abs_ :: Num a => a -> a
+abs_ = abs
+
+thRootOf :: Int -> Prob -> Prob
+thRootOf a b = b ** (recip $ fromIntegral a)
+{-# INLINE thRootOf #-}
+
+array
+    :: (G.Vector (MayBoxVec a) a)
+    => Int
+    -> (Int -> a)
+    -> MayBoxVec a a
+array n f = G.generate (fromIntegral n) (f . fromIntegral)
+{-# INLINE array #-}
+
+arrayLit :: (G.Vector (MayBoxVec a) a) => [a] -> MayBoxVec a a
+arrayLit = G.fromList
+{-# INLINE arrayLit #-}
+
+(!) :: (G.Vector (MayBoxVec a) a) => MayBoxVec a a -> Int -> a
+a ! b = a G.! (fromIntegral b)
+{-# INLINE (!) #-}
+
+size :: (G.Vector (MayBoxVec a) a) => MayBoxVec a a -> Int
+size v = fromIntegral (G.length v)
+{-# INLINE size #-}
+
+reduce
+    :: (G.Vector (MayBoxVec a) a)
+    => (a -> a -> a)
+    -> a
+    -> MayBoxVec a a
+    -> a
+reduce f n v = G.foldr f n v
+{-# INLINE reduce #-}
+
+product
+    :: Num a
+    => Int
+    -> Int
+    -> (Int -> a)
+    -> a
+product a b f = F.foldl' (\x y -> x * f y) 1 [a .. b-1]
+{-# INLINE product #-}
+
+summate
+    :: Num a
+    => Int
+    -> Int
+    -> (Int -> a)
+    -> a
+summate a b f = F.foldl' (\x y -> x + f y) 0 [a .. b-1]
+{-# INLINE summate #-}
+
+run :: Show a
+    => MWC.GenIO
+    -> Measure a
+    -> IO ()
+run g k = unMeasure k g >>= \case
+           Just a  -> print a
+           Nothing -> return ()
+
+iterateM_
+    :: Monad m
+    => (a -> m a)
+    -> a
+    -> m b
+iterateM_ f = g
+    where g x = f x >>= g
+
+withPrint :: Show a => (a -> IO b) -> a -> IO b
+withPrint f x = print x >> f x
diff --git a/haskell/Language/Hakaru/Sample.hs b/haskell/Language/Hakaru/Sample.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Sample.hs
@@ -0,0 +1,722 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , KindSignatures
+           , TypeOperators
+           , TypeFamilies
+           , EmptyCase
+           , DataKinds
+           , PolyKinds
+           , ExistentialQuantification
+           , FlexibleContexts
+           , OverloadedStrings
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+
+module Language.Hakaru.Sample where
+
+import           Numeric.SpecFunctions            (logFactorial)
+import qualified Data.Number.LogFloat             as LF
+import qualified Math.Combinatorics.Exact.Binomial as EB
+-- import qualified Numeric.Integration.TanhSinh     as TS
+import qualified System.Random.MWC                as MWC
+import qualified System.Random.MWC.CondensedTable as MWC
+import qualified System.Random.MWC.Distributions  as MWCD
+
+import qualified Data.Vector                      as V
+import           Data.STRef
+import           Data.Sequence (Seq)
+import qualified Data.Foldable                    as F
+import qualified Data.List.NonEmpty               as L
+import           Data.List.NonEmpty               (NonEmpty(..))
+import           Data.Maybe                       (fromMaybe)
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+#endif
+import           Control.Monad
+import           Control.Monad.ST
+import           Control.Monad.Identity
+import           Control.Monad.Trans.Maybe
+import           Control.Monad.State.Strict
+import qualified Data.IntMap                      as IM
+
+import Data.Number.Nat     (fromNat)
+import Data.Number.Natural (fromNatural, fromNonNegativeRational, Natural, unsafeNatural)
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.Value
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.DatumCase
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.ABT
+
+data EAssoc =
+    forall a. EAssoc {-# UNPACK #-} !(Variable a) !(Value a)
+
+newtype Env = Env (IM.IntMap EAssoc)
+
+emptyEnv :: Env
+emptyEnv = Env IM.empty
+
+updateEnv :: EAssoc -> Env -> Env
+updateEnv v@(EAssoc x _) (Env xs) =
+    Env $ IM.insert (fromNat $ varID x) v xs
+
+updateEnvs
+    :: List1 Variable xs
+    -> List1 Value xs
+    -> Env
+    -> Env
+updateEnvs Nil1         Nil1         env = env
+updateEnvs (Cons1 x xs) (Cons1 y ys) env =
+    updateEnvs xs ys (updateEnv (EAssoc x y) env)
+
+lookupVar :: Variable a -> Env -> Maybe (Value a)
+lookupVar x (Env env) = do
+    EAssoc x' e' <- IM.lookup (fromNat $ varID x) env
+    Refl         <- varEq x x'
+    return e'
+
+---------------------------------------------------------------
+
+-- Makes use of Atkinson's algorithm as described in:
+-- Monte Carlo Statistical Methods pg. 55
+--
+-- Further discussion at:
+-- http://www.johndcook.com/blog/2010/06/14/generating-poisson-random-values/
+poisson_rng :: Double -> MWC.GenIO -> IO Int
+poisson_rng lambda g' = make_poisson g'
+    where
+    smu   = sqrt lambda
+    b     = 0.931 + 2.53*smu
+    a     = -0.059 + 0.02483*b
+    vr    = 0.9277 - 3.6224/(b - 2)
+    arep  = 1.1239 + 1.1368/(b - 3.4)
+    lnlam = log lambda
+
+    make_poisson :: MWC.GenIO -> IO Int
+    make_poisson g = do
+        u <- MWC.uniformR (-0.5,0.5) g
+        v <- MWC.uniformR (0,1) g
+        let us = 0.5 - abs u
+            k = floor $ (2*a / us + b)*u + lambda + 0.43
+        case () of
+            () | us >= 0.07 && v <= vr -> return k
+            () | k < 0                 -> make_poisson g
+            () | us <= 0.013 && v > us -> make_poisson g
+            () | accept_region us v k  -> return k
+            _                          -> make_poisson g
+
+    accept_region :: Double -> Double -> Int -> Bool
+    accept_region us v k =
+        log (v * arep / (a/(us*us)+b))
+        <=
+        -lambda + fromIntegral k * lnlam - logFactorial k
+
+
+normalize :: [Value 'HProb] -> (LF.LogFloat, Double, [Double])
+normalize []          = (0, 0, [])
+normalize [(VProb x)] = (x, 1, [1])
+normalize xs          = (m, y, ys)
+    where
+    xs' = map (\(VProb x) -> x) xs
+    m   = maximum xs'
+    ys  = [ LF.fromLogFloat (x/m) | x <- xs' ]
+    y   = sum ys
+
+
+normalizeVector
+    :: Value ('HArray 'HProb) -> (LF.LogFloat, Double, V.Vector Double)
+normalizeVector (VArray xs) =
+    let xs' = V.map (\(VProb x) -> x) xs in
+    case V.length xs of
+    0 -> (0, 0, V.empty)
+    1 -> (V.unsafeHead xs', 1, V.singleton 1)
+    _ ->
+        let m   = V.maximum xs'
+            ys  = V.map (\x -> LF.fromLogFloat (x/m)) xs'
+            y   = V.sum ys
+        in (m, y, ys)
+
+---------------------------------------------------------------
+
+runEvaluate
+    :: (ABT Term abt)
+    => abt '[] a
+    -> Value a
+runEvaluate prog = evaluate prog emptyEnv
+
+evaluate
+    :: (ABT Term abt)
+    => abt '[] a
+    -> Env
+    -> Value a
+evaluate e env = caseVarSyn e (evaluateVar env) (flip evaluateTerm env)
+
+evaluateVar :: Env -> Variable a -> Value a
+evaluateVar env v =
+    case lookupVar v env of
+    Nothing -> error "variable not found!"
+    Just a  -> a
+
+evaluateTerm
+    :: (ABT Term abt)
+    => Term abt a
+    -> Env
+    -> Value a
+evaluateTerm t env =
+    case t of
+    o :$          es -> evaluateSCon    o es    env
+    NaryOp_  o    es -> evaluateNaryOp  o es    env
+    Literal_ v       -> evaluateLiteral v
+    Empty_   _       -> evaluateEmpty
+    Array_   n    es -> evaluateArray   n es    env
+    ArrayLiteral_ es -> VArray . V.fromList $ map (flip evaluate env) es
+    Bucket b e    rs -> evaluateBucket  b e  rs env
+    Datum_   d       -> evaluateDatum   d       env
+    Case_    o    es -> evaluateCase    o es    env
+    Superpose_    es -> evaluateSuperpose es    env
+    Reject_  _       -> VMeasure $ \_ _ -> return Nothing
+
+evaluateSCon
+    :: (ABT Term abt)
+    => SCon args a
+    -> SArgs abt args
+    -> Env
+    -> Value a
+evaluateSCon Lam_ (e1 :* End) env =
+    caseBind e1 $ \x e1' ->
+        VLam $ \v -> evaluate e1' (updateEnv (EAssoc x v) env)
+evaluateSCon App_ (e1 :* e2 :* End) env =
+    case evaluate e1 env of
+    VLam f -> f (evaluate e2 env)
+evaluateSCon Let_ (e1 :* e2 :* End) env =
+    let v = evaluate e1 env
+    in caseBind e2 $ \x e2' ->
+        evaluate e2' (updateEnv (EAssoc x v) env)
+evaluateSCon (CoerceTo_   c) (e1 :* End) env =
+    coerceTo c $ evaluate e1 env
+evaluateSCon (UnsafeFrom_ c) (e1 :* End) env =
+    coerceFrom c $ evaluate e1 env
+evaluateSCon (PrimOp_ o)     es env = evaluatePrimOp    o es env
+evaluateSCon (ArrayOp_ o)    es env = evaluateArrayOp   o es env
+evaluateSCon (MeasureOp_  m) es env = evaluateMeasureOp m es env
+evaluateSCon Dirac           (e1 :* End) env =
+    VMeasure $ \p _ -> return $ Just (evaluate e1 env, p)
+evaluateSCon MBind (e1 :* e2 :* End) env =
+    case evaluate e1 env of
+    VMeasure m1 -> VMeasure $ \ p g -> do
+        x <- m1 p g
+        case x of
+            Nothing -> return Nothing
+            Just (a, p') ->
+                caseBind e2 $ \x' e2' ->
+                    case evaluate e2' (updateEnv (EAssoc x' a) env) of
+                    VMeasure y -> y p' g
+
+evaluateSCon Plate (n :* e2 :* End) env =
+    case evaluate n env of
+    VNat n' -> caseBind e2 $ \x e' ->
+        VMeasure $ \(VProb p) g -> runMaybeT $ do
+            (v', ps) <- fmap V.unzip . V.mapM (performMaybe g) $
+                V.generate (fromInteger $ fromNatural n') $ \v ->
+                    evaluate e' $
+                    updateEnv (EAssoc x . VNat $ intToNatural v) env
+            return
+                ( VArray v'
+                , VProb $ p * V.product (V.map (\(VProb y) -> y) ps)
+                )
+    where
+    performMaybe
+        :: MWC.GenIO
+        -> Value ('HMeasure a)
+        -> MaybeT IO (Value a, Value 'HProb)
+    performMaybe g (VMeasure m) = MaybeT $ m (VProb 1) g
+
+evaluateSCon Chain (n :* s :* e :* End) env =
+    case (evaluate n env, evaluate s env) of
+    (VNat n', start) ->
+        caseBind e $ \x e' ->
+            let s' = VLam $ \v -> evaluate e' (updateEnv (EAssoc x v) env) in
+            VMeasure (\(VProb p) g -> runMaybeT $ do
+                (evaluates, sout) <- runStateT (replicateM (unsafeInt n') $ convert g s') start
+                let (v', ps) = unzip evaluates
+                    bodyType :: Sing ('HMeasure (HPair a b)) -> Sing ('HArray a)
+                    bodyType = SArray . fst . sUnPair . sUnMeasure
+                return
+                    ( VDatum $ dPair_ (bodyType $ caseBind e (const typeOf)) (typeOf s)
+                        (VArray . V.fromList $ v') sout
+                    , VProb $ p * product (map (\(VProb y) -> y) ps)
+                    ))
+    where
+    convert
+        :: MWC.GenIO
+        -> Value (s ':-> 'HMeasure (HPair a s))
+        -> StateT (Value s) (MaybeT IO) (Value a, Value 'HProb)
+    convert g (VLam f) = StateT $ \s' ->
+        case f s' of
+        VMeasure f' -> do
+            (as'', p') <- MaybeT (f' (VProb 1) g)
+            let (a, s'') = unPair as''
+            return ((a, p'), s'')
+
+    unPair :: Value (HPair a b) -> (Value a, Value b)
+    unPair (VDatum (Datum "pair" _typ
+        (Inl (Et (Konst a)
+            (Et (Konst b) Done))))) = (a, b)
+    unPair x = case x of {}
+
+evaluateSCon (Summate hd hs) (e1 :* e2 :* e3 :* End) env =
+    case (evaluate e1 env, evaluate e2 env) of
+    (lo, hi) ->
+        caseBind e3 $ \x e3' ->
+            foldl (\t i ->
+                   evalOp (Sum  hs) t $
+                     evaluate e3' (updateEnv (EAssoc x i) env))
+                  (identityElement $ Sum hs)
+                  (enumFromUntilValue hd lo hi)
+
+evaluateSCon (Product hd hs) (e1 :* e2 :* e3 :* End) env =
+    case (evaluate e1 env, evaluate e2 env) of
+    (lo, hi) ->
+        caseBind e3 $ \x e3' ->
+            foldl (\t i ->
+                   evalOp (Prod hs) t $
+                     evaluate e3' (updateEnv (EAssoc x i) env))
+                  (identityElement $ Prod hs)
+                  (enumFromUntilValue hd lo hi)
+
+evaluateSCon s _ _ = error $ "TODO: evaluateSCon{" ++ show s ++ "}"
+
+evaluatePrimOp
+    ::  ( ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => PrimOp typs a
+    -> SArgs abt args
+    -> Env
+    -> Value a
+evaluatePrimOp Not (e1 :* End) env = 
+    case evaluate e1 env of        
+      VDatum a -> if a == dTrue
+                  then VDatum dFalse
+                  else VDatum dTrue
+
+evaluatePrimOp Pi  End         _   = VProb . LF.logFloat $ pi
+evaluatePrimOp Cos (e1 :* End) env =
+    case evaluate e1 env of
+      VReal v1 -> VReal . cos $ v1
+
+evaluatePrimOp Sin (e1 :* End) env =
+    case evaluate e1 env of
+      VReal v1 -> VReal . sin $ v1
+
+evaluatePrimOp Tan (e1 :* End) env =
+    case evaluate e1 env of
+      VReal v1 -> VReal . tan $ v1
+
+evaluatePrimOp RealPow (e1 :* e2 :* End) env =
+    case (evaluate e1 env, evaluate e2 env) of
+      (VProb v1, VReal v2) -> VProb $ LF.pow v1 v2
+
+evaluatePrimOp Choose (e1 :* e2 :* End) env =
+    case (evaluate e1 env, evaluate e2 env) of
+      (VNat v1, VNat v2) -> VNat $ EB.choose v1 v2
+      
+evaluatePrimOp Exp (e1 :* End) env =
+    case evaluate e1 env of
+      VReal v1 -> VProb . LF.logToLogFloat $ v1
+
+evaluatePrimOp Log (e1 :* End) env =
+    case evaluate e1 env of
+      VProb v1 -> VReal . LF.logFromLogFloat $ v1
+
+evaluatePrimOp (Infinity h) End _ =
+    case h of
+      HIntegrable_Nat  -> error "Can not evaluate infinity for natural numbers"
+      HIntegrable_Prob -> VProb $ LF.logFloat LF.infinity
+
+evaluatePrimOp (Equal _) (e1 :* e2 :* End) env = (VDatum . dBool) $ evaluate e1 env == evaluate e2 env
+
+evaluatePrimOp (Less _) (e1 :* e2 :* End) env =
+    case (evaluate e1 env, evaluate e2 env) of
+    (VNat  v1, VNat  v2) -> VDatum $ if v1 < v2 then dTrue else dFalse
+    (VInt  v1, VInt  v2) -> VDatum $ if v1 < v2 then dTrue else dFalse
+    (VProb v1, VProb v2) -> VDatum $ if v1 < v2 then dTrue else dFalse
+    (VReal v1, VReal v2) -> VDatum $ if v1 < v2 then dTrue else dFalse
+    _                    -> error "TODO: evaluatePrimOp{Less}"
+evaluatePrimOp (NatPow _) (e1 :* e2 :* End) env = 
+    case evaluate e2 env of
+    VNat  v2 ->
+        let v2' = fromNatural v2 in
+        case evaluate e1 env of
+          VNat  v1 -> VNat  (v1 ^ v2')
+          VInt  v1 -> VInt  (v1 ^ v2')
+          VProb v1 -> VProb (v1 ^ v2')
+          VReal v1 -> VReal (v1 ^ v2')
+          _        -> error "NatPow should always return some kind of number"
+evaluatePrimOp (Negate _) (e1 :* End) env = 
+    case evaluate e1 env of
+    VInt  v -> VInt  (negate v)
+    VReal v -> VReal (negate v)
+    v       -> case v of {}
+evaluatePrimOp (Abs   _) (e1 :* End) env =
+    case evaluate e1 env of
+    VInt  v -> VNat  . unsafeNatural   $ abs v
+    VReal v -> VProb . LF.logFloat $ abs v
+    v       -> case v of {}
+evaluatePrimOp (Recip _) (e1 :* End) env = 
+    case evaluate e1 env of
+    VProb v -> VProb (recip v)
+    VReal v -> VReal (recip v)
+    v       -> case v of {}
+evaluatePrimOp (NatRoot _) (e1 :* e2 :* End) env =
+    case (evaluate e1 env, evaluate e2 env) of
+    (VProb v1, VNat v2) -> VProb $ LF.pow v1 (recip . fromIntegral $ v2)
+    v                   -> case v of {}    
+
+evaluatePrimOp (Floor) (e1 :* End) env =
+    case (evaluate e1 env) of
+    VProb v1 -> VNat (floor (LF.fromLogFloat v1))
+
+evaluatePrimOp prim _ _ =
+    error ("TODO: evaluatePrimOp{" ++ show prim ++ "}")
+
+evaluateArrayOp
+    :: ( ABT Term abt
+       , typs ~ UnLCs args
+       , args ~ LCs typs)
+    => ArrayOp typs a
+    -> SArgs abt args
+    -> Env
+    -> Value a
+evaluateArrayOp (Index _) = \(e1 :* e2 :* End) env ->
+    case (evaluate e1 env, evaluate e2 env) of
+    (VArray v, VNat n) -> v V.! unsafeInt n
+
+evaluateArrayOp (Size _) = \(e1 :* End) env ->
+    case evaluate e1 env of
+    VArray v -> VNat . intToNatural $ V.length v
+
+evaluateArrayOp (Reduce _) = \(e1 :* e2 :* e3 :* End) env ->
+    case ( evaluate e1 env
+         , evaluate e2 env
+         , evaluate e3 env) of
+    (f, a, VArray v) -> V.foldl' (lam2 f) a v
+
+evaluateMeasureOp
+    :: ( ABT Term abt
+       , typs ~ UnLCs args
+       , args ~ LCs typs)
+    => MeasureOp typs a
+    -> SArgs abt args
+    -> Env
+    -> Value ('HMeasure a)
+
+evaluateMeasureOp Lebesgue = \(e1 :* e2 :* End) env ->
+  case (evaluate e1 env, evaluate e2 env) of
+    (VReal v1, VReal v2) | v1 < v2 ->
+      VMeasure $ \(VProb p) g ->
+        case (isInfinite v1, isInfinite v2) of
+          (False, False) -> do
+            x <- MWC.uniformR (v1, v2) g
+            return $ Just (VReal $ x,
+                           VProb $ p * LF.logFloat (v2 - v1))
+          (False, True) -> do
+            u <- MWC.uniform g
+            let l = log u
+            let n = -l
+            return $ Just (VReal $ v1 + n,
+                           VProb $ p * LF.logToLogFloat n)
+          (True, False) -> do
+            u <- MWC.uniform g
+            let l = log u
+            let n = -l
+            return $ Just (VReal $ v2 - n,
+                           VProb $ p * LF.logToLogFloat n)
+          (True, True) -> do
+            (u,b) <- MWC.uniform g
+            let l = log u
+            let n = -l
+            return $ Just (VReal $ if b then n else l,
+                           VProb $ p * 2 * LF.logToLogFloat n)
+    (VReal _, VReal _) -> error "Lebesgue with length 0 or flipped endpoints"
+
+evaluateMeasureOp Counting = \End _ ->
+    VMeasure $ \(VProb p) g -> do
+        let success = LF.logToLogFloat (-3 :: Double)
+        let pow x y = LF.logToLogFloat (LF.logFromLogFloat x *
+                                       (fromIntegral y :: Double))
+        u' <- MWCD.geometric0 (LF.fromLogFloat success) g
+        let u = toInteger u'
+        b <- MWC.uniform g
+        return $ Just
+            ( VInt  $ if b then -1-u else u
+            , VProb $ p * 2 / pow (1-success) u / success)
+
+evaluateMeasureOp Categorical = \(e1 :* End) env ->
+    VMeasure $ \p g -> do
+        let (_,y,ys) = normalizeVector (evaluate e1 env)
+        if not (y > (0::Double)) -- TODO: why not use @y <= 0@ ??
+        then error "Categorical needs positive weights"
+        else do
+            u <- MWC.uniformR (0, y) g
+            return $ Just
+                ( VNat
+                . intToNatural
+                . fromMaybe 0
+                . V.findIndex (u <=) 
+                . V.scanl1' (+)
+                $ ys
+                , p)
+
+evaluateMeasureOp Uniform = \(e1 :* e2 :* End) env ->
+    case (evaluate e1 env, evaluate e2 env) of
+    (VReal v1, VReal v2) -> VMeasure $ \p g -> do
+        x <- MWC.uniformR (v1, v2) g
+        return $ Just (VReal x, p)
+
+evaluateMeasureOp Normal = \(e1 :* e2 :* End) env ->
+    case (evaluate e1 env, evaluate e2 env) of 
+    (VReal v1, VProb v2) -> VMeasure $ \ p g -> do
+        x <- MWCD.normal v1 (LF.fromLogFloat v2) g
+        return $ Just (VReal x, p)
+
+evaluateMeasureOp Poisson = \(e1 :* End) env ->
+    case evaluate e1 env of
+    VProb v1 -> VMeasure $ \ p g -> do
+        x <- MWC.genFromTable (MWC.tablePoisson (LF.fromLogFloat v1)) g
+        return $ Just (VNat $ intToNatural x, p)
+
+evaluateMeasureOp Gamma = \(e1 :* e2 :* End) env ->
+    case (evaluate e1 env, evaluate e2 env) of 
+    (VProb v1, VProb v2) -> VMeasure $ \ p g -> do
+        x <- MWCD.gamma (LF.fromLogFloat v1) (LF.fromLogFloat v2) g
+        return $ Just (VProb $ LF.logFloat x, p)
+
+evaluateMeasureOp Beta = \(e1 :* e2 :* End) env ->
+    case (evaluate e1 env, evaluate e2 env) of 
+    (VProb v1, VProb v2) -> VMeasure $ \ p g -> do
+        x <- MWCD.beta (LF.fromLogFloat v1) (LF.fromLogFloat v2) g
+        return $ Just (VProb $ LF.logFloat x, p)
+
+evaluateNaryOp
+    :: (ABT Term abt)
+    => NaryOp a -> Seq (abt '[] a) -> Env -> Value a
+evaluateNaryOp s es =
+    F.foldr (evalOp s) (identityElement s) . mapEvaluate es
+
+identityElement :: NaryOp a -> Value a
+identityElement And                   = VDatum dTrue
+identityElement (Sum HSemiring_Nat)   = VNat  0
+identityElement (Sum HSemiring_Int)   = VInt  0
+identityElement (Sum HSemiring_Prob)  = VProb 0
+identityElement (Sum HSemiring_Real)  = VReal 0
+identityElement (Prod HSemiring_Nat)  = VNat  1
+identityElement (Prod HSemiring_Int)  = VInt  1
+identityElement (Prod HSemiring_Prob) = VProb 1
+identityElement (Prod HSemiring_Real) = VReal 1
+identityElement (Max  HOrd_Prob)      = VProb 0
+identityElement (Max  HOrd_Real)      = VReal LF.negativeInfinity
+identityElement (Min  HOrd_Prob)      = VProb (LF.logFloat LF.infinity)
+identityElement (Min  HOrd_Real)      = VReal LF.infinity
+identityElement _                     = error "Missing identity elements?"
+
+
+evalOp
+    :: NaryOp a -> Value a -> Value a -> Value a
+evalOp And (VDatum a) (VDatum b)        
+    | a == dTrue && b == dTrue = VDatum dTrue
+    | otherwise = VDatum dFalse
+evalOp (Sum  HSemiring_Nat)  (VNat  a) (VNat  b) = VNat  (a + b)
+evalOp (Sum  HSemiring_Int)  (VInt  a) (VInt  b) = VInt  (a + b)
+evalOp (Sum  HSemiring_Prob) (VProb a) (VProb b) = VProb (a + b)
+evalOp (Sum  HSemiring_Real) (VReal a) (VReal b) = VReal (a + b)
+evalOp (Prod HSemiring_Nat)  (VNat  a) (VNat  b) = VNat  (a * b)
+evalOp (Prod HSemiring_Int)  (VInt  a) (VInt  b) = VInt  (a * b)  
+evalOp (Prod HSemiring_Prob) (VProb a) (VProb b) = VProb (a * b)  
+evalOp (Prod HSemiring_Real) (VReal a) (VReal b) = VReal (a * b)
+evalOp (Max  HOrd_Prob)      (VProb a) (VProb b) = VProb (max a b)
+evalOp (Max  HOrd_Real)      (VReal a) (VReal b) = VReal (max a b)
+evalOp (Min  HOrd_Prob)      (VProb a) (VProb b) = VProb (min a b) 
+evalOp (Min  HOrd_Real)      (VReal a) (VReal b) = VReal (min a b) 
+
+evalOp op                    _          _        =
+    error ("TODO: evalOp{" ++ show op ++ "}")
+
+mapEvaluate
+    :: (ABT Term abt)
+    => Seq (abt '[] a) -> Env -> Seq (Value a)
+mapEvaluate es env = fmap (flip evaluate env) es
+
+
+evaluateLiteral :: Literal a -> Value a
+evaluateLiteral (LNat  n) = VNat  . fromInteger $ fromNatural n -- TODO: catch overflow errors
+evaluateLiteral (LInt  n) = VInt  $ fromInteger n -- TODO: catch overflow errors
+evaluateLiteral (LProb n) = VProb . fromRational $ fromNonNegativeRational n
+evaluateLiteral (LReal n) = VReal $ fromRational n
+
+evaluateEmpty :: Value ('HArray a)
+evaluateEmpty = VArray V.empty
+
+evaluateArray
+    :: (ABT Term abt)
+    => (abt '[] 'HNat)
+    -> (abt '[ 'HNat ] a)
+    -> Env
+    -> Value ('HArray a)
+evaluateArray n e env =
+    case evaluate n env of
+    VNat n' -> caseBind e $ \x e' ->
+        VArray $ V.generate (unsafeInt n') $ \v ->
+            let v' = VNat $ intToNatural v in
+            evaluate e' (updateEnv (EAssoc x v') env)
+
+evaluateBucket
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> abt '[] 'HNat
+    -> Reducer abt '[] a
+    -> Env
+    -> Value a
+evaluateBucket b e rs env =
+    case (evaluate b env, evaluate e env) of
+      (VNat b', VNat e') -> runST $ do
+          s' <- init Nil1 rs env
+          mapM_ (\i -> accum (VNat i) Nil1 rs s' env) [b' .. e' - 1]
+          done s'
+    where init :: (ABT Term abt)
+               => List1 Value xs
+               -> Reducer abt xs a
+               -> Env
+               -> ST s (VReducer s a)
+          init ix (Red_Fanout r1 r2)    env  =
+              VRed_Pair (type_ r1) (type_ r2) <$> init ix r1 env <*> init ix r2 env
+          init ix (Red_Index  n  _  mr) env' =
+              let (vars, n') = caseBinds n in
+              case evaluate n' (updateEnvs vars ix env') of
+                VNat n'' -> VRed_Array <$> V.generateM (fromIntegral n'')
+                            (\bb -> init (Cons1 (vnat bb) ix) mr env')
+          init ix (Red_Split _ r1 r2)   env' =
+              VRed_Pair (type_ r1) (type_ r2) <$> init ix r1 env <*> init ix r2 env'
+          init _  Red_Nop               _    = return VRed_Unit
+          init _  (Red_Add h _) _ = VRed_Num <$> newSTRef (identityElement (Sum h))
+
+          type_ = typeOfReducer
+
+          vnat :: Int -> Value 'HNat
+          vnat  = VNat . fromIntegral
+
+          accum :: (ABT Term abt)
+                => Value 'HNat
+                -> List1 Value xs
+                -> Reducer abt xs a
+                -> VReducer s a
+                -> Env
+                -> ST s ()
+          accum n ix (Red_Fanout r1 r2)   (VRed_Pair _ _ v1 v2) env' =
+              accum n ix r1 v1 env >> accum n ix r2 v2 env'
+          accum n ix (Red_Index n' a1 r2) (VRed_Array v)          env' =
+              caseBind a1 $ \i a1' ->
+              let (vars, a1'') = caseBinds a1'
+                  VNat ov = evaluate a1''
+                            (updateEnv (EAssoc i n) (updateEnvs vars ix env'))
+                  ov' = fromIntegral ov in
+              accum n (Cons1 (VNat ov) ix) r2 (v V.! ov') env
+          accum n ix (Red_Split bb r1 r2) (VRed_Pair _ _ v1 v2) env' =
+              caseBind bb $ \i b' ->
+                  let (vars, b'') = caseBinds b' in
+                  case evaluate b''
+                       (updateEnv (EAssoc i n) (updateEnvs vars ix env')) of
+                  VDatum bb -> if bb == dTrue then
+                                   accum n ix r1 v1 env'
+                               else
+                                   accum n ix r2 v2 env'
+          accum n ix (Red_Add h ee) (VRed_Num s) env' =
+              caseBind ee $ \i e' ->
+                  let (vars, e'') = caseBinds e'
+                      v = evaluate e''
+                          (updateEnv (EAssoc i n) (updateEnvs vars ix env')) in
+                  modifySTRef' s (evalOp (Sum h) v)
+          accum _ _ Red_Nop _ _ = return ()
+          accum _ _ _ _ _ = error "Some impossible combinations happened?"
+
+          done :: VReducer s a -> ST s (Value a)
+          done (VRed_Num s)            = readSTRef s
+          done VRed_Unit               = return (VDatum dUnit)
+          done (VRed_Pair s1 s2 v1 v2) = do
+            v1' <- done v1
+            v2' <- done v2
+            return (VDatum $ dPair_ s1 s2 v1' v2')
+          done (VRed_Array v)          = VArray <$> V.sequence (V.map done v)
+
+evaluateDatum
+    :: (ABT Term abt)
+    => Datum (abt '[]) (HData' a)
+    -> Env
+    -> Value (HData' a)
+evaluateDatum d env = VDatum (fmap11 (flip evaluate env) d)
+
+evaluateCase
+    :: forall abt a b
+    .  (ABT Term abt)
+    => abt '[] a
+    -> [Branch a abt b]
+    -> Env
+    -> Value b
+evaluateCase o es env =
+    case runIdentity $ matchBranches evaluateDatum' (evaluate o env) es of
+    Just (Matched rho b) ->
+        evaluate b (extendFromMatch (fromAssocs rho) env)
+    _ -> error "Missing cases in match expression"
+    where
+    extendFromMatch :: [Assoc Value] -> Env -> Env
+    extendFromMatch []                env' = env'
+    extendFromMatch (Assoc x v : xvs) env' =
+        extendFromMatch xvs (updateEnv (EAssoc x v) env')
+
+    evaluateDatum' :: DatumEvaluator Value Identity
+    evaluateDatum' = return . Just . getVDatum
+
+    getVDatum :: Value (HData' a) -> Datum Value (HData' a)
+    getVDatum (VDatum a) = a
+
+evaluateSuperpose
+    :: (ABT Term abt)
+    => NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
+    -> Env
+    -> Value ('HMeasure a)
+evaluateSuperpose ((q, m) :| []) env =
+    case evaluate m env of
+    VMeasure m' ->
+        let VProb q' = evaluate q env
+        in  VMeasure (\(VProb p) g -> m' (VProb $ p * q') g)
+        
+evaluateSuperpose pms@((_, m) :| _) env =
+    case evaluate m env of
+    VMeasure m' ->
+        let pms'     = L.toList pms
+            weights  = map ((flip evaluate env) . fst) pms'
+            (x,y,ys) = normalize weights
+        in VMeasure $ \(VProb p) g ->
+            if not (y > (0::Double)) then return Nothing else do
+            u <- MWC.uniformR (0, y) g
+            case [ m1 | (v,(_,m1)) <- zip (scanl1 (+) ys) pms', u <= v ] of
+                m2 : _ ->
+                    case evaluate m2 env of
+                    VMeasure m2' -> m2' (VProb $ p * x * LF.logFloat y) g
+                []     -> m' (VProb $ p * x * LF.logFloat y) g
+
+----------------------------------------------------------------
+
+-- Useful 'short-hand'
+intToNatural :: Int -> Natural
+intToNatural = unsafeNatural . toInteger
+
+unsafeInt :: Natural -> Int
+unsafeInt = fromInteger . fromNatural
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Simplify.hs b/haskell/Language/Hakaru/Simplify.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Simplify.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE TypeSynonymInstances
+           , FlexibleInstances
+           , FlexibleContexts
+           , DeriveDataTypeable
+           , CPP
+           , GADTs
+           , DataKinds
+           , OverloadedStrings
+           , ScopedTypeVariables
+           , TypeOperators
+           , RecordWildCards
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.28
+-- |
+-- Module      :  Language.Hakaru.Simplify
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Take strings from Maple and interpret them in Haskell (Hakaru)
+----------------------------------------------------------------
+module Language.Hakaru.Simplify
+    ( simplify, simplifyWithOpts
+    , simplify'
+    , simplifyDebug
+    ) where
+
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Maple 
+import Language.Hakaru.Syntax.TypeCheck
+
+----------------------------------------------------------------
+
+simplify
+    :: forall abt a
+    .  (ABT Term abt) 
+    => abt '[] a -> IO (abt '[] a)
+simplify = simplifyWithOpts defaultMapleOptions
+
+simplifyWithOpts
+    :: forall abt a
+    .  (ABT Term abt) 
+    => MapleOptions () -> abt '[] a -> IO (abt '[] a)
+simplifyWithOpts o = sendToMaple o{command=MapleCommand Simplify}
+
+simplify'
+    :: forall abt
+    .  (ABT Term (abt Term)) 
+    => TypedAST (abt Term)  -> IO (TypedAST (abt Term))
+simplify' = sendToMaple' defaultMapleOptions{command="Simplify"}
+
+simplifyDebug
+    :: forall abt a
+    .  (ABT Term abt) 
+    => Bool
+    -> Int
+    -> abt '[] a
+    -> IO (abt '[] a)
+simplifyDebug d t = sendToMaple
+  defaultMapleOptions{command=MapleCommand Simplify,
+                      debug=d,timelimit=t}
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Summary.hs b/haskell/Language/Hakaru/Summary.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Summary.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE TypeSynonymInstances
+           , FlexibleInstances
+           , FlexibleContexts
+           , DeriveDataTypeable
+           , CPP
+           , GADTs
+           , DataKinds
+           , OverloadedStrings
+           , ScopedTypeVariables
+           , TypeOperators
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2017.06.19
+-- |
+-- Module      :  Language.Hakaru.Summary
+-- Copyright   :  Copyright (c) 2017 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Take strings from Maple and interpret them in Haskell (Hakaru)
+----------------------------------------------------------------
+module Language.Hakaru.Summary
+    ( summary
+    , summaryDebug
+    , MapleException(MapleInterpreterException)
+    ) where
+
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Maple 
+
+----------------------------------------------------------------
+
+summary
+    :: forall abt a
+    .  (ABT Term abt) 
+    => abt '[] a -> IO (abt '[] a)
+summary = sendToMaple defaultMapleOptions{command=MapleCommand Summarize}
+
+summaryDebug
+    :: forall abt a
+    .  (ABT Term abt) 
+    => Bool -> abt '[] a -> IO (abt '[] a)
+summaryDebug d = sendToMaple
+   defaultMapleOptions{command=MapleCommand Summarize,
+                       debug=d}
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/ABT.hs b/haskell/Language/Hakaru/Syntax/ABT.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/ABT.hs
@@ -0,0 +1,1145 @@
+{-# LANGUAGE CPP
+           , ScopedTypeVariables
+           , GADTs
+           , DataKinds
+           , PolyKinds
+           , TypeInType
+           , TypeOperators
+           , Rank2Types
+           , MultiParamTypeClasses
+           , FlexibleContexts
+           , FlexibleInstances
+           , FunctionalDependencies
+           , UndecidableInstances
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.24
+-- |
+-- Module      :  Language.Hakaru.Syntax.ABT
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- The interface for abstract binding trees. Given the generating
+-- functor 'Term': the non-recursive 'View' type extends 'Term' by
+-- adding variables and binding; and each 'ABT' type (1) provides
+-- some additional annotations at each recursion site, and then (2)
+-- ties the knot to produce the recursive trees. For an introduction
+-- to this technique\/approach, see:
+--
+--    * <http://semantic-domain.blogspot.co.uk/2015/03/abstract-binding-trees.html>
+--    * <http://semantic-domain.blogspot.co.uk/2015/03/abstract-binding-trees-addendum.html>
+--    * <http://winterkoninkje.dreamwidth.org/103978.html>
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.ABT
+    (
+    -- * Our basic notion of variables.
+      module Language.Hakaru.Syntax.Variable
+    , resolveVar
+
+    -- * The abstract binding tree interface
+    -- See note about exposing 'View', 'viewABT', and 'unviewABT'
+    , View(..)
+    , unviewABT
+    , ABT(..)
+    , caseVarSyn
+    , binds
+    , binds_
+    , caseBinds
+    , underBinders
+    , maxNextFree
+    , maxNextBind
+    , maxNextFreeOrBind
+    -- ** Capture avoiding substitution for any 'ABT'
+    , rename
+    , renames
+    , subst
+    , substM
+    , substs
+    -- ** Constructing first-order trees with a HOAS-like API
+    -- cf., <http://comonad.com/reader/2014/fast-circular-substitution/>
+    , binder
+    , binderM
+    , Binders(binders)
+    -- *** Highly experimental
+    -- , Hint(..)
+    -- , multibinder
+    , withMetadata
+    -- ** Abstract nonsense
+    , cataABT
+    , cataABTM
+    , paraABT
+    , dupABT
+
+    -- * Some ABT instances
+    , TrivialABT()
+    , MemoizedABT()
+    , MetaABT(..)
+    ) where
+
+import           Data.Text         (Text, empty)
+import qualified Data.Foldable     as F
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative hiding (empty)
+import           Data.Monoid                (Monoid(..))
+#endif
+
+import Control.Monad.Identity    
+import Data.Kind
+import Data.Number.Nat
+import Language.Hakaru.Syntax.IClasses
+-- TODO: factor the definition of the 'Sing' type family out from
+-- the instances, so that we can make our ABT stuff totally independent
+-- of the definition of Hakaru's types.
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Syntax.Variable
+
+#ifdef __TRACE_DISINTEGRATE__
+import Debug.Trace (trace)
+#endif
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: (probably) parameterize the 'ABT' class over it's
+-- implementation of 'Variable', so that after we're done constructing
+-- terms with 'binder' we can make the varID strict\/unboxed.
+
+-- TODO: (maybe) parameterize the 'ABT' class over it's implementation
+-- of 'View' so that we can unpack the implementation of 'Variable'
+-- into the 'Var' constructor. That is, the current version does
+-- this unpacking, but if we parameterize the variable implementation
+-- then we'd lose it; so this would allow us to regain it. Also,
+-- if we do this, then 'MemoizedABT' could define it's own specialized
+-- 'Bind' in order to keep track of whether bound variables occur
+-- or not (for defining 'caseBind' precisely).
+
+
+----------------------------------------------------------------
+-- | The raw view of abstract binding trees, to separate out variables
+-- and binders from (1) the rest of syntax (cf., 'Term'), and (2)
+-- whatever annotations (cf., the 'ABT' instances).
+--
+-- The first parameter gives the generating signature for the
+-- signature. The second index gives the number and types of
+-- locally-bound variables. And the final parameter gives the type
+-- of the whole expression.
+--
+-- HACK: We only want to expose the patterns generated by this type,
+-- not the constructors themselves. That way, callers must use the
+-- smart constructors of the ABT class. But if we don't expose this
+-- type, then clients can't define their own ABT instances (without
+-- reinventing their own copy of this type)...
+data View :: (k -> Type) -> [k] -> k -> Type where
+    -- BUG: haddock doesn't like annotations on GADT constructors
+    -- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+    -- Some syntax from the generating signature @rec@.
+    Syn  :: !(rec a) -> View rec '[] a
+
+    -- A variable use.
+    Var  :: {-# UNPACK #-} !(Variable a) -> View rec '[] a
+
+    -- N.B., this constructor is recursive, thus minimizing the
+    -- memory overhead of whatever annotations our ABT stores (we
+    -- only annotate once, at the top of a chaing of 'Bind's, rather
+    -- than before each one). However, in the 'ABT' class, we provide
+    -- an API as if things went straight back to @abt@. Doing so
+    -- requires that 'caseBind' is part of the class so that we
+    -- can push whatever annotations down over one single level of
+    -- 'Bind', rather than pushing over all of them at once and
+    -- then needing to reconstruct all but the first one.
+    --
+    -- A variable binding.
+    Bind
+        :: {-# UNPACK #-} !(Variable a)
+        -> !(View rec xs b)
+        -> View rec (a ': xs) b
+
+
+instance Functor12 View where
+    fmap12 f (Syn  t)   = Syn  (f t)
+    fmap12 _ (Var  x)   = Var  x
+    fmap12 f (Bind x e) = Bind x (fmap12 f e)
+
+instance Foldable12 View where
+    foldMap12 f (Syn  t)   = f t
+    foldMap12 _ (Var  _)   = mempty
+    foldMap12 f (Bind _ e) = foldMap12 f e
+
+instance Traversable12 View where
+    traverse12 f (Syn t)    = Syn <$> f t
+    traverse12 _ (Var x)    = pure $ Var x
+    traverse12 f (Bind x e) = Bind x <$> traverse12 f e
+
+
+instance (Show1 (Sing :: k -> Type), Show1 rec)
+    => Show2 (View (rec :: k -> Type))
+    where
+    showsPrec2 p (Syn  t)   = showParen_1  p "Syn"  t
+    showsPrec2 p (Var  x)   = showParen_1  p "Var"  x
+    showsPrec2 p (Bind x v) = showParen_12 p "Bind" x v
+
+instance (Show1 (Sing :: k -> Type), Show1 rec)
+    => Show1 (View (rec :: k -> Type) xs)
+    where
+    showsPrec1 = showsPrec2
+    show1      = show2
+
+-- TODO: could weaken the Show1 requirements to Show requirements...
+instance (Show1 (Sing :: k -> Type), Show1 rec)
+    => Show (View (rec :: k -> Type) xs a)
+    where
+    showsPrec = showsPrec1
+    show      = show1
+
+
+-- TODO: neelk includes 'subst' as a method. Any reason we should?
+-- TODO: jon includes instantiation as a method. Any reason we should?
+-- TODO: require @(JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type), Foldable21 syn)@ since all our instances will need those too?
+--
+-- | The class interface for abstract binding trees. The first
+-- argument, @syn@, gives the syntactic signature of the ABT;
+-- whereas, the second argument, @abt@, is thing being declared as
+-- an ABT for @syn@. The first three methods ('syn', 'var', 'bind')
+-- alow us to inject any 'View' into the @abt@. The other methods
+-- provide various views for extracting information from the @abt@.
+--
+-- At present we're using fundeps in order to restrict the relationship
+-- between @abt@ and @syn@. However, in the future we may move @syn@
+-- into being an associated type, if that helps to clean things up
+-- (since fundeps and type families don't play well together). The
+-- idea behind the fundep is that certain @abt@ implementations may
+-- only be able to work for particular @syn@ signatures. This isn't
+-- the case for 'TrivialABT' nor 'MemoizedABT', but isn't too
+-- far-fetched.
+class ABT (syn :: ([k] -> k -> Type) -> k -> Type) (abt :: [k] -> k -> Type) | abt -> syn where
+    -- Smart constructors for building a 'View' and then injecting it into the @abt@.
+    syn  :: syn abt  a -> abt '[] a
+    var  :: Variable a -> abt '[] a
+    bind :: Variable a -> abt xs b -> abt (a ': xs) b
+
+    -- TODO: better name. "unbind"? "fromBind"?
+    --
+    -- When the left side is defined, we have the following laws:
+    -- > caseBind e bind == e
+    -- > caseBind (bind x e) k == k x (unviewABT $ viewABT e)
+    -- However, we do not necessarily have the following:
+    -- > caseBind (bind x e) k == k x e
+    -- because the definition of 'caseBind' for 'MemoizedABT'
+    -- is not exact.
+    --
+    -- | Since the first argument to @abt@ is not @'[]@, we know
+    -- it must be 'Bind'. So we do case analysis on that constructor,
+    -- pushing the annotation down one binder (but not over the
+    -- whole recursive 'View' layer).
+    caseBind :: abt (x ': xs) a -> (Variable x -> abt xs a -> r) -> r
+
+    -- See note about exposing 'View', 'viewABT', and 'unviewABT'.
+    -- We could replace 'viewABT' with a case-elimination version...
+    viewABT  :: abt xs a -> View (syn abt) xs a
+
+    freeVars :: abt xs a -> VarSet (KindOf a)
+
+    -- | Return the successor of the largest 'varID' of /free/
+    -- variables. Thus, if there are no free variables we return
+    -- zero. The default implementation is to take the successor
+    -- of the maximum of 'freeVars'. This is part of the class in
+    -- case you want to memoize it.
+    --
+    -- This function is used in order to generate guaranteed-fresh
+    -- variables without the need for a name supply. In particular,
+    -- it's used to ensure that the generated variable don't capture
+    -- any free variables in the term.
+    --
+    -- * /Default:/ @nextFree = 'nextVarID' . 'freeVars'@
+    nextFree :: abt xs a -> Nat
+    nextFree = nextVarID . freeVars
+
+    -- | Return the successor of the largest 'varID' of variable
+    -- /binding sites/ (i.e., of variables bound by the 'Bind'
+    -- constructor). Thus, if there are no binders, then we will
+    -- return zero. N.B., this should return zero for /uses/ of the
+    -- bound variables themselves. This is part of the class in
+    -- case you want to memoize it.
+    --
+    -- This function is used in order to generate guaranteed-fresh
+    -- variables without the need for a name supply. In particular,
+    -- it's used to ensure that the generated variable won't be
+    -- captured or shadowed by bindings already in the term.
+    nextBind :: abt xs a -> Nat
+
+
+    -- | Return the maximum of 'nextFree' and 'nextBind'. For when
+    -- you want to be really paranoid about choosing new variable
+    -- IDs. In principle this shouldn't be necessary since we should
+    -- always freshen things when going under binders; but for some
+    -- reason only using 'nextFree' keeps leading to bugs in
+    -- transformations like disintegration and expectation.
+    --
+    -- /N.B./, it is impossible to implement this function such
+    -- that it is lazy in the bound variables like 'nextBind' is.
+    -- Thus, it cannot be used for knot-tying tricks like 'nextBind'
+    -- can.
+    --
+    -- * /Default:/ @nextFreeOrBind e = 'nextFree' e `max` 'nextBind' e@
+    nextFreeOrBind :: abt xs a -> Nat
+    nextFreeOrBind e = nextFree e `max` nextBind e
+
+
+    -- TODO: add a function for checking alpha-equivalence? Refreshing all variable IDs to be in some canonical form? Other stuff?
+
+
+-- See note about exposing 'View', 'viewABT', and 'unviewABT'
+unviewABT :: (ABT syn abt) => View (syn abt) xs a -> abt xs a
+unviewABT (Syn  t)   = syn  t
+unviewABT (Var  x)   = var  x
+unviewABT (Bind x v) = bind x (unviewABT v)
+
+
+-- | Since the first argument to @abt@ is @'[]@, we know it must
+-- be either 'Syn' of 'Var'. So we do case analysis with those two
+-- constructors.
+caseVarSyn
+    :: (ABT syn abt)
+    => abt '[] a
+    -> (Variable a -> r)
+    -> (syn abt  a -> r)
+    -> r
+caseVarSyn e var_ syn_ =
+    case viewABT e of
+    Syn t -> syn_ t
+    Var x -> var_ x
+
+
+-- | Call 'bind' repeatedly.
+binds :: (ABT syn abt) => List1 Variable xs -> abt ys b -> abt (xs ++ ys) b
+binds Nil1         e = e
+binds (Cons1 x xs) e = bind x (binds xs e)
+
+-- | A specialization of 'binds' for when @ys ~ '[]@. We define
+-- this to avoid the need for using 'eqAppendIdentity' on the result
+-- of 'binds' itself.
+binds_ :: (ABT syn abt) => List1 Variable xs -> abt '[] b -> abt xs b
+binds_ Nil1         e = e
+binds_ (Cons1 x xs) e = bind x (binds_ xs e)
+
+
+-- TODO: take a continuation so that the type more closely resembles 'caseBind'; or, remove the CPSing in 'caseBind' so it more closely resembles this
+-- | Call 'caseBind' repeatedly. (Actually we use 'viewABT'.)
+caseBinds :: (ABT syn abt) => abt xs a -> (List1 Variable xs, abt '[] a)
+caseBinds = go . viewABT
+    where
+    go  :: (ABT syn abt)
+        => View (syn abt) xs a -> (List1 Variable xs, abt '[] a)
+    go (Syn  t)   = (Nil1, syn t)
+    go (Var  x)   = (Nil1, var x)
+    go (Bind x v) = let ~(xs,e) = go v in (Cons1 x xs, e)
+
+
+-- TODO: give better name
+-- | Transform expression under binds
+underBinders
+    :: (ABT syn abt)
+    => (abt '[] a -> abt '[] b)
+    -> abt xs a
+    -> abt xs b
+underBinders f e =
+    let (vars, e') = caseBinds e
+    in binds_ vars (f e')
+
+
+-- | Call 'nextFree' on all the terms and return the maximum.
+maxNextFree :: (ABT syn abt, F.Foldable f) => f (Some2 abt) -> Nat
+maxNextFree = unMaxNat . F.foldMap (\(Some2 e) -> MaxNat $ nextFree e)
+
+-- | Call 'nextBind' on all the terms and return the maximum.
+maxNextBind :: (ABT syn abt, F.Foldable f) => f (Some2 abt) -> Nat
+maxNextBind = unMaxNat . F.foldMap (\(Some2 e) -> MaxNat $ nextBind e)
+
+-- | Call 'nextFreeOrBind' on all the terms and return the maximum.
+maxNextFreeOrBind :: (ABT syn abt, F.Foldable f) => f (Some2 abt) -> Nat
+maxNextFreeOrBind =
+    unMaxNat . F.foldMap (\(Some2 e) -> MaxNat $ nextFreeOrBind e)
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- | A trivial ABT with no annotations.
+--
+-- The 'Show' instance does not expose the raw underlying data
+-- types, but rather prints the smart constructors 'var', 'syn',
+-- and 'bind'. This makes things prettier, but also means that if
+-- you paste the string into a Haskell file you can use it for any
+-- 'ABT' instance.
+--
+-- The 'freeVars', 'nextFree', and 'nextBind' methods are all very
+-- expensive for this ABT, because we have to traverse the term
+-- every time we want to call them. The 'MemoizedABT' implementation
+-- fixes this.
+newtype TrivialABT (syn :: ([k] -> k -> Type) -> k -> Type) (xs :: [k]) (a :: k) =
+    TrivialABT (View (syn (TrivialABT syn)) xs a)
+
+instance (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type), Foldable21 syn)
+    => ABT (syn :: ([k] -> k -> Type) -> k -> Type) (TrivialABT syn)
+    where
+    syn  t                = TrivialABT (Syn  t)
+    var  x                = TrivialABT (Var  x)
+    bind x (TrivialABT v) = TrivialABT (Bind x v)
+
+    caseBind (TrivialABT v) k =
+        case v of
+        Bind x v' -> k x (TrivialABT v')
+
+    viewABT (TrivialABT v) = v
+
+    freeVars = go . viewABT
+        where
+        go  :: View (syn (TrivialABT syn)) xs a
+            -> VarSet (KindOf a)
+        go (Syn  t)   = foldMap21 freeVars t
+        go (Var  x)   = singletonVarSet x
+        go (Bind x v) = deleteVarSet x (go v)
+
+    -- N.B., we could make this implementation much faster by
+    -- avoiding traversing under binders. Under the assumption that
+    -- the largest binder is the outermost one, this optimization
+    -- is sound; and indeed the 'binder' function maintains that
+    -- invariant. (If implementing this optimization, we can
+    -- distinguish the case of 'Syn' underneath 'Bind' vs a top-level
+    -- 'Syn' by checking whether the accumulator @n@ is zero or
+    -- not.) However, if the largest binder is not the outermost
+    -- one, then it would return the wrong answer. Since the
+    -- 'TrivialABT' type is mainly intended for testing rather than
+    -- production use, we avoid using this optimization so as to
+    -- err on the side of soundness.
+    nextBind = go . viewABT
+        where
+        go :: View (syn (TrivialABT syn)) xs a -> Nat
+        go (Syn  t)   = unMaxNat $ foldMap21 (MaxNat . nextBind) t
+        go (Var  _)   = unMaxNat $ mempty -- We mustn't look at variable *uses*!
+        go (Bind x v) = max (1 + varID x) (go v)
+
+
+    -- Deforest the intermediate 'VarSet' of the default 'nextFree'
+    -- implementation, and fuse the two passes of 'nextFree' and
+    -- 'nextBind' into a single pass.
+    nextFreeOrBind = go . viewABT
+        where
+        go :: View (syn (TrivialABT syn)) xs a -> Nat
+        go (Syn  t)   = unMaxNat $ foldMap21 (MaxNat . nextFreeOrBind) t
+        go (Var  x)   = 1 + varID x
+        go (Bind x v) = max (1 + varID x) (go v)
+
+
+-- BUG: requires UndecidableInstances
+instance (Show1 (Sing :: k -> Type), Show1 (syn (TrivialABT syn)))
+    => Show2 (TrivialABT (syn :: ([k] -> k -> Type) -> k -> Type))
+    where
+    {-
+    -- Print the concrete data constructors:
+    showsPrec2 p (TrivialABT v) =
+        showParen (p > 9)
+            ( showString "TrivialABT "
+            . showsPrec1 11 v
+            )
+    -}
+    -- Do something a bit prettier. (Because we print the smart
+    -- constructors, this output can also be cut-and-pasted to work
+    -- for any ABT instance.)
+    showsPrec2 p (TrivialABT (Syn  t))   = showParen_1  p "syn"  t
+    showsPrec2 p (TrivialABT (Var  x))   = showParen_1  p "var"  x
+    showsPrec2 p (TrivialABT (Bind x v)) = showParen_11 p "bind" x (TrivialABT v)
+
+instance (Show1 (Sing :: k -> Type), Show1 (syn (TrivialABT syn)))
+    => Show1 (TrivialABT (syn :: ([k] -> k -> Type) -> k -> Type) xs)
+    where
+    showsPrec1 = showsPrec2
+    show1      = show2
+
+-- TODO: could weaken the Show1 requirements to Show requirements...
+instance (Show1 (Sing :: k -> Type), Show1 (syn (TrivialABT syn)))
+    => Show (TrivialABT (syn :: ([k] -> k -> Type) -> k -> Type) xs a)
+    where
+    showsPrec = showsPrec1
+    show      = show1
+
+----------------------------------------------------------------
+-- TODO: replace @VarSet@ with @VarMap Nat@ where the
+-- Nat is the number of times the variable occurs. That way, we can
+-- tell when a bound variable is unused or only used only once (and
+-- hence performing beta\/let reduction would be a guaranteed win),
+-- and if it's used more than once then we can use the number of
+-- occurances in our heuristic for deciding whether reduction would
+-- be a win or not.
+--
+-- TODO: generalize this pattern for any monoidal annotation?
+-- TODO: what is the performance cost of letting 'memoizedFreeVars' be lazy? Is it okay to lose the ability to use 'binder' in order to shore that up?
+
+
+-- WARNING: in older versions of the library, there was an issue
+-- about the memoization of 'nextBind' breaking our ability to
+-- tie-the-knot in 'binder'. Everything seems to work now, but it's
+-- not entirely clear to me what changed...
+
+-- | An ABT which memoizes 'freeVars', 'nextBind', and 'nextFree',
+-- thereby making them take only /O(1)/ time.
+--
+-- N.B., the memoized set of free variables is lazy so that we can
+-- tie-the-knot in 'binder' without interfering with our memos. The
+-- memoized 'nextFree' must be lazy for the same reason.
+data MemoizedABT (syn :: ([k] -> k -> Type) -> k -> Type) (xs :: [k]) (a :: k) =
+    MemoizedABT
+        { _memoizedFreeVars :: VarSet (KindOf a) -- N.B., lazy!
+        , memoizedNextFree  :: Nat -- N.B., lazy!
+        , memoizedNextBind  :: {-# UNPACK #-} !Nat
+        , memoizedView      :: !(View (syn (MemoizedABT syn)) xs a)
+        }
+
+-- HACK: ""Cannot use record selector ‘_memoizedFreeVars’ as a function due to escaped type variables""
+memoizedFreeVars :: MemoizedABT syn xs a -> VarSet (KindOf a)
+memoizedFreeVars (MemoizedABT xs _ _ _) = xs
+
+
+instance (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type), Foldable21 syn)
+    => ABT (syn :: ([k] -> k -> Type) -> k -> Type) (MemoizedABT syn)
+    where
+    syn t =
+        MemoizedABT
+            (foldMap21 freeVars t)
+            (unMaxNat $ foldMap21 (MaxNat . nextFree) t)
+            (unMaxNat $ foldMap21 (MaxNat . nextBind) t)
+            (Syn t)
+
+    var x =
+        MemoizedABT
+            (singletonVarSet x)
+            (1 + varID x)
+            0
+            (Var x)
+
+    bind x (MemoizedABT xs _ nb v) =
+        let xs' = deleteVarSet x xs
+        in MemoizedABT
+            xs'
+            (nextVarID xs')
+            ((1 + varID x) `max` nb)
+            (Bind x v)
+
+    -- N.B., when we go under the binder, the variable @x@ may not
+    -- actually be used, but we add it to the set of freeVars
+    -- anyways. The reasoning is thus: this function is mainly used
+    -- in defining 'subst', and for that purpose it's important to
+    -- track all the variables which /could be/ free, so that we
+    -- can freshen appropriately. It may be safe to not include @x@
+    -- when @x@ is not actually used in @v'@, but it's best not to
+    -- risk it. Moreover, once we add support for open terms (i.e.,
+    -- truly-free variables) then we'll need to account for the
+    -- fact that the variable @x@ may come to be used in the grounding
+    -- of the open term, even though it's not used in the part of
+    -- the term we already know. Similarly, the true 'nextBind' may
+    -- be lower now that we're going under this binding; but keeping
+    -- it the same is an always valid approximation.
+    --
+    -- TODO: we could actually compute things exactly, similar to
+    -- how we do it in 'syn'; but unclear if that's really worth it...
+    caseBind (MemoizedABT xs nf nb v) k =
+        case v of
+        Bind x v' ->
+            k x $ MemoizedABT
+                (insertVarSet x xs)
+                ((1 + varID x) `max` nf)
+                nb
+                v'
+
+    viewABT  = memoizedView
+    freeVars = memoizedFreeVars
+    nextFree = memoizedNextFree
+    nextBind = memoizedNextBind
+
+
+instance (Show1 (Sing :: k -> Type), Show1 (syn (MemoizedABT syn)))
+    => Show2 (MemoizedABT (syn :: ([k] -> k -> Type) -> k -> Type))
+    where
+    showsPrec2 p (MemoizedABT xs nf nb v) =
+        showParen (p > 9)
+            ( showString "MemoizedABT "
+            . showsPrec  11 xs
+            . showString " "
+            . showsPrec  11 nf
+            . showString " "
+            . showsPrec  11 nb
+            . showString " "
+            . showsPrec1 11 v
+            )
+
+instance (Show1 (Sing :: k -> Type), Show1 (syn (MemoizedABT syn)))
+    => Show1 (MemoizedABT (syn :: ([k] -> k -> Type) -> k -> Type) xs)
+    where
+    showsPrec1 = showsPrec2
+    show1      = show2
+
+-- TODO: could weaken the Show1 requirements to Show requirements...
+instance (Show1 (Sing :: k -> Type), Show1 (syn (MemoizedABT syn)))
+    => Show (MemoizedABT (syn :: ([k] -> k -> Type) -> k -> Type) xs a)
+    where
+    showsPrec = showsPrec1
+    show      = show1
+
+----------------------------------------------------------------
+
+
+-- | An ABT which carries around metadata at each node.
+--
+-- Right now this essentially inlines the the TrivialABT instance
+-- but it would be nice if it was abstract in the choice of ABT.
+data MetaABT
+    (meta :: Type)
+    (syn  :: ([k] -> k -> Type) -> k -> Type)
+    (xs   :: [k])
+    (a    :: k) =
+    MetaABT
+    { getMetadata  :: !(Maybe meta)
+    , metaView     :: !(View (syn (MetaABT meta syn)) xs a)
+    }
+
+withMetadata
+    :: meta
+    -> MetaABT meta syn xs a
+    -> MetaABT meta syn xs a
+withMetadata x (MetaABT _ v) = MetaABT (Just x) v
+
+instance (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type), Foldable21 syn)
+    => ABT (syn :: ([k] -> k -> Type) -> k -> Type) (MetaABT meta syn)
+    where
+    syn t                   = MetaABT Nothing (Syn  t)
+    var x                   = MetaABT Nothing (Var  x)
+    bind x (MetaABT meta v) = MetaABT meta    (Bind x v)
+
+    caseBind (MetaABT meta v) k =
+        case v of
+        Bind x v' -> k x (MetaABT meta v')
+
+    viewABT  = metaView
+
+    freeVars = go . viewABT
+        where
+        go  :: View (syn (MetaABT meta syn)) xs a
+            -> VarSet (KindOf a)
+        go (Syn  t)   = foldMap21 freeVars t
+        go (Var  x)   = singletonVarSet x
+        go (Bind x v) = deleteVarSet x (go v)
+
+    nextBind = go . viewABT
+        where
+        go :: View (syn (MetaABT meta syn)) xs a -> Nat
+        go (Syn  t)   = unMaxNat $ foldMap21 (MaxNat . nextBind) t
+        go (Var  _)   = unMaxNat $ mempty
+        go (Bind x v) = max (1 + varID x) (go v)
+
+
+    -- Deforest the intermediate 'VarSet' of the default 'nextFree'
+    -- implementation, and fuse the two passes of 'nextFree' and
+    -- 'nextBind' into a single pass.
+    nextFreeOrBind = go . viewABT
+        where
+        go :: View (syn (MetaABT meta syn)) xs a -> Nat
+        go (Syn  t)   = unMaxNat $ foldMap21 (MaxNat . nextFreeOrBind) t
+        go (Var  x)   = 1 + varID x
+        go (Bind x v) = max (1 + varID x) (go v)
+
+
+
+instance ( Show1 (Sing :: k -> Type)
+         , Show1 (syn (MetaABT meta syn))
+         , Show  meta)
+    => Show2 (MetaABT meta (syn :: ([k] -> k -> Type) -> k -> Type))
+    where
+    showsPrec2 p (MetaABT meta v) =
+        showParen (p > 9)
+            ( showString "MetaABT "
+            . showsPrec  11 meta
+            . showString " "
+            . showsPrec1 11 v
+            )
+
+instance ( Show1 (Sing :: k -> Type)
+         , Show1 (syn (MetaABT meta syn))
+         , Show  meta)
+    => Show1 (MetaABT meta (syn :: ([k] -> k -> Type) -> k -> Type) xs)
+    where
+    showsPrec1 = showsPrec2
+    show1      = show2
+
+instance ( Show1 (Sing :: k -> Type)
+         , Show1 (syn (MetaABT meta syn))
+         , Show  meta)
+    => Show (MetaABT meta (syn :: ([k] -> k -> Type) -> k -> Type) xs a)
+    where
+    showsPrec = showsPrec1
+    show      = show1
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- TODO: do something smarter
+-- | If the variable is in the set, then construct a new one which
+-- isn't (but keeping the same hint and type as the old variable).
+-- If it isn't in the set, then just return it.
+-- FIXME: this is actually not used!
+freshen
+    :: (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type))
+    => Variable (a :: k)
+    -> VarSet (KindOf a)
+    -> Variable a
+freshen x xs
+    | x `memberVarSet` xs = let i = nextVarID xs in i `seq` x{varID = i}
+    | otherwise           = x
+
+
+-- TODO: reimplement this using 'cataABT' or 'paraABT'. Possibly make
+-- strict versions of them in order to match the semantics we already
+-- have about throwing 'VarEqTypeError' in a timely manner.
+--
+-- | Rename a free variable. Does nothing if the variable is bound.
+rename
+    :: forall k syn abt (a :: k) xs (b :: k)
+    .  (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type), Functor21 syn, ABT syn abt)
+    => Variable a
+    -> Variable a
+    -> abt xs b
+    -> abt xs b
+rename x y =
+#ifdef __TRACE_DISINTEGRATE__
+    trace ("renaming " ++ show (varID x)
+           ++ " to " ++ show (varID y)) $
+#endif           
+    start
+    where
+    start :: forall xs' b'. abt xs' b' -> abt xs' b'
+    start e = loop e (viewABT e)
+
+    -- TODO: is it actually worth passing around the @e@? Benchmark.
+    loop :: forall xs' b'. abt xs' b' -> View (syn abt) xs' b' -> abt xs' b'
+    loop _ (Syn t) = syn $! fmap21 start t
+    loop e (Var z) =
+        case varEq x z of
+        Just Refl -> var y
+        Nothing   -> e
+    loop e (Bind z v) =
+#ifdef __TRACE_DISINTEGRATE__
+        trace ("checking varEq "++ show (varID x) ++ " " ++ show (varID z)) $
+#endif
+        case varEq x z of
+        Just Refl -> e
+        Nothing   -> bind z $ loop (caseBind e $ const id) v
+
+
+-- TODO: reimplement this using 'cataABT' or 'paraABT'. Possibly make
+-- strict versions of them in order to match the semantics we already
+-- have about throwing 'VarEqTypeError' in a timely manner.
+--
+-- TODO: keep track of a variable renaming environment, and do
+-- renaming on the fly rather than traversing the ABT repeatedly.
+--
+-- TODO: make an explicit distinction between substitution in general
+-- vs instantiation of the top-level bound variable (i.e., the
+-- function of type @abt (x ': xs) a -> abt '[] x -> abt xs a@).
+-- cf., <http://hackage.haskell.org/package/abt>
+--
+-- | Perform capture-avoiding substitution. This function will
+-- either preserve type-safety or else throw an 'VarEqTypeError'
+-- (depending on which interpretation of 'varEq' is chosen). N.B.,
+-- to ensure timely throwing of exceptions, the 'Term' and 'ABT'
+-- should have strict 'fmap21' definitions.
+subst
+    :: forall k syn abt (a :: k) xs (b :: k)
+    .  (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type), Traversable21 syn, ABT syn abt)
+    => Variable a
+    -> abt '[]  a
+    -> abt xs   b
+    -> abt xs   b
+subst x e = 
+#ifdef __TRACE_DISINTEGRATE__
+    trace ("about to subst " ++ show (varID x)) $
+#endif
+    runIdentity . substM x e varCase
+    where
+      varCase :: forall m b'. (Applicative m, Functor m, Monad m)
+              => Variable b' -> m (abt '[] b')
+      varCase = return . var
+                     
+substM
+    :: forall k syn abt (a :: k) xs (b :: k) m
+    .  (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type),
+        Traversable21 syn, ABT syn abt,
+        Applicative m, Functor m, Monad m)
+    => Variable a
+    -> abt '[] a
+    -> (forall b'. Variable b' -> m (abt '[] b'))
+    -> abt xs b
+    -> m (abt xs b)
+substM x e vf =
+    start (maxNextFreeOrBind [Some2 (var x), Some2 e])
+    where
+    -- TODO: we could use the director-strings approach to optimize
+    -- this (for MemoizedABT, but pessimizing for TrivialABT) by first
+    -- checking whether @x@ is free in @f@; if so then recurse, if not
+    -- then we're done.
+    start :: forall xs' b'. Nat -> abt xs' b' -> m (abt xs' b')
+    start n f = loop n f (viewABT f)
+
+    -- TODO: is it actually worth passing around the @f@? Benchmark.
+    loop :: forall xs' b'
+         .  Nat -> abt xs' b' -> View (syn abt) xs' b' -> m (abt xs' b')
+    loop n _ (Syn t) = syn <$> traverse21 (start n) t
+    loop _ _ (Var z) =
+#ifdef __TRACE_DISINTEGRATE__
+        trace ("checking varEq " ++ show (varID x) ++ " " ++ show (varID z)) $
+#endif        
+        case varEq x z of
+          Just Refl -> return e
+          Nothing   -> vf z
+    loop n f (Bind z b) =
+        if (varID x == varID z) then return f
+        else do -- TODO: even if we don't come up with a smarter way
+                -- of freshening variables, it'd be better to just pass
+                -- both sets to 'freshen' directly and then check them
+                -- each; rather than paying for taking their union every
+                -- time we go under a binder like this.
+          let i  = 1 + max n (nextFreeOrBind f) -- (freeVars e `mappend` freeVars f)
+              z' = i `seq` z{varID = i}
+          f'' <- substM z (var z') vf (unviewABT b)
+          bind z' <$> loop i f'' (viewABT f'')
+               
+
+renames
+    :: forall k
+        (syn :: ([k] -> k -> Type) -> k -> Type)
+        (abt :: [k] -> k -> Type)
+        (xs  :: [k])
+        (a   :: k)
+    .   ( ABT syn abt
+        , JmEq1 (Sing :: k -> Type)
+        , Show1 (Sing :: k -> Type)
+        , Functor21 syn
+        )
+    => Assocs (Variable :: k -> Type)
+    -> abt xs a
+    -> abt xs a
+renames rho0 =
+    -- Guaranteed correct (since 'subst' is correct) but very inefficient
+    \e0 -> F.foldl (\e (Assoc x v) -> rename x v e) e0 (unAssocs rho0)
+
+{-
+-- called (//) in Jon's abt library. We use this textual name so we can also have 'insts' for the n-ary version, rather than iterating the unary version. Or we could use something like (!) and (!!), albeit those names tend to be used to mean other things. It'd be nice to do (@) and (@@), but the first one is illegal.
+inst
+    :: forall syn abt (a :: k) xs (b :: k)
+    .   ( JmEq1 (Sing :: k -> Type)
+        , Show1 (Sing :: k -> Type)
+        , Functor21 syn
+        , ABT syn abt
+        )
+    => abt (a ': xs) b
+    -> abt '[] a
+    -> abt xs  b
+inst f e =
+    caseBind f $ \x f' ->
+    subst x e f'
+-}
+
+
+-- BUG: This appears to have both capture and escape issues as demonstrated by 'Tests.Disintegrate.test0' and commented on at 'Language.Hakaru.Evaluation.Types.runM'.
+-- | The parallel version of 'subst' for performing multiple substitutions at once.
+substs
+    :: forall k
+        (syn :: ([k] -> k -> Type) -> k -> Type)
+        (abt :: [k] -> k -> Type)
+        (xs  :: [k])
+        (a   :: k)
+    .   ( ABT syn abt
+        , JmEq1 (Sing :: k -> Type)
+        , Show1 (Sing :: k -> Type)
+        , Traversable21 syn
+        )
+    => Assocs (abt '[])
+    -> abt xs a
+    -> abt xs a
+substs rho0 =
+    -- Guaranteed correct (since 'subst' is correct) but very inefficient
+    \e0 -> F.foldl (\e (Assoc x v) -> subst x v e) e0 (unAssocs rho0)
+    {- -- old buggy version
+    start rho0
+    where
+    fv0 :: VarSet (KindOf a)
+    fv0 = F.foldMap (\(Assoc _ e) -> freeVars e) (unAssocs rho0)
+
+    start :: forall xs' a'. Assocs abt -> abt xs' a' -> abt xs' a'
+    start rho e = loop rho e (viewABT e)
+
+    loop :: forall xs' a'
+        . Assocs abt -> abt xs' a' -> View (syn abt) xs' a' -> abt xs' a'
+    loop rho _ (Syn t) = syn $! fmap21 (start rho) t
+    loop rho e (Var x) =
+        case IM.lookup (fromNat $ varID x) (unAssocs rho) of
+        Nothing           -> e
+        Just (Assoc y e') ->
+            case varEq x y of
+            Just Refl     -> e'
+            Nothing       -> e
+    loop rho e (Bind x _body) =
+        case IM.lookup (fromNat $ varID x) (unAssocs rho) of
+        Nothing          -> e
+        Just (Assoc y _) ->
+            case varEq x y of
+            Just Refl ->
+                let rho' = IM.delete (fromNat $ varID x) (unAssocs rho) in
+                if IM.null rho'
+                then e
+                else caseBind e $ \_x body' ->
+                        bind x . loop (Assocs rho') body' $ viewABT body'
+            Nothing   ->
+                -- TODO: even if we don't come up with a smarter way
+                -- of freshening variables, it'd be better to just pass
+                -- both sets to 'freshen' directly and then check them
+                -- each; rather than paying for taking their union every
+                -- time we go under a binder like this.
+                let x' = freshen x (fv0 `mappend` freeVars e) in
+                -- HACK: the 'rename' function requires an ABT not a
+                -- View, so we have to use 'caseBind' to give its
+                -- input and then 'viewABT' to discard the topmost
+                -- annotation. We really should find a way to eliminate
+                -- that overhead.
+                caseBind e $ \_x body' ->
+                    bind x' . loop rho body' . viewABT $ rename x x' body'
+    -}
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- | A combinator for defining a HOAS-like API for our syntax.
+-- Because our 'Term' is first-order, we cannot actually have any
+-- exotic terms in our language. In principle, this function could
+-- be used to do exotic things when constructing those non-exotic
+-- terms; however, trying to do anything other than change the
+-- variable's name hint will cause things to explode (since it'll
+-- interfere with our tying-the-knot).
+--
+-- N.B., if you manually construct free variables and use them in
+-- the body (i.e., via 'var'), they may become captured by the new
+-- binding introduced here! This is inevitable since 'nextBind'
+-- never looks at variable /use sites/; it only ever looks at
+-- /binding sites/. On the other hand, if you manually construct a
+-- bound variable (i.e., manually calling 'bind' yourself), then
+-- the new binding introduced here will respect the old binding and
+-- avoid that variable ID.
+binder
+    :: (ABT syn abt)
+    => Text                     -- ^ The variable's name hint
+    -> Sing a                   -- ^ The variable's type
+    -> (abt '[] a -> abt xs b)  -- ^ Build the binder's body from a variable
+    -> abt (a ': xs) b
+binder hint typ hoas = bind x body
+    where
+    body = hoas (var x)
+    x    = Variable hint (nextBind body) typ
+    -- N.B., cannot use 'nextFree' when deciding the 'varID' of @x@
+
+
+-- A Monadic variant of @binder@ which allows constructing a term in a monadic
+-- context. The dependency on MonadFix is due to the knot-tying used to generate
+-- the bound variable.
+binderM
+  :: (MonadFix m, ABT syn abt)
+  => Text
+  -> Sing a
+  -> (abt '[] a -> m (abt xs b))
+  -> m (abt (a ': xs) b)
+binderM hint typ hoas = do
+  (var', body) <- mfix $ \ ~(_, b) -> do
+    let v = Variable hint (nextBind b) typ
+    b' <- hoas (var v)
+    return (v, b')
+  return (bind var' body)
+
+class (ABT syn abt) =>
+    Binders syn abt xs as | abt -> syn, abt xs -> as, abt as -> xs where
+    binders :: (as -> abt '[] b) -> abt xs b
+
+instance (ABT syn abt) =>
+    Binders syn abt '[] () where
+    binders hoas = hoas ()
+
+instance (Binders syn abt xs as, SingI x) =>
+    Binders syn abt (x ': xs) (abt '[] x, as) where
+    binders hoas = binder empty sing (binders . curry hoas)
+
+
+{-
+data Hint (a :: k)
+    = Hint !Text !(Sing a)
+
+instance Show1 Hint where
+    showsPrec1 p (Hint x s) = showParen_01 p "Hint" x s
+
+instance Show (Hint a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+data VS (a :: k)
+    = VS {-# UNPACK #-} !Variable !(Sing a)
+
+-- this typechecks, and it works!
+-- BUG: but it seems fairly unusable. We must give explicit type signatures to any lambdas passed as the second argument, otherwise it complains about not knowing enough about the types in @xs@... Also, the uncurriedness of it isn't very HOAS-like
+multibinder
+    :: (ABT abt) => List1 Hint xs -> (List1 abt xs -> abt b) -> abt b
+multibinder names hoas = binds vars body
+    where
+    vars = go 0 names
+        where
+        -- BUG: this puts the largest binder on the inside
+        go :: Nat -> List1 Hint xs -> List1 VS xs
+        go _ Nil                         = Nil
+        go n (Cons (Hint name typ) rest) =
+            Cons (VS (Variable name (maxBind body + n) typ) typ)
+                ((go $! n + 1) rest)
+    body = hoas (go vars)
+        where
+        go :: ABT abt => List1 VS xs -> List1 abt xs
+        go Nil                    = Nil
+        go (Cons (VS x typ) rest) = Cons (var x typ) (go rest)
+
+    binds :: ABT abt => List1 VS xs -> abt a -> abt a
+    binds Nil                  = id
+    binds (Cons (VS x _) rest) = bind x . binds rest
+-}
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: versions of 'cataABT' and 'paraABT' which memoize the results for variables rather than recomputing them each time.
+
+-- | The catamorphism (aka: iterator) for ABTs. While this is
+-- equivalent to 'paraABT' in terms of the definable /functions/,
+-- it is weaker in terms of definable /algorithms/. If you need
+-- access to (subterms of) the original ABT, it is more efficient
+-- to use 'paraABT' than to rebuild them. However, if you never
+-- need access to the original ABT, then this function has somewhat
+-- less overhead.
+cataABT
+    :: forall k
+        (abt :: [k] -> k -> Type)
+        (syn :: ([k] -> k -> Type) -> k -> Type)
+        (r   :: [k] -> k -> Type)
+    .  (ABT syn abt, Functor21 syn)
+    => (forall a.      Variable a -> r '[] a)
+    -> (forall x xs a. Variable x -> r xs a -> r (x ': xs) a)
+    -> (forall a.      syn r a    -> r '[] a)
+    -> forall  xs a.   abt xs a   -> r xs a
+cataABT var_ bind_ syn_ = start
+    where
+    start :: forall ys b. abt ys b -> r ys b
+    start = loop . viewABT
+
+    loop :: forall ys b. View (syn abt) ys b -> r ys b
+    loop (Syn  t)   = syn_  (fmap21 start t)
+    loop (Var  x)   = var_  x
+    loop (Bind x e) = bind_ x (loop e)
+{-# INLINE cataABT #-}
+
+-- | A monadic variant of @cataABT@, which may not fit the precise definition of
+-- a catamorphism? The @bind@ and @syn@ operations receive monadic actions as their
+-- inputs, which allows the @bind@ and @syn@ operations to update the monadic
+-- context in which the subterms are evaluated if need be.
+cataABTM
+    :: forall k
+        (abt :: [k] -> k -> Type)
+        (syn :: ([k] -> k -> Type) -> k -> Type)
+        (r   :: [k] -> k -> Type)
+        (f   :: Type -> Type)
+    .  (ABT syn abt, Traversable21 syn, Applicative f)
+    => (forall a.      Variable a  -> f (r '[] a))
+    -> (forall x xs a. Variable x  -> f (r xs a) -> f (r (x ': xs) a))
+    -> (forall a.      f (syn r a) -> f (r '[] a))
+    -> forall  xs a.   abt xs a    -> f (r xs a)
+cataABTM var_ bind_ syn_ = start
+    where
+    start :: forall ys b. abt ys b -> f (r ys b)
+    start = loop . viewABT
+
+    loop :: forall ys b. View (syn abt) ys b -> f (r ys b)
+    loop (Syn  t)   = syn_ (traverse21 start t)
+    loop (Var  x)   = var_  x
+    loop (Bind x e) = bind_ x (loop e)
+{-# INLINE cataABTM #-}
+
+-- | The paramorphism (aka: recursor) for ABTs. While this is
+-- equivalent to 'cataABT' in terms of the definable /functions/,
+-- it is stronger in terms of definable /algorithms/. If you need
+-- access to (subterms of) the original ABT, it is more efficient
+-- to use this function than to use 'cataABT' and rebuild them.
+-- However, if you never need access to the original ABT, then
+-- 'cataABT' has somewhat less overhead.
+--
+-- The provided type is slightly non-uniform since we inline (i.e.,
+-- curry) the definition of 'Pair2' in the type of the @bind_@
+-- argument. But we can't inline 'Pair2' away in the type of the
+-- @syn_@ argument. N.B., if you treat the second component of the
+-- 'Pair2' (either the real ones or the curried ones) lazily, then
+-- this is a top-down function; however, if you treat them strictly
+-- then it becomes a bottom-up function.
+paraABT
+    :: forall k
+        (abt :: [k] -> k -> Type)
+        (syn :: ([k] -> k -> Type) -> k -> Type)
+        (r   :: [k] -> k -> Type)
+    .  (ABT syn abt, Functor21 syn)
+    => (forall a.      Variable a -> r '[] a)
+    -> (forall x xs a. Variable x -> abt xs a -> r xs a -> r (x ': xs) a)
+    -> (forall a.      syn (Pair2 abt r) a -> r '[] a)
+    -> forall  xs a.   abt xs a -> r xs a
+paraABT var_ bind_ syn_ = start
+    where
+    start :: forall ys b. abt ys b -> r ys b
+    start = loop . viewABT
+
+    loop :: forall ys b. View (syn abt) ys b -> r ys b
+    loop (Syn  t)   = syn_  (fmap21 (\e -> Pair2 e (start e)) t)
+    loop (Var  x)   = var_  x
+    loop (Bind x e) = bind_ x (unviewABT e) (loop e)
+        -- HACK: how can we avoid that call to 'unviewABT'?
+{-# INLINE paraABT #-}
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- TODO: Swap the argument order?
+-- | If the expression is a variable, then look it up. Recursing
+-- until we can finally return some syntax.
+resolveVar
+    :: (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type), ABT syn abt)
+    => abt '[] (a :: k)
+    -> Assocs (abt '[])
+    -> Either (Variable a) (syn abt a)
+resolveVar e xs =
+    flip (caseVarSyn e) Right $ \x ->
+        case lookupAssoc x xs of
+        Just e' -> resolveVar e' xs
+        Nothing -> Left x
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- | Makes a copy of an ABT at another type
+dupABT
+    :: (ABT syn abt0, ABT syn abt1, Functor21 syn)
+    => abt0 xs a
+    -> abt1 xs a
+dupABT = cataABT var bind syn
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/ANF.hs b/haskell/Language/Hakaru/Syntax/ANF.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/ANF.hs
@@ -0,0 +1,169 @@
+{-# LANGUAGE DataKinds                 #-}
+{-# LANGUAGE EmptyCase                 #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts          #-}
+{-# LANGUAGE GADTs                     #-}
+{-# LANGUAGE KindSignatures            #-}
+{-# LANGUAGE MultiParamTypeClasses     #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE PolyKinds                 #-}
+{-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE TypeFamilies              #-}
+{-# LANGUAGE TypeOperators             #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2017.02.01
+-- |
+-- Module      :  Language.Hakaru.Syntax.ANF
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.ANF (normalize, isValue) where
+
+import           Data.Maybe
+import           Control.Monad.Cont              (Cont, runCont, cont)
+
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Types.DataKind
+
+import           Language.Hakaru.Syntax.Prelude
+
+-- The renaming environment which maps variables in the original term to their
+-- counterparts in the new term. This is needed since the mechanism which
+-- ensures hygiene for the AST only factors in binders, but not free variables
+-- in the expression being constructed. When we construct a new binding form, a
+-- new variable is introduced and the variable in the old expression must be
+-- mapped to the new one.
+
+type Env = Assocs (Variable :: Hakaru -> *)
+
+updateEnv :: forall (a :: Hakaru) . Variable a -> Variable a -> Env -> Env
+updateEnv vin vout = insertAssoc (Assoc vin vout)
+
+-- | The context in which A-normalization occurs. Represented as a continuation,
+-- the context expects an expression of a particular type (usually a variable)
+-- and produces a new expression as a result.
+type Context abt a b = abt '[] a -> abt '[] b
+
+-- | Extract a variable from an abt. This function is partial
+getVar :: (ABT Term abt) => abt xs a -> Variable a
+getVar abt = case viewABT abt of
+               Var v -> v
+               _     -> error "getVar: not given a variable"
+
+-- | Useful function for generating fresh variables from an existing variable by
+-- wrapping @binder@.
+freshVar
+  :: (ABT Term abt)
+  => Variable a
+  -> (Variable a -> abt xs b)
+  -> abt (a ': xs) b
+freshVar v f = binder (varHint v) (varType v) (f . getVar)
+
+remapVar
+  :: (ABT Term abt)
+  => Variable a
+  -> Env
+  -> (Env -> abt xs b)
+  -> abt (a ': xs) b
+remapVar v env f = freshVar v $ \v' -> f (updateEnv v v' env)
+
+-- | Entry point for the normalization process. Initializes normalize' with the
+-- empty context.
+normalize
+  :: (ABT Term abt)
+  => abt '[] a
+  -> abt '[] a
+normalize abt = normalize' abt emptyAssocs id
+
+normalize'
+  :: (ABT Term abt)
+  => abt '[] a
+  -> Env
+  -> Context abt a b
+  -> abt '[] b
+normalize' = normalizeTail . viewABT
+
+normalizeTail, normalizeSave
+  :: (ABT Term abt)
+  => View (Term abt) xs a
+  -> Env
+  -> (abt xs a -> abt '[] b)
+  -> abt '[] b
+normalizeTail (Var v)     env ctxt = ctxt (normalizeVar v env)
+normalizeTail (Syn s)     env ctxt = normalizeTerm s env ctxt
+normalizeTail view@Bind{} env ctxt = ctxt (normalizeReset view env)
+normalizeSave (Var v)     env ctxt = ctxt (normalizeVar v env)
+normalizeSave (Syn s)     env ctxt = normalizeTerm s env giveName
+  where giveName abt' | isValue abt' = ctxt abt'
+                      | otherwise    = let_ abt' ctxt
+normalizeSave view@Bind{} env ctxt = ctxt (normalizeReset view env)
+
+normalizeReset :: (ABT Term abt) => View (Term abt) xs a -> Env -> abt xs a
+normalizeReset (Var v)    env = normalizeVar v env
+normalizeReset (Syn s)    env = normalizeTerm s env id
+normalizeReset (Bind v b) env = remapVar v env (normalizeReset b)
+
+normalizeVar :: (ABT Term abt) => Variable a -> Env -> abt '[] a
+normalizeVar v env = var $ fromMaybe v (lookupAssoc v env)
+
+isValue
+  :: (ABT Term abt)
+  => abt xs a
+  -> Bool
+isValue abt =
+  case viewABT abt of
+    Var{}  -> True
+    Bind{} -> False
+    Syn s  -> isValueTerm s
+  where
+    isValueTerm Literal_{}  = True
+    isValueTerm (Lam_ :$ _) = True
+    isValueTerm _           = False
+
+normalizeTerm
+  :: forall abt a b
+  .  (ABT Term abt)
+  => Term abt a
+  -> Env
+  -> Context abt a b
+  -> abt '[] b
+
+normalizeTerm (Let_ :$ (rhs :* body :* End)) env ctxt =
+  caseBind body $ \v body' ->
+  normalize' rhs env $ \rhs' ->
+  let mkbody env' = normalize' body' env' ctxt
+  in syn (Let_ :$ rhs' :* remapVar v env mkbody :* End)
+
+normalizeTerm (Case_ cond bs) env ctxt =
+  normalizeSave (viewABT cond) env $ \ cond' ->
+    let normalizeBranch :: forall xs d . abt xs d -> abt xs d
+        normalizeBranch body = normalizeReset (viewABT body) env
+        branches = map (fmap21 normalizeBranch) bs
+    -- A possible optimization is to push the context into each conditional,
+    -- possibly opening up other optimizations at the cost of code growth.
+    in ctxt $ syn $ Case_ cond' branches
+
+normalizeTerm term env ctxt = runCont (fmap syn (traverse21 f term)) ctxt
+  where f :: forall xs c . abt xs c -> Cont (abt '[] b) (abt xs c)
+        f abt = cont (n (viewABT abt) env)
+        n :: forall xs c
+          .  View (Term abt) xs c
+          -> Env
+          -> (abt xs c -> abt '[] b)
+          -> abt '[] b
+        -- TODO: Can we just let n=normalizeTail or n=normalizeSave?
+        n = case term of MBind         :$ _ -> normalizeTail
+                         Plate         :$ _ -> normalizeTail
+                         Dirac         :$ _ -> normalizeTail
+                         UnsafeFrom_ _ :$ _ -> normalizeTail
+                         CoerceTo_   _ :$ _ -> normalizeTail
+                         _                  -> normalizeSave
diff --git a/haskell/Language/Hakaru/Syntax/AST.hs b/haskell/Language/Hakaru/Syntax/AST.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/AST.hs
@@ -0,0 +1,901 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , PolyKinds
+           , GADTs
+           , StandaloneDeriving
+           , TypeOperators
+           , TypeFamilies
+           , FlexibleContexts
+           , UndecidableInstances
+           , Rank2Types
+           , DeriveDataTypeable
+           , LambdaCase
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.02.21
+-- |
+-- Module      :  Language.Hakaru.Syntax.AST
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- The generating functor for the raw syntax, along with various
+-- helper types. For a more tutorial sort of introduction to how
+-- things are structured here and in "Language.Hakaru.Syntax.ABT",
+-- see <http://winterkoninkje.dreamwidth.org/103978.html>
+--
+-- TODO: are we finally at the place where we can get rid of all
+-- those annoying underscores?
+--
+-- TODO: what is the runtime cost of storing all these dictionary
+-- singletons? For existential type variables, it should be the
+-- same as using a type class constraint; but for non-existential
+-- type variables it'll, what, double the size of the AST?
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.AST
+    (
+    -- * Syntactic forms
+      SCon(..)
+    , SArgs(..)
+    , Term(..)
+    , Transform(..), TransformImpl(..)
+    -- allTransforms, transformName comes from Transform
+    -- * Operators
+    , LCs, UnLCs -- LC comes from SArgs
+    , LC_(..)
+    , NaryOp(..)
+    , PrimOp(..)
+    , ArrayOp(..)
+    , MeasureOp(..)
+    -- * Constant values
+    , Literal(..)
+    
+    -- * implementation details
+    , foldMapPairs
+    , traversePairs
+    , module Language.Hakaru.Syntax.SArgs
+    , module Language.Hakaru.Syntax.Transform
+    ) where
+
+import           Data.Sequence (Seq)
+import qualified Data.Foldable as F
+import qualified Data.List.NonEmpty as L
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Monoid   (Monoid(..))
+import           Control.Applicative
+import           Data.Traversable
+#endif
+
+import           Control.Arrow ((***))
+import           Data.Ratio    (numerator, denominator)
+
+import Data.Data ()
+
+import Data.Number.Natural
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.ABT (ABT(syn))
+
+import Language.Hakaru.Syntax.SArgs
+import Language.Hakaru.Syntax.Transform
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- BUG: can't UNPACK 'Integer' and 'Natural' like we can for 'Int' and 'Nat'
+--
+-- | Numeric literals for the primitive numeric types. In addition
+-- to being normal forms, these are also ground terms: that is, not
+-- only are they closed (i.e., no free variables), they also have
+-- no bound variables and thus no binding forms. Notably, we store
+-- literals using exact types so that none of our program transformations
+-- have to worry about issues like overflow or floating-point fuzz.
+data Literal :: Hakaru -> * where
+    LNat   :: !Natural -> Literal 'HNat
+    LInt   :: !Integer -> Literal 'HInt
+    LProb  :: {-# UNPACK #-} !NonNegativeRational -> Literal 'HProb
+    LReal  :: {-# UNPACK #-} !Rational            -> Literal 'HReal
+
+instance JmEq1 Literal where
+    jmEq1 (LNat  x) (LNat  y) = if x == y then Just Refl else Nothing
+    jmEq1 (LInt  x) (LInt  y) = if x == y then Just Refl else Nothing
+    jmEq1 (LProb x) (LProb y) = if x == y then Just Refl else Nothing
+    jmEq1 (LReal x) (LReal y) = if x == y then Just Refl else Nothing
+    jmEq1 _         _         = Nothing
+
+instance Eq1 Literal where
+    eq1 (LNat  x) (LNat  y) = x == y
+    eq1 (LInt  x) (LInt  y) = x == y
+    eq1 (LProb x) (LProb y) = x == y
+    eq1 (LReal x) (LReal y) = x == y
+    -- Because of GADTs, the following is apparently redundant
+    -- eq1 _         _          = False
+
+instance Eq (Literal a) where
+    (==) = eq1
+
+-- TODO: instance Read (Literal a)
+
+instance Show1 Literal where
+    showsPrec1 p t =
+        case t of
+        LNat  v -> showParen_0 p "LNat"  v
+        LInt  v -> showParen_0 p "LInt"  v
+        LProb v -> showParen_0 p "LProb" v -- TODO: pretty print as decimals instead of using the Show Rational instance
+        LReal v -> showParen_0 p "LReal" v -- TODO: pretty print as decimals instead of using the Show Rational instance
+
+instance Show (Literal a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+
+-- TODO: first optimize the @Coercion a b@ to choose the most desirable of many equivalent paths?
+instance Coerce Literal where
+    coerceTo   CNil         v = v
+    coerceTo   (CCons c cs) v = coerceTo cs (primCoerceTo c v)
+
+    coerceFrom CNil         v = v
+    coerceFrom (CCons c cs) v = primCoerceFrom c (coerceFrom cs v)
+
+instance PrimCoerce Literal where
+    primCoerceTo c =
+        case c of
+        Signed     HRing_Int        -> \(LNat  n) -> LInt  (nat2int   n)
+        Signed     HRing_Real       -> \(LProb p) -> LReal (prob2real p)
+        Continuous HContinuous_Prob -> \(LNat  n) -> LProb (nat2prob  n)
+        Continuous HContinuous_Real -> \(LInt  i) -> LReal (int2real  i)
+        where
+        -- HACK: type signatures needed to avoid defaulting
+        nat2int   :: Natural -> Integer
+        nat2int   = fromNatural
+        nat2prob  :: Natural -> NonNegativeRational
+        nat2prob  = unsafeNonNegativeRational . toRational -- N.B., is actually safe here
+        prob2real :: NonNegativeRational -> Rational
+        prob2real = fromNonNegativeRational
+        int2real  :: Integer -> Rational
+        int2real  = fromIntegral
+
+    primCoerceFrom c =
+        case c of
+        Signed     HRing_Int        -> \(LInt  i) -> LNat  (int2nat   i)
+        Signed     HRing_Real       -> \(LReal r) -> LProb (real2prob r)
+        Continuous HContinuous_Prob -> \(LProb p) -> LNat  (prob2nat  p)
+        Continuous HContinuous_Real -> \(LReal r) -> LInt  (real2int  r)
+        where
+        -- HACK: type signatures needed to avoid defaulting
+        -- TODO: how to handle the errors? Generate error code in hakaru? capture it in a monad?
+        int2nat  :: Integer -> Natural
+        int2nat x =
+            case toNatural x of
+            Just y  -> y
+            Nothing -> error $ "primCoerceFrom@Literal: negative HInt " ++ show x
+        prob2nat :: NonNegativeRational -> Natural
+        prob2nat x =
+            if denominator x == 1
+            then numerator x
+            else error $ "primCoerceFrom@Literal: non-integral HProb " ++ show x
+        real2prob :: Rational -> NonNegativeRational
+        real2prob x =
+            case toNonNegativeRational x of
+            Just y  -> y
+            Nothing -> error $ "primCoerceFrom@Literal: negative HReal " ++ show x
+        real2int :: Rational -> Integer
+        real2int x =
+            if denominator x == 1
+            then numerator x
+            else error $ "primCoerceFrom@Literal: non-integral HReal " ++ show x
+
+
+----------------------------------------------------------------
+-- TODO: helper functions for splitting NaryOp_ into components to group up like things. (e.g., grouping all the Literals together so we can do constant propagation)
+
+-- | Primitive associative n-ary functions. By flattening the trees
+-- for associative operators, we can more easily perform equivalence
+-- checking and pattern matching (e.g., to convert @exp (a * log
+-- b)@ into @b ** a@, regardless of whether @a@ is a product of
+-- things or not). Notably, because of this encoding, we encode
+-- things like subtraction and division by their unary operators
+-- (negation and reciprocal).
+--
+-- We do not make any assumptions about whether these semigroups
+-- are monoids, commutative, idempotent, or anything else. That has
+-- to be handled by transformations, rather than by the AST itself.
+data NaryOp :: Hakaru -> * where
+    And  :: NaryOp HBool
+    Or   :: NaryOp HBool
+    Xor  :: NaryOp HBool
+    -- N.B., even though 'Iff' is associative (in Boolean algebras),
+    -- we should not support n-ary uses in our *surface* syntax.
+    -- Because it's too easy for folks to confuse "a <=> b <=> c"
+    -- with "(a <=> b) /\ (b <=> c)".
+    Iff  :: NaryOp HBool -- == Not (Xor x y)
+
+    -- These two don't necessarily have identity elements; thus,
+    -- @NaryOp_ Min []@ and @NaryOp_ Max []@ may not be well-defined...
+    -- TODO: check for those cases!
+    Min  :: !(HOrd a) -> NaryOp a
+    Max  :: !(HOrd a) -> NaryOp a
+
+    Sum  :: !(HSemiring a) -> NaryOp a
+    Prod :: !(HSemiring a) -> NaryOp a
+
+    {-
+    GCD  :: !(GCD_Domain a) -> NaryOp a
+    LCM  :: !(GCD_Domain a) -> NaryOp a
+    -}
+
+-- TODO: instance Read (NaryOp a)
+deriving instance Show (NaryOp a)
+
+instance JmEq1 NaryOp where
+    jmEq1 And      And      = Just Refl
+    jmEq1 Or       Or       = Just Refl
+    jmEq1 Xor      Xor      = Just Refl
+    jmEq1 Iff      Iff      = Just Refl
+    jmEq1 (Min  a) (Min  b) = jmEq1 (sing_HOrd a) (sing_HOrd b)
+    jmEq1 (Max  a) (Max  b) = jmEq1 (sing_HOrd a) (sing_HOrd b)
+    jmEq1 (Sum  a) (Sum  b) = jmEq1 a b
+    jmEq1 (Prod a) (Prod b) = jmEq1 a b
+    jmEq1 _        _        = Nothing
+
+-- TODO: We could optimize this like we do for 'Literal'
+instance Eq1 NaryOp where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+
+instance Eq (NaryOp a) where -- This one can be derived
+    (==) = eq1
+
+
+----------------------------------------------------------------
+-- TODO: should we define our own datakind for @([Hakaru], Hakaru)@ or perhaps for the @/\a -> ([a], Hakaru)@ part of it?
+
+-- BUG: how to declare that these are inverses?
+type family LCs (xs :: [Hakaru]) :: [([Hakaru], Hakaru)] where
+    LCs '[]       = '[]
+    LCs (x ': xs) = LC x ': LCs xs
+
+type family UnLCs (xs :: [([Hakaru], Hakaru)]) :: [Hakaru] where
+    UnLCs '[]                  = '[]
+    UnLCs ( '( '[], x ) ': xs) = x ': UnLCs xs
+
+
+-- | Simple primitive functions, and constants. N.B., nothing in
+-- here should produce or consume things of 'HMeasure' or 'HArray'
+-- type (except perhaps in a totally polymorphic way).
+data PrimOp :: [Hakaru] -> Hakaru -> * where
+
+    -- -- -- Here we have /monomorphic/ operators
+    -- -- The Boolean operators
+    -- TODO: most of these we'll want to optimize away according
+    -- to some circuit-minimization procedure. But we're not
+    -- committing to any particular minimal complete set of primops
+    -- just yet.
+    -- N.B., general circuit minimization problem is Sigma_2^P-complete,
+    -- which is outside of PTIME; so we'll just have to approximate
+    -- it for now, or link into something like Espresso or an
+    -- implementation of Quine–McCluskey
+    -- cf., <https://hackage.haskell.org/package/qm-0.1.0.0/candidate>
+    -- cf., <https://github.com/pfpacket/Quine-McCluskey>
+    -- cf., <https://gist.github.com/dsvictor94/8db2b399a95e301c259a>
+    Not  :: PrimOp '[ HBool ] HBool
+    -- And, Or, Xor, Iff
+    Impl :: PrimOp '[ HBool, HBool ] HBool
+    -- Impl x y == Or (Not x) y
+    Diff :: PrimOp '[ HBool, HBool ] HBool
+    -- Diff x y == Not (Impl x y)
+    Nand :: PrimOp '[ HBool, HBool ] HBool
+    -- Nand aka Alternative Denial, Sheffer stroke
+    Nor  :: PrimOp '[ HBool, HBool ] HBool
+    -- Nor aka Joint Denial, aka Quine dagger, aka Pierce arrow
+    --
+    -- The remaining eight binops are completely uninteresting:
+    --   flip Impl
+    --   flip Diff
+    --   const
+    --   flip const
+    --   (Not .) . const == const . Not
+    --   (Not .) . flip const
+    --   const (const True)
+    --   const (const False)
+
+
+    -- -- Trigonometry operators
+    Pi    :: PrimOp '[] 'HProb -- TODO: maybe make this HContinuous polymorphic?
+    -- TODO: if we're going to bother naming the hyperbolic ones, why not also name /a?(csc|sec|cot)h?/ eh?
+    -- TODO: capture more domain information in these types?
+    Sin   :: PrimOp '[ 'HReal ] 'HReal
+    Cos   :: PrimOp '[ 'HReal ] 'HReal
+    Tan   :: PrimOp '[ 'HReal ] 'HReal
+    Asin  :: PrimOp '[ 'HReal ] 'HReal
+    Acos  :: PrimOp '[ 'HReal ] 'HReal
+    Atan  :: PrimOp '[ 'HReal ] 'HReal
+    Sinh  :: PrimOp '[ 'HReal ] 'HReal
+    Cosh  :: PrimOp '[ 'HReal ] 'HReal
+    Tanh  :: PrimOp '[ 'HReal ] 'HReal
+    Asinh :: PrimOp '[ 'HReal ] 'HReal
+    Acosh :: PrimOp '[ 'HReal ] 'HReal
+    Atanh :: PrimOp '[ 'HReal ] 'HReal
+
+
+    -- -- Other Real\/Prob-valued operators
+    -- N.B., we only give the safe\/exact versions here. The old
+    -- more lenient versions now require explicit coercions. Some
+    -- of those coercions are safe, but others are not. This way
+    -- we're explicit about where things can fail.
+    -- N.B., we also have @NatPow{'HReal} :: 'HReal -> 'HNat -> 'HReal@,
+    -- but non-integer real powers of negative reals are not real numbers!
+    -- TODO: may need @SafeFrom_@ in order to branch on the input
+    -- in order to provide the old unsafe behavior.
+    RealPow   :: PrimOp '[ 'HProb, 'HReal ] 'HProb
+    Choose    :: PrimOp '[ 'HNat, 'HNat ] 'HNat
+    -- ComplexPow :: PrimOp '[ 'HProb, 'HComplex ] 'HComplex
+    -- is uniquely well-defined. Though we may want to implement
+    -- it via @r**z = ComplexExp (z * RealLog r)@
+    -- Defining @HReal -> HComplex -> HComplex@ requires either
+    -- multivalued functions, or a choice of complex logarithm and
+    -- making it discontinuous.
+    Exp       :: PrimOp '[ 'HReal ] 'HProb
+    Log       :: PrimOp '[ 'HProb ] 'HReal
+    -- TODO: Log1p, Expm1
+    Infinity  :: HIntegrable a -> PrimOp '[] a
+    -- TODO: add Factorial as the appropriate type restriction of GammaFunc?
+    GammaFunc :: PrimOp '[ 'HReal ] 'HProb
+    BetaFunc  :: PrimOp '[ 'HProb, 'HProb ] 'HProb
+
+
+    -- -- -- Here we have the /polymorphic/ operators
+
+    -- -- HEq and HOrd operators
+    -- TODO: equality doesn't make constructive sense on the reals...
+    -- would it be better to constructivize our notion of total ordering?
+    -- TODO: should we have LessEq as a primitive, rather than treating it as a macro?
+    Equal :: !(HEq  a) -> PrimOp '[ a, a ] HBool
+    Less  :: !(HOrd a) -> PrimOp '[ a, a ] HBool
+
+
+    -- -- HSemiring operators (the non-n-ary ones)
+    NatPow :: !(HSemiring a) -> PrimOp '[ a, 'HNat ] a
+    -- TODO: would it help to have a specialized version for when
+    -- we happen to know that the 'HNat is a Literal? Same goes for
+    -- the other powers\/roots
+    --
+    -- TODO: add a specialized version which returns NonNegative
+    -- when the power is even? N.B., be sure not to actually constrain
+    -- it to HRing (necessary for calling it \"NonNegative\")
+
+    -- -- HRing operators
+    -- TODO: break these apart into a hierarchy of classes. N.B,
+    -- there are two different interpretations of "abs" and "signum".
+    -- On the one hand we can think of rings as being generated
+    -- from semirings closed under subtraction/negation. From this
+    -- perspective we have abs as a projection into the underlying
+    -- semiring, and signum as a projection giving us the residual
+    -- sign lost by the abs projection. On the other hand, we have
+    -- the view of "abs" as a norm (i.e., distance to the "origin
+    -- point"), which is the more common perspective for complex
+    -- numbers and vector spaces; and relatedly, we have "signum"
+    -- as returning the value on the unit (hyper)sphere, of the
+    -- normalized unit vector. In another class, if we have a notion
+    -- of an "origin axis" then we can have a function Arg which
+    -- returns the angle to that axis, and therefore define signum
+    -- in terms of Arg.
+    -- Ring: Semiring + negate, abs, signum
+    -- NormedLinearSpace: LinearSpace + originPoint, norm, Arg
+    -- ??: NormedLinearSpace + originAxis, angle
+    Negate :: !(HRing a) -> PrimOp '[ a ] a
+    Abs    :: !(HRing a) -> PrimOp '[ a ] (NonNegative a)
+    -- cf., <https://mail.haskell.org/pipermail/libraries/2013-April/019694.html>
+    -- cf., <https://en.wikipedia.org/wiki/Sign_function#Complex_signum>
+    -- Should we have Maple5's \"csgn\" as well as the usual \"sgn\"?
+    -- Also note that the \"generalized signum\" anticommutes with Dirac delta!
+    Signum :: !(HRing a) -> PrimOp '[ a ] a
+    -- Law: x = coerceTo_ signed (abs_ x) * signum x
+    -- More strictly/exactly, the result of Signum should be either
+    -- zero or an @a@-unit value. For Int and Real, the units are
+    -- +1 and -1. For Complex, the units are any point on the unit
+    -- circle. For vectors, the units are any unit vector. Thus,
+    -- more generally:
+    -- Law : x = coerceTo_ signed (abs_ x) `scaleBy` signum x
+    -- TODO: would it be worth defining the associated type of unit values for @a@? Probably...
+    -- TODO: are there any salient types which support abs\/norm but
+    -- do not have all units and thus do not support signum\/normalize?
+
+
+    -- Coecion-like operations that are computations
+    -- we only implement Floor for Prob for now?
+    Floor :: PrimOp '[ 'HProb ] 'HNat
+
+    -- -- HFractional operators
+    Recip :: !(HFractional a) -> PrimOp '[ a ] a
+    -- generates macro: IntPow
+
+
+    -- -- HRadical operators
+    -- TODO: flip argument order to match our prelude's @thRootOf@?
+    NatRoot :: !(HRadical a) -> PrimOp '[ a, 'HNat ] a
+    -- generates macros: Sqrt, NonNegativeRationalPow, and RationalPow
+
+
+    -- -- HContinuous operators
+    -- TODO: what goes here, if anything? cf., <https://en.wikipedia.org/wiki/Closed-form_expression#Comparison_of_different_classes_of_expressions>
+    Erf :: !(HContinuous a) -> PrimOp '[ a ] a
+    -- TODO: make Pi and Infinity HContinuous-polymorphic so that we can avoid the explicit coercion? Probably more mess than benefit.
+
+
+-- TODO: instance Read (PrimOp args a)
+deriving instance Show (PrimOp args a)
+
+instance JmEq2 PrimOp where
+    jmEq2 Not         Not         = Just (Refl, Refl)
+    jmEq2 Impl        Impl        = Just (Refl, Refl)
+    jmEq2 Diff        Diff        = Just (Refl, Refl)
+    jmEq2 Nand        Nand        = Just (Refl, Refl)
+    jmEq2 Nor         Nor         = Just (Refl, Refl)
+    jmEq2 Pi          Pi          = Just (Refl, Refl)
+    jmEq2 Sin         Sin         = Just (Refl, Refl)
+    jmEq2 Cos         Cos         = Just (Refl, Refl)
+    jmEq2 Tan         Tan         = Just (Refl, Refl)
+    jmEq2 Asin        Asin        = Just (Refl, Refl)
+    jmEq2 Acos        Acos        = Just (Refl, Refl)
+    jmEq2 Atan        Atan        = Just (Refl, Refl)
+    jmEq2 Sinh        Sinh        = Just (Refl, Refl)
+    jmEq2 Cosh        Cosh        = Just (Refl, Refl)
+    jmEq2 Tanh        Tanh        = Just (Refl, Refl)
+    jmEq2 Asinh       Asinh       = Just (Refl, Refl)
+    jmEq2 Acosh       Acosh       = Just (Refl, Refl)
+    jmEq2 Atanh       Atanh       = Just (Refl, Refl)
+    jmEq2 RealPow     RealPow     = Just (Refl, Refl)
+    jmEq2 Exp         Exp         = Just (Refl, Refl)
+    jmEq2 Log         Log         = Just (Refl, Refl)
+    jmEq2 GammaFunc   GammaFunc   = Just (Refl, Refl)
+    jmEq2 BetaFunc    BetaFunc    = Just (Refl, Refl)
+    jmEq2 (Equal a)   (Equal b)   =
+        jmEq1 (sing_HEq a) (sing_HEq b) >>= \Refl ->
+        Just (Refl, Refl)
+    jmEq2 (Less a)    (Less b)    =
+        jmEq1 (sing_HOrd a) (sing_HOrd b) >>= \Refl ->
+        Just (Refl, Refl)
+    jmEq2 (Infinity a) (Infinity b) =
+        jmEq1 (sing_HIntegrable a) (sing_HIntegrable b) >>= \Refl ->
+        Just (Refl, Refl)
+    jmEq2 (NatPow   a) (NatPow   b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 (Negate   a) (Negate   b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 (Abs      a) (Abs      b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 (Signum   a) (Signum   b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 (Recip    a) (Recip    b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 (NatRoot  a) (NatRoot  b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 (Erf      a) (Erf      b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 _ _ = Nothing
+
+-- TODO: We could optimize this like we do for 'Literal'
+instance Eq2 PrimOp where
+    eq2 x y = maybe False (const True) (jmEq2 x y)
+
+instance Eq1 (PrimOp args) where
+    eq1 = eq2
+
+instance Eq (PrimOp args a) where -- This one can be derived
+    (==) = eq1
+
+----------------------------------------------------------------
+-- | Primitive operators for consuming or transforming arrays.
+--
+-- TODO: we may want to replace the 'Sing' arguments with something
+-- more specific in order to capture any restrictions on what can
+-- be stored in an array. Or, if we can get rid of them entirely
+-- while still implementing all the use sites of
+-- 'Language.Hakaru.Syntax.AST.Sing.sing_ArrayOp', that'd be
+-- better still.
+data ArrayOp :: [Hakaru] -> Hakaru -> * where
+    -- HACK: is there any way we can avoid storing the Sing values here, while still implementing 'sing_PrimOp'?
+    Index  :: !(Sing a) -> ArrayOp '[ 'HArray a, 'HNat ] a
+    Size   :: !(Sing a) -> ArrayOp '[ 'HArray a ] 'HNat
+    -- The first argument should be a monoid, but we don't enforce
+    -- that; it's the user's responsibility.
+    Reduce :: !(Sing a) -> ArrayOp '[ a ':-> a ':-> a, a, 'HArray a ] a
+    -- TODO: would it make sense to have a specialized version for when the first argument is some \"Op\", in order to avoid the need for lambdas?
+
+-- TODO: instance Read (ArrayOp args a)
+deriving instance Show (ArrayOp args a)
+
+instance JmEq2 ArrayOp where
+    jmEq2 (Index  a) (Index  b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 (Size   a) (Size   b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 (Reduce a) (Reduce b) = jmEq1 a b >>= \Refl -> Just (Refl, Refl)
+    jmEq2 _          _          = Nothing
+
+-- TODO: We could optimize this like we do for 'Literal'
+instance Eq2 ArrayOp where
+    eq2 x y = maybe False (const True) (jmEq2 x y)
+
+instance Eq1 (ArrayOp args) where
+    eq1 = eq2
+
+instance Eq (ArrayOp args a) where -- This one can be derived
+    (==) = eq1
+
+
+----------------------------------------------------------------
+-- | Primitive operators to produce, consume, or transform
+-- distributions\/measures. This corresponds to the old @Mochastic@
+-- class, except that 'MBind' and 'Superpose_' are handled elsewhere
+-- since they are not simple operators. (Also 'Dirac' is handled
+-- elsewhere since it naturally fits with 'MBind', even though it
+-- is a siple operator.)
+--
+-- TODO: we may want to replace the 'Sing' arguments with something
+-- more specific in order to capture any restrictions on what can
+-- be a measure space (e.g., to exclude functions). Or, if we can
+-- get rid of them entirely while still implementing all the use
+-- sites of 'Language.Hakaru.Syntax.AST.Sing.sing_MeasureOp',
+-- that'd be better still.
+data MeasureOp :: [Hakaru] -> Hakaru -> * where
+    -- We might consider making Lebesgue and Counting polymorphic,
+    -- since their restrictions to HProb and HNat are perfectly
+    -- valid primitive measures. However, there are many other
+    -- restrictions on measures we may want to consider, so handling
+    -- these two here would only complicate matters.
+    Lebesgue    :: MeasureOp '[ 'HReal, 'HReal ] 'HReal
+    Counting    :: MeasureOp '[]                 'HInt
+    Categorical :: MeasureOp '[ 'HArray 'HProb ] 'HNat
+    -- TODO: make Uniform polymorphic, so that if the two inputs
+    -- are HProb then we know the measure must be over HProb too.
+    -- More generally, if the first input is HProb (since the second
+    -- input is assumed to be greater thant he first); though that
+    -- would be a bit ugly IMO.
+    Uniform     :: MeasureOp '[ 'HReal, 'HReal ] 'HReal
+    Normal      :: MeasureOp '[ 'HReal, 'HProb ] 'HReal
+    Poisson     :: MeasureOp '[ 'HProb         ] 'HNat
+    Gamma       :: MeasureOp '[ 'HProb, 'HProb ] 'HProb
+    Beta        :: MeasureOp '[ 'HProb, 'HProb ] 'HProb
+
+-- TODO: instance Read (MeasureOp typs a)
+deriving instance Show (MeasureOp typs a)
+
+instance JmEq2 MeasureOp where
+    jmEq2 Lebesgue    Lebesgue    = Just (Refl, Refl)
+    jmEq2 Counting    Counting    = Just (Refl, Refl)
+    jmEq2 Categorical Categorical = Just (Refl, Refl)
+    jmEq2 Uniform     Uniform     = Just (Refl, Refl)
+    jmEq2 Normal      Normal      = Just (Refl, Refl)
+    jmEq2 Poisson     Poisson     = Just (Refl, Refl)
+    jmEq2 Gamma       Gamma       = Just (Refl, Refl)
+    jmEq2 Beta        Beta        = Just (Refl, Refl)
+    jmEq2 _           _           = Nothing
+
+-- TODO: We could optimize this like we do for 'Literal'
+instance Eq2 MeasureOp where
+    eq2 x y = maybe False (const True) (jmEq2 x y)
+
+instance Eq1 (MeasureOp typs) where
+    eq1 = eq2
+
+instance Eq (MeasureOp typs a) where -- This one can be derived
+    (==) = eq1
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- N.B., the precedence of (:$) must be lower than (:*).
+-- N.B., if these are changed, then be sure to update the Show instances
+infix  4 :$ -- Chosen to be at the same precedence as (<$>) rather than ($)
+
+-- | The constructor of a @(':$')@ node in the 'Term'. Each of these
+-- constructors denotes a \"normal\/standard\/basic\" syntactic
+-- form (i.e., a generalized quantifier). In the literature, these
+-- syntactic forms are sometimes called \"operators\", but we avoid
+-- calling them that so as not to introduce confusion vs 'PrimOp'
+-- etc. Instead we use the term \"operator\" to refer to any primitive
+-- function or constant; that is, non-binding syntactic forms. Also
+-- in the literature, the 'SCon' type itself is usually called the
+-- \"signature\" of the term language. However, we avoid calling
+-- it that since our 'Term' has constructors other than just @(:$)@,
+-- so 'SCon' does not give a complete signature for our terms.
+--
+-- The main reason for breaking this type out and using it in
+-- conjunction with @(':$')@ and 'SArgs' is so that we can easily
+-- pattern match on /fully saturated/ nodes. For example, we want
+-- to be able to match @MeasureOp_ Uniform :$ lo :* hi :* End@
+-- without needing to deal with 'App_' nodes nor 'viewABT'.
+data SCon :: [([Hakaru], Hakaru)] -> Hakaru -> * where
+    -- BUG: haddock doesn't like annotations on GADT constructors
+    -- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+    -- -- Standard lambda calculus stuff
+    Lam_ :: SCon '[ '( '[ a ], b ) ] (a ':-> b)
+    App_ :: SCon '[ LC (a ':-> b ), LC a ] b
+    Let_ :: SCon '[ LC a, '( '[ a ], b ) ] b
+    -- TODO: a general \"@letrec*@\" version of let-binding so we can have mutual recursion
+    --
+    -- TODO: if we decide to add arbitrary fixedpoints back in, we
+    -- should probably prefer only recursive-functions:
+    -- `SCon '[ '( '[ a ':-> b, a ], a ':-> b ) ] (a ':-> b)`
+    -- over than the previous recursive-everything:
+    -- `SCon '[ '( '[ a ], a ) ] a`
+    -- Or, if we really want to guarantee soundness, then we should
+    -- only have the inductive principles for each HData.
+
+    -- -- Type munging
+    CoerceTo_   :: !(Coercion a b) -> SCon '[ LC a ] b
+    UnsafeFrom_ :: !(Coercion a b) -> SCon '[ LC b ] a
+    -- TODO: add something like @SafeFrom_ :: Coercion a b -> abt b -> Term abt ('HMaybe a)@ so we can capture the safety of patterns like @if_ (0 <= x) (let x_ = unsafeFrom signed x in...) (...)@ Of course, since we're just going to do case analysis on the result; why not make it a binding form directly?
+    -- TODO: we'll probably want some more general thing to capture these sorts of patterns. For example, in the default implementation of Uniform we see: @if_ (lo < x && x < hi) (... unsafeFrom_ signed (hi - lo) ...) (...)@
+
+    -- HACK: we must add the constraints that 'LCs' and 'UnLCs' are inverses, so that we have those in scope when doing case analysis (e.g., in TypeCheck.hs).
+    -- As for this file itself, we can get it to typecheck by using 'UnLCs' in the argument rather than 'LCs' in the result; trying to do things the other way results in type inference issues in the typeclass instances for 'SCon'
+    PrimOp_
+        :: (typs ~ UnLCs args, args ~ LCs typs)
+        => !(PrimOp typs a) -> SCon args a
+    ArrayOp_
+        :: (typs ~ UnLCs args, args ~ LCs typs)
+        => !(ArrayOp typs a) -> SCon args a
+    MeasureOp_
+        :: (typs ~ UnLCs args, args ~ LCs typs)
+        => !(MeasureOp typs a) -> SCon args ('HMeasure a)
+
+    Dirac :: SCon '[ LC a ] ('HMeasure a)
+
+    MBind :: SCon
+        '[ LC ('HMeasure a)
+        ,  '( '[ a ], 'HMeasure b)
+        ] ('HMeasure b)
+
+    -- TODO: unify Plate and Chain as @sequence@ a~la traversable?
+    Plate :: SCon 
+        '[ LC 'HNat
+        , '( '[ 'HNat ], 'HMeasure a)
+        ] ('HMeasure ('HArray a))
+
+
+    -- TODO: if we swap the order of arguments to 'Chain', we could
+    -- change the functional argument to be a binding form in order
+    -- to avoid the need for lambdas. It'd no longer be trivial to
+    -- see 'Chain' as an instance of @sequence@, but might be worth
+    -- it... Of course, we also need to handle the fact that it's
+    -- an array of transition functions; i.e., we could do:
+    -- > chain n s0 $ \i s -> do {...}
+    Chain :: SCon
+        '[ LC 'HNat, LC s
+        , '( '[ s ],  'HMeasure (HPair a s))
+        ] ('HMeasure (HPair ('HArray a) s))
+
+
+    -- -- Continuous and discrete integration.
+    -- TODO: make Integrate and Summate polymorphic, so that if the
+    -- two inputs are HProb then we know the function must be over
+    -- HProb\/HNat too. More generally, if the first input is HProb
+    -- (since the second input is assumed to be greater than the
+    -- first); though that would be a bit ugly IMO.
+    Integrate
+        :: SCon '[ LC 'HReal, LC 'HReal, '( '[ 'HReal ], 'HProb) ] 'HProb
+    -- TODO: the high and low bounds *should* be HInt. The only reason we use HReal is so that we can have infinite summations. Once we figure out a way to handle infinite bounds here, we can make the switch
+
+    Summate
+        :: HDiscrete a
+        -> HSemiring b
+        -> SCon '[ LC a, LC a, '( '[ a ], b) ] b
+
+    Product
+        :: HDiscrete a
+        -> HSemiring b
+        -> SCon '[ LC a, LC a, '( '[ a ], b) ] b
+
+    -- Internalized program transformations
+    Transform_ :: !(Transform as x)
+               -> SCon as x
+
+deriving instance Eq   (SCon args a)
+-- TODO: instance Read (SCon args a)
+deriving instance Show (SCon args a)
+
+----------------------------------------------------------------
+-- | The generating functor for Hakaru ASTs. This type is given in
+-- open-recursive form, where the first type argument gives the
+-- recursive form. The recursive form @abt@ does not have exactly
+-- the same kind as @Term abt@ because every 'Term' represents a
+-- locally-closed term whereas the underlying @abt@ may bind some
+-- variables.
+data Term :: ([Hakaru] -> Hakaru -> *) -> Hakaru -> * where
+    -- BUG: haddock doesn't like annotations on GADT constructors
+    -- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+    -- Simple syntactic forms (i.e., generalized quantifiers)
+    (:$) :: !(SCon args a) -> !(SArgs abt args) -> Term abt a
+
+    -- N-ary operators
+    NaryOp_ :: !(NaryOp a) -> !(Seq (abt '[] a)) -> Term abt a
+
+    -- TODO: 'Literal_', 'Empty_', 'Array_', and 'Datum_' are generalized quantifiers (to the same extent that 'Ann_', 'CoerceTo_', and 'UnsafeFrom_' are). Should we move them into 'SCon' just for the sake of minimizing how much lives in 'Term'? Or are they unique enough to be worth keeping here?
+
+    -- Literal\/Constant values
+    Literal_ :: !(Literal a) -> Term abt a
+
+    -- These two constructors are here rather than in 'ArrayOp' because 'Array_' is a binding form; though it also means they're together with the other intro forms like 'Literal_' and 'Datum_'.
+    --
+    -- TODO: should we add a @Sing a@ argument to avoid ambiguity of 'Empty_'?
+    Empty_ :: !(Sing ('HArray a)) -> Term abt ('HArray a)
+    Array_
+        :: !(abt '[] 'HNat)
+        -> !(abt '[ 'HNat ] a)
+        -> Term abt ('HArray a)
+
+    ArrayLiteral_
+        :: [abt '[] a]
+        -> Term abt ('HArray a)
+
+    -- Constructor for Reducers
+    Bucket
+        :: !(abt '[] 'HNat)
+        -> !(abt '[] 'HNat)
+        -> Reducer abt '[] a
+        -> Term abt a
+           
+    -- -- User-defined data types
+    -- BUG: even though the 'Datum' type has a single constructor, we get a warning about not being able to UNPACK it in 'Datum_'... wtf?
+    --
+    -- A data constructor applied to some expressions. N.B., this
+    -- definition only accounts for data constructors which are
+    -- fully saturated. Unsaturated constructors will need to be
+    -- eta-expanded.
+    Datum_ :: !(Datum (abt '[]) (HData' t)) -> Term abt (HData' t)
+
+    -- Generic case-analysis (via ABTs and Structural Focalization).
+    Case_ :: !(abt '[] a) -> [Branch a abt b] -> Term abt b
+
+    -- Linear combinations of measures.
+    Superpose_
+        :: L.NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
+        -> Term abt ('HMeasure a)
+
+    -- The zero measure
+    Reject_ :: !(Sing ('HMeasure a)) -> Term abt ('HMeasure a)
+
+----------------------------------------------------------------
+-- N.B., having a @singTerm :: Term abt a -> Sing a@ doesn't make
+-- sense: That's what 'inferType' is for, but not all terms can be
+-- inferred; some must be checked... Similarly, we can't derive
+-- Read, since that's what typechecking is all about.
+
+
+-- | A newtype of @abt '[]@, because sometimes we need this in order
+-- to give instances for things. In particular, this is often used
+-- to derive the obvious @Foo1 (abt '[])@ instance from an underlying
+-- @Foo2 abt@ instance. The primary motivating example is to give
+-- the 'Datum_' branch of the @Show1 (Term abt)@ instance.
+newtype LC_ (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) =
+    LC_ { unLC_ :: abt '[] a }
+
+instance Show2 abt => Show1 (LC_ abt) where
+    showsPrec1 p = showsPrec2 p . unLC_
+    show1        = show2        . unLC_
+
+-- Alas, these two instances require importing ABT.hs
+-- HACK: these instances require -XUndecidableInstances
+instance ABT Term abt => Coerce (LC_ abt) where
+    coerceTo   CNil e       = e
+    coerceTo   c    (LC_ e) = LC_ (syn (CoerceTo_ c :$ e :* End))
+
+    coerceFrom CNil e       = e
+    coerceFrom c    (LC_ e) = LC_ (syn (UnsafeFrom_ c :$ e :* End))
+
+instance ABT Term abt => Coerce (Term abt) where
+    coerceTo   CNil e = e
+    coerceTo   c    e = CoerceTo_ c :$ syn e :* End
+
+    coerceFrom CNil e = e
+    coerceFrom c    e = UnsafeFrom_ c :$ syn e :* End
+
+instance Show2 abt => Show1 (Term abt) where
+    showsPrec1 p t =
+        case t of
+        o :$ es ->
+            showParen (p > 4)
+                ( showsPrec  (p+1) o
+                . showString " :$ "
+                . showsPrec1 (p+1) es
+                )
+        NaryOp_ o es ->
+            showParen (p > 9)
+                ( showString "NaryOp_ "
+                . showsPrec  11 o
+                . showString " "
+                . showParen True
+                    ( showString "Seq.fromList "
+                    . showList2 (F.toList es)
+                    )
+                )
+        Literal_ v       -> showParen_0   p "Literal_" v
+        Empty_ _         -> showString      "Empty_"
+        Array_ e1 e2     -> showParen_22  p "Array_" e1 e2
+        ArrayLiteral_ es -> showParen (p > 9) (showString "ArrayLiteral_" . showList2 es)
+        Datum_ d         -> showParen_1   p "Datum_" (fmap11 LC_ d)
+        Case_  e bs      ->
+            showParen (p > 9)
+                ( showString "Case_ "
+                . showsPrec2 11 e
+                . showString " "
+                . showList1 bs
+                )
+        Bucket _ _ _   -> showString "Bucket ..."
+        Superpose_ pes ->
+            showParen (p > 9)
+                ( showString "Superpose_ "
+                . showListWith
+                    (\(e1,e2) -> showTuple [shows2 e1, shows2 e2])
+                    (L.toList pes)
+                )
+        Reject_ _     -> showString      "Reject_"
+
+instance Show2 abt => Show (Term abt a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+
+----------------------------------------------------------------
+instance Functor21 Term where
+    fmap21 f (o :$ es)          = o :$ fmap21 f es
+    fmap21 f (NaryOp_    o  es) = NaryOp_    o (fmap f es)
+    fmap21 _ (Literal_   v)     = Literal_   v
+    fmap21 _ (Empty_ t)         = Empty_ t
+    fmap21 f (Array_     e1 e2) = Array_     (f e1) (f e2)
+    fmap21 f (ArrayLiteral_ es) = ArrayLiteral_ (fmap f es)
+    fmap21 f (Datum_     d)     = Datum_     (fmap11 f d)
+    fmap21 f (Case_      e  bs) = Case_      (f e)  (map (fmap21 f) bs)
+    fmap21 f (Bucket     b e r) = Bucket (f b) (f e) (fmap22 f r)
+    fmap21 f (Superpose_ pes)   = Superpose_ (L.map (f *** f) pes)
+    fmap21 _ (Reject_ t)        = Reject_ t
+
+
+----------------------------------------------------------------
+instance Foldable21 Term where
+    foldMap21 f (_ :$ es)          = foldMap21 f es
+    foldMap21 f (NaryOp_    _  es) = F.foldMap f es
+    foldMap21 _ (Literal_   _)     = mempty
+    foldMap21 _ (Empty_     _)     = mempty
+    foldMap21 f (Array_     e1 e2) = f e1 `mappend` f e2
+    foldMap21 f (ArrayLiteral_ es) = F.foldMap f es
+    foldMap21 f (Datum_     d)     = foldMap11 f d
+    foldMap21 f (Case_      e  bs) = f e `mappend` F.foldMap (foldMap21 f) bs
+    foldMap21 f (Bucket     b e r) = f b `mappend` f e `mappend` foldMap22 f r
+    foldMap21 f (Superpose_ pes)   = foldMapPairs f pes
+    foldMap21 _ (Reject_    _)     = mempty
+
+foldMapPairs
+    :: (Monoid m, F.Foldable f)
+    => (forall h i. abt h i -> m)
+    -> f (abt xs a, abt ys b)
+    -> m
+foldMapPairs f = F.foldMap $ \(e1,e2) -> f e1 `mappend` f e2
+
+
+----------------------------------------------------------------
+instance Traversable21 Term where
+    traverse21 f (o :$ es)          = (o :$) <$> traverse21 f es
+    traverse21 f (NaryOp_    o  es) = NaryOp_  o <$> traverse f es
+    traverse21 _ (Literal_   v)     = pure $ Literal_ v
+    traverse21 _ (Empty_     typ)   = pure $ Empty_   typ
+    traverse21 f (Array_     e1 e2) = Array_ <$> f e1 <*> f e2
+    traverse21 f (ArrayLiteral_ es) = ArrayLiteral_ <$> traverse f es
+    traverse21 f (Bucket b e r)     = Bucket <$> f b <*> f e <*> traverse22 f r
+    traverse21 f (Datum_     d)     = Datum_ <$> traverse11 f d
+    traverse21 f (Case_      e  bs) = Case_  <$> f e <*> traverse (traverse21 f) bs
+    traverse21 f (Superpose_ pes)   = Superpose_ <$> traversePairs f pes
+    traverse21 _ (Reject_    typ)   = pure $ Reject_  typ
+
+traversePairs
+    :: (Applicative f, Traversable t)
+    => (forall h i. abt1 h i -> f (abt2 h i))
+    -> t (abt1 xs a, abt1 ys b)
+    -> f (t (abt2 xs a, abt2 ys b))
+traversePairs f = traverse $ \(x,y) -> (,) <$> f x <*> f y
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/AST/Eq.hs b/haskell/Language/Hakaru/Syntax/AST/Eq.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/AST/Eq.hs
@@ -0,0 +1,629 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , GADTs
+           , TypeOperators
+           , PolyKinds
+           , FlexibleContexts
+           , ScopedTypeVariables
+           , UndecidableInstances
+           #-}
+
+-- TODO: all the instances here are orphans. To ensure that we don't
+-- have issues about orphan instances, we should give them all
+-- newtypes and only provide the instance for those newtypes!
+-- (and\/or: for the various op types, it's okay to move them to
+-- AST.hs to avoid orphanage. It's just the instances for 'Term'
+-- itself which are morally suspect outside of testing.)
+{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-orphans -fno-warn-name-shadowing #-}
+----------------------------------------------------------------
+--                                                    2016.05.24
+-- |
+-- Module      :  Language.Hakaru.Syntax.ABT.Eq
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Warning: The following module is for testing purposes only. Using
+-- the 'JmEq1' instance for 'Term' is inefficient and should not
+-- be done accidentally. To implement that (orphan) instance we
+-- also provide the following (orphan) instances:
+--
+-- > SArgs      : JmEq1
+-- > Term       : JmEq1, Eq1, Eq
+-- > TrivialABT : JmEq2, JmEq1, Eq2, Eq1, Eq
+--
+-- TODO: because this is only for testing, everything else should
+-- move to the @Tests@ directory.
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.AST.Eq where
+
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.Reducer
+
+import Control.Monad.Reader
+
+import qualified Data.Foldable      as F
+import qualified Data.List.NonEmpty as L
+import qualified Data.Sequence      as S
+import qualified Data.Traversable   as T
+
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor ((<$>))
+import           Data.Traversable
+#endif
+
+
+import Data.Maybe
+import Data.List (inits,tails)
+-- import Data.Number.Nat
+
+import Unsafe.Coerce
+
+---------------------------------------------------------------------
+-- | This function performs 'jmEq' on a @(:$)@ node of the AST.
+-- It's necessary to break it out like this since we can't just
+-- give a 'JmEq1' instance for 'SCon' due to polymorphism issues
+-- (e.g., we can't just say that 'Lam_' is John Major equal to
+-- 'Lam_', since they may be at different types). However, once the
+-- 'SArgs' associated with the 'SCon' is given, that resolves the
+-- polymorphism.
+jmEq_S
+    :: (ABT Term abt, JmEq2 abt)
+    => SCon args  a  -> SArgs abt args
+    -> SCon args' a' -> SArgs abt args'
+    -> Maybe (TypeEq a a', TypeEq args args')
+jmEq_S Lam_      es Lam_       es' =
+    jmEq1 es es' >>= \Refl -> Just (Refl, Refl)
+jmEq_S App_      es App_       es' =
+    jmEq1 es es' >>= \Refl -> Just (Refl, Refl)
+jmEq_S Let_      es Let_       es' =
+    jmEq1 es es' >>= \Refl -> Just (Refl, Refl)
+jmEq_S (CoerceTo_ c) (es :* End) (CoerceTo_ c') (es' :* End) = do
+    (Refl, Refl) <- jmEq2 es es'
+    let t1 = coerceTo c  (typeOf es)
+    let t2 = coerceTo c' (typeOf es')
+    Refl <- jmEq1 t1 t2
+    return (Refl, Refl)
+jmEq_S (UnsafeFrom_ c) (es :* End) (UnsafeFrom_ c') (es' :* End) = do
+    (Refl, Refl) <- jmEq2 es es'
+    let t1 = coerceFrom c  (typeOf es)
+    let t2 = coerceFrom c' (typeOf es')
+    Refl <- jmEq1 t1 t2
+    return (Refl, Refl)
+jmEq_S (PrimOp_ op) es (PrimOp_ op') es' = do
+    Refl <- jmEq1 es es'
+    (Refl, Refl) <- jmEq2 op op'
+    return (Refl, Refl)
+jmEq_S (ArrayOp_ op) es (ArrayOp_ op') es' = do
+    Refl <- jmEq1 es es'
+    (Refl, Refl) <- jmEq2 op op'
+    return (Refl, Refl)
+jmEq_S (MeasureOp_ op) es (MeasureOp_ op') es' = do
+    Refl <- jmEq1 es es'
+    (Refl, Refl) <- jmEq2 op op'
+    return (Refl, Refl)
+jmEq_S Dirac     es Dirac      es' =
+    jmEq1 es es' >>= \Refl -> Just (Refl, Refl)
+jmEq_S MBind     es MBind      es' =
+    jmEq1 es es' >>= \Refl -> Just (Refl, Refl)
+jmEq_S Integrate es Integrate  es' =
+    jmEq1 es es' >>= \Refl -> Just (Refl, Refl)
+jmEq_S (Summate h1 h2) es (Summate h1' h2') es' = do
+    Refl <- jmEq1 (sing_HDiscrete h1) (sing_HDiscrete h1')
+    Refl <- jmEq1 (sing_HSemiring h2) (sing_HSemiring h2')
+    Refl <- jmEq1 es es'
+    Just (Refl, Refl)
+jmEq_S (Product h1 h2) es (Product h1' h2') es' = do
+    Refl <- jmEq1 (sing_HDiscrete h1) (sing_HDiscrete h1')
+    Refl <- jmEq1 (sing_HSemiring h2) (sing_HSemiring h2')
+    Refl <- jmEq1 es es'
+    Just (Refl, Refl)
+jmEq_S (Transform_ t0) es (Transform_ t1)   es' = do
+    Refl <- jmEq1 es es'
+    Refl <- jmEq_Transform t0 t1
+    Just (Refl, Refl)
+jmEq_S _         _  _          _   = Nothing
+
+jmEq_Transform
+    :: Transform args a
+    -> Transform args a'
+    -> Maybe (TypeEq a a')
+jmEq_Transform t0 t1 =
+  case (t0, t1) of
+    (Expect   , Expect   ) -> Just Refl
+    (Observe  , Observe  ) -> Just Refl
+    (MH       , MH       ) -> Just Refl
+    (MCMC     , MCMC     ) -> Just Refl
+    (Disint k0, Disint k1) ->
+      if k0==k1 then Just Refl else Nothing
+    (Summarize, Summarize) -> Just Refl
+    (Simplify , Simplify ) -> Just Refl
+    (Reparam  , Reparam  ) -> Just Refl
+    _                      -> Nothing
+
+-- TODO: Handle jmEq2 of pat and pat'
+jmEq_Branch
+    :: (ABT Term abt, JmEq2 abt)
+    => [(Branch a abt b, Branch a abt b')]
+    -> Maybe (TypeEq b b')
+jmEq_Branch []                                  = Nothing
+jmEq_Branch [(Branch _ e, Branch _ e')]    = do
+    (Refl, Refl) <- jmEq2 e e'
+    return Refl
+jmEq_Branch ((Branch _ e, Branch _ e'):es) = do
+    (Refl, Refl) <- jmEq2 e e'
+    jmEq_Branch es
+
+instance JmEq2 abt => JmEq1 (SArgs abt) where
+    jmEq1 End       End       = Just Refl
+    jmEq1 (x :* xs) (y :* ys) =
+        jmEq2 x  y  >>= \(Refl, Refl) ->
+        jmEq1 xs ys >>= \Refl ->
+        Just Refl
+    jmEq1 _         _         = Nothing
+
+
+instance (ABT Term abt, JmEq2 abt) => JmEq1 (Term abt) where
+    jmEq1 (o :$ es) (o' :$ es') = do
+        (Refl, Refl) <- jmEq_S o es o' es'
+        return Refl
+    jmEq1 (NaryOp_ o es) (NaryOp_ o' es') = do
+        Refl <- jmEq1 o o'
+        () <- all_jmEq2 es es'
+        return Refl
+    jmEq1 (Literal_ v)  (Literal_ w)   = jmEq1 v w
+    jmEq1 (Empty_ a)    (Empty_ b)     = jmEq1 a b
+    jmEq1 (Array_ i f)  (Array_ j g)   = do
+        (Refl, Refl) <- jmEq2 i j
+        (Refl, Refl) <- jmEq2 f g
+        Just Refl
+    -- Assumes nonempty literal arrays. The hope is that Empty_ covers that case.
+    -- TODO handle empty literal arrays.
+    jmEq1 (ArrayLiteral_ (e:es)) (ArrayLiteral_ (e':es')) = do
+        (Refl, Refl) <- jmEq2 e e'
+        () <- all_jmEq2 (S.fromList es) (S.fromList es')
+        return Refl
+    jmEq1 (Bucket a b r) (Bucket a' b' r') = do
+        (Refl, Refl) <- jmEq2 a a'
+        (Refl, Refl) <- jmEq2 b b'
+        Refl         <- jmEq1 r r'
+        return Refl
+    jmEq1 (Datum_ (Datum hint _ _)) (Datum_ (Datum hint' _ _))
+        -- BUG: We need to compare structurally rather than using the hint
+        | hint == hint' = unsafeCoerce (Just Refl)
+        | otherwise     = Nothing
+    jmEq1 (Case_  a bs) (Case_  a' bs')      = do
+        (Refl, Refl) <- jmEq2 a a'
+        jmEq_Branch (zip bs bs')
+    jmEq1 (Superpose_ pms) (Superpose_ pms') = do
+      (Refl,Refl) L.:| _ <- T.sequence $ fmap jmEq_Tuple (L.zip pms pms')
+      return Refl
+    jmEq1 _              _              = Nothing
+
+
+all_jmEq2
+    :: (ABT Term abt, JmEq2 abt)
+    => S.Seq (abt '[] a)
+    -> S.Seq (abt '[] a)
+    -> Maybe ()
+all_jmEq2 xs ys =
+    let eq x y = isJust (jmEq2 x y)
+    in if F.and (S.zipWith eq xs ys) then Just () else Nothing
+
+
+jmEq_Tuple :: (ABT Term abt, JmEq2 abt)
+           => ((abt '[] a , abt '[] b), 
+               (abt '[] a', abt '[] b'))
+           -> Maybe (TypeEq a a', TypeEq b b')
+jmEq_Tuple ((a,b), (a',b')) = do
+  a'' <- jmEq2 a a' >>= (\(Refl, Refl) -> Just Refl)
+  b'' <- jmEq2 b b' >>= (\(Refl, Refl) -> Just Refl)
+  return (a'', b'')
+
+
+-- TODO: a more general function of type:
+--   (JmEq2 abt) => Term abt a -> Term abt b -> Maybe (Sing a, TypeEq a b)
+-- This can then be used to define typeOf and instance JmEq2 Term
+
+instance (ABT Term abt, JmEq2 abt) => Eq1 (Term abt) where
+    eq1 x y = isJust (jmEq1 x y)
+
+instance (ABT Term abt, JmEq2 abt) => Eq (Term abt a) where
+    (==) = eq1
+
+instance ( Show1 (Sing :: k -> *)
+         , JmEq1 (Sing :: k -> *)
+         , JmEq1 (syn (TrivialABT syn))
+         , Foldable21 syn
+         ) => JmEq2 (TrivialABT (syn :: ([k] -> k -> *) -> k -> *))
+    where
+    jmEq2 x y =
+        case (viewABT x, viewABT y) of
+        (Syn t1, Syn t2) ->
+            jmEq1 t1 t2 >>= \Refl -> Just (Refl, Refl) 
+        (Var (Variable _ _ t1), Var (Variable _ _ t2)) ->
+            jmEq1 t1 t2 >>= \Refl -> Just (Refl, Refl)
+        (Bind (Variable _ _ x1) v1, Bind (Variable _ _ x2) v2) -> do
+            Refl <- jmEq1 x1 x2
+            (Refl,Refl) <- jmEq2 (unviewABT v1) (unviewABT v2)
+            return (Refl, Refl)
+        _ -> Nothing
+
+instance ( Show1 (Sing :: k -> *)
+         , JmEq1 (Sing :: k -> *)
+         , JmEq1 (syn (TrivialABT syn))
+         , Foldable21 syn
+         ) => JmEq1 (TrivialABT (syn :: ([k] -> k -> *) -> k -> *) xs)
+    where
+    jmEq1 x y = jmEq2 x y >>= \(Refl, Refl) -> Just Refl
+
+instance ( Show1 (Sing :: k ->  *)
+         , JmEq1 (Sing :: k -> *)
+         , Foldable21 syn
+         , JmEq1 (syn (TrivialABT syn))
+         ) => Eq2 (TrivialABT (syn :: ([k] -> k -> *) -> k -> *))
+    where
+    eq2 x y = isJust (jmEq2 x y)
+
+instance ( Show1 (Sing :: k ->  *)
+         , JmEq1 (Sing :: k -> *)
+         , Foldable21 syn
+         , JmEq1 (syn (TrivialABT syn))
+         ) => Eq1 (TrivialABT (syn :: ([k] -> k -> *) -> k -> *) xs)
+    where
+    eq1 = eq2
+
+instance ( Show1 (Sing :: k ->  *)
+         , JmEq1 (Sing :: k -> *)
+         , Foldable21 syn
+         , JmEq1 (syn (TrivialABT syn))
+         ) => Eq (TrivialABT (syn :: ([k] -> k -> *) -> k -> *) xs a)
+    where
+    (==) = eq1
+
+
+type Varmap = Assocs (Variable :: Hakaru -> *)
+
+void_jmEq1
+    :: Sing (a :: Hakaru)
+    -> Sing (b :: Hakaru)
+    -> ReaderT Varmap Maybe ()
+void_jmEq1 x y = lift (jmEq1 x y) >> return ()
+
+void_varEq
+    :: Variable (a :: Hakaru)
+    -> Variable (b :: Hakaru)
+    -> ReaderT Varmap Maybe ()   
+void_varEq x y = lift (varEq x y) >> return ()
+
+try_bool :: Bool -> ReaderT Varmap Maybe ()
+try_bool b = lift $ if b then Just () else Nothing
+
+split :: [a] -> [(a,[a])]
+split xs = zipWith (\as (b:bs)->(b,as++bs)) (inits xs) (init $ tails xs)
+
+zipWithSetM :: MonadPlus m => (a -> a -> m ()) -> [a] -> [a] -> m ()
+zipWithSetM _ [] ys = guard (null ys)
+zipWithSetM q (x:xs) ys = msum [ q x y >> zipWithSetM q xs ys' | (y,ys') <- split ys ]
+
+zipWithSetMF :: (MonadPlus m, F.Foldable f) => (a -> a -> m ()) -> f a -> f a -> m ()
+zipWithSetMF q a b = zipWithSetM q (F.toList a) (F.toList b)
+
+
+alphaEq
+    :: forall abt d
+    .  (ABT Term abt)
+    => abt '[] d
+    -> abt '[] d
+    -> Bool
+alphaEq e1 e2 =
+    maybe False (const True)
+        $ runReaderT (go (viewABT e1) (viewABT e2)) emptyAssocs
+    where
+    -- Don't compare @x@ to @y@ directly; instead,
+    -- look up whatever @x@ renames to (i.e., @y'@)
+    -- and then see whether that is equal to @y@.
+    go  :: forall xs1 xs2 a
+        .  View (Term abt) xs1 a
+        -> View (Term abt) xs2 a
+        -> ReaderT Varmap Maybe ()
+    go (Var x) (Var y) = do
+        s <- ask
+        case lookupAssoc x s of
+            Nothing -> void_varEq x  y -- free variables
+            Just y' -> void_varEq y' y
+
+    -- remember that @x@ renames to @y@ and recurse
+    go (Bind x e1) (Bind y e2) = do
+        Refl <- lift $ jmEq1 (varType x) (varType y)
+        local (insertAssoc (Assoc x y)) (go e1 e2)
+
+    -- perform the core comparison for syntactic equality
+    go (Syn t1) (Syn t2) = termEq t1 t2
+
+    -- if the views don't match, then clearly they are not equal.
+    go _ _ = lift Nothing
+
+    termEq :: forall a
+        .  Term abt a
+        -> Term abt a
+        -> ReaderT Varmap Maybe ()
+    termEq e1 e2 =
+        case (e1, e2) of
+        (o1 :$ es1, o2 :$ es2)             -> sConEq o1 es1 o2 es2
+        (NaryOp_ op1 es1, NaryOp_ op2 es2) -> do
+            try_bool (op1 == op2)
+            zipWithSetMF go (viewABT <$> es1) (viewABT <$> es2)
+        (Literal_ x, Literal_ y)           -> try_bool (x == y)
+        (Empty_ x, Empty_ y)               -> void_jmEq1 x y
+        (Datum_ d1, Datum_ d2)             -> datumEq d1 d2
+        (Array_ n1 e1, Array_ n2 e2)       -> do
+            go (viewABT n1) (viewABT n2)
+            go (viewABT e1) (viewABT e2)
+        (ArrayLiteral_ es, ArrayLiteral_ es') ->
+            F.sequence_ $ zipWith go (viewABT <$> es) (viewABT <$> es')
+        (Bucket a b r, Bucket a' b' r')    -> do
+            go (viewABT a) (viewABT a')
+            go (viewABT b) (viewABT b')
+            reducerEq r r'
+        (Case_ e1 bs1, Case_ e2 bs2)       -> do
+            Refl <- lift $ jmEq1 (typeOf e1) (typeOf e2)
+            go (viewABT e1) (viewABT e2)
+            zipWithM_ sBranch bs1 bs2
+        (Superpose_ pms1, Superpose_ pms2) ->
+            zipWithSetMF pairEq pms1 pms2
+        (Reject_ x, Reject_ y)             -> void_jmEq1 x y
+        (_, _)                             -> lift Nothing
+
+    sArgsEq
+        :: forall args
+        .  SArgs abt args
+        -> SArgs abt args
+        -> ReaderT Varmap Maybe ()
+    sArgsEq End         End         = return ()
+    sArgsEq (e1 :* es1) (e2 :* es2) = do
+        go (viewABT e1) (viewABT e2)
+        sArgsEq es1 es2
+
+    sConEq
+        :: forall a args1 args2
+        .  SCon  args1 a
+        -> SArgs abt args1
+        -> SCon args2 a
+        -> SArgs abt args2
+        -> ReaderT Varmap Maybe ()
+    sConEq Lam_   e1
+           Lam_   e2 = sArgsEq e1 e2
+
+    sConEq App_   (e1  :* e2  :* End)
+           App_   (e1' :* e2' :* End) = do
+        Refl <- lift $ jmEq1 (typeOf e2) (typeOf e2')
+        go (viewABT e1) (viewABT e1')
+        go (viewABT e2) (viewABT e2')
+
+    sConEq Let_   (e1  :* e2  :* End)
+           Let_   (e1' :* e2' :* End) = do
+        Refl <- lift $ jmEq1 (typeOf e1) (typeOf e1')
+        go (viewABT e1) (viewABT e1')
+        go (viewABT e2) (viewABT e2')
+
+    sConEq (CoerceTo_ _) (e1 :* End)
+           (CoerceTo_ _) (e2 :* End) = do
+        Refl <- lift $ jmEq1 (typeOf e1) (typeOf e2)
+        go (viewABT e1) (viewABT e2)
+
+    sConEq (UnsafeFrom_ _) (e1 :* End)
+           (UnsafeFrom_ _) (e2 :* End) = do
+        Refl <- lift $ jmEq1 (typeOf e1) (typeOf e2)
+        go (viewABT e1) (viewABT e2)
+
+    sConEq (PrimOp_ o1) es1
+           (PrimOp_ o2) es2    = primOpEq o1 es1 o2 es2
+
+    sConEq (ArrayOp_ o1) es1
+           (ArrayOp_ o2) es2   = arrayOpEq o1 es1 o2 es2
+
+    sConEq (MeasureOp_ o1) es1
+           (MeasureOp_ o2) es2 = measureOpEq o1 es1 o2 es2
+
+    sConEq Dirac e1
+           Dirac e2            = sArgsEq e1 e2
+
+    sConEq MBind (e1  :* e2  :* End)
+           MBind (e1' :* e2' :* End) = do
+        Refl <- lift $ jmEq1 (typeOf e1) (typeOf e1')
+        go (viewABT e1) (viewABT e1')
+        go (viewABT e2) (viewABT e2')
+
+    sConEq Plate     e1 Plate     e2    = sArgsEq e1 e2
+    sConEq Chain     e1 Chain     e2    = sArgsEq e1 e2
+    sConEq Integrate e1 Integrate e2    = sArgsEq e1 e2
+
+    sConEq (Summate h1 h2) e1 (Summate h1' h2') e2 = do
+        Refl <- lift $ jmEq1 (sing_HDiscrete h1) (sing_HDiscrete h1')
+        Refl <- lift $ jmEq1 (sing_HSemiring h2) (sing_HSemiring h2')
+        sArgsEq e1 e2
+
+    sConEq (Product h1 h2) e1 (Product h1' h2') e2 = do
+        Refl <- lift $ jmEq1 (sing_HDiscrete h1) (sing_HDiscrete h1')
+        Refl <- lift $ jmEq1 (sing_HSemiring h2) (sing_HSemiring h2')
+        sArgsEq e1 e2
+
+    sConEq (Transform_ t1) e1
+           (Transform_ t2) e2 = transformEq t1 e1 t2 e2
+
+    sConEq _ _ _ _ = lift Nothing
+
+    transformEq
+        :: Transform args1 a1
+        -> SArgs abt args1
+        -> Transform args2 a1
+        -> SArgs abt args2
+        -> ReaderT Varmap Maybe ()
+    transformEq t0 e0 t1 e1 =
+      case (t0, t1) of
+        -- Special case needed because some type variables in the input do not
+        -- appear in the output
+        (Expect   , Expect   ) ->
+          case (e0, e1) of
+           (e1  :* e2  :* End,
+            e1' :* e2' :* End) -> do
+             Refl <- lift $ jmEq1 (typeOf e1) (typeOf e1')
+             go (viewABT e1) (viewABT e1')
+             go (viewABT e2) (viewABT e2')
+        (Observe  , Observe  ) -> sArgsEq e0 e1
+        (MH       , MH       ) -> sArgsEq e0 e1
+        (MCMC     , MCMC     ) -> sArgsEq e0 e1
+        (Disint k0, Disint k1) ->
+          if k0==k1 then sArgsEq e0 e1 else lift Nothing
+        (Summarize, Summarize) -> sArgsEq e0 e1
+        (Simplify , Simplify ) -> sArgsEq e0 e1
+        (Reparam  , Reparam  ) -> sArgsEq e0 e1
+        _                      -> lift Nothing
+
+    primOpEq
+        :: forall a typs1 typs2 args1 args2
+        .  (typs1 ~ UnLCs args1, args1 ~ LCs typs1,
+            typs2 ~ UnLCs args2, args2 ~ LCs typs2)
+        => PrimOp typs1 a -> SArgs abt args1
+        -> PrimOp typs2 a -> SArgs abt args2
+        -> ReaderT Varmap Maybe ()
+    primOpEq p1 e1' p2 e2' = do
+        (Refl, Refl) <- lift $ jmEq2 p1 p2
+        sArgsEq e1' e2'
+
+    arrayOpEq
+        :: forall a typs1 typs2 args1 args2
+        .  (typs1 ~ UnLCs args1, args1 ~ LCs typs1,
+            typs2 ~ UnLCs args2, args2 ~ LCs typs2)
+        => ArrayOp typs1 a -> SArgs abt args1
+        -> ArrayOp typs2 a -> SArgs abt args2
+        -> ReaderT Varmap Maybe ()
+    arrayOpEq p1 e1 p2 e2 = do
+        (Refl, Refl) <- lift $ jmEq2 p1 p2
+        sArgsEq e1 e2
+
+    measureOpEq
+        :: forall a typs1 typs2 args1 args2
+        . (typs1 ~ UnLCs args1, args1 ~ LCs typs1,
+            typs2 ~ UnLCs args2, args2 ~ LCs typs2)
+        => MeasureOp typs1 a -> SArgs abt args1
+        -> MeasureOp typs2 a -> SArgs abt args2
+        -> ReaderT Varmap Maybe ()
+    measureOpEq m1 e1' m2 e2' = do
+        (Refl,Refl) <- lift $ jmEq2 m1 m2
+        sArgsEq e1' e2'
+
+    datumEq :: forall a
+        .  Datum (abt '[]) a
+        -> Datum (abt '[]) a
+        -> ReaderT Varmap Maybe ()
+    datumEq (Datum _ _ d1) (Datum _ _ d2) = datumCodeEq d1 d2
+
+    datumCodeEq
+        :: forall xss a
+        .  DatumCode xss (abt '[]) a
+        -> DatumCode xss (abt '[]) a
+        -> ReaderT Varmap Maybe ()
+    datumCodeEq (Inr c) (Inr d) = datumCodeEq c d
+    datumCodeEq (Inl c) (Inl d) = datumStructEq c d
+    datumCodeEq _       _       = lift Nothing
+
+    datumStructEq
+        :: forall xs a
+        .  DatumStruct xs (abt '[]) a
+        -> DatumStruct xs (abt '[]) a
+        -> ReaderT Varmap Maybe ()
+    datumStructEq (Et c1 c2) (Et d1 d2) = do
+        datumFunEq c1 d1
+        datumStructEq c2 d2
+    datumStructEq Done       Done       = return ()
+    
+    datumFunEq
+        :: forall x a
+        .  DatumFun x (abt '[]) a
+        -> DatumFun x (abt '[]) a
+        -> ReaderT Varmap Maybe ()
+    datumFunEq (Konst e) (Konst f) = go (viewABT e) (viewABT f) 
+    datumFunEq (Ident e) (Ident f) = go (viewABT e) (viewABT f) 
+    
+    pairEq
+        :: forall c b
+        .  (abt '[] c, abt '[] b)
+        -> (abt '[] c, abt '[] b)
+        -> ReaderT Varmap Maybe ()
+    pairEq (x1, y1) (x2, y2) = do
+        go (viewABT x1) (viewABT x2)
+        go (viewABT y1) (viewABT y2)
+
+    sBranch
+        :: forall c b
+        .  Branch c abt b
+        -> Branch c abt b
+        -> ReaderT Varmap Maybe ()
+    sBranch (Branch p3 e3) (Branch p4 e4) = patternEq p3 p4 >> go (viewABT e3) (viewABT e4)
+
+    patternEq 
+        :: Pattern a0 b0
+        -> Pattern a1 b1
+        -> ReaderT Varmap Maybe ()
+    patternEq PWild         PWild       = return () 
+    patternEq PVar          PVar        = return () 
+    patternEq (PDatum _ a) (PDatum _ b) = pdatumCodeEq a b 
+    patternEq _             _           = mzero 
+      
+    pdatumCodeEq
+        :: PDatumCode xss0 vs0 a0
+        -> PDatumCode xss1 vs1 a1
+        -> ReaderT Varmap Maybe ()
+    pdatumCodeEq (PInr c) (PInr d) = pdatumCodeEq c d
+    pdatumCodeEq (PInl c) (PInl d) = pdatumStructEq c d
+    pdatumCodeEq _         _       = mzero
+
+    pdatumStructEq
+        :: PDatumStruct xs0 vs0 a0
+        -> PDatumStruct xs1 vs1 a1
+        -> ReaderT Varmap Maybe ()
+    pdatumStructEq (PEt c1 c2) (PEt d1 d2) = do
+        pdatumFunEq c1 d1
+        pdatumStructEq c2 d2
+    pdatumStructEq PDone        PDone      = return ()
+    pdatumStructEq _            _          = lift Nothing
+
+    pdatumFunEq
+        :: PDatumFun x0 vs0 a0
+        -> PDatumFun x1 vs1 a1
+        -> ReaderT Varmap Maybe ()
+    pdatumFunEq (PKonst e) (PKonst f) = patternEq e f
+    pdatumFunEq (PIdent e) (PIdent f) = patternEq e f
+    pdatumFunEq _          _          = lift Nothing
+
+    reducerEq
+        :: forall xs b
+        .  Reducer abt xs b
+        -> Reducer abt xs b
+        -> ReaderT Varmap Maybe ()
+    reducerEq (Red_Fanout r s) (Red_Fanout r' s')    = do
+        reducerEq r r'
+        reducerEq s s'
+    reducerEq (Red_Index s i r) (Red_Index s' i' r') = do
+        go (viewABT s) (viewABT s')
+        go (viewABT i) (viewABT i')
+        reducerEq r r'
+    reducerEq (Red_Split i r s) (Red_Split i' r' s') = do
+        go (viewABT i) (viewABT i')
+        reducerEq r r'
+        reducerEq s s'
+    reducerEq Red_Nop Red_Nop                        = return ()
+    reducerEq (Red_Add _ x) (Red_Add _ x')           = go (viewABT x) (viewABT x')
+    reducerEq _ _                                    = lift Nothing
diff --git a/haskell/Language/Hakaru/Syntax/AST/Sing.hs b/haskell/Language/Hakaru/Syntax/AST/Sing.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/AST/Sing.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE CPP, GADTs #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2015.12.19
+-- |
+-- Module      :  Language.Hakaru.Syntax.AST.Sing
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Factored out from "Language.Hakaru.Syntax.AST".
+--
+-- TODO: if we're not going to have this in "Language.Hakaru.Syntax.AST", then we should rename it to @Language.Hakaru.Syntax.AST.Sing@ or the like.
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.AST.Sing
+    ( sing_NaryOp
+    , sing_PrimOp
+    , sing_ArrayOp
+    , sing_MeasureOp
+    , sing_Literal
+    ) where
+
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Syntax.AST
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- N.B., we do case analysis so that we don't need the class constraint!
+sing_Literal :: Literal a -> Sing a
+sing_Literal (LNat  _) = sing
+sing_Literal (LInt  _) = sing
+sing_Literal (LProb _) = sing
+sing_Literal (LReal _) = sing
+
+-- TODO: we don't need to store the HOrd\/HSemiring values here,
+-- we can recover them by typeclass, just like we use 'sing' to get
+-- 'sBool' for the other ones...
+sing_NaryOp :: NaryOp a -> Sing a
+sing_NaryOp And            = sing
+sing_NaryOp Or             = sing
+sing_NaryOp Xor            = sing
+sing_NaryOp Iff            = sing
+sing_NaryOp (Min  theOrd)  = sing_HOrd      theOrd
+sing_NaryOp (Max  theOrd)  = sing_HOrd      theOrd
+sing_NaryOp (Sum  theSemi) = sing_HSemiring theSemi
+sing_NaryOp (Prod theSemi) = sing_HSemiring theSemi
+
+-- TODO: is there any way to define a @sing_List1@ like @sing@ for automating all these monomorphic cases?
+sing_PrimOp :: PrimOp typs a -> (List1 Sing typs, Sing a)
+sing_PrimOp Not          = (sing `Cons1` Nil1, sing)
+sing_PrimOp Impl         = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_PrimOp Diff         = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_PrimOp Nand         = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_PrimOp Nor          = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_PrimOp Pi           = (Nil1, sing)
+sing_PrimOp Sin          = (sing `Cons1` Nil1, sing)
+sing_PrimOp Cos          = (sing `Cons1` Nil1, sing)
+sing_PrimOp Tan          = (sing `Cons1` Nil1, sing)
+sing_PrimOp Asin         = (sing `Cons1` Nil1, sing)
+sing_PrimOp Acos         = (sing `Cons1` Nil1, sing)
+sing_PrimOp Atan         = (sing `Cons1` Nil1, sing)
+sing_PrimOp Sinh         = (sing `Cons1` Nil1, sing)
+sing_PrimOp Cosh         = (sing `Cons1` Nil1, sing)
+sing_PrimOp Tanh         = (sing `Cons1` Nil1, sing)
+sing_PrimOp Asinh        = (sing `Cons1` Nil1, sing)
+sing_PrimOp Acosh        = (sing `Cons1` Nil1, sing)
+sing_PrimOp Atanh        = (sing `Cons1` Nil1, sing)
+sing_PrimOp RealPow      = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_PrimOp Choose       = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_PrimOp Exp          = (sing `Cons1` Nil1, sing)
+sing_PrimOp Log          = (sing `Cons1` Nil1, sing)
+sing_PrimOp Floor        = (sing `Cons1` Nil1, sing)
+sing_PrimOp (Infinity h) = (Nil1, sing_HIntegrable h)
+sing_PrimOp GammaFunc    = (sing `Cons1` Nil1, sing)
+sing_PrimOp BetaFunc     = (sing `Cons1` sing `Cons1` Nil1, sing)
+-- Mere case analysis isn't enough for the rest of these, because
+-- of the class constraints. We fix that by various helper functions
+-- on explicit dictionary passing.
+--
+-- TODO: is there any way to automate building these from their
+-- respective @a@ proofs?
+sing_PrimOp (Equal theEq) =
+    let a = sing_HEq theEq
+    in  (a `Cons1` a `Cons1` Nil1, sBool)
+sing_PrimOp (Less theOrd) =
+    let a = sing_HOrd theOrd
+    in  (a `Cons1` a `Cons1` Nil1, sBool)
+sing_PrimOp (NatPow theSemi) =
+    let a = sing_HSemiring theSemi
+    in  (a `Cons1` SNat `Cons1` Nil1, a)
+sing_PrimOp (Negate theRing) =
+    let a = sing_HRing theRing
+    in  (a `Cons1` Nil1, a)
+sing_PrimOp (Abs theRing) =
+    let a = sing_HRing theRing
+        b = sing_NonNegative theRing
+    in  (a `Cons1` Nil1, b)
+sing_PrimOp (Signum theRing) =
+    let a = sing_HRing theRing
+    in  (a `Cons1` Nil1, a)
+sing_PrimOp (Recip theFrac) =
+    let a = sing_HFractional theFrac
+    in  (a `Cons1` Nil1, a)
+sing_PrimOp (NatRoot theRad) =
+    let a = sing_HRadical theRad
+    in  (a `Cons1` SNat `Cons1` Nil1, a)
+sing_PrimOp (Erf theCont) =
+    let a = sing_HContinuous theCont
+    in  (a `Cons1` Nil1, a)
+
+
+sing_ArrayOp :: ArrayOp typs a -> (List1 Sing typs, Sing a)
+sing_ArrayOp (Index  a) = (SArray a `Cons1` SNat `Cons1` Nil1, a)
+sing_ArrayOp (Size   a) = (SArray a `Cons1` Nil1, SNat)
+sing_ArrayOp (Reduce a) =
+    ((a `SFun` a `SFun` a) `Cons1` a `Cons1` SArray a `Cons1` Nil1, a)
+
+
+sing_MeasureOp :: MeasureOp typs a -> (List1 Sing typs, Sing a)
+sing_MeasureOp Lebesgue    = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_MeasureOp Counting    = (Nil1, sing)
+sing_MeasureOp Categorical = (sing `Cons1` Nil1, sing)
+sing_MeasureOp Uniform     = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_MeasureOp Normal      = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_MeasureOp Poisson     = (sing `Cons1` Nil1, sing)
+sing_MeasureOp Gamma       = (sing `Cons1` sing `Cons1` Nil1, sing)
+sing_MeasureOp Beta        = (sing `Cons1` sing `Cons1` Nil1, sing)
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/AST/Transforms.hs b/haskell/Language/Hakaru/Syntax/AST/Transforms.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/AST/Transforms.hs
@@ -0,0 +1,284 @@
+{-# LANGUAGE FlexibleContexts
+           , GADTs
+           , ScopedTypeVariables
+           , DataKinds
+           , TypeOperators
+           , OverloadedStrings
+           , LambdaCase
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+---------------------------------------------------------------
+module Language.Hakaru.Syntax.AST.Transforms where
+
+import qualified Data.Sequence as S
+
+import Language.Hakaru.Syntax.ANF      (normalize)
+import Language.Hakaru.Syntax.CSE      (cse)
+import Language.Hakaru.Syntax.Prune    (prune)
+import Language.Hakaru.Syntax.Uniquify (uniquify)
+import Language.Hakaru.Syntax.Hoist    (hoist)
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Syntax.Prelude (lamWithVar, app)
+import Language.Hakaru.Types.DataKind
+
+import Language.Hakaru.Expect       (expectInCtx, determineExpect)
+import Language.Hakaru.Disintegrate (determine, observeInCtx, disintegrateInCtx)
+import Language.Hakaru.Inference    (mcmc', mh')
+import Language.Hakaru.Maple        (sendToMaple, MapleOptions(..)
+                                    ,defaultMapleOptions, MapleCommand(..)
+                                    ,MapleException)
+
+import Data.Ratio (numerator, denominator)
+import Language.Hakaru.Types.Sing (sing, Sing(..), sUnFun)
+import Language.Hakaru.Types.HClasses (HFractional(..))
+import Language.Hakaru.Types.Coercion (findCoercion, Coerce(..))
+import qualified Data.Sequence as Seq 
+import Control.Monad.Fix (MonadFix)
+import Control.Monad (liftM)
+import Control.Monad.Trans (MonadTrans(..))
+import Control.Monad.State  (StateT(..), evalStateT, put, get, withStateT)
+import Control.Applicative (Applicative(..), Alternative(..), (<$>), (<$))
+import Data.Functor.Identity (Identity(..))
+
+import Control.Exception (try)
+import System.IO (stderr)
+import Data.Text.Utf8 (hPutStrLn)
+import Data.Text (pack)
+import Data.Monoid (Monoid(..), (<>))
+
+import Debug.Trace
+
+
+optimizations
+  :: (ABT Term abt)
+  => abt '[] a
+  -> abt '[] a
+optimizations = uniquify
+              . prune
+              . cse
+              . hoist
+              -- The hoist pass needs globally uniqiue identifiers
+              . uniquify
+              . normalize
+
+underLam
+    :: (ABT Term abt, Monad m)
+    => (abt '[] b -> m (abt '[] b))
+    -> abt '[] (a ':-> b)
+    -> m (abt '[] (a ':-> b))
+underLam f e = caseVarSyn e (return . var) $ \t ->
+                   case t of
+                   Lam_ :$ e1 :* End ->
+                       caseBind e1 $ \x e1' -> do
+                           e1'' <- f e1'
+                           return . syn $
+                                  Lam_  :$ (bind x e1'' :* End)
+
+                   Let_ :$ e1 :* e2 :* End ->
+                        case jmEq1 (typeOf e1) (typeOf e) of
+                          Just Refl -> do
+                               e1' <- underLam f e1
+                               return . syn $
+                                      Let_ :$ e1' :* e2 :* End
+                          Nothing   -> caseBind e2 $ \x e2' -> do
+                                         e2'' <- underLam f e2'
+                                         return . syn $
+                                                Let_ :$ e1 :* (bind x e2'') :* End
+
+                   _ -> error "TODO: underLam"
+
+underLam'
+    :: forall abt m a b b'
+     . (ABT Term abt, MonadFix m)
+    => (abt '[] b -> m (abt '[] b'))
+    -> abt '[] (a ':-> b)
+    -> m (abt '[] (a ':-> b'))
+underLam' f e = do
+  f' <- trace "underLam': build function" $
+        liftM (\f' b -> app (syn $ Lam_ :$ f' :* End) b) $
+        binderM "" (snd $ sUnFun $ typeOf e) f
+  return $ underLam'p f' e
+
+underLam'p
+    :: forall abt a b b'
+     . (ABT Term abt)
+    => (abt '[] b -> abt '[] b')
+    -> abt '[] (a ':-> b)
+    -> abt '[] (a ':-> b')
+underLam'p f e =
+  let var_ :: Variable (a ':-> b) -> abt '[] (a ':-> b')
+      var_ v_ab = trace "underLam': entered var" $
+        lamWithVar "" (fst $ sUnFun $ varType v_ab) $ \a ->
+        trace "underLam': applied function" $ f $ app (var v_ab) a
+
+      syn_ t = trace "underLam': entered syn" $
+        case t of
+        Lam_ :$ e1 :* End -> trace "underLam': entered syn/Lam_" $
+          caseBind e1 $ \x e1' ->
+            trace "underLam': rebuilt Lam_" $
+            syn $ Lam_  :$
+                (trace "underLam': applied bind{Lam_}" $
+                      bind x (trace "underLam': applied function{Lam_}"
+                                $ f e1')) :* End
+
+        Let_ :$ e1 :* e2 :* End -> trace "underLam': entered syn/Lam_" $
+          caseBind e2 $ \x e2' ->
+            trace "underLam': rebuilt Let_" $
+            syn $ Let_ :$ e1 :*
+                  (trace "underLam': applied bind{Lam_}" $
+                         bind x (trace "underLam': recursive case{Let_}" $
+                                       go e2')) :* End
+
+        _ -> error "TODO: underLam'"
+
+      go e' = trace "underLam': entered main body" $
+              caseVarSyn e' var_ syn_
+  in go e
+
+--------------------------------------------------------------------------------
+
+expandTransformations
+    :: forall abt a
+    . (ABT Term abt)
+    => abt '[] a -> abt '[] a
+expandTransformations =
+  expandTransformationsWith' haskellTransformations
+
+expandAllTransformations
+    :: forall abt a
+    . (ABT Term abt)
+    => abt '[] a -> IO (abt '[] a)
+expandAllTransformations =
+  expandTransformationsWith allTransformations
+
+expandTransformationsWith'
+    :: forall abt a
+    . (ABT Term abt)
+    => TransformTable abt Identity
+    -> abt '[] a -> abt '[] a
+expandTransformationsWith' tbl =
+  runIdentity . expandTransformationsWith tbl
+
+type TransformM = StateT TransformCtx
+
+expandTransformationsWith
+    :: forall abt a m
+    . (ABT Term abt, Applicative m, Monad m)
+    => TransformTable abt m
+    -> abt '[] a -> m (abt '[] a)
+expandTransformationsWith tbl t0 =
+  flip evalStateT (mempty {nextFreeVar = nextFreeOrBind t0}) .
+  cataABTM (pure . var) bind_ (>>= syn_) $ t0
+    where
+    bind_ :: forall x xs b
+           . Variable x
+          -> TransformM m (abt xs b)
+          -> TransformM m (abt (x ': xs) b)
+    bind_ v mt = bind v <$> withStateT (ctxOf v <>) mt
+
+    syn_ :: forall b. Term abt b -> TransformM m (abt '[] b)
+    syn_ t =
+      case t of
+        Transform_ tr :$ as ->
+          get >>= \ctx ->
+          maybe (pure $ syn t)
+                (\r -> r <$ put (ctxOf r <> ctx))
+                =<< lift (lookupTransform' tbl tr ctx as)
+        _ -> pure $ syn t
+
+mapleTransformationsWithOpts
+  :: forall abt
+   . ABT Term abt
+  => MapleOptions ()
+  -> TransformTable abt IO
+mapleTransformationsWithOpts opts = TransformTable $ \tr ->
+  let cmd c ctx x =
+        try (sendToMaple opts{command=MapleCommand c
+                             ,context=ctx} x) >>=
+          \case
+            Left (err :: MapleException) ->
+              hPutStrLn stderr (pack $ show err) >> pure Nothing
+            Right r ->
+              pure $ Just r
+      cmd :: Transform '[LC i] o -> TransformCtx
+          -> abt '[] i  -> IO (Maybe (abt '[] o)) in
+  case tr of
+    Simplify       ->
+      Just $ \ctx -> \case { e1 :* End -> cmd tr ctx e1 }
+    Summarize      ->
+      Just $ \ctx -> \case { e1 :* End -> cmd tr ctx e1 }
+    Reparam        ->
+      Just $ \ctx -> \case { e1 :* End -> cmd tr ctx e1 }
+    Disint InMaple ->
+      Just $ \ctx -> \case { e1 :* End -> cmd tr ctx e1 }
+    _              -> Nothing
+
+mapleTransformations
+  :: ABT Term abt
+  => TransformTable abt IO
+mapleTransformations = mapleTransformationsWithOpts defaultMapleOptions
+
+haskellTransformations :: (Applicative m, ABT Term abt) => TransformTable abt m
+haskellTransformations = simpleTable $ \tr ->
+  case tr of
+    Expect ->
+      Just $ \ctx -> \case
+        e1 :* e2 :* End -> determineExpect $ expectInCtx ctx e1 e2
+
+    Observe ->
+      Just $ \ctx -> \case
+        e1 :* e2 :* End -> determine $ observeInCtx ctx e1 e2
+
+    MCMC ->
+      Just $ \ctx -> \case
+        e1 :* e2 :* End -> mcmc' ctx e1 e2
+
+    MH ->
+      Just $ \ctx -> \case
+        e1 :* e2 :* End -> mh' ctx e1 e2
+
+    Disint InHaskell ->
+      Just $ \ctx -> \case
+        e1 :* End -> determine $ disintegrateInCtx ctx e1
+
+    _ -> Nothing
+
+allTransformationsWithMOpts
+   :: ABT Term abt
+   => MapleOptions ()
+   -> TransformTable abt IO
+allTransformationsWithMOpts opts = unionTable
+  (mapleTransformationsWithOpts opts)
+  haskellTransformations
+
+allTransformations :: ABT Term abt => TransformTable abt IO
+allTransformations = allTransformationsWithMOpts defaultMapleOptions
+
+--------------------------------------------------------------------------------
+
+coalesce
+  :: forall abt a
+  .  (ABT Term abt)
+  => abt '[] a
+  -> abt '[] a
+coalesce abt = caseVarSyn abt var onNaryOps
+  where onNaryOps (NaryOp_ t es) = syn $ NaryOp_ t (coalesceNaryOp t es)
+        onNaryOps term           = syn term
+
+coalesceNaryOp
+  :: ABT Term abt
+  => NaryOp a
+  -> S.Seq (abt '[] a)
+  -> S.Seq (abt '[] a)
+coalesceNaryOp typ args =
+  do abt <- args
+     case viewABT abt of
+       Syn (NaryOp_ typ' args') ->
+         if typ == typ'
+         then coalesceNaryOp typ args'
+         else return (coalesce abt)
+       _ -> return abt
diff --git a/haskell/Language/Hakaru/Syntax/CSE.hs b/haskell/Language/Hakaru/Syntax/CSE.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/CSE.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , EmptyCase
+           , ExistentialQuantification
+           , FlexibleContexts
+           , GADTs
+           , GeneralizedNewtypeDeriving
+           , KindSignatures
+           , MultiParamTypeClasses
+           , OverloadedStrings
+           , PolyKinds
+           , ScopedTypeVariables
+           , TypeFamilies
+           , TypeOperators
+           #-}
+
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2017.02.01
+-- |
+-- Module      :  Language.Hakaru.Syntax.CSE
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.CSE (cse) where
+
+import           Control.Monad.Reader
+
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.AST.Eq
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Syntax.TypeOf
+import           Language.Hakaru.Types.DataKind
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative
+#endif
+
+-- What we need is an environment like data structure which maps Terms (or
+-- general abts?) to other abts. Can such a mapping be implemented efficiently?
+-- This would seem to require a hash operation to make efficient.
+
+data EAssoc (abt :: [Hakaru] -> Hakaru -> *)
+  = forall a . EAssoc !(abt '[] a) !(abt '[] a)
+
+-- An association list for now
+newtype Env (abt :: [Hakaru] -> Hakaru -> *) = Env [EAssoc abt]
+
+emptyEnv :: Env a
+emptyEnv = Env []
+
+trivial :: (ABT Term abt) => abt '[] a -> Bool
+trivial abt = case viewABT abt of
+                Var _            -> True
+                Syn (Literal_ _) -> True
+                _                -> False
+
+-- Attempt to find a new expression in the environment. The lookup is chained
+-- to iteratively perform lookup until no match is found, resulting in an
+-- equivalence-relation in the environment. This could be made faster with path
+-- compression and a more efficient lookup structure.
+-- NB: This code could potentially produce an infinite loop depending on how
+-- terms are added to the environment. How do we want to prevent this?
+lookupEnv
+  :: forall abt a . (ABT Term abt)
+  => abt '[] a
+  -> Env abt
+  -> abt '[] a
+lookupEnv start (Env env) = go start env
+  where
+    go :: abt '[] a -> [EAssoc abt] -> abt '[] a
+    go ast []                = ast
+    go ast (EAssoc a b : xs) =
+      case jmEq1 (typeOf ast) (typeOf a) of
+        Just Refl | alphaEq ast a -> go b env
+        _         -> go ast xs
+
+insertEnv
+  :: forall abt a . (ABT Term abt)
+  => abt '[] a
+  -> abt '[] a
+  -> Env abt
+  -> Env abt
+insertEnv ast1 ast2 (Env env)
+  -- Point new variables to the older ones, this does not affect the amount of
+  -- work done, since ast2 is always a variable. This allows the pass to
+  -- eliminate redundant variables, as we only eliminate binders during CSE.
+  | trivial ast1 = Env (EAssoc ast2 ast1 : env)
+  -- Otherwise map expressions to their binding variables
+  | otherwise    = Env (EAssoc ast1 ast2 : env)
+
+newtype CSE (abt :: [Hakaru] -> Hakaru -> *) a = CSE { runCSE :: Reader (Env abt) a }
+  deriving (Functor, Applicative, Monad, MonadReader (Env abt))
+
+replaceCSE
+  :: (ABT Term abt)
+  => abt '[] a
+  -> CSE abt (abt '[] a)
+replaceCSE abt = lookupEnv abt `fmap` ask
+
+cse :: forall abt a . (ABT Term abt) => abt '[] a -> abt '[] a
+cse abt = runReader (runCSE (cse' abt)) emptyEnv
+
+cse' :: forall abt xs a . (ABT Term abt) => abt xs a -> CSE abt (abt xs a)
+cse' = loop . viewABT
+  where
+    loop :: View (Term abt) ys a ->  CSE abt (abt ys a)
+    loop (Var v)    = cseVar v
+    loop (Syn s)    = cseTerm s
+    loop (Bind v b) = fmap (bind v) (loop b)
+
+-- Variables can be equivalent to other variables
+-- TODO: A good sanity check would be to ensure the result in this case is
+-- always a variable or constant. A variable should never be substituted for
+-- a more complex expression.
+cseVar
+  :: (ABT Term abt)
+  => Variable a
+  -> CSE abt (abt '[] a)
+cseVar = replaceCSE  . var
+
+mklet :: ABT Term abt => Variable b -> abt '[] b -> abt '[] a -> abt '[] a
+mklet v rhs body = syn (Let_ :$ rhs :* bind v body :* End)
+
+-- Thanks to A-normalization, the only case we need to care about is let bindings.
+-- Everything else is just structural recursion.
+cseTerm
+  :: (ABT Term abt)
+  => Term abt a
+  -> CSE abt (abt '[] a)
+
+cseTerm (Let_ :$ rhs :* body :* End) = do
+  rhs' <- cse' rhs
+  caseBind body $ \v body' ->
+    local (insertEnv rhs' (var v)) $
+      if trivial rhs'
+      then cse' body'
+      else fmap (mklet v rhs') (cse' body')
+
+cseTerm term = traverse21 cse' term >>= replaceCSE . syn
+
diff --git a/haskell/Language/Hakaru/Syntax/Datum.hs b/haskell/Language/Hakaru/Syntax/Datum.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Datum.hs
@@ -0,0 +1,795 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , PolyKinds
+           , GADTs
+           , TypeOperators
+           , TypeFamilies
+           , ExistentialQuantification
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.24
+-- |
+-- Module      :  Language.Hakaru.Syntax.Datum
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Haskell types and helpers for Hakaru's user-defined data types.
+-- At present we only support regular-recursive polynomial data
+-- types. Reduction of case analysis on data types is in
+-- "Language.Hakaru.Syntax.Datum".
+--
+-- /Developers note:/ many of the 'JmEq1' instances in this file
+-- don't actually work because of problems with matching existentially
+-- quantified types in the basis cases. For now I've left the
+-- partially-defined code in place, but turned it off with the
+-- @__PARTIAL_DATUM_JMEQ__@ CPP macro. In the future we should
+-- either (a) remove this unused code, or (b) if the instances are
+-- truly necessary then we should add the 'Sing' arguments everywhere
+-- to make things work :(
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.Datum
+    (
+    -- * Data constructors
+      Datum(..), datumHint, datumType
+    , DatumCode(..)
+    , DatumStruct(..)
+    , DatumFun(..)
+    -- ** Some smart constructors for the \"built-in\" datatypes
+    , dTrue, dFalse, dBool
+    , dUnit
+    , dPair
+    , dLeft, dRight
+    , dNil, dCons
+    , dNothing, dJust
+    -- *** Variants which allow explicit type passing.
+    , dPair_
+    , dLeft_, dRight_
+    , dNil_, dCons_
+    , dNothing_, dJust_
+
+    -- * Pattern constructors
+    , Branch(..)
+    , Pattern(..)
+    , PDatumCode(..)
+    , PDatumStruct(..)
+    , PDatumFun(..)
+    -- ** Some smart constructors for the \"built-in\" datatypes
+    , pTrue, pFalse
+    , pUnit
+    , pPair
+    , pLeft, pRight
+    , pNil, pCons
+    , pNothing, pJust
+    -- ** Generalized branches
+    , GBranch(..)
+    ) where
+
+import qualified Data.Text     as Text
+import           Data.Text     (Text)
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid             (Monoid(..))
+import Control.Applicative
+#endif
+import qualified Data.Foldable    as F
+import qualified Data.Traversable as T
+
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Syntax.Variable (Variable(..))
+-- TODO: make things polykinded so we can make our ABT implementation
+-- independent of Hakaru's type system.
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+#if __PARTIAL_DATUM_JMEQ__
+cannotProve :: String -> a
+cannotProve fun =
+    error $ "Language.Hakaru.Syntax.Datum." ++ fun ++ ": Cannot prove Refl because of phantomness"
+#endif
+
+
+-- TODO: change the kind to @(Hakaru -> *) -> HakaruCon -> *@ so
+-- we can avoid the use of GADTs? Would that allow us to actually
+-- UNPACK?
+--
+-- | A fully saturated data constructor, which recurses as @ast@.
+-- We define this type as separate from 'DatumCode' for two reasons.
+-- First is to capture the fact that the datum is \"complete\"
+-- (i.e., is a well-formed constructor). The second is to have a
+-- type which is indexed by its 'Hakaru' type, whereas 'DatumCode'
+-- involves non-Hakaru types.
+--
+-- The first component is a hint for what the data constructor
+-- should be called when pretty-printing, giving error messages,
+-- etc. Like the hints for variable names, its value is not actually
+-- used to decide which constructor is meant or which pattern
+-- matches.
+data Datum :: (Hakaru -> *) -> Hakaru -> * where
+    Datum
+        :: {-# UNPACK #-} !Text
+        -> !(Sing (HData' t))
+        -> !(DatumCode (Code t) ast (HData' t))
+        -> Datum ast (HData' t)
+
+datumHint :: Datum ast (HData' t) -> Text
+datumHint (Datum hint _ _) = hint
+
+datumType :: Datum ast (HData' t) -> Sing (HData' t)
+datumType (Datum _ typ _) = typ
+
+-- N.B., This doesn't require jmEq on 'DatumCode' nor on @ast@. The
+-- jmEq on the singleton is sufficient.
+instance Eq1 ast => JmEq1 (Datum ast) where
+    jmEq1 (Datum _ typ1 d1) (Datum _ typ2 d2) =
+        case jmEq1 typ1 typ2 of
+        Just proof@Refl
+            | eq1 d1 d2 -> Just proof
+        _               -> Nothing
+
+instance Eq1 ast => Eq1 (Datum ast) where
+    eq1 (Datum _ _ d1) (Datum _ _ d2) = eq1 d1 d2
+
+instance Eq1 ast => Eq (Datum ast a) where
+    (==) = eq1
+
+-- TODO: instance Read (Datum ast a)
+
+instance Show1 ast => Show1 (Datum ast) where
+    showsPrec1 p (Datum hint typ d) =
+        showParen_011 p "Datum" hint typ d
+
+instance Show1 ast => Show (Datum ast a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance Functor11 Datum where
+    fmap11 f (Datum hint typ d) = Datum hint typ (fmap11 f d)
+
+instance Foldable11 Datum where
+    foldMap11 f (Datum _ _ d) = foldMap11 f d
+
+instance Traversable11 Datum where
+    traverse11 f (Datum hint typ d) = Datum hint typ <$> traverse11 f d
+
+
+----------------------------------------------------------------
+infixr 7 `Et`, `PEt`
+
+-- | The intermediate components of a data constructor. The intuition
+-- behind the two indices is that the @[[HakaruFun]]@ is a functor
+-- applied to the Hakaru type. Initially the @[[HakaruFun]]@ functor
+-- will be the 'Code' associated with the Hakaru type; hence it's
+-- the one-step unrolling of the fixed point for our recursive
+-- datatypes. But as we go along, we'll be doing induction on the
+-- @[[HakaruFun]]@ functor.
+data DatumCode :: [[HakaruFun]] -> (Hakaru -> *) -> Hakaru -> * where
+    -- BUG: haddock doesn't like annotations on GADT constructors
+    -- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+    -- Skip rightwards along the sum.
+    Inr :: !(DatumCode  xss abt a) -> DatumCode (xs ': xss) abt a
+    -- Inject into the sum.
+    Inl :: !(DatumStruct xs abt a) -> DatumCode (xs ': xss) abt a
+
+
+-- N.B., these \"Foo1\" instances rely on polymorphic recursion,
+-- since the @code@ changes at each constructor. However, we don't
+-- actually need to abstract over @code@ in order to define these
+-- functions, because (1) we never existentially close over any
+-- codes, and (2) the code is always getting smaller; so we have
+-- a good enough inductive hypothesis from polymorphism alone.
+
+#if __PARTIAL_DATUM_JMEQ__
+-- This instance works, but recurses into non-working instances.
+instance JmEq1 ast => JmEq1 (DatumCode xss ast) where
+    jmEq1 (Inr c) (Inr d) = jmEq1 c d
+    jmEq1 (Inl c) (Inl d) = jmEq1 c d
+    jmEq1 _       _       = Nothing
+#endif
+
+instance Eq1 ast => Eq1 (DatumCode xss ast) where
+    eq1 (Inr c) (Inr d) = eq1 c d
+    eq1 (Inl c) (Inl d) = eq1 c d
+    eq1 _       _       = False
+
+instance Eq1 ast => Eq (DatumCode xss ast a) where
+    (==) = eq1
+
+-- TODO: instance Read (DatumCode xss abt a)
+
+instance Show1 ast => Show1 (DatumCode xss ast) where
+    showsPrec1 p (Inr d) = showParen_1 p "Inr" d
+    showsPrec1 p (Inl d) = showParen_1 p "Inl" d
+
+instance Show1 ast => Show (DatumCode xss ast a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance Functor11 (DatumCode xss) where
+    fmap11 f (Inr d) = Inr (fmap11 f d)
+    fmap11 f (Inl d) = Inl (fmap11 f d)
+
+instance Foldable11 (DatumCode xss) where
+    foldMap11 f (Inr d) = foldMap11 f d
+    foldMap11 f (Inl d) = foldMap11 f d
+
+instance Traversable11 (DatumCode xss) where
+    traverse11 f (Inr d) = Inr <$> traverse11 f d
+    traverse11 f (Inl d) = Inl <$> traverse11 f d
+
+
+----------------------------------------------------------------
+data DatumStruct :: [HakaruFun] -> (Hakaru -> *) -> Hakaru -> * where
+    -- BUG: haddock doesn't like annotations on GADT constructors
+    -- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+    -- Combine components of the product. (\"et\" means \"and\" in Latin)
+    Et  :: !(DatumFun    x         abt a)
+        -> !(DatumStruct xs        abt a)
+        ->   DatumStruct (x ': xs) abt a
+
+    -- Close off the product.
+    Done :: DatumStruct '[] abt a
+
+
+#if __PARTIAL_DATUM_JMEQ__
+instance JmEq1 ast => JmEq1 (DatumStruct xs ast) where
+    jmEq1 (Et c1 Done) (Et d1 Done) = jmEq1 c1 d1 -- HACK: to handle 'Done' in the cases where we can.
+    jmEq1 (Et c1 c2)   (Et d1 d2)   = do
+        Refl <- jmEq1 c1 d1
+        Refl <- jmEq1 c2 d2
+        Just Refl
+    jmEq1 Done Done = Just (cannotProve "jmEq1@DatumStruct{Done}")
+    jmEq1 _    _    = Nothing
+#endif
+
+instance Eq1 ast => Eq1 (DatumStruct xs ast) where
+    eq1 (Et c1 c2) (Et d1 d2) = eq1 c1 d1 && eq1 c2 d2
+    eq1 Done       Done       = True
+
+instance Eq1 ast => Eq (DatumStruct xs ast a) where
+    (==) = eq1
+
+-- TODO: instance Read (DatumStruct xs abt a)
+
+instance Show1 ast => Show1 (DatumStruct xs ast) where
+    showsPrec1 p (Et d1 d2) = showParen_11 p "Et" d1 d2
+    showsPrec1 _ Done       = showString     "Done"
+
+instance Show1 ast => Show (DatumStruct xs ast a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance Functor11 (DatumStruct xs) where
+    fmap11 f (Et d1 d2) = Et (fmap11 f d1) (fmap11 f d2)
+    fmap11 _ Done       = Done
+
+instance Foldable11 (DatumStruct xs) where
+    foldMap11 f (Et d1 d2) = foldMap11 f d1 `mappend` foldMap11 f d2
+    foldMap11 _ Done       = mempty
+
+instance Traversable11 (DatumStruct xs) where
+    traverse11 f (Et d1 d2) = Et <$> traverse11 f d1 <*> traverse11 f d2
+    traverse11 _ Done       = pure Done
+
+
+----------------------------------------------------------------
+-- TODO: do we like those constructor names? Should we change them?
+data DatumFun :: HakaruFun -> (Hakaru -> *) -> Hakaru -> * where
+    -- BUG: haddock doesn't like annotations on GADT constructors
+    -- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+    -- Hit a leaf which isn't a recursive component of the datatype.
+    Konst :: !(ast b) -> DatumFun ('K b) ast a
+    -- Hit a leaf which is a recursive component of the datatype.
+    Ident :: !(ast a) -> DatumFun 'I     ast a
+
+
+#if __PARTIAL_DATUM_JMEQ__
+instance JmEq1 ast => JmEq1 (DatumFun x ast) where
+    jmEq1 (Konst e) (Konst f) = do
+        Refl <- jmEq1 e f -- This 'Refl' should be free because @x@ is fixed
+        Just (cannotProve "jmEq1@DatumFun{Konst}")
+    jmEq1 (Ident e) (Ident f) = jmEq1 e f
+    jmEq1 _         _         = Nothing
+#endif
+
+instance Eq1 ast => Eq1 (DatumFun x ast) where
+    eq1 (Konst e) (Konst f) = eq1 e f
+    eq1 (Ident e) (Ident f) = eq1 e f
+
+instance Eq1 ast => Eq (DatumFun x ast a) where
+    (==) = eq1
+
+-- TODO: instance Read (DatumFun x abt a)
+
+instance Show1 ast => Show1 (DatumFun x ast) where
+    showsPrec1 p (Konst e) = showParen_1 p "Konst" e
+    showsPrec1 p (Ident e) = showParen_1 p "Ident" e
+
+instance Show1 ast => Show (DatumFun x ast a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance Functor11 (DatumFun x) where
+    fmap11 f (Konst e) = Konst (f e)
+    fmap11 f (Ident e) = Ident (f e)
+
+instance Foldable11 (DatumFun x) where
+    foldMap11 f (Konst e) = f e
+    foldMap11 f (Ident e) = f e
+
+instance Traversable11 (DatumFun x) where
+    traverse11 f (Konst e) = Konst <$> f e
+    traverse11 f (Ident e) = Ident <$> f e
+
+
+----------------------------------------------------------------
+-- In GHC 7.8 we can make the monomorphic smart constructors into
+-- pattern synonyms, but 7.8 can't handle anything polymorphic (but
+-- GHC 7.10 can). For libraries (e.g., "Language.Hakaru.Syntax.Prelude")
+-- we can use functions to construct our Case_ statements, so library
+-- designers don't need pattern synonyms. Whereas, for the internal
+-- aspects of the compiler, we need to handle all possible Datum
+-- values, so the pattern synonyms wouldn't even be helpful.
+
+dTrue, dFalse :: Datum ast HBool
+dTrue  = Datum tdTrue  sBool . Inl $ Done
+dFalse = Datum tdFalse sBool . Inr . Inl $ Done
+
+dBool :: Bool -> Datum ast HBool
+dBool b = if b then dTrue else dFalse
+
+dUnit  :: Datum ast HUnit
+dUnit  = Datum tdUnit sUnit . Inl $ Done
+
+dPair :: (SingI a, SingI b) => ast a -> ast b -> Datum ast (HPair a b)
+dPair = dPair_ sing sing
+
+dPair_ :: Sing a -> Sing b -> ast a -> ast b -> Datum ast (HPair a b)
+dPair_ a b x y =
+    Datum tdPair (sPair a b) . Inl $ Konst x `Et` Konst y `Et` Done
+
+dLeft :: (SingI a, SingI b) => ast a -> Datum ast (HEither a b)
+dLeft = dLeft_ sing sing
+
+dLeft_ :: Sing a -> Sing b -> ast a -> Datum ast (HEither a b)
+dLeft_ a b =
+    Datum tdLeft (sEither a b) . Inl . (`Et` Done) . Konst
+
+dRight :: (SingI a, SingI b) => ast b -> Datum ast (HEither a b)
+dRight = dRight_ sing sing
+
+dRight_ :: Sing a -> Sing b -> ast b -> Datum ast (HEither a b)
+dRight_ a b =
+    Datum tdRight (sEither a b) . Inr . Inl . (`Et` Done) . Konst
+
+dNil :: (SingI a) => Datum ast (HList a)
+dNil = dNil_ sing
+
+dNil_ :: Sing a -> Datum ast (HList a)
+dNil_ a = Datum tdNil (sList a) . Inl $ Done
+
+dCons :: (SingI a) => ast a -> ast (HList a) -> Datum ast (HList a)
+dCons = dCons_ sing
+
+dCons_ :: Sing a -> ast a -> ast (HList a) -> Datum ast (HList a)
+dCons_ a x xs =
+    Datum tdCons (sList a) . Inr . Inl $ Konst x `Et` Ident xs `Et` Done
+
+dNothing :: (SingI a) => Datum ast (HMaybe a)
+dNothing = dNothing_ sing
+
+dNothing_ :: Sing a -> Datum ast (HMaybe a)
+dNothing_ a = Datum tdNothing (sMaybe a) $ Inl Done
+
+dJust :: (SingI a) => ast a -> Datum ast (HMaybe a)
+dJust = dJust_ sing
+
+dJust_ :: Sing a -> ast a -> Datum ast (HMaybe a)
+dJust_ a = Datum tdJust (sMaybe a)  . Inr . Inl . (`Et` Done) . Konst
+
+
+----------------------------------------------------------------
+tdTrue, tdFalse, tdUnit, tdPair, tdLeft, tdRight, tdNil, tdCons, tdNothing, tdJust :: Text
+tdTrue    = Text.pack "true"
+tdFalse   = Text.pack "false"
+tdUnit    = Text.pack "unit"
+tdPair    = Text.pack "pair"
+tdLeft    = Text.pack "left"
+tdRight   = Text.pack "right"
+tdNil     = Text.pack "nil"
+tdCons    = Text.pack "cons"
+tdNothing = Text.pack "nothing"
+tdJust    = Text.pack "just"
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: negative patterns? (to facilitate reordering of case branches)
+-- TODO: disjunctive patterns, a~la ML?
+-- TODO: equality patterns for Nat\/Int? (what about Prob\/Real??)
+-- TODO: exhaustiveness, non-overlap, dead-branch checking
+--
+-- | We index patterns by the type they scrutinize. This requires
+-- the parser to be smart enough to build these patterns up, but
+-- then it guarantees that we can't have 'Case_' of patterns which
+-- can't possibly match according to our type system. In addition,
+-- we also index patterns by the type of what variables they bind,
+-- so that we can ensure that 'Branch' will never \"go wrong\".
+-- Alas, this latter indexing means we can't use 'DatumCode',
+-- 'DatumStruct', and 'DatumFun' but rather must define our own @P@
+-- variants for pattern matching.
+data Pattern :: [Hakaru] -> Hakaru -> * where
+    -- BUG: haddock doesn't like annotations on GADT constructors
+    -- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+    -- The \"don't care\" wildcard pattern.
+    PWild :: Pattern '[]    a
+
+    -- A pattern variable.
+    PVar  :: Pattern '[ a ] a
+
+    -- A data type constructor pattern. As with the 'Datum'
+    -- constructor, the first component is a hint.
+    PDatum
+        :: {-# UNPACK #-} !Text
+        -> !(PDatumCode (Code t) vars (HData' t))
+        -> Pattern vars (HData' t)
+
+
+#if __PARTIAL_DATUM_JMEQ__
+instance JmEq2 Pattern where
+    jmEq2 PWild PWild = Just (Refl, cannotProve "jmEq2@Pattern{PWild}")
+    jmEq2 PVar  PVar  = Just (cannotProve "jmEq2@Pattern{PVar}", cannotProve "jmEq2@Pattern{PVar}")
+    jmEq2 (PDatum _ d1) (PDatum _ d2) =
+        jmEq2_fake d1 d2
+        where
+        jmEq2_fake
+            :: PDatumCode xss  vars1 a1
+            -> PDatumCode xss' vars2 a2
+            -> Maybe (TypeEq vars1 vars2, TypeEq a1 a2)
+        jmEq2_fake =
+            error "jmEq2@Pattern{PDatum}: can't recurse because Code isn't injective" -- so @xss@ and @xss'@ aren't guaranteed to be the same
+    jmEq2 _ _ = Nothing
+
+instance JmEq1 (Pattern vars) where
+    jmEq1 p1 p2 = jmEq2 p1 p2 >>= \(_,proof) -> Just proof
+#endif
+
+instance Eq2 Pattern where
+    eq2 PWild         PWild         = True
+    eq2 PVar          PVar          = True
+    eq2 (PDatum _ d1) (PDatum _ d2) = eq2 d1 d2
+    eq2 _           _               = False
+
+instance Eq1 (Pattern vars) where
+    eq1 = eq2
+
+instance Eq (Pattern vars a) where
+    (==) = eq1
+
+-- TODO: instance Read (Pattern vars a)
+
+instance Show2 Pattern where
+    showsPrec2 _ PWild           = showString     "PWild"
+    showsPrec2 _ PVar            = showString     "PVar"
+    showsPrec2 p (PDatum hint d) = showParen_02 p "PDatum" hint d
+
+instance Show1 (Pattern vars) where
+    showsPrec1 = showsPrec2
+    show1      = show2
+
+instance Show (Pattern vars a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+-- TODO: as necessary Functor22, Foldable22, Traversable22
+
+
+----------------------------------------------------------------
+data PDatumCode :: [[HakaruFun]] -> [Hakaru] -> Hakaru -> * where
+    PInr :: !(PDatumCode  xss vars a) -> PDatumCode (xs ': xss) vars a
+    PInl :: !(PDatumStruct xs vars a) -> PDatumCode (xs ': xss) vars a
+
+
+#if __PARTIAL_DATUM_JMEQ__
+instance JmEq2 (PDatumCode xss) where
+    jmEq2 (PInr c) (PInr d) = jmEq2 c d
+    jmEq2 (PInl c) (PInl d) = jmEq2 c d
+    jmEq2 _        _        = Nothing
+
+-- This instance works, but recurses into non-working instances.
+instance JmEq1 (PDatumCode xss vars) where
+    jmEq1 (PInr c) (PInr d) = jmEq1 c d
+    jmEq1 (PInl c) (PInl d) = jmEq1 c d
+    jmEq1 _        _        = Nothing
+#endif
+
+instance Eq2 (PDatumCode xss) where
+    eq2 (PInr c) (PInr d) = eq2 c d
+    eq2 (PInl c) (PInl d) = eq2 c d
+    eq2 _        _        = False
+
+instance Eq1 (PDatumCode xss vars) where
+    eq1 = eq2
+
+instance Eq (PDatumCode xss vars a) where
+    (==) = eq1
+
+-- TODO: instance Read (PDatumCode xss vars a)
+
+instance Show2 (PDatumCode xss) where
+    showsPrec2 p (PInr d) = showParen_2 p "PInr" d
+    showsPrec2 p (PInl d) = showParen_2 p "PInl" d
+
+instance Show1 (PDatumCode xss vars) where
+    showsPrec1 = showsPrec2
+    show1      = show2
+
+instance Show (PDatumCode xss vars a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+-- TODO: as necessary Functor22, Foldable22, Traversable22
+
+----------------------------------------------------------------
+data PDatumStruct :: [HakaruFun] -> [Hakaru] -> Hakaru -> * where
+    PEt :: !(PDatumFun    x         vars1 a)
+        -> !(PDatumStruct xs        vars2 a)
+        ->   PDatumStruct (x ': xs) (vars1 ++ vars2) a
+
+    PDone :: PDatumStruct '[] '[] a
+
+
+-- This block of recursive functions are analogous to 'JmEq2' except
+-- we only return the equality proof for the penultimate index
+-- rather than both the penultimate and ultimate index. (Because
+-- we /can/ return proofs for the penultimate index, but not for
+-- the ultimate.) This is necessary for defining the @Eq1 (PDatumStruct
+-- xs vars)@ and @Eq1 (Branch a abt)@ instances, since we need to
+-- make sure the existential @vars@ match up.
+
+-- N.B., that we can use 'Refl' in the 'PVar' case relies on the
+-- fact that the @a@ parameter is fixed to be the same in both
+-- patterns.
+jmEq_P :: Pattern vs a -> Pattern ws a -> Maybe (TypeEq vs ws)
+jmEq_P PWild         PWild         = Just Refl
+jmEq_P PVar          PVar          = Just Refl
+jmEq_P (PDatum _ p1) (PDatum _ p2) = jmEq_PCode p1 p2
+jmEq_P _             _             = Nothing
+
+jmEq_PCode
+    :: PDatumCode xss vs a
+    -> PDatumCode xss ws a
+    -> Maybe (TypeEq vs ws)
+jmEq_PCode (PInr p1) (PInr p2) = jmEq_PCode   p1 p2
+jmEq_PCode (PInl p1) (PInl p2) = jmEq_PStruct p1 p2
+jmEq_PCode _         _         = Nothing
+
+jmEq_PStruct
+    :: PDatumStruct xs vs a
+    -> PDatumStruct xs ws a
+    -> Maybe (TypeEq vs ws)
+jmEq_PStruct (PEt c1 c2) (PEt d1 d2) = do
+    Refl <- jmEq_PFun    c1 d1
+    Refl <- jmEq_PStruct c2 d2
+    Just Refl
+jmEq_PStruct PDone PDone = Just Refl
+
+jmEq_PFun :: PDatumFun f vs a -> PDatumFun f ws a -> Maybe (TypeEq vs ws)
+jmEq_PFun (PKonst p1) (PKonst p2) = jmEq_P p1 p2
+jmEq_PFun (PIdent p1) (PIdent p2) = jmEq_P p1 p2
+
+
+#if __PARTIAL_DATUM_JMEQ__
+instance JmEq2 (PDatumStruct xs) where
+    jmEq2 (PEt c1 c2) (PEt d1 d2) = do
+        (Refl, Refl) <- jmEq2 c1 d1
+        (Refl, Refl) <- jmEq2 c2 d2
+        Just (Refl, Refl)
+    jmEq2 PDone PDone = Just (Refl, cannotProve "jmEq2@PDatumStruct{PDone}")
+    jmEq2 _     _     = Nothing
+
+instance JmEq1 (PDatumStruct xs vars) where
+    jmEq1 p1 p2 = jmEq2 p1 p2 >>= \(_,proof) -> Just proof
+#endif
+
+instance Eq2 (PDatumStruct xs) where
+    eq2 p1 p2 = maybe False (const True) $ jmEq_PStruct p1 p2
+
+instance Eq1 (PDatumStruct xs vars) where
+    eq1 = eq2
+
+instance Eq (PDatumStruct xs vars a) where
+    (==) = eq1
+
+-- TODO: instance Read (PDatumStruct xs vars a)
+
+instance Show2 (PDatumStruct xs) where
+    showsPrec2 p (PEt d1 d2) = showParen_22 p "PEt" d1 d2
+    showsPrec2 _ PDone       = showString     "PDone"
+
+instance Show1 (PDatumStruct xs vars) where
+    showsPrec1 = showsPrec2
+    show1      = show2
+
+instance Show (PDatumStruct xs vars a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+-- TODO: as necessary Functor22, Foldable22, Traversable22
+
+
+----------------------------------------------------------------
+data PDatumFun :: HakaruFun -> [Hakaru] -> Hakaru -> * where
+    PKonst :: !(Pattern vars b) -> PDatumFun ('K b) vars a
+    PIdent :: !(Pattern vars a) -> PDatumFun 'I     vars a
+
+
+#if __PARTIAL_DATUM_JMEQ__
+instance JmEq2 (PDatumFun x) where
+    jmEq2 (PKonst p1) (PKonst p2) = do
+        (Refl, Refl) <- jmEq2 p1 p2
+        Just (Refl, cannotProve "jmEq2@PDatumFun{PKonst}")
+    jmEq2 (PIdent p1) (PIdent p2) = jmEq2 p1 p2
+    jmEq2 _ _ = Nothing
+
+instance JmEq1 (PDatumFun x vars) where
+    jmEq1 (PKonst e) (PKonst f) = do
+        Refl <- jmEq1 e f
+        Just (cannotProve "jmEq1@PDatumFun{PKonst}")
+    jmEq1 (PIdent e) (PIdent f) = jmEq1 e f
+    jmEq1 _          _          = Nothing
+#endif
+
+instance Eq2 (PDatumFun x) where
+    eq2 (PKonst e) (PKonst f) = eq2 e f
+    eq2 (PIdent e) (PIdent f) = eq2 e f
+
+instance Eq1 (PDatumFun x vars) where
+    eq1 = eq2
+
+instance Eq (PDatumFun x vars a) where
+    (==) = eq1
+
+-- TODO: instance Read (PDatumFun x vars a)
+
+instance Show2 (PDatumFun x) where
+    showsPrec2 p (PKonst e) = showParen_2 p "PKonst" e
+    showsPrec2 p (PIdent e) = showParen_2 p "PIdent" e
+
+instance Show1 (PDatumFun x vars) where
+    showsPrec1 = showsPrec2
+    show1      = show2
+
+instance Show (PDatumFun x vars a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+-- TODO: as necessary Functor22, Foldable22, Traversable22
+
+
+----------------------------------------------------------------
+pTrue, pFalse :: Pattern '[] HBool
+pTrue  = PDatum tdTrue  . PInl $ PDone
+pFalse = PDatum tdFalse . PInr . PInl $ PDone
+
+pUnit  :: Pattern '[] HUnit
+pUnit  = PDatum tdUnit . PInl $ PDone
+
+-- HACK: using undefined like that isn't going to help if we use
+-- the variant of eqAppendIdentity that actually needs the Sing...
+varsOfPattern :: Pattern vars a -> proxy vars
+varsOfPattern _ = error "TODO: varsOfPattern"
+
+pPair
+    :: Pattern vars1 a
+    -> Pattern vars2 b
+    -> Pattern (vars1 ++ vars2) (HPair a b)
+pPair x y =
+    case eqAppendIdentity (varsOfPattern y) of
+    Refl -> PDatum tdPair . PInl $ PKonst x `PEt` PKonst y `PEt` PDone
+
+pLeft :: Pattern vars a -> Pattern vars (HEither a b)
+pLeft x =
+    case eqAppendIdentity (varsOfPattern x) of
+    Refl -> PDatum tdLeft . PInl $ PKonst x `PEt` PDone
+
+pRight :: Pattern vars b -> Pattern vars (HEither a b)
+pRight y =
+    case eqAppendIdentity (varsOfPattern y) of
+    Refl -> PDatum tdRight . PInr . PInl $ PKonst y `PEt` PDone
+
+pNil :: Pattern '[] (HList a)
+pNil = PDatum tdNil . PInl $ PDone
+
+pCons :: Pattern vars1 a
+    -> Pattern vars2 (HList a)
+    -> Pattern (vars1 ++ vars2) (HList a)
+pCons x xs = 
+    case eqAppendIdentity (varsOfPattern xs) of
+    Refl -> PDatum tdCons . PInr . PInl $ PKonst x `PEt` PIdent xs `PEt` PDone
+
+pNothing :: Pattern '[] (HMaybe a)
+pNothing = PDatum tdNothing . PInl $ PDone
+
+pJust :: Pattern vars a -> Pattern vars (HMaybe a)
+pJust x =
+    case eqAppendIdentity (varsOfPattern x) of
+    Refl -> PDatum tdJust . PInr . PInl $ PKonst x `PEt` PDone
+
+----------------------------------------------------------------
+-- TODO: a pretty infix syntax, like (:=>) or something?
+--
+-- TODO: this datatype is helpful for capturing the existential;
+-- but other than that, it should be replaced\/augmented with a
+-- type for pattern automata, so we can optimize case analysis.
+--
+-- TODO: if we used the argument order @Branch abt a b@ then we
+-- could give @Foo2@ instances instead of just @Foo1@ instances.
+-- Also would possibly let us talk about branches as profunctors
+-- mapping @a@ to @b@. Would either of these actually be helpful
+-- in practice for us?
+data Branch
+    (a   :: Hakaru)                  -- The type of the scrutinee.
+    (abt :: [Hakaru] -> Hakaru -> *) -- The 'ABT' of the body.
+    (b   :: Hakaru)                  -- The type of the body.
+    = forall xs. Branch
+        !(Pattern xs a)
+        !(abt xs b)
+
+instance Eq2 abt => Eq1 (Branch a abt) where
+    eq1 (Branch p1 e1) (Branch p2 e2) =
+        case jmEq_P p1 p2 of
+        Nothing   -> False
+        Just Refl -> eq2 e1 e2
+
+instance Eq2 abt => Eq (Branch a abt b) where
+    (==) = eq1
+
+-- TODO: instance Read (Branch abt a b)
+
+instance Show2 abt => Show1 (Branch a abt) where
+    showsPrec1 p (Branch pat e) = showParen_22 p "Branch" pat e
+
+instance Show2 abt => Show (Branch a abt b) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance Functor21 (Branch a) where
+    fmap21 f (Branch p e) = Branch p (f e)
+
+instance Foldable21 (Branch a) where
+    foldMap21 f (Branch _ e) = f e
+
+instance Traversable21 (Branch a) where
+    traverse21 f (Branch pat e) = Branch pat <$> f e
+
+----------------------------------------------------------------
+-- | A generalization of the 'Branch' type to allow a \"body\" of
+-- any Haskell type.
+data GBranch (a :: Hakaru) (r :: *)
+    = forall xs. GBranch
+        !(Pattern xs a)
+        !(List1 Variable xs)
+        r
+
+instance Functor (GBranch a) where
+    fmap f (GBranch pat vars x) = GBranch pat vars (f x)
+
+instance F.Foldable (GBranch a) where
+    foldMap f (GBranch _ _ x) = f x
+
+instance T.Traversable (GBranch a) where
+    traverse f (GBranch pat vars x) = GBranch pat vars <$> f x
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/DatumABT.hs b/haskell/Language/Hakaru/Syntax/DatumABT.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/DatumABT.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , PolyKinds
+           , GADTs
+           , TypeOperators
+           , TypeFamilies
+           , ExistentialQuantification
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.24
+-- |
+-- Module      :  Language.Hakaru.Syntax.DatumABT
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Stuff that depends on both "Language.Hakaru.Syntax.ABT" and
+-- "Language.Hakaru.Syntax.Datum"; factored out to avoid the cyclic
+-- dependency issues.
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.DatumABT
+    ( fromGBranch
+    , toGBranch
+    ) where
+
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.Datum
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+fromGBranch
+    :: (ABT syn abt)
+    => GBranch a (abt '[] b)
+    -> Branch a abt b
+fromGBranch (GBranch pat vars e) =
+    Branch pat (binds_ vars e)
+
+toGBranch
+    :: (ABT syn abt)
+    => Branch a abt b
+    -> GBranch a (abt '[] b)
+toGBranch (Branch pat body) =
+    uncurry (GBranch pat) (caseBinds body)
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/DatumCase.hs b/haskell/Language/Hakaru/Syntax/DatumCase.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/DatumCase.hs
@@ -0,0 +1,376 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , PolyKinds
+           , GADTs
+           , TypeOperators
+           , TypeFamilies
+           , Rank2Types
+           , ScopedTypeVariables
+           , FlexibleInstances
+           , FlexibleContexts
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.28
+-- |
+-- Module      :  Language.Hakaru.Syntax.DatumCase
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Reduction of case analysis on user-defined data types.
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.DatumCase
+    (
+    -- * External API
+      MatchResult(..)
+    , DatumEvaluator
+    , matchBranches
+    , matchBranch
+
+    -- * Internal API
+    , MatchState(..)
+    , matchTopPattern
+    , matchPattern
+    , viewDatum
+    ) where
+
+import Data.Proxy (Proxy(..))
+import Prelude hiding ((<>))
+
+import Language.Hakaru.Syntax.IClasses
+-- TODO: make things polykinded so we can make our ABT implementation
+-- independend of Hakaru's type system.
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.AST (Term(Datum_))
+import Language.Hakaru.Syntax.ABT
+
+import qualified Data.Text        as Text
+import           Data.Number.Nat  (fromNat)
+import           Text.PrettyPrint (Doc, (<+>), (<>))
+import qualified Text.PrettyPrint as PP
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: would it be better to combine the 'Maybe' for failure into
+-- the MatchResult itself instead of nesting the types? That'd make
+-- the return types for 'matchBranch'\/'matchBranches' a bit trickier;
+-- we'd prolly have to turn MatchResult into a monad (namely the
+-- @Maybe (Either e (Writer (DList...) (Reader (List1...) a)))@
+-- monad, or similar but restricting the Reader to a stream consumer).
+
+-- BUG: haddock doesn't like annotations on GADT constructors. So
+-- here we'll avoid using the GADT syntax, even though it'd make
+-- the data type declaration prettier\/cleaner.
+-- <https://github.com/hakaru-dev/hakaru/issues/6>
+data MatchResult
+    (ast :: Hakaru -> *)
+    (abt :: [Hakaru] -> Hakaru -> *)
+    (a   :: Hakaru)
+
+    -- | Our 'DatumEvaluator' failed (perhaps in a nested pattern),
+    -- thus preventing us from continuing case-reduction.
+    = GotStuck
+
+    -- | We successfully matched everything. The first argument
+    -- gives the substitution for all the pattern variables. The
+    -- second argument gives the body of the branch matched. N.B.,
+    -- the substitution maps variables to some type @ast@ which is
+    -- defined by the 'DatumEvaluator' used; it is not necessarily
+    -- @abt '[]@! However, the body is definitely @abt '[]@ since
+    -- thats what a 'Branch' stores after we account for the
+    -- pattern-bound variables.
+    --
+    -- N.B., because the substitution may not have the right type
+    -- (and because we are lazy), we do not perform substitution.
+    -- Thus, the body has \"free\" variables which are defined\/bound
+    -- in the association list. It's up to callers to perform the
+    -- substitution, push the assocs onto the heap, or whatever.
+    | Matched !(Assocs ast) !(abt '[] a)
+
+
+instance (Show1 ast, Show2 abt) => Show1 (MatchResult ast abt) where
+    showsPrec1 _ GotStuck           = showString "GotStuck"
+    showsPrec1 p (Matched rho body) =
+        showParen (p > 9)
+            ( showString "Matched "
+            . showsPrec  11 rho
+            . showString " "
+            . showsPrec2 11 body
+            )
+
+instance (Show1 ast, Show2 abt) => Show (MatchResult ast abt a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+
+-- | A function for trying to extract a 'Datum' from an arbitrary
+-- term. This function is called every time we enter the 'matchPattern'
+-- function. If this function returns 'Nothing' then the final
+-- 'MatchResult' will be 'GotStuck'; otherwise, this function returns
+-- 'Just' some 'Datum' that we can take apart to continue matching.
+--
+-- We don't care anything about the monad @m@, we just order the
+-- effects in a top-down left-to-right manner as we traverse the
+-- pattern. However, do note that we may end up calling this evaluator
+-- repeatedly on the same argument, so it should be sufficiently
+-- idempotent to work under those conditions. In particular,
+-- 'matchBranches' will call it once on the top-level scrutinee for
+-- each branch. (We should fix that, but it'll require using pattern
+-- automata rather than a list of patterns\/branches.)
+--
+-- TODO: we could change this from returning 'Maybe' to returning
+-- 'Either', that way the evaluator could give some reason for its
+-- failure (we would store it in the 'GotStuck' constructor).
+type DatumEvaluator ast m =
+    forall t
+    .  ast (HData' t)
+    -> m (Maybe (Datum ast (HData' t)))
+
+
+-- TODO: see the todo for 'matchBranch' about changing the return
+-- type. For this function we'd want to return the list of branches
+-- including not just the stuck one but all the ones after it too.
+-- (Though there's no need to return earlier branches, since we
+-- already know they won't match.)
+--
+-- | Walk through a list of branches and try matching against them
+-- in order. We just call 'matchBranches' repeatedly, and return
+-- the first non-failure.
+matchBranches
+    :: (ABT Term abt, Monad m)
+    => DatumEvaluator ast m
+    -> ast a
+    -> [Branch a abt b]
+    -> m (Maybe (MatchResult ast abt b))
+matchBranches getDatum e = go
+    where
+    -- TODO: isn't there a combinator in "Control.Monad" for this?
+    -- TODO: lift the call to 'getDatum' out here, to avoid duplicating work
+    go []     = return Nothing
+    go (b:bs) = do
+        match <- matchBranch getDatum e b
+        case match of
+            Nothing -> go bs
+            Just _  -> return match
+
+
+-- TODO: change the result type to have values @Nothing@, @Just
+-- (GotStuck modifiedScrutinee theStuckBranch)@ and @Just (Matched
+-- assocs body)@. That is, give more information about getting
+-- stuck, and avoid returning stupid stuff when we get stuck.
+--
+-- | Try matching against a single branch. This function is a thin
+-- wrapper around 'matchTopPattern'; we just take apart the 'Branch'
+-- to extract the pattern, list of variables to bind, and the body
+-- of the branch.
+matchBranch
+    :: (ABT Term abt, Monad m)
+    => DatumEvaluator ast m
+    -> ast a
+    -> Branch a abt b
+    -> m (Maybe (MatchResult ast abt b))
+matchBranch getDatum e (Branch pat body) = do
+    let (vars,body') = caseBinds body
+    match <- matchTopPattern getDatum e pat vars
+    return $
+        case match of
+        Nothing                  -> Nothing
+        Just GotStuck_           -> Just GotStuck
+        Just (Matched_ rho Nil1) ->
+            Just (Matched (toAssocs $ rho []) body')
+
+
+----------------------------------------------------------------
+type DList a = [a] -> [a]
+
+-- | The internal version of 'MatchResult' for giving us the properly
+-- generalized inductive hypothesis.
+data MatchState
+    (ast  :: Hakaru -> *)
+    (vars :: [Hakaru])
+
+    -- | Our 'DatumEvaluator' failed (perhaps in a nested pattern),
+    -- thus preventing us from continuing case-reduction.
+    = GotStuck_
+
+    -- TODO: we used to use @DList1 (Pair1 Variable (abt '[]))
+    -- vars1@ for the first argument, with @vars1@ another parameter
+    -- to the type; this would be helpful internally for guaranteeing
+    -- that we return the right number and types of bindings.
+    -- However, because the user-facing 'matchBranch' uses 'Branch'
+    -- which existentializes over @vars1@, we'd need our user-facing
+    -- 'MatchResult' type to also existentialize over @vars1@. Also,
+    -- actually keeping track of @vars1@ makes the 'matchStruct'
+    -- function much more difficult to get to typecheck. But,
+    -- supposing we get that working, would the added guarantees
+    -- of this more specific type be helpful for anyone else?
+    --
+    -- | We successfully matched everything (so far). The first
+    -- argument gives the bindings for all the pattern variables
+    -- we've already checked. The second argument gives the pattern
+    -- variables remaining to be bound by checking the rest of the
+    -- pattern.
+    | Matched_
+        (DList (Assoc ast))
+        (List1 Variable vars)
+
+
+instance Show1 ast => Show (MatchState ast vars) where
+    showsPrec p = shows . ppMatchState p
+
+ppMatchState :: Show1 ast => Int -> MatchState ast vars -> Doc
+ppMatchState _ GotStuck_ = PP.text "GotStuck_"
+ppMatchState p (Matched_ boundVars unboundVars) =
+    let f = "Matched_" in
+    parens (p > 9)
+        (PP.text f <+> PP.nest (1 + length f) (PP.sep
+            [ ppList . map prettyPrecAssoc $ boundVars []
+            , ppList $ ppVariables unboundVars
+            ]))
+    where
+    ppList       = PP.brackets . PP.nest 1 . PP.fsep . PP.punctuate PP.comma
+    parens True  = PP.parens   . PP.nest 1
+    parens False = id
+
+    prettyPrecAssoc :: Show1 ast => Assoc ast -> Doc
+    prettyPrecAssoc (Assoc x e) =
+        -- PP.cat $ ppFun 11 "Assoc" [ppVariable x, ...]
+        let f = "Assoc" in
+        PP.cat [PP.text f <+> PP.nest (1 + length f) (PP.sep
+            [ ppVariable x
+            , PP.text $ showsPrec1 11 e ""
+            ])]
+
+    ppVariables :: List1 Variable xs -> [Doc]
+    ppVariables Nil1         = []
+    ppVariables (Cons1 x xs) = ppVariable x : ppVariables xs
+
+    ppVariable :: Variable a -> Doc
+    ppVariable x = hint <> (PP.int . fromNat . varID) x
+        where
+        hint
+            | Text.null (varHint x) = PP.char 'x' -- We used to use '_' but...
+            | otherwise             = (PP.text . Text.unpack . varHint) x
+
+
+-- | Try matching against a (top-level) pattern. This function is
+-- a thin wrapper around 'matchPattern' in order to restrict the
+-- type.
+matchTopPattern
+    :: (Monad m)
+    => DatumEvaluator ast m
+    -> ast a
+    -> Pattern vars a
+    -> List1 Variable vars
+    -> m (Maybe (MatchState ast '[]))
+matchTopPattern getDatum e pat vars =
+    case eqAppendIdentity (secondProxy pat) of
+    Refl -> matchPattern getDatum e pat vars
+
+secondProxy :: f i j -> Proxy i
+secondProxy _ = Proxy
+
+
+-- | A trivial \"evaluation function\". If the term is already a
+-- 'Datum_', then we extract the 'Datum' value; otherwise we fail.
+-- You can 'return' the result to turn this into an 'DatumEvaluator'.
+viewDatum
+    :: (ABT Term abt)
+    => abt '[] (HData' t)
+    -> Maybe (Datum (abt '[]) (HData' t))
+viewDatum e =
+    caseVarSyn e (const Nothing) $ \t ->
+        case t of
+        Datum_ d -> Just d
+        _        -> Nothing
+
+
+-- | Try matching against a (potentially nested) pattern. This
+-- function generalizes 'matchTopPattern', which is necessary for
+-- being able to handle nested patterns correctly. You probably
+-- don't ever need to call this function.
+matchPattern
+    :: (Monad m)
+    => DatumEvaluator ast m
+    -> ast a
+    -> Pattern vars1 a
+    -> List1 Variable (vars1 ++ vars2)
+    -> m (Maybe (MatchState ast vars2))
+matchPattern getDatum e pat vars =
+    case pat of
+    PWild              -> return . Just $ Matched_ id vars
+    PVar               ->
+        case vars of
+        Cons1 x vars'  -> return . Just $ Matched_ (Assoc x e :) vars'
+    PDatum _hint1 pat1 -> do
+        mb <- getDatum e
+        case mb of
+            Nothing                     -> return $ Just GotStuck_
+            Just (Datum _hint2 _typ2 d) -> matchCode getDatum d pat1 vars
+
+
+matchCode
+    :: (Monad m)
+    => DatumEvaluator ast m
+    -> DatumCode  xss ast   (HData' t)
+    -> PDatumCode xss vars1 (HData' t)
+    -> List1 Variable (vars1 ++ vars2)
+    -> m (Maybe (MatchState ast vars2))
+matchCode getDatum d pat vars =
+    case (d,pat) of
+    (Inr d2, PInr pat2) -> matchCode   getDatum d2 pat2 vars
+    (Inl d1, PInl pat1) -> matchStruct getDatum d1 pat1 vars
+    _                   -> return Nothing
+
+
+matchStruct
+    :: forall m ast xs t vars1 vars2
+    .  (Monad m)
+    => DatumEvaluator ast m
+    -> DatumStruct  xs ast   (HData' t)
+    -> PDatumStruct xs vars1 (HData' t)
+    -> List1 Variable (vars1 ++ vars2)
+    -> m (Maybe (MatchState ast vars2))
+matchStruct getDatum d pat vars =
+    case (d,pat) of
+    (Done,     PDone)     -> return . Just $ Matched_ id vars
+    (Et d1 d2, PEt p1 p2) ->
+        let vars0 =
+                case
+                    eqAppendAssoc
+                        (secondProxy p1)
+                        (secondProxy p2)
+                        (Proxy :: Proxy vars2) -- HACK: is there any other way to get our hands on @vars2@?
+                of Refl -> vars
+        in
+        matchFun    getDatum d1 p1 vars0 `bindMMR` \xs1 vars1 ->
+        matchStruct getDatum d2 p2 vars1 `bindMMR` \xs2 vars2 ->
+        return . Just $ Matched_ (xs1 . xs2) vars2
+    where
+    -- TODO: just turn @Maybe MatchState@ into a monad already?
+    bindMMR m k = do
+        mb <- m
+        case mb of
+            Nothing                  -> return Nothing
+            Just GotStuck_           -> return $ Just GotStuck_
+            Just (Matched_ xs vars') -> k xs vars'
+
+matchFun
+    :: (Monad m)
+    => DatumEvaluator ast m
+    -> DatumFun  x ast   (HData' t)
+    -> PDatumFun x vars1 (HData' t)
+    -> List1 Variable (vars1 ++ vars2)
+    -> m (Maybe (MatchState ast vars2))
+matchFun getDatum d pat vars =
+    case (d,pat) of
+    (Konst d2, PKonst p2) -> matchPattern getDatum d2 p2 vars
+    (Ident d1, PIdent p1) -> matchPattern getDatum d1 p1 vars
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/Gensym.hs b/haskell/Language/Hakaru/Syntax/Gensym.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Gensym.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , FlexibleInstances
+           , FlexibleContexts
+           , KindSignatures
+           , OverloadedStrings
+           , UndecidableInstances
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Language.Hakaru.Syntax.Gensym where
+
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Functor                    ((<$>))
+#endif
+import Control.Monad.State
+import Data.Number.Nat
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+
+class Monad m => Gensym m where
+  freshVarId :: m Nat
+
+instance (Monad m, MonadState Nat m) => Gensym m where
+  freshVarId = do
+    vid <- gets succ
+    put vid
+    return vid
+
+freshVar
+    :: (Functor m, Gensym m)
+    => Variable (a :: Hakaru) -> m (Variable a)
+freshVar v = fmap (\n -> v{varID=n}) freshVarId
+
+varOfType
+    :: (Functor m, Gensym m)
+    => Sing (a :: Hakaru) -> m (Variable a)
+varOfType t = fmap (\n  -> Variable "" n t) freshVarId
+
+varForExpr
+    :: (Functor m, Gensym m, ABT Term abt)
+    => abt '[] a -> m (Variable a)
+varForExpr v = fmap (\n -> Variable "" n (typeOf v)) freshVarId
+
diff --git a/haskell/Language/Hakaru/Syntax/Hoist.hs b/haskell/Language/Hakaru/Syntax/Hoist.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Hoist.hs
@@ -0,0 +1,412 @@
+{-# LANGUAGE CPP
+           , BangPatterns
+           , DataKinds
+           , EmptyCase
+           , ExistentialQuantification
+           , FlexibleContexts
+           , FlexibleInstances
+           , GADTs
+           , GeneralizedNewtypeDeriving
+           , KindSignatures
+           , MultiParamTypeClasses
+           , OverloadedStrings
+           , PolyKinds
+           , ScopedTypeVariables
+           , StandaloneDeriving
+           , TupleSections
+           , TypeFamilies
+           , TypeOperators
+           , UndecidableInstances
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2017.02.01
+-- |
+-- Module      :  Language.Hakaru.Syntax.Hoist
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Hoist expressions to the point where their data dependencies are met.
+-- This pass duplicates *a lot* of work and relies on a the CSE and pruning
+-- passes to cleanup the junk (most of which is trivial to do, but we don't know
+-- what is junk until after CSE has occured).
+--
+-- NOTE: This pass assumes globally unique variable ids, as two subterms may
+-- otherwise bind the same variable. Those variables would potentially shadow
+-- eachother if hoisted upward to a common scope.
+--
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.Hoist (hoist) where
+
+import           Control.Applicative             (liftA2)
+import           Control.Monad.RWS               hiding ((<>))
+import qualified Data.Foldable                   as F
+import qualified Data.Graph                      as G
+import qualified Data.IntMap.Strict              as IM
+import qualified Data.List                       as L
+import           Data.Maybe                      (mapMaybe)
+import           Data.Number.Nat
+import           Data.Proxy                      (KProxy (..))
+import qualified Data.Vector                     as V
+
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.ANF      (isValue)
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.AST.Eq   (alphaEq)
+import           Language.Hakaru.Syntax.Gensym
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Types.DataKind
+import           Language.Hakaru.Types.Sing      (Sing)
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative
+#endif
+
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Semigroup
+#endif
+
+data Entry (abt :: Hakaru -> *)
+  = forall (a :: Hakaru) . Entry
+  { varDependencies :: !(VarSet (KindOf a))
+  , expression      :: !(abt a)
+  -- The type of the expression, to allow for easy comparison of types.
+  -- The typeOf operator is technically O(n) in the size of the expresion
+  -- and we may need to call it many times.
+  , sing            :: !(Sing a)
+  , bindings        :: ![Variable a]
+  }
+
+instance Show (Entry abt) where
+  show (Entry d _ _ b) = "Entry (" ++ show d ++ ") (" ++ show b ++ ")"
+
+type HakaruProxy = ('KProxy :: KProxy Hakaru)
+type LiveSet     = VarSet HakaruProxy
+type HakaruVar   = SomeVariable HakaruProxy
+
+-- The @HoistM@ monad makes use of three monadic layers to propagate information
+-- both downwards to the leaves and upwards to the root node of the AST.
+--
+-- The Writer layer propagates the live expressions which may be hoisted (i.e.
+-- all their data dependencies are currently filled) from each subexpression to
+-- their parents.
+--
+-- The Reader layer propagates the currently bound variables which will be used
+-- to decide when to introduce new bindings.
+--
+-- The State layer is just to provide a counter in order to gensym new
+-- variables, since the process of adding new bindings is a little tricky.
+-- What we want is to fully duplicate bindings without altering the original
+-- variable identifiers. To do so, all original variable names are preserved and
+-- new variables are added outside the range of existing variables.
+newtype HoistM (abt :: [Hakaru] -> Hakaru -> *) a
+  = HoistM { runHoistM :: RWS LiveSet (ExpressionSet abt) Nat a }
+
+deriving instance                   Functor (HoistM abt)
+deriving instance (ABT Term abt) => Applicative (HoistM abt)
+deriving instance (ABT Term abt) => Monad (HoistM abt)
+deriving instance (ABT Term abt) => MonadState Nat (HoistM abt)
+deriving instance (ABT Term abt) => MonadWriter (ExpressionSet abt) (HoistM abt)
+deriving instance (ABT Term abt) => MonadReader LiveSet (HoistM abt)
+
+newtype ExpressionSet (abt :: [Hakaru] -> Hakaru -> *)
+  = ExpressionSet [Entry (abt '[])]
+
+mergeEntry :: (ABT Term abt) => Entry (abt '[]) -> Entry (abt '[]) -> Entry (abt '[])
+mergeEntry (Entry d e s1 b1) (Entry _ _ s2 b2) =
+  case jmEq1 s1 s2 of
+    Just Refl -> Entry d e s1 $ L.nub (b1 ++ b2)
+    Nothing   -> error "cannot union mismatched entries"
+
+entryEqual :: (ABT Term abt) => Entry (abt '[]) -> Entry (abt '[]) -> Bool
+entryEqual Entry{varDependencies=d1,expression=e1,sing=s1}
+           Entry{varDependencies=d2,expression=e2,sing=s2} =
+  case (d1 == d2, jmEq1 s1 s2) of
+    (True , Just Refl) -> alphaEq e1 e2
+    _                  -> False
+
+unionEntrySet
+  :: forall abt
+  .  (ABT Term abt)
+  => ExpressionSet abt
+  -> ExpressionSet abt
+  -> ExpressionSet abt
+unionEntrySet (ExpressionSet xs) (ExpressionSet ys) =
+  ExpressionSet . mapMaybe uniquify $ L.groupBy entryEqual (xs ++ ys)
+  where
+    uniquify :: [Entry (abt '[])] -> Maybe (Entry (abt '[]))
+    uniquify [] = Nothing
+    uniquify zs = Just $ L.foldl1' mergeEntry zs
+
+intersectEntrySet
+  :: forall abt
+  .  (ABT Term abt)
+  => ExpressionSet abt
+  -> ExpressionSet abt
+  -> ExpressionSet abt
+intersectEntrySet (ExpressionSet xs) (ExpressionSet ys) = ExpressionSet merged
+  where
+    merged :: [Entry (abt '[])]
+    merged = map (uncurry mergeEntry) . filter (uncurry entryEqual) $ liftA2 (,) xs ys
+
+-- The general case for generating the entry set for a term is to simply union
+-- the sets for all the subterms, so we choose union as our monoidal operation
+-- for the Writer monad.
+instance (ABT Term abt) => Semigroup (ExpressionSet abt) where
+  (<>) = unionEntrySet
+
+instance (ABT Term abt) => Monoid (ExpressionSet abt) where
+  mempty  = ExpressionSet []
+#if !(MIN_VERSION_base(4,11,0))
+  mappend = (<>)
+#endif
+
+-- Given a list of entries to introduce, order them so that their data
+-- data dependencies are satisified.
+topSortEntries
+  :: forall abt
+  .  [Entry (abt '[])]
+  -> [Entry (abt '[])]
+topSortEntries entryList = map (entries V.!) $ G.topSort graph
+  where
+    entries :: V.Vector (Entry (abt '[]))
+    !entries = V.fromList entryList
+
+    -- The graph is represented as dependencies between entries, where an entry
+    -- (a) depends on entry (b) if (b) introduces a variable which (a) depends
+    -- on.
+    getVIDs :: Entry (abt '[]) -> [Int]
+    getVIDs Entry{bindings=b} = map (fromNat . varID) b
+
+    -- Associates all variables introduced by an entry to the entry itself.
+    -- A given entry may introduce multiple bindings, since an entry stores all
+    -- α-equivalent variable definitions.
+    assocBindingsTo :: IM.IntMap Int -> Int -> Entry (abt '[]) -> IM.IntMap Int
+    assocBindingsTo m n = L.foldl' (\acc v -> IM.insert v n acc) m . getVIDs
+
+    -- Mapping from variable IDs to their corresponding entries
+    varMap :: IM.IntMap Int
+    !varMap = V.ifoldl' assocBindingsTo IM.empty entries
+
+    -- Create an edge from each dependency to the variable
+    makeEdges :: Int -> Entry (abt '[]) -> [G.Edge]
+    makeEdges idx Entry{varDependencies=d} = map (, idx)
+                                           . mapMaybe (flip IM.lookup varMap)
+                                           $ varSetKeys d
+
+    -- Collect all the verticies to build the full graph
+    vertices :: [G.Edge]
+    !vertices = V.foldr (++) [] $ V.imap makeEdges entries
+
+    -- The full graph structure to be topologically sorted
+    graph :: G.Graph
+    !graph = G.buildG (0, V.length entries - 1) vertices
+
+recordEntry
+  :: (ABT Term abt)
+  => Variable a
+  -> abt '[] a
+  -> HoistM abt ()
+recordEntry v abt = tell $ ExpressionSet [Entry (freeVars abt) abt (varType v) [v]]
+
+execHoistM :: Nat -> HoistM abt a -> a
+execHoistM counter act = a
+  where
+    hoisted   = runHoistM act
+    (a, _, _) = runRWS hoisted emptyVarSet counter
+
+-- | An expression is considered "toplevel" if it can be hoisted outside all
+-- binders. This means that the expression has no data dependencies.
+toplevelEntry
+  :: Entry abt
+  -> Bool
+toplevelEntry Entry{varDependencies=d} = sizeVarSet d == 0
+
+captureEntries
+  :: (ABT Term abt)
+  => HoistM abt a
+  -> HoistM abt (a, ExpressionSet abt)
+captureEntries = censor (const mempty) . listen
+
+hoist
+  :: (ABT Term abt)
+  => abt '[] a
+  -> abt '[] a
+hoist abt = execHoistM (nextFreeOrBind abt) $
+  captureEntries (hoist' abt) >>= uncurry (introduceToplevel emptyVarSet)
+
+partitionEntrySet
+  :: (Entry (abt '[]) -> Bool)
+  -> ExpressionSet abt
+  -> (ExpressionSet abt, ExpressionSet abt)
+partitionEntrySet p (ExpressionSet xs) = (ExpressionSet true, ExpressionSet false)
+  where
+    (true, false) = L.partition p xs
+
+introduceToplevel
+  :: (ABT Term abt)
+  => LiveSet
+  -> abt '[] a
+  -> ExpressionSet abt
+  -> HoistM abt (abt '[] a)
+introduceToplevel avail abt entries = do
+  -- After transforming the given ast, we need to introduce all the toplevel
+  -- bindings (i.e. bindings with no data dependencies), most of which should be
+  -- eliminated by constant propagation.
+  let (ExpressionSet toplevel, rest) = partitionEntrySet toplevelEntry entries
+      intro = concatMap getBoundVars toplevel ++ fromVarSet avail
+  -- First we wrap the now AST in the all terms which depdend on top level
+  -- definitions
+  wrapped <- introduceBindings intro abt rest
+  -- Then wrap the result in the toplevel definitions
+  wrapExpr wrapped toplevel
+
+bindVar
+  :: (ABT Term abt)
+  => Variable (a :: Hakaru)
+  -> HoistM abt b
+  -> HoistM abt b
+bindVar = local . insertVarSet
+
+isolateBinder
+  :: (ABT Term abt)
+  => Variable (a :: Hakaru)
+  -> HoistM abt b
+  -> HoistM abt (b, ExpressionSet abt)
+isolateBinder v = captureEntries . bindVar v
+
+hoist'
+  :: forall abt xs a . (ABT Term abt)
+  => abt xs a
+  -> HoistM abt (abt xs a)
+hoist' = start
+  where
+    insertMany :: [HakaruVar] -> LiveSet -> LiveSet
+    insertMany = flip $ L.foldl' (\ acc (SomeVariable v) -> insertVarSet v acc)
+
+    start :: forall ys b . abt ys b -> HoistM abt (abt ys b)
+    start = loop [] . viewABT
+
+    isolateBinders :: [HakaruVar] -> HoistM abt c -> HoistM abt (c, ExpressionSet abt)
+    isolateBinders xs = censor (const mempty) . listen . local (insertMany xs)
+
+    -- @loop@ takes 2 parameters.
+    --
+    -- 1. The list of variables bound so far
+    -- 2. The current term we are recurring over
+    --
+    -- We add a value to the first every time we hit a @Bind@ term, and when
+    -- a @Syn@ term is finally reached, we introduce any hoisted values whose
+    -- data dependencies are satisified by these new variables.
+    loop :: forall ys b
+         .  [HakaruVar]
+         -> View (Term abt) ys b
+         -> HoistM abt (abt ys b)
+    loop _  (Var v)    = return (var v)
+
+    -- This case is not needed, but we can avoid performing the expensive work
+    -- of calling introduceBindings in the case were we won't be performing any
+    -- work.
+    loop [] (Syn s)    = hoistTerm s
+    loop xs (Syn s)    = do
+      (term, entries) <- isolateBinders xs (hoistTerm s)
+      introduceBindings xs term entries
+
+    loop xs (Bind v b) = bind v <$> loop (SomeVariable v : xs) b
+
+getBoundVars :: Entry x -> [HakaruVar]
+getBoundVars Entry{bindings=b} = fmap SomeVariable b
+
+wrapExpr
+  :: forall abt b . (ABT Term abt)
+  => abt '[] b
+  -> [Entry (abt '[])]
+  -> HoistM abt (abt '[] b)
+wrapExpr = F.foldrM wrap
+  where
+    mklet :: abt '[] a -> Variable a -> abt '[] b -> abt '[] b
+    mklet e v b =
+      case viewABT b of
+        Var v' | Just Refl <- varEq v v' -> e
+        _      -> syn (Let_ :$ e :* bind v b :* End)
+
+    -- Binds the Entry's expression to a fresh variable and rebinds any other
+    -- variable uses to the fresh variable.
+    wrap :: Entry (abt '[]) -> abt '[] b ->  HoistM abt (abt '[] b)
+    wrap Entry{expression=e,bindings=[]} acc = do
+      tmp <- varForExpr e
+      return $ mklet e tmp acc
+    wrap Entry{expression=e,bindings=(x:xs)} acc = do
+      let rhs  = var x
+          body = foldr (mklet rhs) acc xs
+      return $ mklet e x body
+
+-- This will introduce all binders which must be introduced by binding the
+-- @newVars@ set. As a side effect, the remaining entries are written into the
+-- Writer layer of the stack.
+introduceBindings
+  :: forall (a :: Hakaru) abt
+  .  (ABT Term abt)
+  => [HakaruVar]
+  -> abt '[] a
+  -> ExpressionSet abt
+  -> HoistM abt (abt '[] a)
+introduceBindings newVars body (ExpressionSet entries) = do
+  tell (ExpressionSet leftOver)
+  wrapExpr body (topSortEntries resultEntries)
+  where
+    resultEntries, leftOver :: [Entry (abt '[])]
+    (resultEntries, leftOver) = loop entries newVars
+
+    introducedBy
+      :: forall (b :: Hakaru)
+      .  Variable b
+      -> Entry (abt '[])
+      -> Bool
+    introducedBy v Entry{varDependencies=deps} = memberVarSet v deps
+
+    loop
+      :: [Entry (abt '[])]
+      -> [HakaruVar]
+      -> ([Entry (abt '[])], [Entry (abt '[])])
+    loop exprs []                    = ([], exprs)
+    loop exprs (SomeVariable v : xs) = (introduced ++ intro, acc)
+      where
+        ~(intro, acc)      = loop rest (xs ++ vars)
+        vars               = concatMap getBoundVars introduced
+        (introduced, rest) = L.partition (introducedBy v) exprs
+
+-- Contrary to the other binding forms, let expressions are killed by the
+-- hoisting pass. Their RHSs are floated upward in the AST and re-introduced
+-- where their data dependencies are fulfilled. Thus, the result of hoisting
+-- a let expression is just the hoisted body.
+hoistTerm
+  :: forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *)
+  .  (ABT Term abt)
+  => Term abt a
+  -> HoistM abt (abt '[] a)
+hoistTerm (Let_ :$ rhs :* body :* End) =
+  caseBind body $ \ v body' -> do
+    rhs' <- hoist' rhs
+    recordEntry v rhs'
+    bindVar v (hoist' body')
+
+hoistTerm (Lam_ :$ body :* End) =
+  caseBind body $ \ v body' -> do
+    available         <- fmap (insertVarSet v) ask
+    (body'', entries) <- isolateBinder v (hoist' body')
+    finalized         <- introduceToplevel available body'' entries
+    return $ syn (Lam_ :$ bind v finalized :* End)
+
+hoistTerm term = do
+  result <- syn <$> traverse21 hoist' term
+  if isValue result
+    then return result
+    else do fresh <- varForExpr result
+            recordEntry fresh result
+            return (var fresh)
+
diff --git a/haskell/Language/Hakaru/Syntax/IClasses.hs b/haskell/Language/Hakaru/Syntax/IClasses.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/IClasses.hs
@@ -0,0 +1,867 @@
+-- TODO: move this file somewhere else, like "Language.Hakaru.IClasses"
+{-# LANGUAGE CPP
+           , PolyKinds
+           , DataKinds
+           , TypeOperators
+           , GADTs
+           , TypeFamilies
+           , Rank2Types
+           , ScopedTypeVariables
+           , ConstraintKinds
+           , MultiParamTypeClasses
+           , FlexibleInstances
+           , UndecidableInstances
+           #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.28
+-- |
+-- Module      :  Language.Hakaru.Syntax.IClasses
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- A collection of classes generalizing standard classes in order
+-- to support indexed types.
+--
+-- TODO: DeriveDataTypeable for all our newtypes?
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.IClasses
+    (
+    -- * Showing indexed types
+      Show1(..), shows1, showList1
+    , Show2(..), shows2, showList2
+    -- ** Some more-generic helper functions for showing things
+    , showListWith
+    , showTuple
+    -- ** some helpers for implementing the instances
+    , showParen_0
+    , showParen_1
+    , showParen_2
+    , showParen_01
+    , showParen_02
+    , showParen_11
+    , showParen_12
+    , showParen_22
+    , showParen_010
+    , showParen_011
+    , showParen_111
+
+    -- * Equality
+    , Eq1(..)
+    , Eq2(..)
+    , TypeEq(..), symmetry, transitivity, congruence
+    , JmEq1(..)
+    , JmEq2(..)
+
+    -- * Generalized abstract nonsense
+    , Functor11(..), Fix11(..), cata11, ana11, hylo11
+    , Functor12(..)
+    , Functor21(..)
+    , Functor22(..)
+    , Foldable11(..), Lift1(..)
+    , Foldable12(..)
+    , Foldable21(..), Lift2(..)
+    , Foldable22(..)
+    , Traversable11(..)
+    , Traversable12(..)
+    , Traversable21(..)
+    , Traversable22(..)
+
+    -- * Helper types
+    , Some1(..)
+    , Some2(..)
+    , Pair1(..), fst1, snd1
+    , Pair2(..), fst2, snd2
+    , Pointwise(..), PointwiseP(..)
+    -- ** List types
+    , type (++), eqAppendIdentity, eqAppendAssoc
+    , List1(..), append1
+    , List2(..)
+    , DList1(..), toList1, fromList1, dnil1, dcons1, dsnoc1, dsingleton1, dappend1
+    -- ** Constraints
+    , All(..), Holds(..)
+    ) where
+
+import Prelude hiding   (id, (.))
+import Control.Category (Category(..))
+import Unsafe.Coerce    (unsafeCoerce)
+import GHC.Exts         (Constraint)
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid      (Monoid(..))
+import Control.Applicative
+#endif
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: cf., <http://hackage.haskell.org/package/abt-0.1.1.0>
+-- | Uniform variant of 'Show' for @k@-indexed types. This differs
+-- from @transformers:@'Data.Functor.Classes.Show1' in being
+-- polykinded, like it ought to be.
+--
+-- Alas, I don't think there's any way to derive instances the way
+-- we can derive for 'Show'.
+class Show1 (a :: k -> *) where
+    {-# MINIMAL showsPrec1 | show1 #-}
+
+    showsPrec1 :: Int -> a i -> ShowS
+    showsPrec1 _ x s = show1 x ++ s
+
+    show1 :: a i -> String
+    show1 x = shows1 x ""
+
+shows1 :: (Show1 a) => a i -> ShowS
+shows1 =  showsPrec1 0
+
+showList1 :: (Show1 a) => [a i] -> ShowS
+showList1 = showListWith shows1
+
+{-
+-- BUG: these require (Show (i::k)) in the class definition of Show1
+instance Show1 Maybe where
+    showsPrec1 = showsPrec
+    show1      = show
+
+instance Show1 [] where
+    showsPrec1 = showsPrec
+    show1      = show
+
+instance Show1 ((,) a) where
+    showsPrec1 = showsPrec
+    show1      = show
+
+instance Show1 (Either a) where
+    showsPrec1 = showsPrec
+    show1      = show
+-}
+
+
+----------------------------------------------------------------
+-- TODO: how to show, in general, that @Show2 a@ implies @Show1 (a i)@ for all @i@... This is needed for 'Datum' which uses the 'LC_' trick...
+class Show2 (a :: k1 -> k2 -> *) where
+    {-# MINIMAL showsPrec2 | show2 #-}
+
+    showsPrec2 :: Int -> a i j -> ShowS
+    showsPrec2 _ x s = show2 x ++ s
+
+    show2 :: a i j -> String
+    show2 x = shows2 x ""
+
+shows2 :: (Show2 a) => a i j -> ShowS
+shows2 =  showsPrec2 0
+
+showList2 :: Show2 a => [a i j] -> ShowS
+showList2 = showListWith shows2
+
+
+----------------------------------------------------------------
+-- This implementation taken from 'showList' in base-4.8:"GHC.Show",
+-- generalizing over the showing function. Looks like this is available from base-4.8.2.0:"Text.Show"
+showListWith :: (a -> ShowS) -> [a] -> ShowS
+showListWith f = start
+    where
+    start []     s = "[]" ++ s
+    start (x:xs) s = '[' : f x (go xs)
+        where
+        go []     = ']' : s
+        go (y:ys) = ',' : f y (go ys)
+
+
+-- This implementation taken from 'show_tuple' in base-4.8:"GHC.Show",
+-- verbatim.
+showTuple :: [ShowS] -> ShowS
+showTuple ss
+    = showChar '('
+    . foldr1 (\s r -> s . showChar ',' . r) ss
+    . showChar ')'
+
+
+showParen_0 :: Show a => Int -> String -> a -> ShowS
+showParen_0 p s e =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec 11 e
+        )
+
+showParen_1 :: Show1 a => Int -> String -> a i -> ShowS
+showParen_1 p s e =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec1 11 e
+        )
+
+showParen_2 :: Show2 a => Int -> String -> a i j -> ShowS
+showParen_2 p s e =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec2 11 e
+        )
+
+showParen_01 :: (Show b, Show1 a) => Int -> String -> b -> a i -> ShowS
+showParen_01 p s e1 e2 =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec  11 e1
+        . showString " "
+        . showsPrec1 11 e2
+        )
+
+showParen_02 :: (Show b, Show2 a) => Int -> String -> b -> a i j -> ShowS
+showParen_02 p s e1 e2 =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec  11 e1
+        . showString " "
+        . showsPrec2 11 e2
+        )
+
+showParen_11 :: (Show1 a, Show1 b) => Int -> String -> a i -> b j -> ShowS
+showParen_11 p s e1 e2 =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec1 11 e1
+        . showString " "
+        . showsPrec1 11 e2
+        )
+
+showParen_12 :: (Show1 a, Show2 b) => Int -> String -> a i -> b j l -> ShowS
+showParen_12 p s e1 e2 =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec1 11 e1
+        . showString " "
+        . showsPrec2 11 e2
+        )
+
+showParen_22 :: (Show2 a, Show2 b) => Int -> String -> a i1 j1 -> b i2 j2 -> ShowS
+showParen_22 p s e1 e2 =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec2 11 e1
+        . showString " "
+        . showsPrec2 11 e2
+        )
+
+showParen_010
+    :: (Show a, Show1 b, Show c)
+    => Int -> String -> a -> b i -> c -> ShowS
+showParen_010 p s e1 e2 e3 =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec  11 e1
+        . showString " "
+        . showsPrec1 11 e2
+        . showString " "
+        . showsPrec  11 e3
+        )
+
+showParen_011
+    :: (Show a, Show1 b, Show1 c)
+    => Int -> String -> a -> b i -> c j -> ShowS
+showParen_011 p s e1 e2 e3 =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec  11 e1
+        . showString " "
+        . showsPrec1 11 e2
+        . showString " "
+        . showsPrec1 11 e3
+        )
+
+showParen_111
+    :: (Show1 a, Show1 b, Show1 c)
+    => Int -> String -> a i -> b j -> c k -> ShowS
+showParen_111 p s e1 e2 e3 =
+    showParen (p > 9)
+        ( showString s
+        . showString " "
+        . showsPrec1 11 e1
+        . showString " "
+        . showsPrec1 11 e2
+        . showString " "
+        . showsPrec1 11 e3
+        )
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- | Uniform variant of 'Eq' for homogeneous @k@-indexed types.
+-- N.B., we keep this separate from the 'JmEq1' class because for
+-- some types we may be able to decide 'eq1' while not being able
+-- to decide 'jmEq1' (e.g., if using phantom types rather than
+-- GADTs). N.B., this function returns value\/term equality! That
+-- is, the following four laws must hold relating the 'Eq1' class
+-- to the 'Eq' class:
+--
+--     (1) if @eq1 x y == True@, then @x@ and @y@ have the same
+--         type index and @(x == y) == True@
+--     (2) if @eq1 x y == False@ where @x@ and @y@ have the same
+--         type index, then @(x == y) == False@
+--     (3) if @(x == y) == True@, then @eq1 x y == True@
+--     (4) if @(x == y) == False@, then @eq1 x y == False@
+--
+-- Alas, I don't think there's any way to derive instances the way
+-- we can derive for 'Eq'.
+class Eq1 (a :: k -> *) where
+    eq1 :: a i -> a i -> Bool
+    -- TODO: how do we give the default instance for whenever we have a JmEq1 instance?
+    -- TODO: is there a way to require the induced @Eq (a i)@ instance to be given?
+
+
+class Eq2 (a :: k1 -> k2 -> *) where
+    eq2 :: a i j -> a i j -> Bool
+
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: it'd be okay to use @(:~:)@ from "Data.Typeable" instead of defining our own. Except that one doesn't define the Category instance, symmetry, or congruence...
+
+-- | Concrete proofs of type equality. In order to make use of a
+-- proof @p :: TypeEq a b@, you must pattern-match on the 'Refl'
+-- constructor in order to show GHC that the types @a@ and @b@ are
+-- equal.
+data TypeEq :: k -> k -> * where
+    Refl :: TypeEq a a
+
+instance Category TypeEq where
+    id          = Refl
+    Refl . Refl = Refl
+
+-- | Type equality is symmetric.
+symmetry :: TypeEq a b -> TypeEq b a
+symmetry Refl = Refl
+
+-- | Type equality is transitive. N.B., this is has a more general
+-- type than @(.)@
+transitivity :: TypeEq a b -> TypeEq b c -> TypeEq a c
+transitivity Refl Refl = Refl
+
+-- | Type constructors are extensional.
+congruence :: TypeEq a b -> TypeEq (f a) (f b)
+congruence Refl = Refl
+
+
+-- TODO: Should we add an additional method which only checks for index equality, ignoring possible differences at the term\/value level?
+--
+-- | Uniform variant of 'Eq' for heterogeneous @k@-indexed types.
+-- N.B., this function returns value\/term equality! That is, the
+-- following four laws must hold relating the 'JmEq1' class to the
+-- 'Eq1' class:
+--
+--     (1) if @jmEq1 x y == Just Refl@, then @x@ and @y@ have the
+--         same type index and @eq1 x y == True@
+--     (2) if @jmEq1 x y == Nothing@ where @x@ and @y@ have the
+--         same type index, then @eq1 x y == False@
+--     (3) if @eq1 x y == True@, then @jmEq1 x y == Just Refl@
+--     (4) if @eq1 x y == False@, then @jmEq1 x y == Nothing@
+--
+-- Alas, I don't think there's any way to derive instances the way
+-- we can derive for 'Eq'.
+class Eq1 a => JmEq1 (a :: k -> *) where
+    jmEq1 :: a i -> a j -> Maybe (TypeEq i j)
+
+class Eq2 a => JmEq2 (a :: k1 -> k2 -> *) where
+    jmEq2 :: a i1 j1 -> a i2 j2 -> Maybe (TypeEq i1 i2, TypeEq j1 j2)
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: rather than having this plethora of classes for different
+-- indexing, define newtypes for 1-natural transformations, 2-natural
+-- transformations, etc; and then define a single higher-order functor
+-- class which is parameterized by the input and output categories.
+
+-- | A functor on the category of @k@-indexed types (i.e., from
+-- @k@-indexed types to @k@-indexed types). We unify the two indices,
+-- because that seems the most helpful for what we're doing; we
+-- could, of course, offer a different variant that maps @k1@-indexed
+-- types to @k2@-indexed types...
+--
+-- Alas, I don't think there's any way to derive instances the way
+-- we can derive for 'Functor'.
+class Functor11 (f :: (k1 -> *) -> k2 -> *) where
+    fmap11 :: (forall i. a i -> b i) -> f a j -> f b j
+
+class Functor12 (f :: (k1 -> *) -> k2 -> k3 -> *) where
+    fmap12 :: (forall i. a i -> b i) -> f a j l -> f b j l
+
+-- | A functor from @(k1,k2)@-indexed types to @k3@-indexed types.
+class Functor21 (f :: (k1 -> k2 -> *) -> k3 -> *) where
+    fmap21 :: (forall h i. a h i -> b h i) -> f a j -> f b j
+
+
+-- | A functor from @(k1,k2)@-indexed types to @(k3,k4)@-indexed types.
+class Functor22 (f :: (k1 -> k2 -> *) -> k3 -> k4 -> *) where
+    fmap22 :: (forall h i. a h i -> b h i) -> f a j l -> f b j l
+
+
+----------------------------------------------------------------
+newtype Fix11 (f :: (k -> *) -> k -> *) (i :: k) =
+    Fix11 { unFix11 :: f (Fix11 f) i }
+
+cata11
+    :: forall f a j
+    .  (Functor11 f)
+    => (forall i. f a i -> a i)
+    -> Fix11 f j -> a j
+cata11 alg = go
+    where
+    go :: forall j'. Fix11 f j' -> a j'
+    go = alg . fmap11 go . unFix11
+
+ana11
+    :: forall f a j
+    .  (Functor11 f)
+    => (forall i. a i -> f a i)
+    -> a j -> Fix11 f j
+ana11 coalg = go
+    where
+    go :: forall j'. a j' -> Fix11 f j'
+    go = Fix11 . fmap11 go . coalg
+
+hylo11
+    :: forall f a b j
+    .  (Functor11 f)
+    => (forall i. a i -> f a i)
+    -> (forall i. f b i -> b i)
+    -> a j
+    -> b j
+hylo11 coalg alg = go
+    where
+    go :: forall j'. a j' -> b j'
+    go = alg . fmap11 go . coalg
+
+-- TODO: a tracing evaluator: <http://www.timphilipwilliams.com/posts/2013-01-16-fixing-gadts.html>
+
+
+----------------------------------------------------------------
+-- TODO: in theory we could define some Monoid1 class to avoid the
+-- explicit dependency on Lift1 in fold1's type. But we'd need that
+-- Monoid1 class to have some sort of notion of combining things
+-- at different indices...
+
+-- | A foldable functor on the category of @k@-indexed types.
+--
+-- Alas, I don't think there's any way to derive instances the way
+-- we can derive for 'Foldable'.
+class Functor11 f => Foldable11 (f :: (k1 -> *) -> k2 -> *) where
+    {-# MINIMAL fold11 | foldMap11 #-}
+
+    fold11 :: (Monoid m) => f (Lift1 m) i -> m
+    fold11 = foldMap11 unLift1
+
+    foldMap11 :: (Monoid m) => (forall i. a i -> m) -> f a j -> m
+    foldMap11 f = fold11 . fmap11 (Lift1 . f)
+
+-- TODO: standard Foldable wrappers 'and11', 'or11', 'all11', 'any11',...
+
+
+class Functor12 f => Foldable12 (f :: (k1 -> *) -> k2 -> k3 -> *) where
+    {-# MINIMAL fold12 | foldMap12 #-}
+
+    fold12 :: (Monoid m) => f (Lift1 m) j l -> m
+    fold12 = foldMap12 unLift1
+
+    foldMap12 :: (Monoid m) => (forall i. a i -> m) -> f a j l -> m
+    foldMap12 f = fold12 . fmap12 (Lift1 . f)
+
+class Functor21 f => Foldable21 (f :: (k1 -> k2 -> *) -> k3 -> *) where
+    {-# MINIMAL fold21 | foldMap21 #-}
+
+    fold21 :: (Monoid m) => f (Lift2 m) j -> m
+    fold21 = foldMap21 unLift2
+
+    foldMap21 :: (Monoid m) => (forall h i. a h i -> m) -> f a j -> m
+    foldMap21 f = fold21 . fmap21 (Lift2 . f)
+
+class Functor22 f =>
+    Foldable22 (f :: (k1 -> k2 -> *) -> k3 -> k4 -> *)
+    where
+    {-# MINIMAL fold22 | foldMap22 #-}
+
+    fold22 :: (Monoid m) => f (Lift2 m) j l -> m
+    fold22 = foldMap22 unLift2
+
+    foldMap22 :: (Monoid m) => (forall h i. a h i -> m) -> f a j l -> m
+    foldMap22 f = fold22 . fmap22 (Lift2 . f)
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+class Foldable11 t => Traversable11 (t :: (k1 -> *) -> k2 -> *) where
+    traverse11
+        :: Applicative f
+        => (forall i. a i -> f (b i))
+        -> t a j
+        -> f (t b j)
+    {-
+    sequenceA :: Applicative f => t (f a) -> f (t a)
+    mapM :: Monad m => (a -> m b) -> t a -> m (t b)
+    sequence :: Monad m => t (m a) -> m (t a)
+    -}
+
+class Foldable12 t => Traversable12 (t :: (k1 -> *) -> k2 -> k3 -> *) where
+    traverse12
+        :: Applicative f
+        => (forall i. a i -> f (b i))
+        -> t a j l
+        -> f (t b j l)
+
+class Foldable21 t => Traversable21 (t :: (k1 -> k2 -> *) -> k3 -> *) where
+    traverse21
+        :: Applicative f
+        => (forall h i. a h i -> f (b h i))
+        -> t a j
+        -> f (t b j)
+
+class Foldable22 t =>
+    Traversable22 (t :: (k1 -> k2 -> *) -> k3 -> k4 -> *)
+    where
+    traverse22
+        :: Applicative f
+        => (forall h i. a h i -> f (b h i))
+        -> t a j l
+        -> f (t b j l)
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- | Any unindexed type can be lifted to be (trivially) @k@-indexed.
+newtype Lift1 (a :: *) (i :: k) =
+    Lift1 { unLift1 :: a }
+    deriving (Read, Show, Eq, Ord)
+
+instance Show a => Show1 (Lift1 a) where
+    showsPrec1 p (Lift1 x) = showsPrec p x
+    show1        (Lift1 x) = show x
+
+instance Eq a => Eq1 (Lift1 a) where
+    eq1 (Lift1 a) (Lift1 b) = a == b
+
+
+----------------------------------------------------------------
+-- | Any unindexed type can be lifted to be (trivially) @(k1,k2)@-indexed.
+newtype Lift2 (a :: *) (i :: k1) (j :: k2) =
+    Lift2 { unLift2 :: a }
+    deriving (Read, Show, Eq, Ord)
+
+instance Show a => Show2 (Lift2 a) where
+    showsPrec2 p (Lift2 x) = showsPrec p x
+    show2        (Lift2 x) = show x
+
+instance Show a => Show1 (Lift2 a i) where
+    showsPrec1 p (Lift2 x) = showsPrec p x
+    show1        (Lift2 x) = show x
+
+instance Eq a => Eq2 (Lift2 a) where
+    eq2 (Lift2 a) (Lift2 b) = a == b
+
+instance Eq a => Eq1 (Lift2 a i) where
+    eq1 (Lift2 a) (Lift2 b) = a == b
+
+----------------------------------------------------------------
+data Pointwise (f :: k0 -> *) (g :: k1 -> *) (x :: k0) (y :: k1) where
+    Pw :: f x -> g y -> Pointwise f g x y
+
+data PointwiseP (f :: k0 -> *) (g :: k1 -> *) (xy :: (k0, k1)) where
+    PwP :: f x -> g y -> PointwiseP f g '(x,y)
+
+----------------------------------------------------------------
+-- BUG: haddock doesn't like annotations on GADT constructors. So
+-- here we'll avoid using the GADT syntax, even though it'd make
+-- the data type declaration prettier\/cleaner.
+-- <https://github.com/hakaru-dev/hakaru/issues/6>
+--
+-- | Existentially quantify over a single index.
+-- TODO: replace 'SomeVariable' with @(Some1 Variable)@
+data Some1 (a :: k -> *)
+    = forall i. Some1 !(a i)
+
+instance Show1 a => Show (Some1 a) where
+    showsPrec p (Some1 x) = showParen_1 p "Some1" x
+
+instance JmEq1 a  => Eq (Some1 a) where
+    Some1 x == Some1 y = maybe False (const True) (jmEq1 x y)
+
+
+-- | Existentially quantify over two indices.
+data Some2 (a :: k1 -> k2 -> *)
+    = forall i j. Some2 !(a i j)
+
+instance Show2 a => Show (Some2 a) where
+    showsPrec p (Some2 x) = showParen_2 p "Some2" x
+
+instance JmEq2 a  => Eq (Some2 a) where
+    Some2 x == Some2 y = maybe False (const True) (jmEq2 x y)
+
+
+----------------------------------------------------------------
+-- | A lazy pairing of identically @k@-indexed values.
+data Pair1 (a :: k -> *) (b :: k -> *) (i :: k) =
+    Pair1 (a i) (b i)
+
+fst1 :: Pair1 a b i -> a i
+fst1 (Pair1 x _) = x
+
+snd1 :: Pair1 a b i -> b i
+snd1 (Pair1 _ y) = y
+
+instance (Show1 a, Show1 b) => Show1 (Pair1 a b) where
+    showsPrec1 p (Pair1 x y) = showParen_11 p "Pair1" x y
+
+instance (Show1 a, Show1 b) => Show (Pair1 a b i) where
+    showsPrec = showsPrec1
+    show      = show1
+
+-- TODO: derived Eq, JmEq, functor, foldable, traversable instances
+
+----------------------------------------------------------------
+-- | A lazy pairing of identically @(k1,k2)@-indexed values.
+data Pair2 (a :: k1 -> k2 -> *) (b :: k1 -> k2 -> *) (i :: k1) (j :: k2) =
+    Pair2 (a i j) (b i j)
+
+fst2 :: Pair2 a b i j -> a i j
+fst2 (Pair2 x _) = x
+
+snd2 :: Pair2 a b i j -> b i j
+snd2 (Pair2 _ y) = y
+
+instance (Show2 a, Show2 b) => Show2 (Pair2 a b) where
+    showsPrec2 p (Pair2 x y) = showParen_22 p "Pair2" x y
+
+instance (Show2 a, Show2 b) => Show1 (Pair2 a b i) where
+    showsPrec1 = showsPrec2
+    show1      = show2
+
+instance (Show2 a, Show2 b) => Show (Pair2 a b i j) where
+    showsPrec = showsPrec1
+    show      = show1
+
+-- TODO: derived Eq, JmEq, functor, foldable, traversable instances
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: move all the list stuff off somewhere else
+
+-- BUG: how do we actually use the term-level @(++)@ at the type level? Or do we have to redefine it ourselves (as below)? If we define it ourselves, how can we make sure it's usable? In particular, how can we prove associativity and that @'[]@ is a /two-sided/ identity element?
+type family (xs :: [k]) ++ (ys :: [k]) :: [k] where
+    '[]       ++ ys = ys
+    (x ': xs) ++ ys = x ': (xs ++ ys)
+
+{-
+-- BUG: having the instances for @[[HakaruFun]]@ and @[HakaruFun]@ precludes giving a general kind-polymorphic data instance for type-level lists; so we have to monomorphize it to just the @[Hakaru]@ kind.
+-- TODO: we should figure out some way to clean that up without introducing too much ambiguity\/overloading of the constructor names.
+data instance Sing (xs :: [Hakaru]) where
+    SNil  :: Sing ('[] :: [Hakaru])
+    SCons :: !(Sing x) -> !(Sing xs) -> Sing ((x ': xs) :: [Hakaru])
+
+-- BUG: ghc calls all these orphan instances, even though the data instance is defined here... Will that actually cause problems? Should we move this to TypeEq.hs?
+instance Show1 (Sing :: [Hakaru] -> *) where
+    showsPrec1 p s =
+        case s of
+        SNil        -> showString     "SNil"
+        SCons s1 s2 -> showParen_11 p "SCons" s1 s2
+instance Show (Sing (xs :: [Hakaru])) where
+    showsPrec = showsPrec1
+    show      = show1
+instance SingI ('[] :: [Hakaru]) where
+    sing = SNil
+instance (SingI x, SingI xs) => SingI ((x ': xs) :: [Hakaru]) where
+    sing = SCons sing sing
+-}
+
+
+-- | The empty list is (also) a right-identity for @('++')@. Because
+-- we define @('++')@ by induction on the first argument, this
+-- identity doesn't come for free but rather must be proven.
+eqAppendIdentity :: proxy xs -> TypeEq xs (xs ++ '[])
+-- This version should be used for runtime performance
+eqAppendIdentity _ = unsafeCoerce Refl
+{-
+-- This version demonstrates that our use of unsafeCoerce is sound
+-- BUG: to have an argument of type @Sing xs@, instead of an arbitrary @proxy xs@, we'd need to store the singleton somewhere (prolly in the 'Branch', for the use site in TypeCheck.hs) or else produce it somehow
+eqAppendIdentity :: Sing (xs :: [Hakaru]) -> TypeEq xs (xs ++ '[])
+eqAppendIdentity SNil        = Refl
+eqAppendIdentity (SCons _ s) = case eqAppendIdentity s of Refl -> Refl
+-}
+
+
+-- To make a version that doesn't require proxies, we'd need to
+-- enable -XAllowAmbiguousTypes. We'd need to do this even just to
+-- drop the second or third proxies, which aren't needed for the
+-- safe version.
+--
+-- | @('++')@ is associative. This identity doesn't come for free
+-- but rather must be proven.
+eqAppendAssoc
+    :: proxy1 xs
+    -> proxy2 ys
+    -> proxy3 zs
+    -> TypeEq ((xs ++ ys) ++ zs) (xs ++ (ys ++ zs))
+-- This version should be used for runtime performance
+eqAppendAssoc _ _ _ = unsafeCoerce Refl
+{-
+-- This version demonstrates that our use of unsafeCoerce is sound
+-- BUG: to have the arguments be of type @Sing xs@, instead of arbitrary proxy types, we'd need to store the singletons somewhere (for the use site in TypeCheck.hs), but where?
+eqAppendAssoc
+    :: Sing (xs :: [Hakaru])
+    -> Sing (ys :: [Hakaru])
+    -> Sing (zs :: [Hakaru])
+    -> TypeEq ((xs ++ ys) ++ zs) (xs ++ (ys ++ zs))
+eqAppendAssoc SNil         _  _  = Refl
+eqAppendAssoc (SCons _ sx) sy sz =
+    case eqAppendAssoc sx sy sz of Refl -> Refl
+-}
+
+-- TODO: eqAppendNil :: proxy xs -> proxy ys -> TypeEq '[] (xs ++ ys) -> (TypeEq '[] xs, TypeEq '[] ys)
+
+
+----------------------------------------------------------------
+infixr 5 `Cons1`
+
+-- | A /lazy/ list of @k@-indexed elements, itself indexed by the
+-- list of indices
+data List1 :: (k -> *) -> [k] -> * where
+    Nil1  :: List1 a '[]
+    Cons1 :: a x -> List1 a xs -> List1 a (x ': xs)
+
+
+append1 :: List1 a xs -> List1 a ys -> List1 a (xs ++ ys)
+append1 Nil1         ys = ys
+append1 (Cons1 x xs) ys = Cons1 x (append1 xs ys)
+
+
+instance Show1 a => Show1 (List1 a) where
+    showsPrec1 _ Nil1         = showString     "Nil1"
+    showsPrec1 p (Cons1 x xs) = showParen_11 p "Cons1" x xs
+
+instance Show1 a => Show (List1 a xs) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance JmEq1 a  => JmEq1 (List1 a) where
+    jmEq1 Nil1         Nil1         = Just Refl
+    jmEq1 (Cons1 x xs) (Cons1 y ys) =
+        jmEq1 x  y  >>= \Refl ->
+        jmEq1 xs ys >>= \Refl ->
+        Just Refl
+    jmEq1 _ _ = Nothing
+
+instance Eq1 a  => Eq1 (List1 a) where
+    eq1 Nil1         Nil1         = True
+    eq1 (Cons1 x xs) (Cons1 y ys) = eq1 x y && eq1 xs ys
+
+instance Eq1 a  => Eq (List1 a xs) where
+    (==) = eq1
+
+instance Functor11 List1 where
+    fmap11 _ Nil1         = Nil1
+    fmap11 f (Cons1 x xs) = Cons1 (f x) (fmap11 f xs)
+
+instance Foldable11 List1 where
+    foldMap11 _ Nil1         = mempty
+    foldMap11 f (Cons1 x xs) = f x `mappend` foldMap11 f xs
+
+instance Traversable11 List1 where
+    traverse11 _ Nil1         = pure Nil1
+    traverse11 f (Cons1 x xs) = Cons1 <$> f x <*> traverse11 f xs
+
+----------------------------------------------------------------
+-- | Lifting of relations pointwise to lists
+data List2 :: (k0 -> k1 -> *) -> [k0] -> [k1] -> * where
+  Nil2  :: List2 f '[] '[]
+  Cons2 :: f x y -> List2 f xs ys -> List2 f (x ': xs) (y ': ys)
+
+----------------------------------------------------------------
+data Holds (c :: k -> Constraint) (x :: k) where
+  Holds :: c x => Holds c x
+
+class All (c :: k -> Constraint) (xs :: [k]) where
+  allHolds :: List1 (Holds c) xs
+
+instance All c '[] where allHolds = Nil1
+instance (All c xs, c x)
+  => All c (x ': xs) where allHolds = Cons1 Holds allHolds
+
+----------------------------------------------------------------
+-- TODO: cf the interface of <https://hackage.haskell.org/package/dlist-0.7.1.2/docs/Data-DList.html>
+-- | A difference-list variant of 'List1'.
+newtype DList1 a xs =
+    DList1 { unDList1 :: forall ys. List1 a ys -> List1 a (xs ++ ys) }
+
+
+toList1 :: DList1 a xs -> List1 a xs
+toList1 dx@(DList1 xs) =
+    case eqAppendIdentity dx of
+    Refl -> xs Nil1
+
+fromList1 :: List1 a xs -> DList1 a xs
+fromList1 xs = DList1 (append1 xs)
+    -- N.B., using @DList1 . append1@ doesn't type check
+
+dnil1 :: DList1 a '[]
+dnil1 = DList1 id
+
+dcons1 :: a x -> DList1 a xs -> DList1 a (x ': xs)
+dcons1 x (DList1 xs) = DList1 (Cons1 x . xs)
+
+-- TODO: for this access pattern it's prolly better to define some @DListR@ where the index is in the reverse order of the list itself (or else uses type-level snoc-lists); that way we can avoid needing to use 'eqAppendAssoc' at every step...
+dsnoc1 :: DList1 a xs -> a x -> DList1 a (xs ++ '[ x ])
+dsnoc1 dx@(DList1 xs) x =
+    DList1 $ \ys ->
+        case eqAppendAssoc dx (dsingleton1 x) ys of
+        Refl -> xs (Cons1 x ys)
+
+-- HACK: we need to give this a top-level definition rather than
+-- inlining it in order to prove that the resulting index is @[x]@
+-- rather than possibly some other @(x:xs)@. No, I'm not sure why
+-- GHC can't infer that...
+dsingleton1 :: a x -> DList1 a '[ x ]
+dsingleton1 x = DList1 (Cons1 x)
+
+dappend1 :: DList1 a xs -> DList1 a ys -> DList1 a (xs ++ ys)
+dappend1 dx@(DList1 xs) dy@(DList1 ys) =
+    DList1 $ \zs ->
+        case eqAppendAssoc dx dy zs of
+        Refl -> xs (ys zs)
+
+{-
+instance Show1 a => Show1 (DList1 a) where
+    showsPrec1 p xs =
+
+instance Show1 a => Show (DList1 a xs) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance JmEq1 a => JmEq1 (DList1 a) where
+    jmEq1 xs ys =
+
+instance Eq1 a => Eq1 (DList1 a) where
+    eq1 xs ys =
+
+instance Eq1 a => Eq (DList1 a xs) where
+    (==) = eq1
+
+instance Functor11 DList1 where
+    fmap11 f xs =
+
+instance Foldable11 DList1 where
+    foldMap11 f xs =
+
+instance Traversable11 DList1 where
+    traverse11 f xs =
+-}
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/Prelude.hs b/haskell/Language/Hakaru/Syntax/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Prelude.hs
@@ -0,0 +1,1699 @@
+{-# LANGUAGE TypeOperators
+           , KindSignatures
+           , DataKinds
+           , TypeFamilies
+           , GADTs
+           , FlexibleInstances
+           , NoImplicitPrelude
+           , ScopedTypeVariables
+           , FlexibleContexts
+           , Rank2Types
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.22
+-- |
+-- Module      :  Language.Hakaru.Syntax.Prelude
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- A replacement for Haskell's Prelude, using the familiar symbols
+-- in order to construct 'AST's and 'ABT's. This is only necessary
+-- if we want to use Hakaru as an embedded language in Haskell, but
+-- it also provides some examples of how to use the infrastructure.
+--
+-- TODO: is there a way to get rid of the need to specify @'[]@ everywhere in here? Some sort of distinction between the Var vs the Open parts of View?
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.Prelude
+    (
+    -- * Basic syntax
+    -- ** Types and coercions
+      ann_, triv, memo
+    , coerceTo_, fromProb, nat2int, nat2prob, fromInt, nat2real
+    , unsafeFrom_, unsafeProb, unsafeProbFraction, unsafeProbFraction_, unsafeProbSemiring, unsafeProbSemiring_
+    -- ** Numeric literals
+    , literal_, nat_, int_, prob_, real_
+    , fromRational, half, third
+    -- ** Booleans
+    , true, false, bool_, if_
+    , not, (&&), and, (||), or, nand, nor
+    -- ** Equality and ordering
+    , (==), (/=), (<), (<=), (>), (>=), min, minimum, max, maximum
+    -- ** Semirings
+    , zero, zero_, one, one_, (+), sum, (*), prod, (^), square
+    , unsafeMinusNat, unsafeMinusProb, unsafeMinus, unsafeMinus_
+    , unsafeDiv, unsafeDiv_
+    -- ** Rings
+    , (-), negate, negative, abs, abs_, signum
+    -- ** Fractional
+    , (/), recip, (^^)
+    -- ** Radical
+    , sqrt, thRootOf
+    -- ** Integration
+    , integrate, summate, product
+    -- ** Continuous
+    , RealProb(..), Integrable(..)
+    , betaFunc
+    , log, logBase
+    , negativeInfinity
+    -- *** Trig
+    , sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh
+    -- Choose
+    , choose
+    -- *** coercions-that-compute
+    , floor
+    
+    -- * Measures
+    -- ** Abstract nonsense
+    , dirac, (<$>), (<*>), (<*), (*>), (>>=), (>>), bindx, liftM2
+    -- ** Linear operators
+    , superpose, (<|>)
+    , weight, withWeight, weightedDirac
+    , reject, guard, withGuard
+    -- ** Measure operators
+    -- | When two versions of the same operator are given, the one without the prime builds an AST using the built-in operator, whereas the one with the prime is a default definition in terms of more primitive measure operators.
+    , lebesgue, lebesgue'
+    , counting
+    , densityCategorical, categorical, categorical'
+    , densityUniform, uniform, uniform'
+    , densityNormal, normal, normal'
+    , densityPoisson, poisson, poisson'
+    , densityGamma, gamma, gamma'
+    , densityBeta, beta, beta', beta''
+    , plateWithVar, plate, plate'
+    , chain, chain'
+    , invgamma
+    , exponential
+    , chi2
+    , cauchy
+    , laplace
+    , studentT
+    , weibull
+    , bern
+    , mix
+    , binomial
+    , negativeBinomial
+    , geometric
+    , multinomial
+    , dirichlet
+
+    -- * Data types (other than booleans)
+    , datum_
+    -- * Case and Branch
+    , case_, branch
+    -- ** HUnit
+    , unit
+    -- ** HPair
+    , pair, pair_, unpair, fst, snd, swap
+    -- ** HEither
+    , left, right, uneither
+    -- ** HMaybe
+    , nothing, just, maybe, unmaybe
+    -- ** HList
+    , nil, cons, list
+
+    -- * Lambda calculus
+    , lam, lamWithVar, let_, letM
+    , app, app2, app3
+
+    -- * Arrays
+    , empty, arrayWithVar, array, arrayLit, (!), size, reduce
+    , sumV, summateV, appendV, mapV, mapWithIndex, normalizeV, constV, unitV, zipWithV
+
+    -- * Implementation details
+    , primOp0_, primOp1_, primOp2_, primOp3_
+    , arrayOp0_, arrayOp1_, arrayOp2_, arrayOp3_
+    , measure0_, measure1_, measure2_
+    , unsafeNaryOp_, naryOp_withIdentity, naryOp2_
+
+    -- * Reducers
+    , bucket, r_fanout, r_index, r_split, r_nop, r_add
+
+    ) where
+
+-- TODO: implement and use Prelude's fromInteger and fromRational, so we can use numeric literals!
+import Prelude (Maybe(..), Functor(..), Bool(..), Integer, Rational, ($), flip, const, error)
+import qualified Prelude
+import           Data.Sequence       (Seq)
+import qualified Data.Sequence       as Seq
+import qualified Data.Text           as Text
+import           Data.List.NonEmpty  (NonEmpty(..))
+import qualified Data.List.NonEmpty  as L
+import           Data.Semigroup      (Semigroup(..))
+import           Control.Category    (Category(..))
+import           Control.Monad.Fix
+
+import Data.Number.Natural
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing (Sing(..), SingI(sing), sUnPair, sUnEither, sUnMaybe, sUnMeasure, sUnArray)
+import Language.Hakaru.Syntax.TypeOf
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.ABT hiding (View(..))
+
+----------------------------------------------------------------
+----- Helper combinators for defining our EDSL
+{-
+Below we implement a lot of simple optimizations; however, these
+optimizations only apply if the client uses the type class methods
+to produce the AST. We should implement a stand-alone function which
+performs these sorts of optimizations, as a program transformation.
+-}
+-- TODO: constant propogation
+
+-- TODO: NBE to get rid of administrative redexes.
+app :: (ABT Term abt) => abt '[] (a ':-> b) -> abt '[] a -> abt '[] b
+app e1 e2 = syn (App_ :$ e1 :* e2 :* End)
+
+app2 :: (ABT Term abt) => abt '[] (a ':-> b ':-> c) -> abt '[] a -> abt '[] b -> abt '[] c
+app2 = (app .) . app
+
+app3 :: (ABT Term abt) => abt '[] (a ':-> b ':-> c ':-> d) -> abt '[] a -> abt '[] b -> abt '[] c -> abt '[] d
+app3 = (app2 .) . app
+
+triv :: TrivialABT Term '[] a -> TrivialABT Term '[] a
+triv = id
+
+memo :: MemoizedABT Term '[] a -> MemoizedABT Term '[] a
+memo = id
+
+primOp0_ :: (ABT Term abt) => PrimOp '[] a -> abt '[] a
+primOp0_ o = syn (PrimOp_ o :$ End)
+
+primOp1_
+    :: (ABT Term abt)
+    => PrimOp '[ a ] b
+    -> abt '[] a -> abt '[] b
+primOp1_ o e1 = syn (PrimOp_ o :$ e1 :* End)
+
+primOp2_
+    :: (ABT Term abt)
+    => PrimOp '[ a, b ] c
+    -> abt '[] a -> abt '[] b -> abt '[] c
+primOp2_ o e1 e2 = syn (PrimOp_ o :$ e1 :* e2 :* End)
+
+primOp3_
+    :: (ABT Term abt)
+    => PrimOp '[ a, b, c ] d
+    -> abt '[] a -> abt '[] b -> abt '[] c -> abt '[] d
+primOp3_ o e1 e2 e3 = syn (PrimOp_ o :$ e1 :* e2 :* e3 :* End)
+
+arrayOp0_ :: (ABT Term abt) => ArrayOp '[] a -> abt '[] a
+arrayOp0_ o = syn (ArrayOp_ o :$ End)
+
+arrayOp1_
+    :: (ABT Term abt)
+    => ArrayOp '[ a ] b
+    -> abt '[] a -> abt '[] b
+arrayOp1_ o e1 = syn (ArrayOp_ o :$ e1 :* End)
+
+arrayOp2_
+    :: (ABT Term abt)
+    => ArrayOp '[ a, b ] c
+    -> abt '[] a -> abt '[] b -> abt '[] c
+arrayOp2_ o e1 e2 = syn (ArrayOp_ o :$ e1 :* e2 :* End)
+
+arrayOp3_
+    :: (ABT Term abt)
+    => ArrayOp '[ a, b, c ] d
+    -> abt '[] a -> abt '[] b -> abt '[] c -> abt '[] d
+arrayOp3_ o e1 e2 e3 = syn (ArrayOp_ o :$ e1 :* e2 :* e3 :* End)
+
+measure0_ :: (ABT Term abt) => MeasureOp '[] a -> abt '[] ('HMeasure a)
+measure0_ o = syn (MeasureOp_ o :$ End)
+
+measure1_
+    :: (ABT Term abt)
+    => MeasureOp '[ a ] b
+    -> abt '[] a -> abt '[] ('HMeasure b)
+measure1_ o e1 = syn (MeasureOp_ o :$ e1 :* End)
+
+measure2_
+    :: (ABT Term abt)
+    => MeasureOp '[ a, b ] c
+    -> abt '[] a -> abt '[] b -> abt '[] ('HMeasure c)
+measure2_ o e1 e2 = syn (MeasureOp_ o :$ e1 :* e2 :* End)
+
+
+-- N.B., we don't take advantage of commutativity, for more predictable
+-- AST outputs. However, that means we can end up being slow...
+--
+-- N.B., we also don't try to eliminate the identity elements or
+-- do cancellations because (a) it's undecidable in general, and
+-- (b) that's prolly better handled as a post-processing simplification
+-- step
+--
+-- TODO: generalize these two from [] to Foldable?
+
+-- | Apply an n-ary operator to a list. This smart constructor will
+-- flatten nested calls to the same operator. And if there is exactly
+-- one element in the flattened sequence, then it will remove the
+-- 'NaryOp_' node from the AST.
+--
+-- N.B., if the flattened sequence is empty, this smart constructor
+-- will return an AST which applies the operator to the empty
+-- sequence; which may or may not be unsafe. If the operator has
+-- an identity element, then it's fine (operating on the empty
+-- sequence evaluates to the identity element). However, if the
+-- operator doesn't have an identity, then the generated code will
+-- error whenever we attempt to run it.
+unsafeNaryOp_ :: (ABT Term abt) => NaryOp a -> [abt '[] a] -> abt '[] a
+unsafeNaryOp_ o = naryOp_withIdentity o (syn $ NaryOp_ o Seq.empty)
+
+
+-- | A variant of 'unsafeNaryOp_' which will replace operating over
+-- the empty sequence with a specified identity element. The produced
+-- AST has the same semantics, we're just preemptively
+-- evaluating\/simplifying the 'NaryOp_' node of the AST.
+--
+-- N.B., this function does not simplify away the identity element
+-- if it exists in the flattened sequence! We should add that in
+-- the future.
+naryOp_withIdentity
+    :: (ABT Term abt) => NaryOp a -> abt '[] a -> [abt '[] a] -> abt '[] a
+naryOp_withIdentity o i = go Seq.empty
+    where
+    go es [] =
+        case Seq.viewl es of
+        Seq.EmptyL   -> i
+        e Seq.:< es' ->
+            case Seq.viewl es' of
+            Seq.EmptyL -> e
+            _          -> syn $ NaryOp_ o es
+    go es (e:es') =
+        case matchNaryOp o e of
+        Nothing   -> go (es Seq.|> e)    es'
+        Just es'' -> go (es Seq.>< es'') es'
+
+
+-- TODO: is this actually worth breaking out, performance-wise? Or should we simply use:
+-- > naryOp2_ o x y = unsafeNaryOp_ o [x,y]
+naryOp2_
+    :: (ABT Term abt) => NaryOp a -> abt '[] a -> abt '[] a -> abt '[] a
+naryOp2_ o x y =
+    case (matchNaryOp o x, matchNaryOp o y) of
+    (Just xs, Just ys) -> syn . NaryOp_ o $ xs Seq.>< ys
+    (Just xs, Nothing) -> syn . NaryOp_ o $ xs Seq.|> y
+    (Nothing, Just ys) -> syn . NaryOp_ o $ x  Seq.<| ys
+    (Nothing, Nothing) -> syn . NaryOp_ o $ x  Seq.<| Seq.singleton y
+
+
+matchNaryOp
+    :: (ABT Term abt) => NaryOp a -> abt '[] a -> Maybe (Seq (abt '[] a))
+matchNaryOp o e =
+    caseVarSyn e
+        (const Nothing)
+        $ \t ->
+            case t of
+            NaryOp_ o' xs | o' Prelude.== o -> Just xs
+            _ -> Nothing
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+----- Now for the actual EDSL
+
+{-
+infixr 9 `pair`
+
+infixr 1 =<<
+infixr 1 <=<, >=>
+infixr 9 .
+infixr 0 $
+-}
+
+infixl 1 >>=, >>
+infixr 2 ||
+infixr 3 &&
+infix  4 ==, /=, <, <=, >, >=
+infixl 4 <$>, <*>, <*, *> -- <$
+infixl 6 +, -
+infixl 7 *, /
+infixr 8 ^, ^^, **
+-- infixl9 is the default when things are unspecified
+infixl 9 !, `app`, `thRootOf`
+
+-- TODO: some infix notation reminiscent of \"::\"
+-- TODO: actually do something with the type argument?
+ann_ :: (ABT Term abt) => Sing a -> abt '[] a -> abt '[] a
+ann_ _ e = e
+
+coerceTo_ :: (ABT Term abt) => Coercion a b -> abt '[] a -> abt '[] b
+coerceTo_ CNil e = e
+coerceTo_ c    e = syn (CoerceTo_ c :$ e :* End)
+
+unsafeFrom_ :: (ABT Term abt) => Coercion a b -> abt '[] b -> abt '[] a
+unsafeFrom_ CNil e = e
+unsafeFrom_ c    e = syn (UnsafeFrom_ c :$ e :* End)
+
+literal_ :: (ABT Term abt) => Literal a  -> abt '[] a
+literal_ = syn . Literal_
+bool_    :: (ABT Term abt) => Bool     -> abt '[] HBool
+bool_    = datum_ . (\b -> if b then dTrue else dFalse)
+nat_     :: (ABT Term abt) => Natural  -> abt '[] 'HNat
+nat_     = literal_ . LNat
+int_     :: (ABT Term abt) => Integer  -> abt '[] 'HInt
+int_     = literal_ . LInt
+prob_    :: (ABT Term abt) => NonNegativeRational -> abt '[] 'HProb
+prob_    = literal_ . LProb
+real_    :: (ABT Term abt) => Rational -> abt '[] 'HReal
+real_    = literal_ . LReal
+
+fromRational
+    :: forall abt a
+    . (ABT Term abt, HFractional_ a)
+    => Rational
+    -> abt '[] a
+fromRational =
+    case (hFractional :: HFractional a) of
+    HFractional_Prob -> prob_ . unsafeNonNegativeRational
+    HFractional_Real -> real_
+
+half :: forall abt a
+     .  (ABT Term abt, HFractional_ a) => abt '[] a
+half = fromRational (1 Prelude./ 2)
+
+third :: (ABT Term abt, HFractional_ a) => abt '[] a
+third = fromRational (1 Prelude./ 3)
+
+
+-- Boolean operators
+true, false :: (ABT Term abt) => abt '[] HBool
+true  = bool_ True
+false = bool_ False
+
+-- TODO: simplifications: distribution, constant-propogation
+-- TODO: do we really want to distribute /by default/? Clearly we'll want to do that in some optimization\/partial-evaluation pass, but do note that it makes terms larger in general...
+not :: (ABT Term abt) => abt '[] HBool -> abt '[] HBool
+not e =
+    Prelude.maybe (primOp1_ Not e) id
+        $ caseVarSyn e
+            (const Nothing)
+            $ \t ->
+                case t of
+                PrimOp_ Not :$ es' ->
+                    case es' of
+                    e' :* End -> Just e'
+                NaryOp_ And xs ->
+                    Just . syn . NaryOp_ Or  $ Prelude.fmap not xs
+                NaryOp_ Or xs ->
+                    Just . syn . NaryOp_ And $ Prelude.fmap not xs
+                NaryOp_ Xor xs ->
+                    Just . syn . NaryOp_ Iff $ Prelude.fmap not xs
+                NaryOp_ Iff xs ->
+                    Just . syn . NaryOp_ Xor $ Prelude.fmap not xs
+                Literal_ _ -> error "not: the impossible happened"
+                _ -> Nothing
+
+and, or :: (ABT Term abt) => [abt '[] HBool] -> abt '[] HBool
+and = naryOp_withIdentity And true
+or  = naryOp_withIdentity Or  false
+
+(&&), (||),
+    -- (</=>), (<==>), (==>), (<==), (\\), (//) -- TODO: better names?
+    nand, nor
+    :: (ABT Term abt) => abt '[] HBool -> abt '[] HBool -> abt '[] HBool
+(&&) = naryOp2_ And
+(||) = naryOp2_ Or
+-- (</=>) = naryOp2_ Xor
+-- (<==>) = naryOp2_ Iff
+-- (==>)  = primOp2_ Impl
+-- (<==)  = flip (==>)
+-- (\\)   = primOp2_ Diff
+-- (//)   = flip (\\)
+nand   = primOp2_ Nand
+nor    = primOp2_ Nor
+
+
+-- HEq & HOrder operators
+(==), (/=)
+    :: (ABT Term abt, HEq_ a) => abt '[] a -> abt '[] a -> abt '[] HBool
+(==) = primOp2_ $ Equal hEq
+(/=) = (not .) . (==)
+
+(<), (<=), (>), (>=)
+    :: (ABT Term abt, HOrd_ a) => abt '[] a -> abt '[] a -> abt '[] HBool
+(<)    = primOp2_ $ Less hOrd
+x <= y = not (x > y) -- or: @(x < y) || (x == y)@
+(>)    = flip (<)
+(>=)   = flip (<=)
+
+min, max :: (ABT Term abt, HOrd_ a) => abt '[] a -> abt '[] a -> abt '[] a
+min = naryOp2_ $ Min hOrd
+max = naryOp2_ $ Max hOrd
+
+-- TODO: if @a@ is bounded, then we can make these safe...
+minimum, maximum :: (ABT Term abt, HOrd_ a) => [abt '[] a] -> abt '[] a
+minimum = unsafeNaryOp_ $ Min hOrd
+maximum = unsafeNaryOp_ $ Max hOrd
+
+
+-- HSemiring operators
+(+), (*)
+    :: (ABT Term abt, HSemiring_ a) => abt '[] a -> abt '[] a -> abt '[] a
+(+) = naryOp2_ $ Sum  hSemiring
+(*) = naryOp2_ $ Prod hSemiring
+
+zero, one :: forall abt a. (ABT Term abt, HSemiring_ a) => abt '[] a
+zero = zero_ (hSemiring :: HSemiring a)
+one  = one_  (hSemiring :: HSemiring a)
+
+zero_, one_ :: (ABT Term abt) => HSemiring a -> abt '[] a
+zero_ HSemiring_Nat  = literal_ $ LNat  0
+zero_ HSemiring_Int  = literal_ $ LInt  0
+zero_ HSemiring_Prob = literal_ $ LProb 0
+zero_ HSemiring_Real = literal_ $ LReal 0
+one_  HSemiring_Nat  = literal_ $ LNat  1
+one_  HSemiring_Int  = literal_ $ LInt  1
+one_  HSemiring_Prob = literal_ $ LProb 1
+one_  HSemiring_Real = literal_ $ LReal 1
+
+-- TODO: add a smart constructor for @HSemiring_ a => Natural -> abt '[] a@ and\/or @HRing_ a => Integer -> abt '[] a@
+
+sum, prod :: (ABT Term abt, HSemiring_ a) => [abt '[] a] -> abt '[] a
+sum  = naryOp_withIdentity (Sum  hSemiring) zero
+prod = naryOp_withIdentity (Prod hSemiring) one
+
+{-
+sum, product :: (ABT Term abt, HSemiring_ a) => [abt '[] a] -> abt '[] a
+sum     = unsafeNaryOp_ $ Sum  hSemiring
+product = unsafeNaryOp_ $ Prod hSemiring
+-}
+
+
+-- TODO: simplifications
+(^) :: (ABT Term abt, HSemiring_ a)
+    => abt '[] a -> abt '[] 'HNat -> abt '[] a
+(^) = primOp2_ $ NatPow hSemiring
+
+-- TODO: this is actually safe, how can we capture that?
+-- TODO: is this type restruction actually helpful anywhere for us?
+-- If so, we ought to make this function polymorphic so that we can
+-- use it for non-HRing HSemirings too...
+square :: (ABT Term abt, HRing_ a) => abt '[] a -> abt '[] (NonNegative a)
+square e = unsafeFrom_ signed (e ^ nat_ 2)
+
+
+-- HRing operators
+(-) :: (ABT Term abt, HRing_ a) => abt '[] a -> abt '[] a -> abt '[] a
+x - y = x + negate y
+
+
+-- TODO: do we really want to distribute negation over addition /by
+-- default/? Clearly we'll want to do that in some
+-- optimization\/partial-evaluation pass, but do note that it makes
+-- terms larger in general...
+negate :: (ABT Term abt, HRing_ a) => abt '[] a -> abt '[] a
+negate e =
+    Prelude.maybe (primOp1_ (Negate hRing) e) id
+        $ caseVarSyn e
+            (const Nothing)
+            $ \t ->
+                case t of
+                -- TODO: need we case analyze the @HSemiring@?
+                NaryOp_ (Sum theSemi) xs ->
+                    Just . syn . NaryOp_ (Sum theSemi) $ Prelude.fmap negate xs
+                -- TODO: need we case analyze the @HRing@?
+                PrimOp_ (Negate _theRing) :$ es' ->
+                    case es' of
+                    e' :* End -> Just e'
+                _ -> Nothing
+
+
+-- TODO: test case: @negative . square@ simplifies away the intermediate coercions. (cf., normal')
+-- BUG: this can lead to ambiguity when used with the polymorphic functions of RealProb.
+-- | An occasionally helpful variant of 'negate'.
+negative :: (ABT Term abt, HRing_ a) => abt '[] (NonNegative a) -> abt '[] a
+negative = negate . coerceTo_ signed
+
+
+abs :: (ABT Term abt, HRing_ a) => abt '[] a -> abt '[] a
+abs = coerceTo_ signed . abs_
+
+abs_ :: (ABT Term abt, HRing_ a) => abt '[] a -> abt '[] (NonNegative a)
+abs_ e = 
+    Prelude.maybe (primOp1_ (Abs hRing) e) id
+        $ caseVarSyn e
+            (const Nothing)
+            $ \t ->
+                case t of
+                -- BUG: can't use the 'Signed' pattern synonym here, because that /requires/ the input to be (NonNegative a), instead of giving us the information that it is.
+                -- TODO: need we case analyze the @HRing@?
+                CoerceTo_ (CCons (Signed _theRing) CNil) :$ es' ->
+                    case es' of
+                    e' :* End -> Just e'
+                _ -> Nothing
+
+
+-- TODO: any obvious simplifications? idempotent?
+signum :: (ABT Term abt, HRing_ a) => abt '[] a -> abt '[] a
+signum = primOp1_ $ Signum hRing
+
+
+-- HFractional operators
+(/) :: (ABT Term abt, HFractional_ a) => abt '[] a -> abt '[] a -> abt '[] a
+x / y = x * recip y
+
+
+-- TODO: generalize this pattern so we don't have to repeat it...
+--
+-- TODO: do we really want to distribute reciprocal over multiplication
+-- /by default/? Clearly we'll want to do that in some
+-- optimization\/partial-evaluation pass, but do note that it makes
+-- terms larger in general...
+recip :: (ABT Term abt, HFractional_ a) => abt '[] a -> abt '[] a
+recip e0 =
+    Prelude.maybe (primOp1_ (Recip hFractional) e0) id
+        $ caseVarSyn e0
+            (const Nothing)
+            $ \t0 ->
+                case t0 of
+                -- TODO: need we case analyze the @HSemiring@?
+                NaryOp_ (Prod theSemi) xs ->
+                    Just . syn . NaryOp_ (Prod theSemi) $ Prelude.fmap recip xs
+                -- TODO: need we case analyze the @HFractional@?
+                PrimOp_ (Recip _theFrac) :$ es' ->
+                    case es' of
+                    e :* End -> Just e
+                _ -> Nothing
+
+
+-- TODO: simplifications
+-- TODO: a variant of 'if_' which gives us the evidence that the argument is non-negative, so we don't need to coerce or use 'abs_'
+(^^) :: (ABT Term abt, HFractional_ a)
+    => abt '[] a -> abt '[] 'HInt -> abt '[] a
+x ^^ y =
+    if_ (y < int_ 0)
+        (recip x ^ abs_ y)
+        (x ^ abs_ y)
+
+
+-- HRadical operators
+-- N.B., HProb is the only HRadical type (for now...)
+-- TODO: simplifications
+thRootOf
+    :: (ABT Term abt, HRadical_ a)
+    => abt '[] 'HNat -> abt '[] a -> abt '[] a
+n `thRootOf` x = primOp2_ (NatRoot hRadical) x n
+
+sqrt :: (ABT Term abt, HRadical_ a) => abt '[] a -> abt '[] a
+sqrt = (nat_ 2 `thRootOf`)
+
+{-
+-- TODO: simplifications
+(^+) :: (ABT Term abt, HRadical_ a)
+    => abt '[] a -> abt '[] 'HPositiveRational -> abt '[] a
+x ^+ y = casePositiveRational y $ \n d -> d `thRootOf` (x ^ n)
+
+(^*) :: (ABT Term abt, HRadical_ a)
+    => abt '[] a -> abt '[] 'HRational -> abt '[] a
+x ^* y = caseRational y $ \n d -> d `thRootOf` (x ^^ n)
+-}
+
+betaFunc
+    :: (ABT Term abt) => abt '[] 'HProb -> abt '[] 'HProb -> abt '[] 'HProb
+betaFunc = primOp2_ BetaFunc
+
+
+integrate
+    :: (ABT Term abt)
+    => abt '[] 'HReal
+    -> abt '[] 'HReal
+    -> (abt '[] 'HReal -> abt '[] 'HProb)
+    -> abt '[] 'HProb
+integrate lo hi f =
+    syn (Integrate :$ lo :* hi :* binder Text.empty sing f :* End)
+
+summate
+    :: (ABT Term abt, HDiscrete_ a, HSemiring_ b, SingI a)
+    => abt '[] a
+    -> abt '[] a
+    -> (abt '[] a -> abt '[] b)
+    -> abt '[] b
+summate lo hi f =
+    syn (Summate hDiscrete hSemiring
+         :$ lo :* hi :* binder Text.empty sing f :* End)
+
+product
+    :: (ABT Term abt, HDiscrete_ a, HSemiring_ b, SingI a)
+    => abt '[] a
+    -> abt '[] a
+    -> (abt '[] a -> abt '[] b)
+    -> abt '[] b
+product lo hi f =
+    syn (Product hDiscrete hSemiring
+         :$ lo :* hi :* binder Text.empty sing f :* End)
+
+
+class Integrable (a :: Hakaru) where
+    infinity :: (ABT Term abt) => abt '[] a
+
+instance Integrable 'HNat where
+    infinity = primOp0_ (Infinity HIntegrable_Nat)
+
+instance Integrable 'HInt where
+    infinity = nat2int $ primOp0_ (Infinity HIntegrable_Nat)
+
+instance Integrable 'HProb where
+    infinity = primOp0_ (Infinity HIntegrable_Prob)
+
+instance Integrable 'HReal where
+    infinity = fromProb $ primOp0_ (Infinity HIntegrable_Prob)
+
+-- HACK: we define this class in order to gain more polymorphism;
+-- but, will it cause type inferencing issues? Excepting 'log'
+-- (which should be moved out of the class) these are all safe.
+class RealProb (a :: Hakaru) where
+    (**) :: (ABT Term abt) => abt '[] 'HProb -> abt '[] a -> abt '[] 'HProb
+    exp  :: (ABT Term abt) => abt '[] a -> abt '[] 'HProb
+    erf  :: (ABT Term abt) => abt '[] a -> abt '[] a
+    pi   :: (ABT Term abt) => abt '[] a
+    gammaFunc :: (ABT Term abt) => abt '[] a -> abt '[] 'HProb
+
+instance RealProb 'HReal where
+    (**)      = primOp2_ RealPow
+    exp       = primOp1_ Exp
+    erf       = primOp1_ $ Erf hContinuous
+    pi        = fromProb $ primOp0_ Pi
+    gammaFunc = primOp1_ GammaFunc
+
+instance RealProb 'HProb where
+    x ** y    = primOp2_ RealPow x $ fromProb y
+    exp       = primOp1_ Exp . fromProb
+    erf       = primOp1_ $ Erf hContinuous
+    pi        = primOp0_ Pi
+    gammaFunc = primOp1_ GammaFunc . fromProb
+
+log  :: (ABT Term abt) => abt '[] 'HProb -> abt '[] 'HReal
+log = primOp1_ Log
+
+logBase
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] 'HReal
+logBase b x = log x / log b -- undefined when b == 1
+
+sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh
+    :: (ABT Term abt) => abt '[] 'HReal -> abt '[] 'HReal
+sin    = primOp1_ Sin
+cos    = primOp1_ Cos
+tan    = primOp1_ Tan
+asin   = primOp1_ Asin
+acos   = primOp1_ Acos
+atan   = primOp1_ Atan
+sinh   = primOp1_ Sinh
+cosh   = primOp1_ Cosh
+tanh   = primOp1_ Tanh
+asinh  = primOp1_ Asinh
+acosh  = primOp1_ Acosh
+atanh  = primOp1_ Atanh
+
+choose
+    :: (ABT Term abt) => abt '[] 'HNat -> abt '[] 'HNat -> abt '[] 'HNat
+choose = primOp2_ Choose
+
+floor :: (ABT Term abt) => abt '[] 'HProb -> abt '[] 'HNat
+floor  = primOp1_ Floor
+
+----------------------------------------------------------------
+datum_
+    :: (ABT Term abt)
+    => Datum (abt '[]) (HData' t)
+    -> abt '[] (HData' t)
+datum_ = syn . Datum_
+
+case_
+     :: (ABT Term abt)
+     => abt '[] a
+     -> [Branch a abt b]
+     -> abt '[] b
+case_ e bs = syn (Case_ e bs)
+
+branch
+    :: (ABT Term abt)
+    => Pattern xs a
+    -> abt xs b
+    -> Branch a abt b
+branch = Branch
+
+unit :: (ABT Term abt) => abt '[] HUnit
+unit = datum_ dUnit
+
+pair
+    :: (ABT Term abt, SingI a, SingI b)
+    => abt '[] a -> abt '[] b -> abt '[] (HPair a b)
+pair = (datum_ .) . dPair
+
+
+pair_
+    :: (ABT Term abt)
+    => Sing a
+    -> Sing b
+    -> abt '[] a
+    -> abt '[] b
+    -> abt '[] (HPair a b)
+pair_ a b = (datum_ .) . dPair_ a b
+
+
+unpair
+    :: forall abt a b c
+    .  (ABT Term abt)
+    => abt '[] (HPair a b)
+    -> (abt '[] a -> abt '[] b -> abt '[] c)
+    -> abt '[] c
+unpair e hoas =
+    let (aTyp,bTyp) = sUnPair $ typeOf e
+        body        = hoas (var a) (var b)
+        inc x       = 1 Prelude.+ x
+        a           = Variable Text.empty (nextBind body)         aTyp
+        b           = Variable Text.empty (inc . nextBind $ body) bTyp
+    in case_ e
+        [Branch (pPair PVar PVar)
+           (bind a (bind b body))
+        ]
+
+fst :: (ABT Term abt)
+    => abt '[] (HPair a b)
+    -> abt '[] a
+fst p = unpair p (\x _ -> x)
+
+snd :: (ABT Term abt)
+    => abt '[] (HPair a b)
+    -> abt '[] b
+snd p = unpair p (\_ y -> y)
+
+swap :: (ABT Term abt, SingI a, SingI b)
+    => abt '[] (HPair a b)
+    -> abt '[] (HPair b a)
+swap ab = unpair ab (flip pair)
+
+left
+    :: (ABT Term abt, SingI a, SingI b)
+    => abt '[] a -> abt '[] (HEither a b)
+left = datum_ . dLeft
+
+right
+    :: (ABT Term abt, SingI a, SingI b)
+    => abt '[] b -> abt '[] (HEither a b)
+right = datum_ . dRight
+
+uneither
+    :: (ABT Term abt)
+    => abt '[] (HEither a b)
+    -> (abt '[] a -> abt '[] c)
+    -> (abt '[] b -> abt '[] c)
+    -> abt '[] c
+uneither e l r =
+    let (a,b) = sUnEither $ typeOf e
+    in case_ e
+        [ Branch (pLeft  PVar) (binder Text.empty a l)
+        , Branch (pRight PVar) (binder Text.empty b r)
+        ]
+
+if_ :: (ABT Term abt)
+    => abt '[] HBool
+    -> abt '[] a
+    -> abt '[] a
+    -> abt '[] a
+if_ b t f =
+    case_ b
+     [ Branch pTrue  t
+     , Branch pFalse f
+     ]
+
+nil :: (ABT Term abt, SingI a) => abt '[] (HList a)
+nil = datum_ dNil
+
+cons
+    :: (ABT Term abt, SingI a)
+    => abt '[] a -> abt '[] (HList a) -> abt '[] (HList a)
+cons = (datum_ .) . dCons
+
+list :: (ABT Term abt, SingI a) => [abt '[] a] -> abt '[] (HList a)
+list = Prelude.foldr cons nil
+
+nothing :: (ABT Term abt, SingI a) => abt '[] (HMaybe a)
+nothing = datum_ dNothing
+
+just :: (ABT Term abt, SingI a) => abt '[] a -> abt '[] (HMaybe a)
+just = datum_ . dJust
+
+maybe :: (ABT Term abt, SingI a) => Maybe (abt '[] a) -> abt '[] (HMaybe a)
+maybe = Prelude.maybe nothing just
+
+unmaybe
+    :: (ABT Term abt)
+    => abt '[] (HMaybe a)
+    -> abt '[] b
+    -> (abt '[] a -> abt '[] b)
+    -> abt '[] b
+unmaybe e n j = 
+    case_ e
+     [ Branch pNothing     n
+     , Branch (pJust PVar) (binder Text.empty (sUnMaybe $ typeOf e) j)
+     ]
+
+unsafeProb :: (ABT Term abt) => abt '[] 'HReal -> abt '[] 'HProb
+unsafeProb = unsafeFrom_ signed
+
+fromProb   :: (ABT Term abt) => abt '[] 'HProb -> abt '[] 'HReal
+fromProb   = coerceTo_ signed
+
+nat2int    :: (ABT Term abt) => abt '[] 'HNat -> abt '[] 'HInt
+nat2int    = coerceTo_ signed
+
+fromInt    :: (ABT Term abt) => abt '[] 'HInt  -> abt '[] 'HReal
+fromInt    = coerceTo_ continuous
+
+nat2prob   :: (ABT Term abt) => abt '[] 'HNat  -> abt '[] 'HProb
+nat2prob   = coerceTo_ continuous
+
+nat2real   :: (ABT Term abt) => abt '[] 'HNat  -> abt '[] 'HReal
+nat2real   = coerceTo_ (continuous . signed)
+
+{- -- Uncomment only if we actually end up needing this anywhere
+class FromNat (a :: Hakaru) where
+    fromNat :: (ABT Term abt) => abt '[] 'HNat  -> abt '[] a
+
+instance FromNat 'HNat  where fromNat = id
+instance FromNat 'HInt  where fromNat = nat2int
+instance FromNat 'HProb where fromNat = nat2prob
+instance FromNat 'HReal where fromNat = fromProb . nat2prob
+-}
+
+unsafeProbFraction
+    :: forall abt a
+    .  (ABT Term abt, HFractional_ a)
+    => abt '[] a
+    -> abt '[] 'HProb
+unsafeProbFraction e =
+    unsafeProbFraction_ (hFractional :: HFractional a) e
+
+unsafeProbFraction_
+    :: (ABT Term abt)
+    => HFractional a
+    -> abt '[] a
+    -> abt '[] 'HProb
+unsafeProbFraction_ HFractional_Prob = id
+unsafeProbFraction_ HFractional_Real = unsafeProb
+
+unsafeProbSemiring
+    :: forall abt a
+    .  (ABT Term abt, HSemiring_ a)
+    => abt '[] a
+    -> abt '[] 'HProb
+unsafeProbSemiring e =
+    unsafeProbSemiring_ (hSemiring :: HSemiring a) e
+
+unsafeProbSemiring_
+    :: (ABT Term abt)
+    => HSemiring a
+    -> abt '[] a
+    -> abt '[] 'HProb
+unsafeProbSemiring_ HSemiring_Nat  = nat2prob
+unsafeProbSemiring_ HSemiring_Int  = coerceTo_ continuous . unsafeFrom_ signed
+unsafeProbSemiring_ HSemiring_Prob = id
+unsafeProbSemiring_ HSemiring_Real = unsafeProb
+
+
+negativeInfinity :: ( ABT Term abt
+                    , HRing_ a
+                    , Integrable a)
+                 => abt '[] a
+negativeInfinity = negate infinity
+
+-- instance (ABT Term abt) => Lambda abt where
+-- 'app' already defined
+
+-- TODO: use 'typeOf' to remove the 'SingI' requirement somehow
+-- | A variant of 'lamWithVar' for automatically computing the type
+-- via 'sing'.
+lam :: (ABT Term abt, SingI a)
+    => (abt '[] a -> abt '[] b)
+    -> abt '[] (a ':-> b)
+lam = lamWithVar Text.empty sing
+
+-- | Create a lambda abstraction. The first two arguments give the
+-- hint and type of the lambda-bound variable in the result. If you
+-- want to automatically fill those in, then see 'lam'.
+lamWithVar
+    :: (ABT Term abt)
+    => Text.Text
+    -> Sing a
+    -> (abt '[] a -> abt '[] b)
+    -> abt '[] (a ':-> b)
+lamWithVar hint typ f = syn (Lam_ :$ binder hint typ f :* End)
+
+{-
+-- some test cases to make sure we tied-the-knot successfully:
+> let
+    lam :: (ABT Term abt)
+        => String
+        -> Sing a
+        -> (abt '[] a -> abt '[] b)
+        -> abt '[] (a ':-> b)
+    lam name typ f = syn (Lam_ :$ binder name typ f :* End)
+> lam "x" SInt (\x -> x) :: TrivialABT Term ('HInt ':-> 'HInt)
+> lam "x" SInt (\x -> lam "y" SInt $ \y -> x < y) :: TrivialABT Term ('HInt ':-> 'HInt ':-> 'HBool)
+-}
+
+-- TODO: make this smarter so that if the @e@ is already a variable then we just plug it into @f@ instead of introducing the trivial let-binding.
+let_
+    :: (ABT Term abt)
+    => abt '[] a
+    -> (abt '[] a -> abt '[] b)
+    -> abt '[] b
+let_ e f = syn (Let_ :$ e :* binder Text.empty (typeOf e) f :* End)
+
+letM :: (Functor m, MonadFix m, ABT Term abt)
+     => abt '[] a
+     -> (abt '[] a -> m (abt '[] b))
+     -> m (abt '[] b)
+letM e f = fmap (\ body -> syn $ Let_ :$ e :* body :* End) (binderM Text.empty t f)
+  where t = typeOf e
+
+----------------------------------------------------------------
+array
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> (abt '[] 'HNat -> abt '[] a)
+    -> abt '[] ('HArray a)
+array n =
+    syn . Array_ n . binder Text.empty sing        
+
+arrayWithVar
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> Variable 'HNat
+    -> abt '[] a
+    -> abt '[] ('HArray a)
+arrayWithVar n x body =
+    syn $ Array_ n (bind x body)
+
+arrayLit
+    :: (ABT Term abt)
+    => [abt '[] a]
+    -> abt '[] ('HArray a)
+arrayLit = syn . ArrayLiteral_
+
+empty :: (ABT Term abt, SingI a) => abt '[] ('HArray a)
+empty = syn (Empty_ sing)
+
+(!) :: (ABT Term abt)
+    => abt '[] ('HArray a) -> abt '[] 'HNat -> abt '[] a
+(!) e = arrayOp2_ (Index . sUnArray $ typeOf e) e
+
+size :: (ABT Term abt) => abt '[] ('HArray a) -> abt '[] 'HNat
+size e = arrayOp1_ (Size . sUnArray $ typeOf e) e
+
+reduce
+    :: (ABT Term abt)
+    => (abt '[] a -> abt '[] a -> abt '[] a)
+    -> abt '[] a
+    -> abt '[] ('HArray a)
+    -> abt '[] a
+reduce f e =
+    let a  = typeOf e
+        f' = lamWithVar Text.empty a $ \x ->
+                lamWithVar Text.empty a $ \y -> f x y
+    in arrayOp3_ (Reduce a) f' e
+
+-- TODO: better names for all these. The \"V\" suffix doesn't make sense anymore since we're calling these arrays, not vectors...
+-- TODO: bust these all out into their own place, since the API for arrays is gonna be huge
+
+sumV :: (ABT Term abt, HSemiring_ a)
+    => abt '[] ('HArray a) -> abt '[] a
+sumV = reduce (+) zero -- equivalent to summateV if @a ~ 'HProb@
+
+summateV :: (ABT Term abt) => abt '[] ('HArray 'HProb) -> abt '[] 'HProb
+summateV x =
+    summate (nat_ 0) (size x)
+        (\i -> x ! i)
+
+-- TODO: a variant of 'if_' for giving us evidence that the subtraction is sound.
+
+unsafeMinusNat
+    :: (ABT Term abt) => abt '[] 'HNat -> abt '[] 'HNat -> abt '[] 'HNat
+unsafeMinusNat x y = unsafeFrom_ signed (nat2int x - nat2int y)
+
+unsafeMinusProb
+    :: (ABT Term abt) => abt '[] 'HProb -> abt '[] 'HProb -> abt '[] 'HProb
+unsafeMinusProb x y = unsafeProb (fromProb x - fromProb y)
+
+-- | For any semiring we can attempt subtraction by lifting to a
+-- ring, subtracting there, and then lowering back to the semiring.
+-- Of course, the lowering step may well fail.
+unsafeMinus
+    :: (ABT Term abt, HSemiring_ a) => abt '[] a -> abt '[] a -> abt '[] a
+unsafeMinus = unsafeMinus_ hSemiring
+
+-- | A variant of 'unsafeMinus' for explicitly passing the semiring
+-- instance.
+unsafeMinus_
+    :: (ABT Term abt) => HSemiring a -> abt '[] a -> abt '[] a -> abt '[] a
+unsafeMinus_ theSemi =
+    signed_HSemiring theSemi $ \c ->
+        let lift  = coerceTo_   c
+            lower = unsafeFrom_ c
+        in \e1 e2 -> lower (lift e1 - lift e2)
+
+-- TODO: move to Coercion.hs?
+-- | For any semiring, return a coercion to its ring completion.
+-- Because this completion is existentially quantified, we must use
+-- a cps trick to eliminate the existential.
+signed_HSemiring
+    :: HSemiring a -> (forall b. (HRing_ b) => Coercion a b -> r) -> r
+signed_HSemiring c k =
+    case c of
+    HSemiring_Nat  -> k $ singletonCoercion (Signed HRing_Int)
+    HSemiring_Int  -> k CNil
+    HSemiring_Prob -> k $ singletonCoercion (Signed HRing_Real)
+    HSemiring_Real -> k CNil
+
+-- | For any semiring we can attempt division by lifting to a
+-- semifield, dividing there, and then lowering back to the semiring.
+-- Of course, the lowering step may well fail.
+unsafeDiv
+    :: (ABT Term abt, HSemiring_ a) => abt '[] a -> abt '[] a -> abt '[] a
+unsafeDiv = unsafeDiv_ hSemiring
+
+-- | A variant of 'unsafeDiv' for explicitly passing the semiring
+-- instance.
+unsafeDiv_
+    :: (ABT Term abt) => HSemiring a -> abt '[] a -> abt '[] a -> abt '[] a
+unsafeDiv_ theSemi =
+    continuous_HSemiring theSemi $ \c ->
+        let lift  = coerceTo_   c
+            lower = unsafeFrom_ c
+        in \e1 e2 -> lower (lift e1 / lift e2)
+
+-- TODO: move to Coercion.hs?
+-- | For any semiring, return a coercion to its semifield completion.
+-- Because this completion is existentially quantified, we must use
+-- a cps trick to eliminate the existential.
+continuous_HSemiring
+    :: HSemiring a -> (forall b. (HFractional_ b) => Coercion a b -> r) -> r
+continuous_HSemiring c k =
+    case c of
+    HSemiring_Nat  -> k $ singletonCoercion (Continuous HContinuous_Prob)
+    HSemiring_Int  -> k $ singletonCoercion (Continuous HContinuous_Real)
+    HSemiring_Prob -> k CNil
+    HSemiring_Real -> k CNil
+
+
+appendV
+    :: (ABT Term abt)
+    => abt '[] ('HArray a) -> abt '[] ('HArray a) -> abt '[] ('HArray a)
+appendV v1 v2 =
+    array (size v1 + size v2) $ \i ->
+        if_ (i < size v1)
+            (v1 ! i)
+            (v2 ! (i `unsafeMinusNat` size v1))
+
+mapWithIndex
+    :: (ABT Term abt)
+    => (abt '[] 'HNat -> abt '[] a -> abt '[] b)
+    -> abt '[] ('HArray a)
+    -> abt '[] ('HArray b)
+mapWithIndex f v = array (size v) $ \i -> f i (v ! i)
+
+mapV
+    :: (ABT Term abt)
+    => (abt '[] a -> abt '[] b)
+    -> abt '[] ('HArray a)
+    -> abt '[] ('HArray b)
+mapV f v = array (size v) $ \i -> f (v ! i)
+
+normalizeV
+    :: (ABT Term abt)
+    => abt '[] ('HArray 'HProb)
+    -> abt '[] ('HArray 'HProb)
+normalizeV x = mapV (/ sumV x) x
+
+constV
+    :: (ABT Term abt) => abt '[] 'HNat -> abt '[] b -> abt '[] ('HArray b)
+constV n c = array n (const c)
+
+unitV
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> abt '[] 'HNat
+    -> abt '[] ('HArray 'HProb)
+unitV s i = array s (\j -> if_ (i == j) (prob_ 1) (prob_ 0))
+
+zipWithV
+    :: (ABT Term abt)
+    => (abt '[] a -> abt '[] b -> abt '[] c)
+    -> abt '[] ('HArray a)
+    -> abt '[] ('HArray b)
+    -> abt '[] ('HArray c)
+zipWithV f v1 v2 =
+    array (size v1) (\i -> f (v1 ! i) (v2 ! i))
+
+----------------------------------------------------------------
+
+r_fanout
+    :: (ABT Term abt)
+    => Reducer abt xs a
+    -> Reducer abt xs b
+    -> Reducer abt xs (HPair a b)
+r_fanout = Red_Fanout
+
+r_index
+    :: (Binders Term abt xs as)
+    => (as -> abt '[] 'HNat)
+    -> ((abt '[] 'HNat, as) -> abt '[] 'HNat)
+    -> Reducer abt ( 'HNat ': xs) a
+    -> Reducer abt xs ('HArray a)
+r_index n f = Red_Index (binders n) (binders f)
+
+r_split
+    :: (Binders Term abt xs as)
+    => ((abt '[] 'HNat, as) -> abt '[] HBool)
+    -> Reducer abt xs a
+    -> Reducer abt xs b
+    -> Reducer abt xs (HPair a b)
+r_split b = Red_Split (binders b)
+
+r_nop :: (ABT Term abt) => Reducer abt xs HUnit
+r_nop = Red_Nop
+
+r_add
+    :: (Binders Term abt xs as, HSemiring_ a)
+    => ((abt '[] 'HNat, as) -> abt '[] a)
+    -> Reducer abt xs a
+r_add f = Red_Add hSemiring (binders f)
+
+bucket
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> abt '[] 'HNat
+    -> Reducer abt '[] a
+    -> abt '[] a
+bucket i j r = syn $ Bucket i j r
+
+----------------------------------------------------------------
+(>>=)
+    :: (ABT Term abt)
+    => abt '[] ('HMeasure a)
+    -> (abt '[] a -> abt '[] ('HMeasure b))
+    -> abt '[] ('HMeasure b)
+m >>= f =
+    syn (MBind :$ m
+               :* binder Text.empty (sUnMeasure $ typeOf m) f
+               :* End)
+
+
+dirac :: (ABT Term abt) => abt '[] a -> abt '[] ('HMeasure a)
+dirac e1 = syn (Dirac :$ e1 :* End)
+
+
+-- TODO: can we use let-binding instead of (>>=)-binding (i.e., for when the dirac is immediately (>>=)-bound again...)?
+(<$>)
+    :: (ABT Term abt, SingI a)
+    => (abt '[] a -> abt '[] b)
+    -> abt '[] ('HMeasure a)
+    -> abt '[] ('HMeasure b)
+f <$> m = m >>= dirac . f
+
+-- | N.B, this function may introduce administrative redexes.
+-- Moreover, it's not clear that we should even allow the type
+-- @'HMeasure (a ':-> b)@!
+(<*>)
+    :: (ABT Term abt, SingI a, SingI b)
+    => abt '[] ('HMeasure (a ':-> b))
+    -> abt '[] ('HMeasure a)
+    -> abt '[] ('HMeasure b)
+mf <*> mx = mf >>= \f -> app f <$> mx
+
+-- TODO: ensure that @dirac a *> n@ simplifies to just @n@, regardless of @a@ but especially when @a = unit@.
+(*>), (>>)
+    :: (ABT Term abt, SingI a)
+    => abt '[] ('HMeasure a)
+    -> abt '[] ('HMeasure b)
+    -> abt '[] ('HMeasure b)
+m *> n = m >>= \_ -> n
+(>>) = (*>)
+
+-- TODO: ensure that @m <* dirac a@ simplifies to just @m@, regardless of @a@ but especially when @a = unit@.
+(<*)
+    :: (ABT Term abt, SingI a, SingI b)
+    => abt '[] ('HMeasure a)
+    -> abt '[] ('HMeasure b)
+    -> abt '[] ('HMeasure a)
+m <* n = m >>= \a -> n *> dirac a
+
+bindx
+    :: (ABT Term abt, SingI a, SingI b)
+    => abt '[] ('HMeasure a)
+    -> (abt '[] a -> abt '[] ('HMeasure b))
+    -> abt '[] ('HMeasure (HPair a b))
+m `bindx` f = m >>= \a -> pair a <$> f a
+
+-- Defined because using @(<$>)@ and @(<*>)@ would introduce administrative redexes
+liftM2
+    :: (ABT Term abt, SingI a, SingI b)
+    => (abt '[] a -> abt '[] b -> abt '[] c)
+    -> abt '[] ('HMeasure a)
+    -> abt '[] ('HMeasure b)
+    -> abt '[] ('HMeasure c)
+liftM2 f m n = m >>= \x -> f x <$> n
+
+lebesgue' :: (ABT Term abt) => abt '[] 'HReal -> abt '[] 'HReal -> abt '[] ('HMeasure 'HReal)
+lebesgue' = measure2_ Lebesgue 
+
+lebesgue :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
+lebesgue = lebesgue' negativeInfinity infinity 
+
+counting :: (ABT Term abt) => abt '[] ('HMeasure 'HInt)
+counting = measure0_ Counting
+
+-- TODO: make this smarter by collapsing nested @Superpose_@ similar to how we collapse nested NaryOps. Though beware, that could cause duplication of the computation for the probabilities\/weights; thus may want to only do it when the weights are constant values, or \"simplify\" things by generating let-bindings in order to share work.
+--
+-- TODO: can we make this smarter enough to handle empty lists?
+superpose
+    :: (ABT Term abt)
+    => NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
+    -> abt '[] ('HMeasure a)
+superpose = syn . Superpose_
+
+-- | The empty measure. Is called @fail@ in the Core Hakaru paper.
+reject
+    :: (ABT Term abt)
+    => (Sing ('HMeasure a))
+    -> abt '[] ('HMeasure a)
+reject = syn . Reject_
+
+-- | The sum of two measures. Is called @mplus@ in the Core Hakaru paper.
+(<|>) :: (ABT Term abt)
+      => abt '[] ('HMeasure a)
+      -> abt '[] ('HMeasure a)
+      -> abt '[] ('HMeasure a)
+x <|> y =
+    superpose $
+        case (matchSuperpose x, matchSuperpose y) of
+        (Just xs, Just ys) -> xs <> ys
+        (Just xs, Nothing) -> (one, y) :| L.toList xs -- HACK: reordering!
+        (Nothing, Just ys) -> (one, x) :| L.toList ys
+        (Nothing, Nothing) -> (one, x) :| [(one, y)]
+
+matchSuperpose
+    :: (ABT Term abt) 
+    => abt '[] ('HMeasure a)
+    -> Maybe (NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a)))
+matchSuperpose e =
+    caseVarSyn e
+        (const Nothing)
+        $ \t ->
+            case t of
+            Superpose_ xs -> Just xs
+            _ -> Nothing
+
+-- TODO: we should ensure that the following reductions happen:
+-- > (withWeight p m >> n) ---> withWeight p (m >> n)
+-- > (m >> withWeight p n) ---> withWeight p (m >> n)
+-- > withWeight 1 m ---> m
+-- > withWeight p (withWeight q m) ---> withWeight (p*q) m
+-- > (weight p >> m) ---> withWeight p m
+--
+-- | Adjust the weight of the current measure.
+--
+-- /N.B.,/ the name for this function is terribly inconsistent
+-- across the literature, even just the Hakaru literature, let alone
+-- the Hakaru code base. It is variously called \"factor\" or
+-- \"weight\"; though \"factor\" is also used to mean the function
+-- 'factor' or the function 'observe', and \"weight\" is also used
+-- to mean the 'weight' function.
+weight
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] ('HMeasure HUnit)
+weight p = withWeight p (dirac unit)
+
+
+-- | A variant of 'weight' which removes an administrative @(dirac
+-- unit >>)@ redex.
+--
+-- TODO: ideally we'll be able to get rid of this function entirely,
+-- and be able to trust optimization to clean up any redexes
+-- introduced by 'weight'.
+withWeight
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] ('HMeasure w)
+    -> abt '[] ('HMeasure w)
+withWeight p m = syn $ Superpose_ ((p, m) :| [])
+
+
+-- | A particularly common use case of 'weight':
+--
+-- > weightedDirac e p
+-- >     == weight p (dirac e)
+-- >     == weight p *> dirac e
+-- >     == dirac e <* weight p
+weightedDirac
+    :: (ABT Term abt, SingI a)
+    => abt '[] a
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure a)
+weightedDirac e p = withWeight p (dirac e)
+
+
+-- TODO: this taking of two arguments is as per the Core Hakaru specification; but for the EDSL, can we rephrase this as just taking the first argument, using @dirac unit@ for the else-branch, and then, making @(>>)@ work in the right way to plug the continuation measure in place of the @dirac unit@.
+-- TODO: would it help inference\/simplification at all to move this into the AST as a primitive? I mean, it is a primitive of Core Hakaru afterall... Also, that would help clarify whether the (first)argument should actually be an @HBool@ or whether it should be some sort of proposition.
+
+-- | Assert that a condition is true.
+--
+-- /N.B.,/ the name for this function is terribly inconsistent
+-- across the literature, even just the Hakaru literature, let alone
+-- the Hakaru code base. It is variously called \"factor\" or
+-- \"observe\"; though \"factor\" is also used to mean the function
+-- 'pose', and \"observe\" is also used to mean the backwards part
+-- of Lazy.hs.
+guard
+    :: (ABT Term abt)
+    => abt '[] HBool
+    -> abt '[] ('HMeasure HUnit)
+guard b = withGuard b (dirac unit)
+
+
+-- | A variant of 'guard' which removes an administrative @(dirac
+-- unit >>)@ redex.
+--
+-- TODO: ideally we'll be able to get rid of this function entirely,
+-- and be able to trust optimization to clean up any redexes
+-- introduced by 'guard'.
+withGuard
+    :: (ABT Term abt)
+    => abt '[] HBool
+    -> abt '[] ('HMeasure a)
+    -> abt '[] ('HMeasure a)
+withGuard b m = if_ b m (reject (typeOf m))
+
+
+densityCategorical
+    :: (ABT Term abt)
+    => abt '[] ('HArray 'HProb)
+    -> abt '[] 'HNat
+    -> abt '[] 'HProb
+densityCategorical v i = v ! i / summateV v
+
+categorical, categorical'
+    :: (ABT Term abt)
+    => abt '[] ('HArray 'HProb)
+    -> abt '[] ('HMeasure 'HNat)
+categorical = measure1_ Categorical
+
+-- TODO: a variant of 'if_' which gives us the evidence that the argument is non-negative, so we don't need to coerce or use 'abs_'
+categorical' v =
+    counting >>= \i ->
+    withGuard (int_ 0 <= i && i < nat2int (size v)) $
+    let_ (unsafeFrom_ signed i) $ \i_ ->
+    weightedDirac i_ (densityCategorical v i_)
+
+
+densityUniform
+    :: (ABT Term abt)
+    => abt '[] 'HReal
+    -> abt '[] 'HReal
+    -> abt '[] 'HReal
+    -> abt '[] 'HProb
+densityUniform lo hi _ = recip . unsafeProb $ hi - lo
+
+
+-- TODO: make Uniform polymorphic, so that if the two inputs are
+-- HProb then we know the measure must be over HProb too
+uniform, uniform'
+    :: (ABT Term abt)
+    => abt '[] 'HReal
+    -> abt '[] 'HReal
+    -> abt '[] ('HMeasure 'HReal)
+uniform = measure2_ Uniform
+
+uniform' lo hi = 
+    lebesgue >>= \x ->
+    withGuard (lo < x && x < hi) $
+        -- TODO: how can we capture that this 'unsafeProb' is safe? (and that this 'recip' isn't Infinity, for that matter)
+    weightedDirac x (densityUniform lo hi x)
+
+densityNormal
+    :: (ABT Term abt)
+    => abt '[] 'HReal
+    -> abt '[] 'HProb
+    -> abt '[] 'HReal
+    -> abt '[] 'HProb
+densityNormal mu sd x = 
+    exp (negate ((x - mu) ^ nat_ 2)  -- TODO: use negative\/square instead of negate\/(^2)
+         / fromProb (prob_ 2 * sd ^ nat_ 2)) -- TODO: use square?
+     / sd / sqrt (prob_ 2 * pi)
+
+
+normal, normal'
+    :: (ABT Term abt)
+    => abt '[] 'HReal
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure 'HReal)
+normal = measure2_ Normal
+
+normal' mu sd  = 
+    lebesgue >>= \x ->
+    weightedDirac x (densityNormal mu sd x)
+
+
+densityPoisson
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HNat
+    -> abt '[] 'HProb
+densityPoisson l x =
+     l ^ x
+       / gammaFunc (nat2real (x + nat_ 1)) -- TODO: use factorial instead of gammaFunc...
+       / exp l
+
+
+poisson, poisson'
+    :: (ABT Term abt) => abt '[] 'HProb -> abt '[] ('HMeasure 'HNat)
+poisson = measure1_ Poisson
+
+poisson' l = 
+    counting >>= \x ->
+    -- TODO: use 'SafeFrom_' instead of @if_ (x >= int_ 0)@ so we can prove that @unsafeFrom_ signed x@ is actually always safe.
+    withGuard (int_ 0 <= x && prob_ 0 < l) $ -- N.B., @0 < l@ means simply that @l /= 0@; why phrase it the other way?
+    let_ (unsafeFrom_ signed x) $ \x_ ->
+        weightedDirac x_ (densityPoisson l x_)
+
+densityGamma
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] 'HProb
+densityGamma shape scale x =
+    x ** (fromProb shape - real_ 1)
+    * exp (negate . fromProb $ x / scale)
+    / (scale ** shape * gammaFunc shape)
+
+
+gamma, gamma'
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure 'HProb)
+gamma = measure2_ Gamma
+
+gamma' shape scale =
+    lebesgue >>= \x ->
+    -- TODO: use 'SafeFrom_' instead of @if_ (real_ 0 < x)@ so we can prove that @unsafeProb x@ is actually always safe. Of course, then we'll need to mess around with checking (/=0) which'll get ugly... Use another SafeFrom_ with an associated NonZero type?
+    withGuard (real_ 0 < x) $
+    let_ (unsafeProb x) $ \ x_ ->
+    weightedDirac x_ (densityGamma shape scale x_)
+
+densityBeta
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] 'HProb
+densityBeta a b x =
+    x ** (fromProb a - real_ 1)
+    * unsafeProb (real_ 1 - fromProb x) ** (fromProb b - real_ 1)
+    / betaFunc a b
+
+beta, beta', beta''
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure 'HProb)
+beta = measure2_ Beta
+
+beta' a b =
+    -- TODO: make Uniform polymorphic, so that if the two inputs are HProb then we know the measure must be over HProb too, and hence @unsafeProb x@ must always be safe. Alas, capturing the safety of @unsafeProb (1-x)@ would take a lot more work...
+    unsafeProb <$> uniform (real_ 0) (real_ 1) >>= \x ->
+    weightedDirac x (densityBeta a b x)
+
+beta'' a b =
+    gamma a (prob_ 1) >>= \x ->
+    gamma b (prob_ 1) >>= \y ->
+    dirac (x / (x+y))
+
+plateWithVar
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> Variable 'HNat
+    -> abt '[] ('HMeasure a)
+    -> abt '[] ('HMeasure ('HArray a))
+plateWithVar e1 x e2 = syn (Plate :$ e1 :* bind x e2 :* End)
+        
+plate :: (ABT Term abt)
+      => abt '[] 'HNat
+      -> (abt '[] 'HNat -> abt '[] ('HMeasure a))
+      -> abt '[] ('HMeasure ('HArray a))
+plate e f = syn (Plate :$ e :* binder Text.empty sing f :* End)
+
+plate'
+    :: (ABT Term abt, SingI a)
+    => abt '[] ('HArray ('HMeasure          a))
+    -> abt '[] (         'HMeasure ('HArray a))
+
+plate' v = reduce r z (mapV m v)
+    where
+    r   = liftM2 appendV
+    z   = dirac empty
+    m a = (array (nat_ 1) . const) <$> a
+
+
+-- BUG: remove the 'SingI' requirement!
+chain :: (ABT Term abt, SingI s)
+      => abt '[] 'HNat
+      -> abt '[] s
+      -> (abt '[] s -> abt '[] ('HMeasure (HPair a s)))
+      -> abt '[] ('HMeasure (HPair ('HArray a) s))
+chain n s f = syn (Chain :$ n :* s :* binder Text.empty sing f :* End)
+
+chain'
+    :: (ABT Term abt, SingI s, SingI a)
+    => abt '[] ('HArray (s ':-> 'HMeasure (HPair a s)))
+    -> abt '[] s
+    -> abt '[] ('HMeasure (HPair ('HArray a) s))
+
+chain' v s0 = reduce r z (mapV m v) `app` s0
+    where
+    r x y = lam $ \s ->
+            app x s >>= \v1s1 ->
+            v1s1 `unpair` \v1 s1 ->
+            app y s1 >>= \v2s2 ->
+            v2s2 `unpair` \v2 s2 ->
+            dirac $ pair (appendV v1 v2) s2
+    z     = lam $ \s -> dirac (pair empty s)
+    m a   = lam $ \s -> (`unpair` pair . array (nat_ 1) . const) <$> app a s
+
+
+invgamma
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure 'HProb)
+invgamma k t = recip <$> gamma k (recip t)
+
+exponential
+    :: (ABT Term abt) => abt '[] 'HProb -> abt '[] ('HMeasure 'HProb)
+exponential = gamma (prob_ 1)
+
+chi2 :: (ABT Term abt) => abt '[] 'HProb -> abt '[] ('HMeasure 'HProb)
+chi2 v = gamma (v / prob_ 2) (prob_ 2)
+
+cauchy
+    :: (ABT Term abt)
+    => abt '[] 'HReal
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure 'HReal)
+cauchy loc scale =
+    normal (real_ 0) (prob_ 1) >>= \x ->
+    normal (real_ 0) (prob_ 1) >>= \y ->
+    dirac $ loc + fromProb scale * x / y
+
+laplace
+    :: (ABT Term abt)
+    => abt '[] 'HReal
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure 'HReal)
+laplace loc scale =
+    exponential (prob_ 1) >>= \v ->
+    normal (real_ 0) (prob_ 1) >>= \z ->
+    dirac $ loc + z * fromProb (scale * sqrt (prob_ 2 * v))
+
+studentT
+    :: (ABT Term abt)
+    => abt '[] 'HReal
+    -> abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure 'HReal)
+studentT loc scale v =
+    normal loc scale >>= \z ->
+    chi2 v >>= \df ->
+    dirac $ z * fromProb (sqrt (v / df))
+
+weibull
+    :: (ABT Term abt)
+    => abt '[] 'HProb
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure 'HProb)
+weibull b k =
+    exponential (prob_ 1) >>= \x ->
+    dirac $ b * x ** recip k
+
+bern :: (ABT Term abt) => abt '[] 'HProb -> abt '[] ('HMeasure HBool)
+bern p = categorical (arrayLit [p, prob_ 1 `unsafeMinusProb` p]) >>= \i ->
+         dirac (arrayLit [true, false] ! i)
+
+mix :: (ABT Term abt)
+    => abt '[] ('HArray 'HProb) -> abt '[] ('HMeasure 'HNat)
+mix v = withWeight (sumV v) (categorical v)
+
+binomial
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> abt '[] 'HProb
+    -> abt '[] ('HMeasure 'HInt)
+binomial n p =
+    sumV <$> plate n (const $ ((\b -> if_ b (int_ 1) (int_ 0)) <$> bern p))
+
+-- BUG: would it be better to 'observe' that @p >= 1@ before doing everything? At least that way things would be /defined/ for all inputs...
+negativeBinomial
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> abt '[] 'HProb -- N.B., must actually be between 0 and 1
+    -> abt '[] ('HMeasure 'HNat)
+negativeBinomial r p =
+    gamma (nat2prob r) (recip (recip p `unsafeMinusProb` prob_ 1)) >>= poisson
+
+geometric :: (ABT Term abt) => abt '[] 'HProb -> abt '[] ('HMeasure 'HNat)
+geometric = negativeBinomial (nat_ 1)
+
+
+multinomial
+    :: (ABT Term abt)
+    => abt '[] 'HNat
+    -> abt '[] ('HArray 'HProb)
+    -> abt '[] ('HMeasure ('HArray 'HProb))
+multinomial n v =
+    reduce (liftM2 (zipWithV (+)))
+        (dirac (constV (size v) (prob_ 0)))
+        (constV n (unitV (size v) <$> categorical v))
+
+dirichlet
+    :: (ABT Term abt)
+    => abt '[] ('HArray 'HProb)
+    -> abt '[] ('HMeasure ('HArray 'HProb))
+dirichlet a = normalizeV <$> plate (size a) (\ i -> a ! i  `gamma` prob_ 1)
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/Prune.hs b/haskell/Language/Hakaru/Syntax/Prune.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Prune.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , FlexibleContexts
+           , GADTs
+           , GeneralizedNewtypeDeriving
+           , KindSignatures
+           , MultiParamTypeClasses
+           , ScopedTypeVariables
+           , TypeOperators
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2017.02.01
+-- |
+-- Module      :  Language.Hakaru.Syntax.Prune
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+--
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.Prune (prune) where
+
+import           Control.Monad.Reader
+import           Data.Maybe
+
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.AST.Eq
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Syntax.Unroll   (renameInEnv)
+import           Language.Hakaru.Types.DataKind
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative
+#endif
+
+-- A Simple pass for pruning the unused let bindings from an AST.
+
+newtype PruneM a = PruneM { runPruneM :: Reader Varmap a }
+  deriving (Functor, Applicative, Monad, MonadReader Varmap, MonadFix)
+
+lookupEnv
+  :: forall (a :: Hakaru)
+  .  Variable a
+  -> Varmap
+  -> Variable a
+lookupEnv v = fromMaybe v . lookupAssoc v
+
+prune
+  :: (ABT Term abt)
+  => abt '[] a
+  -> abt '[] a
+prune = flip runReader emptyAssocs . runPruneM . prune'
+
+prune'
+  :: forall abt xs a . (ABT Term abt)
+  => abt xs a
+  -> PruneM (abt xs a)
+prune' = loop . viewABT
+   where
+    loop :: forall (b :: Hakaru) ys . View (Term abt) ys b -> PruneM (abt ys b)
+    loop (Var v)    = (var . lookupEnv v) `fmap` ask
+    loop (Syn s)    = pruneTerm s
+    loop (Bind v b) = renameInEnv v (loop b)
+
+pruneTerm
+  :: forall a abt
+  .  (ABT Term abt)
+  => Term abt a
+  -> PruneM (abt '[] a)
+pruneTerm (Let_ :$ rhs :* body :* End) =
+  caseBind body $ \v body' ->
+  let frees     = freeVars body'
+      mklet r b = syn (Let_ :$ r :* b :* End)
+      doRhs     = prune' rhs
+      doBody    = prune' body'
+      fullExpr  = mklet <$> doRhs <*> renameInEnv v doBody
+  in case viewABT body' of
+       Var v' | Just Refl <- varEq v v' -> doRhs
+       _      | memberVarSet v frees    -> fullExpr
+              | otherwise               -> doBody
+
+pruneTerm term = syn <$> traverse21 prune' term
diff --git a/haskell/Language/Hakaru/Syntax/Reducer.hs b/haskell/Language/Hakaru/Syntax/Reducer.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Reducer.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , InstanceSigs
+           , GADTs
+           , KindSignatures
+           , Rank2Types
+           , TypeOperators
+           #-}
+
+module Language.Hakaru.Syntax.Reducer where
+
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Syntax.IClasses
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative
+import           Data.Monoid   (Monoid(..))
+#endif
+
+data Reducer (abt :: [Hakaru] -> Hakaru -> *)
+             (xs  :: [Hakaru])
+             (a :: Hakaru) where
+     Red_Fanout
+         :: Reducer abt xs a
+         -> Reducer abt xs b
+         -> Reducer abt xs (HPair a b)
+     Red_Index
+         :: abt xs 'HNat                 -- size of resulting array
+         -> abt ( 'HNat ': xs) 'HNat     -- index into array (bound i)
+         -> Reducer abt ( 'HNat ': xs) a -- reduction body (bound b)
+         -> Reducer abt xs ('HArray a)
+     Red_Split
+         :: abt ( 'HNat ': xs) HBool     -- (bound i)
+         -> Reducer abt xs a
+         -> Reducer abt xs b
+         -> Reducer abt xs (HPair a b)
+     Red_Nop
+         :: Reducer abt xs HUnit
+     Red_Add
+         :: HSemiring a
+         -> abt ( 'HNat ': xs) a         -- (bound i)
+         -> Reducer abt xs a
+
+instance Functor22 Reducer where
+    fmap22 f (Red_Fanout r1 r2)  = Red_Fanout (fmap22 f r1) (fmap22 f r2)
+    fmap22 f (Red_Index n ix r)  = Red_Index (f n) (f ix) (fmap22 f r)
+    fmap22 f (Red_Split b r1 r2) = Red_Split (f b) (fmap22 f r1) (fmap22 f r2)
+    fmap22 _ Red_Nop             = Red_Nop
+    fmap22 f (Red_Add h e)       = Red_Add h (f e)
+
+instance Foldable22 Reducer where
+    foldMap22 f (Red_Fanout r1 r2)  = foldMap22 f r1 `mappend` foldMap22 f r2
+    foldMap22 f (Red_Index n ix r)  = f n `mappend` f ix `mappend` foldMap22 f r
+    foldMap22 f (Red_Split b r1 r2) = f b `mappend` foldMap22 f r1 `mappend` foldMap22 f r2
+    foldMap22 _ Red_Nop             = mempty
+    foldMap22 f (Red_Add _ e)       = f e
+
+instance Traversable22 Reducer where
+    traverse22 f (Red_Fanout r1 r2)  = Red_Fanout <$> traverse22 f r1 <*> traverse22 f r2
+    traverse22 f (Red_Index n ix r)  = Red_Index  <$> f n <*> f ix <*> traverse22 f r
+    traverse22 f (Red_Split b r1 r2) = Red_Split <$> f b <*> traverse22 f r1 <*> traverse22 f r2
+    traverse22 _ Red_Nop             = pure Red_Nop
+    traverse22 f (Red_Add h e)       = Red_Add h <$> f e
+
+
+instance Eq2 abt => Eq1 (Reducer abt xs) where
+    eq1 (Red_Fanout r1 r2)  (Red_Fanout r1' r2')   = eq1 r1 r1' && eq1 r2 r2'
+    eq1 (Red_Index n ix r)  (Red_Index n' ix' r')  = eq2 n n' && eq2 ix ix' && eq1 r r'
+    eq1 (Red_Split b r1 r2) (Red_Split b' r1' r2') = eq2 b b' && eq1 r1 r1' && eq1 r2 r2'
+    eq1 Red_Nop             Red_Nop                = True
+    eq1 (Red_Add _ e)       (Red_Add _ e')         = eq2 e e'
+    eq1 _ _ = False
+
+instance JmEq2 abt => JmEq1 (Reducer abt xs) where
+    jmEq1 = jmEqReducer
+
+jmEqReducer
+  :: (JmEq2 abt)
+  => Reducer abt xs a
+  -> Reducer abt xs b
+  -> Maybe (TypeEq a b)
+jmEqReducer (Red_Fanout a b) (Red_Fanout a' b') = do
+  Refl <- jmEqReducer a a'
+  Refl <- jmEqReducer b b'
+  return Refl
+jmEqReducer (Red_Index s i r) (Red_Index s' i' r') = do
+  (Refl, Refl) <- jmEq2 s s'
+  (Refl, Refl) <- jmEq2 i i'
+  Refl         <- jmEqReducer r r'
+  return Refl
+jmEqReducer (Red_Split b r s) (Red_Split b' r' s') = do
+  (Refl, Refl) <- jmEq2 b b'
+  Refl         <- jmEqReducer r r'
+  Refl         <- jmEqReducer s s'
+  return Refl
+jmEqReducer Red_Nop Red_Nop = return Refl
+jmEqReducer (Red_Add _ x) (Red_Add _ x') = do
+  (Refl, Refl) <- jmEq2 x x'
+  return Refl
+jmEqReducer _ _ = Nothing
+
diff --git a/haskell/Language/Hakaru/Syntax/Rename.hs b/haskell/Language/Hakaru/Syntax/Rename.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Rename.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , EmptyCase
+           , ExistentialQuantification
+           , FlexibleContexts
+           , GADTs
+           , GeneralizedNewtypeDeriving
+           , KindSignatures
+           , MultiParamTypeClasses
+           , OverloadedStrings
+           , PolyKinds
+           , ScopedTypeVariables
+           , TypeFamilies
+           , TypeOperators
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+-- |
+-- Module      :  Language.Hakaru.Syntax.Rename 
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Performs renaming of variables hints only (in Hakaru expressions) 
+-- which hopefully has no effect on semantics but can produce prettier expressions
+--
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.Rename where
+
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.IClasses
+import qualified Data.Text as Text 
+import           Data.Text (Text) 
+import           Data.Char 
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative
+#endif
+
+type Renamer = Text -> Text 
+
+renameAST 
+  :: forall abt xs a . (ABT Term abt)
+  => Renamer 
+  -> abt xs a
+  -> abt xs a
+renameAST r = start
+  where
+    start :: abt ys b -> abt ys b
+    start = loop . viewABT
+
+    loop :: View (Term abt) ys b -> abt ys b
+    loop (Var v)    = var (renameVar r v)
+    loop (Syn s)    = syn (fmap21 start s)
+    loop (Bind v b) = bind (renameVar r v) (loop b) 
+
+renameVar :: Renamer -> Variable a -> Variable a 
+renameVar r v = v { varHint = r (varHint v) } 
+
+removeUnicodeChars :: Text -> Text 
+removeUnicodeChars = Text.filter isAscii 
diff --git a/haskell/Language/Hakaru/Syntax/SArgs.hs b/haskell/Language/Hakaru/Syntax/SArgs.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/SArgs.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , PolyKinds
+           , GADTs
+           , RankNTypes
+           , TypeOperators
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.SArgs
+  ( module Language.Hakaru.Syntax.SArgs
+  ) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative (pure,(<$>),(<*>),Applicative)
+import Data.Monoid (Monoid(mempty,mappend))
+#endif
+
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+
+
+-- | Locally closed values (i.e., not binding forms) of a given type.
+-- TODO: come up with a better name
+type LC (a :: Hakaru) = '( '[], a )
+
+----------------------------------------------------------------
+-- TODO: ideally we'd like to make SArgs totally flat, like tuples and arrays. Is there a way to do that with data families?
+-- TODO: is there any good way to reuse 'List1' instead of defining 'SArgs' (aka @List2@)?
+
+-- TODO: come up with a better name for 'End'
+-- TODO: unify this with 'List1'? However, strictness differences...
+--
+-- | The arguments to a @(':$')@ node in the 'Term'; that is, a list
+-- of ASTs, where the whole list is indexed by a (type-level) list
+-- of the indices of each element.
+data SArgs :: ([Hakaru] -> Hakaru -> *) -> [([Hakaru], Hakaru)] -> *
+    where
+    End :: SArgs abt '[]
+    (:*) :: !(abt vars a)
+        -> !(SArgs abt args)
+        -> SArgs abt ( '(vars, a) ': args)
+
+infixr 5 :* -- Chosen to match (:)
+
+-- TODO: instance Read (SArgs abt args)
+
+instance Show2 abt => Show1 (SArgs abt) where
+    showsPrec1 _ End       = showString "End"
+    showsPrec1 p (e :* es) =
+        showParen (p > 5)
+            ( showsPrec2 (p+1) e
+            . showString " :* "
+            . showsPrec1 (p+1) es
+            )
+
+instance Show2 abt => Show (SArgs abt args) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance Eq2 abt => Eq1 (SArgs abt) where
+    eq1 End       End       = True
+    eq1 (x :* xs) (y :* ys) = eq2 x y && eq1 xs ys
+
+instance Eq2 abt => Eq (SArgs abt args) where
+    (==) = eq1
+
+instance Functor21 SArgs where
+    fmap21 f (e :* es) = f e :* fmap21 f es
+    fmap21 _ End       = End
+
+instance Foldable21 SArgs where
+    foldMap21 f (e :* es) = f e `mappend` foldMap21 f es
+    foldMap21 _ End       = mempty
+
+instance Traversable21 SArgs where
+    traverse21 f (e :* es) = (:*) <$> f e <*> traverse21 f es
+    traverse21 _ End       = pure End
+
+
+type SArgsSing = SArgs (Pointwise (Lift1 ()) Sing)
+
+getSArgsSing
+    :: forall abt xs m
+     . (Applicative m)
+    => (forall ys a . abt ys a -> m (Sing a))
+    -> SArgs abt xs
+    -> m (SArgsSing xs)
+getSArgsSing k = traverse21 $ \x -> Pw (Lift1 ()) <$> k x
diff --git a/haskell/Language/Hakaru/Syntax/Transform.hs b/haskell/Language/Hakaru/Syntax/Transform.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Transform.hs
@@ -0,0 +1,257 @@
+{-# LANGUAGE CPP
+           , FlexibleInstances
+           , GADTs
+           , DataKinds
+           , TypeOperators
+           , KindSignatures
+           , LambdaCase
+           , ViewPatterns
+           , DeriveDataTypeable
+           , StandaloneDeriving
+           , OverlappingInstances
+           , UndecidableInstances
+           , RankNTypes
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+-- |
+-- Module      :  Language.Hakaru.Syntax.Transform
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- The internal syntax of Hakaru transformations, which are functions on Hakaru
+-- terms which are neither primitive, nor expressible in terms of Hakaru
+-- primitives.
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.Transform
+  (
+  -- * Transformation internal syntax
+    TransformImpl(..)
+  , Transform(..)
+  -- * Some utilities
+  , transformName, allTransforms
+  -- * Mapping of input type to output type for transforms
+  , typeOfTransform
+  -- * Transformation contexts
+  , TransformCtx(..), HasTransformCtx(..), unionCtx, minimalCtx
+  -- * Transformation tables
+  , TransformTable(..), lookupTransform', simpleTable
+  , unionTable, someTransformations
+  )
+  where
+
+
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.SArgs
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Syntax.Variable
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+
+import Control.Applicative (Alternative(..), Applicative(..))
+import Data.Number.Nat
+import Data.Data (Data, Typeable)
+import Data.List (stripPrefix)
+import Data.Monoid (Monoid(..))
+
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Semigroup
+#endif
+
+----------------------------------------------------------------
+
+-- | Some transformations have the same type and 'same' semantics, but are
+--   implemented in multiple different ways. Such transformations are
+--   distinguished in concrete syntax by differing keywords.
+data TransformImpl = InMaple | InHaskell
+  deriving (Eq, Ord, Show, Read, Data, Typeable)
+
+-- | Transformations and their types. Like 'Language.Hakaru.Syntax.AST.SCon'.
+data Transform :: [([Hakaru], Hakaru)] -> Hakaru -> * where
+  Expect  ::
+    Transform
+      '[ LC ('HMeasure a), '( '[ a ], 'HProb) ] 'HProb
+
+  Observe ::
+    Transform
+      '[ LC ('HMeasure a), LC a ] ('HMeasure a)
+
+  MH ::
+    Transform
+      '[ LC (a ':-> 'HMeasure a), LC ('HMeasure a) ]
+      (a ':-> 'HMeasure (HPair a 'HProb))
+
+  MCMC ::
+    Transform
+      '[ LC (a ':-> 'HMeasure a), LC ('HMeasure a) ]
+      (a ':-> 'HMeasure a)
+
+  Disint :: TransformImpl ->
+    Transform
+      '[ LC ('HMeasure (HPair a b)) ]
+      (a :-> 'HMeasure b)
+
+  Summarize ::
+    Transform '[ LC a ] a
+
+  Simplify ::
+    Transform '[ LC a ] a
+
+  Reparam ::
+    Transform '[ LC a ] a
+
+deriving instance Eq   (Transform args a)
+deriving instance Show (Transform args a)
+
+instance Eq (Some2 Transform) where
+  Some2 t0 == Some2 t1 =
+    case (t0, t1) of
+      (Expect    , Expect   ) -> True
+      (Observe   , Observe  ) -> True
+      (MH        , MH       ) -> True
+      (MCMC      , MCMC     ) -> True
+      (Disint k0 , Disint k1) -> k0==k1
+      (Summarize , Summarize) -> True
+      (Simplify  , Simplify ) -> True
+      (Reparam   , Reparam  ) -> True
+      _ -> False
+
+instance Read (Some2 Transform) where
+  readsPrec _ s =
+    let trs = map (\t'@(Some2 t) -> (show t, t')) allTransforms
+        readMay (s', t)
+          | Just rs <- stripPrefix s' s = [(t, rs)]
+          | otherwise                   = []
+    in concatMap readMay trs
+
+-- | The concrete syntax names of transformations.
+transformName :: Transform args a -> String
+transformName =
+  \case
+    Expect    -> "expect"
+    Observe   -> "observe"
+    MH        -> "mh"
+    MCMC      -> "mcmc"
+    Disint k  -> "disint" ++
+      (case k of
+         InHaskell -> ""
+         InMaple   -> "_m")
+    Summarize -> "summarize"
+    Simplify  -> "simplify"
+    Reparam   -> "reparam"
+
+-- | All transformations.
+allTransforms :: [Some2 Transform]
+allTransforms =
+  [ Some2 Expect, Some2 Observe, Some2 MH, Some2 MCMC
+  , Some2 (Disint InHaskell), Some2 (Disint InMaple)
+  , Some2 Summarize, Some2 Simplify, Some2 Reparam ]
+
+typeOfTransform
+    :: Transform as x
+    -> SArgsSing as
+    -> Sing x
+typeOfTransform t as =
+  case (t,as) of
+    (Expect   , _)
+      -> SProb
+    (Observe  , Pw _ e :* _ :* End)
+      -> e
+    (MH       , Pw _ (fst.sUnFun -> a) :* _ :* End)
+      -> SFun a (SMeasure (sPair a SProb))
+    (MCMC     , Pw _ a :* _)
+      -> a
+    (Disint _ , Pw _ (sUnPair.sUnMeasure -> (a,b)) :* End)
+      -> SFun a (SMeasure b)
+    (Summarize, Pw _ e :* End)
+      -> e
+    (Simplify , Pw _ e :* End)
+      -> e
+    (Reparam  , Pw _ e :* End)
+      -> e
+
+-- | The context in which a transformation is called.  Currently this is simply
+--   the next free variable in the enclosing program, but it could one day be
+--   expanded to include more information, e.g., an association of variables to
+--   terms in the enclosing program.
+newtype TransformCtx = TransformCtx
+  { nextFreeVar :: Nat }
+    deriving (Eq, Ord, Show)
+
+-- | The smallest possible context, i.e. a default context suitable for use when
+-- performing induction on terms which may contain transformations as subterms.
+minimalCtx :: TransformCtx
+minimalCtx = TransformCtx { nextFreeVar = 0 }
+
+-- | The union of two contexts
+unionCtx :: TransformCtx -> TransformCtx -> TransformCtx
+unionCtx ctx0 ctx1 =
+  TransformCtx { nextFreeVar = max (nextFreeVar ctx0) (nextFreeVar ctx1) }
+
+instance Semigroup TransformCtx where
+  (<>) = unionCtx
+
+instance Monoid TransformCtx where
+  mempty  = minimalCtx
+#if !(MIN_VERSION_base(4,11,0))
+  mappend = (<>)
+#endif
+
+-- | The class of types which have an associated context
+class HasTransformCtx x where
+  ctxOf :: x -> TransformCtx
+
+instance HasTransformCtx (Variable (a :: Hakaru)) where
+  ctxOf v = TransformCtx { nextFreeVar = varID v + 1 }
+
+instance ABT syn abt => HasTransformCtx (abt (xs :: [Hakaru]) (a :: Hakaru)) where
+  ctxOf t = TransformCtx { nextFreeVar = nextFree t }
+
+-- | A functional lookup table which indicates how to expand
+--   transformations. The function returns @Nothing@ when the transformation
+--   shouldn't be expanded. When it returns @Just k@, @k@ is passed an @SArgs@
+--   and a @TransformCtx@.
+newtype TransformTable abt m
+  =  TransformTable
+  {  lookupTransform
+  :: forall as b
+  .  Transform as b
+  -> Maybe (TransformCtx -> SArgs abt as -> m (Maybe (abt '[] b))) }
+
+-- | A variant of @lookupTransform@ which joins the two layers of @Maybe@.
+lookupTransform'
+  :: (Applicative m)
+  => TransformTable abt m
+  -> Transform as b
+  -> TransformCtx
+  -> SArgs abt as -> m (Maybe (abt '[] b))
+lookupTransform' tbl tr ctx args=
+  case lookupTransform tbl tr of
+    Just f  -> f ctx args
+    Nothing -> pure Nothing
+
+-- | Builds a 'simple' transformation table, i.e. one which doesn't make use of
+--  the monadic context. Such a table is valid in every @Applicative@ context.
+simpleTable
+  :: (Applicative m)
+  => (forall as b . Transform as b
+                 -> Maybe (TransformCtx -> SArgs abt as -> Maybe (abt '[] b)))
+  -> TransformTable abt m
+simpleTable k = TransformTable $ \tr -> fmap (fmap (fmap pure)) $ k tr
+
+-- | Take the left-biased union of two transformation tables
+unionTable :: TransformTable abt m
+           -> TransformTable abt m
+           -> TransformTable abt m
+unionTable tbl0 tbl1 = TransformTable $ \tr ->
+  lookupTransform tbl0 tr <|>
+  lookupTransform tbl1 tr
+
+-- | Intersect a transformation table with a list of transformations
+someTransformations :: [Some2 Transform]
+                    -> TransformTable abt m
+                    -> TransformTable abt m
+someTransformations toExpand tbl = TransformTable $
+  \tr -> if Some2 tr `elem` toExpand then lookupTransform tbl tr else Nothing
diff --git a/haskell/Language/Hakaru/Syntax/TypeCheck.hs b/haskell/Language/Hakaru/Syntax/TypeCheck.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/TypeCheck.hs
@@ -0,0 +1,1504 @@
+{-# LANGUAGE CPP
+           , ScopedTypeVariables
+           , GADTs
+           , DataKinds
+           , KindSignatures
+           , GeneralizedNewtypeDeriving
+           , TypeOperators
+           , FlexibleContexts
+           , FlexibleInstances
+           , OverloadedStrings
+           , PatternGuards
+           , Rank2Types
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.28
+-- |
+-- Module      :  Language.Hakaru.Syntax.TypeCheck
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Bidirectional type checking for our AST.
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.TypeCheck
+    (
+    -- * The type checking monad
+      TypeCheckError
+    , TypeCheckMonad(), runTCM, unTCM
+    , TypeCheckMode(..)
+    -- * Type checking itself
+    , inferable
+    , mustCheck
+    , TypedAST(..)
+    , onTypedAST, onTypedASTM, elimTypedAST
+    , inferType
+    , checkType
+    ) where
+
+import           Prelude hiding (id, (.))
+import           Control.Category
+import           Data.Proxy            (KProxy(..))
+import           Data.Text             (pack, Text())
+import           Data.Either           (partitionEithers)
+import qualified Data.IntMap           as IM
+import qualified Data.Traversable      as T
+import qualified Data.List.NonEmpty    as L
+import qualified Data.Foldable         as F
+import qualified Data.Sequence         as S
+import qualified Data.Vector           as V
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+import           Data.Monoid           (Monoid(..))
+#endif
+import qualified Language.Hakaru.Parser.AST as U
+
+import Data.Number.Nat                (fromNat)
+import Language.Hakaru.Syntax.TypeCheck.TypeCheckMonad
+import Language.Hakaru.Syntax.TypeCheck.Unification
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Types.DataKind (Hakaru(..), HData', HBool)
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Types.HClasses
+    ( HEq, hEq_Sing, HOrd, hOrd_Sing, HSemiring, hSemiring_Sing
+    , hRing_Sing, sing_HRing, hFractional_Sing, sing_HFractional
+    , sing_NonNegative, hDiscrete_Sing
+    , HIntegrable(..)
+    , HRadical(..), HContinuous(..))
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.AST.Sing
+    (sing_Literal, sing_MeasureOp)
+import Language.Hakaru.Pretty.Concrete (prettyType, prettyTypeT)
+import Language.Hakaru.Syntax.TypeOf (typeOf)
+import Language.Hakaru.Syntax.Prelude (triv)
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- | Those terms from which we can synthesize a unique type. We are
+-- also allowed to check them, via the change-of-direction rule.
+inferable :: U.AST -> Bool
+inferable = not . mustCheck
+
+
+-- | Those terms whose types must be checked analytically. We cannot
+-- synthesize (unambiguous) types for these terms.
+--
+-- N.B., this function assumes we're in 'StrictMode'. If we're
+-- actually in 'LaxMode' then a handful of AST nodes behave
+-- differently: in particular, 'U.NaryOp_', 'U.Superpose', and
+-- 'U.Case_'. In strict mode those cases can just infer one of their
+-- arguments and then check the rest against the inferred type.
+-- (For case-expressions, we must also check the scrutinee since
+-- it's type cannot be unambiguously inferred from the patterns.)
+-- Whereas in lax mode we must infer all arguments and then take
+-- the lub of their types in order to know which coercions to
+-- introduce.
+mustCheck :: U.AST -> Bool
+mustCheck e = caseVarSyn e (const False) go
+    where
+    go :: U.MetaTerm -> Bool
+    go (U.Lam_ _  e2)     = mustCheck' e2
+
+    -- In general, applications don't require checking; we infer
+    -- the first applicand to get the type of the second and of the
+    -- result, then we check the second and return the result type.
+    -- Thus, applications will only yield \"must check\" errors if
+    -- the function does; but that's the responsability of the
+    -- function term, not of the application term it's embedded
+    -- within.
+    --
+    -- However, do note that the above only applies to lambda-defined
+    -- functions, not to all \"function-like\" things. In particular,
+    -- data constructors require checking (see the note below).
+    go (U.App_ _  _)      = False
+
+    -- We follow Dunfield & Pientka and \Pi\Sigma in inferring or
+    -- checking depending on what the body requires. This is as
+    -- opposed to the TLDI'05 paper, which always infers @e2@ but
+    -- will check or infer the @e1@ depending on whether it has a
+    -- type annotation or not.
+    go (U.Let_ _ e2)      = mustCheck' e2
+
+    go (U.Ann_ _ _)       = False
+    go (U.CoerceTo_ _ _)  = False
+    go (U.UnsafeTo_ _ _)  = False
+
+    -- In general (according to Dunfield & Pientka), we should be
+    -- able to infer the result of a fully saturated primop by
+    -- looking up its type and then checking all the arguments.
+    go (U.PrimOp_  _ _)   = False
+    go (U.ArrayOp_ _ es)  = F.all mustCheck es
+
+    -- In strict mode: if we can infer any of the arguments, then
+    -- we can check all the rest at the same type.
+    --
+    -- BUG: in lax mode we must be able to infer all of them;
+    -- otherwise we may not be able to take the lub of the types
+    go (U.NaryOp_   _ es) = F.all mustCheck es
+    go (U.Superpose_ pes) = F.all (mustCheck . snd) pes
+
+    -- Our numeric literals aren't polymorphic, so we can infer
+    -- them just fine. Or rather, according to our AST they aren't;
+    -- in truth, they are in the surface language. Which is part
+    -- of the reason for needing 'LaxMode'
+    --
+    -- TODO: correctly capture our surface-language semantics by
+    -- always treating literals as if we're in 'LaxMode'.
+    go (U.Literal_ _) = False
+
+    -- I return true because most folks (neelk, Pfenning, Dunfield
+    -- & Pientka) say all data constructors mustCheck. The main
+    -- issue here is dealing with (polymorphic) sum types and phantom
+    -- types, since these mean the term doesn't contain enough
+    -- information for all the type indices. Even for record types,
+    -- there's the additional issue of the term (perhaps) not giving
+    -- enough information about the nominal type even if it does
+    -- give enough info for the structural type.
+    --
+    -- Still, given those limitations, we should be able to infer
+    -- a subset of data constructors which happen to avoid the
+    -- problem areas. In particular, given that our surface syntax
+    -- doesn't use the sum-of-products representation, we should
+    -- be able to rely on symbol resolution to avoid the nominal
+    -- typing issue. Thus, for non-empty arrays and non-phantom
+    -- record types, we should be able to infer the whole type
+    -- provided we can infer the various subterms.
+    go (U.Pair_ e1 e2)      = mustCheck  e1 && mustCheck e2
+    go (U.Array_ _ e1)      = mustCheck' e1
+    go (U.ArrayLiteral_ es) = F.all mustCheck es
+    go (U.Datum_ _)         = True
+
+    -- TODO: everyone says this, but it seems to me that if we can
+    -- infer any of the branches (and check the rest to agree) then
+    -- we should be able to infer the whole thing... Or maybe the
+    -- problem is that the change-of-direction rule might send us
+    -- down the wrong path?
+    go (U.Case_ _ _)     = True
+
+    go (U.Dirac_  e1)        = mustCheck  e1
+    go (U.MBind_  _   e2)    = mustCheck' e2
+    go (U.Plate_  _   e2)    = mustCheck' e2
+    go (U.Chain_  _   e2 e3) = mustCheck  e2 && mustCheck' e3
+    go (U.MeasureOp_ _ _)    = False
+    go (U.Integrate_  _ _ _) = False
+    go (U.Summate_    _ _ _) = False
+    go (U.Product_    _ _ _) = False
+    go (U.Bucket_     _ _ _) = False
+    go U.Reject_             = True
+    go (U.Transform_ tr es ) =
+      case (tr, es) of
+        (Expect   , (Nil2, e1) U.:* _ U.:* U.End)
+          -> mustCheck e1
+        (Observe  , (Nil2, e1) U.:* _ U.:* U.End)
+          -> mustCheck e1
+        (MCMC     , (Nil2, e1) U.:* (Nil2, e2) U.:* U.End)
+          -> mustCheck e1 && mustCheck e2
+        (Disint _ , (Nil2, e1) U.:* U.End)
+          -> mustCheck e1
+        (Simplify , (Nil2, e1) U.:* U.End)
+          -> mustCheck e1
+        (Summarize, (Nil2, e1) U.:* U.End)
+          -> mustCheck e1
+        (Reparam  , (Nil2, e1) U.:* U.End)
+          -> mustCheck e1
+    go U.InjTyped{}          = False
+
+mustCheck'
+    :: MetaABT U.SourceSpan U.Term '[ 'U.U ] 'U.U
+    -> Bool
+mustCheck' e = caseBind e $ \_ e' -> mustCheck e'
+
+inferBinder
+    :: (ABT Term abt)
+    => Sing a
+    -> MetaABT U.SourceSpan U.Term '[ 'U.U ] 'U.U
+    -> (forall b. Sing b -> abt '[ a ] b -> TypeCheckMonad r)
+    -> TypeCheckMonad r
+inferBinder typ e k =
+    caseBind e $ \x e1 -> do
+    let x' = x {varType = typ}
+    TypedAST typ1 e1' <- pushCtx x' (inferType e1)
+    k typ1 (bind x' e1')
+
+inferBinders
+    :: (ABT Term abt)
+    => List1 Variable xs
+    -> U.AST
+    -> (forall a. Sing a -> abt xs a -> TypeCheckMonad r)
+    -> TypeCheckMonad r
+inferBinders = \xs e k -> do
+    TypedAST typ e' <- pushesCtx xs (inferType e)
+    k typ (binds_ xs e')
+    where
+    -- TODO: make sure the 'TCM'\/'unTCM' stuff doesn't do stupid asymptotic things
+    pushesCtx
+        :: List1 Variable (xs :: [Hakaru])
+        -> TypeCheckMonad b
+        -> TypeCheckMonad b
+    pushesCtx Nil1         m = m
+    pushesCtx (Cons1 x xs) m = pushesCtx xs (TCM (unTCM m . insertVarSet x))
+
+
+checkBinder
+    :: (ABT Term abt)
+    => Sing a
+    -> Sing b
+    -> MetaABT U.SourceSpan U.Term '[ 'U.U ] 'U.U
+    -> TypeCheckMonad (abt '[ a ] b)
+checkBinder typ eTyp e =
+    caseBind e $ \x e1 -> do
+    let x' = x {varType = typ}
+    pushCtx x' (bind x' <$> checkType eTyp e1)
+
+
+checkBinders
+    :: (ABT Term abt)
+    => List1 Variable xs
+    -> Sing a
+    -> U.AST
+    -> TypeCheckMonad (abt xs a)
+checkBinders xs eTyp e =
+    case xs of
+    Nil1        -> checkType eTyp e
+    Cons1 x xs' -> pushCtx x (bind x <$> checkBinders xs' eTyp e)
+
+----------------------------------------------------------------
+-- | Given a typing environment and a term, synthesize the term's
+-- type (and produce an elaborated term):
+--
+-- > Γ ⊢ e ⇒ e' ∈ τ
+inferType
+    :: forall abt
+    .  (ABT Term abt)
+    => U.AST
+    -> TypeCheckMonad (TypedAST abt)
+inferType = inferType_
+  where
+  -- HACK: we need to give these local definitions to avoid
+  -- \"ambiguity\" in the choice of ABT instance...
+  checkType_ :: forall b. Sing b -> U.AST -> TypeCheckMonad (abt '[] b)
+  checkType_ = checkType
+
+  inferOneCheckOthers_ ::
+      [U.AST] -> TypeCheckMonad (TypedASTs abt)
+  inferOneCheckOthers_ = inferOneCheckOthers
+
+
+  inferVariable
+      :: Maybe U.SourceSpan
+      -> Variable 'U.U
+      -> TypeCheckMonad (TypedAST abt)
+  inferVariable sourceSpan (Variable hintID nameID _) = do
+      ctx <- getCtx
+      case IM.lookup (fromNat nameID) (unVarSet ctx) of
+        Just (SomeVariable x') ->
+            return $ TypedAST (varType x') (var x')
+        Nothing -> ambiguousFreeVariable hintID sourceSpan
+
+
+  -- HACK: We need this monomorphic binding so that GHC doesn't get
+  -- confused about which @(ABT AST abt)@ instance to use in recursive
+  -- calls.
+  inferType_ :: U.AST -> TypeCheckMonad (TypedAST abt)
+  inferType_ e0 =
+    let s = getMetadata e0 in
+    caseVarSyn e0 (inferVariable s) (go s)
+    where
+    go :: Maybe U.SourceSpan -> U.MetaTerm -> TypeCheckMonad (TypedAST abt)
+    go sourceSpan t =
+      case t of
+       U.Lam_ (U.SSing typ) e -> do
+           inferBinder typ e $ \typ2 e2 ->
+               return . TypedAST (SFun typ typ2) $ syn (Lam_ :$ e2 :* End)
+
+       U.App_ e1 e2 -> do
+           TypedAST typ1 e1' <- inferType_ e1
+           unifyFun typ1 sourceSpan $ \typ2 typ3 -> do
+            e2' <- checkType_ typ2 e2
+            return . TypedAST typ3 $ syn (App_ :$ e1' :* e2' :* End)
+
+           -- case typ1 of
+           --     SFun typ2 typ3 -> do
+           --         e2' <- checkType_ typ2 e2
+           --         return . TypedAST typ3 $ syn (App_ :$ e1' :* e2' :* End)
+           --     _ -> typeMismatch sourceSpan (Left "function type") (Right typ1)
+           -- The above is the standard rule that everyone uses.
+           -- However, if the @e1@ is a lambda (rather than a primop
+           -- or a variable), then it will require a type annotation.
+           -- Couldn't we just as well add an additional rule that
+           -- says to infer @e2@ and then infer @e1@ under the assumption
+           -- that the variable has the same type as the argument? (or
+           -- generalize that idea to keep track of a bunch of arguments
+           -- being passed in; sort of like a dual to our typing
+           -- environments?) Is this at all related to what Dunfield
+           -- & Neelk are doing in their ICFP'13 paper with that
+           -- \"=>=>\" judgment? (prolly not, but...)
+
+       U.Let_ e1 e2 -> do
+           TypedAST typ1 e1' <- inferType_ e1
+           inferBinder typ1 e2 $ \typ2 e2' ->
+               return . TypedAST typ2 $ syn (Let_ :$ e1' :* e2' :* End)
+
+       U.Ann_ (U.SSing typ1) e1 -> do
+           -- N.B., this requires that @typ1@ is a 'Sing' not a 'Proxy',
+           -- since we can't generate a 'Sing' from a 'Proxy'.
+           TypedAST typ1 <$> checkType_ typ1 e1
+
+       U.PrimOp_  op es -> inferPrimOp  op es
+       U.ArrayOp_ op es -> inferArrayOp op es
+       U.NaryOp_  op es -> do
+           mode <- getMode
+           TypedASTs typ es' <-
+               case mode of
+               StrictMode -> inferOneCheckOthers_ es
+               LaxMode    -> inferLubType sourceSpan es
+               UnsafeMode -> inferLubType sourceSpan es
+           op' <- make_NaryOp typ op
+           return . TypedAST typ $ syn (NaryOp_ op' $ S.fromList es')
+
+       U.Literal_ (Some1 v) ->
+           -- TODO: in truth, we can infer this to be any supertype
+           -- (adjusting the concrete @v@ as necessary). That is, the
+           -- surface language treats numeric literals as polymorphic,
+           -- so we should capture that somehow--- even if we're not
+           -- in 'LaxMode'. We'll prolly need to handle this
+           -- subtype-polymorphism the same way as we do for for
+           -- everything when in 'UnsafeMode'.
+           return . TypedAST (sing_Literal v) $ syn (Literal_ v)
+
+       -- TODO: we can try to do 'U.Case_' by using branch-based
+       -- variants of 'inferOneCheckOthers' and 'inferLubType' depending
+       -- on the mode; provided we can in fact infer the type of the
+       -- scrutinee. N.B., if we add this case, then we need to update
+       -- 'mustCheck' to return the right thing.
+
+       U.CoerceTo_ (Some2 c) e1 ->
+           case singCoerceDomCod c of
+           Nothing
+               | inferable e1 -> inferType_ e1
+               | otherwise    -> ambiguousNullCoercion sourceSpan
+           Just (dom,cod) -> do
+               e1' <- checkType_ dom e1
+               return . TypedAST cod $ syn (CoerceTo_ c :$ e1' :* End)
+
+       U.UnsafeTo_ (Some2 c) e1 ->
+           case singCoerceDomCod c of
+           Nothing
+               | inferable e1 -> inferType_ e1
+               | otherwise    -> ambiguousNullCoercion sourceSpan
+           Just (dom,cod) -> do
+               e1' <- checkType_ cod e1
+               return . TypedAST dom $ syn (UnsafeFrom_ c :$ e1' :* End)
+
+       U.MeasureOp_ (U.SomeOp op) es -> do
+           let (typs, typ1) = sing_MeasureOp op
+           es' <- checkSArgs typs es
+           return . TypedAST (SMeasure typ1) $ syn (MeasureOp_ op :$ es')
+
+       U.Pair_ e1 e2 -> do
+           TypedAST typ1 e1' <- inferType_ e1
+           TypedAST typ2 e2' <- inferType_ e2
+           return . TypedAST (sPair typ1 typ2) $
+                  syn (Datum_ $ dPair_ typ1 typ2 e1' e2')
+
+       U.Array_ e1 e2 -> do
+           e1' <- checkType_ SNat e1
+           inferBinder SNat e2 $ \typ2 e2' ->
+               return . TypedAST (SArray typ2) $ syn (Array_ e1' e2')
+
+       U.ArrayLiteral_ es -> do
+           mode <- getMode
+           TypedASTs typ es' <-
+               case mode of
+                 StrictMode -> inferOneCheckOthers_ es
+                 LaxMode    -> inferLubType sourceSpan es
+                 UnsafeMode -> inferLubType sourceSpan es
+           return . TypedAST (SArray typ) $ syn (ArrayLiteral_ es')
+
+       U.Case_ e1 branches -> do
+           TypedAST typ1 e1' <- inferType_ e1
+           mode <- getMode
+           case mode of
+               StrictMode -> inferCaseStrict typ1 e1' branches
+               LaxMode    -> inferCaseLax sourceSpan typ1 e1' branches
+               UnsafeMode -> inferCaseLax sourceSpan typ1 e1' branches
+
+       U.Dirac_ e1 -> do
+           TypedAST typ1 e1' <- inferType_ e1
+           return . TypedAST (SMeasure typ1) $ syn (Dirac :$ e1' :* End)
+
+       U.MBind_ e1 e2 ->
+           caseBind e2 $ \x e2' -> do
+           TypedAST typ1 e1' <- inferType_ e1
+           unifyMeasure typ1 sourceSpan $ \typ2 ->
+            let x' = makeVar x typ2 in
+            pushCtx x' $ do
+             TypedAST typ3 e3' <- inferType_ e2'
+             unifyMeasure typ3 sourceSpan $ \_ ->
+              return . TypedAST typ3 $ syn (MBind :$ e1' :* bind x' e3' :* End)
+
+       U.Plate_ e1 e2 ->
+           caseBind e2 $ \x e2' -> do
+           e1' <- checkType_ SNat e1
+           let x' = makeVar x SNat
+           pushCtx x' $ do
+            TypedAST typ2 e3' <- inferType_ e2'
+            unifyMeasure typ2 sourceSpan $ \typ3 ->
+             return . TypedAST (SMeasure . SArray $ typ3) $
+              syn (Plate :$ e1' :* bind x' e3' :* End)
+
+       U.Chain_ e1 e2 e3 ->
+           caseBind e3 $ \x e3' -> do
+           e1' <- checkType_ SNat e1
+           TypedAST typ2 e2' <- inferType_ e2
+           let x' = makeVar x typ2
+           pushCtx x' $ do
+               TypedAST typ3 e4' <- inferType_ e3'
+               unifyMeasure typ3 sourceSpan $ \typ4 ->
+                unifyPair typ4 sourceSpan $ \a b ->
+                matchTypes typ2 b sourceSpan () () $
+                 return . TypedAST (SMeasure $ sPair (SArray a) typ2) $
+                 syn (Chain :$ e1' :* e2' :* bind x' e4' :* End)
+
+       U.Integrate_ e1 e2 e3 -> do
+           e1' <- checkType_ SReal e1
+           e2' <- checkType_ SReal e2
+           e3' <- checkBinder SReal SProb e3
+           return . TypedAST SProb $
+                  syn (Integrate :$ e1' :* e2' :* e3' :* End)
+
+       U.Summate_ e1 e2 e3 -> do
+           TypedAST typ1 e1' <- inferType e1
+           e2' <- checkType_ typ1 e2
+           case hDiscrete_Sing typ1 of
+             Nothing -> failwith_ "Summate given bounds which are not discrete"
+             Just h1 -> inferBinder typ1 e3 $ \typ2 ee' ->
+               case hSemiring_Sing typ2 of
+                 Nothing -> failwith_ "Summate given summands which are not in a semiring"
+                 Just h2 ->
+                     return . TypedAST typ2 $
+                            syn (Summate h1 h2 :$ e1' :* e2' :* ee' :* End)
+
+       U.Product_ e1 e2 e3 -> do
+           TypedAST typ1 e1' <- inferType e1
+           e2' <- checkType_ typ1 e2
+           case hDiscrete_Sing typ1 of
+             Nothing -> failwith_ "Product given bounds which are not discrete"
+             Just h1 -> inferBinder typ1 e3 $ \typ2 e3' ->
+               case hSemiring_Sing typ2 of
+                 Nothing -> failwith_ "Product given factors which are not in a semiring"
+                 Just h2 ->
+                     return . TypedAST typ2 $
+                            syn (Product h1 h2 :$ e1' :* e2' :* e3' :* End)
+
+       U.Bucket_ e1 e2 r1 -> do
+           e1' <- checkType_ SNat e1
+           e2' <- checkType_ SNat e2
+           TypedReducer typ1 Nil1 r1' <- inferReducer r1 Nil1
+           return . TypedAST typ1 $
+                  syn (Bucket e1' e2' r1')
+
+       U.Transform_ tr es -> inferTransform sourceSpan tr es
+
+       U.Superpose_ pes -> do
+           -- TODO: clean up all this @map fst@, @map snd@, @zip@ stuff
+           mode <- getMode
+           TypedASTs typ es' <-
+               case mode of
+               StrictMode -> inferOneCheckOthers_    (L.toList $ fmap snd pes)
+               LaxMode    -> inferLubType sourceSpan (L.toList $ fmap snd pes)
+               UnsafeMode -> inferLubType sourceSpan (L.toList $ fmap snd pes)
+           unifyMeasure typ sourceSpan $ \_ -> do
+            ps' <- T.traverse (checkType SProb) (fmap fst pes)
+            return $ TypedAST typ (syn (Superpose_ (L.zip ps' (L.fromList es'))))
+
+       U.InjTyped t     -> let t' = t in return $ TypedAST (typeOf t') t'
+
+       _   | mustCheck e0 -> ambiguousMustCheck sourceSpan
+           | otherwise    -> error "inferType: missing an inferable branch!"
+
+  inferTransform
+      :: Maybe U.SourceSpan
+      -> Transform as x
+      -> U.SArgs U.U_ABT as
+      -> TypeCheckMonad (TypedAST abt)
+  inferTransform sourceSpan
+                 Expect
+                 ((Nil2, e1) U.:* (Cons2 U.ToU Nil2, e2) U.:* U.End) = do
+    let e1src = getMetadata e1
+    TypedAST typ1 e1' <- inferType_ e1
+    unifyMeasure typ1 e1src $ \typ2 -> do
+     e2' <- checkBinder typ2 SProb e2
+     return . TypedAST SProb $ syn
+       (Transform_ Expect :$ e1' :* e2' :* End)
+
+  inferTransform sourceSpan
+                 Observe
+                 ((Nil2, e1) U.:* (Nil2, e2) U.:* U.End) = do
+    let e1src = getMetadata e1
+    TypedAST typ1 e1' <- inferType_ e1
+    unifyMeasure typ1 e1src $ \typ2 -> do
+     e2' <- checkType_ typ2 e2
+     return . TypedAST typ1 $ syn
+       (Transform_ Observe :$ e1' :* e2' :* End)
+
+  inferTransform sourceSpan
+                 MCMC
+                 ((Nil2, e1) U.:* (Nil2, e2) U.:* U.End) = do
+    let e1src = getMetadata e1
+        e2src = getMetadata e2
+    TypedAST typ1 e1' <- inferType_ e1
+    TypedAST typ2 e2' <- inferType_ e2
+    unifyFun     typ1  e1src $ \typa typmb ->
+     unifyMeasure typmb e1src $ \typb ->
+     unifyMeasure typ2  e2src $ \typc ->
+     matchTypes typa typb e1src (SFun typa (SMeasure typa)) typ1 $
+     matchTypes typb typc e2src typmb typ2 $
+     return $ TypedAST (SFun typa (SMeasure typa))
+            $ syn $ Transform_ MCMC :$ e1' :* e2' :* End
+
+  inferTransform sourceSpan
+                 (Disint k)
+                 ((Nil2, e1) U.:* U.End) = do
+    let e1src = getMetadata e1
+    TypedAST typ1 e1' <- inferType_ e1
+    unifyMeasure typ1 e1src $ \typ2 ->
+     unifyPair typ2 e1src $ \typa typb ->
+     return $ TypedAST (SFun typa (SMeasure typb)) $
+     syn $ Transform_ (Disint k) :$ e1' :* End
+
+  inferTransform sourceSpan
+                 Simplify
+                 ((Nil2, e1) U.:* U.End) = do
+    TypedAST typ1 e1' <- inferType_ e1
+    return $ TypedAST typ1 $ syn (Transform_ Simplify :$ e1' :* End)
+
+  inferTransform sourceSpan
+                 Reparam
+                 ((Nil2, e1) U.:* U.End) = do
+    TypedAST typ1 e1' <- inferType_ e1
+    return $ TypedAST typ1 $ syn (Transform_ Reparam :$ e1' :* End)
+
+  inferTransform sourceSpan
+                 Summarize
+                 ((Nil2, e1) U.:* U.End) = do
+    TypedAST typ1 e1' <- inferType_ e1
+    return $ TypedAST typ1 $ syn (Transform_ Summarize :$ e1' :* End)
+
+  inferTransform _ tr _ = error $ "inferTransform{" ++ show tr ++ "}: TODO"
+
+  inferPrimOp
+      :: U.PrimOp
+      -> [U.AST]
+      -> TypeCheckMonad (TypedAST abt)
+  inferPrimOp U.Not es =
+      case es of
+        [e] -> do e' <- checkType_ sBool e
+                  return . TypedAST sBool $ syn (PrimOp_ Not :$ e' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp U.Pi es =
+      case es of
+        [] -> return . TypedAST SProb $ syn (PrimOp_ Pi :$ End)
+        _  -> argumentNumberError
+
+  inferPrimOp U.Cos es =
+      case es of
+        [e] -> do e' <- checkType_ SReal e
+                  return . TypedAST SReal $ syn (PrimOp_ Cos :$ e' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp U.RealPow es =
+      case es of
+        [e1, e2] -> do e1' <- checkType_ SProb e1
+                       e2' <- checkType_ SReal e2
+                       return . TypedAST SProb $
+                              syn (PrimOp_ RealPow :$ e1' :* e2' :* End)
+        _        -> argumentNumberError
+
+  inferPrimOp U.Choose es =
+      case es of 
+        [e1, e2] -> do e1' <- checkType_ SNat e1
+                       e2' <- checkType_ SNat e2
+                       return . TypedAST SNat $
+                              syn (PrimOp_ Choose :$ e1' :* e2' :* End)
+        _        -> argumentNumberError
+
+  inferPrimOp U.Exp es =
+      case es of
+        [e] -> do e' <- checkType_ SReal e
+                  return . TypedAST SProb $ syn (PrimOp_ Exp :$ e' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp U.Log es =
+      case es of
+        [e] -> do e' <- checkType_ SProb e
+                  return . TypedAST SReal $ syn (PrimOp_ Log :$ e' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp U.Infinity es =
+      case es of
+        [] -> return . TypedAST SProb $
+                     syn (PrimOp_ (Infinity HIntegrable_Prob) :$ End)
+        _  -> argumentNumberError
+
+  inferPrimOp U.GammaFunc es =
+      case es of
+        [e] -> do e' <- checkType_ SReal e
+                  return . TypedAST SProb $ syn (PrimOp_ GammaFunc :$ e' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp U.BetaFunc es =
+      case es of
+        [e1, e2] -> do e1' <- checkType_ SProb e1
+                       e2' <- checkType_ SProb e2
+                       return . TypedAST SProb $
+                              syn (PrimOp_ BetaFunc :$ e1' :* e2' :* End)
+        _        -> argumentNumberError
+
+  inferPrimOp U.Equal es =
+      case es of
+        [_, _] -> do mode <- getMode
+                     TypedASTs typ [e1', e2'] <-
+                         case mode of
+                           StrictMode -> inferOneCheckOthers_ es
+                           _          -> inferLubType Nothing es
+                     primop <- Equal <$> getHEq typ
+                     return . TypedAST sBool $
+                            syn (PrimOp_ primop :$ e1' :* e2' :* End)
+        _      -> argumentNumberError
+
+  inferPrimOp U.Less es =
+      case es of
+        [_, _] -> do mode <- getMode
+                     TypedASTs typ [e1', e2'] <-
+                         case mode of
+                           StrictMode -> inferOneCheckOthers_ es
+                           _          -> inferLubType Nothing es
+                     primop <- Less <$> getHOrd typ
+                     return . TypedAST sBool $
+                            syn (PrimOp_ primop :$ e1' :* e2' :* End)
+        _      -> argumentNumberError
+
+  inferPrimOp U.NatPow es =
+      case es of
+        [e1, e2] -> do TypedAST typ e1' <- inferType_ e1
+                       e2' <- checkType_ SNat e2
+                       primop <- NatPow <$> getHSemiring typ
+                       return . TypedAST typ $
+                              syn (PrimOp_ primop :$ e1' :* e2' :* End)
+        _        -> argumentNumberError
+
+  inferPrimOp U.Negate es =
+      case es of
+        [e] -> do TypedAST typ e' <- inferType_ e
+                  mode <- getMode
+                  SomeRing ring c <- getHRing typ mode
+                  primop <- Negate <$> return ring
+                  let e'' = case c of
+                              CNil -> e'
+                              c'   -> unLC_ . coerceTo c' $ LC_ e'
+                  return . TypedAST (sing_HRing ring) $
+                         syn (PrimOp_ primop :$ e'' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp U.Abs es =
+      case es of
+        [e] -> do TypedAST typ e' <- inferType_ e
+                  mode <- getMode
+                  SomeRing ring c <- getHRing typ mode
+                  primop <- Abs <$> return ring
+                  let e'' = case c of
+                              CNil -> e'
+                              c'   -> unLC_ . coerceTo c' $ LC_ e'
+                  return . TypedAST (sing_NonNegative ring) $
+                         syn (PrimOp_ primop :$ e'' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp U.Signum es =
+      case es of
+        [e] -> do TypedAST typ e' <- inferType_ e
+                  mode <- getMode
+                  SomeRing ring c <- getHRing typ mode
+                  primop <- Signum <$> return ring
+                  let e'' = case c of
+                              CNil -> e'
+                              c'   -> unLC_ . coerceTo c' $ LC_ e'
+                  return . TypedAST (sing_HRing ring) $
+                         syn (PrimOp_ primop :$ e'' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp U.Recip es =
+      case es of
+        [e] -> do TypedAST typ e' <- inferType_ e
+                  mode <- getMode
+                  SomeFractional frac c <- getHFractional typ mode
+                  primop <- Recip <$> return frac
+                  let e'' = case c of
+                              CNil -> e'
+                              c'   -> unLC_ . coerceTo c' $ LC_ e'
+                  return . TypedAST (sing_HFractional frac) $
+                         syn (PrimOp_ primop :$ e'' :* End)
+        _   -> argumentNumberError
+
+  -- BUG: Only defined for HRadical_Prob
+  inferPrimOp U.NatRoot es =
+      case es of
+        [e1, e2] -> do e1' <- checkType_ SProb e1
+                       e2' <- checkType_ SNat  e2
+                       return . TypedAST SProb $
+                              syn (PrimOp_ (NatRoot HRadical_Prob)
+                                   :$ e1' :* e2' :* End)
+        _   -> argumentNumberError
+
+  -- BUG: Only defined for HContinuous_Real
+  inferPrimOp U.Erf es =
+      case es of
+        [e] -> do e' <- checkType_ SReal e
+                  return . TypedAST SReal $
+                         syn (PrimOp_ (Erf HContinuous_Real)
+                              :$ e' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp x es
+      | Just y <- lookup x
+                 [(U.Sin  , Sin  ),
+                  (U.Cos  , Cos  ),
+                  (U.Tan  , Tan  ),
+                  (U.Asin , Asin ),
+                  (U.Acos , Acos ),
+                  (U.Atan , Atan ),
+                  (U.Sinh , Sinh ),
+                  (U.Cosh , Cosh ),
+                  (U.Tanh , Tanh ),
+                  (U.Asinh, Asinh),
+                  (U.Acosh, Acosh),
+                  (U.Atanh, Atanh)] =
+      case es of
+        [e] -> do e' <- checkType_ SReal e
+                  return . TypedAST SReal $
+                         syn (PrimOp_ y :$ e' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp U.Floor es =
+      case es of
+        [e] -> do e' <- checkType_ SProb e
+                  return . TypedAST SNat $ syn (PrimOp_ Floor :$ e' :* End)
+        _   -> argumentNumberError
+
+  inferPrimOp x _ = error ("TODO: inferPrimOp: " ++ show x)
+
+
+  inferArrayOp :: U.ArrayOp
+               -> [U.AST]
+               -> TypeCheckMonad (TypedAST abt)
+  inferArrayOp U.Index_ es =
+      case es of
+        [e1, e2] -> do TypedAST typ1 e1' <- inferType_ e1
+                       unifyArray typ1 Nothing $ \typ2 -> do
+                        e2' <- checkType_ SNat e2
+                        return . TypedAST typ2 $
+                               syn (ArrayOp_ (Index typ2) :$ e1' :* e2' :* End)
+        _        -> argumentNumberError
+
+  inferArrayOp U.Size es =
+      case es of
+        [e] -> do TypedAST typ e' <- inferType_ e
+                  unifyArray typ Nothing $ \typ1 ->
+                   return . TypedAST SNat $
+                          syn (ArrayOp_ (Size typ1) :$ e' :* End)
+        _   -> argumentNumberError
+
+  inferArrayOp U.Reduce es =
+      case es of
+        [e1, e2, e3] -> do
+           TypedAST typ e1' <- inferType_ e1
+           unifyFun typ Nothing $ \typ1 typ2 -> do
+            Refl <- jmEq1_ typ2 (SFun typ1 typ1)
+            e2' <- checkType_ typ1 e2
+            e3' <- checkType_ (SArray typ1) e3
+            return . TypedAST typ1 $
+                   syn (ArrayOp_ (Reduce typ1)
+                        :$ e1' :* e2' :* e3' :* End)
+        _            -> argumentNumberError
+
+  inferReducer :: U.Reducer xs U.U_ABT 'U.U
+               -> List1 Variable xs1
+               -> TypeCheckMonad (TypedReducer abt xs1)
+
+  inferReducer (U.R_Fanout_ r1 r2) xs = do
+      TypedReducer t1 _ r1' <- inferReducer r1 xs
+      TypedReducer t2 _ r2' <- inferReducer r2 xs
+      return (TypedReducer (sPair t1 t2) xs (Red_Fanout r1' r2'))
+
+  inferReducer (U.R_Index_ x n ix r1) xs = do
+      let (_, n') = caseBinds n
+      let b = makeVar x SNat
+      TypedReducer t1 _ r1' <- inferReducer r1 (Cons1 b xs)
+      n'' <- checkBinders xs SNat n'
+      caseBind ix $ \i ix1 ->
+          let i' = makeVar i SNat
+              (_, ix2) = caseBinds ix1 in do
+          ix3 <- pushCtx i' (checkBinders xs SNat ix2)
+          return . TypedReducer (SArray t1) xs $
+                 Red_Index n'' (bind i' ix3) r1'
+
+  inferReducer (U.R_Split_ b r1 r2) xs = do
+      TypedReducer t1 _ r1' <- inferReducer r1 xs
+      TypedReducer t2 _ r2' <- inferReducer r2 xs
+      caseBind b $ \x b1 ->
+       let (_, b2) = caseBinds b1
+           x'  = makeVar x SNat in do
+           b3 <- pushCtx x' (checkBinders xs sBool b2)
+           return . TypedReducer (sPair t1 t2) xs $
+                  (Red_Split (bind x' b3) r1' r2')
+
+  inferReducer U.R_Nop_ xs = return (TypedReducer sUnit xs Red_Nop)
+
+  inferReducer (U.R_Add_ e) xs =
+      caseBind e $ \x e1 ->
+      let (_, e2) = caseBinds e1
+          x'  = makeVar x SNat in
+          pushCtx x' $
+            inferBinders xs e2 $ \typ e3 -> do
+              h <- getHSemiring typ
+              return $ TypedReducer typ xs (Red_Add h (bind x' e3))
+
+-- TODO: can we make this lazier in the second component of 'TypedASTs'
+-- so that we can perform case analysis on the type component before
+-- actually evaluating 'checkOthers'? Problem is, even though we
+-- have the type to return we don't know whether the whole thing
+-- will succeed or not until after calling 'checkOthers'... We could
+-- handle this by changing the return type to @TypeCheckMonad (exists
+-- b. (Sing b, TypeCheckMonad [abt '[] b]))@ thereby making the
+-- staging explicit.
+--
+-- | Given a list of terms which must all have the same type, try
+-- inferring each term in order until one of them succeeds and then
+-- check all the others against that type. This is appropriate for
+-- 'StrictMode' where we won't need to insert coercions; for
+-- 'LaxMode', see 'inferLubType' instead.
+inferOneCheckOthers
+    :: forall abt
+    .  (ABT Term abt)
+    => [U.AST]
+    -> TypeCheckMonad (TypedASTs abt)
+inferOneCheckOthers = inferOne []
+    where
+    inferOne :: [U.AST] -> [U.AST] -> TypeCheckMonad (TypedASTs abt)
+    inferOne ls []
+        | null ls   = ambiguousEmptyNary Nothing
+        | otherwise = ambiguousMustCheckNary Nothing
+    inferOne ls (e:rs) = do
+        m <- try $ inferType e
+        case m of
+            Nothing                -> inferOne (e:ls) rs
+            Just (TypedAST typ e') -> do
+                ls' <- checkOthers typ ls
+                rs' <- checkOthers typ rs
+                return (TypedASTs typ (reverse ls' ++ e' : rs'))
+
+    checkOthers
+        :: forall a. Sing a -> [U.AST] -> TypeCheckMonad [abt '[] a]
+    checkOthers typ = T.traverse (checkType typ)
+
+-- | Given a list of terms which must all have the same type, infer
+-- all the terms in order and coerce them to the lub of all their
+-- types. This is appropriate for 'LaxMode' where we need to insert
+-- coercions; for 'StrictMode', see 'inferOneCheckOthers' instead.
+inferLubType
+    :: forall abt
+    .  (ABT Term abt)
+    => Maybe U.SourceSpan
+    -> [U.AST]
+    -> TypeCheckMonad (TypedASTs abt)
+inferLubType s = start
+    where
+    start :: [U.AST] -> TypeCheckMonad (TypedASTs abt)
+    start []     = ambiguousEmptyNary Nothing
+    start (u:us) = do
+        TypedAST  typ1 e1 <- inferType u
+        TypedASTs typ2 es <- F.foldlM step (TypedASTs typ1 [e1]) us
+        return (TypedASTs typ2 (reverse es))
+
+    -- TODO: inline 'F.foldlM' and then inline this, to unpack the first argument.
+    step :: TypedASTs abt -> U.AST -> TypeCheckMonad (TypedASTs abt)
+    step (TypedASTs typ1 es) u = do
+        TypedAST typ2 e2 <- inferType u
+        case findLub typ1 typ2 of
+            Nothing              -> missingLub typ1 typ2 s
+            Just (Lub typ c1 c2) ->
+                let es' = map (unLC_ . coerceTo c1 . LC_) es
+                    e2' = unLC_ . coerceTo c2 $ LC_ e2
+                in return (TypedASTs typ (e2' : es'))
+
+
+inferCaseStrict
+    :: forall abt a
+    .  (ABT Term abt)
+    => Sing a
+    -> abt '[] a
+    -> [U.Branch]
+    -> TypeCheckMonad (TypedAST abt)
+inferCaseStrict typA e1 = inferOne []
+    where
+    inferOne :: [U.Branch] -> [U.Branch] -> TypeCheckMonad (TypedAST abt)
+    inferOne ls []
+        | null ls   = ambiguousEmptyNary Nothing
+        | otherwise = ambiguousMustCheckNary Nothing
+    inferOne ls (b@(U.Branch_ pat e):rs) = do
+        SP pat' vars <- checkPattern typA pat
+        m <- try $ inferBinders vars e $ \typ e' -> do
+                    ls' <- checkOthers typ ls
+                    rs' <- checkOthers typ rs
+                    return (TypedAST typ $ syn (Case_ e1 (reverse ls' ++ (Branch pat' e') : rs')))
+        case m of
+            Nothing -> inferOne (b:ls) rs
+            Just m' -> return m'
+
+    checkOthers
+        :: forall b. Sing b -> [U.Branch] -> TypeCheckMonad [Branch a abt b]
+    checkOthers typ = T.traverse (checkBranch typA typ)
+
+inferCaseLax
+    :: forall abt a
+    .  (ABT Term abt)
+    => Maybe U.SourceSpan
+    -> Sing a
+    -> abt '[] a
+    -> [U.Branch]
+    -> TypeCheckMonad (TypedAST abt)
+inferCaseLax s typA e1 = start
+    where
+    start :: [U.Branch] -> TypeCheckMonad (TypedAST abt)
+    start []     = ambiguousEmptyNary Nothing
+    start ((U.Branch_ pat e):us) = do
+        SP pat' vars <- checkPattern typA pat
+        inferBinders vars e $ \typ1 e' -> do
+            SomeBranch typ2 bs <- F.foldlM step (SomeBranch typ1 [Branch pat' e']) us
+            return . TypedAST typ2 . syn . Case_ e1 $ reverse bs
+
+    -- TODO: inline 'F.foldlM' and then inline this, to unpack the first argument.
+    step :: SomeBranch a abt
+        -> U.Branch
+        -> TypeCheckMonad (SomeBranch a abt)
+    step (SomeBranch typB bs) (U.Branch_ pat e) = do
+        SP pat' vars <- checkPattern typA pat
+        inferBinders vars e $ \typE e' ->
+            case findLub typB typE of
+            Nothing                     -> missingLub typB typE s
+            Just (Lub typLub coeB coeE) ->
+                return $ SomeBranch typLub
+                    ( Branch pat' (coerceTo_nonLC coeE e')
+                    : map (coerceTo coeB) bs
+                    )
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- HACK: we must add the constraints that 'LCs' and 'UnLCs' are inverses.
+-- TODO: how can we do that in general rather than needing to repeat
+-- it here and in the various constructors of 'SCon'?
+checkSArgs
+    :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
+    => List1 Sing typs
+    -> [U.AST]
+    -> TypeCheckMonad (SArgs abt args)
+checkSArgs Nil1             []     = return End
+checkSArgs (Cons1 typ typs) (e:es) =
+    (:*) <$> checkType typ e <*> checkSArgs typs es
+checkSArgs _ _ =
+    error "checkSArgs: the number of types and terms doesn't match up"
+
+
+-- | Given a typing environment, a type, and a term, verify that
+-- the term satisfies the type (and produce an elaborated term):
+--
+-- > Γ ⊢ τ ∋ e ⇒ e'
+checkType
+    :: forall abt a
+    .  (ABT Term abt)
+    => Sing a
+    -> U.AST
+    -> TypeCheckMonad (abt '[] a)
+checkType = checkType_
+    where
+    -- HACK: to convince GHC to stop being stupid about resolving
+    -- the \"choice\" of @abt'@. I'm not sure why we don't need to
+    -- use this same hack when 'inferType' calls 'checkType', but whatevs.
+    inferType_ :: U.AST -> TypeCheckMonad (TypedAST abt)
+    inferType_ = inferType
+
+    checkVariable
+        :: forall b
+        .  Sing b
+        -> Maybe U.SourceSpan
+        -> Variable 'U.U
+        -> TypeCheckMonad (abt '[] b)
+    checkVariable typ0 sourceSpan x = do
+      TypedAST typ' e0' <- inferType_ (var x)
+      mode <- getMode
+      case mode of
+        StrictMode ->
+            case jmEq1 typ0 typ' of
+              Just Refl -> return e0'
+              Nothing   -> typeMismatch sourceSpan (Right typ0) (Right typ')
+        LaxMode    -> checkOrCoerce       sourceSpan e0' typ' typ0
+        UnsafeMode -> checkOrUnsafeCoerce sourceSpan e0' typ' typ0
+
+
+    checkType_
+        :: forall b. Sing b -> U.AST -> TypeCheckMonad (abt '[] b)
+    checkType_ typ0 e0 =
+      let s = getMetadata e0 in
+      caseVarSyn e0 (checkVariable typ0 s) (go s)
+      where
+      go sourceSpan t =
+        case t of
+        -- Change of direction rule suggests this doesn't need to be here
+        -- We keep it here in case, we later use a U.Lam which doesn't
+        -- carry the type of its variable 
+        U.Lam_ (U.SSing typ) e1 ->
+          unifyFun typ0 sourceSpan $ \typ1 typ2 ->
+          matchTypes typ1 typ sourceSpan () () $
+            do e1' <- checkBinder typ1 typ2 e1
+               return $ syn (Lam_ :$ e1' :* End)
+
+        U.Let_ e1 e2 -> do
+            TypedAST typ1 e1' <- inferType_ e1
+            e2' <- checkBinder typ1 typ0 e2
+            return $ syn (Let_ :$ e1' :* e2' :* End)
+
+        U.CoerceTo_ (Some2 c) e1 ->
+            case singCoerceDomCod c of
+            Nothing -> do
+                e1' <- checkType_ typ0 e1
+                return $ syn (CoerceTo_ CNil :$  e1' :* End)
+            Just (dom, cod) ->
+                matchTypes typ0 cod sourceSpan () () $ do
+                 e1' <- checkType_ dom e1
+                 return $ syn (CoerceTo_ c :$ e1' :* End)
+
+        U.UnsafeTo_ (Some2 c) e1 ->
+            case singCoerceDomCod c of
+            Nothing -> do
+                e1' <- checkType_ typ0 e1
+                return $ syn (UnsafeFrom_ CNil :$  e1' :* End)
+            Just (dom, cod) ->
+                matchTypes typ0 dom sourceSpan () () $ do
+                 e1' <- checkType_ cod e1
+                 return $ syn (UnsafeFrom_ c :$ e1' :* End)
+
+        -- TODO: Find better place to put this logic
+        U.PrimOp_ U.Infinity [] -> do
+            case typ0 of
+              SNat  -> return $
+                         syn (PrimOp_ (Infinity HIntegrable_Nat) :$ End)
+              SInt  -> checkOrCoerce sourceSpan (syn (PrimOp_ (Infinity HIntegrable_Nat) :$ End))
+                         SNat
+                         SInt
+              SProb -> return $
+                         syn (PrimOp_ (Infinity HIntegrable_Prob) :$ End)
+              SReal -> checkOrCoerce sourceSpan (syn (PrimOp_ (Infinity HIntegrable_Prob) :$ End))
+                         SProb
+                         SReal
+              _     -> failwith =<<
+                        makeErrMsg
+                         "Type Mismatch:"
+                         sourceSpan
+                         "infinity can only be checked against nat or prob"
+
+        U.Product_ e1 e2 e3 ->
+           case hSemiring_Sing typ0 of
+             Nothing -> failwith_ "Product given factors which are not in a semiring"
+             Just h2 -> do
+               TypedAST typ1 e1' <- inferType e1
+               e2' <- checkType_ typ1 e2
+               case hDiscrete_Sing typ1 of
+                 Nothing -> failwith_ "Product given bounds which are not discrete"
+                 Just h1 -> do
+                     e3' <- checkBinder typ1 typ0 e3
+                     return $ syn (Product h1 h2 :$ e1' :* e2' :* e3' :* End)
+
+        U.NaryOp_ op es -> do
+            mode <- getMode
+            case mode of
+              StrictMode -> safeNaryOp typ0
+              LaxMode    -> safeNaryOp typ0
+              UnsafeMode -> case op of
+               U.Prod -> do
+                op' <- make_NaryOp typ0 op
+                (bads, goods) <-
+                  fmap partitionEithers . T.forM es $ \e -> do
+                    r <- tryWith LaxMode (checkType_ typ0 e)
+                    case r of
+                      Just er -> return (Right er)
+                      Nothing -> do
+                        r <- try (do TypedAST t p <- inferType e
+                                     checkOrCoerce sourceSpan p t typ0)
+                        case r of
+                          Just er -> return (Right er)
+                          Nothing -> return (Left e)
+                if null bads
+                then return $ syn (NaryOp_ op' (S.fromList goods))
+                else do TypedAST typ bad <- inferType (case bads of
+                          [b] -> b
+                          _   -> syn $ U.NaryOp_ op bads)
+                        bad <- checkOrUnsafeCoerce sourceSpan bad typ typ0
+                        return (case bad:goods of
+                          [e] -> e
+                          es' -> syn $ NaryOp_ op' (S.fromList es'))
+               _ -> do
+                es' <- tryWith LaxMode (safeNaryOp typ0)
+                case es' of
+                  Just es'' -> return es''
+                  Nothing   -> do
+                    TypedAST typ e0' <- inferType (syn $ U.NaryOp_ op es)
+                    checkOrUnsafeCoerce sourceSpan e0' typ typ0
+            where
+            safeNaryOp :: forall c. Sing c -> TypeCheckMonad (abt '[] c)
+            safeNaryOp typ = do
+                op'  <- make_NaryOp typ op
+                es'  <- T.forM es $ checkType_ typ
+                return $ syn (NaryOp_ op' (S.fromList es'))
+
+        U.Pair_ e1 e2 ->
+          unifyPair typ0 sourceSpan $ \a b -> do
+           e1' <- checkType_ a e1
+           e2' <- checkType_ b e2
+           return $ syn (Datum_ $ dPair_ a b e1' e2')
+
+        U.Array_ e1 e2 ->
+            unifyArray typ0 sourceSpan $ \typ1 -> do
+             e1' <- checkType_  SNat e1
+             e2' <- checkBinder SNat typ1 e2
+             return $ syn (Array_ e1' e2')
+
+        U.ArrayLiteral_ es ->
+            unifyArray typ0 sourceSpan $ \typ1 ->
+            if null es then return $ syn (Empty_ typ0) else do
+               es' <- T.forM es $ checkType_ typ1
+               return $ syn (ArrayLiteral_ es')
+
+        U.Datum_ (U.Datum hint d) ->
+            case typ0 of
+            SData _ typ2 ->
+                (syn . Datum_ . Datum hint typ0)
+                    <$> checkDatumCode typ0 typ2 d
+            _ -> typeMismatch sourceSpan (Right typ0) (Left "HData")
+
+        U.Case_ e1 branches -> do
+            TypedAST typ1 e1' <- inferType_ e1
+            branches' <- T.forM branches $ checkBranch typ1 typ0
+            return $ syn (Case_ e1' branches')
+
+        U.Dirac_ e1 ->
+            unifyMeasure typ0 sourceSpan $ \typ1 -> do
+             e1' <- checkType_ typ1 e1
+             return $ syn (Dirac :$ e1' :* End)
+
+        U.MBind_ e1 e2 ->
+            unifyMeasure typ0 sourceSpan $ \_ -> do
+             TypedAST typ1 e1' <- inferType_ e1
+             unifyMeasure typ1 (getMetadata e1) $ \typ2 -> do
+              e2' <- checkBinder typ2 typ0 e2
+              return $ syn (MBind :$ e1' :* e2' :* End)
+
+        U.Plate_ e1 e2 ->
+            unifyMeasure typ0 sourceSpan $ \typ1 -> do
+             e1' <- checkType_ SNat e1
+             unifyArray typ1 sourceSpan $ \typ2 -> do
+              e2' <- checkBinder SNat (SMeasure typ2) e2
+              return $ syn (Plate :$ e1' :* e2' :* End)
+
+        U.Chain_ e1 e2 e3 ->
+            unifyMeasure typ0 sourceSpan $ \typ1 ->
+            unifyPair typ1 sourceSpan $ \aa s ->
+            unifyArray aa sourceSpan $ \a -> do
+              e1' <- checkType_  SNat e1
+              e2' <- checkType_  s    e2
+              e3' <- checkBinder s    (SMeasure $ sPair a s) e3
+              return $ syn (Chain :$ e1' :* e2' :* e3' :* End)
+
+        U.Transform_ tr es -> checkTransform sourceSpan typ0 tr es
+
+        U.Superpose_ pes ->
+            unifyMeasure typ0 sourceSpan $ \_ ->
+                fmap (syn . Superpose_) .
+                    T.forM pes $ \(p,e) ->
+                        (,) <$> checkType_ SProb p <*> checkType_ typ0 e
+
+        U.Reject_ ->
+            unifyMeasure typ0 sourceSpan $ \_ ->
+            return $ syn (Reject_ typ0)
+
+        U.InjTyped t ->
+            let typ1 = typeOf $ triv t
+            in case jmEq1 typ0 typ1 of
+                 Just Refl -> return t
+                 Nothing   -> typeMismatch sourceSpan (Right typ0) (Right typ1)
+
+        _   | inferable e0 -> do
+                TypedAST typ' e0' <- inferType_ e0
+                mode <- getMode
+                case mode of
+                  StrictMode ->
+                    case jmEq1 typ0 typ' of
+                    Just Refl -> return e0'
+                    Nothing   -> typeMismatch sourceSpan (Right typ0) (Right typ')
+                  LaxMode    -> checkOrCoerce       sourceSpan e0' typ' typ0
+                  UnsafeMode -> checkOrUnsafeCoerce sourceSpan e0' typ' typ0
+            | otherwise -> error "checkType: missing an mustCheck branch!"
+
+    checkTransform
+        :: Maybe U.SourceSpan
+        -> Sing x'
+        -> Transform as x
+        -> U.SArgs U.U_ABT as
+        -> TypeCheckMonad (abt '[] x')
+    checkTransform sourceSpan typ0
+                   Expect
+                   ((Nil2, e1) U.:* (Cons2 U.ToU Nil2, e2) U.:* U.End) =
+      case typ0 of
+      SProb -> do
+          TypedAST typ1 e1' <- inferType_ e1
+          unifyMeasure typ1 sourceSpan $ \typ2 -> do
+           e2' <- checkBinder typ2 typ0 e2
+           return $ syn (Transform_ Expect :$ e1' :* e2' :* End)
+      _ -> typeMismatch sourceSpan (Right typ0) (Left "HProb")
+
+    checkTransform sourceSpan typ0
+                   Observe
+                   ((Nil2, e1) U.:* (Nil2, e2) U.:* U.End) =
+      unifyMeasure typ0 sourceSpan $ \typ2 -> do
+          e1' <- checkType_ typ0 e1
+          e2' <- checkType_ typ2 e2
+          return $ syn (Transform_ Observe :$ e1' :* e2' :* End)
+
+    checkTransform sourceSpan typ0
+                   MCMC
+                   ((Nil2, e1) U.:* (Nil2, e2) U.:* U.End) =
+      unifyFun typ0 sourceSpan $ \typa typmb ->
+      unifyMeasure typmb sourceSpan $ \typb ->
+      matchTypes typa typb sourceSpan (SFun typa (SMeasure typa)) typ0 $ do
+       e1' <- checkType (SFun typa (SMeasure typa)) e1
+       e2' <- checkType            (SMeasure typa)  e2
+       return $ syn $ Transform_ MCMC :$ e1' :* e2' :* End
+
+    checkTransform sourceSpan typ0
+                   (Disint k)
+                   ((Nil2, e1) U.:* U.End) =
+      unifyFun typ0 sourceSpan $ \typa typmb ->
+      unifyMeasure typmb sourceSpan $ \typb -> do
+       e1' <- checkType (SMeasure (sPair typa typb)) e1
+       return $ syn $ Transform_ (Disint k) :$ e1' :* End
+
+    checkTransform sourceSpan typ0
+                   Simplify
+                   ((Nil2, e1) U.:* U.End) = do
+      e1' <- checkType_ typ0 e1
+      return $ syn (Transform_ Simplify :$ e1' :* End)
+
+    checkTransform sourceSpan typ0
+                   Reparam
+                   ((Nil2, e1) U.:* U.End) = do
+      e1' <- checkType_ typ0 e1
+      return $ syn (Transform_ Reparam :$ e1' :* End)
+
+    checkTransform sourceSpan typ0
+                   Summarize
+                   ((Nil2, e1) U.:* U.End) = do
+      e1' <- checkType_ typ0 e1
+      return $ syn (Transform_ Summarize :$ e1' :* End)
+
+    checkTransform _ _ tr _ = error $ "checkTransform{" ++ show tr ++ "}: TODO"
+
+    --------------------------------------------------------
+    -- We make these local to 'checkType' for the same reason we have 'checkType_'
+    -- TODO: can we combine these in with the 'checkBranch' functions somehow?
+    checkDatumCode
+        :: forall xss t
+        .  Sing (HData' t)
+        -> Sing xss
+        -> U.DCode_
+        -> TypeCheckMonad (DatumCode xss (abt '[]) (HData' t))
+    checkDatumCode typA typ d =
+        case d of
+        U.Inr d2 ->
+            case typ of
+            SPlus _ typ2 -> Inr <$> checkDatumCode typA typ2 d2
+            _            -> failwith_ "expected datum of `inr' type"
+        U.Inl d1 ->
+            case typ of
+            SPlus typ1 _ -> Inl <$> checkDatumStruct typA typ1 d1
+            _            -> failwith_ "expected datum of `inl' type"
+
+    checkDatumStruct
+        :: forall xs t
+        .  Sing (HData' t)
+        -> Sing xs
+        -> U.DStruct_
+        -> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
+    checkDatumStruct typA typ d =
+        case d of
+        U.Et d1 d2 ->
+            case typ of
+            SEt typ1 typ2 -> Et
+                <$> checkDatumFun    typA typ1 d1
+                <*> checkDatumStruct typA typ2 d2
+            _     -> failwith_ "expected datum of `et' type"
+        U.Done ->
+            case typ of
+            SDone -> return Done
+            _     -> failwith_ "expected datum of `done' type"
+
+    checkDatumFun
+        :: forall x t
+        .  Sing (HData' t)
+        -> Sing x
+        -> U.DFun_
+        -> TypeCheckMonad (DatumFun x (abt '[]) (HData' t))
+    checkDatumFun typA typ d =
+        case d of
+        U.Ident e1 ->
+            case typ of
+            SIdent      -> Ident <$> checkType_ typA e1
+            _           -> failwith_ "expected datum of `I' type"
+        U.Konst e1 ->
+            case typ of
+            SKonst typ1 -> Konst <$> checkType_ typ1 e1
+            _           -> failwith_ "expected datum of `K' type"
+
+checkBranch
+    :: (ABT Term abt)
+    => Sing a
+    -> Sing b
+    -> U.Branch
+    -> TypeCheckMonad (Branch a abt b)
+checkBranch patTyp bodyTyp (U.Branch_ pat body) = do
+    SP pat' vars <- checkPattern patTyp pat
+    Branch pat' <$> checkBinders vars bodyTyp body
+
+checkPattern
+    :: Sing a
+    -> U.Pattern
+    -> TypeCheckMonad (SomePattern a)
+checkPattern = \typA pat ->
+    case pat of
+    U.PVar x -> return $ SP PVar (Cons1 (makeVar (U.nameToVar x) typA) Nil1)
+    U.PWild  -> return $ SP PWild Nil1
+    U.PDatum hint pat1 ->
+        case typA of
+        SData _ typ1 -> do
+            SPC pat1' xs <- checkPatternCode typA typ1 pat1
+            return $ SP (PDatum hint pat1') xs
+        _ -> typeMismatch Nothing (Right typA) (Left "HData")
+    where
+    checkPatternCode
+        :: Sing (HData' t)
+        -> Sing xss
+        -> U.PCode
+        -> TypeCheckMonad (SomePatternCode xss t)
+    checkPatternCode typA typ pat =
+        case pat of
+        U.PInr pat2 ->
+            case typ of
+            SPlus _ typ2 -> do
+                SPC pat2' xs <- checkPatternCode typA typ2 pat2
+                return $ SPC (PInr pat2') xs
+            _            -> failwith_ "expected pattern of `sum' type"
+        U.PInl pat1 ->
+            case typ of
+            SPlus typ1 _ -> do
+                SPS pat1' xs <- checkPatternStruct typA typ1 pat1
+                return $ SPC (PInl pat1') xs
+            _ -> failwith_ "expected pattern of `zero' type"
+
+    checkPatternStruct
+        :: Sing (HData' t)
+        -> Sing xs
+        -> U.PStruct
+        -> TypeCheckMonad (SomePatternStruct xs t)
+    checkPatternStruct  typA typ pat =
+        case pat of
+        U.PEt pat1 pat2 ->
+            case typ of
+            SEt typ1 typ2 -> do
+                SPF pat1' xs <- checkPatternFun    typA typ1 pat1
+                SPS pat2' ys <- checkPatternStruct typA typ2 pat2
+                return $ SPS (PEt pat1' pat2') (append1 xs ys)
+            _ -> failwith_ "expected pattern of `et' type"
+        U.PDone ->
+            case typ of
+            SDone -> return $ SPS PDone Nil1
+            _     -> failwith_ "expected pattern of `done' type"
+
+    checkPatternFun
+        :: Sing (HData' t)
+        -> Sing x
+        -> U.PFun
+        -> TypeCheckMonad (SomePatternFun x t)
+    checkPatternFun typA typ pat =
+        case pat of
+        U.PIdent pat1 ->
+            case typ of
+            SIdent -> do
+                SP pat1' xs <- checkPattern typA pat1
+                return $ SPF (PIdent pat1') xs
+            _ -> failwith_ "expected pattern of `I' type"
+        U.PKonst pat1 ->
+            case typ of
+            SKonst typ1 -> do
+                SP pat1' xs <- checkPattern typ1 pat1
+                return $ SPF (PKonst pat1') xs
+            _ -> failwith_ "expected pattern of `K' type"
+
+checkOrCoerce
+    :: (ABT Term abt)
+    => Maybe (U.SourceSpan)
+    -> abt '[] a
+    -> Sing a
+    -> Sing b
+    -> TypeCheckMonad (abt '[] b)
+checkOrCoerce s e typA typB =
+    case findCoercion typA typB of
+    Just c  -> return . unLC_ . coerceTo c $ LC_ e
+    Nothing -> typeMismatch s (Right typB) (Right typA)
+
+checkOrUnsafeCoerce
+    :: (ABT Term abt)
+    => Maybe (U.SourceSpan)
+    -> abt '[] a
+    -> Sing a
+    -> Sing b
+    -> TypeCheckMonad (abt '[] b)
+checkOrUnsafeCoerce s e typA typB =
+    case findEitherCoercion typA typB of
+    Just (Unsafe  c) ->
+        return . unLC_ . coerceFrom c $ LC_ e
+    Just (Safe    c) ->
+        return . unLC_ . coerceTo c $ LC_ e
+    Just (Mixed   (_, c1, c2)) ->
+        return . unLC_ . coerceTo c2 . coerceFrom c1 $ LC_ e
+    Nothing ->
+        case (typA, typB) of
+          -- mighty, mighty hack!
+          (SMeasure typ1, SMeasure _) -> do
+            let x = Variable (pack "") 0 U.SU
+            e2' <- checkBinder typ1 typB (bind x $ syn $ U.Dirac_ (var x))
+            return $ syn (MBind :$ e :* e2' :* End)
+          (_ ,  _) -> typeMismatch s (Right typB) (Right typA)
+
+
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/TypeCheck/TypeCheckMonad.hs b/haskell/Language/Hakaru/Syntax/TypeCheck/TypeCheckMonad.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/TypeCheck/TypeCheckMonad.hs
@@ -0,0 +1,426 @@
+{-# LANGUAGE CPP
+           , ScopedTypeVariables
+           , GADTs
+           , DataKinds
+           , KindSignatures
+           , GeneralizedNewtypeDeriving
+           , TypeOperators
+           , FlexibleContexts
+           , FlexibleInstances
+           , OverloadedStrings
+           , PatternGuards
+           , Rank2Types
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+-- |
+-- Module      :  Language.Hakaru.Syntax.TypeCheck
+-- Copyright   :  Copyright (c) 2017 the Hakaru team
+-- License     :  BSD3
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Bidirectional type checking for our AST.
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.TypeCheck.TypeCheckMonad where
+
+import           Prelude hiding (id, (.))
+import           Control.Category
+import           Data.Proxy            (KProxy(..))
+import           Data.Text             (Text())
+import qualified Data.Vector           as V
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative   (Applicative(..), (<$>))
+import           Data.Monoid           (Monoid(..))
+#endif
+#if __GLASGOW_HASKELL__ > 805
+import           Control.Monad.Fail
+#endif
+import qualified Language.Hakaru.Parser.AST as U
+
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Types.DataKind (Hakaru(..), HData', HBool)
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.Coercion
+import Language.Hakaru.Types.HClasses
+    ( HEq, hEq_Sing, HOrd, hOrd_Sing, HSemiring, hSemiring_Sing
+    , hRing_Sing, sing_HRing, hFractional_Sing)
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Pretty.Concrete (prettyTypeT)
+
+-- | * Definition of the typechecking monad and related
+-- types\/functions\/instances.
+
+type Input = Maybe (V.Vector Text)
+
+type Ctx = VarSet ('KProxy :: KProxy Hakaru)
+
+data TypeCheckMode = StrictMode | LaxMode | UnsafeMode
+    deriving (Read, Show)
+
+type TypeCheckError = Text
+
+newtype TypeCheckMonad a =
+    TCM { unTCM :: Ctx
+                -> Input
+                -> TypeCheckMode
+                -> Either TypeCheckError a }
+
+runTCM :: TypeCheckMonad a -> Input -> TypeCheckMode -> Either TypeCheckError a
+runTCM m = unTCM m emptyVarSet
+
+instance Functor TypeCheckMonad where
+    fmap f m = TCM $ \ctx input mode -> fmap f (unTCM m ctx input mode)
+
+instance Applicative TypeCheckMonad where
+    pure x    = TCM $ \_ _ _ -> Right x
+    mf <*> mx = mf >>= \f -> fmap f mx
+
+-- TODO: ensure this instance has the appropriate strictness
+instance Monad TypeCheckMonad where
+    return   = pure
+    mx >>= k =
+        TCM $ \ctx input mode ->
+        unTCM mx ctx input mode >>= \x ->
+        unTCM (k x) ctx input mode
+
+#if __GLASGOW_HASKELL__ > 805
+instance MonadFail TypeCheckMonad where
+    fail = error
+#endif
+
+{-
+-- We could provide this instance, but there's no decent error
+-- message to give for the 'empty' case that works in all circumstances.
+-- Because we only would need this to define 'inferOneCheckOthers',
+-- we inline the definition there instead.
+instance Alternative TypeCheckMonad where
+    empty   = failwith "Alternative.empty"
+    x <|> y = TCM $ \ctx mode ->
+        case unTCM x ctx mode of
+        Left  _ -> unTCM y ctx mode
+        Right e -> Right e
+-}
+
+-- | Return the mode in which we're checking\/inferring types.
+getInput :: TypeCheckMonad Input
+getInput = TCM $ \_ input _ -> Right input
+
+-- | Return the mode in which we're checking\/inferring types.
+getMode :: TypeCheckMonad TypeCheckMode
+getMode = TCM $ \_ _ mode -> Right mode
+
+-- | Extend the typing context, but only locally.
+pushCtx
+    :: Variable (a :: Hakaru)
+    -> TypeCheckMonad b
+    -> TypeCheckMonad b
+pushCtx x (TCM m) = TCM (m . insertVarSet x)
+
+getCtx :: TypeCheckMonad Ctx
+getCtx = TCM $ \ctx _ _ -> Right ctx
+
+failwith :: TypeCheckError -> TypeCheckMonad r
+failwith e = TCM $ \_ _ _ -> Left e
+
+failwith_ :: TypeCheckError -> TypeCheckMonad r
+failwith_ = failwith
+
+-- TODO: some day we may want a variant of this function which
+-- returns the error message in the event that the computation fails
+-- (e.g., to provide all of them if 'inferOneCheckOthers' ultimately
+-- fails.
+--
+-- | a la @optional :: Alternative f => f a -> f (Maybe a)@ but
+-- without needing the 'empty' of the 'Alternative' class.
+try :: TypeCheckMonad a -> TypeCheckMonad (Maybe a)
+try m = TCM $ \ctx input mode -> Right $
+    case unTCM m ctx input mode of
+    Left  _ -> Nothing -- Don't worry; no side effects to unwind
+    Right e -> Just e
+
+-- | Tries to typecheck in a given mode
+tryWith :: TypeCheckMode -> TypeCheckMonad a -> TypeCheckMonad (Maybe a)
+tryWith mode m = TCM $ \ctx input _ -> Right $
+    case unTCM m ctx input mode of
+    Left  _ -> Nothing
+    Right e -> Just e
+
+-- | * Helpers for constructing error messages
+
+makeErrMsg
+    :: Text
+    -> Maybe U.SourceSpan
+    -> Text
+    -> TypeCheckMonad TypeCheckError
+makeErrMsg header sourceSpan footer = do
+  input_ <- getInput
+  case (sourceSpan, input_) of
+    (Just s, Just input) ->
+          return $ mconcat [ header
+                           , "\n"
+                           , U.printSourceSpan s input
+                           , footer
+                           ]
+    _                    ->
+          return $ mconcat [ header, "\n", footer ]
+
+-- | Fail with a type-mismatch error.
+typeMismatch
+    :: Maybe U.SourceSpan
+    -> Either Text (Sing (a :: Hakaru))
+    -> Either Text (Sing (b :: Hakaru))
+    -> TypeCheckMonad r
+typeMismatch s typ1 typ2 = failwith =<<
+    makeErrMsg
+     "Type Mismatch:"
+     s
+     (mconcat [ "expected "
+              , msg1
+              , ", found "
+              , msg2
+              ])
+    where
+    msg1 = case typ1 of { Left msg -> msg; Right typ -> prettyTypeT typ }
+    msg2 = case typ2 of { Left msg -> msg; Right typ -> prettyTypeT typ }
+
+missingInstance
+    :: Text
+    -> Sing (a :: Hakaru)
+    -> Maybe U.SourceSpan
+    -> TypeCheckMonad r
+missingInstance clas typ s = failwith =<<
+   makeErrMsg
+    "Missing Instance:"
+    s
+    (mconcat $ ["No ", clas, " instance for type ", prettyTypeT typ])
+
+missingLub
+    :: Sing (a :: Hakaru)
+    -> Sing (b :: Hakaru)
+    -> Maybe U.SourceSpan
+    -> TypeCheckMonad r
+missingLub typ1 typ2 s = failwith =<<
+    makeErrMsg
+     "Missing common type:"
+     s
+     (mconcat ["No lub of types ", prettyTypeT typ1, " and ", prettyTypeT typ2])
+
+-- we can't have free variables, so it must be a typo
+ambiguousFreeVariable
+    :: Text
+    -> Maybe U.SourceSpan
+    -> TypeCheckMonad r
+ambiguousFreeVariable x s = failwith =<<
+    makeErrMsg
+     (mconcat $ ["Name not in scope: ", x])
+     s
+     "Perhaps it is a typo?"
+
+ambiguousNullCoercion
+    :: Maybe U.SourceSpan
+    -> TypeCheckMonad r
+ambiguousNullCoercion s = failwith =<<
+    makeErrMsg
+     "Cannot infer type for null-coercion over a checking term."
+     s
+     "Please add a type annotation to either the term being coerced or the result of the coercion."
+
+ambiguousEmptyNary
+    :: Maybe U.SourceSpan
+    -> TypeCheckMonad r
+ambiguousEmptyNary s = failwith =<<
+    makeErrMsg
+     "Cannot infer unambiguous type for empty n-ary operator."
+     s
+     "Try adding an annotation on the result of the operator."
+
+ambiguousMustCheckNary
+    :: Maybe U.SourceSpan
+    -> TypeCheckMonad r
+ambiguousMustCheckNary s = failwith =<<
+    makeErrMsg
+     "Could not infer any of the arguments."
+     s
+     "Try adding a type annotation to at least one of them."
+
+ambiguousMustCheck
+    :: Maybe U.SourceSpan
+    -> TypeCheckMonad r
+ambiguousMustCheck s = failwith =<<
+    makeErrMsg
+     "Cannot infer types for checking terms."
+     s
+     "Please add a type annotation."
+
+argumentNumberError
+     :: TypeCheckMonad r
+argumentNumberError = failwith =<<
+    makeErrMsg "Argument error:" Nothing "Passed wrong number of arguments"
+
+-- | * Terms whose type is existentially quantified packed with a singleton for
+-- the type.
+
+-- BUG: haddock doesn't like annotations on GADT constructors. So
+-- here we'll avoid using the GADT syntax, even though it'd make
+-- the data type declaration prettier\/cleaner.
+-- <https://github.com/hakaru-dev/hakaru/issues/6>
+--
+-- | The @e' ∈ τ@ portion of the inference judgement.
+data TypedAST (abt :: [Hakaru] -> Hakaru -> *)
+    = forall b. TypedAST !(Sing b) !(abt '[] b)
+
+onTypedAST :: (forall b . abt '[] b -> abt '[] b) -> TypedAST abt -> TypedAST abt
+onTypedAST f (TypedAST t p) = TypedAST t (f p)
+
+onTypedASTM :: (Functor m)
+            => (forall b . abt '[] b -> m (abt '[] b))
+            -> TypedAST abt -> m (TypedAST abt)
+onTypedASTM f (TypedAST t p) = TypedAST t <$> f p
+
+elimTypedAST :: (forall b . Sing b -> abt '[] b -> x) -> TypedAST abt -> x 
+elimTypedAST f (TypedAST t p) = f t p 
+
+instance Show2 abt => Show (TypedAST abt) where
+    showsPrec p (TypedAST typ e) =
+        showParen_12 p "TypedAST" typ e
+
+
+----------------------------------------------------------------
+data TypedASTs (abt :: [Hakaru] -> Hakaru -> *)
+    = forall b. TypedASTs !(Sing b) [abt '[] b]
+
+{-
+instance Show2 abt => Show (TypedASTs abt) where
+    showsPrec p (TypedASTs typ es) =
+        showParen_1x p "TypedASTs" typ es
+-}
+
+----------------------------------------------------------------
+-- HACK: Passing this list of variables feels like a hack
+-- it would be nice if it could be removed from this datatype
+data TypedReducer (abt :: [Hakaru] -> Hakaru -> *)
+                  (xs  :: [Hakaru])
+    = forall b. TypedReducer !(Sing b) (List1 Variable xs) (Reducer abt xs b)
+
+----------------------------------------------------------------
+-- BUG: haddock doesn't like annotations on GADT constructors. So
+-- here we'll avoid using the GADT syntax, even though it'd make
+-- the data type declaration prettier\/cleaner.
+-- <https://github.com/hakaru-dev/hakaru/issues/6>
+data SomePattern (a :: Hakaru) =
+    forall vars.
+        SP  !(Pattern vars a)
+            !(List1 Variable vars)
+
+data SomePatternCode xss t =
+    forall vars.
+        SPC !(PDatumCode xss vars (HData' t))
+            !(List1 Variable vars)
+
+data SomePatternStruct xs t =
+    forall vars.
+        SPS !(PDatumStruct xs vars (HData' t))
+            !(List1 Variable vars)
+
+data SomePatternFun x t =
+    forall vars.
+        SPF !(PDatumFun x vars (HData' t))
+            !(List1 Variable vars)
+
+data SomeBranch a abt = forall b. SomeBranch !(Sing b) [Branch a abt b]
+
+-- | * Misc.
+
+makeVar :: forall (a :: Hakaru). Variable 'U.U -> Sing a -> Variable a
+makeVar (Variable hintID nameID _) typ =
+    Variable hintID nameID typ
+
+make_NaryOp :: Sing a -> U.NaryOp -> TypeCheckMonad (NaryOp a)
+make_NaryOp a U.And  = isBool a >>= \Refl -> return And
+make_NaryOp a U.Or   = isBool a >>= \Refl -> return Or
+make_NaryOp a U.Xor  = isBool a >>= \Refl -> return Xor
+make_NaryOp a U.Iff  = isBool a >>= \Refl -> return Iff
+make_NaryOp a U.Min  = Min  <$> getHOrd a
+make_NaryOp a U.Max  = Max  <$> getHOrd a
+make_NaryOp a U.Sum  = Sum  <$> getHSemiring a
+make_NaryOp a U.Prod = Prod <$> getHSemiring a
+
+isBool :: Sing a -> TypeCheckMonad (TypeEq a HBool)
+isBool typ =
+    case jmEq1 typ sBool of
+    Just proof -> return proof
+    Nothing    -> typeMismatch Nothing (Left "HBool") (Right typ)
+
+
+jmEq1_ :: Sing (a :: Hakaru)
+       -> Sing (b :: Hakaru)
+       -> TypeCheckMonad (TypeEq a b)
+jmEq1_ typA typB =
+    case jmEq1 typA typB of
+    Just proof -> return proof
+    Nothing    -> typeMismatch Nothing (Right typA) (Right typB)
+
+
+getHEq :: Sing a -> TypeCheckMonad (HEq a)
+getHEq typ =
+    case hEq_Sing typ of
+    Just theEq -> return theEq
+    Nothing    -> missingInstance "HEq" typ Nothing
+
+getHOrd :: Sing a -> TypeCheckMonad (HOrd a)
+getHOrd typ =
+    case hOrd_Sing typ of
+    Just theOrd -> return theOrd
+    Nothing     -> missingInstance "HOrd" typ Nothing
+
+getHSemiring :: Sing a -> TypeCheckMonad (HSemiring a)
+getHSemiring typ =
+    case hSemiring_Sing typ of
+    Just theSemi -> return theSemi
+    Nothing      -> missingInstance "HSemiring" typ Nothing
+
+getHRing :: Sing a -> TypeCheckMode -> TypeCheckMonad (SomeRing a)
+getHRing typ mode =
+    case mode of
+    StrictMode -> case hRing_Sing typ of
+                    Just theRing -> return (SomeRing theRing CNil)
+                    Nothing      -> missingInstance "HRing" typ Nothing
+    LaxMode    -> case findRing typ of
+                    Just proof   -> return proof
+                    Nothing      -> missingInstance "HRing" typ Nothing
+    UnsafeMode -> case findRing typ of
+                    Just proof   -> return proof
+                    Nothing      -> missingInstance "HRing" typ Nothing
+
+getHFractional :: Sing a -> TypeCheckMode -> TypeCheckMonad (SomeFractional a)
+getHFractional typ mode =
+    case mode of
+    StrictMode -> case hFractional_Sing typ of
+                    Just theFrac -> return (SomeFractional theFrac CNil)
+                    Nothing      -> missingInstance "HFractional" typ Nothing
+    LaxMode    -> case findFractional typ of
+                    Just proof   -> return proof
+                    Nothing      -> missingInstance "HFractional" typ Nothing
+    UnsafeMode -> case findFractional typ of
+                    Just proof   -> return proof
+                    Nothing      -> missingInstance "HFractional" typ Nothing
+
+-- TODO: find a better name, and move to where 'LC_' is defined.
+lc :: (LC_ abt a -> LC_ abt b) -> abt '[] a -> abt '[] b
+lc f = unLC_ . f . LC_
+
+coerceTo_nonLC :: (ABT Term abt) => Coercion a b -> abt xs a -> abt xs b
+coerceTo_nonLC = underBinders . lc . coerceTo
+
+coerceFrom_nonLC :: (ABT Term abt) => Coercion a b -> abt xs b -> abt xs a
+coerceFrom_nonLC = underBinders . lc . coerceFrom
+
+-- BUG: how to make this not an orphan, without dealing with cyclic imports between AST.hs (for the 'LC_' instance), Datum.hs, and Coercion.hs?
+instance (ABT Term abt) => Coerce (Branch a abt) where
+    coerceTo   c (Branch pat e) = Branch pat (coerceTo_nonLC   c e)
+    coerceFrom c (Branch pat e) = Branch pat (coerceFrom_nonLC c e)
diff --git a/haskell/Language/Hakaru/Syntax/TypeCheck/Unification.hs b/haskell/Language/Hakaru/Syntax/TypeCheck/Unification.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/TypeCheck/Unification.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE CPP
+           , ScopedTypeVariables
+           , GADTs
+           , DataKinds
+           , KindSignatures
+           , GeneralizedNewtypeDeriving
+           , TypeOperators
+           , FlexibleContexts
+           , FlexibleInstances
+           , OverloadedStrings
+           , PatternGuards
+           , Rank2Types
+           , LiberalTypeSynonyms
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+-- |
+-- Module      :  Language.Hakaru.Syntax.TypeCheck
+-- Copyright   :  Copyright (c) 2017 the Hakaru team
+-- License     :  BSD3
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Ad-hoc implementation of unification (ad-hoc because polytypes are
+-- inexpressible, and this module makes no attempt to express them).
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.TypeCheck.Unification where
+
+import Language.Hakaru.Syntax.TypeCheck.TypeCheckMonad
+import Language.Hakaru.Types.DataKind (Hakaru(..), HPair)
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Syntax.IClasses
+import qualified Language.Hakaru.Parser.AST as U
+import Data.Text (Text)
+
+type Metadata = Maybe U.SourceSpan
+
+type Unify1 (t :: Hakaru -> Hakaru) r x
+  =  Sing x
+  -> Metadata
+  -> (forall a . x ~ t a => Sing a -> TypeCheckMonad r)
+  -> TypeCheckMonad r
+
+type Unify2 (t :: Hakaru -> Hakaru -> Hakaru) r x
+  =  Sing x
+  -> Metadata
+  -> (forall a b . x ~ t a b => Sing a -> Sing b -> TypeCheckMonad r)
+  -> TypeCheckMonad r
+
+class TCMTypeRepr x where
+  toTypeRepr :: x -> Maybe (Either Text (Some1 (Sing :: Hakaru -> *)))
+
+instance TCMTypeRepr (Sing (x :: Hakaru)) where
+  toTypeRepr = Just . Right . Some1
+
+instance TCMTypeRepr Text where
+  toTypeRepr = Just . Left
+
+instance TCMTypeRepr () where
+  toTypeRepr () = Nothing
+
+unifyMeasure :: Unify1 'HMeasure r x
+unifyMeasure ty m k =
+  case ty of
+    SMeasure a -> k a
+    _          -> typeMismatch m (Left "HMeasure") (Right ty)
+
+unifyArray :: Unify1 'HArray r x
+unifyArray ty m k =
+  case ty of
+    SArray a -> k a
+    _        -> typeMismatch m (Left "HArray") (Right ty)
+
+unifyFun :: Unify2 '(:->) r x
+unifyFun ty m k =
+  case ty of
+    SFun a b -> k a b
+    _        -> typeMismatch m (Left ":->") (Right ty)
+
+unifyPair :: Unify2 HPair r x
+unifyPair ty m k =
+  maybe (typeMismatch m (Left "HPair") (Right ty)) id $ do
+    SData (STyCon sym `STyApp` a `STyApp` b) _ <- Just ty
+    Refl <- jmEq1 sym sSymbol_Pair
+    Just $ k a b
+
+matchTypes
+  :: (TCMTypeRepr t0, TCMTypeRepr t1)
+  => Sing (x :: Hakaru)
+  -> Sing y
+  -> Metadata
+  -> t0 -> t1
+  -> (x ~ y => TypeCheckMonad r)
+  -> TypeCheckMonad r
+matchTypes t0 t1 m e0 e1 k
+  | Just Refl <- jmEq1 t0 t1 = k
+  | otherwise                =
+    let tyRepr
+          :: TCMTypeRepr t
+          => Sing (x :: Hakaru)
+          -> t
+          -> Either Text (Some1 (Sing :: Hakaru -> *))
+        tyRepr d = maybe (Right $ Some1 d) id . toTypeRepr
+        err = typeMismatch m
+        err :: Either Text (Sing (x :: Hakaru))
+            -> Either Text (Sing (y :: Hakaru))
+            -> TypeCheckMonad r
+    in case (tyRepr t0 e0, tyRepr t1 e1) of
+         (Left a, Left b) -> err (Left a) (Left b)
+         (Left a, Right (Some1 b)) -> err (Left a) (Right b)
+         (Right (Some1 a), Left b) -> err (Right a) (Left b)
+         (Right (Some1 a), Right (Some1 b)) -> err (Right a) (Right b)
diff --git a/haskell/Language/Hakaru/Syntax/TypeOf.hs b/haskell/Language/Hakaru/Syntax/TypeOf.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/TypeOf.hs
@@ -0,0 +1,209 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , KindSignatures
+           , GADTs
+           , ScopedTypeVariables
+           , Rank2Types
+           , FlexibleContexts
+           , PolyKinds
+           , ViewPatterns
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.02.23
+-- |
+-- Module      :  Language.Hakaru.Syntax.TypeOf
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- BUG: can't put this in "Language.Hakaru.Syntax.AST.Sing" because
+-- of some sort of cyclic dependency...
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.TypeOf
+    (
+    -- * Get singletons for well-typed ABTs
+      typeOf
+    , typeOfReducer
+    -- * Implementation details
+    , getTermSing
+    ) where
+
+import qualified Data.Foldable as F
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative   (Applicative(..), (<$>))
+#endif
+
+import Language.Hakaru.Syntax.IClasses (Pair2(..), fst2, snd2)
+import Language.Hakaru.Syntax.Variable (varType)
+import Language.Hakaru.Syntax.ABT      (ABT, caseBind, paraABT)
+import Language.Hakaru.Types.DataKind  (Hakaru())
+import Language.Hakaru.Types.HClasses  (sing_HSemiring)
+import Language.Hakaru.Types.Sing      (Sing(..), sUnMeasure, sUnit, sPair)
+import Language.Hakaru.Types.Coercion
+    (singCoerceCod, singCoerceDom, Coerce(..))
+import Language.Hakaru.Syntax.Datum    (Datum(..), Branch(..))
+import Language.Hakaru.Syntax.Reducer
+import Language.Hakaru.Syntax.AST      (Term(..), SCon(..), SArgs(..)
+                                       ,typeOfTransform
+                                       ,getSArgsSing)
+import Language.Hakaru.Syntax.AST.Sing
+    (sing_PrimOp, sing_ArrayOp, sing_MeasureOp, sing_NaryOp, sing_Literal)
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- | Given any well-typed term, produce its type.
+--
+-- TODO: at present this function may throw errors; in particular,
+-- whenever encountering a 'Case_' or 'Superpose_' which is either
+-- empty or where all the branches fail. This is considered a bug
+-- (since all well-typed terms should be able to produce their
+-- types), however it only arises on programs which are (at least
+-- partially) undefined or (where defined) are the zero measure,
+-- so fixing this is a low priority. When working to correct this
+-- bug, it is strongly discouraged to try correcting it by adding
+-- singletons to the 'Case_' and 'Superpose_' constructors; since
+-- doing so will cause a lot of code to break (and therefore is not
+-- a lightweight change), as well as greatly increasing the memory
+-- cost for storing ASTs. It would be much better to consider whole
+-- programs as being something more than just the AST, thus when
+-- trying to get the type of subterms (which should be the only
+-- time we ever call this function) we should have access to some
+-- sort of context, or intern-table for type singletons, or whatever
+-- else makes something a whole program.
+--
+-- N.B., this is a bit of a hack in order to avoid using 'SingI'
+-- or needing to memoize the types of everything. You should really
+-- avoid using this function if at all possible since it's very
+-- expensive.
+typeOf :: (ABT Term abt) => abt '[] a -> Sing a
+typeOf e0 =
+    case typeOf_ e0 of
+    Left  err -> error $ "typeOf: " ++ err
+    Right typ -> typ
+
+
+-- | For private use only.
+typeOf_ :: (ABT Term abt) => abt '[] a -> Either String (Sing a)
+typeOf_
+    = unLiftSing
+    . paraABT
+        (LiftSing . return . varType)
+        (\_ _ -> LiftSing . unLiftSing) -- cast out phantoms
+        (LiftSing . getTermSing unLiftSing)
+
+
+
+typeOfReducer
+    :: Reducer abt xs a
+    -> Sing a
+typeOfReducer (Red_Fanout a b)  = sPair  (typeOfReducer a) (typeOfReducer b)
+typeOfReducer (Red_Index _ _ a) = SArray (typeOfReducer a)
+typeOfReducer (Red_Split _ a b) = sPair  (typeOfReducer a) (typeOfReducer b)
+typeOfReducer Red_Nop           = sUnit
+typeOfReducer (Red_Add h _)     = sing_HSemiring h
+
+-- | This newtype serves two roles. First we add the phantom @xs@
+-- so that we can fit this in with the types of 'paraABT'. And
+-- second, we wrap up the 'Sing' in a monad for capturing errors,
+-- so that we can bring them all the way to the top of the term
+-- before deciding whether to throw them or not.
+newtype LiftSing (xs :: [Hakaru]) (a :: Hakaru) =
+    LiftSing { unLiftSing :: Either String (Sing a) }
+
+
+----------------------------------------------------------------
+-- | This is the core of the 'Term'-algebra for computing 'typeOf'.
+-- It is exported because it is useful for constructing other
+-- 'Term'-algebras for use with 'paraABT'; namely, for callers who
+-- need singletons for every subterm while converting an ABT to
+-- something else (e.g., pretty printing).
+--
+-- The @r@ type is whatever it is you're building up via 'paraABT'.
+-- The first argument to 'getTermSing' gives some way of projecting
+-- a singleton out of @r@ (to avoid the need to map that projection
+-- over the term before calling 'getTermSing'). You can then use
+-- the resulting singleton for constructing the overall @r@ to be
+-- returned.
+--
+-- If this function returns 'Left', this is considered an error
+-- (see the description of 'typeOf'). We pose things in this form
+-- (rather than throwing the error immediately) because it enables
+-- us to automatically recover from certain error situations.
+getTermSing
+    :: forall abt r
+    .  (ABT Term abt)
+    => (forall xs a. r xs a -> Either String (Sing a))
+    -> forall a
+    .  Term (Pair2 abt r) a
+    -> Either String (Sing a)
+getTermSing singify = go
+    where
+    getSing :: forall xs a. Pair2 abt r xs a -> Either String (Sing a)
+    getSing = singify . snd2
+    {-# INLINE getSing #-}
+
+    getBranchSing
+        :: forall a b
+        .  Branch a (Pair2 abt r) b
+        -> Either String (Sing b)
+    getBranchSing (Branch _ e) = getSing e
+    {-# INLINE getBranchSing #-}
+
+    go :: forall a. Term (Pair2 abt r) a -> Either String (Sing a)
+    go (Lam_ :$ r1 :* End) =
+        caseBind (fst2 r1) $ \x _ ->
+            SFun (varType x) <$> getSing r1
+    go (App_ :$ r1 :* _ :* End) = do
+        typ1 <- getSing r1
+        case typ1 of SFun _ typ3            -> return typ3
+    go (Let_ :$ _  :* r2 :* End)    = getSing r2
+    go (CoerceTo_   c :$ r1 :* End) =
+        maybe (coerceTo   c <$> getSing r1) return (singCoerceCod c)
+    go (UnsafeFrom_ c :$ r1 :* End) =
+        maybe (coerceFrom c <$> getSing r1) return (singCoerceDom c)
+    go (PrimOp_     o :$ _)         = return . snd $ sing_PrimOp o
+    go (ArrayOp_    o :$ _)         = return . snd $ sing_ArrayOp o
+    go (MeasureOp_  o :$ _)         =
+        return . SMeasure . snd $ sing_MeasureOp o
+    go (Dirac  :$ r1 :* End)        = SMeasure <$> getSing r1
+    go (MBind  :$ _  :* r2 :* End)  = getSing r2
+    go (Plate  :$ _  :* r2 :* End)  = SMeasure . SArray . sUnMeasure <$> getSing r2
+    go (Integrate :$  _)            = return SProb
+    go (Summate _ h :$  _)          = return $ sing_HSemiring h
+    go (Product _ h :$  _)          = return $ sing_HSemiring h
+    go (Transform_ t :$ as)         =
+      typeOfTransform t <$> getSArgsSing getSing as
+    go (NaryOp_  o  _)              = return $ sing_NaryOp o
+    go (Literal_ v)                 = return $ sing_Literal v
+    go (Empty_   typ)               = return typ
+    go (Array_   _  r2)             = SArray <$> getSing r2
+    go (ArrayLiteral_ es)           = SArray <$> tryAll "ArrayLiteral_" getSing es
+    go (Bucket _ _  r)              = return (typeOfReducer r)
+    go (Datum_ (Datum _ typ _))     = return typ
+    go (Case_    _  bs) = tryAll "Case_"      getBranchSing   bs
+    go (Superpose_ pes) = tryAll "Superpose_" (getSing . snd) pes
+    go (Reject_ typ)    = return typ
+    go (_ :$ _) = error "getTermSing: the impossible happened"
+
+tryAll
+    :: F.Foldable f
+    => String
+    -> (a -> Either String b)
+    -> f a
+    -> Either String b
+tryAll name f =
+    F.foldr step (Left $ "no unique type for " ++ name)
+    where
+    step x rest =
+        case f x of
+        r@(Right _) -> r
+        Left _      -> rest
+{-# INLINE tryAll #-}
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/Uniquify.hs b/haskell/Language/Hakaru/Syntax/Uniquify.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Uniquify.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , EmptyCase
+           , ExistentialQuantification
+           , FlexibleContexts
+           , GADTs
+           , GeneralizedNewtypeDeriving
+           , KindSignatures
+           , MultiParamTypeClasses
+           , OverloadedStrings
+           , PolyKinds
+           , ScopedTypeVariables
+           , TypeFamilies
+           , TypeOperators
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2017.02.01
+-- |
+-- Module      :  Language.Hakaru.Syntax.Uniquify
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Performs renaming of Hakaru expressions to ensure globally unique variable
+-- identifiers.
+--
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.Uniquify (uniquify) where
+
+import           Control.Monad.Reader
+import           Control.Monad.State
+import           Data.Maybe                      (fromMaybe)
+import           Data.Number.Nat
+
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.AST.Eq   (Varmap)
+import           Language.Hakaru.Syntax.Gensym
+import           Language.Hakaru.Syntax.IClasses
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative
+#endif
+
+newtype Uniquifier a = Uniquifier { runUniquifier :: StateT Nat (Reader Varmap) a }
+  deriving (Functor, Applicative, Monad, MonadState Nat, MonadReader Varmap)
+
+uniquify :: (ABT Term abt) => abt '[] a -> abt '[] a
+uniquify abt = fst $ runReader (runStateT unique seed) emptyAssocs
+  where
+    unique = runUniquifier (uniquify' abt)
+    seed   = nextFreeOrBind abt
+
+uniquify'
+  :: forall abt xs a . (ABT Term abt)
+  => abt xs a
+  -> Uniquifier (abt xs a)
+uniquify' = start
+  where
+    start :: abt ys b -> Uniquifier (abt ys b)
+    start = loop . viewABT
+
+    loop :: View (Term abt) ys b -> Uniquifier (abt ys b)
+    loop (Var v)    = uniquifyVar v
+    loop (Syn s)    = fmap syn (traverse21 start s)
+    loop (Bind v b) = do
+      fresh <- freshVar v
+      let assoc = Assoc v fresh
+      -- Process the body with the updated Varmap and wrap the
+      -- result in a bind form
+      bind fresh <$> local (insertAssoc assoc) (loop b)
+
+uniquifyVar
+  :: (ABT Term abt)
+  => Variable a
+  -> Uniquifier (abt '[] a)
+uniquifyVar v = (var . fromMaybe v . lookupAssoc v) <$> ask
+
diff --git a/haskell/Language/Hakaru/Syntax/Unroll.hs b/haskell/Language/Hakaru/Syntax/Unroll.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Unroll.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , FlexibleContexts
+           , GADTs
+           , GeneralizedNewtypeDeriving
+           , MultiParamTypeClasses
+           , RankNTypes
+           , ScopedTypeVariables
+           , TypeOperators
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2017.02.01
+-- |
+-- Module      :  Language.Hakaru.Syntax.Unroll
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Performs renaming of Hakaru expressions to ensure globally unique variable
+-- identifiers.
+--
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.Unroll (renameInEnv, unroll) where
+
+import           Control.Monad.Reader
+import           Data.Maybe                     (fromMaybe)
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.AST.Eq  (Varmap)
+import           Language.Hakaru.Syntax.Prelude hiding ((>>=))
+import           Language.Hakaru.Types.HClasses
+import           Prelude                        hiding (product, (*), (+), (-),
+                                                 (==), (>=))
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative
+#endif
+
+newtype Unroll a = Unroll { runUnroll :: Reader Varmap a }
+  deriving (Functor, Applicative, Monad, MonadReader Varmap, MonadFix)
+
+rebind
+  :: (ABT Term abt, MonadFix m)
+  => Variable a
+  -> (Variable a -> m (abt xs b))
+  -> m (abt (a ': xs) b)
+rebind source f = binderM (varHint source) (varType source) $ \var' ->
+  let v = caseVarSyn var' id (const $ error "oops")
+  in f v
+
+renameInEnv
+  :: (ABT Term abt, MonadReader Varmap m, MonadFix m)
+  => Variable a
+  -> m (abt xs b)
+  -> m (abt (a ': xs) b)
+renameInEnv source action = rebind source $ \v ->
+  local (insertAssoc $ Assoc source v) action
+
+unroll :: forall abt xs a . (ABT Term abt) => abt xs a -> abt xs a
+unroll abt = runReader (runUnroll $ unroll' abt) emptyAssocs
+
+unroll' :: forall abt xs a . (ABT Term abt) => abt xs a -> Unroll (abt xs a)
+unroll' = cataABTM var_ renameInEnv (>>= unrollTerm)
+  where
+    var_ :: Variable b -> Unroll (abt '[] b)
+    var_ v = fmap (var . fromMaybe v . lookupAssoc v) ask
+
+mklet :: ABT Term abt => abt '[] b -> abt '[b] a -> abt '[] a
+mklet rhs body = syn (Let_ :$ rhs :* body :* End)
+
+mksummate, mkproduct
+  :: (ABT Term abt)
+  => HDiscrete a
+  -> HSemiring b
+  -> abt '[] a
+  -> abt '[] a
+  -> abt '[a] b
+  -> abt '[] b
+mksummate a b lo hi body = syn (Summate a b :$ lo :* hi :* body :* End)
+mkproduct a b lo hi body = syn (Product a b :$ lo :* hi :* body :* End)
+
+unrollTerm
+  :: (ABT Term abt)
+  => Term abt a
+  -> Unroll (abt '[] a)
+unrollTerm (Summate disc semi :$ lo :* hi :* body :* End) =
+  case (disc, semi) of
+    (HDiscrete_Nat, HSemiring_Nat)  -> unrollSummate disc semi lo hi body
+    (HDiscrete_Nat, HSemiring_Int)  -> unrollSummate disc semi lo hi body
+    (HDiscrete_Nat, HSemiring_Prob) -> unrollSummate disc semi lo hi body
+    (HDiscrete_Nat, HSemiring_Real) -> unrollSummate disc semi lo hi body
+
+    (HDiscrete_Int, HSemiring_Nat)  -> unrollSummate disc semi lo hi body
+    (HDiscrete_Int, HSemiring_Int)  -> unrollSummate disc semi lo hi body
+    (HDiscrete_Int, HSemiring_Prob) -> unrollSummate disc semi lo hi body
+    (HDiscrete_Int, HSemiring_Real) -> unrollSummate disc semi lo hi body
+
+unrollTerm (Product disc semi :$ lo :* hi :* body :* End) =
+  case (disc, semi) of
+    (HDiscrete_Nat, HSemiring_Nat)  -> unrollProduct disc semi lo hi body
+    (HDiscrete_Nat, HSemiring_Int)  -> unrollProduct disc semi lo hi body
+    (HDiscrete_Nat, HSemiring_Prob) -> unrollProduct disc semi lo hi body
+    (HDiscrete_Nat, HSemiring_Real) -> unrollProduct disc semi lo hi body
+
+    (HDiscrete_Int, HSemiring_Nat)  -> unrollProduct disc semi lo hi body
+    (HDiscrete_Int, HSemiring_Int)  -> unrollProduct disc semi lo hi body
+    (HDiscrete_Int, HSemiring_Prob) -> unrollProduct disc semi lo hi body
+    (HDiscrete_Int, HSemiring_Real) -> unrollProduct disc semi lo hi body
+
+unrollTerm term = return (syn term)
+
+-- Conditionally introduce a variable for the rhs if the rhs is not currently a
+-- variable already. Be careful that the provided variable has been remaped to
+-- its equivalent in the target term if altering the binding structure of the
+-- program.
+letM' :: (Functor m, MonadFix m, ABT Term abt)
+      => abt '[] a
+      -> (abt '[] a -> m (abt '[] b))
+      -> m (abt '[] b)
+letM' e f =
+  case viewABT e of
+    Var _            -> f e
+    Syn (Literal_ _) -> f e
+    _                -> letM e f
+
+unrollSummate
+  :: (ABT Term abt, HSemiring_ a, HSemiring_ b, HEq_ a)
+  => HDiscrete a
+  -> HSemiring b
+  -> abt '[] a
+  -> abt '[] a
+  -> abt '[a] b
+  -> Unroll (abt '[] b)
+unrollSummate disc semi lo hi body =
+   letM' lo $ \loVar ->
+     letM' hi $ \hiVar ->
+       let preamble = mklet loVar body
+           loop     = mksummate disc semi (loVar + one) hiVar body
+       in return $ if_ (loVar == hiVar) zero (preamble + loop)
+
+unrollProduct
+  :: (ABT Term abt, HSemiring_ a, HSemiring_ b, HEq_ a)
+  => HDiscrete a
+  -> HSemiring b
+  -> abt '[] a
+  -> abt '[] a
+  -> abt '[a] b
+  -> Unroll (abt '[] b)
+unrollProduct disc semi lo hi body =
+   letM' lo $ \loVar ->
+     letM' hi $ \hiVar ->
+       let preamble = mklet loVar body
+           loop     = mkproduct disc semi (loVar + one) hiVar body
+       in return $ if_ (loVar == hiVar) one (preamble * loop)
+
diff --git a/haskell/Language/Hakaru/Syntax/Value.hs b/haskell/Language/Hakaru/Syntax/Value.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Value.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE CPP
+           , DataKinds
+           , PolyKinds
+           , GADTs
+           , TypeOperators
+           , EmptyCase
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Language.Hakaru.Syntax.Value where
+
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Syntax.Datum
+import           Language.Hakaru.Types.HClasses
+import           Language.Hakaru.Types.DataKind
+import           Language.Hakaru.Types.Coercion
+import           Language.Hakaru.Types.Sing
+
+import           Data.STRef
+
+import qualified Data.Vector                     as V
+import qualified Data.Number.LogFloat            as LF
+import           Data.Number.Natural
+
+import qualified System.Random.MWC               as MWC
+
+data Value :: Hakaru -> * where
+     VNat     ::                !Natural -> Value 'HNat
+     VInt     ::                !Integer -> Value 'HInt
+     VProb    :: {-# UNPACK #-} !LF.LogFloat -> Value 'HProb
+     VReal    :: {-# UNPACK #-} !Double -> Value 'HReal
+
+     VDatum   :: !(Datum Value (HData' t)) -> Value (HData' t)
+
+     -- Assuming you want to consider lambdas/closures to be values.
+     -- N.B., the type below is larger than is correct; that is,
+     VLam     :: (Value a -> Value b) -> Value (a ':-> b)
+
+     -- Measures hold their importance weight and random seed
+     VMeasure :: (Value 'HProb ->
+                  MWC.GenIO    ->
+                  IO (Maybe (Value a, Value 'HProb))
+                 ) -> Value ('HMeasure a)
+     VArray   :: {-# UNPACK #-} !(V.Vector (Value a)) -> Value ('HArray a)
+
+instance Eq1 Value where
+    eq1 (VNat  a) (VNat  b)   = a == b
+    eq1 (VInt  a) (VInt  b)   = a == b
+    eq1 (VProb a) (VProb b)   = a == b
+    eq1 (VReal a) (VReal b)   = a == b
+    eq1 (VDatum a) (VDatum b) = a == b
+    eq1 (VArray a) (VArray b) = a == b
+    eq1 _        _            = False
+
+instance Eq (Value a) where
+    (==) = eq1
+
+instance Show1 Value where
+    showsPrec1 p (VNat   v)   = showsPrec  p v
+    showsPrec1 p (VInt   v)   = showsPrec  p v
+    showsPrec1 p (VProb  v)   = showsPrec  p v
+    showsPrec1 p (VReal  v)   = showsPrec  p v
+    showsPrec1 p (VDatum d)   = showsPrec1 p d
+    showsPrec1 _ (VLam   _)   = showString "<function>"
+    showsPrec1 _ (VMeasure _) = showString "<measure>"
+    showsPrec1 p (VArray e)   = showsPrec  p e
+
+instance Show (Value a) where
+    showsPrec = showsPrec1
+    show      = show1
+
+instance Coerce Value where
+    coerceTo   CNil         v = v
+    coerceTo   (CCons c cs) v = coerceTo cs (primCoerceTo c v)
+
+    coerceFrom CNil         v = v
+    coerceFrom (CCons c cs) v = primCoerceFrom c (coerceFrom cs v)
+
+instance PrimCoerce Value where
+    primCoerceTo c l =
+        case (c,l) of
+        (Signed HRing_Int,            VNat  a) -> VInt  $ fromNatural a
+        (Signed HRing_Real,           VProb a) -> VReal $ LF.fromLogFloat a
+        (Continuous HContinuous_Prob, VNat  a) ->
+            VProb $ LF.logFloat (fromIntegral (fromNatural a) :: Double)
+        (Continuous HContinuous_Real, VInt  a) -> VReal $ fromIntegral a
+
+    primCoerceFrom c l =
+        case (c,l) of
+        (Signed HRing_Int,            VInt  a) -> VNat  $ unsafeNatural a
+        (Signed HRing_Real,           VReal a) -> VProb $ LF.logFloat a
+        (Continuous HContinuous_Prob, VProb a) ->
+            VNat $ unsafeNatural $ floor (LF.fromLogFloat a :: Double)
+        (Continuous HContinuous_Real, VReal a) -> VInt  $ floor a
+
+
+lam2 :: Value (a ':-> b ':-> c) -> (Value a -> Value b -> Value c)
+lam2 (VLam f1) v1 =
+    case f1 v1 of
+    VLam f2 -> f2
+
+enumFromUntilValue
+    :: (HDiscrete a)
+    -> Value a
+    -> Value a
+    -> [Value a]
+enumFromUntilValue _ (VNat lo) (VNat hi) = map VNat (init (enumFromTo lo hi))
+enumFromUntilValue _ (VInt lo) (VInt hi) = map VInt (init (enumFromTo lo hi))
+enumFromUntilValue _ _         _         = error "Tried to iterate over a non-iterable value"
+
+data VReducer :: * -> Hakaru -> * where
+     VRed_Num    :: STRef s (Value a)
+                 -> VReducer s a
+     VRed_Unit   :: VReducer s HUnit
+     VRed_Pair   :: Sing a
+                 -> Sing b
+                 -> VReducer s a
+                 -> VReducer s b
+                 -> VReducer s (HPair a b)
+     VRed_Array  :: V.Vector (VReducer s a)
+                 -> VReducer s ('HArray a)
diff --git a/haskell/Language/Hakaru/Syntax/Variable.hs b/haskell/Language/Hakaru/Syntax/Variable.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Syntax/Variable.hs
@@ -0,0 +1,611 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , DataKinds
+           , PolyKinds
+           , FlexibleContexts
+           , DeriveDataTypeable
+           , ExistentialQuantification
+           , TypeInType
+           , UndecidableInstances
+           , ScopedTypeVariables
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.28
+-- |
+-- Module      :  Language.Hakaru.Syntax.Variable
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- An implementation of variables, for use with "Language.Hakaru.Syntax.ABT".
+----------------------------------------------------------------
+module Language.Hakaru.Syntax.Variable
+    (
+    -- * Our basic notion of variables.
+      Variable(..)
+    , varEq
+    , VarEqTypeError(..)
+    -- ** Variables with existentially quantified types
+    , KindOf
+    , SomeVariable(..)
+    
+    -- * Some helper types for \"heaps\", \"environments\", etc
+    -- ** Typing environments; aka: sets of (typed) variables
+    , VarSet(..)
+    , emptyVarSet
+    , singletonVarSet
+    , fromVarSet
+    , toVarSet
+    , toVarSet1
+    , varSetKeys
+    , insertVarSet
+    , deleteVarSet
+    , memberVarSet
+    , unionVarSet
+    , intersectVarSet
+    , sizeVarSet
+    , nextVarID
+    -- ** Substitutions; aka: maps from variables to their definitions
+    , Assoc(..)
+    , Assocs(..) -- TODO: hide the data constructors
+    , emptyAssocs
+    , singletonAssocs
+    , fromAssocs
+    , toAssocs
+    , toAssocs1
+    , insertAssoc
+    , insertOrReplaceAssoc
+    , insertAssocs
+    , lookupAssoc
+    , adjustAssoc
+    , mapAssocs
+    ) where
+
+import           Data.Proxy        (KProxy(..))
+import           Data.Typeable     (Typeable)
+import           Data.Kind
+import           Data.Text         (Text)
+import           Data.IntMap       (IntMap)
+import qualified Data.IntMap       as IM
+import           Data.Function     (on)
+import           Control.Exception (Exception, throw)
+#if __GLASGOW_HASKELL__ < 710
+import           Data.Monoid       (Monoid(..))
+#endif
+
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Semigroup
+#endif
+
+import Data.Number.Nat
+import Language.Hakaru.Syntax.IClasses
+-- TODO: factor the definition of the 'Sing' type family out from
+-- the instances, so that we can make our ABT stuff totally independent
+-- of the definition of Hakaru's types.
+import Language.Hakaru.Types.Sing
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: should we make this type abstract, or type-class it?
+
+-- TODO: alas we need to keep the Sing in order to make 'subst'
+-- typesafe... Is there any way to work around that? Maybe only
+-- define substitution for well-typed ABTs (i.e., what we produce
+-- via typechecking a plain ABT)? If we can manage to get rid of
+-- the Sing, then 'binder' and 'multibinder' would become much
+-- simpler. Alas, it looks like we also need it for 'inferType' to
+-- be well-typed... How can we avoid that?
+--
+-- TODO: what are the overhead costs of storing a Sing? Would
+-- it be cheaper to store the SingI dictionary (and a Proxy,
+-- as necessary)?
+
+
+-- | A variable is a triple of a unique identifier ('varID'), a
+-- hint for how to display things to humans ('varHint'), and a type
+-- ('varType'). Notably, the hint is only used for display purposes,
+-- and the type is only used for typing purposes; thus, the 'Eq'
+-- and 'Ord' instances only look at the unique identifier, completely
+-- ignoring the other two components. However, the 'varEq' function
+-- does take the type into consideration (but still ignores the
+-- hint).
+--
+-- N.B., the unique identifier is lazy so that we can tie-the-knot
+-- in 'binder'.
+data Variable (a :: k) = Variable
+    { varHint :: {-# UNPACK #-} !Text
+    , varID   :: Nat -- N.B., lazy!
+    , varType :: !(Sing a)
+    }
+
+-- TODO: instance Read (Variable a)
+
+-- HACK: this requires UndecidableInstances
+instance Show1 (Sing :: k -> Type) => Show1 (Variable :: k -> Type) where
+    showsPrec1 p (Variable hint i typ) =
+        showParen (p > 9)
+            ( showString "Variable "
+            . showsPrec  11 hint
+            . showString " "
+            . showsPrec  11 i
+            . showString " "
+            . showsPrec1 11 typ
+            )
+
+instance Show (Sing a) => Show (Variable a) where
+    showsPrec p (Variable hint i typ) =
+        showParen (p > 9)
+            ( showString "Variable "
+            . showsPrec  11 hint
+            . showString " "
+            . showsPrec  11 i
+            . showString " "
+            . showsPrec  11 typ
+            )
+
+-- BUG: these may not be consistent with the interpretation chosen by 'varEq'
+instance Eq1 Variable where
+    eq1 = (==) `on` varID
+
+instance Eq (Variable a) where
+    (==) = (==) `on` varID
+
+
+-- BUG: this must be consistent with the 'Eq' instance, but should
+-- also be consistent with the 'varEq' interpretation. In particular,
+-- it's not clear how to make any Ord instance consistent with
+-- interpretation #1 (unless we have some sort of `jmCompare` on
+-- types!)
+instance Ord (Variable a) where
+    compare = compare `on` varID
+
+
+-- TODO: so long as we don't go with interpretation #1 (because
+-- that'd cause consistency issues with the 'Ord' instance) we could
+-- simply use this to give a 'JmEq1' instance. Would help to minimize
+-- the number of distinct concepts floating around...
+--
+-- | Compare to variables at possibly-different types. If the
+-- variables are \"equal\", then they must in fact have the same
+-- type. N.B., it is not entirely specified what this function
+-- /means/ when two variables have the same 'varID' but different
+-- 'varType'. However, so long as we use this function everywhere,
+-- at least we'll be consistent.
+--
+-- Possible interpretations:
+--
+-- * We could /assume/ that when the 'varType's do not match the
+-- variables are not equal. Upside: we can statically guarantee
+-- that every variable is \"well-typed\" (by fiat). Downside: every
+-- type has its own variable namespace, which is very confusing.
+-- Also, the @Ord SomeVariable@ instance will be really difficult
+-- to get right.
+--
+-- * We could /require/ that whenever two 'varID's match, their
+-- 'varType's must also match. Upside: a single variable namespace.
+-- Downside: if the types do not in fact match (e.g., the preprocessing
+-- step for ensuring variable uniqueness is buggy), then we must
+-- throw (or return) an 'VarEqTypeError' exception.
+--
+-- * We could /assert/ that whenever two 'varID's match, their
+-- 'varType's must also match. Upsides: we get a single variable
+-- namespace, and we get /O(1)/ equality checking. Downsides: if
+-- the types do not in fact match, we'll probably segfault.
+--
+-- Whichever interpretation we choose, we must make sure that typing
+-- contexts, binding environments, and so on all behave consistently.
+varEq
+    :: (Show1 (Sing :: k -> Type), JmEq1 (Sing :: k -> Type))
+    => Variable (a :: k)
+    -> Variable (b :: k)
+    -> Maybe (TypeEq a b)
+{-
+-- Interpretation #1:
+varEq x y =
+    case jmEq1 (varType x) (varType y) of
+    Just Refl | x == y -> Just Refl
+    _                  -> Nothing
+-}
+-- Interpretation #2:
+varEq x y
+    | varID x == varID y =
+        case jmEq1 (varType x) (varType y) of
+        Just Refl -> Just Refl
+        Nothing   -> throw (VarEqTypeError x y)
+    | otherwise = Nothing
+{-
+-- Interpretation #3:
+varEq x y
+    | varID x == varID y = Just (unsafeCoerce Refl)
+    | otherwise          = Nothing
+-}
+
+
+-- TODO: is there any reason we ought to parameterize 'VarEqTypeError'
+-- by the kind of the variables it closes over? Packaging up the
+-- dictionaries seems fine for the 'Show' and 'Exception' instances,
+-- but maybe elsewhere?
+--
+-- | An exception type for if we need to throw an error when two
+-- variables do not have an equal 'varType'. This is mainly used
+-- when 'varEq' chooses the second interpretation.
+data VarEqTypeError where
+    VarEqTypeError
+        :: (Show1 (Sing :: k -> Type), JmEq1 (Sing :: k -> Type))
+        => {-# UNPACK #-} !(Variable (a :: k))
+        -> {-# UNPACK #-} !(Variable (b :: k))
+        -> VarEqTypeError
+    deriving (Typeable)
+
+instance Show VarEqTypeError where
+    showsPrec p (VarEqTypeError x y) =
+        showParen (p > 9)
+            ( showString "VarEqTypeError "
+            . showsPrec1 11 x
+            . showString " "
+            . showsPrec1 11 y
+            )
+
+instance Exception VarEqTypeError
+
+
+----------------------------------------------------------------
+-- TODO: switch to using 'Some1' itself? Maybe no longer a good idea, due to the need for the kind parameter...
+
+-- | Hide an existentially quantified parameter to 'Variable'.
+--
+-- Because the 'Variable' type is poly-kinded, we need to be careful
+-- not to erase too much type\/kind information. Thus, we parameterize
+-- the 'SomeVariable' type by the /kind/ of the type we existentially
+-- quantify over. This is necessary for giving 'Eq' and 'Ord'
+-- instances since we can only compare variables whose types live
+-- in the same kind.
+--
+-- N.B., the 'Ord' instance assumes that 'varEq' uses either the
+-- second or third interpretation. If 'varEq' uses the first
+-- interpretation then, the 'Eq' instance (which uses 'varEq') will
+-- be inconsistent with the 'Ord' instance!
+data SomeVariable (kproxy :: KProxy k) =
+    forall (a :: k) . SomeVariable
+        {-# UNPACK #-} !(Variable (a :: k))
+
+
+-- | Convenient synonym to refer to the kind of a type variable:
+-- @type KindOf (a :: k) = ('KProxy :: KProxy k)@
+type KindOf (a :: k) = ('KProxy :: KProxy k)
+
+
+-- This instance requires the 'JmEq1' and 'Show1' constraints because we use 'varEq'.
+instance (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type))
+    => Eq (SomeVariable (kproxy :: KProxy k))
+    where
+    SomeVariable x == SomeVariable y =
+        case varEq x y of
+        Just Refl -> True
+        Nothing   -> False
+
+
+-- This instance requires the 'JmEq1' and 'Show1' constraints because 'Ord' requires the 'Eq' instance, which in turn requires those constraints.
+instance (JmEq1 (Sing :: k -> Type), Show1 (Sing :: k -> Type))
+    => Ord (SomeVariable (kproxy :: KProxy k))
+    where
+    SomeVariable x `compare` SomeVariable y =
+        varID x `compare` varID y
+
+
+-- TODO: instance Read SomeVariable
+
+
+instance Show1 (Sing :: k -> Type)
+    => Show (SomeVariable (kproxy :: KProxy k))
+    where
+    showsPrec p (SomeVariable v) =
+        showParen (p > 9)
+            ( showString "SomeVariable "
+            . showsPrec1 11 v
+            )
+
+
+----------------------------------------------------------------
+-- | A set of (typed) variables.
+newtype VarSet (kproxy :: KProxy k) =
+    VarSet { unVarSet :: IntMap (SomeVariable kproxy) }
+
+instance Show1 (Sing :: k -> Type) => Show (VarSet (kproxy :: KProxy k)) where
+    showsPrec p (VarSet xs) =
+        showParen (p > 9)
+            ( showString "VarSet "
+            . showsPrec  11 xs
+            )
+
+instance (Eq (SomeVariable (kproxy :: KProxy k))) => Eq (VarSet kproxy) where
+  VarSet s1 == VarSet s2 = s1 == s2
+
+-- | Return the successor of the largest 'varID' of all the variables
+-- in the set. Thus, we return zero for the empty set and non-zero
+-- for non-empty sets.
+nextVarID :: VarSet kproxy -> Nat
+nextVarID (VarSet xs)
+    | IM.null xs = 0
+    | otherwise  =
+        case IM.findMax xs of
+        (_, SomeVariable x) -> 1 + varID x
+
+
+emptyVarSet :: VarSet kproxy
+emptyVarSet = VarSet IM.empty
+
+singletonVarSet :: Variable a -> VarSet (KindOf a)
+singletonVarSet x =
+    VarSet $ IM.singleton (fromNat $ varID x) (SomeVariable x)
+
+fromVarSet :: VarSet kproxy -> [SomeVariable kproxy]
+fromVarSet (VarSet xs) = IM.elems xs
+
+-- | Convert a list of variables into a variable set.
+--
+-- In the event that multiple variables have conflicting 'varID',
+-- the latter variable will be kept. This generally won't matter
+-- because we're treating the list as a /set/. In the cases where
+-- it would matter, chances are you're going to encounter a
+-- 'VarEqTypeError' sooner or later anyways.
+toVarSet :: [SomeVariable kproxy] -> VarSet kproxy
+toVarSet = VarSet . go IM.empty
+    where
+    go vars _ | vars `seq` False = error "toVarSet: the impossible happened"
+    go vars []     = vars
+    go vars (x:xs) = go (IM.insert (fromNat $ someVarID x) x vars) xs
+
+    someVarID :: SomeVariable kproxy -> Nat
+    someVarID (SomeVariable x) = varID x
+
+
+-- | Convert a list of variables into a variable set.
+--
+-- In the event that multiple variables have conflicting 'varID',
+-- the latter variable will be kept. This generally won't matter
+-- because we're treating the list as a /set/. In the cases where
+-- it would matter, chances are you're going to encounter a
+-- 'VarEqTypeError' sooner or later anyways.
+toVarSet1 :: List1 Variable (xs :: [k]) -> VarSet (kproxy :: KProxy k)
+toVarSet1 = toVarSet . someVariables
+    where
+    -- N.B., this conversion maintains the variable ordering.
+    someVariables
+        :: List1 Variable (xs :: [k])
+        -> [SomeVariable (kproxy :: KProxy k)]
+    someVariables Nil1         = []
+    someVariables (Cons1 x xs) = SomeVariable x : someVariables xs
+
+instance Semigroup (VarSet kproxy) where
+    VarSet xs <> VarSet ys = VarSet (IM.union xs ys) -- TODO: remove bias; crash if conflicting definitions
+
+instance Monoid (VarSet kproxy) where
+    mempty  = emptyVarSet
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (<>)
+#endif
+    mconcat = VarSet . IM.unions . map unVarSet
+
+varSetKeys :: VarSet a -> [Int]
+varSetKeys (VarSet set) = IM.keys set
+
+insertVarSet :: Variable a -> VarSet (KindOf a) -> VarSet (KindOf a)
+insertVarSet x (VarSet xs) =
+    case
+        IM.insertLookupWithKey
+            (\_ v' _ -> v')
+            (fromNat $ varID x)
+            (SomeVariable x)
+            xs
+    of
+    (Nothing, xs') -> VarSet xs'
+    (Just _,  _)   -> error "insertVarSet: variable is already assigned!"
+
+
+deleteVarSet :: Variable a -> VarSet (KindOf a) -> VarSet (KindOf a)
+deleteVarSet x (VarSet xs) =
+    --- BUG: use some sort of deleteLookupWithKey to make sure we got the right one...
+    VarSet $ IM.delete (fromNat $ varID x) xs
+
+
+memberVarSet
+    :: (Show1 (Sing :: k -> Type), JmEq1 (Sing :: k -> Type))
+    => Variable (a :: k)
+    -> VarSet (kproxy :: KProxy k)
+    -> Bool
+memberVarSet x (VarSet xs) =
+    -- HACK: can't use do-notation here for GADT reasons
+    case IM.lookup (fromNat $ varID x) xs of
+    Nothing                -> False
+    Just (SomeVariable x') -> 
+        case varEq x x' of
+        Nothing -> False
+        Just _  -> True
+
+-- NB: The union and intersection operations are left biased.
+-- What is the best behaviour when we have two variables with
+-- different types in the set?
+unionVarSet
+    :: forall k (kproxy :: KProxy k)
+    .  (Show1 (Sing :: k -> Type), JmEq1 (Sing :: k -> Type))
+    => VarSet kproxy
+    -> VarSet kproxy
+    -> VarSet kproxy
+unionVarSet (VarSet s1) (VarSet s2) = VarSet (IM.union s1 s2)
+
+intersectVarSet
+    :: forall k (kproxy :: KProxy k)
+    .  (Show1 (Sing :: k -> Type), JmEq1 (Sing :: k -> Type))
+    => VarSet kproxy
+    -> VarSet kproxy
+    -> VarSet kproxy
+intersectVarSet (VarSet s1) (VarSet s2) = VarSet (IM.intersection s1 s2)
+
+sizeVarSet :: VarSet a -> Int
+sizeVarSet (VarSet xs) = IM.size xs
+
+----------------------------------------------------------------
+-- BUG: haddock doesn't like annotations on GADT constructors. So
+-- here we'll avoid using the GADT syntax, even though it'd make
+-- the data type declaration prettier\/cleaner.
+-- <https://github.com/hakaru-dev/hakaru/issues/6>
+--
+-- | A pair of variable and term, both of the same Hakaru type.
+data Assoc (ast :: k -> Type)
+    = forall (a :: k) . Assoc
+        {-# UNPACK #-} !(Variable a)
+        !(ast a)
+
+instance (Show1 (Sing :: k -> Type), Show1 (ast :: k -> Type))
+    => Show (Assoc ast)
+    where
+    showsPrec p (Assoc x e) =
+        showParen (p > 9)
+            ( showString "Assoc "
+            . showsPrec1 11 x
+            . showString " "
+            . showsPrec1 11 e
+            )
+
+
+-- BUG: since multiple 'varEq'-distinct variables could have the
+-- same ID, we should really have the elements be a list of
+-- associations (or something more efficient; e.g., if 'Sing' is
+-- hashable).
+--
+-- | A set of variable\/term associations.
+--
+-- N.B., the current implementation assumes 'varEq' uses either the
+-- second or third interpretations; that is, it is impossible to
+-- have a single 'varID' be shared by multiple variables (i.e., at
+-- different types). If you really want the first interpretation,
+-- then the implementation must be updated.
+newtype Assocs ast = Assocs { unAssocs :: IntMap (Assoc ast) }
+
+instance (Show1 (Sing :: k -> Type), Show1 (ast :: k -> Type))
+    => Show (Assocs ast)
+    where
+    showsPrec p rho =
+        showParen (p > 9)
+            ( showString "toAssocs "
+            . showListWith shows (fromAssocs rho)
+            )
+
+-- | The empty set of associations.
+emptyAssocs :: Assocs abt
+emptyAssocs = Assocs IM.empty
+
+-- | A single association.
+singletonAssocs :: Variable a -> f a -> Assocs f
+singletonAssocs x e =
+    Assocs $ IM.singleton (fromNat $ varID x) (Assoc x e)
+
+-- | Convert an association list into a list of associations.
+fromAssocs :: Assocs ast -> [Assoc ast]
+fromAssocs (Assocs rho) = IM.elems rho
+
+-- | Convert a list of associations into an association list. In
+-- the event of conflict, later associations override earlier ones.
+toAssocs :: [Assoc ast] -> Assocs ast
+toAssocs = Assocs . foldl step IM.empty
+    where
+    step :: IntMap (Assoc ast) -> Assoc ast -> IntMap (Assoc ast)
+    step xes xe@(Assoc x _) = IM.insert (fromNat $ varID x) xe xes
+
+
+-- TODO: Do we also want a zipped curried variant: @List1 (Pair1 Variable ast) xs@?
+-- | Convert an unzipped list of curried associations into an
+-- association list. In the event of conflict, later associations
+-- override earlier ones.
+toAssocs1 :: List1 Variable xs -> List1 ast xs -> Assocs ast
+toAssocs1 = \xs es -> Assocs (go IM.empty xs es)
+    where
+    go  :: IntMap (Assoc ast)
+        -> List1 Variable xs
+        -> List1 ast xs
+        -> IntMap (Assoc ast)
+    -- BUG: GHC claims the patterns are non-exhaustive here
+    go m Nil1         Nil1         = m
+    go m (Cons1 x xs) (Cons1 e es) =
+        go (IM.insert (fromNat $ varID x) (Assoc x e) m) xs es
+
+instance Semigroup (Assocs abt) where
+    Assocs xs <> Assocs ys = Assocs (IM.union xs ys) -- TODO: remove bias; crash if conflicting definitions
+
+instance Monoid (Assocs abt) where
+    mempty  = emptyAssocs
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (<>)
+#endif
+    mconcat = Assocs . IM.unions . map unAssocs
+
+
+-- If we actually do have a list (etc) of variables for each ID,
+-- and want to add the new binding to whatever old ones, then it
+-- looks like there's no way to do that in one pass of both the
+-- IntMap and the list.
+--
+-- | Add an association to the set of associations.
+--
+-- HACK: if the variable is already associated with some term then
+-- we throw an error! In the future it'd be better to take some
+-- sort of continuation to decide between (a) replacing the old
+-- binding, (b) throwing an exception, or (c) safely wrapping the
+-- result up with 'Maybe'
+insertAssoc :: Assoc ast -> Assocs ast -> Assocs ast
+insertAssoc v@(Assoc x _) (Assocs xs) =
+    case IM.insertLookupWithKey (\_ v' _ -> v') (fromNat $ varID x) v xs of
+    (Nothing, xs') -> Assocs xs'
+    (Just _,  _  ) -> error "insertAssoc: variable is already assigned!"
+
+insertOrReplaceAssoc :: Assoc ast -> Assocs ast -> Assocs ast
+insertOrReplaceAssoc v@(Assoc x _) (Assocs xs) =
+    Assocs $ IM.insert (fromNat $ varID x) v xs
+
+insertAssocs :: Assocs ast -> Assocs ast -> Assocs ast
+insertAssocs (Assocs from) to = IM.foldr insertAssoc to from
+
+-- | Adjust an association so existing variable refers to different
+-- value. Does nothing if variable not present.
+adjustAssoc :: Variable (a :: k)
+            -> (Assoc ast -> Assoc ast)
+            -> Assocs ast
+            -> Assocs ast
+adjustAssoc x f (Assocs xs) =
+    Assocs $ IM.adjust f (fromNat $ varID x) xs
+
+-- | Look up a variable and return the associated term.
+--
+-- N.B., this function is robust to all interpretations of 'varEq'.
+lookupAssoc
+    :: (Show1 (Sing :: k -> Type), JmEq1 (Sing :: k -> Type))
+    => Variable (a :: k)
+    -> Assocs ast
+    -> Maybe (ast a)
+lookupAssoc x (Assocs xs) = do
+    Assoc x' e' <- IM.lookup (fromNat $ varID x) xs
+    Refl        <- varEq x x'
+    return e'
+{-
+-- for @Assocs abt = IntMap [Assoc abt]@ this should work:
+lookupAssoc x (Assocs xss) =
+    go x <$> IM.lookup (fromNat $ varID x) xss
+    where
+    go x []                 = Nothing
+    go x (Assoc x' e' : xs) =
+        case varEq x x' of
+        Just Refl -> Just e'
+        Nothing   -> go x xs
+-}
+
+mapAssocs :: (Assoc ast1 -> Assoc ast2) -> Assocs ast1 -> Assocs ast2
+mapAssocs f (Assocs xs) = Assocs (IM.map f xs)
+                
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Types/Coercion.hs b/haskell/Language/Hakaru/Types/Coercion.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Types/Coercion.hs
@@ -0,0 +1,502 @@
+{-# LANGUAGE CPP
+           , KindSignatures
+           , DataKinds
+           , GADTs
+           , StandaloneDeriving
+           , ExistentialQuantification
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2015.12.18
+-- |
+-- Module      :  Language.Hakaru.Types.Coercion
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Our theory of coercions for Hakaru's numeric hierarchy.
+----------------------------------------------------------------
+module Language.Hakaru.Types.Coercion
+    (
+    -- * The primitive coercions
+      PrimCoercion(..)
+    , PrimCoerce(..)
+
+    -- * The category of general coercions
+    , Coercion(..)
+    , singletonCoercion
+    , signed
+    , continuous
+    , Coerce(..)
+    , singCoerceDom
+    , singCoerceCod
+    , singCoerceDomCod
+
+    -- * The induced coercion hierarchy
+    , CoercionMode(..)
+    , findCoercion
+    , findEitherCoercion
+    , Lub(..)
+    , findLub
+    , SomeRing(..)
+    , findRing
+    , SomeFractional(..)
+    , findFractional
+
+    -- * Experimental optimization functions
+    {-
+    , CoerceTo_UnsafeFrom(..)
+    , simplifyCTUF
+    , UnsafeFrom_CoerceTo(..)
+    , simplifyUFCT
+    -}
+    , ZigZag(..)
+    , simplifyZZ
+    ) where
+
+import Prelude          hiding (id, (.))
+import Control.Category (Category(..))
+#if __GLASGOW_HASKELL__ < 710
+import Data.Functor        ((<$>))
+#endif
+import Control.Applicative ((<|>))
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Syntax.IClasses
+    (TypeEq(..), Eq1(..), Eq2(..), JmEq1(..), JmEq2(..))
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- TODO: (?) coercing HMeasure by coercing the underlying measure space.
+-- TODO: lifting coercion over (:->), to avoid the need for eta-expansion
+-- TODO: lifting coersion over datatypes, to avoid traversing them at runtime
+-- TODO: see how GHC handles lifting coersions these days...
+
+-- N.B., we don't need to store the dictionary values here, we can recover them by typeclass (using -XScopedTypeVariables).
+--
+-- | Primitive proofs of the inclusions in our numeric hierarchy.
+data PrimCoercion :: Hakaru -> Hakaru -> * where
+    Signed     :: !(HRing a)       -> PrimCoercion (NonNegative a) a
+    Continuous :: !(HContinuous a) -> PrimCoercion (HIntegral   a) a
+
+-- TODO: instance Read (PrimCoercion a b)
+deriving instance Show (PrimCoercion a b)
+
+instance Eq (PrimCoercion a b) where -- this one could be derived
+    (==) = eq1
+instance Eq1 (PrimCoercion a) where
+    eq1 = eq2
+instance Eq2 PrimCoercion where
+    eq2 x y = maybe False (const True) (jmEq2 x y)
+instance JmEq1 (PrimCoercion a) where
+    jmEq1 x y = snd <$> jmEq2 x y
+instance JmEq2 PrimCoercion where
+    jmEq2 (Signed r1) (Signed r2) =
+        jmEq1 r1 r2 >>= \Refl -> Just (Refl, Refl)
+    jmEq2 (Continuous c1) (Continuous c2) =
+        jmEq1 c1 c2 >>= \Refl -> Just (Refl, Refl)
+    jmEq2 _ _ = Nothing
+
+
+----------------------------------------------------------------
+-- | General proofs of the inclusions in our numeric hierarchy.
+-- Notably, being a partial order, 'Coercion' forms a category. In
+-- addition to the 'Category' instance, we also have the class
+-- 'Coerce' for functors from 'Coercion' to the category of Haskell
+-- functions, and you can get the co\/domain objects (via
+-- 'singCoerceDom', 'singCoerceCod', or 'singCoerceDomCod').
+data Coercion :: Hakaru -> Hakaru -> * where
+    -- BUG: haddock doesn't like annotations on GADT constructors
+    -- <https://github.com/hakaru-dev/hakaru/issues/6>
+
+    -- Added the trivial coercion so we get the Category instance.
+    -- This may/should make program transformations easier to write
+    -- by allowing more intermediate ASTs, but will require a cleanup
+    -- pass afterwards to remove the trivial coercions.
+    CNil :: Coercion a a
+
+    -- TODO: but sometimes we need the snoc-based inductive hypothesis...
+    -- We use a cons-based approach rather than append-based in
+    -- order to get a better inductive hypothesis.
+    CCons :: !(PrimCoercion a b) -> !(Coercion b c) -> Coercion a c
+
+infixr 5 `CCons`
+
+-- TODO: instance Read (Coercion a b)
+deriving instance Show (Coercion a b)
+
+instance Eq  (Coercion a b) where
+    (==) = eq1
+instance Eq1 (Coercion a) where
+    eq1 = eq2
+instance Eq2 Coercion where
+    eq2 CNil         CNil         = True
+    eq2 (CCons x xs) (CCons y ys) =
+      case jmEq2 x y of
+         Just (Refl, Refl) -> eq2 xs ys
+         Nothing -> False
+    eq2 _            _            = False
+
+-- TODO: the JmEq2 and JmEq1 instances
+
+instance Category Coercion where
+    id = CNil
+    xs . CNil       = xs
+    xs . CCons y ys = CCons y (xs . ys)
+
+
+-- BUG: GHC 7.8 does not allow making these into pattern synonyms:
+-- (1) it disallows standalone type signatures for pattern synonyms,
+-- so we'd need to give it as an annotation, which isn't too terrible;
+-- but, (2) it does not allow polymorphic pattern synonyms :(
+
+-- | A smart constructor for lifting 'PrimCoercion' into 'Coercion'
+singletonCoercion :: PrimCoercion a b -> Coercion a b
+singletonCoercion c = CCons c CNil
+
+-- | A smart constructor for 'Signed'.
+signed :: (HRing_ a) => Coercion (NonNegative a) a
+signed = singletonCoercion $ Signed hRing
+
+-- | A smart constructor for 'Continuous'.
+continuous :: (HContinuous_ a) => Coercion (HIntegral a) a
+continuous = singletonCoercion $ Continuous hContinuous
+
+
+----------------------------------------------------------------
+-- | This class defines a mapping from 'PrimCoercion' to the @(->)@
+-- category. (Technically these mappings aren't functors, since
+-- 'PrimCoercion' doesn't form a category.) It's mostly used for
+-- defining the analogous 'Coerce' instance; that is, given a
+-- @PrimCoerce F@ instance, we have the following canonical @Coerce
+-- F@ instance:
+--
+-- > instance Coerce F where
+-- >     coerceTo   CNil         s = s
+-- >     coerceTo   (CCons c cs) s = coerceTo cs (primCoerceTo c s)
+-- >
+-- >     coerceFrom CNil         s = s
+-- >     coerceFrom (CCons c cs) s = primCoerceFrom c (coerceFrom cs s)
+--
+class PrimCoerce (f :: Hakaru -> *) where
+    primCoerceTo   :: PrimCoercion a b -> f a -> f b
+    primCoerceFrom :: PrimCoercion a b -> f b -> f a
+
+instance PrimCoerce (Sing :: Hakaru -> *) where
+    primCoerceTo (Signed theRing) s =
+        case jmEq1 s (sing_NonNegative theRing) of
+        Just Refl -> sing_HRing theRing
+        Nothing   -> error "primCoerceTo@Sing: the impossible happened"
+    primCoerceTo (Continuous theCont) s =
+        case jmEq1 s (sing_HIntegral theCont) of
+        Just Refl -> sing_HContinuous theCont
+        Nothing   -> error "primCoerceTo@Sing: the impossible happened"
+
+    primCoerceFrom (Signed theRing) s =
+        case jmEq1 s (sing_HRing theRing) of
+        Just Refl -> sing_NonNegative theRing
+        Nothing   -> error "primCoerceFrom@Sing: the impossible happened"
+    primCoerceFrom (Continuous theCont) s =
+        case jmEq1 s (sing_HContinuous theCont) of
+        Just Refl -> sing_HIntegral theCont
+        Nothing   -> error "primCoerceFrom@Sing: the impossible happened"
+
+
+-- | This class defines functors from the 'Coercion' category to
+-- the @(->)@ category. It's mostly used for defining smart
+-- constructors that implement the coercion in @f@. We don't require
+-- a 'PrimCoerce' constraint (because we never need it), but given
+-- a @Coerce F@ instance, we have the following canonical @PrimCoerce
+-- F@ instance:
+--
+-- > instance PrimCoerce F where
+-- >     primCoerceTo   c = coerceTo   (singletonCoercion c)
+-- >     primCoerceFrom c = coerceFrom (singletonCoercion c)
+--
+class Coerce (f :: Hakaru -> *) where
+    coerceTo   :: Coercion a b -> f a -> f b
+    coerceFrom :: Coercion a b -> f b -> f a
+
+instance Coerce (Sing :: Hakaru -> *) where
+    coerceTo   CNil         s = s
+    coerceTo   (CCons c cs) s = coerceTo cs (primCoerceTo c s)
+
+    coerceFrom CNil         s = s
+    coerceFrom (CCons c cs) s = primCoerceFrom c (coerceFrom cs s)
+
+----------------------------------------------------------------
+singPrimCoerceDom :: PrimCoercion a b -> Sing a
+singPrimCoerceDom (Signed     theRing) = sing_NonNegative theRing
+singPrimCoerceDom (Continuous theCont) = sing_HIntegral   theCont
+
+singPrimCoerceCod :: PrimCoercion a b -> Sing b
+singPrimCoerceCod (Signed     theRing) = sing_HRing       theRing
+singPrimCoerceCod (Continuous theCont) = sing_HContinuous theCont
+
+
+-- | Return a singleton for the domain type, or 'Nothing' if it's
+-- the 'CNil' coercion.
+singCoerceDom :: Coercion a b -> Maybe (Sing a)
+singCoerceDom CNil           = Nothing
+singCoerceDom (CCons c CNil) = Just $ singPrimCoerceDom c
+singCoerceDom (CCons c cs)   = primCoerceFrom c <$> singCoerceDom cs
+
+-- | Return a singleton for the codomain type, or 'Nothing' if it's
+-- the 'CNil' coercion.
+singCoerceCod :: Coercion a b -> Maybe (Sing b)
+singCoerceCod CNil           = Nothing
+singCoerceCod (CCons c CNil) = Just $ singPrimCoerceCod c
+singCoerceCod (CCons c cs)   = Just . coerceTo cs $ singPrimCoerceCod c
+
+-- | Return singletons for the domain and codomain types, or 'Nothing'
+-- if it's the 'CNil' coercion. If you need both types, this is a
+-- bit more efficient than calling 'singCoerceDom' and 'singCoerceCod'
+-- separately.
+singCoerceDomCod :: Coercion a b -> Maybe (Sing a, Sing b)
+singCoerceDomCod CNil           = Nothing
+singCoerceDomCod (CCons c CNil) =
+    Just (singPrimCoerceDom c, singPrimCoerceCod c)
+singCoerceDomCod (CCons c cs)   = do
+    dom <- singCoerceDom cs
+    Just (primCoerceFrom c dom
+        , coerceTo cs $ singPrimCoerceCod c
+        )
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- | Given two types, find a coercion from the first to the second,
+-- or return 'Nothing' if there is no such coercion.
+findCoercion :: Sing a -> Sing b -> Maybe (Coercion a b)
+findCoercion SNat  SInt  = Just signed
+findCoercion SProb SReal = Just signed
+findCoercion SNat  SProb = Just continuous
+findCoercion SInt  SReal = Just continuous
+findCoercion SNat  SReal = Just (continuous . signed)
+findCoercion a     b     = jmEq1 a b >>= \Refl -> Just CNil
+
+
+-- | Given two types, find a coercion where an unsafe
+-- coercion, followed by a safe coercion are needed to
+-- coerce the first type into the second, return otherwise
+findMixedCoercion
+    :: Sing a
+    -> Sing b
+    -> Maybe (Sing 'HNat, Coercion 'HNat a, Coercion 'HNat b)
+findMixedCoercion SProb SInt  = Just (SNat, continuous, signed)
+findMixedCoercion SInt  SProb = Just (SNat, signed, continuous)
+findMixedCoercion _     _     = Nothing
+
+data CoercionMode a b = 
+              Safe   (Coercion a b)
+  |           Unsafe (Coercion b a)
+  | forall c. Mixed  (Sing c, Coercion c a, Coercion c b)                
+
+-- | Given two types, find either a coercion from the first to the
+-- second or a coercion from the second to the first, or returns
+-- 'Nothing' if there is neither such coercion.
+--
+-- If the two types are equal, then we preferentially return the
+-- @Coercion a b@. The ordering of the 'Either' is so that we
+-- consider the @Coercion a b@ direction \"success\" in the 'Either'
+-- monad (which also expresses our bias when the types are equal).
+findEitherCoercion
+    :: Sing a
+    -> Sing b
+    -> Maybe (CoercionMode a b)
+findEitherCoercion a b =
+    (Safe   <$> findCoercion a b) <|>
+    (Unsafe <$> findCoercion b a) <|>
+    (Mixed  <$> findMixedCoercion a b)
+
+
+-- | An upper bound of two types, with the coercions witnessing its
+-- upperbound-ness. The type itself ensures that we have /some/
+-- upper bound; but in practice we assume it is in fact the /least/
+-- upper bound.
+data Lub (a :: Hakaru) (b :: Hakaru)
+    = forall c. Lub !(Sing c) !(Coercion a c) !(Coercion b c)
+
+
+-- TODO: is there any way we can reuse 'findCoercion' to DRY?
+-- | Given two types, find their least upper bound.
+findLub :: Sing a -> Sing b -> Maybe (Lub a b)
+-- cases where @a < b@:
+findLub SNat  SInt  = Just $ Lub SInt  signed CNil
+findLub SProb SReal = Just $ Lub SReal signed CNil
+findLub SNat  SProb = Just $ Lub SProb continuous CNil
+findLub SInt  SReal = Just $ Lub SReal continuous CNil
+findLub SNat  SReal = Just $ Lub SReal (continuous . signed) CNil
+-- the symmetric cases where @b < a@:
+findLub SInt  SNat  = Just $ Lub SInt  CNil signed
+findLub SReal SProb = Just $ Lub SReal CNil signed
+findLub SProb SNat  = Just $ Lub SProb CNil continuous
+findLub SReal SInt  = Just $ Lub SReal CNil continuous
+findLub SReal SNat  = Just $ Lub SReal CNil (continuous . signed)
+-- cases where the lub is different from both @a@ and @b@:
+findLub SInt  SProb = Just $ Lub SReal continuous signed
+findLub SProb SInt  = Just $ Lub SReal signed continuous
+-- case where @a == b@:
+findLub a     b     = jmEq1 a b >>= \Refl -> Just $ Lub a CNil CNil
+
+
+data SomeRing (a :: Hakaru)
+    = forall b. SomeRing !(HRing b) !(Coercion a b)
+
+-- | Give a type, finds the smallest coercion to another
+-- with a HRing instance
+findRing :: Sing a -> Maybe (SomeRing a)
+findRing SNat  = Just (SomeRing HRing_Int  signed)
+findRing SInt  = Just (SomeRing HRing_Int  CNil)
+findRing SProb = Just (SomeRing HRing_Real signed)
+findRing SReal = Just (SomeRing HRing_Real CNil)
+findRing _     = Nothing
+
+data SomeFractional (a :: Hakaru)
+    = forall b. SomeFractional !(HFractional b) !(Coercion a b)
+
+-- | Give a type, finds the smallest coercion to another
+-- with a HFractional instance
+findFractional :: Sing a -> Maybe (SomeFractional a)
+findFractional SNat  = Just (SomeFractional HFractional_Prob continuous)
+findFractional SInt  = Just (SomeFractional HFractional_Real continuous)
+findFractional SProb = Just (SomeFractional HFractional_Prob CNil)
+findFractional SReal = Just (SomeFractional HFractional_Real CNil)
+findFractional _     = Nothing
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+data CoerceTo_UnsafeFrom :: Hakaru -> Hakaru -> * where
+    CTUF :: !(Coercion b c) -> !(Coercion b a) -> CoerceTo_UnsafeFrom a c
+
+-- BUG: deriving instance Eq   (CoerceTo_UnsafeFrom a b)
+-- BUG: deriving instance Read (CoerceTo_UnsafeFrom a b)
+deriving instance Show (CoerceTo_UnsafeFrom a b)
+
+-- TODO: handle the fact that certain coercions commute over one another!
+simplifyCTUF :: CoerceTo_UnsafeFrom a c -> CoerceTo_UnsafeFrom a c
+simplifyCTUF (CTUF xs ys) =
+    case xs of
+    CNil        -> CTUF CNil ys
+    CCons x xs' ->
+        case ys of
+        CNil        -> CTUF xs CNil
+        CCons y ys' ->
+            case jmEq2 x y of
+            Just (Refl, Refl) -> simplifyCTUF (CTUF xs' ys')
+            Nothing           -> CTUF xs ys
+
+----------------------------------------------------------------
+-- | Choose the other inductive hypothesis.
+data RevCoercion :: Hakaru -> Hakaru -> * where
+    CLin  :: RevCoercion a a
+    CSnoc :: !(RevCoercion a b) -> !(PrimCoercion b c) -> RevCoercion a c
+
+-- BUG: deriving instance Eq   (RevCoercion a b)
+-- BUG: deriving instance Read (RevCoercion a b)
+deriving instance Show (RevCoercion a b)
+
+instance Category RevCoercion where
+    id = CLin
+    CLin . xs       = xs
+    CSnoc ys y . xs = CSnoc (ys . xs) y
+
+revCons :: PrimCoercion a b -> RevCoercion b c -> RevCoercion a c
+revCons x CLin         = CSnoc CLin x
+revCons x (CSnoc ys y) = CSnoc (revCons x ys) y
+
+toRev :: Coercion a b -> RevCoercion a b
+toRev CNil         = CLin
+toRev (CCons x xs) = revCons x (toRev xs)
+
+obvSnoc :: Coercion a b -> PrimCoercion b c -> Coercion a c
+obvSnoc CNil         y = CCons y CNil
+obvSnoc (CCons x xs) y = CCons x (obvSnoc xs y)
+
+fromRev :: RevCoercion a b -> Coercion a b
+fromRev CLin         = CNil
+fromRev (CSnoc xs x) = obvSnoc (fromRev xs) x
+
+data UnsafeFrom_CoerceTo :: Hakaru -> Hakaru -> * where
+    UFCT
+        :: !(Coercion c b)
+        -> !(Coercion a b)
+        -> UnsafeFrom_CoerceTo a c
+
+-- BUG: deriving instance Eq   (UnsafeFrom_CoerceTo a b)
+-- BUG: deriving instance Read (UnsafeFrom_CoerceTo a b)
+deriving instance Show (UnsafeFrom_CoerceTo a b)
+
+data RevUFCT :: Hakaru -> Hakaru -> * where
+    RevUFCT :: !(RevCoercion c b) -> !(RevCoercion a b) -> RevUFCT a c
+        
+-- TODO: handle the fact that certain coercions commute over one another!
+-- N.B., This version can be tricky to get to type check because our associated type families aren't guaranteed injective.
+simplifyUFCT :: UnsafeFrom_CoerceTo a c -> UnsafeFrom_CoerceTo a c
+simplifyUFCT (UFCT xs ys) =
+    case simplifyRevUFCT $ RevUFCT (toRev xs) (toRev ys) of
+    RevUFCT xs' ys' -> UFCT (fromRev xs') (fromRev ys')
+
+simplifyRevUFCT :: RevUFCT a c -> RevUFCT a c
+simplifyRevUFCT (RevUFCT xs ys) =
+    case xs of
+    CLin        -> RevUFCT CLin ys
+    CSnoc xs' x ->
+        case ys of
+        CLin        -> RevUFCT xs CLin
+        CSnoc ys' y ->
+            case jmEq2 x y of
+            Just (Refl, Refl) -> simplifyRevUFCT (RevUFCT xs' ys')
+            Nothing           -> RevUFCT xs ys
+
+
+-- TODO: implement a simplifying pass for pushing/gathering coersions over other things (e.g., Less/Equal)
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+-- | An arbitrary composition of safe and unsafe coercions.
+data ZigZag :: Hakaru -> Hakaru -> * where
+    ZRefl :: ZigZag a a
+    Zig   :: !(Coercion a b) -> !(ZigZag b c) -> ZigZag a c
+    Zag   :: !(Coercion b a) -> !(ZigZag b c) -> ZigZag a c
+
+-- BUG: deriving instance Eq   (ZigZag a b)
+-- BUG: deriving instance Read (ZigZag a b)
+deriving instance Show (ZigZag a b)
+
+-- TODO: whenever we build up a new ZigZag from the remains of a simplification step, do we need to resimplify? If so, how can we avoid quadratic behavior? cf., <http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/fc-normalization-rta.pdf> Also, try just doing a shortest-path problem on the graph of coercions (since we can get all the singletons along the way)
+-- TODO: handle the fact that certain coercions commute over one another!
+simplifyZZ :: ZigZag a b -> ZigZag a b
+simplifyZZ ZRefl      = ZRefl
+simplifyZZ (Zig x xs) =
+    case simplifyZZ xs of
+    ZRefl   -> Zig x ZRefl
+    Zig y z -> Zig (y . x) z
+    Zag y z ->
+        -- TODO: can we optimize this to avoid reversing things?
+        case simplifyUFCT (UFCT x y) of
+        UFCT CNil CNil -> z
+        UFCT CNil y'   -> Zag y' z
+        UFCT x'   CNil -> Zig x' z
+        UFCT x'   y'   -> Zig x' (Zag y' z)
+simplifyZZ (Zag x xs) =
+    case simplifyZZ xs of
+    ZRefl   -> Zag x ZRefl
+    Zag y z -> Zag (x . y) z
+    Zig y z ->
+        case simplifyCTUF (CTUF x y) of
+        CTUF CNil CNil -> z
+        CTUF CNil y'   -> Zig y' z
+        CTUF x'   CNil -> Zag x' z
+        CTUF x'   y'   -> Zag x' (Zig y' z)
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Types/DataKind.hs b/haskell/Language/Hakaru/Types/DataKind.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Types/DataKind.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE DataKinds
+           , PolyKinds
+           , TypeOperators
+           , TypeFamilies
+           , StandaloneDeriving
+           , DeriveDataTypeable
+           , ScopedTypeVariables
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.28
+-- |
+-- Module      :  Language.Hakaru.Types.DataKind
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- A data-kind for the universe of Hakaru types.
+----------------------------------------------------------------
+module Language.Hakaru.Types.DataKind
+    (
+    -- * The core definition of Hakaru types
+      Hakaru(..)
+    , HakaruFun(..)
+    , HakaruCon(..) 
+    -- *
+    , Symbol
+    , Code
+    , HData'
+    -- * Some \"built-in\" types
+    -- Naturally, these aren't actually built-in, otherwise they'd
+    -- be part of the 'Hakaru' data-kind.
+    , HBool, HUnit, HPair, HEither, HList, HMaybe
+    ) where
+
+import Data.Typeable (Typeable)
+import GHC.TypeLits (Symbol)
+
+----------------------------------------------------------------
+-- BUG: can't define the fixity of @(':->)@
+infixr 0 :->
+
+-- | The universe\/kind of Hakaru types.
+data Hakaru
+    = HNat -- ^ The natural numbers; aka, the non-negative integers.
+
+    -- TODO: in terms of Summate (etc), do we consider this to include omega?
+    -- | The integers.
+    | HInt
+
+    -- | Non-negative real numbers. Unlike what you might expect,
+    -- this is /not/ restructed to the @[0,1]@ interval!
+    | HProb
+
+    -- | The affinely extended real number line. That is, the real
+    -- numbers extended with positive and negative infinities.
+    | HReal
+
+    -- TODO: so much of our code has to distinguish between monadic and pure stuff. Maybe we should just break this out into a separate larger universe?
+    -- | The measure monad
+    | HMeasure !Hakaru
+
+    -- | The built-in type for uniform arrays.
+    | HArray !Hakaru
+
+    -- | The type of Hakaru functions.
+    | !Hakaru :-> !Hakaru
+
+    -- TODO: do we need to actually store the code? or can we get away with just requiring that the particular HakaruCon has a Code instance defined?
+    -- | A user-defined polynomial datatype. Each such type is
+    -- specified by a \"tag\" (the @HakaruCon@) which names the type, and a sum-of-product representation of the type itself.
+    | HData !HakaruCon [[HakaruFun]]
+
+
+-- N.B., The @Proxy@ type from "Data.Proxy" is polykinded, so it
+-- works for @Hakaru@ too. However, it is _not_ Typeable!
+--
+-- TODO: all the Typeable instances in this file are only used in
+-- 'Language.Hakaru.Simplify.closeLoop'; it would be cleaner to
+-- remove these instances and reimplement that function to work
+-- without them.
+
+deriving instance Typeable 'HNat
+deriving instance Typeable 'HInt
+deriving instance Typeable 'HProb
+deriving instance Typeable 'HReal
+deriving instance Typeable 'HMeasure
+deriving instance Typeable 'HArray
+deriving instance Typeable '(:->)
+deriving instance Typeable 'HData
+
+
+----------------------------------------------------------------
+-- | The identity and constant functors on 'Hakaru'. This gives
+-- us limited access to type-variables in @Hakaru@, for use in
+-- recursive sums-of-products. Notably, however, it only allows a
+-- single variable (namely the one bound by the closest binder) so
+-- it can't encode mutual recursion or other non-local uses of
+-- multiple binders. We also cannot encode non-regular recursive
+-- types (aka nested datatypes), like rose trees. To do that, we'd
+-- need to allow any old functor here.
+--
+-- Products and sums are represented as lists in the 'Hakaru'
+-- data-kind itself, so they aren't in this datatype.
+data HakaruFun = I | K !Hakaru
+
+deriving instance Typeable 'I
+deriving instance Typeable 'K
+
+
+----------------------------------------------------------------
+-- | The kind of user-defined Hakaru type constructors, which serves
+-- as a tag for the sum-of-products representation of the user-defined
+-- Hakaru type. The head of the 'HakaruCon' is a symbolic name, and
+-- the rest are arguments to that type constructor. The @a@ parameter
+-- is parametric, which is especially useful when you need a singleton
+-- of the constructor. The argument positions are necessary to do
+-- variable binding in Code. 'Symbol' is the kind of \"type level
+-- strings\".
+data HakaruCon = TyCon !Symbol | HakaruCon :@ Hakaru
+infixl 0 :@
+
+deriving instance Typeable 'TyCon
+deriving instance Typeable '(:@)
+
+
+-- | The Code type family allows users to extend the Hakaru language
+-- by adding new types. The right hand side is the sum-of-products
+-- representation of that type. See the \"built-in\" types for examples.
+type family   Code (a :: HakaruCon) :: [[HakaruFun]]
+type instance Code ('TyCon "Bool")               = '[ '[], '[] ]
+type instance Code ('TyCon "Unit")               = '[ '[] ]
+type instance Code ('TyCon "Maybe"  ':@ a)       = '[ '[] , '[ 'K a ] ]
+type instance Code ('TyCon "List"   ':@ a)       = '[ '[] , '[ 'K a, 'I ] ]
+type instance Code ('TyCon "Pair"   ':@ a ':@ b) = '[ '[ 'K a, 'K b ] ]
+type instance Code ('TyCon "Either" ':@ a ':@ b) = '[ '[ 'K a ], '[ 'K b ] ]
+
+
+-- | A helper type alias for simplifying type signatures for
+-- user-provided Hakaru types.
+--
+-- BUG: you cannot use this alias when defining other type aliases!
+-- For some reason the type checker doesn't reduce the type family
+-- applications, which prevents the use of these type synonyms in
+-- class instance heads. Any type synonym created with 'HData''
+-- will suffer the same issue, so type synonyms must be written out
+-- by hand— or copied from the GHC pretty printer, which will happily
+-- reduce things in the repl, even in the presence of quantified
+-- type variables.
+type HData' t = 'HData t (Code t)
+{-
+   >:kind! forall a b . HData' (TyCon "Pair" :@ a :@ b)
+   forall a b . HData' (TyCon "Pair" :@ a :@ b) :: Hakaru
+   = forall (a :: Hakaru) (b :: Hakaru).
+     'HData (('TyCon "Pair" ':@ a) ':@ b) '['['K a, 'K b]]
+
+type HBool       = HData' (TyCon "Bool")
+type HUnit       = HData' (TyCon "Unit")
+type HPair   a b = HData' (TyCon "Pair"   :@ a :@ b)
+type HEither a b = HData' (TyCon "Either" :@ a :@ b)
+type HList   a   = HData' (TyCon "List"   :@ a)
+type HMaybe  a   = HData' (TyCon "Maybe"  :@ a)
+-}
+
+type HBool       = 'HData ('TyCon "Bool") '[ '[], '[] ]
+type HUnit       = 'HData ('TyCon "Unit") '[ '[] ]
+type HPair   a b = 'HData ('TyCon "Pair"   ':@ a ':@ b) '[ '[ 'K a, 'K b] ]
+type HEither a b = 'HData ('TyCon "Either" ':@ a ':@ b) '[ '[ 'K a], '[ 'K b] ]
+type HList   a   = 'HData ('TyCon "List"    ':@ a) '[ '[], '[ 'K a, 'I] ]
+type HMaybe  a   = 'HData ('TyCon "Maybe"   ':@ a) '[ '[], '[ 'K a] ]
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Types/HClasses.hs b/haskell/Language/Hakaru/Types/HClasses.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Types/HClasses.hs
@@ -0,0 +1,608 @@
+{-# LANGUAGE CPP
+           , GADTs
+           , KindSignatures
+           , DataKinds
+           , PolyKinds
+           , TypeFamilies
+           , FlexibleContexts
+           , FlexibleInstances
+           , TypeSynonymInstances
+           , StandaloneDeriving
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2015.12.15
+-- |
+-- Module      :  Language.Hakaru.Types.HClasses
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- A collection of type classes for encoding Hakaru's numeric hierarchy.
+----------------------------------------------------------------
+module Language.Hakaru.Types.HClasses
+    (
+    -- * Equality
+      HEq(..)
+    , HEq_(..)
+    , sing_HEq
+    , hEq_Sing
+
+    -- * Ordering
+    , HOrd(..)
+    , hEq_HOrd
+    , HOrd_(..)
+    , sing_HOrd
+    , hOrd_Sing
+
+   -- * HIntegrable
+    , HIntegrable(..)
+    , sing_HIntegrable
+    , hIntegrable_Sing
+
+    -- * Semirings
+    , HSemiring(..)
+    , HSemiring_(..)
+    , sing_HSemiring
+    , hSemiring_Sing
+
+    -- * Rings
+    , HRing(..)
+    , hSemiring_HRing
+    , hSemiring_NonNegativeHRing
+    , HRing_(..)
+    , sing_HRing
+    , hRing_Sing
+    , sing_NonNegative
+
+    -- * Fractional types
+    , HFractional(..)
+    , hSemiring_HFractional
+    , HFractional_(..)
+    , sing_HFractional
+    , hFractional_Sing
+
+    -- * Radical types
+    , HRadical(..)
+    , hSemiring_HRadical
+    , HRadical_(..)
+    , sing_HRadical
+    , hRadical_Sing
+
+   -- * Discrete types
+    , HDiscrete(..)
+    , HDiscrete_(..)
+    , sing_HDiscrete
+    , hDiscrete_Sing
+
+    -- * Continuous types
+    , HContinuous(..)
+    , hFractional_HContinuous
+    , hSemiring_HIntegralContinuous
+    , HContinuous_(..)
+    , sing_HContinuous
+    , hContinuous_Sing
+    , sing_HIntegral
+    ) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Data.Functor ((<$>))
+#endif
+import Control.Applicative ((<|>), (<*>))
+import Language.Hakaru.Syntax.IClasses (TypeEq(..), Eq1(..), JmEq1(..))
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Control.Monad (join)
+
+----------------------------------------------------------------
+-- | Concrete dictionaries for Hakaru types with decidable equality.
+data HEq :: Hakaru -> * where
+    HEq_Nat    :: HEq 'HNat
+    HEq_Int    :: HEq 'HInt
+    HEq_Prob   :: HEq 'HProb
+    HEq_Real   :: HEq 'HReal
+    HEq_Array  :: !(HEq a) -> HEq ('HArray a)
+    HEq_Bool   :: HEq HBool
+    HEq_Unit   :: HEq HUnit
+    HEq_Pair   :: !(HEq a) -> !(HEq b) -> HEq (HPair   a b)
+    HEq_Either :: !(HEq a) -> !(HEq b) -> HEq (HEither a b)
+
+deriving instance Eq   (HEq a)
+-- TODO: instance JmEq1 HEq
+-- BUG: deriving instance Read (HEq a)
+deriving instance Show (HEq a)
+
+-- N.B., we do case analysis so that we don't need the class constraint!
+sing_HEq :: HEq a -> Sing a
+sing_HEq HEq_Nat          = SNat
+sing_HEq HEq_Int          = SInt
+sing_HEq HEq_Prob         = SProb
+sing_HEq HEq_Real         = SReal
+sing_HEq (HEq_Array  a)   = SArray  (sing_HEq a)
+sing_HEq HEq_Bool         = sBool
+sing_HEq HEq_Unit         = sUnit
+sing_HEq (HEq_Pair   a b) = sPair   (sing_HEq a) (sing_HEq b)
+sing_HEq (HEq_Either a b) = sEither (sing_HEq a) (sing_HEq b)
+
+hEq_Sing :: Sing a -> Maybe (HEq a)
+hEq_Sing SNat        = Just HEq_Nat
+hEq_Sing SInt        = Just HEq_Int
+hEq_Sing SProb       = Just HEq_Prob
+hEq_Sing SReal       = Just HEq_Real
+hEq_Sing (SArray a)  = HEq_Array <$> hEq_Sing a
+hEq_Sing s           =
+  (jmEq1 s sUnit  >>= \Refl -> Just HEq_Unit) <|>
+  (jmEq1 s sBool  >>= \Refl -> Just HEq_Bool) <|>
+  (join $ sUnPair' s $ \(Refl, a, b) ->
+     HEq_Pair <$> hEq_Sing a <*> hEq_Sing b)  <|>
+  (join $ sUnEither' s $ \(Refl, a, b) ->
+     HEq_Either <$> hEq_Sing a <*> hEq_Sing b)
+
+-- | Haskell type class for automatic 'HEq' inference.
+class    HEq_ (a :: Hakaru) where hEq :: HEq a
+instance HEq_ 'HNat         where hEq = HEq_Nat 
+instance HEq_ 'HInt         where hEq = HEq_Int 
+instance HEq_ 'HProb        where hEq = HEq_Prob 
+instance HEq_ 'HReal        where hEq = HEq_Real 
+instance HEq_ HBool         where hEq = HEq_Bool 
+instance HEq_ HUnit         where hEq = HEq_Unit 
+instance (HEq_ a) => HEq_ ('HArray a) where
+    hEq = HEq_Array hEq
+instance (HEq_ a, HEq_ b) => HEq_ (HPair a b) where
+    hEq = HEq_Pair hEq hEq
+instance (HEq_ a, HEq_ b) => HEq_ (HEither a b) where
+    hEq = HEq_Either hEq hEq
+
+
+----------------------------------------------------------------
+-- | Concrete dictionaries for Hakaru types with decidable total ordering.
+data HOrd :: Hakaru -> * where
+    HOrd_Nat    :: HOrd 'HNat
+    HOrd_Int    :: HOrd 'HInt
+    HOrd_Prob   :: HOrd 'HProb
+    HOrd_Real   :: HOrd 'HReal
+    HOrd_Array  :: !(HOrd a) -> HOrd ('HArray a)
+    HOrd_Bool   :: HOrd HBool
+    HOrd_Unit   :: HOrd HUnit
+    HOrd_Pair   :: !(HOrd a) -> !(HOrd b) -> HOrd (HPair   a b)
+    HOrd_Either :: !(HOrd a) -> !(HOrd b) -> HOrd (HEither a b)
+
+deriving instance Eq   (HOrd a)
+-- TODO: instance JmEq1 HOrd
+-- BUG: deriving instance Read (HOrd a)
+deriving instance Show (HOrd a)
+
+sing_HOrd :: HOrd a -> Sing a
+sing_HOrd HOrd_Nat          = SNat
+sing_HOrd HOrd_Int          = SInt
+sing_HOrd HOrd_Prob         = SProb
+sing_HOrd HOrd_Real         = SReal
+sing_HOrd (HOrd_Array  a)   = SArray  (sing_HOrd a)
+sing_HOrd HOrd_Bool         = sBool
+sing_HOrd HOrd_Unit         = sUnit
+sing_HOrd (HOrd_Pair   a b) = sPair   (sing_HOrd a) (sing_HOrd b)
+sing_HOrd (HOrd_Either a b) = sEither (sing_HOrd a) (sing_HOrd b)
+
+hOrd_Sing :: Sing a -> Maybe (HOrd a)
+hOrd_Sing SNat              = Just HOrd_Nat
+hOrd_Sing SInt              = Just HOrd_Int
+hOrd_Sing SProb             = Just HOrd_Prob
+hOrd_Sing SReal             = Just HOrd_Real
+hOrd_Sing (SArray a)        = HOrd_Array <$> hOrd_Sing a
+hOrd_Sing _                 = Nothing
+
+-- | Every 'HOrd' type is 'HEq'.
+hEq_HOrd :: HOrd a -> HEq a
+hEq_HOrd HOrd_Nat          = HEq_Nat
+hEq_HOrd HOrd_Int          = HEq_Int
+hEq_HOrd HOrd_Prob         = HEq_Prob
+hEq_HOrd HOrd_Real         = HEq_Real
+hEq_HOrd (HOrd_Array  a)   = HEq_Array  (hEq_HOrd a)
+hEq_HOrd HOrd_Bool         = HEq_Bool
+hEq_HOrd HOrd_Unit         = HEq_Unit
+hEq_HOrd (HOrd_Pair   a b) = HEq_Pair   (hEq_HOrd a) (hEq_HOrd b)
+hEq_HOrd (HOrd_Either a b) = HEq_Either (hEq_HOrd a) (hEq_HOrd b)
+
+-- | Haskell type class for automatic 'HOrd' inference.
+class    HEq_ a => HOrd_ (a :: Hakaru) where hOrd :: HOrd a
+instance HOrd_ 'HNat                   where hOrd = HOrd_Nat 
+instance HOrd_ 'HInt                   where hOrd = HOrd_Int 
+instance HOrd_ 'HProb                  where hOrd = HOrd_Prob 
+instance HOrd_ 'HReal                  where hOrd = HOrd_Real 
+instance HOrd_ HBool                   where hOrd = HOrd_Bool 
+instance HOrd_ HUnit                   where hOrd = HOrd_Unit 
+instance (HOrd_ a) => HOrd_ ('HArray a) where
+    hOrd = HOrd_Array hOrd
+instance (HOrd_ a, HOrd_ b) => HOrd_ (HPair a b) where
+    hOrd = HOrd_Pair hOrd hOrd
+instance (HOrd_ a, HOrd_ b) => HOrd_ (HEither a b) where
+    hOrd = HOrd_Either hOrd hOrd
+
+
+-- TODO: class HPER (a :: Hakaru)
+-- TODO: class HPartialOrder (a :: Hakaru)
+
+----------------------------------------------------------------
+-- | Concrete dictionaries for Hakaru types which are semirings.
+-- N.B., even though these particular semirings are commutative,
+-- we don't necessarily assume that.
+data HSemiring :: Hakaru -> * where
+    HSemiring_Nat  :: HSemiring 'HNat
+    HSemiring_Int  :: HSemiring 'HInt
+    HSemiring_Prob :: HSemiring 'HProb
+    HSemiring_Real :: HSemiring 'HReal
+
+
+instance Eq (HSemiring a) where -- This one could be derived...
+    (==) = eq1
+instance Eq1 HSemiring where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 HSemiring where
+    jmEq1 HSemiring_Nat  HSemiring_Nat  = Just Refl
+    jmEq1 HSemiring_Int  HSemiring_Int  = Just Refl
+    jmEq1 HSemiring_Prob HSemiring_Prob = Just Refl
+    jmEq1 HSemiring_Real HSemiring_Real = Just Refl
+    jmEq1 _              _              = Nothing
+
+-- BUG: deriving instance Read (HSemiring a)
+deriving instance Show (HSemiring a)
+
+sing_HSemiring :: HSemiring a -> Sing a
+sing_HSemiring HSemiring_Nat  = SNat
+sing_HSemiring HSemiring_Int  = SInt
+sing_HSemiring HSemiring_Prob = SProb
+sing_HSemiring HSemiring_Real = SReal
+
+hSemiring_Sing :: Sing a -> Maybe (HSemiring a)
+hSemiring_Sing SNat  = Just HSemiring_Nat 
+hSemiring_Sing SInt  = Just HSemiring_Int 
+hSemiring_Sing SProb = Just HSemiring_Prob
+hSemiring_Sing SReal = Just HSemiring_Real
+hSemiring_Sing _     = Nothing
+
+-- | Haskell type class for automatic 'HSemiring' inference.
+class    HSemiring_ (a :: Hakaru) where hSemiring :: HSemiring a
+instance HSemiring_ 'HNat  where hSemiring = HSemiring_Nat 
+instance HSemiring_ 'HInt  where hSemiring = HSemiring_Int 
+instance HSemiring_ 'HProb where hSemiring = HSemiring_Prob 
+instance HSemiring_ 'HReal where hSemiring = HSemiring_Real 
+
+
+----------------------------------------------------------------
+-- | Concrete dictionaries for Hakaru types which are rings. N.B.,
+-- even though these particular rings are commutative, we don't
+-- necessarily assume that.
+data HRing :: Hakaru -> * where
+    HRing_Int  :: HRing 'HInt
+    HRing_Real :: HRing 'HReal
+
+
+instance Eq (HRing a) where -- This one could be derived...
+    (==) = eq1
+instance Eq1 HRing where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 HRing where
+    jmEq1 HRing_Int  HRing_Int  = Just Refl
+    jmEq1 HRing_Real HRing_Real = Just Refl
+    jmEq1 _          _          = Nothing
+
+    
+-- BUG: deriving instance Read (HRing a)
+
+deriving instance Show (HRing a)
+
+sing_HRing :: HRing a -> Sing a
+sing_HRing HRing_Int  = SInt
+sing_HRing HRing_Real = SReal
+
+hRing_Sing :: Sing a -> Maybe (HRing a)
+hRing_Sing SInt  = Just HRing_Int
+hRing_Sing SReal = Just HRing_Real
+hRing_Sing _     = Nothing
+
+sing_NonNegative :: HRing a -> Sing (NonNegative a)
+sing_NonNegative = sing_HSemiring . hSemiring_NonNegativeHRing
+
+-- hNonNegative_Sing :: Sing (NonNegative a) -> Maybe (HRing a)
+
+-- | Every 'HRing' is a 'HSemiring'.
+hSemiring_HRing :: HRing a -> HSemiring a
+hSemiring_HRing HRing_Int  = HSemiring_Int
+hSemiring_HRing HRing_Real = HSemiring_Real
+
+-- | The non-negative type of every 'HRing' is a 'HSemiring'.
+hSemiring_NonNegativeHRing :: HRing a -> HSemiring (NonNegative a)
+hSemiring_NonNegativeHRing HRing_Int  = HSemiring_Nat
+hSemiring_NonNegativeHRing HRing_Real = HSemiring_Prob
+
+-- | Haskell type class for automatic 'HRing' inference.
+--
+-- Every 'HRing' has an associated type for the semiring of its
+-- non-negative elements. This type family captures two notions.
+-- First, if we take the semiring and close it under negation\/subtraction
+-- then we will generate this ring. Second, when we take the absolute
+-- value of something in the ring we will get back something in the
+-- non-negative semiring. For 'HInt' and 'HReal' these two notions
+-- coincide; however for Complex and Vector types, the notions
+-- diverge.
+--
+-- TODO: Can we somehow specify that the @HSemiring (NonNegative
+-- a)@ semantics coincides with the @HSemiring a@ semantics? Or
+-- should we just assume that?
+class (HSemiring_ (NonNegative a), HSemiring_ a) => HRing_ (a :: Hakaru)
+    where
+    type NonNegative (a :: Hakaru) :: Hakaru
+    hRing :: HRing a
+
+instance HRing_ 'HInt where
+    type NonNegative 'HInt = 'HNat
+    hRing = HRing_Int
+
+instance HRing_ 'HReal where
+    type NonNegative 'HReal = 'HProb
+    hRing = HRing_Real
+
+
+
+----------------------------------------------------------------
+-- N.B., We're assuming two-sided inverses here. That doesn't entail
+-- commutativity, though it does strongly suggest it... (cf.,
+-- Wedderburn's little theorem)
+--
+-- N.B., the (Nat,"+"=lcm,"*"=gcd) semiring is sometimes called
+-- "the division semiring"
+--
+-- HACK: tracking the generating carriers here wouldn't be quite
+-- right b/c we get more than just the (non-negative)rationals
+-- generated from HNat/HInt! However, we should have some sort of
+-- associated type so we can add rationals and non-negative
+-- rationals...
+--
+-- TODO: associated type for non-zero elements. To guarantee the
+-- safety of division\/recip? For now, we have Infinity, so it's
+-- actually safe for these two types. But if we want to add the
+-- rationals...
+--
+-- | Concrete dictionaries for Hakaru types which are division-semirings;
+-- i.e., division-rings without negation. This is called a \"semifield\"
+-- in ring theory, but should not be confused with the \"semifields\"
+-- of geometry.
+data HFractional :: Hakaru -> * where
+    HFractional_Prob :: HFractional 'HProb
+    HFractional_Real :: HFractional 'HReal
+
+
+instance Eq (HFractional a) where -- This one could be derived...
+    (==) = eq1
+instance Eq1 HFractional where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 HFractional where
+    jmEq1 HFractional_Prob HFractional_Prob = Just Refl
+    jmEq1 HFractional_Real HFractional_Real = Just Refl
+    jmEq1 _                _                = Nothing
+
+-- BUG: deriving instance Read (HFractional a)
+deriving instance Show (HFractional a)
+
+sing_HFractional :: HFractional a -> Sing a
+sing_HFractional HFractional_Prob = SProb
+sing_HFractional HFractional_Real = SReal
+
+hFractional_Sing :: Sing a -> Maybe (HFractional a)
+hFractional_Sing SProb = Just HFractional_Prob
+hFractional_Sing SReal = Just HFractional_Real
+hFractional_Sing _     = Nothing
+
+-- | Every 'HFractional' is a 'HSemiring'.
+hSemiring_HFractional :: HFractional a -> HSemiring a
+hSemiring_HFractional HFractional_Prob = HSemiring_Prob
+hSemiring_HFractional HFractional_Real = HSemiring_Real
+
+-- | Haskell type class for automatic 'HFractional' inference.
+class (HSemiring_ a) => HFractional_ (a :: Hakaru) where
+    hFractional :: HFractional a
+instance HFractional_ 'HProb where hFractional = HFractional_Prob 
+instance HFractional_ 'HReal where hFractional = HFractional_Real 
+
+
+-- type HDivisionRing a = (HFractional a, HRing a)
+-- type HField a = (HDivisionRing a, HCommutativeSemiring a)
+
+
+----------------------------------------------------------------
+-- Numbers formed by finitely many uses of integer addition,
+-- subtraction, multiplication, division, and nat-roots are all
+-- algebraic; however, N.B., not all algebraic numbers can be formed
+-- this way (cf., Abel–Ruffini theorem)
+-- TODO: ought we require HFractional rather than HSemiring?
+-- TODO: any special associated type?
+--
+-- | Concrete dictionaries for semirings which are closed under all
+-- 'HNat'-roots. This means it's closed under all positive rational
+-- powers as well. (If the type happens to be 'HFractional', then
+-- it's closed under /all/ rational powers.)
+--
+-- N.B., 'HReal' is not 'HRadical' because we do not have real-valued
+-- roots for negative reals.
+--
+-- N.B., we assume not only that the type is surd-complete, but
+-- also that it's still complete under the semiring operations.
+-- Thus we have values like @sqrt 2 + sqrt 3@ which cannot be
+-- expressed as a single root. Thus, in order to solve for zeros\/roots,
+-- we'll need solutions to more general polynomials than just the
+-- @x^n - a@ polynomials. However, the Galois groups of these are
+-- all solvable, so this shouldn't be too bad.
+data HRadical :: Hakaru -> * where
+    HRadical_Prob :: HRadical 'HProb
+
+
+instance Eq (HRadical a) where -- This one could be derived...
+    (==) = eq1
+instance Eq1 HRadical where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 HRadical where
+    jmEq1 HRadical_Prob HRadical_Prob = Just Refl
+
+-- BUG: deriving instance Read (HRadical a)
+deriving instance Show (HRadical a)
+
+sing_HRadical :: HRadical a -> Sing a
+sing_HRadical HRadical_Prob = SProb
+
+hRadical_Sing :: Sing a -> Maybe (HRadical a)
+hRadical_Sing SProb = Just HRadical_Prob
+hRadical_Sing _     = Nothing
+
+-- | Every 'HRadical' is a 'HSemiring'.
+hSemiring_HRadical :: HRadical a -> HSemiring a
+hSemiring_HRadical HRadical_Prob = HSemiring_Prob
+
+-- | Haskell type class for automatic 'HRadical' inference.
+class (HSemiring_ a) => HRadical_ (a :: Hakaru) where
+    hRadical :: HRadical a
+instance HRadical_ 'HProb where hRadical = HRadical_Prob 
+
+
+-- TODO: class (HDivisionRing a, HRadical a) => HAlgebraic a where...
+
+-- | Concrete dictionaries for types where Infinity can have
+data HIntegrable :: Hakaru -> * where
+    HIntegrable_Nat  :: HIntegrable 'HNat
+    HIntegrable_Prob :: HIntegrable 'HProb
+
+instance Eq (HIntegrable a) where -- This one could be derived...
+    (==) = eq1
+instance Eq1 HIntegrable where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 HIntegrable where
+    jmEq1 HIntegrable_Nat  HIntegrable_Nat  = Just Refl
+    jmEq1 HIntegrable_Prob HIntegrable_Prob = Just Refl
+    jmEq1 _             _                   = Nothing
+
+-- BUG: deriving instance Read (HIntegrable a)
+deriving instance Show (HIntegrable a)
+
+sing_HIntegrable :: HIntegrable a -> Sing a
+sing_HIntegrable HIntegrable_Nat  = SNat
+sing_HIntegrable HIntegrable_Prob = SProb
+
+hIntegrable_Sing :: Sing a -> Maybe (HIntegrable a)
+hIntegrable_Sing SNat  = Just HIntegrable_Nat
+hIntegrable_Sing SProb = Just HIntegrable_Prob
+hIntegrable_Sing _     = Nothing
+
+-- | Concrete dictionaries for Hakaru types which are \"discrete\".
+data HDiscrete :: Hakaru -> * where
+    HDiscrete_Nat :: HDiscrete 'HNat
+    HDiscrete_Int :: HDiscrete 'HInt
+
+instance Eq (HDiscrete a) where -- This one could be derived...
+    (==) = eq1
+instance Eq1 HDiscrete where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 HDiscrete where
+    jmEq1 HDiscrete_Nat HDiscrete_Nat = Just Refl
+    jmEq1 HDiscrete_Int HDiscrete_Int = Just Refl
+    jmEq1 _             _             = Nothing
+
+-- BUG: deriving instance Read (HDiscrete a)
+deriving instance Show (HDiscrete a)
+
+sing_HDiscrete :: HDiscrete a -> Sing a
+sing_HDiscrete HDiscrete_Nat = SNat
+sing_HDiscrete HDiscrete_Int = SInt
+
+hDiscrete_Sing :: Sing a -> Maybe (HDiscrete a)
+hDiscrete_Sing SNat = Just HDiscrete_Nat
+hDiscrete_Sing SInt = Just HDiscrete_Int
+hDiscrete_Sing _    = Nothing
+
+-- | Haskell type class for automatic 'HDiscrete' inference.
+class (HSemiring_ a) => HDiscrete_ (a :: Hakaru) where
+    hDiscrete :: HDiscrete a
+instance HDiscrete_ 'HNat where hDiscrete = HDiscrete_Nat 
+instance HDiscrete_ 'HInt where hDiscrete = HDiscrete_Int 
+
+----------------------------------------------------------------
+-- TODO: find better names than HContinuous and HIntegral
+-- TODO: how to require that "if HRing a, then HRing b too"?
+-- TODO: should we call this something like Dedekind-complete?
+-- That's what distinguishes the reals from the rationals. Of course,
+-- calling it that suggests (but does not require) that we should
+-- have some supremum operator; but supremum only differs from
+-- maximum if we have some way of talking about infinite sets of
+-- values (which is surely too much to bother with).
+--
+-- | Concrete dictionaries for Hakaru types which are \"continuous\".
+-- This is an ad-hoc class for (a) lifting 'HNat'\/'HInt' into
+-- 'HProb'\/'HReal', and (b) handling the polymorphism of monotonic
+-- functions like @etf@.
+data HContinuous :: Hakaru -> * where
+    HContinuous_Prob :: HContinuous 'HProb
+    HContinuous_Real :: HContinuous 'HReal
+
+
+instance Eq (HContinuous a) where -- This one could be derived...
+    (==) = eq1
+instance Eq1 HContinuous where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 HContinuous where
+    jmEq1 HContinuous_Prob HContinuous_Prob = Just Refl
+    jmEq1 HContinuous_Real HContinuous_Real = Just Refl
+    jmEq1 _                _                = Nothing
+
+-- BUG: deriving instance Read (HContinuous a)
+deriving instance Show (HContinuous a)
+
+sing_HContinuous :: HContinuous a -> Sing a
+sing_HContinuous HContinuous_Prob = SProb
+sing_HContinuous HContinuous_Real = SReal
+
+hContinuous_Sing :: Sing a -> Maybe (HContinuous a)
+hContinuous_Sing SProb = Just HContinuous_Prob
+hContinuous_Sing SReal = Just HContinuous_Real
+hContinuous_Sing _     = Nothing
+
+sing_HIntegral :: HContinuous a -> Sing (HIntegral a)
+sing_HIntegral = sing_HSemiring . hSemiring_HIntegralContinuous
+
+-- hIntegral_Sing :: Sing (HIntegral a) -> Maybe (HContinuous a)
+
+-- | Every 'HContinuous' is a 'HFractional'.
+hFractional_HContinuous :: HContinuous a -> HFractional a
+hFractional_HContinuous HContinuous_Prob = HFractional_Prob
+hFractional_HContinuous HContinuous_Real = HFractional_Real
+
+-- | The integral type of every 'HContinuous' is a 'HSemiring'.
+hSemiring_HIntegralContinuous :: HContinuous a -> HSemiring (HIntegral a)
+hSemiring_HIntegralContinuous HContinuous_Prob = HSemiring_Nat
+hSemiring_HIntegralContinuous HContinuous_Real = HSemiring_Int
+
+-- | Haskell type class for automatic 'HContinuous' inference.
+--
+-- Every 'HContinuous' has an associated type for the semiring of
+-- its integral elements.
+--
+-- TODO: Can we somehow specify that the @HSemiring (HIntegral a)@
+-- semantics coincides with the @HSemiring a@ semantics? Or should
+-- we just assume that?
+class (HSemiring_ (HIntegral a), HFractional_ a)
+    => HContinuous_ (a :: Hakaru)
+    where
+    type HIntegral (a :: Hakaru) :: Hakaru
+    hContinuous :: HContinuous a
+
+instance HContinuous_ 'HProb where
+    type HIntegral 'HProb = 'HNat
+    hContinuous = HContinuous_Prob
+
+instance HContinuous_ 'HReal where
+    type HIntegral 'HReal = 'HInt
+    hContinuous = HContinuous_Real
+
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Types/Sing.hs b/haskell/Language/Hakaru/Types/Sing.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Language/Hakaru/Types/Sing.hs
@@ -0,0 +1,449 @@
+{-# LANGUAGE DataKinds
+           , PolyKinds
+           , TypeOperators
+           , GADTs
+           , TypeFamilies
+           , FlexibleInstances
+           , Rank2Types
+           , UndecidableInstances
+           , ScopedTypeVariables
+           #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.05.28
+-- |
+-- Module      :  Language.Hakaru.Types.Sing
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Singleton types for the @Hakaru@ kind, and a decision procedure
+-- for @Hakaru@ type-equality.
+----------------------------------------------------------------
+module Language.Hakaru.Types.Sing
+    ( Sing(..)
+    , SingI(..), singOf
+    -- * Some helpful shorthands for \"built-in\" datatypes
+    -- ** Constructing singletons
+    , sBool
+    , sUnit
+    , sPair
+    , sEither
+    , sList
+    , sMaybe
+    -- ** Destructing singletons
+    , sUnMeasure
+    , sUnArray
+    , sUnPair, sUnPair'
+    , sUnEither, sUnEither'
+    , sUnList
+    , sUnMaybe
+    , sUnFun
+    -- ** Singletons for `Symbol`
+    , someSSymbol, ssymbolVal
+    , sSymbol_Bool
+    , sSymbol_Unit
+    , sSymbol_Pair
+    , sSymbol_Either
+    , sSymbol_List
+    , sSymbol_Maybe
+    ) where
+
+import qualified GHC.TypeLits as TL
+-- TODO: should we use @(Data.Type.Equality.:~:)@ everywhere instead of our own 'TypeEq'?
+import Unsafe.Coerce
+
+import Data.Proxy
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Types.DataKind
+----------------------------------------------------------------
+----------------------------------------------------------------
+infixr 0 `SFun`
+infixr 6 `SPlus`
+infixr 7 `SEt`
+
+
+-- | The data families of singletons for each kind.
+data family Sing (a :: k) :: *
+
+
+-- | A class for automatically generating the singleton for a given
+-- Hakaru type.
+class SingI (a :: k) where sing :: Sing a
+
+singOf :: SingI a => proxy a -> Sing a
+singOf _ = sing
+
+{-
+-- TODO: we'd much rather have something like this, to prove that
+-- we have a SingI instance for /every/ @a :: Hakaru@. Is there any
+-- possible way of actually doing this?
+
+class SingI1 (kproxy :: KProxy k) where
+    sing1 :: Sing (a :: k)
+    -- or, if it helps at all:
+    -- > sing1 :: forall (a :: k). proxy a -> Sing a
+
+instance SingI1 ('KProxy :: KProxy Hakaru) where
+    sing1 = undefined
+-}
+
+----------------------------------------------------------------
+-- BUG: data family instances must be fully saturated, but since
+-- these are GADTs, the name of the parameter is irrelevant. However,
+-- using a wildcard causes GHC to panic. cf.,
+-- <https://ghc.haskell.org/trac/ghc/ticket/10586>
+
+-- | Singleton types for the kind of Hakaru types. We need to use
+-- this instead of 'Proxy' in order to implement 'jmEq1'.
+data instance Sing (a :: Hakaru) where
+    SNat     :: Sing 'HNat
+    SInt     :: Sing 'HInt
+    SProb    :: Sing 'HProb
+    SReal    :: Sing 'HReal
+    SMeasure :: !(Sing a) -> Sing ('HMeasure a)
+    SArray   :: !(Sing a) -> Sing ('HArray a)
+    -- TODO: would it be clearer to use (:$->) in order to better mirror the type-level (:->)
+    SFun     :: !(Sing a) -> !(Sing b) -> Sing (a ':-> b)
+    SData    :: !(Sing t) -> !(Sing (Code t)) -> Sing (HData' t)
+
+
+instance Eq (Sing (a :: Hakaru)) where
+    (==) = eq1
+instance Eq1 (Sing :: Hakaru -> *) where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 (Sing :: Hakaru -> *) where
+    jmEq1 SNat             SNat             = Just Refl
+    jmEq1 SInt             SInt             = Just Refl
+    jmEq1 SProb            SProb            = Just Refl
+    jmEq1 SReal            SReal            = Just Refl
+    jmEq1 (SMeasure a)     (SMeasure b)     =
+        jmEq1 a  b  >>= \Refl ->
+        Just Refl
+    jmEq1 (SArray   a)     (SArray   b)     =
+        jmEq1 a  b  >>= \Refl ->
+        Just Refl
+    jmEq1 (SFun     a1 a2) (SFun     b1 b2) =
+        jmEq1 a1 b1 >>= \Refl ->
+        jmEq1 a2 b2 >>= \Refl ->
+        Just Refl
+    jmEq1 (SData con1 code1) (SData con2 code2) =
+        jmEq1 con1  con2  >>= \Refl ->
+        jmEq1 code1 code2 >>= \Refl ->
+        Just Refl
+    jmEq1 _ _ = Nothing
+
+
+-- TODO: instance Read (Sing (a :: Hakaru))
+
+
+instance Show (Sing (a :: Hakaru)) where
+    showsPrec = showsPrec1
+    show      = show1
+instance Show1 (Sing :: Hakaru -> *) where
+    showsPrec1 p s =
+        case s of
+        SNat            -> showString     "SNat"
+        SInt            -> showString     "SInt"
+        SProb           -> showString     "SProb"
+        SReal           -> showString     "SReal"
+        SMeasure  s1    -> showParen_1  p "SMeasure"  s1
+        SArray    s1    -> showParen_1  p "SArray"    s1
+        SFun      s1 s2 -> showParen_11 p "SFun"      s1 s2
+        SData     s1 s2 -> showParen_11 p "SData"     s1 s2
+
+
+instance SingI 'HNat                            where sing = SNat 
+instance SingI 'HInt                            where sing = SInt 
+instance SingI 'HProb                           where sing = SProb 
+instance SingI 'HReal                           where sing = SReal 
+instance (SingI a) => SingI ('HMeasure a)       where sing = SMeasure sing
+instance (SingI a) => SingI ('HArray a)         where sing = SArray sing
+instance (SingI a, SingI b) => SingI (a ':-> b) where sing = SFun sing sing
+-- N.B., must use @(~)@ to delay the use of the type family (it's illegal to put it inline in the instance head).
+instance (sop ~ Code t, SingI t, SingI sop) => SingI ('HData t sop) where
+    sing = SData sing sing
+
+
+----------------------------------------------------------------
+
+sUnMeasure :: Sing ('HMeasure a) -> Sing a
+sUnMeasure (SMeasure a) = a
+
+sUnArray :: Sing ('HArray a) -> Sing a
+sUnArray (SArray a) = a
+
+-- These aren't pattern synonyms (cf., the problems mentioned
+-- elsewhere about those), but they're helpful for generating
+-- singletons at least.
+-- TODO: we might be able to use 'singByProxy' to generate singletons
+-- for Symbols? Doesn't work in pattern synonyms, of course.
+sUnit :: Sing HUnit
+sUnit =
+    SData (STyCon sSymbol_Unit)
+        (SDone `SPlus` SVoid)
+
+sBool :: Sing HBool
+sBool =
+    SData (STyCon sSymbol_Bool)
+        (SDone `SPlus` SDone `SPlus` SVoid)
+
+-- BUG: what does this "Conflicting definitions for ‘a’" message mean when we try to make this a pattern synonym?
+sPair :: Sing a -> Sing b -> Sing (HPair a b)
+sPair a b =
+    SData (STyCon sSymbol_Pair `STyApp` a `STyApp` b)
+        ((SKonst a `SEt` SKonst b `SEt` SDone) `SPlus` SVoid)
+
+sUnPair :: Sing (HPair a b) -> (Sing a, Sing b)
+sUnPair (SData (STyApp (STyApp (STyCon _) a) b) _) = (a,b)
+sUnPair _ = error "sUnPair: the impossible happened"
+
+sUnPair' :: Sing (x :: Hakaru)
+         -> (forall (a :: Hakaru) (b :: Hakaru) .
+             (TypeEq x (HPair a b), Sing a, Sing b) -> r)
+         -> Maybe r
+sUnPair' (SData (STyApp (STyApp (STyCon t) a) b) _) k
+  | Just Refl <- jmEq1 t sSymbol_Pair = Just $ k (Refl, a, b)
+sUnPair' _ _                          = Nothing
+
+sEither :: Sing a -> Sing b -> Sing (HEither a b)
+sEither a b =
+    SData (STyCon sSymbol_Either `STyApp` a `STyApp` b)
+        ((SKonst a `SEt` SDone) `SPlus` (SKonst b `SEt` SDone)
+            `SPlus` SVoid)
+
+sUnEither :: Sing (HEither a b) -> (Sing a, Sing b)
+sUnEither (SData (STyApp (STyApp (STyCon _) a) b) _) = (a,b)
+sUnEither _ = error "sUnEither: the impossible happened"
+
+sUnEither' :: Sing (x :: Hakaru)
+         -> (forall (a :: Hakaru) (b :: Hakaru) .
+             (TypeEq x (HEither a b), Sing a, Sing b) -> r)
+         -> Maybe r
+sUnEither' (SData (STyApp (STyApp (STyCon t) a) b) _) k
+  | Just Refl <- jmEq1 t sSymbol_Either = Just $ k (Refl, a, b)
+sUnEither' _ _                          = Nothing
+
+sList :: Sing a -> Sing (HList a)
+sList a =
+    SData (STyCon sSymbol_List `STyApp` a)
+        (SDone `SPlus` (SKonst a `SEt` SIdent `SEt` SDone) `SPlus` SVoid)
+
+sUnList :: Sing (HList a) -> Sing a
+sUnList (SData (STyApp (STyCon _) a) _) = a
+sUnList _ = error "sUnList: the impossible happened"
+
+sMaybe :: Sing a -> Sing (HMaybe a)
+sMaybe a =
+    SData (STyCon sSymbol_Maybe `STyApp` a)
+        (SDone `SPlus` (SKonst a `SEt` SDone) `SPlus` SVoid)
+
+sUnMaybe :: Sing (HMaybe a) -> Sing a
+sUnMaybe (SData (STyApp (STyCon _) a) _) = a
+sUnMaybe _ = error "sUnMaybe: the impossible happened"
+
+sUnFun :: Sing (a ':-> b) -> (Sing a, Sing b)
+sUnFun (SFun a b) = (a,b)
+
+----------------------------------------------------------------
+data instance Sing (a :: HakaruCon) where
+    STyCon :: !(Sing s)              -> Sing ('TyCon s :: HakaruCon)
+    STyApp :: !(Sing a) -> !(Sing b) -> Sing (a ':@ b  :: HakaruCon)
+
+
+instance Eq (Sing (a :: HakaruCon)) where
+    (==) = eq1
+instance Eq1 (Sing :: HakaruCon -> *) where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 (Sing :: HakaruCon -> *) where
+    jmEq1 (STyCon s)   (STyCon z)   = jmEq1 s z >>= \Refl -> Just Refl
+    jmEq1 (STyApp f a) (STyApp g b) =
+        jmEq1 f g >>= \Refl ->
+        jmEq1 a b >>= \Refl ->
+        Just Refl
+    jmEq1 _ _ = Nothing
+
+
+-- TODO: instance Read (Sing (a :: HakaruCon))
+
+
+instance Show (Sing (a :: HakaruCon)) where
+    showsPrec = showsPrec1
+    show      = show1
+instance Show1 (Sing :: HakaruCon -> *) where
+    showsPrec1 p (STyCon s1)    = showParen_1  p "STyCon" s1
+    showsPrec1 p (STyApp s1 s2) = showParen_11 p "STyApp" s1 s2
+
+
+instance TL.KnownSymbol s => SingI ('TyCon s :: HakaruCon) where
+    sing = STyCon sing
+instance (SingI a, SingI b) => SingI ((a ':@ b) :: HakaruCon) where
+    sing = STyApp sing sing
+
+
+----------------------------------------------------------------
+-- | N.B., in order to bring the 'TL.KnownSymbol' dictionary into
+-- scope, you need to pattern match on the 'SingSymbol' constructor
+-- (similar to when we need to match on 'Refl' explicitly). In
+-- general you'll want to do this with an at-pattern so that you
+-- can also have a variable name for passing the value around (e.g.
+-- to be used as an argument to 'TL.symbolVal').
+data instance Sing (s :: Symbol) where
+    SingSymbol :: TL.KnownSymbol s => Sing (s :: Symbol)
+
+sSymbol_Bool   :: Sing "Bool"
+sSymbol_Bool   = SingSymbol
+sSymbol_Unit   :: Sing "Unit"
+sSymbol_Unit   = SingSymbol
+sSymbol_Pair   :: Sing "Pair"
+sSymbol_Pair   = SingSymbol
+sSymbol_Either :: Sing "Either"
+sSymbol_Either = SingSymbol
+sSymbol_List   :: Sing "List"
+sSymbol_List   = SingSymbol
+sSymbol_Maybe  :: Sing "Maybe"
+sSymbol_Maybe  = SingSymbol
+
+someSSymbol :: String -> (forall s . Sing (s :: Symbol) -> k) -> k
+someSSymbol s k = case TL.someSymbolVal s of { TL.SomeSymbol (_::Proxy s) -> k (SingSymbol :: Sing s) }
+
+ssymbolVal :: forall s. Sing (s :: Symbol) -> String 
+ssymbolVal SingSymbol = TL.symbolVal (Proxy :: Proxy s)
+
+instance Eq (Sing (s :: Symbol)) where
+    (==) = eq1
+instance Eq1 (Sing :: Symbol -> *) where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 (Sing :: Symbol -> *) where
+     jmEq1 x@SingSymbol y@SingSymbol
+        | TL.symbolVal x == TL.symbolVal y = Just (unsafeCoerce Refl)
+        | otherwise                        = Nothing
+
+-- TODO: is any meaningful Read (Sing (a :: Symbol)) instance possible?
+
+instance Show (Sing (s :: Symbol)) where
+    showsPrec = showsPrec1
+    show      = show1
+instance Show1 (Sing :: Symbol -> *) where
+    showsPrec1 _ s@SingSymbol =
+        showParen True
+            ( showString "SingSymbol :: Sing "
+            . showString (show $ TL.symbolVal s)
+            )
+
+-- Alas, this requires UndecidableInstances
+instance TL.KnownSymbol s => SingI (s :: Symbol) where
+    sing = SingSymbol
+
+
+----------------------------------------------------------------
+data instance Sing (a :: [[HakaruFun]]) where
+    SVoid :: Sing ('[] :: [[HakaruFun]])
+    SPlus
+        :: !(Sing xs)
+        -> !(Sing xss)
+        -> Sing ((xs ': xss) :: [[HakaruFun]])
+
+
+instance Eq (Sing (a :: [[HakaruFun]])) where
+    (==) = eq1
+instance Eq1 (Sing :: [[HakaruFun]] -> *) where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 (Sing :: [[HakaruFun]] -> *) where
+    jmEq1 SVoid        SVoid        = Just Refl
+    jmEq1 (SPlus x xs) (SPlus y ys) =
+        jmEq1 x  y  >>= \Refl ->
+        jmEq1 xs ys >>= \Refl ->
+        Just Refl
+    jmEq1 _ _ = Nothing
+
+
+-- TODO: instance Read (Sing (a :: [[HakaruFun]]))
+
+
+instance Show (Sing (a :: [[HakaruFun]])) where
+    showsPrec = showsPrec1
+    show      = show1
+instance Show1 (Sing :: [[HakaruFun]] -> *) where
+    showsPrec1 _ SVoid         = showString     "SVoid"
+    showsPrec1 p (SPlus s1 s2) = showParen_11 p "SPlus" s1 s2
+
+
+instance SingI ('[] :: [[HakaruFun]]) where
+    sing = SVoid
+instance (SingI xs, SingI xss) => SingI ((xs ': xss) :: [[HakaruFun]]) where
+    sing = SPlus sing sing
+
+
+----------------------------------------------------------------
+data instance Sing (a :: [HakaruFun]) where
+    SDone :: Sing ('[] :: [HakaruFun])
+    SEt   :: !(Sing x) -> !(Sing xs) -> Sing ((x ': xs) :: [HakaruFun])
+
+
+instance Eq (Sing (a :: [HakaruFun])) where
+    (==) = eq1
+instance Eq1 (Sing :: [HakaruFun] -> *) where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 (Sing :: [HakaruFun] -> *) where
+    jmEq1 SDone      SDone      = Just Refl
+    jmEq1 (SEt x xs) (SEt y ys) =
+        jmEq1 x  y  >>= \Refl ->
+        jmEq1 xs ys >>= \Refl ->
+        Just Refl
+    jmEq1 _ _ = Nothing
+
+
+-- TODO: instance Read (Sing (a :: [HakaruFun]))
+
+
+instance Show (Sing (a :: [HakaruFun])) where
+    showsPrec = showsPrec1
+    show      = show1
+instance Show1 (Sing :: [HakaruFun] -> *) where
+    showsPrec1 _ SDone       = showString     "SDone"
+    showsPrec1 p (SEt s1 s2) = showParen_11 p "SEt" s1 s2
+
+
+instance SingI ('[] :: [HakaruFun]) where
+    sing = SDone
+instance (SingI x, SingI xs) => SingI ((x ': xs) :: [HakaruFun]) where
+    sing = SEt sing sing
+
+
+----------------------------------------------------------------
+data instance Sing (a :: HakaruFun) where
+    SIdent :: Sing 'I
+    SKonst :: !(Sing a) -> Sing ('K a)
+
+
+instance Eq (Sing (a :: HakaruFun)) where
+    (==) = eq1
+instance Eq1 (Sing :: HakaruFun -> *) where
+    eq1 x y = maybe False (const True) (jmEq1 x y)
+instance JmEq1 (Sing :: HakaruFun -> *) where
+    jmEq1 SIdent     SIdent     = Just Refl
+    jmEq1 (SKonst a) (SKonst b) = jmEq1 a b >>= \Refl -> Just Refl
+    jmEq1 _          _          = Nothing
+
+
+-- TODO: instance Read (Sing (a :: HakaruFun))
+
+
+instance Show (Sing (a :: HakaruFun)) where
+    showsPrec = showsPrec1
+    show      = show1
+instance Show1 (Sing :: HakaruFun -> *) where
+    showsPrec1 _ SIdent      = showString    "SIdent"
+    showsPrec1 p (SKonst s1) = showParen_1 p "SKonst" s1
+
+instance SingI 'I where
+    sing = SIdent
+instance (SingI a) => SingI ('K a) where
+    sing = SKonst sing
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/System/MapleSSH.hs b/haskell/System/MapleSSH.hs
new file mode 100644
--- /dev/null
+++ b/haskell/System/MapleSSH.hs
@@ -0,0 +1,55 @@
+module System.MapleSSH (maple, mapleWithArgs) where
+
+import Data.Maybe(fromMaybe)
+import Data.Char(isSpace)
+import System.IO (hPutStrLn, hClose, hGetContents)
+import System.Process (proc, CreateProcess(..), StdStream(CreatePipe), createProcess, waitForProcess)
+import System.Environment (lookupEnv)
+import System.Exit (ExitCode(ExitSuccess))
+
+-- Default values for SSH environment variables
+defSSH, defUser, defServer, defCommand :: String
+defSSH     = "/usr/bin/ssh"
+defUser    = "ppaml"
+defServer  = "karst.uits.iu.edu"
+defCommand = "maple"
+-- On the server side, ~/.modules should load maple/18, and ~/.mapleinit
+-- should point to ~/hakaru/maple (updated by hakaru/maple/MapleUpdate.hs)
+
+envVarsSSH :: IO (String, String, String, String)
+envVarsSSH = do
+    ssh     <- get "MAPLE_SSH"     defSSH
+    user    <- get "MAPLE_USER"    defUser
+    server  <- get "MAPLE_SERVER"  defServer
+    command <- get "MAPLE_COMMAND" defCommand
+    return (ssh, user, server, command)
+    where get name def = fmap (fromMaybe def) (lookupEnv name)
+
+processWithArgs :: [String] -> IO CreateProcess
+processWithArgs args = do
+    bin <- lookupEnv "LOCAL_MAPLE"
+    case bin of
+        Just b  -> return $ proc b args 
+        Nothing -> 
+          do (ssh, user, server, command) <- envVarsSSH
+             let commands = command ++ concatMap (' ':) args
+             return $ proc ssh ["-l" ++ user, server, commands]
+
+maple :: String -> IO String
+maple = flip mapleWithArgs ["-q", "-t"]
+
+mapleWithArgs :: String -> [String] -> IO String
+mapleWithArgs cmd args = do
+    p <- processWithArgs args 
+    (Just inH, Just outH, Nothing, p') <- createProcess p { std_in = CreatePipe, std_out = CreatePipe, close_fds = True }
+    hPutStrLn inH $ cmd ++ ";"
+    hClose inH
+    c <- hGetContents outH
+    length c `seq` hClose outH
+    exit <- waitForProcess p'
+    case exit of
+      ExitSuccess -> return $ trim c
+      _           -> error ("maple returned exit code: " ++ show exit)
+
+trim :: String -> String
+trim = dropWhile isSpace
diff --git a/haskell/Tests/ASTTransforms.hs b/haskell/Tests/ASTTransforms.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/ASTTransforms.hs
@@ -0,0 +1,221 @@
+{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs            #-}
+{-# LANGUAGE KindSignatures   #-}
+{-# LANGUAGE RankNTypes       #-}
+
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Tests.ASTTransforms (allTests) where
+
+import           Control.Monad
+import qualified Data.Number.LogFloat             as LF
+import qualified Data.Vector                      as V
+import           GHC.Word                         (Word32)
+import           Language.Hakaru.Sample           (runEvaluate)
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.ANF       (normalize)
+import           Language.Hakaru.Syntax.CSE       (cse)
+import           Language.Hakaru.Syntax.Prune     (prune)
+import           Language.Hakaru.Syntax.Hoist     (hoist)
+import           Language.Hakaru.Syntax.Uniquify  (uniquify)
+import           Language.Hakaru.Syntax.Unroll    (unroll)
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.AST.Eq    (alphaEq)
+import           Language.Hakaru.Syntax.Datum
+import           Language.Hakaru.Syntax.DatumCase
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Syntax.Prelude
+import           Language.Hakaru.Syntax.Value
+import           Language.Hakaru.Syntax.Variable
+import           Language.Hakaru.Types.Coercion
+import           Language.Hakaru.Types.DataKind
+import           Language.Hakaru.Types.HClasses
+import           Language.Hakaru.Types.Sing
+import           Prelude                          hiding (product, (*), (+),
+                                                   (-), (==))
+
+import qualified System.Random.MWC                as MWC
+import           Test.HUnit
+import           Tests.Disintegrate               hiding (allTests)
+import           Tests.TestTools
+
+checkMeasure :: String
+             -> Value ('HMeasure a)
+             -> Value ('HMeasure a)
+             -> Assertion
+checkMeasure p (VMeasure m1) (VMeasure m2) = do
+  -- Generate 2 copies of the same random seed so that sampling the random seeds
+  -- always produce the same trace of results.
+  g1 <- MWC.createSystemRandom
+  s  <- MWC.save g1
+  g2 <- MWC.restore s
+  forM_ [1 :: Int .. 10000] $ \_ -> do
+      p1 <- LF.logFloat `fmap` MWC.uniform g1
+      p2 <- LF.logFloat `fmap` MWC.uniform g2
+      Just (v1, w1) <- m1 (VProb p1) g1
+      Just (v2, w2) <- m2 (VProb p2) g2
+      assertEqual p v1 v2
+      assertEqual p w1 w2
+
+allTests :: Test
+allTests = test [ TestLabel "ANF" anfTests ]
+
+opts :: (ABT Term abt) => abt '[] a -> abt '[] a
+opts = uniquify . prune . cse . hoist . uniquify . normalize
+
+optsUnroll :: (ABT Term abt) => abt '[] a -> abt '[] a
+optsUnroll = uniquify . prune . cse . normalize . unroll
+
+anfTests :: Test
+anfTests = test [ "example1" ~: testNormalizer "example1" example1 example1'
+                , "example2" ~: testNormalizer "example2" example2 example2'
+                , "example3" ~: testNormalizer "example3" example3 example3'
+
+                -- Test some deterministic results
+                , "runExample1" ~: testPreservesResult "example1" example1 normalize
+                , "runExample2" ~: testPreservesResult "example2" example2 normalize
+                , "runExample3" ~: testPreservesResult "example3" example3 normalize
+
+                -- Test some programs which produce measures, these are
+                -- statistical tests
+                , "norm1a"        ~: testPreservesMeasure "norm1a" norm1a normalize
+                , "norm1b"        ~: testPreservesMeasure "norm1b" norm1b normalize
+                , "norm1c"        ~: testPreservesMeasure "norm1c" norm1c normalize
+                , "easyRoad"      ~: testPreservesMeasure "easyRoad" easyRoad normalize
+                , "helloWorld100" ~: testPreservesMeasure "helloWorld100" helloWorld100 normalize
+
+                -- Test some deterministic results
+                , "runExample1CSE" ~: testPreservesResult "example1" example1 opts
+                , "runExample2CSE" ~: testPreservesResult "example2" example2 opts
+                , "runExample3CSE" ~: testPreservesResult "example3" example3 opts
+
+                , "cse1" ~: testCSE "cse1" example1CSE example1CSE'
+                , "cse2" ~: testCSE "cse2" example2CSE example2CSE'
+                , "cse3" ~: testCSE "cse3" example3CSE example3CSE
+                , "cse4" ~: testCSE "cse4" (normalize example3CSE) example2CSE'
+
+                -- Test some programs which produce measures, these are
+                -- statistical tests
+                , "norm1a all"        ~: testPreservesMeasure "norm1a" norm1a opts
+                , "norm1b all"        ~: testPreservesMeasure "norm1b" norm1b opts
+                , "norm1c all"        ~: testPreservesMeasure "norm1c" norm1c opts
+                , "easyRoad all"      ~: testPreservesMeasure "easyRoad" easyRoad opts
+                , "helloWorld100 all" ~: testPreservesMeasure "helloWorld100" helloWorld100 opts
+
+                , "example1Hoist" ~: testPreservesResult "result" example1Hoist opts
+                , "example1Hoist" ~: testTransform "transform" example1Hoist example1Hoist' opts
+
+                , "unroll" ~: testTransform "unroll" example1Unroll example1Unroll' optsUnroll
+                ]
+
+
+example1 :: TrivialABT Term '[] 'HReal
+example1 = if_ (real_ 1 == real_ 2)
+               (real_ 2 + real_ 3)
+               (real_ 3 + real_ 4)
+
+example1' :: TrivialABT Term '[] 'HReal
+example1' = let_ (real_ 1 == real_ 2) $ \v ->
+            if_ v (real_ 2 + real_ 3)
+                  (real_ 3 + real_ 4)
+
+example2 :: TrivialABT Term '[] 'HNat
+example2 = let_ (nat_ 1) $ \ a -> triv ((summate a (a + (nat_ 10)) (\i -> i)) +
+                                        (product a (a + (nat_ 10)) (\i -> i)))
+
+example2' :: TrivialABT Term '[] 'HNat
+example2' = let_ (nat_ 1) $ \ x4 ->
+            let_ (x4 + nat_ 10) $ \ x3 ->
+            let_ (summate x4 x3 (\ x0 -> x0)) $ \ x2 ->
+            let_ (x4 + nat_ 10) $ \ x1 ->
+            let_ (product x4 x1 (\ x0 -> x0)) $ \ x0 ->
+            x2 + x0
+
+example3 :: TrivialABT Term '[] 'HReal
+example3 = triv (real_ 1 * (real_ 2 + real_ 3) * (real_ 4 + (real_ 5 + (real_ 6 * real_ 7))))
+
+
+example3' :: TrivialABT Term '[] 'HReal
+example3' = let_ (real_ 2 + real_ 3) $ \ x2 ->
+            let_ (real_ 6 * real_ 7) $ \ x1 ->
+            let_ (real_ 4 + real_ 5 + x1) $ \ x0 ->
+            real_ 1 * x2 * x0
+
+testNormalizer :: (ABT Term abt) => String -> abt '[] a -> abt '[] a -> Assertion
+testNormalizer name a b = testTransform name a b normalize
+
+testTransform
+  :: (ABT Term abt)
+  => String
+  -> abt '[] a
+  -> abt '[] a
+  -> (abt '[] a -> abt '[] a)
+  -> Assertion
+testTransform name a b opt = assertBool name (alphaEq (opt a) b)
+
+testCSE :: (ABT Term abt) => String -> abt '[] a -> abt '[] a -> Assertion
+testCSE name a b = assertBool name (alphaEq (cse a) b)
+
+testPreservesResult
+  :: forall (a :: Hakaru) abt . (ABT Term abt)
+  => String
+  -> abt '[] a
+  -> (abt '[] a -> abt '[] a)
+  -> Assertion
+testPreservesResult name ast opt = assertEqual name result1 result2
+  where result1 = runEvaluate ast
+        result2 = runEvaluate (opt ast)
+
+testPreservesMeasure
+  :: forall (a :: Hakaru) abt . (ABT Term abt)
+  => String
+  -> abt '[] ('HMeasure a)
+  -> (abt '[] ('HMeasure a) -> abt '[] ('HMeasure a))
+  -> Assertion
+testPreservesMeasure name ast opt = checkMeasure name result1 result2
+  where result1 = runEvaluate ast
+        result2 = runEvaluate (opt ast)
+
+example1CSE :: TrivialABT Term '[] 'HReal
+example1CSE = let_ (real_ 1 + real_ 2) $ \x ->
+              let_ (real_ 1 + real_ 2) $ \y ->
+              x + y
+
+example1CSE' :: TrivialABT Term '[] 'HReal
+example1CSE' = let_ (real_ 1 + real_ 2) $ \x ->
+               x + x
+
+example2CSE :: TrivialABT Term '[] 'HReal
+example2CSE = let_ (summate (nat_ 0) (nat_ 1) $ \x -> real_ 1) $ \x ->
+              let_ (summate (nat_ 0) (nat_ 1) $ \x -> real_ 1) $ \y ->
+              x + y
+
+example2CSE' :: TrivialABT Term '[] 'HReal
+example2CSE' = let_ (summate (nat_ 0) (nat_ 1) $ \x -> real_ 1) $ \x ->
+               x + x
+
+example3CSE :: TrivialABT Term '[] 'HReal
+example3CSE = (summate (nat_ 0) (nat_ 1) $ \x -> real_ 1)
+            + (summate (nat_ 0) (nat_ 1) $ \x -> real_ 1)
+
+
+example1Unroll :: TrivialABT Term '[] 'HInt
+example1Unroll = (summate (int_ 0) (int_ 100) $ \x -> x + (int_ 1 * int_ 42))
+
+example1Unroll' :: TrivialABT Term '[] 'HInt
+example1Unroll' = let_ (int_ 0 == int_ 100) $ \cond ->
+                  if_ cond (int_ 0)
+                      (let_ (int_ 1 * int_ 42) $ \tmp ->
+                       let_ (int_ 0 + tmp)     $ \first ->
+                       let_ (int_ 0 + int_ 1)  $ \start ->
+                       let_ (summate start (int_ 100) $ (+ tmp)) $ \total ->
+                       first + total)
+
+example1Hoist :: TrivialABT Term '[] 'HInt
+example1Hoist = summate (int_ 0) (int_ 1) $ \_ ->
+                summate (int_ 1) (int_ 2) id
+
+example1Hoist' :: TrivialABT Term '[] 'HInt
+example1Hoist' = let_ (summate (int_ 1) (int_ 2) id) $ \x ->
+                 summate (int_ 0) (int_ 1) (const x)
+
diff --git a/haskell/Tests/Disintegrate.hs b/haskell/Tests/Disintegrate.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/Disintegrate.hs
@@ -0,0 +1,571 @@
+{-# LANGUAGE DataKinds
+           , GADTs
+           , TypeOperators
+           , NoImplicitPrelude
+           , FlexibleContexts
+           , OverloadedStrings
+           #-}
+
+module Tests.Disintegrate where
+
+import           Prelude (($), (.), (++), head, String, Maybe(..))
+import qualified Prelude
+import qualified Data.List.NonEmpty  as L    
+
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Datum
+import Language.Hakaru.Syntax.Prelude
+import Language.Hakaru.Syntax.IClasses (Some2(..), TypeEq(..), jmEq1)
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Pretty.Concrete
+import Language.Hakaru.Syntax.TypeCheck
+import Language.Hakaru.Evaluation.Types               (fromWhnf)
+import Language.Hakaru.Evaluation.DisintegrationMonad (runDis)
+import Language.Hakaru.Disintegrate
+
+import Test.HUnit
+import Tests.TestTools
+import Tests.Models hiding (easyRoad)
+
+----------------------------------------------------------------
+type Model a b = TrivialABT Term '[] ('HMeasure (HPair a b))
+type Cond  a b = TrivialABT Term '[] (a ':-> 'HMeasure b)
+----------------------------------------------------------------
+
+-- | A very simple program. Is sufficient for testing escape and
+-- capture of substitution.
+norm0a :: Model 'HReal 'HReal
+norm0a =
+    normal (real_ 0) (prob_ 1) >>= \x ->
+    normal x         (prob_ 1) >>= \y ->
+    dirac (pair y x)
+
+-- | A version of 'norm0' which adds a type annotation at the
+-- top-level; useful for testing that using 'Ann_' doesn't cause
+-- perform\/disintegrate to loop.
+norm0b :: Model 'HReal 'HReal
+norm0b = ann_ sing norm0a
+
+-- | A version of 'norm0' which inserts an annotation around the
+-- 'Datum' constructor itself. The goal here is to circumvent the
+-- @typeOf_{Datum_}@ issue without needing to change the 'Datum'
+-- type nor the 'typeOf' definition.
+norm0c :: Model 'HReal 'HReal
+norm0c =
+    normal (real_ 0) (prob_ 1) >>= \x ->
+    normal x         (prob_ 1) >>= \y ->
+    dirac (ann_ sing $ pair y x)
+
+-- | What we expect 'norm0a' (and variants) to disintegrate to.
+norm0' :: Cond 'HReal 'HReal
+norm0' =
+    lam $ \y ->
+    normal (real_ 0) (prob_ 1) >>= \x ->
+    weight (densityNormal x (prob_ 1) y) >>
+    dirac x
+
+{-
+-- Eliminating some redexes of 'norm0'', that is:
+    lam $ \y ->
+    normal (real_ 0) (prob_ 1) >>= \x ->
+    withWeight
+        (exp ((x - y) ^ nat_ 2 / real_ 2)
+        / (nat_ 2 `thRootOf` (prob_ 2 * pi)))
+    $ dirac x
+
+-- N.B., calling 'evaluate' on 'norm0'' doesn't catch those redexes because they're not on the way to computing stuff. need to call 'constantPropagation' to get rid of them.
+-}
+
+
+testPerform0a, testPerform0b, testPerform0c
+    :: [Model 'HReal 'HReal]
+testPerform0a = runPerform norm0a
+testPerform0b = runPerform norm0b
+testPerform0c = runPerform norm0c
+
+testDisintegrate0a, testDisintegrate0b, testDisintegrate0c
+    :: [Cond 'HReal 'HReal]
+testDisintegrate0a = disintegrate norm0a
+testDisintegrate0b = disintegrate norm0b
+testDisintegrate0c = disintegrate norm0c
+
+-- | The goal of this test is to be sure we maintain proper hygiene
+-- for the weight component when disintegrating superpose. Moreover,
+-- in earlier versions it used to throw VarEqTypeError due to
+-- 'disintegrate' not choosing a sufficiently fresh variable name
+-- for its lambda; thus this also serves as a regression test to
+-- make sure we don't run into that problem again.
+testHygiene0b :: [Cond 'HReal 'HReal]
+testHygiene0b =
+    disintegrate $
+        let_ (prob_ 1) $ \x ->
+        withWeight x norm0b
+
+----------------------------------------------------------------
+-- | This simple progam is to check for disintegrating case analysis
+-- when the scrutinee contains a heap-bound variable.
+norm1a :: Model 'HReal HUnit
+norm1a =
+    normal (real_ 3) (prob_ 2) >>= \x ->
+    dirac $ if_ (x < real_ 0)
+        (ann_ sing $ pair (negate x) unit)
+        (ann_ sing $ pair         x  unit)
+
+norm1b :: Model HReal HUnit
+norm1b =
+    normal (real_ 3) (prob_ 2) >>= \x ->
+    if_ (x < real_ 0)
+        (ann_ sing . dirac $ pair (negate x) unit)
+        (ann_ sing . dirac $ pair         x  unit)
+
+norm1c :: Model 'HReal HUnit
+norm1c =
+    normal (real_ 3) (prob_ 2) >>= \x ->
+    if_ (x < real_ 0)
+        (dirac . ann_ sing $ pair (negate x) unit)
+        (dirac . ann_ sing $ pair         x  unit)
+
+norm1' :: Cond 'HReal HUnit
+norm1' =
+    lam $ \t -> superpose $
+     L.fromList 
+      [ (one,
+         weight (densityNormal (real_ 3) (prob_ 2) (negate t)) >>= \_ ->
+         let_ (negate t) $ \x ->
+         case_ (x < zero) [branch pTrue (dirac unit)])
+      , (one,
+         weight (densityNormal (real_ 3) (prob_ 2) t) >>= \_ ->
+         case_ (t < zero) [branch pFalse (dirac unit)]) ]
+
+-- BUG: the first solutions returned by 'testPerform1b' and 'testPerform1c' break hygiene! They drops the variable bound by 'normal' and has all the uses of @x@ become free.
+testPerform1a, testPerform1b, testPerform1c
+    :: [Model 'HReal HUnit]
+testPerform1a = runPerform norm1a
+testPerform1b = runPerform norm1b
+testPerform1c = runPerform norm1c
+
+testDisintegrate1a, testDisintegrate1b, testDisintegrate1c
+    :: [Cond 'HReal HUnit]
+testDisintegrate1a = disintegrate norm1a
+testDisintegrate1b = disintegrate norm1b
+testDisintegrate1c = disintegrate norm1c
+
+
+----------------------------------------------------------------
+norm2 :: Model 'HReal 'HReal
+norm2 =
+    normal (real_ 3) (prob_ 2) >>= \x ->
+    normal (real_ 5) (prob_ 4) >>= \y ->
+    dirac $ if_ (x < y)
+        (pair y x)
+        (pair x x)
+
+norm2' :: Cond 'HReal 'HReal
+norm2' =
+    lam $ \t -> superpose $
+     L.fromList
+      [ (one,
+         normal (real_ 3) (prob_ 2) >>= \x ->
+         weight (densityNormal (real_ 5) (prob_ 4) t) >>= \_ ->
+         case_ (x < t) [branch pTrue (dirac x)])
+      , (one,
+         weight (densityNormal (real_ 3) (prob_ 2) t) >>= \_ ->
+         normal (real_ 5) (prob_ 4) >>= \y ->
+         case_ (t < y) [branch pFalse (dirac t)]) ]   
+
+testPerform2
+    :: [Model 'HReal 'HReal]
+testPerform2 = runPerform norm2
+
+testDisintegrate2
+    :: [Cond 'HReal 'HReal]
+testDisintegrate2 = disintegrate norm2
+
+----------------------------------------------------------------
+
+normSquare :: Model 'HProb 'HReal
+normSquare =
+    normal (real_ 0) (prob_ 1) >>= \x ->
+    dirac (pair (square x) x)
+
+normSquare' :: Cond 'HProb 'HReal
+normSquare' =
+    lam $ \t ->
+    weight (recip (nat2prob (nat_ 2) * sqrt t)) >>= \_ ->
+    weight (densityNormal (real_ 0) (prob_ 1) (fromProb (sqrt t))) >>= \_ ->
+    dirac (fromProb (sqrt t)) >>= \x ->
+    dirac x
+          
+----------------------------------------------------------------
+
+normDirac :: Model 'HReal 'HReal
+normDirac =
+    normal (real_ 0) (prob_ 1) >>= \x ->
+    dirac x >>= \y ->
+    dirac (pair y x)
+
+normDirac' :: Cond 'HReal 'HReal
+normDirac' =
+    lam $ \t ->
+    weight (densityNormal (real_ 0) (prob_ 1) t) >>= \_ ->
+    dirac t >>= \x ->
+    dirac x
+
+----------------------------------------------------------------
+
+pendulum :: Model 'HReal 'HReal
+pendulum =
+    normal (real_ 42) (prob_ 1) >>= \theta ->
+    dirac (sin theta) >>= \x ->
+    normal (real_ 0) (prob_ 1) >>= \noise ->
+    dirac (pair (x + noise) theta)
+
+pendulum' :: Cond 'HReal 'HReal
+pendulum' =
+    lam $ \t ->
+    normal (real_ 42) (prob_ 1) >>= \theta ->
+    weight (densityNormal (real_ 0) (prob_ 1) (t - sin theta)) >>= \_ ->
+    dirac theta
+          
+----------------------------------------------------------------
+easyRoad :: Model (HPair 'HReal 'HReal) (HPair 'HProb 'HProb)
+easyRoad =
+    uniform (real_ 3) (real_ 8) >>= \noiseT_ ->
+    uniform (real_ 1) (real_ 4) >>= \noiseE_ ->
+    let_ (unsafeProb noiseT_) $ \noiseT ->
+    let_ (unsafeProb noiseE_) $ \noiseE ->
+    normal (real_ 0) noiseT >>= \x1 ->
+    normal x1 noiseE >>= \m1 ->
+    normal x1 noiseT >>= \x2 ->
+    normal x2 noiseE >>= \m2 ->
+    dirac (pair (pair m1 m2) (pair noiseT noiseE))
+
+easyRoad' :: Cond (HPair 'HReal 'HReal) (HPair 'HProb 'HProb)
+easyRoad' =
+    lam $ \t ->
+    unpair t (\t1 t2 ->
+              uniform (real_ 3) (real_ 8) >>= \noiseT_ ->
+              uniform (real_ 1) (real_ 4) >>= \noiseE_ ->
+              let_ (unsafeProb noiseT_) $ \noiseT ->
+              let_ (unsafeProb noiseE_) $ \noiseE ->
+              normal (real_ 0) noiseT >>= \x1 ->
+              weight (densityNormal x1 noiseE t1) >>= \_ ->
+              normal x1 noiseT >>= \x2 ->
+              weight (densityNormal x2 noiseE t2) >>
+              dirac (pair noiseT noiseE))
+                                     
+testPerformEasyRoad
+    :: [Model (HPair 'HReal 'HReal) (HPair 'HProb 'HProb)]
+testPerformEasyRoad = runPerform easyRoad
+
+
+testDisintegrateEasyRoad
+    :: [Cond (HPair 'HReal 'HReal) (HPair 'HProb 'HProb)]
+testDisintegrateEasyRoad = disintegrate easyRoad
+
+----------------------------------------------------------------
+helloWorld100
+    :: Model ('HArray 'HReal) 'HReal
+helloWorld100 =
+    normal (real_ 0) (prob_ 1) >>= \mu ->
+    plate (nat_ 100) (\_ -> normal mu (prob_ 1)) >>= \v ->
+    dirac (pair v mu)
+
+helloWorld100'
+    :: Cond ('HArray 'HReal) 'HReal
+helloWorld100' =
+    lam $ \t ->
+    normal (real_ 0) (prob_ 1) >>= \mu ->
+    plate (nat_ 100)
+          (\i -> weight (densityNormal mu (prob_ 1) (t ! i))) >>
+    dirac mu
+
+testHelloWorld100
+    :: [Cond ('HArray 'HReal) 'HReal]
+testHelloWorld100 = disintegrate helloWorld100
+
+----------------------------------------------------------------
+copy1 :: Model ('HArray 'HReal) HUnit
+copy1 =
+    plate n (\_ -> normal (real_ 0) (prob_ 1)) >>= \u ->
+    dirac (array n (\i -> u ! i)) >>= \v ->
+    dirac (pair v unit)
+    where n = nat_ 100
+
+copy1' :: Cond ('HArray 'HReal) HUnit
+copy1' =
+    lam $ \t ->        
+    plate (nat_ 100)
+          (\i -> weight (densityNormal (real_ 0) (prob_ 1) (t ! i))) >>
+    dirac unit
+
+testCopy1 :: [Cond ('HArray 'HReal) HUnit]
+testCopy1 = disintegrate copy1
+
+----------------------------------------------------------------
+copy2 :: Model ('HArray 'HReal) HUnit
+copy2 =
+    plate n (\_ -> normal (real_ 0) (prob_ 1)) >>= \u ->
+    plate n (\j -> dirac (u ! j)) >>= \v ->
+    dirac (pair v unit)
+    where n = nat_ 100
+
+testCopy2 :: [Cond ('HArray 'HReal) HUnit]
+testCopy2 = disintegrate copy2
+
+
+----------------------------------------------------------------
+naiveBayes
+    :: Model ('HArray ('HArray 'HNat)) ('HArray 'HNat)
+naiveBayes =
+    plate numLabels (\_ -> dirichlet (array sizeVocab (\_ -> prob_ 1))) >>= \bs ->
+    dirichlet (array numLabels (\_ -> prob_ 1)) >>= \ts ->
+    plate numDocs (\_ -> categorical ts) >>= \zs ->
+    plate numDocs (\i -> plate sizeEachDoc
+                               (\_ -> categorical (bs ! (zs ! i)))) >>= \ds ->
+    dirac (pair ds zs)
+    where sizeVocab   = nat_ 1000
+          numLabels   = nat_ 40
+          numDocs     = nat_ 200
+          sizeEachDoc = nat_ 5000
+
+naiveBayes'
+    :: Cond ('HArray ('HArray 'HNat)) ('HArray 'HNat)
+naiveBayes' =
+    lam $ \t ->
+    Prelude.error "TODO define naiveBayes'"
+
+testNaiveBayes
+    :: [Cond ('HArray ('HArray 'HNat)) ('HArray 'HNat)]
+testNaiveBayes = disintegrate naiveBayes
+          
+----------------------------------------------------------------
+-- | R2 benchmarks
+-- Based on examples from the R2 probabilistic programming tool
+-- Found in r2-0.0.1/examples/ when downloaded from:
+-- https://www.microsoft.com/en-us/download/details.aspx?id=52372
+
+clinicalTrial
+    :: Model (HPair ('HArray HBool) ('HArray HBool)) HBool
+clinicalTrial = 
+    bern (prob_ 0.5) >>= \isEffective ->
+    beta (prob_ 1) (prob_ 1) >>= \probControl ->
+    beta (prob_ 1) (prob_ 1) >>= \probTreated ->
+    beta (prob_ 1) (prob_ 1) >>= \probAll ->
+    if_ isEffective
+        (liftM2 pair (plate n (\_ -> bern probControl))
+                     (plate m (\_ -> bern probTreated)))
+        (liftM2 pair (plate n (\_ -> bern probAll))
+                     (plate m (\_ -> bern probAll))) >>= \groups ->
+    dirac (pair groups isEffective)
+    where (n,m) = (nat_ 1000, nat_ 1000)
+
+coinBias :: Model ('HArray HBool) 'HProb
+coinBias = beta (prob_ 2) (prob_ 5) >>= \bias ->
+           plate (nat_ 5) (\_ -> bern bias) >>= \tossResults ->
+           dirac (pair tossResults bias)
+
+digitRecognition :: Model ('HArray HBool) 'HNat
+digitRecognition =
+    categorical dataPrior >>= \y ->
+    plate n (\i -> bern $ (dataParams ! y) ! i) >>= \x ->
+    dirac (pair x y)
+    where n          = nat_ 784
+          dataPrior  = var (Variable "dataPrior"  73 (SArray SProb))
+          dataParams = var (Variable "dataParams" 41 (SArray (SArray SProb)))
+
+hiv :: Model ('HArray 'HReal)
+             (HPair (HPair ('HArray 'HReal) ('HArray 'HReal))
+                    ('HArray 'HReal))
+hiv = normal (real_ 0) (prob_ 1) >>= \muA1 ->
+      normal (real_ 0) (prob_ 1) >>= \muA2 ->
+      uniform (real_ 0) (real_ 100) >>= \sigmaA1 ->
+      uniform (real_ 0) (real_ 100) >>= \sigmaA2 ->
+      plate (nat_ 84) (\_ -> normal muA1       (unsafeProb sigmaA1)) >>= \a1 ->
+      plate (nat_ 84) (\_ -> normal ((real_ 0.1)*muA2) (unsafeProb sigmaA2)) >>= \a2 ->
+      dirac (array n (\i -> a1 ! (unsafeMinusNat (dataPerson ! i) (nat_ 1)) +
+                            a2 ! (unsafeMinusNat (dataPerson ! i) (nat_ 1)) *
+                            dataTime ! i)) >>= \yHat ->
+      uniform (real_ 0) (real_ 100) >>= \sigmaY ->
+      plate n (\i -> normal (yHat ! i) (unsafeProb sigmaY)) >>= \y ->
+      dirac (pair y (pair (pair a1 a2)
+                          (arrayLit [muA1, muA2, sigmaA1, sigmaA2, sigmaY])))
+    where n          = nat_ 369
+          dataPerson = var (Variable "dataPerson" 73 (SArray SNat)) 
+          dataTime   = var (Variable "dataTime"   41 (SArray SReal)) -- hacks :(
+
+linearRegression
+    :: Model ('HArray 'HReal) ('HArray 'HReal)
+linearRegression =
+    normal (real_ 0) (prob_ 1) >>= \a ->
+    normal (real_ 5) (prob_ 1.82574185835055371152) >>= \b ->
+    gamma (prob_ 1) (prob_ 1) >>= \invNoise ->
+    plate n (\i -> normal (a * (dataX ! i) + b) (recip $ sqrt invNoise)) >>= \y ->
+    dirac (pair y (arrayLit [a, b, fromProb invNoise]))
+    where n     = nat_ 1000
+          dataX = var (Variable "dataX" 73 (SArray SReal)) -- hack :(
+
+surveyUnbias :: Model ('HArray HBool)
+                      (HPair ('HArray ('HArray 'HProb)) ('HArray 'HReal))
+surveyUnbias =
+    dirac (size population) >>= \n ->
+    plate n (\_ -> beta (prob_ 1) (prob_ 1)) >>= \bias ->
+    dirac (array n (\i -> population!i * bias!i)) >>= \mean ->
+    dirac (array n (\i -> mean!i `unsafeMinusProb`
+                          (mean!i * bias!i))) >>= \variance ->
+    plate n (\i -> normal (fromProb $ mean!i)
+                          (sqrt $ variance!i)) >>= \votes ->
+    dirac (size personGender) >>= \m ->
+    dirac (array m (\i -> bias ! (personGender ! i))) >>= \ansBias ->
+    plate m (\i -> bern $ ansBias ! i) >>= \answer ->
+    dirac (pair answer (pair (arrayLit [bias, mean, variance]) votes))
+    where population   = var (Variable "population"   73 (SArray SProb))
+          personGender = var (Variable "personGender" 41 (SArray SNat))
+
+surveyUnbias2 :: Model ('HArray HBool)
+                       (HPair ('HArray 'HProb) ('HArray 'HInt))
+surveyUnbias2 =
+    dirac (size population) >>= \n ->
+    plate n (\_ -> beta (prob_ 1) (prob_ 1)) >>= \bias ->
+    plate n (\i -> binomial (population!i) (bias!i)) >>= \votes ->
+    dirac (size personGender) >>= \m ->
+    dirac (array m (\i -> bias ! (personGender ! i))) >>= \ansBias ->
+    plate m (\i -> bern $ ansBias ! i) >>= \answer ->
+    dirac (pair answer (pair bias votes))
+    where population   = var (Variable "population"   73 (SArray SNat))
+          personGender = var (Variable "personGender" 41 (SArray SNat))
+    
+----------------------------------------------------------------
+
+unzipFst :: Model ('HArray 'HReal) HUnit
+unzipFst = plate n (\_ -> liftM2 pair (normal zero one)
+                                      (normal zero one)) >>= \u ->
+           dirac (array n (\i -> fst (u ! i))) >>= \v ->
+           dirac (pair v unit)
+    where n = nat_ 1000
+
+transpose :: Model ('HArray ('HArray 'HReal)) HUnit
+transpose = plate n (\_ -> plate n (\_ -> normal zero one)) >>= \u ->
+            dirac (array n (\i -> array n (\j -> (u ! j) ! i))) >>= \v ->
+            dirac (pair v unit)
+    where n = nat_ 3500
+
+----------------------------------------------------------------
+
+testEmissions :: Model ('HArray 'HReal) HUnit
+testEmissions = plate n (\_ -> lebesgue) >>= \xs ->
+                plate n (\_ -> lebesgue) >>= \ys ->
+                dirac (pair (array n (\i -> (xs ! i) + (ys ! i))) unit)
+    where n = nat_ 100
+
+-- Tug of war example for debugging scope extrusion errors
+-- https://github.com/hakaru-dev/hakaru/issues/30
+tow :: Model (HPair 'HReal 'HReal) 'HReal
+tow = normal zero one >>= \alice ->
+      normal zero one >>= \bob ->
+      normal zero one >>= \carol ->
+      (normal alice one >>= \a ->
+       normal bob   one >>= \b ->
+       dirac (a-b)) >>= \match1 ->
+      (normal bob   one >>= \b ->
+       normal carol one >>= \c ->
+       dirac (b-c)) >>= \match2 ->
+      (normal alice one >>= \a ->
+       normal carol one >>= \c ->
+       dirac (a-c)) >>= \match3 ->
+      dirac (pair (pair match1 match2) match3)
+
+-- Smaller version of tug of war
+minimaltow :: Model 'HReal HUnit
+minimaltow = normal zero one >>= \alice ->
+             normal zero one >>= \bob ->
+             (normal alice one >>= \a ->
+              normal bob   one >>= \b ->
+              dirac (a-b)) >>= \match ->
+             dirac (pair match unit)
+
+slice :: Model 'HReal 'HReal 
+slice = normal zero one >>= \x ->
+        uniform zero (fromProb (densityNormal zero one x)) >>= \y ->
+        dirac (pair y x)
+
+oneAndAll :: Model 'HReal ('HArray 'HReal)
+oneAndAll = plate (nat_ 100) (\_ -> normal zero one) >>= \x ->
+            dirac (pair (x ! nat_ 3) x)
+
+runPerform
+    :: TrivialABT Term '[] ('HMeasure a)
+    -> [TrivialABT Term '[] ('HMeasure a)]
+runPerform e = runDis (fromWhnf `Prelude.fmap` perform e) [Some2 e]               
+
+-- | Tests that disintegration doesn't error and produces at least
+-- one solution.
+testDis
+    :: (ABT Term abt)
+    => String
+    -> abt '[] ('HMeasure (HPair a b))
+    -> Assertion
+testDis p =
+    assertBool (p ++ ": no disintegration found")
+    . Prelude.not
+    . Prelude.null
+    . disintegrate
+
+showFirst :: Model a b -> Prelude.IO ()
+showFirst e = let anss = disintegrate e
+              in if Prelude.null anss
+                 then Prelude.putStrLn $ "no disintegration found"
+                 else Prelude.print    $ pretty (head anss)
+
+-- TODO: put all the "perform" tests in here
+allTests :: Test
+allTests = test
+    [ testDis "testDisintegrate0a" norm0a
+    , testDis "testDisintegrate0b" norm0b
+    , testDis "testDisintegrate0c" norm0c
+    , assertAlphaEq "testDisintegrate0a" (head testDisintegrate0a) norm0'
+    , assertAlphaEq "testDisintegrate0b" (head testDisintegrate0b) norm0'
+    , assertAlphaEq "testDisintegrate0c" (head testDisintegrate0c) norm0'
+    , assertBool "testHygiene0b" $ Prelude.not (Prelude.null testHygiene0b)
+    , testDis "testDisintegrate1a" norm1a
+    , testDis "testDisintegrate1b" norm1b
+    , testDis "testDisintegrate1c" norm1c
+    , assertAlphaEq "testDisintegrate1a" (head testDisintegrate1a) norm1'
+    , assertAlphaEq "testDisintegrate1b" (head testDisintegrate1b) norm1'
+    , assertAlphaEq "testDisintegrate1c" (head testDisintegrate1c) norm1'
+    , testDis "testDisintegrate2" norm2
+    , assertAlphaEq "testDisintegrate2" (head testDisintegrate2) norm2'
+    , testWithConcrete' match_norm_unif LaxMode $ \_typ ast ->
+        case jmEq1 _typ (SMeasure $ sPair SReal sBool) of
+        Just Refl -> testDis "testMatchNormUnif" ast
+        Nothing   -> assertFailure "BUG: jmEq1 got the wrong type"
+    , testWithConcrete' dont_atomize_weights LaxMode $ \_typ ast ->
+        case jmEq1 _typ (SMeasure $ sPair SReal sUnit) of
+        Just Refl -> testDis "testAtomizeWeights" ast
+        Nothing   -> assertFailure "BUG: jmEq1 got the wrong type"
+    , assertBool "testPerformEasyRoad" $ Prelude.not (Prelude.null testPerformEasyRoad)
+    , testDis "testDisintegrateEasyRoad" easyRoad
+    , assertAlphaEq "testDisintegrateEasyRoad" (head testDisintegrateEasyRoad) easyRoad'
+    , testDis "testHelloWorld100" helloWorld100
+    , assertAlphaEq "testHelloWorld100" (head testHelloWorld100) helloWorld100'
+    , testDis "testCopy1" copy1
+    , assertAlphaEq "testCopy1" (head testCopy1) copy1'
+    , testDis "testCopy2" copy2
+    , assertAlphaEq "testCopy2" (head testCopy2) copy1'
+    , testDis "testPendulum" pendulum
+    , assertAlphaEq "testPendulumDisintegrate" (disintegrate pendulum Prelude.!! 2) pendulum'
+    , testDis "testNaiveBayes" naiveBayes
+    , testDis "testClinicalTrial" clinicalTrial
+    , testDis "testCoinBias" coinBias
+    , testDis "testDigitRecognition" digitRecognition
+    , testDis "TestHIV" hiv
+    , testDis "testLinearRegression" linearRegression
+    , testDis "testSurveyUnbias" surveyUnbias
+    , testDis "testSurveyUnbias2" surveyUnbias2
+    ]
+
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Tests/Models.hs b/haskell/Tests/Models.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/Models.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE DataKinds
+           , NoImplicitPrelude
+           , OverloadedStrings
+           , FlexibleContexts #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+----------------------------------------------------------------
+--                                                    2016.04.22
+-- |
+-- Module      :  Tests.Models
+-- Copyright   :  Copyright (c) 2016 the Hakaru team
+-- License     :  BSD3
+-- Maintainer  :  wren@community.haskell.org
+-- Stability   :  experimental
+-- Portability :  GHC-only
+--
+-- Some common models used in many different tests.
+--
+-- TODO: we might should adjust our use of 'pair' to include a type
+-- annotation, to avoid issues about 'Language.Hakaru.Syntax.TypeOf.typeOf'
+-- on 'Datum'.
+----------------------------------------------------------------
+module Tests.Models where
+
+import Data.Text
+import qualified Data.List.NonEmpty as L
+
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Syntax.AST (Term)
+import Language.Hakaru.Syntax.ABT (ABT)
+import Language.Hakaru.Syntax.Prelude
+
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+uniform_0_1 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
+uniform_0_1 = uniform zero one
+
+-- build uniform with nats and coercions
+uniformC :: (ABT Term abt)
+         => abt '[] 'HNat
+         -> abt '[] 'HNat
+         -> abt '[] ('HMeasure 'HReal)
+uniformC lo hi = uniform (nat2real lo) (nat2real hi)
+
+normal_0_1 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
+normal_0_1 = normal zero one
+
+-- build normal with nats and coercions
+normalC  :: (ABT Term abt)
+         => abt '[] 'HNat
+         -> abt '[] 'HNat
+         -> abt '[] ('HMeasure 'HReal)
+normalC mu sd = normal (nat2real mu) (nat2prob sd)
+
+gamma_1_1 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
+gamma_1_1 = gamma one one
+
+beta_1_1 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
+beta_1_1 = beta one one
+
+
+-- TODO: a better name for this
+t4 :: (ABT Term abt) => abt '[] ('HMeasure (HPair 'HProb HBool))
+t4 =
+    beta one one >>= \bias ->
+    bern bias >>= \coin ->
+    dirac (pair bias coin)
+
+t4' :: (ABT Term abt) => abt '[] ('HMeasure (HPair 'HProb HBool))
+t4' =
+    uniform zero one >>= \x ->
+    let x' = unsafeProb x in
+    superpose (L.fromList
+        [ (x'                  , dirac (pair x' true))
+        , (unsafeProb (one - x), dirac (pair x' false))
+        ])
+
+norm :: (ABT Term abt) => abt '[] ('HMeasure (HPair 'HReal 'HReal))
+norm =
+    normal zero one >>= \x ->
+    normal x one >>= \y ->
+    dirac (pair x y)
+
+unif2 :: (ABT Term abt) => abt '[] ('HMeasure (HPair 'HReal 'HReal))
+unif2 =
+    uniform (negate one) one >>= \x ->
+    uniform (x - one) (x + one) >>= \y ->
+    dirac (pair x y)
+
+match_norm_unif :: Text
+match_norm_unif = unlines
+    [ "def bern(p prob):"
+    , "    x <~ categorical([p, real2prob(1 - p)])"
+    , "    return [true, false][x]"
+    , ""
+    , "x <~ bern(0.5)"
+    , "y <~ match x:"
+    , "       true:  normal(0,1)"
+    , "       false: uniform(0,1)"
+    , "return ((y,x). pair(real, bool))"
+    ]
+
+match_norm_bool :: Text
+match_norm_bool = unlines
+    [ "x <~ normal(3,2)"
+    , "return (match x < 0:"
+    , "          true:  (-x, ())"
+    , "          false: ( x, ()))"
+    ]
+
+easyRoad :: Text
+easyRoad = unlines
+    ["noiseT_ <~ uniform(3, 8)"
+    ,"noiseE_ <~ uniform(1, 4)"
+    ,"noiseT = unsafeProb(noiseT_)"
+    ,"noiseE = unsafeProb(noiseE_)"
+    ,"x1 <~ normal(0,  noiseT)"
+    ,"m1 <~ normal(x1, noiseE)"
+    ,"x2 <~ normal(x1, noiseT)"
+    ,"m2 <~ normal(x2, noiseE)"
+    ,"return ((m1, m2), (noiseT, noiseE))"
+    ]
+
+plate_norm :: Text
+plate_norm = unlines
+    [ "x <~ normal(0,1)"
+    , "y <~ plate _ of 5:"
+    , "       normal(x,1)"
+    , "return (y, x)"
+    ]
+
+negate_prob :: Text
+negate_prob = "unsafeProb(1.0 + negate(2.0))"
+
+dont_atomize_weights :: Text
+dont_atomize_weights = unlines
+    ["x <~ uniform(1,3)"
+    ,"weight(real2prob(x), return (x, ()))"]
+
+----------------------------------------------------------------
+----------------------------------------------------------- fin.
diff --git a/haskell/Tests/Parser.hs b/haskell/Tests/Parser.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/Parser.hs
@@ -0,0 +1,539 @@
+{-# LANGUAGE CPP, OverloadedStrings, DataKinds #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-orphans #-}
+
+module Tests.Parser where
+
+import Prelude hiding (unlines)
+
+import Language.Hakaru.Parser.Parser (parseHakaru)
+import Language.Hakaru.Parser.AST
+
+import Data.String (IsString)
+import Data.Text
+import Test.HUnit
+import Test.QuickCheck.Arbitrary
+import Test.QuickCheck
+import Data.Function (on)
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative   (Applicative(..), (<$>))
+#endif
+
+arbNat  :: Gen (Positive Integer)
+arbNat  = arbitrary
+
+arbProb :: Gen (Positive Rational)
+arbProb = arbitrary
+
+instance Arbitrary Text where
+    arbitrary = pack <$> ("x" ++) . show <$> getPositive <$> arbNat
+    shrink xs = pack <$> shrink (unpack xs)
+
+instance Arbitrary Literal' where
+    arbitrary = oneof
+        [ Nat  <$> getPositive <$> arbNat
+        , Int  <$> arbitrary
+        , Prob <$> getPositive <$> arbProb
+        , Real <$> arbitrary
+        ]
+
+instance Arbitrary TypeAST' where
+    arbitrary = frequency
+        [ (20, TypeVar <$> arbitrary)
+        , ( 1, TypeApp <$> arbitrary <*> arbitrary)
+        , ( 1, TypeFun <$> arbitrary <*> arbitrary)
+        ]
+
+instance Arbitrary NaryOp where
+    arbitrary = elements
+        [And, Or,  Xor, Iff, Min, Max, Sum, Prod]
+
+instance Arbitrary a => Arbitrary (Pattern' a) where
+    arbitrary = oneof
+        [ PVar' <$> arbitrary
+        , return PWild'
+        , PData' <$> (DV <$> arbitrary <*> arbitrary)
+        ]
+
+instance (Arbitrary a, IsString a) => Arbitrary (Branch' a) where
+    arbitrary = Branch' <$> arbitrary <*> arbitrary
+
+instance (Arbitrary a, IsString a) => Arbitrary (AST' a) where
+    arbitrary = frequency
+        [ (10, Var <$> arbitrary)
+        , ( 1, Lam <$> arbitrary <*> arbitrary <*> arbitrary)
+        , ( 1, App <$> arbitrary <*> arbitrary)
+        , ( 1, Let <$> arbitrary <*> arbitrary <*> arbitrary)
+        , ( 1, If  <$> arbitrary <*> arbitrary <*> arbitrary)
+        , ( 1, Ann <$> arbitrary <*> arbitrary)
+        , ( 1, return Infinity')
+        , ( 1, ULiteral <$> arbitrary)
+        --, ( 1, NaryOp <$> arbitrary)
+        , ( 1, return (ArrayLiteral []))
+        , ( 1, Case  <$> arbitrary <*> arbitrary)
+        , ( 1, App (Var "dirac") <$> arbitrary)
+        , ( 1, Bind  <$> arbitrary <*> arbitrary <*> arbitrary)
+        ]
+
+testParse :: Text -> AST' Text -> Assertion
+testParse s p =
+    case parseHakaru s of
+    Left  m  -> assertFailure (unpack s ++ "\n" ++ show m)
+    Right p' -> assertEqual "" (withoutMetaE p) (withoutMetaE p')
+
+if1, if2, if3, if4, if5 :: Text
+
+ifAST1, ifAST2 :: AST' Text
+
+if1 = "if True: 1 else: 2"
+
+if2 = unlines
+    ["if True: 1 else:"
+    ,"2"
+    ] 
+
+if3 = unlines
+    ["if True:"
+    ,"  1"
+    ,"else:"
+    ,"  2"
+    ]
+
+if4 = unlines
+    ["if True:"
+    ,"  1 else: 2"
+    ]
+
+if5 = unlines
+    ["if True:"
+    ,"   4"
+    ,"else:"
+    ,"   if False:"
+    ,"      2"
+    ,"   else:"
+    ,"      3"
+    ]
+
+ifAST1 =
+    If (Var "True")
+    (ULiteral (Nat 1))
+    (ULiteral (Nat 2))
+
+ifAST2 =
+    If (Var "True")
+    (ULiteral (Nat 4))
+    (If (Var "False")
+        (ULiteral (Nat 2))
+        (ULiteral (Nat 3)))
+
+testIfs :: Test
+testIfs = test
+    [ testParse if1 ifAST1
+    , testParse if2 ifAST1
+    , testParse if3 ifAST1
+    , testParse if4 ifAST1
+    , testParse if5 ifAST2
+    ]
+
+lam1 :: Text
+lam1 = "fn x nat: x+3"
+
+lam1AST :: AST' Text
+lam1AST = Lam "x" (TypeVar "nat")
+          (NaryOp Sum [ Var "x"
+                      , ULiteral (Nat 3)
+                      ])
+
+def1 :: Text
+def1 = unlines
+    ["def foo(x nat):"
+    ,"    x + 3"
+    ,"foo(5)"
+    ]
+
+def2 :: Text
+def2 = unlines
+    ["def foo(x nat): x + 3"
+    ,"foo(5)"
+    ]
+
+def3 :: Text
+def3 = unlines
+    ["def foo(x real):"
+    ,"    y <~ normal(x,1.0)"
+    ,"    return (y + y. real)"
+    ,"foo(-(2.0))"
+    ]
+
+def4 :: Text
+def4 = unlines
+    ["def foo(x nat) nat:"
+    ,"    x+3"
+    ,"foo(5)"
+    ]
+
+def1AST :: AST' Text
+def1AST =
+    Let "foo" (Lam "x" (TypeVar "nat")
+               (NaryOp Sum [Var "x", ULiteral (Nat 3)]))
+    (App (Var "foo") (ULiteral (Nat 5)))
+
+def2AST :: AST' Text
+def2AST =
+    Let "foo" (Lam "x" (TypeVar "real")
+        (Bind "y" (App (App (Var "normal") (Var "x")) (ULiteral (Prob 1.0)))
+        (App (Var "dirac") (Ann (NaryOp Sum [Var "y", Var "y"])
+                    (TypeVar "real")))))
+    (App (Var "foo") (App (Var "negate") (ULiteral (Prob 2.0))))
+
+def3AST :: AST' Text
+def3AST =
+    Let "foo" (Ann
+        (Lam "x" (TypeVar "nat")
+                 (NaryOp Sum [Var "x", ULiteral (Nat 3)]))
+        (TypeFun (TypeVar "nat") (TypeVar "nat")))
+    (App (Var "foo") (ULiteral (Nat 5)))
+
+testLams :: Test
+testLams = test
+    [ testParse lam1 lam1AST
+    , testParse def1 def1AST
+    , testParse def2 def1AST
+    , testParse def3 def2AST
+    , testParse def4 def3AST
+    ]
+
+let1 :: Text
+let1 = unlines
+    ["x = 3"
+    ,"y = 2"
+    ,"x + y"
+    ]
+
+let1AST :: AST' Text
+let1AST =
+    Let "x" (ULiteral (Nat 3))
+    (Let "y" (ULiteral (Nat 2))
+    (NaryOp Sum [Var "x", Var "y"]))
+
+testLets :: Test
+testLets = test
+    [ testParse let1 let1AST ]
+
+bind1 :: Text
+bind1 = unlines
+    ["x <~ uniform(0,1)"
+    ,"y <~ normal(x, 1)"
+    ,"dirac(y)"
+    ]
+
+bind2 :: Text
+bind2 = unlines
+    ["x <~ uniform(0,1)"
+    ,"y <~ normal(x, 1)"
+    ,"return y"
+    ]
+
+bind1AST :: AST' Text
+bind1AST =
+    Bind "x" (App (App (Var "uniform")
+                       (ULiteral (Nat 0)))
+                       (ULiteral (Nat 1)))
+    (Bind "y" (App (App (Var "normal")
+                        (Var "x"))
+                        (ULiteral (Nat 1)))
+    (App (Var "dirac") (Var "y")))
+
+ret1 :: Text
+ret1 =  "return return 3"
+
+ret1AST :: AST' Text
+ret1AST = App (Var "dirac") (App (Var "dirac") (ULiteral (Nat 3)))
+
+testBinds :: Test
+testBinds = test
+   [ testParse bind1 bind1AST
+   , testParse bind2 bind1AST
+   , testParse ret1  ret1AST
+   ]
+
+match1 :: Text
+match1 = unlines
+    ["match e:"
+    ,"  left(a): e1"
+    ]
+
+match1AST :: AST' Text
+match1AST =
+    Case (Var "e")
+    [Branch' (PData' (DV "left" [PVar' "a"])) (Var "e1")]
+
+-- The space between _ and : is important
+match2 :: Text
+match2 = unlines
+    ["match e:"
+    ,"  _: e"
+    ]
+
+match2AST :: AST' Text
+match2AST =
+    Case (Var "e")
+    [Branch' PWild' (Var "e")]
+
+match3 :: Text
+match3 = unlines
+    ["match e:"
+    ,"  a: e"
+    ]
+
+match3AST :: AST' Text
+match3AST =
+    Case (Var "e")
+    [Branch' (PVar' "a") (Var "e")]
+
+match4 :: Text
+match4 = unlines
+    ["match e:"
+    ,"  left(a):  e1"
+    ,"  right(b): e2"
+    ]
+
+match4AST :: AST' Text
+match4AST =
+    Case (Var "e")
+    [ Branch' (PData' (DV "left"  [PVar' "a"])) (Var "e1")
+    , Branch' (PData' (DV "right" [PVar' "b"])) (Var "e2")
+    ]
+
+match5 :: Text
+match5 = unlines
+    ["match e:"
+    ,"  left(a):"
+    ,"   e1"
+    ,"  right(b):"
+    ,"   e2"
+    ]
+
+match5AST :: AST' Text
+match5AST =
+    Case (Var "e")
+    [ Branch' (PData' (DV "left" [PVar' "a"])) (Var "e1")
+    , Branch' (PData' (DV "right" [PVar' "b"])) (Var "e2")
+    ]
+
+match6 :: Text
+match6 = unlines
+    ["match (2,3). pair(nat,nat):"
+    ,"   (a,b): a+b"
+    ]
+
+match6AST :: AST' Text
+match6AST =
+    Case (Ann
+          (Pair
+           (ULiteral (Nat 2))
+           (ULiteral (Nat 3)))
+     (TypeApp "pair" [TypeVar "nat",TypeVar "nat"]))
+    [Branch' (PData' (DV "pair" [PVar' "a",PVar' "b"]))
+     (NaryOp Sum [Var "a", Var "b"])]
+
+
+match7 :: Text
+match7 = unlines
+    ["match (-2.0,1.0). pair(real,prob):"
+    ,"   (a,b): normal(a,b)"
+    ]
+
+match7AST :: AST' Text
+match7AST = Case (Ann
+                  (Pair
+                   (ULiteral (Real (-2.0)))
+                   (ULiteral (Prob 1.0)))
+             (TypeApp "pair" [TypeVar "real",TypeVar "prob"]))
+            [Branch' (PData' (DV "pair" [PVar' "a",PVar' "b"]))
+             (App (App (Var "normal") (Var "a")) (Var "b"))]
+
+testMatches :: Test
+testMatches = test
+    [ testParse match1 match1AST
+    , testParse match2 match2AST
+    , testParse match3 match3AST
+    , testParse match4 match4AST
+    , testParse match5 match5AST
+    , testParse match6 match6AST
+    , testParse match7 match7AST
+    ]
+
+ann1 :: Text
+ann1 = "5. nat"
+
+ann1AST :: AST' Text
+ann1AST = Ann (ULiteral (Nat 5)) (TypeVar "nat")
+
+ann2 :: Text
+ann2 = "(2,3). pair(a,b)"
+
+ann2AST :: AST' Text
+ann2AST =
+    Ann (Pair (ULiteral (Nat 2)) (ULiteral (Nat 3)))
+        (TypeApp "pair" [TypeVar "a", TypeVar "b"])
+
+ann3 :: Text
+ann3 = "f. a -> measure(a)"
+
+ann3AST :: AST' Text
+ann3AST =
+    Ann (Var "f") (TypeFun (TypeVar "a")
+        (TypeApp "measure" [(TypeVar "a")]))
+
+testAnn :: Test
+testAnn = test
+    [ testParse ann1 ann1AST
+    , testParse ann2 ann2AST
+    , testParse ann3 ann3AST
+    ]
+
+expect1 :: Text
+expect1 = unlines
+    ["expect x <~ normal(0,1):"
+    ,"   1"
+    ]
+
+expect1AST :: AST' Text
+expect1AST = _Expect "x" (App (App (Var "normal")
+                              (ULiteral (Nat 0)))
+                         (ULiteral (Nat 1)))
+             (ULiteral (Nat 1))
+
+expect2 :: Text
+expect2 = unlines
+    ["expect x <~ normal(0,1):"
+    ,"   unsafeProb(x*x)"
+    ]
+
+expect2AST :: AST' Text
+expect2AST = _Expect "x" (App (App (Var "normal")
+                              (ULiteral (Nat 0)))
+                         (ULiteral (Nat 1)))
+             (App (Var "unsafeProb")
+              (NaryOp Prod [Var "x", Var "x"]))
+
+testExpect :: Test
+testExpect = test
+    [ testParse expect1 expect1AST
+    , testParse expect2 expect2AST
+    ]
+
+array1 :: Text
+array1 = unlines
+   ["array x of 12:"
+   ,"   x + 1"
+   ]
+
+array1AST :: AST' Text
+array1AST = Array "x" (ULiteral (Nat 12))
+            (NaryOp Sum [Var "x", ULiteral (Nat 1)])
+
+array2 :: Text
+array2 = "2 + x[3][4]"
+
+array2AST :: AST' Text
+array2AST = NaryOp Sum
+            [ ULiteral (Nat 2)
+            , Index (Index (Var "x")
+                     (ULiteral (Nat 3)))
+              (ULiteral (Nat 4))
+            ]
+
+array3 :: Text
+array3 = "[4, 0, 9]"
+
+array3AST :: AST' Text
+array3AST = ArrayLiteral [ ULiteral (Nat 4)
+                         , ULiteral (Nat 0)
+                         , ULiteral (Nat 9)
+                         ]
+                                   
+testArray :: Test
+testArray = test
+    [ testParse array1 array1AST
+    , testParse array2 array2AST
+    , testParse array3 array3AST
+    ]
+
+easyRoad1 :: Text
+easyRoad1 = unlines
+    ["noiseT <~ uniform(3, 8)"
+    ,"noiseE <~ uniform(1, 4)"
+    ,"x1 <~ normal( 0, noiseT)"
+    ,"m1 <~ normal(x1, noiseE)"
+    ,"x2 <~ normal(x1, noiseT)"
+    ,"m2 <~ normal(x2, noiseE)"
+    ,"return ((m1, m2), (noiseT, noiseE))"
+    ]
+
+-- works in lax mode
+easyRoad2 :: Text
+easyRoad2 = unlines
+    ["noiseT_ <~ uniform(3, 8)"
+    ,"noiseE_ <~ uniform(1, 4)"
+    ,"noiseT = unsafeProb(noiseT_)"
+    ,"noiseE = unsafeProb(noiseE_)"
+    ,"x1 <~ normal(0,  noiseT)"
+    ,"m1 <~ normal(x1, noiseE)"
+    ,"x2 <~ normal(x1, noiseT)"
+    ,"m2 <~ normal(x2, noiseE)"
+    ,"return ((m1, m2), (noiseT, noiseE)). measure(pair(pair(real,real),pair(prob,prob)))"
+    ]
+
+
+easyRoadAST :: AST' Text
+easyRoadAST =
+    Bind "noiseT" (App (App (Var "uniform")
+                            (ULiteral (Nat 3)))
+                            (ULiteral (Nat 8)))
+    (Bind "noiseE" (App (App (Var "uniform")
+                             (ULiteral (Nat 1)))
+                             (ULiteral (Nat 4)))
+    (Bind "x1" (App (App (Var "normal")
+                         (ULiteral (Nat 0)))
+                         (Var "noiseT"))
+    (Bind "m1" (App (App (Var "normal")
+                         (Var "x1"))
+                         (Var "noiseE"))
+    (Bind "x2" (App (App (Var "normal")
+                         (Var "x1"))
+                         (Var "noiseT"))
+    (Bind "m2" (App (App (Var "normal")
+                         (Var "x2"))
+                         (Var "noiseE"))
+    (App (Var "dirac")
+        (Pair
+         (Pair
+          (Var "m1")
+          (Var "m2"))
+         (Pair
+          (Var "noiseT")
+          (Var "noiseE")))))))))
+
+testRoadmap :: Test
+testRoadmap = test
+    [ testParse easyRoad1 easyRoadAST
+    ]
+
+
+
+allTests :: Test
+allTests = test
+    [ testIfs
+    , testLams
+    , testLets
+    , testBinds
+    , testMatches
+    , testAnn
+    , testExpect
+    , testArray
+    , testRoadmap
+    ]
+
+
diff --git a/haskell/Tests/Pretty.hs b/haskell/Tests/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/Pretty.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE OverloadedStrings
+           , DataKinds
+           , GADTs
+           , TypeOperators 
+           , FlexibleContexts #-}
+
+module Tests.Pretty where
+
+import           Language.Hakaru.Command (parseAndInfer)
+import           Language.Hakaru.Pretty.Concrete
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Syntax.Prelude
+import           Language.Hakaru.Syntax.TypeCheck
+import           Language.Hakaru.Types.Sing
+import           Language.Hakaru.Types.DataKind
+import qualified Language.Hakaru.Parser.AST as U
+import qualified Language.Hakaru.Syntax.AST as T
+import           Language.Hakaru.Syntax.IClasses
+import           Language.Hakaru.Types.Sing
+
+
+import           Tests.TestTools 
+import           Data.Text
+import           Text.PrettyPrint
+import           Test.HUnit
+import           Text.Parsec.Error
+import           Control.Monad.Trans.State.Strict (evalState)
+
+import           Prelude ((.), ($), asTypeOf, String, FilePath, Show(..), (++), Bool(..), concat 
+                         ,Either(..), Maybe(..))
+import qualified Prelude 
+
+allTests :: Test
+allTests = test
+    [ "basic let"  ~: testPretty letTest 
+    , "nested let" ~: testPretty letTest2
+    , "basic fn"   ~: testPretty defTest 
+    , "nested fn"  ~: testPretty defTest2
+    , "fn in case" ~: testPretty' caseFn  
+    , "fn literal in case" ~: testPretty' caseFn2 
+    , "hof"        ~: testPretty' hof
+    ]
+
+letTest = unlines ["x = 2"
+                  ,"y = 3"
+                  ,"x"
+                  ]
+
+letTest2 = unlines ["x = y = 2"
+                   ,"    y"
+                   ,"x"
+                   ]
+
+defTest = unlines ["foo = fn x nat:"
+                  ,"  x + 2"
+                  ,"foo(3)"
+                  ]
+
+defTest2 = unlines ["foo = fn x nat: fn y nat:"
+                   ,"  x + y"
+                   ,"foo(2,3)"
+                   ]
+
+caseFn :: (ABT T.Term abt) => abt '[] 'HProb
+caseFn = 
+  pair (lam $ \x -> x) (lam $ \x -> x)
+     `unpair` \a b -> (a `app` prob_ 1) + (b `app` prob_ 2)
+
+caseFn2 :: (ABT T.Term abt, b ~ HProb) => abt '[] (b :-> (b :-> (b :-> b)))
+caseFn2 = 
+    lam $ \x0 ->
+    let_ (lam $ \x1 ->
+        (lam $ \x2 ->
+         (pair (lam $ \x -> x) (prob_ 12)) `unpair` \x4 x5 -> x4 `app` (x0 + x1 + x2 + x5))) $ \x -> x 
+
+hof :: (ABT T.Term abt, a ~ HProb) => abt '[] (a :-> a :-> a :-> (a :-> (a :-> HPair a ((a :-> a) :-> a))) :-> a)
+hof = 
+  lam $ \x0 -> lam $ \x1 -> lam $ \x3 -> lam $ \x4 -> (
+     x4 `app` x0
+        `app` x1 `unpair` \x2 x3 ->
+        x3 `app` (lam $ \_ -> prob_ 1))
+
+-- Tests things are parsed and prettyprinted nearly the same
+testPretty :: Text -> Assertion 
+testPretty t =
+  case parseAndInfer t of 
+    Left err                -> assertFailure ("Program failed to parse\n" ++ unpack err)
+    Right (TypedAST ty ast) -> 
+      case parseAndInfer $ pack $ show $ pretty ast of 
+        Left err                  -> assertFailure ("Pretty printed program failed to parse\n" ++ unpack err)
+        Right (TypedAST ty' ast') -> 
+          Prelude.maybe 
+              (assertFailure $ mismatchMessage (prettyType 10) "Pretty printed programs has different type!" ty ty')
+              (\Refl -> assertAlphaEq "" ast ast') 
+              (jmEq1 ty ty')
+
+testPretty' :: TrivialABT T.Term '[] a -> Assertion 
+testPretty' = testPretty . pack . show . pretty 
diff --git a/haskell/Tests/Relationships.hs b/haskell/Tests/Relationships.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/Relationships.hs
@@ -0,0 +1,369 @@
+{-# LANGUAGE NoImplicitPrelude
+           , DataKinds
+           , TypeOperators
+           , TypeFamilies
+           , ScopedTypeVariables
+           , FlexibleContexts
+           #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Tests.Relationships (allTests) where
+
+import Prelude ((.), id, ($), asTypeOf)
+
+import Language.Hakaru.Syntax.Prelude
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Syntax.AST (Term)
+import Language.Hakaru.Syntax.ABT (ABT)
+
+import Test.HUnit
+import Tests.TestTools
+import Tests.Models (normal_0_1, uniform_0_1)
+
+
+allTests :: Test
+allTests = test
+    [ testRelationships
+    ]
+
+testRelationships :: Test
+testRelationships = test [
+    "t1"   ~: testSStriv [t1] (lam $ \_ -> lam $ \_ -> normal_0_1),
+    "t2"   ~: testSStriv [t2] (lam $ \b -> gamma b (prob_ 2)),
+    "t3"   ~: testSStriv [t3, t3'] (lam $ \a -> lam $ \x -> gamma a (prob_ 2)),
+    "t4"   ~: testSStriv [t4] (lam $ \a -> lam $ \b -> lam $ \_ -> beta a b),
+    -- "t5"   ~: testSStriv [t5, t5'] (lam $ \alpha -> gamma one (unsafeProb alpha)),
+    --"t6"   ~: testSS [t5] (lam $ \mu -> poisson mu >>= \x -> dirac (fromInt x)),
+    "t7"   ~: testSStriv [t7]
+        (normal_0_1 >>= \x1 ->
+        normal_0_1 >>= \x2 ->
+        dirac (x1 * recip x2)),
+
+    "t8"   ~: testSStriv [t8]
+        (lam $ \a ->
+        lam $ \alpha ->
+        (normal_0_1 >>= \x1 ->
+        normal_0_1 >>= \x2 ->
+        dirac (a + fromProb alpha * (x1 / x2)))),
+
+    "t9"   ~: testSStriv [t9]
+        (lam $ \p -> bern p >>= \x -> dirac (if_ x one zero)),
+    --Doesn't (if_ x one zero) simplify to just x?--Carl 2016Jul16
+     
+
+    "t10"  ~: testSStriv [t10] (unsafeProb <$> uniform_0_1),
+
+    "t11"  ~: testSStriv [t11]
+        (lam $ \a1 ->
+        lam $ \a2 ->
+        gamma one (unsafeProb a1) >>= \x1 ->
+        gamma one a2 >>= \x2 ->
+        dirac ((fromProb x1) - (fromProb x2))),
+
+    -- sum of n exponential(b) random variables is a gamma(n, b) random variable
+    "t12"   ~: testSStriv [t12] (lam $ \b -> gamma (prob_ 2) b),
+
+    --  Weibull(b, 1) random variable is an exponential random variable with mean b
+    --Above comment is wrong. Should be:
+    --X ~ Weibull(a,1)  =>  X ~ Exponential(1/a) 
+    --"t13"   ~: testSS [t13] (lam $ \b -> exponential (recip b)),
+    --Above line is wrong. Should be:
+    "t13"   ~: testSStriv [t13] (lam $ \a -> exponential(recip a)),
+    --Carl 2016Jul14
+
+    -- If X is a standard normal random variable and U is a chi-squared random variable with v degrees of freedom,
+    -- then X/sqrt(U/v) is a Student's t(v) random variable
+    "t14"   ~: testSStriv [t14] (lam $ \v -> studentT zero one v),
+
+    "t15"   ~: testSStriv [t15] (lam $ \k -> lam $ \t -> gamma k t),
+
+    -- Linear combination property
+    "t16"   ~: testSStriv [t16] (normal zero (sqrt (prob_ 2))),
+    "t17"   ~: testSStriv [t17]
+        (lam $ \mu ->
+        lam $ \sigma ->
+        normal mu (sqrt (one + sigma * sigma))),
+    "t18"   ~: testSStriv [t18]
+        (lam $ \a1 ->
+        lam $ \a2 ->
+        normal zero (sqrt (a1 * a1 + a2 * a2))),
+
+    -- Convolution property
+    "t19"   ~: testSStriv [t19]
+        (lam $ \n1 ->
+        lam $ \n2 ->
+        lam $ \p ->
+        binomial (n1 + n2) p),
+    "t20"   ~: testSStriv [t20]
+        (lam $ \n ->
+        lam $ \p ->
+        binomial n p),
+    "t21"   ~: testSStriv [t21]
+        (lam $ \l1 ->
+        lam $ \l2 ->
+        poisson (l1 + l2)),
+    "t22"   ~: testSStriv [t22]
+        (lam $ \a1 ->
+        lam $ \a2 ->
+        lam $ \b ->
+        gamma (a1 + a2) b),
+    "t23"   ~: testSStriv [t23] (lam $ \n -> lam $ \t -> gamma n t),
+
+--I can't find any evidence for the truth of relationship t24. Indeed,
+--it's trivial to prove false.--Carl 2016Jul16
+--    -- Scaling property
+--    "t24"   ~: testSS [t24]
+--        (lam $ \a ->
+--        lam $ \b ->
+--        lam $ \k ->
+--        weibull (a * (k ** fromProb b)) b),
+
+--The next test is wrong. The log x should be exp x (or whatever the
+--exponential function is in Haskell).
+    -- Product property
+    "t25"   ~: testSStriv [t25]
+        (lam $ \mu1 ->
+        lam $ \mu2 ->
+        lam $ \sigma1 ->
+        lam $ \sigma2 ->
+        normal (mu1 + mu2) (sigma1 + sigma2) >>= \x ->
+        dirac (log (unsafeProb x))),
+
+    -- Inverse property
+--I can't verify the relationship below. It's easy to prove false, except for
+--the case l=0, where it's true. Where did it come from? It's too complex to
+--have been entered by mistake.--Carl 2016Jul17 
+    "t26"   ~: testSStriv [t26]
+        (lam $ \l ->
+        lam $ \s ->
+        cauchy (l / (l*l + fromProb (s*s)))
+            (s / (unsafeProb (l*l) + s*s))),
+
+    -- Multiple of a random variable
+    "t27"   ~: testSStriv [t27]
+        (lam $ \r ->
+        lam $ \lambda ->
+        lam $ \a ->
+        gamma r (a * lambda))
+
+    -- If X is a beta (a, b) random variable then (1 - X) is a beta (b, a) random variable.
+    -- "t28"   ~: testSStriv [t28] (lam $ \a -> lam $ \b -> beta b a)
+
+    -- Cannot resolve type mismatch
+    -- If X is a binomial (n, p) random variable then (n - X) is a binomial (n, 1-p) random variable.
+    -- "t29"   ~: testSStriv [t29] (lam $ \n -> lam $ \p -> binomial n (one - p))
+    ]
+
+t1  :: (ABT Term abt) => abt '[] ('HReal ':-> 'HProb ':-> 'HMeasure 'HReal)
+t1 = lam (\mu -> (lam (\sigma ->
+    normal mu sigma >>= \x ->
+    dirac ((x - mu) / (fromProb sigma)))))
+
+t2  :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HProb)
+t2 = lam $ \b -> chi2 ((prob_ 2) * b)
+
+-- This test (and probably many others involving gamma) is wrong,
+-- because the argument order to our gamma is the opposite of
+-- the order used by 2008amstat.pdf
+t3  :: (ABT Term abt) => abt '[] ('HProb ':-> 'HProb ':-> 'HMeasure 'HProb)
+t3 =
+    lam $ \alpha ->
+    lam $ \bet ->
+    gamma alpha bet >>= \x ->
+    dirac ((prob_ 2) * x / bet)
+
+t3' :: (ABT Term abt) => abt '[] ('HProb ':-> 'HProb ':-> 'HMeasure 'HProb)
+t3' = lam $ \_ -> lam $ \bet -> chi2 ((prob_ 2) * bet)
+
+t4  :: (ABT Term abt)
+    => abt '[] ('HProb ':-> 'HProb ':-> 'HProb ':-> 'HMeasure 'HProb)
+t4 =
+    lam $ \a ->
+    lam $ \b ->
+    lam $ \t -> 
+    gamma a t >>= \x1 ->
+    gamma b t >>= \x2 ->
+    dirac (x1 / (x1+x2))
+
+-- t5 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HProb)
+-- t5 =
+    -- lam $ \alpha ->
+    -- uniform_0_1 >>= \x ->
+    -- dirac (unsafeProb (-1 * alpha) * unsafeProb (log (unsafeProb x)))
+
+-- t5' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HProb)
+-- t5' =
+    -- lam $ \alpha ->
+    -- laplace alpha (unsafeProb alpha) >>= \x ->
+    -- dirac (abs (unsafeProb x))
+
+-- Untestable right now with mu -> infinity, maybe later?
+--t6 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HReal)
+--t6 = lam (\mu -> normal infinity mu)
+
+t7 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
+t7 = cauchy zero one
+
+t8 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HProb ':-> 'HMeasure 'HReal)
+t8 = lam $ \a -> lam $ \alpha -> cauchy a alpha
+
+t9 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HInt)
+t9 = lam $ \p -> binomial one p
+
+t10 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
+t10 = beta one one
+
+t11 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HProb ':-> 'HMeasure 'HReal)
+t11 = lam $ \a1 -> lam $ \a2 -> laplace a1 a2
+
+t12 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HProb)
+t12 =
+    lam $ \b ->
+    exponential b >>= \x1 ->
+    exponential b >>= \x2 ->
+    dirac (x1 + x2)
+
+t13 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HProb)
+--t13 = lam $ \b -> weibull one b
+--Parameter order wrong in line above.--Carl 2016Jul14
+t13 = lam $ \a -> weibull a one
+
+t14 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HReal)
+t14 =
+    lam $ \v ->
+    normal_0_1 >>= \x ->
+    chi2 v >>= \u ->
+    dirac (x / fromProb (sqrt (u / v)))
+
+t15 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HProb ':-> 'HMeasure 'HProb)
+t15 =
+    lam $ \k ->
+    lam $ \t ->
+    invgamma k (recip t) >>= \x ->
+    dirac (recip x)
+
+t16 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
+t16 =
+    normal_0_1 >>= \x1 ->
+    normal_0_1 >>= \x2 ->
+    dirac (x1 + x2)
+
+t17 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HProb ':-> 'HMeasure 'HReal)
+t17 =
+    lam $ \mu ->
+    lam $ \sigma ->
+    normal_0_1 >>= \x1 ->
+    normal mu sigma >>= \x2 ->
+    dirac (x1 + x2)
+
+--I corrected the below. The relationship is about two rvs, not one. 
+t18 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HProb ':-> 'HMeasure 'HReal)
+t18 =
+    lam $ \a1 ->
+    lam $ \a2 ->
+    normal_0_1 >>= \x ->
+    normal_0_1 >>= \y ->
+    --dirac (fromProb a1 * x + fromProb a2 * x)
+    dirac (fromProb a1 * x + fromProb a2 * y)
+--Actually, this relation is also true if a1 < 0 and/or a2 < 0. 
+
+t19 :: (ABT Term abt)
+    => abt '[] ('HNat ':-> 'HNat ':-> 'HProb ':-> 'HMeasure 'HInt)
+t19 =
+    lam $ \n1 ->
+    lam $ \n2 ->
+    lam $ \p ->
+    binomial n1 p >>= \x1 ->
+    binomial n2 p >>= \x2 ->
+    dirac (x1 + x2)
+
+--The next test is completely wrong. It's supposed to express something about
+--the sum of n iid Bernoulli rvs. That's not the same thing as n times a single
+--rv. Also, if_ x one zero simplifies to simply x.
+t20 :: (ABT Term abt) => abt '[] ('HNat ':-> 'HProb ':-> 'HMeasure 'HInt)
+t20 =
+    lam $ \n ->
+    lam $ \p ->
+    bern p >>= \x ->
+    dirac (nat2int (n * if_ x one zero))
+
+t21 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HProb ':-> 'HMeasure 'HNat)
+t21 =
+    lam $ \l1 ->
+    lam $ \l2 ->
+    poisson l1 >>= \x1 ->
+    poisson l2 >>= \x2 ->
+    dirac (x1 + x2)
+
+t22 :: (ABT Term abt)
+    => abt '[] ('HProb ':-> 'HProb ':-> 'HProb ':-> 'HMeasure 'HProb)
+t22 =
+    lam $ \a1 ->
+    lam $ \a2 ->
+    lam $ \b ->
+    gamma a1 b >>= \x1 ->
+    gamma a2 b >>= \x2 ->
+    dirac (x1 + x2)
+
+--The next test is completely wrong. It's supposed to express something about
+--the sum of n iid Exponential rvs. That's not the same thing as n times a single
+--rv. 
+t23 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HProb ':-> 'HMeasure 'HProb)
+t23 =
+    lam $ \n ->
+    lam $ \t ->
+    exponential t >>= \x ->
+    dirac (n * x)
+
+--I can find no evidence for the truth of relationship t24. Indeed, it's
+--trivial to prove false,
+--t24 :: (ABT Term abt)
+--    => abt '[] ('HProb ':-> 'HProb ':-> 'HProb ':-> 'HMeasure 'HProb)
+--t24 =
+--  lam $ \a ->
+--  lam $ \b ->
+--  lam $ \k ->
+--  weibull a b >>= \x ->
+--  dirac (k * x)
+
+--The next test is wrong. The logs should be exps.
+t25 :: (ABT Term abt) => abt '[]
+    ('HReal ':-> 'HReal ':-> 'HProb ':-> 'HProb ':-> 'HMeasure 'HReal)
+t25 =
+    lam $ \mu1 ->
+    lam $ \mu2 ->
+    lam $ \sigma1 ->
+    lam $ \sigma2 ->
+    normal mu1 sigma1 >>= \x1 ->
+    normal mu2 sigma2 >>= \x2 ->
+    dirac (log (unsafeProb x1) * log (unsafeProb x2))
+
+t26 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HProb ':-> 'HMeasure 'HReal)
+t26 =
+    lam $ \l ->
+    lam $ \s ->
+    cauchy l s >>= \x ->
+    dirac (recip x)
+
+t27 :: (ABT Term abt)
+    => abt '[] ('HProb ':-> 'HProb ':-> 'HProb ':-> 'HMeasure 'HProb)
+t27 =
+    lam $ \r ->
+    lam $ \lambda ->
+    lam $ \a ->
+    gamma r lambda >>= \x ->
+    dirac (a * x)
+
+-- t28 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HProb ':-> 'HMeasure 'HProb)
+-- t28 =
+    -- lam $ \a ->
+    -- lam $ \b ->
+    -- beta a b >>= \x ->
+    -- dirac ((prob_ 1) - x)
+
+-- Cannot resolve type mismatch
+-- t29 :: (ABT Term abt) => abt '[] ('HNat ':-> 'HProb ':-> 'HMeasure 'HInt)
+-- t29 =
+    -- lam $ \n ->
+    -- lam $ \p ->
+    -- binomial n p >>= \x ->
+    -- dirac (n - x)
diff --git a/haskell/Tests/RoundTrip.hs b/haskell/Tests/RoundTrip.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/RoundTrip.hs
@@ -0,0 +1,731 @@
+{-# LANGUAGE NoImplicitPrelude
+           , DataKinds
+           , TypeOperators
+           , TypeFamilies
+           , ScopedTypeVariables
+           , FlexibleContexts
+           , MultiParamTypeClasses
+           , FunctionalDependencies
+           , TypeSynonymInstances
+           , GADTs
+           , FlexibleInstances 
+           , FlexibleContexts 
+           , ConstraintKinds
+           #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Tests.RoundTrip where
+
+import           Prelude ((.), ($), asTypeOf, String, FilePath, Show(..), (++), Bool(..), concat)
+import qualified Prelude 
+import qualified Data.List.NonEmpty as L
+import           Data.Ratio
+import qualified Data.Text.Utf8 as IO 
+
+import Language.Hakaru.Syntax.Prelude
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Pretty.Concrete (pretty)
+import Language.Hakaru.Syntax.AST (Term, PrimOp(..))
+import Language.Hakaru.Syntax.AST.Transforms
+import Language.Hakaru.Syntax.ABT (ABT, TrivialABT(..))
+import Language.Hakaru.Expect     (total)
+import Language.Hakaru.Inference  (priorAsProposal, mcmc, mh)
+import Language.Hakaru.Types.Sing
+import System.IO 
+import System.Directory 
+import Control.Monad (mapM_, Monad(return))
+import Data.Foldable (null)
+import Data.List (intercalate) 
+
+import qualified Data.Text as Text 
+import Test.HUnit
+import Tests.TestTools
+import Tests.Models
+    (uniform_0_1, normal_0_1, gamma_1_1,
+     uniformC, normalC, beta_1_1, norm, unif2)
+-- import Tests.Models (t4, t4')
+unsafeSuperpose
+    :: (ABT Term abt)
+    => [(abt '[] 'HProb, abt '[] ('HMeasure a))]
+    -> abt '[] ('HMeasure a)
+unsafeSuperpose = superpose . L.fromList
+
+testMeasureUnit :: Test
+testMeasureUnit = test [
+    "t1"      ~: testConcreteFiles "tests/RoundTrip/t1,t5.0.hk" "tests/RoundTrip/t1,t5.expected.hk", -- In Maple, should 'evaluate' to "\c -> 1/2*c(Unit)"
+    "t5"      ~: testConcreteFiles "tests/RoundTrip/t1,t5.1.hk" "tests/RoundTrip/t1,t5.expected.hk", -- t5 is "the same" as t1.
+    "t10"     ~: testConcreteFiles "tests/RoundTrip/t10.0.hk" "tests/RoundTrip/t10.expected.hk",
+    "t11"     ~: testConcreteFiles "tests/RoundTrip/t11,t22.0.hk" "tests/RoundTrip/t11,t22.expected.hk",  
+    "t12"     ~: testConcreteFilesMany [] "tests/RoundTrip/t12.hk",
+    "t20"     ~: testConcreteFiles "tests/RoundTrip/t20.0.hk" "tests/RoundTrip/t20.expected.hk",
+    "t22"     ~: testConcreteFiles "tests/RoundTrip/t11,t22.1.hk" "tests/RoundTrip/t11,t22.expected.hk",
+    "t24"     ~: testConcreteFiles "tests/RoundTrip/t24.0.hk" "tests/RoundTrip/t24.expected.hk",
+    "t25"     ~: testConcreteFiles "tests/RoundTrip/t25.0.hk" "tests/RoundTrip/t25.expected.hk",
+    "t44Add"  ~: testConcreteFiles "tests/RoundTrip/t44Add.0.hk" "tests/RoundTrip/t44Add.expected.hk",
+    "t44Mul"  ~: testConcreteFiles "tests/RoundTrip/t44Mul.0.hk" "tests/RoundTrip/t44Mul.expected.hk",
+    "t53"     ~: testConcreteFiles "tests/RoundTrip/t53.0.hk" "tests/RoundTrip/t53.expected.hk",
+    "t53'"    ~: testConcreteFiles "tests/RoundTrip/t53.1.hk" "tests/RoundTrip/t53.expected.hk",
+    "t54"     ~: testConcreteFile "tests/RoundTrip/t54.hk",
+    "t55"     ~: testConcreteFiles "tests/RoundTrip/t55.0.hk" "tests/RoundTrip/t55.expected.hk",
+    "t56"     ~: testConcreteFiles "tests/RoundTrip/t56.0.hk" "tests/RoundTrip/t56.expected.hk",
+    "t56'"    ~: testConcreteFiles "tests/RoundTrip/t56.1.hk" "tests/RoundTrip/t56.expected.hk",
+    "t57"     ~: testConcreteFiles "tests/RoundTrip/t57.0.hk" "tests/RoundTrip/t57.expected.hk",
+    "t58"     ~: testConcreteFiles "tests/RoundTrip/t58.0.hk" "tests/RoundTrip/t58.expected.hk",
+    "t59"     ~: testConcreteFile "tests/RoundTrip/t59.hk",
+    "t60"     ~: testConcreteFilesMany [ "tests/RoundTrip/t60.0.hk"
+                                       , "tests/RoundTrip/t60.1.hk" ]
+                                       "tests/RoundTrip/t60.expected.hk",
+    "t62"     ~: testConcreteFiles "tests/RoundTrip/t62.0.hk" "tests/RoundTrip/t62.expected.hk", ---- "Special case" of t56
+        "t63"     ~: testConcreteFiles "tests/RoundTrip/t63.0.hk" "tests/RoundTrip/t63.expected.hk", ---- "Scalar multiple" of t62
+    "t64"     ~: testConcreteFiles "tests/RoundTrip/t64.0.hk" "tests/RoundTrip/t64.expected.hk", -- Density calculation for (Exp (Log StdRandom)) and StdRandom
+    "t64'"    ~: testConcreteFiles "tests/RoundTrip/t64.1.hk" "tests/RoundTrip/t64.expected.hk", -- Density calculation for (Exp (Log StdRandom)) and StdRandom
+    "t65"     ~: testConcreteFiles "tests/RoundTrip/t65.0.hk" "tests/RoundTrip/t65.expected.hk", -- Density calculation for (Add StdRandom (Exp (Neg StdRandom))); Maple can integrate this but we don't simplify it for some reason.
+    "t77"     ~: testConcreteFilesMany [] "tests/RoundTrip/t77.hk" -- the (x * (-1)) below is an unfortunate artifact not worth fixing
+    ]
+
+testMeasureProb :: Test
+testMeasureProb = test [
+    "t2"    ~: testConcreteFiles "tests/RoundTrip/t2.0.hk" "tests/RoundTrip/t2.expected.hk",
+    "t26"   ~: testConcreteFiles "tests/RoundTrip/t26.0.hk" "tests/RoundTrip/t26.expected.hk",
+    "t30"   ~: testConcreteFilesMany [] "tests/RoundTrip/t30.hk",
+    "t33"   ~: testConcreteFilesMany [] "tests/RoundTrip/t33.hk",
+    "t34"   ~: testConcreteFiles "tests/RoundTrip/t34.0.hk" "tests/RoundTrip/t34.expected.hk",
+    "t35"   ~: testConcreteFilesMany [] "tests/RoundTrip/t35.0.hk",
+    "t35'"  ~: testConcreteFilesMany [] "tests/RoundTrip/t35.expected.hk",
+    "t38"   ~: testConcreteFilesMany [] "tests/RoundTrip/t38.hk",
+    "t42"   ~: testConcreteFiles "tests/RoundTrip/t42.0.hk" "tests/RoundTrip/t42.expected.hk",
+    "t49"   ~: testConcreteFilesMany [] "tests/RoundTrip/t49.hk",
+        "t61"   ~: testConcreteFiles "tests/RoundTrip/t61.0.hk" "tests/RoundTrip/t61.expected.hk",
+    "t66"   ~: testConcreteFilesMany [] "tests/RoundTrip/t66.hk",
+    "t67"   ~: testConcreteFilesMany [] "tests/RoundTrip/t67.hk",
+    "t69x"  ~: testConcreteFiles "tests/RoundTrip/t69x.0.hk" "tests/RoundTrip/t69x.expected.hk",
+    "t69y"  ~: testConcreteFiles "tests/RoundTrip/t69y.0.hk" "tests/RoundTrip/t69y.expected.hk"
+    ]
+
+-- t45, t46, t47 are all equivalent.
+-- But t47 is worse than t45 and t46 because the importance weight generated by
+-- t47 as a sampler varies between 0 and 1 whereas the importance weight generated
+-- by t45 and t46 is always 1.  In general it's good to reduce weight variance.
+testMeasureReal :: Test
+testMeasureReal = test [ 
+        "t3"                ~: testConcreteFilesMany [] "tests/RoundTrip/t3.hk",
+    "t6"                ~: testConcreteFiles "tests/RoundTrip/t6.0.hk" "tests/RoundTrip/t6.expected.hk",
+    "t7"                ~: testConcreteFiles "tests/RoundTrip/t7.0.hk" "tests/RoundTrip/t7.expected.hk",
+    "t7n"               ~: testConcreteFiles "tests/RoundTrip/t7n.0.hk" "tests/RoundTrip/t7n.expected.hk",
+    "t8'"               ~: testConcreteFiles "tests/RoundTrip/t8'.0.hk" "tests/RoundTrip/t8'.expected.hk", -- Normal is conjugate to normal
+    "t9"                ~: testConcreteFiles "tests/RoundTrip/t9.0.hk" "tests/RoundTrip/t9.expected.hk",
+    "t13"               ~: testConcreteFiles "tests/RoundTrip/t13.0.hk" "tests/RoundTrip/t13.expected.hk",
+    "t14"               ~: testConcreteFiles "tests/RoundTrip/t14.0.hk" "tests/RoundTrip/t14.expected.hk",
+    "t21"               ~: testConcreteFile "tests/RoundTrip/t21.hk",
+    "t28"               ~: testConcreteFilesMany [] "tests/RoundTrip/t28.hk",
+    "t31"               ~: testConcreteFilesMany [] "tests/RoundTrip/t31.hk",
+    "t36"               ~: testConcreteFilesMany [] "tests/RoundTrip/t36.hk",
+    "t37"               ~: testConcreteFilesMany [] "tests/RoundTrip/t37.hk",
+    "t39"               ~: testConcreteFilesMany [] "tests/RoundTrip/t39.hk",
+    "t40"               ~: testConcreteFilesMany [] "tests/RoundTrip/t40.hk",
+    "t43"               ~: testConcreteFiles "tests/RoundTrip/t43.0.hk" "tests/RoundTrip/t43.expected.hk",
+    "t43'"              ~: testConcreteFiles "tests/RoundTrip/t43.1.hk" "tests/RoundTrip/t43.expected.hk",
+    "t45"               ~: testConcreteFiles "tests/RoundTrip/t45.1.hk" "tests/RoundTrip/t45.expected.hk",
+    "t46"               ~: testConcreteFilesMany [] "tests/RoundTrip/t45.0.hk",
+    "t50"               ~: testConcreteFile "tests/RoundTrip/t50.hk",
+    "t51"               ~: testConcreteFile "tests/RoundTrip/t51.hk",
+    "t68"               ~: testConcreteFile "tests/RoundTrip/t68.hk",
+    "t68'"              ~: testConcreteFile "tests/RoundTrip/t68'.hk",
+    "t70a"              ~: testConcreteFiles "tests/RoundTrip/t70a.0.hk" "tests/RoundTrip/t70a.expected.hk",
+    "t71a"              ~: testConcreteFiles "tests/RoundTrip/t71a.0.hk" "tests/RoundTrip/t71a.expected.hk",
+    "t72a"              ~: testConcreteFiles "tests/RoundTrip/t72a.0.hk" "tests/RoundTrip/t72a.expected.hk",
+    "t73a"              ~: testConcreteFiles "tests/RoundTrip/t73a.0.hk" "tests/RoundTrip/t73a.expected.hk",
+    "t74a"              ~: testConcreteFiles "tests/RoundTrip/t74a.0.hk" "tests/RoundTrip/t74a.expected.hk",
+    "t70b"              ~: testConcreteFiles "tests/RoundTrip/t70b.0.hk" "tests/RoundTrip/t70b.expected.hk",
+    "t71b"              ~: testConcreteFiles "tests/RoundTrip/t71b.0.hk" "tests/RoundTrip/t71b.expected.hk",
+    "t72b"              ~: testConcreteFiles "tests/RoundTrip/t72b.0.hk" "tests/RoundTrip/t72b.expected.hk",
+    "t73b"              ~: testConcreteFiles "tests/RoundTrip/t73b.0.hk" "tests/RoundTrip/t73b.expected.hk",
+    "t74b"              ~: testConcreteFiles "tests/RoundTrip/t74b.0.hk" "tests/RoundTrip/t74b.expected.hk",
+    "t70c"              ~: testConcreteFiles "tests/RoundTrip/t70c.0.hk" "tests/RoundTrip/t70c.expected.hk",
+    "t71c"              ~: testConcreteFiles "tests/RoundTrip/t71c.0.hk" "tests/RoundTrip/t71c.expected.hk",
+    "t72c"              ~: testConcreteFiles "tests/RoundTrip/t72c.0.hk" "tests/RoundTrip/t72c.expected.hk",
+    "t73c"              ~: testConcreteFiles "tests/RoundTrip/t73c.0.hk" "tests/RoundTrip/t73c.expected.hk",
+    "t74c"              ~: testConcreteFiles "tests/RoundTrip/t74c.0.hk" "tests/RoundTrip/t74c.expected.hk",
+    "t70d"              ~: testConcreteFiles "tests/RoundTrip/t70d.0.hk" "tests/RoundTrip/t70d.expected.hk",
+    "t71d"              ~: testConcreteFiles "tests/RoundTrip/t71d.0.hk" "tests/RoundTrip/t71d.expected.hk",
+    "t72d"              ~: testConcreteFiles "tests/RoundTrip/t72d.0.hk" "tests/RoundTrip/t72d.expected.hk",
+    "t73d"              ~: testConcreteFiles "tests/RoundTrip/t73d.0.hk" "tests/RoundTrip/t73d.expected.hk",
+    "t74d"              ~: testConcreteFiles "tests/RoundTrip/t74d.0.hk" "tests/RoundTrip/t74d.expected.hk",
+    "t76"               ~: testConcreteFile "tests/RoundTrip/t76.hk",
+    "t78"               ~: testConcreteFiles "tests/RoundTrip/t78.0.hk" "tests/RoundTrip/t78.expected.hk",
+    "t79"               ~: testConcreteFiles "tests/RoundTrip/t79.0.hk" "tests/RoundTrip/t79.expected.hk", -- what does this simplify to?
+    "t80"               ~: testConcreteFile "tests/RoundTrip/t80.hk",
+    "t81"               ~: testConcreteFilesMany [] "tests/RoundTrip/t81.hk",
+    -- TODO "kalman"    ~: testConcreteFile "tests/RoundTrip/kalman.hk",
+    -- TODO "seismic"         ~: testConcreteFilesMany [] "tests/RoundTrip/seismic.hk",
+    "lebesgue1"         ~: testConcreteFiles
+                              "tests/RoundTrip/lebesgue1.hk"
+                              "tests/RoundTrip/lebesgue1.expected.hk",
+    "lebesgue2"         ~: testConcreteFiles
+                              "tests/RoundTrip/lebesgue2.hk"
+                              "tests/RoundTrip/lebesgue2.expected.hk",
+    "lebesgue3"         ~: testConcreteFiles "tests/RoundTrip/lebesgue3.0.hk" "tests/RoundTrip/lebesgue3.expected.hk",
+    "testexponential"   ~: testConcreteFile "tests/RoundTrip/testexponential.hk", -- Testing round-tripping of some other distributions
+    "testcauchy"        ~: testConcreteFile "tests/RoundTrip/testcauchy.hk",
+    "exceptionLebesgue" ~: testConcreteFiles "tests/RoundTrip/exceptionLebesgue.0.hk" "tests/RoundTrip/exceptionLebesgue.expected.hk",
+    "exceptionUniform"  ~: testConcreteFiles "tests/RoundTrip/exceptionUniform.0.hk" "tests/RoundTrip/exceptionUniform.expected.hk"
+        -- TODO "two_coins" ~: testConcreteFile "tests/RoundTrip/two_coins.hk" -- needs support for lists
+    ]
+
+testMeasureNat :: Test 
+testMeasureNat = test [ 
+    "size" ~: testConcreteFiles "tests/RoundTrip/size.0.hk" "tests/RoundTrip/size.expected.hk"
+    ]
+
+testMeasureInt :: Test
+testMeasureInt = test [ 
+    "t75"                ~: testConcreteFile "tests/RoundTrip/t75.hk",
+    "t75'"               ~: testConcreteFile "tests/RoundTrip/t75'.hk",
+    "t83"                ~: testConcreteFiles "tests/RoundTrip/t83.0.hk" "tests/RoundTrip/t83.expected.hk",
+    "exceptionCounting"  ~: testConcreteFilesMany [] "tests/RoundTrip/exceptionCounting.hk", -- Jacques wrote: "bug: [simp_pw_equal] implicitly assumes the ambient measure is Lebesgue"
+    "exceptionSuperpose" ~: testConcreteFiles "tests/RoundTrip/exceptionSuperpose.0.hk" "tests/RoundTrip/exceptionSuperpose.expected.hk"
+        ]
+
+testMeasurePair :: Test 
+testMeasurePair = test [
+    "t4"                ~: testConcreteFiles "tests/RoundTrip/t4.0.hk" "tests/RoundTrip/t4.expected.hk",
+    "t8"                ~: testConcreteFile "tests/RoundTrip/t8.hk", -- For sampling efficiency (to keep importance weights at or close to 1); t8 below should read back to uses of "normal", not uses of "lebesgue" then "weight".
+    "t23"               ~: testConcreteFiles "tests/RoundTrip/t23.0.hk" "tests/RoundTrip/t23.expected.hk", -- was called bayesNet in Nov.06 msg by Ken for exact inference
+    "t48"               ~: testConcreteFile "tests/RoundTrip/t48.hk",
+    "t52"               ~: testConcreteFile "tests/RoundTrip/t52.hk", -- Example 1 from Chang & Pollard's Conditioning as Disintegration
+    "dup"               ~: testConcreteFiles "tests/RoundTrip/dup.0.hk" "tests/RoundTrip/dup.expected.hk",
+    "norm"              ~: testConcreteFile "tests/RoundTrip/norm.hk",
+    "norm_nox"          ~: testConcreteFiles "tests/RoundTrip/norm_nox.0.hk" "tests/RoundTrip/norm_nox.expected.hk",
+    "norm_noy"          ~: testConcreteFiles "tests/RoundTrip/norm_noy.0.hk" "tests/RoundTrip/norm_noy.expected.hk",
+    "flipped_norm"      ~: testConcreteFiles "tests/RoundTrip/flipped_norm.0.hk" "tests/RoundTrip/flipped_norm.expected.hk",
+    "priorProp"         ~: testConcreteFiles "tests/RoundTrip/priorProp.0.hk" "tests/RoundTrip/priorProp.expected.hk",
+        "mhPriorProp"       ~: testConcreteFiles "tests/RoundTrip/mhPriorProp.0.hk" "tests/RoundTrip/mhPriorProp.expected.hk",
+    "unif2"             ~: testConcreteFile "tests/RoundTrip/unif2.hk",
+    "easyHMM"           ~: testConcreteFile "tests/RoundTrip/easyHMM.hk",
+    "testMCMCPriorProp" ~: testConcreteFile "tests/RoundTrip/testMCMCPriorProp.hk"
+    ]
+    
+testStdChiSqRelations :: Test
+testStdChiSqRelations = test [
+    "t_stdChiSq_superposition" ~: testConcreteFiles "tests/RoundTrip2/t_stdChiSq_superposition.0.hk" "tests/RoundTrip2/t_stdChiSq_superposition.expected.hk",
+    "t_uniform_to_stdChiSq" ~: testConcreteFiles "tests/RoundTrip2/t_uniform_to_stdChiSq.0.hk" "tests/RoundTrip2/t_uniform_to_stdChiSq.expected.hk",
+    "t_stdChiSq_to_beta" ~: testConcreteFiles "tests/RoundTrip2/t_stdChiSq_to_beta.0.hk" "tests/RoundTrip2/t_stdChiSq_to_beta.expected.hk",
+    "t_stdChiSq_to_gamma"   ~: testConcreteFiles "tests/RoundTrip/t_stdChiSq_to_gamma.0.hk" "tests/RoundTrip/t_stdChiSq_to_gamma.expected.hk",
+    "t_stdChiSq_to_exponential" ~: testConcreteFiles "tests/RoundTrip2/t_stdChiSq_to_exponential.0.hk" "tests/RoundTrip2/t_stdChiSq_to_exponential.expected.hk",
+    "t_rayleigh_to_stdChiSq"     ~: testConcreteFiles "tests/RoundTrip2/t_rayleigh_to_stdChiSq.0.hk" "tests/RoundTrip2/t_rayleigh_to_stdChiSq.expected.hk"        
+    ]
+
+
+testCauchyRelations :: Test 
+testCauchyRelations = test [
+    "t_cauchy_add_transformation" ~: testConcreteFiles "tests/RoundTrip2/t_cauchy_add_transformation.0.hk" "tests/RoundTrip2/t_cauchy_add_transformation.expected.hk",
+    "t_cauchy_sub_transformation" ~: testConcreteFiles "tests/RoundTrip2/t_cauchy_sub_transformation.0.hk" "tests/RoundTrip2/t_cauchy_sub_transformation.expected.hk"
+    ]
+
+testExponentialRelations :: Test 
+testExponentialRelations = test [
+    "t_pareto_to_exponential"        ~: testConcreteFiles "tests/RoundTrip/t_pareto_to_exponential.0.hk" "tests/RoundTrip/t_pareto_to_exponential.expected.hk",
+    "t_exponential_to_pareto"        ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_pareto.0.hk" "tests/RoundTrip/t_exponential_to_pareto.expected.hk",
+    "t_exponential_to_laplace"        ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_laplace.0.hk" "tests/RoundTrip/t_exponential_to_laplace.expected.hk",
+    "t_exponential_to_beta"        ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_beta.0.hk" "tests/RoundTrip/t_exponential_to_beta.expected.hk",
+
+    "t_exponential_sum_to_erlang"        ~: testConcreteFiles "tests/RoundTrip/t_exponential_sum_to_erlang.0.hk" "tests/RoundTrip/t_exponential_sum_to_erlang.expected.hk",
+
+    "t_exp_erlang_to_pareto"        ~: testConcreteFiles "tests/RoundTrip/t_exp_erlang_to_pareto.0.hk" "tests/RoundTrip/t_exp_erlang_to_pareto.expected.hk",
+    "t_exponential_sum_rates"        ~: testConcreteFiles "tests/RoundTrip/t_exponential_sum_rates.0.hk" "tests/RoundTrip/t_exponential_sum_rates.expected.hk",
+    "t_exponential_to_stdChiSq"     ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_stdChiSq.0.hk" "tests/RoundTrip/t_exponential_to_stdChiSq.expected.hk",
+    "t_exponential_scale_closure"   ~: testConcreteFiles "tests/RoundTrip/t_exponential_scale_closure.0.hk" "tests/RoundTrip/t_exponential_scale_closure.expected.hk"
+    ]
+
+testErlangRelations :: Test
+testErlangRelations = test [
+    "t_erlang_to_erlang"   ~: testConcreteFiles "tests/RoundTrip/t_erlang_to_erlang.0.hk" "tests/RoundTrip/t_erlang_to_erlang.expected.hk",
+    "t_erlang_to_erlang_2"   ~: testConcreteFiles "tests/RoundTrip/t_erlang_to_erlang_1.0.hk" "tests/RoundTrip/t_erlang_to_erlang_1.expected.hk",
+    "t_exponential_to_erlang"   ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_erlang.0.hk" "tests/RoundTrip/t_exponential_to_erlang.expected.hk",
+    "t_erlang_to_pareto"   ~: testConcreteFiles "tests/RoundTrip2/t_erlang_to_pareto.0.hk" "tests/RoundTrip2/t_erlang_to_pareto.expected.hk",
+    "t_erlang_to_stdChiSq"   ~: testConcreteFiles "tests/RoundTrip2/t_erlang_to_stdChiSq.0.hk" "tests/RoundTrip2/t_erlang_to_stdChiSq.expected.hk"
+    ]
+
+testRayleighRelations :: Test 
+testRayleighRelations = test [
+    "t_exponential_to_rayleigh" ~: testConcreteFiles "tests/RoundTrip2/t_exponential_to_rayleigh.0.hk" "tests/RoundTrip2/t_exponential_to_rayleigh.expected.hk",
+    "t_gamma_to_rayleigh" ~: testConcreteFiles "tests/RoundTrip2/t_gamma_to_rayleigh.0.hk" "tests/RoundTrip2/t_gamma_to_rayleigh.expected.hk",
+    "t_weibull_to_rayleigh" ~: testConcreteFiles "tests/RoundTrip2/t_weibull_to_rayleigh.0.hk" "tests/RoundTrip2/t_weibull_to_rayleigh.expected.hk"
+    ]
+
+testOther :: Test
+testOther = test [
+    "t82"              ~: testConcreteFiles "tests/RoundTrip/t82.0.hk" "tests/RoundTrip/t82.expected.hk",
+    "testRoadmapProg1" ~: testConcreteFile "tests/RoundTrip/testRoadmapProg1.hk",
+    "testKernel"       ~: testConcreteFiles "tests/RoundTrip/testKernel.0.hk" "tests/RoundTrip/testKernel.expected.hk",
+    "LDA"              ~: testConcreteFilesET defaultMapleOptions
+                          [ "tests/RoundTrip/lda2.hk" ]
+                          "tests/RoundTrip/lda2_res.hk",
+    "LDA - hand simplified" ~: testConcreteFilesET defaultMapleOptions
+                               [ "tests/RoundTrip/lda3-ds.0.hk"
+                               , "tests/RoundTrip/lda3-ds.1.hk" ]
+                               "tests/RoundTrip/lda3-ds.expected.hk",
+    "gmm_gibbs"        ~: testConcreteFilesET
+                           defaultMapleOptions { timelimit=300 }
+                           [ "tests/RoundTrip/gmm_gibbs.0.hk" ]
+                           "tests/RoundTrip/gmm_gibbs.expected.hk",
+    "naive_bayes_gibbs" ~: testConcreteFilesET defaultMapleOptions
+                            [ "tests/RoundTrip/naive_bayes_gibbs.0.hk" ]
+                            "tests/RoundTrip/naive_bayes_gibbs.expected.hk",
+    "\"thermometer\" pipeline" ~:
+                           testConcreteFilesET defaultMapleOptions
+                           [ "tests/RoundTrip/thermometer_workflow.hk" ]
+                           "tests/RoundTrip/thermometer_workflow_res.hk",
+    "\"burglary\" pipeline" ~:
+                           testConcreteFilesET defaultMapleOptions
+                           [ "tests/RoundTrip/burglary_workflow.hk" ]
+                           "tests/RoundTrip/burglary_workflow_res.hk"
+    --"testFalseDetection" ~: testStriv (lam seismicFalseDetection),
+    --"testTrueDetection" ~: testStriv (lam2 seismicTrueDetection)
+    --"testTrueDetectionL" ~: testStriv tdl,
+    --"testTrueDetectionR" ~: testStriv tdr
+    ]
+
+allTests :: Test 
+allTests = test
+    [ testMeasureUnit
+    , testMeasureProb
+    , testMeasureReal
+    , testMeasurePair
+    , testMeasureNat
+    , testMeasureInt
+    , testErlangRelations
+    , testStdChiSqRelations
+    , testCauchyRelations
+    , testExponentialRelations
+    , testRayleighRelations
+    , testCauchyRelations
+    , testOther
+    ]
+
+----------------------------------------------------------------
+
+t46 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
+t46 = normal (real_ 4) (prob_ 5) >>= \x -> dirac (if_ (x < (real_ 3)) (x*x) (x-one))
+
+t47 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
+t47 = unsafeSuperpose
+    [ (one, normal (real_ 4) (prob_ 5) >>= \x -> if_ (x < (real_ 3)) (dirac (x*x)) (reject sing))
+    , (one, normal (real_ 4) (prob_ 5) >>= \x -> if_ (x < (real_ 3)) (reject sing) (dirac (x-one)))
+    ]
+
+-- pull out some of the intermediate expressions for independent study
+expr1 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HProb)
+expr1 =
+    lam $ \x0 ->
+        (lam $ \_ ->
+        lam $ \x2 ->
+        lam $ \x3 ->
+          (lam $ \x4 ->
+            zero
+            + one
+              * (lam $ \x5 ->
+                 (lam $ \x6 ->
+                  zero
+                  + exp (negate (x2 - zero) * (x2 - zero) / fromProb ((fromRational 2) * exp (log (fromRational 5) * (fromRational 2))))
+                    / (fromRational 5)
+                    / exp (log ((fromRational 2) * pi) * half)
+                    * (lam $ \x7 -> x7 `app` unit) `app` x6)
+                 `app` (lam $ \_ ->
+                        (lam $ \x7 ->
+                         (lam $ \x8 -> x8 `app` x2)
+                         `app` (lam $ \_ ->
+                                (lam $ \x9 ->
+                                 (lam $ \x10 -> x10 `app` unit)
+                                 `app` (lam $ \x10 ->
+                                        (lam $ \x11 ->
+                                         (lam $ \x12 -> x12 `app` x2)
+                                         `app` (lam $ \_ ->
+                                                (lam $ \x13 -> x13 `app` pair x2 x10) `app` x11))
+                                        `app` x9))
+                                `app` x7))
+                        `app` x5))
+                `app` x4)
+           `app` (lam $ \x4 ->
+                  (lam $ \x5 -> x5 `app` (x4 `unpair` \_ x7 -> x7)) `app` x3)
+        )
+        `app` unit
+        `app` x0
+        `app` (lam $ \_ -> one)
+
+expr2 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HReal ':-> 'HProb)
+expr2 =
+    lam $ \x1 ->
+    lam $ \x2 ->
+        (lam $ \x3 ->
+        lam $ \x4 ->
+        lam $ \x5 ->
+           (lam $ \x6 ->
+            zero
+            + one
+              * (lam $ \x7 ->
+                 (lam $ \x8 ->
+                  zero
+                  + exp (((negate x4) - x3) * (x4 - x3) / fromProb ((fromRational 2) * exp (log one * (fromRational 2))))
+                    / one
+                    / exp (log ((fromRational 2) * pi) * half)
+                    * (lam $ \x9 -> x9 `app` unit) `app` x8)
+                 `app` (lam $ \_ ->
+                        (lam $ \x9 ->
+                         (lam $ \x10 -> x10 `app` x4)
+                         `app` (lam $ \_ ->
+                                (lam $ \x11 ->
+                                 (lam $ \x12 -> x12 `app` unit)
+                                 `app` (lam $ \x12 ->
+                                        (lam $ \x13 ->
+                                         (lam $ \x14 -> x14 `app` x4)
+                                         `app` (lam $ \_ ->
+                                                (lam $ \x15 -> x15 `app` pair x4 x12) `app` x13))
+                                        `app` x11))
+                                `app` x9))
+                        `app` x7))
+                `app` x6)
+           `app` (lam $ \x6 ->
+                  (lam $ \x7 -> x7 `app` (x6 `unpair` \_ x9 -> x9)) `app` x5)
+        )
+        `app` x1
+        `app` x2
+        `app` (lam $ \_ -> one)
+
+-- the one we need in testKernel
+expr3 :: (ABT Term abt)
+    => abt '[] (d ':-> 'HProb)
+    -> abt '[] (d ':-> d ':-> 'HProb)
+    -> abt '[] d -> abt '[] d -> abt '[] 'HProb
+expr3 x0 x1 x2 x3 =
+    let q = x0 `app` x3
+            / x1 `app` x2 `app` x3
+            * x1 `app` x3 `app` x2
+            / x0 `app` x2
+    in if_ (one < q) one q
+
+-- testKernel :: Sample IO ('HReal ':-> 'HMeasure 'HReal)
+testKernel :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HReal)
+testKernel =
+-- Below is the output of testMcmc as of 2014-11-05
+    let_ expr1 $ \x0 ->
+    let_ expr2 $ \x1 ->
+    lam $ \x2 ->
+    normal x2 one >>= \x3 ->
+    let_ (expr3 x0 x1 x2 x3) $ \x4 ->
+    bern x4 >>= \x5 ->
+    dirac (if_ x5 x3 x2)
+
+-- this should be equivalent to the above
+testKernel2 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HReal)
+testKernel2 =
+    lam $ \x2 ->
+    normal x2 one >>= \x3 ->
+    let q = exp(negate (real_ 1)/(real_ 50)*(x3-x2)*(x3+x2)) in
+    let_ (if_ (one < q) one q) $ \x4 ->
+    bern x4 >>= \x5 ->
+    dirac $ if_ x5 x3 x2
+
+-- this comes from {Tests.Lazy,Examples.EasierRoadmap}.easierRoadmapProg1.  It is the
+-- program post-disintegrate, as passed to Maple to simplify
+rmProg1 :: (ABT Term abt) => abt '[]
+    (HUnit
+    ':-> HPair 'HReal 'HReal
+    ':-> 'HMeasure (HPair 'HProb 'HProb))
+rmProg1 =
+    lam $ \_ ->
+    lam $ \x1 ->
+    x1 `unpair` \x2 x3 ->
+    withWeight one $
+    withWeight one $
+    unsafeSuperpose
+        [(one,
+            withWeight one $
+            lebesgue >>= \x4 ->
+            unsafeSuperpose
+                [(one,
+                    withWeight one $
+                    lebesgue >>= \x5 ->
+                    withWeight one $
+                    lebesgue >>= \x6 ->
+                    withWeight
+                        ( exp (negate (x3 - x6) * (x3 - x6)
+                            / (fromProb ((fromRational 2) * exp (log (unsafeProb x5) * (fromRational 2)))))
+                        / unsafeProb x5
+                        / (exp (log ((fromRational 2) * pi) * half))) $
+                    withWeight one $
+                    lebesgue >>= \x7 ->
+                    withWeight
+                        ( exp (negate (x6 - x7) * (x6 - x7)
+                            / (fromProb ((fromRational 2) * exp (log (unsafeProb x4) * (fromRational 2)))))
+                        / (unsafeProb x4)
+                        / (exp (log ((fromRational 2) * pi) * half))) $
+                    withWeight
+                        ( exp (negate (x2 - x7) * (x2 - x7)
+                            / (fromProb ((fromRational 2) * exp (log (unsafeProb x5) * (fromRational 2)))))
+                        / unsafeProb x5
+                        / (exp (log ((fromRational 2) * pi) * half))) $
+                    withWeight
+                        ( exp (negate x7 * x7
+                            / (fromProb ((fromRational 2) * exp (log (unsafeProb x4) * (fromRational 2)))))
+                        / unsafeProb x4
+                        / (exp (log ((fromRational 2) * pi) * half))) $
+                    withWeight (recip (fromRational 3)) $
+                    unsafeSuperpose
+                        [(one,
+                            if_ (x5 < (real_ 4))
+                                (if_ (one < x5)
+                                    (withWeight (recip (prob_ 5)) $
+                                    unsafeSuperpose
+                                        [(one,
+                                            if_ (x4 < (real_ 8))
+                                                (if_ ((real_ 3) < x4)
+                                                    (dirac (pair (unsafeProb x4)
+                                                        (unsafeProb x5)))
+                                                    (reject sing))
+                                                (reject sing))
+                                        , (one, reject sing)])
+                                    (reject sing))
+                                (reject sing))
+                , (one, reject sing)])
+            , (one, reject sing)])
+        , (one, reject sing)]
+
+-- this comes from Examples.EasierRoadmap.easierRoadmapProg4'.
+-- TODO: this needs to be regenerated from original program
+rmProg4
+    :: (ABT Term abt)
+    => abt '[]
+        (HPair 'HReal 'HReal
+        ':-> HPair 'HProb 'HProb
+        ':-> 'HMeasure (HPair (HPair 'HProb 'HProb) 'HProb))
+rmProg4 =
+    lam $ \x0 ->
+    let_ (lam $ \x1 ->
+        (lam $ \x2 ->
+         lam $ \x3 ->
+         x3 `unpair` \x4 x5 ->
+         let_ one $ \x6 ->
+         let_ (let_ one $ \x7 ->
+               let_ (let_ one $ \x8 ->
+                     let_ (let_ one $ \x9 ->
+                           let_ (let_ one $ \x10 ->
+                                 let_ (let_ one $ \x11 ->
+                                       let_ (x2 `unpair` \x12 _ ->
+                                             x2 `unpair` \x14 _ ->
+                                             x2 `unpair` \x16 _ ->
+                                             x2 `unpair` \_ x19 ->
+                                             x2 `unpair` \_ x21 ->
+                                             x2 `unpair` \_ x23 ->
+                                             x2 `unpair` \x24 _ ->
+                                             x2 `unpair` \x26 _ ->
+                                             x2 `unpair` \_ x29 ->
+                                             x2 `unpair` \_ x31 ->
+                                             let_ (recip pi
+                                                   * exp ((x12 * x14 * (fromProb x4 * fromProb x4)
+                                                            * (fromRational 2)
+                                                            + fromProb x4 * fromProb x4 * x16 * x19
+                                                              * (negate (fromRational 2))
+                                                            + x21 * x23 * (fromProb x4 * fromProb x4)
+                                                            + fromProb x5 * fromProb x5 * (x24 * x26)
+                                                            + fromProb x5 * fromProb x5 * (x29 * x31))
+                                                           * recip (fromProb x4 * fromProb x4
+                                                                    * (fromProb x4 * fromProb x4)
+                                                                    + fromProb x5 * fromProb x5
+                                                                      * (fromProb x4 * fromProb x4)
+                                                                      * (fromRational 3)
+                                                                    + fromProb x5 * fromProb x5
+                                                                      * (fromProb x5 * fromProb x5))
+                                                           * (negate half))
+                                                   * exp (log (exp (log x4 * (fromRational 4))
+                                                                             + exp (log x5 * (fromRational 2))
+                                                                               * exp (log x4 * (fromRational 2))
+                                                                               * (fromRational 3)
+                                                                             + exp (log x5 * (fromRational 4)))
+                                                           * (negate half))
+                                                   * (fromRational 1)/(fromRational 10)) $ \x32 ->
+                                             let_ (let_ (recip (fromRational 3)) $ \x33 ->
+                                                   let_ (let_ one $ \x34 ->
+                                                         let_ (if_ (fromProb x5 < (fromRational 4))
+                                                                   (if_ (one < fromProb x5)
+                                                                        (let_ (recip (fromRational 5)) $ \x35 ->
+                                                                         let_ (let_ one $ \x36 ->
+                                                                               let_ (if_ (fromProb x4
+                                                                                          < (fromRational 8))
+                                                                                         (if_ ((fromRational 3)
+                                                                                               < fromProb x4)
+                                                                                              (let_ (fromRational 5) $ \x37 ->
+                                                                                               let_ (let_ (pair x4 x5) $ \x38 ->
+                                                                                                     pair (dirac x38)
+                                                                                                          (lam $ \x39 ->
+                                                                                                           x39
+                                                                                                           `app` x38)) $ \x38 ->
+                                                                                               pair (withWeight x37 $
+                                                                                                     x38 `unpair` \x39 _ ->
+                                                                                                     x39)
+                                                                                                    (lam $ \x39 ->
+                                                                                                     zero
+                                                                                                     + x37
+                                                                                                       * (x38 `unpair` \_ x41 ->
+                                                                                                          x41)
+                                                                                                         `app` x39))
+                                                                                              (pair (reject sing)
+                                                                                                    (lam $ \x37 ->
+                                                                                                     zero)))
+                                                                                         (pair (reject sing)
+                                                                                               (lam $ \x37 ->
+                                                                                                zero))) $ \x37 ->
+                                                                               let_ one $ \x38 ->
+                                                                               let_ (pair (reject sing)
+                                                                                          (lam $ \x39 ->
+                                                                                           zero)) $ \x39 ->
+                                                                               pair (unsafeSuperpose [(x36,
+                                                                                                 x37 `unpair` \x40 x41 ->
+                                                                                                 x40),
+                                                                                                (x38,
+                                                                                                 x39 `unpair` \x40 x41 ->
+                                                                                                 x40)])
+                                                                                    (lam $ \x40 ->
+                                                                                     zero
+                                                                                     + x36
+                                                                                       * (x37 `unpair` \x41 x42 ->
+                                                                                          x42)
+                                                                                         `app` x40
+                                                                                     + x38
+                                                                                       * (x39 `unpair` \x41 x42 ->
+                                                                                          x42)
+                                                                                         `app` x40)) $ \x36 ->
+                                                                         pair (withWeight x35 $
+                                                                               x36 `unpair` \x37 x38 ->
+                                                                               x37)
+                                                                              (lam $ \x37 ->
+                                                                               zero
+                                                                               + x35
+                                                                                 * (x36 `unpair` \x38 x39 ->
+                                                                                    x39)
+                                                                                   `app` x37))
+                                                                        (pair (reject sing)
+                                                                              (lam $ \x35 -> zero)))
+                                                                   (pair (reject sing)
+                                                                         (lam $ \x35 -> zero))) $ \x35 ->
+                                                         let_ one $ \x36 ->
+                                                         let_ (pair (reject sing)
+                                                                    (lam $ \x37 -> zero)) $ \x37 ->
+                                                         pair (unsafeSuperpose [(x34,
+                                                                           x35 `unpair` \x38 x39 ->
+                                                                           x38),
+                                                                          (x36,
+                                                                           x37 `unpair` \x38 x39 ->
+                                                                           x38)])
+                                                              (lam $ \x38 ->
+                                                               zero
+                                                               + x34
+                                                                 * (x35 `unpair` \x39 x40 -> x40)
+                                                                   `app` x38
+                                                               + x36
+                                                                 * (x37 `unpair` \x39 x40 -> x40)
+                                                                   `app` x38)) $ \x34 ->
+                                                   pair (withWeight x33 $ x34 `unpair` \x35 x36 -> x35)
+                                                        (lam $ \x35 ->
+                                                         zero
+                                                         + x33
+                                                           * (x34 `unpair` \x36 x37 -> x37)
+                                                             `app` x35)) $ \x33 ->
+                                             pair (withWeight x32 $ x33 `unpair` \x34 x35 -> x34)
+                                                  (lam $ \x34 ->
+                                                   zero
+                                                   + x32
+                                                     * (x33 `unpair` \x35 x36 -> x36)
+                                                       `app` x34)) $ \x12 ->
+                                       pair (withWeight x11 $ x12 `unpair` \x13 x14 -> x13)
+                                            (lam $ \x13 ->
+                                             zero
+                                             + x11
+                                               * (x12 `unpair` \x14 x15 -> x15) `app` x13)) $ \x11 ->
+                                 let_ one $ \x12 ->
+                                 let_ (pair (reject sing) (lam $ \x13 -> zero)) $ \x13 ->
+                                 pair (unsafeSuperpose [(x10, x11 `unpair` \x14 x15 -> x14),
+                                                  (x12, x13 `unpair` \x14 x15 -> x14)])
+                                      (lam $ \x14 ->
+                                       zero + x10 * (x11 `unpair` \x15 x16 -> x16) `app` x14
+                                       + x12 * (x13 `unpair` \x15 x16 -> x16) `app` x14)) $ \x10 ->
+                           pair (withWeight x9 $ x10 `unpair` \x11 x12 -> x11)
+                                (lam $ \x11 ->
+                                 zero + x9 * (x10 `unpair` \x12 x13 -> x13) `app` x11)) $ \x9 ->
+                     let_ one $ \x10 ->
+                     let_ (pair (reject sing) (lam $ \x11 -> zero)) $ \x11 ->
+                     pair (unsafeSuperpose [(x8, x9 `unpair` \x12 x13 -> x12),
+                                      (x10, x11 `unpair` \x12 x13 -> x12)])
+                          (lam $ \x12 ->
+                           zero + x8 * (x9 `unpair` \x13 x14 -> x14) `app` x12
+                           + x10 * (x11 `unpair` \x13 x14 -> x14) `app` x12)) $ \x8 ->
+               pair (withWeight x7 $ x8 `unpair` \x9 x10 -> x9)
+                    (lam $ \x9 ->
+                     zero + x7 * (x8 `unpair` \x10 x11 -> x11) `app` x9)) $ \x7 ->
+         pair (withWeight x6 $ x7 `unpair` \x8 x9 -> x8)
+              (lam $ \x8 -> zero + x6 * (x7 `unpair` \x9 x10 -> x10) `app` x8))
+        `app` x0
+        `app` x1 `unpair` \x2 x3 ->
+        x3 `app` (lam $ \x4 -> one)) $ \x1 ->
+  lam $ \x2 ->
+  (x2 `unpair` \x3 x4 ->
+   unsafeSuperpose [(half,
+               uniform (real_ 3) (real_ 8) >>= \x5 -> dirac (pair (unsafeProb x5) x4)),
+              (half,
+               uniform one (real_ 4) >>= \x5 ->
+               dirac (pair x3 (unsafeProb x5)))]) >>= \x3 ->
+  dirac (pair x3 (x1 `app` x3 / x1 `app` x2))
+
+
+pairReject
+    :: (ABT Term abt)
+    => abt '[] (HPair ('HMeasure 'HReal) 'HReal)
+pairReject =
+    pair (reject (SMeasure SReal) >>= \_ -> dirac one)
+         (real_ 2)
+
+-- from a web question
+-- these are mathematically equivalent, albeit at different types
+chal1 :: (ABT Term abt) => abt '[]
+    ('HProb ':-> 'HReal ':-> 'HReal ':-> 'HReal ':-> 'HMeasure HBool)
+chal1 =
+    lam $ \sigma ->
+    lam $ \a     ->
+    lam $ \b     ->
+    lam $ \c     ->
+    normal a sigma >>= \ya ->
+    normal b sigma >>= \yb ->
+    normal c sigma >>= \yc ->
+    dirac (yb < ya && yc < ya)
+
+chal2 :: (ABT Term abt) => abt '[]
+    ('HProb ':-> 'HReal ':-> 'HReal ':-> 'HReal ':-> 'HMeasure 'HReal)
+chal2 =
+    lam $ \sigma ->
+    lam $ \a     ->
+    lam $ \b     ->
+    lam $ \c     ->
+    normal a sigma >>= \ya ->
+    normal b sigma >>= \yb ->
+    normal c sigma >>= \yc ->
+    dirac (if_ (yb < ya && yc < ya) one zero)
+
+chal3 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HReal)
+chal3 = lam $ \sigma -> app3 (app chal2 sigma) zero zero zero
+
+--seismic :: (ABT Term abt) => abt '[]
+--    (SE.HStation
+--    ':-> HPair 'HReal (HPair 'HReal (HPair 'HProb 'HReal))
+--    ':-> HPair 'HReal (HPair 'HReal (HPair 'HReal 'HProb))
+--    ':-> 'HMeasure 'HProb)
+--seismic = lam3 (\s e d -> dirac $ SE.densT s e d)
+
+easyHMM :: (ABT Term abt) => abt '[]
+    ('HMeasure (HPair (HPair 'HReal 'HReal) (HPair 'HProb 'HProb)))
+easyHMM =
+    gamma (prob_ 3)  one >>= \noiseT ->
+    gamma_1_1 >>= \noiseE ->
+    normal zero noiseT >>= \x1 ->
+    normal x1 noiseE >>= \m1 ->
+    normal x1 noiseT >>= \x2 ->
+    normal x2 noiseE >>= \m2 ->
+    dirac (pair (pair m1 m2) (pair noiseT noiseE))
diff --git a/haskell/Tests/Sample.hs b/haskell/Tests/Sample.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/Sample.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE DataKinds
+           , GADTs
+           , FlexibleContexts
+           #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Tests.Sample where
+
+import           Prelude                        hiding ((+))
+import           GHC.Word (Word32)
+import qualified Data.Vector as V
+
+import           Language.Hakaru.Types.DataKind
+import           Language.Hakaru.Syntax.Prelude
+import           Language.Hakaru.Syntax.Value
+import           Language.Hakaru.Syntax.AST
+import           Language.Hakaru.Syntax.ABT
+import           Language.Hakaru.Sample
+
+import           Tests.Models
+
+import qualified System.Random.MWC as MWC
+import           Test.HUnit
+
+seed :: V.Vector Word32
+seed = V.singleton 42
+
+testMeasure :: String
+          -> Value ('HMeasure a)
+          -> Value 'HProb
+          -> Value a
+          -> Assertion
+testMeasure p (VMeasure m) w v = do
+  g <- MWC.initialize seed
+  Just (v', w') <- m (VProb 1) g
+  assertEqual p v' v
+  assertEqual p w' w
+
+testEvaluate :: (ABT Term abt)
+             => String
+             -> abt '[] a
+             -> Value a
+             -> Assertion
+testEvaluate p prog = assertEqual p (runEvaluate prog)
+
+normal01Value :: Value ('HMeasure 'HReal)
+normal01Value = runEvaluate (triv normal_0_1)
+
+allTests :: Test
+allTests = test
+   [ testMeasure "normal01" normal01Value (VProb 1) (VReal 0.35378756491616103)
+   , testEvaluate "1+1" (triv $ real_ 1 + real_ 1) (VReal 2)
+   ]
diff --git a/haskell/Tests/Simplify.hs b/haskell/Tests/Simplify.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/Simplify.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE OverloadedStrings
+           , DataKinds
+           , FlexibleContexts
+           #-}
+
+module Tests.Simplify where
+
+import Prelude hiding ((>>=))
+
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.Prelude
+import Language.Hakaru.Simplify
+
+import Test.HUnit
+import Tests.TestTools
+
+v :: (ABT Term abt) => abt '[] ('HMeasure 'HNat)
+v = var (Variable "x" 0 (SMeasure SNat))
+
+freevar :: TrivialABT Term '[] ('HMeasure 'HNat)
+freevar = v
+
+normal01T :: TrivialABT Term '[] ('HMeasure 'HReal)
+normal01T =
+    syn (MeasureOp_ Normal
+        :$ syn (Literal_ (LReal (-2)))
+        :* syn (Literal_ (LProb 1))
+        :* End)
+
+realpair :: TrivialABT Term '[] ('HMeasure (HPair 'HReal 'HReal))
+realpair =
+    ann_ (SMeasure $ sPair SReal SReal)
+        (dirac (pair (nat2real $ nat_ 1) (nat2real $ nat_ 2)))
+
+unifprob  :: TrivialABT Term '[] ('HMeasure 'HProb)
+unifprob =
+    uniform (real_ 1) (real_ 2) >>= \x ->
+    dirac (unsafeProb x)
+
+testSimplify
+    ::  ( ABT Term abt
+        , Show (abt '[] a)
+        , Eq   (abt '[] a)
+        )
+    => String
+    -> abt '[] a
+    -> abt '[] a
+    -> Assertion
+testSimplify nm x y = do
+    x' <- simplify x
+    assertEqual nm y x'
+
+allTests :: Test
+allTests = test
+    [ testSimplify "freevar" freevar freevar
+    , testSimplify "normal01T" normal01T normal01T
+    , testSimplify "realpair" realpair realpair
+    , testSimplify "unifprob" unifprob unifprob
+    , testS "true" (triv $ ann_ (SMeasure sBool) (dirac true))
+    ]
diff --git a/haskell/Tests/TestSuite.hs b/haskell/Tests/TestSuite.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/TestSuite.hs
@@ -0,0 +1,49 @@
+module Main(main) where
+
+import System.Exit (exitFailure)
+import System.Environment (lookupEnv)
+
+import qualified Tests.ASTTransforms as TR
+import qualified Tests.Parser        as P
+import qualified Tests.Pretty        as Pr
+import qualified Tests.TypeCheck     as TC
+import qualified Tests.Simplify      as S
+import qualified Tests.Disintegrate  as D
+import qualified Tests.Sample        as E
+import qualified Tests.RoundTrip     as RT
+import qualified Tests.Relationships as REL
+
+import Test.HUnit
+
+-- master test suite
+
+ignored :: Assertion
+ignored = putStrLn "Warning: maple tests will be ignored"
+
+simplifyTests :: Test -> Maybe String -> Test
+simplifyTests t env =
+  case env of
+    Just _  -> t
+    Nothing -> test ignored
+
+allTests :: Maybe String -> Test
+allTests env = test $
+  [ TestLabel "Parser"       P.allTests
+  , TestLabel "Pretty"       Pr.allTests
+  , TestLabel "TypeCheck"    TC.allTests
+  , TestLabel "Simplify"     (simplifyTests S.allTests env)
+  , TestLabel "Disintegrate" D.allTests
+  , TestLabel "Evaluate"     E.allTests
+  , TestLabel "RoundTrip"    (simplifyTests RT.allTests env)
+  , TestLabel "Relationships" (simplifyTests REL.allTests env)
+  , TestLabel "ASTTransforms" TR.allTests
+  ]
+
+main :: IO ()
+main = mainWith allTests (fmap Just . runTestTT)
+
+mainWith :: (Maybe String -> Test) -> (Test -> IO (Maybe Counts)) -> IO ()
+mainWith mkTests run = do
+    env <- lookupEnv "LOCAL_MAPLE"
+    run (mkTests env) >>=
+      maybe (return ()) (\(Counts _ _ e f) -> if (e>0) || (f>0) then exitFailure else return ())
diff --git a/haskell/Tests/TestTools.hs b/haskell/Tests/TestTools.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/TestTools.hs
@@ -0,0 +1,261 @@
+{-# LANGUAGE DeriveDataTypeable
+           , DataKinds
+           , RankNTypes
+           , GADTs
+           , PolyKinds
+           , TypeInType
+           , ScopedTypeVariables
+           , FlexibleContexts #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
+module Tests.TestTools
+  ( module Tests.TestTools
+  , MapleOptions(..)
+  , defaultMapleOptions)
+   where
+
+import Language.Hakaru.Types.Sing
+import Language.Hakaru.Parser.Parser (parseHakaru)
+import Language.Hakaru.Parser.SymbolResolve (resolveAST)
+import Language.Hakaru.Command (parseAndInferWithMode', Source(..),
+                                fileSource, noFileSource)
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.AST
+import Language.Hakaru.Syntax.TypeCheck
+import Language.Hakaru.Syntax.AST.Eq (alphaEq)
+import Language.Hakaru.Syntax.AST.Transforms (expandTransformations
+                                             ,expandTransformationsWith
+                                             ,allTransformationsWithMOpts)
+import Language.Hakaru.Syntax.IClasses (TypeEq(..), jmEq1)
+import Language.Hakaru.Pretty.Concrete
+import Language.Hakaru.Simplify
+import Language.Hakaru.Maple (MapleOptions(..), defaultMapleOptions)
+import Language.Hakaru.Syntax.AST.Eq()
+import Text.PrettyPrint (Doc)
+
+import Data.Maybe (isJust)
+import Data.List
+import Data.Kind
+import qualified Data.Text    as T
+import qualified Data.Text.Utf8 as IO
+import Data.Typeable (Typeable)
+import Control.Exception
+import Control.Monad
+
+import Test.HUnit
+
+data TestException = TestSimplifyException String SomeException
+    deriving Typeable
+instance Exception TestException
+instance Show TestException where
+    show (TestSimplifyException prettyHakaru e) =
+        show e ++ "\nwhile simplifying Hakaru:\n" ++ prettyHakaru
+
+-- assert that we get a result and that no error is thrown
+assertResult :: [a] -> Assertion
+assertResult s = assertBool "no result" $ not $ null s
+
+assertJust :: Maybe a -> Assertion
+assertJust = assertBool "expected Just but got Nothing" . isJust
+
+handleException :: String -> SomeException -> IO a
+handleException t e = throw (TestSimplifyException t e)
+
+testS
+    :: (ABT Term abt)
+    => String
+    -> abt '[] a
+    -> Assertion
+testS p x = do
+    _ <- simplify (expandTransformations x) `catch`
+           handleException (p ++ ": simplify failed")
+    return ()
+
+testStriv 
+    :: TrivialABT Term '[] a
+    -> Assertion
+testStriv = testS ""
+
+testSS1
+    :: (ABT Term abt)
+    => String
+    -> abt '[] a -- | Expected
+    -> abt '[] a -- | To simplify
+    -> Assertion
+testSS1 = testSS1WithOpts defaultMapleOptions
+
+testSS1WithOpts
+    :: (ABT Term abt)
+    => MapleOptions ()
+    -> String
+    -> abt '[] a -- | Expected
+    -> abt '[] a -- | To simplify
+    -> Assertion
+testSS1WithOpts o nm t' t =
+   simplifyWithOpts o (expandTransformations t) >>= \p -> assertAlphaEq nm p t'
+
+-- Assert that all the given Hakaru programs simplify to the given one
+testSS 
+    :: (ABT Term abt)
+    => String
+    -> [(abt '[] a)] 
+    -> abt '[] a 
+    -> Test
+testSS nm ts t' = test $ map (testSS1 nm t') (t':ts)
+
+testSStriv 
+    :: [(TrivialABT Term '[] a)] 
+    -> TrivialABT Term '[] a 
+    -> Test
+testSStriv = testSS ""
+
+-- | Assert that the given programs are equal after expanding transformations.
+--   By convention, the first program is taken to be the expected output, but
+--   this function is symmetric.
+testET
+    :: (ABT Term abt)
+    => MapleOptions ()
+    -> String
+    -> abt '[] a
+    -> abt '[] a
+    -> Assertion
+testET opts nm t0 t1 =
+  let et = expandTransformationsWith (allTransformationsWithMOpts opts) in
+  mapM et [t0, t1] >>= \[t0', t1'] -> assertAlphaEq nm t0' t1'
+
+assertAlphaEq ::
+    (ABT Term abt) 
+    => String
+    -> abt '[] a
+    -> abt '[] a
+    -> Assertion
+assertAlphaEq preface a b =
+   unless (alphaEq a b) (assertFailure $ mismatchMessage pretty preface a b)
+
+mismatchMessage :: forall q (k :: q -> Type) . (forall a . k a -> Doc) -> String -> forall a b . k a -> k b -> String 
+mismatchMessage k preface a b = msg 
+ where msg = concat [ p
+                    , "expected:\n"
+                    , show (k b)
+                    , "\nbut got:\n"
+                    , show (k a)
+                    ]
+       p = if null preface then "" else preface ++ "\n"
+
+testWithConcreteImport ::
+    (ABT Term abt)
+    => Source
+    -> TypeCheckMode
+    -> (forall a. Sing a -> abt '[] a -> Assertion)
+    -> Assertion
+testWithConcreteImport s mode k =
+  either (assertFailure . T.unpack) (\(TypedAST typ ast) -> k typ ast) =<<
+  parseAndInferWithMode' s mode
+
+testWithConcrete ::
+    (ABT Term abt)
+    => T.Text
+    -> TypeCheckMode
+    -> (forall a. Sing a -> abt '[] a -> Assertion)
+    -> Assertion
+testWithConcrete t m k = testWithConcreteImport (noFileSource t) m k
+
+-- Like testWithConcrete, but for many programs 
+testWithConcreteMany 
+  :: forall abt. (ABT Term abt) 
+  => FilePath
+  -> [FilePath]
+  -> TypeCheckMode 
+  -> (forall a . Sing a -> abt '[] a -> abt '[] a -> Assertion) 
+  -> Test
+testWithConcreteMany t ts mode k = test $ map (mkT t) (t:ts)
+  where mkT :: FilePath -> FilePath -> Assertion
+        mkT t0' t1' =
+          mapM (\t -> fileSource t <$> IO.readFile t) [t0', t1'] >>= \[t0,t1] ->
+          testWithConcreteImport t0 mode $ \t0ty (t0p :: abt '[] x0) ->
+          testWithConcreteImport t1 mode $ \t1ty (t1p :: abt '[] x1) ->
+            case jmEq1 t0ty t1ty of
+              Just Refl -> k t0ty t0p t1p
+              Nothing   -> assertFailure $ concat
+                           [ "Files don't have same type ("
+                           , T.unpack (source t0), " :: ", prettyTypeS t0ty
+                           , ", "
+                           , T.unpack (source t1), " :: ", prettyTypeS t1ty ]
+
+testWithConcrete'
+    :: T.Text
+    -> TypeCheckMode
+    -> (forall a. Sing a -> TrivialABT Term '[] a -> Assertion)
+    -> Assertion
+testWithConcrete' = testWithConcrete
+
+testWithConcreteMany'
+  :: FilePath
+  -> [FilePath] 
+  -> TypeCheckMode 
+  -> (forall a . Sing a 
+        -> TrivialABT Term '[] a
+        -> TrivialABT Term '[] a
+        -> Assertion) 
+  -> Test
+testWithConcreteMany' = testWithConcreteMany
+
+-- Like testSStriv but for many concrete files
+testConcreteFilesMany
+    :: [FilePath] 
+    -> FilePath
+    -> Test
+testConcreteFilesMany = testConcreteFilesManyWithOpts defaultMapleOptions
+
+-- TODO: Should there be a variant with options for each program?
+testConcreteFilesManyWithOpts
+    :: MapleOptions ()
+    -> [FilePath]
+    -> FilePath
+    -> Test
+testConcreteFilesManyWithOpts o fs f =
+  testWithConcreteMany' f fs LaxMode $
+  \_ -> testSS1WithOpts o ""
+
+testConcreteFilesET
+    :: MapleOptions ()
+    -> [FilePath]
+    -> FilePath
+    -> Test
+testConcreteFilesET o fs f =
+  testWithConcreteMany' f fs LaxMode $
+  \_ -> testET o ""
+
+-- Like testSStriv but for two concrete files
+testConcreteFiles
+    :: FilePath
+    -> FilePath
+    -> Test
+testConcreteFiles f1 f2 = testConcreteFilesMany [f1] f2 
+
+-- Like testStriv but for a concrete file. 
+testConcreteFile :: FilePath -> Assertion
+testConcreteFile f =
+  IO.readFile f >>= \t -> testWithConcreteImport (fileSource f t) LaxMode $
+  \_ -> testStriv
+
+ignore :: a -> Assertion
+ignore _ = assertFailure "ignored"  -- ignoring a test reports as a failure
+
+-- Runs a single test from a list of tests given its index
+runTestI :: Test -> Int -> IO Counts
+runTestI (TestList ts) i = runTestTT $ ts !! i
+runTestI (TestCase _) _ = error "expecting a TestList, but got a TestCase"
+runTestI (TestLabel _ _) _ = error "expecting a TestList, but got a TestLabel"
+
+hasLab :: String -> Test -> Bool
+hasLab l (TestLabel lab _) = lab == l
+hasLab _ _ = False
+
+-- Runs a single test from a TestList given its label
+runTestN :: Test -> String -> IO Counts
+runTestN (TestList ts) l =
+  case find (hasLab l) ts of
+    Just t -> runTestTT t
+    Nothing -> error $ "no test with label " ++ l
+runTestN (TestCase _) _ = error "expecting a TestList, but got a TestCase"
+runTestN (TestLabel _ _) _ = error "expecting a TestList, but got a TestLabel"
diff --git a/haskell/Tests/TypeCheck.hs b/haskell/Tests/TypeCheck.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Tests/TypeCheck.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE GADTs
+           , OverloadedStrings
+           , DataKinds
+           , FlexibleContexts
+           #-}
+
+module Tests.TypeCheck where
+
+import Prelude hiding (unlines)
+
+import qualified Language.Hakaru.Parser.AST as U
+import qualified Language.Hakaru.Syntax.AST as T
+
+import Language.Hakaru.Syntax.AST.Eq()
+
+import Language.Hakaru.Syntax.ABT
+import Language.Hakaru.Syntax.TypeCheck
+import Language.Hakaru.Syntax.IClasses
+import Language.Hakaru.Types.HClasses
+import Language.Hakaru.Types.DataKind
+import Language.Hakaru.Types.Sing
+
+import Data.Number.Nat
+
+import Data.Sequence
+import Data.Text
+import Test.HUnit
+import Tests.TestTools
+
+five :: Text
+five = "2 + 3"
+
+fiveU :: U.AST
+fiveU = syn $ 
+    U.NaryOp_ U.Sum
+        [ syn $ U.Literal_ $ Some1 $ T.LNat 2
+        , syn $ U.Literal_ $ Some1 $ T.LNat 3
+        ]
+
+fiveT :: TrivialABT T.Term '[] 'HNat
+fiveT =
+    syn . T.NaryOp_ (T.Sum HSemiring_Nat) $ fromList
+        [ syn $ T.Literal_ $ T.LNat 2
+        , syn $ T.Literal_ $ T.LNat 3
+        ]
+
+normal01 :: U.AST
+normal01 = syn $
+    U.MeasureOp_ (U.SomeOp T.Normal)
+        [ syn $ U.Literal_ $ Some1 $ T.LReal 0
+        , syn $ U.Literal_ $ Some1 $ T.LProb 1
+        ]
+
+normal01T :: TrivialABT T.Term '[] ('HMeasure 'HReal)
+normal01T =
+    syn (T.MeasureOp_ T.Normal
+        T.:$ (syn $ T.Literal_ $ T.LReal 0)
+        T.:* (syn $ T.Literal_ $ T.LProb 1)
+        T.:* T.End)
+
+xname :: Variable 'U.U
+xname =  Variable "x" (unsafeNat 0) U.SU
+
+normalb :: U.AST
+normalb = syn $
+    U.MBind_
+        normal01
+        (bind xname $
+              syn $ U.MeasureOp_ (U.SomeOp T.Normal)
+                      [ var xname
+                      , syn $ U.Literal_ $ Some1 $ T.LProb 1
+                      ])
+
+
+inferType' :: U.AST -> TypeCheckMonad (TypedAST (TrivialABT T.Term))
+inferType' = inferType
+
+testTC :: Sing b -> U.AST -> TrivialABT T.Term '[] b -> Assertion
+testTC typ uast tast =
+    case runTCM (inferType' uast) Nothing StrictMode of
+    Left _err                 -> assertFailure (show tast)
+    Right (TypedAST _typ ast) ->
+        case jmEq1 _typ typ of
+        Just Refl -> assertEqual "" tast ast
+        Nothing   -> assertFailure
+            (show ast ++ " does not have same type as " ++ show tast)
+
+testConcreteTC :: Sing b -> Text -> TrivialABT T.Term '[] b -> Assertion
+testConcreteTC typ s ast =
+    testWithConcrete' s StrictMode $ \_typ tast ->
+        case jmEq1 _typ typ of
+          Just Refl -> assertEqual "" tast ast
+          Nothing   -> assertFailure
+                       (show ast ++ " does not have same type as " ++ show tast)
+
+
+allTests :: Test
+allTests = test
+    [ testTC SNat fiveU fiveT
+    , testTC (SMeasure SReal) normal01 normal01T
+    , testConcreteTC SNat five fiveT
+    ]
diff --git a/haskell/Text/Parsec/Indentation.hs b/haskell/Text/Parsec/Indentation.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Text/Parsec/Indentation.hs
@@ -0,0 +1,209 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances, TupleSections #-}
+{-# OPTIONS -Wall  #-}
+module Text.Parsec.Indentation (module Text.Parsec.Indentation, I.IndentationRel(..), Indentation, infIndentation) where
+
+-- Implements "Indentation Senstivie Parising: Landin Revisited"
+--
+-- Primary functions are:
+--  - 'localIndent':
+--  - 'absoluteIndent':
+--  - 'localTokenMode':
+--
+-- Primary driver functions are:
+--  - TODO
+
+-- TODO:
+--   Grace style indentation stream
+
+import Control.Monad
+--import Text.Parsec.Prim
+import Text.Parsec.Prim (ParsecT, mkPT, runParsecT,
+                         Stream(..), Consumed(..), Reply(..),
+                         State(..), getInput, setInput)
+import Text.Parsec.Error (Message (Message), addErrorMessage)
+import Text.Parser.Indentation.Implementation as I
+
+------------------------
+-- Indentable Stream
+------------------------
+
+data IndentStream s = IndentStream { indentationState :: !IndentationState, tokenStream :: !s } deriving (Show)
+--data IndentationToken t = IndentationToken !t | InvalidIndentation String
+type IndentationToken t = t
+
+{-# INLINE mkIndentStream #-}
+mkIndentStream :: Indentation -> Indentation -> Bool -> IndentationRel -> s -> IndentStream s
+mkIndentStream lo hi mode rel s = IndentStream (mkIndentationState lo hi mode rel) s
+
+instance (Monad m, Stream s m (t, Indentation)) => Stream (IndentStream s) m (IndentationToken t) where
+  uncons (IndentStream is s) = do
+    x <- uncons s
+    case x of
+      Nothing -> return Nothing
+      Just ((t, i), s') -> return $ updateIndentation is i ok err where
+        ok is' = Just ({-IndentationToken-} t, IndentStream is' s')
+        err _ = Nothing --(InvalidIndentation msg, IndentStream is s)
+        -- HACK: Sigh! We have no way to properly signal the
+        -- sort of failure that occurs here.  We would do 'fail
+        -- "Invalid indentation.  "++msg', but that triggers a
+        -- non-backtracking error.  'return Nothing' will make
+        -- Parsec think the stream is empty (which is wrong),
+        -- but at least it is a backtracking error.  The
+        -- fundamental problem is that 'm' *not* ParsecT (where
+        -- we could signal a parsing error) but is whatever
+        -- monad 'm' happens to be the argument to ParsecT.
+
+{-# INLINE localState #-}
+localState :: (Monad m) => LocalState (ParsecT (IndentStream s) u m a)
+localState pre post m = do
+  IndentStream is s <- getInput
+  setInput (IndentStream (pre is) s)
+  x <- m
+  IndentStream is' s' <- getInput
+  setInput (IndentStream (post is is') s')
+  return x
+
+{-# INLINE localStateUnlessAbsMode #-}
+localStateUnlessAbsMode :: (Monad m) => LocalState (ParsecT (IndentStream s) u m a)
+localStateUnlessAbsMode pre post m = do
+  a <- liftM (indentationStateAbsMode . indentationState) getInput
+  if a then m else localState pre post m
+
+
+------------------------
+-- Operations
+------------------------
+
+{-# INLINE localTokenMode #-}
+localTokenMode :: (Monad m) => (IndentationRel -> IndentationRel) -> ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
+localTokenMode = I.localTokenMode localState
+
+{-# INLINE localIndentation #-}
+localIndentation :: (Monad m) => IndentationRel -> ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
+localIndentation = I.localIndentation localStateUnlessAbsMode
+
+{-# INLINE absoluteIndentation #-}
+absoluteIndentation :: (Monad m) => ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
+absoluteIndentation = I.absoluteIndentation localState
+--  post _  i2 = when (absMode i2) (fail "absoluteIndent: no tokens consumed") >>
+
+{-# INLINE ignoreAbsoluteIndentation #-}
+ignoreAbsoluteIndentation :: (Monad m) => ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
+ignoreAbsoluteIndentation = I.ignoreAbsoluteIndentation localState
+
+{-# INLINE localAbsoluteIndentation #-}
+localAbsoluteIndentation :: (Monad m) => ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
+localAbsoluteIndentation = I.localAbsoluteIndentation localState
+
+------------------------
+-- Indent Stream Impls
+------------------------
+
+streamToList :: (Monad m, Stream s m t) => s -> m [t]
+streamToList s = do
+  x <- uncons s
+  case x of
+    Nothing -> return []
+    Just (c, s') -> do s'' <- streamToList s'
+                       return (c : s'')
+
+----------------
+-- SourcePos
+
+{-
+mkSourcePosIndentStream s = SourcePosIndentStream s
+newtype SourcePosIndentStream s = SourcePosIndentStream s
+instance (Stream s m t) => Stream (SourcePosIndentStream s) m (Indent, t) where
+  uncons (SourcePosIndentStream s) = do
+    col <- liftM sourceColumn $ getPosition
+    x <- uncons s
+    case x of
+      Nothing -> return Nothing
+      Just x -> return (Just ((col, x), SourcePosIndentStream s))
+-}
+
+
+----------------
+-- TODO: parser based on first non-whitespace char
+
+----------------
+-- First token of line indents
+
+----------------
+-- Based on Indents
+
+-- Note that if 'p' consumes input but is at the wrong indentation, then
+-- 'indentStreamParser p' signals an error but does *not* consume input.
+-- This allows Parsec primitives like 'string' to be properly backtracked.
+{-# INLINE indentStreamParser #-}
+indentStreamParser :: (Monad m) => ParsecT s u m (t, Indentation) -> ParsecT (IndentStream s) u m (IndentationToken t)
+indentStreamParser p = mkPT $ \state ->
+  let IndentStream is s = stateInput state
+      go f (Ok (a, i) state' e) = updateIndentation is i ok err where
+        ok is' = return $ f $ return (Ok ({-IndentationToken-} a) (state' {stateInput = IndentStream is' (stateInput state') }) e)
+        err msg = return $ Empty $ return $ Error (Message ("Invalid indentation.  "++msg++show ((stateInput state) { tokenStream = ""})) `addErrorMessage` e)
+      go f (Error e) = return $ f $ return (Error e)
+  in runParsecT p (state { stateInput = s }) >>= consumed (go Consumed) (go Empty)
+
+{-# INLINE consumed #-}
+consumed :: (Monad m) => (a -> m b) -> (a -> m b) -> Consumed (m a) -> m b
+consumed c _ (Consumed m) = m >>= c
+consumed _ e (Empty m)    = m >>= e
+
+-- lifting operator
+-- token, tokens, tokenPrim, tokenPrimEx ???
+-- whiteSpace
+-- ByteString
+-- ByteString.Lazy
+-- Text
+
+{-
+delimitedLayout :: Stream (IndentStream s) m t =>
+  ParsecT (IndentStream s) u m open -> Bool ->
+  ParsecT (IndentStream s) u m close -> Bool ->
+  ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
+delimitedLayout open openAny close closeAny body = between open' close' (localIndent (Const 0) body) where
+  open'  | openAny = localIndent (Const 0) open
+         | otherwise = open
+  close' | closeAny = localIndent (Const 0) close
+         | otherwise = close
+
+indentedLayout :: Stream (IndentStream s) m t =>
+  (Maybe (ParsecT (IndentStream s) u m sep)) ->
+  ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m [a]
+indentedLayout (Nothing ) clause = localIndent Gt $ many $ absoluteIndent $ clause
+indentedLayout (Just sep) clause = liftM concat $ localIndent Gt $ many $ absoluteIndent $ sepBy1 clause sep
+-}
+
+{-
+layout p = delimitedLayout (symbol "{") False (symbol "}") True (semiSep p)
+       <|> indentedLayout (Just semi) p
+
+identifier pred = liftM fromString $ try $ identifier >>= \x -> guard (pred x) >> return x
+operator pred = liftM fromString $ try $ operator >>= \x -> guard (pred x) >> return x
+
+reserved name = (if name `elem` middleKeywords then localFirstTokenMode (const Ge) else id) $ reserved name
+
+Numbers, Integers and Naturals are custom
+
+dotSep
+dotSep1
+
+-}
+
+{-
+test :: String
+test = foo where
+          foo = "abc \
+\def" ++ ""
+
+test2 :: Int
+test2 = foo where
+          foo = let { x = 1;
+ } in x
+
+
+--- All code indented?
+  foo = 3
+  bar = 4
+-}
diff --git a/haskell/Text/Parsec/Indentation/Char.hs b/haskell/Text/Parsec/Indentation/Char.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Text/Parsec/Indentation/Char.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
+module Text.Parsec.Indentation.Char where
+
+import Text.Parsec.Prim (ParsecT, mkPT, runParsecT,
+                         Stream(..),
+                         Consumed(..), Reply(..),
+                         State(..))
+import Text.Parsec.Pos (sourceColumn)
+import Text.Parser.Indentation.Implementation (Indentation)
+
+----------------
+-- Unicode char
+-- newtype UnicodeIndentStream
+
+----------------
+-- Based on Char
+{-# INLINE mkCharIndentStream #-}
+mkCharIndentStream :: s -> CharIndentStream s
+mkCharIndentStream s = CharIndentStream 1 s
+data CharIndentStream s = CharIndentStream { charIndentStreamColumn :: {-# UNPACK #-} !Indentation,
+                                             charIndentStreamStream :: !s } deriving (Show)
+
+instance (Stream s m Char) => Stream (CharIndentStream s) m (Char, Indentation) where
+  uncons (CharIndentStream i s) = do
+    x <- uncons s
+    case x of
+      Nothing -> return Nothing
+      Just (c, cs) -> return (Just ((c, i), CharIndentStream (updateColumn i c) cs))
+
+{-# INLINE updateColumn #-}
+updateColumn :: Integral a => a -> Char -> a
+updateColumn _ '\n' = 1
+updateColumn i '\t' = i + 8 - ((i-1) `mod` 8)
+updateColumn i _    = i + 1
+
+{-# INLINE charIndentStreamParser #-}
+charIndentStreamParser :: (Monad m) => ParsecT s u m t -> ParsecT (CharIndentStream s) u m (t, Indentation)
+charIndentStreamParser p = mkPT $ \state ->
+  let go (Ok a state' e) = return (Ok (a, sourceColumn $ statePos state) (state' { stateInput = CharIndentStream (sourceColumn $ statePos state') (stateInput state') }) e)
+      go (Error e) = return (Error e)
+  in runParsecT p (state { stateInput = charIndentStreamStream (stateInput state) })
+         >>= consumed (return . Consumed . go) (return . Empty . go)
+
+{-# INLINE consumed #-}
+consumed :: (Monad m) => (a -> m b) -> (a -> m b) -> Consumed (m a) -> m b
+consumed c _ (Consumed m) = m >>= c
+consumed _ e (Empty m)    = m >>= e
diff --git a/haskell/Text/Parsec/Indentation/Token.hs b/haskell/Text/Parsec/Indentation/Token.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Text/Parsec/Indentation/Token.hs
@@ -0,0 +1,400 @@
+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}
+{-# OPTIONS -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
+module Text.Parsec.Indentation.Token where
+
+import Control.Monad.Identity
+import Data.Char
+import Data.List (nub, sort)
+import Text.Parsec
+import Text.Parsec.Token
+
+import Text.Parsec.Indentation
+import Text.Parsec.Indentation.Char (CharIndentStream(..), charIndentStreamParser)
+
+type IndentLanguageDef st = GenLanguageDef (IndentStream (CharIndentStream String)) st Identity
+
+makeIndentLanguageDef :: (Monad m) => GenLanguageDef s st m -> GenLanguageDef (IndentStream (CharIndentStream s)) st m
+makeIndentLanguageDef l = l {
+  identStart = indentStreamParser (charIndentStreamParser (identStart l)),
+  identLetter = indentStreamParser (charIndentStreamParser (identLetter l)),
+  opStart = indentStreamParser (charIndentStreamParser (opStart l)),
+  opLetter = indentStreamParser (charIndentStreamParser (opLetter l))
+  }
+
+-- TODO: makeTokenParser :: (Stream (IndentStream s) m Char)
+makeTokenParser :: (Stream s m (Char, Indentation))
+                => GenLanguageDef (IndentStream s) u m -> GenTokenParser (IndentStream s) u m
+makeTokenParser languageDef
+    = TokenParser{ identifier = identifier
+                 , reserved = reserved
+                 , operator = operator
+                 , reservedOp = reservedOp
+
+                 , charLiteral = charLiteral
+                 , stringLiteral = stringLiteral
+                 , natural = natural
+                 , integer = integer
+                 , float = float
+                 , naturalOrFloat = naturalOrFloat
+                 , decimal = decimal
+                 , hexadecimal = hexadecimal
+                 , octal = octal
+
+                 , symbol = symbol
+                 , lexeme = lexeme
+                 , whiteSpace = whiteSpace
+                 , parens = parens
+                 , braces = braces
+                 , angles = angles
+                 , brackets = brackets
+                 , squares = brackets
+                 , semi = semi
+                 , comma = comma
+                 , colon = colon
+                 , dot = dot
+                 , semiSep = semiSep
+                 , semiSep1 = semiSep1
+                 , commaSep = commaSep
+                 , commaSep1 = commaSep1
+                 }
+    where
+
+    -----------------------------------------------------------
+    -- Bracketing
+    -----------------------------------------------------------
+    parens p        = between (symbol "(") (symbol ")") p
+    braces p        = between (symbol "{") (symbol "}") p
+    angles p        = between (symbol "<") (symbol ">") p
+    brackets p      = between (symbol "[") (symbol "]") p
+
+    semi            = symbol ";"
+    comma           = symbol ","
+    dot             = symbol "."
+    colon           = symbol ":"
+
+    commaSep p      = sepBy p comma
+    semiSep p       = sepBy p semi
+
+    commaSep1 p     = sepBy1 p comma
+    semiSep1 p      = sepBy1 p semi
+
+
+    -----------------------------------------------------------
+    -- Chars & Strings
+    -----------------------------------------------------------
+    charLiteral     = lexeme (between (char '\'')
+                                      (char '\'' <?> "end of character")
+                                      characterChar )
+                    <?> "character"
+
+    characterChar   = charLetter <|> charEscape
+                    <?> "literal character"
+
+    charEscape      = do{ char '\\'; escapeCode }
+    charLetter      = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))
+
+
+
+    stringLiteral   = lexeme (
+                      do{ str <- between (char '"')
+                                         (localTokenMode (const Any) (char '"' <?> "end of string"))
+                                         (localTokenMode (const Any) (many stringChar))
+                        ; return (foldr (maybe id (:)) "" str)
+                        }
+                      <?> "literal string")
+
+    stringChar      =   do{ c <- stringLetter; return (Just c) }
+                    <|> stringEscape
+                    <?> "string character"
+
+    stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
+
+    stringEscape    = do{ char '\\'
+                        ;     do{ escapeGap  ; return Nothing }
+                          <|> do{ escapeEmpty; return Nothing }
+                          <|> do{ esc <- escapeCode; return (Just esc) }
+                        }
+
+    escapeEmpty     = char '&'
+    escapeGap       = do{ many1 space
+                        ; char '\\' <?> "end of string gap"
+                        }
+
+
+
+    -- escape codes
+    escapeCode      = charEsc <|> charNum <|> charAscii <|> charControl
+                    <?> "escape code"
+
+    charControl     = do{ char '^'
+                        ; code <- upper
+                        ; return (toEnum (fromEnum code - fromEnum 'A'))
+                        }
+
+    charNum         = do{ code <- decimal
+                                  <|> do{ char 'o'; number 8 octDigit }
+                                  <|> do{ char 'x'; number 16 hexDigit }
+                        ; return (toEnum (fromInteger code))
+                        }
+
+    charEsc         = choice (map parseEsc escMap)
+                    where
+                      parseEsc (c,code)     = do{ char c; return code }
+
+    charAscii       = choice (map parseAscii asciiMap)
+                    where
+                      parseAscii (asc,code) = try (do{ string asc; return code })
+
+
+    -- escape code tables
+    escMap          = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")
+    asciiMap        = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
+
+    ascii2codes     = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",
+                       "FS","GS","RS","US","SP"]
+    ascii3codes     = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",
+                       "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",
+                       "CAN","SUB","ESC","DEL"]
+
+    ascii2          = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',
+                       '\EM','\FS','\GS','\RS','\US','\SP']
+    ascii3          = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',
+                       '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',
+                       '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']
+
+
+    -----------------------------------------------------------
+    -- Numbers
+    -----------------------------------------------------------
+    naturalOrFloat  = lexeme (natFloat) <?> "number"
+
+    float           = lexeme floating   <?> "float"
+    integer         = lexeme int        <?> "integer"
+    natural         = lexeme nat        <?> "natural"
+
+
+    -- floats
+    floating        = do{ n <- decimal
+                        ; fractExponent n
+                        }
+
+
+    natFloat        = do{ char '0'
+                        ; zeroNumFloat
+                        }
+                      <|> decimalFloat
+
+    zeroNumFloat    =  do{ n <- hexadecimal <|> octal
+                         ; return (Left n)
+                         }
+                    <|> decimalFloat
+                    <|> fractFloat 0
+                    <|> return (Left 0)
+
+    decimalFloat    = do{ n <- decimal
+                        ; option (Left n)
+                                 (fractFloat n)
+                        }
+
+    fractFloat n    = do{ f <- fractExponent n
+                        ; return (Right f)
+                        }
+
+    fractExponent n = do{ fract <- fraction
+                        ; expo  <- option 1.0 exponent'
+                        ; return ((fromInteger n + fract)*expo)
+                        }
+                    <|>
+                      do{ expo <- exponent'
+                        ; return ((fromInteger n)*expo)
+                        }
+
+    fraction        = do{ char '.'
+                        ; digits <- many1 digit <?> "fraction"
+                        ; return (foldr op 0.0 digits)
+                        }
+                      <?> "fraction"
+                    where
+                      op d f    = (f + fromIntegral (digitToInt d))/10.0
+
+    exponent'       = do{ oneOf "eE"
+                        ; f <- sign
+                        ; e <- decimal <?> "exponent"
+                        ; return (power (f e))
+                        }
+                      <?> "exponent"
+                    where
+                       power e  | e < 0      = 1.0/power(-e)
+                                | otherwise  = fromInteger (10^e)
+
+
+    -- integers and naturals
+    int             = do{ f <- lexeme sign
+                        ; n <- nat
+                        ; return (f n)
+                        }
+
+    sign            =   (char '-' >> return negate)
+                    <|> (char '+' >> return id)
+                    <|> return id
+
+    nat             = zeroNumber <|> decimal
+
+    zeroNumber      = do{ char '0'
+                        ; hexadecimal <|> octal <|> decimal <|> return 0
+                        }
+                      <?> ""
+
+    decimal         = number 10 digit
+    hexadecimal     = do{ oneOf "xX"; number 16 hexDigit }
+    octal           = do{ oneOf "oO"; number 8 octDigit  }
+
+    number base baseDigit
+        = do{ digits <- many1 baseDigit
+            ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits
+            ; seq n (return n)
+            }
+
+    -----------------------------------------------------------
+    -- Operators & reserved ops
+    -----------------------------------------------------------
+    reservedOp name =
+        lexeme $ try $
+        do{ string name
+          ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)
+          }
+
+    operator =
+        lexeme $ try $
+        do{ name <- oper
+          ; if (isReservedOp name)
+             then unexpected ("reserved operator " ++ show name)
+             else return name
+          }
+
+    oper =
+        do{ c <- (opStart languageDef)
+          ; cs <- many (opLetter languageDef)
+          ; return (c:cs)
+          }
+        <?> "operator"
+
+    isReservedOp name =
+        isReserved (sort (reservedOpNames languageDef)) name
+
+
+    -----------------------------------------------------------
+    -- Identifiers & Reserved words
+    -----------------------------------------------------------
+    reserved name =
+        lexeme $ try $
+        do{ caseString name
+          ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)
+          }
+
+    caseString name
+        | caseSensitive languageDef  = string name
+        | otherwise               = do{ walk name; return name }
+        where
+          walk []     = return ()
+          walk (c:cs) = do{ caseChar c <?> msg; walk cs }
+
+          caseChar c  | isAlpha c  = char (toLower c) <|> char (toUpper c)
+                      | otherwise  = char c
+
+          msg         = show name
+
+
+    identifier =
+        lexeme $ try $
+        do{ name <- ident
+          ; if (isReservedName name)
+             then unexpected ("reserved word " ++ show name)
+             else return name
+          }
+
+
+    ident
+        = do{ c <- identStart languageDef
+            ; cs <- many (identLetter languageDef)
+            ; return (c:cs)
+            }
+        <?> "identifier"
+
+    isReservedName name
+        = isReserved theReservedNames caseName
+        where
+          caseName      | caseSensitive languageDef  = name
+                        | otherwise               = map toLower name
+
+
+    isReserved names name
+        = scan names
+        where
+          scan []       = False
+          scan (r:rs)   = case (compare r name) of
+                            LT  -> scan rs
+                            EQ  -> True
+                            GT  -> False
+
+    theReservedNames
+        | caseSensitive languageDef  = sort reserved
+        | otherwise                  = sort . map (map toLower) $ reserved
+        where
+          reserved = reservedNames languageDef
+
+
+
+    -----------------------------------------------------------
+    -- White space & symbols
+    -----------------------------------------------------------
+    symbol name
+        = lexeme (string name)
+
+    lexeme p
+        = do{ x <- p; whiteSpace; return x  }
+
+    whiteSpace = ignoreAbsoluteIndentation (localTokenMode (const Any) whiteSpace')
+    whiteSpace'
+        | noLine && noMulti  = skipMany (simpleSpace <?> "")
+        | noLine             = skipMany (simpleSpace <|> multiLineComment <?> "")
+        | noMulti            = skipMany (simpleSpace <|> oneLineComment <?> "")
+        | otherwise          = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
+        where
+          noLine  = null (commentLine languageDef)
+          noMulti = null (commentStart languageDef)
+
+    simpleSpace =
+        skipMany1 (satisfy isSpace)
+
+    oneLineComment =
+        do{ try (string (commentLine languageDef))
+          ; skipMany (satisfy (/= '\n'))
+          ; return ()
+          }
+
+    multiLineComment =
+        do { try (string (commentStart languageDef))
+           ; inComment
+           }
+
+    inComment
+        | nestedComments languageDef  = inCommentMulti
+        | otherwise                = inCommentSingle
+
+    inCommentMulti
+        =   do{ try (string (commentEnd languageDef)) ; return () }
+        <|> do{ multiLineComment                     ; inCommentMulti }
+        <|> do{ skipMany1 (noneOf startEnd)          ; inCommentMulti }
+        <|> do{ oneOf startEnd                       ; inCommentMulti }
+        <?> "end of comment"
+        where
+          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)
+
+    inCommentSingle
+        =   do{ try (string (commentEnd languageDef)); return () }
+        <|> do{ skipMany1 (noneOf startEnd)         ; inCommentSingle }
+        <|> do{ oneOf startEnd                      ; inCommentSingle }
+        <?> "end of comment"
+        where
+          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)
diff --git a/haskell/Text/Parser/Indentation/Implementation.hs b/haskell/Text/Parser/Indentation/Implementation.hs
new file mode 100644
--- /dev/null
+++ b/haskell/Text/Parser/Indentation/Implementation.hs
@@ -0,0 +1,338 @@
+module Text.Parser.Indentation.Implementation where
+
+-- Implements common code for "Indentation Senstivie Parising: Landin Revisited"
+--
+-- Primary functions are:
+--  - TODO
+-- Primary driver functions are:
+--  - TODO
+
+-- TODO:
+--   Grace style indentation stream
+--   Haskell style indentation stream
+
+--import Control.Monad
+
+------------------------
+-- Indentations
+------------------------
+
+-- We use indent 1 for the first column.  Not only is this consistent
+-- with how Parsec counts columns, but it also allows 'Gt' to refer to
+-- the first column by setting the indent to 0.
+--data Indentation = Indentation# Int# deriving (Eq, Ord)
+type Indentation = Int
+data IndentationRel = Eq | Any | Const Indentation | Ge | Gt deriving (Show, Eq)
+
+{-# INLINE infIndentation #-}
+infIndentation :: Indentation
+infIndentation = maxBound
+
+{-
+instance Num Indentation where
+
+instance Show Indentation where
+  show i@(Indentation# i') | i' == maxBound = "Infinity"
+                           | otherwise = show (Int# i')
+-}
+
+------------------------
+-- Indentable Stream
+------------------------
+
+-- We store state information about the current indentation in the
+-- Stream.  Encoding the indentation state in the Stream is weird, but
+-- the other two places where we could put it don't work.  The monad
+-- isn't rolledback when backtracking happens (which we need the
+-- indentation state to do), and the user state isn't available when
+-- we do an 'uncons'.
+
+{-# INLINE mkIndentationState #-}
+mkIndentationState :: Indentation -> Indentation -> Bool -> IndentationRel -> IndentationState
+mkIndentationState lo hi mode rel
+  | lo == infIndentation = error "mkIndentationState: minimum indentation 'infIndentation' is out of bounds"
+  | lo > hi = error "mkIndentationState: minimum indentation is greater than maximum indent"
+  | otherwise = IndentationState lo hi mode rel
+
+-- THEOREM: indent sets are all describable by upper and lower bounds (maxBound is infinity)
+-- GLOBAL INVARIANT: minIndentation /= infIndentation
+-- GLOBAL INVARIANT: minIndentation <= maxIndentation
+-- GLOBAL INVARIENT: lo <= lo' where lo and lo' are minIndentation respectively before and after a monadic action
+-- GLOBAL INVARIENT: hi' <= hi where hi and hi' are maxIndentation respectively before and after a monadic action
+
+data IndentationState = IndentationState {
+  minIndentation :: {-# UNPACK #-} !Indentation, -- inclusive, must not equal infIndentation
+  maxIndentation :: {-# UNPACK #-} !Indentation, -- inclusive, infIndentation (i.e., maxBound) means infinity
+  absMode :: !Bool, -- true if we are in 'absolute' mode
+  tokenRel :: !IndentationRel
+  } deriving (Show)
+  -- Our representation of maxIndentation will get us in trouble if things
+  -- overflow.  In future we may want to use a type representing
+  -- Integer+Infinity However, this bug triggers *only* when there are
+  -- a large number of nested 'Gt' indentations which shouldn't be all
+  -- that common and 'local'
+
+{-# INLINE indentationStateAbsMode #-}
+indentationStateAbsMode :: IndentationState -> Bool
+indentationStateAbsMode x = absMode x
+
+{-# INLINE updateIndentation #-}
+-- PRIVATE: Use assertIndentation instead
+updateIndentation :: IndentationState -> Indentation -> (IndentationState -> a) -> (String -> a) -> a
+updateIndentation (IndentationState lo hi mode rel) i ok err = updateIndentation' lo hi (if mode then Eq else rel) i ok' err' where
+  ok' lo' hi' = ok (IndentationState lo' hi' False rel)
+  err' = err
+
+{-# INLINE updateIndentation' #-}
+updateIndentation' :: Indentation -> Indentation -> IndentationRel -> Indentation -> (Indentation -> Indentation -> a) -> (String -> a) -> a
+updateIndentation' lo hi rel i ok err =
+  case rel of
+    Any                          -> ok lo hi
+    Const c | c  == i            -> ok lo hi
+            | otherwise          -> err' $ "indentation "++show c
+    Eq      | lo <= i && i <= hi -> ok i i
+            | otherwise          -> err' $ "an indentation between "++show lo++" and "++show hi
+    Gt      | lo <  i            -> ok lo (min (i-1) hi)
+            | otherwise          -> err' $ "an indentation greater than "++show lo
+    Ge      | lo <= i            -> ok lo (min i hi)
+            | otherwise          -> err' $ "an indentation greater than or equal to "++show lo
+  where err' place = err $ "Found a token at indentation "++show i++".  Expecting a token at "++place++"."
+
+-- TODO: error when hi is maxIndentation
+
+-- There is no way to query the current indentation because multiple
+-- indentations are tried in parallel and later parsing may disqualify
+-- one of these indentations.  However, we can assert that the current
+-- indentation must have a particular relation, 'r', to a given
+-- indentation, 'i'.  The call 'assertIndent r i' does this.  Calling
+-- 'assertIndent r i' is equivalent to consuming a pseudo-token that has
+-- been annotated with the relation 'r' at indentation 'i'.
+--
+-- Note that the absolute indentation mode may override 'r'.
+{-
+assertIndent :: (Monad m, Stream (IndentStream s) m t) => IndentRel -> Indent -> ParsecT (IndentStream s) u m ()
+assertIndent r i = do
+  IndentStream lo hi mode rel s <- getInput
+  let ok s' = setInput (s' { absMode = mode }) -- Update input sets mode to False by default
+      --ok lo' hi' = setInput (IndentStream lo' hi' mode rel s)
+      err msg = unexpected $ "Indentation assertion '"++show r++" "++show i++"' failed.  "++msg
+  updateIndent lo hi mode r i s ok err
+  --updateIndent lo hi (if mode then Eq else r) i ok err
+-}
+
+{-
+{-# INLINE askTokenMode #-}
+askTokenMode :: (Monad m) => ParsecT (IndentStream s) u m IndentRel
+askTokenMode = liftM tokenRel getInput
+-}
+
+------------------------
+-- Token Modes
+------------------------
+
+-- Token modes determine how the current indentation must relate to
+-- the indentation of a token.  Because several languages have special
+-- rules for the first token of the production, we split the token
+-- mode into two parts.  The first part is the mode for the first
+-- token in a grammatical form while the second part is the mode for
+-- the other tokens in a grammatical form.
+--
+-- Because of this split, while token modes generally follow a reader
+-- monad pattern, there is one important exception.  Namely the
+-- first-token mode may follow a state monad pattern.  (Thus we have
+-- the divergent names for the first-token and other-token query
+-- operators.)
+
+-- THEOREM: tokenMode == tokenMode'
+-- THEOREM: firstTokenMode' == firstTokenMode \/ firstTokenMode' == otherTokenMode
+
+type LocalState a = (IndentationState -> IndentationState) -- pre
+                  -> (IndentationState {-old-} -> IndentationState {-new-} -> IndentationState) -- post
+                  -> a -> a
+
+{-# INLINE localTokenMode #-}
+localTokenMode :: (LocalState a)
+               -> (IndentationRel -> IndentationRel)
+               -> a -> a
+localTokenMode localState f_rel = localState pre post where
+  pre  i1    = i1 { tokenRel = f_rel (tokenRel i1) }
+  post i1 i2 = i2 { tokenRel =        tokenRel i1  }
+
+{-# INLINE absoluteIndentation #-}
+absoluteIndentation :: LocalState a -> a -> a
+absoluteIndentation localState = localState pre post where
+  pre  i1    = i1 { absMode = True }
+  post i1 i2 = i2 { absMode = absMode i1 && absMode i2 }
+
+{-# INLINE ignoreAbsoluteIndentation #-}
+ignoreAbsoluteIndentation :: LocalState a -> a -> a
+ignoreAbsoluteIndentation localState = localState pre post where
+  pre  i1    = i1 { absMode = False }
+  post i1 i2 = i2 { absMode = absMode i1 }
+
+{-# INLINE localAbsoluteIndentation #-}
+localAbsoluteIndentation :: LocalState a -> a -> a
+localAbsoluteIndentation localState = localState pre post where
+  pre  i1    = i1 { absMode = True }
+  post i1 i2 = i2 { absMode = absMode i1 }
+
+--{-# INLINE askTokenMode #-}
+--askTokenMode :: (Monad m) => ParsecT (IndentationStream s) u m IndentationRel
+--askTokenMode = liftM tokenRel getInput
+-- TODO: assertNotAbsMod/askAbsMode
+-- when (absMode i2) (fail "absoluteIndentation: no tokens consumed") >>
+
+------------------------
+-- Local Indentations
+------------------------
+
+{-# INLINE localIndentation' #-}
+-- PRIVATE: locally violates global invariants but used in a way that does not
+localIndentation' :: LocalState a -> (Indentation -> Indentation) -> (Indentation -> Indentation) -> (Indentation -> Indentation -> Indentation) -> a -> a
+localIndentation' localState f_lo f_hi f_hi' m = localState pre post m
+  where pre (IndentationState lo hi mode rel) = IndentationState (f_lo lo) (f_hi hi) mode rel
+        post (IndentationState lo hi _ _) i2 = i2 { minIndentation = lo, maxIndentation = f_hi' hi (maxIndentation i2) }
+--        post (IndentationStream lo hi mode rel s) i2 = IndentationStream lo (f_hi' hi (maxIndentation i2)) mode rel s
+
+-- 'localIndentation r p' specifies that the current indentation for 'p' must have relation 'r'
+-- relative to the current indentation of the context in which 'localIndentation r p' is called.
+{-# INLINE localIndentation #-}
+-- NOTE: it is the responsibility of 'localState' to *not* use it's arguments if we are in absMode
+localIndentation :: LocalState a -> IndentationRel -> a -> a
+localIndentation _localState Eq m = m
+localIndentation localState Any m = localIndentation' localState (const 0) (const infIndentation) (const) m
+localIndentation localState (Const c) m
+    | c == infIndentation = error "localIndentation: Const indentation 'infIndentation' is out of bounds"
+    | otherwise = localIndentation' localState (const c) (const c) (const) m
+localIndentation localState Ge m = localIndentation' localState (id) (const infIndentation) (flip const) m
+localIndentation localState Gt m = localIndentation' localState (+1) (const infIndentation) (f) ({-TODO: checkOverflow >>-} m) where
+  f hi hi' | hi' == infIndentation || hi < hi' = hi
+           | hi' > 0 = hi' - 1 -- Safe only b/c hi' > 0
+           | otherwise = error "localIndentation: assertion failed: hi' > 0"
+{-
+  checkOverflow = do
+    IndentationStream { minIndentation = lo } <- getState
+    when (lo == infIndentation) $ fail "localIndentation: Overflow in indentation lower bound."
+-}
+
+----------------
+-- SourcePos
+
+{-
+mkSourcePosIndentStream s = SourcePosIndentStream s
+newtype SourcePosIndentStream s = SourcePosIndentStream s
+instance (Stream s m t) => Stream (SourcePosIndentStream s) m (Indent, t) where
+  uncons (SourcePosIndentStream s) = do
+    col <- liftM sourceColumn $ getPosition
+    x <- uncons s
+    case x of
+      Nothing -> return Nothing
+      Just x -> return (Just ((col, x), SourcePosIndentStream s))
+-}
+
+----------------
+-- Unicode char
+-- newtype UnicodeIndentStream
+
+{-
+----------------
+-- Based on Char
+mkCharIndentStream :: s -> CharIndentStream s
+mkCharIndentStream s = CharIndentStream 1 s
+data CharIndentStream s = CharIndentStream { charIndentStreamColumn :: !Indent,
+                                             charIndentStreamStream :: s } deriving (Show)
+
+instance (Stream s m Char) => Stream (CharIndentStream s) m (Indent, Char) where
+  uncons (CharIndentStream i s) = do
+    x <- uncons s
+    case x of
+      Nothing -> return Nothing
+      Just (c, cs) -> return (Just ((i, c), CharIndentStream (f c) cs)) where
+        f '\n' = 1
+        f '\t' = i + 8 - ((i-1) `mod` 8)
+        f _    = i + 1
+
+charIndentStreamParser :: (Monad m) => ParsecT s u m t -> ParsecT (CharIndentStream s) u m (Indent, t)
+charIndentStreamParser p = mkPT $ \state ->
+  let go (Ok a state' e) = return (Ok (sourceColumn $ statePos state, a) (state' { stateInput = CharIndentStream (sourceColumn $ statePos state') (stateInput state') }) e)
+      go (Error e) = return (Error e)
+  in runParsecT p (state { stateInput = charIndentStreamStream (stateInput state) })
+         >>= consumed (return . Consumed . go) (return . Empty . go)
+
+----------------
+-- TODO: parser based on first non-whitespace char
+
+----------------
+-- First token of line indents
+
+----------------
+-- Based on Indents
+
+-- Note that if 'p' consumes input but is at the wrong indentation, then
+-- 'indentStreamParser p' signals an error but does *not* consume input.
+-- This allows Parsec primitives like 'string' to be properly backtracked.
+indentStreamParser :: (Monad m) => ParsecT s u m (Indent, t) -> ParsecT (IndentStream s) u m t
+indentStreamParser p = mkPT $ \state ->
+  let IndentStream lo hi mode rel _ = stateInput state
+      go f (Ok (i, a) state' e) = updateIndent lo hi (if mode then Eq else rel) i ok err where
+        ok lo' hi' = return $ f $ return (Ok a (state' {stateInput = IndentStream lo' hi' False rel (stateInput state') }) e)
+        err msg = return $ Empty $ return $ Error (Message ("Invalid indentation.  "++msg++show ((stateInput state) { tokenStream = ""})) `addErrorMessage` e)
+      go f (Error e) = return $ f $ return (Error e)
+  in runParsecT p (state { stateInput = tokenStream (stateInput state) }) >>= consumed (go Consumed) (go Empty)
+
+-- lifting operator
+-- token, tokens, tokenPrim, tokenPrimEx ???
+-- whiteSpace
+-- ByteString
+-- ByteString.Lazy
+-- Text
+
+delimitedLayout :: Stream (IndentStream s) m t =>
+  ParsecT (IndentStream s) u m open -> Bool ->
+  ParsecT (IndentStream s) u m close -> Bool ->
+  ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a
+delimitedLayout open openAny close closeAny body = between open' close' (localIndent (Const 0) body) where
+  open'  | openAny = localIndent (Const 0) open
+         | otherwise = open
+  close' | closeAny = localIndent (Const 0) close
+         | otherwise = close
+
+indentedLayout :: Stream (IndentStream s) m t =>
+  (Maybe (ParsecT (IndentStream s) u m sep)) ->
+  ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m [a]
+indentedLayout (Nothing ) clause = localIndent Gt $ many $ absoluteIndent $ clause
+indentedLayout (Just sep) clause = liftM concat $ localIndent Gt $ many $ absoluteIndent $ sepBy1 clause sep
+
+{-
+layout p = delimitedLayout (symbol "{") False (symbol "}") True (semiSep p)
+       <|> indentedLayout (Just semi) p
+
+identifier pred = liftM fromString $ try $ identifier >>= \x -> guard (pred x) >> return x
+operator pred = liftM fromString $ try $ operator >>= \x -> guard (pred x) >> return x
+
+reserved name = (if name `elem` middleKeywords then localFirstTokenMode (const Ge) else id) $ reserved name
+
+Numbers, Integers and Naturals are custom
+
+dotSep
+dotSep1
+
+-}
+
+{-
+test :: String
+test = foo where
+          foo = "abc \
+\def" ++ ""
+
+test2 :: Int
+test2 = foo where
+          foo = let { x = 1;
+ } in x
+
+
+--- All code indented?
+  foo = 3
+  bar = 4
+-}
+-}