[commit: ghc] master: Refactor newSCWorkFromFlavoured (3509191)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/3509191250d60a3e04a9ef9e126ecd7cc5974250/ghc

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

commit 3509191250d60a3e04a9ef9e126ecd7cc5974250
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jul 20 23:39:44 2015 +0100

    Refactor newSCWorkFromFlavoured
    
    No change in behaviour is intended here


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

3509191250d60a3e04a9ef9e126ecd7cc5974250
 compiler/typecheck/TcCanonical.hs | 40 +++++++++++++++++++++------------------
 1 file changed, 22 insertions(+), 18 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 6f02325..f37ad3e 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -331,36 +331,40 @@ newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS ()
 -- Returns superclasses, see Note [Adding superclasses]
 newSCWorkFromFlavored flavor cls xis
   | CtGiven { ctev_evar = evar, ctev_loc = loc } <- flavor
-  = do { let size = sizeTypes xis
-             loc' | isCTupleClass cls
-                  = loc   -- For tuple predicates, just take them apart, without
-                          -- adding their (large) size into the chain.  When we
-                          -- get down to a base predicate, we'll include its size.
-                          -- Trac #10335
-                  | otherwise
-                  = case ctLocOrigin loc of
-                       GivenOrigin InstSkol
-                         -> loc { ctl_origin = GivenOrigin (InstSC size) }
-                       GivenOrigin (InstSC n)
-                         -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }
-                       _ -> loc
-                    -- See Note [Solving superclass constraints] in TcInstDcls
-                    -- for explantation of loc'
-
-       ; given_evs <- newGivenEvVars loc' (mkEvScSelectors (EvId evar) cls xis)
+  = do { given_evs <- newGivenEvVars (mk_given_loc loc)
+                                     (mkEvScSelectors (EvId evar) cls xis)
        ; emitWorkNC given_evs }
 
   | isEmptyVarSet (tyVarsOfTypes xis)
   = return () -- Wanteds with no variables yield no deriveds.
               -- See Note [Improvement from Ground Wanteds]
 
-  | otherwise -- Derived case, just add those SC that can lead to improvement.
+  | otherwise -- Wanted/Derived case, just add those SC that can lead to improvement.
   = do { let sc_rec_theta = transSuperClasses cls xis
              impr_theta   = filter isImprovementPred sc_rec_theta
              loc          = ctEvLoc flavor
        ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta
        ; emitNewDeriveds loc impr_theta }
 
+  where
+    size = sizeTypes xis
+    mk_given_loc loc
+       | isCTupleClass cls
+       = loc   -- For tuple predicates, just take them apart, without
+               -- adding their (large) size into the chain.  When we
+               -- get down to a base predicate, we'll include its size.
+               -- Trac #10335
+
+       | GivenOrigin skol_info <- ctLocOrigin loc
+         -- See Note [Solving superclass constraints] in TcInstDcls
+         -- for explantation of this transformation for givens
+       = case skol_info of
+            InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) }
+            InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }
+            _        -> loc
+
+       | otherwise  -- Probably doesn't happen, since this function
+       = loc        -- is only used for Givens, but does no harm
 
 {-
 ************************************************************************