[project @ 2000-03-27 13:23:49 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcSimplify.lhs

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 3bd5792..f1467ba 100644 (file)
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -118,7 +118,7 @@ and hence the default mechanism would resolve the "a".
 module TcSimplify (
        tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts, 
        tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
-       bindInstsOfLocalFuns
+       bindInstsOfLocalFuns, partitionPredsOfLIE
     ) where
 
 #include "HsVersions.h"
@@ -137,9 +137,11 @@ import Inst                ( lookupInst, lookupSimpleInst, LookupInstResult(..),
                          instToId, instBindingRequired, instCanBeGeneralised,
                          newDictFromOld,
                          getDictClassTys, getIPs,
+                         getDictPred_maybe, getMethodTheta_maybe,
                          instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
                          Inst, LIE, pprInsts, pprInstsInFull,
-                         mkLIE, emptyLIE, plusLIE, lieToList
+                         mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
+                         lieToList, listToLIE
                        )
 import TcEnv           ( tcGetGlobalTyVars )
 import TcType          ( TcType, TcTyVarSet, typeToTcType )
@@ -163,6 +165,7 @@ import CmdLineOpts  ( opt_GlasgowExts )
 import Outputable
 import Util
 import List            ( partition )
+import Maybes          ( maybeToBool )
 \end{code}
 
 
@@ -252,7 +255,7 @@ tcSimplify str local_tvs wanted_lie
 
       -- We're infering (not checking) the type, and 
       -- the inst constrains a local type variable
-      | isDict inst  = DontReduce              -- Dicts
+      | isDict inst  = DontReduceUnlessConstant        -- Dicts
       | otherwise    = ReduceMe AddToIrreds    -- Lits and Methods
 \end{code}
 
@@ -336,13 +339,57 @@ tcSimplifyToDicts wanted_lie
     returnTc (mkLIE irreds, binds)
   where
     -- see comment on wanteds in tcSimplify
-    wanteds = filter notFunDep (lieToList wanted_lie)
+    -- ZZ waitaminute - doesn't appear that any funDeps should even be here...
+    -- wanteds = filter notFunDep (lieToList wanted_lie)
+    wanteds = lieToList wanted_lie
 
        -- Reduce methods and lits only; stop as soon as we get a dictionary
     try_me inst        | isDict inst = DontReduce
                | otherwise   = ReduceMe AddToIrreds
 \end{code}
 
+The following function partitions a LIE by a predicate defined
+over `Pred'icates (an unfortunate overloading of terminology!).
+This means it sometimes has to split up `Methods', in which case
+a binding is generated.
+
+It is used in `with' bindings to extract from the LIE the implicit
+parameters being bound.
+
+\begin{code}
+partitionPredsOfLIE pred lie
+  = foldlTc (partPreds pred) (emptyLIE, emptyLIE, EmptyMonoBinds) insts
+  where insts = lieToList lie
+
+-- warning: the term `pred' is overloaded here!
+partPreds pred (lie1, lie2, binds) inst
+  | maybeToBool maybe_pred
+  = if pred p then
+       returnTc (consLIE inst lie1, lie2, binds)
+    else
+       returnTc (lie1, consLIE inst lie2, binds)
+    where maybe_pred = getDictPred_maybe inst
+         Just p = maybe_pred
+
+-- the assumption is that those satisfying `pred' are being extracted,
+-- so we leave the method untouched when nothing satisfies `pred'
+partPreds pred (lie1, lie2, binds1) inst
+  | maybeToBool maybe_theta
+  = if any pred theta then
+       zonkInst inst                           `thenTc` \ inst' ->
+       tcSimplifyToDicts (unitLIE inst')       `thenTc` \ (lie3, binds2) ->
+       partitionPredsOfLIE pred lie3           `thenTc` \ (lie1', lie2', EmptyMonoBinds) ->
+       returnTc (lie1 `plusLIE` lie1',
+                 lie2 `plusLIE` lie2',
+                 binds1 `AndMonoBinds` binds2)
+    else
+       returnTc (lie1, consLIE inst lie2, binds1)
+    where maybe_theta = getMethodTheta_maybe inst
+         Just theta = maybe_theta
+
+partPreds pred (lie1, lie2, binds) inst
+  = returnTc (lie1, consLIE inst lie2, binds)
+\end{code}
 
 
 %************************************************************************
@@ -358,7 +405,10 @@ data WhatToDo
  = ReduceMe              -- Try to reduce this
        NoInstanceAction  -- What to do if there's no such instance
 
- | DontReduce            -- Return as irreducible
+ | DontReduce                  -- Return as irreducible 
+
+ | DontReduceUnlessConstant    -- Return as irreducible unless it can
+                               -- be reduced to a constant in one step
 
  | Free                          -- Return as free
 
@@ -605,7 +655,11 @@ reduce stack try_me wanted state@(avails, frees, irreds)
 
 
     ;
-    DontReduce ->    -- It's irreducible (or at least should not be reduced)
+
+    DontReduce -> add_to_irreds
+    ;
+
+    DontReduceUnlessConstant ->    -- It's irreducible (or at least should not be reduced)
         -- See if the inst can be reduced to a constant in one step
        lookupInst wanted         `thenNF_Tc` \ lookup_result ->
        case lookup_result of
@@ -1169,8 +1223,7 @@ addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
 addAmbigErr ambig_tv_fn dict
   = addInstErrTcM (instLoc dict)
        (tidy_env,
-        sep [text "Ambiguous type variable(s)" <+>
-                       hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
+        sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
              nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
   where
     ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)