Instantiate abstraction body during inference (purescript#3128)

LiamGoodacre · paf31 · commit 64d6c5a2e03a · 2017-11-07T20:39:48.000-08:00
diff --git a/examples/passing/3125.purs b/examples/passing/3125.purs
@@ -0,0 +1,16 @@
+module Main where
+
+import Prelude
+import Data.Monoid (class Monoid, mempty)
+import Control.Monad.Eff.Console (log, logShow)
+
+data B a = B a a
+
+memptyB :: forall a b. Monoid b => B (a -> b)
+memptyB = B l r where
+  l _ = mempty
+  r _ = mempty
+
+main = do
+  logShow $ case (memptyB :: B (Int -> Array Unit)) of B l r -> l 0 == r 0
+  log "Done"
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -357,7 +357,8 @@ infer' (Abs binder ret)
       ty <- freshType
       withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do
         body@(TypedValue _ _ bodyTy) <- infer' ret
-        return $ TypedValue True (Abs (VarBinder arg) body) $ function ty bodyTy
+        (body', bodyTy') <- instantiatePolyTypeWithUnknowns body bodyTy
+        return $ TypedValue True (Abs (VarBinder arg) body') (function ty bodyTy')
   | otherwise = internalError "Binder was not desugared"
 infer' (App f arg) = do
   f'@(TypedValue _ _ ft) <- infer f
