| ... |
... |
@@ -405,11 +405,12 @@ tcApp rn_expr exp_res_ty |
|
405
|
405
|
|
|
406
|
406
|
-- Step 5.1: Take a quick look at the result type
|
|
407
|
407
|
; quickLookResultType app_res_rho exp_res_ty
|
|
408
|
|
- ; inst_args' <- mapM quickLookArg inst_args
|
|
|
408
|
+ ; inst_args' <- mapM zonkValArgType inst_args
|
|
|
409
|
+ ; inst_args'' <- mapM quickLookArg inst_args'
|
|
409
|
410
|
|
|
410
|
411
|
-- Step 5.2: typecheck the arguments, and monomorphise
|
|
411
|
412
|
-- any un-unified instantiation variables
|
|
412
|
|
- ; tc_args <- tcValArgs DoQL inst_args'
|
|
|
413
|
+ ; tc_args <- tcValArgs DoQL inst_args''
|
|
413
|
414
|
|
|
414
|
415
|
-- Step 5.3: zonk to expose the polymorphism hidden under
|
|
415
|
416
|
-- QuickLook instantiation variables in `app_res_rho`
|
| ... |
... |
@@ -1843,8 +1844,7 @@ This turned out to be more subtle than I expected. Wrinkles: |
|
1843
|
1844
|
|
|
1844
|
1845
|
-}
|
|
1845
|
1846
|
|
|
1846
|
|
-quickLookArg :: HsExprArg 'TcpInst
|
|
1847
|
|
- -> TcM (HsExprArg 'TcpInst)
|
|
|
1847
|
+quickLookArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst)
|
|
1848
|
1848
|
-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper
|
|
1849
|
1849
|
-- See Note [Quick Look at value arguments]
|
|
1850
|
1850
|
quickLookArg e_arg@(EValArg { ea_ctxt = ctxt
|
| ... |
... |
@@ -1917,8 +1917,9 @@ quickLookArg e_arg@(EValArg { ea_ctxt = ctxt |
|
1917
|
1917
|
; (arg_influences_call, inst_args')
|
|
1918
|
1918
|
<- if isGuardedTy orig_arg_rho
|
|
1919
|
1919
|
then do { qlUnify app_res_rho orig_arg_rho
|
|
1920
|
|
- ; inst_args' <- mapM quickLookArg inst_args
|
|
1921
|
|
- ; return (True, inst_args') }
|
|
|
1920
|
+ ; inst_args' <- mapM zonkValArgType inst_args
|
|
|
1921
|
+ ; inst_args'' <- mapM quickLookArg inst_args'
|
|
|
1922
|
+ ; return (True, inst_args'') }
|
|
1922
|
1923
|
else do { inst_args' <- mapM quickLookArg inst_args
|
|
1923
|
1924
|
; has_free_inst_vars <- anyFreeKappa app_res_rho
|
|
1924
|
1925
|
; if has_free_inst_vars
|
| ... |
... |
@@ -1940,6 +1941,15 @@ quickLookArg e_arg@(EValArg { ea_ctxt = ctxt |
|
1940
|
1941
|
|
|
1941
|
1942
|
quickLookArg other_arg = return other_arg
|
|
1942
|
1943
|
|
|
|
1944
|
+zonkValArgType :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst)
|
|
|
1945
|
+zonkValArgType arg@(EValArg { ea_arg_ty = Scaled mult arg_rho })
|
|
|
1946
|
+ = do { arg_rho' <- liftZonkM $ zonkTcType arg_rho
|
|
|
1947
|
+ ; return (arg { ea_arg_ty = Scaled mult arg_rho' }) }
|
|
|
1948
|
+zonkValArgType arg@(EValArgQL {})
|
|
|
1949
|
+ = pprPanic "zonkValArgType" (ppr arg)
|
|
|
1950
|
+zonkValArgType arg
|
|
|
1951
|
+ = return arg
|
|
|
1952
|
+
|
|
1943
|
1953
|
whenQL :: QLFlag -> ZonkM () -> TcM ()
|
|
1944
|
1954
|
whenQL DoQL thing_inside = liftZonkM thing_inside
|
|
1945
|
1955
|
whenQL NoQL _ = return ()
|