diff --git a/commands/Compile.hs b/commands/Compile.hs
--- a/commands/Compile.hs
+++ b/commands/Compile.hs
@@ -17,8 +17,7 @@
 import           Language.Hakaru.Syntax.TypeCheck
 
 import           Language.Hakaru.Syntax.IClasses
-import           Language.Hakaru.Types.Sing
-import           Language.Hakaru.Types.DataKind
+import           Language.Hakaru.Types.Sing (Sing(SFun, SMeasure))
 
 import           Language.Hakaru.Pretty.Haskell
 import           Language.Hakaru.Command
@@ -86,29 +85,29 @@
 
 prettyProg :: (ABT T.Term abt)
            => String
+           -> Sing a
            -> abt '[] a
            -> String
-prettyProg name ast =
+prettyProg name typ ast =
     renderStyle style
-    (cat [ text (name ++ " = ")
-         , nest 2 (pretty ast)
-         ])
+    (    sep [text (name ++ " ::"), nest 2 (prettyType typ)]
+     $+$ sep [text (name ++ " =") , nest 2 (pretty     ast)] )
 
 compileHakaru
     :: Options
     -> IO ()
 compileHakaru opts = do
-    let file = fileIn opts
-    prog <- readFromFile file
+    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 file (fileOut opts) . TxT.unlines $
+        writeHkHsToFile infile (fileOut opts) . TxT.unlines $
           header (logFloatPrelude opts) (asModule opts) ++
-          [ pack $ prettyProg "prog" ast' ] ++
+          [ pack $ prettyProg "prog" typ ast' ] ++
           (case asModule opts of
-             Nothing -> footer (logFloatPrelude opts) typ
+             Nothing -> footer
              Just _  -> [])
   where et = expandTransformations
 
@@ -128,8 +127,8 @@
               | (Just Refl, Just Refl) <- (jmEq1 a b, jmEq1 b c)
               -> writeHkHsToFile f1 (fileOut opts) . TxT.unlines $
                    header (logFloatPrelude opts) (asModule opts) ++
-                   [ pack $ prettyProg "prog1" (expandTransformations ast1) ] ++
-                   [ pack $ prettyProg "prog2" (expandTransformations ast2) ] ++
+                   [ pack $ prettyProg "prog1" typ1 (expandTransformations ast1) ] ++
+                   [ pack $ prettyProg "prog2" typ2 (expandTransformations ast2) ] ++
                    (case asModule opts of
                       Nothing -> footerWalk
                       Just _  -> [])
@@ -155,14 +154,13 @@
   , ""
   , if logfloats
     then TxT.unlines [ "import           Data.Number.LogFloat (LogFloat)"
-                     , "import           Prelude              hiding (product, exp, log, (**))"
+                     , "import           Prelude hiding (product, exp, log, (**), pi)"
+                     , "import           Language.Hakaru.Runtime.LogFloatPrelude"
                      ]
-    else "import           Prelude hiding (product)"
-  , if logfloats
-    then TxT.unlines [ "import           Language.Hakaru.Runtime.LogFloatPrelude"
-                     , "import           Language.Hakaru.Runtime.LogFloatCmdLine" ]
-    else TxT.unlines [ "import           Language.Hakaru.Runtime.Prelude"
-                     , "import           Language.Hakaru.Runtime.CmdLine" ]
+    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"
@@ -170,24 +168,10 @@
   , ""
   ]
 
-footer :: forall (a :: Hakaru) . Bool -> Sing a -> [Text]
-footer logfloats typ =
+footer :: [Text]
+footer =
     ["","main :: IO ()"
-    , TxT.concat ["main = makeMain (prog :: ",toHsType typ,")  =<< getArgs"]]
-  where toHsType :: forall (a :: Hakaru) . Sing a -> Text
-        toHsType SInt = "Int"
-        toHsType SNat = "Int"
-        toHsType SReal = "Double"
-        toHsType SProb = if logfloats then "LogFloat" else "Double"
-        toHsType (SArray t) = let t' = toHsType t in
-                                TxT.concat ["(",TxT.unwords ["MayBoxVec",t',t'],")"]
-        toHsType (SMeasure t) = TxT.concat ["(",TxT.unwords ["Measure",toHsType t],")"]
-        toHsType (SFun t1 t2) = TxT.unwords [toHsType t1,"->",toHsType t2]
-        toHsType (SData _
-                   ((SKonst t1 `SEt` SKonst t2 `SEt` SDone) `SPlus` SVoid)) =
-          TxT.concat ["(",toHsType t1,",",toHsType t2,")"]
-        toHsType _ = "type"
-
+    , TxT.concat ["main = makeMain prog =<< getArgs"]]
 
 footerWalk :: [Text]
 footerWalk =
diff --git a/commands/Disintegrate.hs b/commands/Disintegrate.hs
--- a/commands/Disintegrate.hs
+++ b/commands/Disintegrate.hs
@@ -65,8 +65,8 @@
 main = do
   args  <- parseOpts
   case args of
-    Options t i file -> do
-      prog <- readFromFile file
+    Options t i infile -> do
+      prog <- readFromFile infile
       runDisintegrate prog t i
 
 runDisintegrate :: T.Text -> Bool -> Int -> IO ()
@@ -99,13 +99,13 @@
               _ -> putErrorMsg ast
                    
 putErrorMsg :: (Show a) => a -> IO ()
-putErrorMsg a = IO.hPutStrLn stderr . T.pack $
+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 a. abt '[] a -> IO ()) -> abt '[] a -> IO ()
+     -> (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
--- a/commands/HKC.hs
+++ b/commands/HKC.hs
@@ -40,7 +40,7 @@
          , asFunc           :: Maybe String
          , fileIn           :: String
          , fileOut          :: Maybe String
-         , par              :: Bool
+         , par              :: Bool -- turns on simd and sharedMem
          , noWeightsOpt     :: Bool
          , showProbInLogOpt :: Bool
          , garbageCollector :: Bool
@@ -77,7 +77,7 @@
                             <> metavar "OUTPUT"
                             <> help "output FILE"))
   <*> switch (  short 'j'
-             <> help "Generates parallel programs using OpenMP directives")
+             <> help "Generates multithreaded and simd parallel programs using OpenMP directives")
   <*> switch (  long "no-weights"
              <> short 'w'
              <> help "Don't print the weights")
@@ -110,7 +110,9 @@
                                 (asFunc config)
                                 (PrintConfig { noWeights     = noWeightsOpt config
                                              , showProbInLog = showProbInLogOpt config })
-          codeGenConfig = emptyCG {sharedMem = par config, managedMem = garbageCollector 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
diff --git a/commands/Hakaru.hs b/commands/Hakaru.hs
--- a/commands/Hakaru.hs
+++ b/commands/Hakaru.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE CPP
-           , OverloadedStrings
+{-# LANGUAGE OverloadedStrings
            , PatternGuards
            , DataKinds
            , GADTs
@@ -10,25 +9,23 @@
 
 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.Syntax.IClasses
 import           Language.Hakaru.Types.Sing
 import           Language.Hakaru.Types.DataKind
 
 import           Language.Hakaru.Sample
 import           Language.Hakaru.Pretty.Concrete
-import           Language.Hakaru.Command ( parseAndInfer, parseAndInfer'
-                                         , readFromFile, Term
+import           Language.Hakaru.Command ( parseAndInfer'
+                                         , readFromFile', Term, Source
+                                         , sourceInput
                                          )
 
-#if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative   (Applicative(..), (<$>))
-#endif
+import           Control.Applicative   (Applicative(..), (<$>), liftA2)
 import           Control.Monad
 
 import           Data.Monoid
-import           Data.Text
 import qualified Data.Text.IO as IO
 import qualified Data.Vector  as V
 import           Data.Word
@@ -73,10 +70,10 @@
               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'
+      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 ()
@@ -98,22 +95,9 @@
 renderLn = putStrLn . renderStyle style {mode = LeftMode} . prettyValue
 
 -- TODO: A better needs to be found for passing weights around
-runHakaru :: MWC.GenIO -> Bool -> Text -> IO ()
-runHakaru g weights prog' =
-    case parseAndInfer 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
-
--- TODO: A better needs to be found for passing weights around
-runHakaru' :: MWC.GenIO -> Bool -> Text -> IO ()
-runHakaru' g weights prog = do
-    prog' <- parseAndInfer' prog
+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
@@ -124,40 +108,22 @@
     run :: Term a -> Value a
     run = runEvaluate . expandTransformations
 
-randomWalk :: MWC.GenIO -> Text -> Text -> IO ()
-randomWalk g p1 p2 =
-    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)
-              -> iterateM_ (chain $ run ast1) (run ast2)
-            _ -> IO.hPutStrLn stderr "hakaru: programs have wrong type"
-      (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)
-
-randomWalk' :: MWC.GenIO -> Text -> Text -> IO ()
-randomWalk' g p1 p2 = do
+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)) ->
-          -- 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)
-              -> iterateM_ (chain $ run ast1) (run ast2)
-            _ -> IO.hPutStrLn stderr "hakaru: programs have wrong type"
+        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
diff --git a/commands/HkMaple.hs b/commands/HkMaple.hs
--- a/commands/HkMaple.hs
+++ b/commands/HkMaple.hs
@@ -8,58 +8,62 @@
 
 module Main where
 
-import           Language.Hakaru.Pretty.Concrete  
+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, Term)
+import           Language.Hakaru.Command (parseAndInfer', readFromFile')
 
 import           Language.Hakaru.Syntax.Rename
-import           Language.Hakaru.Simplify
-import           Language.Hakaru.Maple 
-import           Language.Hakaru.Parser.Maple 
+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 ((<>), mconcat)
-import           Data.Text (Text, unpack, pack)
-import qualified Data.Text as Text 
-import qualified Data.Text.IO as IO
+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           Data.List (intercalate)
 import           Text.Read (readMaybe)
 import           Control.Exception(throw)
 import qualified Options.Applicative as O
-import qualified Data.Map as M 
+import qualified Data.Map as M
 
 
-data Options a 
+data Options a
   = Options
-    { moptions      :: MapleOptions String
+    { moptions      :: MapleOptions (Maybe String)
     , no_unicode    :: Bool
-    , program       :: a } 
-  | ListCommands 
+    , 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 (unpack k, unpack v)
-      _     -> Nothing) . pack 
+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.str
+  <$> (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. "
-                 ++"Default: Simplify") <>
-          O.short 'c' <> 
-          O.value "Simplify" ) 
+                 ++"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." )
@@ -69,31 +73,45 @@
           O.showDefault <>
           O.value 90 <>
           O.metavar "N")
-    <*> (M.fromList <$> 
+    <*> (M.fromList <$>
           O.many (O.option parseKeyVal
-        ( O.long "maple-opt" <> 
-          O.short 'm' <> 
+        ( 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.")
-        ))))
-  <*> O.switch 
-      ( O.long "no-unicode" <> 
-        O.short 'u' <> 
+        )))
+    <*> 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.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.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  
+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"
@@ -101,28 +119,43 @@
   ,"pretty print, parse and typecheck the program resulting from Maple"
   ]
 
-et (TypedAST t (x :: Term a)) = TypedAST t (expandTransformations x)
-
 main :: IO ()
 main = parseOpts >>= runMaple
 
 runMaple :: Options FilePath -> IO ()
-runMaple ListCommands = 
+runMaple ListCommands =
   listCommands >>= \cs -> putStrLn $ "Available Hakaru Maple commands:\n\t"++ intercalate ", " cs
 
-runMaple Options{..} = readFromFile program >>= \prog -> 
-  case parseAndInfer prog of
+runMaple PrintVersion = printVersion
+
+runMaple Options{..} = readFromFile' program >>= parseAndInfer' >>= \prog ->
+  case prog of
     Left  err  -> IO.hPutStrLn stderr err
-    Right ast  -> do 
-      TypedAST _ ast' <- sendToMaple' moptions (et ast)
-      print $ pretty 
-            $ (if no_unicode then renameAST removeUnicodeChars else id) 
+    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 
+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) 
+          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
--- a/commands/Mh.hs
+++ b/commands/Mh.hs
@@ -1,4 +1,11 @@
-{-# LANGUAGE OverloadedStrings, PatternGuards, DataKinds, GADTs #-}
+{-# LANGUAGE OverloadedStrings
+           , PatternGuards
+           , DataKinds
+           , GADTs
+           , KindSignatures
+           , RankNTypes
+           , TypeOperators
+           , FlexibleContexts #-}
 
 module Main where
 
@@ -6,9 +13,11 @@
 import           Language.Hakaru.Syntax.TypeCheck
 
 import           Language.Hakaru.Syntax.IClasses
-import           Language.Hakaru.Types.Sing
-import           Language.Hakaru.Inference
-import           Language.Hakaru.Command
+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
@@ -27,12 +36,20 @@
 runMH :: Text -> Text -> IO ()
 runMH prog1 prog2 =
     case (parseAndInfer prog1, parseAndInfer prog2) 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)
-              -> print . pretty $ mcmc ast1 ast2
-            _ -> IO.hPutStrLn stderr "mh: programs have wrong type"
+      (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/Pretty.hs b/commands/Pretty.hs
--- a/commands/Pretty.hs
+++ b/commands/Pretty.hs
@@ -1,22 +1,72 @@
-{-# LANGUAGE OverloadedStrings, DataKinds, GADTs #-}
+{-# 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           Data.Text
+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 = simpleCommand runPretty "pretty"
+main = parseOpts >>= runPretty 
 
-runPretty :: Text -> IO ()
-runPretty prog =
-    case parseAndInfer prog of
-    Left  err              -> IO.hPutStrLn stderr err
-    Right (TypedAST _ ast) -> IO.print . pretty . expandTransformations $ ast
+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
--- a/commands/Summary.hs
+++ b/commands/Summary.hs
@@ -15,8 +15,7 @@
 import           Language.Hakaru.Syntax.ABT
 import           Language.Hakaru.Syntax.TypeCheck
 
-import           Language.Hakaru.Types.Sing
-import           Language.Hakaru.Types.DataKind
+import           Language.Hakaru.Types.Sing (Sing)
 
 import           Language.Hakaru.Pretty.Haskell
 import           Language.Hakaru.Command
@@ -79,29 +78,29 @@
 
 prettyProg :: (ABT T.Term abt)
            => String
+           -> Sing a
            -> abt '[] a
            -> String
-prettyProg name ast =
+prettyProg name typ ast =
     renderStyle style
-    (cat [ text (name ++ " = ")
-         , nest 2 (pretty ast)
-         ])
+    (    sep [text (name ++ " ::"), nest 2 (prettyType typ)]
+     $+$ sep [text (name ++ " =") , nest 2 (pretty     ast)] )
 
 compileHakaru
     :: Options
     -> IO ()
 compileHakaru opts = do
-    let file = fileIn opts
-    prog <- readFromFile file
+    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 file (fileOut opts) . TxT.unlines $
+        writeHkHsToFile infile (fileOut opts) . TxT.unlines $
           header (logFloatPrelude opts) (asModule opts) ++
-          [ pack $ prettyProg "prog" ast' ] ++
+          [ pack $ prettyProg "prog" typ ast' ] ++
           (case asModule opts of
-             Nothing -> footer typ
+             Nothing -> footer
              Just _  -> [])
   where et = expandTransformations
 
@@ -123,14 +122,13 @@
   , ""
   , if logfloats
     then TxT.unlines [ "import           Data.Number.LogFloat (LogFloat)"
-                     , "import           Prelude              hiding (product, exp, log, (**))"
+                     , "import           Prelude hiding (product, exp, log, (**), pi)"
+                     , "import           Language.Hakaru.Runtime.LogFloatPrelude"
                      ]
-    else "import           Prelude hiding (product)"
-  , if logfloats
-    then TxT.unlines [ "import           Language.Hakaru.Runtime.LogFloatPrelude"
-                     , "import           Language.Hakaru.Runtime.LogFloatCmdLine" ]
-    else TxT.unlines [ "import           Language.Hakaru.Runtime.Prelude"
-                     , "import           Language.Hakaru.Runtime.CmdLine" ]
+    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"
@@ -138,23 +136,10 @@
   , ""
   ]
 
-footer :: Sing (a :: Hakaru) -> [Text]
-footer typ =
+footer :: [Text]
+footer =
     ["","main :: IO ()"
-    , TxT.concat ["main = makeMain (prog :: ",toHsType typ,")  =<< getArgs"]]
-  where toHsType :: Sing (a :: Hakaru) -> Text
-        toHsType SInt = "Int"
-        toHsType SNat = "Int"
-        toHsType SReal = "Double"
-        toHsType SProb = "LogFloat"
-        toHsType (SArray t) = let t' = toHsType t in
-                                TxT.concat ["(",TxT.unwords ["MayBoxVec",t',t'],")"]
-        toHsType (SMeasure t) = TxT.concat ["(",TxT.unwords ["Measure",toHsType t],")"]
-        toHsType (SFun t1 t2) = TxT.unwords [toHsType t1,"->",toHsType t2]
-        toHsType (SData _
-                   ((SKonst t1 `SEt` SKonst t2 `SEt` SDone) `SPlus` SVoid)) =
-          TxT.concat ["(",toHsType t1,",",toHsType t2,")"]
-        toHsType _ = "type"
+    , TxT.concat ["main = makeMain prog =<< getArgs"]]
 
 footerWalk :: [Text]
 footerWalk =
diff --git a/hakaru.cabal b/hakaru.cabal
--- a/hakaru.cabal
+++ b/hakaru.cabal
@@ -3,11 +3,11 @@
 cabal-version:       >=1.16
 build-type:          Simple
 name:                hakaru
-version:             0.4.0
+version:             0.6.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://indiana.edu/~ppaml/
+homepage:            http://hakaru-dev.github.io/
 license:             BSD3
 license-file:        LICENSE
 author:              The Hakaru Team
@@ -30,7 +30,7 @@
 Library
     Hs-Source-Dirs:    haskell
     Default-Language:  Haskell2010
-    GHC-Options:       -Wall -fwarn-tabs -j6
+    GHC-Options:       -Wall -fwarn-tabs -j6 
 
     if flag(traceDisintegrate)
         Cpp-Options:   -D__TRACE_DISINTEGRATE__
@@ -48,33 +48,36 @@
                        Language.Hakaru.Types.HClasses,
                        Language.Hakaru.Types.Coercion,
                        Language.Hakaru.Syntax.ANF,
-                       Language.Hakaru.Syntax.Uniquify,
-                       Language.Hakaru.Syntax.Unroll,
                        Language.Hakaru.Syntax.AST,
-                       Language.Hakaru.Syntax.AST.Transforms,
-                       Language.Hakaru.Syntax.AST.Sing,
                        Language.Hakaru.Syntax.AST.Eq,
-                       Language.Hakaru.Syntax.Command,
+                       Language.Hakaru.Syntax.AST.Sing,
+                       Language.Hakaru.Syntax.AST.Transforms,
                        Language.Hakaru.Syntax.CSE,
                        Language.Hakaru.Syntax.Gensym,
-                       Language.Hakaru.Syntax.Rename,
                        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.Prelude,
+                       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.Runtime.LogFloatCmdLine,
                        Language.Hakaru.Observe,
                        Language.Hakaru.Maple,
                        Language.Hakaru.Simplify,
@@ -105,31 +108,32 @@
 
     other-modules:     System.MapleSSH
 
-    build-depends:     base               >= 4.7  && < 5.0,
-                       Cabal              >= 1.16,
-                       ghc-prim           >= 0.3  && < 0.6,
-                       transformers       >= 0.3  && < 0.6,
-                       transformers-compat >= 0.3  && < 0.6,
-                       containers         >= 0.5  && < 0.6,
-                       semigroups         >= 0.16,
-                       pretty             >= 1.1  && < 1.2,
-                       logfloat           >= 0.13 && < 0.14,
-                       math-functions     >= 0.1  && < 0.3,
-                       vector             >= 0.10,
-                       indentation-parsec >= 0.0,
-                       ansi-terminal      >= 0.6,
-                       text               >= 0.11 && < 1.3,
-                       parsec             >= 3.1  && < 3.2,
-                       mwc-random         >= 0.13 && < 0.14,
-                       directory          >= 1.2  && < 1.4,
-                       integration        >= 0.2.0 && < 0.3.0,
-                       primitive          >= 0.5  && < 0.7,
-                       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.15
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       Cabal                >= 1.16,
+                       ghc-prim             >= 0.3  && < 0.6,
+                       transformers         >= 0.3  && < 0.6,
+                       transformers-compat  >= 0.3  && < 0.7,
+                       containers           >= 0.5  && < 0.6,
+                       semigroups           >= 0.16,
+                       pretty               >= 1.1  && < 1.2,
+                       logfloat             >= 0.13 && < 0.14,
+                       math-functions       >= 0.1  && < 0.3,
+                       vector               >= 0.10,
+                       indentation-parsec   >= 0.0,
+                       text                 >= 0.11 && < 1.3,
+                       parsec               >= 3.1  && < 3.2,
+                       mwc-random           >= 0.13 && < 0.14,
+                       directory            >= 1.2  && < 1.4,
+                       integration          >= 0.2.0 && < 0.3.0,
+                       primitive            >= 0.5  && < 0.7,
+                       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.15,
+                       syb                  >= 0.6,
+                       exact-combinatorics  >= 0.2.0
 
 ----------------------------------------------------------------
 Test-Suite system-testsuite
@@ -138,7 +142,7 @@
     Hs-Source-Dirs:    haskell
     Default-Language:  Haskell2010
     GHC-Options:       -Wall -fwarn-tabs
-	
+
     other-modules:     Data.Number.Nat
                        Data.Number.Natural
                        Data.Text.Utf8
@@ -154,6 +158,7 @@
                        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
@@ -168,6 +173,7 @@
                        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
@@ -179,7 +185,11 @@
                        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
@@ -194,36 +204,40 @@
                        Tests.Disintegrate
                        Tests.Models
                        Tests.Parser
+                       Tests.Pretty
+                       Tests.Relationships
                        Tests.RoundTrip
                        Tests.Sample
                        Tests.Simplify
                        Tests.TestTools
                        Tests.TypeCheck
 
-    Build-Depends:     base               >= 4.6  && < 5.0,
-                       Cabal              >= 1.16,
-                       ghc-prim           >= 0.3  && < 0.6,
-                       indentation-parsec >= 0.0,
-                       transformers       >= 0.3  && < 0.6,
-                       containers         >= 0.5  && < 0.6,
-                       semigroups         >= 0.16,
-                       logfloat           >= 0.13 && < 0.14,
-                       parsec             >= 3.1  && < 3.2,
-                       primitive          >= 0.5  && < 0.7,
-                       pretty             >= 1.1  && < 1.2,
-                       mwc-random         >= 0.13 && < 0.14,
-                       math-functions     >= 0.1  && < 0.3,
-                       integration        >= 0.2  && < 0.3,
-                       ansi-terminal      >= 0.6,
-                       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.15
+    build-depends:     base                 >= 4.6  && < 5.0,
+                       Cabal                >= 1.16,
+                       ghc-prim             >= 0.3  && < 0.6,
+                       indentation-parsec   >= 0.0,
+                       transformers         >= 0.3  && < 0.6,
+                       containers           >= 0.5  && < 0.6,
+                       semigroups           >= 0.16,
+                       logfloat             >= 0.13 && < 0.14,
+                       parsec               >= 3.1  && < 3.2,
+                       primitive            >= 0.5  && < 0.7,
+                       pretty               >= 1.1  && < 1.2,
+                       mwc-random           >= 0.13 && < 0.14,
+                       math-functions       >= 0.1  && < 0.3,
+                       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.15,
+                       syb                  >= 0.6,
+                       filepath             >= 1.1.0.2,
+                       exact-combinatorics  >= 0.2.0
 
 ----------------------------------------------------------------
 Executable hakaru
@@ -237,8 +251,7 @@
                        text                 >= 0.11 && < 1.3,
                        pretty               >= 1.1  && < 1.2,
                        vector               >= 0.10,
-                       optparse-applicative >= 0.11 && < 0.15,
-                       hakaru               >= 0.3
+                       optparse-applicative >= 0.11 && < 0.15
 
 ----------------------------------------------------------------
 Executable compile
@@ -252,8 +265,7 @@
                        text                 >= 0.11 && < 1.3,
                        pretty               >= 1.1  && < 1.2,
                        filepath             >= 1.3,
-                       optparse-applicative >= 0.11 && < 0.15,
-                       hakaru               >= 0.3
+                       optparse-applicative >= 0.11 && < 0.15
 
 ----------------------------------------------------------------
 Executable summary
@@ -267,8 +279,7 @@
                        text                 >= 0.11 && < 1.3,
                        pretty               >= 1.1  && < 1.2,
                        filepath             >= 1.3,
-                       optparse-applicative >= 0.11 && < 0.15,
-                       hakaru               >= 0.3
+                       optparse-applicative >= 0.11 && < 0.15
 
 ----------------------------------------------------------------
 Executable hk-maple
@@ -282,8 +293,7 @@
                        text                 >= 0.11 && < 1.3,
                        pretty               >= 1.1  && < 1.2,
                        optparse-applicative >= 0.13 && < 0.15,
-                       containers           >= 0.5  && < 0.6,
-                       hakaru               >= 0.3
+                       containers           >= 0.5  && < 0.6
 
 ----------------------------------------------------------------
 Executable density
@@ -295,8 +305,7 @@
     build-depends:     base             >= 4.7  && < 5.0,
                        mwc-random       >= 0.13 && < 0.14,
                        text             >= 0.11 && < 1.3,
-                       pretty           >= 1.1  && < 1.2,
-                       hakaru           >= 0.3
+                       pretty           >= 1.1  && < 1.2
 
 ----------------------------------------------------------------
 Executable disintegrate
@@ -309,8 +318,7 @@
                        mwc-random           >= 0.13 && < 0.14,
                        text                 >= 0.11 && < 1.3,
                        pretty               >= 1.1  && < 1.2,
-                       optparse-applicative >= 0.11 && < 0.15,
-                       hakaru               >= 0.3
+                       optparse-applicative >= 0.11 && < 0.15
 
 ----------------------------------------------------------------
 Executable pretty
@@ -319,12 +327,24 @@
     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,
-                       hakaru           >= 0.3
+    build-depends:     base                 >= 4.7  && < 5.0,
+                       text                 >= 0.11 && < 1.3,
+                       pretty               >= 1.1  && < 1.2,
+                       optparse-applicative >= 0.11 && < 0.15
 
 ----------------------------------------------------------------
+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.15
+
+----------------------------------------------------------------
 Executable momiji
     Main-is:           Momiji.hs
     Hs-Source-Dirs:    commands
@@ -332,8 +352,7 @@
     GHC-Options:       -O2 -Wall -fwarn-tabs
 
     build-depends:     base             >= 4.7  && < 5.0,
-                       text             >= 0.11 && < 1.3,
-                       hakaru           >= 0.3
+                       text             >= 0.11 && < 1.3
 
 ----------------------------------------------------------------
 Executable normalize
@@ -346,8 +365,7 @@
                        mwc-random       >= 0.13 && < 0.14,
                        text             >= 0.11 && < 1.3,
                        mtl              >= 2.1,
-                       pretty           >= 1.1  && < 1.2,
-                       hakaru           >= 0.3
+                       pretty           >= 1.1  && < 1.2
 
 
 ----------------------------------------------------------------
@@ -364,8 +382,7 @@
                        optparse-applicative >= 0.11 && < 0.15,
                        pretty               >= 1.1  && < 1.2,
                        process              >= 1.1  && < 2.0,
-                       semigroups           >= 0.16,
-                       hakaru               >= 0.3
+                       semigroups           >= 0.16
 
 
 ----------------------------------------------------------------
@@ -379,8 +396,7 @@
                        mwc-random       >= 0.13 && < 0.14,
                        text             >= 0.11 && < 1.3,
                        mtl              >= 2.1,
-                       pretty           >= 1.1  && < 1.2,
-                       hakaru           >= 0.3
+                       pretty           >= 1.1  && < 1.2
 
 ----------------------------------------------------------------
 ----------------------------------------------------------- fin.
diff --git a/haskell/Data/Number/Nat.hs b/haskell/Data/Number/Nat.hs
--- a/haskell/Data/Number/Nat.hs
+++ b/haskell/Data/Number/Nat.hs
@@ -1,5 +1,5 @@
 -- TODO: merge with the Posta version. And release them as a standalone package
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
 ----------------------------------------------------------------
 --                                                    2015.12.17
@@ -25,13 +25,19 @@
 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)
+    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
@@ -138,10 +144,14 @@
 ----------------------------------------------------------------
 newtype MaxNat = MaxNat { unMaxNat :: Nat }
 
-instance Monoid MaxNat where
-    mempty                        = MaxNat 0
-    mappend (MaxNat m) (MaxNat n) = MaxNat (max m n)
+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
diff --git a/haskell/Data/Number/Natural.hs b/haskell/Data/Number/Natural.hs
--- a/haskell/Data/Number/Natural.hs
+++ b/haskell/Data/Number/Natural.hs
@@ -28,6 +28,11 @@
 #if __GLASGOW_HASKELL__ < 710
 import Data.Monoid (Monoid(..))
 #endif
+
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Semigroup
+#endif
+
 import Data.Ratio
 
 ----------------------------------------------------------------
@@ -150,9 +155,14 @@
 ----------------------------------------------------------------
 newtype MaxNatural = MaxNatural { unMaxNatural :: Natural }
 
+instance Semigroup MaxNatural where
+    MaxNatural m <> MaxNatural n = MaxNatural (max m n)
+
 instance Monoid MaxNatural where
-    mempty                                = MaxNatural 0
-    mappend (MaxNatural m) (MaxNatural n) = MaxNatural (max m n)
+    mempty  = MaxNatural 0
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (<>)
+#endif
 
 
 ----------------------------------------------------------------
diff --git a/haskell/Data/Text/Utf8.hs b/haskell/Data/Text/Utf8.hs
--- a/haskell/Data/Text/Utf8.hs
+++ b/haskell/Data/Text/Utf8.hs
@@ -3,7 +3,6 @@
 module Data.Text.Utf8 where
 
 import           Prelude               hiding (putStr, putStrLn)
-import           Control.Applicative   (liftA)
 
 #if __GLASGOW_HASKELL__ < 710
 import           Control.Applicative   (Applicative(..), (<$>))
@@ -13,7 +12,6 @@
 import qualified Data.Text             as Text
 import           Data.Text.Encoding    (decodeUtf8, encodeUtf8)
 import           System.IO (Handle)
-import           Data.Monoid ((<>))
 
 readFile :: FilePath -> IO Text.Text
 readFile f = decodeUtf8 <$> (BIO.readFile f)
diff --git a/haskell/Language/Hakaru/CodeGen/AST.hs b/haskell/Language/Hakaru/CodeGen/AST.hs
--- a/haskell/Language/Hakaru/CodeGen/AST.hs
+++ b/haskell/Language/Hakaru/CodeGen/AST.hs
@@ -8,10 +8,11 @@
 -- Stability   :  experimental
 -- Portability :  GHC-only
 --
---   An AST for the C Family and preprocessor
--- Much of this is based on Manuel M T Chakravarty and Benedikt
--- Hubar's "language-c" package
+--   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
@@ -177,7 +178,7 @@
 data CDirectDeclr
   = CDDeclrIdent Ident
   | CDDeclrArr   CDirectDeclr (Maybe CExpr)
-  | CDDeclrFun   CDirectDeclr [CTypeSpec]
+  | CDDeclrFun   CDirectDeclr [[CTypeSpec]]
   | CDDeclrRec   CDeclr
   deriving (Show, Eq, Ord)
 
diff --git a/haskell/Language/Hakaru/CodeGen/CodeGenMonad.hs b/haskell/Language/Hakaru/CodeGen/CodeGenMonad.hs
--- a/haskell/Language/Hakaru/CodeGen/CodeGenMonad.hs
+++ b/haskell/Language/Hakaru/CodeGen/CodeGenMonad.hs
@@ -44,9 +44,9 @@
   , extDeclareTypes
 
   , funCG
-  , isParallel
-  , mkParallel
-  , mkSequential
+  , whenPar
+  , parDo
+  , seqDo
 
   , reserveIdent
   , genIdent
@@ -81,7 +81,6 @@
 import Language.Hakaru.Types.Sing
 import Language.Hakaru.CodeGen.Types
 import Language.Hakaru.CodeGen.AST
-import Language.Hakaru.CodeGen.Pretty
 import Language.Hakaru.CodeGen.Libs
 
 import Data.Number.Nat (fromNat)
@@ -89,23 +88,23 @@
 import qualified Data.Text          as T
 import qualified Data.Set           as S
 
-import Text.PrettyPrint (render)
-
 -- 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
-             , distributed   :: Bool         -- ^ distributed supported block
-             , logProbs      :: Bool         -- ^ true by default, but might not matter in some situations
-             }
+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 True
+emptyCG = CG cNameStream mempty mempty [] [] emptyEnv False False False False True
 
 type CodeGen = State CG
 
@@ -132,18 +131,26 @@
 
 --------------------------------------------------------------------------------
 
-isParallel :: CodeGen Bool
-isParallel = sharedMem <$> get
+whenPar :: CodeGen () -> CodeGen ()
+whenPar m = (sharedMem <$> get) >>= (\b -> when b m)
 
-mkParallel :: CodeGen ()
-mkParallel =
-  do cg <- get
-     put (cg { sharedMem = True } )
+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
 
-mkSequential :: CodeGen ()
-mkSequential =
-  do cg <- get
-     put (cg { sharedMem = False } )
+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
 
 --------------------------------------------------------------------------------
 
@@ -267,27 +274,6 @@
                                else d:extds
                   put $ cg { extDecls = extds' }
 
-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 [CTypeSpec ts]
-               (CDeclr Nothing (CDDeclrIdent ident))
-               args
-               (CCompound ((fmap CBlockDecl decls) ++ (fmap CBlockStat stmts)))
-
-
-
-
 ---------
 -- ENV --
 ---------
@@ -306,9 +292,35 @@
 lookupVar (Variable _ nat _) (Env env) =
   IM.lookup (fromNat nat) env
 
-----------------------------------------------------------------
--- Control Flow
+--------------------------------------------------------------------------------
+--                      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
@@ -361,9 +373,7 @@
      put $ cg' { statements   = statements cg
                , declarations = declarations cg
                , sharedMem    = sharedMem cg } -- only use pragmas at the top level
-     par <- isParallel
-     when par . putStat . CPPStat . PPPragma
-       $ ["omp","parallel","for"]
+     whenPar . putStat . CPPStat . ompToPP $ OMP (Parallel [For])
      putStat $ CFor (Just iter)
                     (Just cond)
                     (Just inc)
@@ -371,54 +381,79 @@
                                ++ (fmap CBlockStat (reverse $ statements cg'))))
 
 {-
-The operation for a reduction is either a builtin binary op, or must be
-specified
+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 (CExpr -> CExpr -> CExpr)
-  -> Ident
-  -> CExpr
-  -> CExpr
-  -> CExpr
-  -> CodeGen ()
+  :: 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 = []
+     let (_,cg') = runState body $ cg { statements   = []
                                       , declarations = []
-                                      , sharedMem = False } -- only use pragmas at the top level
+                                      , sharedMem    = False } -- only use pragmas at the top level
      put $ cg' { statements   = statements cg
                , declarations = declarations cg
                , sharedMem    = sharedMem cg }
-     par <- isParallel
-     when par $
+     whenPar $
        case op of
-         Left binop -> putStat . CPPStat . PPPragma $
-                         [ "omp","parallel","for","reduction("
-                         , render . pretty $ binop
-                         , ":"
-                         , render . pretty $ acc
-                         ,")"]
-         -- INCOMPLETE
-         Right red  -> do (Ident redName) <- genIdent' "red"
-                          let declRedPragma = [ "omp","declare","reduction("
-                                              , redName,":",undefined,":"
-                                              , render . pretty $
-                                                  red (CVar . Ident $ "omp_in")
-                                                      (CVar . Ident $ "omp_out")
-                                              , ")"]
-                              redPragma = [ "omp","parallel","for","reduction("
-                                          , redName
-                                          , ":"
-                                          , render . pretty $ acc
-                                          ,")"]
-                          putStat . CPPStat . PPPragma $ declRedPragma
-                          putStat . CPPStat . PPPragma $ redPragma
+         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:unitId:mulId:[]) <- mapM genIdent' ["red","unit","mul"]
+     let declType = typePtrDeclaration typ
+
+     inId <- genIdent' "in"
+     funCG [CVoid] unitId [declType inId] $
+       unit . CVar $ inId
+
+     (outId:in2Id:[]) <- mapM genIdent' ["out","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
diff --git a/haskell/Language/Hakaru/CodeGen/Flatten.hs b/haskell/Language/Hakaru/CodeGen/Flatten.hs
--- a/haskell/Language/Hakaru/CodeGen/Flatten.hs
+++ b/haskell/Language/Hakaru/CodeGen/Flatten.hs
@@ -45,18 +45,15 @@
 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.Syntax.IClasses
 import Language.Hakaru.Types.Coercion
 import Language.Hakaru.Types.Sing
 
 import           Control.Monad.State.Strict
-import           Control.Monad (replicateM)
-import           Control.Applicative (pure)
 import           Data.Number.Natural
-import           Data.Monoid        hiding (Product,Sum)
 import           Data.Ratio
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Sequence      as S
@@ -65,7 +62,10 @@
 
 
 #if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative (pure)
+import           Control.Monad (replicateM)
 import           Data.Functor
+import           Data.Monoid        hiding (Product,Sum)
 #endif
 
 
@@ -171,27 +171,48 @@
     \loc -> do
       caseBind body $ \v@(Variable _ _ typ) body'->
         do ident <- createIdent v
-           case typ of
-             (SFun _ _) -> return ()
-             _ -> declare typ ident
+           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 -> do
-      -- externally declare closure and function
-      closureTypeSpec <- coalesceLambda body extDeclClosure
-
-      -- declare local closure var
-      closureId <- genIdent' "closure"
-      declare' (buildDeclaration closureTypeSpec closureId)
+    \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 }
 
-      -- capture environment in closure
-      putExprStat $ loc .=. (CVar closureId)
+                -- 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 coalesceLambda
+  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)
@@ -204,65 +225,37 @@
                   coalesceLambda body $ \vars abt'' -> k (Cons1 v vars) abt''
                 _ -> k (Cons1 v Nil1) abt'
 
-        -- given a parameter, create identifiers corresponding to Hakaru vars,
-        -- and return a CTypeSpec for the param
-        -- Will this fail if the parameter is a SFun?
-        mkVarIdandSpec :: Variable (a :: Hakaru) -> CodeGen (Ident,[CTypeSpec])
-        mkVarIdandSpec v@(Variable _ _ typ) = do
-          extDeclareTypes typ
-          vId <- createIdent v
-          return (vId,buildType typ)
+        argDecl :: Variable (a :: Hakaru) -> [CodeGen CDecl]
+        argDecl v@(Variable _ _ typ) =
+          [do { ident <- createIdent v ; return (typeDeclaration typ ident) }]
 
-        extDeclClosure
-          :: ( ABT Term abt )
-          => List1 Variable (ys :: [Hakaru])
-          -> abt '[] b
-          -> CodeGen CTypeSpec
-        extDeclClosure vars body'= do
-          funcId <- genIdent' "fn"
-          idAndSpecs <- sequence $ foldMap11 (\v -> [mkVarIdandSpec v]) vars
-          let fVars   = freeVars body'
-              typ     = typeOf body'
-          sId@(Ident sname) <- extDeclClosureStruct typ (fmap snd idAndSpecs) fVars
-          funCG (head . buildType $ typ)
-                funcId
-                ([buildDeclaration (callStruct sname) (Ident "env")]
-                 ++ (fmap (\(vId,specs) -> buildDeclaration' specs vId) idAndSpecs))
-                ((putStat . CReturn . Just) =<< flattenWithName body')
-          return (callStruct sname)
+        -- 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"
 
-        extDeclClosureStruct
-          :: forall (a :: Hakaru) (ys :: [Hakaru])
-          .  Sing a
-          -> [[CTypeSpec]]
-          -> VarSet (KindOf a)
-          -> CodeGen Ident
-        extDeclClosureStruct retTyp paramTypeSpecs freeVars = do
-          sId@(Ident sname) <- genIdent' "clos"
-          freeVarDecls <- mapM (\(SomeVariable v@(Variable _ _ typ)) -> do
-                                  extDeclareTypes typ
-                                  vId <- createIdent v
-                                  return (typeDeclaration typ vId)
-                               ) (fromVarSet freeVars)
-          let funPtrDecl =
-                CDecl (fmap CTypeSpec $ buildType retTyp)
-                      [( CDeclr Nothing
-                         (CDDeclrFun
-                           (CDDeclrRec (CDeclr (Just $ CPtrDeclr []) (CDDeclrIdent . Ident $ "fn")))
-                           ([callStruct sname]++(concat paramTypeSpecs)))
-                       , Nothing)]
-          extDeclare $ CDeclExt
-                     $ CDecl [ CTypeSpec $ buildStruct (Just sId)
-                                             ([funPtrDecl]++freeVarDecls) ]
-                             []
-          return sId
+        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 "clos"
-     paramE <- flattenWithName' fun "param"
-     putExprStat $ loc .=. (CCall (CMember closE (Ident "fn") True) [paramE])
+   \loc ->
+     do { closE <- flattenWithName' fun "closure"
+        ; paramE <- flattenWithName' arg "param"
+        ; putExprStat $ loc .=. CCall (indirect (closE ... "_code_ptr"))
+                                      [closE,paramE] }
 
 flattenSCon (PrimOp_ op) = flattenPrimOp op
 
@@ -306,7 +299,7 @@
                      iterVar = CVar iterI
 
                  reductionCG (Left CAddOp)
-                             accI
+                             accVar
                              (iterVar .=. loE)
                              (iterVar .<. hiE)
                              (CUnary CPostIncOp iterVar) $
@@ -345,7 +338,7 @@
                      iterVar = CVar iterI
 
                  reductionCG (Left CMulOp)
-                             accI
+                             accVar
                              (iterVar .=. loE)
                              (iterVar .<. hiE)
                              (CUnary CPostIncOp iterVar) $
@@ -404,7 +397,7 @@
 flattenSCon Plate           =
   \(size :* b :* End) ->
     \loc ->
-      caseBind b $ \v@(Variable _ _ typ) body ->
+      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")
@@ -426,7 +419,7 @@
            let sampE = CVar sampId
 
            reductionCG (Left CAddOp)
-                       weightId
+                       weightE
                        (itE .=. (intE 0))
                        (itE .<. sizeE)
                        (CUnary CPostIncOp itE)
@@ -557,9 +550,9 @@
           => abt '[] a
           -> Integer
           -> (CExpr -> CodeGen ())
-        assignIndex e index loc = do
+        assignIndex e i loc = do
           eE <- flattenWithName e
-          putExprStat $ indirect ((arrayData loc) .+. (intE index)) .=. eE
+          putExprStat $ indirect ((arrayData loc) .+. (intE i)) .=. eE
 
 --------------
 -- ArrayOps --
@@ -647,11 +640,21 @@
     declare SNat itId
     let itE = CVar itId
     initRed red loc
-    forCG (itE .=. loE)
-          (itE .<. hiE)
-          (CUnary CPostIncOp itE)
-          (accumRed red itE 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
@@ -670,7 +673,7 @@
                        (Variable _ _ typ') ->
                          [declare typ' =<< createIdent v'])
                      $ vs
-                   sE <- flattenWithName s'
+                   sE <- flattenWithName' s' "red_size"
                    putExprStat $ arraySize loc .=. sE
                    putMallocStat (arrayData loc) sE btyp
                    itId  <- genIdent
@@ -686,10 +689,11 @@
 
         accumRed
           :: (ABT Term abt)
-          => Reducer abt xs a
+          => Bool
+          -> Reducer abt xs a
           -> CExpr
           -> (CExpr -> CodeGen ())
-        accumRed mr itE = \loc ->
+        accumRed isPar mr itE = \loc ->
           case mr of
             (Red_Index _ a body) ->
               caseBind a $ \v@(Variable _ _ typ) a' ->
@@ -703,9 +707,9 @@
                            [declare typ' =<< createIdent v'])
                        $ vs
                      aE <- flattenWithName' a'' "index"
-                     accumRed body itE (index (arrayData loc) aE)
-            (Red_Fanout mr1 mr2) -> accumRed mr1 itE (datumFst loc)
-                                 >> accumRed mr2 itE (datumSnd loc)
+                     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
@@ -719,8 +723,8 @@
                        $ vs
                      bE <- flattenWithName' b'' "cond"
                      ifCG (bE ... "index" .==. (intE 0))
-                          (accumRed mr1 itE (datumFst loc))
-                          (accumRed mr2 itE (datumSnd loc))
+                          (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' ->
@@ -734,10 +738,32 @@
                            [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
@@ -775,9 +801,9 @@
   -> CExpr
   -> CodeGen ()
 assignDatum code ident =
-  let index     = getIndex code
-      indexExpr = CMember ident (Ident "index") True
-  in  do putExprStat (indexExpr .=. (intE index))
+  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
@@ -831,6 +857,7 @@
                             True
      rest' <- assignProd' rest topIdent (CVar sumIdent)
      return $ [flattenABT d varName] ++ rest'
+
 assignProd' _ _ _  = error $ "TODO: assignProd Ident"
 
 
@@ -897,8 +924,7 @@
       do aE <- flattenWithName a
          bId <- genIdent
          declare (typeOf a) bId
-         let datumIndex e = CMember e (Ident "index") True
-             bE = CVar bId
+         let bE = CVar bId
          putExprStat $ datumIndex bE .=. (CCond (datumIndex aE .==. (intE 1))
                                                (intE 0)
                                                (intE 1))
@@ -990,6 +1016,8 @@
      do aE <- flattenWithName a
         putExprStat $ loc .=. (CUnary CMinOp $ aE)
 
+flattenPrimOp Choose = \(_ :* _ :* End) -> error $ "TODO: flattenPrimOp: choose"
+
 flattenPrimOp t  = \_ -> error $ "TODO: flattenPrimOp: " ++ show t
 
 
@@ -1235,40 +1263,36 @@
 
        let currE = index (arrayData arrE) itE
 
-       isPar <- isParallel
-       mkSequential
-
-       -- 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)
+       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)
 
-       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
+         -- 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)
 
-       when isPar mkParallel
+         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
@@ -1395,7 +1419,7 @@
        let argIds = fmap Ident (take size cNameStream)
            decls  = fmap (typeDeclaration SProb) argIds
            vars   = fmap CVar argIds
-       funCG CDouble funcId decls
+       funCG [CDouble] funcId decls
          (putStat . CReturn . Just . logSumExp . S.fromList $ vars)
        putExprStat $ loc .=. (CCall (CVar funcId) (F.toList seqE))
 
@@ -1403,10 +1427,8 @@
 -- 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
@@ -1416,7 +1438,7 @@
   -> (CExpr -> CodeGen ())
 lseSummateArrayCG body arrayE =
   caseBind body $ \v body' ->
-    \loc -> do
+    \loc -> seqDo $ do
       (maxVId:maxIId:sumId:[]) <- mapM genIdent' ["maxV","maxI","sum"]
       itId <- createIdent v
       mapM_ (declare SProb) [maxVId,sumId]
@@ -1439,9 +1461,9 @@
       forCG (itE .=. intE 0)
             (itE .<. arraySize arrayE)
             (CUnary CPostIncOp itE)
-            (putStat $ CIf (itE .!=. maxIE)
-                           (CExpr . Just $ sumE .+=. (expE ((derefIndex itE) .-. (maxVE))))
-                           Nothing)
+            (ifCG (itE .!=. maxIE)
+                  (putExprStat $ sumE .+=. (expE ((derefIndex itE) .-. (maxVE))))
+                  (return ()))
 
       putExprStat $ loc .=. (maxVE .+. (log1pE sumE))
 
@@ -1477,35 +1499,16 @@
                 flattenABT body' xE
                 putExprStat $ yE .=. (xE .-. cE)
                 putExprStat $ zE .=. (tE .+. yE)
-                putExprStat $ cE .=.  ((zE .-. tE) .-. yE)
-                putExprStat $ tE .=. zE)
+                whenPar $ putStat . CPPStat . ompToPP $ OMP Critical
+                codeBlockCG $ do
+                  putExprStat $ cE .=.  ((zE .-. tE) .-. yE)
+                  putExprStat $ tE .=. zE)
       putExprStat $ loc .=. tE
 
 --------------------------------------------------------------------------------
 --                            Coercion Helpers                                --
 --------------------------------------------------------------------------------
 
--- instance PrimCoerce Value where
---     primCoerceTo c l =
---         case (c,l) of
---         (Signed HRing_Int,            VNat  a) -> VInt  $ fromNat a
---         (Signed HRing_Real,           VProb a) -> VReal $ LF.fromLogFloat a
---         (Continuous HContinuous_Prob, VNat  a) ->
---             VProb $ LF.logFloat (fromIntegral (fromNat a) :: Double)
---         (Continuous HContinuous_Real, VInt  a) -> VReal $ fromIntegral a
---         _ -> error "no a defined primitive coercion"
-
---     primCoerceFrom c l =
---         case (c,l) of
---         (Signed HRing_Int,            VInt  a) -> VNat  $ unsafeNat a
---         (Signed HRing_Real,           VReal a) -> VProb $ LF.logFloat a
---         (Continuous HContinuous_Prob, VProb a) ->
---             VNat $ unsafeNat $ floor (LF.fromLogFloat a :: Double)
---         (Continuous HContinuous_Real, VReal a) -> VInt  $ floor a
---         _ -> error "no a defined primitive coercion"
-
-
-
 coerceToCG
   :: forall (a :: Hakaru) (b :: Hakaru)
   .  Coercion a b
@@ -1562,3 +1565,27 @@
           (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
--- a/haskell/Language/Hakaru/CodeGen/Libs.hs
+++ b/haskell/Language/Hakaru/CodeGen/Libs.hs
@@ -27,10 +27,13 @@
     gcHeader, gcInit, gcMalloc,
 
     -- OpenMP
-    openMpHeader, ompGetNumThreads, ompGetThreadNum,
+    openMpHeader, ompGetNumThreads, ompGetThreadNum, OMP(..), Directive(..),
+    ompToPP
   ) where
 
 import Language.Hakaru.CodeGen.AST
+import Language.Hakaru.CodeGen.Pretty
+import Text.PrettyPrint (render)
 
 {-
 
@@ -129,6 +132,8 @@
    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
@@ -139,3 +144,30 @@
 
 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
--- a/haskell/Language/Hakaru/CodeGen/Pretty.hs
+++ b/haskell/Language/Hakaru/CodeGen/Pretty.hs
@@ -18,6 +18,7 @@
   , Pretty
   ) where
 
+import Prelude hiding ((<>))
 import Text.PrettyPrint
 import Language.Hakaru.CodeGen.AST
 
@@ -43,8 +44,8 @@
 parensPrec :: Int -> Int -> Doc -> Doc
 parensPrec x y = if x <= y then parens else id
 
-newline :: Doc
-newline = char '\n'
+emptyText :: Doc
+emptyText = text ""
 
 instance Pretty a => Pretty (Maybe a) where
   pretty Nothing  = empty
@@ -59,11 +60,11 @@
   pretty (Ident i) = text i
 
 instance Pretty CAST where
-  pretty (CAST extdecls) = (vcat . fmap pretty $ extdecls) $$ newline
+  pretty (CAST extdecls) = vcat . fmap pretty $ extdecls
 
 instance Pretty CExtDecl where
-  pretty (CDeclExt d) =  newline <> pretty d <> semi
-  pretty (CFunDefExt f) = newline <> pretty f
+  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
 
@@ -72,7 +73,7 @@
     ((hsep . fmap pretty $ dspecs)
      <+> pretty dr
      <>  (parens . hsep . punctuate comma . fmap pretty $ ds))
-    $+$ pretty s
+    $+$ (pretty s)
 
 --------------------------------------------------------------------------------
 --                               Preprocessor                                 --
@@ -114,7 +115,7 @@
   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 pretty $ ts)
+    pretty dd <> (parens . hsep . punctuate comma . fmap (hsep . fmap pretty) $ ts)
   pretty (CDDeclrRec declr) = parens . pretty $ declr
 
 
@@ -160,9 +161,10 @@
   pretty (CSUSpec tag mi []) =
     pretty tag <+> mpretty mi
   pretty (CSUSpec tag mi ds) =
-    (pretty tag <+> mpretty mi <+> lbrace)
-    $+$ (nest (-1) $ (nest 2 . sep . fmap (\d -> pretty d <> semi)  $ ds)
-                     $+$ rbrace)
+    (pretty tag <+> pretty mi)
+    $+$ (   lbrace
+        $+$ (nest 2 . sep . fmap (\d -> pretty d <> semi) $ ds)
+        $+$ rbrace )
 
 instance Pretty CSUTag where
   pretty CStructTag = text "struct"
@@ -192,25 +194,25 @@
   pretty (CDefault s) = text "default" <> colon $$ nest 2 (pretty s)
   pretty (CExpr me) = mpretty me <> semi
   pretty (CCompound bs) =
-    nest (-1) (lbrace $+$ (nest 2 . vcat . fmap pretty $ bs) $+$ rbrace)
+    lbrace $+$ (nest 2 . vcat . fmap pretty $ bs) $+$ rbrace
 
-  pretty (CIf ce thns (Just elss)) = nest 1 $
+  pretty (CIf ce thns (Just elss)) =
     text "if" <+> (parens . prettyPrec (-5) $ ce)
-              $+$ (nest 1 $ pretty thns)
+              $+$ (pretty thns)
               $+$ text "else"
-              $+$ (nest 1 $ pretty elss)
+              $+$ (pretty elss)
   pretty (CIf ce thns Nothing) =
-    text "if" <+> (parens . prettyPrec (-5) $ ce) $+$ (nest 1 $ pretty thns)
+    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) $$ (nest 1 $ pretty s)
+    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])
-    $$  (nest 1 $ pretty s)
+    $$  (pretty s)
 
   pretty CCont = text "continue" <> semi
   pretty CBreak = text "break" <> semi
diff --git a/haskell/Language/Hakaru/CodeGen/Types.hs b/haskell/Language/Hakaru/CodeGen/Types.hs
--- a/haskell/Language/Hakaru/CodeGen/Types.hs
+++ b/haskell/Language/Hakaru/CodeGen/Types.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds,
              FlexibleContexts,
              GADTs,
+             RankNTypes,
              KindSignatures #-}
 
 ----------------------------------------------------------------
@@ -52,10 +53,11 @@
   , datumProd
   , datumFst
   , datumSnd
+  , datumIndex
 
   -- functions and closures
   , functionDef
-  , closureDeclaration
+  , closureStructure
 
   , buildType
   , castTo
@@ -68,7 +70,9 @@
 
 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
@@ -262,10 +266,10 @@
 datumSum dat funs ident =
   let declrs = fst $ runState (datumSum' dat funs) cNameStream
       union  = buildDeclaration (buildUnion declrs) (Ident "sum")
-      index  = buildDeclaration CInt (Ident "index")
+      ind    = buildDeclaration CInt (Ident "index")
       struct = buildStruct (Just ident) $ case declrs of
-                                            [] -> [index]
-                                            _  -> [index,union]
+                                            [] -> [ind]
+                                            _  -> [ind,union]
   in CDecl [ CTypeSpec struct ] []
 
 datumSum'
@@ -326,6 +330,9 @@
 datumSnd :: CExpr -> CExpr
 datumSnd x = x ... "sum" ... "a" ... "b"
 
+datumIndex :: CExpr -> CExpr
+datumIndex x = x ... "index"
+
 --------------------------------------------------------------------------------
 --                                Functions                                   --
 --------------------------------------------------------------------------------
@@ -353,11 +360,32 @@
 -- Closures --
 --------------
 
-closureDeclaration
-  :: (Sing (a :: Hakaru))
-  -> Ident
-  -> CDecl
-closureDeclaration = buildDeclaration . callStruct . typeName
+-- 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'])
 
 
 
diff --git a/haskell/Language/Hakaru/CodeGen/Wrapper.hs b/haskell/Language/Hakaru/CodeGen/Wrapper.hs
--- a/haskell/Language/Hakaru/CodeGen/Wrapper.hs
+++ b/haskell/Language/Hakaru/CodeGen/Wrapper.hs
@@ -72,7 +72,7 @@
        ( TypedAST typ' abt,       Just name ) ->
          -- still buggy for measures
          do mfId <- reserveIdent name
-            funCG (head . buildType $ typ') mfId [] $
+            funCG (buildType typ') mfId [] $
               do outE <- flattenWithName' abt "out"
                  putStat . CReturn . Just $ outE
 
@@ -107,7 +107,6 @@
 -- when measure, compile to a sampler
 mainFunction pconfig typ@(SMeasure _) abt =
   do mfId    <- reserveIdent "measure"
-     mdataId <- reserveIdent "mdata"
      mainId  <- reserveIdent "main"
      argVId <- reserveIdent "argv"
      argCId <- reserveIdent "argc"
@@ -115,10 +114,10 @@
      extDeclareTypes typ
 
      -- defined a measure function that returns mdata
-     funCG (head . buildType $ typ) mfId  [] $
+     funCG (buildType typ) mfId  [] $
        (putStat . CReturn . Just) =<< flattenWithName' abt "samp"
 
-     funCG CInt mainId mainArgs $
+     funCG [CInt] mainId mainArgs $
        do isManagedMem <- managedMem <$> get
           when isManagedMem (putExprStat gcInit)
 
@@ -131,8 +130,8 @@
           printCG pconfig typ (CCall (CVar mfId) []) (Just nSamples)
           putStat . CReturn . Just $ intE 0
 
-mainFunction pconfig typ@(SFun _ _) abt =
-  coalesceLambda abt $ \vars abt' ->
+mainFunction pconfig (SFun _ _) abt =
+  coalesceLambda abt $ \_ abt' ->
     do resId  <- reserveIdent "result"
        mainId <- reserveIdent "main"
        argVId <- reserveIdent "argv"
@@ -142,7 +141,7 @@
        let (resE:funE:argCE:argVE:[]) = fmap CVar [resId,funId,argCId,argVId]
            typ' = typeOf abt'
 
-       funCG CInt mainId mainArgs $
+       funCG [CInt] mainId mainArgs $
          do isManagedMem <- managedMem <$> get
             when isManagedMem (putExprStat gcInit)
             declare typ' resId
@@ -166,7 +165,7 @@
             putStat $ opComment "Parse Args"
             argEs <- foldLambdaWithIndex 1 abt $ \i (Variable _ _ t) ->
                        do argE <- localVar' t "arg"
-                          parseCG t (index argVE (intE i)) argE
+                          _ <- parseCG t (index argVE (intE i)) argE
                           return argE
 
             case typ' of
@@ -185,9 +184,7 @@
           :: ABT Term abt
           => Integer
           -> abt '[] a
-          -> ( forall (x :: Hakaru)
-             .  Integer
-             -> CodeGen ())
+          -> (Integer -> CodeGen ())
           -> CodeGen ()
         withLambdaDepth' n abt_ k =
           caseVarSyn abt_
@@ -210,7 +207,7 @@
      mainId <- reserveIdent "main"
      let resE  = CVar resId
 
-     funCG CInt mainId [] $
+     funCG [CInt] mainId [] $
        do declare typ resId
 
           isManagedMem <- managedMem <$> get
@@ -358,16 +355,25 @@
 printCG pconfig (SArray typ) arg Nothing =
   do itE <- localVar' SNat "it"
      putString "[ "
-     mkSequential
-     forCG (itE .=. (intE 0))
-           (itE .<. (arraySize arg))
-           (CUnary CPostIncOp itE)
-           (putExprStat
-           $ printfE [ stringE $ printFormat pconfig typ " "
-                     , index (arrayData arg) itE ])
+     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"
@@ -380,6 +386,10 @@
               [ 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
@@ -420,7 +430,7 @@
     let varMs = foldMap11 (\v -> [mkVarDecl v =<< createIdent' "param" v]) vars
         typ   = typeOf abt'
     in  do argDecls <- sequence varMs
-           funCG (head . buildType $ typ) name argDecls $
+           funCG (buildType typ) name argDecls $
              (putStat . CReturn . Just) =<< flattenWithName' abt' "out"
 
   -- do at top level
diff --git a/haskell/Language/Hakaru/Command.hs b/haskell/Language/Hakaru/Command.hs
--- a/haskell/Language/Hakaru/Command.hs
+++ b/haskell/Language/Hakaru/Command.hs
@@ -1,12 +1,14 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# 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 hiding (style)
+import           Language.Hakaru.Parser.Parser (parseHakaru, parseHakaruWithImports)
 import           Language.Hakaru.Parser.SymbolResolve (resolveAST)
 import           Language.Hakaru.Syntax.TypeCheck
 
@@ -20,6 +22,7 @@
 import           System.IO (stderr)
 import           System.Environment (getArgs)
 import           Data.Monoid ((<>),mconcat)
+import           System.FilePath (takeDirectory)
 
 #if __GLASGOW_HASKELL__ < 710
 import           Control.Applicative   (Applicative(..), (<$>))
@@ -29,25 +32,52 @@
 
 parseAndInfer :: Text.Text
               -> Either Text.Text (TypedAST (TrivialABT T.Term))
-parseAndInfer x =
+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) LaxMode
+        runTCM m (splitLines x) mode
 
-parseAndInfer' :: Text.Text
+-- 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' x =
+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 past)
+      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) LaxMode)
+          return (runTCM m (splitLines x) mode)
 
 parseAndInferWithDebug
     :: Bool
@@ -75,6 +105,9 @@
 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 = 
diff --git a/haskell/Language/Hakaru/Disintegrate.hs b/haskell/Language/Hakaru/Disintegrate.hs
--- a/haskell/Language/Hakaru/Disintegrate.hs
+++ b/haskell/Language/Hakaru/Disintegrate.hs
@@ -85,10 +85,10 @@
     ( lam_
     -- * the Hakaru API
     , disintegrateWithVar
-    , disintegrate
+    , disintegrate, disintegrateInCtx
     , densityWithVar
-    , density
-    , observe
+    , density, densityInCtx
+    , observe, observeInCtx
     , determine
     
     -- * Implementation details
@@ -128,6 +128,7 @@
 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
@@ -170,13 +171,14 @@
 -- this note should be deleted.]
 disintegrateWithVar
     :: (ABT Term abt)
-    => Text.Text
+    => TransformCtx
+    -> Text.Text
     -> Sing a
     -> abt '[] ('HMeasure (HPair a b))
     -> [abt '[] (a ':-> 'HMeasure b)]
-disintegrateWithVar hint typ m =
+disintegrateWithVar ctx hint typ m =
     let x = Variable hint (nextFreeOrBind m) typ
-    in map (lam_ x) . flip runDis [Some2 m, Some2 (var x)] $ do
+    in map (lam_ x) . flip (runDisInCtx ctx) [Some2 m, Some2 (var x)] $ do
         ab <- perform m
 #ifdef __TRACE_DISINTEGRATE__
         ss <- getStatements
@@ -203,16 +205,26 @@
 
 -- | A variant of 'disintegrateWithVar' which automatically computes
 -- the type via 'typeOf'.
-disintegrate
+disintegrateInCtx
     :: (ABT Term abt)
-    => abt '[] ('HMeasure (HPair a b))
+    => TransformCtx
+    -> abt '[] ('HMeasure (HPair a b))
     -> [abt '[] (a ':-> 'HMeasure b)]
-disintegrate m =
+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
@@ -224,40 +236,55 @@
 -- we should make it into a Haskell function instead.
 densityWithVar
     :: (ABT Term abt)
-    => Text.Text
+    => TransformCtx
+    -> Text.Text
     -> Sing a
     -> abt '[] ('HMeasure a)
     -> [abt '[] (a ':-> 'HProb)]
-densityWithVar hint typ m =
+densityWithVar ctx hint typ m =
     let x = Variable hint (nextFree m `max` nextBind m) typ
-    in (lam_ x . E.total) <$> observe m (var x)
+    in (lam_ x . E.total) <$> observeInCtx ctx m (var x)
 
 
 -- | A variant of 'densityWithVar' which automatically computes the
 -- type via 'typeOf'.
-density
+densityInCtx
     :: (ABT Term abt)
-    => abt '[] ('HMeasure a)
+    => TransformCtx
+    -> abt '[] ('HMeasure a)
     -> [abt '[] (a ':-> 'HProb)]
-density m =
+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 m x =
-    runDis (constrainOutcome x m >> return x) [Some2 m, Some2 x]
-
+observe = observeInCtx minimalCtx
 
 -- | Arbitrarily choose one of the possible alternatives. In the
 -- future, this function should be replaced by a better one that
@@ -548,8 +575,11 @@
             constrainValue  (P.coerceTo_ c v0) e1
         NaryOp_     o    es        -> constrainNaryOp v0 o es
         PrimOp_     o :$ es        -> constrainPrimOp v0 o es
-        Expect  :$ e1 :* e2 :* End -> error "TODO: constrainValue{Expect}"
 
+        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
@@ -797,7 +827,8 @@
     -- 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    = \End               -> bot -- TODO: see note above
+    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)
@@ -990,6 +1021,8 @@
     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...
@@ -1208,8 +1241,10 @@
     -> Dis abt ()
 constrainOutcomeMeasureOp v0 = go
     where
-    -- Per the paper
-    go Lebesgue = \End -> return ()
+    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 ()
diff --git a/haskell/Language/Hakaru/Evaluation/DisintegrationMonad.hs b/haskell/Language/Hakaru/Evaluation/DisintegrationMonad.hs
--- a/haskell/Language/Hakaru/Evaluation/DisintegrationMonad.hs
+++ b/haskell/Language/Hakaru/Evaluation/DisintegrationMonad.hs
@@ -31,7 +31,7 @@
     -- * The disintegration monad
     -- ** List-based version
       getStatements, putStatements
-    , ListContext(..), Ans, Dis(..), runDis
+    , ListContext(..), Ans, Dis(..), runDis, runDisInCtx
     -- ** TODO: IntMap-based version
     
     -- * Operators on the disintegration monad
@@ -107,6 +107,7 @@
 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
@@ -301,11 +302,13 @@
 -- 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.
-runDis :: (ABT Term abt, F.Foldable f)
-    => Dis abt (abt '[] a)
+runDisInCtx
+    :: (ABT Term abt, F.Foldable f)
+    => TransformCtx
+    -> Dis abt (abt '[] a)
     -> f (Some2 abt)
     -> [abt '[] ('HMeasure a)]
-runDis d es =
+runDisInCtx ctx d es =
     m0 [] c0 (ListContext i0 []) emptyAssocs
     where
     (Dis m0) = d >>= residualizeLocs
@@ -316,7 +319,14 @@
     -- that redex by changing the type of 'residualizeListContext'...
     c0 (e,rho) ss _ = [residualizeListContext ss rho (syn(Dirac :$ e :* End))]
                   
-    i0 = maxNextFree es
+    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
 
 {---------------------------------------------------------------------------------- 
  
diff --git a/haskell/Language/Hakaru/Evaluation/ExpectMonad.hs b/haskell/Language/Hakaru/Evaluation/ExpectMonad.hs
--- a/haskell/Language/Hakaru/Evaluation/ExpectMonad.hs
+++ b/haskell/Language/Hakaru/Evaluation/ExpectMonad.hs
@@ -48,6 +48,7 @@
 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(..))
@@ -120,13 +121,14 @@
     :: 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) f es =
+runExpect (Expect m) ctx f es =
     m c0 h0
     where
-    i0   = nextFreeOrBind f `max` maxNextFreeOrBind es
+    i0   = maximum [nextFreeOrBind f, maxNextFreeOrBind es, nextFreeVar ctx]
     h0   = ListContext i0 []
     c0 e =
         residualizeExpectListContext $
diff --git a/haskell/Language/Hakaru/Evaluation/Lazy.hs b/haskell/Language/Hakaru/Evaluation/Lazy.hs
--- a/haskell/Language/Hakaru/Evaluation/Lazy.hs
+++ b/haskell/Language/Hakaru/Evaluation/Lazy.hs
@@ -59,7 +59,7 @@
 import Language.Hakaru.Syntax.TypeOf
 import Language.Hakaru.Syntax.AST
 import Language.Hakaru.Syntax.Datum
-import Language.Hakaru.Syntax.DatumCase (DatumEvaluator, MatchResult(..), matchBranches, MatchState(..), matchTopPattern)
+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
@@ -121,7 +121,7 @@
         -- We don't bother evaluating these, even though we could...
         Integrate :$ e1 :* e2 :* e3 :* End ->
             return . Head_ $ WIntegrate e1 e2 e3
-        Summate h1 h2 :$ e1 :* e2 :* e3 :* End ->
+        Summate _ _ :$ _ :* _ :* _ :* End ->
             return . Neutral $ syn t
             --return . Head_ $ WSummate   e1 e2 e3
 
@@ -154,17 +154,12 @@
         ArrayOp_ o :$ es -> evaluateArrayOp evaluate_ o es
         PrimOp_  o :$ es -> evaluatePrimOp  evaluate_ o es
 
-        -- BUG: avoid the chance of looping in case 'E.expect' residualizes!
-        -- TODO: use 'evaluate' in 'E.expect' for the evaluation of @e1@
-        Expect :$ e1 :* e2 :* End ->
-            error "TODO: evaluate{Expect}: unclear how to handle this without cyclic dependencies"
-        {-
-        -- BUG: can't call E.expect because of cyclic dependency
-            evaluate_ . E.expect e1 $ \e3 ->
-                syn (Let_ :$ e3 :* e2 :* End)
-        -}
+        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"
 
@@ -288,8 +283,8 @@
 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))
+-- natRoot :: (Floating a) => a -> Nat -> a
+-- natRoot x y = x ** recip (fromIntegral (fromNat y))
 
 
 ----------------------------------------------------------------
@@ -443,8 +438,9 @@
             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 _) = \(e1 :* e2 :* e3 :* End) ->
+    go (Reduce _) = \(_ :* _ :* _ :* End) ->
         error "TODO: evaluateArrayOp{Reduce}"
 
 ----------------------------------------------------------------
@@ -546,10 +542,12 @@
     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)@
@@ -612,7 +610,7 @@
         HEq_Int    -> rr2 (==) (P.==)
         HEq_Prob   -> rr2 (==) (P.==)
         HEq_Real   -> rr2 (==) (P.==)
-        HEq_Array aEq -> error "TODO: rrEqual{HEq_Array}"
+        HEq_Array _ -> error "TODO: rrEqual{HEq_Array}"
         HEq_Bool   -> rr2 (==) (P.==)
         HEq_Unit   -> rr2 (==) (P.==)
         HEq_Pair   aEq bEq ->
@@ -645,7 +643,7 @@
                                     | reify va  -> wb
                                     | otherwise -> Head_ $ WDatum dFalse
 
-        HEq_Either aEq bEq -> error "TODO: rrEqual{HEq_Either}"
+        HEq_Either _ _ -> error "TODO: rrEqual{HEq_Either}"
 
     rrLess
         :: forall b. HOrd b -> abt '[] b -> abt '[] b -> m (Whnf abt HBool)
@@ -655,10 +653,10 @@
         HOrd_Int    -> rr2 (<) (P.<)
         HOrd_Prob   -> rr2 (<) (P.<)
         HOrd_Real   -> rr2 (<) (P.<)
-        HOrd_Array aOrd -> error "TODO: rrLess{HOrd_Array}"
+        HOrd_Array _ -> error "TODO: rrLess{HOrd_Array}"
         HOrd_Bool   -> rr2 (<) (P.<)
         HOrd_Unit   -> rr2 (<) (P.<)
-        HOrd_Pair aOrd bOrd ->
+        HOrd_Pair _ _ ->
             \e1 e2 -> do
                 w1 <- evaluate_ e1
                 w2 <- evaluate_ e2
@@ -672,11 +670,11 @@
                             return . Neutral
                                 $ P.primOp2_ (Less theOrd) (fromHead v1) e2'
                         Head_ v2 -> do
-                            let (v1a, v1b) = reifyPair v1
-                            let (v2a, v2b) = reifyPair v2
+                            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 aOrd bOrd -> error "TODO: rrLess{HOrd_Either}"
+        HOrd_Either _ _ -> error "TODO: rrLess{HOrd_Either}"
 
 
 ----------------------------------------------------------------
diff --git a/haskell/Language/Hakaru/Evaluation/Types.hs b/haskell/Language/Hakaru/Evaluation/Types.hs
--- a/haskell/Language/Hakaru/Evaluation/Types.hs
+++ b/haskell/Language/Hakaru/Evaluation/Types.hs
@@ -394,7 +394,6 @@
                     CoerceTo_ c' :$ es' ->
                         case es' of
                         e' :* End -> Just $ P.coerceTo_ (c . c') e'
-                        _ -> error "coerceTo@Whnf: the impossible happened"
                     _ -> Nothing
         Head_ v ->
             case v of
@@ -415,7 +414,6 @@
                     UnsafeFrom_ c' :$ es' ->
                         case es' of
                         e' :* End -> Just $ P.unsafeFrom_ (c' . c) e'
-                        _ -> error "unsafeFrom@Whnf: the impossible happened"
                     _ -> Nothing
         Head_ v ->
             case v of
@@ -874,7 +872,7 @@
 
     substVar :: Variable a -> abt '[] a
              -> (forall b'. Variable b' -> m (abt '[] b'))
-    substVar x e = return . var
+    substVar _ _ = return . var
 
 
     extFreeVars :: abt xs a -> m (VarSet (KindOf a))
@@ -930,7 +928,7 @@
         -- can return for them because the variables are
         -- untouchable\/abstract.
         SStuff1 _ _ _ -> Just . return . Neutral $ var x
-        SGuard ys pat scrutinee i -> Just . return . Neutral $ var x
+        SGuard _ _ _ _ -> Just . return . Neutral $ var x
 
 
 -- | A simple 'CaseEvaluator' which uses the 'DatumEvaluator' to
diff --git a/haskell/Language/Hakaru/Expect.hs b/haskell/Language/Hakaru/Expect.hs
--- a/haskell/Language/Hakaru/Expect.hs
+++ b/haskell/Language/Hakaru/Expect.hs
@@ -7,6 +7,7 @@
            , NoImplicitPrelude
            , ScopedTypeVariables
            , FlexibleContexts
+           , ViewPatterns
            #-}
 
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
@@ -25,10 +26,10 @@
 module Language.Hakaru.Expect
     ( normalize
     , total
-    , expect
+    , expect, expectInCtx, determineExpect
     ) where
 
-import           Prelude               (($), (.), error, reverse)
+import           Prelude               (($), (.), error, reverse, Maybe(..))
 import qualified Data.Text             as Text
 import           Data.Functor          ((<$>))
 import qualified Data.Foldable         as F
@@ -43,6 +44,7 @@
 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)
@@ -88,9 +90,27 @@
     => abt '[] ('HMeasure a)
     -> abt '[a] 'HProb
     -> abt '[] 'HProb
-expect e f = runExpect (expectTerm e) f [Some2 e, Some2 f]
+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)
@@ -99,7 +119,7 @@
     -- 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.Expect :$ e :* bind x c :* End)) [])
+        syn (AST.Transform_ AST.Expect :$ e :* bind x c :* End)) [])
     return $ var x
 {-
 residualizeExpect e = do
@@ -303,8 +323,10 @@
     => MeasureOp typs a
     -> SArgs abt args
     -> Expect abt (abt '[] a)
-expectMeasureOp Lebesgue = \End ->
-    var <$> pushIntegrate P.negativeInfinity P.infinity
+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
diff --git a/haskell/Language/Hakaru/Inference.hs b/haskell/Language/Hakaru/Inference.hs
--- a/haskell/Language/Hakaru/Inference.hs
+++ b/haskell/Language/Hakaru/Inference.hs
@@ -2,6 +2,10 @@
            , TypeOperators
            , NoImplicitPrelude
            , FlexibleContexts
+           , GADTs
+           , TypeFamilies
+           , FlexibleInstances
+           , ViewPatterns
            #-}
 
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
@@ -20,8 +24,8 @@
 ----------------------------------------------------------------
 module Language.Hakaru.Inference
     ( priorAsProposal
-    , mh
-    , mcmc
+    , mh, mh'
+    , mcmc, mcmc'
     , gibbsProposal
     , slice
     , sliceX
@@ -33,17 +37,25 @@
     ) 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, disintegrate)
+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
@@ -68,34 +80,48 @@
 --
 -- 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)
-    => abt '[] (a ':-> 'HMeasure a)
-    -> abt '[] ('HMeasure a)
-    -> abt '[] (a ':-> 'HMeasure (HPair a 'HProb))
-mh proposal target =
-    case determine $ density target of
-    Nothing -> error "mh: couldn't get density"
-    Just theDensity ->
-        let_ theDensity $ \mu ->
+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-})
+            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)
-    => abt '[] (a ':-> 'HMeasure a)
-    -> abt '[] ('HMeasure a)
-    -> abt '[] (a ':-> 'HMeasure a)
-mcmc proposal target =
-    let_ (mh proposal target) $ \f ->
+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)
+        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)
diff --git a/haskell/Language/Hakaru/Maple.hs b/haskell/Language/Hakaru/Maple.hs
--- a/haskell/Language/Hakaru/Maple.hs
+++ b/haskell/Language/Hakaru/Maple.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE FlexibleInstances
+{-# LANGUAGE CPP
+           , FlexibleInstances
            , FlexibleContexts
            , DeriveDataTypeable
            , DataKinds
@@ -6,7 +7,11 @@
            , RecordWildCards
            , ViewPatterns
            , LambdaCase
-           , DeriveFunctor, DeriveFoldable, DeriveTraversable 
+           , KindSignatures
+           , TypeOperators
+           , GADTs
+           , RankNTypes
+           , DeriveFunctor, DeriveFoldable, DeriveTraversable
            #-}
 
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
@@ -17,51 +22,62 @@
 -- Stability   :  experimental
 -- Portability :  GHC-only
 --
--- Take strings from Maple and interpret them in Haskell (Hakaru), 
--- in a type-safe way. 
+-- Take strings from Maple and interpret them in Haskell (Hakaru),
+-- in a type-safe way.
 ----------------------------------------------------------------
-module Language.Hakaru.Maple 
+module Language.Hakaru.Maple
   ( MapleException(..)
   , MapleOptions(..)
+  , MapleCommand(MapleCommand)
   , defaultMapleOptions
   , sendToMaple, sendToMaple'
   , maple
-  ) where 
-    
-import Control.Exception
+  ) 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 qualified Language.Hakaru.Parser.SymbolResolve as SR (resolveAST', fromVarSet)
+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.Command 
+import Language.Hakaru.Syntax.IClasses
 
 import Language.Hakaru.Evaluation.ConstantPropagation
 
-import Data.Typeable (Typeable)
-
 import System.MapleSSH (maple)
 import System.IO
 import Data.Text (pack)
-import qualified Data.Map as M 
-import Data.List (intercalate) 
+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       
+data MapleException
   = MapleInterpreterException String String
   | MapleInputTypeMismatch String String
   | MapleUnknownCommand String
+  | MapleAmbiguousCommand String [String]
+  | MultipleErrors [MapleException]
       deriving Typeable
 
 instance Exception MapleException
@@ -77,12 +93,19 @@
       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 () 
@@ -90,32 +113,113 @@
   { command = ()    
   , debug = False 
   , timelimit = 90
-  , extraOpts = M.empty }
+  , 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' MapleOptions{..} (TypedAST ty expr) = 
-  commandFromName command ty $ \case 
-    Left True       -> throw $ MapleInputTypeMismatch command (show ty) 
-    Left False      -> throw $ MapleUnknownCommand command 
-    Right (c, ty_o) -> fmap (TypedAST ty_o) (sendToMaple MapleOptions{command=c,..} expr)
+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  
+sendToMaple
     :: (ABT Term abt)
-    => MapleOptions (CommandType c i o) 
-    -> abt '[] i 
+    => MapleOptions (MapleCommand i o)
+    -> abt '[] i
     -> IO (abt '[] o)
-sendToMaple MapleOptions{..} e = do 
+sendToMaple MapleOptions{..} e = do
+  nm <- either throw return $ nameOfMapleCommand command
   let typ_in = typeOf e
-      typ_out = commandIsType command typ_in 
+      typ_out = typeOfMapleCommand command typ_in 
       optStr (k,v) = concat["_",k,"=",v]
       optsStr = 
         intercalate "," $ 
         map optStr $ M.assocs $ 
-        M.insert "command" (ssymbolVal(nameOfCommand command)) extraOpts 
+        M.insert "command" nm extraOpts 
       toMaple_ = "use Hakaru, NewSLO in timelimit("
                  ++ show timelimit ++ ", RoundTrip("
                  ++ Maple.pretty e ++ ", " ++ Maple.mapleType typ_in (", "
@@ -131,10 +235,11 @@
              (return . constantPropagation) $ do
         past <- leftShow $ parseMaple (pack fromMaple)
         let m = checkType typ_out
-                 (SR.resolveAST' (getNames e) (maple2AST past))
+                 (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
diff --git a/haskell/Language/Hakaru/Parser/AST.hs b/haskell/Language/Hakaru/Parser/AST.hs
--- a/haskell/Language/Hakaru/Parser/AST.hs
+++ b/haskell/Language/Hakaru/Parser/AST.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP
+ {-# LANGUAGE CPP
            , GADTs
            , DataKinds
            , PolyKinds
@@ -7,6 +7,11 @@
            , TypeFamilies
            , TypeOperators
            , OverloadedStrings
+           , DeriveDataTypeable
+           , ScopedTypeVariables
+           , RankNTypes
+           , FlexibleContexts
+           , LambdaCase
            #-}
 
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
@@ -28,88 +33,113 @@
 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 Data.Text
-import Text.Printf
+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 #-}!Text
-    deriving (Read, Show, Eq, Ord)
+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 -> Text
+hintID :: Name -> T.Text
 hintID (Name _ t) = t
 
 ----------------------------------------------------------------
 ----------------------------------------------------------------
 
-type Name' = Text
+type Name' = T.Text
 
 data Branch' a
     = Branch'  (Pattern' Name') (AST' a)
     | Branch'' (Pattern' Name)  (AST' a)
-    deriving (Eq, Show)
+    deriving (Eq, Show, Data, Typeable)
 
 data Pattern' a
     = PVar'  a
     | PWild'
     | PData' (PDatum a)
-    deriving (Eq, Show)
+    deriving (Eq, Show, Data, Typeable)
 
 data PDatum a = DV Name' [Pattern' a]
-    deriving (Eq, Show)
+    deriving (Eq, Show, Data, Typeable)
 
 -- Meta stores start and end position for AST in source code
 data SourceSpan = SourceSpan !SourcePos !SourcePos
-    deriving (Eq, Show)
-
-numberLine :: Text -> Int -> Text
-numberLine s n = append (pack (printf "%5d| " n)) s
+    deriving (Eq, Show, Data, Typeable)
 
-printSourceSpan :: SourceSpan -> V.Vector Text -> Text
+printSourceSpan :: SourceSpan -> V.Vector T.Text -> T.Text
 printSourceSpan (SourceSpan start stop) input
-    | sourceLine start == sourceLine stop =
-        unlines [ numberLine endLine (sourceLine stop)
-                , append "       " textSpan
-                ]
-    | otherwise                           =
-        unlines $ flip fmap [sourceLine start .. sourceLine stop] $ \i ->
-            numberLine (input V.! (i - 1)) i
-   where endLine  = input V.! (sourceLine stop - 1)
-         spanLen  = sourceColumn stop - sourceColumn start
-         textSpan =
-             append (replicate (sourceColumn start - 1) " ")
-                    (replicate spanLen "^")
+  = 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)
+    deriving (Eq, Show, Data, Typeable)
 
 data NaryOp
     = And | Or   | Xor
     | Iff | Min  | Max
     | Sum | Prod
-    deriving (Eq, Show)
+    deriving (Eq, Show, Data, Typeable)
 
-data ArrayOp = Index_ | Size | Reduce
+data ArrayOp = Index_ | Size | Reduce deriving (Data, Typeable)
 
 data TypeAST'
     = TypeVar Name'
     | TypeApp Name'    [TypeAST']
     | TypeFun TypeAST' TypeAST'
-    deriving (Eq, Show)
+    deriving (Eq, Show, Data, Typeable)
 
 data Reducer' a
     = R_Fanout (Reducer' a) (Reducer' a)
@@ -117,8 +147,30 @@
     | R_Split (AST' a) (Reducer' a) (Reducer' a)
     | R_Nop
     | R_Add (AST' a)
-    deriving (Eq, Show)
+    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)
@@ -130,13 +182,11 @@
     | ULiteral Literal'
     | NaryOp NaryOp [AST' a]
     | Unit
-    | Empty
     | 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
-    | Dirac (AST' a)
     | Bind  a  (AST' a) (AST' a)
     | Plate a  (AST' a) (AST' a)
     | Chain a  (AST' a) (AST' a) (AST' a)
@@ -144,13 +194,26 @@
     | Summate   a (AST' a) (AST' a) (AST' a)
     | Product   a (AST' a) (AST' a) (AST' a)
     | Bucket    a (AST' a) (AST' a) (Reducer' a)
-    | Expect a (AST' a) (AST' a)
-    | Observe  (AST' a) (AST' a)
+    | Transform Transform' (SArgs' a)
     | Msum  [AST' a]
     | Data  a [a] [TypeAST'] (AST' a)
     | WithMeta (AST' a) SourceSpan
-    deriving (Show)
+    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'  &&
@@ -171,7 +234,6 @@
     (NaryOp op args)    == (NaryOp op' args')       = op   == op' &&
                                                       args == args'
     Unit                == Unit                     = True
-    Empty               == Empty                    = True
     (Pair  e1 e2)       == (Pair   e1' e2')         = e1   == e1' &&
                                                       e2   == e2'
     (Array e1 e2 e3)    == (Array  e1' e2' e3')     = e1   == e1' &&
@@ -182,7 +244,6 @@
                                                       e2   == e2'
     (Case  e1 bs)       == (Case   e1' bs')         = e1   == e1' &&
                                                       bs   == bs'
-    (Dirac e1)          == (Dirac  e1')             = e1   == e1'
     (Bind  e1 e2 e3)    == (Bind   e1' e2' e3')     = e1   == e1' &&
                                                       e2   == e2' &&
                                                       e3   == e3'
@@ -209,11 +270,8 @@
                                                       b    == b' &&
                                                       c    == c' &&
                                                       d    == d'
-    (Expect e1 e2 e3)   == (Expect e1' e2' e3')     = e1   == e1' &&
-                                                      e2   == e2' &&
-                                                      e3   == e3'
-    (Observe  e1 e2)    == (Observe    e1' e2')     = e1   == e1' &&
-                                                      e2   == e2'
+    (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' &&
@@ -244,12 +302,13 @@
     | Asin       | Acos   | Atan
     | Sinh       | Cosh   | Tanh
     | Asinh      | Acosh  | Atanh
-    | RealPow    | NatPow
+    | RealPow    | Choose | NatPow
     | Exp        | Log    | Infinity
     | GammaFunc  | BetaFunc
     | Equal      | Less
     | Negate     | Recip
     | Abs        | Signum | NatRoot | Erf
+    | Floor
     deriving (Eq, Show)
 
 data SomeOp op where
@@ -278,7 +337,7 @@
 data Pattern
     = PWild
     | PVar Name
-    | PDatum Text PCode
+    | PDatum T.Text PCode
 
 data PFun
     = PKonst Pattern
@@ -306,7 +365,7 @@
     = Inr (DCode   abt)
     | Inl (DStruct abt)
 
-data Datum abt = Datum Text (DCode abt)
+data Datum abt = Datum T.Text (DCode abt)
 
 fmapDatum
     :: (f '[] 'U -> g '[] 'U)
@@ -412,7 +471,6 @@
     MeasureOp_    :: SomeOp MeasureOp -> [abt '[] 'U]    -> Term abt 'U
     NaryOp_       :: NaryOp           -> [abt '[] 'U]    -> Term abt 'U
     Literal_      :: Some1 Literal                       -> Term abt 'U
-    Empty_        ::                                        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
@@ -426,12 +484,27 @@
     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
-    Expect_       :: abt '[] 'U       -> abt '[ 'U ] 'U  -> Term abt 'U
-    Observe_      :: abt '[] 'U       -> 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)
@@ -445,7 +518,6 @@
     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 _ Empty_                 = Empty_
     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)
@@ -459,11 +531,16 @@
     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 (Expect_    e1  e2)    = Expect_    (f e1) (f e2)
-    fmap21 f (Observe_   e1  e2)    = Observe_   (f e1) (f e2)
+    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
@@ -476,7 +553,6 @@
     foldMap21 f (MeasureOp_ _  es)    = F.foldMap f es
     foldMap21 f (NaryOp_    _  es)    = F.foldMap f es
     foldMap21 _ (Literal_   _)        = mempty
-    foldMap21 _ Empty_                = 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
@@ -490,10 +566,10 @@
     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 (Expect_    e1 e2)    = f e1 `mappend` f e2
-    foldMap21 f (Observe_   e1 e2)    = f e1 `mappend` f e2
+    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
diff --git a/haskell/Language/Hakaru/Parser/Import.hs b/haskell/Language/Hakaru/Parser/Import.hs
--- a/haskell/Language/Hakaru/Parser/Import.hs
+++ b/haskell/Language/Hakaru/Parser/Import.hs
@@ -1,15 +1,15 @@
 {-# LANGUAGE CPP, OverloadedStrings #-}
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
-module Language.Hakaru.Parser.Import where
+module Language.Hakaru.Parser.Import (expandImports) where
 
 import           Language.Hakaru.Parser.AST
-import           Language.Hakaru.Parser.Parser
+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                   hiding (Empty)
+import           Text.Parsec
 
 replaceBody :: AST' T.Text -> AST' T.Text -> AST' T.Text
 replaceBody e1 e2 =
@@ -20,11 +20,13 @@
       _                 -> e2
 
 expandImports
-    :: ASTWithImport' T.Text
+    :: Maybe FilePath
+    -> ASTWithImport' T.Text
     -> ExceptT ParseError IO (AST' T.Text)
-expandImports (ASTWithImport' (Import i:is) ast) = do
-    file  <- liftIO . IO.readFile . T.unpack $ T.append i ".hk"
+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 astIm
-    expandImports (ASTWithImport' is (replaceBody ast' ast))
-expandImports (ASTWithImport' [] ast) = return ast
+    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
--- a/haskell/Language/Hakaru/Parser/Maple.hs
+++ b/haskell/Language/Hakaru/Parser/Maple.hs
@@ -239,7 +239,7 @@
 
 lesseq :: Parser InertExpr
 lesseq = do
-    text "_Inert_LESSEQ"
+    _ <- text "_Inert_LESSEQ"
     args <- arg expr
     return $ InertArgs Not_
                [ InertArgs Less (reverse args)]
@@ -317,9 +317,6 @@
         [InertName "Datum", InertArgs ExpSeq [InertName h, d]]) =
     mapleDatum2AST h d
 
-maple2AST (InertArgs Func [InertName "Lebesgue", _]) =
-    Var "lebesgue"
-
 maple2AST (InertArgs Func [InertName "Counting", _]) =
     Var "counting"
 
@@ -360,6 +357,8 @@
 
 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
@@ -485,6 +484,13 @@
 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)
 
@@ -546,6 +552,8 @@
   [ 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
@@ -651,6 +659,7 @@
         [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
diff --git a/haskell/Language/Hakaru/Parser/Parser.hs b/haskell/Language/Hakaru/Parser/Parser.hs
--- a/haskell/Language/Hakaru/Parser/Parser.hs
+++ b/haskell/Language/Hakaru/Parser/Parser.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE CPP, OverloadedStrings #-}
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
-module Language.Hakaru.Parser.Parser where
+module Language.Hakaru.Parser.Parser (parseHakaru, parseHakaruWithImports) where
 
 import Prelude hiding (Real)
 
@@ -8,35 +8,37 @@
 import           Data.Functor                  ((<$>), (<$))
 import           Control.Applicative           (Applicative(..))
 #endif
-import qualified Control.Monad                 as M
 import           Data.Functor.Identity
 import           Data.Text                     (Text)
 import qualified Data.Text                     as Text
 import           Data.Ratio                    ((%))
 import           Data.Char                     (digitToInt)
-import           Text.Parsec                   hiding (Empty)
+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 qualified Text.Parsec.Expr              as Ex
+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, types, names :: [String]
-ops   = ["+","*","-","^", "**", ":",".", "<~",
-         "==", "=", "_", "<|>", "&&", "||"]
-types = ["->"]
-names = ["def", "fn", "if", "else", "∞", "expect", "observe",
-         "return", "match", "integrate", "summate", "product",
-         "data", "import"]
+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 Operator a      = Ex.Operator ParserStream () Identity a
-type OperatorTable a = [[Operator a]]
+type OperatorTable a = [[Operator ParserStream () Identity a]]
 
 style :: Tok.GenLanguageDef ParserStream st Identity
 style = ITok.makeIndentLanguageDef $ Tok.LanguageDef
@@ -45,22 +47,14 @@
     , Tok.nestedComments  = True
     , Tok.identStart      = letter <|> char '_'
     , Tok.identLetter     = alphaNum <|> oneOf "_'"
-    , Tok.opStart         = oneOf "!$%&*+./<=>?@\\^|-~"
-    , Tok.opLetter        = oneOf "!$%&*+./<=>?@\\^|-~"
+    , Tok.opStart         = oneOf [ c | c:_ <- ops ]
+    , Tok.opLetter        = oneOf [ c | _:cs <- ops, c <- cs ]
     , Tok.caseSensitive   = True
     , Tok.commentLine     = "#"
-    , Tok.reservedOpNames = ops ++ types
+    , Tok.reservedOpNames = ops
     , Tok.reservedNames   = names
     }
 
-comments :: Parser ()
-comments = string "#"
-           *> manyTill anyChar newline
-           *> return ()
-
-emptyLine :: Parser ()
-emptyLine = newline *> return ()
-
 lexer :: Tok.GenTokenParser ParserStream () Identity
 lexer = ITok.makeTokenParser style
 
@@ -70,14 +64,9 @@
 decimal :: Parser Integer
 decimal = Tok.decimal lexer
 
-integer :: Parser Integer
-integer = Tok.integer lexer
-
-float :: Parser Rational
-float =  (decimal >>= fractExponent) <* whiteSpace
-
-fractFloat :: Integer -> Parser (Either Integer Rational)
-fractFloat n  =  fractExponent n >>= return . Right
+decimalFloat :: Parser Literal'
+decimalFloat = do n <- decimal
+                  option (Nat n) (Prob <$> fractExponent n)
 
 fractExponent   :: Integer -> Parser Rational
 fractExponent n =  do{ fract <- fraction
@@ -90,181 +79,187 @@
                     }
 
 fraction        :: Parser Rational
-fraction        =  do{ _ <- char '.'
-                     ; digits <- many1 digit <?> "fraction"
-                     ; return (foldr op 0 digits)
+fraction        =  do{ d      <- try (char '.' *> digit)
+                     ; digits <- many digit <?> "fraction"
+                     ; return (foldr1 op (map (fromIntegral.digitToInt) (d:digits))
+                               / 10)
                      }
                   <?> "fraction"
                     where
-                      op d f    = (f + fromIntegral (digitToInt d))/10
+                      op d f    = d + f / 10
 
 exponent'       :: Parser Rational
 exponent'       =  do{ _ <- oneOf "eE"
-                     ; f <- sign
+                     ; f <- (negate <$ char '-') <|> (id <$ optional (char '+'))
                      ; e <- decimal <?> "exponent"
-                     ; return (power (f e))
+                     ; return (10 ^^ f e)
                      }
                   <?> "exponent"
-                      where
-                       power e  | e < 0      = 1.0/power(-e)
-                                | otherwise  = fromInteger (10^e)
-                       sign            =   (char '-' >> return negate)
-                                       <|> (char '+' >> return id)
-                                       <|> return id
 
 parens :: Parser a -> Parser a
 parens = Tok.parens lexer . localIndentation Any
 
-braces :: Parser a -> Parser a
-braces = 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
 
-semiSep :: Parser a -> Parser [a]
-semiSep = Tok.semiSep lexer
-
-semiSep1 :: Parser a -> Parser [a]
-semiSep1 = Tok.semiSep1 lexer
-
 identifier :: Parser Text
-identifier = M.liftM Text.pack $ Tok.identifier lexer
+identifier = Text.pack <$> Tok.identifier lexer
 
 reserved :: String -> Parser ()
-reserved = Tok.reserved lexer
+reserved s
+  | s `elem` names -- assertion
+  = Tok.reserved lexer s
+  | otherwise
+  = error ("Parser failed to reserve the name " ++ show s)
 
 reservedOp :: String -> Parser ()
-reservedOp = Tok.reservedOp lexer
-
-symbol :: Text -> Parser Text
-symbol = M.liftM Text.pack . Tok.symbol lexer . Text.unpack
+reservedOp s
+  | s `elem` ops -- assertion
+  = Tok.reservedOp lexer s
+  | otherwise
+  = error ("Parser failed to reserve the operator " ++ show s)
 
-app1 :: Text -> AST' Text -> AST' Text
-app1 s x@(WithMeta _ m) = WithMeta (Var s `App` x) m
-app1 s x                = Var s `App` x
+app1 :: a -> AST' a -> AST' a
+app1 s x = Var s `App` x
 
-app2 :: Text -> AST' Text -> AST' Text -> AST' Text
+app2 :: a -> AST' a -> AST' a -> AST' a
 app2 s x y = Var s `App` x `App` y
 
--- | Smart constructor for divide
-divide :: AST' Text -> AST' Text -> AST' Text
-divide (ULiteral x') (ULiteral y') = ULiteral (go x' y')
-  where go :: Literal' -> Literal' -> Literal'
-        go (Nat  x) (Nat  y) = Prob (x % y)
-        go x        y        = Real (litToRat x / litToRat y)
-
-        litToRat :: Literal' -> Rational
-        litToRat (Nat  x) = toRational x
-        litToRat (Int  x) = toRational x
-        litToRat (Prob x) = toRational x
-        litToRat (Real x) = toRational x
+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]
 
-binop :: Text ->  AST' Text ->  AST' Text ->  AST' Text
-binop s x y
-    | s == "+"   = NaryOp Sum  [x, y]
-    | s == "-"   = NaryOp Sum  [x, app1 "negate" y]
-    | s == "*"   = NaryOp Prod [x, y]
-    | s == "/"   = x `divide` y
-    | s == "<"   = app2 "less"  x y
-    | s == ">"   = app2 "less"  y x
-    | s == "=="  = app2 "equal" x y
-    | s == "<="  = NaryOp Or [ app2 "less"  x y
-                             , app2 "equal" x y]
-    | s == ">="  = NaryOp Or [ app2 "less"  y x
-                             , app2 "equal" x y]
-    | s == "&&"  = NaryOp And  [x, y]
-    | s == "||"  = NaryOp Or   [x, y]
-    | s == "<|>" = Msum [x, y]
-    | otherwise  = app2 s x y
+bi :: ([a] -> b) -> a -> a -> b
+bi f x y = f [x, y]
 
-binary :: String -> Ex.Assoc -> Operator (AST' Text)
-binary s = Ex.Infix (binop (Text.pack s) <$ reservedOp s)
+negate_rel :: (AST' Text -> AST' Text -> AST' Text)
+           -> (AST' Text -> AST' Text -> AST' Text)
+negate_rel f x y = app1 "not" (f x y)
 
-prefix :: String -> (a -> a) -> Operator a
-prefix s f = Ex.Prefix (f <$ reservedOp s)
+binary :: String
+       -> Assoc
+       -> (a -> a -> a)
+       -> Operator ParserStream () Identity a
+binary s a f = Infix (f <$ reservedOp s) a
 
-postfix :: Parser (a -> a) -> Operator a
-postfix p = Ex.Postfix . chainl1 p . return $ flip (.)
+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 ]
-    , [ prefix "+"  id ]
-    , [ binary "^"  Ex.AssocRight
-      , binary "**" Ex.AssocRight]
-    , [ binary "*"  Ex.AssocLeft
-      , binary "/"  Ex.AssocLeft]
-    , [ binary "+"  Ex.AssocLeft
-      , binary "-"  Ex.AssocLeft
-      , prefix "-"  (app1 "negate")]
-    -- TODO: add "/="
-    -- TODO: do you *really* mean AssocLeft? Shouldn't they be non-assoc?
-    , [ postfix ann_expr ]
-    , [ binary "<|>" Ex.AssocRight]
-    , [ binary "<"   Ex.AssocLeft
-      , binary ">"   Ex.AssocLeft
-      , binary "<="  Ex.AssocLeft
-      , binary ">="  Ex.AssocLeft
-      , binary "=="  Ex.AssocLeft]
-    , [ binary "&&"  Ex.AssocLeft]
-    , [ binary "||"  Ex.AssocLeft]]
+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 ] ]
 
-unit_ :: Parser (AST' a)
-unit_ = Unit <$ symbol "()"
+red_expr :: Parser (Reducer' Text)
+red_expr =  red_fanout
+        <|> red_index
+        <|> red_split
+        <|> red_nop
+        <|> red_add
 
-empty_ :: Parser (AST' a)
-empty_ = Empty <$ symbol "[]"
+red_fanout :: Parser (Reducer' Text)
+red_fanout = reserved "r_fanout" *>
+             (R_Fanout
+              <$> red_expr
+              <*  reservedOp "||"
+              <*> red_expr
+              )
 
-int :: Parser (AST' a)
-int = do
-    n <- integer
-    return $
-        if n < 0
-        then ULiteral $ Int n
-        else ULiteral $ Nat n
+red_split :: Parser (Reducer' Text)
+red_split = reserved "r_split" *>
+             (R_Split
+              <$> expr
+              <*  reservedOp ":"
+              <*> red_expr
+              <*  reserved "else"
+              <*  reservedOp ":"
+              <*> red_expr
+              )
 
-floating :: Parser (AST' a)
-floating = do
-    sign <- option '+' (oneOf "+-")
-    n <- float
-    return $
-        case sign of
-        '-' -> ULiteral $ Real (negate n)
-        '+' -> ULiteral $ Prob n
-        _   -> error "floating: the impossible happened"
+red_index :: Parser (Reducer' Text)
+red_index = reserved "r_index" *>
+             (R_Index
+              <$> identifier
+              <*  reservedOp "="
+              <*> expr
+              <*  reserved "of"
+              <*> expr
+              <*  reservedOp ":"
+              <*> red_expr
+              )
 
-inf_ :: Parser (AST' Text)
+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
 
-pairs :: Parser (AST' Text)
-pairs = foldr1 Pair <$> parens (commaSep expr)
-
-type_var :: Parser TypeAST'
-type_var = TypeVar <$> identifier
-
-type_app :: Parser TypeAST'
-type_app = TypeApp <$> identifier <*> parens (commaSep type_expr)
+parenthesized :: Parser (AST' Text)
+parenthesized = f <$> parens (commaSep expr)
+  where f [] = Unit
+        f xs = foldr1 Pair xs
 
-type_fun :: Parser TypeAST'
-type_fun =
-    chainr1
-        (    try type_app
-         <|> try type_var
-         <|> parens type_fun)
-        (TypeFun <$ reservedOp "->")
+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 = try type_fun
-        <|> try type_app
-        <|> try type_var
-        <|> parens type_expr
+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)
@@ -275,8 +270,8 @@
 pat_expr :: Parser (Pattern' Text)
 pat_expr =  try (PData' <$> pdat_expr)
         <|> (PData' <$> (DV "pair" <$> parens (commaSep pat_expr)))
-        <|> (PWild' <$ reservedOp "_")
-        <|> (PVar' <$> identifier)
+        <|> (PWild' <$  reservedOp "_")
+        <|> (PVar'  <$> identifier)
 
 
 -- | Blocks are indicated by colons, and must be indented.
@@ -286,42 +281,25 @@
     localIndentation Gt (many $ absoluteIndentation p)
 
 
--- | Semiblocks are like blocks, but indentation is optional. Also,
--- there are only 'expr' semiblocks.
-semiblockExpr :: Parser (AST' Text)
-semiblockExpr = reservedOp ":" *> localIndentation Ge expr
-
-
--- | Pseudoblocks seem like semiblocks, but actually they aren't
--- indented.
---
--- TODO: do we actually want this in our grammar, or did we really
--- mean to use 'semiblockExpr' instead?
-pseudoblockExpr :: Parser (AST' Text)
-pseudoblockExpr = reservedOp ":" *> expr
-
-
 branch_expr :: Parser (Branch' Text)
-branch_expr = Branch' <$> pat_expr <*> semiblockExpr
+branch_expr = Branch' <$> pat_expr <* reservedOp ":"
+              <*> localIndentation Gt expr
 
 match_expr :: Parser (AST' Text)
-match_expr =
-    reserved "match"
-    *>  (Case
-        <$> expr
-        <*> blockOfMany branch_expr
-        )
+match_expr = Case <$ reserved "match" <*> expr <* reservedOp ":"
+             <*> localIndentation Ge (many (absoluteIndentation branch_expr))
 
 integrate_expr :: Parser (AST' Text)
 integrate_expr =
     reserved "integrate"
     *> (Integrate
         <$> identifier
-        <*  symbol "from"
+        <*  reserved "from"
         <*> expr
-        <*  symbol "to"
+        <*  reserved "to"
         <*> expr
-        <*> semiblockExpr
+        <*  reservedOp ":"
+        <*> expr
         )
 
 summate_expr :: Parser (AST' Text)
@@ -329,11 +307,12 @@
     reserved "summate"
     *> (Summate
         <$> identifier
-        <*  symbol "from"
+        <*  reserved "from"
         <*> expr
-        <*  symbol "to"
+        <*  reserved "to"
         <*> expr
-        <*> semiblockExpr
+        <*  reservedOp ":"
+        <*> expr
         )
 
 product_expr :: Parser (AST' Text)
@@ -341,28 +320,55 @@
     reserved "product"
     *> (Product
         <$> identifier
-        <*  symbol "from"
+        <*  reserved "from"
         <*> expr
-        <*  symbol "to"
+        <*  reserved "to"
         <*> expr
-        <*> semiblockExpr
+        <*  reservedOp ":"
+        <*> expr
         )
 
-expect_expr :: Parser (AST' Text)
-expect_expr =
-    reserved "expect"
-    *> (Expect
+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
-        <*> semiblockExpr
-        )
-
-observe_expr :: Parser (AST' Text)
-observe_expr =
-    reserved "observe"
-    *> (Observe
-        <$> expr
+        <*  reserved "to"
         <*> expr
+        <*  reservedOp ":"
+        <*> red_expr
         )
 
 array_expr :: Parser (AST' Text)
@@ -370,49 +376,46 @@
     reserved "array"
     *> (Array
         <$> identifier
-        <*  symbol "of"
+        <*  reserved "of"
         <*> expr
-        <*> semiblockExpr
+        <*  reservedOp ":"
+        <*> expr
         )
 
 array_index :: Parser (AST' Text -> AST' Text)
 array_index = flip Index <$> brackets expr
 
 array_literal :: Parser (AST' Text)
-array_literal = checkEmpty <$> brackets (commaSep expr)
-  where checkEmpty [] = Empty
-        checkEmpty xs = ArrayLiteral xs
+array_literal = ArrayLiteral <$> brackets (commaSep expr)
 
 plate_expr :: Parser (AST' Text)
 plate_expr =
     reserved "plate"
     *> (Plate
         <$> identifier
-        <*  symbol "of"
+        <*  reserved "of"
         <*> expr
-        <*> semiblockExpr
+        <*  reservedOp ":"
+        <*> expr
         )
 
 chain_expr :: Parser (AST' Text)
 chain_expr =
     reserved "chain"
-    *> (Chain
+    *> (flip . Chain
         <$> identifier
+        <*  reserved "from"
         <*> expr
+        <*  reserved "of"
         <*> expr
-        <*> semiblockExpr
+        <*  reservedOp ":"
+        <*> expr
         )
 
 
 if_expr :: Parser (AST' Text)
-if_expr =
-    reserved "if"
-    *>  (If
-        <$> localIndentation Ge expr
-        <*> semiblockExpr
-        <*  reserved "else"
-        <*> semiblockExpr
-        )
+if_expr = If <$ reserved "if" <*> expr <* reservedOp ":" <*> expr
+             <* reserved "else"        <* reservedOp ":" <*> expr
 
 lam_expr :: Parser (AST' Text)
 lam_expr =
@@ -420,80 +423,73 @@
     *>  (Lam
         <$> identifier
         <*> type_expr
-        <*> semiblockExpr
+        <*  reservedOp ":"
+        <*> expr
         )
 
 bind_expr :: Parser (AST' Text)
-bind_expr = Bind
-    <$> identifier
-    <*  reservedOp "<~"
-    <*> expr
-    <*> expr
+bind_expr = localIndentation Ge
+  (absoluteIndentation (try (Bind <$> identifier <* reservedOp "<~")
+   <*> localIndentation Gt expr)
+   <*> absoluteIndentation expr)
 
 let_expr :: Parser (AST' Text)
-let_expr = Let
-    <$> identifier
-    <*  reservedOp "="
-    <*> expr
-    <*> expr
+let_expr = localIndentation Ge
+  (absoluteIndentation (try (Let <$> identifier <* reservedOp "=")
+   <*> localIndentation Gt expr)
+   <*> absoluteIndentation expr)
 
 def_expr :: Parser (AST' Text)
-def_expr = do
-    reserved "def"
+def_expr = localIndentation Ge $ do
+    absoluteIndentation (reserved "def")
     name <- identifier
     vars <- parens (commaSep defarg)
     bodyTyp <- optionMaybe type_expr
-    body    <- semiblockExpr
+    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')
-        <$> expr -- the \"rest\"; i.e., where the 'def' is in scope
+        <$> absoluteIndentation expr -- the \"rest\"; i.e., where the 'def' is in scope
 
 defarg :: Parser (Text, TypeAST')
 defarg = (,) <$> identifier <*> type_expr
 
-call_expr :: Parser (AST' Text)
-call_expr =
-    foldl App
-        <$> (Var <$> identifier)
-        <*> parens (commaSep 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"
-    Dirac <$> expr
+    app1 "dirac" <$> expr
 
 term :: Parser (AST' Text)
-term =  try if_expr
-    <|> try return_expr
-    <|> try lam_expr
-    <|> try def_expr
-    <|> try match_expr
-    <|> try data_expr
-    <|> try integrate_expr
-    <|> try summate_expr
-    <|> try product_expr
-    <|> try expect_expr
-    <|> try observe_expr
-    <|> try array_expr
-    <|> try plate_expr
-    <|> try chain_expr
-    <|> try let_expr
-    <|> try bind_expr
-    <|> try call_expr
-    <|> try array_literal
-    <|> try floating
-    <|> try inf_
-    <|> try unit_
-    <|> try empty_
-    <|> try int
-    <|> try var
-    <|> try pairs
-    <|> parens expr
-    <?> "an expression"
+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 (Ex.buildExpressionParser table (withPos term) <?> "an expression")
+expr = withPos (let_expr <|>
+                bind_expr <|>
+                return_expr <|>
+                buildExpressionParser table (withPos term))
+       <?> "expression"
 
 
 indentConfig :: Text -> ParserStream
@@ -506,10 +502,10 @@
 parseHakaruWithImports :: Text -> Either ParseError (ASTWithImport' Text)
 parseHakaruWithImports = parseAtTopLevel exprWithImport
 
-parseAtTopLevel :: Parser a -> Text -> Either ParseError a 
-parseAtTopLevel p = 
-    runParser (skipMany (comments <|> emptyLine) *>
-               p <* eof) () "<input>" . indentConfig . Text.strip 
+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
@@ -535,7 +531,7 @@
     reserved "data"
     ident <- identifier
     typvars <- parens (commaSep identifier)
-    ts <- blockOfMany (try type_app <|> type_var)
+    ts <- blockOfMany type_var_or_app
     e <- expr
     return (Data ident typvars ts e)
 
@@ -545,3 +541,98 @@
 
 exprWithImport :: Parser (ASTWithImport' Text)
 exprWithImport = ASTWithImport' <$> (many import_expr) <*> expr
+
+-- | 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
--- a/haskell/Language/Hakaru/Parser/SymbolResolve.hs
+++ b/haskell/Language/Hakaru/Parser/SymbolResolve.hs
@@ -3,9 +3,15 @@
            , DataKinds
            , KindSignatures
            , GADTs
+           , LambdaCase
+           , PolyKinds
+           , RankNTypes
            #-}
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
-module Language.Hakaru.Parser.SymbolResolve where
+module Language.Hakaru.Parser.SymbolResolve
+    (
+      resolveAST, resolveAST', makeName, fromVarSet
+    ) where
 
 import Data.Text hiding (concat, map, maximum, foldr1, singleton)
 #if __GLASGOW_HASKELL__ < 710
@@ -13,6 +19,7 @@
 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
@@ -25,11 +32,12 @@
 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
+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)
@@ -99,15 +107,15 @@
     ,("true",        TNeu $ true_)
     ,("false",       TNeu $ false_)
      -- Coercions
-    ,("int2nat",     primUnsafe cNat2Int)
+    ,("int2nat",     primUnsafe cNat2Int)  -- unsafe, wrong direction
     ,("int2real",    primCoerce cInt2Real)
     ,("prob2real",   primCoerce cProb2Real)
-    ,("real2prob",   primUnsafe cProb2Real)
+    ,("real2prob",   primUnsafe cProb2Real) -- unsafe, wrong direction
     ,("nat2real",    primCoerce cNat2Real)
     ,("nat2prob",    primCoerce cNat2Prob)
     ,("nat2int",     primCoerce cNat2Int)
      -- Measures
-    ,("lebesgue",    TNeu $ syn $ U.MeasureOp_ (U.SomeOp T.Lebesgue) [])
+    ,("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))
@@ -121,8 +129,13 @@
     ,("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)
@@ -151,12 +164,19 @@
     ,("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
@@ -262,6 +282,19 @@
         <$> 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.
@@ -327,7 +360,6 @@
         <$> mapM (symbolResolution symbols) es
 
     U.Unit              -> return $ U.Unit
-    U.Empty             -> return $ U.Empty
     U.Pair e1 e2        -> U.Pair
         <$> symbolResolution symbols e1
         <*> symbolResolution symbols e2
@@ -344,19 +376,15 @@
         <$> symbolResolution symbols e1
         <*> mapM (symbolResolveBranch symbols) bs
 
-    U.Dirac  e1            -> U.Dirac <$> symbolResolution symbols e1
     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.Expect name e1 e2    -> resolveBinder symbols name e1 e2 U.Expect
+    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.Observe e1 e2        -> U.Observe
-        <$> symbolResolution symbols e1
-        <*> symbolResolution symbols e2
 
     U.Msum es -> U.Msum <$> mapM (symbolResolution symbols) es
 
@@ -432,10 +460,11 @@
     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 in
-        case normAST f of
+        let x' = normAST x
+            f' = normAST f in
+        case U.withoutMeta f' of
         U.Var (TLam f)      -> U.Var $ f (makeAST x')
-        f'                  -> U.App f' 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)
@@ -448,23 +477,23 @@
     U.ULiteral v              -> U.ULiteral v
     U.NaryOp op es            -> U.NaryOp op (map normAST es)
     U.Unit                    -> U.Unit
-    U.Empty                   -> U.Empty
     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.Dirac       e1          -> U.Dirac (normAST e1)
     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.Expect name e1 e2       -> U.Expect name (normAST e1) (normAST e2)
-    U.Observe     e1 e2       -> U.Observe (normAST e1) (normAST e2)
+    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')
@@ -576,7 +605,6 @@
     U.ULiteral v      -> syn $ U.Literal_  (U.val v)
     U.NaryOp op es    -> syn $ U.NaryOp_ op (map makeAST es)
     U.Unit            -> unit_
-    U.Empty           -> syn $ U.Empty_
     U.Pair e1 e2      -> syn $ U.Pair_ (makeAST e1) (makeAST e2)
     U.Array s e1 e2 ->
         withName "U.Array" s $ \name ->
@@ -584,7 +612,6 @@
     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.Dirac e1        -> syn $ U.Dirac_ (makeAST e1)
     U.Bind s e1 e2 ->
         withName "U.Bind" s $ \name ->
             syn $ U.MBind_ (makeAST e1) (bind name $ makeAST e2)
@@ -606,15 +633,74 @@
     U.Bucket s e1 e2 e3 ->
         withName "U.Bucket"  s $ \name ->
             syn $ U.Bucket_ (makeAST e1) (makeAST e2) (makeReducerAST name e3 Nil1)
-    U.Expect s e1 e2 ->
-        withName "U.Expect" s $ \name ->
-            syn $ U.Expect_ (makeAST e1) (bind name $ makeAST e2)
-    U.Observe e1 e2  -> syn $ U.Observe_ (makeAST e1) (makeAST e2)
+    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
@@ -629,19 +715,20 @@
     evalState (symbolResolution primTable ast) 0
 
 resolveAST'
-    :: [U.Name]
+    :: N.Nat
+    -> [U.Name]
     -> U.AST' Text
     -> U.AST
-resolveAST' syms ast =
+resolveAST' nextVar syms ast =
     coalesce .
     makeAST  .
     normAST  $
     evalState (symbolResolution
         (insertSymbols syms primTable) ast)
-        (nextVarID_ syms)
+        (N.fromNat $ nextVarID_ syms)
     where
-    nextVarID_ [] = N.fromNat 0
-    nextVarID_ xs = N.fromNat . (1+) . F.maximum $ map U.nameID xs
+    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
diff --git a/haskell/Language/Hakaru/Pretty/Concrete.hs b/haskell/Language/Hakaru/Pretty/Concrete.hs
--- a/haskell/Language/Hakaru/Pretty/Concrete.hs
+++ b/haskell/Language/Hakaru/Pretty/Concrete.hs
@@ -7,6 +7,7 @@
            , TypeOperators
            , FlexibleContexts
            , UndecidableInstances
+           , LambdaCase
            #-}
 
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
@@ -28,29 +29,34 @@
       pretty
     , prettyPrec
     , prettyType
-    , prettyAssoc
-    , prettyPrecAssoc
     , prettyValue
+    , prettyT
+    , prettyTypeT, prettyTypeS
     -- * Helper functions (semi-public internal API)
     ) where
 
-import           System.Console.ANSI
-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           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 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.Natural   (fromNatural, fromNonNegativeRational)
 import           Data.Number.Nat
-import qualified Data.Number.LogFloat            as LF
+import qualified Data.Number.LogFloat  as LF
 
-import Language.Hakaru.Syntax.IClasses (fmap11, foldMap11, jmEq1, TypeEq(..))
+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
@@ -58,230 +64,247 @@
 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
-    (ppRatio, prettyAssoc, prettyPrecAssoc, Associativity(..))
+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 = toDoc . prettyPrec_ p . LC_
+prettyPrec p = prettyPrec_ p . LC_
 
 ----------------------------------------------------------------
 class Pretty (f :: Hakaru -> *) where
     -- | A polymorphic variant if 'prettyPrec', for internal use.
-    prettyPrec_ :: Int -> f a -> Docs
+    prettyPrec_ :: Int -> f a -> Doc
 
-type Docs = [Doc] 
+mapInit :: (a -> a) -> [a] -> [a]
+mapInit f (x:xs@(_:_)) = f x : mapInit f xs
+mapInit _ xs           = xs
 
--- 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.cat
+sepByR :: String -> [Doc] -> Doc
+sepByR s = sep . mapInit (<+> text s)
 
--- | Color a Doc
-color :: Color -> Doc -> Doc
-color c d =
-    PP.text (setSGRCode [SetColor Foreground Dull c])
-    <> d
-    <> PP.text (setSGRCode [Reset])
+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.
 
-keyword :: Doc -> Doc
-keyword = color Red
+parensIf :: Bool -> Doc -> Doc
+parensIf False = id
+parensIf True  = parens
 
 -- | Pretty-print a variable.
 ppVariable :: Variable (a :: Hakaru) -> Doc
-ppVariable x = hint
-    where
-    hint
-        | Text.null (varHint x) = PP.char 'x'  <> (PP.int . fromNat . varID) x -- We used to use '_' but...
-        | otherwise             = (PP.text . Text.unpack . varHint) x
-
-ppVariableWithType :: Variable (a :: Hakaru) -> (Doc, Doc)
-ppVariableWithType x = (hint, (prettyType 0 . varType) x)
-    where
-    hint
-        | Text.null (varHint x) = PP.char 'x' <> (PP.int . fromNat . varID) x -- We used to use '_' but...
-        | otherwise             = (PP.text . Text.unpack . varHint) x
+ppVariable x
+    | Text.null (varHint x) = text ('x' : show (fromNat (varID x))) -- We used to use '_' but...
+    | otherwise             = text (Text.unpack (varHint x))
 
--- BUG: we still use this in a few places. I'm pretty sure they should all actually be 'ppBinder2', in which case we can delete this function and just use that one.
-ppBinder :: (ABT Term abt) => abt xs a -> Docs
-ppBinder e =
-    case go [] (viewABT e) of
-    ([],  body) -> body
-    (vars,body) -> PP.char '\\' <> PP.sep vars <+> PP.text "-> " : body
+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],Docs)
+    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, prettyPrec_ 0 (LC_ (syn t)))
-
-
-ppBinder2prec :: (ABT Term abt) => Int -> abt xs a -> ([Doc], [Doc], Docs)
-ppBinder2prec p e = unpackVarTypes $ go [] (viewABT e)
-    where
-    unpackVarTypes (varTypes, body) =
-        (map fst varTypes, map snd varTypes, body)
+    go xs (Var  x)   = (reverse xs, ppVariable x)
+    go xs (Syn  t)   = (reverse xs, pretty (syn t))
 
-    go :: (ABT Term abt) => [(Doc, Doc)] -> View (Term abt) xs a -> ([(Doc, Doc)],Docs)
-    go xs (Bind x v) = go (ppVariableWithType x : xs) v
-    go xs (Var  x)   = (reverse xs, [ppVariable x])
-    go xs (Syn  t)   = (reverse xs, prettyPrec_ p (LC_ (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]
 
-ppBinder2 :: (ABT Term abt) => abt xs a -> ([Doc], [Doc], Docs)
-ppBinder2 = ppBinder2prec 0 
+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 ->
+    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      -> parens (p > 3)
-                              . PP.punctuate (PP.text " && ")
-                              . map (prettyPrec 3)
-                              $ F.toList es
-                  Or       -> parens (p > 2)
-                              . PP.punctuate (PP.text " || ")
-                              . map (prettyPrec 2)
-                              $ F.toList es
-                  Xor      -> parens (p > 0)
-                              . PP.punctuate (PP.text " != ")
-                              . map (prettyPrec 0)
-                              $ F.toList es
-                -- 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)".
-                  Iff      -> [F.foldl1 (\a b -> toDoc $ ppFun p "iff" [a, b])
-                                         (fmap (toDoc . ppArg) es)]
-                  (Min  _) -> [F.foldl1 (\a b -> toDoc $ ppFun p "min" [a, b])
-                                         (fmap (toDoc . ppArg) es)]
-                  (Max  _) -> [F.foldl1 (\a b -> toDoc $ ppFun p "max" [a, b])
-                                          (fmap (toDoc . ppArg) es)]
-                  (Sum  _) -> case Seq.viewl es of
-                                Seq.EmptyL -> [PP.text "0"]
-                                (e' Seq.:< es') -> parens (p > 6) $
-                                    F.foldl (\a b -> a ++ (ppNaryOpSum 6 b))
-                                            [prettyPrec 6 e']
-                                            es'
-                  (Prod _) ->  case Seq.viewl es of
-                                Seq.EmptyL -> [PP.text "1"]
-                                (e' Seq.:< es') -> parens (p > 7) $
-                                    F.foldl (\a b -> a ++ (ppNaryOpProd 7 b))
-                                            [prettyPrec 7 e']
-                                            es'
+                  And    -> asOp 3 "&&" es
+                  Or     -> asOp 2 "||" es
+                  Xor    -> asFun "xor" es
+                  Iff    -> asFun "iff" es
+                  Min  _ -> asFun "min" es
+                  Max  _ -> asFun "max" es
 
-          where identityElement :: NaryOp a -> Docs
-                identityElement And      = [PP.text "true"]
-                identityElement Or       = [PP.text "false"]
-                identityElement Xor      = [PP.text "false"]
-                identityElement Iff      = [PP.text "true"]
+                  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  _) = [PP.text "0"]
-                identityElement (Prod _) = [PP.text "1"]
+                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_   _    -> [PP.text "empty"]
-        Array_ e1 e2  ->
-            let (vars, _, body) = ppBinder2 e2 in
-            [ PP.text "array"
-              <+> toDoc vars
-              <+> PP.text "of"
-              <+> toDoc (ppArg e1)
-              <> PP.colon <> PP.space
-            , PP.nest 1 (toDoc body)]
+        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 $ fmap (prettyPrec 0) es
+        ArrayLiteral_ es -> ppList $ map pretty es
 
         Datum_ d      -> prettyPrec_ p (fmap11 LC_ d)
-        Case_  e1 bs  -> parens True $
-            -- TODO: should we also add hints to the 'Case_' constructor to know whether it came from 'if_', 'unpair', etc?
-            [ PP.text "match"
-              <+> (toDoc $ ppArg e1)
-              <> PP.colon <> PP.space
-            , PP.nest 1 (PP.vcat (map (toDoc . prettyPrec_ 0) bs))
-            ]
-        Superpose_ pes ->
-            PP.punctuate (PP.text " <|> ") $ L.toList $ fmap ppWeight pes
-          where ppWeight (w,m)
-                    | (PP.render $ pretty w) == "1" =
-                        toDoc $ ppArg m
-                    | otherwise                 =
-                        toDoc $ ppFun p "weight" [pretty w, pretty m]
+        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 -> [PP.text "reject." <+> prettyType 0 typ]
+        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)
-    => Int
-    -> abt '[] a
-    -> Docs
-ppNaryOpSum p e =
-    caseVarSyn e (const $ prefixToTerm "+" e) $ \t ->
+    :: forall abt a . (ABT Term abt) => abt '[] a -> Doc
+ppNaryOpSum e =
+    caseVarSyn e (const d) $ \t ->
         case t of
-        Literal_ (LInt  i) | i < 0 ->      prefixToTerm "-" (syn . Literal_ . LInt  . abs $ i)
-        Literal_ (LReal i) | i < 0 ->      prefixToTerm "-" (syn . Literal_ . LReal . abs $ i)
-        PrimOp_ (Negate _) :$ e1 :* End -> prefixToTerm "-" e1
-        _ -> prefixToTerm "+" e
-  where prefixToTerm :: forall a. String -> abt '[] a -> Docs
-        prefixToTerm s e = [ PP.space <> PP.text s <> PP.space
-                           , prettyPrec p e
-                           ]
+        PrimOp_ (Negate _) :$ e1 :* End -> text "-" <+> prettyPrec 7 e1
+        _ -> d
+  where d = text "+" <+> prettyPrec 7 e
 
 ppNaryOpProd
-    :: forall abt a
-    . (ABT Term abt)
-    => Int
-    -> abt '[] a
-    -> Docs
-ppNaryOpProd p e =
-    caseVarSyn e (const $ prefixToTerm "*" e) $ \t ->
+    :: forall abt a . (ABT Term abt) => Bool -> abt '[] a -> Doc
+ppNaryOpProd second e =
+    caseVarSyn e (const d) $ \t ->
         case t of
-        Literal_ (LProb i) | numerator i == 1 -> 
-          prefixToTerm "/" (syn . Literal_ . LProb . fromIntegral . denominator $ i)
-        Literal_ (LReal i) | numerator i == 1 -> 
-          prefixToTerm "/" (syn . Literal_ . LReal . fromIntegral . denominator $ i)
-        PrimOp_ (Recip _) :$ e1 :* End -> prefixToTerm "/" e1
-        _ -> prefixToTerm "*" e
-  where prefixToTerm :: forall a. String -> abt '[] a -> Docs
-        prefixToTerm s e = [ PP.space <> PP.text s <> PP.space
-                           , prettyPrec p e
-                           ]
+        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 -> Docs
+ppSCon :: (ABT Term abt) => Int -> SCon args a -> SArgs abt args -> Doc
 ppSCon p Lam_ = \(e1 :* End) ->
-    let (vars, types, body) = ppBinder2prec 11 e1 in
-    parens (p < 11)
-    [ PP.text "fn" <+> toDoc vars
-                   <+> toDoc types
-                    <> PP.colon <> PP.space
-    , PP.nest 1 (toDoc body)]
+    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 _ App_ = \(e1 :* e2 :* End) -> prettyApps e1 e2
+ppSCon p App_ = \(e1 :* e2 :* End) -> prettyApps p e1 e2
 
-ppSCon _ Let_ = \(e1 :* e2 :* End) ->
-    {-
-    caseBind e2 $ \x e2' ->
-        (ppVariable x <+> PP.equals <+> PP.nest n (pretty e1))
-        : pretty e2'
-    -}
-    let (vars, _, body) = ppBinder2 e2 in
-    [toDoc vars <+> PP.equals <+> toDoc (ppArg e1)
-    PP.$$ (toDoc body)]
+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) ->
-    [toDoc (ppArg e1) <+> PP.text "::" <+> prettyType p typ]
+    parensIf (p > 5) (prettyPrec 6 e1 <> text "." <+> prettyType 0 typ)
 -}
 
 ppSCon p (PrimOp_     o) = \es          -> ppPrimOp     p o es
@@ -289,233 +312,227 @@
 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 _ Dirac = \(e1 :* End) -> [PP.text "return" <+> toDoc (ppArg e1)]
-ppSCon _ MBind = \(e1 :* e2 :* End) ->
-    let (vars, _, body) = ppBinder2 e2 in
-    [toDoc vars <+> PP.text "<~" <+> toDoc (ppArg e1)
-        PP.$$ (toDoc body)]
+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 (vars, types, body) = ppBinder2 e2 in
-    [ PP.text "plate"
-      <+> toDoc vars
-      <+> PP.text "of"
-      <+> (toDoc $ ppArg e1)
-      <> PP.colon <> PP.space
-    , PP.nest 1 (toDoc body)
-    ]
+    let (var, _, body) = ppBinder1 e2 in
+    parensIf (p > 0) $
+    sep [ sep [ text "plate" <+> var
+              , text "of" <+> pretty e1 <> colon ]
+        , body ]
 
 ppSCon p Chain = \(e1 :* e2 :* e3 :* End) ->
-    ppFun 11 "chain"
-        [ toDoc (ppArg e1)
-        , toDoc (ppArg e2) <+> PP.char '$'
-        , toDoc $ ppBinder e2
-        ]
+    let (var, _, body) = ppBinder1 e3 in
+    parensIf (p > 0) $
+    sep [ sep [ text "chain" <+> var
+              , text "from" <+> pretty e2
+              , text "of" <+> pretty e1 <> colon ]
+        , body ]
 
 ppSCon p Integrate = \(e1 :* e2 :* e3 :* End) ->
-    let (vars, types, body) = ppBinder2 e3 in
-    [ PP.text "integrate"
-      <+> toDoc vars
-      <+> PP.text "from"
-      <+> (toDoc $ ppArg e1)
-      <+> PP.text "to"
-      <+> (toDoc $ ppArg e2)
-      <> PP.colon <> PP.space
-    , PP.nest 1 (toDoc body)
-    ]
+    let (var, _, body) = ppBinder1 e3 in
+    parensIf (p > 0) $
+    sep [ sep [ text "integrate" <+> var
+              , text "from" <+> pretty e1
+              , text "to" <+> pretty e2 <> colon ]
+        , body ]
 
 ppSCon p (Summate _ _) = \(e1 :* e2 :* e3 :* End) ->
-    let (vars, types, body) = ppBinder2 e3 in
-    parens True $
-    [ PP.text "summate"
-      <+> toDoc vars
-      <+> PP.text "from"
-      <+> (toDoc $ ppArg e1)
-      <+> PP.text "to"
-      <+> (toDoc $ ppArg e2)
-      <> PP.colon <> PP.space
-    , PP.nest 1 (toDoc body)
-    ]
+    let (var, _, body) = ppBinder1 e3 in
+    parensIf (p > 0) $
+    sep [ sep [ text "summate" <+> var
+              , text "from" <+> pretty e1
+              , text "to" <+> pretty e2 <> colon ]
+        , body ]
 
 ppSCon p (Product _ _) = \(e1 :* e2 :* e3 :* End) ->
-    let (vars, types, body) = ppBinder2 e3 in
-    parens True $
-    [ PP.text "product"
-      <+> toDoc vars
-      <+> PP.text "from"
-      <+> (toDoc $ ppArg e1)
-      <+> PP.text "to"
-      <+> (toDoc $ ppArg e2)
-      <> PP.colon <> PP.space
-    , PP.nest 1 (toDoc body)
-    ]
-
-ppSCon p Expect = \(e1 :* e2 :* End) ->
-    let (vars, types, body) = ppBinder2 e2 in
-    [ PP.text "expect"
-      <+> toDoc vars
-      <+> (toDoc . parens True $ ppArg e1)
-      <> PP.colon
-    , PP.nest 1 (toDoc body)
-    ]
+    let (var, _, body) = ppBinder1 e3 in
+    parensIf (p > 0) $
+    sep [ sep [ text "product" <+> var
+              , text "from" <+> pretty e1
+              , text "to" <+> pretty e2 <> colon ]
+        , body ]
 
-ppSCon p Observe = \(e1 :* e2 :* End) ->
-    [ PP.text "observe"
-      <+> (toDoc $ ppArg e1)
-      <+> (toDoc $ ppArg e2)
-    ]
+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 <+> pretty e1 <> colon
+              , body ]
+    _ -> ppApply p (transformName t) es
 
-ppCoerceTo :: ABT Term abt => Int -> Coercion a b -> abt '[] a -> Docs
-ppCoerceTo =
+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...
-    \p c e -> ppFun p (prettyShow c) [toDoc $ ppArg e]
     where
-    prettyShow (CCons (Signed HRing_Real) CNil)           = "prob2real"
-    prettyShow (CCons (Signed HRing_Int)  CNil)           = "nat2int"
-    prettyShow (CCons (Continuous HContinuous_Real) CNil) = "int2real"
-    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 ""
+    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 -> Docs
-ppUnsafeFrom =
+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...
-    \p c e -> ppFun p (prettyShow c) [toDoc $ ppArg e]
     where
-    prettyShow (CCons (Signed HRing_Real) CNil) = "real2prob"
-    prettyShow (CCons (Signed HRing_Int)  CNil) = "int2nat"
-    prettyShow c = "unsafeFrom_ " ++ showsPrec 11 c ""
+    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         = PP.text "nat"
-prettyType _ SInt         = PP.text "int"
-prettyType _ SProb        = PP.text "prob"
-prettyType _ SReal        = PP.text "real"
-prettyType p (SMeasure a) = PP.text "measure" <> PP.parens (prettyType p a)
-prettyType p (SArray   a) = PP.text "array" <> PP.parens (prettyType p a)
--- HACK: precedence of function types
-prettyType p (SFun   a b) = PP.parens (prettyType p a <+> PP.text "->" <+> prettyType p b)
-prettyType p typ          =
-    case typ of
-    SData (STyCon sym `STyApp` a `STyApp` b) _
-      | Just Refl <- jmEq1 sym sSymbol_Pair
-      -> toDoc $ ppFun p "pair" [prettyType p a, prettyType p b]
-      | Just Refl <- jmEq1 sym sSymbol_Either
-      -> toDoc $ ppFun p "either" [prettyType p a, prettyType p b]
-    SData (STyCon sym `STyApp` a) _
-      | Just Refl <- jmEq1 sym sSymbol_Maybe
-      -> toDoc $ ppFun p "maybe" [prettyType p 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 "")
+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 -> 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"
-            [ toDoc $ ppArg e1
-            , toDoc $ ppArg e2
-            ]]
-ppPrimOp p Diff = \(e1 :* e2 :* End) ->
-    -- TODO: make prettier
-    ppFun p "syn"
-        [ toDoc $ ppFun 11 "Diff"
-            [ toDoc $ ppArg e1
-            , toDoc $ 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 Exp       = \(e1 :* End)       -> ppApply1 p "exp"   e1
-ppPrimOp p Log       = \(e1 :* End)       -> ppApply1 p "log"   e1
-ppPrimOp _ (Infinity _) = \End               -> [PP.text "∞"]
-ppPrimOp p GammaFunc    = \(e1 :* End)       -> ppApply1 p "gammaFunc" e1
-ppPrimOp p BetaFunc     = \(e1 :* e2 :* End) -> ppApply2 p "betaFunc" e1 e2
+    => 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
 
-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) -> ppNatRoot p e1 e2
-ppPrimOp p (Erf _)     = \(e1 :* End)       -> ppApply1  p "erf"     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
-    -> Docs
+    -> Doc
 ppNatRoot p e1 e2 =
-    caseVarSyn e2 (\x -> ppApply2 p "natroot" e1 e2) $ \t ->
+    caseVarSyn e2 (const d) $ \t ->
         case t of
-          Literal_ (LNat 2) -> ppApply1 p "sqrt"    e1
-          _                 -> ppApply2 p "natroot" e1 e2
+          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 -> Docs
-ppArrayOp p (Index   _) = \(e1 :* e2 :* End) ->
-    [(toDoc $ parensIf (isArray e1) $ ppArg e1) <>
-     PP.text "["        <>
-     (toDoc $ ppArg e2) <>
-     PP.text "]"]
-  where isArray e = caseVarSyn e (const False) $ \t ->
-                      case t of
-                      Array_ _ _ -> True
-                      _          -> False
-        parensIf True  e = parens True e
-        parensIf False e = e
+    => 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"
-        [ toDoc $ ppArg e1 -- N.B., @e1@ uses lambdas rather than being a binding form!
-        , toDoc $ ppArg e2
-        , toDoc $ ppArg e3
-        ]
+        [ 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 -> Docs
-ppMeasureOp _ Lebesgue    = \End           -> [PP.text "lebesgue"]
-ppMeasureOp _ Counting    = \End           -> [PP.text "counting"]
+    => 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
@@ -523,28 +540,36 @@
 ppMeasureOp p Gamma   = \(e1 :* e2 :* End) -> ppApply2 p "gamma"       e1 e2
 ppMeasureOp p Beta    = \(e1 :* e2 :* End) -> ppApply2 p "beta"        e1 e2
 
--- BUG: doubles may not properly and unambiguously represent the correct rational! Consider using 'ppRatio' instead.
 instance Pretty Literal where
-    prettyPrec_ _ (LNat  n) = [PP.integer (fromNatural n)]
-    prettyPrec_ _ (LInt  i) = [PP.integer i]
-    prettyPrec_ p (LProb l) =
-        [ppRatio p $ fromNonNegativeRational l]
-    prettyPrec_ p (LReal r) = [ppRatio p r]
+    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)    = [PP.int (fromNat n)]
-    prettyPrec_ _ (VInt  i)    = [PP.int i]
-    prettyPrec_ _ (VProb l)    =
-        [PP.double $ LF.fromLogFloat l]
-    prettyPrec_ _ (VReal r)    = [PP.double r]
+    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 _)     = [PP.text "<function>"]
-    prettyPrec_ _ (VMeasure _) = [PP.text "<measure>"]
-    prettyPrec_ p (VArray a)   =
-        ppList . V.toList $ V.map (toDoc . prettyPrec_ p) a
+    prettyPrec_ _ (VLam _)     = text "<function>"
+    prettyPrec_ _ (VMeasure _) = text "<measure>"
+    prettyPrec_ _ (VArray a)   = ppList . V.toList $ V.map (prettyPrec_ 0) a
 
 prettyValue :: Value a -> Doc
-prettyValue = toDoc . prettyPrec_ 0
+prettyValue = prettyPrec_ 0
 
 instance Pretty f => Pretty (Datum f) where
     prettyPrec_ p (Datum hint _typ d)
@@ -554,73 +579,66 @@
         | otherwise =
             case Text.unpack hint of
             -- Special cases for certain datums
-            "pair"  -> ppFun p ""
-                (foldMap11 ((:[]) . toDoc . prettyPrec_ 11) d) 
-            "true"  -> [PP.text "true"]
-            "false" -> [PP.text "false"]
-            "unit"  -> [PP.text "()"]
+            "pair"  -> ppTuple p (foldMap11 (\e -> [flip prettyPrec_ e]) d) 
+            "true"  -> text "true"
+            "false" -> text "false"
+            "unit"  -> text "()"
             -- General case
-            _       -> ppFun p (Text.unpack hint)
-                (foldMap11 ((:[]) . toDoc . prettyPrec_ 11) d)
-                ++ [PP.text "." <+> prettyType p _typ]
+            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 :: Int -> [Doc] -> Pattern xs a -> (Docs, [Doc])
-ppPattern _ _      PWild = ([PP.text "_"], [])
-ppPattern _ (v:vs) PVar  = ([v], vs)
-ppPattern p vars   (PDatum hint d0)
+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"  -> ([PP.text "true"],  vars)
-        "false" -> ([PP.text "false"], vars)
-        "pair"  -> ppFunWithVars p Text.empty
+        "true"  -> (const (text "true" ), vars)
+        "false" -> (const (text "false"), vars)
+        "pair"  -> ppFunWithVars ppTuple
         -- General case
-        _        -> ppFunWithVars p hint
+        f       -> ppFunWithVars (flip ppFun f)
     where
-    ppFunWithVars p hint = (ppFun p (Text.unpack hint) g, vars')
+    ppFunWithVars ppHint = (flip ppHint g, vars')
        where (g, vars') = goCode d0 vars
 
-    goCode :: PDatumCode xss vars a -> [Doc] -> (Docs, [Doc])
+    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] -> (Docs, [Doc])
+    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] -> (Docs, [Doc])
-    goFun (PKonst d) vars = ([toDoc $ fst r], snd r)
-       where r = ppPattern 11 vars d
-    goFun (PIdent d) vars = ([toDoc $ fst r], snd r)
-       where r = ppPattern 11 vars d
+    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
-    -- 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.
     prettyPrec_ p (Branch pat e) =
-        let (vars, _, body) = ppBinder2 e in
-        [ (toDoc . fst $ ppPattern 11 vars pat) <> PP.colon <> PP.space
-        , PP.nest 1 $ toDoc $ body
-        ]
+        let (vars, body) = ppBinder e
+            (pp, []) = ppPattern vars pat
+        in sep [ pp 0 <> colon, nest 2 body ]
 
 ----------------------------------------------------------------
-type DList a = [a] -> [a]
-
-prettyApps :: (ABT Term abt) => abt '[] (a ':-> b) -> abt '[] a -> Docs
-prettyApps = \ e1 e2 ->
+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  ->
-      let (d, vars) = collectApps e1 (pretty e2 :) in
-      [d <> ppTuple (vars [])]
+-}
+      uncurry (ppApp p) (collectApps e1 [flip prettyPrec e2])
     where
     reduceLams
         :: (ABT Term abt)
@@ -633,79 +651,56 @@
                 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) -> DList Doc -> (Doc, DList Doc)
+        => abt '[] (a ':-> b) -> [Int -> Doc] -> (Int -> Doc, [Int -> Doc])
     collectApps e es = 
-        caseVarSyn e (\x -> (ppVariable x, es)) $ \t ->
+        caseVarSyn e (const ret) $ \t ->
             case t of
-            App_ :$ e1 :* e2 :* End -> collectApps e1 ((pretty e2 :) . es)
-            _                       -> (pretty e, es)
+            App_ :$ e1 :* e2 :* End -> collectApps e1 (flip prettyPrec e2 : es)
+            _                       -> ret
+        where ret = (flip prettyPrec e, es)
 
 
-prettyLams :: (ABT Term abt) => abt '[a] b -> Doc
-prettyLams = \e ->
-    let (d, vars) = collectLams e id in
-    PP.char '\\' <+> PP.sep (vars []) <+> PP.text "->" <+> d
-    where
-    collectLams
-        :: (ABT Term abt)
-        => abt '[a] b -> DList Doc -> (Doc, DList Doc)
-    collectLams e xs = 
-        caseBind e $ \x e' ->
-            let xs' = xs . (ppVariable x :) in
-            caseVarSyn e' (\y -> (ppVariable y, xs')) $ \t ->
-                case t of
-                Lam_ :$ e1 :* End -> collectLams e1 xs'
-                _                 -> (pretty e', xs')
 
-
--- | For the \"@lam $ \x ->\n@\"  style layout.
-adjustHead :: (Doc -> Doc) -> Docs -> Docs
-adjustHead f []     = [f (toDoc [])]
-adjustHead f (d:ds) = f d : ds
-
-parens :: Bool -> Docs -> Docs
-parens True  ds = [PP.parens (PP.nest 1 (toDoc ds))]
-parens False ds = [PP.parens (toDoc ds)]
+ppList :: [Doc] -> Doc
+ppList = brackets . sepComma
 
-ppList :: [Doc] -> Docs
-ppList = (:[]) . PP.brackets . PP.nest 1 . PP.fsep . PP.punctuate PP.comma
+ppTuple :: Int -> [Int -> Doc] -> Doc
+ppTuple _ = parens . sepComma . map ($ 0)
 
-ppTuple :: [Doc] -> Doc
-ppTuple = PP.parens . PP.sep . PP.punctuate PP.comma
+ppApp :: Int -> (Int -> Doc) -> [Int -> Doc] -> Doc
+ppApp p f ds = parensIf (p > 10)
+             $ cat [ f 10, nest 2 (ppTuple 11 ds) ]
 
--- TODO: why does this take the precedence argument if it doesn't care?
-ppFun :: Int -> String -> [Doc] -> Docs
-ppFun _ f [] = [PP.text f <> PP.text "()"]
-ppFun _ f ds = [PP.text f <> ppTuple ds]
+ppFun :: Int -> String -> [Int -> Doc] -> Doc
+ppFun p = ppApp p . const . text
 
-ppArg :: (ABT Term abt) => abt '[] a -> Docs
-ppArg = prettyPrec_ 11 . LC_
+ppApply1 :: (ABT Term abt) => Int -> String -> abt '[] a -> Doc
+ppApply1 p f e1 = ppFun p f [flip prettyPrec e1]
 
-ppApply1 :: (ABT Term abt) => Int -> String -> abt '[] a -> Docs
-ppApply1 p f e1 = ppFun p f [toDoc $ ppArg 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]
 
-ppApply2
-    :: (ABT Term abt) => Int -> String -> abt '[] a -> abt '[] b -> Docs
-ppApply2 p f e1 e2 = ppFun p f [toDoc $ ppArg e1, toDoc $ ppArg 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 -> Docs
+    -> Int -> abt '[] a -> abt '[] b -> Doc
 ppBinop op p0 assoc =
-    let (p1,p2) =
+    let (p1,p2,f1,f2) =
             case assoc of
-            LeftAssoc  -> (p0, 1 + p0)
-            RightAssoc -> (1 + p0, p0)
-            NonAssoc   -> (1 + p0, 1 + p0)
+            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 ->
-        parens (p > p0)
-            [ prettyPrec p1 e1
-            , PP.space <> PP.text op <> PP.space
-            , prettyPrec p2 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
--- a/haskell/Language/Hakaru/Pretty/Haskell.hs
+++ b/haskell/Language/Hakaru/Pretty/Haskell.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE GADTs
+           , OverloadedStrings
            , KindSignatures
            , DataKinds
            , FlexibleContexts
            , UndecidableInstances
+           , LambdaCase
            #-}
 
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
@@ -22,9 +24,11 @@
     (
     -- * The user-facing API
       pretty
+    , prettyString
     , prettyPrec
     , prettyAssoc
     , prettyPrecAssoc
+    , prettyType
 
     -- * Helper functions (semi-public internal API)
     , ppVariable
@@ -44,13 +48,16 @@
 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(..))
+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
@@ -62,6 +69,23 @@
 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_
@@ -80,12 +104,41 @@
         , 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] 
+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
@@ -143,7 +196,7 @@
 -- 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 -> 
+    caseVarSyn e ((:[]) . ppVariable) $ \t ->
         case t of
         o :$ es      -> ppSCon p o es
         NaryOp_ o es ->
@@ -192,13 +245,13 @@
                  [ ppArg e1
                  , toDoc $ ppList (map (toDoc . prettyPrec_ 0) bs)
                  ]
-        Bucket b e r  ->
+        Bucket b ee r  ->
             ppFun p "bucket"
             [ ppArg b
-            , ppArg e
+            , ppArg ee
             , toDoc $ parens True (prettyPrec_ p r)
             ]
-              
+
         Superpose_ pes ->
             case pes of
             (e1,e2) L.:| [] ->
@@ -223,7 +276,7 @@
     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) $ 
+    parens (p > 0) $
         adjustHead
             (PP.text "let_" <+> ppArg e1 <+> PP.char '$' <+>)
             (ppBinder e2)
@@ -245,13 +298,7 @@
         adjustHead
             (prettyPrec 1 e1 <+> PP.text ">>=" <+>)
             (ppBinder e2)
-ppSCon p Expect = \(e1 :* e2 :* End) ->
-    -- N.B., for this to be read back in correctly, "Language.Hakaru.Expect" must be in scope as well as the prelude.
-    parens (p > 0) $
-        adjustHead
-            (PP.text "expect" <+> ppArg e1 <+> PP.char '$' <+>)
-            (ppBinder e2)
-ppSCon p Observe   = \(e1 :* e2 :* End) -> ppApply2 p "observe" e1 e2
+ppSCon p (Transform_ t) = ppTransform p t
 ppSCon p Integrate = \(e1 :* e2 :* e3 :* End) ->
     ppFun p "integrate"
         [ ppArg e1
@@ -272,7 +319,7 @@
         , toDoc $ parens True (ppBinder e3)
         ]
 
-ppSCon _ Plate = \(e1 :* e2 :* End) -> 
+ppSCon _ Plate = \(e1 :* e2 :* End) ->
     ppFun 11 "plate"
         [ ppArg e1 <+> PP.char '$'
         , toDoc $ ppBinder e2
@@ -285,6 +332,19 @@
         , 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...
@@ -346,6 +406,7 @@
 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"]
@@ -361,7 +422,8 @@
 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 (Erf _)     = \(e1 :* End)        -> ppApply1 p "erf"   e1
+ppPrimOp p Floor       = \(e1 :* End)        -> ppApply1 p "floor" e1
 
 
 -- | Pretty-print a 'ArrayOp' @(:$)@ node in the AST.
@@ -384,7 +446,7 @@
 ppMeasureOp
     :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
     => Int -> MeasureOp typs a -> SArgs abt args -> Docs
-ppMeasureOp _ Lebesgue    = \End           -> [PP.text "lebesgue"]
+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
@@ -405,7 +467,7 @@
         | Text.null hint =
             ppFun p "datum_"
                 [error "TODO: prettyPrec_@Datum"]
-        | otherwise = 
+        | otherwise =
           ppFun p "ann_"
             [ PP.parens . PP.text . show $ _typ
             , PP.parens . toDoc $ ppFun p (Text.unpack hint)
@@ -465,12 +527,12 @@
             , toDoc $ prettyPrec_ 11 r1
             , toDoc $ prettyPrec_ 11 r2
             ]
-    prettyPrec_ p Red_Nop             =
+    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
@@ -509,6 +571,9 @@
     :: (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
@@ -557,12 +622,27 @@
             LeftAssoc  -> (p0, 1 + p0)
             RightAssoc -> (1 + p0, p0)
             NonAssoc   -> (1 + p0, 1 + p0)
-    in \p e1 e2 -> 
+    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
--- a/haskell/Language/Hakaru/Pretty/Maple.hs
+++ b/haskell/Language/Hakaru/Pretty/Maple.hs
@@ -123,7 +123,7 @@
         o :$ es          -> mapleSCon o  es
         NaryOp_ op es    -> mapleNary op es
         Literal_ v       -> mapleLiteral v
-        Empty_ _         -> error "TODO: mapleAST{Empty}"
+        Empty_ _         -> brackets id
         Array_ e1 e2     ->
             caseBind e2 $ \x e2' ->
                 app3 "ary" e1 (var x) e2'
@@ -155,8 +155,16 @@
 
 var1 :: Variable (a :: Hakaru) -> ShowS
 var1 x | Text.null (varHint x) = showChar 'x' . (shows . fromNat . varID) x
-       | otherwise             = showString (Text.unpack (varHint 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
@@ -216,17 +224,12 @@
         . showString "..("
         . arg e2
         . showString ")-1)"
-mapleSCon Expect = \(e1 :* e2 :* End) ->
-    error "TODO: mapleSCon{Expect}"
-    {-
-    caseBind e2 $ \x e2' ->
-    arg
-        . expect e1
-        . binder Text.empty (varType x)
-        $ \x' -> subst x x' e2'
-    -}
 
+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"
@@ -310,6 +313,7 @@
 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"
@@ -325,6 +329,7 @@
 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 ++ "}"
 
@@ -338,7 +343,7 @@
 mapleMeasureOp
     :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
     => MeasureOp typs a -> SArgs abt args -> ShowS
-mapleMeasureOp Lebesgue    = \End               -> showString "Lebesgue(-infinity,infinity)"
+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
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/Runtime/CmdLine.hs b/haskell/Language/Hakaru/Runtime/CmdLine.hs
--- a/haskell/Language/Hakaru/Runtime/CmdLine.hs
+++ b/haskell/Language/Hakaru/Runtime/CmdLine.hs
@@ -6,16 +6,38 @@
 module Language.Hakaru.Runtime.CmdLine where
 
 import qualified Data.Vector.Unboxed             as U
-import qualified Data.Vector.Generic             as G
 import qualified System.Random.MWC               as MWC
-import Language.Hakaru.Runtime.Prelude
-import Data.Number.LogFloat
-import Control.Monad (forever)
+import           Control.Monad                   (liftM, ap, forever)
 
 #if __GLASGOW_HASKELL__ < 710
-import Data.Functor
+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
@@ -29,16 +51,17 @@
 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 MakeMain Int where
-  makeMain p _ = print p
-
-instance MakeMain Double where
+instance {-# OVERLAPPABLE #-}
+         Show a => MakeMain a where
   makeMain p _ = print p
 
 instance Show a => MakeMain (Measure a) where
@@ -49,12 +72,7 @@
                        Nothing -> return ()
                        Just s  -> print s
 
-instance {-# OVERLAPPABLE #-}
-         ( Show (v a), (G.Vector (MayBoxVec a) a), v ~ MayBoxVec a)
-         => MakeMain (v a) where
-  makeMain p _ = print p
-
-instance {-# OVERLAPPING #-}(Parseable a, MakeMain b)
+instance (Parseable a, MakeMain b)
          => MakeMain (a -> b) where
   makeMain p (a:as) = do a' <- parse a
                          makeMain (p a') as
diff --git a/haskell/Language/Hakaru/Runtime/LogFloatCmdLine.hs b/haskell/Language/Hakaru/Runtime/LogFloatCmdLine.hs
deleted file mode 100644
--- a/haskell/Language/Hakaru/Runtime/LogFloatCmdLine.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# LANGUAGE CPP,
-             FlexibleContexts,
-             FlexibleInstances,
-             UndecidableInstances,
-             TypeFamilies #-}
-module Language.Hakaru.Runtime.LogFloatCmdLine where
-
-import qualified Data.Vector.Unboxed             as U
-import qualified Data.Vector.Generic             as G
-import qualified System.Random.MWC               as MWC
-import Language.Hakaru.Runtime.LogFloatPrelude
-import Data.Number.LogFloat
-import Control.Monad (forever)
-
-#if __GLASGOW_HASKELL__ < 710
-import Data.Functor
-#endif
-
--- This Read instance really should be the logfloat package
-instance Read LogFloat where
-    readsPrec p s = [(logFloat x, r) | (x, r) <- readsPrec p s]
-
--- 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 Parseable LogFloat 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, Parseable 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 MakeMain Int where
-  makeMain p _ = print p
-
-instance MakeMain Double where
-  makeMain p _ = print p
-
-instance MakeMain LogFloat 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 {-# OVERLAPPABLE #-}
-         ( Show (v a), (G.Vector (MayBoxVec a) a), v ~ MayBoxVec a)
-         => MakeMain (v a) where
-  makeMain p _ = print p
-
-instance {-# OVERLAPPING #-}(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
--- a/haskell/Language/Hakaru/Runtime/LogFloatPrelude.hs
+++ b/haskell/Language/Hakaru/Runtime/LogFloatPrelude.hs
@@ -10,7 +10,7 @@
            , OverloadedStrings
            #-}
 
-{-# OPTIONS_GHC -Wall -fwarn-tabs -fsimpl-tick-factor=1000 #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs -fsimpl-tick-factor=1000 -fno-warn-orphans #-}
 module Language.Hakaru.Runtime.LogFloatPrelude where
 
 #if __GLASGOW_HASKELL__ < 710
@@ -30,9 +30,18 @@
 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
@@ -101,6 +110,7 @@
                 = 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
@@ -118,59 +128,37 @@
 ann_ _ a = a
 {-# INLINE ann_ #-}
 
-exp :: Double -> LogFloat
+exp :: Double -> Prob
 exp = logToLogFloat
 {-# INLINE exp #-}
 
-log :: LogFloat -> Double
+log :: Prob -> Double
 log = logFromLogFloat
 {-# INLINE log #-}
 
-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 #-}
+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 -> LogFloat -> Measure Double
-normal mu sd = makeMeasure $ MWCD.normal mu (fromLogFloat sd)
+normal :: Double -> Prob -> Measure Double
+normal mu sd = makeMeasure $ MWCD.normal mu (fromProb sd)
 {-# INLINE normal #-}
 
-beta :: LogFloat -> LogFloat -> Measure LogFloat
+beta :: Prob -> Prob -> Measure Prob
 beta a b = makeMeasure $ \g ->
-  logFloat <$> MWCD.beta (fromLogFloat a) (fromLogFloat b) g
+  unsafeProb <$> MWCD.beta (fromProb a) (fromProb b) g
 {-# INLINE beta #-}
 
-gamma :: LogFloat -> LogFloat -> Measure LogFloat
+gamma :: Prob -> Prob -> Measure Prob
 gamma a b = makeMeasure $ \g ->
-  logFloat <$> MWCD.gamma (fromLogFloat a) (fromLogFloat b) g
+  unsafeProb <$> MWCD.gamma (fromProb a) (fromProb b) g
 {-# INLINE gamma #-}
 
-categorical :: MayBoxVec LogFloat LogFloat -> Measure Int
-categorical a = makeMeasure $ \g ->
-  fromIntegral <$> MWCD.categorical (U.map prep a) g
+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 #-}
@@ -266,6 +254,12 @@
 just :: a -> Maybe a
 just = Just
 
+left :: a -> Either a b
+left = Left
+
+right :: b -> Either a b
+right = Right
+
 unit :: ()
 unit = ()
 
@@ -293,9 +287,21 @@
 pjust PVar c = Branch { extract = \ma -> case ma of
                                            Nothing -> Nothing
                                            Just x  -> Just (c x) }
-pjust _ _ = error "Runtime.Prelude pjust"
+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"
@@ -323,11 +329,11 @@
 dirac = return
 {-# INLINE dirac #-}
 
-pose :: LogFloat -> Measure a -> Measure a
+pose :: Prob -> Measure a -> Measure a
 pose _ a = a
 {-# INLINE pose #-}
 
-superpose :: [(LogFloat, Measure a)]
+superpose :: [(Prob, Measure a)]
           -> Measure a
 superpose pms = do
   i <- categorical (G.fromList $ map fst pms)
@@ -346,7 +352,7 @@
 unsafeNat :: Int -> Int
 unsafeNat = id
 
-nat2prob :: Int -> LogFloat
+nat2prob :: Int -> Prob
 nat2prob = fromIntegral
 
 fromInt  :: Int -> Double
@@ -358,16 +364,16 @@
 nat2real :: Int -> Double
 nat2real = fromIntegral
 
-fromProb :: LogFloat -> Double
+fromProb :: Prob -> Double
 fromProb = fromLogFloat
 
-unsafeProb :: Double -> LogFloat
+unsafeProb :: Double -> Prob
 unsafeProb = logFloat
 
 real_ :: Rational -> Double
 real_ = fromRational
 
-prob_ :: NonNegativeRational -> LogFloat
+prob_ :: NonNegativeRational -> Prob
 prob_ = fromRational . fromNonNegativeRational
 
 infinity :: Double
@@ -376,16 +382,16 @@
 abs_ :: Num a => a -> a
 abs_ = abs
 
-(**) :: LogFloat -> Double -> LogFloat
+(**) :: Prob -> Double -> Prob
 (**) = pow
 {-# INLINE (**) #-}
 
-pi :: LogFloat
-pi = logFloat P.pi
+pi :: Prob
+pi = unsafeProb P.pi
 {-# INLINE pi #-}
 
-thRootOf :: Int -> LogFloat -> LogFloat
-thRootOf a b = b `pow` (recip $ fromIntegral a)
+thRootOf :: Int -> Prob -> Prob
+thRootOf a b = b ** (recip $ fromIntegral a)
 {-# INLINE thRootOf #-}
 
 array
@@ -407,6 +413,15 @@
 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
diff --git a/haskell/Language/Hakaru/Runtime/Prelude.hs b/haskell/Language/Hakaru/Runtime/Prelude.hs
--- a/haskell/Language/Hakaru/Runtime/Prelude.hs
+++ b/haskell/Language/Hakaru/Runtime/Prelude.hs
@@ -27,6 +27,7 @@
 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
@@ -42,6 +43,8 @@
 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 #-}
@@ -58,48 +61,26 @@
 ann_ _ a = a
 {-# INLINE ann_ #-}
 
-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 #-}
-
 uniform :: Double -> Double -> Measure Double
 uniform lo hi = makeMeasure $ MWC.uniformR (lo, hi)
 {-# INLINE uniform #-}
 
-normal :: Double -> Double -> Measure Double
-normal mu sd = makeMeasure $ MWCD.normal mu sd
+normal :: Double -> Prob -> Measure Double
+normal mu sd = makeMeasure $ MWCD.normal mu (fromProb sd)
 {-# INLINE normal #-}
 
-beta :: Double -> Double -> Measure Double
-beta a b = makeMeasure $ MWCD.beta a b
+beta :: Prob -> Prob -> Measure Prob
+beta a b = makeMeasure $ \g ->
+  unsafeProb <$> MWCD.beta (fromProb a) (fromProb b) g
 {-# INLINE beta #-}
 
-gamma :: Double -> Double -> Measure Double
-gamma a b = makeMeasure $ MWCD.gamma a b
+gamma :: Prob -> Prob -> Measure Prob
+gamma a b = makeMeasure $ \g ->
+  unsafeProb <$> MWCD.gamma (fromProb a) (fromProb b) g
 {-# INLINE gamma #-}
 
-categorical :: MayBoxVec Double Double -> Measure Int
-categorical a = makeMeasure (\g -> fromIntegral <$> MWCD.categorical a g)
+categorical :: MayBoxVec Prob Prob -> Measure Int
+categorical a = makeMeasure $ MWCD.categorical a
 {-# INLINE categorical #-}
 
 plate :: (G.Vector (MayBoxVec a) a) =>
@@ -217,7 +198,6 @@
                   | otherwise  = Nothing
 {-# INLINE extractBool #-}
 
-
 pnothing :: b -> Branch (Maybe a) b
 pnothing b = Branch { extract = \ma -> case ma of
                                          Nothing -> Just b
@@ -269,14 +249,14 @@
 dirac = return
 {-# INLINE dirac #-}
 
-pose :: Double -> Measure a -> Measure a
+pose :: Prob -> Measure a -> Measure a
 pose _ a = a
 {-# INLINE pose #-}
 
-superpose :: [(Double, Measure a)]
+superpose :: [(Prob, Measure a)]
           -> Measure a
 superpose pms = do
-  i <- makeMeasure $ MWCD.categorical (U.fromList $ map fst pms)
+  i <- categorical (G.fromList $ map fst pms)
   snd (pms !! i)
 {-# INLINE superpose #-}
 
@@ -292,7 +272,7 @@
 unsafeNat :: Int -> Int
 unsafeNat = id
 
-nat2prob :: Int -> Double
+nat2prob :: Int -> Prob
 nat2prob = fromIntegral
 
 fromInt  :: Int -> Double
@@ -304,16 +284,16 @@
 nat2real :: Int -> Double
 nat2real = fromIntegral
 
-fromProb :: Double -> Double
+fromProb :: Prob -> Double
 fromProb = id
 
-unsafeProb :: Double -> Double
+unsafeProb :: Double -> Prob
 unsafeProb = id
 
 real_ :: Rational -> Double
 real_ = fromRational
 
-prob_ :: NonNegativeRational -> Double
+prob_ :: NonNegativeRational -> Prob
 prob_ = fromRational . fromNonNegativeRational
 
 infinity :: Double
@@ -322,7 +302,7 @@
 abs_ :: Num a => a -> a
 abs_ = abs
 
-thRootOf :: Int -> Double -> Double
+thRootOf :: Int -> Prob -> Prob
 thRootOf a b = b ** (recip $ fromIntegral a)
 {-# INLINE thRootOf #-}
 
diff --git a/haskell/Language/Hakaru/Sample.hs b/haskell/Language/Hakaru/Sample.hs
--- a/haskell/Language/Hakaru/Sample.hs
+++ b/haskell/Language/Hakaru/Sample.hs
@@ -15,19 +15,21 @@
 
 module Language.Hakaru.Sample where
 
-import           Numeric.SpecFunctions           (logGamma, logBeta, logFactorial)
-import qualified Data.Number.LogFloat            as LF
--- import qualified Numeric.Integration.TanhSinh    as TS
-import qualified System.Random.MWC               as MWC
-import qualified System.Random.MWC.Distributions as MWCD
+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 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)
+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(..), (<$>))
@@ -37,10 +39,10 @@
 import           Control.Monad.Identity
 import           Control.Monad.Trans.Maybe
 import           Control.Monad.State.Strict
-import qualified Data.IntMap                     as IM
+import qualified Data.IntMap                      as IM
 
-import Data.Number.Nat     (fromNat, unsafeNat)
-import Data.Number.Natural (fromNatural, fromNonNegativeRational)
+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
@@ -194,7 +196,6 @@
 evaluateSCon App_ (e1 :* e2 :* End) env =
     case evaluate e1 env of
     VLam f -> f (evaluate e2 env)
-    v      -> case v of {}
 evaluateSCon Let_ (e1 :* e2 :* End) env =
     let v = evaluate e1 env
     in caseBind e2 $ \x e2' ->
@@ -218,22 +219,19 @@
                 caseBind e2 $ \x' e2' ->
                     case evaluate e2' (updateEnv (EAssoc x' a) env) of
                     VMeasure y -> y p' g
-                    v          -> case v of {}
-    v -> case v of {}
 
 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 (fromNat n') $ \v ->
+                V.generate (fromInteger $ fromNatural n') $ \v ->
                     evaluate e' $
-                    updateEnv (EAssoc x . VNat $ unsafeNat v) env
+                    updateEnv (EAssoc x . VNat $ intToNatural v) env
             return
                 ( VArray v'
-                , VProb $ p * V.product (V.map (\(VProb x) -> x) ps)
+                , VProb $ p * V.product (V.map (\(VProb y) -> y) ps)
                 )
-    v -> case v of {}
     where
     performMaybe
         :: MWC.GenIO
@@ -247,16 +245,15 @@
         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 (fromNat n') $ convert g s') start
+                (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 x) -> x) ps)
+                    , VProb $ p * product (map (\(VProb y) -> y) ps)
                     ))
-    v -> case v of {}
     where
     convert
         :: MWC.GenIO
@@ -268,7 +265,6 @@
             (as'', p') <- MaybeT (f' (VProb 1) g)
             let (a, s'') = unPair as''
             return ((a, p'), s'')
-        v -> case v of {}
 
     unPair :: Value (HPair a b) -> (Value a, Value b)
     unPair (VDatum (Datum "pair" _typ
@@ -285,7 +281,6 @@
                      evaluate e3' (updateEnv (EAssoc x i) env))
                   (identityElement $ Sum hs)
                   (enumFromUntilValue hd lo hi)
-    v                        -> case v of {}
 
 evaluateSCon (Product hd hs) (e1 :* e2 :* e3 :* End) env =
     case (evaluate e1 env, evaluate e2 env) of
@@ -296,7 +291,6 @@
                      evaluate e3' (updateEnv (EAssoc x i) env))
                   (identityElement $ Prod hs)
                   (enumFromUntilValue hd lo hi)
-    v                        -> case v of {}
 
 evaluateSCon s _ _ = error $ "TODO: evaluateSCon{" ++ show s ++ "}"
 
@@ -311,49 +305,60 @@
       VDatum a -> if a == dTrue
                   then VDatum dFalse
                   else VDatum dTrue
-      v        -> case v of {}
 
 evaluatePrimOp Pi  End         _   = VProb . LF.logFloat $ pi
 evaluatePrimOp Cos (e1 :* End) env =
     case evaluate e1 env of
       VReal v1 -> VReal . cos $ v1
-      v        -> case v of {}
+
+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
-      v                    -> case v of {}
+
+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
-      v        -> case v of {}
+
+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 =
-    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
-    v                    -> error "TODO: evaluatePrimOp{Equal}"
+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
-    v                    -> error "TODO: evaluatePrimOp{Less}"
+    _                    -> error "TODO: evaluatePrimOp{Less}"
 evaluatePrimOp (NatPow _) (e1 :* e2 :* End) env = 
     case evaluate e2 env of
     VNat  v2 ->
-        let v2' = fromNat v2 in
+        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')
-    v2       -> case v2 of {}
+          _        -> error "NatPow should always return some kind of number"
 evaluatePrimOp (Negate _) (e1 :* End) env = 
     case evaluate e1 env of
     VInt  v -> VInt  (negate v)
@@ -361,7 +366,7 @@
     v       -> case v of {}
 evaluatePrimOp (Abs   _) (e1 :* End) env =
     case evaluate e1 env of
-    VInt  v -> VNat  . unsafeNat   $ abs v
+    VInt  v -> VNat  . unsafeNatural   $ abs v
     VReal v -> VProb . LF.logFloat $ abs v
     v       -> case v of {}
 evaluatePrimOp (Recip _) (e1 :* End) env = 
@@ -374,6 +379,10 @@
     (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 ++ "}")
 
@@ -387,20 +396,17 @@
     -> Value a
 evaluateArrayOp (Index _) = \(e1 :* e2 :* End) env ->
     case (evaluate e1 env, evaluate e2 env) of
-    (VArray v, VNat n) -> v V.! fromNat n
-    _                  -> error "evaluateArrayOp: the impossible happened"
+    (VArray v, VNat n) -> v V.! unsafeInt n
 
 evaluateArrayOp (Size _) = \(e1 :* End) env ->
     case evaluate e1 env of
-    VArray v -> VNat . unsafeNat $ V.length v
-    _        -> error "evaluateArrayOp: the impossible happened"
+    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
-    _                -> error "evaluateArrayOp: the impossible happened"
 
 evaluateMeasureOp
     :: ( ABT Term abt
@@ -411,22 +417,42 @@
     -> Env
     -> Value ('HMeasure a)
 
-evaluateMeasureOp Lebesgue = \End _ ->
-    VMeasure $ \(VProb p) g -> 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
-            )
+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
+        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
@@ -441,7 +467,7 @@
             u <- MWC.uniformR (0, y) g
             return $ Just
                 ( VNat
-                . unsafeNat
+                . intToNatural
                 . fromMaybe 0
                 . V.findIndex (u <=) 
                 . V.scanl1' (+)
@@ -453,35 +479,30 @@
     (VReal v1, VReal v2) -> VMeasure $ \p g -> do
         x <- MWC.uniformR (v1, v2) g
         return $ Just (VReal x, p)
-    _ -> error "evaluateMeasureOp: the impossible happened"
 
 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)
-    _ -> error "evaluateMeasureOp: the impossible happened"
 
 evaluateMeasureOp Poisson = \(e1 :* End) env ->
     case evaluate e1 env of
     VProb v1 -> VMeasure $ \ p g -> do
-        x <- poisson_rng (LF.fromLogFloat v1) g
-        return $ Just (VNat $ unsafeNat x, p)
-    _ -> error "evaluateMeasureOp: the impossible happened"
+        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)
-    _ -> error "evaluateMeasureOp: the impossible happened"
 
 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)
-    _ -> error "evaluateMeasureOp: the impossible happened"
 
 evaluateNaryOp
     :: (ABT Term abt)
@@ -503,6 +524,7 @@
 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
@@ -550,8 +572,8 @@
 evaluateArray n e env =
     case evaluate n env of
     VNat n' -> caseBind e $ \x e' ->
-        VArray $ V.generate (fromNat n') $ \v ->
-            let v' = VNat $ unsafeNat v in
+        VArray $ V.generate (unsafeInt n') $ \v ->
+            let v' = VNat $ intToNatural v in
             evaluate e' (updateEnv (EAssoc x v') env)
 
 evaluateBucket
@@ -567,7 +589,6 @@
           s' <- init Nil1 rs env
           mapM_ (\i -> accum (VNat i) Nil1 rs s' env) [b' .. e' - 1]
           done s'
-      v2                 -> case v2 of {}
     where init :: (ABT Term abt)
                => List1 Value xs
                -> Reducer abt xs a
@@ -575,15 +596,15 @@
                -> 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  =
+          init ix (Red_Index  n  _  mr) env' =
               let (vars, n') = caseBinds n in
-              case evaluate n' (updateEnvs vars ix env) of
+              case evaluate n' (updateEnvs vars ix env') of
                 VNat n'' -> VRed_Array <$> V.generateM (fromIntegral n'')
-                            (\b -> init (Cons1 (vnat b) 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 ix Red_Nop               env  = return VRed_Unit
-          init ix (Red_Add h _) env = VRed_Num <$> newSTRef (identityElement (Sum h))
+                            (\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
 
@@ -597,31 +618,32 @@
                 -> VReducer s a
                 -> Env
                 -> ST s ()
-          accum n ix (Red_Fanout r1 r2)   (VRed_Pair s1 s2 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 =
+          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))
+                            (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 b  r1 r2) (VRed_Pair s1 s2 v1 v2) env =
-              caseBind b $ \i b' ->
+          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 b' -> if b' == dTrue then
-                                   accum n ix r1 v1 env
+                       (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 e) (VRed_Num s) env =
-              caseBind e $ \i e' ->
+                                   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
+                          (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
@@ -690,4 +712,11 @@
                 []     -> 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
--- a/haskell/Language/Hakaru/Simplify.hs
+++ b/haskell/Language/Hakaru/Simplify.hs
@@ -25,14 +25,15 @@
 -- Take strings from Maple and interpret them in Haskell (Hakaru)
 ----------------------------------------------------------------
 module Language.Hakaru.Simplify
-    ( simplify
+    ( simplify, simplifyWithOpts
+    , simplify'
     , simplifyDebug
     ) where
 
 import Language.Hakaru.Syntax.ABT
 import Language.Hakaru.Syntax.AST
-import Language.Hakaru.Syntax.Command
 import Language.Hakaru.Maple 
+import Language.Hakaru.Syntax.TypeCheck
 
 ----------------------------------------------------------------
 
@@ -40,8 +41,20 @@
     :: forall abt a
     .  (ABT Term abt) 
     => abt '[] a -> IO (abt '[] a)
-simplify = sendToMaple defaultMapleOptions{command=Simplify}
+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 a
+    .  (ABT Term (abt Term)) 
+    => TypedAST (abt Term)  -> IO (TypedAST (abt Term))
+simplify' = sendToMaple' defaultMapleOptions{command="Simplify"}
+
 simplifyDebug
     :: forall abt a
     .  (ABT Term abt) 
@@ -49,7 +62,9 @@
     -> Int
     -> abt '[] a
     -> IO (abt '[] a)
-simplifyDebug d t = sendToMaple defaultMapleOptions{command=Simplify,debug=d,timelimit=t}
+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
--- a/haskell/Language/Hakaru/Summary.hs
+++ b/haskell/Language/Hakaru/Summary.hs
@@ -31,7 +31,6 @@
 
 import Language.Hakaru.Syntax.ABT
 import Language.Hakaru.Syntax.AST
-import Language.Hakaru.Syntax.Command
 import Language.Hakaru.Maple 
 
 ----------------------------------------------------------------
@@ -40,13 +39,15 @@
     :: forall abt a
     .  (ABT Term abt) 
     => abt '[] a -> IO (abt '[] a)
-summary = sendToMaple defaultMapleOptions{command=Summarize}
+summary = sendToMaple defaultMapleOptions{command=MapleCommand Summarize}
 
 summaryDebug
     :: forall abt a
     .  (ABT Term abt) 
     => Bool -> abt '[] a -> IO (abt '[] a)
-summaryDebug d = sendToMaple defaultMapleOptions{command=Summarize,debug=d}
+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
--- a/haskell/Language/Hakaru/Syntax/ABT.hs
+++ b/haskell/Language/Hakaru/Syntax/ABT.hs
@@ -72,6 +72,7 @@
     , cataABT
     , cataABTM
     , paraABT
+    , dupABT
 
     -- * Some ABT instances
     , TrivialABT()
@@ -80,16 +81,13 @@
     ) where
 
 import           Data.Text         (Text, empty)
---import qualified Data.IntMap       as IM
 import qualified Data.Foldable     as F
 #if __GLASGOW_HASKELL__ < 710
 import           Control.Applicative hiding (empty)
 import           Data.Monoid                (Monoid(..))
 #endif
 
-import Control.Monad
 import Control.Monad.Identity    
-import Control.Monad.Fix
 import Data.Number.Nat
 import Language.Hakaru.Syntax.IClasses
 -- TODO: factor the definition of the 'Sing' type family out from
@@ -167,8 +165,8 @@
 
 instance Foldable12 View where
     foldMap12 f (Syn  t)   = f t
-    foldMap12 f (Var  x)   = mempty
-    foldMap12 f (Bind x e) = foldMap12 f e
+    foldMap12 _ (Var  _)   = mempty
+    foldMap12 f (Bind _ e) = foldMap12 f e
 
 instance Traversable12 View where
     traverse12 f (Syn t)    = Syn <$> f t
@@ -690,6 +688,7 @@
 -- | 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 -> *), Show1 (Sing :: k -> *))
     => Variable (a :: k)
@@ -796,7 +795,7 @@
     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 _ f (Var z) =
+    loop _ _ (Var z) =
 #ifdef __TRACE_DISINTEGRATE__
         trace ("checking varEq " ++ show (varID x) ++ " " ++ show (varID z)) $
 #endif        
@@ -959,11 +958,11 @@
   -> (abt '[] a -> m (abt xs b))
   -> m (abt (a ': xs) b)
 binderM hint typ hoas = do
-  (var, body) <- mfix $ \ ~(_, b) -> do
+  (var', body) <- mfix $ \ ~(_, b) -> do
     let v = Variable hint (nextBind b) typ
     b' <- hoas (var v)
     return (v, b')
-  return (bind var body)
+  return (bind var' body)
 
 class (ABT syn abt) =>
     Binders syn abt xs as | abt -> syn, abt xs -> as, abt as -> xs where
@@ -1129,6 +1128,16 @@
         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/AST.hs b/haskell/Language/Hakaru/Syntax/AST.hs
--- a/haskell/Language/Hakaru/Syntax/AST.hs
+++ b/haskell/Language/Hakaru/Syntax/AST.hs
@@ -8,6 +8,8 @@
            , FlexibleContexts
            , UndecidableInstances
            , Rank2Types
+           , DeriveDataTypeable
+           , LambdaCase
            #-}
 
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
@@ -40,8 +42,10 @@
       SCon(..)
     , SArgs(..)
     , Term(..)
+    , Transform(..), TransformImpl(..)
+    -- allTransforms, transformName comes from Transform
     -- * Operators
-    , LC, LCs, UnLCs
+    , LCs, UnLCs -- LC comes from SArgs
     , LC_(..)
     , NaryOp(..)
     , PrimOp(..)
@@ -53,6 +57,8 @@
     -- * implementation details
     , foldMapPairs
     , traversePairs
+    , module Language.Hakaru.Syntax.SArgs
+    , module Language.Hakaru.Syntax.Transform
     ) where
 
 import           Data.Sequence (Seq)
@@ -67,6 +73,8 @@
 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
@@ -77,6 +85,9 @@
 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'
@@ -105,7 +116,8 @@
     eq1 (LInt  x) (LInt  y) = x == y
     eq1 (LProb x) (LProb y) = x == y
     eq1 (LReal x) (LReal y) = x == y
-    eq1 _         _          = False
+    -- Because of GADTs, the following is apparently redundant
+    -- eq1 _         _          = False
 
 instance Eq (Literal a) where
     (==) = eq1
@@ -245,10 +257,6 @@
 ----------------------------------------------------------------
 -- TODO: should we define our own datakind for @([Hakaru], Hakaru)@ or perhaps for the @/\a -> ([a], Hakaru)@ part of it?
 
--- | Locally closed values (i.e., not binding forms) of a given type.
--- TODO: come up with a better name
-type LC (a :: Hakaru) = '( '[], a )
-
 -- BUG: how to declare that these are inverses?
 type family LCs (xs :: [Hakaru]) :: [([Hakaru], Hakaru)] where
     LCs '[]       = '[]
@@ -327,6 +335,7 @@
     -- 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)@
@@ -362,7 +371,6 @@
     -- 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".
@@ -401,6 +409,10 @@
     -- 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
@@ -531,7 +543,7 @@
     -- 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
+    Lebesgue    :: MeasureOp '[ 'HReal, 'HReal ] 'HReal
     Counting    :: MeasureOp '[]                 'HInt
     Categorical :: MeasureOp '[ 'HArray 'HProb ] 'HNat
     -- TODO: make Uniform polymorphic, so that if the two inputs
@@ -575,9 +587,7 @@
 -- 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 ($)
-infixr 5 :* -- Chosen to match (:)
 
-
 -- | 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
@@ -678,81 +688,13 @@
         -> HSemiring b
         -> SCon '[ LC a, LC a, '( '[ a ], b) ] b
 
-    -- -- Internalized program transformations
-    -- TODO: do these belong in their own place?
-    --
-    -- We generally want to evaluate these away at compile-time,
-    -- but sometimes we may be stuck with a few unresolved things
-    -- for open terms.
-
-    -- TODO: did we want the singleton @a@ argument back?
-    Expect :: SCon '[ LC ('HMeasure a), '( '[ a ], 'HProb) ] 'HProb
-
-    -- TODO: implement a \"change of variables\" program transformation
-    -- to map, say, @Lam_ x. blah (Expect x)@ into @Lam x'. blah x'@.
-    -- Or, perhaps rather, transform it into @Lam_ x. App_ (Lam_ x'. blah x') (Expect x)@.
-
-    -- TODO: add the four ops for disintegration
-    Observe :: SCon '[ LC ('HMeasure a), LC a ] ('HMeasure a)
-
+    -- 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)
-
-
-----------------------------------------------------------------
--- 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)
-
--- 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
-    eq1 _         _         = False
-
-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
-
 
 ----------------------------------------------------------------
 -- | The generating functor for Hakaru ASTs. This type is given in
diff --git a/haskell/Language/Hakaru/Syntax/AST/Eq.hs b/haskell/Language/Hakaru/Syntax/AST/Eq.hs
--- a/haskell/Language/Hakaru/Syntax/AST/Eq.hs
+++ b/haskell/Language/Hakaru/Syntax/AST/Eq.hs
@@ -14,7 +14,7 @@
 -- (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 #-}
+{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-orphans -fno-warn-name-shadowing #-}
 ----------------------------------------------------------------
 --                                                    2016.05.24
 -- |
@@ -128,25 +128,39 @@
     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')
+jmEq_S (Transform_ t0) es (Transform_ t1)   es' = do
     Refl <- jmEq1 es es'
+    Refl <- jmEq_Transform t0 t1
     Just (Refl, Refl)
-jmEq_S Expect    es Expect     es' =
-    jmEq1 es es' >>= \Refl -> 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 pat e, Branch pat' e')]    = do
+jmEq_Branch [(Branch _ e, Branch _ e')]    = do
     (Refl, Refl) <- jmEq2 e e'
     return Refl
-jmEq_Branch ((Branch pat e, Branch pat' e'):es) = do
+jmEq_Branch ((Branch _ e, Branch _ e'):es) = do
     (Refl, Refl) <- jmEq2 e e'
     jmEq_Branch es
 
@@ -307,10 +321,10 @@
 
 
 alphaEq
-    :: forall abt a
+    :: forall abt d
     .  (ABT Term abt)
-    => abt '[] a
-    -> abt '[] a
+    => abt '[] d
+    -> abt '[] d
     -> Bool
 alphaEq e1 e2 =
     maybe False (const True)
@@ -380,7 +394,6 @@
     sArgsEq (e1 :* es1) (e2 :* es2) = do
         go (viewABT e1) (viewABT e2)
         sArgsEq es1 es2
-    sArgsEq _ _ = lift Nothing
 
     sConEq
         :: forall a args1 args2
@@ -446,19 +459,37 @@
         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 Expect (e1  :* e2  :* End)
-           Expect (e1' :* e2' :* End) = do
-        Refl <- lift $ jmEq1 (typeOf e1) (typeOf e1')
-        go (viewABT e1) (viewABT e1')
-        go (viewABT e2) (viewABT 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
@@ -467,9 +498,9 @@
         => PrimOp typs1 a -> SArgs abt args1
         -> PrimOp typs2 a -> SArgs abt args2
         -> ReaderT Varmap Maybe ()
-    primOpEq p1 e1 p2 e2 = do
+    primOpEq p1 e1' p2 e2' = do
         (Refl, Refl) <- lift $ jmEq2 p1 p2
-        sArgsEq e1 e2
+        sArgsEq e1' e2'
 
     arrayOpEq
         :: forall a typs1 typs2 args1 args2
@@ -489,9 +520,9 @@
         => MeasureOp typs1 a -> SArgs abt args1
         -> MeasureOp typs2 a -> SArgs abt args2
         -> ReaderT Varmap Maybe ()
-    measureOpEq m1 e1 m2 e2 = do
+    measureOpEq m1 e1' m2 e2' = do
         (Refl,Refl) <- lift $ jmEq2 m1 m2
-        sArgsEq e1 e2
+        sArgsEq e1' e2'
 
     datumEq :: forall a
         .  Datum (abt '[]) a
@@ -517,7 +548,6 @@
         datumFunEq c1 d1
         datumStructEq c2 d2
     datumStructEq Done       Done       = return ()
-    datumStructEq _          _          = lift Nothing
     
     datumFunEq
         :: forall x a
@@ -526,23 +556,22 @@
         -> ReaderT Varmap Maybe ()
     datumFunEq (Konst e) (Konst f) = go (viewABT e) (viewABT f) 
     datumFunEq (Ident e) (Ident f) = go (viewABT e) (viewABT f) 
-    datumFunEq _          _        = lift Nothing
     
     pairEq
-        :: forall a b
-        .  (abt '[] a, abt '[] b)
-        -> (abt '[] a, abt '[] b)
+        :: 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 a b
-        .  Branch a abt b
-        -> Branch a abt b
+        :: forall c b
+        .  Branch c abt b
+        -> Branch c abt b
         -> ReaderT Varmap Maybe ()
-    sBranch (Branch p1 e1) (Branch p2 e2) = patternEq p1 p2 >> go (viewABT e1) (viewABT e2)
+    sBranch (Branch p3 e3) (Branch p4 e4) = patternEq p3 p4 >> go (viewABT e3) (viewABT e4)
 
     patternEq 
         :: Pattern a0 b0
@@ -580,9 +609,9 @@
     pdatumFunEq _          _          = lift Nothing
 
     reducerEq
-        :: forall xs a
-        .  Reducer abt xs a
-        -> Reducer abt xs a
+        :: 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'
diff --git a/haskell/Language/Hakaru/Syntax/AST/Sing.hs b/haskell/Language/Hakaru/Syntax/AST/Sing.hs
--- a/haskell/Language/Hakaru/Syntax/AST/Sing.hs
+++ b/haskell/Language/Hakaru/Syntax/AST/Sing.hs
@@ -72,8 +72,10 @@
 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)
@@ -121,7 +123,7 @@
 
 
 sing_MeasureOp :: MeasureOp typs a -> (List1 Sing typs, Sing a)
-sing_MeasureOp Lebesgue    = (Nil1, sing)
+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)
diff --git a/haskell/Language/Hakaru/Syntax/AST/Transforms.hs b/haskell/Language/Hakaru/Syntax/AST/Transforms.hs
--- a/haskell/Language/Hakaru/Syntax/AST/Transforms.hs
+++ b/haskell/Language/Hakaru/Syntax/AST/Transforms.hs
@@ -1,9 +1,10 @@
 {-# LANGUAGE FlexibleContexts
            , GADTs
-           , Rank2Types
            , ScopedTypeVariables
            , DataKinds
            , TypeOperators
+           , OverloadedStrings
+           , LambdaCase
            #-}
 
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
@@ -21,11 +22,37 @@
 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       (expect)
-import Language.Hakaru.Disintegrate (determine, observe)
+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
@@ -64,24 +91,175 @@
 
                    _ -> 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 =
-    cataABT var bind alg
-    where 
-    alg :: forall b. Term abt b -> abt '[] b
-    alg t =
-        case t of
-        Expect  :$ e1 :* e2 :* End -> expect  e1 e2
-        Observe :$ e1 :* e2 :* End ->
-          case determine (observe e1 e2) of
-          Just t' -> t'
-          Nothing -> syn t
-        _                         -> syn t
-        
+  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)
diff --git a/haskell/Language/Hakaru/Syntax/Command.hs b/haskell/Language/Hakaru/Syntax/Command.hs
deleted file mode 100644
--- a/haskell/Language/Hakaru/Syntax/Command.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-{-# LANGUAGE FlexibleInstances
-           , GADTs
-           , DataKinds
-           , TypeOperators
-           , ViewPatterns
-           , KindSignatures
-           , RankNTypes
-           , UndecidableInstances 
-           #-}
-
-{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
--- |
--- Module      :  Language.Hakaru.Syntax.Command  
--- Copyright   :  Copyright (c) 2016 the Hakaru team
--- License     :  BSD3
--- Stability   :  experimental
--- Portability :  GHC-only
---
--- An encoding of (some) Hakaru commands and their types. 
-----------------------------------------------------------------
-module Language.Hakaru.Syntax.Command where 
-    
-import Language.Hakaru.Types.Sing
-import Language.Hakaru.Types.DataKind
-import Language.Hakaru.Syntax.ABT
-import Language.Hakaru.Syntax.AST
-import Language.Hakaru.Syntax.IClasses
-import GHC.TypeLits (Symbol)
-import Data.List (isInfixOf)
-import Data.Char (toLower)
-import Data.Function (on) 
-
-----------------------------------------------------------------
-
-data CommandType (c :: Symbol) (i :: Hakaru) (o :: Hakaru) where 
-  Simplify     :: CommandType "Simplify"     a a 
-  DisintMeas   :: CommandType "Disintegrate" (HMeasure (HPair a b)) (a :-> HMeasure b)
-  DisintFun    :: !(CommandType "Disintegrate" x x') 
-               -> CommandType "Disintegrate" (a :-> x) (a :-> x') 
-  Summarize    :: CommandType "Summarize"     a a 
-
-commandIsType :: CommandType c i o -> Sing i -> Sing o
-commandIsType DisintMeas (SMeasure (sUnPair->(a,b))) = SFun a (SMeasure b)
-commandIsType (DisintFun t) (SFun a x) = SFun a (commandIsType t x)
-commandIsType Simplify x = x
-commandIsType Summarize x = x
-  
-nameOfCommand :: CommandType c i o -> Sing c
-nameOfCommand Simplify{} = sing 
-nameOfCommand Summarize{} = sing 
-nameOfCommand DisintMeas{} = sing
-nameOfCommand DisintFun{} = sing 
-
-parseCommand = flip (isInfixOf `on` map toLower)
-
-commandFromName 
-  :: String 
-  -> Sing i 
-  -> (forall o c . Either Bool (CommandType c i o, Sing o) -> k) 
-  -> k
-commandFromName (parseCommand "Simplify"->True) i k = k $ Right (Simplify, i)
-
-commandFromName (parseCommand "Disintegrate"->True) i k = 
-  let disint_commandFromType 
-        :: Sing i 
-        -> (forall o . Either Bool (CommandType "Disintegrate" i o, Sing o) -> k) 
-        -> k
-      disint_commandFromType i k = 
-        case i of 
-          SMeasure (SData (STyApp (STyApp (STyCon (jmEq1 sSymbol_Pair -> Just Refl)) a) b) _) -> 
-            k $ Right (DisintMeas, SFun a (SMeasure b))
-          SFun a x -> 
-            disint_commandFromType x $ \q -> 
-              k $ fmap (\(c,x') -> (DisintFun c, SFun a x')) q
-          _ -> k $ Left True
-  in disint_commandFromType i k 
-
-commandFromName (parseCommand "Summarize"->True) i k = k $ Right (Summarize, i)
-
-commandFromName _ _ k = k $ Left False 
diff --git a/haskell/Language/Hakaru/Syntax/Datum.hs b/haskell/Language/Hakaru/Syntax/Datum.hs
--- a/haskell/Language/Hakaru/Syntax/Datum.hs
+++ b/haskell/Language/Hakaru/Syntax/Datum.hs
@@ -40,7 +40,7 @@
     , DatumStruct(..)
     , DatumFun(..)
     -- ** Some smart constructors for the \"built-in\" datatypes
-    , dTrue, dFalse
+    , dTrue, dFalse, dBool
     , dUnit
     , dPair
     , dLeft, dRight
@@ -253,7 +253,6 @@
 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
-    eq1 _          _          = False
 
 instance Eq1 ast => Eq (DatumStruct xs ast a) where
     (==) = eq1
@@ -305,7 +304,6 @@
 instance Eq1 ast => Eq1 (DatumFun x ast) where
     eq1 (Konst e) (Konst f) = eq1 e f
     eq1 (Ident e) (Ident f) = eq1 e f
-    eq1 _         _         = False
 
 instance Eq1 ast => Eq (DatumFun x ast a) where
     (==) = eq1
@@ -346,6 +344,9 @@
 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
 
@@ -582,12 +583,10 @@
     Refl <- jmEq_PStruct c2 d2
     Just Refl
 jmEq_PStruct PDone PDone = Just Refl
-jmEq_PStruct _     _     = Nothing
 
 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
-jmEq_PFun _           _           = Nothing
 
 
 #if __PARTIAL_DATUM_JMEQ__
@@ -654,7 +653,6 @@
 instance Eq2 (PDatumFun x) where
     eq2 (PKonst e) (PKonst f) = eq2 e f
     eq2 (PIdent e) (PIdent f) = eq2 e f
-    eq2 _          _          = False
 
 instance Eq1 (PDatumFun x vars) where
     eq1 = eq2
diff --git a/haskell/Language/Hakaru/Syntax/DatumCase.hs b/haskell/Language/Hakaru/Syntax/DatumCase.hs
--- a/haskell/Language/Hakaru/Syntax/DatumCase.hs
+++ b/haskell/Language/Hakaru/Syntax/DatumCase.hs
@@ -39,6 +39,7 @@
     ) where
 
 import Data.Proxy (Proxy(..))
+import Prelude hiding ((<>))
 
 import Language.Hakaru.Syntax.IClasses
 -- TODO: make things polykinded so we can make our ABT implementation
@@ -306,7 +307,6 @@
     PVar               ->
         case vars of
         Cons1 x vars'  -> return . Just $ Matched_ (Assoc x e :) vars'
-        _              -> error "matchPattern: the impossible happened"
     PDatum _hint1 pat1 -> do
         mb <- getDatum e
         case mb of
@@ -351,7 +351,6 @@
         matchFun    getDatum d1 p1 vars0 `bindMMR` \xs1 vars1 ->
         matchStruct getDatum d2 p2 vars1 `bindMMR` \xs2 vars2 ->
         return . Just $ Matched_ (xs1 . xs2) vars2
-    _ -> return Nothing
     where
     -- TODO: just turn @Maybe MatchState@ into a monad already?
     bindMMR m k = do
@@ -372,7 +371,6 @@
     case (d,pat) of
     (Konst d2, PKonst p2) -> matchPattern getDatum d2 p2 vars
     (Ident d1, PIdent p1) -> matchPattern getDatum d1 p1 vars
-    _                     -> return Nothing
 
 ----------------------------------------------------------------
 ----------------------------------------------------------- fin.
diff --git a/haskell/Language/Hakaru/Syntax/Hoist.hs b/haskell/Language/Hakaru/Syntax/Hoist.hs
--- a/haskell/Language/Hakaru/Syntax/Hoist.hs
+++ b/haskell/Language/Hakaru/Syntax/Hoist.hs
@@ -43,7 +43,7 @@
 module Language.Hakaru.Syntax.Hoist (hoist) where
 
 import           Control.Applicative             (liftA2)
-import           Control.Monad.RWS
+import           Control.Monad.RWS               hiding ((<>))
 import qualified Data.Foldable                   as F
 import qualified Data.Graph                      as G
 import qualified Data.IntMap.Strict              as IM
@@ -66,6 +66,10 @@
 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))
@@ -152,9 +156,14 @@
 -- 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 []
-  mappend = unionEntrySet
+#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.
diff --git a/haskell/Language/Hakaru/Syntax/IClasses.hs b/haskell/Language/Hakaru/Syntax/IClasses.hs
--- a/haskell/Language/Hakaru/Syntax/IClasses.hs
+++ b/haskell/Language/Hakaru/Syntax/IClasses.hs
@@ -7,6 +7,10 @@
            , TypeFamilies
            , Rank2Types
            , ScopedTypeVariables
+           , ConstraintKinds
+           , MultiParamTypeClasses
+           , FlexibleInstances
+           , UndecidableInstances
            #-}
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
 ----------------------------------------------------------------
@@ -71,15 +75,20 @@
     , 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
@@ -467,7 +476,6 @@
 
     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 #-}
@@ -478,7 +486,6 @@
     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
@@ -490,7 +497,6 @@
     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
@@ -563,7 +569,13 @@
 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
@@ -749,7 +761,6 @@
 instance Eq1 a  => Eq1 (List1 a) where
     eq1 Nil1         Nil1         = True
     eq1 (Cons1 x xs) (Cons1 y ys) = eq1 x y && eq1 xs ys
-    eq1 _            _            = False
 
 instance Eq1 a  => Eq (List1 a xs) where
     (==) = eq1
@@ -766,6 +777,22 @@
     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>
diff --git a/haskell/Language/Hakaru/Syntax/Prelude.hs b/haskell/Language/Hakaru/Syntax/Prelude.hs
--- a/haskell/Language/Hakaru/Syntax/Prelude.hs
+++ b/haskell/Language/Hakaru/Syntax/Prelude.hs
@@ -62,6 +62,10 @@
     , negativeInfinity
     -- *** Trig
     , sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh
+    -- Choose
+    , choose
+    -- *** coercions-that-compute
+    , floor
     
     -- * Measures
     -- ** Abstract nonsense
@@ -72,7 +76,7 @@
     , 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, lebesgue'
     , counting
     , densityCategorical, categorical, categorical'
     , densityUniform, uniform, uniform'
@@ -141,7 +145,6 @@
 import qualified Data.List.NonEmpty  as L
 import           Data.Semigroup      (Semigroup(..))
 import           Control.Category    (Category(..))
-import           Control.Monad       (return)
 import           Control.Monad.Fix
 
 import Data.Number.Natural
@@ -398,7 +401,6 @@
                 PrimOp_ Not :$ es' ->
                     case es' of
                     e' :* End -> Just e'
-                    _         -> error "not: the impossible happened"
                 NaryOp_ And xs ->
                     Just . syn . NaryOp_ Or  $ Prelude.fmap not xs
                 NaryOp_ Or xs ->
@@ -522,7 +524,6 @@
                 PrimOp_ (Negate _theRing) :$ es' ->
                     case es' of
                     e' :* End -> Just e'
-                    _         -> error "negate: the impossible happened"
                 _ -> Nothing
 
 
@@ -548,7 +549,6 @@
                 CoerceTo_ (CCons (Signed _theRing) CNil) :$ es' ->
                     case es' of
                     e' :* End -> Just e'
-                    _         -> error "abs_: the impossible happened"
                 _ -> Nothing
 
 
@@ -582,7 +582,6 @@
                 PrimOp_ (Recip _theFrac) :$ es' ->
                     case es' of
                     e :* End -> Just e
-                    _ -> error "recip: the impossible happened"
                 _ -> Nothing
 
 
@@ -717,7 +716,13 @@
 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)
@@ -1262,9 +1267,11 @@
     -> 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 = measure0_ Lebesgue
+lebesgue = lebesgue' negativeInfinity infinity 
 
 counting :: (ABT Term abt) => abt '[] ('HMeasure 'HInt)
 counting = measure0_ Counting
diff --git a/haskell/Language/Hakaru/Syntax/Reducer.hs b/haskell/Language/Hakaru/Syntax/Reducer.hs
--- a/haskell/Language/Hakaru/Syntax/Reducer.hs
+++ b/haskell/Language/Hakaru/Syntax/Reducer.hs
@@ -60,7 +60,7 @@
     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 f Red_Nop             = pure Red_Nop
+    traverse22 _ Red_Nop             = pure Red_Nop
     traverse22 f (Red_Add h e)       = Red_Add h <$> f e
 
 
diff --git a/haskell/Language/Hakaru/Syntax/Rename.hs b/haskell/Language/Hakaru/Syntax/Rename.hs
--- a/haskell/Language/Hakaru/Syntax/Rename.hs
+++ b/haskell/Language/Hakaru/Syntax/Rename.hs
@@ -29,17 +29,9 @@
 ----------------------------------------------------------------
 module Language.Hakaru.Syntax.Rename 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
-import           Language.Hakaru.Syntax.Variable
 import qualified Data.Text as Text 
 import           Data.Text (Text) 
 import           Data.Char 
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
--- a/haskell/Language/Hakaru/Syntax/TypeCheck.hs
+++ b/haskell/Language/Hakaru/Syntax/TypeCheck.hs
@@ -35,6 +35,7 @@
     , inferable
     , mustCheck
     , TypedAST(..)
+    , onTypedAST, onTypedASTM, elimTypedAST
     , inferType
     , checkType
     ) where
@@ -43,6 +44,7 @@
 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
@@ -56,6 +58,8 @@
 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
@@ -72,6 +76,9 @@
 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)
 
 ----------------------------------------------------------------
 ----------------------------------------------------------------
@@ -165,7 +172,6 @@
     -- 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.Empty_             = True
     go (U.Pair_ e1 e2)      = mustCheck  e1 && mustCheck e2
     go (U.Array_ _ e1)      = mustCheck' e1
     go (U.ArrayLiteral_ es) = F.all mustCheck es
@@ -188,225 +194,29 @@
     go (U.Product_    _ _ _) = False
     go (U.Bucket_     _ _ _) = False
     go U.Reject_             = True
-    go (U.Expect_ _ e2)      = mustCheck' e2
-    go (U.Observe_  e1  _)   = mustCheck  e1
+    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'
 
-----------------------------------------------------------------
-----------------------------------------------------------------
-
-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
-
-{-
--- 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
--}
-
-showT :: Show a => a -> Text
-showT = pack . show
-
-show1T :: Show1 a => a (i :: Hakaru) -> Text
-show1T = pack . show1
-
-
--- | 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
-
-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\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 -> show1T typ }
-    msg2 = case typ2 of { Left msg -> msg; Right typ -> show1T 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 ", showT 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 ", showT typ1, " and ", showT 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"
-
-----------------------------------------------------------------
-----------------------------------------------------------------
--- 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)
-
-instance Show2 abt => Show (TypedAST abt) where
-    showsPrec p (TypedAST typ e) =
-        showParen_12 p "TypedAST" typ e
-
-
-makeVar :: forall (a :: Hakaru). Variable 'U.U -> Sing a -> Variable a
-makeVar (Variable hintID nameID _) typ =
-    Variable hintID nameID typ
-
-
 inferBinder
     :: (ABT Term abt)
     => Sing a
@@ -461,13 +271,6 @@
     Nil1        -> checkType eTyp e
     Cons1 x xs' -> pushCtx x (bind x <$> checkBinders xs' eTyp e)
 
-
--- 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)
-
 ----------------------------------------------------------------
 -- | Given a typing environment and a term, synthesize the term's
 -- type (and produce an elaborated term):
@@ -519,11 +322,15 @@
 
        U.App_ e1 e2 -> do
            TypedAST typ1 e1' <- inferType_ e1
-           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)
+           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.
@@ -632,37 +439,22 @@
        U.MBind_ e1 e2 ->
            caseBind e2 $ \x e2' -> do
            TypedAST typ1 e1' <- inferType_ e1
-           case typ1 of
-               SMeasure typ2 ->
-                   let x' = makeVar x typ2 in
-                   pushCtx x' $ do
-                       TypedAST typ3 e3' <- inferType_ e2'
-                       case typ3 of
-                           SMeasure _ ->
-                               return . TypedAST typ3 $
-                                   syn (MBind :$ e1' :* bind x' e3' :* End)
-                           _ -> typeMismatch sourceSpan (Left "HMeasure") (Right typ3)
-                   {-
-                   -- BUG: the \"ambiguous\" @abt@ issue again...
-                   inferBinder typ2 e2 $ \typ3 e2' ->
-                       case typ3 of
-                       SMeasure _ -> return . TypedAST typ3 $
-                           syn (MBind :$ e1' :* e2' :* End)
-                       _ -> typeMismatch (Left "HMeasure") (Right typ3)
-                   -}
-               _ -> typeMismatch sourceSpan (Left "HMeasure") (Right typ1)
+           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'
-               case typ2 of
-                   SMeasure typ3 ->
-                       return . TypedAST (SMeasure . SArray $ typ3) $
-                              syn (Plate :$ e1' :* bind x' e3' :* End)
-                   _ -> typeMismatch sourceSpan (Left "HMeasure") (Right typ2)
+            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
@@ -671,14 +463,11 @@
            let x' = makeVar x typ2
            pushCtx x' $ do
                TypedAST typ3 e4' <- inferType_ e3'
-               case typ3 of
-                   SMeasure (SData (STyCon sym `STyApp` a `STyApp` b) _) ->
-                       case (jmEq1 sym sSymbol_Pair, jmEq1 b typ2) of
-                       (Just Refl, Just Refl) ->
-                           return . TypedAST (SMeasure $ sPair (SArray a) typ2) $
-                                  syn (Chain :$ e1' :* e2' :* bind x' e4' :* End)
-                       _ -> typeMismatch sourceSpan (Left "HMeasure(HPair)") (Right typ3)
-                   _     -> typeMismatch sourceSpan (Left "HMeasure(HPair)") (Right typ3)
+               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
@@ -714,21 +503,7 @@
            return . TypedAST typ1 $
                   syn (Bucket e1' e2' r1')
 
-       U.Expect_ e1 e2 -> do
-           TypedAST typ1 e1' <- inferType_ e1
-           case typ1 of
-               SMeasure typ2 -> do
-                   e2' <- checkBinder typ2 SProb e2
-                   return . TypedAST SProb $ syn (Expect :$ e1' :* e2' :* End)
-               _ -> typeMismatch sourceSpan (Left "HMeasure") (Right typ1)
-
-       U.Observe_ e1 e2 -> do
-           TypedAST typ1 e1' <- inferType_ e1
-           case typ1 of
-               SMeasure typ2 -> do
-                   e2' <- checkType_ typ2 e2
-                   return . TypedAST typ1 $ syn (Observe :$ e1' :* e2' :* End)
-               _ -> typeMismatch sourceSpan (Left "HMeasure") (Right typ1)
+       U.Transform_ tr es -> inferTransform sourceSpan tr es
 
        U.Superpose_ pes -> do
            -- TODO: clean up all this @map fst@, @map snd@, @zip@ stuff
@@ -738,15 +513,85 @@
                StrictMode -> inferOneCheckOthers_    (L.toList $ fmap snd pes)
                LaxMode    -> inferLubType sourceSpan (L.toList $ fmap snd pes)
                UnsafeMode -> inferLubType sourceSpan (L.toList $ fmap snd pes)
-           case typ of
-               SMeasure _ -> do
-                   ps' <- T.traverse (checkType SProb) (fmap fst pes)
-                   return $ TypedAST typ (syn (Superpose_ (L.zip ps' (L.fromList es'))))
-               _ -> typeMismatch sourceSpan (Left "HMeasure") (Right typ)
+           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]
@@ -776,6 +621,14 @@
                               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
@@ -932,6 +785,12 @@
                          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)
 
 
@@ -941,37 +800,31 @@
   inferArrayOp U.Index_ es =
       case es of
         [e1, e2] -> do TypedAST typ1 e1' <- inferType_ e1
-                       case typ1 of
-                         SArray typ2 -> do
-                           e2' <- checkType_ SNat e2
-                           return . TypedAST typ2 $
-                                  syn (ArrayOp_ (Index typ2) :$ e1' :* e2' :* End)
-                         _ -> typeMismatch Nothing (Left "HArray") (Right typ1)
+                       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
-                  case typ of
-                    SArray typ1 -> do
-                       return . TypedAST SNat $
-                              syn (ArrayOp_ (Size typ1) :$ e' :* End)
-                    _ -> typeMismatch Nothing (Left "HArray") (Right typ)
+                  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
-           case typ of
-             SFun 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)
-             _ -> typeMismatch Nothing (Right typ) (Left "HFun")
+           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
@@ -1016,87 +869,6 @@
               h <- getHSemiring typ
               return $ TypedReducer typ xs (Red_Add h (bind x' e3))
 
-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
-
-
-
-----------------------------------------------------------------
-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
--}
-
 -- 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
@@ -1135,27 +907,6 @@
         :: forall a. Sing a -> [U.AST] -> TypeCheckMonad [abt '[] a]
     checkOthers typ = T.traverse (checkType typ)
 
-
--- 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
-
 -- | 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
@@ -1214,24 +965,6 @@
         :: forall b. Sing b -> [U.Branch] -> TypeCheckMonad [Branch a abt b]
     checkOthers typ = T.traverse (checkBranch typA typ)
 
-data SomeBranch a abt = forall b. SomeBranch !(Sing b) [Branch a abt b]
-
--- 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)
-
-
 inferCaseLax
     :: forall abt a
     .  (ABT Term abt)
@@ -1331,13 +1064,10 @@
         -- 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 ->
-            case typ0 of
-            SFun typ1 typ2 ->
-                case jmEq1 typ1 typ of
-                  Just Refl -> do e1' <- checkBinder typ1 typ2 e1
-                                  return $ syn (Lam_ :$ e1' :* End)
-                  Nothing   -> typeMismatch sourceSpan (Right typ1) (Right typ)
-            _ -> typeMismatch sourceSpan (Right typ0) (Left "function type")
+          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
@@ -1350,11 +1080,9 @@
                 e1' <- checkType_ typ0 e1
                 return $ syn (CoerceTo_ CNil :$  e1' :* End)
             Just (dom, cod) ->
-                case jmEq1 typ0 cod of
-                Just Refl -> do
-                    e1' <- checkType_ dom e1
-                    return $ syn (CoerceTo_ c :$ e1' :* End)
-                Nothing -> typeMismatch sourceSpan (Right typ0) (Right 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
@@ -1362,11 +1090,9 @@
                 e1' <- checkType_ typ0 e1
                 return $ syn (UnsafeFrom_ CNil :$  e1' :* End)
             Just (dom, cod) ->
-                case jmEq1 typ0 dom of
-                Just Refl -> do
-                    e1' <- checkType_ cod e1
-                    return $ syn (UnsafeFrom_ c :$ e1' :* End)
-                Nothing -> typeMismatch sourceSpan (Right typ0) (Right dom)
+                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
@@ -1393,12 +1119,20 @@
               StrictMode -> safeNaryOp typ0
               LaxMode    -> safeNaryOp typ0
               UnsafeMode -> 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
+                op' <- make_NaryOp typ0 op
+                (bads, goods) <-
+                  fmap partitionEithers . T.forM es $
+                  \e -> fmap (maybe (Left e) Right)
+                             (tryWith LaxMode (checkType_ typ0 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'))
             where
             safeNaryOp :: forall c. Sing c -> TypeCheckMonad (abt '[] c)
             safeNaryOp typ = do
@@ -1406,36 +1140,23 @@
                 es'  <- T.forM es $ checkType_ typ
                 return $ syn (NaryOp_ op' (S.fromList es'))
 
-        U.Empty_ ->
-            case typ0 of
-            SArray _ -> return $ syn (Empty_ typ0)
-            _        -> typeMismatch sourceSpan (Right typ0) (Left "HArray")
-
         U.Pair_ e1 e2 ->
-            case typ0 of
-            SData (STyCon sym `STyApp` a `STyApp` b) _ ->
-                case jmEq1 sym sSymbol_Pair of
-                Just Refl  -> do
-                    e1' <- checkType_ a e1
-                    e2' <- checkType_ b e2
-                    return $ syn (Datum_ $ dPair_ a b e1' e2')
-                Nothing    -> typeMismatch sourceSpan (Right typ0) (Left "HPair")
-            _              -> typeMismatch sourceSpan (Right typ0) (Left "HPair")
+          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 ->
-            case typ0 of
-            SArray typ1 -> do
-                e1' <- checkType_  SNat e1
-                e2' <- checkBinder SNat typ1 e2
-                return $ syn (Array_ e1' e2')
-            _ -> typeMismatch sourceSpan (Right typ0) (Left "HArray")
+            unifyArray typ0 sourceSpan $ \typ1 -> do
+             e1' <- checkType_  SNat e1
+             e2' <- checkBinder SNat typ1 e2
+             return $ syn (Array_ e1' e2')
 
         U.ArrayLiteral_ es ->
-            case typ0 of
-            SArray typ1 -> do
+            unifyArray typ0 sourceSpan $ \typ1 ->
+            if null es then return $ syn (Empty_ typ0) else do
                es' <- T.forM es $ checkType_ typ1
                return $ syn (ArrayLiteral_ es')
-            _ -> typeMismatch sourceSpan (Right typ0) (Left "HArray")
 
         U.Datum_ (U.Datum hint d) ->
             case typ0 of
@@ -1450,79 +1171,51 @@
             return $ syn (Case_ e1' branches')
 
         U.Dirac_ e1 ->
-            case typ0 of
-            SMeasure typ1 -> do
-                e1' <- checkType_ typ1 e1
-                return $ syn (Dirac :$ e1' :* End)
-            _ -> typeMismatch sourceSpan (Right typ0) (Left "HMeasure")
+            unifyMeasure typ0 sourceSpan $ \typ1 -> do
+             e1' <- checkType_ typ1 e1
+             return $ syn (Dirac :$ e1' :* End)
 
         U.MBind_ e1 e2 ->
-            case typ0 of
-            SMeasure _ -> do
-                TypedAST typ1 e1' <- inferType_ e1
-                case typ1 of
-                    SMeasure typ2 -> do
-                        e2' <- checkBinder typ2 typ0 e2
-                        return $ syn (MBind :$ e1' :* e2' :* End)
-                    _ -> typeMismatch sourceSpan (Right typ0) (Right typ1)
-            _ -> typeMismatch sourceSpan (Right typ0) (Left "HMeasure")
+            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 ->
-            case typ0 of
-            SMeasure typ1 -> do
-                e1' <- checkType_ SNat e1
-                case typ1 of
-                    SArray typ2 -> do
-                        e2' <- checkBinder SNat (SMeasure typ2) e2
-                        return $ syn (Plate :$ e1' :* e2' :* End)
-                    _ -> typeMismatch sourceSpan (Right typ1) (Left "HArray")
-            _ -> typeMismatch sourceSpan (Right typ0) (Left "HMeasure")
+            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 ->
-            case typ0 of
-            SMeasure (SData (STyCon sym `STyApp` (SArray a) `STyApp` s) _) ->
-                case jmEq1 sym sSymbol_Pair of
-                Just Refl -> do
-                    e1' <- checkType_  SNat e1
-                    e2' <- checkType_  s    e2
-                    e3' <- checkBinder s    (SMeasure $ sPair a s) e3
-                    return $ syn (Chain :$ e1' :* e2' :* e3' :* End)
-                Nothing -> typeMismatch sourceSpan (Right typ0) (Left "HMeasure(HPair(HArray, s)")
-            _           -> typeMismatch sourceSpan (Right typ0) (Left "HMeasure(HPair(HArray, s)")
-
-
-        U.Expect_ e1 e2 ->
-            case typ0 of
-            SProb -> do
-                TypedAST typ1 e1' <- inferType_ e1
-                case typ1 of
-                    SMeasure typ2 -> do
-                        e2' <- checkBinder typ2 typ0 e2
-                        return $ syn (Expect :$ e1' :* e2' :* End)
-                    _ -> typeMismatch sourceSpan (Left "HMeasure") (Right typ1)
-            _ -> typeMismatch sourceSpan (Right typ0) (Left "HProb")
+            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.Observe_ e1 e2 ->
-            case typ0 of
-            SMeasure typ2 -> do
-                e1' <- checkType_ typ0 e1
-                e2' <- checkType_ typ2 e2
-                return $ syn (Observe :$ e1' :* e2' :* End)
-            _ -> typeMismatch sourceSpan (Right typ0) (Left "HMeasure")
+        U.Transform_ tr es -> checkTransform sourceSpan typ0 tr es
 
         U.Superpose_ pes ->
-            case typ0 of
-            SMeasure _ ->
+            unifyMeasure typ0 sourceSpan $ \_ ->
                 fmap (syn . Superpose_) .
                     T.forM pes $ \(p,e) ->
                         (,) <$> checkType_ SProb p <*> checkType_ typ0 e
-            _ -> typeMismatch sourceSpan (Right typ0) (Left "HMeasure")
 
         U.Reject_ ->
-            case typ0 of
-            SMeasure _ -> return $ syn (Reject_ typ0)
-            _          -> typeMismatch sourceSpan (Right typ0) (Left "HMeasure")
+            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
@@ -1535,7 +1228,69 @@
                   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?
@@ -1591,32 +1346,6 @@
             case typ of
             SKonst typ1 -> Konst <$> checkType_ typ1 e1
             _           -> failwith_ "expected datum of `K' 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>
-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)
 
 checkBranch
     :: (ABT Term abt)
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,418 @@
+{-# 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
+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
+
+{-
+-- 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
--- a/haskell/Language/Hakaru/Syntax/TypeOf.hs
+++ b/haskell/Language/Hakaru/Syntax/TypeOf.hs
@@ -5,6 +5,8 @@
            , ScopedTypeVariables
            , Rank2Types
            , FlexibleContexts
+           , PolyKinds
+           , ViewPatterns
            #-}
 
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
@@ -26,7 +28,6 @@
     -- * Get singletons for well-typed ABTs
       typeOf
     , typeOfReducer
-    
     -- * Implementation details
     , getTermSing
     ) where
@@ -46,7 +47,9 @@
     (singCoerceCod, singCoerceDom, Coerce(..))
 import Language.Hakaru.Syntax.Datum    (Datum(..), Branch(..))
 import Language.Hakaru.Syntax.Reducer
-import Language.Hakaru.Syntax.AST      (Term(..), SCon(..), SArgs(..))
+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)
 
@@ -157,9 +160,7 @@
             SFun (varType x) <$> getSing r1
     go (App_ :$ r1 :* _ :* End) = do
         typ1 <- getSing r1
-        case typ1 of
-            SFun _ typ3            -> return typ3
-            _ -> error "getTermSing: the impossible happened"
+        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)
@@ -175,8 +176,8 @@
     go (Integrate :$  _)            = return SProb
     go (Summate _ h :$  _)          = return $ sing_HSemiring h
     go (Product _ h :$  _)          = return $ sing_HSemiring h
-    go (Expect :$  _)               = return SProb
-    go (Observe :$ r1 :* _ :* End)  = getSing r1
+    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
@@ -188,7 +189,6 @@
     go (Superpose_ pes) = tryAll "Superpose_" (getSing . snd) pes
     go (Reject_ typ)    = return typ
     go (_ :$ _) = error "getTermSing: the impossible happened"
-
 
 tryAll
     :: F.Foldable f
diff --git a/haskell/Language/Hakaru/Syntax/Uniquify.hs b/haskell/Language/Hakaru/Syntax/Uniquify.hs
--- a/haskell/Language/Hakaru/Syntax/Uniquify.hs
+++ b/haskell/Language/Hakaru/Syntax/Uniquify.hs
@@ -41,7 +41,6 @@
 import           Language.Hakaru.Syntax.AST.Eq   (Varmap)
 import           Language.Hakaru.Syntax.Gensym
 import           Language.Hakaru.Syntax.IClasses
-import           Debug.Trace
 
 #if __GLASGOW_HASKELL__ < 710
 import           Control.Applicative
diff --git a/haskell/Language/Hakaru/Syntax/Value.hs b/haskell/Language/Hakaru/Syntax/Value.hs
--- a/haskell/Language/Hakaru/Syntax/Value.hs
+++ b/haskell/Language/Hakaru/Syntax/Value.hs
@@ -20,13 +20,13 @@
 
 import qualified Data.Vector                     as V
 import qualified Data.Number.LogFloat            as LF
-import           Data.Number.Nat
+import           Data.Number.Natural
 
 import qualified System.Random.MWC               as MWC
 
 data Value :: Hakaru -> * where
-     VNat     :: {-# UNPACK #-} !Nat -> Value 'HNat
-     VInt     :: {-# UNPACK #-} !Int -> Value 'HInt
+     VNat     ::                !Natural -> Value 'HNat
+     VInt     ::                !Integer -> Value 'HInt
      VProb    :: {-# UNPACK #-} !LF.LogFloat -> Value 'HProb
      VReal    :: {-# UNPACK #-} !Double -> Value 'HReal
 
@@ -79,28 +79,25 @@
 instance PrimCoerce Value where
     primCoerceTo c l =
         case (c,l) of
-        (Signed HRing_Int,            VNat  a) -> VInt  $ fromNat a
+        (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 (fromNat a) :: Double)
+            VProb $ LF.logFloat (fromIntegral (fromNatural a) :: Double)
         (Continuous HContinuous_Real, VInt  a) -> VReal $ fromIntegral a
-        _ -> error "no a defined primitive coercion"
 
     primCoerceFrom c l =
         case (c,l) of
-        (Signed HRing_Int,            VInt  a) -> VNat  $ unsafeNat a
+        (Signed HRing_Int,            VInt  a) -> VNat  $ unsafeNatural a
         (Signed HRing_Real,           VReal a) -> VProb $ LF.logFloat a
         (Continuous HContinuous_Prob, VProb a) ->
-            VNat $ unsafeNat $ floor (LF.fromLogFloat a :: Double)
+            VNat $ unsafeNatural $ floor (LF.fromLogFloat a :: Double)
         (Continuous HContinuous_Real, VReal a) -> VInt  $ floor a
-        _ -> error "no a defined primitive coercion"
 
 
 lam2 :: Value (a ':-> b ':-> c) -> (Value a -> Value b -> Value c)
 lam2 (VLam f1) v1 =
     case f1 v1 of
     VLam f2 -> f2
-    _       -> error "lam2: the impossible happened"
 
 enumFromUntilValue
     :: (HDiscrete a)
@@ -109,6 +106,7 @@
     -> [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)
diff --git a/haskell/Language/Hakaru/Syntax/Variable.hs b/haskell/Language/Hakaru/Syntax/Variable.hs
--- a/haskell/Language/Hakaru/Syntax/Variable.hs
+++ b/haskell/Language/Hakaru/Syntax/Variable.hs
@@ -75,6 +75,10 @@
 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
@@ -375,9 +379,14 @@
     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
-    mappend (VarSet xs) (VarSet ys) = VarSet (IM.union xs ys) -- TODO: remove bias; crash if conflicting definitions
+    mempty  = emptyVarSet
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (<>)
+#endif
     mconcat = VarSet . IM.unions . map unVarSet
 
 varSetKeys :: VarSet a -> [Int]
@@ -522,12 +531,15 @@
     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
-    go _ _ _ = error "toAssocs1: the impossible happened"
 
+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
-    mappend (Assocs xs) (Assocs ys) = Assocs (IM.union xs ys) -- TODO: remove bias; crash if conflicting definitions
+    mempty  = emptyAssocs
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (<>)
+#endif
     mconcat = Assocs . IM.unions . map unAssocs
 
 
diff --git a/haskell/Language/Hakaru/Types/Coercion.hs b/haskell/Language/Hakaru/Types/Coercion.hs
--- a/haskell/Language/Hakaru/Types/Coercion.hs
+++ b/haskell/Language/Hakaru/Types/Coercion.hs
@@ -124,6 +124,8 @@
     -- 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)
 
diff --git a/haskell/Language/Hakaru/Types/HClasses.hs b/haskell/Language/Hakaru/Types/HClasses.hs
--- a/haskell/Language/Hakaru/Types/HClasses.hs
+++ b/haskell/Language/Hakaru/Types/HClasses.hs
@@ -91,10 +91,11 @@
 #if __GLASGOW_HASKELL__ < 710
 import Data.Functor ((<$>))
 #endif
-import Control.Applicative ((<|>))
+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.
@@ -132,12 +133,13 @@
 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)
-{-
-hEq_Sing (sPair   a b) = HEq_Pair <$> hEq_Sing a <*> hEq_Sing b
-hEq_Sing (sEither a b) = HEq_Either <$> hEq_Sing a <*> hEq_Sing b
--}
+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
diff --git a/haskell/Language/Hakaru/Types/Sing.hs b/haskell/Language/Hakaru/Types/Sing.hs
--- a/haskell/Language/Hakaru/Types/Sing.hs
+++ b/haskell/Language/Hakaru/Types/Sing.hs
@@ -25,7 +25,7 @@
 ----------------------------------------------------------------
 module Language.Hakaru.Types.Sing
     ( Sing(..)
-    , SingI(..)
+    , SingI(..), singOf
     -- * Some helpful shorthands for \"built-in\" datatypes
     -- ** Constructing singletons
     , sBool
@@ -37,10 +37,11 @@
     -- ** Destructing singletons
     , sUnMeasure
     , sUnArray
-    , sUnPair
-    , sUnEither
+    , sUnPair, sUnPair'
+    , sUnEither, sUnEither'
     , sUnList
     , sUnMaybe
+    , sUnFun
     -- ** Singletons for `Symbol`
     , someSSymbol, ssymbolVal
     , sSymbol_Bool
@@ -73,6 +74,9 @@
 -- 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
@@ -197,6 +201,14 @@
 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)
@@ -207,6 +219,14 @@
 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)
@@ -224,6 +244,9 @@
 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
diff --git a/haskell/Tests/Parser.hs b/haskell/Tests/Parser.hs
--- a/haskell/Tests/Parser.hs
+++ b/haskell/Tests/Parser.hs
@@ -5,13 +5,15 @@
 
 import Prelude hiding (unlines)
 
-import Language.Hakaru.Parser.Parser
+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(..), (<$>))
@@ -53,10 +55,10 @@
         , PData' <$> (DV <$> arbitrary <*> arbitrary)
         ]
 
-instance Arbitrary a => Arbitrary (Branch' a) where
+instance (Arbitrary a, IsString a) => Arbitrary (Branch' a) where
     arbitrary = Branch' <$> arbitrary <*> arbitrary
 
-instance Arbitrary a => Arbitrary (AST' a) where
+instance (Arbitrary a, IsString a) => Arbitrary (AST' a) where
     arbitrary = frequency
         [ (10, Var <$> arbitrary)
         , ( 1, Lam <$> arbitrary <*> arbitrary <*> arbitrary)
@@ -67,9 +69,9 @@
         , ( 1, return Infinity')
         , ( 1, ULiteral <$> arbitrary)
         --, ( 1, NaryOp <$> arbitrary)
-        , ( 1, return Empty)
+        , ( 1, return (ArrayLiteral []))
         , ( 1, Case  <$> arbitrary <*> arbitrary)
-        , ( 1, Dirac <$> arbitrary)
+        , ( 1, App (Var "dirac") <$> arbitrary)
         , ( 1, Bind  <$> arbitrary <*> arbitrary <*> arbitrary)
         ]
 
@@ -77,7 +79,7 @@
 testParse s p =
     case parseHakaru s of
     Left  m  -> assertFailure (unpack s ++ "\n" ++ show m)
-    Right p' -> assertEqual "" p p'
+    Right p' -> assertEqual "" (withoutMetaE p) (withoutMetaE p')
 
 if1, if2, if3, if4, if5 :: Text
 
@@ -160,7 +162,7 @@
     ["def foo(x real):"
     ,"    y <~ normal(x,1.0)"
     ,"    return (y + y. real)"
-    ,"foo(-2.0)"
+    ,"foo(-(2.0))"
     ]
 
 def4 :: Text
@@ -180,7 +182,7 @@
 def2AST =
     Let "foo" (Lam "x" (TypeVar "real")
         (Bind "y" (App (App (Var "normal") (Var "x")) (ULiteral (Prob 1.0)))
-        (Dirac (Ann (NaryOp Sum [Var "y", Var "y"])
+        (App (Var "dirac") (Ann (NaryOp Sum [Var "y", Var "y"])
                     (TypeVar "real")))))
     (App (Var "foo") (App (Var "negate") (ULiteral (Prob 2.0))))
 
@@ -240,13 +242,13 @@
     (Bind "y" (App (App (Var "normal")
                         (Var "x"))
                         (ULiteral (Nat 1)))
-    (Dirac (Var "y")))
+    (App (Var "dirac") (Var "y")))
 
 ret1 :: Text
 ret1 =  "return return 3"
 
 ret1AST :: AST' Text
-ret1AST = Dirac (Dirac (ULiteral (Nat 3)))
+ret1AST = App (Var "dirac") (App (Var "dirac") (ULiteral (Nat 3)))
 
 testBinds :: Test
 testBinds = test
@@ -345,7 +347,7 @@
 match7AST :: AST' Text
 match7AST = Case (Ann
                   (Pair
-                   (App (Var "negate") (ULiteral (Prob 2.0)))
+                   (ULiteral (Real (-2.0)))
                    (ULiteral (Prob 1.0)))
              (TypeApp "pair" [TypeVar "real",TypeVar "prob"]))
             [Branch' (PData' (DV "pair" [PVar' "a",PVar' "b"]))
@@ -393,24 +395,24 @@
 
 expect1 :: Text
 expect1 = unlines
-    ["expect x normal(0,1):"
+    ["expect x <~ normal(0,1):"
     ,"   1"
     ]
 
 expect1AST :: AST' Text
-expect1AST = Expect "x" (App (App (Var "normal")
+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):"
+    ["expect x <~ normal(0,1):"
     ,"   unsafeProb(x*x)"
     ]
 
 expect2AST :: AST' Text
-expect2AST = Expect "x" (App (App (Var "normal")
+expect2AST = _Expect "x" (App (App (Var "normal")
                               (ULiteral (Nat 0)))
                          (ULiteral (Nat 1)))
              (App (Var "unsafeProb")
@@ -505,7 +507,7 @@
     (Bind "m2" (App (App (Var "normal")
                          (Var "x2"))
                          (Var "noiseE"))
-    (Dirac
+    (App (Var "dirac")
         (Pair
          (Pair
           (Var "m1")
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
--- a/haskell/Tests/RoundTrip.hs
+++ b/haskell/Tests/RoundTrip.hs
@@ -37,968 +37,248 @@
 import Data.List (intercalate) 
 
 import qualified Data.Text as Text 
-import Test.HUnit hiding ((~:), test)
-import qualified Test.HUnit as HUnit
-import Tests.TestTools hiding (testStriv, testSStriv, testConcreteFiles)
-import qualified Tests.TestTools as Tools
-import Tests.Models
-    (uniform_0_1, normal_0_1, gamma_1_1,
-     uniformC, normalC, beta_1_1, t4, t4', norm, unif2)
-
-unsafeSuperpose
-    :: (ABT Term abt)
-    => [(abt '[] 'HProb, abt '[] ('HMeasure a))]
-    -> abt '[] ('HMeasure a)
-unsafeSuperpose = superpose . L.fromList
-
-
-class IsTestGroup t where 
-  test :: [t] -> t 
-
-class IsTest' ta t | ta -> t, t -> ta where
-  (~:) :: String -> ta -> t 
-
-class IsTestAssertion ta where 
-  testStriv 
-    :: TrivialABT Term '[] a
-    -> ta 
-
-  testSStriv 
-    :: [(TrivialABT Term '[] a)] 
-    -> TrivialABT Term '[] a 
-    -> ta 
-
-  testConcreteFiles
-      :: FilePath
-      -> FilePath
-      -> ta   
-
-  
-instance IsTestGroup Test where test = HUnit.test; 
-instance IsTest' Assertion Test where (~:) = (HUnit.~:)
-instance IsTestAssertion Assertion where 
-  testStriv = Tools.testStriv; testSStriv = Tools.testSStriv; testConcreteFiles = Tools.testConcreteFiles
-
-
-data SaveInput = forall a . TestInput [TrivialABT Term '[] a] (TrivialABT Term '[] a) | DoNothing
-newtype SaveTests = SaveTests { runSaveTests :: IO () }
-
-instance IsTestAssertion SaveInput where 
-  testStriv = TestInput [] 
-  testSStriv = TestInput 
-  testConcreteFiles _ _ = DoNothing
-
-instance IsTestGroup SaveTests where 
-  test = SaveTests . mapM_ runSaveTests
-
-instance IsTest' SaveInput SaveTests where 
-  (~:) _ DoNothing = SaveTests (return ()) 
-  (~:) tnm (TestInput xs r) = 
-    let go (s,x) = do 
-          createDirectoryIfMissing True $ intercalate "/" dn 
-          (IO.writeFile fn . Text.pack . show . pretty . expandTransformations) x
-            where 
-              dn = ["tests", "RoundTrip"]
-              fn = intercalate "/" $ dn ++ [concat [tnm, if null s then "" else ".", s, ".hk"]]
-            
-        xs' = case xs of
-                [] -> [("",r)]
-                _  -> ("expected",r) : Prelude.zip (Prelude.map Prelude.show [0..]) xs 
-    in SaveTests $ mapM_ go xs' 
-
-type IsTest ta t = (IsTest' ta t, IsTestGroup t, IsTestAssertion ta)
-  
-
-testMeasureUnit :: IsTest ta t => t
-testMeasureUnit = test [
-    "t1,t5"   ~: testSStriv [t1,t5] (weight half),
-    "t10"     ~: testSStriv [t10] (reject sing),
-    "t11,t22" ~: testSStriv [t11,t22] (dirac unit),
-    "t12"     ~: testSStriv [] t12,
-    "t20"     ~: testSStriv [t20] (lam $ \y -> weight (y * half)),
-    "t24"     ~: testSStriv [t24] t24',
-    "t25"     ~: testSStriv [t25] t25',
-    "t44Add"  ~: testSStriv [t44Add] t44Add',
-    "t44Mul"  ~: testSStriv [t44Mul] t44Mul',
-    "t53"     ~: testSStriv [t53,t53'] t53'',
-    "t54"     ~: testStriv t54,
-    "t55"     ~: testSStriv [t55] t55',
-    "t56"     ~: testSStriv [t56,t56'] t56'',
-    "t57"     ~: testSStriv [t57] t57',
-    "t58"     ~: testSStriv [t58] t58',
-    "t59"     ~: testStriv t59,
-    "t60"     ~: testSStriv [t60,t60'] t60'',
-    "t62"     ~: testSStriv [t62] t62',
-    "t63"     ~: testSStriv [t63] t63',
-    "t64"     ~: testSStriv [t64,t64'] t64'',
-    "t65"     ~: testSStriv [t65] t65',
-    "t77"     ~: testSStriv [] t77
-    ]
-
-testMeasureProb :: IsTest ta t => t
-testMeasureProb = test [
-    "t2"  ~: testSStriv [t2] (unsafeProb <$> uniform zero one),
-    "t26" ~: testSStriv [t26] (dirac half),
-    "t30" ~: testSStriv [] t30,
-    "t33" ~: testSStriv [] t33,
-    "t34" ~: testSStriv [t34] (dirac (prob_ 3)),
-    "t35" ~: testSStriv [] t35,
-    "t35'" ~: testSStriv [] t35',
-    "t38" ~: testSStriv [] t38,
-    "t42" ~: testSStriv [t42] (dirac one),
-    "t49" ~: testSStriv [] t49,
-    "t61" ~: testSStriv [t61] t61',
-    "t66" ~: testSStriv [] t66,
-    "t67" ~: testSStriv [] t67,
-    "t69x" ~: testSStriv [t69x] (dirac $ prob_ 1.5),
-    "t69y" ~: testSStriv [t69y] (dirac $ prob_ 3.5)
-    ]
-
-testMeasureReal :: IsTest ta t => t
-testMeasureReal = test
-    [ "t3"  ~: testSStriv [] t3
-    , "t6"  ~: testSStriv [t6'] t6
-    , "t7"  ~: testSStriv [t7] t7'
-    , "t7n" ~: testSStriv [t7n] t7n'
-    , "t8'" ~: testSStriv [t8'] (lam $ \s1 ->
-                                 lam $ \s2 ->
-                                 normal zero (sqrt $ (s2 ^ (nat_ 2) + s1 ^ (nat_ 2))))
-    , "t9"  ~: testSStriv [t9] (unsafeSuperpose [(prob_ 2, uniform (real_ 3) (real_ 7))])
-    , "t13" ~: testSStriv [t13] t13'
-    , "t14" ~: testSStriv [t14] t14'
-    , "t21" ~: testStriv t21
-    , "t28" ~: testSStriv [] t28
-    , "t31" ~: testSStriv [] t31
-    , "t36" ~: testSStriv [] t36
-    , "t37" ~: testSStriv [] t37
-    , "t39" ~: testSStriv [] t39
-    , "t40" ~: testSStriv [] t40
-    , "t43" ~: testSStriv [t43, t43'] t43''
-    , "t46" ~: testSStriv [] t46
-    , "t45" ~: testSStriv [t47] t45
-    , "t50" ~: testStriv t50
-    , "t51" ~: testStriv t51
-    , "t68" ~: testStriv t68
-    , "t68'" ~: testStriv t68'
-    , "t70a" ~: testSStriv [t70a] (uniform one (real_ 3))
-    , "t71a" ~: testSStriv [t71a] (uniform one (real_ 3))
-    , "t72a" ~: testSStriv [t72a] (withWeight half $ uniform one (real_ 2))
-    , "t73a" ~: testSStriv [t73a] (reject sing)
-    , "t74a" ~: testSStriv [t74a] (reject sing)
-    , "t70b" ~: testSStriv [t70b] (reject sing)
-    , "t71b" ~: testSStriv [t71b] (reject sing)
-    , "t72b" ~: testSStriv [t72b] (withWeight half $ uniform (real_ 2) (real_ 3))
-    , "t73b" ~: testSStriv [t73b] (uniform one (real_ 3))
-    , "t74b" ~: testSStriv [t74b] (uniform one (real_ 3))
-    , "t70c" ~: testSStriv [t70c] (uniform one (real_ 3))
-    , "t71c" ~: testSStriv [t71c] (uniform one (real_ 3))
-    , "t72c" ~: testSStriv [t72c] (withWeight half $ uniform one (real_ 2))
-    , "t73c" ~: testSStriv [t73c] (reject sing)
-    , "t74c" ~: testSStriv [t74c] (reject sing)
-    , "t70d" ~: testSStriv [t70d] (reject sing)
-    , "t71d" ~: testSStriv [t71d] (reject sing)
-    , "t72d" ~: testSStriv [t72d] (withWeight half $ uniform (real_ 2) (real_ 3))
-    , "t73d" ~: testSStriv [t73d] (uniform one (real_ 3))
-    , "t74d" ~: testSStriv [t74d] (uniform one (real_ 3))
-    , "t76" ~: testStriv t76
-    , "t78" ~: testSStriv [t78] t78'
-    , "t79" ~: testSStriv [t79] (dirac one)
-    , "t80" ~: testStriv t80
-    , "t81" ~: testSStriv [] t81
-    -- TODO, "kalman" ~: testStriv kalman
-    --, "seismic" ~: testSStriv [] seismic
-    , "lebesgue1" ~: testSStriv [] (lebesgue >>= \x -> if_ ((real_ 42) < x) (dirac x) (reject sing))
-    , "lebesgue2" ~: testSStriv [] (lebesgue >>= \x -> if_ (x < (real_ 42)) (dirac x) (reject sing))
-    , "lebesgue3" ~: testSStriv [lebesgue >>= \x -> if_ (x < (real_ 42) && (real_ 40) < x) (dirac x) (reject sing)]
-                                (withWeight (prob_ $ 2) $ uniform (real_ 40) (real_ 42))
-    , "testexponential" ~: testStriv testexponential
-    , "testcauchy" ~: testStriv testCauchy
-    , "exceptionLebesgue" ~: testSStriv [lebesgue >>= \x -> dirac (if_ (x == (real_ 3)) one x)] lebesgue
-    , "exceptionUniform"  ~: testSStriv [uniform (real_ 2) (real_ 4) >>= \x ->
-                                         dirac (if_ (x == (real_ 3)) one x)
-                                        ] (uniform (real_ 2) (real_ 4))
-    -- TODO "two_coins" ~: testStriv two_coins -- needs support for lists
-    ]
-
-testMeasureNat :: IsTest ta t => t 
-testMeasureNat = test
-    [ "size" ~: testConcreteFiles "tests/RoundTrip/size.0.hk" "tests/RoundTrip/size.expected.hk"
-    ]
-
-testMeasureInt :: IsTest ta t => t
-testMeasureInt = test
-    [ "t75"  ~: testStriv t75
-	, "t75_hakaru" ~: testConcreteFiles "tests/t75_in.hk" "tests/t75_out.hk"
-    , "t75'" ~: testStriv t75'
-    , "t83"  ~: testSStriv [t83] t83'
-    -- Jacques wrote: "bug: [simp_pw_equal] implicitly assumes the ambient measure is Lebesgue"
-    , "exceptionCounting" ~: testSStriv [] (counting >>= \x ->
-                                            if_ (x == (int_ 3))
-                                                (dirac one)
-                                                (dirac x))
-    , "exceptionSuperpose" ~: testSStriv 
-                                [(unsafeSuperpose [ (third, dirac (int_ 2))
-                                                  , (third, dirac (int_ 3))
-                                                  , (third, dirac (int_ 4))
-                                                  ] `asTypeOf` counting) >>= \x -> 
-                                 dirac (if_ (x == (int_ 3)) one x)]
-                                (unsafeSuperpose [ (third, dirac (int_ 2))
-                                                 , (third, dirac one)
-                                                 , (third, dirac (int_ 4))
-                                                 ])
-    ]
-
-testMeasurePair :: IsTest ta t => t 
-testMeasurePair = test [
-    "t4"            ~: testSStriv [t4] t4',
-    "t8"            ~: testSStriv [] t8,
-    "t23"           ~: testSStriv [t23] t23',
-    "t48"           ~: testStriv t48,
-    "t52"           ~: testSStriv [] t52,
-    "dup"           ~: testSStriv [dup normal_0_1] (liftM2 pair
-                                                           (normal zero one)
-                                                           (normal zero one)),
-    "norm"          ~: testSStriv [] norm,
-    "norm_nox"      ~: testSStriv [norm_nox] (normal zero (sqrt (prob_ 2))),
-    "norm_noy"      ~: testSStriv [norm_noy] (normal zero one),
-    "flipped_norm"  ~: testSStriv [swap <$> norm] flipped_norm,
-    "priorProp"     ~: testSStriv [lam (priorAsProposal norm)]
-                                  (lam $ \x -> unpair x $ \x0 x1 ->
-                                               unsafeSuperpose [(half, normal zero
-                                                                         (sqrt (prob_ 2)) >>= \y ->
-                                                                       dirac (pair x0 y)),
-                                                                (half, normal_0_1 >>= \y ->
-                                                                       dirac (pair y x1))]),
-    "mhPriorProp"   ~: testSStriv [testMHPriorProp] testPriorProp',
-    "unif2"         ~: testStriv unif2,
-    "easyHMM"       ~: testStriv easyHMM,
-    "testMCMCPriorProp" ~: testStriv testMCMCPriorProp
-    ]
-
-testOther :: IsTest ta t => t
-testOther = test [
-    "t82" ~: testSStriv [t82] t82',
-    "testRoadmapProg1" ~: testStriv rmProg1,
-    "testKernel" ~: testSStriv [testKernel] testKernel2
-    --"testFalseDetection" ~: testStriv (lam seismicFalseDetection),
-    --"testTrueDetection" ~: testStriv (lam2 seismicTrueDetection)
-    --"testTrueDetectionL" ~: testStriv tdl,
-    --"testTrueDetectionR" ~: testStriv tdr
-    ]
-
-allTests :: IsTest ta t => t 
-allTests = test
-    [ testMeasureUnit
-    , testMeasureProb
-    , testMeasureReal
-    , testMeasurePair
-    , testMeasureNat
-    , testMeasureInt
-    , testOther
-    ]
-
-save_allTests :: IO () 
-save_allTests = runSaveTests allTests 
-
-----------------------------------------------------------------
--- In Maple, should 'evaluate' to "\c -> 1/2*c(Unit)"
-t1 :: (ABT Term abt) => abt '[] ('HMeasure HUnit)
-t1 = uniform_0_1 >>= \x -> weight (unsafeProb x)
-
-t2 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-t2 = beta_1_1
-
-t3 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t3 = normal zero (prob_ 10)
-
--- t5 is "the same" as t1.
-t5 :: (ABT Term abt) => abt '[] ('HMeasure HUnit)
-t5 = weight half >> dirac unit
-
-t6, t6' :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t6 = dirac (real_ 5)
-t6' = unsafeSuperpose [(one, dirac (real_ 5))]
-
-t7,t7', t7n,t7n' :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t7   = uniform_0_1 >>= \x -> weight (unsafeProb (x+one)) >> dirac (x*x)
-t7'  = uniform_0_1 >>= \x -> unsafeSuperpose [(unsafeProb (x+one), dirac (x^(nat_ 2)))]
-t7n  =
-    uniform (negate one) zero >>= \x ->
-    weight (unsafeProb (x+one)) >>
-    dirac (x*x)
-t7n' =
-    uniform (real_ (-1)) zero >>= \x ->
-    unsafeSuperpose [(unsafeProb (x + one), dirac (x^(nat_ 2)))]
-
--- 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".
-t8 :: (ABT Term abt) => abt '[] ('HMeasure (HPair 'HReal 'HReal))
-t8 = normal zero (prob_ 10) >>= \x -> normal x (prob_ 20) >>= \y -> dirac (pair x y)
-
--- Normal is conjugate to normal
-t8' :: (ABT Term abt)
-    => abt '[] ('HProb ':-> 'HProb ':-> 'HMeasure 'HReal)
-t8' =
-    lam $ \s1 ->
-    lam $ \s2 ->
-    normal zero s1 >>= \x ->
-    normal x s2
-
-t9 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t9 =
-    lebesgue >>= \x -> 
-    weight (if_ ((real_ 3) < x && x < (real_ 7)) half zero) >> 
-    dirac x
-
-t10 :: (ABT Term abt) => abt '[] ('HMeasure HUnit)
-t10 = weight zero
-
-t11 :: (ABT Term abt) => abt '[] ('HMeasure HUnit)
-t11 = weight one
-
-t12 :: (ABT Term abt) => abt '[] ('HMeasure HUnit)
-t12 = weight (prob_ 2)
-
-t13,t13' :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t13 = bern ((prob_ 3)/(prob_ 5)) >>= \b -> dirac (if_ b (real_ 37) (real_ 42))
-t13' = unsafeSuperpose
-    [ (prob_ $ 3 % 5, dirac (real_ 37))
-    , (prob_ $ 2 % 5, dirac (real_ 42))
-    ]
-
-t14,t14' :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t14 =
-    bern ((prob_ 3)/(prob_ 5)) >>= \b ->
-    if_ b t13 (bern ((prob_ 2)/(prob_ 7)) >>= \b' ->
-        if_ b' (uniform (real_ 10) (real_ 12)) (uniform (real_ 14) (real_ 16)))
-t14' = unsafeSuperpose 
-    [ (prob_ $ 9 % 25, dirac (real_ 37))
-    , (prob_ $ 6 % 25, dirac (real_ 42))
-    , (prob_ $ 4 % 35, uniform (real_ 10) (real_ 12))
-    , (prob_ $ 2 % 7 , uniform (real_ 14) (real_ 16))
-    ]
-
-t20 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure HUnit)
-t20 = lam $ \y -> uniform_0_1 >>= \x -> weight (unsafeProb x * y)
-
-t21 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HReal)
-t21 = mcmc (lam $ \x -> normal x one) (normal zero (prob_ 5))
-
-t22 :: (ABT Term abt) => abt '[] ('HMeasure HUnit)
-t22 = bern half >> dirac unit
-
--- was called bayesNet in Nov.06 msg by Ken for exact inference
-t23, t23' :: (ABT Term abt) => abt '[] ('HMeasure (HPair HBool HBool))
-t23 =
-    bern half >>= \a ->
-    bern (if_ a ((prob_ 9)/(prob_ 10)) ((prob_ 1)/(prob_ 10))) >>= \b ->
-    bern (if_ a ((prob_ 9)/(prob_ 10)) ((prob_ 1)/(prob_ 10))) >>= \c ->
-    dirac (pair b c)
-t23' = unsafeSuperpose
-    [ ((prob_ $ 41 % 100), dirac (pair true true))
-    , ((prob_ $ 9  % 100), dirac (pair true false))
-    , ((prob_ $ 9  % 100), dirac (pair false true))
-    , ((prob_ $ 41 % 100), dirac (pair false false))
-    ]
-
-t24,t24' :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure HUnit)
-t24 =
-   lam $ \x ->
-   uniform_0_1 >>= \y ->
-   uniform_0_1 >>= \z ->
-   weight (x * exp (cos y) * unsafeProb z)
-t24' =
-   lam $ \x ->
-   withWeight (x * half) $
-   uniform_0_1 >>= \y ->
-   weight (exp (cos y))
-
-t25,t25' :: (ABT Term abt)
-   => abt '[] ('HProb ':-> 'HReal ':-> 'HMeasure HUnit)
-t25 =
-   lam $ \x ->
-   lam $ \y ->
-   uniform_0_1 >>= \z ->
-   weight (x * exp (cos y) * unsafeProb z)
-t25' =
-   lam $ \x ->
-   lam $ \y ->
-   weight (x * exp (cos y) * half)
-
-t26 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-t26 = dirac (total t1)
-
-t28 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t28 = uniform zero one
-
-t30 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-t30 = exp <$> uniform zero one
-
-t31 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t31 = uniform (real_ (-1)) one
-
-t33 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-t33 = exp <$> t31
-
-t34 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-t34 = dirac (if_ ((real_ 2) < (real_ 4)) (prob_ 3) (prob_ 5))
-
-t35, t35' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HProb)
-t35  = lam $ \x -> dirac (if_ ((x `asTypeOf` log one) < (real_ 4)) (prob_ 3) (prob_ 5))
-t35' = lam $ \x -> if_ (x < (fromRational 4)) (dirac (fromRational 3)) (dirac (fromRational 5))
-
-t36 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HProb)
-t36 = lam (dirac . sqrt)
-
-t37 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HReal)
-t37 = lam (dirac . recip)
-
-t38 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HProb)
-t38 = lam (dirac . recip)
-
-t39 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HReal)
-t39 = lam (dirac . log)
-
-t40 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HReal)
-t40 = lam (dirac . log)
-
-t42 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-t42 = dirac . total $ (unsafeProb <$> uniform zero (real_ 2))
-
-t43, t43', t43'' :: (ABT Term abt) => abt '[] (HBool ':-> 'HMeasure 'HReal)
-t43   = lam $ \b -> if_ b uniform_0_1 (fromProb <$> beta_1_1)
-t43'  = lam $ \b -> if_ b uniform_0_1 uniform_0_1
-t43'' = lam $ \_ -> uniform_0_1
-
-t44Add, t44Add', t44Mul, t44Mul'
-    :: (ABT Term abt) => abt '[] ('HReal ':-> 'HReal ':-> 'HMeasure HUnit)
-t44Add  = lam $ \x -> lam $ \y -> weight (unsafeProb $ (x * x) + (y * y))
-t44Add' = lam $ \x -> lam $ \y -> weight (unsafeProb $ (x ^ (nat_ 2) + y ^ (nat_ 2)))
-t44Mul  = lam $ \x -> lam $ \y -> weight (unsafeProb $ (x * x * y * y))
-t44Mul' = lam $ \x -> lam $ \y -> weight (unsafeProb $ (x ^ (nat_ 2)) * (y ^ (nat_ 2)))
-
--- 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.
-t45 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t45 = normal (real_ 4) (prob_ 5) >>= \x -> if_ (x < (real_ 3)) (dirac (x^(nat_ 2))) (dirac (x+(real_ (-1))))
-
-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)))
-    ]
-
-t48 :: (ABT Term abt) => abt '[] (HPair 'HReal 'HReal ':-> 'HMeasure 'HReal)
-t48 = lam $ \x -> uniform (real_ (-5)) (real_ 7) >>= \w -> dirac ((fst x + snd x) * w)
-
-t49 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-t49 = gamma (prob_ 0.01)  (prob_ 0.35)
-
-t50 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t50 = uniform one (real_ 3) >>= \x -> normal one (unsafeProb x)
-
-t51 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t51 = t31 >>= \x -> normal x one
-
--- Example 1 from Chang & Pollard's Conditioning as Disintegration
-t52 :: (ABT Term abt) => abt '[] ('HMeasure (HPair 'HReal (HPair 'HReal 'HReal)))
-t52 =
-    uniform_0_1 >>= \x ->
-    uniform_0_1 >>= \y ->
-    dirac (pair (max y x) (pair x y))
-
-t53, t53', t53'' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t53 =
-    lam $ \x ->
-    unsafeSuperpose
-        [ (one, unsafeSuperpose
-            [ (one,
-                if_ (zero < x)
-                    (if_ (x < one) (dirac unit) (reject sing))
-                    (reject sing))
-            ])
-        , (one, if_ false (dirac unit) (reject sing))
-        ]
-t53' =
-    lam $ \x ->
-    unsafeSuperpose
-        [ (one,
-            if_ (zero < x)
-                (if_ (x < one) (dirac unit) (reject sing))
-                (reject sing))
-        , (one, if_ false (dirac unit) (reject sing))
-        ]
-t53'' =
-    lam $ \x ->
-    if_ (zero < x && x < one) (dirac unit) (reject sing)
-
-t54 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t54 =
-    lam $ \x0 ->
-    (   dirac x0 >>= \x1 ->
-        (negate <$> uniform_0_1) >>= \x2 ->
-        dirac (x1 + x2)
-    ) >>= \x1 ->
-    (   (   (dirac zero >>= \x2 ->
-            dirac x1 >>= \x3 ->
-            dirac (x2 < x3)
-            ) >>= \x2 ->
-        if_ x2
-            (recip <$> dirac x1)
-            (dirac zero)
-        ) >>= \x2 ->
-        weight (unsafeProb x2)
-    ) >>
-    (log <$> dirac (unsafeProb x1)) >>= \x3 ->
-    (negate <$> dirac x3) >>= \x4 ->
-    (
-        (dirac zero >>= \x5 ->
-        dirac x4 >>= \x6 ->
-        dirac (x5 < x6)
-        ) >>= \x5 ->
-        if_ x5
-            (   (dirac x4 >>= \x6 ->
-                dirac one >>= \x7 ->
-                dirac (x6 < x7)
-                ) >>= \x6 ->
-            if_ x6 (dirac one) (dirac zero)
-            )
-         (dirac zero)
-    ) >>= \x5 ->
-    weight (unsafeProb x5)
-
-t55, t55' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t55 =
-    lam $ \t ->
-    uniform_0_1 >>= \x ->
-    if_ (x < t) (dirac unit) (reject sing)
-t55' =
-    lam $ \t ->
-    if_ (t < zero) (reject sing) $
-    if_ (t < one) (weight (unsafeProb t)) $
-    dirac unit
-
-t56, t56', t56'' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t56 =
-    lam $ \x0 ->
-    (   dirac x0 >>= \x1 ->
-        (negate <$> uniform_0_1) >>= \x2 ->
-        dirac (x1 + x2)
-    ) >>= \x1 ->
-    (   (dirac zero >>= \x2 ->
-        dirac x1 >>= \x3 ->
-        dirac (x2 < x3)
-        ) >>= \x2 ->
-    if_ x2
-        (   (dirac x1 >>= \x3 ->
-            dirac one >>= \x4 ->
-            dirac (x3 < x4)
-            ) >>= \x3 ->
-        if_ x3 (dirac one) (dirac zero))
-        (dirac zero)
-    ) >>= \x2 ->
-    withWeight (unsafeProb x2) (dirac unit)
-t56' =
-    lam $ \x0 ->
-    uniform_0_1 >>= \x1 ->
-    if_ (x0 - one < x1 && x1 < x0)
-        (dirac unit)
-        (reject sing)
-t56'' =
-    lam $ \t ->
-    if_ (t <= zero) (reject sing) $
-    if_ (t <= one) (weight (unsafeProb t)) $
-    if_ (t <= (real_ 2)) (weight (unsafeProb ((real_ 2) + t * negate one))) $
-    reject sing
-
-t57, t57' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t57 = lam $ \t -> unsafeSuperpose
-    [ (one, if_ (t < one)  (dirac unit) (reject sing))
-    , (one, if_ (zero < t) (dirac unit) (reject sing)) ]
-t57' = lam $ \t -> 
-    if_ (t < one && zero < t) (weight (prob_ 2)) (dirac unit)
-
-t58, t58' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t58 = lam $ \t -> unsafeSuperpose
-    [ (one, if_ (zero < t && t < (real_ 2)) (dirac unit) (reject sing))
-    , (one, if_ (one  < t && t < (real_ 3)) (dirac unit) (reject sing)) ]
-t58' = lam $ \t ->
-    if_ (if_ (zero < t) (t < (real_ 2)) false)
-        (if_ (if_ (one < t) (t < (real_ 3)) false)
-            (weight (prob_ 2))
-            (dirac unit))
-        (if_ (if_ (one < t) (t < (real_ 3)) false)
-            (dirac unit)
-            (reject sing))
-
-t59 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t59 =
-    lam $ \x0 ->
-    ((recip <$> uniform_0_1) >>= \x1 ->
-     (((dirac zero >>= \x2 ->
-        dirac x1 >>= \x3 ->
-        dirac (x2 < x3)) >>= \x2 ->
-       if_ x2
-           (dirac x1)
-           (negate <$> dirac x1)) >>= \x2 ->
-      weight (unsafeProb x2) ) >>
-     dirac x0 >>= \x3 ->
-     dirac x1 >>= \x4 ->
-     dirac (x3 * x4)) >>= \x1 ->
-    (dirac x1 >>= \x2 ->
-     (negate <$> uniform_0_1) >>= \x3 ->
-     dirac (x2 + x3)) >>= \x2 ->
-    ((dirac zero >>= \x3 ->
-      dirac x2 >>= \x4 ->
-      dirac (x3 < x4)) >>= \x3 ->
-     if_ x3
-         ((dirac x2 >>= \x4 ->
-           dirac one >>= \x5 ->
-           dirac (x4 < x5)) >>= \x4 ->
-          if_ x4 (dirac one) (dirac zero))
-         (dirac zero)) >>= \x3 ->
-    weight (unsafeProb x3) 
-
-t60,t60',t60'' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t60 =
-    lam $ \x0 ->
-    (((uniform_0_1 >>= \x1 ->
-       uniform_0_1 >>= \x2 ->
-       dirac (x1 + x2)) >>= \x1 ->
-      dirac (recip x1)) >>= \x1 ->
-     (((dirac zero >>= \x2 ->
-        dirac x1 >>= \x3 ->
-        dirac (x2 < x3)) >>= \x2 ->
-       if_ x2
-           (dirac x1)
-           (negate <$> dirac x1)) >>= \x2 ->
-      weight (unsafeProb x2) ) >>
-     dirac x0 >>= \x3 ->
-     dirac x1 >>= \x4 ->
-     dirac (x3 * x4)) >>= \x1 ->
-    ((dirac zero >>= \x2 ->
-      dirac x1 >>= \x3 ->
-      dirac (x2 < x3)) >>= \x2 ->
-     if_ x2
-         ((dirac x1 >>= \x3 ->
-           dirac one >>= \x4 ->
-           dirac (x3 < x4)) >>= \x3 ->
-          if_ x3 (dirac one) (dirac zero))
-         (dirac zero)) >>= \x2 ->
-    weight (unsafeProb x2)
-t60' =
-    lam $ \x0 ->
-    uniform_0_1 >>= \x1 ->
-    uniform_0_1 >>= \x2 ->
-    if_ (if_ (zero < x0 / (x2 + x1))
-             (x0 / (x2 + x1) < one)
-             false)
-        (weight ((unsafeProb (x2 + x1)) ^^ negate one) )
-        (reject sing)
-t60'' =
-    lam $ \x0 ->
-    uniform_0_1 >>= \x1 ->
-    uniform_0_1 >>= \x2 ->
-    if_ (if_ (zero < x0 / (x2 + x1))
-             (x0 / (x2 + x1) < one)
-             false)
-        (weight (recip (unsafeProb (x2 + x1))) )
-        (reject sing)
-
-t61, t61' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HProb)
-t61 = lam $ \x -> if_ (x < zero) (dirac zero) $ dirac $ unsafeProb $ recip x
-t61'= lam $ \x -> if_ (x < zero) (dirac zero) $ dirac $ unsafeProb $ recip x
-
----- "Special case" of t56
-t62, t62' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HReal ':-> 'HMeasure HUnit)
-t62 = lam $ \t ->
-      lam $ \x ->
-      uniform_0_1 >>= \y ->
-      if_ (zero < t/x - y && t/x - y < one)
-          (dirac unit)
-          (reject sing)
-t62'= lam $ \t ->
-      lam $ \x ->
-      if_ (t/x <= zero) (reject sing) $
-      if_ (t/x <= one) (weight (unsafeProb (t/x))) $
-      if_ (t/x <= (real_ 2)) (weight (unsafeProb ((real_ 2)-t/x))) $
-      reject sing
-
----- "Scalar multiple" of t62
-t63, t63' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t63 = lam $ \t ->
-      uniform_0_1 >>= \x ->
-      uniform_0_1 >>= \y ->
-      if_ (zero < t/x - y && t/x - y < one)
-          (weight (recip (unsafeProb x)))
-          (reject sing)
-t63'= lam $ \t ->
-      uniform_0_1 >>= \x ->
-      if_ (t/x <= zero) (reject sing) $
-      if_ (t/x <= one) (weight (unsafeProb (t/x) / unsafeProb x)) $
-      if_ (t/x <= (real_ 2)) (weight (unsafeProb ((real_ 2)-t/x) / unsafeProb x)) $
-      reject sing
-
--- Density calculation for (Exp (Log StdRandom)) and StdRandom
-t64, t64', t64'' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t64 = lam $ \x0 ->
-      (((dirac zero >>= \x1 ->
-         dirac x0 >>= \x2 ->
-         dirac (x1 < x2)) >>= \x1 ->
-        if_ x1
-            (recip <$> dirac x0)
-            (dirac zero)) >>= \x1 ->
-       weight (unsafeProb x1)) >>
-      (log <$> dirac (unsafeProb x0)) >>= \x2 ->
-      ((exp <$> dirac x2) >>= \x3 ->
-       weight x3) >>
-      (exp <$> dirac x2) >>= \x4 ->
-      ((dirac zero >>= \x5 ->
-        dirac x4 >>= \x6 ->
-        dirac (x5 < x6)) >>= \x5 ->
-       if_ x5
-           ((dirac x4 >>= \x6 ->
-             dirac one >>= \x7 ->
-             dirac (x6 < x7)) >>= \x6 ->
-            if_ x6 (dirac one) (dirac zero))
-           (dirac zero)) >>= \x5 ->
-      weight (unsafeProb x5) 
-t64' =lam $ \x0 ->
-      ((dirac zero >>= \x1 ->
-        dirac x0 >>= \x2 ->
-        dirac (x1 < x2)) >>= \x1 ->
-       if_ x1
-           ((dirac x0 >>= \x2 ->
-             dirac one >>= \x3 ->
-             dirac (x2 < x3)) >>= \x2 ->
-            if_ x2 (dirac one) (dirac zero))
-           (dirac zero)) >>= \x1 ->
-      weight (unsafeProb x1) 
-t64''=lam $ \x0 ->
-      if_ (zero < x0 && x0 < one) 
-          (dirac unit)
-          (reject sing)
-
--- Density calculation for (Add StdRandom (Exp (Neg StdRandom))).
--- Maple can integrate this but we don't simplify it for some reason.
-t65, t65' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t65 =
-    lam $ \t ->
-    uniform_0_1 >>= \x ->
-    if_ (zero < t-x)
-        (let_ (unsafeProb (t-x)) $ \t_x ->
-        withWeight (recip t_x) $
-        (if_ (zero < negate (log t_x) && negate (log t_x) < one)
-            (dirac unit)
-            (reject sing)))
-        (reject sing)
-t65' =
-     lam $ \t ->
-     uniform_0_1  >>= \x->
-     withWeight (if_ (real_ 0 < (log (unsafeProb (t + x * real_ (-1))) * real_ (-1)) &&
-                      x < (t * fromProb (exp (real_ 1)) + real_ (-1)) * fromProb (exp (real_ (-1))) &&
-                      x < t)
-                 (unsafeProb (recip (x * real_ (-1) + t)))
-                 (prob_ 0)) $ (dirac unit)
-
-half' :: (ABT Term abt) => abt '[] 'HReal
-half' = half
-
-t66 :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-t66 = dirac (sqrt $ prob_ 3 + (sqrt $ prob_ 3))
-
-t67 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HReal ':-> 'HMeasure 'HProb)
-t67 = lam $ \p -> lam $ \r -> dirac (exp (r * fromProb p))
-
-t68 :: (ABT Term abt)
-    => abt '[] ('HProb ':-> 'HProb ':-> 'HReal ':-> 'HMeasure 'HReal)
-t68 =
-    lam $ \x4 ->
-    lam $ \x5 ->
-    lam $ \x1 ->
-    lebesgue >>= \x2 ->
-    lebesgue >>= \x3 ->
-    withWeight (exp (negate (x2 - x3) * (x2 - x3)
-                     * recip (fromProb ((fromRational 2) * exp (log x4 * (fromRational 2)))))
-              * recip x4
-              * recip (exp (log ((fromRational 2) * pi) * half)))
-             (withWeight (exp (negate (x1 - x3) * (x1 - x3)
-                             * recip (fromProb ((fromRational 2) * exp (log x5 * (fromRational 2)))))
-                      * recip x5
-                      * recip (exp (log ((fromRational 2) * pi) * half)))
-                     (withWeight (exp (negate x3 * x3
-                                     * recip (fromProb ((fromRational 2) * exp (log x4 * (fromRational 2)))))
-                              * recip x4
-                              * recip (exp (log ((fromRational 2) * pi) * half)))
-                             (dirac x2)))
-
-t68' :: (ABT Term abt) => abt '[] ('HProb ':-> 'HReal ':-> 'HMeasure 'HReal)
-t68' = lam $ \noise -> app (app t68 noise) noise
-
-t69x, t69y :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-t69x = dirac (integrate one (real_ 2) $ \x -> integrate (real_ 3) (real_ 4) $ \_ -> unsafeProb x)
-t69y = dirac (integrate one (real_ 2) $ \_ -> integrate (real_ 3) (real_ 4) $ \y -> unsafeProb y)
-
-t70a, t71a, t72a, t73a, t74a :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t70a = uniform one (real_ 3) >>= \x -> if_ ((real_ 4) < x) (reject sing) (dirac x)
-t71a = uniform one (real_ 3) >>= \x -> if_ ((real_ 3) < x) (reject sing) (dirac x)
-t72a = uniform one (real_ 3) >>= \x -> if_ ((real_ 2) < x) (reject sing) (dirac x)
-t73a = uniform one (real_ 3) >>= \x -> if_ (one < x) (reject sing) (dirac x)
-t74a = uniform one (real_ 3) >>= \x -> if_ (zero < x) (reject sing) (dirac x)
-
-t70b, t71b, t72b, t73b, t74b :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t70b = uniform one (real_ 3) >>= \x -> if_ ((real_ 4) < x) (dirac x) (reject sing)
-t71b = uniform one (real_ 3) >>= \x -> if_ ((real_ 3) < x) (dirac x) (reject sing)
-t72b = uniform one (real_ 3) >>= \x -> if_ ((real_ 2) < x) (dirac x) (reject sing)
-t73b = uniform one (real_ 3) >>= \x -> if_ (one < x) (dirac x) (reject sing)
-t74b = uniform one (real_ 3) >>= \x -> if_ (zero < x) (dirac x) (reject sing)
-
-t70c, t71c, t72c, t73c, t74c :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t70c = uniform one (real_ 3) >>= \x -> if_ (x < (real_ 4)) (dirac x) (reject sing)
-t71c = uniform one (real_ 3) >>= \x -> if_ (x < (real_ 3)) (dirac x) (reject sing)
-t72c = uniform one (real_ 3) >>= \x -> if_ (x < (real_ 2)) (dirac x) (reject sing)
-t73c = uniform one (real_ 3) >>= \x -> if_ (x < one) (dirac x) (reject sing)
-t74c = uniform one (real_ 3) >>= \x -> if_ (x < zero) (dirac x) (reject sing)
-
-t70d, t71d, t72d, t73d, t74d :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t70d = uniform one (real_ 3) >>= \x -> if_ (x < (real_ 4)) (reject sing) (dirac x)
-t71d = uniform one (real_ 3) >>= \x -> if_ (x < (real_ 3)) (reject sing) (dirac x)
-t72d = uniform one (real_ 3) >>= \x -> if_ (x < (real_ 2)) (reject sing) (dirac x)
-t73d = uniform one (real_ 3) >>= \x -> if_ (x < one) (reject sing) (dirac x)
-t74d = uniform one (real_ 3) >>= \x -> if_ (x < zero) (reject sing) (dirac x)
-
-t75 :: (ABT Term abt) => abt '[] ('HMeasure 'HNat)
-t75 = gamma (prob_ 6) one >>= poisson
-
-t75' :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HNat)
-t75' = lam $ \x -> gamma x one >>= poisson
-
-t76 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HReal)
-t76 =
-    lam $ \x ->
-    lebesgue >>= \y ->
-    withWeight (unsafeProb (abs y)) $
-    if_ (y < one)
-        (if_ (zero < y)
-            (if_ (x * y < one)
-                (if_ (zero < x * y)
-                    (dirac (x * y))
-                    (reject sing))
-                (reject sing))
-            (reject sing))
-        (reject sing)
-
--- the (x * (-1)) below is an unfortunate artifact not worth fixing
-t77 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure HUnit)
-t77 =
-    lam $ \x ->
-    if_ (x < zero)
-        (weight (recip (exp x)))
-        (weight (exp x))
-
-t78, t78' :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t78 = uniform zero (real_ 2) >>= \x2 -> withWeight (unsafeProb x2) (dirac x2)
-t78' = beta (prob_ 2) one >>= \x -> dirac ((fromProb x) * (real_ 2))
-
--- what does this simplify to?
-t79 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t79 = dirac (real_ 3) >>= \x -> dirac (if_ (x == (real_ 3)) one x)
-
-t80 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t80 = gamma_1_1 >>= \t -> normal zero t
-
-t81 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-t81 = uniform zero pi
-
-t82 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HProb)
-t82 = lam (densityUniform zero one)
-
-t82' :: (ABT Term abt) => abt '[] ('HReal ':-> 'HProb)
-t82' = lam $ \x -> one 
-
-t83 :: (ABT Term abt) => abt '[] ('HNat ':-> 'HMeasure 'HNat)
-t83 = lam $ \k ->
-      plate k (\_ -> dirac (nat_ 1)) >>= \x ->
-      dirac (size x)
-
-t83' :: (ABT Term abt) => abt '[] ('HNat ':-> 'HMeasure 'HNat)
-t83' = lam dirac
-
--- Testing round-tripping of some other distributions
-testexponential :: (ABT Term abt) => abt '[] ('HMeasure 'HProb)
-testexponential = exponential third
-
-testCauchy :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-testCauchy = cauchy (real_ 5) (prob_ 3)
-
-testMCMCPriorProp
-    :: (ABT Term abt)
-    => abt '[] (HPair 'HReal 'HReal ':-> 'HMeasure (HPair 'HReal 'HReal))
-testMCMCPriorProp = mcmc (lam $ priorAsProposal norm) norm
-
-testMHPriorProp
-    :: (ABT Term abt)
-    => abt '[]
-        (HPair 'HReal 'HReal
-        ':-> 'HMeasure (HPair (HPair 'HReal 'HReal) 'HProb))
-testMHPriorProp = mh (lam $ priorAsProposal norm) norm
-
-testPriorProp'
-    :: (ABT Term abt)
-    => abt '[]
-        (HPair 'HReal 'HReal
-        ':-> 'HMeasure (HPair (HPair 'HReal 'HReal) 'HProb))
-testPriorProp' =
-    lam $ \old ->
-    unsafeSuperpose
-        [(half,
-            normal_0_1 >>= \x1 ->
-            dirac (pair (pair x1 (snd old))
-                (exp
-                    ( (x1 * negate one + (old `unpair` \x2 x3 -> x2))
-                    *   ( (old `unpair` \x2 x3 -> x2)
-                        + (old `unpair` \x2 x3 -> x3) * (negate (real_ 2))
-                        + x1)
-                    * half))))
-        , (half,
-            normal zero (sqrt (prob_ 2)) >>= \x1 ->
-            dirac (pair (pair (fst old) x1)
-                (exp
-                    ( (x1 + (old `unpair` \x2 x3 -> x3) * negate one)
-                    *   ( (old `unpair` \x2 x3 -> x3)
-                        + (old `unpair` \x2 x3 -> x2) * (negate (real_ 4))
-                        + x1)
-                    * (negate (real_ 1))/(real_ 4)))))
-        ]
-
-dup :: (ABT Term abt, SingI a)
-    => abt '[] ('HMeasure a)
-    -> abt '[] ('HMeasure (HPair a a))
-dup m = let_ m (\m' -> liftM2 pair m' m')
-
-norm_nox :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-norm_nox =
-    normal_0_1 >>= \x ->
-    normal x one >>= \y ->
-    dirac y
-
-norm_noy :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
-norm_noy =
-    normal_0_1 >>= \x ->
-    normal x one >>
-    dirac x
-
-flipped_norm :: (ABT Term abt) => abt '[] ('HMeasure (HPair 'HReal 'HReal))
-flipped_norm =
-    normal zero one >>= \x ->
-    normal x one >>= \y ->
-    dirac (pair y x)
+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_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"        
+    ]
+
+testExponentialRelations :: Test 
+testExponentialRelations = test [ 
+    "t_exponential_to_stdChiSq"     ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_stdChiSq.0.hk" "tests/RoundTrip/t_exponential_to_stdChiSq.expected.hk"
+    ]
+
+testErlangRelations :: Test
+testErlangRelations = test [
+        "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"        
+    ]
+
+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
+    , testExponentialRelations
+    , 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)
diff --git a/haskell/Tests/TestSuite.hs b/haskell/Tests/TestSuite.hs
--- a/haskell/Tests/TestSuite.hs
+++ b/haskell/Tests/TestSuite.hs
@@ -1,4 +1,4 @@
--- module Tests.TestSuite(main) where
+module Main(main) where
 
 import System.Exit (exitFailure)
 import System.Environment (lookupEnv)
@@ -11,6 +11,7 @@
 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
 
@@ -26,7 +27,7 @@
     Nothing -> test ignored
 
 allTests :: Maybe String -> Test
-allTests env = test
+allTests env = test $
   [ TestLabel "Parser"       P.allTests
   , TestLabel "Pretty"       Pr.allTests
   , TestLabel "TypeCheck"    TC.allTests
@@ -34,16 +35,15 @@
   , 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 (fmap Just . runTestTT)
+main = mainWith allTests (fmap Just . runTestTT)
 
-mainWith :: (Test -> IO (Maybe Counts)) -> IO ()
-mainWith run = do
+mainWith :: (Maybe String -> Test) -> (Test -> IO (Maybe Counts)) -> IO ()
+mainWith mkTests run = do
     env <- lookupEnv "LOCAL_MAPLE"
-    run (allTests env) >>=
+    run (mkTests env) >>=
       maybe (return ()) (\(Counts _ _ e f) -> if (e>0) || (f>0) then exitFailure else return ())
-
--- maini = mainWith 
diff --git a/haskell/Tests/TestTools.hs b/haskell/Tests/TestTools.hs
--- a/haskell/Tests/TestTools.hs
+++ b/haskell/Tests/TestTools.hs
@@ -3,28 +3,38 @@
            , RankNTypes
            , GADTs
            , PolyKinds
+           , ScopedTypeVariables
            , FlexibleContexts #-}
 {-# OPTIONS_GHC -Wall -fwarn-tabs #-}
-module Tests.TestTools where
+module Tests.TestTools
+  ( module Tests.TestTools
+  , MapleOptions(..)
+  , defaultMapleOptions)
+   where
 
 import Language.Hakaru.Types.Sing
-import Language.Hakaru.Parser.Parser
+import Language.Hakaru.Parser.Parser (parseHakaru)
 import Language.Hakaru.Parser.SymbolResolve (resolveAST)
-import Language.Hakaru.Command (parseAndInfer, splitLines)
+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 qualified Data.Text    as T
-import qualified Data.Text.IO as IO
+import qualified Data.Text.Utf8 as IO
 import Data.Typeable (Typeable)
 import Control.Exception
 import Control.Monad
@@ -54,7 +64,8 @@
     -> abt '[] a
     -> Assertion
 testS p x = do
-    _ <- simplify x `catch` handleException (p ++ ": simplify failed")
+    _ <- simplify (expandTransformations x) `catch`
+           handleException (p ++ ": simplify failed")
     return ()
 
 testStriv 
@@ -62,24 +73,53 @@
     -> 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 
-    -> Assertion
-testSS nm ts t' = 
-     mapM_ (\t -> do p <- simplify t 
-                     assertAlphaEq nm p t')
-           (t':ts)
+    -> Test
+testSS nm ts t' = test $ map (testSS1 nm t') (t':ts)
 
 testSStriv 
     :: [(TrivialABT Term '[] a)] 
     -> TrivialABT Term '[] a 
-    -> Assertion
+    -> 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
@@ -99,21 +139,45 @@
                     ]
        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 s mode k =
-    case parseHakaru s of
-      Left  err  -> assertFailure (show err)
-      Right past ->
-          let m = inferType (resolveAST past) in
-          case runTCM m (splitLines s) mode of
-            Left err                 -> assertFailure (show err)
-            Right (TypedAST typ ast) -> k typ ast
+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
@@ -122,22 +186,55 @@
     -> 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
-    -> Assertion
-testConcreteFiles f1 f2 = do
-  t1 <- IO.readFile f1
-  t2 <- IO.readFile f2
-  case (parseAndInfer t1, parseAndInfer t2) of
-    (Left err, _) -> assertFailure (show err)
-    (_, Left err) -> assertFailure (show err)
-    (Right (TypedAST typ1 ast1), Right (TypedAST typ2 ast2)) -> do
-      ast1' <- simplify ast1
-      ast2' <- simplify ast2
-      case jmEq1 typ1 typ2 of
-        Just Refl -> assertAlphaEq "" ast1' ast2'
-        Nothing   -> assertFailure "files don't have same type"
+    -> 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