[commit: ghc] wip/impredicativity: Fix problems with type var flavour discrimination (fd3c060)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/impredicativity
Link       : http://ghc.haskell.org/trac/ghc/changeset/fd3c060b8a7c62e85b597360d38f76bd4389353f/ghc

>---------------------------------------------------------------

commit fd3c060b8a7c62e85b597360d38f76bd4389353f
Author: Alejandro Serrano <trupill at gmail.com>
Date:   Thu Jul 2 09:31:10 2015 +0200

    Fix problems with type var flavour discrimination


>---------------------------------------------------------------

fd3c060b8a7c62e85b597360d38f76bd4389353f
 compiler/typecheck/TcBinds.hs    | 17 ++++++++---------
 compiler/typecheck/TcInteract.hs | 29 ++++++++++++++---------------
 2 files changed, 22 insertions(+), 24 deletions(-)

diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 6fe2a25..4c95286 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -311,7 +311,7 @@ tcValBinds top_lvl binds sigs thing_inside
                 -- declared with complete type signatures
                 -- Do not extend the TcIdBinderStack; instead
                 -- we extend it on a per-rhs basis in tcExtendForRhs
-        ; tcExtendLetEnvIds top_lvl [( idName id, id, TcIdUnrestricted) | id <- poly_ids] $ do
+        ; tcExtendLetEnvIds top_lvl [(idName id, id, choose_tc_id_flavour id) | id <- poly_ids] $ do
             { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
                    { thing <- thing_inside
                      -- See Note [Pattern synonym builders don't yield dependencies]
@@ -387,7 +387,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
 
     go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
     go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc
-                        ; let uids1 = map (\x -> (x, TcIdUnrestricted)) ids1
+                        ; let uids1 = map (\x -> (x, choose_tc_id_flavour x)) ids1
                         ; (binds2, thing) <- tcExtendLetEnv top_lvl uids1 $
                                              go sccs
                         ; return (binds1 `unionBags` binds2, thing) }
@@ -431,12 +431,11 @@ tc_single top_lvl sig_fn prag_fn lbind thing_inside
        ; let uids = map (\x -> (x, choose_tc_id_flavour x)) ids
        ; thing <- tcExtendLetEnv top_lvl uids thing_inside
        ; return (binds1, thing) }
-  where
-    choose_tc_id_flavour v
-      | Just _ <- tcGetTyVar_maybe (idType v)
-      = TcIdMonomorphic
-      | otherwise
-      = TcIdUnrestricted
+
+
+choose_tc_id_flavour v
+  | Just _ <- tcGetTyVar_maybe (idType v) = TcIdMonomorphic
+  | otherwise = TcIdUnrestricted
 
 -- | No signature or a partial signature
 noCompleteSig :: Maybe TcSigInfo -> Bool
@@ -1304,7 +1303,7 @@ tcMonoBinds _ sig_fn no_gen binds
 
         -- Bring the monomorphic Ids, into scope for the RHSs
         ; let mono_info  = getMonoBindInfo tc_binds
-              rhs_id_env = [(name, mono_id, TcIdMonomorphic)
+              rhs_id_env = [(name, mono_id, choose_tc_id_flavour mono_id)
                            | (name, mb_sig, mono_id) <- mono_info
                            , noCompleteSig mb_sig ]
                     -- A monomorphic binding for each term variable that lacks
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index c4e7593..52a0d96 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -1735,24 +1735,23 @@ matchClassInst dflags _ clas tys loc
             ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
             ; return $ GenInst theta (EvDFunApp dfun_id tys) so eqs }
 
-     inerts_to_lazy_eqs :: Cts -> TcS (LazyEqs [TcPredType])
-     inerts_to_lazy_eqs = flatMapBagM $ \ct ->
-       case (ctEvidence ct, classifyPredType (ctPred ct)) of
-         (CtWanted { }, InstanceOfPred lhs rhs)
-           | Just _ <- getTyVar_maybe lhs
-           -- InstanceOf var sigma --> var ~ sigma
-           -> return $ unitBag (lhs, rhs, [mkTcEqPredRole Nominal lhs rhs])
-           | Just _ <- getTyVar_maybe rhs
-           -- InstanceOf sigma var -> instantiate sigma
-           -> do { (_qvars, q, ty) <- splitInst lhs
-                 ; return $ unitBag (rhs, ty, mkTcEqPredRole Nominal rhs ty : q) }
-           | otherwise
-           -> pprPanic "malformed irred InstanceOf" (ppr (ctPred ct))
-         _ -> return noLazyEqs
-
      extract_lazy_eqs :: LazyEqs [TcPredType] -> [TcPredType]
      extract_lazy_eqs leqs = concatMap (\(_,_,qs) -> qs) (bagToList leqs)
 
+inerts_to_lazy_eqs :: Cts -> TcS (LazyEqs [TcPredType])
+inerts_to_lazy_eqs = flatMapBagM $ \ct ->
+  case (ctEvidence ct, classifyPredType (ctPred ct)) of
+    (CtWanted { }, InstanceOfPred lhs rhs)
+      | Just _ <- getTyVar_maybe lhs
+      -- InstanceOf var sigma --> var ~ sigma
+      -> return $ unitBag (lhs, rhs, [mkTcEqPredRole Nominal lhs rhs])
+      | Just _ <- getTyVar_maybe rhs
+      -- InstanceOf sigma var -> instantiate sigma
+      -> do { (_qvars, q, ty) <- splitInst lhs
+            ; return $ unitBag (rhs, ty, mkTcEqPredRole Nominal ty rhs : q) }
+      | otherwise
+      -> pprPanic "malformed irred InstanceOf" (ppr (ctPred ct))
+    _ -> return noLazyEqs
 
 
 {- Note [Instance and Given overlap]