Merge pull request purescript#1566 from purescript/1169

paf31 · paf31 · commit 2c7f09292648 · 2015-10-26T09:33:18.000-07:00
Fix purescript#1169
diff --git a/examples/failing/1169.purs b/examples/failing/1169.purs
@@ -0,0 +1,12 @@
+-- @shouldFailWith IncorrectConstructorArity 
+module Test where
+
+data Outer a = Outer a
+            
+data Inner a b = Inner a b
+
+test1 :: forall a b. Outer (Inner a b) -> Boolean
+test1 (Outer (Inner _)) = true
+
+test2 :: forall a b. Inner a b -> Boolean
+test2 (Inner _) = true
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -338,18 +338,17 @@ inferBinder val (ConstructorBinder ctor binders) = do
     Just (_, _, ty, _) -> do
       (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty
       fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn
-      go binders fn'
-        where
-        go [] ty' = case (val, ty') of
-          (TypeConstructor _, TypeApp _ _) -> throwIncorrectArity
-          _ -> do
-            _ <- val =?= ty'
-            return M.empty
-        go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
-          M.union <$> inferBinder obj binder <*> go binders' ret
-        go _ _ = throwIncorrectArity
-        throwIncorrectArity = throwError . errorMessage $ IncorrectConstructorArity ctor
+      let (args, ret) = peelArgs fn'
+      unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor
+      ret =?= val
+      M.unions <$> zipWithM inferBinder (reverse args) binders
     _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing
+  where
+  peelArgs :: Type -> ([Type], Type)
+  peelArgs = go []
+    where
+    go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret
+    go args ret = (args, ret)
 inferBinder val (ObjectBinder props) = do
   row <- fresh
   rest <- fresh
