version 0.2.10.2.1

17 files changed, 256 insertions, 70 deletions

diff --git a/purescript.cabal b/purescript.cabal
index ef94abd..a7a8af8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
 name: purescript
-version: 0.2.0
+version: 0.2.1
 cabal-version: >=1.8
 build-type: Simple
 license: MIT
@@ -15,11 +15,12 @@ data-dir: ""
 
 library
     build-depends: base >=4 && <5, cmdtheline -any, containers -any,
-                   directory -any, filepath -any, mtl -any, parsec -any,
-                   syb -any, transformers -any, utf8-string -any
-    exposed-modules: Data.Generics.Extras Language.PureScript
-                     Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
-                     Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST
+                   directory -any, filepath -any, mtl -any, parsec -any, syb -any,
+                   transformers -any, utf8-string -any
+    exposed-modules: Language.PureScript.Scope Data.Generics.Extras
+                     Language.PureScript Language.PureScript.CodeGen
+                     Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS
+                     Language.PureScript.CodeGen.JS.AST
                      Language.PureScript.CodeGen.Monad Language.PureScript.Declarations
                      Language.PureScript.Kinds Language.PureScript.Names
                      Language.PureScript.Operators Language.PureScript.Optimize
@@ -36,6 +37,7 @@ library
                      Language.PureScript.TypeChecker.Synonyms
                      Language.PureScript.TypeChecker.Types Language.PureScript.Types
                      Language.PureScript.Unknown Language.PureScript.Values Main
+                     Language.PureScript.CaseDeclarations
     exposed: True
     buildable: True
     hs-source-dirs: src
@@ -47,6 +49,7 @@ executable psc
     main-is: Main.hs
     buildable: True
     hs-source-dirs: src
+    other-modules:
     ghc-options: -Wall -O2 -fno-warn-unused-do-bind
 
 test-suite tests
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 9a40e30..4df2b55 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -25,6 +25,7 @@ import Language.PureScript.TypeChecker as P
 import Language.PureScript.Pretty as P
 import Language.PureScript.Optimize as P
 import Language.PureScript.Operators as P
+import Language.PureScript.CaseDeclarations as P
 
 import Data.List (intercalate)
 import Data.Maybe (mapMaybe)
@@ -32,7 +33,8 @@ import Data.Maybe (mapMaybe)
 compile :: [Declaration] -> Either String (String, String, Environment)
 compile decls = do
   bracketted <- rebracket decls
-  (_, env) <- runCheck (typeCheckAll bracketted)
-  let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ bracketted
-  let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted
+  desugared <- desugarCases bracketted
+  (_, env) <- runCheck (typeCheckAll desugared)
+  let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared
+  let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared
   return (js, exts, env)
diff --git a/src/Language/PureScript/CaseDeclarations.hs b/src/Language/PureScript/CaseDeclarations.hs
new file mode 100644
index 0000000..b482c1d
--- /dev/null
+++ b/src/Language/PureScript/CaseDeclarations.hs
@@ -0,0 +1,62 @@
+-----------------------------------------------------------------------------
+--
+-- Module      :  Language.PureScript.CaseDeclarations
+-- Copyright   :  (c) Phil Freeman 2013
+-- License     :  MIT
+--
+-- Maintainer  :  Phil Freeman <paf31@cantab.net>
+-- Stability   :  experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.CaseDeclarations (
+    desugarCases
+) where
+
+import Data.List (groupBy)
+import Control.Monad (join, unless)
+import Control.Monad.Error.Class
+
+import Language.PureScript.Names
+import Language.PureScript.Values
+import Language.PureScript.Declarations
+import Language.PureScript.Scope
+
+desugarCases :: [Declaration] -> Either String [Declaration]
+desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
+
+inSameGroup :: Declaration -> Declaration -> Bool
+inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
+inSameGroup _ _ = False
+
+toDecls :: [Declaration] -> Either String [Declaration]
+toDecls d@[ValueDeclaration _ [] Nothing _] = return d
+toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
+  let tuples = map toTuple ds
+  unless (all ((== map length bs) . map length . fst) tuples) $
+      throwError $ "Argument list lengths differ in declaration " ++ show ident
+  return [makeCaseDeclaration ident tuples]
+toDecls ds = return ds
+
+toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
+toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
+toTuple _ = error "Not a value declaration"
+
+makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration
+makeCaseDeclaration ident alternatives =
+  let
+    argPattern = map length . fst . head $ alternatives
+    args = take (sum argPattern) $ unusedNames (ident, alternatives)
+    vars = map (\arg -> Var (Qualified global arg)) args
+    binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]
+    value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)
+  in
+    ValueDeclaration ident [] Nothing value
+
+rearrange :: [Int] -> [a] -> [[a]]
+rearrange [] _ = []
+rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)
+
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index b5bcc28..1375d85 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -24,7 +24,7 @@ import Language.PureScript.Pretty
 import Language.PureScript.Names
 
 externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String
-externToPs indent path env (ValueDeclaration name _) = do
+externToPs indent path env (ValueDeclaration name _ _ _) = do
   (ty, _) <- M.lookup (path, name) $ names env
   return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
 externToPs indent path env (DataDeclaration name _ _) = do
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index a3b0ec8..9fbbfe4 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -20,11 +20,12 @@ module Language.PureScript.CodeGen.JS (
 import Data.Maybe (mapMaybe)
 import qualified Data.Map as M
 import Control.Arrow (second)
-import Control.Monad (forM)
+import Control.Monad (replicateM, forM)
 
 import Language.PureScript.TypeChecker (Environment, names)
 import Language.PureScript.Values
 import Language.PureScript.Names
+import Language.PureScript.Scope
 import Language.PureScript.Declarations
 import Language.PureScript.Pretty.Common
 import Language.PureScript.CodeGen.Monad
@@ -32,10 +33,10 @@ import Language.PureScript.CodeGen.JS.AST as AST
 import Language.PureScript.TypeChecker.Monad (NameKind(..))
 
 declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]
-declToJs curMod mp (ValueDeclaration ident (Abs args ret)) e =
+declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
   Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :
          maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
-declToJs curMod mp (ValueDeclaration ident val) e =
+declToJs curMod mp (ValueDeclaration ident _ _ val) e =
   Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :
          maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
 declToJs curMod _ (ExternMemberDeclaration member ident _) _ =
@@ -73,7 +74,7 @@ valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e))
 valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]
 valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name
 valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []
-valueToJs m e (Case value binders) = runGen (bindersToJs m e binders (valueToJs m e value))
+valueToJs m e (Case values binders) = runGen (bindersToJs m e binders (map (valueToJs m e) values))
 valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)
 valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val)
 valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)
@@ -94,12 +95,21 @@ qualifiedToJS f (Qualified (ModulePath parts) a) =
        delimited (part:parts') = JSAccessor part (delimited parts')
        delimited _            = error "Invalid argument to delimited"
 
-bindersToJs :: ModulePath -> Environment -> [(Binder, Value)] -> JS -> Gen JS
-bindersToJs m e binders val = do
-  valName <- fresh
-  jss <- forM binders $ \(binder, result) -> binderToJs m e valName [JSReturn (valueToJs m e result)] binder
-  return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
-                 [val]
+bindersToJs :: ModulePath -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
+bindersToJs m e binders vals = do
+  setNextName $ firstUnusedName (binders, vals)
+  valNames <- replicateM (length vals) fresh
+  jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs m e result)] bs grd
+  return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
+                 vals
+  where
+    go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
+    go _ done [] Nothing = return done
+    go _ done [] (Just cond) = return [JSIfElse (valueToJs m e 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"
 
 binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]
 binderToJs _ _ _ done NullBinder = return done
@@ -152,9 +162,6 @@ binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
 binderToJs m e varName done (NamedBinder ident binder) = do
   js <- binderToJs m e varName done binder
   return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
-binderToJs m e varName done (GuardedBinder cond binder) = binderToJs m e varName done' binder
-  where
-  done' = [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]
 
 statementToJs :: ModulePath -> Environment -> Statement -> JS
 statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 59d34b5..ee8ad50 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -47,3 +47,5 @@ data JS
 data JSAssignment
   = JSAssignVariable Ident
   | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
+
+
diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs
index 5cf876e..0ea9f5d 100644
--- a/src/Language/PureScript/CodeGen/Monad.hs
+++ b/src/Language/PureScript/CodeGen/Monad.hs
@@ -19,7 +19,7 @@ module Language.PureScript.CodeGen.Monad where
 import Control.Monad.State
 import Control.Applicative
 
-newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)
+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int, MonadFix)
 
 runGen :: Gen a -> a
 runGen = flip evalState 0 . unGen
@@ -29,3 +29,9 @@ fresh = do
   n <- get
   modify (+ 1)
   return $ '_' : show n
+
+getNextName :: Gen Int
+getNextName = get
+
+setNextName :: Int -> Gen ()
+setNextName = put
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 5457a73..21242d2 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -33,7 +33,7 @@ data Declaration
   = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
   | TypeSynonymDeclaration ProperName [String] PolyType
   | TypeDeclaration Ident PolyType
-  | ValueDeclaration Ident Value
+  | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
   | ExternDeclaration Ident PolyType
   | ExternMemberDeclaration String Ident PolyType
   | ExternDataDeclaration ProperName Kind
diff --git a/src/Language/PureScript/Optimize.hs b/src/Language/PureScript/Optimize.hs
index 537a1ae..b9e2790 100644
--- a/src/Language/PureScript/Optimize.hs
+++ b/src/Language/PureScript/Optimize.hs
@@ -17,6 +17,7 @@ module Language.PureScript.Optimize (
 ) where
 
 import Data.Data
+import Data.Maybe (fromMaybe)
 import Data.Generics
 
 import Language.PureScript.Names
@@ -31,6 +32,12 @@ replaceIdent var1 js = everywhere (mkT replace)
   replace (JSVar var2) | var1 == var2 = js
   replace other = other
 
+replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d
+replaceIdents vars = everywhere (mkT replace)
+  where
+  replace v@(JSVar var) = fromMaybe v $ lookup var vars
+  replace other = other
+
 isReassigned :: (Data d) => Ident -> d -> Bool
 isReassigned var1 = everything (||) (mkQ False check)
   where
@@ -84,7 +91,8 @@ etaConvert :: JS -> JS
 etaConvert = everywhere (mkT convert)
   where
   convert :: JS -> JS
-  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [ident] (JSBlock body)) [arg])]) | shouldInline arg = JSBlock (replaceIdent ident arg body)
+  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])
+    | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)
   convert js = js
 
 unThunk :: JS -> JS
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 95326c1..c21fa56 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -74,10 +74,10 @@ reservedNames = [ "case"
 
 builtInOperators :: [String]
 builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
-                  , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!", "." ]
+                  , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
 
 reservedOpNames :: [String]
-reservedOpNames = builtInOperators ++ [ "->" ]
+reservedOpNames = builtInOperators ++ [ "->", "=", "." ]
 
 identStart :: P.Parsec String u Char
 identStart = P.lower <|> P.oneOf "_$"
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 0345ce0..751d185 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -27,6 +27,7 @@ import Language.PureScript.Declarations
 import Language.PureScript.Parser.Values
 import Language.PureScript.Parser.Types
 import Language.PureScript.Parser.Kinds
+import Language.PureScript.Values
 
 parseDataDeclaration :: P.Parsec String ParseState Declaration
 parseDataDeclaration = do
@@ -50,8 +51,13 @@ parseTypeSynonymDeclaration =
 
 parseValueDeclaration :: P.Parsec String ParseState Declaration
 parseValueDeclaration =
-  ValueDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.char '='))
-                   <*> parseValue
+  ValueDeclaration <$> parseIdent
+                   <*> P.many parseTopLevelBinder
+                   <*> P.optionMaybe parseGuard
+                   <*> ((lexeme (indented *> P.char '=')) *> parseValue)
+
+parseTopLevelBinder :: P.Parsec String ParseState [Binder]
+parseTopLevelBinder = return <$> P.try parseBinderNoParens <|> parens (commaSep parseBinder)
 
 parseExternDeclaration :: P.Parsec String ParseState Declaration
 parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index f2e7ad4..465b5f2 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -14,7 +14,9 @@
 
 module Language.PureScript.Parser.Values (
     parseValue,
-    parseBinder
+    parseGuard,
+    parseBinder,
+    parseBinderNoParens
 ) where
 
 import Language.PureScript.Values
@@ -72,13 +74,14 @@ parseConstructor :: P.Parsec String ParseState Value
 parseConstructor = Constructor <$> C.parseQualified C.properName
 
 parseCase :: P.Parsec String ParseState Value
-parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue
+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
                  <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
 
-parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)
-parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))
-                           <*> parseValue
-                           P.<?> "case alternative"
+parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)
+parseCaseAlternative = (,,) <$> (return <$> parseBinder)
+                            <*> P.optionMaybe parseGuard
+                            <*> (C.lexeme (P.string "->") *> parseValue)
+                            P.<?> "case alternative"
 
 parseIfThenElse :: P.Parsec String ParseState Value
 parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
@@ -263,6 +266,19 @@ parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expressio
   where
   operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]
 
-parseGuardedBinder :: P.Parsec String ParseState Binder
-parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))
+parseBinderNoParens :: P.Parsec String ParseState Binder
+parseBinderNoParens = P.choice (map P.try
+                  [ parseNullBinder
+                  , parseStringBinder
+                  , parseBooleanBinder
+                  , parseNumberBinder
+                  , parseNamedBinder
+                  , parseVarBinder
+                  , parseNullaryBinder
+                  , parseObjectBinder
+                  , parseArrayBinder
+                  , C.parens parseBinder ]) P.<?> "binder"
+
+parseGuard :: P.Parsec String ParseState Guard
+parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
 
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index de6b030..f9c6d81 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -37,12 +37,14 @@ literals = mkPattern match
   match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
   match (Constructor name) = Just $ show name
   match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"
-  match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
+  match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++
+    " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
   match (Var ident) = Just $ show ident
   match _ = Nothing
 
-prettyPrintCaseAlternative :: Binder -> Value -> String
-prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
+prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String
+prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
+  (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val
 
 ifThenElse :: Pattern () Value ((Value, Value), Value)
 ifThenElse = mkPattern match
@@ -158,7 +160,6 @@ prettyPrintBinderAtom = mkPattern match
   match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
   match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
   match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
-  match (GuardedBinder cond binder) = Just $ prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond
   match _ = Nothing
 
 prettyPrintBinder :: Binder -> String
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
new file mode 100644
index 0000000..5b3e73b
--- /dev/null
+++ b/src/Language/PureScript/Scope.hs
@@ -0,0 +1,71 @@
+-----------------------------------------------------------------------------
+--
+-- Module      :  Language.PureScript.Scope
+-- Copyright   :  (c) Phil Freeman 2013
+-- License     :  MIT
+--
+-- Maintainer  :  Phil Freeman <paf31@cantab.net>
+-- Stability   :  experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Scope (
+    usedNames,
+    unusedNames,
+    firstUnusedName
+) where
+
+import Data.Data
+import Data.List ((\\), nub)
+import Data.Generics (extQ, mkQ, everything)
+
+import Language.PureScript.Values
+import Language.PureScript.Names
+import Language.PureScript.CodeGen.JS.AST
+import Data.Maybe (mapMaybe)
+import Text.Read (readMaybe)
+
+usedNames :: (Data d) => d -> [Ident]
+usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val
+  where
+  namesV :: Value -> [Ident]
+  namesV (Abs args _) = args
+  namesV (Var (Qualified (ModulePath []) name)) = [name]
+  namesV _ = []
+  namesS :: Statement -> [Ident]
+  namesS (VariableIntroduction name _) = [name]
+  namesS (For name _ _ _) = [name]
+  namesS _ = []
+  namesB :: Binder -> [Ident]
+  namesB (VarBinder name) = [name]
+  namesB _ = []
+  namesJS :: JS -> [Ident]
+  namesJS (JSVar name) = [name]
+  namesJS (JSFunction (Just name) args _) = name : args
+  namesJS (JSFunction Nothing args _) = args
+  namesJS (JSVariableIntroduction name _) = [name]
+  namesJS (JSFor name _ _ _) = [name]
+  namesJS _ = []
+
+unusedNames :: (Data d) => d -> [Ident]
+unusedNames val =
+  let
+    allNames = usedNames val
+    varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])
+  in
+    varNames \\ allNames
+
+firstUnusedName :: (Data d) => d -> Int
+firstUnusedName val =
+  let
+    allNames = usedNames val
+    varNames = mapMaybe toUnknown allNames
+  in
+    1 + maximum (0 : varNames)
+  where
+  toUnknown :: Ident -> Maybe Int
+  toUnknown (Ident ('_' : s)) = readMaybe s
+  toUnknown _ = Nothing
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 8a9e6da..85b48df 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -63,10 +63,10 @@ typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
     putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)
                  , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }
   typeCheckAll rest
-typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
-  typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =
+  typeCheckAll (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)
 typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
-typeCheckAll (ValueDeclaration name val : rest) = do
+typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do
   rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
     env <- getEnv
     modulePath <- checkModulePath `fmap` get
@@ -76,6 +76,7 @@ typeCheckAll (ValueDeclaration name val : rest) = do
         ty <- typeOf (Just name) val
         putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
   typeCheckAll rest
+typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
 typeCheckAll (ExternDataDeclaration name kind : rest) = do
   env <- getEnv
   modulePath <- checkModulePath `fmap` get
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 15f1cad..c48804b 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -331,10 +331,10 @@ infer' (Constructor c) = do
   case M.lookup (qualify modulePath c) (dataConstructors env) of
     Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
     Just ty -> replaceAllTypeSynonyms ty
-infer' (Case val binders) = do
-  t1 <- infer val
+infer' (Case vals binders) = do
+  ts <- mapM infer vals
   ret <- fresh
-  checkBinders t1 ret binders
+  checkBinders ts ret binders
   return ret
 infer' (IfThenElse cond th el) = do
   check cond Boolean
@@ -451,9 +451,12 @@ inferBinder val (UnaryBinder ctor binder) = do
   modulePath <- checkModulePath <$> get
   case M.lookup (qualify modulePath ctor) (dataConstructors env) of
     Just ty -> do
-      Function [obj] ret <- replaceAllVarsWithUnknowns ty
-      val `subsumes` ret
-      inferBinder obj binder
+      fn <- replaceAllVarsWithUnknowns ty
+      case fn of
+        Function [obj] ret -> do
+          val `subsumes` ret
+          inferBinder obj binder
+        _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
     _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
 inferBinder val (ObjectBinder props) = do
   row <- fresh
@@ -483,21 +486,17 @@ inferBinder val (ConsBinder headBinder tailBinder) = do
 inferBinder val (NamedBinder name binder) = do
   m <- inferBinder val binder
   return $ M.insert name val m
-inferBinder _ _ = error "Invalid argument to inferBinder"
 
-inferGuardedBinder :: Type -> Binder -> Subst (M.Map Ident Type)
-inferGuardedBinder val (GuardedBinder cond binder) = do
-  m1 <- inferBinder val binder
-  bindLocalVariables (M.toList m1) $ check cond Boolean
-  return m1
-inferGuardedBinder val b = inferBinder val b
-
-checkBinders :: Type -> Type -> [(Binder, Value)] -> Subst ()
+checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()
 checkBinders _ _ [] = return ()
-checkBinders nval ret ((binder, val):bs) = do
-  m1 <- inferGuardedBinder nval binder
-  bindLocalVariables (M.toList m1) $ check val ret
-  checkBinders nval ret bs
+checkBinders nvals ret ((binders, grd, val):bs) = do
+  m1 <- M.unions <$> zipWithM inferBinder nvals binders
+  bindLocalVariables (M.toList m1) $ do
+    check val ret
+    case grd of
+      Nothing -> return ()
+      Just g -> check g Boolean
+  checkBinders nvals ret bs
 
 assignVariable :: Ident -> Subst ()
 assignVariable name = do
@@ -618,9 +617,9 @@ check' (TypedValue val ty1) ty2 = do
   guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
   ty1 `subsumes` ty2
   check val ty1
-check' (Case val binders) ret = do
-  t1 <- infer val
-  checkBinders t1 ret binders
+check' (Case vals binders) ret = do
+  ts <- mapM infer vals
+  checkBinders ts ret binders
 check' (IfThenElse cond th el) ty = do
   check cond Boolean
   check th ty
@@ -712,6 +711,7 @@ inferFunctionApplication (ForAll ident ty) args = do
   replaced <- replaceVarWithUnknown ident ty
   inferFunctionApplication replaced args
 inferFunctionApplication u@(TUnknown _) args = do
+
   ret <- fresh
   args' <- mapM replaceAllVarsWithUnknowns args
   u ~~ Function args' ret
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 108b733..1e57a74 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -21,6 +21,8 @@ import Language.PureScript.Names
 
 import Data.Data
 
+type Guard = Value
+
 data UnaryOperator
   = Negate
   | Not
@@ -67,7 +69,7 @@ data Value
   | IfThenElse Value Value Value
   | Block [Statement]
   | Constructor (Qualified ProperName)
-  | Case Value [(Binder, Value)]
+  | Case [Value] [([Binder], Maybe Guard, Value)]
   | TypedValue Value PolyType deriving (Show, Data, Typeable)
 
 data Statement
@@ -97,5 +99,4 @@ data Binder
   | ObjectBinder [(String, Binder)]
   | ArrayBinder [Binder]
   | ConsBinder Binder Binder
-  | NamedBinder Ident Binder
-  | GuardedBinder Value Binder deriving (Show, Data, Typeable)
+  | NamedBinder Ident Binder deriving (Show, Data, Typeable)