Revert "Fix #922"

src/Language/PureScript/TypeChecker/Types.hs

@@ -282,12 +282,10 @@ infer' v@(Constructor c) = do
     Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty
                              return $ TypedValue True v' ty'
 infer' (Case vals binders) = do
-  (vals', ts) <- fmap unzip $ forM vals $ \val -> do
-    TypedValue _ val' ty <- infer val
-    instantiatePolyTypeWithUnknowns val' ty
+  ts <- mapM infer vals
   ret <- fresh
-  binders' <- checkBinders ts ret binders
-  return $ TypedValue True (Case vals' binders') ret
+  binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders
+  return $ TypedValue True (Case ts binders') ret
 infer' (IfThenElse cond th el) = do
   cond' <- check cond tyBoolean
   v2@(TypedValue _ _ t2) <- infer th
@@ -378,7 +376,7 @@ inferBinder val (ConstructorBinder ctor binders) = do
         go [] ty' = case (val, ty') of
           (TypeConstructor _, TypeApp _ _) -> throwIncorrectArity
           _ -> do
-            _ <- val =?= ty'
+            _ <- subsumes Nothing val ty'
             return M.empty
         go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
           M.union <$> inferBinder obj binder <*> go binders' ret
@@ -539,9 +537,8 @@ check' (TypedValue checkType val ty1) ty2 = do
       val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val
       return $ TypedValue checkType val''' ty2'
 check' (Case vals binders) ret = do
-  (vals', ts) <- fmap unzip $ forM vals $ \val -> do
-    TypedValue _ val' ty <- infer val
-    instantiatePolyTypeWithUnknowns val' ty
+  vals' <- mapM infer vals
+  let ts = map (\(TypedValue _ _ t) -> t) vals'
   binders' <- checkBinders ts ret binders
   return $ TypedValue True (Case vals' binders') ret
 check' (IfThenElse cond th el) ty = do
@@ -570,16 +567,14 @@ check' (Accessor prop val) ty = do
   rest <- fresh
   val' <- check val (TypeApp tyObject (RCons prop ty rest))
   return $ TypedValue True (Accessor prop val') ty
-check' v@(Constructor c) ty = do
+check' (Constructor c) ty = do
   env <- getEnv
   case M.lookup c (dataConstructors env) of
     Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing
     Just (_, _, ty1, _) -> do
       repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
-      mv <- subsumes (Just v) repl ty
-      case mv of
-        Nothing -> throwError . errorMessage $ SubsumptionCheckFailed
-        Just v' -> return $ TypedValue True v' ty
+      _ <- subsumes Nothing repl ty
+      return $ TypedValue True (Constructor c) ty
 check' (Let ds val) ty = do
   (ds', val') <- inferLetBinding [] ds val (`check` ty)
   return $ TypedValue True (Let ds' val') ty