@@ -99,11 +99,8 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
9999 unifyTypes' String String = return ()
100100 unifyTypes' Boolean Boolean = return ()
101101 unifyTypes' Array Array = return ()
102+ unifyTypes' Function Function = return ()
102103 unifyTypes' (Object row1) (Object row2) = row1 ?= row2
103− unifyTypes' (Function args1 ret1) (Function args2 ret2) = do
104− guardWith "Function applied to incorrect number of args" $ length args1 == length args2
105− zipWithM_ unifyTypes args1 args2
106− ret1 `unifyTypes` ret2
107104 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
108105 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
109106 env <- getEnv
@@ -235,14 +232,19 @@ entails moduleName context goal@(className, ty) = do
235232 , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
236233 , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
237234 , args <- solveSubgoals env subst (tcdDependencies tcd) ]
235+ solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, Type)] -> [Maybe [Value]]
238236 solveSubgoals _ _ Nothing = return Nothing
239237 solveSubgoals env subst (Just subgoals) = do
240238 dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
241239 return $ Just dict
242− mkDictionary fnName args = maybe id (flip App) args $ (Var fnName)
240+ mkDictionary :: Qualified Ident -> Maybe [Value] -> Value
241+ mkDictionary fnName Nothing = Var fnName
242+ mkDictionary fnName (Just dicts) = foldr (flip App) (Var fnName) dicts
243+ filterModule :: TypeClassDictionaryInScope -> Bool
243244 filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
244245 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
245246 filterModule _ = False
247+ canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
246248 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
247249 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
248250
@@ -431,16 +433,16 @@ infer' (Accessor prop val) = do
431433 _ <- subsumes Nothing objTy (Object (RCons prop field rest))
432434 return $ TypedValue True (Accessor prop typed) field
433435 Just ty -> return $ TypedValue True (Accessor prop typed) ty
434−infer' (Abs args ret) = do
435− ts <- replicateM (length args) fresh
436+infer' (Abs arg ret) = do
437+ ty <- fresh
436438 Just moduleName <- checkCurrentModule <$> get
437− bindLocalVariables moduleName (zip args ts) $ do
439+ bindLocalVariables moduleName [(arg, ty)] $ do
438440 body@(TypedValue _ _ bodyTy) <- infer' ret
439− return $ TypedValue True (Abs args body) $ Function ts bodyTy
440−infer' (App f args) = do
441+ return $ TypedValue True (Abs arg body) $ function ty bodyTy
442+infer' (App f arg) = do
441443 f'@(TypedValue _ _ ft) <- infer f
442444 ret <- fresh
443− app <- checkFunctionApplication f' ft args ret
445+ app <- checkFunctionApplication f' ft arg ret
444446 return $ TypedValue True app ret
445447infer' (Var var) = do
446448 Just moduleName <- checkCurrentModule <$> get
@@ -450,7 +452,7 @@ infer' (Var var) = do
450452 ConstrainedType constraints _ -> do
451453 env <- getEnv
452454 dicts <- getTypeClassDictionaries
453− return $ TypedValue True (App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'
455+ return $ TypedValue True (foldr App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'
454456 _ -> return $ TypedValue True (Var var) ty'
455457infer' (Block ss) = do
456458 ret <- fresh
@@ -619,7 +621,7 @@ inferBinder val (UnaryBinder ctor binder) = do
619621 Just (ty, _) -> do
620622 fn <- replaceAllVarsWithUnknowns ty
621623 case fn of
622− Function [obj] ret -> do
624+ TypeApp (TypeApp Function obj) ret -> do
623625 _ <- subsumes Nothing val ret
624626 inferBinder obj binder
625627 _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
@@ -792,7 +794,7 @@ check' val (ConstrainedType constraints ty) = do
792794 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
793795 (qualifyAllUnqualifiedNames moduleName env constraints)) $
794796 check val ty
795− return $ Abs dictNames val'
797+ return $ foldr Abs val' dictNames
796798check' val u@(TUnknown _) = do
797799 val'@(TypedValue _ _ ty) <- infer val
798800 -- Don't unify an unknown with an inferred polytype
@@ -809,14 +811,13 @@ check' (Indexer index vals) ty = do
809811 index' <- check index Number
810812 vals' <- check vals (TypeApp Array ty)
811813 return $ Indexer index' vals'
812−check' (Abs args ret) (Function argTys retTy) = do
814+check' (Abs arg ret) (TypeApp (TypeApp Function argTy) retTy) = do
813815 Just moduleName <- checkCurrentModule <$> get
814− guardWith "Incorrect number of function arguments" (length args == length argTys)
815− ret' <- bindLocalVariables moduleName (zip args argTys) $ check ret retTy
816− return $ Abs args ret'
817−check' (App f args) ret = do
816+ ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy
817+ return $ Abs arg ret'
818+check' (App f arg) ret = do
818819 f'@(TypedValue _ _ ft) <- infer f
819− app <- checkFunctionApplication f' ft args ret
820+ app <- checkFunctionApplication f' ft arg ret
820821 return $ app
821822check' v@(Var var) ty = do
822823 Just moduleName <- checkCurrentModule <$> get
@@ -918,42 +919,43 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
918919-- |
919920-- Check the type of a function application, rethrowing errors to provide a better error message
920921--
921−checkFunctionApplication :: Value -> Type -> [Value] -> Type -> UnifyT Check Value
922−checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret
922+checkFunctionApplication :: Value -> Type -> Value -> Type -> UnifyT Check Value
923+checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg ret
923924 where
924925 errorMessage msg = "Error applying function of type "
925926 ++ prettyPrintType fnTy
926− ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
927+ ++ " to argument " ++ prettyPrintValue arg
927928 ++ ":\n" ++ msg
928929
929930-- |
930931-- Check the type of a function application
931932--
932−checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> UnifyT Check Value
933−checkFunctionApplication' fn (Function argTys retTy) args ret = do
934− guardWith "Incorrect number of function arguments" (length args == length argTys)
935− args' <- zipWithM check args argTys
933+checkFunctionApplication' :: Value -> Type -> Value -> Type -> UnifyT Check Value
934+checkFunctionApplication' fn (TypeApp (TypeApp Function argTy) retTy) arg ret = do
935+ arg' <- check arg argTy
936936 _ <- subsumes Nothing retTy ret
937− return $ App fn args'
938−checkFunctionApplication' fn (ForAll ident ty) args ret = do
937+ return $ App fn arg'
938+checkFunctionApplication' fn (ForAll ident ty) arg ret = do
939939 replaced <- replaceVarWithUnknown ident ty
940− checkFunctionApplication fn replaced args ret
941−checkFunctionApplication' fn u@(TUnknown _) args ret = do
942− args' <- mapM (\arg -> infer arg >>= \(TypedValue _ v t) -> TypedValue True v <$> replaceAllVarsWithUnknowns t) args
943− let tys = map (\(TypedValue _ _ t) -> t) args'
944− u ?= Function tys ret
945− return $ App fn args'
946−checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do
940+ checkFunctionApplication fn replaced arg ret
941+checkFunctionApplication' fn u@(TUnknown _) arg ret = do
942+ arg' <- do
943+ TypedValue _ v t <- infer arg
944+ TypedValue True v <$> replaceAllVarsWithUnknowns t
945+ let ty = (\(TypedValue _ _ t) -> t) arg'
946+ u ?= function ty ret
947+ return $ App fn arg'
948+checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
947949 ty <- expandTypeSynonym name tyArgs
948− checkFunctionApplication fn ty args ret
949−checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do
950+ checkFunctionApplication fn ty arg ret
951+checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
950952 env <- getEnv
951953 dicts <- getTypeClassDictionaries
952954 Just moduleName <- checkCurrentModule <$> get
953− checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy args ret
954−checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "
955+ checkFunctionApplication' (foldr App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy arg ret
956+checkFunctionApplication' _ fnTy arg ret = throwError $ "Applying a function of type "
955957 ++ prettyPrintType fnTy
956− ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
958+ ++ " to argument(s) " ++ prettyPrintValue arg
957959 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
958960
959961-- |
@@ -975,8 +977,8 @@ subsumes' :: Maybe Value -> Type -> Type -> UnifyT Check (Maybe Value)
975977subsumes' val (ForAll ident ty1) ty2 = do
976978 replaced <- replaceVarWithUnknown ident ty1
977979 subsumes val replaced ty2
978−subsumes' val (Function args1 ret1) (Function args2 ret2) = do
979− zipWithM_ (subsumes Nothing) args2 args1
980+subsumes' val (TypeApp (TypeApp Function arg1) ret1) (TypeApp (TypeApp Function arg2) ret2) = do
981+ subsumes Nothing arg2 arg1
980982 subsumes Nothing ret1 ret2
981983 return val
982984subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
@@ -984,7 +986,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
984986 dicts <- getTypeClassDictionaries
985987 Just moduleName <- checkCurrentModule <$> get
986988 _ <- subsumes' Nothing ty1 ty2
987− return . Just $ App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))
989+ return . Just $ foldr App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))
988990subsumes' val ty1 ty2 = do
989991 ty1 ?= ty2
990992 return val