| ... |
... |
@@ -10,7 +10,7 @@ module GHC.Tc.Solver.Dict ( |
|
10
|
10
|
solveCallStack, -- For GHC.Tc.Solver
|
|
11
|
11
|
|
|
12
|
12
|
-- * Functional dependencies
|
|
13
|
|
- generateTopFunDeps
|
|
|
13
|
+ doTopFunDepImprovement, doLocalFunDepImprovement
|
|
14
|
14
|
) where
|
|
15
|
15
|
|
|
16
|
16
|
import GHC.Prelude
|
| ... |
... |
@@ -95,7 +95,7 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) |
|
95
|
95
|
|
|
96
|
96
|
-- Try fundeps /after/ tryInstances:
|
|
97
|
97
|
-- see (DFL2) in Note [Do fundeps last]
|
|
98
|
|
- ; doLocalFunDepImprovement dict_ct
|
|
|
98
|
+-- ; doLocalFunDepImprovement dict_ct
|
|
99
|
99
|
-- doLocalFunDepImprovement does StartAgain if there
|
|
100
|
100
|
-- are any fundeps: see (DFL1) in Note [Do fundeps last]
|
|
101
|
101
|
|
| ... |
... |
@@ -1434,7 +1434,7 @@ But in general it's a bit painful to figure out the necessary coercion, |
|
1434
|
1434
|
so we just take the first approach. Here is a better example. Consider:
|
|
1435
|
1435
|
class C a b c | a -> b
|
|
1436
|
1436
|
And:
|
|
1437
|
|
- [G] d1 : C T Int Char
|
|
|
1437
|
+ [G] d1 : C T Int Char
|
|
1438
|
1438
|
[W] d2 : C T beta Int
|
|
1439
|
1439
|
In this case, it's *not even possible* to solve the wanted immediately.
|
|
1440
|
1440
|
So we should simply output the functional dependency and add this guy
|
| ... |
... |
@@ -1630,16 +1630,23 @@ as the fundeps. |
|
1630
|
1630
|
#7875 is a case in point.
|
|
1631
|
1631
|
-}
|
|
1632
|
1632
|
|
|
1633
|
|
-generateTopFunDeps :: InstEnvs -> Cts -> [FunDepEqn (CtLoc, RewriterSet)]
|
|
|
1633
|
+doTopFunDepImprovement :: Bag DictCt -> TcS (Cts, Bool)
|
|
|
1634
|
+-- (doFunDeps inst_envs cts)
|
|
|
1635
|
+-- * Generate the fundeps from interacting the
|
|
|
1636
|
+-- top-level `inst_envs` with the constraints `cts`
|
|
|
1637
|
+-- * Do the unifications and return any unsolved constraints
|
|
1634
|
1638
|
-- See Note [Fundeps with instances, and equality orientation]
|
|
1635
|
|
-generateTopFunDeps inst_evs cts
|
|
1636
|
|
- = foldMap do_top cts -- "RAE" `unionBags` interactions
|
|
|
1639
|
+doTopFunDepImprovement cts
|
|
|
1640
|
+ = do { inst_envs <- getInstEnvs
|
|
|
1641
|
+ ; do_dict_fundeps (do_one inst_envs) cts }
|
|
1637
|
1642
|
where
|
|
1638
|
|
- do_top :: Ct -> [FunDepEqn (CtLoc, RewriterSet)]
|
|
1639
|
|
- do_top (CDictCan (DictCt { di_ev = ev, di_cls = cls, di_tys = xis }))
|
|
1640
|
|
- = assert (not (isGiven ev)) $
|
|
1641
|
|
- improveFromInstEnv inst_evs mk_ct_loc cls xis
|
|
|
1643
|
+ do_one :: InstEnvs -> DictCt -> TcS (Cts, Bool)
|
|
|
1644
|
+ do_one inst_envs (DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
|
|
|
1645
|
+ = unifyFunDepWanteds ev eqns
|
|
1642
|
1646
|
where
|
|
|
1647
|
+ eqns :: [FunDepEqn (CtLoc, RewriterSet)]
|
|
|
1648
|
+ eqns = improveFromInstEnv inst_envs mk_ct_loc cls xis
|
|
|
1649
|
+
|
|
1643
|
1650
|
dict_pred = mkClassPred cls xis
|
|
1644
|
1651
|
dict_loc = ctEvLoc ev
|
|
1645
|
1652
|
dict_origin = ctLocOrigin dict_loc
|
| ... |
... |
@@ -1655,93 +1662,57 @@ generateTopFunDeps inst_evs cts |
|
1655
|
1662
|
new_orig = FunDepOrigin2 dict_pred dict_origin
|
|
1656
|
1663
|
inst_pred inst_loc
|
|
1657
|
1664
|
|
|
1658
|
|
- do_top _other = []
|
|
1659
|
|
-
|
|
1660
|
|
-
|
|
1661
|
|
-doLocalFunDepImprovement :: DictCt -> SolverStage ()
|
|
1662
|
|
--- Add wanted constraints from type-class functional dependencies.
|
|
1663
|
|
-doLocalFunDepImprovement dict_ct@(DictCt { di_ev = work_ev, di_cls = cls })
|
|
1664
|
|
- = Stage $
|
|
1665
|
|
- do { inerts <- getInertCans
|
|
1666
|
|
- ; imp <- foldlM add_fds False (findDictsByClass (inert_dicts inerts) cls)
|
|
1667
|
|
- ; if imp then startAgainWith (CDictCan dict_ct)
|
|
1668
|
|
- else continueWith () }
|
|
|
1665
|
+doLocalFunDepImprovement :: Bag DictCt -> TcS (Cts,Bool)
|
|
|
1666
|
+-- Add wanted constraints from type-class functional dependencies
|
|
|
1667
|
+-- against Givens
|
|
|
1668
|
+doLocalFunDepImprovement cts
|
|
|
1669
|
+ = do { inerts <- getInertCans -- The inert_dicts are all Givens
|
|
|
1670
|
+ ; do_dict_fundeps (do_one (inert_dicts inerts)) cts }
|
|
1669
|
1671
|
where
|
|
1670
|
|
- work_pred = ctEvPred work_ev
|
|
1671
|
|
- work_loc = ctEvLoc work_ev
|
|
1672
|
|
-
|
|
1673
|
|
- add_fds :: Bool -> DictCt -> TcS Bool
|
|
1674
|
|
- add_fds so_far (DictCt { di_ev = inert_ev })
|
|
1675
|
|
- | isGiven work_ev && isGiven inert_ev
|
|
1676
|
|
- -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps]
|
|
1677
|
|
- = return so_far
|
|
1678
|
|
- | otherwise
|
|
1679
|
|
- = do { traceTcS "doLocalFunDepImprovement" (vcat
|
|
1680
|
|
- [ ppr work_ev
|
|
1681
|
|
- , pprCtLoc work_loc, ppr (isGivenLoc work_loc)
|
|
1682
|
|
- , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)
|
|
1683
|
|
- , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ])
|
|
1684
|
|
-
|
|
1685
|
|
- ; (new_eqs, unifs)
|
|
1686
|
|
- <- unifyFunDepWanteds work_ev $
|
|
1687
|
|
- improveFromAnother (derived_loc, inert_rewriters)
|
|
1688
|
|
- inert_pred work_pred
|
|
1689
|
|
-
|
|
1690
|
|
- -- Emit the deferred constraints
|
|
1691
|
|
- -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality
|
|
1692
|
|
- --
|
|
1693
|
|
- -- All the constraints in `cts` share the same rewriter set so,
|
|
1694
|
|
- -- rather than looking at it one by one, we pass it to
|
|
1695
|
|
- -- extendWorkListChildEqs; just a small optimisation.
|
|
1696
|
|
- ; unless (isEmptyBag cts) $
|
|
1697
|
|
- updWorkListTcS (extendWorkListChildEqs ev new_eqs)
|
|
1698
|
|
-
|
|
1699
|
|
- ; return (so_far || unifs)
|
|
1700
|
|
- }
|
|
|
1672
|
+ do_one givens (DictCt { di_cls = cls, di_ev = wanted_ev })
|
|
|
1673
|
+ = do_dict_fundeps do_one_given (findDictsByClass givens cls)
|
|
1701
|
1674
|
where
|
|
1702
|
|
- inert_pred = ctEvPred inert_ev
|
|
1703
|
|
- inert_loc = ctEvLoc inert_ev
|
|
1704
|
|
- inert_rewriters = ctEvRewriters inert_ev
|
|
1705
|
|
- derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth`
|
|
1706
|
|
- ctl_depth inert_loc
|
|
1707
|
|
- , ctl_origin = FunDepOrigin1 work_pred
|
|
1708
|
|
- (ctLocOrigin work_loc)
|
|
1709
|
|
- (ctLocSpan work_loc)
|
|
1710
|
|
- inert_pred
|
|
1711
|
|
- (ctLocOrigin inert_loc)
|
|
1712
|
|
- (ctLocSpan inert_loc) }
|
|
1713
|
|
-
|
|
1714
|
|
-doTopFunDepImprovement :: DictCt -> SolverStage ()
|
|
1715
|
|
--- Try to functional-dependency improvement between the constraint
|
|
1716
|
|
--- and the top-level instance declarations
|
|
1717
|
|
--- See Note [Fundeps with instances, and equality orientation]
|
|
1718
|
|
--- See also Note [Weird fundeps]
|
|
1719
|
|
-doTopFunDepImprovement dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
|
|
1720
|
|
- | isGiven ev -- No improvement for Givens
|
|
1721
|
|
- = Stage $ continueWith ()
|
|
1722
|
|
- | otherwise
|
|
1723
|
|
- = Stage $
|
|
1724
|
|
- do { traceTcS "try_fundeps" (ppr dict_ct)
|
|
1725
|
|
- ; instEnvs <- getInstEnvs
|
|
1726
|
|
- ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis
|
|
1727
|
|
- ; imp <- emitFunDepWanteds ev fundep_eqns
|
|
1728
|
|
- ; if imp then startAgainWith (CDictCan dict_ct)
|
|
1729
|
|
- else continueWith () }
|
|
|
1675
|
+ wanted_pred = ctEvPred wanted_ev
|
|
|
1676
|
+ wanted_loc = ctEvLoc wanted_ev
|
|
|
1677
|
+
|
|
|
1678
|
+ do_one_given :: DictCt -> TcS (Cts,Bool)
|
|
|
1679
|
+ do_one_given (DictCt { di_ev = given_ev })
|
|
|
1680
|
+ = do { traceTcS "doLocalFunDepImprovement" $
|
|
|
1681
|
+ vcat [ ppr wanted_ev
|
|
|
1682
|
+ , pprCtLoc wanted_loc, ppr (isGivenLoc wanted_loc)
|
|
|
1683
|
+ , pprCtLoc given_loc, ppr (isGivenLoc given_loc)
|
|
|
1684
|
+ , pprCtLoc deriv_loc, ppr (isGivenLoc deriv_loc) ]
|
|
|
1685
|
+
|
|
|
1686
|
+ ; unifyFunDepWanteds wanted_ev $
|
|
|
1687
|
+ improveFromAnother (deriv_loc, given_rewriters)
|
|
|
1688
|
+ given_pred wanted_pred }
|
|
|
1689
|
+ where
|
|
|
1690
|
+ given_pred = ctEvPred given_ev
|
|
|
1691
|
+ given_loc = ctEvLoc given_ev
|
|
|
1692
|
+ given_rewriters = ctEvRewriters given_ev
|
|
|
1693
|
+ deriv_loc = wanted_loc { ctl_depth = deriv_depth
|
|
|
1694
|
+ , ctl_origin = deriv_origin }
|
|
|
1695
|
+ deriv_depth = ctl_depth wanted_loc `maxSubGoalDepth`
|
|
|
1696
|
+ ctl_depth given_loc
|
|
|
1697
|
+ deriv_origin = FunDepOrigin1 wanted_pred
|
|
|
1698
|
+ (ctLocOrigin wanted_loc)
|
|
|
1699
|
+ (ctLocSpan wanted_loc)
|
|
|
1700
|
+ given_pred
|
|
|
1701
|
+ (ctLocOrigin given_loc)
|
|
|
1702
|
+ (ctLocSpan given_loc)
|
|
|
1703
|
+
|
|
|
1704
|
+do_dict_fundeps :: (DictCt -> TcS (Cts,Bool)) -> Bag DictCt -> TcS (Cts,Bool)
|
|
|
1705
|
+do_dict_fundeps do_dict_fundep cts
|
|
|
1706
|
+ = foldr do_one (return (emptyBag, False)) cts
|
|
1730
|
1707
|
where
|
|
1731
|
|
- dict_pred = mkClassPred cls xis
|
|
1732
|
|
- dict_loc = ctEvLoc ev
|
|
1733
|
|
- dict_origin = ctLocOrigin dict_loc
|
|
1734
|
|
- dict_rewriters = ctEvRewriters ev
|
|
1735
|
|
-
|
|
1736
|
|
- mk_ct_loc :: ClsInst -- The instance decl
|
|
1737
|
|
- -> (CtLoc, RewriterSet)
|
|
1738
|
|
- mk_ct_loc ispec
|
|
1739
|
|
- = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin
|
|
1740
|
|
- inst_pred inst_loc }
|
|
1741
|
|
- , dict_rewriters )
|
|
1742
|
|
- where
|
|
1743
|
|
- inst_pred = mkClassPred cls (is_tys ispec)
|
|
1744
|
|
- inst_loc = getSrcSpan (is_dfun ispec)
|
|
|
1708
|
+ do_one :: DictCt -> TcS (Cts,Bool) -> TcS (Cts,Bool)
|
|
|
1709
|
+ do_one dict_ct do_rest
|
|
|
1710
|
+ = -- assert (not (isGiven (dictCtEvidence dict_ct)) $
|
|
|
1711
|
+ do { (cts1, unifs1) <- do_dict_fundep dict_ct
|
|
|
1712
|
+ ; if isEmptyBag cts1 && not unifs1
|
|
|
1713
|
+ then do_rest -- Common case
|
|
|
1714
|
+ else do { (cts2, unifs2) <- do_rest
|
|
|
1715
|
+ ; return (cts1 `unionBags` cts2, unifs1 || unifs2) } }
|
|
1745
|
1716
|
|
|
1746
|
1717
|
|
|
1747
|
1718
|
{- *********************************************************************
|