Fixed bugs with JS output for typeclass dictionaries

garyb · garyb · commit a86e71a4326a · 2014-02-01T00:27:06.000Z
diff --git a/examples/passing/Do.purs b/examples/passing/Do.purs
@@ -9,15 +9,15 @@ instance Prelude.Monad Maybe where
   (>>=) Nothing _ = Nothing
   (>>=) (Just a) f = f a
 
-test1 = \ -> do 
+test1 = \_ -> do 
   Just "abc"
 
-test2 = \ -> do
+test2 = \_ -> do
   (x : _) <- Just [1, 2, 3]
   (y : _) <- Just [4, 5, 6]
   Just (x + y)
 
-test3 = \ -> do
+test3 = \_ -> do
   Just 1
   Nothing :: Maybe Number
   Just 2
@@ -34,11 +34,11 @@ test5 mx my mz = do
   z <- mz
   Just (z + sum)
 
-test6 mx = \ -> do 
+test6 mx = \_ -> do 
   let Just x = mx
   Just x
 
-test8 = \ -> do 
+test8 = \_ -> do 
   Just (do 
     Just 1)
 
@@ -60,7 +60,7 @@ forever a = do
   a
   forever a
 
-test9 = \ -> foo <$> Just 1 <*> Just 2 <*> Just 3
+test9 = \_ -> foo <$> Just 1 <*> Just 2 <*> Just 3
     
 module Main where
 
diff --git a/examples/passing/ExternData.purs b/examples/passing/ExternData.purs
@@ -12,7 +12,7 @@ module ExternData where
 
   foreign import prompt :: IO String
 
-  main = \ -> prompt `bind` \s -> showMessage s
+  main = \_ -> prompt `bind` \s -> showMessage s
     
 module Main where
 
diff --git a/examples/passing/FFI.purs b/examples/passing/FFI.purs
@@ -9,7 +9,7 @@ module FFIModuleTest where
 
 import FFI
 
-baz = \ -> foo "test"
+baz = \_ -> foo "test"
     
 module Main where
 
diff --git a/examples/passing/Rank2Types.purs b/examples/passing/Rank2Types.purs
@@ -9,7 +9,7 @@ module Rank2Types where
 
   foreign import exampleST :: forall s. ST s Number
 
-  testST = \ -> runST exampleST
+  testST = \_ -> runST exampleST
 
   foreign import push :: forall el. el -> [el] -> [el]
 
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -97,7 +97,7 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do
     memberName <- mkDictionaryEntryName mn name ty ident
     return (identToJs ident, TypedValue False
                                (if null deps then Var (Qualified Nothing memberName)
-                                else foldr App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
+                                else foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
                                (quantify memberType))
   memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
 
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -452,7 +452,7 @@ infer' (Var var) = do
     ConstrainedType constraints _ -> do
       env <- getEnv
       dicts <- getTypeClassDictionaries
-      return $ TypedValue True (foldr App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'
+      return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'
     _ -> return $ TypedValue True (Var var) ty'
 infer' (Block ss) = do
   ret <- fresh
@@ -952,7 +952,7 @@ checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
   env <- getEnv
   dicts <- getTypeClassDictionaries
   Just moduleName <- checkCurrentModule <$> get
-  checkFunctionApplication' (foldr App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy arg ret
+  checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy arg ret
 checkFunctionApplication' _ fnTy arg ret = throwError $ "Applying a function of type "
   ++ prettyPrintType fnTy
   ++ " to argument(s) " ++ prettyPrintValue arg
@@ -986,7 +986,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
   dicts <- getTypeClassDictionaries
   Just moduleName <- checkCurrentModule <$> get
   _ <- subsumes' Nothing ty1 ty2
-  return . Just $ foldr App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))
+  return . Just $ foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))
 subsumes' val ty1 ty2 = do
   ty1 ?= ty2
   return val
