version 0.5.20.5.2

16 files changed, 245 insertions, 300 deletions

diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index 7792f89..bb0ecb0 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -45,7 +45,7 @@ readInput input = fmap collect $ forM input $ \inputFile -> do
   collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]
   collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)
 
-newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, MonadError String)
+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)
 
 runMake :: Make a -> IO (Either String a)
 runMake = runErrorT . unMake
diff --git a/purescript.cabal b/purescript.cabal
index 9058539..186add8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
 name: purescript
-version: 0.5.1
+version: 0.5.2
 cabal-version: >=1.8
 build-type: Custom
 license: MIT
@@ -34,8 +34,8 @@ library
                      Language.PureScript.Errors
                      Language.PureScript.Kinds
                      Language.PureScript.Names
+                     Language.PureScript.Supply
                      Language.PureScript.Types
-                     Language.PureScript.Scope
                      Language.PureScript.Traversals
                      Language.PureScript.TypeClassDictionaries
                      Language.PureScript.DeadCodeElimination
@@ -53,7 +53,6 @@ library
                      Language.PureScript.CodeGen.Externs
                      Language.PureScript.CodeGen.JS
                      Language.PureScript.CodeGen.JS.AST
-                     Language.PureScript.CodeGen.Monad
                      Language.PureScript.Optimizer
                      Language.PureScript.Optimizer.Common
                      Language.PureScript.Optimizer.MagicDo
@@ -106,7 +105,7 @@ executable psc-make
 
 executable psci
     build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
-                   mtl -any, parsec -any, haskeline -any, purescript -any,
+                   mtl -any, parsec -any, haskeline >= 0.7.0.0, purescript -any,
                    transformers -any, utf8-string -any, process -any,
                    xdg-basedir -any, cmdtheline -any
     main-is: Main.hs
@@ -136,7 +135,7 @@ executable hierarchy
 
 test-suite tests
     build-depends: base >=4 && <5, containers -any, directory -any,
-                   filepath -any, mtl -any, parsec -any, purescript -any, 
+                   filepath -any, mtl -any, parsec -any, purescript -any,
                    transformers -any, utf8-string -any, process -any
     type: exitcode-stdio-1.0
     main-is: Main.hs
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index ba6913f..eadd44d 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -30,6 +30,7 @@ import Language.PureScript.ModuleDependencies as P
 import Language.PureScript.Environment as P
 import Language.PureScript.Errors as P
 import Language.PureScript.DeadCodeElimination as P
+import Language.PureScript.Supply as P
 
 import qualified Language.PureScript.Constants as C
 
@@ -40,7 +41,7 @@ import Data.Maybe (fromJust, fromMaybe)
 import Control.Monad.Error
 import Control.Monad.State.Lazy
 import Control.Arrow ((&&&))
-import Control.Applicative ((<$>))
+import Control.Applicative
 import qualified Data.Map as M
 import qualified Data.Set as S
 import System.FilePath (pathSeparator)
@@ -70,14 +71,14 @@ compile = compile' initEnvironment
 compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)
 compile' env opts ms = do
   (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
-  desugared <- stringifyErrorStack True $ desugar sorted
+  (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
   (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
   regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
   let entryPoints = moduleNameFromString `map` optionsModules opts
   let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
   let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts
   let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
-  let js = concatMap (\m -> moduleToJs Globals opts m env') modulesToCodeGen
+  let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen
   let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen
   js' <- generateMain env' opts js
   return (prettyPrintJS js', exts, env')
@@ -165,7 +166,7 @@ class MonadMake m where
 -- If timestamps have not changed, the externs file can be used to provide the module's types without
 -- having to typecheck the module again.
 --
-make :: (Functor m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment
+make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment
 make outputDir opts ms = do
   let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
 
@@ -188,15 +189,15 @@ make outputDir opts ms = do
 
   marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
 
-  desugared <- liftError $ stringifyErrorStack True $ zip (map fst marked) <$> desugar (map snd marked)
+  (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
 
-  go initEnvironment desugared
+  evalSupplyT nextVar (go initEnvironment desugared)
 
   where
-  go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m Environment
+  go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment
   go env [] = return env
   go env ((False, m) : ms') = do
-    (_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
+    (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
 
     go env' ms'
   go env ((True, m@(Module moduleName' _ exps)) : ms') = do
@@ -204,18 +205,18 @@ make outputDir opts ms = do
         jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"
         externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"
 
-    progress $ "Compiling " ++ runModuleName moduleName'
+    lift . progress $ "Compiling " ++ runModuleName moduleName'
 
-    (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
+    (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
 
-    regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
+    regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
 
     let mod' = Module moduleName' regrouped exps
-        js = prettyPrintJS $ moduleToJs CommonJS opts mod' env'
-        exts = moduleToPs mod' env'
+    js <- prettyPrintJS <$> moduleToJs CommonJS opts mod' env'
+    let exts = moduleToPs mod' env'
 
-    writeTextFile jsFile js
-    writeTextFile externsFile exts
+    lift $ writeTextFile jsFile js
+    lift $ writeTextFile externsFile exts
 
     go env' ms'
 
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 52d0f7d..6757465 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -85,7 +85,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
 
     exportToPs (TypeInstanceRef ident) = do
       let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
-            fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env
+            fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ M.elems $ typeClassDictionaries env
       let constraintsText = case fromMaybe [] deps of
                               [] -> ""
                               cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 790ff61..e59d43f 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -23,26 +23,25 @@ module Language.PureScript.CodeGen.JS (
     isIdent
 ) where
 
-import Data.Maybe (fromJust, fromMaybe, mapMaybe)
+import Data.Maybe (catMaybes, fromJust, fromMaybe)
 import Data.Function (on)
 import Data.List (nub, (\\))
 
-import Control.Arrow (second)
 import Control.Monad (replicateM, forM)
+import Control.Applicative
 
 import qualified Data.Map as M
 
 import Language.PureScript.Names
 import Language.PureScript.Declarations
-import Language.PureScript.CodeGen.Monad
 import Language.PureScript.Options
 import Language.PureScript.CodeGen.JS.AST as AST
 import Language.PureScript.Types
 import Language.PureScript.Optimizer
 import Language.PureScript.CodeGen.Common
 import Language.PureScript.Environment
-
-import qualified Language.PureScript.Scope as S
+import Language.PureScript.Supply
+import Language.PureScript.Traversals (sndM)
 
 -- |
 -- Different types of modules which are supported
@@ -53,22 +52,23 @@ data ModuleType = CommonJS | Globals
 -- Generate code in the simplified Javascript intermediate representation for all declarations in a
 -- module.
 --
-moduleToJs :: ModuleType -> Options -> Module -> Environment -> [JS]
-moduleToJs mt opts (Module name decls (Just exps)) env = case mt of
-  CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
-  Globals | not isModuleEmpty ->
-    [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))
-                             (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )
-    , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))
-                   (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
-    ]
-  _ -> []
-  where
-  isModuleEmpty = null jsDecls
-  moduleBody = JSStringLiteral "use strict" : jsImports ++ jsDecls
-  moduleExports = JSObjectLiteral $ concatMap exportToJs exps
-  jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls)
-  jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls
+moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]
+moduleToJs mt opts (Module name decls (Just exps)) env = do
+  let jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls
+  jsDecls <- mapM (\decl -> declToJs opts name decl env) decls
+  let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
+  let isModuleEmpty = null optimized
+  let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
+  let moduleExports = JSObjectLiteral $ concatMap exportToJs exps
+  return $ case mt of
+    CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
+    Globals | not isModuleEmpty ->
+      [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))
+                               (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )
+      , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))
+                     (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
+      ]
+    _ -> []
 moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"
 
 importToJs :: ModuleType -> Options -> ModuleName -> JS
@@ -91,14 +91,17 @@ imports =
 -- |
 -- Generate code in the simplified Javascript intermediate representation for a declaration
 --
-declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
-declToJs opts mp (ValueDeclaration ident _ _ _ val) e =
-  Just [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]
-declToJs opts mp (BindingGroupDeclaration vals) e =
-  Just $ flip concatMap vals $ \(ident, _, val) ->
-    [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]
-declToJs _ mp (DataDeclaration _ _ ctors) _ =
-  Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
+declToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
+declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do
+  js <- valueToJs opts mp e val
+  return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
+declToJs opts mp (BindingGroupDeclaration vals) e = do
+  jss <- flip mapM vals $ \(ident, _, val) -> do
+    js <- valueToJs opts mp e val
+    return $ JSVariableIntroduction (identToJs ident) (Just js)
+  return $ Just jss
+declToJs _ mp (DataDeclaration _ _ ctors) _ = do
+  return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
     [JSVariableIntroduction ctor (Just (go pn 0 tys []))]
     where
     go :: ProperName -> Integer -> [Type] -> [JS] -> JS
@@ -107,10 +110,12 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
     go pn index (_ : tys') values =
       JSFunction Nothing ["value" ++ show index]
         (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
-declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
-declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]
+declToJs opts mp (DataBindingGroupDeclaration ds) e = do
+  jss <- mapM (\decl -> declToJs opts mp decl e) ds
+  return $ Just $ concat $ catMaybes jss
+declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
 declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
-declToJs _ _ _ _ = Nothing
+declToJs _ _ _ _ = return Nothing
 
 -- |
 -- Generate key//value pairs for an object literal exporting values from a module.
@@ -144,22 +149,35 @@ accessorString prop | isIdent prop = JSAccessor prop
 -- |
 -- Generate code in the simplified Javascript intermediate representation for a value or expression.
 --
-valueToJs :: Options -> ModuleName -> Environment -> Value -> JS
-valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n
-valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s
-valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
-valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
-valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
-valueToJs opts m e (ObjectUpdate o ps) = extendObj (valueToJs opts m e o) (map (second (valueToJs opts m e)) ps)
-valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name
-valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
-valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
-valueToJs opts m e (Accessor prop val) = accessorString prop (valueToJs opts m e val)
-valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]
-valueToJs opts m e (Let ds val) = JSApp (JSFunction Nothing [] (JSBlock (concat (mapMaybe (flip (declToJs opts m) e) ds) ++ [JSReturn $ valueToJs opts m e val]))) []
-valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])
-valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])
-valueToJs _ m _ (Var ident) = varToJs m ident
+valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS
+valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
+valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
+valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs
+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps
+valueToJs opts m e (ObjectUpdate o ps) = do
+  obj <- valueToJs opts m e o
+  sts <- mapM (sndM (valueToJs opts m e)) ps
+  extendObj obj sts
+valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident . runProperName) name
+valueToJs opts m e (Case values binders) = do
+  vals <- mapM (valueToJs opts m e) values
+  bindersToJs opts m e binders vals
+valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
+valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
+valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)
+valueToJs opts m e (Let ds val) = do
+  decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds
+  ret <- valueToJs opts m e val
+  return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
+valueToJs opts m e (Abs (Left arg) val) = do
+  ret <- valueToJs opts m (bindName m arg e) val
+  return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
+valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = do
+  let arg' = identToJs arg
+  ret <- valueToJs opts m e val
+  return $ JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn ret])
+valueToJs _ m _ (Var ident) = return $ varToJs m ident
 valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
 valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
 valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"
@@ -168,20 +186,22 @@ valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
 -- |
 -- Shallow copy an object.
 --
-extendObj :: JS -> [(String, JS)] -> JS
-extendObj obj sts = JSApp (JSFunction Nothing [] block) []
+extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS
+extendObj obj sts = do
+  newObj <- freshName
+  key <- freshName
+  let
+    jsKey = JSVar key
+    jsNewObj = JSVar newObj
+    block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
+    objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
+    copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
+    cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
+    assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
+    stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
+    extend = map stToAssign sts
+  return $ JSApp (JSFunction Nothing [] block) []
   where
-  [newObj, key] = take 2 . map identToJs . S.unusedNames $ used
-  used = usedNamesJS obj ++ concatMap (usedNamesJS . snd) sts
-  jsKey = JSVar key
-  jsNewObj = JSVar newObj
-  block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
-  objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
-  copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
-  cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
-  assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
-  stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
-  extend = map stToAssign sts
 
 -- |
 -- Temporarily extends the environment with a single local variable name
@@ -198,7 +218,6 @@ bindNames m idents env = env { names = M.fromList [ ((m, ident), (noType, LocalV
   where
   noType = error "Temporary lambda variable type was read"
 
-
 -- |
 -- Generate code in the simplified Javascript intermediate representation for runtime type checks.
 --
@@ -251,42 +270,31 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
 -- Generate code in the simplified Javascript intermediate representation for pattern match binders
 -- and guards.
 --
-bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS
-bindersToJs opts m e binders vals = runGen (map identToJs (S.unusedNames usedNames)) $ do
-  valNames <- replicateM (length vals) fresh
-  jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (concatMap binderNames bs) e) result)] bs grd
-  return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
-                 vals
+bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
+bindersToJs opts m e binders vals = do
+  valNames <- replicateM (length vals) freshName
+  let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
+  jss <- forM binders $ \(CaseAlternative bs grd result) -> do
+    ret <- valueToJs opts m (bindNames m (concatMap binderNames bs) e) result
+    go valNames [JSReturn ret] bs grd
+  return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
+                 []
   where
-    usedNames = concatMap usedNamesJS vals ++ concatMap S.usedNamesCaseAlternative binders
-
-    go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
+    go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]
     go _ done [] Nothing = return done
-    go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]
+    go _ done [] (Just cond) = do
+      cond' <- valueToJs opts m e cond
+      return [JSIfElse cond' (JSBlock done) Nothing]
     go (v:vs) done' (b:bs) grd = do
       done'' <- go vs done' bs grd
       binderToJs m e v done'' b
     go _ _ _ _ = error "Invalid arguments to bindersToJs"
 
 -- |
--- Gather all used names appearing inside a value
---
-usedNamesJS :: JS -> [Ident]
-usedNamesJS val = nub $ everythingOnJS (++) namesJS val
-  where
-  namesJS (JSVar name) = [Ident name]
-  namesJS (JSFunction (Just name) args _) = Ident name : map Ident args
-  namesJS (JSFunction Nothing args _) = map Ident args
-  namesJS (JSVariableIntroduction name _) = [Ident name]
-  namesJS (JSFor name _ _ _) = [Ident name]
-  namesJS (JSForIn name _ _) = [Ident name]
-  namesJS _ = []
-
--- |
 -- Generate code in the simplified Javascript intermediate representation for a pattern match
 -- binder.
 --
-binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]
+binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]
 binderToJs _ _ _ done NullBinder = return done
 binderToJs _ _ varName done (StringBinder str) =
   return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
@@ -308,19 +316,19 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do
                      (JSBlock js)
                      Nothing]
   where
-  go :: Integer -> [JS] -> [Binder] -> Gen [JS]
+  go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]
   go _ done' [] = return done'
   go index done' (binder:bs') = do
-    argVar <- fresh
+    argVar <- freshName
     done'' <- go (index + 1) done' bs'
     js <- binderToJs m e argVar done'' binder
     return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)
 binderToJs m e varName done (ObjectBinder bs) = go done bs
   where
-  go :: [JS] -> [(String, Binder)] -> Gen [JS]
+  go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]
   go done' [] = return done'
   go done' ((prop, binder):bs') = do
-    propVar <- fresh
+    propVar <- freshName
     done'' <- go done' bs'
     js <- binderToJs m e propVar done'' binder
     return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
@@ -328,16 +336,16 @@ binderToJs m e varName done (ArrayBinder bs) = do
   js <- go done 0 bs
   return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
   where
-  go :: [JS] -> Integer -> [Binder] -> Gen [JS]
+  go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]
   go done' _ [] = return done'
   go done' index (binder:bs') = do
-    elVar <- fresh
+    elVar <- freshName
     done'' <- go done' (index + 1) bs'
     js <- binderToJs m e elVar done'' binder
     return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
 binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
-  headVar <- fresh
-  tailVar <- fresh
+  headVar <- freshName
+  tailVar <- freshName
   js1 <- binderToJs m e headVar done headBinder
   js2 <- binderToJs m e tailVar js1 tailBinder
   return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock
diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs
deleted file mode 100644
index d6b0d71..0000000
--- a/src/Language/PureScript/CodeGen/Monad.hs
+++ /dev/null
@@ -1,43 +0,0 @@
------------------------------------------------------------------------------
---
--- Module      :  Language.PureScript.CodeGen.Monad
--- Copyright   :  (c) Phil Freeman 2013
--- License     :  MIT
---
--- Maintainer  :  Phil Freeman <paf31@cantab.net>
--- Stability   :  experimental
--- Portability :
---
--- |
--- Code generation monad
---
--- This monad provides a supply of fresh names which can be used to create variables.
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module Language.PureScript.CodeGen.Monad where
-
-import Control.Monad.State
-import Control.Applicative
-
--- |
--- Code generation monad data type
---
-newtype Gen a = Gen { unGen :: State [String] a } deriving (Functor, Applicative, Monad, MonadState [String])
-
--- |
--- Run a computation in the code generation monad
---
-runGen :: [String] -> Gen a -> a
-runGen names = flip evalState names . unGen
-
--- |
--- Generate a fresh name
---
-fresh :: Gen String
-fresh = do
-  (s:ss) <- get
-  put ss
-  return s
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 687128f..a148869 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -49,7 +49,7 @@ data Environment = Environment {
   -- |
   -- Available type class dictionaries
   --
-  , typeClassDictionaries :: [TypeClassDictionaryInScope]
+  , typeClassDictionaries :: M.Map (Qualified Ident, Maybe ModuleName) TypeClassDictionaryInScope
   -- |
   -- Type classes
   --
@@ -60,7 +60,7 @@ data Environment = Environment {
 -- The initial environment with no values and only the default javascript types defined
 --
 initEnvironment :: Environment
-initEnvironment = Environment M.empty primTypes M.empty M.empty [] M.empty
+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
 
 -- |
 -- The type of a foreign import
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs
index 65dc217..0c3626e 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -53,7 +53,11 @@ unThunk :: JS -> JS
 unThunk = everywhereOnJS convert
   where
   convert :: JS -> JS
-  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
+  convert (JSBlock []) = JSBlock []
+  convert (JSBlock jss) =
+    case (last jss) of
+      JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
+      _ -> JSBlock jss
   convert js = js
 
 evaluateIifes :: JS -> JS
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
deleted file mode 100644
index 50cf065..0000000
--- a/src/Language/PureScript/Scope.hs
+++ /dev/null
@@ -1,84 +0,0 @@
------------------------------------------------------------------------------
---
--- Module      :  Language.PureScript.Scope
--- Copyright   :  (c) Phil Freeman 2013
--- License     :  MIT
---
--- Maintainer  :  Phil Freeman <paf31@cantab.net>
--- Stability   :  experimental
--- Portability :
---
--- |
--- Utility functions for working with names in scope
---
------------------------------------------------------------------------------
-
-module Language.PureScript.Scope (
-    usedNamesDecl,
-    usedNamesValue,
-    usedNamesBinder,
-    usedNamesCaseAlternative,
-    usedNamesDoNotationElement,
-    unusedNames
-) where
-
-import Data.List ((\\), nub)
-
-import Language.PureScript.Declarations
-import Language.PureScript.Names
-
-usedNames :: (Declaration -> [Ident], Value -> [Ident], Binder -> [Ident], CaseAlternative -> [Ident], DoNotationElement -> [Ident])
-usedNames = everythingOnValues (++) f g h (const []) (const [])
-  where
-  f :: Declaration -> [Ident]
-  f (ValueDeclaration name _ _ _ _) = [name]
-  f _ = []
-
-  g :: Value -> [Ident]
-  g (Abs (Left arg) _) = [arg]
-  g (Var (Qualified Nothing name)) = [name]
-  g _ = []
-
-  h :: Binder -> [Ident]
-  h (VarBinder name) = [name]
-  h _ = []
-
--- |
--- Gather all used names appearing inside a declaration
---
-usedNamesDecl :: Declaration -> [Ident]
-usedNamesDecl = let (f, _, _, _, _) = usedNames in nub . f
-
--- |
--- Gather all used names appearing inside a value
---
-usedNamesValue :: Value -> [Ident]
-usedNamesValue = let (_, f, _, _, _) = usedNames in nub . f
-
--- |
--- Gather all used names appearing inside a binder
---
-usedNamesBinder :: Binder -> [Ident]
-usedNamesBinder = let (_, _, f, _, _) = usedNames in nub . f
-
--- |
--- Gather all used names appearing inside a case alternative
---
-usedNamesCaseAlternative :: CaseAlternative -> [Ident]
-usedNamesCaseAlternative = let (_, _, _, f, _) = usedNames in nub . f
-
--- |
--- Gather all used names appearing inside a do notation element
---
-usedNamesDoNotationElement :: DoNotationElement -> [Ident]
-usedNamesDoNotationElement = let (_, _, _, _, f) = usedNames in nub . f
-
--- |
--- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@
---
-unusedNames :: [Ident] -> [Ident]
-unusedNames allNames =
-  let
-    varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])
-  in
-    varNames \\ allNames
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index b2db77a..5296f6e 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -16,9 +16,12 @@
 module Language.PureScript.Sugar (desugar, module S) where
 
 import Control.Monad
+import Control.Category ((>>>))
+import Control.Monad.Trans.Class
 
 import Language.PureScript.Declarations
 import Language.PureScript.Errors
+import Language.PureScript.Supply
 
 import Language.PureScript.Sugar.Operators as S
 import Language.PureScript.Sugar.DoNotation as S
@@ -28,8 +31,6 @@ import Language.PureScript.Sugar.BindingGroups as S
 import Language.PureScript.Sugar.TypeClasses as S
 import Language.PureScript.Sugar.Names as S
 
-import Control.Category ((>>>))
-
 -- |
 -- The desugaring pipeline proceeds as follows:
 --
@@ -47,12 +48,12 @@ import Control.Category ((>>>))
 --
 --  * Qualify any unqualified names and types
 --
-desugar :: [Module] -> Either ErrorStack [Module]
+desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
 desugar = map removeSignedLiterals
           >>> mapM desugarDoModule
           >=> desugarCasesModule
-          >=> desugarTypeDeclarationsModule
-          >=> desugarImports
-          >=> rebracket
+          >=> lift . (desugarTypeDeclarationsModule
+                      >=> desugarImports
+                      >=> rebracket)
           >=> desugarTypeClasses
-          >=> createBindingGroupsModule
+          >=> lift . createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index c8a97b4..805a00c 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -23,43 +23,41 @@ import Data.Monoid ((<>))
 import Data.List (groupBy)
 
 import Control.Applicative
-import Control.Monad ((<=<), forM, join, unless)
+import Control.Monad ((<=<), forM, join, unless, replicateM)
 import Control.Monad.Error.Class
 
 import Language.PureScript.Names
 import Language.PureScript.Declarations
-import Language.PureScript.Scope
 import Language.PureScript.Environment
 import Language.PureScript.Errors
+import Language.PureScript.Supply
 
 -- |
 -- Replace all top-level binders in a module with case expressions.
 --
-desugarCasesModule :: [Module] -> Either ErrorStack [Module]
+desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]
 desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
   rethrow (strMsg ("Error in module " ++ show name) <>) $
-    Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps
+    Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
 
-desugarAbs :: [Declaration] -> [Declaration]
-desugarAbs = map f
+desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
+desugarAbs = mapM f
   where
-  (f, _, _) = everywhereOnValues id replace id
+  (f, _, _) = everywhereOnValuesM return replace return
 
-  replace (Abs (Right binder) val) =
-    let
-      used = usedNamesBinder binder ++ usedNamesValue val
-      ident = head $ unusedNames used
-    in
-      Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
-  replace other = other
+  replace :: Value -> SupplyT (Either ErrorStack) Value
+  replace (Abs (Right binder) val) = do
+    ident <- Ident <$> freshName
+    return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
+  replace other = return other
 
 -- |
 -- Replace all top-level binders with case expressions.
 --
-desugarCases :: [Declaration] -> Either ErrorStack [Declaration]
+desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
 desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
   where
-    desugarRest :: [Declaration] -> Either ErrorStack [Declaration]
+    desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
     desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
       (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
     desugarRest (ValueDeclaration name nameKind bs g val : rest) =
@@ -80,7 +78,7 @@ inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2
 inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2
 inSameGroup _ _ = False
 
-toDecls :: [Declaration] -> Either ErrorStack [Declaration]
+toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
 toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do
   let args = map (\(VarBinder arg) -> arg) bs
       body = foldr (Abs . Left) val args
@@ -89,7 +87,8 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do
   let tuples = map toTuple ds
   unless (all ((== length bs) . length . fst) tuples) $
       throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
-  return [makeCaseDeclaration ident tuples]
+  caseDecl <- makeCaseDeclaration ident tuples
+  return [caseDecl]
 toDecls (PositionedDeclaration pos d : ds) = do
   (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
   return (PositionedDeclaration pos d' : ds')
@@ -104,15 +103,13 @@ toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))
 toTuple (PositionedDeclaration _ d) = toTuple d
 toTuple _ = error "Not a value declaration"
 
-makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration
-makeCaseDeclaration ident alternatives =
+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> SupplyT (Either ErrorStack) Declaration
+makeCaseDeclaration ident alternatives = do
+  let argPattern = length . fst . head $ alternatives
+  args <- map Ident <$> replicateM argPattern freshName
   let
-    argPattern = length . fst . head $ alternatives
-    args = take argPattern $ unusedNames used
-    used = concatMap (\(bs, (grd, val)) -> concatMap usedNamesBinder bs ++ maybe [] usedNamesValue grd ++ usedNamesValue val) alternatives
     vars = map (Var . Qualified Nothing) args
     binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]
     value = foldr (Abs . Left) (Case vars binders) args
-  in
-    ValueDeclaration ident Value [] Nothing value
+  return $ ValueDeclaration ident Value [] Nothing value
 
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index fc665e3..f8f83c8 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -19,25 +19,27 @@ module Language.PureScript.Sugar.DoNotation (
 ) where
 
 import Language.PureScript.Names
-import Language.PureScript.Scope
 import Language.PureScript.Declarations
 import Language.PureScript.Errors
+import Language.PureScript.Supply
 
 import qualified Language.PureScript.Constants as C
 
 import Control.Applicative
+import Control.Monad.Trans.Class
 
 -- |
 -- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
 -- and all @DoNotationLet@ constructors with let expressions.
 --
-desugarDoModule :: Module -> Either ErrorStack Module
+desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
 desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts
 
-desugarDo :: Declaration -> Either ErrorStack Declaration
-desugarDo =
+desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
+desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)
+desugarDo d =
   let (f, _, _) = everywhereOnValuesM return replace return
-  in f
+  in f d
   where
   prelude :: ModuleName
   prelude = ModuleName [ProperName C.prelude]
@@ -45,28 +47,28 @@ desugarDo =
   bind :: Value
   bind = Var (Qualified (Just prelude) (Op (C.>>=)))
 
-  replace :: Value -> Either ErrorStack Value
+  replace :: Value -> SupplyT (Either ErrorStack) Value
   replace (Do els) = go els
+  replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)
   replace other = return other
 
-  go :: [DoNotationElement] -> Either ErrorStack Value
+  go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Value
   go [] = error "The impossible happened in desugarDo"
   go [DoNotationValue val] = return val
   go (DoNotationValue val : rest) = do
     rest' <- go rest
     return $ App (App bind val) (Abs (Left (Ident "_")) rest')
-  go [DoNotationBind _ _] = Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
+  go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
   go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
   go (DoNotationBind (VarBinder ident) val : rest) = do
     rest' <- go rest
     return $ App (App bind val) (Abs (Left ident) rest')
   go (DoNotationBind binder val : rest) = do
     rest' <- go rest
-    let used = concatMap usedNamesDoNotationElement rest
-        ident = head $ unusedNames used
+    ident <- Ident <$> freshName
     return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))
-  go [DoNotationLet _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
+  go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
   go (DoNotationLet ds : rest) = do
     rest' <- go rest
     return $ Let ds rest'
-  go (PositionedDoNotationElement pos el : rest) = PositionedValue pos <$> go (el : rest)
+  go (PositionedDoNotationElement pos el : rest) = rethrowWithPosition pos $ PositionedValue pos <$> go (el : rest)
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 2f2e0c3..3e2470b 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -24,6 +24,7 @@ import Language.PureScript.Types
 import Language.PureScript.Sugar.CaseDeclarations
 import Language.PureScript.Environment
 import Language.PureScript.Errors
+import Language.PureScript.Supply
 import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
 
 import qualified Language.PureScript.Constants as C
@@ -40,13 +41,13 @@ import qualified Data.Map as M
 
 type MemberMap = M.Map (ModuleName, ProperName) Declaration
 
-type Desugar = StateT MemberMap (Either ErrorStack)
+type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))
 
 -- |
 -- Add type synonym declarations for type class dictionary types, and value declarations for type class
 -- instance dictionary expressions.
 --
-desugarTypeClasses :: [Module] -> Either ErrorStack [Module]
+desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
 desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
 
 desugarModule :: Module -> Desugar Module
@@ -160,7 +161,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
   m <- get
 
   -- Lookup the type arguments and member types for the type class
-  (TypeClassDeclaration _ args implies tyDecls) <- lift $
+  (TypeClassDeclaration _ args implies tyDecls) <- lift . lift $
     maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
       M.lookup (qualify mn className) m
 
@@ -203,7 +204,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
 
   memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
   memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
-    _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
+    _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
     let memberValue = typeInstanceDictionaryEntryValue d
     return (ident, memberValue)
   memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
diff --git a/src/Language/PureScript/Supply.hs b/src/Language/PureScript/Supply.hs
new file mode 100644
index 0000000..c11725b
--- /dev/null
+++ b/src/Language/PureScript/Supply.hs
@@ -0,0 +1,56 @@
+-----------------------------------------------------------------------------
+--
+-- Module      :  Language.PureScript.Supply
+-- Copyright   :  (c) Phil Freeman 2014
+-- License     :  MIT
+--
+-- Maintainer  :  Phil Freeman <paf31@cantab.net>
+-- Stability   :  experimental
+-- Portability :
+--
+-- |
+-- Fresh variable supply
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Language.PureScript.Supply where
+
+import Data.Functor.Identity
+
+import Control.Applicative
+import Control.Monad.State
+import Control.Monad.Error.Class
+
+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)
+
+runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
+runSupplyT n = flip runStateT n . unSupplyT
+
+evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a
+evalSupplyT n = fmap fst . runSupplyT n
+
+type Supply = SupplyT Identity
+
+runSupply :: Integer -> Supply a -> (a, Integer)
+runSupply n = runIdentity . runSupplyT n
+
+evalSupply :: Integer -> Supply a -> a
+evalSupply n = runIdentity . evalSupplyT n
+
+fresh :: (Monad m) => SupplyT m Integer
+fresh = SupplyT $ do
+  n <- get
+  put (n + 1)
+  return n
+
+freshName :: (Functor m, Monad m) => SupplyT m String
+freshName = ('_' :) . show <$> fresh
+
+instance (MonadError e m) => MonadError e (SupplyT m) where
+  throwError = SupplyT . throwError
+  catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 6fadcfc..63acafe 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -84,7 +84,8 @@ addTypeClass moduleName pn args implies ds =
 
 addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
 addTypeClassDictionaries entries =
-  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
+  let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ }  <- entries ]
+  in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
 
 checkTypeClassInstance :: ModuleName -> Type -> Check ()
 checkTypeClassInstance _ (TypeVar _) = return ()
@@ -182,8 +183,8 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d
   guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
   return $ d : ds
 typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do
-  env <- getEnv
-  let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) (typeClassDictionaries env)
+  tcds <- getTypeClassDictionaries
+  let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) tcds
   addTypeClassDictionaries [ tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
                            | tcd <- instances
                            , let (Qualified _ ident) = tcdName tcd
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 86bc9a7..9caec9e 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -21,6 +21,7 @@ module Language.PureScript.TypeChecker.Monad where
 import Language.PureScript.Types
 import Language.PureScript.Kinds
 import Language.PureScript.Names
+import Language.PureScript.Declarations (canonicalizeDictionary)
 import Language.PureScript.Environment
 import Language.PureScript.TypeClassDictionaries
 import Language.PureScript.Options
@@ -63,7 +64,8 @@ bindTypes newNames action = do
 withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
 withTypeClassDictionaries entries action = do
   orig <- get
-  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
+  let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ }  <- entries ]
+  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
   a <- action
   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
   return a
@@ -72,7 +74,7 @@ withTypeClassDictionaries entries action = do
 -- Get the currently available list of type class dictionaries
 --
 getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
-getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
+getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get
 
 -- |
 -- Temporarily bind a collection of names to local variables